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