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
Add POLLUTE=1 option to MakeMaker
[perl5.git] / pp_sys.c
CommitLineData
a0d0e21e
LW		 1/* pp_sys.c
2 *
4eb8286e 3 * Copyright (c) 1991-1999, Larry Wall
a0d0e21e
LW		 4 *
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
7 *
8 */
9
10/*
11 * But only a short way ahead its floor and the walls on either side were
12 * cloven by a great fissure, out of which the red glare came, now leaping
13 * up, now dying down into darkness; and all the while far below there was
14 * a rumour and a trouble as of great engines throbbing and labouring.
15 */
16
17#include "EXTERN.h"
18#include "perl.h"
19
76c32331 20/* XXX If this causes problems, set i_unistd=undef in the hint file. */
21#ifdef I_UNISTD
22# include <unistd.h>
23#endif
24
8ac85365
NIS		 25#ifdef HAS_SYSCALL
26#ifdef __cplusplus
27extern "C" int syscall(unsigned long,...);
28#endif
29#endif
30
76c32331 31#ifdef I_SYS_WAIT
32# include <sys/wait.h>
33#endif
34
35#ifdef I_SYS_RESOURCE
36# include <sys/resource.h>
16d20bd9 37#endif
a0d0e21e
LW		 38
39#if defined(HAS_SOCKET) && !defined(VMS) /* VMS handles sockets via vmsish.h */
40# include <sys/socket.h>
3fd537d4
JH		 41# ifdef I_NETDB
42# include <netdb.h>
43# endif
a0d0e21e
LW		 44# ifndef ENOTSOCK
45# ifdef I_NET_ERRNO
46# include <net/errno.h>
47# endif
48# endif
49#endif
50
51#ifdef HAS_SELECT
52#ifdef I_SYS_SELECT
a0d0e21e
LW		 53#include <sys/select.h>
54#endif
55#endif
a0d0e21e 56
dc45a647
MB		 57/* XXX Configure test needed.
58 h_errno might not be a simple 'int', especially for multi-threaded
5ff3f7a4
GS		 59 applications, see "extern int errno in perl.h". Creating such
60 a test requires taking into account the differences between
61 compiling multithreaded and singlethreaded ($ccflags et al).
62 HOST_NOT_FOUND is typically defined in <netdb.h>.
dc45a647
MB		 63*/
64#if defined(HOST_NOT_FOUND) && !defined(h_errno)
a0d0e21e
LW		 65extern int h_errno;
66#endif
67
68#ifdef HAS_PASSWD
69# ifdef I_PWD
70# include <pwd.h>
71# else
72 struct passwd *getpwnam _((char *));
73 struct passwd *getpwuid _((Uid_t));
74# endif
28e8609d 75# ifdef HAS_GETPWENT
a0d0e21e 76 struct passwd *getpwent _((void));
28e8609d 77# endif
a0d0e21e
LW		 78#endif
79
80#ifdef HAS_GROUP
81# ifdef I_GRP
82# include <grp.h>
83# else
84 struct group *getgrnam _((char *));
85 struct group *getgrgid _((Gid_t));
86# endif
28e8609d 87# ifdef HAS_GETGRENT
a0d0e21e 88 struct group *getgrent _((void));
28e8609d 89# endif
a0d0e21e
LW		 90#endif
91
92#ifdef I_UTIME
3730b96e 93# if defined(_MSC_VER) || defined(__MINGW32__)
3fe9a6f1 94# include <sys/utime.h>
95# else
96# include <utime.h>
97# endif
a0d0e21e
LW		 98#endif
99#ifdef I_FCNTL
100#include <fcntl.h>
101#endif
102#ifdef I_SYS_FILE
103#include <sys/file.h>
104#endif
105
54310121 106/* Put this after #includes because fork and vfork prototypes may conflict. */
107#ifndef HAS_VFORK
108# define vfork fork
109#endif
110
d574b85e
CS		 111/* Put this after #includes because <unistd.h> defines _XOPEN_*. */
112#ifndef Sock_size_t
137443ea 113# if _XOPEN_VERSION >= 5 || defined(_XOPEN_SOURCE_EXTENDED) || defined(__GLIBC__)
d574b85e
CS		 114# define Sock_size_t Size_t
115# else
116# define Sock_size_t int
117# endif
54310121 118#endif
119
a0d0e21e
LW		 120#if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
121static int dooneliner _((char *cmd, char *filename));
122#endif
cbdc8872 123
124#ifdef HAS_CHSIZE
cd52b7b2 125# ifdef my_chsize /* Probably #defined to Perl_my_chsize in embed.h */
126# undef my_chsize
127# endif
6ad3d225 128# define my_chsize PerlLIO_chsize
cbdc8872 129#endif
130
ff68c719 131#ifdef HAS_FLOCK
132# define FLOCK flock
133#else /* no flock() */
134
36477c24 135 /* fcntl.h might not have been included, even if it exists, because
136 the current Configure only sets I_FCNTL if it's needed to pick up
137 the *_OK constants. Make sure it has been included before testing
138 the fcntl() locking constants. */
139# if defined(HAS_FCNTL) && !defined(I_FCNTL)
140# include <fcntl.h>
141# endif
142
ff68c719 143# if defined(HAS_FCNTL) && defined(F_SETLK) && defined (F_SETLKW)
144# define FLOCK fcntl_emulate_flock
145# define FCNTL_EMULATE_FLOCK
146# else /* no flock() or fcntl(F_SETLK,...) */
147# ifdef HAS_LOCKF
148# define FLOCK lockf_emulate_flock
149# define LOCKF_EMULATE_FLOCK
150# endif /* lockf */
151# endif /* no flock() or fcntl(F_SETLK,...) */
152
153# ifdef FLOCK
13826f2c 154 static int FLOCK _((int, int));
ff68c719 155
156 /*
157 * These are the flock() constants. Since this sytems doesn't have
158 * flock(), the values of the constants are probably not available.
159 */
160# ifndef LOCK_SH
161# define LOCK_SH 1
162# endif
163# ifndef LOCK_EX
164# define LOCK_EX 2
165# endif
166# ifndef LOCK_NB
167# define LOCK_NB 4
168# endif
169# ifndef LOCK_UN
170# define LOCK_UN 8
171# endif
172# endif /* emulating flock() */
173
174#endif /* no flock() */
55497cff 175
85ab1d1d
JH		 176#define ZBTLEN 10
177static char zero_but_true[ZBTLEN + 1] = "0 but true";
178
5ff3f7a4
GS		 179#if defined(I_SYS_ACCESS) && !defined(R_OK)
180# include <sys/access.h>
181#endif
182
183#undef PERL_EFF_ACCESS_R_OK /* EFFective uid/gid ACCESS R_OK */
184#undef PERL_EFF_ACCESS_W_OK
185#undef PERL_EFF_ACCESS_X_OK
186
187/* F_OK unused: if stat() cannot find it... */
188
189#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_ACCESS) && defined(EFF_ONLY_OK) && !defined(NO_EFF_ONLY_OK)
c955f117 190 /* Digital UNIX (when the EFF_ONLY_OK gets fixed), UnixWare */
5ff3f7a4
GS		 191# define PERL_EFF_ACCESS_R_OK(p) (access((p), R_OK | EFF_ONLY_OK))
192# define PERL_EFF_ACCESS_W_OK(p) (access((p), W_OK | EFF_ONLY_OK))
193# define PERL_EFF_ACCESS_X_OK(p) (access((p), X_OK | EFF_ONLY_OK))
194#endif
195
196#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_EACCESS)
5ff3f7a4
GS		 197# if defined(I_SYS_SECURITY)
198# include <sys/security.h>
199# endif
c955f117
JH		 200 /* XXX Configure test needed for eaccess */
201# ifdef ACC_SELF
202 /* HP SecureWare */
203# define PERL_EFF_ACCESS_R_OK(p) (eaccess((p), R_OK, ACC_SELF))
204# define PERL_EFF_ACCESS_W_OK(p) (eaccess((p), W_OK, ACC_SELF))
205# define PERL_EFF_ACCESS_X_OK(p) (eaccess((p), X_OK, ACC_SELF))
206# else
207 /* SCO */
208# define PERL_EFF_ACCESS_R_OK(p) (eaccess((p), R_OK))
209# define PERL_EFF_ACCESS_W_OK(p) (eaccess((p), W_OK))
210# define PERL_EFF_ACCESS_X_OK(p) (eaccess((p), X_OK))
211# endif
5ff3f7a4
GS		 212#endif
213
214#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_ACCESSX) && defined(ACC_SELF)
c955f117 215 /* AIX */
5ff3f7a4
GS		 216# define PERL_EFF_ACCESS_R_OK(p) (accessx((p), R_OK, ACC_SELF))
217# define PERL_EFF_ACCESS_W_OK(p) (accessx((p), W_OK, ACC_SELF))
218# define PERL_EFF_ACCESS_X_OK(p) (accessx((p), X_OK, ACC_SELF))
219#endif
220
327c3667
GS		 221#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_ACCESS) \
222 && (defined(HAS_SETREUID) || defined(HAS_SETRESUID) \
223 || defined(HAS_SETREGID) || defined(HAS_SETRESGID))
5ff3f7a4 224/* The Hard Way. */
327c3667
GS		 225STATIC int
226emulate_eaccess (const char* path, int mode) {
5ff3f7a4
GS		 227 Uid_t ruid = getuid();
228 Uid_t euid = geteuid();
229 Gid_t rgid = getgid();
230 Gid_t egid = getegid();
231 int res;
232
233 MUTEX_LOCK(&PL_cred_mutex);
234#if !defined(HAS_SETREUID) && !defined(HAS_SETRESUID)
85ab1d1d 235 croak("switching effective uid is not implemented");
5ff3f7a4
GS		 236#else
237#ifdef HAS_SETREUID
238 if (setreuid(euid, ruid))
239#else
240#ifdef HAS_SETRESUID
241 if (setresuid(euid, ruid, (Uid_t)-1))
242#endif
243#endif
85ab1d1d 244 croak("entering effective uid failed");
5ff3f7a4
GS		 245#endif
246
247#if !defined(HAS_SETREGID) && !defined(HAS_SETRESGID)
85ab1d1d 248 croak("switching effective gid is not implemented");
5ff3f7a4
GS		 249#else
250#ifdef HAS_SETREGID
251 if (setregid(egid, rgid))
252#else
253#ifdef HAS_SETRESGID
254 if (setresgid(egid, rgid, (Gid_t)-1))
255#endif
256#endif
85ab1d1d 257 croak("entering effective gid failed");
5ff3f7a4
GS		 258#endif
259
260 res = access(path, mode);
261
262#ifdef HAS_SETREUID
263 if (setreuid(ruid, euid))
264#else
265#ifdef HAS_SETRESUID
266 if (setresuid(ruid, euid, (Uid_t)-1))
267#endif
268#endif
85ab1d1d 269 croak("leaving effective uid failed");
5ff3f7a4
GS		 270
271#ifdef HAS_SETREGID
272 if (setregid(rgid, egid))
273#else
274#ifdef HAS_SETRESGID
275 if (setresgid(rgid, egid, (Gid_t)-1))
276#endif
277#endif
85ab1d1d 278 croak("leaving effective gid failed");
5ff3f7a4
GS		 279 MUTEX_UNLOCK(&PL_cred_mutex);
280
281 return res;
282}
283# define PERL_EFF_ACCESS_R_OK(p) (emulate_eaccess((p), R_OK))
284# define PERL_EFF_ACCESS_W_OK(p) (emulate_eaccess((p), W_OK))
285# define PERL_EFF_ACCESS_X_OK(p) (emulate_eaccess((p), X_OK))
286#endif
287
288#if !defined(PERL_EFF_ACCESS_R_OK)
327c3667
GS		 289STATIC int
290emulate_eaccess (const char* path, int mode) {
85ab1d1d 291 croak("switching effective uid is not implemented");
5ff3f7a4
GS		 292 /*NOTREACHED*/
293 return -1;
294}
295#endif
296
a0d0e21e
LW		 297PP(pp_backtick)
298{
4e35701f 299 djSP; dTARGET;
760ac839 300 PerlIO *fp;
2d8e6c8d
GS		 301 STRLEN n_a;
302 char *tmps = POPpx;
54310121 303 I32 gimme = GIMME_V;
304
a0d0e21e 305 TAINT_PROPER("``");
6ad3d225 306 fp = PerlProc_popen(tmps, "r");
a0d0e21e 307 if (fp) {
54310121 308 if (gimme == G_VOID) {
96827780
MB		 309 char tmpbuf[256];
310 while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0)
54310121 311 /*SUPPRESS 530*/
312 ;
313 }
314 else if (gimme == G_SCALAR) {
aa689395 315 sv_setpv(TARG, ""); /* note that this preserves previous buffer */
a0d0e21e
LW		 316 while (sv_gets(TARG, fp, SvCUR(TARG)) != Nullch)
317 /*SUPPRESS 530*/
318 ;
319 XPUSHs(TARG);
aa689395 320 SvTAINTED_on(TARG);
a0d0e21e
LW		 321 }
322 else {
323 SV *sv;
324
325 for (;;) {
8d6dde3e 326 sv = NEWSV(56, 79);
a0d0e21e
LW		 327 if (sv_gets(sv, fp, 0) == Nullch) {
328 SvREFCNT_dec(sv);
329 break;
330 }
331 XPUSHs(sv_2mortal(sv));
332 if (SvLEN(sv) - SvCUR(sv) > 20) {
333 SvLEN_set(sv, SvCUR(sv)+1);
334 Renew(SvPVX(sv), SvLEN(sv), char);
335 }
aa689395 336 SvTAINTED_on(sv);
a0d0e21e
LW		 337 }
338 }
6ad3d225 339 STATUS_NATIVE_SET(PerlProc_pclose(fp));
aa689395 340 TAINT; /* "I believe that this is not gratuitous!" */
a0d0e21e
LW		 341 }
342 else {
f86702cc 343 STATUS_NATIVE_SET(-1);
54310121 344 if (gimme == G_SCALAR)
a0d0e21e
LW		 345 RETPUSHUNDEF;
346 }
347
348 RETURN;
349}
350
351PP(pp_glob)
352{
353 OP *result;
f5284f61
IZ		 354 tryAMAGICunTARGET(iter, -1);
355
a0d0e21e 356 ENTER;
a0d0e21e 357
c90c0ff4 358#ifndef VMS
3280af22 359 if (PL_tainting) {
7bac28a0 360 /*
361 * The external globbing program may use things we can't control,
362 * so for security reasons we must assume the worst.
363 */
364 TAINT;
22c35a8c 365 taint_proper(PL_no_security, "glob");
7bac28a0 366 }
c90c0ff4 367#endif /* !VMS */
7bac28a0 368
3280af22
NIS		 369 SAVESPTR(PL_last_in_gv); /* We don't want this to be permanent. */
370 PL_last_in_gv = (GV*)*PL_stack_sp--;
a0d0e21e 371
3280af22 372 SAVESPTR(PL_rs); /* This is not permanent, either. */
79cb57f6 373 PL_rs = sv_2mortal(newSVpvn("\000", 1));
c07a80fd 374#ifndef DOSISH
375#ifndef CSH
6b88bc9c 376 *SvPVX(PL_rs) = '\n';
a0d0e21e 377#endif /* !CSH */
55497cff 378#endif /* !DOSISH */
c07a80fd 379
a0d0e21e
LW		 380 result = do_readline();
381 LEAVE;
382 return result;
383}
384
15e52e56 385#if 0 /* XXX never used! */
a0d0e21e
LW		 386PP(pp_indread)
387{
2d8e6c8d
GS		 388 STRLEN n_a;
389 PL_last_in_gv = gv_fetchpv(SvPVx(GvSV((GV*)(*PL_stack_sp--)), n_a), TRUE,SVt_PVIO);
a0d0e21e
LW		 390 return do_readline();
391}
15e52e56 392#endif
a0d0e21e
LW		 393
394PP(pp_rcatline)
395{
3280af22 396 PL_last_in_gv = cGVOP->op_gv;
a0d0e21e
LW		 397 return do_readline();
398}
399
400PP(pp_warn)
401{
4e35701f 402 djSP; dMARK;
06bf62c7 403 SV *tmpsv;
a0d0e21e 404 char *tmps;
06bf62c7 405 STRLEN len;
a0d0e21e
LW		 406 if (SP - MARK != 1) {
407 dTARGET;
3280af22 408 do_join(TARG, &PL_sv_no, MARK, SP);
06bf62c7 409 tmpsv = TARG;
a0d0e21e
LW		 410 SP = MARK + 1;
411 }
412 else {
06bf62c7 413 tmpsv = TOPs;
a0d0e21e 414 }
06bf62c7
GS		 415 tmps = SvPV(tmpsv, len);
416 if (!tmps || !len) {
4e6ea2c3
GS		 417 SV *error = ERRSV;
418 (void)SvUPGRADE(error, SVt_PV);
419 if (SvPOK(error) && SvCUR(error))
420 sv_catpv(error, "\t...caught");
06bf62c7
GS		 421 tmpsv = error;
422 tmps = SvPV(tmpsv, len);
a0d0e21e 423 }
06bf62c7
GS		 424 if (!tmps || !len)
425 tmpsv = sv_2mortal(newSVpvn("Warning: something's wrong", 26));
426
427 warn("%_", tmpsv);
a0d0e21e
LW		 428 RETSETYES;
429}
430
431PP(pp_die)
432{
4e35701f 433 djSP; dMARK;
a0d0e21e 434 char *tmps;
06bf62c7
GS		 435 SV *tmpsv;
436 STRLEN len;
437 bool multiarg = 0;
a0d0e21e
LW		 438 if (SP - MARK != 1) {
439 dTARGET;
3280af22 440 do_join(TARG, &PL_sv_no, MARK, SP);
06bf62c7
GS		 441 tmpsv = TARG;
442 tmps = SvPV(tmpsv, len);
443 multiarg = 1;
a0d0e21e
LW		 444 SP = MARK + 1;
445 }
446 else {
4e6ea2c3 447 tmpsv = TOPs;
06bf62c7 448 tmps = SvROK(tmpsv) ? Nullch : SvPV(tmpsv, len);
a0d0e21e 449 }
06bf62c7 450 if (!tmps || !len) {
4e6ea2c3
GS		 451 SV *error = ERRSV;
452 (void)SvUPGRADE(error, SVt_PV);
06bf62c7
GS		 453 if (multiarg ? SvROK(error) : SvROK(tmpsv)) {
454 if (!multiarg)
4e6ea2c3 455 SvSetSV(error,tmpsv);
06bf62c7 456 else if (sv_isobject(error)) {
05423cc9
GS		 457 HV *stash = SvSTASH(SvRV(error));
458 GV *gv = gv_fetchmethod(stash, "PROPAGATE");
459 if (gv) {
3280af22
NIS		 460 SV *file = sv_2mortal(newSVsv(GvSV(PL_curcop->cop_filegv)));
461 SV *line = sv_2mortal(newSViv(PL_curcop->cop_line));
05423cc9
GS		 462 EXTEND(SP, 3);
463 PUSHMARK(SP);
464 PUSHs(error);
465 PUSHs(file);
466 PUSHs(line);
467 PUTBACK;
468 perl_call_sv((SV*)GvCV(gv),
469 G_SCALAR|G_EVAL|G_KEEPERR);
3280af22 470 sv_setsv(error,*PL_stack_sp--);
05423cc9
GS		 471 }
472 }
06bf62c7 473 DIE(Nullch);
4e6ea2c3
GS		 474 }
475 else {
476 if (SvPOK(error) && SvCUR(error))
477 sv_catpv(error, "\t...propagated");
06bf62c7
GS		 478 tmpsv = error;
479 tmps = SvPV(tmpsv, len);
4e6ea2c3 480 }
a0d0e21e 481 }
06bf62c7
GS		 482 if (!tmps || !len)
483 tmpsv = sv_2mortal(newSVpvn("Died", 4));
484
485 DIE("%_", tmpsv);
a0d0e21e
LW		 486}
487
488/* I/O. */
489
490PP(pp_open)
491{
4e35701f 492 djSP; dTARGET;
a0d0e21e
LW		 493 GV *gv;
494 SV *sv;
495 char *tmps;
496 STRLEN len;
4592e6ca 497 MAGIC *mg;
a0d0e21e
LW		 498
499 if (MAXARG > 1)
500 sv = POPs;
5f05dabc 501 if (!isGV(TOPs))
22c35a8c 502 DIE(PL_no_usym, "filehandle");
5f05dabc 503 if (MAXARG <= 1)
504 sv = GvSV(TOPs);
a0d0e21e 505 gv = (GV*)POPs;
5f05dabc 506 if (!isGV(gv))
22c35a8c 507 DIE(PL_no_usym, "filehandle");
36477c24 508 if (GvIOp(gv))
509 IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
853846ea
NIS		 510
511#if 0 /* no undef means tmpfile() yet */
3eb568f1
NIS		 512 if (sv == &PL_sv_undef) {
513#ifdef PerlIO
514 PerlIO *fp = PerlIO_tmpfile();
515#else
516 PerlIO *fp = tmpfile();
517#endif
518 if (fp != Nullfp && do_open(gv, "+>&", 3, FALSE, 0, 0, fp))
519 PUSHi( (I32)PL_forkprocess );
520 else
521 RETPUSHUNDEF;
522 RETURN;
523 }
853846ea
NIS		 524#endif /* no undef means tmpfile() yet */
525
4592e6ca
NIS		 526
527 if (mg = SvTIED_mg((SV*)gv, 'q')) {
528 PUSHMARK(SP);
529 XPUSHs(SvTIED_obj((SV*)gv, mg));
530 XPUSHs(sv);
531 PUTBACK;
532 ENTER;
533 perl_call_method("OPEN", G_SCALAR);
534 LEAVE;
535 SPAGAIN;
536 RETURN;
537 }
538
a0d0e21e 539 tmps = SvPV(sv, len);
9d116dd7 540 if (do_open(gv, tmps, len, FALSE, O_RDONLY, 0, Nullfp))
3280af22
NIS		 541 PUSHi( (I32)PL_forkprocess );
542 else if (PL_forkprocess == 0) /* we are a new child */
a0d0e21e
LW		 543 PUSHi(0);
544 else
545 RETPUSHUNDEF;
546 RETURN;
547}
548
549PP(pp_close)
550{
4e35701f 551 djSP;
a0d0e21e 552 GV *gv;
1d603a67 553 MAGIC *mg;
a0d0e21e
LW		 554
555 if (MAXARG == 0)
3280af22 556 gv = PL_defoutgv;
a0d0e21e
LW		 557 else
558 gv = (GV*)POPs;
1d603a67 559
33c27489 560 if (mg = SvTIED_mg((SV*)gv, 'q')) {
1d603a67 561 PUSHMARK(SP);
33c27489 562 XPUSHs(SvTIED_obj((SV*)gv, mg));
1d603a67
GB		 563 PUTBACK;
564 ENTER;
565 perl_call_method("CLOSE", G_SCALAR);
566 LEAVE;
567 SPAGAIN;
568 RETURN;
569 }
a0d0e21e 570 EXTEND(SP, 1);
54310121 571 PUSHs(boolSV(do_close(gv, TRUE)));
a0d0e21e
LW		 572 RETURN;
573}
574
575PP(pp_pipe_op)
576{
4e35701f 577 djSP;
a0d0e21e
LW		 578#ifdef HAS_PIPE
579 GV *rgv;
580 GV *wgv;
581 register IO *rstio;
582 register IO *wstio;
583 int fd[2];
584
585 wgv = (GV*)POPs;
586 rgv = (GV*)POPs;
587
588 if (!rgv || !wgv)
589 goto badexit;
590
4633a7c4 591 if (SvTYPE(rgv) != SVt_PVGV || SvTYPE(wgv) != SVt_PVGV)
22c35a8c 592 DIE(PL_no_usym, "filehandle");
a0d0e21e
LW		 593 rstio = GvIOn(rgv);
594 wstio = GvIOn(wgv);
595
596 if (IoIFP(rstio))
597 do_close(rgv, FALSE);
598 if (IoIFP(wstio))
599 do_close(wgv, FALSE);
600
6ad3d225 601 if (PerlProc_pipe(fd) < 0)
a0d0e21e
LW		 602 goto badexit;
603
760ac839
LW		 604 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r");
605 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w");
a0d0e21e
LW		 606 IoIFP(wstio) = IoOFP(wstio);
607 IoTYPE(rstio) = '<';
608 IoTYPE(wstio) = '>';
609
610 if (!IoIFP(rstio) || !IoOFP(wstio)) {
760ac839 611 if (IoIFP(rstio)) PerlIO_close(IoIFP(rstio));
6ad3d225 612 else PerlLIO_close(fd[0]);
760ac839 613 if (IoOFP(wstio)) PerlIO_close(IoOFP(wstio));
6ad3d225 614 else PerlLIO_close(fd[1]);
a0d0e21e
LW		 615 goto badexit;
616 }
4771b018
GS		 617#if defined(HAS_FCNTL) && defined(F_SETFD)
618 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
619 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
620#endif
a0d0e21e
LW		 621 RETPUSHYES;
622
623badexit:
624 RETPUSHUNDEF;
625#else
22c35a8c 626 DIE(PL_no_func, "pipe");
a0d0e21e
LW		 627#endif
628}
629
630PP(pp_fileno)
631{
4e35701f 632 djSP; dTARGET;
a0d0e21e
LW		 633 GV *gv;
634 IO *io;
760ac839 635 PerlIO *fp;
4592e6ca
NIS		 636 MAGIC *mg;
637
a0d0e21e
LW		 638 if (MAXARG < 1)
639 RETPUSHUNDEF;
640 gv = (GV*)POPs;
4592e6ca
NIS		 641
642 if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
643 PUSHMARK(SP);
644 XPUSHs(SvTIED_obj((SV*)gv, mg));
645 PUTBACK;
646 ENTER;
647 perl_call_method("FILENO", G_SCALAR);
648 LEAVE;
649 SPAGAIN;
650 RETURN;
651 }
652
a0d0e21e
LW		 653 if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io)))
654 RETPUSHUNDEF;
760ac839 655 PUSHi(PerlIO_fileno(fp));
a0d0e21e
LW		 656 RETURN;
657}
658
659PP(pp_umask)
660{
4e35701f 661 djSP; dTARGET;
761237fe 662 Mode_t anum;
a0d0e21e
LW		 663
664#ifdef HAS_UMASK
665 if (MAXARG < 1) {
6ad3d225
GS		 666 anum = PerlLIO_umask(0);
667 (void)PerlLIO_umask(anum);
a0d0e21e
LW		 668 }
669 else
6ad3d225 670 anum = PerlLIO_umask(POPi);
a0d0e21e
LW		 671 TAINT_PROPER("umask");
672 XPUSHi(anum);
673#else
eec2d3df
GS		 674 /* Only DIE if trying to restrict permissions on `user' (self).
675 * Otherwise it's harmless and more useful to just return undef
676 * since 'group' and 'other' concepts probably don't exist here. */
677 if (MAXARG >= 1 && (POPi & 0700))
678 DIE("umask not implemented");
6b88bc9c 679 XPUSHs(&PL_sv_undef);
a0d0e21e
LW		 680#endif
681 RETURN;
682}
683
684PP(pp_binmode)
685{
4e35701f 686 djSP;
a0d0e21e
LW		 687 GV *gv;
688 IO *io;
760ac839 689 PerlIO *fp;
4592e6ca 690 MAGIC *mg;
a0d0e21e
LW		 691
692 if (MAXARG < 1)
693 RETPUSHUNDEF;
694
4592e6ca
NIS		 695 gv = (GV*)POPs;
696
697 if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
698 PUSHMARK(SP);
699 XPUSHs(SvTIED_obj((SV*)gv, mg));
700 PUTBACK;
701 ENTER;
702 perl_call_method("BINMODE", G_SCALAR);
703 LEAVE;
704 SPAGAIN;
705 RETURN;
706 }
a0d0e21e
LW		 707
708 EXTEND(SP, 1);
709 if (!(io = GvIO(gv)) || !(fp = IoIFP(io)))
55497cff 710 RETPUSHUNDEF;
a0d0e21e 711
491527d0 712 if (do_binmode(fp,IoTYPE(io),TRUE))
a0d0e21e
LW		 713 RETPUSHYES;
714 else
715 RETPUSHUNDEF;
a0d0e21e
LW		 716}
717
b8e3bfaf 718
a0d0e21e
LW		 719PP(pp_tie)
720{
4e35701f 721 djSP;
e336de0d 722 dMARK;
a0d0e21e
LW		 723 SV *varsv;
724 HV* stash;
725 GV *gv;
a0d0e21e 726 SV *sv;
3280af22 727 I32 markoff = MARK - PL_stack_base;
a0d0e21e 728 char *methname;
6b05c17a 729 int how = 'P';
e336de0d 730 U32 items;
2d8e6c8d 731 STRLEN n_a;
a0d0e21e 732
e336de0d 733 varsv = *++MARK;
6b05c17a
NIS		 734 switch(SvTYPE(varsv)) {
735 case SVt_PVHV:
736 methname = "TIEHASH";
737 break;
738 case SVt_PVAV:
739 methname = "TIEARRAY";
740 break;
741 case SVt_PVGV:
742 methname = "TIEHANDLE";
743 how = 'q';
744 break;
745 default:
746 methname = "TIESCALAR";
747 how = 'q';
748 break;
749 }
e336de0d
GS		 750 items = SP - MARK++;
751 if (sv_isobject(*MARK)) {
6b05c17a 752 ENTER;
e788e7d3 753 PUSHSTACKi(PERLSI_MAGIC);
e336de0d
GS		 754 PUSHMARK(SP);
755 EXTEND(SP,items);
756 while (items--)
757 PUSHs(*MARK++);
758 PUTBACK;
6b05c17a
NIS		 759 perl_call_method(methname, G_SCALAR);
760 }
761 else {
762 /* Not clear why we don't call perl_call_method here too.
763 * perhaps to get different error message ?
764 */
e336de0d 765 stash = gv_stashsv(*MARK, FALSE);
6b05c17a
NIS		 766 if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
767 DIE("Can't locate object method \"%s\" via package \"%s\"",
2d8e6c8d 768 methname, SvPV(*MARK,n_a));
6b05c17a
NIS		 769 }
770 ENTER;
e788e7d3 771 PUSHSTACKi(PERLSI_MAGIC);
e336de0d
GS		 772 PUSHMARK(SP);
773 EXTEND(SP,items);
774 while (items--)
775 PUSHs(*MARK++);
776 PUTBACK;
6b05c17a
NIS		 777 perl_call_sv((SV*)GvCV(gv), G_SCALAR);
778 }
a0d0e21e
LW		 779 SPAGAIN;
780
781 sv = TOPs;
d3acc0f7 782 POPSTACK;
a0d0e21e 783 if (sv_isobject(sv)) {
33c27489
GS		 784 sv_unmagic(varsv, how);
785 sv_magic(varsv, (SvRV(sv) == varsv ? Nullsv : sv), how, Nullch, 0);
a0d0e21e
LW		 786 }
787 LEAVE;
3280af22 788 SP = PL_stack_base + markoff;
a0d0e21e
LW		 789 PUSHs(sv);
790 RETURN;
791}
792
793PP(pp_untie)
794{
4e35701f 795 djSP;
33c27489
GS		 796 SV *sv = POPs;
797 char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) ? 'P' : 'q';
55497cff 798
599cee73 799 if (ckWARN(WARN_UNTIE)) {
cbdc8872 800 MAGIC * mg ;
33c27489 801 if (mg = SvTIED_mg(sv, how)) {
cbdc8872 802 if (mg && SvREFCNT(SvRV(mg->mg_obj)) > 1)
599cee73
PM		 803 warner(WARN_UNTIE,
804 "untie attempted while %lu inner references still exist",
805 (unsigned long)SvREFCNT(SvRV(mg->mg_obj)) - 1 ) ;
cbdc8872 806 }
807 }
808
33c27489 809 sv_unmagic(sv, how);
55497cff 810 RETPUSHYES;
a0d0e21e
LW		 811}
812
c07a80fd 813PP(pp_tied)
814{
4e35701f 815 djSP;
33c27489
GS		 816 SV *sv = POPs;
817 char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) ? 'P' : 'q';
818 MAGIC *mg;
c07a80fd 819
33c27489
GS		 820 if (mg = SvTIED_mg(sv, how)) {
821 SV *osv = SvTIED_obj(sv, mg);
822 if (osv == mg->mg_obj)
823 osv = sv_mortalcopy(osv);
824 PUSHs(osv);
825 RETURN;
c07a80fd 826 }
c07a80fd 827 RETPUSHUNDEF;
828}
829
a0d0e21e
LW		 830PP(pp_dbmopen)
831{
4e35701f 832 djSP;
a0d0e21e
LW		 833 HV *hv;
834 dPOPPOPssrl;
835 HV* stash;
836 GV *gv;
a0d0e21e
LW		 837 SV *sv;
838
839 hv = (HV*)POPs;
840
3280af22 841 sv = sv_mortalcopy(&PL_sv_no);
a0d0e21e
LW		 842 sv_setpv(sv, "AnyDBM_File");
843 stash = gv_stashsv(sv, FALSE);
8ebc5c01 844 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
a0d0e21e 845 PUTBACK;
4633a7c4 846 perl_require_pv("AnyDBM_File.pm");
a0d0e21e 847 SPAGAIN;
8ebc5c01 848 if (!(gv = gv_fetchmethod(stash, "TIEHASH")))
a0d0e21e
LW		 849 DIE("No dbm on this machine");
850 }
851
57d3b86d 852 ENTER;
924508f0 853 PUSHMARK(SP);
6b05c17a 854
924508f0 855 EXTEND(SP, 5);
a0d0e21e
LW		 856 PUSHs(sv);
857 PUSHs(left);
858 if (SvIV(right))
859 PUSHs(sv_2mortal(newSViv(O_RDWR|O_CREAT)));
860 else
861 PUSHs(sv_2mortal(newSViv(O_RDWR)));
862 PUSHs(right);
57d3b86d 863 PUTBACK;
38a03e6e 864 perl_call_sv((SV*)GvCV(gv), G_SCALAR);
a0d0e21e
LW		 865 SPAGAIN;
866
867 if (!sv_isobject(TOPs)) {
924508f0
GS		 868 SP--;
869 PUSHMARK(SP);
a0d0e21e
LW		 870 PUSHs(sv);
871 PUSHs(left);
872 PUSHs(sv_2mortal(newSViv(O_RDONLY)));
873 PUSHs(right);
a0d0e21e 874 PUTBACK;
38a03e6e 875 perl_call_sv((SV*)GvCV(gv), G_SCALAR);
a0d0e21e
LW		 876 SPAGAIN;
877 }
878
6b05c17a
NIS		 879 if (sv_isobject(TOPs)) {
880 sv_unmagic((SV *) hv, 'P');
a0d0e21e 881 sv_magic((SV*)hv, TOPs, 'P', Nullch, 0);
6b05c17a 882 }
a0d0e21e
LW		 883 LEAVE;
884 RETURN;
885}
886
887PP(pp_dbmclose)
888{
889 return pp_untie(ARGS);
890}
891
892PP(pp_sselect)
893{
4e35701f 894 djSP; dTARGET;
a0d0e21e
LW		 895#ifdef HAS_SELECT
896 register I32 i;
897 register I32 j;
898 register char *s;
899 register SV *sv;
900 double value;
901 I32 maxlen = 0;
902 I32 nfound;
903 struct timeval timebuf;
904 struct timeval *tbuf = &timebuf;
905 I32 growsize;
906 char *fd_sets[4];
2d8e6c8d 907 STRLEN n_a;
a0d0e21e
LW		 908#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
909 I32 masksize;
910 I32 offset;
911 I32 k;
912
913# if BYTEORDER & 0xf0000
914# define ORDERBYTE (0x88888888 - BYTEORDER)
915# else
916# define ORDERBYTE (0x4444 - BYTEORDER)
917# endif
918
919#endif
920
921 SP -= 4;
922 for (i = 1; i <= 3; i++) {
923 if (!SvPOK(SP[i]))
924 continue;
925 j = SvCUR(SP[i]);
926 if (maxlen < j)
927 maxlen = j;
928 }
929
5ff3f7a4 930/* little endians can use vecs directly */
a0d0e21e 931#if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
5ff3f7a4 932# if SELECT_MIN_BITS > 1
f2da832e
JH		 933 /* If SELECT_MIN_BITS is greater than one we most probably will want
934 * to align the sizes with SELECT_MIN_BITS/8 because for example
935 * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
8f1f23e8
W		 936 * UNIX, Solaris, NeXT, Rhapsody) the smallest quantum select() operates
937 * on (sets/tests/clears bits) is 32 bits. */
f2da832e 938 growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
5ff3f7a4 939# else
4633a7c4 940 growsize = sizeof(fd_set);
5ff3f7a4
GS		 941# endif
942# else
943# ifdef NFDBITS
a0d0e21e 944
5ff3f7a4
GS		 945# ifndef NBBY
946# define NBBY 8
947# endif
a0d0e21e
LW		 948
949 masksize = NFDBITS / NBBY;
5ff3f7a4 950# else
a0d0e21e 951 masksize = sizeof(long); /* documented int, everyone seems to use long */
5ff3f7a4 952# endif
a0d0e21e
LW		 953 growsize = maxlen + (masksize - (maxlen % masksize));
954 Zero(&fd_sets[0], 4, char*);
955#endif
956
957 sv = SP[4];
958 if (SvOK(sv)) {
959 value = SvNV(sv);
960 if (value < 0.0)
961 value = 0.0;
962 timebuf.tv_sec = (long)value;
963 value -= (double)timebuf.tv_sec;
964 timebuf.tv_usec = (long)(value * 1000000.0);
965 }
966 else
967 tbuf = Null(struct timeval*);
968
969 for (i = 1; i <= 3; i++) {
970 sv = SP[i];
971 if (!SvOK(sv)) {
972 fd_sets[i] = 0;
973 continue;
974 }
975 else if (!SvPOK(sv))
2d8e6c8d 976 SvPV_force(sv,n_a); /* force string conversion */
a0d0e21e
LW		 977 j = SvLEN(sv);
978 if (j < growsize) {
979 Sv_Grow(sv, growsize);
a0d0e21e 980 }
c07a80fd 981 j = SvCUR(sv);
982 s = SvPVX(sv) + j;
983 while (++j <= growsize) {
984 *s++ = '\0';
985 }
986
a0d0e21e
LW		 987#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
988 s = SvPVX(sv);
989 New(403, fd_sets[i], growsize, char);
990 for (offset = 0; offset < growsize; offset += masksize) {
991 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
992 fd_sets[i][j+offset] = s[(k % masksize) + offset];
993 }
994#else
995 fd_sets[i] = SvPVX(sv);
996#endif
997 }
998
6ad3d225 999 nfound = PerlSock_select(
a0d0e21e
LW		 1000 maxlen * 8,
1001 (Select_fd_set_t) fd_sets[1],
1002 (Select_fd_set_t) fd_sets[2],
1003 (Select_fd_set_t) fd_sets[3],
1004 tbuf);
1005 for (i = 1; i <= 3; i++) {
1006 if (fd_sets[i]) {
1007 sv = SP[i];
1008#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1009 s = SvPVX(sv);
1010 for (offset = 0; offset < growsize; offset += masksize) {
1011 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1012 s[(k % masksize) + offset] = fd_sets[i][j+offset];
1013 }
1014 Safefree(fd_sets[i]);
1015#endif
1016 SvSETMAGIC(sv);
1017 }
1018 }
1019
1020 PUSHi(nfound);
1021 if (GIMME == G_ARRAY && tbuf) {
1022 value = (double)(timebuf.tv_sec) +
1023 (double)(timebuf.tv_usec) / 1000000.0;
3280af22 1024 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 1025 sv_setnv(sv, value);
1026 }
1027 RETURN;
1028#else
1029 DIE("select not implemented");
1030#endif
1031}
1032
4633a7c4 1033void
8ac85365 1034setdefout(GV *gv)
4633a7c4 1035{
11343788 1036 dTHR;
4633a7c4
LW		 1037 if (gv)
1038 (void)SvREFCNT_inc(gv);
3280af22
NIS		 1039 if (PL_defoutgv)
1040 SvREFCNT_dec(PL_defoutgv);
1041 PL_defoutgv = gv;
4633a7c4
LW		 1042}
1043
a0d0e21e
LW		 1044PP(pp_select)
1045{
4e35701f 1046 djSP; dTARGET;
4633a7c4
LW		 1047 GV *newdefout, *egv;
1048 HV *hv;
1049
533c011a 1050 newdefout = (PL_op->op_private > 0) ? ((GV *) POPs) : (GV *) NULL;
4633a7c4 1051
3280af22 1052 egv = GvEGV(PL_defoutgv);
4633a7c4 1053 if (!egv)
3280af22 1054 egv = PL_defoutgv;
4633a7c4
LW		 1055 hv = GvSTASH(egv);
1056 if (! hv)
3280af22 1057 XPUSHs(&PL_sv_undef);
4633a7c4 1058 else {
cbdc8872 1059 GV **gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
f86702cc 1060 if (gvp && *gvp == egv) {
3280af22 1061 gv_efullname3(TARG, PL_defoutgv, Nullch);
f86702cc 1062 XPUSHTARG;
1063 }
1064 else {
1065 XPUSHs(sv_2mortal(newRV((SV*)egv)));
1066 }
4633a7c4
LW		 1067 }
1068
1069 if (newdefout) {
ded8aa31
GS		 1070 if (!GvIO(newdefout))
1071 gv_IOadd(newdefout);
4633a7c4
LW		 1072 setdefout(newdefout);
1073 }
1074
a0d0e21e
LW		 1075 RETURN;
1076}
1077
1078PP(pp_getc)
1079{
4e35701f 1080 djSP; dTARGET;
a0d0e21e 1081 GV *gv;
2ae324a7 1082 MAGIC *mg;
a0d0e21e
LW		 1083
1084 if (MAXARG <= 0)
3280af22 1085 gv = PL_stdingv;
a0d0e21e
LW		 1086 else
1087 gv = (GV*)POPs;
1088 if (!gv)
3280af22 1089 gv = PL_argvgv;
2ae324a7 1090
33c27489 1091 if (mg = SvTIED_mg((SV*)gv, 'q')) {
54310121 1092 I32 gimme = GIMME_V;
2ae324a7 1093 PUSHMARK(SP);
33c27489 1094 XPUSHs(SvTIED_obj((SV*)gv, mg));
2ae324a7 1095 PUTBACK;
1096 ENTER;
54310121 1097 perl_call_method("GETC", gimme);
2ae324a7 1098 LEAVE;
1099 SPAGAIN;
54310121 1100 if (gimme == G_SCALAR)
1101 SvSetMagicSV_nosteal(TARG, TOPs);
2ae324a7 1102 RETURN;
1103 }
9bc64814 1104 if (!gv || do_eof(gv)) /* make sure we have fp with something */
a0d0e21e 1105 RETPUSHUNDEF;
bbce6d69 1106 TAINT;
a0d0e21e 1107 sv_setpv(TARG, " ");
9bc64814 1108 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
a0d0e21e
LW		 1109 PUSHTARG;
1110 RETURN;
1111}
1112
1113PP(pp_read)
1114{
1115 return pp_sysread(ARGS);
1116}
1117
76e3520e 1118STATIC OP *
8ac85365 1119doform(CV *cv, GV *gv, OP *retop)
a0d0e21e 1120{
11343788 1121 dTHR;
c09156bb 1122 register PERL_CONTEXT *cx;
54310121 1123 I32 gimme = GIMME_V;
a0d0e21e
LW		 1124 AV* padlist = CvPADLIST(cv);
1125 SV** svp = AvARRAY(padlist);
1126
1127 ENTER;
1128 SAVETMPS;
1129
1130 push_return(retop);
3280af22 1131 PUSHBLOCK(cx, CXt_SUB, PL_stack_sp);
a0d0e21e 1132 PUSHFORMAT(cx);
3280af22
NIS		 1133 SAVESPTR(PL_curpad);
1134 PL_curpad = AvARRAY((AV*)svp[1]);
a0d0e21e 1135
4633a7c4 1136 setdefout(gv); /* locally select filehandle so $% et al work */
a0d0e21e
LW		 1137 return CvSTART(cv);
1138}
1139
1140PP(pp_enterwrite)
1141{
4e35701f 1142 djSP;
a0d0e21e
LW		 1143 register GV *gv;
1144 register IO *io;
1145 GV *fgv;
1146 CV *cv;
1147
1148 if (MAXARG == 0)
3280af22 1149 gv = PL_defoutgv;
a0d0e21e
LW		 1150 else {
1151 gv = (GV*)POPs;
1152 if (!gv)
3280af22 1153 gv = PL_defoutgv;
a0d0e21e
LW		 1154 }
1155 EXTEND(SP, 1);
1156 io = GvIO(gv);
1157 if (!io) {
1158 RETPUSHNO;
1159 }
1160 if (IoFMT_GV(io))
1161 fgv = IoFMT_GV(io);
1162 else
1163 fgv = gv;
1164
1165 cv = GvFORM(fgv);
a0d0e21e
LW		 1166 if (!cv) {
1167 if (fgv) {
748a9306 1168 SV *tmpsv = sv_newmortal();
aac0dd9a 1169 gv_efullname3(tmpsv, fgv, Nullch);
748a9306 1170 DIE("Undefined format \"%s\" called",SvPVX(tmpsv));
a0d0e21e
LW		 1171 }
1172 DIE("Not a format reference");
1173 }
44a8e56a 1174 if (CvCLONE(cv))
1175 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
a0d0e21e 1176
44a8e56a 1177 IoFLAGS(io) &= ~IOf_DIDTOP;
533c011a 1178 return doform(cv,gv,PL_op->op_next);
a0d0e21e
LW		 1179}
1180
1181PP(pp_leavewrite)
1182{
4e35701f 1183 djSP;
a0d0e21e
LW		 1184 GV *gv = cxstack[cxstack_ix].blk_sub.gv;
1185 register IO *io = GvIOp(gv);
760ac839
LW		 1186 PerlIO *ofp = IoOFP(io);
1187 PerlIO *fp;
a0d0e21e
LW		 1188 SV **newsp;
1189 I32 gimme;
c09156bb 1190 register PERL_CONTEXT *cx;
a0d0e21e 1191
760ac839 1192 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
3280af22
NIS		 1193 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1194 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1195 PL_formtarget != PL_toptarget)
a0d0e21e 1196 {
4633a7c4
LW		 1197 GV *fgv;
1198 CV *cv;
a0d0e21e
LW		 1199 if (!IoTOP_GV(io)) {
1200 GV *topgv;
46fc3d4c 1201 SV *topname;
a0d0e21e
LW		 1202
1203 if (!IoTOP_NAME(io)) {
1204 if (!IoFMT_NAME(io))
1205 IoFMT_NAME(io) = savepv(GvNAME(gv));
46fc3d4c 1206 topname = sv_2mortal(newSVpvf("%s_TOP", IoFMT_NAME(io)));
1207 topgv = gv_fetchpv(SvPVX(topname), FALSE, SVt_PVFM);
748a9306 1208 if ((topgv && GvFORM(topgv)) ||
a0d0e21e 1209 !gv_fetchpv("top",FALSE,SVt_PVFM))
46fc3d4c 1210 IoTOP_NAME(io) = savepv(SvPVX(topname));
a0d0e21e
LW		 1211 else
1212 IoTOP_NAME(io) = savepv("top");
1213 }
1214 topgv = gv_fetchpv(IoTOP_NAME(io),FALSE, SVt_PVFM);
1215 if (!topgv || !GvFORM(topgv)) {
1216 IoLINES_LEFT(io) = 100000000;
1217 goto forget_top;
1218 }
1219 IoTOP_GV(io) = topgv;
1220 }
748a9306
LW		 1221 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1222 I32 lines = IoLINES_LEFT(io);
3280af22 1223 char *s = SvPVX(PL_formtarget);
8e07c86e
AD		 1224 if (lines <= 0) /* Yow, header didn't even fit!!! */
1225 goto forget_top;
748a9306
LW		 1226 while (lines-- > 0) {
1227 s = strchr(s, '\n');
1228 if (!s)
1229 break;
1230 s++;
1231 }
1232 if (s) {
3280af22
NIS		 1233 PerlIO_write(ofp, SvPVX(PL_formtarget), s - SvPVX(PL_formtarget));
1234 sv_chop(PL_formtarget, s);
1235 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
748a9306
LW		 1236 }
1237 }
a0d0e21e 1238 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
3280af22 1239 PerlIO_write(ofp, SvPVX(PL_formfeed), SvCUR(PL_formfeed));
a0d0e21e
LW		 1240 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1241 IoPAGE(io)++;
3280af22 1242 PL_formtarget = PL_toptarget;
748a9306 1243 IoFLAGS(io) |= IOf_DIDTOP;
4633a7c4
LW		 1244 fgv = IoTOP_GV(io);
1245 if (!fgv)
1246 DIE("bad top format reference");
1247 cv = GvFORM(fgv);
1248 if (!cv) {
1249 SV *tmpsv = sv_newmortal();
aac0dd9a 1250 gv_efullname3(tmpsv, fgv, Nullch);
4633a7c4
LW		 1251 DIE("Undefined top format \"%s\" called",SvPVX(tmpsv));
1252 }
44a8e56a 1253 if (CvCLONE(cv))
1254 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
533c011a 1255 return doform(cv,gv,PL_op);
a0d0e21e
LW		 1256 }
1257
1258 forget_top:
3280af22 1259 POPBLOCK(cx,PL_curpm);
a0d0e21e
LW		 1260 POPFORMAT(cx);
1261 LEAVE;
1262
1263 fp = IoOFP(io);
1264 if (!fp) {
599cee73 1265 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
a0d0e21e 1266 if (IoIFP(io))
599cee73
PM		 1267 warner(WARN_IO, "Filehandle only opened for input");
1268 else if (ckWARN(WARN_CLOSED))
1269 warner(WARN_CLOSED, "Write on closed filehandle");
a0d0e21e 1270 }
3280af22 1271 PUSHs(&PL_sv_no);
a0d0e21e
LW		 1272 }
1273 else {
3280af22 1274 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
599cee73
PM		 1275 if (ckWARN(WARN_IO))
1276 warner(WARN_IO, "page overflow");
a0d0e21e 1277 }
3280af22 1278 if (!PerlIO_write(ofp, SvPVX(PL_formtarget), SvCUR(PL_formtarget)) ||
760ac839 1279 PerlIO_error(fp))
3280af22 1280 PUSHs(&PL_sv_no);
a0d0e21e 1281 else {
3280af22
NIS		 1282 FmLINES(PL_formtarget) = 0;
1283 SvCUR_set(PL_formtarget, 0);
1284 *SvEND(PL_formtarget) = '\0';
a0d0e21e 1285 if (IoFLAGS(io) & IOf_FLUSH)
760ac839 1286 (void)PerlIO_flush(fp);
3280af22 1287 PUSHs(&PL_sv_yes);
a0d0e21e
LW		 1288 }
1289 }
3280af22 1290 PL_formtarget = PL_bodytarget;
a0d0e21e
LW		 1291 PUTBACK;
1292 return pop_return();
1293}
1294
1295PP(pp_prtf)
1296{
4e35701f 1297 djSP; dMARK; dORIGMARK;
a0d0e21e
LW		 1298 GV *gv;
1299 IO *io;
760ac839 1300 PerlIO *fp;
26db47c4 1301 SV *sv;
46fc3d4c 1302 MAGIC *mg;
2d8e6c8d 1303 STRLEN n_a;
a0d0e21e 1304
533c011a 1305 if (PL_op->op_flags & OPf_STACKED)
a0d0e21e
LW		 1306 gv = (GV*)*++MARK;
1307 else
3280af22 1308 gv = PL_defoutgv;
46fc3d4c 1309
33c27489 1310 if (mg = SvTIED_mg((SV*)gv, 'q')) {
46fc3d4c 1311 if (MARK == ORIGMARK) {
4352c267 1312 MEXTEND(SP, 1);
46fc3d4c 1313 ++MARK;
1314 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1315 ++SP;
1316 }
1317 PUSHMARK(MARK - 1);
33c27489 1318 *MARK = SvTIED_obj((SV*)gv, mg);
46fc3d4c 1319 PUTBACK;
1320 ENTER;
1321 perl_call_method("PRINTF", G_SCALAR);
1322 LEAVE;
1323 SPAGAIN;
1324 MARK = ORIGMARK + 1;
1325 *MARK = *SP;
1326 SP = MARK;
1327 RETURN;
1328 }
1329
26db47c4 1330 sv = NEWSV(0,0);
a0d0e21e 1331 if (!(io = GvIO(gv))) {
599cee73 1332 if (ckWARN(WARN_UNOPENED)) {
aac0dd9a 1333 gv_fullname3(sv, gv, Nullch);
2d8e6c8d 1334 warner(WARN_UNOPENED, "Filehandle %s never opened", SvPV(sv,n_a));
748a9306
LW		 1335 }
1336 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW		 1337 goto just_say_no;
1338 }
1339 else if (!(fp = IoOFP(io))) {
599cee73 1340 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
aac0dd9a 1341 gv_fullname3(sv, gv, Nullch);
a0d0e21e 1342 if (IoIFP(io))
599cee73 1343 warner(WARN_IO, "Filehandle %s opened only for input",
2d8e6c8d 1344 SvPV(sv,n_a));
599cee73
PM		 1345 else if (ckWARN(WARN_CLOSED))
1346 warner(WARN_CLOSED, "printf on closed filehandle %s",
2d8e6c8d 1347 SvPV(sv,n_a));
a0d0e21e 1348 }
748a9306 1349 SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
a0d0e21e
LW		 1350 goto just_say_no;
1351 }
1352 else {
36477c24 1353#ifdef USE_LOCALE_NUMERIC
533c011a 1354 if (PL_op->op_private & OPpLOCALE)
36477c24 1355 SET_NUMERIC_LOCAL();
bbce6d69 1356 else
36477c24 1357 SET_NUMERIC_STANDARD();
1358#endif
a0d0e21e
LW		 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;
1431 perl_call_method("READ", G_SCALAR);
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)
1448 DIE("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)
22c35a8c 1485 DIE(PL_no_sock_func, "recv");
a0d0e21e 1486#endif
bbce6d69 1487 if (offset < 0) {
1488 if (-offset > blen)
1489 DIE("Offset outside string");
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 }
a0d0e21e
LW		 1559 return pp_send(ARGS);
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
GB		 1580 ENTER;
1581 perl_call_method("WRITE", G_SCALAR);
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)
1595 DIE("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)
599cee73 1602 warner(WARN_CLOSED, "Syswrite on closed filehandle");
a0d0e21e 1603 else
599cee73 1604 warner(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)
1612 DIE("Offset outside string");
1613 offset += blen;
fb73857a 1614 } else if (offset >= blen && blen > 0)
bbce6d69 1615 DIE("Offset outside string");
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
22c35a8c 1645 DIE(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{
1660 return pp_sysread(ARGS);
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;
1679 perl_call_method("EOF", G_SCALAR);
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;
1705 perl_call_method("TELL", G_SCALAR);
1706 LEAVE;
1707 SPAGAIN;
1708 RETURN;
1709 }
1710
a0d0e21e
LW		 1711 PUSHi( do_tell(gv) );
1712 RETURN;
1713}
1714
1715PP(pp_seek)
1716{
137443ea 1717 return pp_sysseek(ARGS);
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;
1737 perl_call_method("SEEK", G_SCALAR);
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
1815 DIE("truncate not implemented");
1816#endif
1817}
1818
1819PP(pp_fcntl)
1820{
1821 return pp_ioctl(ARGS);
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
LW		 1862#else
1863 DIE("ioctl is not implemented");
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
a0d0e21e 1873 DIE("fcntl is not implemented");
a0d0e21e
LW		 1874#endif
1875
748a9306
LW		 1876 if (SvPOK(argsv)) {
1877 if (s[SvCUR(argsv)] != 17)
a0d0e21e 1878 DIE("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
22c35a8c 1922 DIE(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
22c35a8c 1966 DIE(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
22c35a8c 2016 DIE(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
PM		 2070 if (ckWARN(WARN_CLOSED))
2071 warner(WARN_CLOSED, "bind() on closed fd");
748a9306 2072 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2073 RETPUSHUNDEF;
2074#else
22c35a8c 2075 DIE(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
PM		 2100 if (ckWARN(WARN_CLOSED))
2101 warner(WARN_CLOSED, "connect() on closed fd");
748a9306 2102 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2103 RETPUSHUNDEF;
2104#else
22c35a8c 2105 DIE(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
PM		 2126 if (ckWARN(WARN_CLOSED))
2127 warner(WARN_CLOSED, "listen() on closed fd");
748a9306 2128 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2129 RETPUSHUNDEF;
2130#else
22c35a8c 2131 DIE(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
PM		 2180 if (ckWARN(WARN_CLOSED))
2181 warner(WARN_CLOSED, "accept() on closed fd");
748a9306 2182 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2183
2184badexit:
2185 RETPUSHUNDEF;
2186
2187#else
22c35a8c 2188 DIE(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
PM		 2207 if (ckWARN(WARN_CLOSED))
2208 warner(WARN_CLOSED, "shutdown() on closed fd");
748a9306 2209 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2210 RETPUSHUNDEF;
2211#else
22c35a8c 2212 DIE(PL_no_sock_func, "shutdown");
a0d0e21e
LW		 2213#endif
2214}
2215
2216PP(pp_gsockopt)
2217{
2218#ifdef HAS_SOCKET
2219 return pp_ssockopt(ARGS);
2220#else
22c35a8c 2221 DIE(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
PM		 2286 if (ckWARN(WARN_CLOSED))
2287 warner(WARN_CLOSED, "[gs]etsockopt() on closed fd");
748a9306 2288 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2289nuts2:
2290 RETPUSHUNDEF;
2291
2292#else
22c35a8c 2293 DIE(PL_no_sock_func, "setsockopt");
a0d0e21e
LW		 2294#endif
2295}
2296
2297PP(pp_getsockname)
2298{
2299#ifdef HAS_SOCKET
2300 return pp_getpeername(ARGS);
2301#else
22c35a8c 2302 DIE(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
PM		 2359 if (ckWARN(WARN_CLOSED))
2360 warner(WARN_CLOSED, "get{sock, peer}name() on closed fd");
748a9306 2361 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2362nuts2:
2363 RETPUSHUNDEF;
2364
2365#else
22c35a8c 2366 DIE(PL_no_sock_func, "getpeername");
a0d0e21e
LW		 2367#endif
2368}
2369
2370/* Stat calls. */
2371
2372PP(pp_lstat)
2373{
2374 return pp_stat(ARGS);
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'))
22c35a8c 2419 warner(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
5ff3f7a4
GS		 2480 result = my_stat(ARGS);
2481#else
2482 result = my_stat(ARGS);
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
5ff3f7a4
GS		 2507 result = my_stat(ARGS);
2508#else
2509 result = my_stat(ARGS);
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
5ff3f7a4
GS		 2534 result = my_stat(ARGS);
2535#else
2536 result = my_stat(ARGS);
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
5ff3f7a4
GS		 2561 result = my_stat(ARGS);
2562#else
2563 result = my_stat(ARGS);
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
5ff3f7a4
GS		 2588 result = my_stat(ARGS);
2589#else
2590 result = my_stat(ARGS);
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
5ff3f7a4
GS		 2615 result = my_stat(ARGS);
2616#else
2617 result = my_stat(ARGS);
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{
2629 I32 result = my_stat(ARGS);
4e35701f 2630 djSP;
a0d0e21e
LW		 2631 if (result < 0)
2632 RETPUSHUNDEF;
2633 RETPUSHYES;
2634}
2635
2636PP(pp_fteowned)
2637{
2638 return pp_ftrowned(ARGS);
2639}
2640
2641PP(pp_ftrowned)
2642{
2643 I32 result = my_stat(ARGS);
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{
2654 I32 result = my_stat(ARGS);
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{
2665 I32 result = my_stat(ARGS);
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{
2675 I32 result = my_stat(ARGS);
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{
2685 I32 result = my_stat(ARGS);
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{
2695 I32 result = my_stat(ARGS);
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{
2705 I32 result = my_stat(ARGS);
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{
2716 I32 result = my_stat(ARGS);
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{
2727 I32 result = my_stat(ARGS);
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{
2738 I32 result = my_stat(ARGS);
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{
2749 I32 result = my_stat(ARGS);
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{
2760 I32 result = my_stat(ARGS);
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{
2771 I32 result = my_lstat(ARGS);
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
LW		 2783#ifdef S_ISUID
2784 I32 result = my_stat(ARGS);
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
LW		 2797#ifdef S_ISGID
2798 I32 result = my_stat(ARGS);
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
LW		 2811#ifdef S_ISVTX
2812 I32 result = my_stat(ARGS);
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)))
2898 DIE("-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
PM		 2921 if (ckWARN(WARN_UNOPENED))
2922 warner(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'))
22c35a8c 2941 warner(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{
2986 return pp_fttext(ARGS);
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
22c35a8c 3039 DIE(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
22c35a8c 3054 DIE(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
22c35a8c 3125 DIE(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
22c35a8c 3141 DIE(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)
3171static int
3172dooneliner(cmd, filename)
3173char *cmd;
3174char *filename;
3175{
1e422769 3176 char *save_filename = filename;
3177 char *cmdline;
3178 char *s;
760ac839 3179 PerlIO *myfp;
1e422769 3180 int anum = 1;
a0d0e21e 3181
1e422769 3182 New(666, cmdline, strlen(cmd) + (strlen(filename) * 2) + 10, char);
3183 strcpy(cmdline, cmd);
3184 strcat(cmdline, " ");
3185 for (s = cmdline + strlen(cmdline); *filename; ) {
a0d0e21e
LW		 3186 *s++ = '\\';
3187 *s++ = *filename++;
3188 }
3189 strcpy(s, " 2>&1");
6ad3d225 3190 myfp = PerlProc_popen(cmdline, "r");
1e422769 3191 Safefree(cmdline);
3192
a0d0e21e 3193 if (myfp) {
1e422769 3194 SV *tmpsv = sv_newmortal();
6b88bc9c 3195 /* Need to save/restore 'PL_rs' ?? */
760ac839 3196 s = sv_gets(tmpsv, myfp, 0);
6ad3d225 3197 (void)PerlProc_pclose(myfp);
a0d0e21e 3198 if (s != Nullch) {
1e422769 3199 int e;
3200 for (e = 1;
a0d0e21e 3201#ifdef HAS_SYS_ERRLIST
1e422769 3202 e <= sys_nerr
3203#endif
3204 ; e++)
3205 {
3206 /* you don't see this */
3207 char *errmsg =
3208#ifdef HAS_SYS_ERRLIST
3209 sys_errlist[e]
a0d0e21e 3210#else
1e422769 3211 strerror(e)
a0d0e21e 3212#endif
1e422769 3213 ;
3214 if (!errmsg)
3215 break;
3216 if (instr(s, errmsg)) {
3217 SETERRNO(e,0);
3218 return 0;
3219 }
a0d0e21e 3220 }
748a9306 3221 SETERRNO(0,0);
a0d0e21e
LW		 3222#ifndef EACCES
3223#define EACCES EPERM
3224#endif
1e422769 3225 if (instr(s, "cannot make"))
748a9306 3226 SETERRNO(EEXIST,RMS$_FEX);
1e422769 3227 else if (instr(s, "existing file"))
748a9306 3228 SETERRNO(EEXIST,RMS$_FEX);
1e422769 3229 else if (instr(s, "ile exists"))
748a9306 3230 SETERRNO(EEXIST,RMS$_FEX);
1e422769 3231 else if (instr(s, "non-exist"))
748a9306 3232 SETERRNO(ENOENT,RMS$_FNF);
1e422769 3233 else if (instr(s, "does not exist"))
748a9306 3234 SETERRNO(ENOENT,RMS$_FNF);
1e422769 3235 else if (instr(s, "not empty"))
748a9306 3236 SETERRNO(EBUSY,SS$_DEVOFFLINE);
1e422769 3237 else if (instr(s, "cannot access"))
748a9306 3238 SETERRNO(EACCES,RMS$_PRV);
a0d0e21e 3239 else
748a9306 3240 SETERRNO(EPERM,RMS$_PRV);
a0d0e21e
LW		 3241 return 0;
3242 }
3243 else { /* some mkdirs return no failure indication */
6b88bc9c 3244 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
911d147d 3245 if (PL_op->op_type == OP_RMDIR)
a0d0e21e
LW		 3246 anum = !anum;
3247 if (anum)
748a9306 3248 SETERRNO(0,0);
a0d0e21e 3249 else
748a9306 3250 SETERRNO(EACCES,RMS$_PRV); /* a guess */
a0d0e21e
LW		 3251 }
3252 return anum;
3253 }
3254 else
3255 return 0;
3256}
3257#endif
3258
3259PP(pp_mkdir)
3260{
4e35701f 3261 djSP; dTARGET;
a0d0e21e
LW		 3262 int mode = POPi;
3263#ifndef HAS_MKDIR
3264 int oldumask;
3265#endif
2d8e6c8d
GS		 3266 STRLEN n_a;
3267 char *tmps = SvPV(TOPs, n_a);
a0d0e21e
LW		 3268
3269 TAINT_PROPER("mkdir");
3270#ifdef HAS_MKDIR
6ad3d225 3271 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
a0d0e21e
LW		 3272#else
3273 SETi( dooneliner("mkdir", tmps) );
6ad3d225
GS		 3274 oldumask = PerlLIO_umask(0);
3275 PerlLIO_umask(oldumask);
3276 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
a0d0e21e
LW		 3277#endif
3278 RETURN;
3279}
3280
3281PP(pp_rmdir)
3282{
4e35701f 3283 djSP; dTARGET;
a0d0e21e 3284 char *tmps;
2d8e6c8d 3285 STRLEN n_a;
a0d0e21e 3286
2d8e6c8d 3287 tmps = POPpx;
a0d0e21e
LW		 3288 TAINT_PROPER("rmdir");
3289#ifdef HAS_RMDIR
6ad3d225 3290 XPUSHi( PerlDir_rmdir(tmps) >= 0 );
a0d0e21e
LW		 3291#else
3292 XPUSHi( dooneliner("rmdir", tmps) );
3293#endif
3294 RETURN;
3295}
3296
3297/* Directory calls. */
3298
3299PP(pp_open_dir)
3300{
4e35701f 3301 djSP;
a0d0e21e 3302#if defined(Direntry_t) && defined(HAS_READDIR)
2d8e6c8d
GS		 3303 STRLEN n_a;
3304 char *dirname = POPpx;
a0d0e21e
LW		 3305 GV *gv = (GV*)POPs;
3306 register IO *io = GvIOn(gv);
3307
3308 if (!io)
3309 goto nope;
3310
3311 if (IoDIRP(io))
6ad3d225
GS		 3312 PerlDir_close(IoDIRP(io));
3313 if (!(IoDIRP(io) = PerlDir_open(dirname)))
a0d0e21e
LW		 3314 goto nope;
3315
3316 RETPUSHYES;
3317nope:
3318 if (!errno)
748a9306 3319 SETERRNO(EBADF,RMS$_DIR);
a0d0e21e
LW		 3320 RETPUSHUNDEF;
3321#else
22c35a8c 3322 DIE(PL_no_dir_func, "opendir");
a0d0e21e
LW		 3323#endif
3324}
3325
3326PP(pp_readdir)
3327{
4e35701f 3328 djSP;
a0d0e21e
LW		 3329#if defined(Direntry_t) && defined(HAS_READDIR)
3330#ifndef I_DIRENT
3331 Direntry_t *readdir _((DIR *));
3332#endif
3333 register Direntry_t *dp;
3334 GV *gv = (GV*)POPs;
3335 register IO *io = GvIOn(gv);
fb73857a 3336 SV *sv;
a0d0e21e
LW		 3337
3338 if (!io || !IoDIRP(io))
3339 goto nope;
3340
3341 if (GIMME == G_ARRAY) {
3342 /*SUPPRESS 560*/
6ad3d225 3343 while (dp = (Direntry_t *)PerlDir_read(IoDIRP(io))) {
a0d0e21e 3344#ifdef DIRNAMLEN
79cb57f6 3345 sv = newSVpvn(dp->d_name, dp->d_namlen);
a0d0e21e 3346#else
fb73857a 3347 sv = newSVpv(dp->d_name, 0);
3348#endif
3349#ifndef INCOMPLETE_TAINTS
3350 SvTAINTED_on(sv);
a0d0e21e 3351#endif
fb73857a 3352 XPUSHs(sv_2mortal(sv));
a0d0e21e
LW		 3353 }
3354 }
3355 else {
6ad3d225 3356 if (!(dp = (Direntry_t *)PerlDir_read(IoDIRP(io))))
a0d0e21e
LW		 3357 goto nope;
3358#ifdef DIRNAMLEN
79cb57f6 3359 sv = newSVpvn(dp->d_name, dp->d_namlen);
a0d0e21e 3360#else
fb73857a 3361 sv = newSVpv(dp->d_name, 0);
a0d0e21e 3362#endif
fb73857a 3363#ifndef INCOMPLETE_TAINTS
3364 SvTAINTED_on(sv);
3365#endif
3366 XPUSHs(sv_2mortal(sv));
a0d0e21e
LW		 3367 }
3368 RETURN;
3369
3370nope:
3371 if (!errno)
748a9306 3372 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 3373 if (GIMME == G_ARRAY)
3374 RETURN;
3375 else
3376 RETPUSHUNDEF;
3377#else
22c35a8c 3378 DIE(PL_no_dir_func, "readdir");
a0d0e21e
LW		 3379#endif
3380}
3381
3382PP(pp_telldir)
3383{
4e35701f 3384 djSP; dTARGET;
a0d0e21e 3385#if defined(HAS_TELLDIR) || defined(telldir)
968dcd91
JH		 3386 /* XXX does _anyone_ need this? --AD 2/20/1998 */
3387 /* XXX netbsd still seemed to.
3388 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3389 --JHI 1999-Feb-02 */
3390# if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
a0d0e21e 3391 long telldir _((DIR *));
dfe9444c 3392# endif
a0d0e21e
LW		 3393 GV *gv = (GV*)POPs;
3394 register IO *io = GvIOn(gv);
3395
3396 if (!io || !IoDIRP(io))
3397 goto nope;
3398
6ad3d225 3399 PUSHi( PerlDir_tell(IoDIRP(io)) );
a0d0e21e
LW		 3400 RETURN;
3401nope:
3402 if (!errno)
748a9306 3403 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 3404 RETPUSHUNDEF;
3405#else
22c35a8c 3406 DIE(PL_no_dir_func, "telldir");
a0d0e21e
LW		 3407#endif
3408}
3409
3410PP(pp_seekdir)
3411{
4e35701f 3412 djSP;
a0d0e21e
LW		 3413#if defined(HAS_SEEKDIR) || defined(seekdir)
3414 long along = POPl;
3415 GV *gv = (GV*)POPs;
3416 register IO *io = GvIOn(gv);
3417
3418 if (!io || !IoDIRP(io))
3419 goto nope;
3420
6ad3d225 3421 (void)PerlDir_seek(IoDIRP(io), along);
a0d0e21e
LW		 3422
3423 RETPUSHYES;
3424nope:
3425 if (!errno)
748a9306 3426 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 3427 RETPUSHUNDEF;
3428#else
22c35a8c 3429 DIE(PL_no_dir_func, "seekdir");
a0d0e21e
LW		 3430#endif
3431}
3432
3433PP(pp_rewinddir)
3434{
4e35701f 3435 djSP;
a0d0e21e
LW		 3436#if defined(HAS_REWINDDIR) || defined(rewinddir)
3437 GV *gv = (GV*)POPs;
3438 register IO *io = GvIOn(gv);
3439
3440 if (!io || !IoDIRP(io))
3441 goto nope;
3442
6ad3d225 3443 (void)PerlDir_rewind(IoDIRP(io));
a0d0e21e
LW		 3444 RETPUSHYES;
3445nope:
3446 if (!errno)
748a9306 3447 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 3448 RETPUSHUNDEF;
3449#else
22c35a8c 3450 DIE(PL_no_dir_func, "rewinddir");
a0d0e21e
LW		 3451#endif
3452}
3453
3454PP(pp_closedir)
3455{
4e35701f 3456 djSP;
a0d0e21e
LW		 3457#if defined(Direntry_t) && defined(HAS_READDIR)
3458 GV *gv = (GV*)POPs;
3459 register IO *io = GvIOn(gv);
3460
3461 if (!io || !IoDIRP(io))
3462 goto nope;
3463
3464#ifdef VOID_CLOSEDIR
6ad3d225 3465 PerlDir_close(IoDIRP(io));
a0d0e21e 3466#else
6ad3d225 3467 if (PerlDir_close(IoDIRP(io)) < 0) {
748a9306 3468 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
a0d0e21e 3469 goto nope;
748a9306 3470 }
a0d0e21e
LW		 3471#endif
3472 IoDIRP(io) = 0;
3473
3474 RETPUSHYES;
3475nope:
3476 if (!errno)
748a9306 3477 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW		 3478 RETPUSHUNDEF;
3479#else
22c35a8c 3480 DIE(PL_no_dir_func, "closedir");
a0d0e21e
LW		 3481#endif
3482}
3483
3484/* Process control. */
3485
3486PP(pp_fork)
3487{
44a8e56a 3488#ifdef HAS_FORK
4e35701f 3489 djSP; dTARGET;
761237fe 3490 Pid_t childpid;
a0d0e21e
LW		 3491 GV *tmpgv;
3492
3493 EXTEND(SP, 1);
45bc9206 3494 PERL_FLUSHALL_FOR_CHILD;
a0d0e21e
LW		 3495 childpid = fork();
3496 if (childpid < 0)
3497 RETSETUNDEF;
3498 if (!childpid) {
3499 /*SUPPRESS 560*/
3500 if (tmpgv = gv_fetchpv("$", TRUE, SVt_PV))
1e422769 3501 sv_setiv(GvSV(tmpgv), (IV)getpid());
3280af22 3502 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
a0d0e21e
LW		 3503 }
3504 PUSHi(childpid);
3505 RETURN;
3506#else
22c35a8c 3507 DIE(PL_no_func, "Unsupported function fork");
a0d0e21e
LW		 3508#endif
3509}
3510
3511PP(pp_wait)
3512{
8736538c 3513#if !defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(CYGWIN32)
4e35701f 3514 djSP; dTARGET;
761237fe 3515 Pid_t childpid;
a0d0e21e 3516 int argflags;
a0d0e21e 3517
44a8e56a 3518 childpid = wait4pid(-1, &argflags, 0);
f86702cc 3519 STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
44a8e56a 3520 XPUSHi(childpid);
a0d0e21e
LW		 3521 RETURN;
3522#else
22c35a8c 3523 DIE(PL_no_func, "Unsupported function wait");
a0d0e21e
LW		 3524#endif
3525}
3526
3527PP(pp_waitpid)
3528{
8736538c 3529#if !defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(CYGWIN32)
4e35701f 3530 djSP; dTARGET;
761237fe 3531 Pid_t childpid;
a0d0e21e
LW		 3532 int optype;
3533 int argflags;
a0d0e21e 3534
a0d0e21e
LW		 3535 optype = POPi;
3536 childpid = TOPi;
3537 childpid = wait4pid(childpid, &argflags, optype);
f86702cc 3538 STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
44a8e56a 3539 SETi(childpid);
a0d0e21e
LW		 3540 RETURN;
3541#else
22c35a8c 3542 DIE(PL_no_func, "Unsupported function waitpid");
a0d0e21e
LW		 3543#endif
3544}
3545
3546PP(pp_system)
3547{
4e35701f 3548 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e 3549 I32 value;
761237fe 3550 Pid_t childpid;
a0d0e21e
LW		 3551 int result;
3552 int status;
ff68c719 3553 Sigsave_t ihand,qhand; /* place to save signals during system() */
2d8e6c8d 3554 STRLEN n_a;
a0d0e21e 3555
a0d0e21e 3556 if (SP - MARK == 1) {
3280af22 3557 if (PL_tainting) {
2d8e6c8d 3558 char *junk = SvPV(TOPs, n_a);
a0d0e21e
LW		 3559 TAINT_ENV();
3560 TAINT_PROPER("system");
3561 }
3562 }
45bc9206 3563 PERL_FLUSHALL_FOR_CHILD;
1e422769 3564#if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2)
a0d0e21e
LW		 3565 while ((childpid = vfork()) == -1) {
3566 if (errno != EAGAIN) {
3567 value = -1;
3568 SP = ORIGMARK;
3569 PUSHi(value);
3570 RETURN;
3571 }
3572 sleep(5);
3573 }
3574 if (childpid > 0) {
ff68c719 3575 rsignal_save(SIGINT, SIG_IGN, &ihand);
3576 rsignal_save(SIGQUIT, SIG_IGN, &qhand);
748a9306
LW		 3577 do {
3578 result = wait4pid(childpid, &status, 0);
3579 } while (result == -1 && errno == EINTR);
ff68c719 3580 (void)rsignal_restore(SIGINT, &ihand);
3581 (void)rsignal_restore(SIGQUIT, &qhand);
91e9c03f 3582 STATUS_NATIVE_SET(result == -1 ? -1 : status);
a0d0e21e
LW		 3583 do_execfree(); /* free any memory child malloced on vfork */
3584 SP = ORIGMARK;
ff0cee69 3585 PUSHi(STATUS_CURRENT);
a0d0e21e
LW		 3586 RETURN;
3587 }
533c011a 3588 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e
LW		 3589 SV *really = *++MARK;
3590 value = (I32)do_aexec(really, MARK, SP);
3591 }
3592 else if (SP - MARK != 1)
3593 value = (I32)do_aexec(Nullsv, MARK, SP);
3594 else {
2d8e6c8d 3595 value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
a0d0e21e 3596 }
6ad3d225 3597 PerlProc__exit(-1);
c3293030 3598#else /* ! FORK or VMS or OS/2 */
911d147d 3599 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e 3600 SV *really = *++MARK;
4e35701f 3601 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
a0d0e21e
LW		 3602 }
3603 else if (SP - MARK != 1)
4e35701f 3604 value = (I32)do_aspawn(Nullsv, (void **)MARK, (void **)SP);
a0d0e21e 3605 else {
2d8e6c8d 3606 value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
a0d0e21e 3607 }
f86702cc 3608 STATUS_NATIVE_SET(value);
a0d0e21e
LW		 3609 do_execfree();
3610 SP = ORIGMARK;
ff0cee69 3611 PUSHi(STATUS_CURRENT);
a0d0e21e
LW		 3612#endif /* !FORK or VMS */
3613 RETURN;
3614}
3615
3616PP(pp_exec)
3617{
4e35701f 3618 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e 3619 I32 value;
2d8e6c8d 3620 STRLEN n_a;
a0d0e21e 3621
45bc9206 3622 PERL_FLUSHALL_FOR_CHILD;
533c011a 3623 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e
LW		 3624 SV *really = *++MARK;
3625 value = (I32)do_aexec(really, MARK, SP);
3626 }
3627 else if (SP - MARK != 1)
3628#ifdef VMS
3629 value = (I32)vms_do_aexec(Nullsv, MARK, SP);
3630#else
092bebab
JH		 3631# ifdef __OPEN_VM
3632 {
3633 (void ) do_aspawn(Nullsv, MARK, SP);
3634 value = 0;
3635 }
3636# else
a0d0e21e 3637 value = (I32)do_aexec(Nullsv, MARK, SP);
092bebab 3638# endif
a0d0e21e
LW		 3639#endif
3640 else {
3280af22 3641 if (PL_tainting) {
2d8e6c8d 3642 char *junk = SvPV(*SP, n_a);
a0d0e21e
LW		 3643 TAINT_ENV();
3644 TAINT_PROPER("exec");
3645 }
3646#ifdef VMS
2d8e6c8d 3647 value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
a0d0e21e 3648#else
092bebab 3649# ifdef __OPEN_VM
2d8e6c8d 3650 (void) do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
092bebab
JH		 3651 value = 0;
3652# else
2d8e6c8d 3653 value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
092bebab 3654# endif
a0d0e21e
LW		 3655#endif
3656 }
3657 SP = ORIGMARK;
3658 PUSHi(value);
3659 RETURN;
3660}
3661
3662PP(pp_kill)
3663{
4e35701f 3664 djSP; dMARK; dTARGET;
a0d0e21e
LW		 3665 I32 value;
3666#ifdef HAS_KILL
533c011a 3667 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 3668 SP = MARK;
3669 PUSHi(value);
3670 RETURN;
3671#else
22c35a8c 3672 DIE(PL_no_func, "Unsupported function kill");
a0d0e21e
LW		 3673#endif
3674}
3675
3676PP(pp_getppid)
3677{
3678#ifdef HAS_GETPPID
4e35701f 3679 djSP; dTARGET;
a0d0e21e
LW		 3680 XPUSHi( getppid() );
3681 RETURN;
3682#else
22c35a8c 3683 DIE(PL_no_func, "getppid");
a0d0e21e
LW		 3684#endif
3685}
3686
3687PP(pp_getpgrp)
3688{
3689#ifdef HAS_GETPGRP
4e35701f 3690 djSP; dTARGET;
a0d0e21e
LW		 3691 int pid;
3692 I32 value;
3693
3694 if (MAXARG < 1)
3695 pid = 0;
3696 else
3697 pid = SvIVx(POPs);
c3293030
IZ		 3698#ifdef BSD_GETPGRP
3699 value = (I32)BSD_GETPGRP(pid);
a0d0e21e 3700#else
aa689395 3701 if (pid != 0 && pid != getpid())
a0d0e21e
LW		 3702 DIE("POSIX getpgrp can't take an argument");
3703 value = (I32)getpgrp();
3704#endif
3705 XPUSHi(value);
3706 RETURN;
3707#else
22c35a8c 3708 DIE(PL_no_func, "getpgrp()");
a0d0e21e
LW		 3709#endif
3710}
3711
3712PP(pp_setpgrp)
3713{
3714#ifdef HAS_SETPGRP
4e35701f 3715 djSP; dTARGET;
a0d0e21e
LW		 3716 int pgrp;
3717 int pid;
3718 if (MAXARG < 2) {
3719 pgrp = 0;
3720 pid = 0;
3721 }
3722 else {
3723 pgrp = POPi;
3724 pid = TOPi;
3725 }
3726
3727 TAINT_PROPER("setpgrp");
c3293030
IZ		 3728#ifdef BSD_SETPGRP
3729 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
a0d0e21e 3730#else
c90c0ff4 3731 if ((pgrp != 0 && pgrp != getpid()) || (pid != 0 && pid != getpid()))
a0d0e21e 3732 DIE("POSIX setpgrp can't take an argument");
a0d0e21e
LW		 3733 SETi( setpgrp() >= 0 );
3734#endif /* USE_BSDPGRP */
3735 RETURN;
3736#else
22c35a8c 3737 DIE(PL_no_func, "setpgrp()");
a0d0e21e
LW		 3738#endif
3739}
3740
3741PP(pp_getpriority)
3742{
4e35701f 3743 djSP; dTARGET;
a0d0e21e
LW		 3744 int which;
3745 int who;
3746#ifdef HAS_GETPRIORITY
3747 who = POPi;
3748 which = TOPi;
3749 SETi( getpriority(which, who) );
3750 RETURN;
3751#else
22c35a8c 3752 DIE(PL_no_func, "getpriority()");
a0d0e21e
LW		 3753#endif
3754}
3755
3756PP(pp_setpriority)
3757{
4e35701f 3758 djSP; dTARGET;
a0d0e21e
LW		 3759 int which;
3760 int who;
3761 int niceval;
3762#ifdef HAS_SETPRIORITY
3763 niceval = POPi;
3764 who = POPi;
3765 which = TOPi;
3766 TAINT_PROPER("setpriority");
3767 SETi( setpriority(which, who, niceval) >= 0 );
3768 RETURN;
3769#else
22c35a8c 3770 DIE(PL_no_func, "setpriority()");
a0d0e21e
LW		 3771#endif
3772}
3773
3774/* Time calls. */
3775
3776PP(pp_time)
3777{
4e35701f 3778 djSP; dTARGET;
cbdc8872 3779#ifdef BIG_TIME
3780 XPUSHn( time(Null(Time_t*)) );
3781#else
a0d0e21e 3782 XPUSHi( time(Null(Time_t*)) );
cbdc8872 3783#endif
a0d0e21e
LW		 3784 RETURN;
3785}
3786
cd52b7b2 3787/* XXX The POSIX name is CLK_TCK; it is to be preferred
3788 to HZ. Probably. For now, assume that if the system
3789 defines HZ, it does so correctly. (Will this break
3790 on VMS?)
3791 Probably we ought to use _sysconf(_SC_CLK_TCK), if
3792 it's supported. --AD 9/96.
3793*/
3794
a0d0e21e 3795#ifndef HZ
cd52b7b2 3796# ifdef CLK_TCK
3797# define HZ CLK_TCK
3798# else
3799# define HZ 60
3800# endif
a0d0e21e
LW		 3801#endif
3802
3803PP(pp_tms)
3804{
4e35701f 3805 djSP;
a0d0e21e 3806
55497cff 3807#ifndef HAS_TIMES
a0d0e21e
LW		 3808 DIE("times not implemented");
3809#else
3810 EXTEND(SP, 4);
3811
3812#ifndef VMS
3280af22 3813 (void)PerlProc_times(&PL_timesbuf);
a0d0e21e 3814#else
6b88bc9c 3815 (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
76e3520e
GS		 3816 /* struct tms, though same data */
3817 /* is returned. */
a0d0e21e
LW		 3818#endif
3819
3280af22 3820 PUSHs(sv_2mortal(newSVnv(((double)PL_timesbuf.tms_utime)/HZ)));
a0d0e21e 3821 if (GIMME == G_ARRAY) {
3280af22
NIS		 3822 PUSHs(sv_2mortal(newSVnv(((double)PL_timesbuf.tms_stime)/HZ)));
3823 PUSHs(sv_2mortal(newSVnv(((double)PL_timesbuf.tms_cutime)/HZ)));
3824 PUSHs(sv_2mortal(newSVnv(((double)PL_timesbuf.tms_cstime)/HZ)));
a0d0e21e
LW		 3825 }
3826 RETURN;
55497cff 3827#endif /* HAS_TIMES */
a0d0e21e
LW		 3828}
3829
3830PP(pp_localtime)
3831{
3832 return pp_gmtime(ARGS);
3833}
3834
3835PP(pp_gmtime)
3836{
4e35701f 3837 djSP;
a0d0e21e
LW		 3838 Time_t when;
3839 struct tm *tmbuf;
3840 static char *dayname[] = {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
3841 static char *monname[] = {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
3842 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
3843
3844 if (MAXARG < 1)
3845 (void)time(&when);
3846 else
cbdc8872 3847#ifdef BIG_TIME
3848 when = (Time_t)SvNVx(POPs);
3849#else
a0d0e21e 3850 when = (Time_t)SvIVx(POPs);
cbdc8872 3851#endif
a0d0e21e 3852
533c011a 3853 if (PL_op->op_type == OP_LOCALTIME)
a0d0e21e
LW		 3854 tmbuf = localtime(&when);
3855 else
3856 tmbuf = gmtime(&when);
3857
3858 EXTEND(SP, 9);
bbce6d69 3859 EXTEND_MORTAL(9);
a0d0e21e
LW		 3860 if (GIMME != G_ARRAY) {
3861 dTARGET;
46fc3d4c 3862 SV *tsv;
a0d0e21e
LW		 3863 if (!tmbuf)
3864 RETPUSHUNDEF;
46fc3d4c 3865 tsv = newSVpvf("%s %s %2d %02d:%02d:%02d %d",
3866 dayname[tmbuf->tm_wday],
3867 monname[tmbuf->tm_mon],
3868 tmbuf->tm_mday,
3869 tmbuf->tm_hour,
3870 tmbuf->tm_min,
3871 tmbuf->tm_sec,
3872 tmbuf->tm_year + 1900);
3873 PUSHs(sv_2mortal(tsv));
a0d0e21e
LW		 3874 }
3875 else if (tmbuf) {
3876 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_sec)));
3877 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_min)));
3878 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_hour)));
3879 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_mday)));
3880 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_mon)));
3881 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_year)));
3882 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_wday)));
3883 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_yday)));
3884 PUSHs(sv_2mortal(newSViv((I32)tmbuf->tm_isdst)));
3885 }
3886 RETURN;
3887}
3888
3889PP(pp_alarm)
3890{
4e35701f 3891 djSP; dTARGET;
a0d0e21e
LW		 3892 int anum;
3893#ifdef HAS_ALARM
3894 anum = POPi;
3895 anum = alarm((unsigned int)anum);
3896 EXTEND(SP, 1);
3897 if (anum < 0)
3898 RETPUSHUNDEF;
3899 PUSHi((I32)anum);
3900 RETURN;
3901#else
22c35a8c 3902 DIE(PL_no_func, "Unsupported function alarm");
a0d0e21e
LW		 3903#endif
3904}
3905
3906PP(pp_sleep)
3907{
4e35701f 3908 djSP; dTARGET;
a0d0e21e
LW		 3909 I32 duration;
3910 Time_t lasttime;
3911 Time_t when;
3912
3913 (void)time(&lasttime);
3914 if (MAXARG < 1)
76e3520e 3915 PerlProc_pause();
a0d0e21e
LW		 3916 else {
3917 duration = POPi;
76e3520e 3918 PerlProc_sleep((unsigned int)duration);
a0d0e21e
LW		 3919 }
3920 (void)time(&when);
3921 XPUSHi(when - lasttime);
3922 RETURN;
3923}
3924
3925/* Shared memory. */
3926
3927PP(pp_shmget)
3928{
3929 return pp_semget(ARGS);
3930}
3931
3932PP(pp_shmctl)
3933{
3934 return pp_semctl(ARGS);
3935}
3936
3937PP(pp_shmread)
3938{
3939 return pp_shmwrite(ARGS);
3940}
3941
3942PP(pp_shmwrite)
3943{
3944#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 3945 djSP; dMARK; dTARGET;
533c011a 3946 I32 value = (I32)(do_shmio(PL_op->op_type, MARK, SP) >= 0);
a0d0e21e
LW		 3947 SP = MARK;
3948 PUSHi(value);
3949 RETURN;
3950#else
748a9306 3951 return pp_semget(ARGS);
a0d0e21e
LW		 3952#endif
3953}
3954
3955/* Message passing. */
3956
3957PP(pp_msgget)
3958{
3959 return pp_semget(ARGS);
3960}
3961
3962PP(pp_msgctl)
3963{
3964 return pp_semctl(ARGS);
3965}
3966
3967PP(pp_msgsnd)
3968{
3969#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 3970 djSP; dMARK; dTARGET;
a0d0e21e
LW		 3971 I32 value = (I32)(do_msgsnd(MARK, SP) >= 0);
3972 SP = MARK;
3973 PUSHi(value);
3974 RETURN;
3975#else
748a9306 3976 return pp_semget(ARGS);
a0d0e21e
LW		 3977#endif
3978}
3979
3980PP(pp_msgrcv)
3981{
3982#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 3983 djSP; dMARK; dTARGET;
a0d0e21e
LW		 3984 I32 value = (I32)(do_msgrcv(MARK, SP) >= 0);
3985 SP = MARK;
3986 PUSHi(value);
3987 RETURN;
3988#else
748a9306 3989 return pp_semget(ARGS);
a0d0e21e
LW		 3990#endif
3991}
3992
3993/* Semaphores. */
3994
3995PP(pp_semget)
3996{
3997#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 3998 djSP; dMARK; dTARGET;
533c011a 3999 int anum = do_ipcget(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 4000 SP = MARK;
4001 if (anum == -1)
4002 RETPUSHUNDEF;
4003 PUSHi(anum);
4004 RETURN;
4005#else
4006 DIE("System V IPC is not implemented on this machine");
4007#endif
4008}
4009
4010PP(pp_semctl)
4011{
4012#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 4013 djSP; dMARK; dTARGET;
533c011a 4014 int anum = do_ipcctl(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 4015 SP = MARK;
4016 if (anum == -1)
4017 RETSETUNDEF;
4018 if (anum != 0) {
4019 PUSHi(anum);
4020 }
4021 else {
8903cb82 4022 PUSHp(zero_but_true, ZBTLEN);
a0d0e21e
LW		 4023 }
4024 RETURN;
4025#else
748a9306 4026 return pp_semget(ARGS);
a0d0e21e
LW		 4027#endif
4028}
4029
4030PP(pp_semop)
4031{
4032#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 4033 djSP; dMARK; dTARGET;
a0d0e21e
LW		 4034 I32 value = (I32)(do_semop(MARK, SP) >= 0);
4035 SP = MARK;
4036 PUSHi(value);
4037 RETURN;
4038#else
748a9306 4039 return pp_semget(ARGS);
a0d0e21e
LW		 4040#endif
4041}
4042
4043/* Get system info. */
4044
4045PP(pp_ghbyname)
4046{
693762b4 4047#ifdef HAS_GETHOSTBYNAME
a0d0e21e
LW		 4048 return pp_ghostent(ARGS);
4049#else
22c35a8c 4050 DIE(PL_no_sock_func, "gethostbyname");
a0d0e21e
LW		 4051#endif
4052}
4053
4054PP(pp_ghbyaddr)
4055{
693762b4 4056#ifdef HAS_GETHOSTBYADDR
a0d0e21e
LW		 4057 return pp_ghostent(ARGS);
4058#else
22c35a8c 4059 DIE(PL_no_sock_func, "gethostbyaddr");
a0d0e21e
LW		 4060#endif
4061}
4062
4063PP(pp_ghostent)
4064{
4e35701f 4065 djSP;
693762b4 4066#if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
533c011a 4067 I32 which = PL_op->op_type;
a0d0e21e
LW		 4068 register char **elem;
4069 register SV *sv;
dc45a647 4070#ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4599a1de
JH		 4071 struct hostent *PerlSock_gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4072 struct hostent *PerlSock_gethostbyname(Netdb_name_t);
6ad3d225 4073 struct hostent *PerlSock_gethostent(void);
a0d0e21e
LW		 4074#endif
4075 struct hostent *hent;
4076 unsigned long len;
2d8e6c8d 4077 STRLEN n_a;
a0d0e21e
LW		 4078
4079 EXTEND(SP, 10);
dc45a647
MB		 4080 if (which == OP_GHBYNAME)
4081#ifdef HAS_GETHOSTBYNAME
2d8e6c8d 4082 hent = PerlSock_gethostbyname(POPpx);
dc45a647 4083#else
22c35a8c 4084 DIE(PL_no_sock_func, "gethostbyname");
dc45a647 4085#endif
a0d0e21e 4086 else if (which == OP_GHBYADDR) {
dc45a647 4087#ifdef HAS_GETHOSTBYADDR
a0d0e21e 4088 int addrtype = POPi;
748a9306 4089 SV *addrsv = POPs;
a0d0e21e 4090 STRLEN addrlen;
4599a1de 4091 Netdb_host_t addr = (Netdb_host_t) SvPV(addrsv, addrlen);
a0d0e21e 4092
4599a1de 4093 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
dc45a647 4094#else
22c35a8c 4095 DIE(PL_no_sock_func, "gethostbyaddr");
dc45a647 4096#endif
a0d0e21e
LW		 4097 }
4098 else
4099#ifdef HAS_GETHOSTENT
6ad3d225 4100 hent = PerlSock_gethostent();
a0d0e21e 4101#else
22c35a8c 4102 DIE(PL_no_sock_func, "gethostent");
a0d0e21e
LW		 4103#endif
4104
4105#ifdef HOST_NOT_FOUND
4106 if (!hent)
f86702cc 4107 STATUS_NATIVE_SET(h_errno);
a0d0e21e
LW		 4108#endif
4109
4110 if (GIMME != G_ARRAY) {
4111 PUSHs(sv = sv_newmortal());
4112 if (hent) {
4113 if (which == OP_GHBYNAME) {
fd0af264 4114 if (hent->h_addr)
4115 sv_setpvn(sv, hent->h_addr, hent->h_length);
a0d0e21e
LW		 4116 }
4117 else
4118 sv_setpv(sv, (char*)hent->h_name);
4119 }
4120 RETURN;
4121 }
4122
4123 if (hent) {
3280af22 4124 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4125 sv_setpv(sv, (char*)hent->h_name);
3280af22 4126 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 4127 for (elem = hent->h_aliases; elem && *elem; elem++) {
4128 sv_catpv(sv, *elem);
4129 if (elem[1])
4130 sv_catpvn(sv, " ", 1);
4131 }
3280af22 4132 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4133 sv_setiv(sv, (IV)hent->h_addrtype);
3280af22 4134 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4135 len = hent->h_length;
1e422769 4136 sv_setiv(sv, (IV)len);
a0d0e21e
LW		 4137#ifdef h_addr
4138 for (elem = hent->h_addr_list; elem && *elem; elem++) {
3280af22 4139 XPUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 4140 sv_setpvn(sv, *elem, len);
4141 }
4142#else
6b88bc9c 4143 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
fd0af264 4144 if (hent->h_addr)
4145 sv_setpvn(sv, hent->h_addr, len);
a0d0e21e
LW		 4146#endif /* h_addr */
4147 }
4148 RETURN;
4149#else
22c35a8c 4150 DIE(PL_no_sock_func, "gethostent");
a0d0e21e
LW		 4151#endif
4152}
4153
4154PP(pp_gnbyname)
4155{
693762b4 4156#ifdef HAS_GETNETBYNAME
a0d0e21e
LW		 4157 return pp_gnetent(ARGS);
4158#else
22c35a8c 4159 DIE(PL_no_sock_func, "getnetbyname");
a0d0e21e
LW		 4160#endif
4161}
4162
4163PP(pp_gnbyaddr)
4164{
693762b4 4165#ifdef HAS_GETNETBYADDR
a0d0e21e
LW		 4166 return pp_gnetent(ARGS);
4167#else
22c35a8c 4168 DIE(PL_no_sock_func, "getnetbyaddr");
a0d0e21e
LW		 4169#endif
4170}
4171
4172PP(pp_gnetent)
4173{
4e35701f 4174 djSP;
693762b4 4175#if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
533c011a 4176 I32 which = PL_op->op_type;
a0d0e21e
LW		 4177 register char **elem;
4178 register SV *sv;
dc45a647
MB		 4179#ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4180 struct netent *PerlSock_getnetbyaddr(Netdb_net_t, int);
4181 struct netent *PerlSock_getnetbyname(Netdb_name_t);
4182 struct netent *PerlSock_getnetent(void);
8ac85365 4183#endif
a0d0e21e 4184 struct netent *nent;
2d8e6c8d 4185 STRLEN n_a;
a0d0e21e
LW		 4186
4187 if (which == OP_GNBYNAME)
dc45a647 4188#ifdef HAS_GETNETBYNAME
2d8e6c8d 4189 nent = PerlSock_getnetbyname(POPpx);
dc45a647 4190#else
22c35a8c 4191 DIE(PL_no_sock_func, "getnetbyname");
dc45a647 4192#endif
a0d0e21e 4193 else if (which == OP_GNBYADDR) {
dc45a647 4194#ifdef HAS_GETNETBYADDR
a0d0e21e 4195 int addrtype = POPi;
4599a1de 4196 Netdb_net_t addr = (Netdb_net_t) U_L(POPn);
76e3520e 4197 nent = PerlSock_getnetbyaddr(addr, addrtype);
dc45a647 4198#else
22c35a8c 4199 DIE(PL_no_sock_func, "getnetbyaddr");
dc45a647 4200#endif
a0d0e21e
LW		 4201 }
4202 else
dc45a647 4203#ifdef HAS_GETNETENT
76e3520e 4204 nent = PerlSock_getnetent();
dc45a647 4205#else
22c35a8c 4206 DIE(PL_no_sock_func, "getnetent");
dc45a647 4207#endif
a0d0e21e
LW		 4208
4209 EXTEND(SP, 4);
4210 if (GIMME != G_ARRAY) {
4211 PUSHs(sv = sv_newmortal());
4212 if (nent) {
4213 if (which == OP_GNBYNAME)
1e422769 4214 sv_setiv(sv, (IV)nent->n_net);
a0d0e21e
LW		 4215 else
4216 sv_setpv(sv, nent->n_name);
4217 }
4218 RETURN;
4219 }
4220
4221 if (nent) {
3280af22 4222 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4223 sv_setpv(sv, nent->n_name);
3280af22 4224 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 4225 for (elem = nent->n_aliases; elem && *elem; elem++) {
a0d0e21e
LW		 4226 sv_catpv(sv, *elem);
4227 if (elem[1])
4228 sv_catpvn(sv, " ", 1);
4229 }
3280af22 4230 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4231 sv_setiv(sv, (IV)nent->n_addrtype);
3280af22 4232 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4233 sv_setiv(sv, (IV)nent->n_net);
a0d0e21e
LW		 4234 }
4235
4236 RETURN;
4237#else
22c35a8c 4238 DIE(PL_no_sock_func, "getnetent");
a0d0e21e
LW		 4239#endif
4240}
4241
4242PP(pp_gpbyname)
4243{
693762b4 4244#ifdef HAS_GETPROTOBYNAME
a0d0e21e
LW		 4245 return pp_gprotoent(ARGS);
4246#else
22c35a8c 4247 DIE(PL_no_sock_func, "getprotobyname");
a0d0e21e
LW		 4248#endif
4249}
4250
4251PP(pp_gpbynumber)
4252{
693762b4 4253#ifdef HAS_GETPROTOBYNUMBER
a0d0e21e
LW		 4254 return pp_gprotoent(ARGS);
4255#else
22c35a8c 4256 DIE(PL_no_sock_func, "getprotobynumber");
a0d0e21e
LW		 4257#endif
4258}
4259
4260PP(pp_gprotoent)
4261{
4e35701f 4262 djSP;
693762b4 4263#if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
533c011a 4264 I32 which = PL_op->op_type;
a0d0e21e 4265 register char **elem;
8ac85365 4266 register SV *sv;
dc45a647 4267#ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4599a1de 4268 struct protoent *PerlSock_getprotobyname(Netdb_name_t);
6ad3d225
GS		 4269 struct protoent *PerlSock_getprotobynumber(int);
4270 struct protoent *PerlSock_getprotoent(void);
8ac85365 4271#endif
a0d0e21e 4272 struct protoent *pent;
2d8e6c8d 4273 STRLEN n_a;
a0d0e21e
LW		 4274
4275 if (which == OP_GPBYNAME)
e5c9fcd0 4276#ifdef HAS_GETPROTOBYNAME
2d8e6c8d 4277 pent = PerlSock_getprotobyname(POPpx);
e5c9fcd0 4278#else
22c35a8c 4279 DIE(PL_no_sock_func, "getprotobyname");
e5c9fcd0 4280#endif
a0d0e21e 4281 else if (which == OP_GPBYNUMBER)
e5c9fcd0 4282#ifdef HAS_GETPROTOBYNUMBER
6ad3d225 4283 pent = PerlSock_getprotobynumber(POPi);
e5c9fcd0 4284#else
22c35a8c 4285 DIE(PL_no_sock_func, "getprotobynumber");
e5c9fcd0 4286#endif
a0d0e21e 4287 else
e5c9fcd0 4288#ifdef HAS_GETPROTOENT
6ad3d225 4289 pent = PerlSock_getprotoent();
e5c9fcd0 4290#else
22c35a8c 4291 DIE(PL_no_sock_func, "getprotoent");
e5c9fcd0 4292#endif
a0d0e21e
LW		 4293
4294 EXTEND(SP, 3);
4295 if (GIMME != G_ARRAY) {
4296 PUSHs(sv = sv_newmortal());
4297 if (pent) {
4298 if (which == OP_GPBYNAME)
1e422769 4299 sv_setiv(sv, (IV)pent->p_proto);
a0d0e21e
LW		 4300 else
4301 sv_setpv(sv, pent->p_name);
4302 }
4303 RETURN;
4304 }
4305
4306 if (pent) {
3280af22 4307 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4308 sv_setpv(sv, pent->p_name);
3280af22 4309 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 4310 for (elem = pent->p_aliases; elem && *elem; elem++) {
a0d0e21e
LW		 4311 sv_catpv(sv, *elem);
4312 if (elem[1])
4313 sv_catpvn(sv, " ", 1);
4314 }
3280af22 4315 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4316 sv_setiv(sv, (IV)pent->p_proto);
a0d0e21e
LW		 4317 }
4318
4319 RETURN;
4320#else
22c35a8c 4321 DIE(PL_no_sock_func, "getprotoent");
a0d0e21e
LW		 4322#endif
4323}
4324
4325PP(pp_gsbyname)
4326{
9ec75305 4327#ifdef HAS_GETSERVBYNAME
a0d0e21e
LW		 4328 return pp_gservent(ARGS);
4329#else
22c35a8c 4330 DIE(PL_no_sock_func, "getservbyname");
a0d0e21e
LW		 4331#endif
4332}
4333
4334PP(pp_gsbyport)
4335{
9ec75305 4336#ifdef HAS_GETSERVBYPORT
a0d0e21e
LW		 4337 return pp_gservent(ARGS);
4338#else
22c35a8c 4339 DIE(PL_no_sock_func, "getservbyport");
a0d0e21e
LW		 4340#endif
4341}
4342
4343PP(pp_gservent)
4344{
4e35701f 4345 djSP;
693762b4 4346#if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
533c011a 4347 I32 which = PL_op->op_type;
a0d0e21e
LW		 4348 register char **elem;
4349 register SV *sv;
dc45a647 4350#ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4599a1de
JH		 4351 struct servent *PerlSock_getservbyname(Netdb_name_t, Netdb_name_t);
4352 struct servent *PerlSock_getservbyport(int, Netdb_name_t);
6ad3d225 4353 struct servent *PerlSock_getservent(void);
8ac85365 4354#endif
a0d0e21e 4355 struct servent *sent;
2d8e6c8d 4356 STRLEN n_a;
a0d0e21e
LW		 4357
4358 if (which == OP_GSBYNAME) {
dc45a647 4359#ifdef HAS_GETSERVBYNAME
2d8e6c8d
GS		 4360 char *proto = POPpx;
4361 char *name = POPpx;
a0d0e21e
LW		 4362
4363 if (proto && !*proto)
4364 proto = Nullch;
4365
6ad3d225 4366 sent = PerlSock_getservbyname(name, proto);
dc45a647 4367#else
22c35a8c 4368 DIE(PL_no_sock_func, "getservbyname");
dc45a647 4369#endif
a0d0e21e
LW		 4370 }
4371 else if (which == OP_GSBYPORT) {
dc45a647 4372#ifdef HAS_GETSERVBYPORT
2d8e6c8d 4373 char *proto = POPpx;
36477c24 4374 unsigned short port = POPu;
a0d0e21e 4375
36477c24 4376#ifdef HAS_HTONS
6ad3d225 4377 port = PerlSock_htons(port);
36477c24 4378#endif
6ad3d225 4379 sent = PerlSock_getservbyport(port, proto);
dc45a647 4380#else
22c35a8c 4381 DIE(PL_no_sock_func, "getservbyport");
dc45a647 4382#endif
a0d0e21e
LW		 4383 }
4384 else
e5c9fcd0 4385#ifdef HAS_GETSERVENT
6ad3d225 4386 sent = PerlSock_getservent();
e5c9fcd0 4387#else
22c35a8c 4388 DIE(PL_no_sock_func, "getservent");
e5c9fcd0 4389#endif
a0d0e21e
LW		 4390
4391 EXTEND(SP, 4);
4392 if (GIMME != G_ARRAY) {
4393 PUSHs(sv = sv_newmortal());
4394 if (sent) {
4395 if (which == OP_GSBYNAME) {
4396#ifdef HAS_NTOHS
6ad3d225 4397 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
a0d0e21e 4398#else
1e422769 4399 sv_setiv(sv, (IV)(sent->s_port));
a0d0e21e
LW		 4400#endif
4401 }
4402 else
4403 sv_setpv(sv, sent->s_name);
4404 }
4405 RETURN;
4406 }
4407
4408 if (sent) {
3280af22 4409 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4410 sv_setpv(sv, sent->s_name);
3280af22 4411 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 4412 for (elem = sent->s_aliases; elem && *elem; elem++) {
a0d0e21e
LW		 4413 sv_catpv(sv, *elem);
4414 if (elem[1])
4415 sv_catpvn(sv, " ", 1);
4416 }
3280af22 4417 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4418#ifdef HAS_NTOHS
76e3520e 4419 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
a0d0e21e 4420#else
1e422769 4421 sv_setiv(sv, (IV)(sent->s_port));
a0d0e21e 4422#endif
3280af22 4423 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 4424 sv_setpv(sv, sent->s_proto);
4425 }
4426
4427 RETURN;
4428#else
22c35a8c 4429 DIE(PL_no_sock_func, "getservent");
a0d0e21e
LW		 4430#endif
4431}
4432
4433PP(pp_shostent)
4434{
4e35701f 4435 djSP;
693762b4 4436#ifdef HAS_SETHOSTENT
76e3520e 4437 PerlSock_sethostent(TOPi);
a0d0e21e
LW		 4438 RETSETYES;
4439#else
22c35a8c 4440 DIE(PL_no_sock_func, "sethostent");
a0d0e21e
LW		 4441#endif
4442}
4443
4444PP(pp_snetent)
4445{
4e35701f 4446 djSP;
693762b4 4447#ifdef HAS_SETNETENT
76e3520e 4448 PerlSock_setnetent(TOPi);
a0d0e21e
LW		 4449 RETSETYES;
4450#else
22c35a8c 4451 DIE(PL_no_sock_func, "setnetent");
a0d0e21e
LW		 4452#endif
4453}
4454
4455PP(pp_sprotoent)
4456{
4e35701f 4457 djSP;
693762b4 4458#ifdef HAS_SETPROTOENT
76e3520e 4459 PerlSock_setprotoent(TOPi);
a0d0e21e
LW		 4460 RETSETYES;
4461#else
22c35a8c 4462 DIE(PL_no_sock_func, "setprotoent");
a0d0e21e
LW		 4463#endif
4464}
4465
4466PP(pp_sservent)
4467{
4e35701f 4468 djSP;
693762b4 4469#ifdef HAS_SETSERVENT
76e3520e 4470 PerlSock_setservent(TOPi);
a0d0e21e
LW		 4471 RETSETYES;
4472#else
22c35a8c 4473 DIE(PL_no_sock_func, "setservent");
a0d0e21e
LW		 4474#endif
4475}
4476
4477PP(pp_ehostent)
4478{
4e35701f 4479 djSP;
693762b4 4480#ifdef HAS_ENDHOSTENT
76e3520e 4481 PerlSock_endhostent();
924508f0 4482 EXTEND(SP,1);
a0d0e21e
LW		 4483 RETPUSHYES;
4484#else
22c35a8c 4485 DIE(PL_no_sock_func, "endhostent");
a0d0e21e
LW		 4486#endif
4487}
4488
4489PP(pp_enetent)
4490{
4e35701f 4491 djSP;
693762b4 4492#ifdef HAS_ENDNETENT
76e3520e 4493 PerlSock_endnetent();
924508f0 4494 EXTEND(SP,1);
a0d0e21e
LW		 4495 RETPUSHYES;
4496#else
22c35a8c 4497 DIE(PL_no_sock_func, "endnetent");
a0d0e21e
LW		 4498#endif
4499}
4500
4501PP(pp_eprotoent)
4502{
4e35701f 4503 djSP;
693762b4 4504#ifdef HAS_ENDPROTOENT
76e3520e 4505 PerlSock_endprotoent();
924508f0 4506 EXTEND(SP,1);
a0d0e21e
LW		 4507 RETPUSHYES;
4508#else
22c35a8c 4509 DIE(PL_no_sock_func, "endprotoent");
a0d0e21e
LW		 4510#endif
4511}
4512
4513PP(pp_eservent)
4514{
4e35701f 4515 djSP;
693762b4 4516#ifdef HAS_ENDSERVENT
76e3520e 4517 PerlSock_endservent();
924508f0 4518 EXTEND(SP,1);
a0d0e21e
LW		 4519 RETPUSHYES;
4520#else
22c35a8c 4521 DIE(PL_no_sock_func, "endservent");
a0d0e21e
LW		 4522#endif
4523}
4524
4525PP(pp_gpwnam)
4526{
4527#ifdef HAS_PASSWD
4528 return pp_gpwent(ARGS);
4529#else
22c35a8c 4530 DIE(PL_no_func, "getpwnam");
a0d0e21e
LW		 4531#endif
4532}
4533
4534PP(pp_gpwuid)
4535{
4536#ifdef HAS_PASSWD
4537 return pp_gpwent(ARGS);
4538#else
22c35a8c 4539 DIE(PL_no_func, "getpwuid");
a0d0e21e
LW		 4540#endif
4541}
4542
4543PP(pp_gpwent)
4544{
4e35701f 4545 djSP;
28e8609d 4546#if defined(HAS_PASSWD) && defined(HAS_GETPWENT)
533c011a 4547 I32 which = PL_op->op_type;
a0d0e21e
LW		 4548 register SV *sv;
4549 struct passwd *pwent;
2d8e6c8d 4550 STRLEN n_a;
a0d0e21e
LW		 4551
4552 if (which == OP_GPWNAM)
2d8e6c8d 4553 pwent = getpwnam(POPpx);
a0d0e21e
LW		 4554 else if (which == OP_GPWUID)
4555 pwent = getpwuid(POPi);
4556 else
4557 pwent = (struct passwd *)getpwent();
4558
4559 EXTEND(SP, 10);
4560 if (GIMME != G_ARRAY) {
4561 PUSHs(sv = sv_newmortal());
4562 if (pwent) {
4563 if (which == OP_GPWNAM)
1e422769 4564 sv_setiv(sv, (IV)pwent->pw_uid);
a0d0e21e
LW		 4565 else
4566 sv_setpv(sv, pwent->pw_name);
4567 }
4568 RETURN;
4569 }
4570
4571 if (pwent) {
3280af22 4572 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4573 sv_setpv(sv, pwent->pw_name);
6ee623d5 4574
3280af22 4575 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
28e8609d 4576#ifdef PWPASSWD
a0d0e21e 4577 sv_setpv(sv, pwent->pw_passwd);
28e8609d 4578#endif
6ee623d5 4579
3280af22 4580 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4581 sv_setiv(sv, (IV)pwent->pw_uid);
6ee623d5 4582
3280af22 4583 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4584 sv_setiv(sv, (IV)pwent->pw_gid);
6ee623d5
GS		 4585
4586 /* pw_change, pw_quota, and pw_age are mutually exclusive. */
3280af22 4587 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4588#ifdef PWCHANGE
1e422769 4589 sv_setiv(sv, (IV)pwent->pw_change);
a0d0e21e 4590#else
6ee623d5 4591# ifdef PWQUOTA
1e422769 4592 sv_setiv(sv, (IV)pwent->pw_quota);
6ee623d5
GS		 4593# else
4594# ifdef PWAGE
a0d0e21e 4595 sv_setpv(sv, pwent->pw_age);
6ee623d5
GS		 4596# endif
4597# endif
a0d0e21e 4598#endif
6ee623d5
GS		 4599
4600 /* pw_class and pw_comment are mutually exclusive. */
3280af22 4601 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 4602#ifdef PWCLASS
4603 sv_setpv(sv, pwent->pw_class);
4604#else
6ee623d5 4605# ifdef PWCOMMENT
a0d0e21e 4606 sv_setpv(sv, pwent->pw_comment);
6ee623d5 4607# endif
a0d0e21e 4608#endif
6ee623d5 4609
3280af22 4610 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
6ee623d5 4611#ifdef PWGECOS
a0d0e21e 4612 sv_setpv(sv, pwent->pw_gecos);
6ee623d5 4613#endif
fb73857a 4614#ifndef INCOMPLETE_TAINTS
d2719217 4615 /* pw_gecos is tainted because user himself can diddle with it. */
fb73857a 4616 SvTAINTED_on(sv);
4617#endif
6ee623d5 4618
3280af22 4619 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4620 sv_setpv(sv, pwent->pw_dir);
6ee623d5 4621
3280af22 4622 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4623 sv_setpv(sv, pwent->pw_shell);
6ee623d5 4624
a0d0e21e 4625#ifdef PWEXPIRE
6b88bc9c 4626 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4627 sv_setiv(sv, (IV)pwent->pw_expire);
a0d0e21e
LW		 4628#endif
4629 }
4630 RETURN;
4631#else
22c35a8c 4632 DIE(PL_no_func, "getpwent");
a0d0e21e
LW		 4633#endif
4634}
4635
4636PP(pp_spwent)
4637{
4e35701f 4638 djSP;
28e8609d 4639#if defined(HAS_PASSWD) && defined(HAS_SETPWENT) && !defined(CYGWIN32)
a0d0e21e
LW		 4640 setpwent();
4641 RETPUSHYES;
4642#else
22c35a8c 4643 DIE(PL_no_func, "setpwent");
a0d0e21e
LW		 4644#endif
4645}
4646
4647PP(pp_epwent)
4648{
4e35701f 4649 djSP;
28e8609d 4650#if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
a0d0e21e
LW		 4651 endpwent();
4652 RETPUSHYES;
4653#else
22c35a8c 4654 DIE(PL_no_func, "endpwent");
a0d0e21e
LW		 4655#endif
4656}
4657
4658PP(pp_ggrnam)
4659{
4660#ifdef HAS_GROUP
4661 return pp_ggrent(ARGS);
4662#else
22c35a8c 4663 DIE(PL_no_func, "getgrnam");
a0d0e21e
LW		 4664#endif
4665}
4666
4667PP(pp_ggrgid)
4668{
4669#ifdef HAS_GROUP
4670 return pp_ggrent(ARGS);
4671#else
22c35a8c 4672 DIE(PL_no_func, "getgrgid");
a0d0e21e
LW		 4673#endif
4674}
4675
4676PP(pp_ggrent)
4677{
4e35701f 4678 djSP;
28e8609d 4679#if defined(HAS_GROUP) && defined(HAS_GETGRENT)
533c011a 4680 I32 which = PL_op->op_type;
a0d0e21e
LW		 4681 register char **elem;
4682 register SV *sv;
4683 struct group *grent;
2d8e6c8d 4684 STRLEN n_a;
a0d0e21e
LW		 4685
4686 if (which == OP_GGRNAM)
2d8e6c8d 4687 grent = (struct group *)getgrnam(POPpx);
a0d0e21e
LW		 4688 else if (which == OP_GGRGID)
4689 grent = (struct group *)getgrgid(POPi);
4690 else
4691 grent = (struct group *)getgrent();
4692
4693 EXTEND(SP, 4);
4694 if (GIMME != G_ARRAY) {
4695 PUSHs(sv = sv_newmortal());
4696 if (grent) {
4697 if (which == OP_GGRNAM)
1e422769 4698 sv_setiv(sv, (IV)grent->gr_gid);
a0d0e21e
LW		 4699 else
4700 sv_setpv(sv, grent->gr_name);
4701 }
4702 RETURN;
4703 }
4704
4705 if (grent) {
3280af22 4706 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4707 sv_setpv(sv, grent->gr_name);
28e8609d 4708
3280af22 4709 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
28e8609d 4710#ifdef GRPASSWD
a0d0e21e 4711 sv_setpv(sv, grent->gr_passwd);
28e8609d
JH		 4712#endif
4713
3280af22 4714 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4715 sv_setiv(sv, (IV)grent->gr_gid);
28e8609d 4716
3280af22 4717 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 4718 for (elem = grent->gr_mem; elem && *elem; elem++) {
a0d0e21e
LW		 4719 sv_catpv(sv, *elem);
4720 if (elem[1])
4721 sv_catpvn(sv, " ", 1);
4722 }
4723 }
4724
4725 RETURN;
4726#else
22c35a8c 4727 DIE(PL_no_func, "getgrent");
a0d0e21e
LW		 4728#endif
4729}
4730
4731PP(pp_sgrent)
4732{
4e35701f 4733 djSP;
28e8609d 4734#if defined(HAS_GROUP) && defined(HAS_SETGRENT)
a0d0e21e
LW		 4735 setgrent();
4736 RETPUSHYES;
4737#else
22c35a8c 4738 DIE(PL_no_func, "setgrent");
a0d0e21e
LW		 4739#endif
4740}
4741
4742PP(pp_egrent)
4743{
4e35701f 4744 djSP;
28e8609d 4745#if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
a0d0e21e
LW		 4746 endgrent();
4747 RETPUSHYES;
4748#else
22c35a8c 4749 DIE(PL_no_func, "endgrent");
a0d0e21e
LW		 4750#endif
4751}
4752
4753PP(pp_getlogin)
4754{
4e35701f 4755 djSP; dTARGET;
a0d0e21e
LW		 4756#ifdef HAS_GETLOGIN
4757 char *tmps;
4758 EXTEND(SP, 1);
76e3520e 4759 if (!(tmps = PerlProc_getlogin()))
a0d0e21e
LW		 4760 RETPUSHUNDEF;
4761 PUSHp(tmps, strlen(tmps));
4762 RETURN;
4763#else
22c35a8c 4764 DIE(PL_no_func, "getlogin");
a0d0e21e
LW		 4765#endif
4766}
4767
4768/* Miscellaneous. */
4769
4770PP(pp_syscall)
4771{
d2719217 4772#ifdef HAS_SYSCALL
4e35701f 4773 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 4774 register I32 items = SP - MARK;
4775 unsigned long a[20];
4776 register I32 i = 0;
4777 I32 retval = -1;
748a9306 4778 MAGIC *mg;
2d8e6c8d 4779 STRLEN n_a;
a0d0e21e 4780
3280af22 4781 if (PL_tainting) {
a0d0e21e 4782 while (++MARK <= SP) {
bbce6d69 4783 if (SvTAINTED(*MARK)) {
4784 TAINT;
4785 break;
4786 }
a0d0e21e
LW		 4787 }
4788 MARK = ORIGMARK;
4789 TAINT_PROPER("syscall");
4790 }
4791
4792 /* This probably won't work on machines where sizeof(long) != sizeof(int)
4793 * or where sizeof(long) != sizeof(char*). But such machines will
4794 * not likely have syscall implemented either, so who cares?
4795 */
4796 while (++MARK <= SP) {
4797 if (SvNIOK(*MARK) || !i)
4798 a[i++] = SvIV(*MARK);
3280af22 4799 else if (*MARK == &PL_sv_undef)
748a9306
LW		 4800 a[i++] = 0;
4801 else
2d8e6c8d 4802 a[i++] = (unsigned long)SvPV_force(*MARK, n_a);
a0d0e21e
LW		 4803 if (i > 15)
4804 break;
4805 }
4806 switch (items) {
4807 default:
4808 DIE("Too many args to syscall");
4809 case 0:
4810 DIE("Too few args to syscall");
4811 case 1:
4812 retval = syscall(a[0]);
4813 break;
4814 case 2:
4815 retval = syscall(a[0],a[1]);
4816 break;
4817 case 3:
4818 retval = syscall(a[0],a[1],a[2]);
4819 break;
4820 case 4:
4821 retval = syscall(a[0],a[1],a[2],a[3]);
4822 break;
4823 case 5:
4824 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
4825 break;
4826 case 6:
4827 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
4828 break;
4829 case 7:
4830 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
4831 break;
4832 case 8:
4833 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
4834 break;
4835#ifdef atarist
4836 case 9:
4837 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
4838 break;
4839 case 10:
4840 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
4841 break;
4842 case 11:
4843 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
4844 a[10]);
4845 break;
4846 case 12:
4847 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
4848 a[10],a[11]);
4849 break;
4850 case 13:
4851 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
4852 a[10],a[11],a[12]);
4853 break;
4854 case 14:
4855 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
4856 a[10],a[11],a[12],a[13]);
4857 break;
4858#endif /* atarist */
4859 }
4860 SP = ORIGMARK;
4861 PUSHi(retval);
4862 RETURN;
4863#else
22c35a8c 4864 DIE(PL_no_func, "syscall");
a0d0e21e
LW		 4865#endif
4866}
4867
ff68c719 4868#ifdef FCNTL_EMULATE_FLOCK
4869
4870/* XXX Emulate flock() with fcntl().
4871 What's really needed is a good file locking module.
4872*/
4873
4874static int
8ac85365 4875fcntl_emulate_flock(int fd, int operation)
ff68c719 4876{
4877 struct flock flock;
4878
4879 switch (operation & ~LOCK_NB) {
4880 case LOCK_SH:
4881 flock.l_type = F_RDLCK;
4882 break;
4883 case LOCK_EX:
4884 flock.l_type = F_WRLCK;
4885 break;
4886 case LOCK_UN:
4887 flock.l_type = F_UNLCK;
4888 break;
4889 default:
4890 errno = EINVAL;
4891 return -1;
4892 }
4893 flock.l_whence = SEEK_SET;
4894 flock.l_start = flock.l_len = 0L;
4895
4896 return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
4897}
4898
4899#endif /* FCNTL_EMULATE_FLOCK */
4900
4901#ifdef LOCKF_EMULATE_FLOCK
16d20bd9
AD		 4902
4903/* XXX Emulate flock() with lockf(). This is just to increase
4904 portability of scripts. The calls are not completely
4905 interchangeable. What's really needed is a good file
4906 locking module.
4907*/
4908
76c32331 4909/* The lockf() constants might have been defined in <unistd.h>.
4910 Unfortunately, <unistd.h> causes troubles on some mixed
4911 (BSD/POSIX) systems, such as SunOS 4.1.3.
16d20bd9
AD		 4912
4913 Further, the lockf() constants aren't POSIX, so they might not be
4914 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
4915 just stick in the SVID values and be done with it. Sigh.
4916*/
4917
4918# ifndef F_ULOCK
4919# define F_ULOCK 0 /* Unlock a previously locked region */
4920# endif
4921# ifndef F_LOCK
4922# define F_LOCK 1 /* Lock a region for exclusive use */
4923# endif
4924# ifndef F_TLOCK
4925# define F_TLOCK 2 /* Test and lock a region for exclusive use */
4926# endif
4927# ifndef F_TEST
4928# define F_TEST 3 /* Test a region for other processes locks */
4929# endif
4930
55497cff 4931static int
16d20bd9
AD		 4932lockf_emulate_flock (fd, operation)
4933int fd;
4934int operation;
4935{
4936 int i;
84902520
TB		 4937 int save_errno;
4938 Off_t pos;
4939
4940 /* flock locks entire file so for lockf we need to do the same */
4941 save_errno = errno;
6ad3d225 4942 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
84902520 4943 if (pos > 0) /* is seekable and needs to be repositioned */
6ad3d225 4944 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
08b714dd 4945 pos = -1; /* seek failed, so don't seek back afterwards */
84902520
TB		 4946 errno = save_errno;
4947
16d20bd9
AD		 4948 switch (operation) {
4949
4950 /* LOCK_SH - get a shared lock */
4951 case LOCK_SH:
4952 /* LOCK_EX - get an exclusive lock */
4953 case LOCK_EX:
4954 i = lockf (fd, F_LOCK, 0);
4955 break;
4956
4957 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
4958 case LOCK_SH|LOCK_NB:
4959 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
4960 case LOCK_EX|LOCK_NB:
4961 i = lockf (fd, F_TLOCK, 0);
4962 if (i == -1)
4963 if ((errno == EAGAIN) || (errno == EACCES))
4964 errno = EWOULDBLOCK;
4965 break;
4966
ff68c719 4967 /* LOCK_UN - unlock (non-blocking is a no-op) */
16d20bd9 4968 case LOCK_UN:
ff68c719 4969 case LOCK_UN|LOCK_NB:
16d20bd9
AD		 4970 i = lockf (fd, F_ULOCK, 0);
4971 break;
4972
4973 /* Default - can't decipher operation */
4974 default:
4975 i = -1;
4976 errno = EINVAL;
4977 break;
4978 }
84902520
TB		 4979
4980 if (pos > 0) /* need to restore position of the handle */
6ad3d225 4981 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
84902520 4982
16d20bd9
AD		 4983 return (i);
4984}
ff68c719 4985
4986#endif /* LOCKF_EMULATE_FLOCK */
Unnamed repository; edit this file 'description' to name the repository.