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