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
integrate cfgperl contents into mainline
[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;
909 double value;
910 I32 maxlen = 0;
911 I32 nfound;
912 struct timeval timebuf;
913 struct timeval *tbuf = &timebuf;
914 I32 growsize;
915 char *fd_sets[4];
2d8e6c8d 916 STRLEN n_a;
a0d0e21e
LW		 917#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
918 I32 masksize;
919 I32 offset;
920 I32 k;
921
922# if BYTEORDER & 0xf0000
923# define ORDERBYTE (0x88888888 - BYTEORDER)
924# else
925# define ORDERBYTE (0x4444 - BYTEORDER)
926# endif
927
928#endif
929
930 SP -= 4;
931 for (i = 1; i <= 3; i++) {
932 if (!SvPOK(SP[i]))
933 continue;
934 j = SvCUR(SP[i]);
935 if (maxlen < j)
936 maxlen = j;
937 }
938
5ff3f7a4 939/* little endians can use vecs directly */
a0d0e21e 940#if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
5ff3f7a4 941# if SELECT_MIN_BITS > 1
f2da832e
JH		 942 /* If SELECT_MIN_BITS is greater than one we most probably will want
943 * to align the sizes with SELECT_MIN_BITS/8 because for example
944 * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
8f1f23e8
W		 945 * UNIX, Solaris, NeXT, Rhapsody) the smallest quantum select() operates
946 * on (sets/tests/clears bits) is 32 bits. */
f2da832e 947 growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
5ff3f7a4 948# else
4633a7c4 949 growsize = sizeof(fd_set);
5ff3f7a4
GS		 950# endif
951# else
952# ifdef NFDBITS
a0d0e21e 953
5ff3f7a4
GS		 954# ifndef NBBY
955# define NBBY 8
956# endif
a0d0e21e
LW		 957
958 masksize = NFDBITS / NBBY;
5ff3f7a4 959# else
a0d0e21e 960 masksize = sizeof(long); /* documented int, everyone seems to use long */
5ff3f7a4 961# endif
a0d0e21e
LW		 962 growsize = maxlen + (masksize - (maxlen % masksize));
963 Zero(&fd_sets[0], 4, char*);
964#endif
965
966 sv = SP[4];
967 if (SvOK(sv)) {
968 value = SvNV(sv);
969 if (value < 0.0)
970 value = 0.0;
971 timebuf.tv_sec = (long)value;
972 value -= (double)timebuf.tv_sec;
973 timebuf.tv_usec = (long)(value * 1000000.0);
974 }
975 else
976 tbuf = Null(struct timeval*);
977
978 for (i = 1; i <= 3; i++) {
979 sv = SP[i];
980 if (!SvOK(sv)) {
981 fd_sets[i] = 0;
982 continue;
983 }
984 else if (!SvPOK(sv))
2d8e6c8d 985 SvPV_force(sv,n_a); /* force string conversion */
a0d0e21e
LW		 986 j = SvLEN(sv);
987 if (j < growsize) {
988 Sv_Grow(sv, growsize);
a0d0e21e 989 }
c07a80fd 990 j = SvCUR(sv);
991 s = SvPVX(sv) + j;
992 while (++j <= growsize) {
993 *s++ = '\0';
994 }
995
a0d0e21e
LW		 996#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
997 s = SvPVX(sv);
998 New(403, fd_sets[i], growsize, char);
999 for (offset = 0; offset < growsize; offset += masksize) {
1000 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1001 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1002 }
1003#else
1004 fd_sets[i] = SvPVX(sv);
1005#endif
1006 }
1007
6ad3d225 1008 nfound = PerlSock_select(
a0d0e21e
LW		 1009 maxlen * 8,
1010 (Select_fd_set_t) fd_sets[1],
1011 (Select_fd_set_t) fd_sets[2],
1012 (Select_fd_set_t) fd_sets[3],
1013 tbuf);
1014 for (i = 1; i <= 3; i++) {
1015 if (fd_sets[i]) {
1016 sv = SP[i];
1017#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1018 s = SvPVX(sv);
1019 for (offset = 0; offset < growsize; offset += masksize) {
1020 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1021 s[(k % masksize) + offset] = fd_sets[i][j+offset];
1022 }
1023 Safefree(fd_sets[i]);
1024#endif
1025 SvSETMAGIC(sv);
1026 }
1027 }
1028
1029 PUSHi(nfound);
1030 if (GIMME == G_ARRAY && tbuf) {
1031 value = (double)(timebuf.tv_sec) +
1032 (double)(timebuf.tv_usec) / 1000000.0;
3280af22 1033 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 1034 sv_setnv(sv, value);
1035 }
1036 RETURN;
1037#else
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)) {
a0d0e21e 1275 if (IoIFP(io))
cea2e8a9 1276 Perl_warner(aTHX_ WARN_IO, "Filehandle only opened for input");
599cee73 1277 else if (ckWARN(WARN_CLOSED))
cea2e8a9 1278 Perl_warner(aTHX_ WARN_CLOSED, "Write on closed filehandle");
a0d0e21e 1279 }
3280af22 1280 PUSHs(&PL_sv_no);
a0d0e21e
LW		 1281 }
1282 else {
3280af22 1283 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
599cee73 1284 if (ckWARN(WARN_IO))
cea2e8a9 1285 Perl_warner(aTHX_ WARN_IO, "page overflow");
a0d0e21e 1286 }
3280af22 1287 if (!PerlIO_write(ofp, SvPVX(PL_formtarget), SvCUR(PL_formtarget)) ||
760ac839 1288 PerlIO_error(fp))
3280af22 1289 PUSHs(&PL_sv_no);
a0d0e21e 1290 else {
3280af22
NIS		 1291 FmLINES(PL_formtarget) = 0;
1292 SvCUR_set(PL_formtarget, 0);
1293 *SvEND(PL_formtarget) = '\0';
a0d0e21e 1294 if (IoFLAGS(io) & IOf_FLUSH)
760ac839 1295 (void)PerlIO_flush(fp);
3280af22 1296 PUSHs(&PL_sv_yes);
a0d0e21e
LW		 1297 }
1298 }
3280af22 1299 PL_formtarget = PL_bodytarget;
a0d0e21e
LW		 1300 PUTBACK;
1301 return pop_return();
1302}
1303
1304PP(pp_prtf)
1305{
4e35701f 1306 djSP; dMARK; dORIGMARK;
a0d0e21e
LW		 1307 GV *gv;
1308 IO *io;
760ac839 1309 PerlIO *fp;
26db47c4 1310 SV *sv;
46fc3d4c 1311 MAGIC *mg;
2d8e6c8d 1312 STRLEN n_a;
a0d0e21e 1313
533c011a 1314 if (PL_op->op_flags & OPf_STACKED)
a0d0e21e
LW		 1315 gv = (GV*)*++MARK;
1316 else
3280af22 1317 gv = PL_defoutgv;
46fc3d4c 1318
33c27489 1319 if (mg = SvTIED_mg((SV*)gv, 'q')) {
46fc3d4c 1320 if (MARK == ORIGMARK) {
4352c267 1321 MEXTEND(SP, 1);
46fc3d4c 1322 ++MARK;
1323 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1324 ++SP;
1325 }
1326 PUSHMARK(MARK - 1);
33c27489 1327 *MARK = SvTIED_obj((SV*)gv, mg);
46fc3d4c 1328 PUTBACK;
1329 ENTER;
864dbfa3 1330 call_method("PRINTF", G_SCALAR);
46fc3d4c 1331 LEAVE;
1332 SPAGAIN;
1333 MARK = ORIGMARK + 1;
1334 *MARK = *SP;
1335 SP = MARK;
1336 RETURN;
1337 }
1338
26db47c4 1339 sv = NEWSV(0,0);
a0d0e21e 1340 if (!(io = GvIO(gv))) {
599cee73 1341 if (ckWARN(WARN_UNOPENED)) {
aac0dd9a 1342 gv_fullname3(sv, gv, Nullch);
cea2e8a9 1343 Perl_warner(aTHX_ WARN_UNOPENED, "Filehandle %s never opened", SvPV(sv,n_a));
748a9306
LW		 1344 }
1345 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW		 1346 goto just_say_no;
1347 }
1348 else if (!(fp = IoOFP(io))) {
599cee73 1349 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
aac0dd9a 1350 gv_fullname3(sv, gv, Nullch);
a0d0e21e 1351 if (IoIFP(io))
cea2e8a9 1352 Perl_warner(aTHX_ WARN_IO, "Filehandle %s opened only for input",
2d8e6c8d 1353 SvPV(sv,n_a));
599cee73 1354 else if (ckWARN(WARN_CLOSED))
cea2e8a9 1355 Perl_warner(aTHX_ WARN_CLOSED, "printf on closed filehandle %s",
2d8e6c8d 1356 SvPV(sv,n_a));
a0d0e21e 1357 }
748a9306 1358 SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
a0d0e21e
LW		 1359 goto just_say_no;
1360 }
1361 else {
1362 do_sprintf(sv, SP - MARK, MARK + 1);
1363 if (!do_print(sv, fp))
1364 goto just_say_no;
1365
1366 if (IoFLAGS(io) & IOf_FLUSH)
760ac839 1367 if (PerlIO_flush(fp) == EOF)
a0d0e21e
LW		 1368 goto just_say_no;
1369 }
1370 SvREFCNT_dec(sv);
1371 SP = ORIGMARK;
3280af22 1372 PUSHs(&PL_sv_yes);
a0d0e21e
LW		 1373 RETURN;
1374
1375 just_say_no:
1376 SvREFCNT_dec(sv);
1377 SP = ORIGMARK;
3280af22 1378 PUSHs(&PL_sv_undef);
a0d0e21e
LW		 1379 RETURN;
1380}
1381
c07a80fd 1382PP(pp_sysopen)
1383{
4e35701f 1384 djSP;
c07a80fd 1385 GV *gv;
c07a80fd 1386 SV *sv;
1387 char *tmps;
1388 STRLEN len;
1389 int mode, perm;
1390
1391 if (MAXARG > 3)
1392 perm = POPi;
1393 else
1394 perm = 0666;
1395 mode = POPi;
1396 sv = POPs;
1397 gv = (GV *)POPs;
1398
4592e6ca
NIS		 1399 /* Need TIEHANDLE method ? */
1400
c07a80fd 1401 tmps = SvPV(sv, len);
1402 if (do_open(gv, tmps, len, TRUE, mode, perm, Nullfp)) {
1403 IoLINES(GvIOp(gv)) = 0;
3280af22 1404 PUSHs(&PL_sv_yes);
c07a80fd 1405 }
1406 else {
3280af22 1407 PUSHs(&PL_sv_undef);
c07a80fd 1408 }
1409 RETURN;
1410}
1411
a0d0e21e
LW		 1412PP(pp_sysread)
1413{
4e35701f 1414 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 1415 int offset;
1416 GV *gv;
1417 IO *io;
1418 char *buffer;
5b54f415 1419 SSize_t length;
1e422769 1420 Sock_size_t bufsize;
748a9306 1421 SV *bufsv;
a0d0e21e 1422 STRLEN blen;
2ae324a7 1423 MAGIC *mg;
a0d0e21e
LW		 1424
1425 gv = (GV*)*++MARK;
533c011a 1426 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD) &&
33c27489 1427 (mg = SvTIED_mg((SV*)gv, 'q')))
137443ea 1428 {
2ae324a7 1429 SV *sv;
1430
1431 PUSHMARK(MARK-1);
33c27489 1432 *MARK = SvTIED_obj((SV*)gv, mg);
2ae324a7 1433 ENTER;
864dbfa3 1434 call_method("READ", G_SCALAR);
2ae324a7 1435 LEAVE;
1436 SPAGAIN;
1437 sv = POPs;
1438 SP = ORIGMARK;
1439 PUSHs(sv);
1440 RETURN;
1441 }
1442
a0d0e21e
LW		 1443 if (!gv)
1444 goto say_undef;
748a9306 1445 bufsv = *++MARK;
ff68c719 1446 if (! SvOK(bufsv))
1447 sv_setpvn(bufsv, "", 0);
748a9306 1448 buffer = SvPV_force(bufsv, blen);
a0d0e21e
LW		 1449 length = SvIVx(*++MARK);
1450 if (length < 0)
cea2e8a9 1451 DIE(aTHX_ "Negative length");
748a9306 1452 SETERRNO(0,0);
a0d0e21e
LW		 1453 if (MARK < SP)
1454 offset = SvIVx(*++MARK);
1455 else
1456 offset = 0;
1457 io = GvIO(gv);
1458 if (!io || !IoIFP(io))
1459 goto say_undef;
1460#ifdef HAS_SOCKET
533c011a 1461 if (PL_op->op_type == OP_RECV) {
46fc3d4c 1462 char namebuf[MAXPATHLEN];
eec2d3df 1463#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE)
490ab354
JH		 1464 bufsize = sizeof (struct sockaddr_in);
1465#else
46fc3d4c 1466 bufsize = sizeof namebuf;
490ab354 1467#endif
abf95952
IZ		 1468#ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1469 if (bufsize >= 256)
1470 bufsize = 255;
1471#endif
626727d5
GS		 1472#ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1473 if (bufsize >= 256)
1474 bufsize = 255;
1475#endif
748a9306 1476 buffer = SvGROW(bufsv, length+1);
bbce6d69 1477 /* 'offset' means 'flags' here */
6ad3d225 1478 length = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
46fc3d4c 1479 (struct sockaddr *)namebuf, &bufsize);
a0d0e21e
LW		 1480 if (length < 0)
1481 RETPUSHUNDEF;
748a9306
LW		 1482 SvCUR_set(bufsv, length);
1483 *SvEND(bufsv) = '\0';
1484 (void)SvPOK_only(bufsv);
1485 SvSETMAGIC(bufsv);
aac0dd9a 1486 /* This should not be marked tainted if the fp is marked clean */
bbce6d69 1487 if (!(IoFLAGS(io) & IOf_UNTAINT))
1488 SvTAINTED_on(bufsv);
a0d0e21e 1489 SP = ORIGMARK;
46fc3d4c 1490 sv_setpvn(TARG, namebuf, bufsize);
a0d0e21e
LW		 1491 PUSHs(TARG);
1492 RETURN;
1493 }
1494#else
911d147d 1495 if (PL_op->op_type == OP_RECV)
cea2e8a9 1496 DIE(aTHX_ PL_no_sock_func, "recv");
a0d0e21e 1497#endif
bbce6d69 1498 if (offset < 0) {
1499 if (-offset > blen)
cea2e8a9 1500 DIE(aTHX_ "Offset outside string");
bbce6d69 1501 offset += blen;
1502 }
cd52b7b2 1503 bufsize = SvCUR(bufsv);
748a9306 1504 buffer = SvGROW(bufsv, length+offset+1);
cd52b7b2 1505 if (offset > bufsize) { /* Zero any newly allocated space */
1506 Zero(buffer+bufsize, offset-bufsize, char);
1507 }
533c011a 1508 if (PL_op->op_type == OP_SYSREAD) {
a7092146
GS		 1509#ifdef PERL_SOCK_SYSREAD_IS_RECV
1510 if (IoTYPE(io) == 's') {
1511 length = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
1512 buffer+offset, length, 0);
1513 }
1514 else
1515#endif
1516 {
1517 length = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
1518 buffer+offset, length);
1519 }
a0d0e21e
LW		 1520 }
1521 else
1522#ifdef HAS_SOCKET__bad_code_maybe
1523 if (IoTYPE(io) == 's') {
46fc3d4c 1524 char namebuf[MAXPATHLEN];
490ab354
JH		 1525#if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
1526 bufsize = sizeof (struct sockaddr_in);
1527#else
46fc3d4c 1528 bufsize = sizeof namebuf;
490ab354 1529#endif
6ad3d225 1530 length = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer+offset, length, 0,
46fc3d4c 1531 (struct sockaddr *)namebuf, &bufsize);
a0d0e21e
LW		 1532 }
1533 else
1534#endif
3b02c43c 1535 {
760ac839 1536 length = PerlIO_read(IoIFP(io), buffer+offset, length);
3b02c43c 1537 /* fread() returns 0 on both error and EOF */
5c7a8c78 1538 if (length == 0 && PerlIO_error(IoIFP(io)))
3b02c43c
GS		 1539 length = -1;
1540 }
a0d0e21e
LW		 1541 if (length < 0)
1542 goto say_undef;
748a9306
LW		 1543 SvCUR_set(bufsv, length+offset);
1544 *SvEND(bufsv) = '\0';
1545 (void)SvPOK_only(bufsv);
1546 SvSETMAGIC(bufsv);
aac0dd9a 1547 /* This should not be marked tainted if the fp is marked clean */
bbce6d69 1548 if (!(IoFLAGS(io) & IOf_UNTAINT))
1549 SvTAINTED_on(bufsv);
a0d0e21e
LW		 1550 SP = ORIGMARK;
1551 PUSHi(length);
1552 RETURN;
1553
1554 say_undef:
1555 SP = ORIGMARK;
1556 RETPUSHUNDEF;
1557}
1558
1559PP(pp_syswrite)
1560{
092bebab
JH		 1561 djSP;
1562 int items = (SP - PL_stack_base) - TOPMARK;
1563 if (items == 2) {
9f089d78 1564 SV *sv;
092bebab 1565 EXTEND(SP, 1);
9f089d78
SB		 1566 sv = sv_2mortal(newSViv(sv_len(*SP)));
1567 PUSHs(sv);
092bebab
JH		 1568 PUTBACK;
1569 }
cea2e8a9 1570 return pp_send();
a0d0e21e
LW		 1571}
1572
1573PP(pp_send)
1574{
4e35701f 1575 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 1576 GV *gv;
1577 IO *io;
1578 int offset;
748a9306 1579 SV *bufsv;
a0d0e21e
LW		 1580 char *buffer;
1581 int length;
1582 STRLEN blen;
1d603a67 1583 MAGIC *mg;
a0d0e21e
LW		 1584
1585 gv = (GV*)*++MARK;
33c27489 1586 if (PL_op->op_type == OP_SYSWRITE && (mg = SvTIED_mg((SV*)gv, 'q'))) {
1d603a67
GB		 1587 SV *sv;
1588
1589 PUSHMARK(MARK-1);
33c27489 1590 *MARK = SvTIED_obj((SV*)gv, mg);
1d603a67 1591 ENTER;
864dbfa3 1592 call_method("WRITE", G_SCALAR);
1d603a67
GB		 1593 LEAVE;
1594 SPAGAIN;
1595 sv = POPs;
1596 SP = ORIGMARK;
1597 PUSHs(sv);
1598 RETURN;
1599 }
a0d0e21e
LW		 1600 if (!gv)
1601 goto say_undef;
748a9306
LW		 1602 bufsv = *++MARK;
1603 buffer = SvPV(bufsv, blen);
a0d0e21e
LW		 1604 length = SvIVx(*++MARK);
1605 if (length < 0)
cea2e8a9 1606 DIE(aTHX_ "Negative length");
748a9306 1607 SETERRNO(0,0);
a0d0e21e
LW		 1608 io = GvIO(gv);
1609 if (!io || !IoIFP(io)) {
1610 length = -1;
599cee73 1611 if (ckWARN(WARN_CLOSED)) {
533c011a 1612 if (PL_op->op_type == OP_SYSWRITE)
cea2e8a9 1613 Perl_warner(aTHX_ WARN_CLOSED, "Syswrite on closed filehandle");
a0d0e21e 1614 else
cea2e8a9 1615 Perl_warner(aTHX_ WARN_CLOSED, "Send on closed socket");
a0d0e21e
LW		 1616 }
1617 }
533c011a 1618 else if (PL_op->op_type == OP_SYSWRITE) {
bbce6d69 1619 if (MARK < SP) {
a0d0e21e 1620 offset = SvIVx(*++MARK);
bbce6d69 1621 if (offset < 0) {
1622 if (-offset > blen)
cea2e8a9 1623 DIE(aTHX_ "Offset outside string");
bbce6d69 1624 offset += blen;
fb73857a 1625 } else if (offset >= blen && blen > 0)
cea2e8a9 1626 DIE(aTHX_ "Offset outside string");
bbce6d69 1627 } else
a0d0e21e
LW		 1628 offset = 0;
1629 if (length > blen - offset)
1630 length = blen - offset;
a7092146
GS		 1631#ifdef PERL_SOCK_SYSWRITE_IS_SEND
1632 if (IoTYPE(io) == 's') {
1633 length = PerlSock_send(PerlIO_fileno(IoIFP(io)),
1634 buffer+offset, length, 0);
1635 }
1636 else
1637#endif
1638 {
1639 length = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
1640 buffer+offset, length);
1641 }
a0d0e21e
LW		 1642 }
1643#ifdef HAS_SOCKET
1644 else if (SP > MARK) {
1645 char *sockbuf;
1646 STRLEN mlen;
1647 sockbuf = SvPVx(*++MARK, mlen);
6ad3d225 1648 length = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen, length,
a0d0e21e
LW		 1649 (struct sockaddr *)sockbuf, mlen);
1650 }
1651 else
6ad3d225 1652 length = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, length);
490ab354 1653
a0d0e21e
LW		 1654#else
1655 else
cea2e8a9 1656 DIE(aTHX_ PL_no_sock_func, "send");
a0d0e21e
LW		 1657#endif
1658 if (length < 0)
1659 goto say_undef;
1660 SP = ORIGMARK;
1661 PUSHi(length);
1662 RETURN;
1663
1664 say_undef:
1665 SP = ORIGMARK;
1666 RETPUSHUNDEF;
1667}
1668
1669PP(pp_recv)
1670{
cea2e8a9 1671 return pp_sysread();
a0d0e21e
LW		 1672}
1673
1674PP(pp_eof)
1675{
4e35701f 1676 djSP;
a0d0e21e 1677 GV *gv;
4592e6ca 1678 MAGIC *mg;
a0d0e21e
LW		 1679
1680 if (MAXARG <= 0)
3280af22 1681 gv = PL_last_in_gv;
a0d0e21e 1682 else
3280af22 1683 gv = PL_last_in_gv = (GV*)POPs;
4592e6ca
NIS		 1684
1685 if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
1686 PUSHMARK(SP);
1687 XPUSHs(SvTIED_obj((SV*)gv, mg));
1688 PUTBACK;
1689 ENTER;
864dbfa3 1690 call_method("EOF", G_SCALAR);
4592e6ca
NIS		 1691 LEAVE;
1692 SPAGAIN;
1693 RETURN;
1694 }
1695
54310121 1696 PUSHs(boolSV(!gv || do_eof(gv)));
a0d0e21e
LW		 1697 RETURN;
1698}
1699
1700PP(pp_tell)
1701{
4e35701f 1702 djSP; dTARGET;
4592e6ca
NIS		 1703 GV *gv;
1704 MAGIC *mg;
a0d0e21e
LW		 1705
1706 if (MAXARG <= 0)
3280af22 1707 gv = PL_last_in_gv;
a0d0e21e 1708 else
3280af22 1709 gv = PL_last_in_gv = (GV*)POPs;
4592e6ca
NIS		 1710
1711 if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
1712 PUSHMARK(SP);
1713 XPUSHs(SvTIED_obj((SV*)gv, mg));
1714 PUTBACK;
1715 ENTER;
864dbfa3 1716 call_method("TELL", G_SCALAR);
4592e6ca
NIS		 1717 LEAVE;
1718 SPAGAIN;
1719 RETURN;
1720 }
1721
a0d0e21e
LW		 1722 PUSHi( do_tell(gv) );
1723 RETURN;
1724}
1725
1726PP(pp_seek)
1727{
cea2e8a9 1728 return pp_sysseek();
137443ea 1729}
1730
1731PP(pp_sysseek)
1732{
4e35701f 1733 djSP;
a0d0e21e
LW		 1734 GV *gv;
1735 int whence = POPi;
97cc44eb 1736 Off_t offset = POPl;
4592e6ca 1737 MAGIC *mg;
a0d0e21e 1738
3280af22 1739 gv = PL_last_in_gv = (GV*)POPs;
4592e6ca
NIS		 1740
1741 if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
1742 PUSHMARK(SP);
1743 XPUSHs(SvTIED_obj((SV*)gv, mg));
1744 XPUSHs(sv_2mortal(newSViv((IV) offset)));
1745 XPUSHs(sv_2mortal(newSViv((IV) whence)));
1746 PUTBACK;
1747 ENTER;
864dbfa3 1748 call_method("SEEK", G_SCALAR);
4592e6ca
NIS		 1749 LEAVE;
1750 SPAGAIN;
1751 RETURN;
1752 }
1753
533c011a 1754 if (PL_op->op_type == OP_SEEK)
8903cb82 1755 PUSHs(boolSV(do_seek(gv, offset, whence)));
1756 else {
97cc44eb 1757 Off_t n = do_sysseek(gv, offset, whence);
3280af22 1758 PUSHs((n < 0) ? &PL_sv_undef
8903cb82 1759 : sv_2mortal(n ? newSViv((IV)n)
79cb57f6 1760 : newSVpvn(zero_but_true, ZBTLEN)));
8903cb82 1761 }
a0d0e21e
LW		 1762 RETURN;
1763}
1764
1765PP(pp_truncate)
1766{
4e35701f 1767 djSP;
a0d0e21e
LW		 1768 Off_t len = (Off_t)POPn;
1769 int result = 1;
1770 GV *tmpgv;
2d8e6c8d 1771 STRLEN n_a;
a0d0e21e 1772
748a9306 1773 SETERRNO(0,0);
5d94fbed 1774#if defined(HAS_TRUNCATE) || defined(HAS_CHSIZE) || defined(F_FREESP)
533c011a 1775 if (PL_op->op_flags & OPf_SPECIAL) {
2d8e6c8d 1776 tmpgv = gv_fetchpv(POPpx, FALSE, SVt_PVIO);
cbdc8872 1777 do_ftruncate:
1e422769 1778 TAINT_PROPER("truncate");
a0d0e21e 1779 if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv)) ||
cbdc8872 1780#ifdef HAS_TRUNCATE
760ac839 1781 ftruncate(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
cbdc8872 1782#else
760ac839 1783 my_chsize(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
cbdc8872 1784#endif
a0d0e21e
LW		 1785 result = 0;
1786 }
1787 else {
cbdc8872 1788 SV *sv = POPs;
1e422769 1789 char *name;
2d8e6c8d 1790 STRLEN n_a;
1e422769 1791
cbdc8872 1792 if (SvTYPE(sv) == SVt_PVGV) {
1793 tmpgv = (GV*)sv; /* *main::FRED for example */
1794 goto do_ftruncate;
1795 }
1796 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
1797 tmpgv = (GV*) SvRV(sv); /* \*main::FRED for example */
1798 goto do_ftruncate;
1799 }
1e422769 1800
2d8e6c8d 1801 name = SvPV(sv, n_a);
1e422769 1802 TAINT_PROPER("truncate");
cbdc8872 1803#ifdef HAS_TRUNCATE
1e422769 1804 if (truncate(name, len) < 0)
a0d0e21e 1805 result = 0;
cbdc8872 1806#else
1807 {
1808 int tmpfd;
6ad3d225 1809 if ((tmpfd = PerlLIO_open(name, O_RDWR)) < 0)
bbce6d69 1810 result = 0;
cbdc8872 1811 else {
1812 if (my_chsize(tmpfd, len) < 0)
1813 result = 0;
6ad3d225 1814 PerlLIO_close(tmpfd);
cbdc8872 1815 }
a0d0e21e 1816 }
a0d0e21e 1817#endif
cbdc8872 1818 }
a0d0e21e
LW		 1819
1820 if (result)
1821 RETPUSHYES;
1822 if (!errno)
748a9306 1823 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW		 1824 RETPUSHUNDEF;
1825#else
cea2e8a9 1826 DIE(aTHX_ "truncate not implemented");
a0d0e21e
LW		 1827#endif
1828}
1829
1830PP(pp_fcntl)
1831{
cea2e8a9 1832 return pp_ioctl();
a0d0e21e
LW		 1833}
1834
1835PP(pp_ioctl)
1836{
4e35701f 1837 djSP; dTARGET;
748a9306 1838 SV *argsv = POPs;
a0d0e21e 1839 unsigned int func = U_I(POPn);
533c011a 1840 int optype = PL_op->op_type;
a0d0e21e 1841 char *s;
324aa91a 1842 IV retval;
a0d0e21e
LW		 1843 GV *gv = (GV*)POPs;
1844 IO *io = GvIOn(gv);
1845
748a9306
LW		 1846 if (!io || !argsv || !IoIFP(io)) {
1847 SETERRNO(EBADF,RMS$_IFI); /* well, sort of... */
a0d0e21e
LW		 1848 RETPUSHUNDEF;
1849 }
1850
748a9306 1851 if (SvPOK(argsv) || !SvNIOK(argsv)) {
a0d0e21e 1852 STRLEN len;
324aa91a 1853 STRLEN need;
748a9306 1854 s = SvPV_force(argsv, len);
324aa91a
HF		 1855 need = IOCPARM_LEN(func);
1856 if (len < need) {
1857 s = Sv_Grow(argsv, need + 1);
1858 SvCUR_set(argsv, need);
a0d0e21e
LW		 1859 }
1860
748a9306 1861 s[SvCUR(argsv)] = 17; /* a little sanity check here */
a0d0e21e
LW		 1862 }
1863 else {
748a9306 1864 retval = SvIV(argsv);
a0d0e21e 1865 s = (char*)retval; /* ouch */
a0d0e21e
LW		 1866 }
1867
1868 TAINT_PROPER(optype == OP_IOCTL ? "ioctl" : "fcntl");
1869
1870 if (optype == OP_IOCTL)
1871#ifdef HAS_IOCTL
76e3520e 1872 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
a0d0e21e 1873#else
cea2e8a9 1874 DIE(aTHX_ "ioctl is not implemented");
a0d0e21e
LW		 1875#endif
1876 else
55497cff 1877#ifdef HAS_FCNTL
1878#if defined(OS2) && defined(__EMX__)
760ac839 1879 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
55497cff 1880#else
760ac839 1881 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
55497cff 1882#endif
1883#else
cea2e8a9 1884 DIE(aTHX_ "fcntl is not implemented");
a0d0e21e
LW		 1885#endif
1886
748a9306
LW		 1887 if (SvPOK(argsv)) {
1888 if (s[SvCUR(argsv)] != 17)
cea2e8a9 1889 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
22c35a8c 1890 PL_op_name[optype]);
748a9306
LW		 1891 s[SvCUR(argsv)] = 0; /* put our null back */
1892 SvSETMAGIC(argsv); /* Assume it has changed */
a0d0e21e
LW		 1893 }
1894
1895 if (retval == -1)
1896 RETPUSHUNDEF;
1897 if (retval != 0) {
1898 PUSHi(retval);
1899 }
1900 else {
8903cb82 1901 PUSHp(zero_but_true, ZBTLEN);
a0d0e21e
LW		 1902 }
1903 RETURN;
1904}
1905
1906PP(pp_flock)
1907{
4e35701f 1908 djSP; dTARGET;
a0d0e21e
LW		 1909 I32 value;
1910 int argtype;
1911 GV *gv;
760ac839 1912 PerlIO *fp;
16d20bd9 1913
ff68c719 1914#ifdef FLOCK
a0d0e21e
LW		 1915 argtype = POPi;
1916 if (MAXARG <= 0)
3280af22 1917 gv = PL_last_in_gv;
a0d0e21e
LW		 1918 else
1919 gv = (GV*)POPs;
1920 if (gv && GvIO(gv))
1921 fp = IoIFP(GvIOp(gv));
1922 else
1923 fp = Nullfp;
1924 if (fp) {
68dc0745 1925 (void)PerlIO_flush(fp);
76e3520e 1926 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
a0d0e21e
LW		 1927 }
1928 else
1929 value = 0;
1930 PUSHi(value);
1931 RETURN;
1932#else
cea2e8a9 1933 DIE(aTHX_ PL_no_func, "flock()");
a0d0e21e
LW		 1934#endif
1935}
1936
1937/* Sockets. */
1938
1939PP(pp_socket)
1940{
4e35701f 1941 djSP;
a0d0e21e
LW		 1942#ifdef HAS_SOCKET
1943 GV *gv;
1944 register IO *io;
1945 int protocol = POPi;
1946 int type = POPi;
1947 int domain = POPi;
1948 int fd;
1949
1950 gv = (GV*)POPs;
1951
1952 if (!gv) {
748a9306 1953 SETERRNO(EBADF,LIB$_INVARG);
a0d0e21e
LW		 1954 RETPUSHUNDEF;
1955 }
1956
1957 io = GvIOn(gv);
1958 if (IoIFP(io))
1959 do_close(gv, FALSE);
1960
1961 TAINT_PROPER("socket");
6ad3d225 1962 fd = PerlSock_socket(domain, type, protocol);
a0d0e21e
LW		 1963 if (fd < 0)
1964 RETPUSHUNDEF;
760ac839
LW		 1965 IoIFP(io) = PerlIO_fdopen(fd, "r"); /* stdio gets confused about sockets */
1966 IoOFP(io) = PerlIO_fdopen(fd, "w");
a0d0e21e
LW		 1967 IoTYPE(io) = 's';
1968 if (!IoIFP(io) || !IoOFP(io)) {
760ac839
LW		 1969 if (IoIFP(io)) PerlIO_close(IoIFP(io));
1970 if (IoOFP(io)) PerlIO_close(IoOFP(io));
6ad3d225 1971 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
a0d0e21e
LW		 1972 RETPUSHUNDEF;
1973 }
1974
1975 RETPUSHYES;
1976#else
cea2e8a9 1977 DIE(aTHX_ PL_no_sock_func, "socket");
a0d0e21e
LW		 1978#endif
1979}
1980
1981PP(pp_sockpair)
1982{
4e35701f 1983 djSP;
a0d0e21e
LW		 1984#ifdef HAS_SOCKETPAIR
1985 GV *gv1;
1986 GV *gv2;
1987 register IO *io1;
1988 register IO *io2;
1989 int protocol = POPi;
1990 int type = POPi;
1991 int domain = POPi;
1992 int fd[2];
1993
1994 gv2 = (GV*)POPs;
1995 gv1 = (GV*)POPs;
1996 if (!gv1 || !gv2)
1997 RETPUSHUNDEF;
1998
1999 io1 = GvIOn(gv1);
2000 io2 = GvIOn(gv2);
2001 if (IoIFP(io1))
2002 do_close(gv1, FALSE);
2003 if (IoIFP(io2))
2004 do_close(gv2, FALSE);
2005
2006 TAINT_PROPER("socketpair");
6ad3d225 2007 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
a0d0e21e 2008 RETPUSHUNDEF;
760ac839
LW		 2009 IoIFP(io1) = PerlIO_fdopen(fd[0], "r");
2010 IoOFP(io1) = PerlIO_fdopen(fd[0], "w");
a0d0e21e 2011 IoTYPE(io1) = 's';
760ac839
LW		 2012 IoIFP(io2) = PerlIO_fdopen(fd[1], "r");
2013 IoOFP(io2) = PerlIO_fdopen(fd[1], "w");
a0d0e21e
LW		 2014 IoTYPE(io2) = 's';
2015 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
760ac839
LW		 2016 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2017 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
6ad3d225 2018 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
760ac839
LW		 2019 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2020 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
6ad3d225 2021 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
a0d0e21e
LW		 2022 RETPUSHUNDEF;
2023 }
2024
2025 RETPUSHYES;
2026#else
cea2e8a9 2027 DIE(aTHX_ PL_no_sock_func, "socketpair");
a0d0e21e
LW		 2028#endif
2029}
2030
2031PP(pp_bind)
2032{
4e35701f 2033 djSP;
a0d0e21e 2034#ifdef HAS_SOCKET
eec2d3df
GS		 2035#ifdef MPE /* Requires PRIV mode to bind() to ports < 1024 */
2036 extern GETPRIVMODE();
2037 extern GETUSERMODE();
2038#endif
748a9306 2039 SV *addrsv = POPs;
a0d0e21e
LW		 2040 char *addr;
2041 GV *gv = (GV*)POPs;
2042 register IO *io = GvIOn(gv);
2043 STRLEN len;
eec2d3df
GS		 2044 int bind_ok = 0;
2045#ifdef MPE
2046 int mpeprivmode = 0;
2047#endif
a0d0e21e
LW		 2048
2049 if (!io || !IoIFP(io))
2050 goto nuts;
2051
748a9306 2052 addr = SvPV(addrsv, len);
a0d0e21e 2053 TAINT_PROPER("bind");
eec2d3df
GS		 2054#ifdef MPE /* Deal with MPE bind() peculiarities */
2055 if (((struct sockaddr *)addr)->sa_family == AF_INET) {
2056 /* The address *MUST* stupidly be zero. */
2057 ((struct sockaddr_in *)addr)->sin_addr.s_addr = INADDR_ANY;
2058 /* PRIV mode is required to bind() to ports < 1024. */
2059 if (((struct sockaddr_in *)addr)->sin_port < 1024 &&
2060 ((struct sockaddr_in *)addr)->sin_port > 0) {
2061 GETPRIVMODE(); /* If this fails, we are aborted by MPE/iX. */
2062 mpeprivmode = 1;
2063 }
2064 }
2065#endif /* MPE */
2066 if (PerlSock_bind(PerlIO_fileno(IoIFP(io)),
2067 (struct sockaddr *)addr, len) >= 0)
2068 bind_ok = 1;
2069
2070#ifdef MPE /* Switch back to USER mode */
2071 if (mpeprivmode)
2072 GETUSERMODE();
2073#endif /* MPE */
2074
2075 if (bind_ok)
a0d0e21e
LW		 2076 RETPUSHYES;
2077 else
2078 RETPUSHUNDEF;
2079
2080nuts:
599cee73 2081 if (ckWARN(WARN_CLOSED))
cea2e8a9 2082 Perl_warner(aTHX_ WARN_CLOSED, "bind() on closed fd");
748a9306 2083 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2084 RETPUSHUNDEF;
2085#else
cea2e8a9 2086 DIE(aTHX_ PL_no_sock_func, "bind");
a0d0e21e
LW		 2087#endif
2088}
2089
2090PP(pp_connect)
2091{
4e35701f 2092 djSP;
a0d0e21e 2093#ifdef HAS_SOCKET
748a9306 2094 SV *addrsv = POPs;
a0d0e21e
LW		 2095 char *addr;
2096 GV *gv = (GV*)POPs;
2097 register IO *io = GvIOn(gv);
2098 STRLEN len;
2099
2100 if (!io || !IoIFP(io))
2101 goto nuts;
2102
748a9306 2103 addr = SvPV(addrsv, len);
a0d0e21e 2104 TAINT_PROPER("connect");
6ad3d225 2105 if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
a0d0e21e
LW		 2106 RETPUSHYES;
2107 else
2108 RETPUSHUNDEF;
2109
2110nuts:
599cee73 2111 if (ckWARN(WARN_CLOSED))
cea2e8a9 2112 Perl_warner(aTHX_ WARN_CLOSED, "connect() on closed fd");
748a9306 2113 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2114 RETPUSHUNDEF;
2115#else
cea2e8a9 2116 DIE(aTHX_ PL_no_sock_func, "connect");
a0d0e21e
LW		 2117#endif
2118}
2119
2120PP(pp_listen)
2121{
4e35701f 2122 djSP;
a0d0e21e
LW		 2123#ifdef HAS_SOCKET
2124 int backlog = POPi;
2125 GV *gv = (GV*)POPs;
2126 register IO *io = GvIOn(gv);
2127
2128 if (!io || !IoIFP(io))
2129 goto nuts;
2130
6ad3d225 2131 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
a0d0e21e
LW		 2132 RETPUSHYES;
2133 else
2134 RETPUSHUNDEF;
2135
2136nuts:
599cee73 2137 if (ckWARN(WARN_CLOSED))
cea2e8a9 2138 Perl_warner(aTHX_ WARN_CLOSED, "listen() on closed fd");
748a9306 2139 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2140 RETPUSHUNDEF;
2141#else
cea2e8a9 2142 DIE(aTHX_ PL_no_sock_func, "listen");
a0d0e21e
LW		 2143#endif
2144}
2145
2146PP(pp_accept)
2147{
4e35701f 2148 djSP; dTARGET;
a0d0e21e
LW		 2149#ifdef HAS_SOCKET
2150 GV *ngv;
2151 GV *ggv;
2152 register IO *nstio;
2153 register IO *gstio;
4633a7c4 2154 struct sockaddr saddr; /* use a struct to avoid alignment problems */
1e422769 2155 Sock_size_t len = sizeof saddr;
a0d0e21e
LW		 2156 int fd;
2157
2158 ggv = (GV*)POPs;
2159 ngv = (GV*)POPs;
2160
2161 if (!ngv)
2162 goto badexit;
2163 if (!ggv)
2164 goto nuts;
2165
2166 gstio = GvIO(ggv);
2167 if (!gstio || !IoIFP(gstio))
2168 goto nuts;
2169
2170 nstio = GvIOn(ngv);
2171 if (IoIFP(nstio))
2172 do_close(ngv, FALSE);
2173
6ad3d225 2174 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *)&saddr, &len);
a0d0e21e
LW		 2175 if (fd < 0)
2176 goto badexit;
760ac839
LW		 2177 IoIFP(nstio) = PerlIO_fdopen(fd, "r");
2178 IoOFP(nstio) = PerlIO_fdopen(fd, "w");
a0d0e21e
LW		 2179 IoTYPE(nstio) = 's';
2180 if (!IoIFP(nstio) || !IoOFP(nstio)) {
760ac839
LW		 2181 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2182 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
6ad3d225 2183 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
a0d0e21e
LW		 2184 goto badexit;
2185 }
2186
748a9306 2187 PUSHp((char *)&saddr, len);
a0d0e21e
LW		 2188 RETURN;
2189
2190nuts:
599cee73 2191 if (ckWARN(WARN_CLOSED))
cea2e8a9 2192 Perl_warner(aTHX_ WARN_CLOSED, "accept() on closed fd");
748a9306 2193 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2194
2195badexit:
2196 RETPUSHUNDEF;
2197
2198#else
cea2e8a9 2199 DIE(aTHX_ PL_no_sock_func, "accept");
a0d0e21e
LW		 2200#endif
2201}
2202
2203PP(pp_shutdown)
2204{
4e35701f 2205 djSP; dTARGET;
a0d0e21e
LW		 2206#ifdef HAS_SOCKET
2207 int how = POPi;
2208 GV *gv = (GV*)POPs;
2209 register IO *io = GvIOn(gv);
2210
2211 if (!io || !IoIFP(io))
2212 goto nuts;
2213
6ad3d225 2214 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
a0d0e21e
LW		 2215 RETURN;
2216
2217nuts:
599cee73 2218 if (ckWARN(WARN_CLOSED))
cea2e8a9 2219 Perl_warner(aTHX_ WARN_CLOSED, "shutdown() on closed fd");
748a9306 2220 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2221 RETPUSHUNDEF;
2222#else
cea2e8a9 2223 DIE(aTHX_ PL_no_sock_func, "shutdown");
a0d0e21e
LW		 2224#endif
2225}
2226
2227PP(pp_gsockopt)
2228{
2229#ifdef HAS_SOCKET
cea2e8a9 2230 return pp_ssockopt();
a0d0e21e 2231#else
cea2e8a9 2232 DIE(aTHX_ PL_no_sock_func, "getsockopt");
a0d0e21e
LW		 2233#endif
2234}
2235
2236PP(pp_ssockopt)
2237{
4e35701f 2238 djSP;
a0d0e21e 2239#ifdef HAS_SOCKET
533c011a 2240 int optype = PL_op->op_type;
a0d0e21e
LW		 2241 SV *sv;
2242 int fd;
2243 unsigned int optname;
2244 unsigned int lvl;
2245 GV *gv;
2246 register IO *io;
1e422769 2247 Sock_size_t len;
a0d0e21e
LW		 2248
2249 if (optype == OP_GSOCKOPT)
2250 sv = sv_2mortal(NEWSV(22, 257));
2251 else
2252 sv = POPs;
2253 optname = (unsigned int) POPi;
2254 lvl = (unsigned int) POPi;
2255
2256 gv = (GV*)POPs;
2257 io = GvIOn(gv);
2258 if (!io || !IoIFP(io))
2259 goto nuts;
2260
760ac839 2261 fd = PerlIO_fileno(IoIFP(io));
a0d0e21e
LW		 2262 switch (optype) {
2263 case OP_GSOCKOPT:
748a9306 2264 SvGROW(sv, 257);
a0d0e21e 2265 (void)SvPOK_only(sv);
748a9306
LW		 2266 SvCUR_set(sv,256);
2267 *SvEND(sv) ='\0';
1e422769 2268 len = SvCUR(sv);
6ad3d225 2269 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
a0d0e21e 2270 goto nuts2;
1e422769 2271 SvCUR_set(sv, len);
748a9306 2272 *SvEND(sv) ='\0';
a0d0e21e
LW		 2273 PUSHs(sv);
2274 break;
2275 case OP_SSOCKOPT: {
1e422769 2276 char *buf;
2277 int aint;
2278 if (SvPOKp(sv)) {
2d8e6c8d
GS		 2279 STRLEN l;
2280 buf = SvPV(sv, l);
2281 len = l;
1e422769 2282 }
56ee1660 2283 else {
a0d0e21e
LW		 2284 aint = (int)SvIV(sv);
2285 buf = (char*)&aint;
2286 len = sizeof(int);
2287 }
6ad3d225 2288 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
a0d0e21e 2289 goto nuts2;
3280af22 2290 PUSHs(&PL_sv_yes);
a0d0e21e
LW		 2291 }
2292 break;
2293 }
2294 RETURN;
2295
2296nuts:
599cee73 2297 if (ckWARN(WARN_CLOSED))
cea2e8a9 2298 Perl_warner(aTHX_ WARN_CLOSED, "[gs]etsockopt() on closed fd");
748a9306 2299 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2300nuts2:
2301 RETPUSHUNDEF;
2302
2303#else
cea2e8a9 2304 DIE(aTHX_ PL_no_sock_func, "setsockopt");
a0d0e21e
LW		 2305#endif
2306}
2307
2308PP(pp_getsockname)
2309{
2310#ifdef HAS_SOCKET
cea2e8a9 2311 return pp_getpeername();
a0d0e21e 2312#else
cea2e8a9 2313 DIE(aTHX_ PL_no_sock_func, "getsockname");
a0d0e21e
LW		 2314#endif
2315}
2316
2317PP(pp_getpeername)
2318{
4e35701f 2319 djSP;
a0d0e21e 2320#ifdef HAS_SOCKET
533c011a 2321 int optype = PL_op->op_type;
a0d0e21e
LW		 2322 SV *sv;
2323 int fd;
2324 GV *gv = (GV*)POPs;
2325 register IO *io = GvIOn(gv);
1e422769 2326 Sock_size_t len;
a0d0e21e
LW		 2327
2328 if (!io || !IoIFP(io))
2329 goto nuts;
2330
2331 sv = sv_2mortal(NEWSV(22, 257));
748a9306 2332 (void)SvPOK_only(sv);
1e422769 2333 len = 256;
2334 SvCUR_set(sv, len);
748a9306 2335 *SvEND(sv) ='\0';
760ac839 2336 fd = PerlIO_fileno(IoIFP(io));
a0d0e21e
LW		 2337 switch (optype) {
2338 case OP_GETSOCKNAME:
6ad3d225 2339 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
a0d0e21e
LW		 2340 goto nuts2;
2341 break;
2342 case OP_GETPEERNAME:
6ad3d225 2343 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
a0d0e21e 2344 goto nuts2;
490ab354
JH		 2345#if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2346 {
2347 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";
2348 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2349 if (((struct sockaddr *)SvPVX(sv))->sa_family == AF_INET &&
2350 !memcmp((char *)SvPVX(sv) + sizeof(u_short), nowhere,
2351 sizeof(u_short) + sizeof(struct in_addr))) {
2352 goto nuts2;
2353 }
2354 }
2355#endif
a0d0e21e
LW		 2356 break;
2357 }
13826f2c
CS		 2358#ifdef BOGUS_GETNAME_RETURN
2359 /* Interactive Unix, getpeername() and getsockname()
2360 does not return valid namelen */
1e422769 2361 if (len == BOGUS_GETNAME_RETURN)
2362 len = sizeof(struct sockaddr);
13826f2c 2363#endif
1e422769 2364 SvCUR_set(sv, len);
748a9306 2365 *SvEND(sv) ='\0';
a0d0e21e
LW		 2366 PUSHs(sv);
2367 RETURN;
2368
2369nuts:
599cee73 2370 if (ckWARN(WARN_CLOSED))
cea2e8a9 2371 Perl_warner(aTHX_ WARN_CLOSED, "get{sock, peer}name() on closed fd");
748a9306 2372 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2373nuts2:
2374 RETPUSHUNDEF;
2375
2376#else
cea2e8a9 2377 DIE(aTHX_ PL_no_sock_func, "getpeername");
a0d0e21e
LW		 2378#endif
2379}
2380
2381/* Stat calls. */
2382
2383PP(pp_lstat)
2384{
cea2e8a9 2385 return pp_stat();
a0d0e21e
LW		 2386}
2387
2388PP(pp_stat)
2389{
4e35701f 2390 djSP;
a0d0e21e 2391 GV *tmpgv;
54310121 2392 I32 gimme;
a0d0e21e 2393 I32 max = 13;
2d8e6c8d 2394 STRLEN n_a;
a0d0e21e 2395
533c011a 2396 if (PL_op->op_flags & OPf_REF) {
a0d0e21e 2397 tmpgv = cGVOP->op_gv;
748a9306 2398 do_fstat:
3280af22
NIS		 2399 if (tmpgv != PL_defgv) {
2400 PL_laststype = OP_STAT;
2401 PL_statgv = tmpgv;
2402 sv_setpv(PL_statname, "");
2403 PL_laststatval = (GvIO(tmpgv) && IoIFP(GvIOp(tmpgv))
2404 ? PerlLIO_fstat(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), &PL_statcache) : -1);
a0d0e21e 2405 }
3280af22 2406 if (PL_laststatval < 0)
a0d0e21e
LW		 2407 max = 0;
2408 }
2409 else {
748a9306
LW		 2410 SV* sv = POPs;
2411 if (SvTYPE(sv) == SVt_PVGV) {
2412 tmpgv = (GV*)sv;
2413 goto do_fstat;
2414 }
2415 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2416 tmpgv = (GV*)SvRV(sv);
2417 goto do_fstat;
2418 }
2d8e6c8d 2419 sv_setpv(PL_statname, SvPV(sv,n_a));
3280af22 2420 PL_statgv = Nullgv;
a0d0e21e 2421#ifdef HAS_LSTAT
533c011a
NIS		 2422 PL_laststype = PL_op->op_type;
2423 if (PL_op->op_type == OP_LSTAT)
2d8e6c8d 2424 PL_laststatval = PerlLIO_lstat(SvPV(PL_statname, n_a), &PL_statcache);
a0d0e21e
LW		 2425 else
2426#endif
2d8e6c8d 2427 PL_laststatval = PerlLIO_stat(SvPV(PL_statname, n_a), &PL_statcache);
3280af22 2428 if (PL_laststatval < 0) {
2d8e6c8d 2429 if (ckWARN(WARN_NEWLINE) && strchr(SvPV(PL_statname, n_a), '\n'))
cea2e8a9 2430 Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "stat");
a0d0e21e
LW		 2431 max = 0;
2432 }
2433 }
2434
54310121 2435 gimme = GIMME_V;
2436 if (gimme != G_ARRAY) {
2437 if (gimme != G_VOID)
2438 XPUSHs(boolSV(max));
2439 RETURN;
a0d0e21e
LW		 2440 }
2441 if (max) {
36477c24 2442 EXTEND(SP, max);
2443 EXTEND_MORTAL(max);
3280af22
NIS		 2444 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_dev)));
2445 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_ino)));
2446 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_mode)));
2447 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_nlink)));
2448 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_uid)));
2449 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_gid)));
cbdc8872 2450#ifdef USE_STAT_RDEV
3280af22 2451 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_rdev)));
cbdc8872 2452#else
79cb57f6 2453 PUSHs(sv_2mortal(newSVpvn("", 0)));
cbdc8872 2454#endif
3280af22 2455 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_size)));
cbdc8872 2456#ifdef BIG_TIME
6b88bc9c
GS		 2457 PUSHs(sv_2mortal(newSVnv((U32)PL_statcache.st_atime)));
2458 PUSHs(sv_2mortal(newSVnv((U32)PL_statcache.st_mtime)));
2459 PUSHs(sv_2mortal(newSVnv((U32)PL_statcache.st_ctime)));
cbdc8872 2460#else
3280af22
NIS		 2461 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_atime)));
2462 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_mtime)));
2463 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_ctime)));
cbdc8872 2464#endif
a0d0e21e 2465#ifdef USE_STAT_BLOCKS
3280af22
NIS		 2466 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_blksize)));
2467 PUSHs(sv_2mortal(newSViv((I32)PL_statcache.st_blocks)));
a0d0e21e 2468#else
79cb57f6
GS		 2469 PUSHs(sv_2mortal(newSVpvn("", 0)));
2470 PUSHs(sv_2mortal(newSVpvn("", 0)));
a0d0e21e
LW		 2471#endif
2472 }
2473 RETURN;
2474}
2475
2476PP(pp_ftrread)
2477{
5ff3f7a4 2478 I32 result;
4e35701f 2479 djSP;
5ff3f7a4 2480#if defined(HAS_ACCESS) && defined(R_OK)
2d8e6c8d 2481 STRLEN n_a;
5ff3f7a4 2482 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2483 result = access(TOPpx, R_OK);
5ff3f7a4
GS		 2484 if (result == 0)
2485 RETPUSHYES;
2486 if (result < 0)
2487 RETPUSHUNDEF;
2488 RETPUSHNO;
22865c03
GS		 2489 }
2490 else
cea2e8a9 2491 result = my_stat();
5ff3f7a4 2492#else
cea2e8a9 2493 result = my_stat();
5ff3f7a4 2494#endif
22865c03 2495 SPAGAIN;
a0d0e21e
LW		 2496 if (result < 0)
2497 RETPUSHUNDEF;
3280af22 2498 if (cando(S_IRUSR, 0, &PL_statcache))
a0d0e21e
LW		 2499 RETPUSHYES;
2500 RETPUSHNO;
2501}
2502
2503PP(pp_ftrwrite)
2504{
5ff3f7a4 2505 I32 result;
4e35701f 2506 djSP;
5ff3f7a4 2507#if defined(HAS_ACCESS) && defined(W_OK)
2d8e6c8d 2508 STRLEN n_a;
5ff3f7a4 2509 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2510 result = access(TOPpx, W_OK);
5ff3f7a4
GS		 2511 if (result == 0)
2512 RETPUSHYES;
2513 if (result < 0)
2514 RETPUSHUNDEF;
2515 RETPUSHNO;
22865c03
GS		 2516 }
2517 else
cea2e8a9 2518 result = my_stat();
5ff3f7a4 2519#else
cea2e8a9 2520 result = my_stat();
5ff3f7a4 2521#endif
22865c03 2522 SPAGAIN;
a0d0e21e
LW		 2523 if (result < 0)
2524 RETPUSHUNDEF;
3280af22 2525 if (cando(S_IWUSR, 0, &PL_statcache))
a0d0e21e
LW		 2526 RETPUSHYES;
2527 RETPUSHNO;
2528}
2529
2530PP(pp_ftrexec)
2531{
5ff3f7a4 2532 I32 result;
4e35701f 2533 djSP;
5ff3f7a4 2534#if defined(HAS_ACCESS) && defined(X_OK)
2d8e6c8d 2535 STRLEN n_a;
5ff3f7a4 2536 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2537 result = access(TOPpx, X_OK);
5ff3f7a4
GS		 2538 if (result == 0)
2539 RETPUSHYES;
2540 if (result < 0)
2541 RETPUSHUNDEF;
2542 RETPUSHNO;
22865c03
GS		 2543 }
2544 else
cea2e8a9 2545 result = my_stat();
5ff3f7a4 2546#else
cea2e8a9 2547 result = my_stat();
5ff3f7a4 2548#endif
22865c03 2549 SPAGAIN;
a0d0e21e
LW		 2550 if (result < 0)
2551 RETPUSHUNDEF;
3280af22 2552 if (cando(S_IXUSR, 0, &PL_statcache))
a0d0e21e
LW		 2553 RETPUSHYES;
2554 RETPUSHNO;
2555}
2556
2557PP(pp_fteread)
2558{
5ff3f7a4 2559 I32 result;
4e35701f 2560 djSP;
5ff3f7a4 2561#ifdef PERL_EFF_ACCESS_R_OK
2d8e6c8d 2562 STRLEN n_a;
5ff3f7a4 2563 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2564 result = PERL_EFF_ACCESS_R_OK(TOPpx);
5ff3f7a4
GS		 2565 if (result == 0)
2566 RETPUSHYES;
2567 if (result < 0)
2568 RETPUSHUNDEF;
2569 RETPUSHNO;
22865c03
GS		 2570 }
2571 else
cea2e8a9 2572 result = my_stat();
5ff3f7a4 2573#else
cea2e8a9 2574 result = my_stat();
5ff3f7a4 2575#endif
22865c03 2576 SPAGAIN;
a0d0e21e
LW		 2577 if (result < 0)
2578 RETPUSHUNDEF;
3280af22 2579 if (cando(S_IRUSR, 1, &PL_statcache))
a0d0e21e
LW		 2580 RETPUSHYES;
2581 RETPUSHNO;
2582}
2583
2584PP(pp_ftewrite)
2585{
5ff3f7a4 2586 I32 result;
4e35701f 2587 djSP;
5ff3f7a4 2588#ifdef PERL_EFF_ACCESS_W_OK
2d8e6c8d 2589 STRLEN n_a;
5ff3f7a4 2590 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2591 result = PERL_EFF_ACCESS_W_OK(TOPpx);
5ff3f7a4
GS		 2592 if (result == 0)
2593 RETPUSHYES;
2594 if (result < 0)
2595 RETPUSHUNDEF;
2596 RETPUSHNO;
22865c03
GS		 2597 }
2598 else
cea2e8a9 2599 result = my_stat();
5ff3f7a4 2600#else
cea2e8a9 2601 result = my_stat();
5ff3f7a4 2602#endif
22865c03 2603 SPAGAIN;
a0d0e21e
LW		 2604 if (result < 0)
2605 RETPUSHUNDEF;
3280af22 2606 if (cando(S_IWUSR, 1, &PL_statcache))
a0d0e21e
LW		 2607 RETPUSHYES;
2608 RETPUSHNO;
2609}
2610
2611PP(pp_fteexec)
2612{
5ff3f7a4 2613 I32 result;
4e35701f 2614 djSP;
5ff3f7a4 2615#ifdef PERL_EFF_ACCESS_X_OK
2d8e6c8d 2616 STRLEN n_a;
5ff3f7a4 2617 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2618 result = PERL_EFF_ACCESS_X_OK(TOPpx);
5ff3f7a4
GS		 2619 if (result == 0)
2620 RETPUSHYES;
2621 if (result < 0)
2622 RETPUSHUNDEF;
2623 RETPUSHNO;
22865c03
GS		 2624 }
2625 else
cea2e8a9 2626 result = my_stat();
5ff3f7a4 2627#else
cea2e8a9 2628 result = my_stat();
5ff3f7a4 2629#endif
22865c03 2630 SPAGAIN;
a0d0e21e
LW		 2631 if (result < 0)
2632 RETPUSHUNDEF;
3280af22 2633 if (cando(S_IXUSR, 1, &PL_statcache))
a0d0e21e
LW		 2634 RETPUSHYES;
2635 RETPUSHNO;
2636}
2637
2638PP(pp_ftis)
2639{
cea2e8a9 2640 I32 result = my_stat();
4e35701f 2641 djSP;
a0d0e21e
LW		 2642 if (result < 0)
2643 RETPUSHUNDEF;
2644 RETPUSHYES;
2645}
2646
2647PP(pp_fteowned)
2648{
cea2e8a9 2649 return pp_ftrowned();
a0d0e21e
LW		 2650}
2651
2652PP(pp_ftrowned)
2653{
cea2e8a9 2654 I32 result = my_stat();
4e35701f 2655 djSP;
a0d0e21e
LW		 2656 if (result < 0)
2657 RETPUSHUNDEF;
533c011a 2658 if (PL_statcache.st_uid == (PL_op->op_type == OP_FTEOWNED ? PL_euid : PL_uid) )
a0d0e21e
LW		 2659 RETPUSHYES;
2660 RETPUSHNO;
2661}
2662
2663PP(pp_ftzero)
2664{
cea2e8a9 2665 I32 result = my_stat();
4e35701f 2666 djSP;
a0d0e21e
LW		 2667 if (result < 0)
2668 RETPUSHUNDEF;
3280af22 2669 if (!PL_statcache.st_size)
a0d0e21e
LW		 2670 RETPUSHYES;
2671 RETPUSHNO;
2672}
2673
2674PP(pp_ftsize)
2675{
cea2e8a9 2676 I32 result = my_stat();
4e35701f 2677 djSP; dTARGET;
a0d0e21e
LW		 2678 if (result < 0)
2679 RETPUSHUNDEF;
3280af22 2680 PUSHi(PL_statcache.st_size);
a0d0e21e
LW		 2681 RETURN;
2682}
2683
2684PP(pp_ftmtime)
2685{
cea2e8a9 2686 I32 result = my_stat();
4e35701f 2687 djSP; dTARGET;
a0d0e21e
LW		 2688 if (result < 0)
2689 RETPUSHUNDEF;
3280af22 2690 PUSHn( ((I32)PL_basetime - (I32)PL_statcache.st_mtime) / 86400.0 );
a0d0e21e
LW		 2691 RETURN;
2692}
2693
2694PP(pp_ftatime)
2695{
cea2e8a9 2696 I32 result = my_stat();
4e35701f 2697 djSP; dTARGET;
a0d0e21e
LW		 2698 if (result < 0)
2699 RETPUSHUNDEF;
3280af22 2700 PUSHn( ((I32)PL_basetime - (I32)PL_statcache.st_atime) / 86400.0 );
a0d0e21e
LW		 2701 RETURN;
2702}
2703
2704PP(pp_ftctime)
2705{
cea2e8a9 2706 I32 result = my_stat();
4e35701f 2707 djSP; dTARGET;
a0d0e21e
LW		 2708 if (result < 0)
2709 RETPUSHUNDEF;
3280af22 2710 PUSHn( ((I32)PL_basetime - (I32)PL_statcache.st_ctime) / 86400.0 );
a0d0e21e
LW		 2711 RETURN;
2712}
2713
2714PP(pp_ftsock)
2715{
cea2e8a9 2716 I32 result = my_stat();
4e35701f 2717 djSP;
a0d0e21e
LW		 2718 if (result < 0)
2719 RETPUSHUNDEF;
3280af22 2720 if (S_ISSOCK(PL_statcache.st_mode))
a0d0e21e
LW		 2721 RETPUSHYES;
2722 RETPUSHNO;
2723}
2724
2725PP(pp_ftchr)
2726{
cea2e8a9 2727 I32 result = my_stat();
4e35701f 2728 djSP;
a0d0e21e
LW		 2729 if (result < 0)
2730 RETPUSHUNDEF;
3280af22 2731 if (S_ISCHR(PL_statcache.st_mode))
a0d0e21e
LW		 2732 RETPUSHYES;
2733 RETPUSHNO;
2734}
2735
2736PP(pp_ftblk)
2737{
cea2e8a9 2738 I32 result = my_stat();
4e35701f 2739 djSP;
a0d0e21e
LW		 2740 if (result < 0)
2741 RETPUSHUNDEF;
3280af22 2742 if (S_ISBLK(PL_statcache.st_mode))
a0d0e21e
LW		 2743 RETPUSHYES;
2744 RETPUSHNO;
2745}
2746
2747PP(pp_ftfile)
2748{
cea2e8a9 2749 I32 result = my_stat();
4e35701f 2750 djSP;
a0d0e21e
LW		 2751 if (result < 0)
2752 RETPUSHUNDEF;
3280af22 2753 if (S_ISREG(PL_statcache.st_mode))
a0d0e21e
LW		 2754 RETPUSHYES;
2755 RETPUSHNO;
2756}
2757
2758PP(pp_ftdir)
2759{
cea2e8a9 2760 I32 result = my_stat();
4e35701f 2761 djSP;
a0d0e21e
LW		 2762 if (result < 0)
2763 RETPUSHUNDEF;
3280af22 2764 if (S_ISDIR(PL_statcache.st_mode))
a0d0e21e
LW		 2765 RETPUSHYES;
2766 RETPUSHNO;
2767}
2768
2769PP(pp_ftpipe)
2770{
cea2e8a9 2771 I32 result = my_stat();
4e35701f 2772 djSP;
a0d0e21e
LW		 2773 if (result < 0)
2774 RETPUSHUNDEF;
3280af22 2775 if (S_ISFIFO(PL_statcache.st_mode))
a0d0e21e
LW		 2776 RETPUSHYES;
2777 RETPUSHNO;
2778}
2779
2780PP(pp_ftlink)
2781{
cea2e8a9 2782 I32 result = my_lstat();
4e35701f 2783 djSP;
a0d0e21e
LW		 2784 if (result < 0)
2785 RETPUSHUNDEF;
3280af22 2786 if (S_ISLNK(PL_statcache.st_mode))
a0d0e21e
LW		 2787 RETPUSHYES;
2788 RETPUSHNO;
2789}
2790
2791PP(pp_ftsuid)
2792{
4e35701f 2793 djSP;
a0d0e21e 2794#ifdef S_ISUID
cea2e8a9 2795 I32 result = my_stat();
a0d0e21e
LW		 2796 SPAGAIN;
2797 if (result < 0)
2798 RETPUSHUNDEF;
3280af22 2799 if (PL_statcache.st_mode & S_ISUID)
a0d0e21e
LW		 2800 RETPUSHYES;
2801#endif
2802 RETPUSHNO;
2803}
2804
2805PP(pp_ftsgid)
2806{
4e35701f 2807 djSP;
a0d0e21e 2808#ifdef S_ISGID
cea2e8a9 2809 I32 result = my_stat();
a0d0e21e
LW		 2810 SPAGAIN;
2811 if (result < 0)
2812 RETPUSHUNDEF;
3280af22 2813 if (PL_statcache.st_mode & S_ISGID)
a0d0e21e
LW		 2814 RETPUSHYES;
2815#endif
2816 RETPUSHNO;
2817}
2818
2819PP(pp_ftsvtx)
2820{
4e35701f 2821 djSP;
a0d0e21e 2822#ifdef S_ISVTX
cea2e8a9 2823 I32 result = my_stat();
a0d0e21e
LW		 2824 SPAGAIN;
2825 if (result < 0)
2826 RETPUSHUNDEF;
3280af22 2827 if (PL_statcache.st_mode & S_ISVTX)
a0d0e21e
LW		 2828 RETPUSHYES;
2829#endif
2830 RETPUSHNO;
2831}
2832
2833PP(pp_fttty)
2834{
4e35701f 2835 djSP;
a0d0e21e
LW		 2836 int fd;
2837 GV *gv;
fb73857a 2838 char *tmps = Nullch;
2d8e6c8d 2839 STRLEN n_a;
fb73857a 2840
533c011a 2841 if (PL_op->op_flags & OPf_REF)
a0d0e21e 2842 gv = cGVOP->op_gv;
fb73857a 2843 else if (isGV(TOPs))
2844 gv = (GV*)POPs;
2845 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
2846 gv = (GV*)SvRV(POPs);
a0d0e21e 2847 else
2d8e6c8d 2848 gv = gv_fetchpv(tmps = POPpx, FALSE, SVt_PVIO);
fb73857a 2849
a0d0e21e 2850 if (GvIO(gv) && IoIFP(GvIOp(gv)))
760ac839 2851 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
fb73857a 2852 else if (tmps && isDIGIT(*tmps))
a0d0e21e
LW		 2853 fd = atoi(tmps);
2854 else
2855 RETPUSHUNDEF;
6ad3d225 2856 if (PerlLIO_isatty(fd))
a0d0e21e
LW		 2857 RETPUSHYES;
2858 RETPUSHNO;
2859}
2860
16d20bd9
AD		 2861#if defined(atarist) /* this will work with atariST. Configure will
2862 make guesses for other systems. */
2863# define FILE_base(f) ((f)->_base)
2864# define FILE_ptr(f) ((f)->_ptr)
2865# define FILE_cnt(f) ((f)->_cnt)
2866# define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
a0d0e21e
LW		 2867#endif
2868
2869PP(pp_fttext)
2870{
4e35701f 2871 djSP;
a0d0e21e
LW		 2872 I32 i;
2873 I32 len;
2874 I32 odd = 0;
2875 STDCHAR tbuf[512];
2876 register STDCHAR *s;
2877 register IO *io;
5f05dabc 2878 register SV *sv;
2879 GV *gv;
2d8e6c8d 2880 STRLEN n_a;
a0d0e21e 2881
533c011a 2882 if (PL_op->op_flags & OPf_REF)
5f05dabc 2883 gv = cGVOP->op_gv;
2884 else if (isGV(TOPs))
2885 gv = (GV*)POPs;
2886 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
2887 gv = (GV*)SvRV(POPs);
2888 else
2889 gv = Nullgv;
2890
2891 if (gv) {
a0d0e21e 2892 EXTEND(SP, 1);
3280af22
NIS		 2893 if (gv == PL_defgv) {
2894 if (PL_statgv)
2895 io = GvIO(PL_statgv);
a0d0e21e 2896 else {
3280af22 2897 sv = PL_statname;
a0d0e21e
LW		 2898 goto really_filename;
2899 }
2900 }
2901 else {
3280af22
NIS		 2902 PL_statgv = gv;
2903 PL_laststatval = -1;
2904 sv_setpv(PL_statname, "");
2905 io = GvIO(PL_statgv);
a0d0e21e
LW		 2906 }
2907 if (io && IoIFP(io)) {
5f05dabc 2908 if (! PerlIO_has_base(IoIFP(io)))
cea2e8a9 2909 DIE(aTHX_ "-T and -B not implemented on filehandles");
3280af22
NIS		 2910 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
2911 if (PL_laststatval < 0)
5f05dabc 2912 RETPUSHUNDEF;
3280af22 2913 if (S_ISDIR(PL_statcache.st_mode)) /* handle NFS glitch */
533c011a 2914 if (PL_op->op_type == OP_FTTEXT)
a0d0e21e
LW		 2915 RETPUSHNO;
2916 else
2917 RETPUSHYES;
760ac839
LW		 2918 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
2919 i = PerlIO_getc(IoIFP(io));
a0d0e21e 2920 if (i != EOF)
760ac839 2921 (void)PerlIO_ungetc(IoIFP(io),i);
a0d0e21e 2922 }
760ac839 2923 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
a0d0e21e 2924 RETPUSHYES;
760ac839
LW		 2925 len = PerlIO_get_bufsiz(IoIFP(io));
2926 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
2927 /* sfio can have large buffers - limit to 512 */
2928 if (len > 512)
2929 len = 512;
a0d0e21e
LW		 2930 }
2931 else {
599cee73 2932 if (ckWARN(WARN_UNOPENED))
cea2e8a9 2933 Perl_warner(aTHX_ WARN_UNOPENED, "Test on unopened file <%s>",
a0d0e21e 2934 GvENAME(cGVOP->op_gv));
748a9306 2935 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW		 2936 RETPUSHUNDEF;
2937 }
2938 }
2939 else {
2940 sv = POPs;
5f05dabc 2941 really_filename:
3280af22
NIS		 2942 PL_statgv = Nullgv;
2943 PL_laststatval = -1;
2d8e6c8d 2944 sv_setpv(PL_statname, SvPV(sv, n_a));
a0d0e21e 2945#ifdef HAS_OPEN3
2d8e6c8d 2946 i = PerlLIO_open3(SvPV(sv, n_a), O_RDONLY, 0);
a0d0e21e 2947#else
2d8e6c8d 2948 i = PerlLIO_open(SvPV(sv, n_a), 0);
a0d0e21e
LW		 2949#endif
2950 if (i < 0) {
2d8e6c8d 2951 if (ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, n_a), '\n'))
cea2e8a9 2952 Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "open");
a0d0e21e
LW		 2953 RETPUSHUNDEF;
2954 }
3280af22
NIS		 2955 PL_laststatval = PerlLIO_fstat(i, &PL_statcache);
2956 if (PL_laststatval < 0)
5f05dabc 2957 RETPUSHUNDEF;
6ad3d225
GS		 2958 len = PerlLIO_read(i, tbuf, 512);
2959 (void)PerlLIO_close(i);
a0d0e21e 2960 if (len <= 0) {
533c011a 2961 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
a0d0e21e
LW		 2962 RETPUSHNO; /* special case NFS directories */
2963 RETPUSHYES; /* null file is anything */
2964 }
2965 s = tbuf;
2966 }
2967
2968 /* now scan s to look for textiness */
4633a7c4 2969 /* XXX ASCII dependent code */
a0d0e21e
LW		 2970
2971 for (i = 0; i < len; i++, s++) {
2972 if (!*s) { /* null never allowed in text */
2973 odd += len;
2974 break;
2975 }
9d116dd7
JH		 2976#ifdef EBCDIC
2977 else if (!(isPRINT(*s) || isSPACE(*s)))
2978 odd++;
2979#else
a0d0e21e
LW		 2980 else if (*s & 128)
2981 odd++;
2982 else if (*s < 32 &&
2983 *s != '\n' && *s != '\r' && *s != '\b' &&
2984 *s != '\t' && *s != '\f' && *s != 27)
2985 odd++;
9d116dd7 2986#endif
a0d0e21e
LW		 2987 }
2988
533c011a 2989 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
a0d0e21e
LW		 2990 RETPUSHNO;
2991 else
2992 RETPUSHYES;
2993}
2994
2995PP(pp_ftbinary)
2996{
cea2e8a9 2997 return pp_fttext();
a0d0e21e
LW		 2998}
2999
3000/* File calls. */
3001
3002PP(pp_chdir)
3003{
4e35701f 3004 djSP; dTARGET;
a0d0e21e
LW		 3005 char *tmps;
3006 SV **svp;
2d8e6c8d 3007 STRLEN n_a;
a0d0e21e
LW		 3008
3009 if (MAXARG < 1)
3010 tmps = Nullch;
3011 else
2d8e6c8d 3012 tmps = POPpx;
a0d0e21e 3013 if (!tmps || !*tmps) {
3280af22 3014 svp = hv_fetch(GvHVn(PL_envgv), "HOME", 4, FALSE);
a0d0e21e 3015 if (svp)
2d8e6c8d 3016 tmps = SvPV(*svp, n_a);
a0d0e21e
LW		 3017 }
3018 if (!tmps || !*tmps) {
3280af22 3019 svp = hv_fetch(GvHVn(PL_envgv), "LOGDIR", 6, FALSE);
a0d0e21e 3020 if (svp)
2d8e6c8d 3021 tmps = SvPV(*svp, n_a);
a0d0e21e 3022 }
491527d0
GS		 3023#ifdef VMS
3024 if (!tmps || !*tmps) {
6b88bc9c 3025 svp = hv_fetch(GvHVn(PL_envgv), "SYS$LOGIN", 9, FALSE);
491527d0 3026 if (svp)
2d8e6c8d 3027 tmps = SvPV(*svp, n_a);
491527d0
GS		 3028 }
3029#endif
a0d0e21e 3030 TAINT_PROPER("chdir");
6ad3d225 3031 PUSHi( PerlDir_chdir(tmps) >= 0 );
748a9306
LW		 3032#ifdef VMS
3033 /* Clear the DEFAULT element of ENV so we'll get the new value
3034 * in the future. */
6b88bc9c 3035 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
748a9306 3036#endif
a0d0e21e
LW		 3037 RETURN;
3038}
3039
3040PP(pp_chown)
3041{
4e35701f 3042 djSP; dMARK; dTARGET;
a0d0e21e
LW		 3043 I32 value;
3044#ifdef HAS_CHOWN
533c011a 3045 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 3046 SP = MARK;
3047 PUSHi(value);
3048 RETURN;
3049#else
cea2e8a9 3050 DIE(aTHX_ PL_no_func, "Unsupported function chown");
a0d0e21e
LW		 3051#endif
3052}
3053
3054PP(pp_chroot)
3055{
4e35701f 3056 djSP; dTARGET;
a0d0e21e
LW		 3057 char *tmps;
3058#ifdef HAS_CHROOT
2d8e6c8d
GS		 3059 STRLEN n_a;
3060 tmps = POPpx;
a0d0e21e
LW		 3061 TAINT_PROPER("chroot");
3062 PUSHi( chroot(tmps) >= 0 );
3063 RETURN;
3064#else
cea2e8a9 3065 DIE(aTHX_ PL_no_func, "chroot");
a0d0e21e
LW		 3066#endif
3067}
3068
3069PP(pp_unlink)
3070{
4e35701f 3071 djSP; dMARK; dTARGET;
a0d0e21e 3072 I32 value;
533c011a 3073 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 3074 SP = MARK;
3075 PUSHi(value);
3076 RETURN;
3077}
3078
3079PP(pp_chmod)
3080{
4e35701f 3081 djSP; dMARK; dTARGET;
a0d0e21e 3082 I32 value;
533c011a 3083 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 3084 SP = MARK;
3085 PUSHi(value);
3086 RETURN;
3087}
3088
3089PP(pp_utime)
3090{
4e35701f 3091 djSP; dMARK; dTARGET;
a0d0e21e 3092 I32 value;
533c011a 3093 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 3094 SP = MARK;
3095 PUSHi(value);
3096 RETURN;
3097}
3098
3099PP(pp_rename)
3100{
4e35701f 3101 djSP; dTARGET;
a0d0e21e 3102 int anum;
2d8e6c8d 3103 STRLEN n_a;
a0d0e21e 3104
2d8e6c8d
GS		 3105 char *tmps2 = POPpx;
3106 char *tmps = SvPV(TOPs, n_a);
a0d0e21e
LW		 3107 TAINT_PROPER("rename");
3108#ifdef HAS_RENAME
baed7233 3109 anum = PerlLIO_rename(tmps, tmps2);
a0d0e21e 3110#else
6b88bc9c 3111 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
ed969818
W		 3112 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3113 anum = 1;
3114 else {
3654eb6c 3115 if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
ed969818
W		 3116 (void)UNLINK(tmps2);
3117 if (!(anum = link(tmps, tmps2)))
3118 anum = UNLINK(tmps);
3119 }
a0d0e21e
LW		 3120 }
3121#endif
3122 SETi( anum >= 0 );
3123 RETURN;
3124}
3125
3126PP(pp_link)
3127{
4e35701f 3128 djSP; dTARGET;
a0d0e21e 3129#ifdef HAS_LINK
2d8e6c8d
GS		 3130 STRLEN n_a;
3131 char *tmps2 = POPpx;
3132 char *tmps = SvPV(TOPs, n_a);
a0d0e21e
LW		 3133 TAINT_PROPER("link");
3134 SETi( link(tmps, tmps2) >= 0 );
3135#else
cea2e8a9 3136 DIE(aTHX_ PL_no_func, "Unsupported function link");
a0d0e21e
LW		 3137#endif
3138 RETURN;
3139}
3140
3141PP(pp_symlink)
3142{
4e35701f 3143 djSP; dTARGET;
a0d0e21e 3144#ifdef HAS_SYMLINK
2d8e6c8d
GS		 3145 STRLEN n_a;
3146 char *tmps2 = POPpx;
3147 char *tmps = SvPV(TOPs, n_a);
a0d0e21e
LW		 3148 TAINT_PROPER("symlink");
3149 SETi( symlink(tmps, tmps2) >= 0 );
3150 RETURN;
3151#else
cea2e8a9 3152 DIE(aTHX_ PL_no_func, "symlink");
a0d0e21e
LW		 3153#endif
3154}
3155
3156PP(pp_readlink)
3157{
4e35701f 3158 djSP; dTARGET;
a0d0e21e
LW		 3159#ifdef HAS_SYMLINK
3160 char *tmps;
46fc3d4c 3161 char buf[MAXPATHLEN];
a0d0e21e 3162 int len;
2d8e6c8d 3163 STRLEN n_a;
46fc3d4c 3164
fb73857a 3165#ifndef INCOMPLETE_TAINTS
3166 TAINT;
3167#endif
2d8e6c8d 3168 tmps = POPpx;
a0d0e21e
LW		 3169 len = readlink(tmps, buf, sizeof buf);
3170 EXTEND(SP, 1);
3171 if (len < 0)
3172 RETPUSHUNDEF;
3173 PUSHp(buf, len);
3174 RETURN;
3175#else
3176 EXTEND(SP, 1);
3177 RETSETUNDEF; /* just pretend it's a normal file */
3178#endif
3179}
3180
3181#if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
ba106d47 3182STATIC int
cea2e8a9 3183S_dooneliner(pTHX_ char *cmd, char *filename)
a0d0e21e 3184{
1e422769 3185 char *save_filename = filename;
3186 char *cmdline;
3187 char *s;
760ac839 3188 PerlIO *myfp;
1e422769 3189 int anum = 1;
a0d0e21e 3190
1e422769 3191 New(666, cmdline, strlen(cmd) + (strlen(filename) * 2) + 10, char);
3192 strcpy(cmdline, cmd);
3193 strcat(cmdline, " ");
3194 for (s = cmdline + strlen(cmdline); *filename; ) {
a0d0e21e
LW		 3195 *s++ = '\\';
3196 *s++ = *filename++;
3197 }
3198 strcpy(s, " 2>&1");
6ad3d225 3199 myfp = PerlProc_popen(cmdline, "r");
1e422769 3200 Safefree(cmdline);
3201
a0d0e21e 3202 if (myfp) {
1e422769 3203 SV *tmpsv = sv_newmortal();
6b88bc9c 3204 /* Need to save/restore 'PL_rs' ?? */
760ac839 3205 s = sv_gets(tmpsv, myfp, 0);
6ad3d225 3206 (void)PerlProc_pclose(myfp);
a0d0e21e 3207 if (s != Nullch) {
1e422769 3208 int e;
3209 for (e = 1;
a0d0e21e 3210#ifdef HAS_SYS_ERRLIST
1e422769 3211 e <= sys_nerr
3212#endif
3213 ; e++)
3214 {
3215 /* you don't see this */
3216 char *errmsg =
3217#ifdef HAS_SYS_ERRLIST
3218 sys_errlist[e]
a0d0e21e 3219#else
1e422769 3220 strerror(e)
a0d0e21e 3221#endif
1e422769 3222 ;
3223 if (!errmsg)
3224 break;
3225 if (instr(s, errmsg)) {
3226 SETERRNO(e,0);
3227 return 0;
3228 }
a0d0e21e 3229 }
748a9306 3230 SETERRNO(0,0);
a0d0e21e
LW		 3231#ifndef EACCES
3232#define EACCES EPERM
3233#endif
1e422769 3234 if (instr(s, "cannot make"))
748a9306 3235 SETERRNO(EEXIST,RMS$_FEX);
1e422769 3236 else if (instr(s, "existing file"))
748a9306 3237 SETERRNO(EEXIST,RMS$_FEX);
1e422769 3238 else if (instr(s, "ile exists"))
748a9306 3239 SETERRNO(EEXIST,RMS$_FEX);
1e422769 3240 else if (instr(s, "non-exist"))
748a9306 3241 SETERRNO(ENOENT,RMS$_FNF);
1e422769 3242 else if (instr(s, "does not exist"))
748a9306 3243 SETERRNO(ENOENT,RMS$_FNF);
1e422769 3244 else if (instr(s, "not empty"))
748a9306 3245 SETERRNO(EBUSY,SS$_DEVOFFLINE);
1e422769 3246 else if (instr(s, "cannot access"))
748a9306 3247 SETERRNO(EACCES,RMS$_PRV);
a0d0e21e 3248 else
748a9306 3249 SETERRNO(EPERM,RMS$_PRV);
a0d0e21e
LW		 3250 return 0;
3251 }
3252 else { /* some mkdirs return no failure indication */
6b88bc9c 3253 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
911d147d 3254 if (PL_op->op_type == OP_RMDIR)
a0d0e21e
LW		 3255 anum = !anum;
3256 if (anum)
748a9306 3257 SETERRNO(0,0);
a0d0e21e 3258 else
748a9306 3259 SETERRNO(EACCES,RMS$_PRV); /* a guess */
a0d0e21e
LW		 3260 }
3261 return anum;
3262 }
3263 else
3264 return 0;
3265}
3266#endif
3267
3268PP(pp_mkdir)
3269{
4e35701f 3270 djSP; dTARGET;
a0d0e21e
LW		 3271 int mode = POPi;
3272#ifndef HAS_MKDIR
3273 int oldumask;
3274#endif
2d8e6c8d
GS		 3275 STRLEN n_a;
3276 char *tmps = SvPV(TOPs, n_a);
a0d0e21e
LW		 3277
3278 TAINT_PROPER("mkdir");
3279#ifdef HAS_MKDIR
6ad3d225 3280 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
a0d0e21e
LW		 3281#else
3282 SETi( dooneliner("mkdir", tmps) );
6ad3d225
GS		 3283 oldumask = PerlLIO_umask(0);
3284 PerlLIO_umask(oldumask);
3285 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
a0d0e21e
LW		 3286#endif
3287 RETURN;
3288}
3289
3290PP(pp_rmdir)
3291{
4e35701f 3292 djSP; dTARGET;
a0d0e21e 3293 char *tmps;
2d8e6c8d 3294 STRLEN n_a;
a0d0e21e 3295
2d8e6c8d 3296 tmps = POPpx;
a0d0e21e
LW		 3297 TAINT_PROPER("rmdir");
3298#ifdef HAS_RMDIR
6ad3d225 3299 XPUSHi( PerlDir_rmdir(tmps) >= 0 );
a0d0e21e
LW		 3300#else
3301 XPUSHi( dooneliner("rmdir", tmps) );
3302#endif
3303 RETURN;
3304}
3305
3306/* Directory calls. */
3307
3308PP(pp_open_dir)
3309{
4e35701f 3310 djSP;
a0d0e21e 3311#if defined(Direntry_t) && defined(HAS_READDIR)
2d8e6c8d
GS		 3312 STRLEN n_a;
3313 char *dirname = POPpx;
a0d0e21e
LW		 3314 GV *gv = (GV*)POPs;
3315 register IO *io = GvIOn(gv);
3316
3317 if (!io)
3318 goto nope;
3319
3320 if (IoDIRP(io))
6ad3d225
GS		 3321 PerlDir_close(IoDIRP(io));
3322 if (!(IoDIRP(io) = PerlDir_open(dirname)))
a0d0e21e
LW		 3323 goto nope;
3324
3325 RETPUSHYES;
3326nope:
3327 if (!errno)
748a9306 3328 SETERRNO(EBADF,RMS$_DIR);
a0d0e21e
LW		 3329 RETPUSHUNDEF;
3330#else
cea2e8a9 3331 DIE(aTHX_ PL_no_dir_func, "opendir");
a0d0e21e
LW		 3332#endif
3333}
3334
3335PP(pp_readdir)
3336{
4e35701f 3337 djSP;
a0d0e21e
LW		 3338#if defined(Direntry_t) && defined(HAS_READDIR)
3339#ifndef I_DIRENT
20ce7b12 3340 Direntry_t *readdir (DIR *);
a0d0e21e
LW		 3341#endif
3342 register Direntry_t *dp;
3343 GV *gv = (GV*)POPs;
3344 register IO *io = GvIOn(gv);
fb73857a 3345 SV *sv;
a0d0e21e
LW		 3346
3347 if (!io || !IoDIRP(io))
3348 goto nope;
3349
3350 if (GIMME == G_ARRAY) {
3351 /*SUPPRESS 560*/
6ad3d225 3352 while (dp = (Direntry_t *)PerlDir_read(IoDIRP(io))) {
a0d0e21e 3353#ifdef DIRNAMLEN
79cb57f6 3354 sv = newSVpvn(dp->d_name, dp->d_namlen);
a0d0e21e 3355#else
fb73857a 3356 sv = newSVpv(dp->d_name, 0);
3357#endif
3358#ifndef INCOMPLETE_TAINTS
3359 SvTAINTED_on(sv);
a0d0e21e 3360#endif
fb73857a 3361 XPUSHs(sv_2mortal(sv));
a0d0e21e
LW		 3362 }
3363 }
3364 else {
6ad3d225 3365 if (!(dp = (Direntry_t *)PerlDir_read(IoDIRP(io))))
a0d0e21e
LW		 3366 goto nope;
3367#ifdef DIRNAMLEN
79cb57f6 3368 sv = newSVpvn(dp->d_name, dp->d_namlen);
a0d0e21e 3369#else
fb73857a 3370 sv = newSVpv(dp->d_name, 0);
a0d0e21e 3371#endif
fb73857a 3372#ifndef INCOMPLETE_TAINTS
3373 SvTAINTED_on(sv);
3374#endif
3375 XPUSHs(sv_2mortal(sv));
a0d0e21e
LW		 3376 }
3377 RETURN;
3378
3379nope:
3380 if (!errno)
748a9306 3381 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 3382 if (GIMME == G_ARRAY)
3383 RETURN;
3384 else
3385 RETPUSHUNDEF;
3386#else
cea2e8a9 3387 DIE(aTHX_ PL_no_dir_func, "readdir");
a0d0e21e
LW		 3388#endif
3389}
3390
3391PP(pp_telldir)
3392{
4e35701f 3393 djSP; dTARGET;
a0d0e21e 3394#if defined(HAS_TELLDIR) || defined(telldir)
968dcd91
JH		 3395 /* XXX does _anyone_ need this? --AD 2/20/1998 */
3396 /* XXX netbsd still seemed to.
3397 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3398 --JHI 1999-Feb-02 */
3399# if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
20ce7b12 3400 long telldir (DIR *);
dfe9444c 3401# endif
a0d0e21e
LW		 3402 GV *gv = (GV*)POPs;
3403 register IO *io = GvIOn(gv);
3404
3405 if (!io || !IoDIRP(io))
3406 goto nope;
3407
6ad3d225 3408 PUSHi( PerlDir_tell(IoDIRP(io)) );
a0d0e21e
LW		 3409 RETURN;
3410nope:
3411 if (!errno)
748a9306 3412 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 3413 RETPUSHUNDEF;
3414#else
cea2e8a9 3415 DIE(aTHX_ PL_no_dir_func, "telldir");
a0d0e21e
LW		 3416#endif
3417}
3418
3419PP(pp_seekdir)
3420{
4e35701f 3421 djSP;
a0d0e21e
LW		 3422#if defined(HAS_SEEKDIR) || defined(seekdir)
3423 long along = POPl;
3424 GV *gv = (GV*)POPs;
3425 register IO *io = GvIOn(gv);
3426
3427 if (!io || !IoDIRP(io))
3428 goto nope;
3429
6ad3d225 3430 (void)PerlDir_seek(IoDIRP(io), along);
a0d0e21e
LW		 3431
3432 RETPUSHYES;
3433nope:
3434 if (!errno)
748a9306 3435 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 3436 RETPUSHUNDEF;
3437#else
cea2e8a9 3438 DIE(aTHX_ PL_no_dir_func, "seekdir");
a0d0e21e
LW		 3439#endif
3440}
3441
3442PP(pp_rewinddir)
3443{
4e35701f 3444 djSP;
a0d0e21e
LW		 3445#if defined(HAS_REWINDDIR) || defined(rewinddir)
3446 GV *gv = (GV*)POPs;
3447 register IO *io = GvIOn(gv);
3448
3449 if (!io || !IoDIRP(io))
3450 goto nope;
3451
6ad3d225 3452 (void)PerlDir_rewind(IoDIRP(io));
a0d0e21e
LW		 3453 RETPUSHYES;
3454nope:
3455 if (!errno)
748a9306 3456 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 3457 RETPUSHUNDEF;
3458#else
cea2e8a9 3459 DIE(aTHX_ PL_no_dir_func, "rewinddir");
a0d0e21e
LW		 3460#endif
3461}
3462
3463PP(pp_closedir)
3464{
4e35701f 3465 djSP;
a0d0e21e
LW		 3466#if defined(Direntry_t) && defined(HAS_READDIR)
3467 GV *gv = (GV*)POPs;
3468 register IO *io = GvIOn(gv);
3469
3470 if (!io || !IoDIRP(io))
3471 goto nope;
3472
3473#ifdef VOID_CLOSEDIR
6ad3d225 3474 PerlDir_close(IoDIRP(io));
a0d0e21e 3475#else
6ad3d225 3476 if (PerlDir_close(IoDIRP(io)) < 0) {
748a9306 3477 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
a0d0e21e 3478 goto nope;
748a9306 3479 }
a0d0e21e
LW		 3480#endif
3481 IoDIRP(io) = 0;
3482
3483 RETPUSHYES;
3484nope:
3485 if (!errno)
748a9306 3486 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW		 3487 RETPUSHUNDEF;
3488#else
cea2e8a9 3489 DIE(aTHX_ PL_no_dir_func, "closedir");
a0d0e21e
LW		 3490#endif
3491}
3492
3493/* Process control. */
3494
3495PP(pp_fork)
3496{
44a8e56a 3497#ifdef HAS_FORK
4e35701f 3498 djSP; dTARGET;
761237fe 3499 Pid_t childpid;
a0d0e21e
LW		 3500 GV *tmpgv;
3501
3502 EXTEND(SP, 1);
45bc9206 3503 PERL_FLUSHALL_FOR_CHILD;
a0d0e21e
LW		 3504 childpid = fork();
3505 if (childpid < 0)
3506 RETSETUNDEF;
3507 if (!childpid) {
3508 /*SUPPRESS 560*/
3509 if (tmpgv = gv_fetchpv("$", TRUE, SVt_PV))
1e422769 3510 sv_setiv(GvSV(tmpgv), (IV)getpid());
3280af22 3511 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
a0d0e21e
LW		 3512 }
3513 PUSHi(childpid);
3514 RETURN;
3515#else
cea2e8a9 3516 DIE(aTHX_ PL_no_func, "Unsupported function fork");
a0d0e21e
LW		 3517#endif
3518}
3519
3520PP(pp_wait)
3521{
8736538c 3522#if !defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(CYGWIN32)
4e35701f 3523 djSP; dTARGET;
761237fe 3524 Pid_t childpid;
a0d0e21e 3525 int argflags;
a0d0e21e 3526
44a8e56a 3527 childpid = wait4pid(-1, &argflags, 0);
f86702cc 3528 STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
44a8e56a 3529 XPUSHi(childpid);
a0d0e21e
LW		 3530 RETURN;
3531#else
cea2e8a9 3532 DIE(aTHX_ PL_no_func, "Unsupported function wait");
a0d0e21e
LW		 3533#endif
3534}
3535
3536PP(pp_waitpid)
3537{
8736538c 3538#if !defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(CYGWIN32)
4e35701f 3539 djSP; dTARGET;
761237fe 3540 Pid_t childpid;
a0d0e21e
LW		 3541 int optype;
3542 int argflags;
a0d0e21e 3543
a0d0e21e
LW		 3544 optype = POPi;
3545 childpid = TOPi;
3546 childpid = wait4pid(childpid, &argflags, optype);
f86702cc 3547 STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
44a8e56a 3548 SETi(childpid);
a0d0e21e
LW		 3549 RETURN;
3550#else
cea2e8a9 3551 DIE(aTHX_ PL_no_func, "Unsupported function waitpid");
a0d0e21e
LW		 3552#endif
3553}
3554
3555PP(pp_system)
3556{
4e35701f 3557 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e 3558 I32 value;
761237fe 3559 Pid_t childpid;
a0d0e21e
LW		 3560 int result;
3561 int status;
ff68c719 3562 Sigsave_t ihand,qhand; /* place to save signals during system() */
2d8e6c8d 3563 STRLEN n_a;
a0d0e21e 3564
a0d0e21e 3565 if (SP - MARK == 1) {
3280af22 3566 if (PL_tainting) {
2d8e6c8d 3567 char *junk = SvPV(TOPs, n_a);
a0d0e21e
LW		 3568 TAINT_ENV();
3569 TAINT_PROPER("system");
3570 }
3571 }
45bc9206 3572 PERL_FLUSHALL_FOR_CHILD;
1e422769 3573#if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2)
a0d0e21e
LW		 3574 while ((childpid = vfork()) == -1) {
3575 if (errno != EAGAIN) {
3576 value = -1;
3577 SP = ORIGMARK;
3578 PUSHi(value);
3579 RETURN;
3580 }
3581 sleep(5);
3582 }
3583 if (childpid > 0) {
ff68c719 3584 rsignal_save(SIGINT, SIG_IGN, &ihand);
3585 rsignal_save(SIGQUIT, SIG_IGN, &qhand);
748a9306
LW		 3586 do {
3587 result = wait4pid(childpid, &status, 0);
3588 } while (result == -1 && errno == EINTR);
ff68c719 3589 (void)rsignal_restore(SIGINT, &ihand);
3590 (void)rsignal_restore(SIGQUIT, &qhand);
91e9c03f 3591 STATUS_NATIVE_SET(result == -1 ? -1 : status);
a0d0e21e
LW		 3592 do_execfree(); /* free any memory child malloced on vfork */
3593 SP = ORIGMARK;
ff0cee69 3594 PUSHi(STATUS_CURRENT);
a0d0e21e
LW		 3595 RETURN;
3596 }
533c011a 3597 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e
LW		 3598 SV *really = *++MARK;
3599 value = (I32)do_aexec(really, MARK, SP);
3600 }
3601 else if (SP - MARK != 1)
3602 value = (I32)do_aexec(Nullsv, MARK, SP);
3603 else {
2d8e6c8d 3604 value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
a0d0e21e 3605 }
6ad3d225 3606 PerlProc__exit(-1);
c3293030 3607#else /* ! FORK or VMS or OS/2 */
911d147d 3608 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e 3609 SV *really = *++MARK;
4f63d024 3610 value = (I32)do_aspawn(aTHX_ really, (void **)MARK, (void **)SP);
a0d0e21e
LW		 3611 }
3612 else if (SP - MARK != 1)
4f63d024 3613 value = (I32)do_aspawn(aTHX_ Nullsv, (void **)MARK, (void **)SP);
a0d0e21e 3614 else {
4f63d024 3615 value = (I32)do_spawn(aTHX_ SvPVx(sv_mortalcopy(*SP), n_a));
a0d0e21e 3616 }
f86702cc 3617 STATUS_NATIVE_SET(value);
a0d0e21e
LW		 3618 do_execfree();
3619 SP = ORIGMARK;
ff0cee69 3620 PUSHi(STATUS_CURRENT);
a0d0e21e
LW		 3621#endif /* !FORK or VMS */
3622 RETURN;
3623}
3624
3625PP(pp_exec)
3626{
4e35701f 3627 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e 3628 I32 value;
2d8e6c8d 3629 STRLEN n_a;
a0d0e21e 3630
45bc9206 3631 PERL_FLUSHALL_FOR_CHILD;
533c011a 3632 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e
LW		 3633 SV *really = *++MARK;
3634 value = (I32)do_aexec(really, MARK, SP);
3635 }
3636 else if (SP - MARK != 1)
3637#ifdef VMS
3638 value = (I32)vms_do_aexec(Nullsv, MARK, SP);
3639#else
092bebab
JH		 3640# ifdef __OPEN_VM
3641 {
4f63d024 3642 (void ) do_aspawn(aTHX_ Nullsv, MARK, SP);
092bebab
JH		 3643 value = 0;
3644 }
3645# else
a0d0e21e 3646 value = (I32)do_aexec(Nullsv, MARK, SP);
092bebab 3647# endif
a0d0e21e
LW		 3648#endif
3649 else {
3280af22 3650 if (PL_tainting) {
2d8e6c8d 3651 char *junk = SvPV(*SP, n_a);
a0d0e21e
LW		 3652 TAINT_ENV();
3653 TAINT_PROPER("exec");
3654 }
3655#ifdef VMS
2d8e6c8d 3656 value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
a0d0e21e 3657#else
092bebab 3658# ifdef __OPEN_VM
4f63d024 3659 (void) do_spawn(aTHX_ SvPVx(sv_mortalcopy(*SP), n_a));
092bebab
JH		 3660 value = 0;
3661# else
2d8e6c8d 3662 value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
092bebab 3663# endif
a0d0e21e
LW		 3664#endif
3665 }
3666 SP = ORIGMARK;
3667 PUSHi(value);
3668 RETURN;
3669}
3670
3671PP(pp_kill)
3672{
4e35701f 3673 djSP; dMARK; dTARGET;
a0d0e21e
LW		 3674 I32 value;
3675#ifdef HAS_KILL
533c011a 3676 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 3677 SP = MARK;
3678 PUSHi(value);
3679 RETURN;
3680#else
cea2e8a9 3681 DIE(aTHX_ PL_no_func, "Unsupported function kill");
a0d0e21e
LW		 3682#endif
3683}
3684
3685PP(pp_getppid)
3686{
3687#ifdef HAS_GETPPID
4e35701f 3688 djSP; dTARGET;
a0d0e21e
LW		 3689 XPUSHi( getppid() );
3690 RETURN;
3691#else
cea2e8a9 3692 DIE(aTHX_ PL_no_func, "getppid");
a0d0e21e
LW		 3693#endif
3694}
3695
3696PP(pp_getpgrp)
3697{
3698#ifdef HAS_GETPGRP
4e35701f 3699 djSP; dTARGET;
a0d0e21e
LW		 3700 int pid;
3701 I32 value;
3702
3703 if (MAXARG < 1)
3704 pid = 0;
3705 else
3706 pid = SvIVx(POPs);
c3293030
IZ		 3707#ifdef BSD_GETPGRP
3708 value = (I32)BSD_GETPGRP(pid);
a0d0e21e 3709#else
aa689395 3710 if (pid != 0 && pid != getpid())
cea2e8a9 3711 DIE(aTHX_ "POSIX getpgrp can't take an argument");
a0d0e21e
LW		 3712 value = (I32)getpgrp();
3713#endif
3714 XPUSHi(value);
3715 RETURN;
3716#else
cea2e8a9 3717 DIE(aTHX_ PL_no_func, "getpgrp()");
a0d0e21e
LW		 3718#endif
3719}
3720
3721PP(pp_setpgrp)
3722{
3723#ifdef HAS_SETPGRP
4e35701f 3724 djSP; dTARGET;
a0d0e21e
LW		 3725 int pgrp;
3726 int pid;
3727 if (MAXARG < 2) {
3728 pgrp = 0;
3729 pid = 0;
3730 }
3731 else {
3732 pgrp = POPi;
3733 pid = TOPi;
3734 }
3735
3736 TAINT_PROPER("setpgrp");
c3293030
IZ		 3737#ifdef BSD_SETPGRP
3738 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
a0d0e21e 3739#else
c90c0ff4 3740 if ((pgrp != 0 && pgrp != getpid()) || (pid != 0 && pid != getpid()))
cea2e8a9 3741 DIE(aTHX_ "POSIX setpgrp can't take an argument");
a0d0e21e
LW		 3742 SETi( setpgrp() >= 0 );
3743#endif /* USE_BSDPGRP */
3744 RETURN;
3745#else
cea2e8a9 3746 DIE(aTHX_ PL_no_func, "setpgrp()");
a0d0e21e
LW		 3747#endif
3748}
3749
3750PP(pp_getpriority)
3751{
4e35701f 3752 djSP; dTARGET;
a0d0e21e
LW		 3753 int which;
3754 int who;
3755#ifdef HAS_GETPRIORITY
3756 who = POPi;
3757 which = TOPi;
3758 SETi( getpriority(which, who) );
3759 RETURN;
3760#else
cea2e8a9 3761 DIE(aTHX_ PL_no_func, "getpriority()");
a0d0e21e
LW		 3762#endif
3763}
3764
3765PP(pp_setpriority)
3766{
4e35701f 3767 djSP; dTARGET;
a0d0e21e
LW		 3768 int which;
3769 int who;
3770 int niceval;
3771#ifdef HAS_SETPRIORITY
3772 niceval = POPi;
3773 who = POPi;
3774 which = TOPi;
3775 TAINT_PROPER("setpriority");
3776 SETi( setpriority(which, who, niceval) >= 0 );
3777 RETURN;
3778#else
cea2e8a9 3779 DIE(aTHX_ PL_no_func, "setpriority()");
a0d0e21e
LW		 3780#endif
3781}
3782
3783/* Time calls. */
3784
3785PP(pp_time)
3786{
4e35701f 3787 djSP; dTARGET;
cbdc8872 3788#ifdef BIG_TIME
3789 XPUSHn( time(Null(Time_t*)) );
3790#else
a0d0e21e 3791 XPUSHi( time(Null(Time_t*)) );
cbdc8872 3792#endif
a0d0e21e
LW		 3793 RETURN;
3794}
3795
cd52b7b2 3796/* XXX The POSIX name is CLK_TCK; it is to be preferred
3797 to HZ. Probably. For now, assume that if the system
3798 defines HZ, it does so correctly. (Will this break
3799 on VMS?)
3800 Probably we ought to use _sysconf(_SC_CLK_TCK), if
3801 it's supported. --AD 9/96.
3802*/
3803
a0d0e21e 3804#ifndef HZ
cd52b7b2 3805# ifdef CLK_TCK
3806# define HZ CLK_TCK
3807# else
3808# define HZ 60
3809# endif
a0d0e21e
LW		 3810#endif
3811
3812PP(pp_tms)
3813{
4e35701f 3814 djSP;
a0d0e21e 3815
55497cff 3816#ifndef HAS_TIMES
cea2e8a9 3817 DIE(aTHX_ "times not implemented");
a0d0e21e
LW		 3818#else
3819 EXTEND(SP, 4);
3820
3821#ifndef VMS
3280af22 3822 (void)PerlProc_times(&PL_timesbuf);
a0d0e21e 3823#else
6b88bc9c 3824 (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
76e3520e
GS		 3825 /* struct tms, though same data */
3826 /* is returned. */
a0d0e21e
LW		 3827#endif
3828
3280af22 3829 PUSHs(sv_2mortal(newSVnv(((double)PL_timesbuf.tms_utime)/HZ)));
a0d0e21e 3830 if (GIMME == G_ARRAY) {
3280af22
NIS		 3831 PUSHs(sv_2mortal(newSVnv(((double)PL_timesbuf.tms_stime)/HZ)));
3832 PUSHs(sv_2mortal(newSVnv(((double)PL_timesbuf.tms_cutime)/HZ)));
3833 PUSHs(sv_2mortal(newSVnv(((double)PL_timesbuf.tms_cstime)/HZ)));
a0d0e21e
LW		 3834 }
3835 RETURN;
55497cff 3836#endif /* HAS_TIMES */
a0d0e21e
LW		 3837}
3838
3839PP(pp_localtime)
3840{
cea2e8a9 3841 return pp_gmtime();
a0d0e21e
LW		 3842}
3843
3844PP(pp_gmtime)
3845{
4e35701f 3846 djSP;
a0d0e21e
LW		 3847 Time_t when;
3848 struct tm *tmbuf;
3849 static char *dayname[] = {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
3850 static char *monname[] = {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
3851 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
3852
3853 if (MAXARG < 1)
3854 (void)time(&when);
3855 else
cbdc8872 3856#ifdef BIG_TIME
3857 when = (Time_t)SvNVx(POPs);
3858#else
a0d0e21e 3859 when = (Time_t)SvIVx(POPs);
cbdc8872 3860#endif
a0d0e21e 3861
533c011a 3862 if (PL_op->op_type == OP_LOCALTIME)
a0d0e21e
LW		 3863 tmbuf = localtime(&when);
3864 else
3865 tmbuf = gmtime(&when);
3866
3867 EXTEND(SP, 9);
bbce6d69 3868 EXTEND_MORTAL(9);
a0d0e21e
LW		 3869 if (GIMME != G_ARRAY) {
3870 dTARGET;
46fc3d4c 3871 SV *tsv;
a0d0e21e
LW		 3872 if (!tmbuf)
3873 RETPUSHUNDEF;
cea2e8a9 3874 tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %d",
46fc3d4c 3875 dayname[tmbuf->tm_wday],
3876 monname[tmbuf->tm_mon],
3877 tmbuf->tm_mday,
3878 tmbuf->tm_hour,
3879 tmbuf->tm_min,
3880 tmbuf->tm_sec,
3881 tmbuf->tm_year + 1900);
3882 PUSHs(sv_2mortal(tsv));
a0d0e21e
LW		 3883 }
3884 else if (tmbuf) {
3885 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_sec)));
3886 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_min)));
3887 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_hour)));
3888 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_mday)));
3889 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_mon)));
3890 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_year)));
3891 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_wday)));
3892 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_yday)));
3893 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_isdst)));
3894 }
3895 RETURN;
3896}
3897
3898PP(pp_alarm)
3899{
4e35701f 3900 djSP; dTARGET;
a0d0e21e
LW		 3901 int anum;
3902#ifdef HAS_ALARM
3903 anum = POPi;
3904 anum = alarm((unsigned int)anum);
3905 EXTEND(SP, 1);
3906 if (anum < 0)
3907 RETPUSHUNDEF;
3908 PUSHi((I32)anum);
3909 RETURN;
3910#else
cea2e8a9 3911 DIE(aTHX_ PL_no_func, "Unsupported function alarm");
a0d0e21e
LW		 3912#endif
3913}
3914
3915PP(pp_sleep)
3916{
4e35701f 3917 djSP; dTARGET;
a0d0e21e
LW		 3918 I32 duration;
3919 Time_t lasttime;
3920 Time_t when;
3921
3922 (void)time(&lasttime);
3923 if (MAXARG < 1)
76e3520e 3924 PerlProc_pause();
a0d0e21e
LW		 3925 else {
3926 duration = POPi;
76e3520e 3927 PerlProc_sleep((unsigned int)duration);
a0d0e21e
LW		 3928 }
3929 (void)time(&when);
3930 XPUSHi(when - lasttime);
3931 RETURN;
3932}
3933
3934/* Shared memory. */
3935
3936PP(pp_shmget)
3937{
cea2e8a9 3938 return pp_semget();
a0d0e21e
LW		 3939}
3940
3941PP(pp_shmctl)
3942{
cea2e8a9 3943 return pp_semctl();
a0d0e21e
LW		 3944}
3945
3946PP(pp_shmread)
3947{
cea2e8a9 3948 return pp_shmwrite();
a0d0e21e
LW		 3949}
3950
3951PP(pp_shmwrite)
3952{
3953#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 3954 djSP; dMARK; dTARGET;
533c011a 3955 I32 value = (I32)(do_shmio(PL_op->op_type, MARK, SP) >= 0);
a0d0e21e
LW		 3956 SP = MARK;
3957 PUSHi(value);
3958 RETURN;
3959#else
cea2e8a9 3960 return pp_semget();
a0d0e21e
LW		 3961#endif
3962}
3963
3964/* Message passing. */
3965
3966PP(pp_msgget)
3967{
cea2e8a9 3968 return pp_semget();
a0d0e21e
LW		 3969}
3970
3971PP(pp_msgctl)
3972{
cea2e8a9 3973 return pp_semctl();
a0d0e21e
LW		 3974}
3975
3976PP(pp_msgsnd)
3977{
3978#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 3979 djSP; dMARK; dTARGET;
a0d0e21e
LW		 3980 I32 value = (I32)(do_msgsnd(MARK, SP) >= 0);
3981 SP = MARK;
3982 PUSHi(value);
3983 RETURN;
3984#else
cea2e8a9 3985 return pp_semget();
a0d0e21e
LW		 3986#endif
3987}
3988
3989PP(pp_msgrcv)
3990{
3991#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 3992 djSP; dMARK; dTARGET;
a0d0e21e
LW		 3993 I32 value = (I32)(do_msgrcv(MARK, SP) >= 0);
3994 SP = MARK;
3995 PUSHi(value);
3996 RETURN;
3997#else
cea2e8a9 3998 return pp_semget();
a0d0e21e
LW		 3999#endif
4000}
4001
4002/* Semaphores. */
4003
4004PP(pp_semget)
4005{
4006#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 4007 djSP; dMARK; dTARGET;
533c011a 4008 int anum = do_ipcget(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 4009 SP = MARK;
4010 if (anum == -1)
4011 RETPUSHUNDEF;
4012 PUSHi(anum);
4013 RETURN;
4014#else
cea2e8a9 4015 DIE(aTHX_ "System V IPC is not implemented on this machine");
a0d0e21e
LW		 4016#endif
4017}
4018
4019PP(pp_semctl)
4020{
4021#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 4022 djSP; dMARK; dTARGET;
533c011a 4023 int anum = do_ipcctl(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 4024 SP = MARK;
4025 if (anum == -1)
4026 RETSETUNDEF;
4027 if (anum != 0) {
4028 PUSHi(anum);
4029 }
4030 else {
8903cb82 4031 PUSHp(zero_but_true, ZBTLEN);
a0d0e21e
LW		 4032 }
4033 RETURN;
4034#else
cea2e8a9 4035 return pp_semget();
a0d0e21e
LW		 4036#endif
4037}
4038
4039PP(pp_semop)
4040{
4041#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 4042 djSP; dMARK; dTARGET;
a0d0e21e
LW		 4043 I32 value = (I32)(do_semop(MARK, SP) >= 0);
4044 SP = MARK;
4045 PUSHi(value);
4046 RETURN;
4047#else
cea2e8a9 4048 return pp_semget();
a0d0e21e
LW		 4049#endif
4050}
4051
4052/* Get system info. */
4053
4054PP(pp_ghbyname)
4055{
693762b4 4056#ifdef HAS_GETHOSTBYNAME
cea2e8a9 4057 return pp_ghostent();
a0d0e21e 4058#else
cea2e8a9 4059 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
a0d0e21e
LW		 4060#endif
4061}
4062
4063PP(pp_ghbyaddr)
4064{
693762b4 4065#ifdef HAS_GETHOSTBYADDR
cea2e8a9 4066 return pp_ghostent();
a0d0e21e 4067#else
cea2e8a9 4068 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
a0d0e21e
LW		 4069#endif
4070}
4071
4072PP(pp_ghostent)
4073{
4e35701f 4074 djSP;
693762b4 4075#if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
533c011a 4076 I32 which = PL_op->op_type;
a0d0e21e
LW		 4077 register char **elem;
4078 register SV *sv;
dc45a647 4079#ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4599a1de
JH		 4080 struct hostent *PerlSock_gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4081 struct hostent *PerlSock_gethostbyname(Netdb_name_t);
6ad3d225 4082 struct hostent *PerlSock_gethostent(void);
a0d0e21e
LW		 4083#endif
4084 struct hostent *hent;
4085 unsigned long len;
2d8e6c8d 4086 STRLEN n_a;
a0d0e21e
LW		 4087
4088 EXTEND(SP, 10);
dc45a647
MB		 4089 if (which == OP_GHBYNAME)
4090#ifdef HAS_GETHOSTBYNAME
2d8e6c8d 4091 hent = PerlSock_gethostbyname(POPpx);
dc45a647 4092#else
cea2e8a9 4093 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
dc45a647 4094#endif
a0d0e21e 4095 else if (which == OP_GHBYADDR) {
dc45a647 4096#ifdef HAS_GETHOSTBYADDR
a0d0e21e 4097 int addrtype = POPi;
748a9306 4098 SV *addrsv = POPs;
a0d0e21e 4099 STRLEN addrlen;
4599a1de 4100 Netdb_host_t addr = (Netdb_host_t) SvPV(addrsv, addrlen);
a0d0e21e 4101
4599a1de 4102 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
dc45a647 4103#else
cea2e8a9 4104 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
dc45a647 4105#endif
a0d0e21e
LW		 4106 }
4107 else
4108#ifdef HAS_GETHOSTENT
6ad3d225 4109 hent = PerlSock_gethostent();
a0d0e21e 4110#else
cea2e8a9 4111 DIE(aTHX_ PL_no_sock_func, "gethostent");
a0d0e21e
LW		 4112#endif
4113
4114#ifdef HOST_NOT_FOUND
4115 if (!hent)
f86702cc 4116 STATUS_NATIVE_SET(h_errno);
a0d0e21e
LW		 4117#endif
4118
4119 if (GIMME != G_ARRAY) {
4120 PUSHs(sv = sv_newmortal());
4121 if (hent) {
4122 if (which == OP_GHBYNAME) {
fd0af264 4123 if (hent->h_addr)
4124 sv_setpvn(sv, hent->h_addr, hent->h_length);
a0d0e21e
LW		 4125 }
4126 else
4127 sv_setpv(sv, (char*)hent->h_name);
4128 }
4129 RETURN;
4130 }
4131
4132 if (hent) {
3280af22 4133 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4134 sv_setpv(sv, (char*)hent->h_name);
3280af22 4135 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 4136 for (elem = hent->h_aliases; elem && *elem; elem++) {
4137 sv_catpv(sv, *elem);
4138 if (elem[1])
4139 sv_catpvn(sv, " ", 1);
4140 }
3280af22 4141 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4142 sv_setiv(sv, (IV)hent->h_addrtype);
3280af22 4143 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4144 len = hent->h_length;
1e422769 4145 sv_setiv(sv, (IV)len);
a0d0e21e
LW		 4146#ifdef h_addr
4147 for (elem = hent->h_addr_list; elem && *elem; elem++) {
3280af22 4148 XPUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 4149 sv_setpvn(sv, *elem, len);
4150 }
4151#else
6b88bc9c 4152 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
fd0af264 4153 if (hent->h_addr)
4154 sv_setpvn(sv, hent->h_addr, len);
a0d0e21e
LW		 4155#endif /* h_addr */
4156 }
4157 RETURN;
4158#else
cea2e8a9 4159 DIE(aTHX_ PL_no_sock_func, "gethostent");
a0d0e21e
LW		 4160#endif
4161}
4162
4163PP(pp_gnbyname)
4164{
693762b4 4165#ifdef HAS_GETNETBYNAME
cea2e8a9 4166 return pp_gnetent();
a0d0e21e 4167#else
cea2e8a9 4168 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
a0d0e21e
LW		 4169#endif
4170}
4171
4172PP(pp_gnbyaddr)
4173{
693762b4 4174#ifdef HAS_GETNETBYADDR
cea2e8a9 4175 return pp_gnetent();
a0d0e21e 4176#else
cea2e8a9 4177 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
a0d0e21e
LW		 4178#endif
4179}
4180
4181PP(pp_gnetent)
4182{
4e35701f 4183 djSP;
693762b4 4184#if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
533c011a 4185 I32 which = PL_op->op_type;
a0d0e21e
LW		 4186 register char **elem;
4187 register SV *sv;
dc45a647
MB		 4188#ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4189 struct netent *PerlSock_getnetbyaddr(Netdb_net_t, int);
4190 struct netent *PerlSock_getnetbyname(Netdb_name_t);
4191 struct netent *PerlSock_getnetent(void);
8ac85365 4192#endif
a0d0e21e 4193 struct netent *nent;
2d8e6c8d 4194 STRLEN n_a;
a0d0e21e
LW		 4195
4196 if (which == OP_GNBYNAME)
dc45a647 4197#ifdef HAS_GETNETBYNAME
2d8e6c8d 4198 nent = PerlSock_getnetbyname(POPpx);
dc45a647 4199#else
cea2e8a9 4200 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
dc45a647 4201#endif
a0d0e21e 4202 else if (which == OP_GNBYADDR) {
dc45a647 4203#ifdef HAS_GETNETBYADDR
a0d0e21e 4204 int addrtype = POPi;
4599a1de 4205 Netdb_net_t addr = (Netdb_net_t) U_L(POPn);
76e3520e 4206 nent = PerlSock_getnetbyaddr(addr, addrtype);
dc45a647 4207#else
cea2e8a9 4208 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
dc45a647 4209#endif
a0d0e21e
LW		 4210 }
4211 else
dc45a647 4212#ifdef HAS_GETNETENT
76e3520e 4213 nent = PerlSock_getnetent();
dc45a647 4214#else
cea2e8a9 4215 DIE(aTHX_ PL_no_sock_func, "getnetent");
dc45a647 4216#endif
a0d0e21e
LW		 4217
4218 EXTEND(SP, 4);
4219 if (GIMME != G_ARRAY) {
4220 PUSHs(sv = sv_newmortal());
4221 if (nent) {
4222 if (which == OP_GNBYNAME)
1e422769 4223 sv_setiv(sv, (IV)nent->n_net);
a0d0e21e
LW		 4224 else
4225 sv_setpv(sv, nent->n_name);
4226 }
4227 RETURN;
4228 }
4229
4230 if (nent) {
3280af22 4231 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4232 sv_setpv(sv, nent->n_name);
3280af22 4233 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 4234 for (elem = nent->n_aliases; elem && *elem; elem++) {
a0d0e21e
LW		 4235 sv_catpv(sv, *elem);
4236 if (elem[1])
4237 sv_catpvn(sv, " ", 1);
4238 }
3280af22 4239 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4240 sv_setiv(sv, (IV)nent->n_addrtype);
3280af22 4241 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4242 sv_setiv(sv, (IV)nent->n_net);
a0d0e21e
LW		 4243 }
4244
4245 RETURN;
4246#else
cea2e8a9 4247 DIE(aTHX_ PL_no_sock_func, "getnetent");
a0d0e21e
LW		 4248#endif
4249}
4250
4251PP(pp_gpbyname)
4252{
693762b4 4253#ifdef HAS_GETPROTOBYNAME
cea2e8a9 4254 return pp_gprotoent();
a0d0e21e 4255#else
cea2e8a9 4256 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
a0d0e21e
LW		 4257#endif
4258}
4259
4260PP(pp_gpbynumber)
4261{
693762b4 4262#ifdef HAS_GETPROTOBYNUMBER
cea2e8a9 4263 return pp_gprotoent();
a0d0e21e 4264#else
cea2e8a9 4265 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
a0d0e21e
LW		 4266#endif
4267}
4268
4269PP(pp_gprotoent)
4270{
4e35701f 4271 djSP;
693762b4 4272#if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
533c011a 4273 I32 which = PL_op->op_type;
a0d0e21e 4274 register char **elem;
8ac85365 4275 register SV *sv;
dc45a647 4276#ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4599a1de 4277 struct protoent *PerlSock_getprotobyname(Netdb_name_t);
6ad3d225
GS		 4278 struct protoent *PerlSock_getprotobynumber(int);
4279 struct protoent *PerlSock_getprotoent(void);
8ac85365 4280#endif
a0d0e21e 4281 struct protoent *pent;
2d8e6c8d 4282 STRLEN n_a;
a0d0e21e
LW		 4283
4284 if (which == OP_GPBYNAME)
e5c9fcd0 4285#ifdef HAS_GETPROTOBYNAME
2d8e6c8d 4286 pent = PerlSock_getprotobyname(POPpx);
e5c9fcd0 4287#else
cea2e8a9 4288 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
e5c9fcd0 4289#endif
a0d0e21e 4290 else if (which == OP_GPBYNUMBER)
e5c9fcd0 4291#ifdef HAS_GETPROTOBYNUMBER
6ad3d225 4292 pent = PerlSock_getprotobynumber(POPi);
e5c9fcd0 4293#else
cea2e8a9 4294 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
e5c9fcd0 4295#endif
a0d0e21e 4296 else
e5c9fcd0 4297#ifdef HAS_GETPROTOENT
6ad3d225 4298 pent = PerlSock_getprotoent();
e5c9fcd0 4299#else
cea2e8a9 4300 DIE(aTHX_ PL_no_sock_func, "getprotoent");
e5c9fcd0 4301#endif
a0d0e21e
LW		 4302
4303 EXTEND(SP, 3);
4304 if (GIMME != G_ARRAY) {
4305 PUSHs(sv = sv_newmortal());
4306 if (pent) {
4307 if (which == OP_GPBYNAME)
1e422769 4308 sv_setiv(sv, (IV)pent->p_proto);
a0d0e21e
LW		 4309 else
4310 sv_setpv(sv, pent->p_name);
4311 }
4312 RETURN;
4313 }
4314
4315 if (pent) {
3280af22 4316 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4317 sv_setpv(sv, pent->p_name);
3280af22 4318 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 4319 for (elem = pent->p_aliases; elem && *elem; elem++) {
a0d0e21e
LW		 4320 sv_catpv(sv, *elem);
4321 if (elem[1])
4322 sv_catpvn(sv, " ", 1);
4323 }
3280af22 4324 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4325 sv_setiv(sv, (IV)pent->p_proto);
a0d0e21e
LW		 4326 }
4327
4328 RETURN;
4329#else
cea2e8a9 4330 DIE(aTHX_ PL_no_sock_func, "getprotoent");
a0d0e21e
LW		 4331#endif
4332}
4333
4334PP(pp_gsbyname)
4335{
9ec75305 4336#ifdef HAS_GETSERVBYNAME
cea2e8a9 4337 return pp_gservent();
a0d0e21e 4338#else
cea2e8a9 4339 DIE(aTHX_ PL_no_sock_func, "getservbyname");
a0d0e21e
LW		 4340#endif
4341}
4342
4343PP(pp_gsbyport)
4344{
9ec75305 4345#ifdef HAS_GETSERVBYPORT
cea2e8a9 4346 return pp_gservent();
a0d0e21e 4347#else
cea2e8a9 4348 DIE(aTHX_ PL_no_sock_func, "getservbyport");
a0d0e21e
LW		 4349#endif
4350}
4351
4352PP(pp_gservent)
4353{
4e35701f 4354 djSP;
693762b4 4355#if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
533c011a 4356 I32 which = PL_op->op_type;
a0d0e21e
LW		 4357 register char **elem;
4358 register SV *sv;
dc45a647 4359#ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4599a1de
JH		 4360 struct servent *PerlSock_getservbyname(Netdb_name_t, Netdb_name_t);
4361 struct servent *PerlSock_getservbyport(int, Netdb_name_t);
6ad3d225 4362 struct servent *PerlSock_getservent(void);
8ac85365 4363#endif
a0d0e21e 4364 struct servent *sent;
2d8e6c8d 4365 STRLEN n_a;
a0d0e21e
LW		 4366
4367 if (which == OP_GSBYNAME) {
dc45a647 4368#ifdef HAS_GETSERVBYNAME
2d8e6c8d
GS		 4369 char *proto = POPpx;
4370 char *name = POPpx;
a0d0e21e
LW		 4371
4372 if (proto && !*proto)
4373 proto = Nullch;
4374
6ad3d225 4375 sent = PerlSock_getservbyname(name, proto);
dc45a647 4376#else
cea2e8a9 4377 DIE(aTHX_ PL_no_sock_func, "getservbyname");
dc45a647 4378#endif
a0d0e21e
LW		 4379 }
4380 else if (which == OP_GSBYPORT) {
dc45a647 4381#ifdef HAS_GETSERVBYPORT
2d8e6c8d 4382 char *proto = POPpx;
36477c24 4383 unsigned short port = POPu;
a0d0e21e 4384
36477c24 4385#ifdef HAS_HTONS
6ad3d225 4386 port = PerlSock_htons(port);
36477c24 4387#endif
6ad3d225 4388 sent = PerlSock_getservbyport(port, proto);
dc45a647 4389#else
cea2e8a9 4390 DIE(aTHX_ PL_no_sock_func, "getservbyport");
dc45a647 4391#endif
a0d0e21e
LW		 4392 }
4393 else
e5c9fcd0 4394#ifdef HAS_GETSERVENT
6ad3d225 4395 sent = PerlSock_getservent();
e5c9fcd0 4396#else
cea2e8a9 4397 DIE(aTHX_ PL_no_sock_func, "getservent");
e5c9fcd0 4398#endif
a0d0e21e
LW		 4399
4400 EXTEND(SP, 4);
4401 if (GIMME != G_ARRAY) {
4402 PUSHs(sv = sv_newmortal());
4403 if (sent) {
4404 if (which == OP_GSBYNAME) {
4405#ifdef HAS_NTOHS
6ad3d225 4406 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
a0d0e21e 4407#else
1e422769 4408 sv_setiv(sv, (IV)(sent->s_port));
a0d0e21e
LW		 4409#endif
4410 }
4411 else
4412 sv_setpv(sv, sent->s_name);
4413 }
4414 RETURN;
4415 }
4416
4417 if (sent) {
3280af22 4418 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4419 sv_setpv(sv, sent->s_name);
3280af22 4420 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 4421 for (elem = sent->s_aliases; elem && *elem; elem++) {
a0d0e21e
LW		 4422 sv_catpv(sv, *elem);
4423 if (elem[1])
4424 sv_catpvn(sv, " ", 1);
4425 }
3280af22 4426 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4427#ifdef HAS_NTOHS
76e3520e 4428 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
a0d0e21e 4429#else
1e422769 4430 sv_setiv(sv, (IV)(sent->s_port));
a0d0e21e 4431#endif
3280af22 4432 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 4433 sv_setpv(sv, sent->s_proto);
4434 }
4435
4436 RETURN;
4437#else
cea2e8a9 4438 DIE(aTHX_ PL_no_sock_func, "getservent");
a0d0e21e
LW		 4439#endif
4440}
4441
4442PP(pp_shostent)
4443{
4e35701f 4444 djSP;
693762b4 4445#ifdef HAS_SETHOSTENT
76e3520e 4446 PerlSock_sethostent(TOPi);
a0d0e21e
LW		 4447 RETSETYES;
4448#else
cea2e8a9 4449 DIE(aTHX_ PL_no_sock_func, "sethostent");
a0d0e21e
LW		 4450#endif
4451}
4452
4453PP(pp_snetent)
4454{
4e35701f 4455 djSP;
693762b4 4456#ifdef HAS_SETNETENT
76e3520e 4457 PerlSock_setnetent(TOPi);
a0d0e21e
LW		 4458 RETSETYES;
4459#else
cea2e8a9 4460 DIE(aTHX_ PL_no_sock_func, "setnetent");
a0d0e21e
LW		 4461#endif
4462}
4463
4464PP(pp_sprotoent)
4465{
4e35701f 4466 djSP;
693762b4 4467#ifdef HAS_SETPROTOENT
76e3520e 4468 PerlSock_setprotoent(TOPi);
a0d0e21e
LW		 4469 RETSETYES;
4470#else
cea2e8a9 4471 DIE(aTHX_ PL_no_sock_func, "setprotoent");
a0d0e21e
LW		 4472#endif
4473}
4474
4475PP(pp_sservent)
4476{
4e35701f 4477 djSP;
693762b4 4478#ifdef HAS_SETSERVENT
76e3520e 4479 PerlSock_setservent(TOPi);
a0d0e21e
LW		 4480 RETSETYES;
4481#else
cea2e8a9 4482 DIE(aTHX_ PL_no_sock_func, "setservent");
a0d0e21e
LW		 4483#endif
4484}
4485
4486PP(pp_ehostent)
4487{
4e35701f 4488 djSP;
693762b4 4489#ifdef HAS_ENDHOSTENT
76e3520e 4490 PerlSock_endhostent();
924508f0 4491 EXTEND(SP,1);
a0d0e21e
LW		 4492 RETPUSHYES;
4493#else
cea2e8a9 4494 DIE(aTHX_ PL_no_sock_func, "endhostent");
a0d0e21e
LW		 4495#endif
4496}
4497
4498PP(pp_enetent)
4499{
4e35701f 4500 djSP;
693762b4 4501#ifdef HAS_ENDNETENT
76e3520e 4502 PerlSock_endnetent();
924508f0 4503 EXTEND(SP,1);
a0d0e21e
LW		 4504 RETPUSHYES;
4505#else
cea2e8a9 4506 DIE(aTHX_ PL_no_sock_func, "endnetent");
a0d0e21e
LW		 4507#endif
4508}
4509
4510PP(pp_eprotoent)
4511{
4e35701f 4512 djSP;
693762b4 4513#ifdef HAS_ENDPROTOENT
76e3520e 4514 PerlSock_endprotoent();
924508f0 4515 EXTEND(SP,1);
a0d0e21e
LW		 4516 RETPUSHYES;
4517#else
cea2e8a9 4518 DIE(aTHX_ PL_no_sock_func, "endprotoent");
a0d0e21e
LW		 4519#endif
4520}
4521
4522PP(pp_eservent)
4523{
4e35701f 4524 djSP;
693762b4 4525#ifdef HAS_ENDSERVENT
76e3520e 4526 PerlSock_endservent();
924508f0 4527 EXTEND(SP,1);
a0d0e21e
LW		 4528 RETPUSHYES;
4529#else
cea2e8a9 4530 DIE(aTHX_ PL_no_sock_func, "endservent");
a0d0e21e
LW		 4531#endif
4532}
4533
4534PP(pp_gpwnam)
4535{
4536#ifdef HAS_PASSWD
cea2e8a9 4537 return pp_gpwent();
a0d0e21e 4538#else
cea2e8a9 4539 DIE(aTHX_ PL_no_func, "getpwnam");
a0d0e21e
LW		 4540#endif
4541}
4542
4543PP(pp_gpwuid)
4544{
4545#ifdef HAS_PASSWD
cea2e8a9 4546 return pp_gpwent();
a0d0e21e 4547#else
cea2e8a9 4548 DIE(aTHX_ PL_no_func, "getpwuid");
a0d0e21e
LW		 4549#endif
4550}
4551
4552PP(pp_gpwent)
4553{
4e35701f 4554 djSP;
28e8609d 4555#if defined(HAS_PASSWD) && defined(HAS_GETPWENT)
533c011a 4556 I32 which = PL_op->op_type;
a0d0e21e
LW		 4557 register SV *sv;
4558 struct passwd *pwent;
2d8e6c8d 4559 STRLEN n_a;
8c0bfa08 4560#ifdef HAS_GETSPENT
eff96b52 4561 struct spwd *spwent = NULL;
8c0bfa08 4562#endif
a0d0e21e
LW		 4563
4564 if (which == OP_GPWNAM)
2d8e6c8d 4565 pwent = getpwnam(POPpx);
a0d0e21e
LW		 4566 else if (which == OP_GPWUID)
4567 pwent = getpwuid(POPi);
4568 else
4569 pwent = (struct passwd *)getpwent();
4570
f1066039 4571#ifdef HAS_GETSPNAM
eff96b52
GS		 4572 if (which == OP_GPWNAM) {
4573 if (pwent)
4574 spwent = getspnam(pwent->pw_name);
4575 }
f1066039 4576# ifdef HAS_GETSPUID /* AFAIK there isn't any anywhere. --jhi */
eff96b52
GS		 4577 else if (which == OP_GPWUID) {
4578 if (pwent)
4579 spwent = getspnam(pwent->pw_name);
4580 }
f1066039 4581# endif
eff96b52
GS		 4582 else
4583 spwent = (struct spwd *)getspent();
8c0bfa08
PB		 4584#endif
4585
a0d0e21e
LW		 4586 EXTEND(SP, 10);
4587 if (GIMME != G_ARRAY) {
4588 PUSHs(sv = sv_newmortal());
4589 if (pwent) {
4590 if (which == OP_GPWNAM)
1e422769 4591 sv_setiv(sv, (IV)pwent->pw_uid);
a0d0e21e
LW		 4592 else
4593 sv_setpv(sv, pwent->pw_name);
4594 }
4595 RETURN;
4596 }
4597
4598 if (pwent) {
3280af22 4599 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4600 sv_setpv(sv, pwent->pw_name);
6ee623d5 4601
3280af22 4602 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
28e8609d 4603#ifdef PWPASSWD
f1066039 4604# ifdef HAS_GETSPENT
8c0bfa08
PB		 4605 if (spwent)
4606 sv_setpv(sv, spwent->sp_pwdp);
4607 else
4608 sv_setpv(sv, pwent->pw_passwd);
f1066039 4609# else
a0d0e21e 4610 sv_setpv(sv, pwent->pw_passwd);
f1066039 4611# endif
8c0bfa08 4612#endif
6ee623d5 4613
3280af22 4614 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4615 sv_setiv(sv, (IV)pwent->pw_uid);
6ee623d5 4616
3280af22 4617 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4618 sv_setiv(sv, (IV)pwent->pw_gid);
6ee623d5
GS		 4619
4620 /* pw_change, pw_quota, and pw_age are mutually exclusive. */
3280af22 4621 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4622#ifdef PWCHANGE
1e422769 4623 sv_setiv(sv, (IV)pwent->pw_change);
a0d0e21e 4624#else
6ee623d5 4625# ifdef PWQUOTA
1e422769 4626 sv_setiv(sv, (IV)pwent->pw_quota);
6ee623d5
GS		 4627# else
4628# ifdef PWAGE
a0d0e21e 4629 sv_setpv(sv, pwent->pw_age);
6ee623d5
GS		 4630# endif
4631# endif
a0d0e21e 4632#endif
6ee623d5
GS		 4633
4634 /* pw_class and pw_comment are mutually exclusive. */
3280af22 4635 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 4636#ifdef PWCLASS
4637 sv_setpv(sv, pwent->pw_class);
4638#else
6ee623d5 4639# ifdef PWCOMMENT
a0d0e21e 4640 sv_setpv(sv, pwent->pw_comment);
6ee623d5 4641# endif
a0d0e21e 4642#endif
6ee623d5 4643
3280af22 4644 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
6ee623d5 4645#ifdef PWGECOS
a0d0e21e 4646 sv_setpv(sv, pwent->pw_gecos);
6ee623d5 4647#endif
fb73857a 4648#ifndef INCOMPLETE_TAINTS
d2719217 4649 /* pw_gecos is tainted because user himself can diddle with it. */
fb73857a 4650 SvTAINTED_on(sv);
4651#endif
6ee623d5 4652
3280af22 4653 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4654 sv_setpv(sv, pwent->pw_dir);
6ee623d5 4655
3280af22 4656 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4657 sv_setpv(sv, pwent->pw_shell);
6ee623d5 4658
a0d0e21e 4659#ifdef PWEXPIRE
6b88bc9c 4660 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4661 sv_setiv(sv, (IV)pwent->pw_expire);
a0d0e21e
LW		 4662#endif
4663 }
4664 RETURN;
4665#else
cea2e8a9 4666 DIE(aTHX_ PL_no_func, "getpwent");
a0d0e21e
LW		 4667#endif
4668}
4669
4670PP(pp_spwent)
4671{
4e35701f 4672 djSP;
28e8609d 4673#if defined(HAS_PASSWD) && defined(HAS_SETPWENT) && !defined(CYGWIN32)
a0d0e21e 4674 setpwent();
f1066039 4675# ifdef HAS_SETSPENT
8c0bfa08 4676 setspent();
f1066039 4677# endif
a0d0e21e
LW		 4678 RETPUSHYES;
4679#else
cea2e8a9 4680 DIE(aTHX_ PL_no_func, "setpwent");
a0d0e21e
LW		 4681#endif
4682}
4683
4684PP(pp_epwent)
4685{
4e35701f 4686 djSP;
28e8609d 4687#if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
a0d0e21e 4688 endpwent();
f1066039 4689# ifdef HAS_ENDSPENT
8c0bfa08 4690 endspent();
f1066039 4691# endif
a0d0e21e
LW		 4692 RETPUSHYES;
4693#else
cea2e8a9 4694 DIE(aTHX_ PL_no_func, "endpwent");
a0d0e21e
LW		 4695#endif
4696}
4697
4698PP(pp_ggrnam)
4699{
4700#ifdef HAS_GROUP
cea2e8a9 4701 return pp_ggrent();
a0d0e21e 4702#else
cea2e8a9 4703 DIE(aTHX_ PL_no_func, "getgrnam");
a0d0e21e
LW		 4704#endif
4705}
4706
4707PP(pp_ggrgid)
4708{
4709#ifdef HAS_GROUP
cea2e8a9 4710 return pp_ggrent();
a0d0e21e 4711#else
cea2e8a9 4712 DIE(aTHX_ PL_no_func, "getgrgid");
a0d0e21e
LW		 4713#endif
4714}
4715
4716PP(pp_ggrent)
4717{
4e35701f 4718 djSP;
28e8609d 4719#if defined(HAS_GROUP) && defined(HAS_GETGRENT)
533c011a 4720 I32 which = PL_op->op_type;
a0d0e21e
LW		 4721 register char **elem;
4722 register SV *sv;
4723 struct group *grent;
2d8e6c8d 4724 STRLEN n_a;
a0d0e21e
LW		 4725
4726 if (which == OP_GGRNAM)
2d8e6c8d 4727 grent = (struct group *)getgrnam(POPpx);
a0d0e21e
LW		 4728 else if (which == OP_GGRGID)
4729 grent = (struct group *)getgrgid(POPi);
4730 else
4731 grent = (struct group *)getgrent();
4732
4733 EXTEND(SP, 4);
4734 if (GIMME != G_ARRAY) {
4735 PUSHs(sv = sv_newmortal());
4736 if (grent) {
4737 if (which == OP_GGRNAM)
1e422769 4738 sv_setiv(sv, (IV)grent->gr_gid);
a0d0e21e
LW		 4739 else
4740 sv_setpv(sv, grent->gr_name);
4741 }
4742 RETURN;
4743 }
4744
4745 if (grent) {
3280af22 4746 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4747 sv_setpv(sv, grent->gr_name);
28e8609d 4748
3280af22 4749 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
28e8609d 4750#ifdef GRPASSWD
a0d0e21e 4751 sv_setpv(sv, grent->gr_passwd);
28e8609d
JH		 4752#endif
4753
3280af22 4754 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4755 sv_setiv(sv, (IV)grent->gr_gid);
28e8609d 4756
3280af22 4757 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 4758 for (elem = grent->gr_mem; elem && *elem; elem++) {
a0d0e21e
LW		 4759 sv_catpv(sv, *elem);
4760 if (elem[1])
4761 sv_catpvn(sv, " ", 1);
4762 }
4763 }
4764
4765 RETURN;
4766#else
cea2e8a9 4767 DIE(aTHX_ PL_no_func, "getgrent");
a0d0e21e
LW		 4768#endif
4769}
4770
4771PP(pp_sgrent)
4772{
4e35701f 4773 djSP;
28e8609d 4774#if defined(HAS_GROUP) && defined(HAS_SETGRENT)
a0d0e21e
LW		 4775 setgrent();
4776 RETPUSHYES;
4777#else
cea2e8a9 4778 DIE(aTHX_ PL_no_func, "setgrent");
a0d0e21e
LW		 4779#endif
4780}
4781
4782PP(pp_egrent)
4783{
4e35701f 4784 djSP;
28e8609d 4785#if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
a0d0e21e
LW		 4786 endgrent();
4787 RETPUSHYES;
4788#else
cea2e8a9 4789 DIE(aTHX_ PL_no_func, "endgrent");
a0d0e21e
LW		 4790#endif
4791}
4792
4793PP(pp_getlogin)
4794{
4e35701f 4795 djSP; dTARGET;
a0d0e21e
LW		 4796#ifdef HAS_GETLOGIN
4797 char *tmps;
4798 EXTEND(SP, 1);
76e3520e 4799 if (!(tmps = PerlProc_getlogin()))
a0d0e21e
LW		 4800 RETPUSHUNDEF;
4801 PUSHp(tmps, strlen(tmps));
4802 RETURN;
4803#else
cea2e8a9 4804 DIE(aTHX_ PL_no_func, "getlogin");
a0d0e21e
LW		 4805#endif
4806}
4807
4808/* Miscellaneous. */
4809
4810PP(pp_syscall)
4811{
d2719217 4812#ifdef HAS_SYSCALL
4e35701f 4813 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 4814 register I32 items = SP - MARK;
4815 unsigned long a[20];
4816 register I32 i = 0;
4817 I32 retval = -1;
748a9306 4818 MAGIC *mg;
2d8e6c8d 4819 STRLEN n_a;
a0d0e21e 4820
3280af22 4821 if (PL_tainting) {
a0d0e21e 4822 while (++MARK <= SP) {
bbce6d69 4823 if (SvTAINTED(*MARK)) {
4824 TAINT;
4825 break;
4826 }
a0d0e21e
LW		 4827 }
4828 MARK = ORIGMARK;
4829 TAINT_PROPER("syscall");
4830 }
4831
4832 /* This probably won't work on machines where sizeof(long) != sizeof(int)
4833 * or where sizeof(long) != sizeof(char*). But such machines will
4834 * not likely have syscall implemented either, so who cares?
4835 */
4836 while (++MARK <= SP) {
4837 if (SvNIOK(*MARK) || !i)
4838 a[i++] = SvIV(*MARK);
3280af22 4839 else if (*MARK == &PL_sv_undef)
748a9306
LW		 4840 a[i++] = 0;
4841 else
2d8e6c8d 4842 a[i++] = (unsigned long)SvPV_force(*MARK, n_a);
a0d0e21e
LW		 4843 if (i > 15)
4844 break;
4845 }
4846 switch (items) {
4847 default:
cea2e8a9 4848 DIE(aTHX_ "Too many args to syscall");
a0d0e21e 4849 case 0:
cea2e8a9 4850 DIE(aTHX_ "Too few args to syscall");
a0d0e21e
LW		 4851 case 1:
4852 retval = syscall(a[0]);
4853 break;
4854 case 2:
4855 retval = syscall(a[0],a[1]);
4856 break;
4857 case 3:
4858 retval = syscall(a[0],a[1],a[2]);
4859 break;
4860 case 4:
4861 retval = syscall(a[0],a[1],a[2],a[3]);
4862 break;
4863 case 5:
4864 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
4865 break;
4866 case 6:
4867 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
4868 break;
4869 case 7:
4870 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
4871 break;
4872 case 8:
4873 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
4874 break;
4875#ifdef atarist
4876 case 9:
4877 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
4878 break;
4879 case 10:
4880 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
4881 break;
4882 case 11:
4883 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
4884 a[10]);
4885 break;
4886 case 12:
4887 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
4888 a[10],a[11]);
4889 break;
4890 case 13:
4891 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
4892 a[10],a[11],a[12]);
4893 break;
4894 case 14:
4895 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
4896 a[10],a[11],a[12],a[13]);
4897 break;
4898#endif /* atarist */
4899 }
4900 SP = ORIGMARK;
4901 PUSHi(retval);
4902 RETURN;
4903#else
cea2e8a9 4904 DIE(aTHX_ PL_no_func, "syscall");
a0d0e21e
LW		 4905#endif
4906}
4907
ff68c719 4908#ifdef FCNTL_EMULATE_FLOCK
4909
4910/* XXX Emulate flock() with fcntl().
4911 What's really needed is a good file locking module.
4912*/
4913
cea2e8a9
GS		 4914static int
4915fcntl_emulate_flock(int fd, int operation)
ff68c719 4916{
4917 struct flock flock;
4918
4919 switch (operation & ~LOCK_NB) {
4920 case LOCK_SH:
4921 flock.l_type = F_RDLCK;
4922 break;
4923 case LOCK_EX:
4924 flock.l_type = F_WRLCK;
4925 break;
4926 case LOCK_UN:
4927 flock.l_type = F_UNLCK;
4928 break;
4929 default:
4930 errno = EINVAL;
4931 return -1;
4932 }
4933 flock.l_whence = SEEK_SET;
4934 flock.l_start = flock.l_len = 0L;
4935
4936 return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
4937}
4938
4939#endif /* FCNTL_EMULATE_FLOCK */
4940
4941#ifdef LOCKF_EMULATE_FLOCK
16d20bd9
AD		 4942
4943/* XXX Emulate flock() with lockf(). This is just to increase
4944 portability of scripts. The calls are not completely
4945 interchangeable. What's really needed is a good file
4946 locking module.
4947*/
4948
76c32331 4949/* The lockf() constants might have been defined in <unistd.h>.
4950 Unfortunately, <unistd.h> causes troubles on some mixed
4951 (BSD/POSIX) systems, such as SunOS 4.1.3.
16d20bd9
AD		 4952
4953 Further, the lockf() constants aren't POSIX, so they might not be
4954 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
4955 just stick in the SVID values and be done with it. Sigh.
4956*/
4957
4958# ifndef F_ULOCK
4959# define F_ULOCK 0 /* Unlock a previously locked region */
4960# endif
4961# ifndef F_LOCK
4962# define F_LOCK 1 /* Lock a region for exclusive use */
4963# endif
4964# ifndef F_TLOCK
4965# define F_TLOCK 2 /* Test and lock a region for exclusive use */
4966# endif
4967# ifndef F_TEST
4968# define F_TEST 3 /* Test a region for other processes locks */
4969# endif
4970
cea2e8a9
GS		 4971static int
4972lockf_emulate_flock(int fd, int operation)
16d20bd9
AD		 4973{
4974 int i;
84902520
TB		 4975 int save_errno;
4976 Off_t pos;
4977
4978 /* flock locks entire file so for lockf we need to do the same */
4979 save_errno = errno;
6ad3d225 4980 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
84902520 4981 if (pos > 0) /* is seekable and needs to be repositioned */
6ad3d225 4982 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
08b714dd 4983 pos = -1; /* seek failed, so don't seek back afterwards */
84902520
TB		 4984 errno = save_errno;
4985
16d20bd9
AD		 4986 switch (operation) {
4987
4988 /* LOCK_SH - get a shared lock */
4989 case LOCK_SH:
4990 /* LOCK_EX - get an exclusive lock */
4991 case LOCK_EX:
4992 i = lockf (fd, F_LOCK, 0);
4993 break;
4994
4995 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
4996 case LOCK_SH|LOCK_NB:
4997 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
4998 case LOCK_EX|LOCK_NB:
4999 i = lockf (fd, F_TLOCK, 0);
5000 if (i == -1)
5001 if ((errno == EAGAIN) || (errno == EACCES))
5002 errno = EWOULDBLOCK;
5003 break;
5004
ff68c719 5005 /* LOCK_UN - unlock (non-blocking is a no-op) */
16d20bd9 5006 case LOCK_UN:
ff68c719 5007 case LOCK_UN|LOCK_NB:
16d20bd9
AD		 5008 i = lockf (fd, F_ULOCK, 0);
5009 break;
5010
5011 /* Default - can't decipher operation */
5012 default:
5013 i = -1;
5014 errno = EINVAL;
5015 break;
5016 }
84902520
TB		 5017
5018 if (pos > 0) /* need to restore position of the handle */
6ad3d225 5019 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
84902520 5020
16d20bd9
AD		 5021 return (i);
5022}
ff68c719 5023
5024#endif /* LOCKF_EMULATE_FLOCK */
Unnamed repository; edit this file 'description' to name the repository.