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