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