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