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