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