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
Implement crlf layer - not ready for merge.
[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 }
304 else if (O_BINARY != O_TEXT) {
305 type = ":crlf";
306 }
307 if (type && *type)
308 PerlIO_apply_layers(aTHX_ fp,mode,type);
309
54310121 310 if (gimme == G_VOID) {
96827780
MB		 311 char tmpbuf[256];
312 while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0)
54310121 313 /*SUPPRESS 530*/
314 ;
315 }
316 else if (gimme == G_SCALAR) {
aa689395 317 sv_setpv(TARG, ""); /* note that this preserves previous buffer */
a0d0e21e
LW		 318 while (sv_gets(TARG, fp, SvCUR(TARG)) != Nullch)
319 /*SUPPRESS 530*/
320 ;
321 XPUSHs(TARG);
aa689395 322 SvTAINTED_on(TARG);
a0d0e21e
LW		 323 }
324 else {
325 SV *sv;
326
327 for (;;) {
8d6dde3e 328 sv = NEWSV(56, 79);
a0d0e21e
LW		 329 if (sv_gets(sv, fp, 0) == Nullch) {
330 SvREFCNT_dec(sv);
331 break;
332 }
333 XPUSHs(sv_2mortal(sv));
334 if (SvLEN(sv) - SvCUR(sv) > 20) {
335 SvLEN_set(sv, SvCUR(sv)+1);
336 Renew(SvPVX(sv), SvLEN(sv), char);
337 }
aa689395 338 SvTAINTED_on(sv);
a0d0e21e
LW		 339 }
340 }
6ad3d225 341 STATUS_NATIVE_SET(PerlProc_pclose(fp));
aa689395 342 TAINT; /* "I believe that this is not gratuitous!" */
a0d0e21e
LW		 343 }
344 else {
f86702cc 345 STATUS_NATIVE_SET(-1);
54310121 346 if (gimme == G_SCALAR)
a0d0e21e
LW		 347 RETPUSHUNDEF;
348 }
349
350 RETURN;
351}
352
353PP(pp_glob)
354{
355 OP *result;
f5284f61
IZ		 356 tryAMAGICunTARGET(iter, -1);
357
71686f12
GS		 358 /* Note that we only ever get here if File::Glob fails to load
359 * without at the same time croaking, for some reason, or if
360 * perl was built with PERL_EXTERNAL_GLOB */
361
a0d0e21e 362 ENTER;
a0d0e21e 363
c90c0ff4 364#ifndef VMS
3280af22 365 if (PL_tainting) {
7bac28a0 366 /*
367 * The external globbing program may use things we can't control,
368 * so for security reasons we must assume the worst.
369 */
370 TAINT;
22c35a8c 371 taint_proper(PL_no_security, "glob");
7bac28a0 372 }
c90c0ff4 373#endif /* !VMS */
7bac28a0 374
3280af22
NIS		 375 SAVESPTR(PL_last_in_gv); /* We don't want this to be permanent. */
376 PL_last_in_gv = (GV*)*PL_stack_sp--;
a0d0e21e 377
3280af22 378 SAVESPTR(PL_rs); /* This is not permanent, either. */
79cb57f6 379 PL_rs = sv_2mortal(newSVpvn("\000", 1));
c07a80fd 380#ifndef DOSISH
381#ifndef CSH
6b88bc9c 382 *SvPVX(PL_rs) = '\n';
a0d0e21e 383#endif /* !CSH */
55497cff 384#endif /* !DOSISH */
c07a80fd 385
a0d0e21e
LW		 386 result = do_readline();
387 LEAVE;
388 return result;
389}
390
15e52e56 391#if 0 /* XXX never used! */
a0d0e21e
LW		 392PP(pp_indread)
393{
2d8e6c8d
GS		 394 STRLEN n_a;
395 PL_last_in_gv = gv_fetchpv(SvPVx(GvSV((GV*)(*PL_stack_sp--)), n_a), TRUE,SVt_PVIO);
a0d0e21e
LW		 396 return do_readline();
397}
15e52e56 398#endif
a0d0e21e
LW		 399
400PP(pp_rcatline)
401{
146174a9 402 PL_last_in_gv = cGVOP_gv;
a0d0e21e
LW		 403 return do_readline();
404}
405
406PP(pp_warn)
407{
4e35701f 408 djSP; dMARK;
06bf62c7 409 SV *tmpsv;
a0d0e21e 410 char *tmps;
06bf62c7 411 STRLEN len;
a0d0e21e
LW		 412 if (SP - MARK != 1) {
413 dTARGET;
3280af22 414 do_join(TARG, &PL_sv_no, MARK, SP);
06bf62c7 415 tmpsv = TARG;
a0d0e21e
LW		 416 SP = MARK + 1;
417 }
418 else {
06bf62c7 419 tmpsv = TOPs;
a0d0e21e 420 }
06bf62c7
GS		 421 tmps = SvPV(tmpsv, len);
422 if (!tmps || !len) {
4e6ea2c3
GS		 423 SV *error = ERRSV;
424 (void)SvUPGRADE(error, SVt_PV);
425 if (SvPOK(error) && SvCUR(error))
426 sv_catpv(error, "\t...caught");
06bf62c7
GS		 427 tmpsv = error;
428 tmps = SvPV(tmpsv, len);
a0d0e21e 429 }
06bf62c7
GS		 430 if (!tmps || !len)
431 tmpsv = sv_2mortal(newSVpvn("Warning: something's wrong", 26));
432
cb50131a 433 Perl_warn(aTHX_ "%"SVf, tmpsv);
a0d0e21e
LW		 434 RETSETYES;
435}
436
437PP(pp_die)
438{
4e35701f 439 djSP; dMARK;
a0d0e21e 440 char *tmps;
06bf62c7
GS		 441 SV *tmpsv;
442 STRLEN len;
443 bool multiarg = 0;
a0d0e21e
LW		 444 if (SP - MARK != 1) {
445 dTARGET;
3280af22 446 do_join(TARG, &PL_sv_no, MARK, SP);
06bf62c7
GS		 447 tmpsv = TARG;
448 tmps = SvPV(tmpsv, len);
449 multiarg = 1;
a0d0e21e
LW		 450 SP = MARK + 1;
451 }
452 else {
4e6ea2c3 453 tmpsv = TOPs;
06bf62c7 454 tmps = SvROK(tmpsv) ? Nullch : SvPV(tmpsv, len);
a0d0e21e 455 }
06bf62c7 456 if (!tmps || !len) {
4e6ea2c3
GS		 457 SV *error = ERRSV;
458 (void)SvUPGRADE(error, SVt_PV);
06bf62c7
GS		 459 if (multiarg ? SvROK(error) : SvROK(tmpsv)) {
460 if (!multiarg)
4e6ea2c3 461 SvSetSV(error,tmpsv);
06bf62c7 462 else if (sv_isobject(error)) {
05423cc9
GS		 463 HV *stash = SvSTASH(SvRV(error));
464 GV *gv = gv_fetchmethod(stash, "PROPAGATE");
465 if (gv) {
146174a9 466 SV *file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0));
b448e4fe 467 SV *line = sv_2mortal(newSVuv(CopLINE(PL_curcop)));
05423cc9
GS		 468 EXTEND(SP, 3);
469 PUSHMARK(SP);
470 PUSHs(error);
471 PUSHs(file);
472 PUSHs(line);
473 PUTBACK;
864dbfa3
GS		 474 call_sv((SV*)GvCV(gv),
475 G_SCALAR|G_EVAL|G_KEEPERR);
3280af22 476 sv_setsv(error,*PL_stack_sp--);
05423cc9
GS		 477 }
478 }
cea2e8a9 479 DIE(aTHX_ Nullch);
4e6ea2c3
GS		 480 }
481 else {
482 if (SvPOK(error) && SvCUR(error))
483 sv_catpv(error, "\t...propagated");
06bf62c7
GS		 484 tmpsv = error;
485 tmps = SvPV(tmpsv, len);
4e6ea2c3 486 }
a0d0e21e 487 }
06bf62c7
GS		 488 if (!tmps || !len)
489 tmpsv = sv_2mortal(newSVpvn("Died", 4));
490
cb50131a 491 DIE(aTHX_ "%"SVf, tmpsv);
a0d0e21e
LW		 492}
493
494/* I/O. */
495
496PP(pp_open)
497{
4e35701f 498 djSP; dTARGET;
a0d0e21e
LW		 499 GV *gv;
500 SV *sv;
6aa016ca 501 SV *name = Nullsv;
6170680b 502 I32 have_name = 0;
a0d0e21e
LW		 503 char *tmps;
504 STRLEN len;
4592e6ca 505 MAGIC *mg;
a0d0e21e 506
6170680b
IZ		 507 if (MAXARG > 2) {
508 name = POPs;
509 have_name = 1;
510 }
a0d0e21e
LW		 511 if (MAXARG > 1)
512 sv = POPs;
5f05dabc 513 if (!isGV(TOPs))
cea2e8a9 514 DIE(aTHX_ PL_no_usym, "filehandle");
5f05dabc 515 if (MAXARG <= 1)
516 sv = GvSV(TOPs);
a0d0e21e 517 gv = (GV*)POPs;
5f05dabc 518 if (!isGV(gv))
cea2e8a9 519 DIE(aTHX_ PL_no_usym, "filehandle");
36477c24 520 if (GvIOp(gv))
521 IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
853846ea 522
155aba94 523 if ((mg = SvTIED_mg((SV*)gv, 'q'))) {
4592e6ca
NIS		 524 PUSHMARK(SP);
525 XPUSHs(SvTIED_obj((SV*)gv, mg));
526 XPUSHs(sv);
6170680b
IZ		 527 if (have_name)
528 XPUSHs(name);
4592e6ca
NIS		 529 PUTBACK;
530 ENTER;
864dbfa3 531 call_method("OPEN", G_SCALAR);
4592e6ca
NIS		 532 LEAVE;
533 SPAGAIN;
534 RETURN;
535 }
536
a0d0e21e 537 tmps = SvPV(sv, len);
6170680b 538 if (do_open9(gv, tmps, len, FALSE, O_RDONLY, 0, Nullfp, name, have_name))
3280af22
NIS		 539 PUSHi( (I32)PL_forkprocess );
540 else if (PL_forkprocess == 0) /* we are a new child */
a0d0e21e
LW		 541 PUSHi(0);
542 else
543 RETPUSHUNDEF;
544 RETURN;
545}
546
547PP(pp_close)
548{
4e35701f 549 djSP;
a0d0e21e 550 GV *gv;
1d603a67 551 MAGIC *mg;
a0d0e21e
LW		 552
553 if (MAXARG == 0)
3280af22 554 gv = PL_defoutgv;
a0d0e21e
LW		 555 else
556 gv = (GV*)POPs;
1d603a67 557
155aba94 558 if ((mg = SvTIED_mg((SV*)gv, 'q'))) {
1d603a67 559 PUSHMARK(SP);
33c27489 560 XPUSHs(SvTIED_obj((SV*)gv, mg));
1d603a67
GB		 561 PUTBACK;
562 ENTER;
864dbfa3 563 call_method("CLOSE", G_SCALAR);
1d603a67
GB		 564 LEAVE;
565 SPAGAIN;
566 RETURN;
567 }
a0d0e21e 568 EXTEND(SP, 1);
54310121 569 PUSHs(boolSV(do_close(gv, TRUE)));
a0d0e21e
LW		 570 RETURN;
571}
572
573PP(pp_pipe_op)
574{
4e35701f 575 djSP;
a0d0e21e
LW		 576#ifdef HAS_PIPE
577 GV *rgv;
578 GV *wgv;
579 register IO *rstio;
580 register IO *wstio;
581 int fd[2];
582
583 wgv = (GV*)POPs;
584 rgv = (GV*)POPs;
585
586 if (!rgv || !wgv)
587 goto badexit;
588
4633a7c4 589 if (SvTYPE(rgv) != SVt_PVGV || SvTYPE(wgv) != SVt_PVGV)
cea2e8a9 590 DIE(aTHX_ PL_no_usym, "filehandle");
a0d0e21e
LW		 591 rstio = GvIOn(rgv);
592 wstio = GvIOn(wgv);
593
594 if (IoIFP(rstio))
595 do_close(rgv, FALSE);
596 if (IoIFP(wstio))
597 do_close(wgv, FALSE);
598
6ad3d225 599 if (PerlProc_pipe(fd) < 0)
a0d0e21e
LW		 600 goto badexit;
601
760ac839
LW		 602 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r");
603 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w");
a0d0e21e 604 IoIFP(wstio) = IoOFP(wstio);
50952442
JH		 605 IoTYPE(rstio) = IoTYPE_RDONLY;
606 IoTYPE(wstio) = IoTYPE_WRONLY;
a0d0e21e
LW		 607
608 if (!IoIFP(rstio) || !IoOFP(wstio)) {
760ac839 609 if (IoIFP(rstio)) PerlIO_close(IoIFP(rstio));
6ad3d225 610 else PerlLIO_close(fd[0]);
760ac839 611 if (IoOFP(wstio)) PerlIO_close(IoOFP(wstio));
6ad3d225 612 else PerlLIO_close(fd[1]);
a0d0e21e
LW		 613 goto badexit;
614 }
4771b018
GS		 615#if defined(HAS_FCNTL) && defined(F_SETFD)
616 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
617 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
618#endif
a0d0e21e
LW		 619 RETPUSHYES;
620
621badexit:
622 RETPUSHUNDEF;
623#else
cea2e8a9 624 DIE(aTHX_ PL_no_func, "pipe");
a0d0e21e
LW		 625#endif
626}
627
628PP(pp_fileno)
629{
4e35701f 630 djSP; dTARGET;
a0d0e21e
LW		 631 GV *gv;
632 IO *io;
760ac839 633 PerlIO *fp;
4592e6ca
NIS		 634 MAGIC *mg;
635
a0d0e21e
LW		 636 if (MAXARG < 1)
637 RETPUSHUNDEF;
638 gv = (GV*)POPs;
4592e6ca
NIS		 639
640 if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
641 PUSHMARK(SP);
642 XPUSHs(SvTIED_obj((SV*)gv, mg));
643 PUTBACK;
644 ENTER;
864dbfa3 645 call_method("FILENO", G_SCALAR);
4592e6ca
NIS		 646 LEAVE;
647 SPAGAIN;
648 RETURN;
649 }
650
a0d0e21e
LW		 651 if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io)))
652 RETPUSHUNDEF;
760ac839 653 PUSHi(PerlIO_fileno(fp));
a0d0e21e
LW		 654 RETURN;
655}
656
657PP(pp_umask)
658{
4e35701f 659 djSP; dTARGET;
761237fe 660 Mode_t anum;
a0d0e21e
LW		 661
662#ifdef HAS_UMASK
663 if (MAXARG < 1) {
6ad3d225
GS		 664 anum = PerlLIO_umask(0);
665 (void)PerlLIO_umask(anum);
a0d0e21e
LW		 666 }
667 else
6ad3d225 668 anum = PerlLIO_umask(POPi);
a0d0e21e
LW		 669 TAINT_PROPER("umask");
670 XPUSHi(anum);
671#else
eec2d3df
GS		 672 /* Only DIE if trying to restrict permissions on `user' (self).
673 * Otherwise it's harmless and more useful to just return undef
674 * since 'group' and 'other' concepts probably don't exist here. */
675 if (MAXARG >= 1 && (POPi & 0700))
cea2e8a9 676 DIE(aTHX_ "umask not implemented");
6b88bc9c 677 XPUSHs(&PL_sv_undef);
a0d0e21e
LW		 678#endif
679 RETURN;
680}
681
682PP(pp_binmode)
683{
4e35701f 684 djSP;
a0d0e21e
LW		 685 GV *gv;
686 IO *io;
760ac839 687 PerlIO *fp;
4592e6ca 688 MAGIC *mg;
16fe6d59 689 SV *discp = Nullsv;
a0d0e21e
LW		 690
691 if (MAXARG < 1)
692 RETPUSHUNDEF;
16fe6d59
GS		 693 if (MAXARG > 1)
694 discp = POPs;
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
301e8125 715 if (do_binmode(fp,IoTYPE(io),mode_from_discipline(discp)))
a0d0e21e
LW		 716 RETPUSHYES;
717 else
718 RETPUSHUNDEF;
a0d0e21e
LW		 719}
720
721PP(pp_tie)
722{
4e35701f 723 djSP;
e336de0d 724 dMARK;
a0d0e21e
LW		 725 SV *varsv;
726 HV* stash;
727 GV *gv;
a0d0e21e 728 SV *sv;
3280af22 729 I32 markoff = MARK - PL_stack_base;
a0d0e21e 730 char *methname;
6b05c17a 731 int how = 'P';
e336de0d 732 U32 items;
2d8e6c8d 733 STRLEN n_a;
a0d0e21e 734
e336de0d 735 varsv = *++MARK;
6b05c17a
NIS		 736 switch(SvTYPE(varsv)) {
737 case SVt_PVHV:
738 methname = "TIEHASH";
739 break;
740 case SVt_PVAV:
741 methname = "TIEARRAY";
742 break;
743 case SVt_PVGV:
744 methname = "TIEHANDLE";
745 how = 'q';
746 break;
747 default:
748 methname = "TIESCALAR";
749 how = 'q';
750 break;
751 }
e336de0d
GS		 752 items = SP - MARK++;
753 if (sv_isobject(*MARK)) {
6b05c17a 754 ENTER;
e788e7d3 755 PUSHSTACKi(PERLSI_MAGIC);
e336de0d
GS		 756 PUSHMARK(SP);
757 EXTEND(SP,items);
758 while (items--)
759 PUSHs(*MARK++);
760 PUTBACK;
864dbfa3 761 call_method(methname, G_SCALAR);
301e8125 762 }
6b05c17a 763 else {
864dbfa3 764 /* Not clear why we don't call call_method here too.
6b05c17a
NIS		 765 * perhaps to get different error message ?
766 */
e336de0d 767 stash = gv_stashsv(*MARK, FALSE);
6b05c17a 768 if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
cea2e8a9 769 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%s\"",
301e8125 770 methname, SvPV(*MARK,n_a));
6b05c17a
NIS		 771 }
772 ENTER;
e788e7d3 773 PUSHSTACKi(PERLSI_MAGIC);
e336de0d
GS		 774 PUSHMARK(SP);
775 EXTEND(SP,items);
776 while (items--)
777 PUSHs(*MARK++);
778 PUTBACK;
864dbfa3 779 call_sv((SV*)GvCV(gv), G_SCALAR);
6b05c17a 780 }
a0d0e21e
LW		 781 SPAGAIN;
782
783 sv = TOPs;
d3acc0f7 784 POPSTACK;
a0d0e21e 785 if (sv_isobject(sv)) {
33c27489 786 sv_unmagic(varsv, how);
ae21d580
JH		 787 /* Croak if a self-tie on an aggregate is attempted. */
788 if (varsv == SvRV(sv) &&
789 (SvTYPE(sv) == SVt_PVAV ||
790 SvTYPE(sv) == SVt_PVHV))
791 Perl_croak(aTHX_
792 "Self-ties of arrays and hashes are not supported");
68a4a7e4 793 sv_magic(varsv, sv, how, Nullch, 0);
a0d0e21e
LW		 794 }
795 LEAVE;
3280af22 796 SP = PL_stack_base + markoff;
a0d0e21e
LW		 797 PUSHs(sv);
798 RETURN;
799}
800
801PP(pp_untie)
802{
4e35701f 803 djSP;
33c27489
GS		 804 SV *sv = POPs;
805 char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) ? 'P' : 'q';
55497cff 806
cbdc8872 807 MAGIC * mg ;
155aba94 808 if ((mg = SvTIED_mg(sv, how))) {
a29a5827
NIS		 809 SV *obj = SvRV(mg->mg_obj);
810 GV *gv;
811 CV *cv = NULL;
a29a5827
NIS		 812 if ((gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE)) &&
813 isGV(gv) && (cv = GvCV(gv))) {
814 PUSHMARK(SP);
815 XPUSHs(SvTIED_obj((SV*)gv, mg));
301e8125 816 XPUSHs(sv_2mortal(newSViv(SvREFCNT(obj)-1)));
a29a5827
NIS		 817 PUTBACK;
818 ENTER;
819 call_sv((SV *)cv, G_VOID);
820 LEAVE;
821 SPAGAIN;
cbdc8872 822 }
301e8125
NIS		 823 else if (ckWARN(WARN_UNTIE)) {
824 if (mg && SvREFCNT(obj) > 1)
825 Perl_warner(aTHX_ WARN_UNTIE,
826 "untie attempted while %"UVuf" inner references still exist",
827 (UV)SvREFCNT(obj) - 1 ) ;
828 }
cbdc8872 829 }
33c27489 830 sv_unmagic(sv, how);
55497cff 831 RETPUSHYES;
a0d0e21e
LW		 832}
833
c07a80fd 834PP(pp_tied)
835{
4e35701f 836 djSP;
33c27489
GS		 837 SV *sv = POPs;
838 char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) ? 'P' : 'q';
839 MAGIC *mg;
c07a80fd 840
155aba94 841 if ((mg = SvTIED_mg(sv, how))) {
33c27489
GS		 842 SV *osv = SvTIED_obj(sv, mg);
843 if (osv == mg->mg_obj)
844 osv = sv_mortalcopy(osv);
845 PUSHs(osv);
846 RETURN;
c07a80fd 847 }
c07a80fd 848 RETPUSHUNDEF;
849}
850
a0d0e21e
LW		 851PP(pp_dbmopen)
852{
4e35701f 853 djSP;
a0d0e21e
LW		 854 HV *hv;
855 dPOPPOPssrl;
856 HV* stash;
857 GV *gv;
a0d0e21e
LW		 858 SV *sv;
859
860 hv = (HV*)POPs;
861
3280af22 862 sv = sv_mortalcopy(&PL_sv_no);
a0d0e21e
LW		 863 sv_setpv(sv, "AnyDBM_File");
864 stash = gv_stashsv(sv, FALSE);
8ebc5c01 865 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
a0d0e21e 866 PUTBACK;
864dbfa3 867 require_pv("AnyDBM_File.pm");
a0d0e21e 868 SPAGAIN;
8ebc5c01 869 if (!(gv = gv_fetchmethod(stash, "TIEHASH")))
cea2e8a9 870 DIE(aTHX_ "No dbm on this machine");
a0d0e21e
LW		 871 }
872
57d3b86d 873 ENTER;
924508f0 874 PUSHMARK(SP);
6b05c17a 875
924508f0 876 EXTEND(SP, 5);
a0d0e21e
LW		 877 PUSHs(sv);
878 PUSHs(left);
879 if (SvIV(right))
b448e4fe 880 PUSHs(sv_2mortal(newSVuv(O_RDWR|O_CREAT)));
a0d0e21e 881 else
b448e4fe 882 PUSHs(sv_2mortal(newSVuv(O_RDWR)));
a0d0e21e 883 PUSHs(right);
57d3b86d 884 PUTBACK;
864dbfa3 885 call_sv((SV*)GvCV(gv), G_SCALAR);
a0d0e21e
LW		 886 SPAGAIN;
887
888 if (!sv_isobject(TOPs)) {
924508f0
GS		 889 SP--;
890 PUSHMARK(SP);
a0d0e21e
LW		 891 PUSHs(sv);
892 PUSHs(left);
b448e4fe 893 PUSHs(sv_2mortal(newSVuv(O_RDONLY)));
a0d0e21e 894 PUSHs(right);
a0d0e21e 895 PUTBACK;
864dbfa3 896 call_sv((SV*)GvCV(gv), G_SCALAR);
a0d0e21e
LW		 897 SPAGAIN;
898 }
899
6b05c17a 900 if (sv_isobject(TOPs)) {
301e8125 901 sv_unmagic((SV *) hv, 'P');
a0d0e21e 902 sv_magic((SV*)hv, TOPs, 'P', Nullch, 0);
6b05c17a 903 }
a0d0e21e
LW		 904 LEAVE;
905 RETURN;
906}
907
908PP(pp_dbmclose)
909{
cea2e8a9 910 return pp_untie();
a0d0e21e
LW		 911}
912
913PP(pp_sselect)
914{
4e35701f 915 djSP; dTARGET;
a0d0e21e
LW		 916#ifdef HAS_SELECT
917 register I32 i;
918 register I32 j;
919 register char *s;
920 register SV *sv;
65202027 921 NV value;
a0d0e21e
LW		 922 I32 maxlen = 0;
923 I32 nfound;
924 struct timeval timebuf;
925 struct timeval *tbuf = &timebuf;
926 I32 growsize;
927 char *fd_sets[4];
2d8e6c8d 928 STRLEN n_a;
a0d0e21e
LW		 929#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
930 I32 masksize;
931 I32 offset;
932 I32 k;
933
934# if BYTEORDER & 0xf0000
935# define ORDERBYTE (0x88888888 - BYTEORDER)
936# else
937# define ORDERBYTE (0x4444 - BYTEORDER)
938# endif
939
940#endif
941
942 SP -= 4;
943 for (i = 1; i <= 3; i++) {
944 if (!SvPOK(SP[i]))
945 continue;
946 j = SvCUR(SP[i]);
947 if (maxlen < j)
948 maxlen = j;
949 }
950
5ff3f7a4 951/* little endians can use vecs directly */
a0d0e21e 952#if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
5ff3f7a4 953# if SELECT_MIN_BITS > 1
f2da832e
JH		 954 /* If SELECT_MIN_BITS is greater than one we most probably will want
955 * to align the sizes with SELECT_MIN_BITS/8 because for example
956 * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
f556e5b9 957 * UNIX, Solaris, NeXT, Darwin) the smallest quantum select() operates
8f1f23e8 958 * on (sets/tests/clears bits) is 32 bits. */
f2da832e 959 growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
5ff3f7a4 960# else
4633a7c4 961 growsize = sizeof(fd_set);
5ff3f7a4
GS		 962# endif
963# else
964# ifdef NFDBITS
a0d0e21e 965
5ff3f7a4
GS		 966# ifndef NBBY
967# define NBBY 8
968# endif
a0d0e21e
LW		 969
970 masksize = NFDBITS / NBBY;
5ff3f7a4 971# else
a0d0e21e 972 masksize = sizeof(long); /* documented int, everyone seems to use long */
5ff3f7a4 973# endif
a0d0e21e
LW		 974 growsize = maxlen + (masksize - (maxlen % masksize));
975 Zero(&fd_sets[0], 4, char*);
976#endif
977
978 sv = SP[4];
979 if (SvOK(sv)) {
980 value = SvNV(sv);
981 if (value < 0.0)
982 value = 0.0;
983 timebuf.tv_sec = (long)value;
65202027 984 value -= (NV)timebuf.tv_sec;
a0d0e21e
LW		 985 timebuf.tv_usec = (long)(value * 1000000.0);
986 }
987 else
988 tbuf = Null(struct timeval*);
989
990 for (i = 1; i <= 3; i++) {
991 sv = SP[i];
992 if (!SvOK(sv)) {
993 fd_sets[i] = 0;
994 continue;
995 }
996 else if (!SvPOK(sv))
2d8e6c8d 997 SvPV_force(sv,n_a); /* force string conversion */
a0d0e21e
LW		 998 j = SvLEN(sv);
999 if (j < growsize) {
1000 Sv_Grow(sv, growsize);
a0d0e21e 1001 }
c07a80fd 1002 j = SvCUR(sv);
1003 s = SvPVX(sv) + j;
1004 while (++j <= growsize) {
1005 *s++ = '\0';
1006 }
1007
a0d0e21e
LW		 1008#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1009 s = SvPVX(sv);
1010 New(403, fd_sets[i], growsize, char);
1011 for (offset = 0; offset < growsize; offset += masksize) {
1012 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1013 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1014 }
1015#else
1016 fd_sets[i] = SvPVX(sv);
1017#endif
1018 }
1019
6ad3d225 1020 nfound = PerlSock_select(
a0d0e21e
LW		 1021 maxlen * 8,
1022 (Select_fd_set_t) fd_sets[1],
1023 (Select_fd_set_t) fd_sets[2],
1024 (Select_fd_set_t) fd_sets[3],
1025 tbuf);
1026 for (i = 1; i <= 3; i++) {
1027 if (fd_sets[i]) {
1028 sv = SP[i];
1029#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1030 s = SvPVX(sv);
1031 for (offset = 0; offset < growsize; offset += masksize) {
1032 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1033 s[(k % masksize) + offset] = fd_sets[i][j+offset];
1034 }
1035 Safefree(fd_sets[i]);
1036#endif
1037 SvSETMAGIC(sv);
1038 }
1039 }
1040
1041 PUSHi(nfound);
1042 if (GIMME == G_ARRAY && tbuf) {
65202027
DS		 1043 value = (NV)(timebuf.tv_sec) +
1044 (NV)(timebuf.tv_usec) / 1000000.0;
3280af22 1045 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 1046 sv_setnv(sv, value);
1047 }
1048 RETURN;
1049#else
cea2e8a9 1050 DIE(aTHX_ "select not implemented");
a0d0e21e
LW		 1051#endif
1052}
1053
4633a7c4 1054void
864dbfa3 1055Perl_setdefout(pTHX_ GV *gv)
4633a7c4 1056{
11343788 1057 dTHR;
4633a7c4
LW		 1058 if (gv)
1059 (void)SvREFCNT_inc(gv);
3280af22
NIS		 1060 if (PL_defoutgv)
1061 SvREFCNT_dec(PL_defoutgv);
1062 PL_defoutgv = gv;
4633a7c4
LW		 1063}
1064
a0d0e21e
LW		 1065PP(pp_select)
1066{
4e35701f 1067 djSP; dTARGET;
4633a7c4
LW		 1068 GV *newdefout, *egv;
1069 HV *hv;
1070
533c011a 1071 newdefout = (PL_op->op_private > 0) ? ((GV *) POPs) : (GV *) NULL;
4633a7c4 1072
3280af22 1073 egv = GvEGV(PL_defoutgv);
4633a7c4 1074 if (!egv)
3280af22 1075 egv = PL_defoutgv;
4633a7c4
LW		 1076 hv = GvSTASH(egv);
1077 if (! hv)
3280af22 1078 XPUSHs(&PL_sv_undef);
4633a7c4 1079 else {
cbdc8872 1080 GV **gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
f86702cc 1081 if (gvp && *gvp == egv) {
f7aaccc2 1082 gv_efullname4(TARG, PL_defoutgv, Nullch, TRUE);
f86702cc 1083 XPUSHTARG;
1084 }
1085 else {
1086 XPUSHs(sv_2mortal(newRV((SV*)egv)));
1087 }
4633a7c4
LW		 1088 }
1089
1090 if (newdefout) {
ded8aa31
GS		 1091 if (!GvIO(newdefout))
1092 gv_IOadd(newdefout);
4633a7c4
LW		 1093 setdefout(newdefout);
1094 }
1095
a0d0e21e
LW		 1096 RETURN;
1097}
1098
1099PP(pp_getc)
1100{
4e35701f 1101 djSP; dTARGET;
a0d0e21e 1102 GV *gv;
2ae324a7 1103 MAGIC *mg;
a0d0e21e 1104
32da55ab 1105 if (MAXARG == 0)
3280af22 1106 gv = PL_stdingv;
a0d0e21e
LW		 1107 else
1108 gv = (GV*)POPs;
2ae324a7 1109
155aba94 1110 if ((mg = SvTIED_mg((SV*)gv, 'q'))) {
54310121 1111 I32 gimme = GIMME_V;
2ae324a7 1112 PUSHMARK(SP);
33c27489 1113 XPUSHs(SvTIED_obj((SV*)gv, mg));
2ae324a7 1114 PUTBACK;
1115 ENTER;
864dbfa3 1116 call_method("GETC", gimme);
2ae324a7 1117 LEAVE;
1118 SPAGAIN;
54310121 1119 if (gimme == G_SCALAR)
1120 SvSetMagicSV_nosteal(TARG, TOPs);
2ae324a7 1121 RETURN;
1122 }
9bc64814 1123 if (!gv || do_eof(gv)) /* make sure we have fp with something */
a0d0e21e 1124 RETPUSHUNDEF;
bbce6d69 1125 TAINT;
a0d0e21e 1126 sv_setpv(TARG, " ");
9bc64814 1127 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
a0d0e21e
LW		 1128 PUSHTARG;
1129 RETURN;
1130}
1131
1132PP(pp_read)
1133{
cea2e8a9 1134 return pp_sysread();
a0d0e21e
LW		 1135}
1136
76e3520e 1137STATIC OP *
cea2e8a9 1138S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
a0d0e21e 1139{
11343788 1140 dTHR;
c09156bb 1141 register PERL_CONTEXT *cx;
54310121 1142 I32 gimme = GIMME_V;
a0d0e21e
LW		 1143 AV* padlist = CvPADLIST(cv);
1144 SV** svp = AvARRAY(padlist);
1145
1146 ENTER;
1147 SAVETMPS;
1148
1149 push_return(retop);
146174a9 1150 PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
a0d0e21e 1151 PUSHFORMAT(cx);
146174a9 1152 SAVEVPTR(PL_curpad);
3280af22 1153 PL_curpad = AvARRAY((AV*)svp[1]);
a0d0e21e 1154
4633a7c4 1155 setdefout(gv); /* locally select filehandle so $% et al work */
a0d0e21e
LW		 1156 return CvSTART(cv);
1157}
1158
1159PP(pp_enterwrite)
1160{
4e35701f 1161 djSP;
a0d0e21e
LW		 1162 register GV *gv;
1163 register IO *io;
1164 GV *fgv;
1165 CV *cv;
1166
1167 if (MAXARG == 0)
3280af22 1168 gv = PL_defoutgv;
a0d0e21e
LW		 1169 else {
1170 gv = (GV*)POPs;
1171 if (!gv)
3280af22 1172 gv = PL_defoutgv;
a0d0e21e
LW		 1173 }
1174 EXTEND(SP, 1);
1175 io = GvIO(gv);
1176 if (!io) {
1177 RETPUSHNO;
1178 }
1179 if (IoFMT_GV(io))
1180 fgv = IoFMT_GV(io);
1181 else
1182 fgv = gv;
1183
1184 cv = GvFORM(fgv);
a0d0e21e 1185 if (!cv) {
2dd78f96 1186 char *name = NULL;
a0d0e21e 1187 if (fgv) {
748a9306 1188 SV *tmpsv = sv_newmortal();
43693395 1189 gv_efullname4(tmpsv, fgv, Nullch, FALSE);
2dd78f96 1190 name = SvPV_nolen(tmpsv);
a0d0e21e 1191 }
2dd78f96
JH		 1192 if (name && *name)
1193 DIE(aTHX_ "Undefined format \"%s\" called", name);
cea2e8a9 1194 DIE(aTHX_ "Not a format reference");
a0d0e21e 1195 }
44a8e56a 1196 if (CvCLONE(cv))
1197 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
a0d0e21e 1198
44a8e56a 1199 IoFLAGS(io) &= ~IOf_DIDTOP;
533c011a 1200 return doform(cv,gv,PL_op->op_next);
a0d0e21e
LW		 1201}
1202
1203PP(pp_leavewrite)
1204{
4e35701f 1205 djSP;
a0d0e21e
LW		 1206 GV *gv = cxstack[cxstack_ix].blk_sub.gv;
1207 register IO *io = GvIOp(gv);
760ac839
LW		 1208 PerlIO *ofp = IoOFP(io);
1209 PerlIO *fp;
a0d0e21e
LW		 1210 SV **newsp;
1211 I32 gimme;
c09156bb 1212 register PERL_CONTEXT *cx;
a0d0e21e 1213
760ac839 1214 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
3280af22
NIS		 1215 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1216 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1217 PL_formtarget != PL_toptarget)
a0d0e21e 1218 {
4633a7c4
LW		 1219 GV *fgv;
1220 CV *cv;
a0d0e21e
LW		 1221 if (!IoTOP_GV(io)) {
1222 GV *topgv;
46fc3d4c 1223 SV *topname;
a0d0e21e
LW		 1224
1225 if (!IoTOP_NAME(io)) {
1226 if (!IoFMT_NAME(io))
1227 IoFMT_NAME(io) = savepv(GvNAME(gv));
cea2e8a9 1228 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%s_TOP", IoFMT_NAME(io)));
46fc3d4c 1229 topgv = gv_fetchpv(SvPVX(topname), FALSE, SVt_PVFM);
748a9306 1230 if ((topgv && GvFORM(topgv)) ||
a0d0e21e 1231 !gv_fetchpv("top",FALSE,SVt_PVFM))
46fc3d4c 1232 IoTOP_NAME(io) = savepv(SvPVX(topname));
a0d0e21e
LW		 1233 else
1234 IoTOP_NAME(io) = savepv("top");
1235 }
1236 topgv = gv_fetchpv(IoTOP_NAME(io),FALSE, SVt_PVFM);
1237 if (!topgv || !GvFORM(topgv)) {
1238 IoLINES_LEFT(io) = 100000000;
1239 goto forget_top;
1240 }
1241 IoTOP_GV(io) = topgv;
1242 }
748a9306
LW		 1243 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1244 I32 lines = IoLINES_LEFT(io);
3280af22 1245 char *s = SvPVX(PL_formtarget);
8e07c86e
AD		 1246 if (lines <= 0) /* Yow, header didn't even fit!!! */
1247 goto forget_top;
748a9306
LW		 1248 while (lines-- > 0) {
1249 s = strchr(s, '\n');
1250 if (!s)
1251 break;
1252 s++;
1253 }
1254 if (s) {
3280af22
NIS		 1255 PerlIO_write(ofp, SvPVX(PL_formtarget), s - SvPVX(PL_formtarget));
1256 sv_chop(PL_formtarget, s);
1257 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
748a9306
LW		 1258 }
1259 }
a0d0e21e 1260 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
3280af22 1261 PerlIO_write(ofp, SvPVX(PL_formfeed), SvCUR(PL_formfeed));
a0d0e21e
LW		 1262 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1263 IoPAGE(io)++;
3280af22 1264 PL_formtarget = PL_toptarget;
748a9306 1265 IoFLAGS(io) |= IOf_DIDTOP;
4633a7c4
LW		 1266 fgv = IoTOP_GV(io);
1267 if (!fgv)
cea2e8a9 1268 DIE(aTHX_ "bad top format reference");
4633a7c4 1269 cv = GvFORM(fgv);
2dd78f96
JH		 1270 {
1271 char *name = NULL;
1272 if (!cv) {
1273 SV *sv = sv_newmortal();
1274 gv_efullname4(sv, fgv, Nullch, FALSE);
1275 name = SvPV_nolen(sv);
1276 }
1277 if (name && *name)
1278 DIE(aTHX_ "Undefined top format \"%s\" called",name);
1279 /* why no:
1280 else
1281 DIE(aTHX_ "Undefined top format called");
1282 ?*/
4633a7c4 1283 }
44a8e56a 1284 if (CvCLONE(cv))
1285 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
533c011a 1286 return doform(cv,gv,PL_op);
a0d0e21e
LW		 1287 }
1288
1289 forget_top:
3280af22 1290 POPBLOCK(cx,PL_curpm);
a0d0e21e
LW		 1291 POPFORMAT(cx);
1292 LEAVE;
1293
1294 fp = IoOFP(io);
1295 if (!fp) {
599cee73 1296 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
cb50131a 1297 if (IoIFP(io)) {
2dd78f96
JH		 1298 /* integrate with report_evil_fh()? */
1299 char *name = NULL;
1300 if (isGV(gv)) {
1301 SV* sv = sv_newmortal();
1302 gv_efullname4(sv, gv, Nullch, FALSE);
1303 name = SvPV_nolen(sv);
1304 }
1305 if (name && *name)
1306 Perl_warner(aTHX_ WARN_IO,
1307 "Filehandle %s opened only for input", name);
1308 else
1309 Perl_warner(aTHX_ WARN_IO,
1310 "Filehandle opened only for input");
cb50131a 1311 }
599cee73 1312 else if (ckWARN(WARN_CLOSED))
bc37a18f 1313 report_evil_fh(gv, io, PL_op->op_type);
a0d0e21e 1314 }
3280af22 1315 PUSHs(&PL_sv_no);
a0d0e21e
LW		 1316 }
1317 else {
3280af22 1318 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
599cee73 1319 if (ckWARN(WARN_IO))
cea2e8a9 1320 Perl_warner(aTHX_ WARN_IO, "page overflow");
a0d0e21e 1321 }
3280af22 1322 if (!PerlIO_write(ofp, SvPVX(PL_formtarget), SvCUR(PL_formtarget)) ||
760ac839 1323 PerlIO_error(fp))
3280af22 1324 PUSHs(&PL_sv_no);
a0d0e21e 1325 else {
3280af22
NIS		 1326 FmLINES(PL_formtarget) = 0;
1327 SvCUR_set(PL_formtarget, 0);
1328 *SvEND(PL_formtarget) = '\0';
a0d0e21e 1329 if (IoFLAGS(io) & IOf_FLUSH)
760ac839 1330 (void)PerlIO_flush(fp);
3280af22 1331 PUSHs(&PL_sv_yes);
a0d0e21e
LW		 1332 }
1333 }
3280af22 1334 PL_formtarget = PL_bodytarget;
a0d0e21e
LW		 1335 PUTBACK;
1336 return pop_return();
1337}
1338
1339PP(pp_prtf)
1340{
4e35701f 1341 djSP; dMARK; dORIGMARK;
a0d0e21e
LW		 1342 GV *gv;
1343 IO *io;
760ac839 1344 PerlIO *fp;
26db47c4 1345 SV *sv;
46fc3d4c 1346 MAGIC *mg;
2d8e6c8d 1347 STRLEN n_a;
a0d0e21e 1348
533c011a 1349 if (PL_op->op_flags & OPf_STACKED)
a0d0e21e
LW		 1350 gv = (GV*)*++MARK;
1351 else
3280af22 1352 gv = PL_defoutgv;
46fc3d4c 1353
155aba94 1354 if ((mg = SvTIED_mg((SV*)gv, 'q'))) {
46fc3d4c 1355 if (MARK == ORIGMARK) {
4352c267 1356 MEXTEND(SP, 1);
46fc3d4c 1357 ++MARK;
1358 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1359 ++SP;
1360 }
1361 PUSHMARK(MARK - 1);
33c27489 1362 *MARK = SvTIED_obj((SV*)gv, mg);
46fc3d4c 1363 PUTBACK;
1364 ENTER;
864dbfa3 1365 call_method("PRINTF", G_SCALAR);
46fc3d4c 1366 LEAVE;
1367 SPAGAIN;
1368 MARK = ORIGMARK + 1;
1369 *MARK = *SP;
1370 SP = MARK;
1371 RETURN;
1372 }
1373
26db47c4 1374 sv = NEWSV(0,0);
a0d0e21e 1375 if (!(io = GvIO(gv))) {
2dd78f96
JH		 1376 dTHR;
1377 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
1378 report_evil_fh(gv, io, PL_op->op_type);
748a9306 1379 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW		 1380 goto just_say_no;
1381 }
1382 else if (!(fp = IoOFP(io))) {
599cee73 1383 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
2dd78f96 1384 /* integrate with report_evil_fh()? */
cb50131a 1385 if (IoIFP(io)) {
2dd78f96
JH		 1386 char *name = NULL;
1387 if (isGV(gv)) {
1388 gv_efullname4(sv, gv, Nullch, FALSE);
1389 name = SvPV_nolen(sv);
1390 }
1391 if (name && *name)
1392 Perl_warner(aTHX_ WARN_IO,
1393 "Filehandle %s opened only for input", name);
1394 else
1395 Perl_warner(aTHX_ WARN_IO,
1396 "Filehandle opened only for input");
cb50131a 1397 }
599cee73 1398 else if (ckWARN(WARN_CLOSED))
bc37a18f 1399 report_evil_fh(gv, io, PL_op->op_type);
a0d0e21e 1400 }
748a9306 1401 SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
a0d0e21e
LW		 1402 goto just_say_no;
1403 }
1404 else {
1405 do_sprintf(sv, SP - MARK, MARK + 1);
1406 if (!do_print(sv, fp))
1407 goto just_say_no;
1408
1409 if (IoFLAGS(io) & IOf_FLUSH)
760ac839 1410 if (PerlIO_flush(fp) == EOF)
a0d0e21e
LW		 1411 goto just_say_no;
1412 }
1413 SvREFCNT_dec(sv);
1414 SP = ORIGMARK;
3280af22 1415 PUSHs(&PL_sv_yes);
a0d0e21e
LW		 1416 RETURN;
1417
1418 just_say_no:
1419 SvREFCNT_dec(sv);
1420 SP = ORIGMARK;
3280af22 1421 PUSHs(&PL_sv_undef);
a0d0e21e
LW		 1422 RETURN;
1423}
1424
c07a80fd 1425PP(pp_sysopen)
1426{
4e35701f 1427 djSP;
c07a80fd 1428 GV *gv;
c07a80fd 1429 SV *sv;
1430 char *tmps;
1431 STRLEN len;
1432 int mode, perm;
1433
1434 if (MAXARG > 3)
1435 perm = POPi;
1436 else
1437 perm = 0666;
1438 mode = POPi;
1439 sv = POPs;
1440 gv = (GV *)POPs;
1441
4592e6ca
NIS		 1442 /* Need TIEHANDLE method ? */
1443
c07a80fd 1444 tmps = SvPV(sv, len);
1445 if (do_open(gv, tmps, len, TRUE, mode, perm, Nullfp)) {
1446 IoLINES(GvIOp(gv)) = 0;
3280af22 1447 PUSHs(&PL_sv_yes);
c07a80fd 1448 }
1449 else {
3280af22 1450 PUSHs(&PL_sv_undef);
c07a80fd 1451 }
1452 RETURN;
1453}
1454
a0d0e21e
LW		 1455PP(pp_sysread)
1456{
4e35701f 1457 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 1458 int offset;
1459 GV *gv;
1460 IO *io;
1461 char *buffer;
5b54f415 1462 SSize_t length;
1e422769 1463 Sock_size_t bufsize;
748a9306 1464 SV *bufsv;
a0d0e21e 1465 STRLEN blen;
2ae324a7 1466 MAGIC *mg;
a0d0e21e
LW		 1467
1468 gv = (GV*)*++MARK;
533c011a 1469 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD) &&
33c27489 1470 (mg = SvTIED_mg((SV*)gv, 'q')))
137443ea 1471 {
2ae324a7 1472 SV *sv;
1473
1474 PUSHMARK(MARK-1);
33c27489 1475 *MARK = SvTIED_obj((SV*)gv, mg);
2ae324a7 1476 ENTER;
864dbfa3 1477 call_method("READ", G_SCALAR);
2ae324a7 1478 LEAVE;
1479 SPAGAIN;
1480 sv = POPs;
1481 SP = ORIGMARK;
1482 PUSHs(sv);
1483 RETURN;
1484 }
1485
a0d0e21e
LW		 1486 if (!gv)
1487 goto say_undef;
748a9306 1488 bufsv = *++MARK;
ff68c719 1489 if (! SvOK(bufsv))
1490 sv_setpvn(bufsv, "", 0);
748a9306 1491 buffer = SvPV_force(bufsv, blen);
a0d0e21e
LW		 1492 length = SvIVx(*++MARK);
1493 if (length < 0)
cea2e8a9 1494 DIE(aTHX_ "Negative length");
748a9306 1495 SETERRNO(0,0);
a0d0e21e
LW		 1496 if (MARK < SP)
1497 offset = SvIVx(*++MARK);
1498 else
1499 offset = 0;
1500 io = GvIO(gv);
1501 if (!io || !IoIFP(io))
1502 goto say_undef;
1503#ifdef HAS_SOCKET
533c011a 1504 if (PL_op->op_type == OP_RECV) {
46fc3d4c 1505 char namebuf[MAXPATHLEN];
eec2d3df 1506#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE)
490ab354
JH		 1507 bufsize = sizeof (struct sockaddr_in);
1508#else
46fc3d4c 1509 bufsize = sizeof namebuf;
490ab354 1510#endif
abf95952
IZ		 1511#ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1512 if (bufsize >= 256)
1513 bufsize = 255;
1514#endif
626727d5
GS		 1515#ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1516 if (bufsize >= 256)
1517 bufsize = 255;
1518#endif
748a9306 1519 buffer = SvGROW(bufsv, length+1);
bbce6d69 1520 /* 'offset' means 'flags' here */
6ad3d225 1521 length = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
46fc3d4c 1522 (struct sockaddr *)namebuf, &bufsize);
a0d0e21e
LW		 1523 if (length < 0)
1524 RETPUSHUNDEF;
748a9306
LW		 1525 SvCUR_set(bufsv, length);
1526 *SvEND(bufsv) = '\0';
1527 (void)SvPOK_only(bufsv);
1528 SvSETMAGIC(bufsv);
aac0dd9a 1529 /* This should not be marked tainted if the fp is marked clean */
bbce6d69 1530 if (!(IoFLAGS(io) & IOf_UNTAINT))
1531 SvTAINTED_on(bufsv);
a0d0e21e 1532 SP = ORIGMARK;
46fc3d4c 1533 sv_setpvn(TARG, namebuf, bufsize);
a0d0e21e
LW		 1534 PUSHs(TARG);
1535 RETURN;
1536 }
1537#else
911d147d 1538 if (PL_op->op_type == OP_RECV)
cea2e8a9 1539 DIE(aTHX_ PL_no_sock_func, "recv");
a0d0e21e 1540#endif
bbce6d69 1541 if (offset < 0) {
1542 if (-offset > blen)
cea2e8a9 1543 DIE(aTHX_ "Offset outside string");
bbce6d69 1544 offset += blen;
1545 }
cd52b7b2 1546 bufsize = SvCUR(bufsv);
748a9306 1547 buffer = SvGROW(bufsv, length+offset+1);
cd52b7b2 1548 if (offset > bufsize) { /* Zero any newly allocated space */
1549 Zero(buffer+bufsize, offset-bufsize, char);
1550 }
533c011a 1551 if (PL_op->op_type == OP_SYSREAD) {
a7092146 1552#ifdef PERL_SOCK_SYSREAD_IS_RECV
50952442 1553 if (IoTYPE(io) == IoTYPE_SOCKET) {
a7092146
GS		 1554 length = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
1555 buffer+offset, length, 0);
1556 }
1557 else
1558#endif
1559 {
1560 length = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
1561 buffer+offset, length);
1562 }
a0d0e21e
LW		 1563 }
1564 else
1565#ifdef HAS_SOCKET__bad_code_maybe
50952442 1566 if (IoTYPE(io) == IoTYPE_SOCKET) {
46fc3d4c 1567 char namebuf[MAXPATHLEN];
490ab354
JH		 1568#if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
1569 bufsize = sizeof (struct sockaddr_in);
1570#else
46fc3d4c 1571 bufsize = sizeof namebuf;
490ab354 1572#endif
6ad3d225 1573 length = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer+offset, length, 0,
46fc3d4c 1574 (struct sockaddr *)namebuf, &bufsize);
a0d0e21e
LW		 1575 }
1576 else
1577#endif
3b02c43c 1578 {
760ac839 1579 length = PerlIO_read(IoIFP(io), buffer+offset, length);
3b02c43c 1580 /* fread() returns 0 on both error and EOF */
5c7a8c78 1581 if (length == 0 && PerlIO_error(IoIFP(io)))
3b02c43c
GS		 1582 length = -1;
1583 }
af8c498a 1584 if (length < 0) {
50952442 1585 if ((IoTYPE(io) == IoTYPE_WRONLY || IoIFP(io) == PerlIO_stdout()
c529f79d 1586 || IoIFP(io) == PerlIO_stderr()) && ckWARN(WARN_IO))
af8c498a 1587 {
2dd78f96
JH		 1588 /* integrate with report_evil_fh()? */
1589 char *name = NULL;
1590 if (isGV(gv)) {
1591 SV* sv = sv_newmortal();
1592 gv_efullname4(sv, gv, Nullch, FALSE);
1593 name = SvPV_nolen(sv);
1594 }
1595 if (name && *name)
1596 Perl_warner(aTHX_ WARN_IO,
1597 "Filehandle %s opened only for output", name);
1598 else
1599 Perl_warner(aTHX_ WARN_IO,
1600 "Filehandle opened only for output");
af8c498a 1601 }
a0d0e21e 1602 goto say_undef;
af8c498a 1603 }
748a9306
LW		 1604 SvCUR_set(bufsv, length+offset);
1605 *SvEND(bufsv) = '\0';
1606 (void)SvPOK_only(bufsv);
1607 SvSETMAGIC(bufsv);
aac0dd9a 1608 /* This should not be marked tainted if the fp is marked clean */
bbce6d69 1609 if (!(IoFLAGS(io) & IOf_UNTAINT))
1610 SvTAINTED_on(bufsv);
a0d0e21e
LW		 1611 SP = ORIGMARK;
1612 PUSHi(length);
1613 RETURN;
1614
1615 say_undef:
1616 SP = ORIGMARK;
1617 RETPUSHUNDEF;
1618}
1619
1620PP(pp_syswrite)
1621{
092bebab
JH		 1622 djSP;
1623 int items = (SP - PL_stack_base) - TOPMARK;
1624 if (items == 2) {
9f089d78 1625 SV *sv;
092bebab 1626 EXTEND(SP, 1);
9f089d78
SB		 1627 sv = sv_2mortal(newSViv(sv_len(*SP)));
1628 PUSHs(sv);
092bebab
JH		 1629 PUTBACK;
1630 }
cea2e8a9 1631 return pp_send();
a0d0e21e
LW		 1632}
1633
1634PP(pp_send)
1635{
4e35701f 1636 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 1637 GV *gv;
1638 IO *io;
748a9306 1639 SV *bufsv;
a0d0e21e 1640 char *buffer;
8c99d73e
GS		 1641 Size_t length;
1642 SSize_t retval;
1643 IV offset;
a0d0e21e 1644 STRLEN blen;
1d603a67 1645 MAGIC *mg;
a0d0e21e
LW		 1646
1647 gv = (GV*)*++MARK;
33c27489 1648 if (PL_op->op_type == OP_SYSWRITE && (mg = SvTIED_mg((SV*)gv, 'q'))) {
1d603a67
GB		 1649 SV *sv;
1650
1651 PUSHMARK(MARK-1);
33c27489 1652 *MARK = SvTIED_obj((SV*)gv, mg);
1d603a67 1653 ENTER;
864dbfa3 1654 call_method("WRITE", G_SCALAR);
1d603a67
GB		 1655 LEAVE;
1656 SPAGAIN;
1657 sv = POPs;
1658 SP = ORIGMARK;
1659 PUSHs(sv);
1660 RETURN;
1661 }
a0d0e21e
LW		 1662 if (!gv)
1663 goto say_undef;
748a9306
LW		 1664 bufsv = *++MARK;
1665 buffer = SvPV(bufsv, blen);
8c99d73e 1666#if Size_t_size > IVSIZE
3c001241 1667 length = (Size_t)SvNVx(*++MARK);
146174a9 1668#else
3c001241 1669 length = (Size_t)SvIVx(*++MARK);
146174a9 1670#endif
3c001241 1671 if ((SSize_t)length < 0)
cea2e8a9 1672 DIE(aTHX_ "Negative length");
748a9306 1673 SETERRNO(0,0);
a0d0e21e
LW		 1674 io = GvIO(gv);
1675 if (!io || !IoIFP(io)) {
8c99d73e 1676 retval = -1;
bc37a18f
RG		 1677 if (ckWARN(WARN_CLOSED))
1678 report_evil_fh(gv, io, PL_op->op_type);
a0d0e21e 1679 }
533c011a 1680 else if (PL_op->op_type == OP_SYSWRITE) {
bbce6d69 1681 if (MARK < SP) {
a0d0e21e 1682 offset = SvIVx(*++MARK);
bbce6d69 1683 if (offset < 0) {
1684 if (-offset > blen)
cea2e8a9 1685 DIE(aTHX_ "Offset outside string");
bbce6d69 1686 offset += blen;
fb73857a 1687 } else if (offset >= blen && blen > 0)
cea2e8a9 1688 DIE(aTHX_ "Offset outside string");
bbce6d69 1689 } else
a0d0e21e
LW		 1690 offset = 0;
1691 if (length > blen - offset)
1692 length = blen - offset;
a7092146 1693#ifdef PERL_SOCK_SYSWRITE_IS_SEND
50952442 1694 if (IoTYPE(io) == IoTYPE_SOCKET) {
8c99d73e 1695 retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
a7092146
GS		 1696 buffer+offset, length, 0);
1697 }
1698 else
1699#endif
1700 {
94e4c244 1701 /* See the note at doio.c:do_print about filesize limits. --jhi */
8c99d73e 1702 retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
a7092146
GS		 1703 buffer+offset, length);
1704 }
a0d0e21e
LW		 1705 }
1706#ifdef HAS_SOCKET
1707 else if (SP > MARK) {
1708 char *sockbuf;
1709 STRLEN mlen;
1710 sockbuf = SvPVx(*++MARK, mlen);
8c99d73e
GS		 1711 retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
1712 length, (struct sockaddr *)sockbuf, mlen);
a0d0e21e
LW		 1713 }
1714 else
8c99d73e 1715 retval = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, length);
490ab354 1716
a0d0e21e
LW		 1717#else
1718 else
cea2e8a9 1719 DIE(aTHX_ PL_no_sock_func, "send");
a0d0e21e 1720#endif
8c99d73e 1721 if (retval < 0)
a0d0e21e
LW		 1722 goto say_undef;
1723 SP = ORIGMARK;
8c99d73e
GS		 1724#if Size_t_size > IVSIZE
1725 PUSHn(retval);
1726#else
1727 PUSHi(retval);
1728#endif
a0d0e21e
LW		 1729 RETURN;
1730
1731 say_undef:
1732 SP = ORIGMARK;
1733 RETPUSHUNDEF;
1734}
1735
1736PP(pp_recv)
1737{
cea2e8a9 1738 return pp_sysread();
a0d0e21e
LW		 1739}
1740
1741PP(pp_eof)
1742{
4e35701f 1743 djSP;
a0d0e21e 1744 GV *gv;
4592e6ca 1745 MAGIC *mg;
a0d0e21e 1746
32da55ab 1747 if (MAXARG == 0) {
146174a9
CB		 1748 if (PL_op->op_flags & OPf_SPECIAL) { /* eof() */
1749 IO *io;
1750 gv = PL_last_in_gv = PL_argvgv;
1751 io = GvIO(gv);
1752 if (io && !IoIFP(io)) {
1753 if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
1754 IoLINES(io) = 0;
1755 IoFLAGS(io) &= ~IOf_START;
1756 do_open(gv, "-", 1, FALSE, O_RDONLY, 0, Nullfp);
1757 sv_setpvn(GvSV(gv), "-", 1);
1758 SvSETMAGIC(GvSV(gv));
1759 }
1760 else if (!nextargv(gv))
1761 RETPUSHYES;
1762 }
1763 }
1764 else
1765 gv = PL_last_in_gv; /* eof */
1766 }
a0d0e21e 1767 else
146174a9 1768 gv = PL_last_in_gv = (GV*)POPs; /* eof(FH) */
4592e6ca
NIS		 1769
1770 if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
1771 PUSHMARK(SP);
1772 XPUSHs(SvTIED_obj((SV*)gv, mg));
1773 PUTBACK;
1774 ENTER;
864dbfa3 1775 call_method("EOF", G_SCALAR);
4592e6ca
NIS		 1776 LEAVE;
1777 SPAGAIN;
1778 RETURN;
1779 }
1780
54310121 1781 PUSHs(boolSV(!gv || do_eof(gv)));
a0d0e21e
LW		 1782 RETURN;
1783}
1784
1785PP(pp_tell)
1786{
4e35701f 1787 djSP; dTARGET;
301e8125 1788 GV *gv;
4592e6ca 1789 MAGIC *mg;
a0d0e21e 1790
32da55ab 1791 if (MAXARG == 0)
3280af22 1792 gv = PL_last_in_gv;
a0d0e21e 1793 else
3280af22 1794 gv = PL_last_in_gv = (GV*)POPs;
4592e6ca
NIS		 1795
1796 if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
1797 PUSHMARK(SP);
1798 XPUSHs(SvTIED_obj((SV*)gv, mg));
1799 PUTBACK;
1800 ENTER;
864dbfa3 1801 call_method("TELL", G_SCALAR);
4592e6ca
NIS		 1802 LEAVE;
1803 SPAGAIN;
1804 RETURN;
1805 }
1806
146174a9
CB		 1807#if LSEEKSIZE > IVSIZE
1808 PUSHn( do_tell(gv) );
1809#else
a0d0e21e 1810 PUSHi( do_tell(gv) );
146174a9 1811#endif
a0d0e21e
LW		 1812 RETURN;
1813}
1814
1815PP(pp_seek)
1816{
cea2e8a9 1817 return pp_sysseek();
137443ea 1818}
1819
1820PP(pp_sysseek)
1821{
4e35701f 1822 djSP;
a0d0e21e
LW		 1823 GV *gv;
1824 int whence = POPi;
146174a9
CB		 1825#if LSEEKSIZE > IVSIZE
1826 Off_t offset = (Off_t)SvNVx(POPs);
1827#else
d9b3e12d 1828 Off_t offset = (Off_t)SvIVx(POPs);
146174a9 1829#endif
4592e6ca 1830 MAGIC *mg;
a0d0e21e 1831
3280af22 1832 gv = PL_last_in_gv = (GV*)POPs;
4592e6ca
NIS		 1833
1834 if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
1835 PUSHMARK(SP);
1836 XPUSHs(SvTIED_obj((SV*)gv, mg));
cb50131a
CB		 1837#if LSEEKSIZE > IVSIZE
1838 XPUSHs(sv_2mortal(newSVnv((NV) offset)));
1839#else
b448e4fe 1840 XPUSHs(sv_2mortal(newSViv(offset)));
cb50131a 1841#endif
b448e4fe 1842 XPUSHs(sv_2mortal(newSViv(whence)));
4592e6ca
NIS		 1843 PUTBACK;
1844 ENTER;
864dbfa3 1845 call_method("SEEK", G_SCALAR);
4592e6ca
NIS		 1846 LEAVE;
1847 SPAGAIN;
1848 RETURN;
1849 }
1850
533c011a 1851 if (PL_op->op_type == OP_SEEK)
8903cb82 1852 PUSHs(boolSV(do_seek(gv, offset, whence)));
1853 else {
b448e4fe
JH		 1854 Off_t sought = do_sysseek(gv, offset, whence);
1855 if (sought < 0)
146174a9
CB		 1856 PUSHs(&PL_sv_undef);
1857 else {
b448e4fe 1858 SV* sv = sought ?
146174a9 1859#if LSEEKSIZE > IVSIZE
b448e4fe 1860 newSVnv((NV)sought)
146174a9 1861#else
b448e4fe 1862 newSViv(sought)
146174a9
CB		 1863#endif
1864 : newSVpvn(zero_but_true, ZBTLEN);
1865 PUSHs(sv_2mortal(sv));
1866 }
8903cb82 1867 }
a0d0e21e
LW		 1868 RETURN;
1869}
1870
1871PP(pp_truncate)
1872{
4e35701f 1873 djSP;
8c99d73e
GS		 1874 /* There seems to be no consensus on the length type of truncate()
1875 * and ftruncate(), both off_t and size_t have supporters. In
1876 * general one would think that when using large files, off_t is
1877 * at least as wide as size_t, so using an off_t should be okay. */
1878 /* XXX Configure probe for the length type of *truncate() needed XXX */
1879 Off_t len;
a0d0e21e
LW		 1880 int result = 1;
1881 GV *tmpgv;
2d8e6c8d 1882 STRLEN n_a;
a0d0e21e 1883
8c99d73e
GS		 1884#if Size_t_size > IVSIZE
1885 len = (Off_t)POPn;
1886#else
1887 len = (Off_t)POPi;
1888#endif
1889 /* Checking for length < 0 is problematic as the type might or
301e8125 1890 * might not be signed: if it is not, clever compilers will moan. */
8c99d73e 1891 /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
748a9306 1892 SETERRNO(0,0);
5d94fbed 1893#if defined(HAS_TRUNCATE) || defined(HAS_CHSIZE) || defined(F_FREESP)
533c011a 1894 if (PL_op->op_flags & OPf_SPECIAL) {
2d8e6c8d 1895 tmpgv = gv_fetchpv(POPpx, FALSE, SVt_PVIO);
cbdc8872 1896 do_ftruncate:
1e422769 1897 TAINT_PROPER("truncate");
cb50131a
CB		 1898 if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv)))
1899 result = 0;
1900 else {
1901 PerlIO_flush(IoIFP(GvIOp(tmpgv)));
cbdc8872 1902#ifdef HAS_TRUNCATE
cb50131a 1903 if (ftruncate(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
301e8125 1904#else
cb50131a 1905 if (my_chsize(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
cbdc8872 1906#endif
cb50131a
CB		 1907 result = 0;
1908 }
a0d0e21e
LW		 1909 }
1910 else {
cbdc8872 1911 SV *sv = POPs;
1e422769 1912 char *name;
2d8e6c8d 1913 STRLEN n_a;
1e422769 1914
cbdc8872 1915 if (SvTYPE(sv) == SVt_PVGV) {
1916 tmpgv = (GV*)sv; /* *main::FRED for example */
1917 goto do_ftruncate;
1918 }
1919 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
1920 tmpgv = (GV*) SvRV(sv); /* \*main::FRED for example */
1921 goto do_ftruncate;
1922 }
1e422769 1923
2d8e6c8d 1924 name = SvPV(sv, n_a);
1e422769 1925 TAINT_PROPER("truncate");
cbdc8872 1926#ifdef HAS_TRUNCATE
1e422769 1927 if (truncate(name, len) < 0)
a0d0e21e 1928 result = 0;
cbdc8872 1929#else
1930 {
1931 int tmpfd;
6ad3d225 1932 if ((tmpfd = PerlLIO_open(name, O_RDWR)) < 0)
bbce6d69 1933 result = 0;
cbdc8872 1934 else {
1935 if (my_chsize(tmpfd, len) < 0)
1936 result = 0;
6ad3d225 1937 PerlLIO_close(tmpfd);
cbdc8872 1938 }
a0d0e21e 1939 }
a0d0e21e 1940#endif
cbdc8872 1941 }
a0d0e21e
LW		 1942
1943 if (result)
1944 RETPUSHYES;
1945 if (!errno)
748a9306 1946 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW		 1947 RETPUSHUNDEF;
1948#else
cea2e8a9 1949 DIE(aTHX_ "truncate not implemented");
a0d0e21e
LW		 1950#endif
1951}
1952
1953PP(pp_fcntl)
1954{
cea2e8a9 1955 return pp_ioctl();
a0d0e21e
LW		 1956}
1957
1958PP(pp_ioctl)
1959{
4e35701f 1960 djSP; dTARGET;
748a9306 1961 SV *argsv = POPs;
a0d0e21e 1962 unsigned int func = U_I(POPn);
533c011a 1963 int optype = PL_op->op_type;
a0d0e21e 1964 char *s;
324aa91a 1965 IV retval;
a0d0e21e
LW		 1966 GV *gv = (GV*)POPs;
1967 IO *io = GvIOn(gv);
1968
748a9306
LW		 1969 if (!io || !argsv || !IoIFP(io)) {
1970 SETERRNO(EBADF,RMS$_IFI); /* well, sort of... */
a0d0e21e
LW		 1971 RETPUSHUNDEF;
1972 }
1973
748a9306 1974 if (SvPOK(argsv) || !SvNIOK(argsv)) {
a0d0e21e 1975 STRLEN len;
324aa91a 1976 STRLEN need;
748a9306 1977 s = SvPV_force(argsv, len);
324aa91a
HF		 1978 need = IOCPARM_LEN(func);
1979 if (len < need) {
1980 s = Sv_Grow(argsv, need + 1);
1981 SvCUR_set(argsv, need);
a0d0e21e
LW		 1982 }
1983
748a9306 1984 s[SvCUR(argsv)] = 17; /* a little sanity check here */
a0d0e21e
LW		 1985 }
1986 else {
748a9306 1987 retval = SvIV(argsv);
c529f79d 1988 s = INT2PTR(char*,retval); /* ouch */
a0d0e21e
LW		 1989 }
1990
1991 TAINT_PROPER(optype == OP_IOCTL ? "ioctl" : "fcntl");
1992
1993 if (optype == OP_IOCTL)
1994#ifdef HAS_IOCTL
76e3520e 1995 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
a0d0e21e 1996#else
cea2e8a9 1997 DIE(aTHX_ "ioctl is not implemented");
a0d0e21e
LW		 1998#endif
1999 else
55497cff 2000#ifdef HAS_FCNTL
2001#if defined(OS2) && defined(__EMX__)
760ac839 2002 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
55497cff 2003#else
760ac839 2004 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
301e8125 2005#endif
55497cff 2006#else
cea2e8a9 2007 DIE(aTHX_ "fcntl is not implemented");
a0d0e21e
LW		 2008#endif
2009
748a9306
LW		 2010 if (SvPOK(argsv)) {
2011 if (s[SvCUR(argsv)] != 17)
cea2e8a9 2012 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
22c35a8c 2013 PL_op_name[optype]);
748a9306
LW		 2014 s[SvCUR(argsv)] = 0; /* put our null back */
2015 SvSETMAGIC(argsv); /* Assume it has changed */
a0d0e21e
LW		 2016 }
2017
2018 if (retval == -1)
2019 RETPUSHUNDEF;
2020 if (retval != 0) {
2021 PUSHi(retval);
2022 }
2023 else {
8903cb82 2024 PUSHp(zero_but_true, ZBTLEN);
a0d0e21e
LW		 2025 }
2026 RETURN;
2027}
2028
2029PP(pp_flock)
2030{
4e35701f 2031 djSP; dTARGET;
a0d0e21e
LW		 2032 I32 value;
2033 int argtype;
2034 GV *gv;
bc37a18f 2035 IO *io = NULL;
760ac839 2036 PerlIO *fp;
16d20bd9 2037
ff68c719 2038#ifdef FLOCK
a0d0e21e 2039 argtype = POPi;
32da55ab 2040 if (MAXARG == 0)
3280af22 2041 gv = PL_last_in_gv;
a0d0e21e
LW		 2042 else
2043 gv = (GV*)POPs;
bc37a18f
RG		 2044 if (gv && (io = GvIO(gv)))
2045 fp = IoIFP(io);
2046 else {
a0d0e21e 2047 fp = Nullfp;
bc37a18f
RG		 2048 io = NULL;
2049 }
a0d0e21e 2050 if (fp) {
68dc0745 2051 (void)PerlIO_flush(fp);
76e3520e 2052 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
a0d0e21e 2053 }
cb50131a 2054 else {
bc37a18f
RG		 2055 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2056 report_evil_fh(gv, io, PL_op->op_type);
a0d0e21e 2057 value = 0;
cb50131a 2058 SETERRNO(EBADF,RMS$_IFI);
cb50131a 2059 }
a0d0e21e
LW		 2060 PUSHi(value);
2061 RETURN;
2062#else
cea2e8a9 2063 DIE(aTHX_ PL_no_func, "flock()");
a0d0e21e
LW		 2064#endif
2065}
2066
2067/* Sockets. */
2068
2069PP(pp_socket)
2070{
4e35701f 2071 djSP;
a0d0e21e
LW		 2072#ifdef HAS_SOCKET
2073 GV *gv;
2074 register IO *io;
2075 int protocol = POPi;
2076 int type = POPi;
2077 int domain = POPi;
2078 int fd;
2079
2080 gv = (GV*)POPs;
2081
2082 if (!gv) {
748a9306 2083 SETERRNO(EBADF,LIB$_INVARG);
a0d0e21e
LW		 2084 RETPUSHUNDEF;
2085 }
2086
2087 io = GvIOn(gv);
2088 if (IoIFP(io))
2089 do_close(gv, FALSE);
2090
2091 TAINT_PROPER("socket");
6ad3d225 2092 fd = PerlSock_socket(domain, type, protocol);
a0d0e21e
LW		 2093 if (fd < 0)
2094 RETPUSHUNDEF;
760ac839
LW		 2095 IoIFP(io) = PerlIO_fdopen(fd, "r"); /* stdio gets confused about sockets */
2096 IoOFP(io) = PerlIO_fdopen(fd, "w");
50952442 2097 IoTYPE(io) = IoTYPE_SOCKET;
a0d0e21e 2098 if (!IoIFP(io) || !IoOFP(io)) {
760ac839
LW		 2099 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2100 if (IoOFP(io)) PerlIO_close(IoOFP(io));
6ad3d225 2101 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
a0d0e21e
LW		 2102 RETPUSHUNDEF;
2103 }
8d2a6795
GS		 2104#if defined(HAS_FCNTL) && defined(F_SETFD)
2105 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2106#endif
a0d0e21e
LW		 2107
2108 RETPUSHYES;
2109#else
cea2e8a9 2110 DIE(aTHX_ PL_no_sock_func, "socket");
a0d0e21e
LW		 2111#endif
2112}
2113
2114PP(pp_sockpair)
2115{
4e35701f 2116 djSP;
a0d0e21e
LW		 2117#ifdef HAS_SOCKETPAIR
2118 GV *gv1;
2119 GV *gv2;
2120 register IO *io1;
2121 register IO *io2;
2122 int protocol = POPi;
2123 int type = POPi;
2124 int domain = POPi;
2125 int fd[2];
2126
2127 gv2 = (GV*)POPs;
2128 gv1 = (GV*)POPs;
2129 if (!gv1 || !gv2)
2130 RETPUSHUNDEF;
2131
2132 io1 = GvIOn(gv1);
2133 io2 = GvIOn(gv2);
2134 if (IoIFP(io1))
2135 do_close(gv1, FALSE);
2136 if (IoIFP(io2))
2137 do_close(gv2, FALSE);
2138
2139 TAINT_PROPER("socketpair");
6ad3d225 2140 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
a0d0e21e 2141 RETPUSHUNDEF;
760ac839
LW		 2142 IoIFP(io1) = PerlIO_fdopen(fd[0], "r");
2143 IoOFP(io1) = PerlIO_fdopen(fd[0], "w");
50952442 2144 IoTYPE(io1) = IoTYPE_SOCKET;
760ac839
LW		 2145 IoIFP(io2) = PerlIO_fdopen(fd[1], "r");
2146 IoOFP(io2) = PerlIO_fdopen(fd[1], "w");
50952442 2147 IoTYPE(io2) = IoTYPE_SOCKET;
a0d0e21e 2148 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
760ac839
LW		 2149 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2150 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
6ad3d225 2151 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
760ac839
LW		 2152 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2153 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
6ad3d225 2154 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
a0d0e21e
LW		 2155 RETPUSHUNDEF;
2156 }
8d2a6795
GS		 2157#if defined(HAS_FCNTL) && defined(F_SETFD)
2158 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
2159 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
2160#endif
a0d0e21e
LW		 2161
2162 RETPUSHYES;
2163#else
cea2e8a9 2164 DIE(aTHX_ PL_no_sock_func, "socketpair");
a0d0e21e
LW		 2165#endif
2166}
2167
2168PP(pp_bind)
2169{
4e35701f 2170 djSP;
a0d0e21e 2171#ifdef HAS_SOCKET
eec2d3df
GS		 2172#ifdef MPE /* Requires PRIV mode to bind() to ports < 1024 */
2173 extern GETPRIVMODE();
2174 extern GETUSERMODE();
2175#endif
748a9306 2176 SV *addrsv = POPs;
a0d0e21e
LW		 2177 char *addr;
2178 GV *gv = (GV*)POPs;
2179 register IO *io = GvIOn(gv);
2180 STRLEN len;
eec2d3df
GS		 2181 int bind_ok = 0;
2182#ifdef MPE
2183 int mpeprivmode = 0;
2184#endif
a0d0e21e
LW		 2185
2186 if (!io || !IoIFP(io))
2187 goto nuts;
2188
748a9306 2189 addr = SvPV(addrsv, len);
a0d0e21e 2190 TAINT_PROPER("bind");
eec2d3df
GS		 2191#ifdef MPE /* Deal with MPE bind() peculiarities */
2192 if (((struct sockaddr *)addr)->sa_family == AF_INET) {
2193 /* The address *MUST* stupidly be zero. */
2194 ((struct sockaddr_in *)addr)->sin_addr.s_addr = INADDR_ANY;
2195 /* PRIV mode is required to bind() to ports < 1024. */
2196 if (((struct sockaddr_in *)addr)->sin_port < 1024 &&
2197 ((struct sockaddr_in *)addr)->sin_port > 0) {
2198 GETPRIVMODE(); /* If this fails, we are aborted by MPE/iX. */
2199 mpeprivmode = 1;
2200 }
2201 }
2202#endif /* MPE */
2203 if (PerlSock_bind(PerlIO_fileno(IoIFP(io)),
2204 (struct sockaddr *)addr, len) >= 0)
2205 bind_ok = 1;
2206
2207#ifdef MPE /* Switch back to USER mode */
2208 if (mpeprivmode)
2209 GETUSERMODE();
2210#endif /* MPE */
2211
2212 if (bind_ok)
a0d0e21e
LW		 2213 RETPUSHYES;
2214 else
2215 RETPUSHUNDEF;
2216
2217nuts:
599cee73 2218 if (ckWARN(WARN_CLOSED))
bc37a18f 2219 report_evil_fh(gv, io, PL_op->op_type);
748a9306 2220 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2221 RETPUSHUNDEF;
2222#else
cea2e8a9 2223 DIE(aTHX_ PL_no_sock_func, "bind");
a0d0e21e
LW		 2224#endif
2225}
2226
2227PP(pp_connect)
2228{
4e35701f 2229 djSP;
a0d0e21e 2230#ifdef HAS_SOCKET
748a9306 2231 SV *addrsv = POPs;
a0d0e21e
LW		 2232 char *addr;
2233 GV *gv = (GV*)POPs;
2234 register IO *io = GvIOn(gv);
2235 STRLEN len;
2236
2237 if (!io || !IoIFP(io))
2238 goto nuts;
2239
748a9306 2240 addr = SvPV(addrsv, len);
a0d0e21e 2241 TAINT_PROPER("connect");
6ad3d225 2242 if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
a0d0e21e
LW		 2243 RETPUSHYES;
2244 else
2245 RETPUSHUNDEF;
2246
2247nuts:
599cee73 2248 if (ckWARN(WARN_CLOSED))
bc37a18f 2249 report_evil_fh(gv, io, PL_op->op_type);
748a9306 2250 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2251 RETPUSHUNDEF;
2252#else
cea2e8a9 2253 DIE(aTHX_ PL_no_sock_func, "connect");
a0d0e21e
LW		 2254#endif
2255}
2256
2257PP(pp_listen)
2258{
4e35701f 2259 djSP;
a0d0e21e
LW		 2260#ifdef HAS_SOCKET
2261 int backlog = POPi;
2262 GV *gv = (GV*)POPs;
2263 register IO *io = GvIOn(gv);
2264
2265 if (!io || !IoIFP(io))
2266 goto nuts;
2267
6ad3d225 2268 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
a0d0e21e
LW		 2269 RETPUSHYES;
2270 else
2271 RETPUSHUNDEF;
2272
2273nuts:
599cee73 2274 if (ckWARN(WARN_CLOSED))
bc37a18f 2275 report_evil_fh(gv, io, PL_op->op_type);
748a9306 2276 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2277 RETPUSHUNDEF;
2278#else
cea2e8a9 2279 DIE(aTHX_ PL_no_sock_func, "listen");
a0d0e21e
LW		 2280#endif
2281}
2282
2283PP(pp_accept)
2284{
4e35701f 2285 djSP; dTARGET;
a0d0e21e
LW		 2286#ifdef HAS_SOCKET
2287 GV *ngv;
2288 GV *ggv;
2289 register IO *nstio;
2290 register IO *gstio;
4633a7c4 2291 struct sockaddr saddr; /* use a struct to avoid alignment problems */
1e422769 2292 Sock_size_t len = sizeof saddr;
a0d0e21e
LW		 2293 int fd;
2294
2295 ggv = (GV*)POPs;
2296 ngv = (GV*)POPs;
2297
2298 if (!ngv)
2299 goto badexit;
2300 if (!ggv)
2301 goto nuts;
2302
2303 gstio = GvIO(ggv);
2304 if (!gstio || !IoIFP(gstio))
2305 goto nuts;
2306
2307 nstio = GvIOn(ngv);
2308 if (IoIFP(nstio))
2309 do_close(ngv, FALSE);
2310
6ad3d225 2311 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *)&saddr, &len);
a0d0e21e
LW		 2312 if (fd < 0)
2313 goto badexit;
760ac839
LW		 2314 IoIFP(nstio) = PerlIO_fdopen(fd, "r");
2315 IoOFP(nstio) = PerlIO_fdopen(fd, "w");
50952442 2316 IoTYPE(nstio) = IoTYPE_SOCKET;
a0d0e21e 2317 if (!IoIFP(nstio) || !IoOFP(nstio)) {
760ac839
LW		 2318 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2319 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
6ad3d225 2320 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
a0d0e21e
LW		 2321 goto badexit;
2322 }
8d2a6795
GS		 2323#if defined(HAS_FCNTL) && defined(F_SETFD)
2324 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2325#endif
a0d0e21e 2326
ed79a026
OF		 2327#ifdef EPOC
2328 len = sizeof saddr; /* EPOC somehow truncates info */
2329#endif
2330
748a9306 2331 PUSHp((char *)&saddr, len);
a0d0e21e
LW		 2332 RETURN;
2333
2334nuts:
599cee73 2335 if (ckWARN(WARN_CLOSED))
bc37a18f 2336 report_evil_fh(ggv, ggv ? GvIO(ggv) : 0, PL_op->op_type);
748a9306 2337 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2338
2339badexit:
2340 RETPUSHUNDEF;
2341
2342#else
cea2e8a9 2343 DIE(aTHX_ PL_no_sock_func, "accept");
a0d0e21e
LW		 2344#endif
2345}
2346
2347PP(pp_shutdown)
2348{
4e35701f 2349 djSP; dTARGET;
a0d0e21e
LW		 2350#ifdef HAS_SOCKET
2351 int how = POPi;
2352 GV *gv = (GV*)POPs;
2353 register IO *io = GvIOn(gv);
2354
2355 if (!io || !IoIFP(io))
2356 goto nuts;
2357
6ad3d225 2358 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
a0d0e21e
LW		 2359 RETURN;
2360
2361nuts:
599cee73 2362 if (ckWARN(WARN_CLOSED))
bc37a18f 2363 report_evil_fh(gv, io, PL_op->op_type);
748a9306 2364 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2365 RETPUSHUNDEF;
2366#else
cea2e8a9 2367 DIE(aTHX_ PL_no_sock_func, "shutdown");
a0d0e21e
LW		 2368#endif
2369}
2370
2371PP(pp_gsockopt)
2372{
2373#ifdef HAS_SOCKET
cea2e8a9 2374 return pp_ssockopt();
a0d0e21e 2375#else
cea2e8a9 2376 DIE(aTHX_ PL_no_sock_func, "getsockopt");
a0d0e21e
LW		 2377#endif
2378}
2379
2380PP(pp_ssockopt)
2381{
4e35701f 2382 djSP;
a0d0e21e 2383#ifdef HAS_SOCKET
533c011a 2384 int optype = PL_op->op_type;
a0d0e21e
LW		 2385 SV *sv;
2386 int fd;
2387 unsigned int optname;
2388 unsigned int lvl;
2389 GV *gv;
2390 register IO *io;
1e422769 2391 Sock_size_t len;
a0d0e21e
LW		 2392
2393 if (optype == OP_GSOCKOPT)
2394 sv = sv_2mortal(NEWSV(22, 257));
2395 else
2396 sv = POPs;
2397 optname = (unsigned int) POPi;
2398 lvl = (unsigned int) POPi;
2399
2400 gv = (GV*)POPs;
2401 io = GvIOn(gv);
2402 if (!io || !IoIFP(io))
2403 goto nuts;
2404
760ac839 2405 fd = PerlIO_fileno(IoIFP(io));
a0d0e21e
LW		 2406 switch (optype) {
2407 case OP_GSOCKOPT:
748a9306 2408 SvGROW(sv, 257);
a0d0e21e 2409 (void)SvPOK_only(sv);
748a9306
LW		 2410 SvCUR_set(sv,256);
2411 *SvEND(sv) ='\0';
1e422769 2412 len = SvCUR(sv);
6ad3d225 2413 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
a0d0e21e 2414 goto nuts2;
1e422769 2415 SvCUR_set(sv, len);
748a9306 2416 *SvEND(sv) ='\0';
a0d0e21e
LW		 2417 PUSHs(sv);
2418 break;
2419 case OP_SSOCKOPT: {
1e422769 2420 char *buf;
2421 int aint;
2422 if (SvPOKp(sv)) {
2d8e6c8d
GS		 2423 STRLEN l;
2424 buf = SvPV(sv, l);
2425 len = l;
1e422769 2426 }
56ee1660 2427 else {
a0d0e21e
LW		 2428 aint = (int)SvIV(sv);
2429 buf = (char*)&aint;
2430 len = sizeof(int);
2431 }
6ad3d225 2432 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
a0d0e21e 2433 goto nuts2;
3280af22 2434 PUSHs(&PL_sv_yes);
a0d0e21e
LW		 2435 }
2436 break;
2437 }
2438 RETURN;
2439
2440nuts:
599cee73 2441 if (ckWARN(WARN_CLOSED))
bc37a18f 2442 report_evil_fh(gv, io, optype);
748a9306 2443 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2444nuts2:
2445 RETPUSHUNDEF;
2446
2447#else
cea2e8a9 2448 DIE(aTHX_ PL_no_sock_func, "setsockopt");
a0d0e21e
LW		 2449#endif
2450}
2451
2452PP(pp_getsockname)
2453{
2454#ifdef HAS_SOCKET
cea2e8a9 2455 return pp_getpeername();
a0d0e21e 2456#else
cea2e8a9 2457 DIE(aTHX_ PL_no_sock_func, "getsockname");
a0d0e21e
LW		 2458#endif
2459}
2460
2461PP(pp_getpeername)
2462{
4e35701f 2463 djSP;
a0d0e21e 2464#ifdef HAS_SOCKET
533c011a 2465 int optype = PL_op->op_type;
a0d0e21e
LW		 2466 SV *sv;
2467 int fd;
2468 GV *gv = (GV*)POPs;
2469 register IO *io = GvIOn(gv);
1e422769 2470 Sock_size_t len;
a0d0e21e
LW		 2471
2472 if (!io || !IoIFP(io))
2473 goto nuts;
2474
2475 sv = sv_2mortal(NEWSV(22, 257));
748a9306 2476 (void)SvPOK_only(sv);
1e422769 2477 len = 256;
2478 SvCUR_set(sv, len);
748a9306 2479 *SvEND(sv) ='\0';
760ac839 2480 fd = PerlIO_fileno(IoIFP(io));
a0d0e21e
LW		 2481 switch (optype) {
2482 case OP_GETSOCKNAME:
6ad3d225 2483 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
a0d0e21e
LW		 2484 goto nuts2;
2485 break;
2486 case OP_GETPEERNAME:
6ad3d225 2487 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
a0d0e21e 2488 goto nuts2;
490ab354
JH		 2489#if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2490 {
2491 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";
2492 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2493 if (((struct sockaddr *)SvPVX(sv))->sa_family == AF_INET &&
2494 !memcmp((char *)SvPVX(sv) + sizeof(u_short), nowhere,
2495 sizeof(u_short) + sizeof(struct in_addr))) {
301e8125 2496 goto nuts2;
490ab354
JH		 2497 }
2498 }
2499#endif
a0d0e21e
LW		 2500 break;
2501 }
13826f2c
CS		 2502#ifdef BOGUS_GETNAME_RETURN
2503 /* Interactive Unix, getpeername() and getsockname()
2504 does not return valid namelen */
1e422769 2505 if (len == BOGUS_GETNAME_RETURN)
2506 len = sizeof(struct sockaddr);
13826f2c 2507#endif
1e422769 2508 SvCUR_set(sv, len);
748a9306 2509 *SvEND(sv) ='\0';
a0d0e21e
LW		 2510 PUSHs(sv);
2511 RETURN;
2512
2513nuts:
599cee73 2514 if (ckWARN(WARN_CLOSED))
bc37a18f 2515 report_evil_fh(gv, io, optype);
748a9306 2516 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2517nuts2:
2518 RETPUSHUNDEF;
2519
2520#else
cea2e8a9 2521 DIE(aTHX_ PL_no_sock_func, "getpeername");
a0d0e21e
LW		 2522#endif
2523}
2524
2525/* Stat calls. */
2526
2527PP(pp_lstat)
2528{
cea2e8a9 2529 return pp_stat();
a0d0e21e
LW		 2530}
2531
2532PP(pp_stat)
2533{
4e35701f 2534 djSP;
2dd78f96 2535 GV *gv;
54310121 2536 I32 gimme;
a0d0e21e 2537 I32 max = 13;
2d8e6c8d 2538 STRLEN n_a;
a0d0e21e 2539
533c011a 2540 if (PL_op->op_flags & OPf_REF) {
2dd78f96 2541 gv = cGVOP_gv;
8a4e5b40
DD		 2542 if (PL_op->op_type == OP_LSTAT) {
2543 if (PL_laststype != OP_LSTAT)
2544 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2545 if (ckWARN(WARN_IO) && gv != PL_defgv)
2546 Perl_warner(aTHX_ WARN_IO,
2dd78f96 2547 "lstat() on filehandle %s", GvENAME(gv));
8a4e5b40
DD		 2548 /* Perl_my_lstat (-l) croak's on filehandle, why warn here? */
2549 }
2550
748a9306 2551 do_fstat:
2dd78f96 2552 if (gv != PL_defgv) {
3280af22 2553 PL_laststype = OP_STAT;
2dd78f96 2554 PL_statgv = gv;
3280af22 2555 sv_setpv(PL_statname, "");
2dd78f96
JH		 2556 PL_laststatval = (GvIO(gv) && IoIFP(GvIOp(gv))
2557 ? PerlLIO_fstat(PerlIO_fileno(IoIFP(GvIOn(gv))), &PL_statcache) : -1);
a0d0e21e 2558 }
9ddeeac9 2559 if (PL_laststatval < 0) {
2dd78f96
JH		 2560 dTHR;
2561 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2562 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
a0d0e21e 2563 max = 0;
9ddeeac9 2564 }
a0d0e21e
LW		 2565 }
2566 else {
748a9306
LW		 2567 SV* sv = POPs;
2568 if (SvTYPE(sv) == SVt_PVGV) {
2dd78f96 2569 gv = (GV*)sv;
748a9306
LW		 2570 goto do_fstat;
2571 }
2572 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2dd78f96 2573 gv = (GV*)SvRV(sv);
748a9306
LW		 2574 goto do_fstat;
2575 }
2d8e6c8d 2576 sv_setpv(PL_statname, SvPV(sv,n_a));
3280af22 2577 PL_statgv = Nullgv;
a0d0e21e 2578#ifdef HAS_LSTAT
533c011a
NIS		 2579 PL_laststype = PL_op->op_type;
2580 if (PL_op->op_type == OP_LSTAT)
2d8e6c8d 2581 PL_laststatval = PerlLIO_lstat(SvPV(PL_statname, n_a), &PL_statcache);
a0d0e21e
LW		 2582 else
2583#endif
2d8e6c8d 2584 PL_laststatval = PerlLIO_stat(SvPV(PL_statname, n_a), &PL_statcache);
3280af22 2585 if (PL_laststatval < 0) {
2d8e6c8d 2586 if (ckWARN(WARN_NEWLINE) && strchr(SvPV(PL_statname, n_a), '\n'))
cea2e8a9 2587 Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "stat");
a0d0e21e
LW		 2588 max = 0;
2589 }
2590 }
2591
54310121 2592 gimme = GIMME_V;
2593 if (gimme != G_ARRAY) {
2594 if (gimme != G_VOID)
2595 XPUSHs(boolSV(max));
2596 RETURN;
a0d0e21e
LW		 2597 }
2598 if (max) {
36477c24 2599 EXTEND(SP, max);
2600 EXTEND_MORTAL(max);
1ff81528
PL		 2601 PUSHs(sv_2mortal(newSViv(PL_statcache.st_dev)));
2602 PUSHs(sv_2mortal(newSViv(PL_statcache.st_ino)));
b448e4fe
JH		 2603 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_mode)));
2604 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_nlink)));
146174a9
CB		 2605#if Uid_t_size > IVSIZE
2606 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_uid)));
2607#else
23dcd6c8 2608# if Uid_t_sign <= 0
1ff81528 2609 PUSHs(sv_2mortal(newSViv(PL_statcache.st_uid)));
23dcd6c8
JH		 2610# else
2611 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_uid)));
2612# endif
146174a9 2613#endif
301e8125 2614#if Gid_t_size > IVSIZE
146174a9
CB		 2615 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_gid)));
2616#else
23dcd6c8 2617# if Gid_t_sign <= 0
1ff81528 2618 PUSHs(sv_2mortal(newSViv(PL_statcache.st_gid)));
23dcd6c8
JH		 2619# else
2620 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_gid)));
2621# endif
146174a9 2622#endif
cbdc8872 2623#ifdef USE_STAT_RDEV
1ff81528 2624 PUSHs(sv_2mortal(newSViv(PL_statcache.st_rdev)));
cbdc8872 2625#else
79cb57f6 2626 PUSHs(sv_2mortal(newSVpvn("", 0)));
cbdc8872 2627#endif
146174a9
CB		 2628#if Off_t_size > IVSIZE
2629 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_size)));
2630#else
1ff81528 2631 PUSHs(sv_2mortal(newSViv(PL_statcache.st_size)));
146174a9 2632#endif
cbdc8872 2633#ifdef BIG_TIME
172ae379
JH		 2634 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_atime)));
2635 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_mtime)));
2636 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_ctime)));
cbdc8872 2637#else
1ff81528
PL		 2638 PUSHs(sv_2mortal(newSViv(PL_statcache.st_atime)));
2639 PUSHs(sv_2mortal(newSViv(PL_statcache.st_mtime)));
2640 PUSHs(sv_2mortal(newSViv(PL_statcache.st_ctime)));
cbdc8872 2641#endif
a0d0e21e 2642#ifdef USE_STAT_BLOCKS
b448e4fe
JH		 2643 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blksize)));
2644 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blocks)));
a0d0e21e 2645#else
79cb57f6
GS		 2646 PUSHs(sv_2mortal(newSVpvn("", 0)));
2647 PUSHs(sv_2mortal(newSVpvn("", 0)));
a0d0e21e
LW		 2648#endif
2649 }
2650 RETURN;
2651}
2652
2653PP(pp_ftrread)
2654{
5ff3f7a4 2655 I32 result;
4e35701f 2656 djSP;
5ff3f7a4 2657#if defined(HAS_ACCESS) && defined(R_OK)
2d8e6c8d 2658 STRLEN n_a;
5ff3f7a4 2659 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2660 result = access(TOPpx, R_OK);
5ff3f7a4
GS		 2661 if (result == 0)
2662 RETPUSHYES;
2663 if (result < 0)
2664 RETPUSHUNDEF;
2665 RETPUSHNO;
22865c03
GS		 2666 }
2667 else
cea2e8a9 2668 result = my_stat();
5ff3f7a4 2669#else
cea2e8a9 2670 result = my_stat();
5ff3f7a4 2671#endif
22865c03 2672 SPAGAIN;
a0d0e21e
LW		 2673 if (result < 0)
2674 RETPUSHUNDEF;
3280af22 2675 if (cando(S_IRUSR, 0, &PL_statcache))
a0d0e21e
LW		 2676 RETPUSHYES;
2677 RETPUSHNO;
2678}
2679
2680PP(pp_ftrwrite)
2681{
5ff3f7a4 2682 I32 result;
4e35701f 2683 djSP;
5ff3f7a4 2684#if defined(HAS_ACCESS) && defined(W_OK)
2d8e6c8d 2685 STRLEN n_a;
5ff3f7a4 2686 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2687 result = access(TOPpx, W_OK);
5ff3f7a4
GS		 2688 if (result == 0)
2689 RETPUSHYES;
2690 if (result < 0)
2691 RETPUSHUNDEF;
2692 RETPUSHNO;
22865c03
GS		 2693 }
2694 else
cea2e8a9 2695 result = my_stat();
5ff3f7a4 2696#else
cea2e8a9 2697 result = my_stat();
5ff3f7a4 2698#endif
22865c03 2699 SPAGAIN;
a0d0e21e
LW		 2700 if (result < 0)
2701 RETPUSHUNDEF;
3280af22 2702 if (cando(S_IWUSR, 0, &PL_statcache))
a0d0e21e
LW		 2703 RETPUSHYES;
2704 RETPUSHNO;
2705}
2706
2707PP(pp_ftrexec)
2708{
5ff3f7a4 2709 I32 result;
4e35701f 2710 djSP;
5ff3f7a4 2711#if defined(HAS_ACCESS) && defined(X_OK)
2d8e6c8d 2712 STRLEN n_a;
5ff3f7a4 2713 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2714 result = access(TOPpx, X_OK);
5ff3f7a4
GS		 2715 if (result == 0)
2716 RETPUSHYES;
2717 if (result < 0)
2718 RETPUSHUNDEF;
2719 RETPUSHNO;
22865c03
GS		 2720 }
2721 else
cea2e8a9 2722 result = my_stat();
5ff3f7a4 2723#else
cea2e8a9 2724 result = my_stat();
5ff3f7a4 2725#endif
22865c03 2726 SPAGAIN;
a0d0e21e
LW		 2727 if (result < 0)
2728 RETPUSHUNDEF;
3280af22 2729 if (cando(S_IXUSR, 0, &PL_statcache))
a0d0e21e
LW		 2730 RETPUSHYES;
2731 RETPUSHNO;
2732}
2733
2734PP(pp_fteread)
2735{
5ff3f7a4 2736 I32 result;
4e35701f 2737 djSP;
5ff3f7a4 2738#ifdef PERL_EFF_ACCESS_R_OK
2d8e6c8d 2739 STRLEN n_a;
5ff3f7a4 2740 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2741 result = PERL_EFF_ACCESS_R_OK(TOPpx);
5ff3f7a4
GS		 2742 if (result == 0)
2743 RETPUSHYES;
2744 if (result < 0)
2745 RETPUSHUNDEF;
2746 RETPUSHNO;
22865c03
GS		 2747 }
2748 else
cea2e8a9 2749 result = my_stat();
5ff3f7a4 2750#else
cea2e8a9 2751 result = my_stat();
5ff3f7a4 2752#endif
22865c03 2753 SPAGAIN;
a0d0e21e
LW		 2754 if (result < 0)
2755 RETPUSHUNDEF;
3280af22 2756 if (cando(S_IRUSR, 1, &PL_statcache))
a0d0e21e
LW		 2757 RETPUSHYES;
2758 RETPUSHNO;
2759}
2760
2761PP(pp_ftewrite)
2762{
5ff3f7a4 2763 I32 result;
4e35701f 2764 djSP;
5ff3f7a4 2765#ifdef PERL_EFF_ACCESS_W_OK
2d8e6c8d 2766 STRLEN n_a;
5ff3f7a4 2767 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2768 result = PERL_EFF_ACCESS_W_OK(TOPpx);
5ff3f7a4
GS		 2769 if (result == 0)
2770 RETPUSHYES;
2771 if (result < 0)
2772 RETPUSHUNDEF;
2773 RETPUSHNO;
22865c03
GS		 2774 }
2775 else
cea2e8a9 2776 result = my_stat();
5ff3f7a4 2777#else
cea2e8a9 2778 result = my_stat();
5ff3f7a4 2779#endif
22865c03 2780 SPAGAIN;
a0d0e21e
LW		 2781 if (result < 0)
2782 RETPUSHUNDEF;
3280af22 2783 if (cando(S_IWUSR, 1, &PL_statcache))
a0d0e21e
LW		 2784 RETPUSHYES;
2785 RETPUSHNO;
2786}
2787
2788PP(pp_fteexec)
2789{
5ff3f7a4 2790 I32 result;
4e35701f 2791 djSP;
5ff3f7a4 2792#ifdef PERL_EFF_ACCESS_X_OK
2d8e6c8d 2793 STRLEN n_a;
5ff3f7a4 2794 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2795 result = PERL_EFF_ACCESS_X_OK(TOPpx);
5ff3f7a4
GS		 2796 if (result == 0)
2797 RETPUSHYES;
2798 if (result < 0)
2799 RETPUSHUNDEF;
2800 RETPUSHNO;
22865c03
GS		 2801 }
2802 else
cea2e8a9 2803 result = my_stat();
5ff3f7a4 2804#else
cea2e8a9 2805 result = my_stat();
5ff3f7a4 2806#endif
22865c03 2807 SPAGAIN;
a0d0e21e
LW		 2808 if (result < 0)
2809 RETPUSHUNDEF;
3280af22 2810 if (cando(S_IXUSR, 1, &PL_statcache))
a0d0e21e
LW		 2811 RETPUSHYES;
2812 RETPUSHNO;
2813}
2814
2815PP(pp_ftis)
2816{
cea2e8a9 2817 I32 result = my_stat();
4e35701f 2818 djSP;
a0d0e21e
LW		 2819 if (result < 0)
2820 RETPUSHUNDEF;
2821 RETPUSHYES;
2822}
2823
2824PP(pp_fteowned)
2825{
cea2e8a9 2826 return pp_ftrowned();
a0d0e21e
LW		 2827}
2828
2829PP(pp_ftrowned)
2830{
cea2e8a9 2831 I32 result = my_stat();
4e35701f 2832 djSP;
a0d0e21e
LW		 2833 if (result < 0)
2834 RETPUSHUNDEF;
146174a9
CB		 2835 if (PL_statcache.st_uid == (PL_op->op_type == OP_FTEOWNED ?
2836 PL_euid : PL_uid) )
a0d0e21e
LW		 2837 RETPUSHYES;
2838 RETPUSHNO;
2839}
2840
2841PP(pp_ftzero)
2842{
cea2e8a9 2843 I32 result = my_stat();
4e35701f 2844 djSP;
a0d0e21e
LW		 2845 if (result < 0)
2846 RETPUSHUNDEF;
146174a9 2847 if (PL_statcache.st_size == 0)
a0d0e21e
LW		 2848 RETPUSHYES;
2849 RETPUSHNO;
2850}
2851
2852PP(pp_ftsize)
2853{
cea2e8a9 2854 I32 result = my_stat();
4e35701f 2855 djSP; dTARGET;
a0d0e21e
LW		 2856 if (result < 0)
2857 RETPUSHUNDEF;
146174a9
CB		 2858#if Off_t_size > IVSIZE
2859 PUSHn(PL_statcache.st_size);
2860#else
3280af22 2861 PUSHi(PL_statcache.st_size);
146174a9 2862#endif
a0d0e21e
LW		 2863 RETURN;
2864}
2865
2866PP(pp_ftmtime)
2867{
cea2e8a9 2868 I32 result = my_stat();
4e35701f 2869 djSP; dTARGET;
a0d0e21e
LW		 2870 if (result < 0)
2871 RETPUSHUNDEF;
c6419e06 2872 PUSHn( (PL_basetime - PL_statcache.st_mtime) / 86400.0 );
a0d0e21e
LW		 2873 RETURN;
2874}
2875
2876PP(pp_ftatime)
2877{
cea2e8a9 2878 I32 result = my_stat();
4e35701f 2879 djSP; dTARGET;
a0d0e21e
LW		 2880 if (result < 0)
2881 RETPUSHUNDEF;
c6419e06 2882 PUSHn( (PL_basetime - PL_statcache.st_atime) / 86400.0 );
a0d0e21e
LW		 2883 RETURN;
2884}
2885
2886PP(pp_ftctime)
2887{
cea2e8a9 2888 I32 result = my_stat();
4e35701f 2889 djSP; dTARGET;
a0d0e21e
LW		 2890 if (result < 0)
2891 RETPUSHUNDEF;
c6419e06 2892 PUSHn( (PL_basetime - PL_statcache.st_ctime) / 86400.0 );
a0d0e21e
LW		 2893 RETURN;
2894}
2895
2896PP(pp_ftsock)
2897{
cea2e8a9 2898 I32 result = my_stat();
4e35701f 2899 djSP;
a0d0e21e
LW		 2900 if (result < 0)
2901 RETPUSHUNDEF;
3280af22 2902 if (S_ISSOCK(PL_statcache.st_mode))
a0d0e21e
LW		 2903 RETPUSHYES;
2904 RETPUSHNO;
2905}
2906
2907PP(pp_ftchr)
2908{
cea2e8a9 2909 I32 result = my_stat();
4e35701f 2910 djSP;
a0d0e21e
LW		 2911 if (result < 0)
2912 RETPUSHUNDEF;
3280af22 2913 if (S_ISCHR(PL_statcache.st_mode))
a0d0e21e
LW		 2914 RETPUSHYES;
2915 RETPUSHNO;
2916}
2917
2918PP(pp_ftblk)
2919{
cea2e8a9 2920 I32 result = my_stat();
4e35701f 2921 djSP;
a0d0e21e
LW		 2922 if (result < 0)
2923 RETPUSHUNDEF;
3280af22 2924 if (S_ISBLK(PL_statcache.st_mode))
a0d0e21e
LW		 2925 RETPUSHYES;
2926 RETPUSHNO;
2927}
2928
2929PP(pp_ftfile)
2930{
cea2e8a9 2931 I32 result = my_stat();
4e35701f 2932 djSP;
a0d0e21e
LW		 2933 if (result < 0)
2934 RETPUSHUNDEF;
3280af22 2935 if (S_ISREG(PL_statcache.st_mode))
a0d0e21e
LW		 2936 RETPUSHYES;
2937 RETPUSHNO;
2938}
2939
2940PP(pp_ftdir)
2941{
cea2e8a9 2942 I32 result = my_stat();
4e35701f 2943 djSP;
a0d0e21e
LW		 2944 if (result < 0)
2945 RETPUSHUNDEF;
3280af22 2946 if (S_ISDIR(PL_statcache.st_mode))
a0d0e21e
LW		 2947 RETPUSHYES;
2948 RETPUSHNO;
2949}
2950
2951PP(pp_ftpipe)
2952{
cea2e8a9 2953 I32 result = my_stat();
4e35701f 2954 djSP;
a0d0e21e
LW		 2955 if (result < 0)
2956 RETPUSHUNDEF;
3280af22 2957 if (S_ISFIFO(PL_statcache.st_mode))
a0d0e21e
LW		 2958 RETPUSHYES;
2959 RETPUSHNO;
2960}
2961
2962PP(pp_ftlink)
2963{
cea2e8a9 2964 I32 result = my_lstat();
4e35701f 2965 djSP;
a0d0e21e
LW		 2966 if (result < 0)
2967 RETPUSHUNDEF;
3280af22 2968 if (S_ISLNK(PL_statcache.st_mode))
a0d0e21e
LW		 2969 RETPUSHYES;
2970 RETPUSHNO;
2971}
2972
2973PP(pp_ftsuid)
2974{
4e35701f 2975 djSP;
a0d0e21e 2976#ifdef S_ISUID
cea2e8a9 2977 I32 result = my_stat();
a0d0e21e
LW		 2978 SPAGAIN;
2979 if (result < 0)
2980 RETPUSHUNDEF;
3280af22 2981 if (PL_statcache.st_mode & S_ISUID)
a0d0e21e
LW		 2982 RETPUSHYES;
2983#endif
2984 RETPUSHNO;
2985}
2986
2987PP(pp_ftsgid)
2988{
4e35701f 2989 djSP;
a0d0e21e 2990#ifdef S_ISGID
cea2e8a9 2991 I32 result = my_stat();
a0d0e21e
LW		 2992 SPAGAIN;
2993 if (result < 0)
2994 RETPUSHUNDEF;
3280af22 2995 if (PL_statcache.st_mode & S_ISGID)
a0d0e21e
LW		 2996 RETPUSHYES;
2997#endif
2998 RETPUSHNO;
2999}
3000
3001PP(pp_ftsvtx)
3002{
4e35701f 3003 djSP;
a0d0e21e 3004#ifdef S_ISVTX
cea2e8a9 3005 I32 result = my_stat();
a0d0e21e
LW		 3006 SPAGAIN;
3007 if (result < 0)
3008 RETPUSHUNDEF;
3280af22 3009 if (PL_statcache.st_mode & S_ISVTX)
a0d0e21e
LW		 3010 RETPUSHYES;
3011#endif
3012 RETPUSHNO;
3013}
3014
3015PP(pp_fttty)
3016{
4e35701f 3017 djSP;
a0d0e21e
LW		 3018 int fd;
3019 GV *gv;
fb73857a 3020 char *tmps = Nullch;
2d8e6c8d 3021 STRLEN n_a;
fb73857a 3022
533c011a 3023 if (PL_op->op_flags & OPf_REF)
146174a9 3024 gv = cGVOP_gv;
fb73857a 3025 else if (isGV(TOPs))
3026 gv = (GV*)POPs;
3027 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3028 gv = (GV*)SvRV(POPs);
a0d0e21e 3029 else
2d8e6c8d 3030 gv = gv_fetchpv(tmps = POPpx, FALSE, SVt_PVIO);
fb73857a 3031
a0d0e21e 3032 if (GvIO(gv) && IoIFP(GvIOp(gv)))
760ac839 3033 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
fb73857a 3034 else if (tmps && isDIGIT(*tmps))
a0d0e21e
LW		 3035 fd = atoi(tmps);
3036 else
3037 RETPUSHUNDEF;
6ad3d225 3038 if (PerlLIO_isatty(fd))
a0d0e21e
LW		 3039 RETPUSHYES;
3040 RETPUSHNO;
3041}
3042
16d20bd9
AD		 3043#if defined(atarist) /* this will work with atariST. Configure will
3044 make guesses for other systems. */
3045# define FILE_base(f) ((f)->_base)
3046# define FILE_ptr(f) ((f)->_ptr)
3047# define FILE_cnt(f) ((f)->_cnt)
3048# define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
a0d0e21e
LW		 3049#endif
3050
3051PP(pp_fttext)
3052{
4e35701f 3053 djSP;
a0d0e21e
LW		 3054 I32 i;
3055 I32 len;
3056 I32 odd = 0;
3057 STDCHAR tbuf[512];
3058 register STDCHAR *s;
3059 register IO *io;
5f05dabc 3060 register SV *sv;
3061 GV *gv;
2d8e6c8d 3062 STRLEN n_a;
146174a9 3063 PerlIO *fp;
a0d0e21e 3064
533c011a 3065 if (PL_op->op_flags & OPf_REF)
146174a9 3066 gv = cGVOP_gv;
5f05dabc 3067 else if (isGV(TOPs))
3068 gv = (GV*)POPs;
3069 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3070 gv = (GV*)SvRV(POPs);
3071 else
3072 gv = Nullgv;
3073
3074 if (gv) {
a0d0e21e 3075 EXTEND(SP, 1);
3280af22
NIS		 3076 if (gv == PL_defgv) {
3077 if (PL_statgv)
3078 io = GvIO(PL_statgv);
a0d0e21e 3079 else {
3280af22 3080 sv = PL_statname;
a0d0e21e
LW		 3081 goto really_filename;
3082 }
3083 }
3084 else {
3280af22
NIS		 3085 PL_statgv = gv;
3086 PL_laststatval = -1;
3087 sv_setpv(PL_statname, "");
3088 io = GvIO(PL_statgv);
a0d0e21e
LW		 3089 }
3090 if (io && IoIFP(io)) {
5f05dabc 3091 if (! PerlIO_has_base(IoIFP(io)))
cea2e8a9 3092 DIE(aTHX_ "-T and -B not implemented on filehandles");
3280af22
NIS		 3093 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3094 if (PL_laststatval < 0)
5f05dabc 3095 RETPUSHUNDEF;
3280af22 3096 if (S_ISDIR(PL_statcache.st_mode)) /* handle NFS glitch */
533c011a 3097 if (PL_op->op_type == OP_FTTEXT)
a0d0e21e
LW		 3098 RETPUSHNO;
3099 else
3100 RETPUSHYES;
a20bf0c3 3101 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
760ac839 3102 i = PerlIO_getc(IoIFP(io));
a0d0e21e 3103 if (i != EOF)
760ac839 3104 (void)PerlIO_ungetc(IoIFP(io),i);
a0d0e21e 3105 }
a20bf0c3 3106 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
a0d0e21e 3107 RETPUSHYES;
a20bf0c3
JH		 3108 len = PerlIO_get_bufsiz(IoIFP(io));
3109 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
760ac839
LW		 3110 /* sfio can have large buffers - limit to 512 */
3111 if (len > 512)
3112 len = 512;
a0d0e21e
LW		 3113 }
3114 else {
2dd78f96
JH		 3115 dTHR;
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 }
92d29cee 3140 do_binmode(fp, '<', O_BINARY);
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.