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