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