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