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