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