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