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