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