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