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