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