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
Buglet found by Mark Bixby: "./try >&2 >/dev/null" should
[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
LW		 1991 int result = 1;
1992 GV *tmpgv;
2d8e6c8d 1993 STRLEN n_a;
a0d0e21e 1994
8c99d73e
GS		 1995#if Size_t_size > IVSIZE
1996 len = (Off_t)POPn;
1997#else
1998 len = (Off_t)POPi;
1999#endif
2000 /* Checking for length < 0 is problematic as the type might or
301e8125 2001 * might not be signed: if it is not, clever compilers will moan. */
8c99d73e 2002 /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
748a9306 2003 SETERRNO(0,0);
5d94fbed 2004#if defined(HAS_TRUNCATE) || defined(HAS_CHSIZE) || defined(F_FREESP)
533c011a 2005 if (PL_op->op_flags & OPf_SPECIAL) {
2d8e6c8d 2006 tmpgv = gv_fetchpv(POPpx, FALSE, SVt_PVIO);
cbdc8872 2007 do_ftruncate:
1e422769 2008 TAINT_PROPER("truncate");
cb50131a
CB		 2009 if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv)))
2010 result = 0;
2011 else {
2012 PerlIO_flush(IoIFP(GvIOp(tmpgv)));
cbdc8872 2013#ifdef HAS_TRUNCATE
cb50131a 2014 if (ftruncate(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
301e8125 2015#else
cb50131a 2016 if (my_chsize(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
cbdc8872 2017#endif
cb50131a
CB		 2018 result = 0;
2019 }
a0d0e21e
LW		 2020 }
2021 else {
cbdc8872 2022 SV *sv = POPs;
1e422769 2023 char *name;
2d8e6c8d 2024 STRLEN n_a;
1e422769 2025
cbdc8872 2026 if (SvTYPE(sv) == SVt_PVGV) {
2027 tmpgv = (GV*)sv; /* *main::FRED for example */
2028 goto do_ftruncate;
2029 }
2030 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2031 tmpgv = (GV*) SvRV(sv); /* \*main::FRED for example */
2032 goto do_ftruncate;
2033 }
1e422769 2034
2d8e6c8d 2035 name = SvPV(sv, n_a);
1e422769 2036 TAINT_PROPER("truncate");
cbdc8872 2037#ifdef HAS_TRUNCATE
1e422769 2038 if (truncate(name, len) < 0)
a0d0e21e 2039 result = 0;
cbdc8872 2040#else
2041 {
2042 int tmpfd;
6ad3d225 2043 if ((tmpfd = PerlLIO_open(name, O_RDWR)) < 0)
bbce6d69 2044 result = 0;
cbdc8872 2045 else {
2046 if (my_chsize(tmpfd, len) < 0)
2047 result = 0;
6ad3d225 2048 PerlLIO_close(tmpfd);
cbdc8872 2049 }
a0d0e21e 2050 }
a0d0e21e 2051#endif
cbdc8872 2052 }
a0d0e21e
LW		 2053
2054 if (result)
2055 RETPUSHYES;
2056 if (!errno)
748a9306 2057 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW		 2058 RETPUSHUNDEF;
2059#else
cea2e8a9 2060 DIE(aTHX_ "truncate not implemented");
a0d0e21e
LW		 2061#endif
2062}
2063
2064PP(pp_fcntl)
2065{
cea2e8a9 2066 return pp_ioctl();
a0d0e21e
LW		 2067}
2068
2069PP(pp_ioctl)
2070{
39644a26 2071 dSP; dTARGET;
748a9306 2072 SV *argsv = POPs;
3bb7c1b4 2073 unsigned int func = POPu;
533c011a 2074 int optype = PL_op->op_type;
a0d0e21e 2075 char *s;
324aa91a 2076 IV retval;
a0d0e21e 2077 GV *gv = (GV*)POPs;
c289d2f7 2078 IO *io = gv ? GvIOn(gv) : 0;
a0d0e21e 2079
748a9306 2080 if (!io || !argsv || !IoIFP(io)) {
c289d2f7
JH		 2081 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2082 report_evil_fh(gv, io, PL_op->op_type);
748a9306 2083 SETERRNO(EBADF,RMS$_IFI); /* well, sort of... */
a0d0e21e
LW		 2084 RETPUSHUNDEF;
2085 }
2086
748a9306 2087 if (SvPOK(argsv) || !SvNIOK(argsv)) {
a0d0e21e 2088 STRLEN len;
324aa91a 2089 STRLEN need;
748a9306 2090 s = SvPV_force(argsv, len);
324aa91a
HF		 2091 need = IOCPARM_LEN(func);
2092 if (len < need) {
2093 s = Sv_Grow(argsv, need + 1);
2094 SvCUR_set(argsv, need);
a0d0e21e
LW		 2095 }
2096
748a9306 2097 s[SvCUR(argsv)] = 17; /* a little sanity check here */
a0d0e21e
LW		 2098 }
2099 else {
748a9306 2100 retval = SvIV(argsv);
c529f79d 2101 s = INT2PTR(char*,retval); /* ouch */
a0d0e21e
LW		 2102 }
2103
2104 TAINT_PROPER(optype == OP_IOCTL ? "ioctl" : "fcntl");
2105
2106 if (optype == OP_IOCTL)
2107#ifdef HAS_IOCTL
76e3520e 2108 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
a0d0e21e 2109#else
cea2e8a9 2110 DIE(aTHX_ "ioctl is not implemented");
a0d0e21e
LW		 2111#endif
2112 else
55497cff 2113#ifdef HAS_FCNTL
2114#if defined(OS2) && defined(__EMX__)
760ac839 2115 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
55497cff 2116#else
760ac839 2117 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
301e8125 2118#endif
55497cff 2119#else
cea2e8a9 2120 DIE(aTHX_ "fcntl is not implemented");
a0d0e21e
LW		 2121#endif
2122
748a9306
LW		 2123 if (SvPOK(argsv)) {
2124 if (s[SvCUR(argsv)] != 17)
cea2e8a9 2125 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
22c35a8c 2126 PL_op_name[optype]);
748a9306
LW		 2127 s[SvCUR(argsv)] = 0; /* put our null back */
2128 SvSETMAGIC(argsv); /* Assume it has changed */
a0d0e21e
LW		 2129 }
2130
2131 if (retval == -1)
2132 RETPUSHUNDEF;
2133 if (retval != 0) {
2134 PUSHi(retval);
2135 }
2136 else {
8903cb82 2137 PUSHp(zero_but_true, ZBTLEN);
a0d0e21e
LW		 2138 }
2139 RETURN;
2140}
2141
2142PP(pp_flock)
2143{
39644a26 2144 dSP; dTARGET;
a0d0e21e
LW		 2145 I32 value;
2146 int argtype;
2147 GV *gv;
bc37a18f 2148 IO *io = NULL;
760ac839 2149 PerlIO *fp;
16d20bd9 2150
ff68c719 2151#ifdef FLOCK
a0d0e21e 2152 argtype = POPi;
32da55ab 2153 if (MAXARG == 0)
3280af22 2154 gv = PL_last_in_gv;
a0d0e21e
LW		 2155 else
2156 gv = (GV*)POPs;
bc37a18f
RG		 2157 if (gv && (io = GvIO(gv)))
2158 fp = IoIFP(io);
2159 else {
a0d0e21e 2160 fp = Nullfp;
bc37a18f
RG		 2161 io = NULL;
2162 }
a0d0e21e 2163 if (fp) {
68dc0745 2164 (void)PerlIO_flush(fp);
76e3520e 2165 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
a0d0e21e 2166 }
cb50131a 2167 else {
bc37a18f
RG		 2168 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2169 report_evil_fh(gv, io, PL_op->op_type);
a0d0e21e 2170 value = 0;
cb50131a 2171 SETERRNO(EBADF,RMS$_IFI);
cb50131a 2172 }
a0d0e21e
LW		 2173 PUSHi(value);
2174 RETURN;
2175#else
cea2e8a9 2176 DIE(aTHX_ PL_no_func, "flock()");
a0d0e21e
LW		 2177#endif
2178}
2179
2180/* Sockets. */
2181
2182PP(pp_socket)
2183{
39644a26 2184 dSP;
a0d0e21e
LW		 2185#ifdef HAS_SOCKET
2186 GV *gv;
2187 register IO *io;
2188 int protocol = POPi;
2189 int type = POPi;
2190 int domain = POPi;
2191 int fd;
2192
2193 gv = (GV*)POPs;
c289d2f7 2194 io = gv ? GvIOn(gv) : NULL;
a0d0e21e 2195
c289d2f7
JH		 2196 if (!gv || !io) {
2197 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2198 report_evil_fh(gv, io, PL_op->op_type);
2199 if (IoIFP(io))
2200 do_close(gv, FALSE);
748a9306 2201 SETERRNO(EBADF,LIB$_INVARG);
a0d0e21e
LW		 2202 RETPUSHUNDEF;
2203 }
2204
57171420
BS		 2205 if (IoIFP(io))
2206 do_close(gv, FALSE);
2207
a0d0e21e 2208 TAINT_PROPER("socket");
6ad3d225 2209 fd = PerlSock_socket(domain, type, protocol);
a0d0e21e
LW		 2210 if (fd < 0)
2211 RETPUSHUNDEF;
760ac839
LW		 2212 IoIFP(io) = PerlIO_fdopen(fd, "r"); /* stdio gets confused about sockets */
2213 IoOFP(io) = PerlIO_fdopen(fd, "w");
50952442 2214 IoTYPE(io) = IoTYPE_SOCKET;
a0d0e21e 2215 if (!IoIFP(io) || !IoOFP(io)) {
760ac839
LW		 2216 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2217 if (IoOFP(io)) PerlIO_close(IoOFP(io));
6ad3d225 2218 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
a0d0e21e
LW		 2219 RETPUSHUNDEF;
2220 }
8d2a6795
GS		 2221#if defined(HAS_FCNTL) && defined(F_SETFD)
2222 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2223#endif
a0d0e21e 2224
d5ff79b3
OF		 2225#ifdef EPOC
2226 setbuf( IoIFP(io), NULL); /* EPOC gets confused about sockets */
2227#endif
2228
a0d0e21e
LW		 2229 RETPUSHYES;
2230#else
cea2e8a9 2231 DIE(aTHX_ PL_no_sock_func, "socket");
a0d0e21e
LW		 2232#endif
2233}
2234
2235PP(pp_sockpair)
2236{
39644a26 2237 dSP;
a0d0e21e
LW		 2238#ifdef HAS_SOCKETPAIR
2239 GV *gv1;
2240 GV *gv2;
2241 register IO *io1;
2242 register IO *io2;
2243 int protocol = POPi;
2244 int type = POPi;
2245 int domain = POPi;
2246 int fd[2];
2247
2248 gv2 = (GV*)POPs;
2249 gv1 = (GV*)POPs;
c289d2f7
JH		 2250 io1 = gv1 ? GvIOn(gv1) : NULL;
2251 io2 = gv2 ? GvIOn(gv2) : NULL;
2252 if (!gv1 || !gv2 || !io1 || !io2) {
2253 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
2254 if (!gv1 || !io1)
2255 report_evil_fh(gv1, io1, PL_op->op_type);
2256 if (!gv2 || !io2)
2257 report_evil_fh(gv1, io2, PL_op->op_type);
2258 }
2259 if (IoIFP(io1))
2260 do_close(gv1, FALSE);
2261 if (IoIFP(io2))
2262 do_close(gv2, FALSE);
a0d0e21e 2263 RETPUSHUNDEF;
c289d2f7 2264 }
a0d0e21e 2265
dc0d0a5f
JH		 2266 if (IoIFP(io1))
2267 do_close(gv1, FALSE);
2268 if (IoIFP(io2))
2269 do_close(gv2, FALSE);
57171420 2270
a0d0e21e 2271 TAINT_PROPER("socketpair");
6ad3d225 2272 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
a0d0e21e 2273 RETPUSHUNDEF;
760ac839
LW		 2274 IoIFP(io1) = PerlIO_fdopen(fd[0], "r");
2275 IoOFP(io1) = PerlIO_fdopen(fd[0], "w");
50952442 2276 IoTYPE(io1) = IoTYPE_SOCKET;
760ac839
LW		 2277 IoIFP(io2) = PerlIO_fdopen(fd[1], "r");
2278 IoOFP(io2) = PerlIO_fdopen(fd[1], "w");
50952442 2279 IoTYPE(io2) = IoTYPE_SOCKET;
a0d0e21e 2280 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
760ac839
LW		 2281 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2282 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
6ad3d225 2283 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
760ac839
LW		 2284 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2285 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
6ad3d225 2286 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
a0d0e21e
LW		 2287 RETPUSHUNDEF;
2288 }
8d2a6795
GS		 2289#if defined(HAS_FCNTL) && defined(F_SETFD)
2290 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
2291 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
2292#endif
a0d0e21e
LW		 2293
2294 RETPUSHYES;
2295#else
cea2e8a9 2296 DIE(aTHX_ PL_no_sock_func, "socketpair");
a0d0e21e
LW		 2297#endif
2298}
2299
2300PP(pp_bind)
2301{
39644a26 2302 dSP;
a0d0e21e 2303#ifdef HAS_SOCKET
eec2d3df
GS		 2304#ifdef MPE /* Requires PRIV mode to bind() to ports < 1024 */
2305 extern GETPRIVMODE();
2306 extern GETUSERMODE();
2307#endif
748a9306 2308 SV *addrsv = POPs;
a0d0e21e
LW		 2309 char *addr;
2310 GV *gv = (GV*)POPs;
2311 register IO *io = GvIOn(gv);
2312 STRLEN len;
eec2d3df
GS		 2313 int bind_ok = 0;
2314#ifdef MPE
2315 int mpeprivmode = 0;
2316#endif
a0d0e21e
LW		 2317
2318 if (!io || !IoIFP(io))
2319 goto nuts;
2320
748a9306 2321 addr = SvPV(addrsv, len);
a0d0e21e 2322 TAINT_PROPER("bind");
eec2d3df
GS		 2323#ifdef MPE /* Deal with MPE bind() peculiarities */
2324 if (((struct sockaddr *)addr)->sa_family == AF_INET) {
2325 /* The address *MUST* stupidly be zero. */
2326 ((struct sockaddr_in *)addr)->sin_addr.s_addr = INADDR_ANY;
2327 /* PRIV mode is required to bind() to ports < 1024. */
2328 if (((struct sockaddr_in *)addr)->sin_port < 1024 &&
2329 ((struct sockaddr_in *)addr)->sin_port > 0) {
2330 GETPRIVMODE(); /* If this fails, we are aborted by MPE/iX. */
2331 mpeprivmode = 1;
2332 }
2333 }
2334#endif /* MPE */
2335 if (PerlSock_bind(PerlIO_fileno(IoIFP(io)),
2336 (struct sockaddr *)addr, len) >= 0)
2337 bind_ok = 1;
2338
2339#ifdef MPE /* Switch back to USER mode */
2340 if (mpeprivmode)
2341 GETUSERMODE();
2342#endif /* MPE */
2343
2344 if (bind_ok)
a0d0e21e
LW		 2345 RETPUSHYES;
2346 else
2347 RETPUSHUNDEF;
2348
2349nuts:
599cee73 2350 if (ckWARN(WARN_CLOSED))
bc37a18f 2351 report_evil_fh(gv, io, PL_op->op_type);
748a9306 2352 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2353 RETPUSHUNDEF;
2354#else
cea2e8a9 2355 DIE(aTHX_ PL_no_sock_func, "bind");
a0d0e21e
LW		 2356#endif
2357}
2358
2359PP(pp_connect)
2360{
39644a26 2361 dSP;
a0d0e21e 2362#ifdef HAS_SOCKET
748a9306 2363 SV *addrsv = POPs;
a0d0e21e
LW		 2364 char *addr;
2365 GV *gv = (GV*)POPs;
2366 register IO *io = GvIOn(gv);
2367 STRLEN len;
2368
2369 if (!io || !IoIFP(io))
2370 goto nuts;
2371
748a9306 2372 addr = SvPV(addrsv, len);
a0d0e21e 2373 TAINT_PROPER("connect");
6ad3d225 2374 if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
a0d0e21e
LW		 2375 RETPUSHYES;
2376 else
2377 RETPUSHUNDEF;
2378
2379nuts:
599cee73 2380 if (ckWARN(WARN_CLOSED))
bc37a18f 2381 report_evil_fh(gv, io, PL_op->op_type);
748a9306 2382 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2383 RETPUSHUNDEF;
2384#else
cea2e8a9 2385 DIE(aTHX_ PL_no_sock_func, "connect");
a0d0e21e
LW		 2386#endif
2387}
2388
2389PP(pp_listen)
2390{
39644a26 2391 dSP;
a0d0e21e
LW		 2392#ifdef HAS_SOCKET
2393 int backlog = POPi;
2394 GV *gv = (GV*)POPs;
c289d2f7 2395 register IO *io = gv ? GvIOn(gv) : NULL;
a0d0e21e 2396
c289d2f7 2397 if (!gv || !io || !IoIFP(io))
a0d0e21e
LW		 2398 goto nuts;
2399
6ad3d225 2400 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
a0d0e21e
LW		 2401 RETPUSHYES;
2402 else
2403 RETPUSHUNDEF;
2404
2405nuts:
599cee73 2406 if (ckWARN(WARN_CLOSED))
bc37a18f 2407 report_evil_fh(gv, io, PL_op->op_type);
748a9306 2408 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2409 RETPUSHUNDEF;
2410#else
cea2e8a9 2411 DIE(aTHX_ PL_no_sock_func, "listen");
a0d0e21e
LW		 2412#endif
2413}
2414
2415PP(pp_accept)
2416{
39644a26 2417 dSP; dTARGET;
a0d0e21e
LW		 2418#ifdef HAS_SOCKET
2419 GV *ngv;
2420 GV *ggv;
2421 register IO *nstio;
2422 register IO *gstio;
4633a7c4 2423 struct sockaddr saddr; /* use a struct to avoid alignment problems */
1e422769 2424 Sock_size_t len = sizeof saddr;
a0d0e21e
LW		 2425 int fd;
2426
2427 ggv = (GV*)POPs;
2428 ngv = (GV*)POPs;
2429
2430 if (!ngv)
2431 goto badexit;
2432 if (!ggv)
2433 goto nuts;
2434
2435 gstio = GvIO(ggv);
2436 if (!gstio || !IoIFP(gstio))
2437 goto nuts;
2438
2439 nstio = GvIOn(ngv);
2440 if (IoIFP(nstio))
2441 do_close(ngv, FALSE);
2442
6ad3d225 2443 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *)&saddr, &len);
a0d0e21e
LW		 2444 if (fd < 0)
2445 goto badexit;
760ac839
LW		 2446 IoIFP(nstio) = PerlIO_fdopen(fd, "r");
2447 IoOFP(nstio) = PerlIO_fdopen(fd, "w");
50952442 2448 IoTYPE(nstio) = IoTYPE_SOCKET;
a0d0e21e 2449 if (!IoIFP(nstio) || !IoOFP(nstio)) {
760ac839
LW		 2450 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2451 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
6ad3d225 2452 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
a0d0e21e
LW		 2453 goto badexit;
2454 }
8d2a6795
GS		 2455#if defined(HAS_FCNTL) && defined(F_SETFD)
2456 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2457#endif
a0d0e21e 2458
ed79a026 2459#ifdef EPOC
a9f1f6b0
OF		 2460 len = sizeof saddr; /* EPOC somehow truncates info */
2461 setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */
ed79a026
OF		 2462#endif
2463
748a9306 2464 PUSHp((char *)&saddr, len);
a0d0e21e
LW		 2465 RETURN;
2466
2467nuts:
599cee73 2468 if (ckWARN(WARN_CLOSED))
bc37a18f 2469 report_evil_fh(ggv, ggv ? GvIO(ggv) : 0, PL_op->op_type);
748a9306 2470 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2471
2472badexit:
2473 RETPUSHUNDEF;
2474
2475#else
cea2e8a9 2476 DIE(aTHX_ PL_no_sock_func, "accept");
a0d0e21e
LW		 2477#endif
2478}
2479
2480PP(pp_shutdown)
2481{
39644a26 2482 dSP; dTARGET;
a0d0e21e
LW		 2483#ifdef HAS_SOCKET
2484 int how = POPi;
2485 GV *gv = (GV*)POPs;
2486 register IO *io = GvIOn(gv);
2487
2488 if (!io || !IoIFP(io))
2489 goto nuts;
2490
6ad3d225 2491 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
a0d0e21e
LW		 2492 RETURN;
2493
2494nuts:
599cee73 2495 if (ckWARN(WARN_CLOSED))
bc37a18f 2496 report_evil_fh(gv, io, PL_op->op_type);
748a9306 2497 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2498 RETPUSHUNDEF;
2499#else
cea2e8a9 2500 DIE(aTHX_ PL_no_sock_func, "shutdown");
a0d0e21e
LW		 2501#endif
2502}
2503
2504PP(pp_gsockopt)
2505{
2506#ifdef HAS_SOCKET
cea2e8a9 2507 return pp_ssockopt();
a0d0e21e 2508#else
cea2e8a9 2509 DIE(aTHX_ PL_no_sock_func, "getsockopt");
a0d0e21e
LW		 2510#endif
2511}
2512
2513PP(pp_ssockopt)
2514{
39644a26 2515 dSP;
a0d0e21e 2516#ifdef HAS_SOCKET
533c011a 2517 int optype = PL_op->op_type;
a0d0e21e
LW		 2518 SV *sv;
2519 int fd;
2520 unsigned int optname;
2521 unsigned int lvl;
2522 GV *gv;
2523 register IO *io;
1e422769 2524 Sock_size_t len;
a0d0e21e
LW		 2525
2526 if (optype == OP_GSOCKOPT)
2527 sv = sv_2mortal(NEWSV(22, 257));
2528 else
2529 sv = POPs;
2530 optname = (unsigned int) POPi;
2531 lvl = (unsigned int) POPi;
2532
2533 gv = (GV*)POPs;
2534 io = GvIOn(gv);
2535 if (!io || !IoIFP(io))
2536 goto nuts;
2537
760ac839 2538 fd = PerlIO_fileno(IoIFP(io));
a0d0e21e
LW		 2539 switch (optype) {
2540 case OP_GSOCKOPT:
748a9306 2541 SvGROW(sv, 257);
a0d0e21e 2542 (void)SvPOK_only(sv);
748a9306
LW		 2543 SvCUR_set(sv,256);
2544 *SvEND(sv) ='\0';
1e422769 2545 len = SvCUR(sv);
6ad3d225 2546 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
a0d0e21e 2547 goto nuts2;
1e422769 2548 SvCUR_set(sv, len);
748a9306 2549 *SvEND(sv) ='\0';
a0d0e21e
LW		 2550 PUSHs(sv);
2551 break;
2552 case OP_SSOCKOPT: {
1e422769 2553 char *buf;
2554 int aint;
2555 if (SvPOKp(sv)) {
2d8e6c8d
GS		 2556 STRLEN l;
2557 buf = SvPV(sv, l);
2558 len = l;
1e422769 2559 }
56ee1660 2560 else {
a0d0e21e
LW		 2561 aint = (int)SvIV(sv);
2562 buf = (char*)&aint;
2563 len = sizeof(int);
2564 }
6ad3d225 2565 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
a0d0e21e 2566 goto nuts2;
3280af22 2567 PUSHs(&PL_sv_yes);
a0d0e21e
LW		 2568 }
2569 break;
2570 }
2571 RETURN;
2572
2573nuts:
599cee73 2574 if (ckWARN(WARN_CLOSED))
bc37a18f 2575 report_evil_fh(gv, io, optype);
748a9306 2576 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2577nuts2:
2578 RETPUSHUNDEF;
2579
2580#else
cea2e8a9 2581 DIE(aTHX_ PL_no_sock_func, "setsockopt");
a0d0e21e
LW		 2582#endif
2583}
2584
2585PP(pp_getsockname)
2586{
2587#ifdef HAS_SOCKET
cea2e8a9 2588 return pp_getpeername();
a0d0e21e 2589#else
cea2e8a9 2590 DIE(aTHX_ PL_no_sock_func, "getsockname");
a0d0e21e
LW		 2591#endif
2592}
2593
2594PP(pp_getpeername)
2595{
39644a26 2596 dSP;
a0d0e21e 2597#ifdef HAS_SOCKET
533c011a 2598 int optype = PL_op->op_type;
a0d0e21e
LW		 2599 SV *sv;
2600 int fd;
2601 GV *gv = (GV*)POPs;
2602 register IO *io = GvIOn(gv);
1e422769 2603 Sock_size_t len;
a0d0e21e
LW		 2604
2605 if (!io || !IoIFP(io))
2606 goto nuts;
2607
2608 sv = sv_2mortal(NEWSV(22, 257));
748a9306 2609 (void)SvPOK_only(sv);
1e422769 2610 len = 256;
2611 SvCUR_set(sv, len);
748a9306 2612 *SvEND(sv) ='\0';
760ac839 2613 fd = PerlIO_fileno(IoIFP(io));
a0d0e21e
LW		 2614 switch (optype) {
2615 case OP_GETSOCKNAME:
6ad3d225 2616 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
a0d0e21e
LW		 2617 goto nuts2;
2618 break;
2619 case OP_GETPEERNAME:
6ad3d225 2620 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
a0d0e21e 2621 goto nuts2;
490ab354
JH		 2622#if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2623 {
2624 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";
2625 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2626 if (((struct sockaddr *)SvPVX(sv))->sa_family == AF_INET &&
2627 !memcmp((char *)SvPVX(sv) + sizeof(u_short), nowhere,
2628 sizeof(u_short) + sizeof(struct in_addr))) {
301e8125 2629 goto nuts2;
490ab354
JH		 2630 }
2631 }
2632#endif
a0d0e21e
LW		 2633 break;
2634 }
13826f2c
CS		 2635#ifdef BOGUS_GETNAME_RETURN
2636 /* Interactive Unix, getpeername() and getsockname()
2637 does not return valid namelen */
1e422769 2638 if (len == BOGUS_GETNAME_RETURN)
2639 len = sizeof(struct sockaddr);
13826f2c 2640#endif
1e422769 2641 SvCUR_set(sv, len);
748a9306 2642 *SvEND(sv) ='\0';
a0d0e21e
LW		 2643 PUSHs(sv);
2644 RETURN;
2645
2646nuts:
599cee73 2647 if (ckWARN(WARN_CLOSED))
bc37a18f 2648 report_evil_fh(gv, io, optype);
748a9306 2649 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2650nuts2:
2651 RETPUSHUNDEF;
2652
2653#else
cea2e8a9 2654 DIE(aTHX_ PL_no_sock_func, "getpeername");
a0d0e21e
LW		 2655#endif
2656}
2657
2658/* Stat calls. */
2659
2660PP(pp_lstat)
2661{
cea2e8a9 2662 return pp_stat();
a0d0e21e
LW		 2663}
2664
2665PP(pp_stat)
2666{
39644a26 2667 dSP;
2dd78f96 2668 GV *gv;
54310121 2669 I32 gimme;
a0d0e21e 2670 I32 max = 13;
2d8e6c8d 2671 STRLEN n_a;
a0d0e21e 2672
533c011a 2673 if (PL_op->op_flags & OPf_REF) {
2dd78f96 2674 gv = cGVOP_gv;
8a4e5b40
DD		 2675 if (PL_op->op_type == OP_LSTAT) {
2676 if (PL_laststype != OP_LSTAT)
2677 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2678 if (ckWARN(WARN_IO) && gv != PL_defgv)
2679 Perl_warner(aTHX_ WARN_IO,
2dd78f96 2680 "lstat() on filehandle %s", GvENAME(gv));
8a4e5b40
DD		 2681 /* Perl_my_lstat (-l) croak's on filehandle, why warn here? */
2682 }
2683
748a9306 2684 do_fstat:
2dd78f96 2685 if (gv != PL_defgv) {
3280af22 2686 PL_laststype = OP_STAT;
2dd78f96 2687 PL_statgv = gv;
3280af22 2688 sv_setpv(PL_statname, "");
2dd78f96
JH		 2689 PL_laststatval = (GvIO(gv) && IoIFP(GvIOp(gv))
2690 ? PerlLIO_fstat(PerlIO_fileno(IoIFP(GvIOn(gv))), &PL_statcache) : -1);
a0d0e21e 2691 }
9ddeeac9 2692 if (PL_laststatval < 0) {
2dd78f96
JH		 2693 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2694 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
a0d0e21e 2695 max = 0;
9ddeeac9 2696 }
a0d0e21e
LW		 2697 }
2698 else {
748a9306
LW		 2699 SV* sv = POPs;
2700 if (SvTYPE(sv) == SVt_PVGV) {
2dd78f96 2701 gv = (GV*)sv;
748a9306
LW		 2702 goto do_fstat;
2703 }
2704 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2dd78f96 2705 gv = (GV*)SvRV(sv);
748a9306
LW		 2706 goto do_fstat;
2707 }
2d8e6c8d 2708 sv_setpv(PL_statname, SvPV(sv,n_a));
3280af22 2709 PL_statgv = Nullgv;
a0d0e21e 2710#ifdef HAS_LSTAT
533c011a
NIS		 2711 PL_laststype = PL_op->op_type;
2712 if (PL_op->op_type == OP_LSTAT)
2d8e6c8d 2713 PL_laststatval = PerlLIO_lstat(SvPV(PL_statname, n_a), &PL_statcache);
a0d0e21e
LW		 2714 else
2715#endif
2d8e6c8d 2716 PL_laststatval = PerlLIO_stat(SvPV(PL_statname, n_a), &PL_statcache);
3280af22 2717 if (PL_laststatval < 0) {
2d8e6c8d 2718 if (ckWARN(WARN_NEWLINE) && strchr(SvPV(PL_statname, n_a), '\n'))
cea2e8a9 2719 Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "stat");
a0d0e21e
LW		 2720 max = 0;
2721 }
2722 }
2723
54310121 2724 gimme = GIMME_V;
2725 if (gimme != G_ARRAY) {
2726 if (gimme != G_VOID)
2727 XPUSHs(boolSV(max));
2728 RETURN;
a0d0e21e
LW		 2729 }
2730 if (max) {
36477c24 2731 EXTEND(SP, max);
2732 EXTEND_MORTAL(max);
1ff81528
PL		 2733 PUSHs(sv_2mortal(newSViv(PL_statcache.st_dev)));
2734 PUSHs(sv_2mortal(newSViv(PL_statcache.st_ino)));
b448e4fe
JH		 2735 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_mode)));
2736 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_nlink)));
146174a9
CB		 2737#if Uid_t_size > IVSIZE
2738 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_uid)));
2739#else
23dcd6c8 2740# if Uid_t_sign <= 0
1ff81528 2741 PUSHs(sv_2mortal(newSViv(PL_statcache.st_uid)));
23dcd6c8
JH		 2742# else
2743 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_uid)));
2744# endif
146174a9 2745#endif
301e8125 2746#if Gid_t_size > IVSIZE
146174a9
CB		 2747 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_gid)));
2748#else
23dcd6c8 2749# if Gid_t_sign <= 0
1ff81528 2750 PUSHs(sv_2mortal(newSViv(PL_statcache.st_gid)));
23dcd6c8
JH		 2751# else
2752 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_gid)));
2753# endif
146174a9 2754#endif
cbdc8872 2755#ifdef USE_STAT_RDEV
1ff81528 2756 PUSHs(sv_2mortal(newSViv(PL_statcache.st_rdev)));
cbdc8872 2757#else
79cb57f6 2758 PUSHs(sv_2mortal(newSVpvn("", 0)));
cbdc8872 2759#endif
146174a9
CB		 2760#if Off_t_size > IVSIZE
2761 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_size)));
2762#else
1ff81528 2763 PUSHs(sv_2mortal(newSViv(PL_statcache.st_size)));
146174a9 2764#endif
cbdc8872 2765#ifdef BIG_TIME
172ae379
JH		 2766 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_atime)));
2767 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_mtime)));
2768 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_ctime)));
cbdc8872 2769#else
1ff81528
PL		 2770 PUSHs(sv_2mortal(newSViv(PL_statcache.st_atime)));
2771 PUSHs(sv_2mortal(newSViv(PL_statcache.st_mtime)));
2772 PUSHs(sv_2mortal(newSViv(PL_statcache.st_ctime)));
cbdc8872 2773#endif
a0d0e21e 2774#ifdef USE_STAT_BLOCKS
b448e4fe
JH		 2775 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blksize)));
2776 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blocks)));
a0d0e21e 2777#else
79cb57f6
GS		 2778 PUSHs(sv_2mortal(newSVpvn("", 0)));
2779 PUSHs(sv_2mortal(newSVpvn("", 0)));
a0d0e21e
LW		 2780#endif
2781 }
2782 RETURN;
2783}
2784
2785PP(pp_ftrread)
2786{
5ff3f7a4 2787 I32 result;
39644a26 2788 dSP;
5ff3f7a4 2789#if defined(HAS_ACCESS) && defined(R_OK)
2d8e6c8d 2790 STRLEN n_a;
5ff3f7a4 2791 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2792 result = access(TOPpx, R_OK);
5ff3f7a4
GS		 2793 if (result == 0)
2794 RETPUSHYES;
2795 if (result < 0)
2796 RETPUSHUNDEF;
2797 RETPUSHNO;
22865c03
GS		 2798 }
2799 else
cea2e8a9 2800 result = my_stat();
5ff3f7a4 2801#else
cea2e8a9 2802 result = my_stat();
5ff3f7a4 2803#endif
22865c03 2804 SPAGAIN;
a0d0e21e
LW		 2805 if (result < 0)
2806 RETPUSHUNDEF;
3280af22 2807 if (cando(S_IRUSR, 0, &PL_statcache))
a0d0e21e
LW		 2808 RETPUSHYES;
2809 RETPUSHNO;
2810}
2811
2812PP(pp_ftrwrite)
2813{
5ff3f7a4 2814 I32 result;
39644a26 2815 dSP;
5ff3f7a4 2816#if defined(HAS_ACCESS) && defined(W_OK)
2d8e6c8d 2817 STRLEN n_a;
5ff3f7a4 2818 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2819 result = access(TOPpx, W_OK);
5ff3f7a4
GS		 2820 if (result == 0)
2821 RETPUSHYES;
2822 if (result < 0)
2823 RETPUSHUNDEF;
2824 RETPUSHNO;
22865c03
GS		 2825 }
2826 else
cea2e8a9 2827 result = my_stat();
5ff3f7a4 2828#else
cea2e8a9 2829 result = my_stat();
5ff3f7a4 2830#endif
22865c03 2831 SPAGAIN;
a0d0e21e
LW		 2832 if (result < 0)
2833 RETPUSHUNDEF;
3280af22 2834 if (cando(S_IWUSR, 0, &PL_statcache))
a0d0e21e
LW		 2835 RETPUSHYES;
2836 RETPUSHNO;
2837}
2838
2839PP(pp_ftrexec)
2840{
5ff3f7a4 2841 I32 result;
39644a26 2842 dSP;
5ff3f7a4 2843#if defined(HAS_ACCESS) && defined(X_OK)
2d8e6c8d 2844 STRLEN n_a;
5ff3f7a4 2845 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2846 result = access(TOPpx, X_OK);
5ff3f7a4
GS		 2847 if (result == 0)
2848 RETPUSHYES;
2849 if (result < 0)
2850 RETPUSHUNDEF;
2851 RETPUSHNO;
22865c03
GS		 2852 }
2853 else
cea2e8a9 2854 result = my_stat();
5ff3f7a4 2855#else
cea2e8a9 2856 result = my_stat();
5ff3f7a4 2857#endif
22865c03 2858 SPAGAIN;
a0d0e21e
LW		 2859 if (result < 0)
2860 RETPUSHUNDEF;
3280af22 2861 if (cando(S_IXUSR, 0, &PL_statcache))
a0d0e21e
LW		 2862 RETPUSHYES;
2863 RETPUSHNO;
2864}
2865
2866PP(pp_fteread)
2867{
5ff3f7a4 2868 I32 result;
39644a26 2869 dSP;
5ff3f7a4 2870#ifdef PERL_EFF_ACCESS_R_OK
2d8e6c8d 2871 STRLEN n_a;
5ff3f7a4 2872 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2873 result = PERL_EFF_ACCESS_R_OK(TOPpx);
5ff3f7a4
GS		 2874 if (result == 0)
2875 RETPUSHYES;
2876 if (result < 0)
2877 RETPUSHUNDEF;
2878 RETPUSHNO;
22865c03
GS		 2879 }
2880 else
cea2e8a9 2881 result = my_stat();
5ff3f7a4 2882#else
cea2e8a9 2883 result = my_stat();
5ff3f7a4 2884#endif
22865c03 2885 SPAGAIN;
a0d0e21e
LW		 2886 if (result < 0)
2887 RETPUSHUNDEF;
3280af22 2888 if (cando(S_IRUSR, 1, &PL_statcache))
a0d0e21e
LW		 2889 RETPUSHYES;
2890 RETPUSHNO;
2891}
2892
2893PP(pp_ftewrite)
2894{
5ff3f7a4 2895 I32 result;
39644a26 2896 dSP;
5ff3f7a4 2897#ifdef PERL_EFF_ACCESS_W_OK
2d8e6c8d 2898 STRLEN n_a;
5ff3f7a4 2899 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2900 result = PERL_EFF_ACCESS_W_OK(TOPpx);
5ff3f7a4
GS		 2901 if (result == 0)
2902 RETPUSHYES;
2903 if (result < 0)
2904 RETPUSHUNDEF;
2905 RETPUSHNO;
22865c03
GS		 2906 }
2907 else
cea2e8a9 2908 result = my_stat();
5ff3f7a4 2909#else
cea2e8a9 2910 result = my_stat();
5ff3f7a4 2911#endif
22865c03 2912 SPAGAIN;
a0d0e21e
LW		 2913 if (result < 0)
2914 RETPUSHUNDEF;
3280af22 2915 if (cando(S_IWUSR, 1, &PL_statcache))
a0d0e21e
LW		 2916 RETPUSHYES;
2917 RETPUSHNO;
2918}
2919
2920PP(pp_fteexec)
2921{
5ff3f7a4 2922 I32 result;
39644a26 2923 dSP;
5ff3f7a4 2924#ifdef PERL_EFF_ACCESS_X_OK
2d8e6c8d 2925 STRLEN n_a;
5ff3f7a4 2926 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2927 result = PERL_EFF_ACCESS_X_OK(TOPpx);
5ff3f7a4
GS		 2928 if (result == 0)
2929 RETPUSHYES;
2930 if (result < 0)
2931 RETPUSHUNDEF;
2932 RETPUSHNO;
22865c03
GS		 2933 }
2934 else
cea2e8a9 2935 result = my_stat();
5ff3f7a4 2936#else
cea2e8a9 2937 result = my_stat();
5ff3f7a4 2938#endif
22865c03 2939 SPAGAIN;
a0d0e21e
LW		 2940 if (result < 0)
2941 RETPUSHUNDEF;
3280af22 2942 if (cando(S_IXUSR, 1, &PL_statcache))
a0d0e21e
LW		 2943 RETPUSHYES;
2944 RETPUSHNO;
2945}
2946
2947PP(pp_ftis)
2948{
cea2e8a9 2949 I32 result = my_stat();
39644a26 2950 dSP;
a0d0e21e
LW		 2951 if (result < 0)
2952 RETPUSHUNDEF;
2953 RETPUSHYES;
2954}
2955
2956PP(pp_fteowned)
2957{
cea2e8a9 2958 return pp_ftrowned();
a0d0e21e
LW		 2959}
2960
2961PP(pp_ftrowned)
2962{
cea2e8a9 2963 I32 result = my_stat();
39644a26 2964 dSP;
a0d0e21e
LW		 2965 if (result < 0)
2966 RETPUSHUNDEF;
146174a9
CB		 2967 if (PL_statcache.st_uid == (PL_op->op_type == OP_FTEOWNED ?
2968 PL_euid : PL_uid) )
a0d0e21e
LW		 2969 RETPUSHYES;
2970 RETPUSHNO;
2971}
2972
2973PP(pp_ftzero)
2974{
cea2e8a9 2975 I32 result = my_stat();
39644a26 2976 dSP;
a0d0e21e
LW		 2977 if (result < 0)
2978 RETPUSHUNDEF;
146174a9 2979 if (PL_statcache.st_size == 0)
a0d0e21e
LW		 2980 RETPUSHYES;
2981 RETPUSHNO;
2982}
2983
2984PP(pp_ftsize)
2985{
cea2e8a9 2986 I32 result = my_stat();
39644a26 2987 dSP; dTARGET;
a0d0e21e
LW		 2988 if (result < 0)
2989 RETPUSHUNDEF;
146174a9
CB		 2990#if Off_t_size > IVSIZE
2991 PUSHn(PL_statcache.st_size);
2992#else
3280af22 2993 PUSHi(PL_statcache.st_size);
146174a9 2994#endif
a0d0e21e
LW		 2995 RETURN;
2996}
2997
2998PP(pp_ftmtime)
2999{
cea2e8a9 3000 I32 result = my_stat();
39644a26 3001 dSP; dTARGET;
a0d0e21e
LW		 3002 if (result < 0)
3003 RETPUSHUNDEF;
c6419e06 3004 PUSHn( (PL_basetime - PL_statcache.st_mtime) / 86400.0 );
a0d0e21e
LW		 3005 RETURN;
3006}
3007
3008PP(pp_ftatime)
3009{
cea2e8a9 3010 I32 result = my_stat();
39644a26 3011 dSP; dTARGET;
a0d0e21e
LW		 3012 if (result < 0)
3013 RETPUSHUNDEF;
c6419e06 3014 PUSHn( (PL_basetime - PL_statcache.st_atime) / 86400.0 );
a0d0e21e
LW		 3015 RETURN;
3016}
3017
3018PP(pp_ftctime)
3019{
cea2e8a9 3020 I32 result = my_stat();
39644a26 3021 dSP; dTARGET;
a0d0e21e
LW		 3022 if (result < 0)
3023 RETPUSHUNDEF;
c6419e06 3024 PUSHn( (PL_basetime - PL_statcache.st_ctime) / 86400.0 );
a0d0e21e
LW		 3025 RETURN;
3026}
3027
3028PP(pp_ftsock)
3029{
cea2e8a9 3030 I32 result = my_stat();
39644a26 3031 dSP;
a0d0e21e
LW		 3032 if (result < 0)
3033 RETPUSHUNDEF;
3280af22 3034 if (S_ISSOCK(PL_statcache.st_mode))
a0d0e21e
LW		 3035 RETPUSHYES;
3036 RETPUSHNO;
3037}
3038
3039PP(pp_ftchr)
3040{
cea2e8a9 3041 I32 result = my_stat();
39644a26 3042 dSP;
a0d0e21e
LW		 3043 if (result < 0)
3044 RETPUSHUNDEF;
3280af22 3045 if (S_ISCHR(PL_statcache.st_mode))
a0d0e21e
LW		 3046 RETPUSHYES;
3047 RETPUSHNO;
3048}
3049
3050PP(pp_ftblk)
3051{
cea2e8a9 3052 I32 result = my_stat();
39644a26 3053 dSP;
a0d0e21e
LW		 3054 if (result < 0)
3055 RETPUSHUNDEF;
3280af22 3056 if (S_ISBLK(PL_statcache.st_mode))
a0d0e21e
LW		 3057 RETPUSHYES;
3058 RETPUSHNO;
3059}
3060
3061PP(pp_ftfile)
3062{
cea2e8a9 3063 I32 result = my_stat();
39644a26 3064 dSP;
a0d0e21e
LW		 3065 if (result < 0)
3066 RETPUSHUNDEF;
3280af22 3067 if (S_ISREG(PL_statcache.st_mode))
a0d0e21e
LW		 3068 RETPUSHYES;
3069 RETPUSHNO;
3070}
3071
3072PP(pp_ftdir)
3073{
cea2e8a9 3074 I32 result = my_stat();
39644a26 3075 dSP;
a0d0e21e
LW		 3076 if (result < 0)
3077 RETPUSHUNDEF;
3280af22 3078 if (S_ISDIR(PL_statcache.st_mode))
a0d0e21e
LW		 3079 RETPUSHYES;
3080 RETPUSHNO;
3081}
3082
3083PP(pp_ftpipe)
3084{
cea2e8a9 3085 I32 result = my_stat();
39644a26 3086 dSP;
a0d0e21e
LW		 3087 if (result < 0)
3088 RETPUSHUNDEF;
3280af22 3089 if (S_ISFIFO(PL_statcache.st_mode))
a0d0e21e
LW		 3090 RETPUSHYES;
3091 RETPUSHNO;
3092}
3093
3094PP(pp_ftlink)
3095{
cea2e8a9 3096 I32 result = my_lstat();
39644a26 3097 dSP;
a0d0e21e
LW		 3098 if (result < 0)
3099 RETPUSHUNDEF;
3280af22 3100 if (S_ISLNK(PL_statcache.st_mode))
a0d0e21e
LW		 3101 RETPUSHYES;
3102 RETPUSHNO;
3103}
3104
3105PP(pp_ftsuid)
3106{
39644a26 3107 dSP;
a0d0e21e 3108#ifdef S_ISUID
cea2e8a9 3109 I32 result = my_stat();
a0d0e21e
LW		 3110 SPAGAIN;
3111 if (result < 0)
3112 RETPUSHUNDEF;
3280af22 3113 if (PL_statcache.st_mode & S_ISUID)
a0d0e21e
LW		 3114 RETPUSHYES;
3115#endif
3116 RETPUSHNO;
3117}
3118
3119PP(pp_ftsgid)
3120{
39644a26 3121 dSP;
a0d0e21e 3122#ifdef S_ISGID
cea2e8a9 3123 I32 result = my_stat();
a0d0e21e
LW		 3124 SPAGAIN;
3125 if (result < 0)
3126 RETPUSHUNDEF;
3280af22 3127 if (PL_statcache.st_mode & S_ISGID)
a0d0e21e
LW		 3128 RETPUSHYES;
3129#endif
3130 RETPUSHNO;
3131}
3132
3133PP(pp_ftsvtx)
3134{
39644a26 3135 dSP;
a0d0e21e 3136#ifdef S_ISVTX
cea2e8a9 3137 I32 result = my_stat();
a0d0e21e
LW		 3138 SPAGAIN;
3139 if (result < 0)
3140 RETPUSHUNDEF;
3280af22 3141 if (PL_statcache.st_mode & S_ISVTX)
a0d0e21e
LW		 3142 RETPUSHYES;
3143#endif
3144 RETPUSHNO;
3145}
3146
3147PP(pp_fttty)
3148{
39644a26 3149 dSP;
a0d0e21e
LW		 3150 int fd;
3151 GV *gv;
fb73857a 3152 char *tmps = Nullch;
2d8e6c8d 3153 STRLEN n_a;
fb73857a 3154
533c011a 3155 if (PL_op->op_flags & OPf_REF)
146174a9 3156 gv = cGVOP_gv;
fb73857a 3157 else if (isGV(TOPs))
3158 gv = (GV*)POPs;
3159 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3160 gv = (GV*)SvRV(POPs);
a0d0e21e 3161 else
2d8e6c8d 3162 gv = gv_fetchpv(tmps = POPpx, FALSE, SVt_PVIO);
fb73857a 3163
a0d0e21e 3164 if (GvIO(gv) && IoIFP(GvIOp(gv)))
760ac839 3165 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
fb73857a 3166 else if (tmps && isDIGIT(*tmps))
a0d0e21e
LW		 3167 fd = atoi(tmps);
3168 else
3169 RETPUSHUNDEF;
6ad3d225 3170 if (PerlLIO_isatty(fd))
a0d0e21e
LW		 3171 RETPUSHYES;
3172 RETPUSHNO;
3173}
3174
16d20bd9
AD		 3175#if defined(atarist) /* this will work with atariST. Configure will
3176 make guesses for other systems. */
3177# define FILE_base(f) ((f)->_base)
3178# define FILE_ptr(f) ((f)->_ptr)
3179# define FILE_cnt(f) ((f)->_cnt)
3180# define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
a0d0e21e
LW		 3181#endif
3182
3183PP(pp_fttext)
3184{
39644a26 3185 dSP;
a0d0e21e
LW		 3186 I32 i;
3187 I32 len;
3188 I32 odd = 0;
3189 STDCHAR tbuf[512];
3190 register STDCHAR *s;
3191 register IO *io;
5f05dabc 3192 register SV *sv;
3193 GV *gv;
2d8e6c8d 3194 STRLEN n_a;
146174a9 3195 PerlIO *fp;
a0d0e21e 3196
533c011a 3197 if (PL_op->op_flags & OPf_REF)
146174a9 3198 gv = cGVOP_gv;
5f05dabc 3199 else if (isGV(TOPs))
3200 gv = (GV*)POPs;
3201 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3202 gv = (GV*)SvRV(POPs);
3203 else
3204 gv = Nullgv;
3205
3206 if (gv) {
a0d0e21e 3207 EXTEND(SP, 1);
3280af22
NIS		 3208 if (gv == PL_defgv) {
3209 if (PL_statgv)
3210 io = GvIO(PL_statgv);
a0d0e21e 3211 else {
3280af22 3212 sv = PL_statname;
a0d0e21e
LW		 3213 goto really_filename;
3214 }
3215 }
3216 else {
3280af22
NIS		 3217 PL_statgv = gv;
3218 PL_laststatval = -1;
3219 sv_setpv(PL_statname, "");
3220 io = GvIO(PL_statgv);
a0d0e21e
LW		 3221 }
3222 if (io && IoIFP(io)) {
5f05dabc 3223 if (! PerlIO_has_base(IoIFP(io)))
cea2e8a9 3224 DIE(aTHX_ "-T and -B not implemented on filehandles");
3280af22
NIS		 3225 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3226 if (PL_laststatval < 0)
5f05dabc 3227 RETPUSHUNDEF;
9cbac4c7 3228 if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
533c011a 3229 if (PL_op->op_type == OP_FTTEXT)
a0d0e21e
LW		 3230 RETPUSHNO;
3231 else
3232 RETPUSHYES;
9cbac4c7 3233 }
a20bf0c3 3234 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
760ac839 3235 i = PerlIO_getc(IoIFP(io));
a0d0e21e 3236 if (i != EOF)
760ac839 3237 (void)PerlIO_ungetc(IoIFP(io),i);
a0d0e21e 3238 }
a20bf0c3 3239 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
a0d0e21e 3240 RETPUSHYES;
a20bf0c3
JH		 3241 len = PerlIO_get_bufsiz(IoIFP(io));
3242 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
760ac839
LW		 3243 /* sfio can have large buffers - limit to 512 */
3244 if (len > 512)
3245 len = 512;
a0d0e21e
LW		 3246 }
3247 else {
2dd78f96 3248 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
146174a9 3249 gv = cGVOP_gv;
2dd78f96 3250 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
146174a9 3251 }
748a9306 3252 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW		 3253 RETPUSHUNDEF;
3254 }
3255 }
3256 else {
3257 sv = POPs;
5f05dabc 3258 really_filename:
3280af22
NIS		 3259 PL_statgv = Nullgv;
3260 PL_laststatval = -1;
2d8e6c8d 3261 sv_setpv(PL_statname, SvPV(sv, n_a));
146174a9 3262 if (!(fp = PerlIO_open(SvPVX(PL_statname), "r"))) {
2d8e6c8d 3263 if (ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, n_a), '\n'))
cea2e8a9 3264 Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "open");
a0d0e21e
LW		 3265 RETPUSHUNDEF;
3266 }
146174a9
CB		 3267 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3268 if (PL_laststatval < 0) {
3269 (void)PerlIO_close(fp);
5f05dabc 3270 RETPUSHUNDEF;
146174a9 3271 }
60382766 3272 PerlIO_binmode(aTHX_ fp, '<', O_BINARY, Nullch);
146174a9
CB		 3273 len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3274 (void)PerlIO_close(fp);
a0d0e21e 3275 if (len <= 0) {
533c011a 3276 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
a0d0e21e
LW		 3277 RETPUSHNO; /* special case NFS directories */
3278 RETPUSHYES; /* null file is anything */
3279 }
3280 s = tbuf;
3281 }
3282
3283 /* now scan s to look for textiness */
4633a7c4 3284 /* XXX ASCII dependent code */
a0d0e21e 3285
146174a9
CB		 3286#if defined(DOSISH) || defined(USEMYBINMODE)
3287 /* ignore trailing ^Z on short files */
3288 if (len && len < sizeof(tbuf) && tbuf[len-1] == 26)
3289 --len;
3290#endif
3291
a0d0e21e
LW		 3292 for (i = 0; i < len; i++, s++) {
3293 if (!*s) { /* null never allowed in text */
3294 odd += len;
3295 break;
3296 }
9d116dd7 3297#ifdef EBCDIC
301e8125 3298 else if (!(isPRINT(*s) || isSPACE(*s)))
9d116dd7
JH		 3299 odd++;
3300#else
146174a9
CB		 3301 else if (*s & 128) {
3302#ifdef USE_LOCALE
2de3dbcc 3303 if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
b3f66c68
GS		 3304 continue;
3305#endif
3306 /* utf8 characters don't count as odd */
fd400ab9 3307 if (UTF8_IS_START(*s)) {
b3f66c68
GS		 3308 int ulen = UTF8SKIP(s);
3309 if (ulen < len - i) {
3310 int j;
3311 for (j = 1; j < ulen; j++) {
fd400ab9 3312 if (!UTF8_IS_CONTINUATION(s[j]))
b3f66c68
GS		 3313 goto not_utf8;
3314 }
3315 --ulen; /* loop does extra increment */
3316 s += ulen;
3317 i += ulen;
3318 continue;
3319 }
3320 }
3321 not_utf8:
3322 odd++;
146174a9 3323 }
a0d0e21e
LW		 3324 else if (*s < 32 &&
3325 *s != '\n' && *s != '\r' && *s != '\b' &&
3326 *s != '\t' && *s != '\f' && *s != 27)
3327 odd++;
9d116dd7 3328#endif
a0d0e21e
LW		 3329 }
3330
533c011a 3331 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
a0d0e21e
LW		 3332 RETPUSHNO;
3333 else
3334 RETPUSHYES;
3335}
3336
3337PP(pp_ftbinary)
3338{
cea2e8a9 3339 return pp_fttext();
a0d0e21e
LW		 3340}
3341
3342/* File calls. */
3343
3344PP(pp_chdir)
3345{
39644a26 3346 dSP; dTARGET;
a0d0e21e
LW		 3347 char *tmps;
3348 SV **svp;
2d8e6c8d 3349 STRLEN n_a;
a0d0e21e
LW		 3350
3351 if (MAXARG < 1)
3352 tmps = Nullch;
3353 else
2d8e6c8d 3354 tmps = POPpx;
a0d0e21e 3355 if (!tmps || !*tmps) {
3280af22 3356 svp = hv_fetch(GvHVn(PL_envgv), "HOME", 4, FALSE);
a0d0e21e 3357 if (svp)
2d8e6c8d 3358 tmps = SvPV(*svp, n_a);
a0d0e21e
LW		 3359 }
3360 if (!tmps || !*tmps) {
3280af22 3361 svp = hv_fetch(GvHVn(PL_envgv), "LOGDIR", 6, FALSE);
a0d0e21e 3362 if (svp)
2d8e6c8d 3363 tmps = SvPV(*svp, n_a);
a0d0e21e 3364 }
491527d0
GS		 3365#ifdef VMS
3366 if (!tmps || !*tmps) {
6b88bc9c 3367 svp = hv_fetch(GvHVn(PL_envgv), "SYS$LOGIN", 9, FALSE);
491527d0 3368 if (svp)
2d8e6c8d 3369 tmps = SvPV(*svp, n_a);
491527d0
GS		 3370 }
3371#endif
a0d0e21e 3372 TAINT_PROPER("chdir");
6ad3d225 3373 PUSHi( PerlDir_chdir(tmps) >= 0 );
748a9306
LW		 3374#ifdef VMS
3375 /* Clear the DEFAULT element of ENV so we'll get the new value
3376 * in the future. */
6b88bc9c 3377 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
748a9306 3378#endif
a0d0e21e
LW		 3379 RETURN;
3380}
3381
3382PP(pp_chown)
3383{
39644a26 3384 dSP; dMARK; dTARGET;
a0d0e21e
LW		 3385 I32 value;
3386#ifdef HAS_CHOWN
533c011a 3387 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 3388 SP = MARK;
3389 PUSHi(value);
3390 RETURN;
3391#else
cea2e8a9 3392 DIE(aTHX_ PL_no_func, "Unsupported function chown");
a0d0e21e
LW		 3393#endif
3394}
3395
3396PP(pp_chroot)
3397{
39644a26 3398 dSP; dTARGET;
a0d0e21e
LW		 3399 char *tmps;
3400#ifdef HAS_CHROOT
2d8e6c8d
GS		 3401 STRLEN n_a;
3402 tmps = POPpx;
a0d0e21e
LW		 3403 TAINT_PROPER("chroot");
3404 PUSHi( chroot(tmps) >= 0 );
3405 RETURN;
3406#else
cea2e8a9 3407 DIE(aTHX_ PL_no_func, "chroot");
a0d0e21e
LW		 3408#endif
3409}
3410
3411PP(pp_unlink)
3412{
39644a26 3413 dSP; dMARK; dTARGET;
a0d0e21e 3414 I32 value;
533c011a 3415 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 3416 SP = MARK;
3417 PUSHi(value);
3418 RETURN;
3419}
3420
3421PP(pp_chmod)
3422{
39644a26 3423 dSP; dMARK; dTARGET;
a0d0e21e 3424 I32 value;
533c011a 3425 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 3426 SP = MARK;
3427 PUSHi(value);
3428 RETURN;
3429}
3430
3431PP(pp_utime)
3432{
39644a26 3433 dSP; dMARK; dTARGET;
a0d0e21e 3434 I32 value;
533c011a 3435 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 3436 SP = MARK;
3437 PUSHi(value);
3438 RETURN;
3439}
3440
3441PP(pp_rename)
3442{
39644a26 3443 dSP; dTARGET;
a0d0e21e 3444 int anum;
2d8e6c8d 3445 STRLEN n_a;
a0d0e21e 3446
2d8e6c8d
GS		 3447 char *tmps2 = POPpx;
3448 char *tmps = SvPV(TOPs, n_a);
a0d0e21e
LW		 3449 TAINT_PROPER("rename");
3450#ifdef HAS_RENAME
baed7233 3451 anum = PerlLIO_rename(tmps, tmps2);
a0d0e21e 3452#else
6b88bc9c 3453 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
ed969818
W		 3454 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3455 anum = 1;
3456 else {
3654eb6c 3457 if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
ed969818
W		 3458 (void)UNLINK(tmps2);
3459 if (!(anum = link(tmps, tmps2)))
3460 anum = UNLINK(tmps);
3461 }
a0d0e21e
LW		 3462 }
3463#endif
3464 SETi( anum >= 0 );
3465 RETURN;
3466}
3467
3468PP(pp_link)
3469{
39644a26 3470 dSP; dTARGET;
a0d0e21e 3471#ifdef HAS_LINK
2d8e6c8d
GS		 3472 STRLEN n_a;
3473 char *tmps2 = POPpx;
3474 char *tmps = SvPV(TOPs, n_a);
a0d0e21e 3475 TAINT_PROPER("link");
146174a9 3476 SETi( PerlLIO_link(tmps, tmps2) >= 0 );
a0d0e21e 3477#else
cea2e8a9 3478 DIE(aTHX_ PL_no_func, "Unsupported function link");
a0d0e21e
LW		 3479#endif
3480 RETURN;
3481}
3482
3483PP(pp_symlink)
3484{
39644a26 3485 dSP; dTARGET;
a0d0e21e 3486#ifdef HAS_SYMLINK
2d8e6c8d
GS		 3487 STRLEN n_a;
3488 char *tmps2 = POPpx;
3489 char *tmps = SvPV(TOPs, n_a);
a0d0e21e
LW		 3490 TAINT_PROPER("symlink");
3491 SETi( symlink(tmps, tmps2) >= 0 );
3492 RETURN;
3493#else
cea2e8a9 3494 DIE(aTHX_ PL_no_func, "symlink");
a0d0e21e
LW		 3495#endif
3496}
3497
3498PP(pp_readlink)
3499{
39644a26 3500 dSP; dTARGET;
a0d0e21e
LW		 3501#ifdef HAS_SYMLINK
3502 char *tmps;
46fc3d4c 3503 char buf[MAXPATHLEN];
a0d0e21e 3504 int len;
2d8e6c8d 3505 STRLEN n_a;
46fc3d4c 3506
fb73857a 3507#ifndef INCOMPLETE_TAINTS
3508 TAINT;
3509#endif
2d8e6c8d 3510 tmps = POPpx;
a0d0e21e
LW		 3511 len = readlink(tmps, buf, sizeof buf);
3512 EXTEND(SP, 1);
3513 if (len < 0)
3514 RETPUSHUNDEF;
3515 PUSHp(buf, len);
3516 RETURN;
3517#else
3518 EXTEND(SP, 1);
3519 RETSETUNDEF; /* just pretend it's a normal file */
3520#endif
3521}
3522
3523#if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
ba106d47 3524STATIC int
cea2e8a9 3525S_dooneliner(pTHX_ char *cmd, char *filename)
a0d0e21e 3526{
1e422769 3527 char *save_filename = filename;
3528 char *cmdline;
3529 char *s;
760ac839 3530 PerlIO *myfp;
1e422769 3531 int anum = 1;
a0d0e21e 3532
1e422769 3533 New(666, cmdline, strlen(cmd) + (strlen(filename) * 2) + 10, char);
3534 strcpy(cmdline, cmd);
3535 strcat(cmdline, " ");
3536 for (s = cmdline + strlen(cmdline); *filename; ) {
a0d0e21e
LW		 3537 *s++ = '\\';
3538 *s++ = *filename++;
3539 }
3540 strcpy(s, " 2>&1");
6ad3d225 3541 myfp = PerlProc_popen(cmdline, "r");
1e422769 3542 Safefree(cmdline);
3543
a0d0e21e 3544 if (myfp) {
1e422769 3545 SV *tmpsv = sv_newmortal();
6b88bc9c 3546 /* Need to save/restore 'PL_rs' ?? */
760ac839 3547 s = sv_gets(tmpsv, myfp, 0);
6ad3d225 3548 (void)PerlProc_pclose(myfp);
a0d0e21e 3549 if (s != Nullch) {
1e422769 3550 int e;
3551 for (e = 1;
a0d0e21e 3552#ifdef HAS_SYS_ERRLIST
1e422769 3553 e <= sys_nerr
3554#endif
3555 ; e++)
3556 {
3557 /* you don't see this */
3558 char *errmsg =
3559#ifdef HAS_SYS_ERRLIST
3560 sys_errlist[e]
a0d0e21e 3561#else
1e422769 3562 strerror(e)
a0d0e21e 3563#endif
1e422769 3564 ;
3565 if (!errmsg)
3566 break;
3567 if (instr(s, errmsg)) {
3568 SETERRNO(e,0);
3569 return 0;
3570 }
a0d0e21e 3571 }
748a9306 3572 SETERRNO(0,0);
a0d0e21e
LW		 3573#ifndef EACCES
3574#define EACCES EPERM
3575#endif
1e422769 3576 if (instr(s, "cannot make"))
748a9306 3577 SETERRNO(EEXIST,RMS$_FEX);
1e422769 3578 else if (instr(s, "existing file"))
748a9306 3579 SETERRNO(EEXIST,RMS$_FEX);
1e422769 3580 else if (instr(s, "ile exists"))
748a9306 3581 SETERRNO(EEXIST,RMS$_FEX);
1e422769 3582 else if (instr(s, "non-exist"))
748a9306 3583 SETERRNO(ENOENT,RMS$_FNF);
1e422769 3584 else if (instr(s, "does not exist"))
748a9306 3585 SETERRNO(ENOENT,RMS$_FNF);
1e422769 3586 else if (instr(s, "not empty"))
748a9306 3587 SETERRNO(EBUSY,SS$_DEVOFFLINE);
1e422769 3588 else if (instr(s, "cannot access"))
748a9306 3589 SETERRNO(EACCES,RMS$_PRV);
a0d0e21e 3590 else
748a9306 3591 SETERRNO(EPERM,RMS$_PRV);
a0d0e21e
LW		 3592 return 0;
3593 }
3594 else { /* some mkdirs return no failure indication */
6b88bc9c 3595 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
911d147d 3596 if (PL_op->op_type == OP_RMDIR)
a0d0e21e
LW		 3597 anum = !anum;
3598 if (anum)
748a9306 3599 SETERRNO(0,0);
a0d0e21e 3600 else
748a9306 3601 SETERRNO(EACCES,RMS$_PRV); /* a guess */
a0d0e21e
LW		 3602 }
3603 return anum;
3604 }
3605 else
3606 return 0;
3607}
3608#endif
3609
3610PP(pp_mkdir)
3611{
39644a26 3612 dSP; dTARGET;
5a211162 3613 int mode;
a0d0e21e
LW		 3614#ifndef HAS_MKDIR
3615 int oldumask;
3616#endif
df25ddba 3617 STRLEN len;
5a211162 3618 char *tmps;
df25ddba 3619 bool copy = FALSE;
5a211162
GS		 3620
3621 if (MAXARG > 1)
3622 mode = POPi;
3623 else
3624 mode = 0777;
3625
df25ddba
JH		 3626 tmps = SvPV(TOPs, len);
3627 /* Different operating and file systems take differently to
16ac3975
JH		 3628 * trailing slashes. According to POSIX 1003.1 1996 Edition
3629 * any number of trailing slashes should be allowed.
3630 * Thusly we snip them away so that even non-conforming
3631 * systems are happy. */
3632 /* We should probably do this "filtering" for all
3633 * the functions that expect (potentially) directory names:
3634 * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3635 * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3636 if (len > 1 && tmps[len-1] == '/') {
3637 while (tmps[len] == '/' && len > 1)
3638 len--;
3639 tmps = savepvn(tmps, len);
df25ddba
JH		 3640 copy = TRUE;
3641 }
a0d0e21e
LW		 3642
3643 TAINT_PROPER("mkdir");
3644#ifdef HAS_MKDIR
6ad3d225 3645 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
a0d0e21e
LW		 3646#else
3647 SETi( dooneliner("mkdir", tmps) );
6ad3d225
GS		 3648 oldumask = PerlLIO_umask(0);
3649 PerlLIO_umask(oldumask);
3650 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
a0d0e21e 3651#endif
df25ddba
JH		 3652 if (copy)
3653 Safefree(tmps);
a0d0e21e
LW		 3654 RETURN;
3655}
3656
3657PP(pp_rmdir)
3658{
39644a26 3659 dSP; dTARGET;
a0d0e21e 3660 char *tmps;
2d8e6c8d 3661 STRLEN n_a;
a0d0e21e 3662
2d8e6c8d 3663 tmps = POPpx;
a0d0e21e
LW		 3664 TAINT_PROPER("rmdir");
3665#ifdef HAS_RMDIR
6ad3d225 3666 XPUSHi( PerlDir_rmdir(tmps) >= 0 );
a0d0e21e
LW		 3667#else
3668 XPUSHi( dooneliner("rmdir", tmps) );
3669#endif
3670 RETURN;
3671}
3672
3673/* Directory calls. */
3674
3675PP(pp_open_dir)
3676{
39644a26 3677 dSP;
a0d0e21e 3678#if defined(Direntry_t) && defined(HAS_READDIR)
2d8e6c8d
GS		 3679 STRLEN n_a;
3680 char *dirname = POPpx;
a0d0e21e
LW		 3681 GV *gv = (GV*)POPs;
3682 register IO *io = GvIOn(gv);
3683
3684 if (!io)
3685 goto nope;
3686
3687 if (IoDIRP(io))
6ad3d225
GS		 3688 PerlDir_close(IoDIRP(io));
3689 if (!(IoDIRP(io) = PerlDir_open(dirname)))
a0d0e21e
LW		 3690 goto nope;
3691
3692 RETPUSHYES;
3693nope:
3694 if (!errno)
748a9306 3695 SETERRNO(EBADF,RMS$_DIR);
a0d0e21e
LW		 3696 RETPUSHUNDEF;
3697#else
cea2e8a9 3698 DIE(aTHX_ PL_no_dir_func, "opendir");
a0d0e21e
LW		 3699#endif
3700}
3701
3702PP(pp_readdir)
3703{
39644a26 3704 dSP;
a0d0e21e 3705#if defined(Direntry_t) && defined(HAS_READDIR)
fd8cd3a3 3706#if !defined(I_DIRENT) && !defined(VMS)
20ce7b12 3707 Direntry_t *readdir (DIR *);
a0d0e21e
LW		 3708#endif
3709 register Direntry_t *dp;
3710 GV *gv = (GV*)POPs;
3711 register IO *io = GvIOn(gv);
fb73857a 3712 SV *sv;
a0d0e21e
LW		 3713
3714 if (!io || !IoDIRP(io))
3715 goto nope;
3716
3717 if (GIMME == G_ARRAY) {
3718 /*SUPPRESS 560*/
155aba94 3719 while ((dp = (Direntry_t *)PerlDir_read(IoDIRP(io)))) {
a0d0e21e 3720#ifdef DIRNAMLEN
79cb57f6 3721 sv = newSVpvn(dp->d_name, dp->d_namlen);
a0d0e21e 3722#else
fb73857a 3723 sv = newSVpv(dp->d_name, 0);
3724#endif
3725#ifndef INCOMPLETE_TAINTS
26fb8f1f
GS		 3726 if (!(IoFLAGS(io) & IOf_UNTAINT))
3727 SvTAINTED_on(sv);
a0d0e21e 3728#endif
fb73857a 3729 XPUSHs(sv_2mortal(sv));
a0d0e21e
LW		 3730 }
3731 }
3732 else {
6ad3d225 3733 if (!(dp = (Direntry_t *)PerlDir_read(IoDIRP(io))))
a0d0e21e
LW		 3734 goto nope;
3735#ifdef DIRNAMLEN
79cb57f6 3736 sv = newSVpvn(dp->d_name, dp->d_namlen);
a0d0e21e 3737#else
fb73857a 3738 sv = newSVpv(dp->d_name, 0);
a0d0e21e 3739#endif
fb73857a 3740#ifndef INCOMPLETE_TAINTS
26fb8f1f
GS		 3741 if (!(IoFLAGS(io) & IOf_UNTAINT))
3742 SvTAINTED_on(sv);
fb73857a 3743#endif
3744 XPUSHs(sv_2mortal(sv));
a0d0e21e
LW		 3745 }
3746 RETURN;
3747
3748nope:
3749 if (!errno)
748a9306 3750 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 3751 if (GIMME == G_ARRAY)
3752 RETURN;
3753 else
3754 RETPUSHUNDEF;
3755#else
cea2e8a9 3756 DIE(aTHX_ PL_no_dir_func, "readdir");
a0d0e21e
LW		 3757#endif
3758}
3759
3760PP(pp_telldir)
3761{
39644a26 3762 dSP; dTARGET;
a0d0e21e 3763#if defined(HAS_TELLDIR) || defined(telldir)
968dcd91
JH		 3764 /* XXX does _anyone_ need this? --AD 2/20/1998 */
3765 /* XXX netbsd still seemed to.
3766 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3767 --JHI 1999-Feb-02 */
3768# if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
20ce7b12 3769 long telldir (DIR *);
dfe9444c 3770# endif
a0d0e21e
LW		 3771 GV *gv = (GV*)POPs;
3772 register IO *io = GvIOn(gv);
3773
3774 if (!io || !IoDIRP(io))
3775 goto nope;
3776
6ad3d225 3777 PUSHi( PerlDir_tell(IoDIRP(io)) );
a0d0e21e
LW		 3778 RETURN;
3779nope:
3780 if (!errno)
748a9306 3781 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 3782 RETPUSHUNDEF;
3783#else
cea2e8a9 3784 DIE(aTHX_ PL_no_dir_func, "telldir");
a0d0e21e
LW		 3785#endif
3786}
3787
3788PP(pp_seekdir)
3789{
39644a26 3790 dSP;
a0d0e21e
LW		 3791#if defined(HAS_SEEKDIR) || defined(seekdir)
3792 long along = POPl;
3793 GV *gv = (GV*)POPs;
3794 register IO *io = GvIOn(gv);
3795
3796 if (!io || !IoDIRP(io))
3797 goto nope;
3798
6ad3d225 3799 (void)PerlDir_seek(IoDIRP(io), along);
a0d0e21e
LW		 3800
3801 RETPUSHYES;
3802nope:
3803 if (!errno)
748a9306 3804 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 3805 RETPUSHUNDEF;
3806#else
cea2e8a9 3807 DIE(aTHX_ PL_no_dir_func, "seekdir");
a0d0e21e
LW		 3808#endif
3809}
3810
3811PP(pp_rewinddir)
3812{
39644a26 3813 dSP;
a0d0e21e
LW		 3814#if defined(HAS_REWINDDIR) || defined(rewinddir)
3815 GV *gv = (GV*)POPs;
3816 register IO *io = GvIOn(gv);
3817
3818 if (!io || !IoDIRP(io))
3819 goto nope;
3820
6ad3d225 3821 (void)PerlDir_rewind(IoDIRP(io));
a0d0e21e
LW		 3822 RETPUSHYES;
3823nope:
3824 if (!errno)
748a9306 3825 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 3826 RETPUSHUNDEF;
3827#else
cea2e8a9 3828 DIE(aTHX_ PL_no_dir_func, "rewinddir");
a0d0e21e
LW		 3829#endif
3830}
3831
3832PP(pp_closedir)
3833{
39644a26 3834 dSP;
a0d0e21e
LW		 3835#if defined(Direntry_t) && defined(HAS_READDIR)
3836 GV *gv = (GV*)POPs;
3837 register IO *io = GvIOn(gv);
3838
3839 if (!io || !IoDIRP(io))
3840 goto nope;
3841
3842#ifdef VOID_CLOSEDIR
6ad3d225 3843 PerlDir_close(IoDIRP(io));
a0d0e21e 3844#else
6ad3d225 3845 if (PerlDir_close(IoDIRP(io)) < 0) {
748a9306 3846 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
a0d0e21e 3847 goto nope;
748a9306 3848 }
a0d0e21e
LW		 3849#endif
3850 IoDIRP(io) = 0;
3851
3852 RETPUSHYES;
3853nope:
3854 if (!errno)
748a9306 3855 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW		 3856 RETPUSHUNDEF;
3857#else
cea2e8a9 3858 DIE(aTHX_ PL_no_dir_func, "closedir");
a0d0e21e
LW		 3859#endif
3860}
3861
3862/* Process control. */
3863
3864PP(pp_fork)
3865{
44a8e56a 3866#ifdef HAS_FORK
39644a26 3867 dSP; dTARGET;
761237fe 3868 Pid_t childpid;
a0d0e21e
LW		 3869 GV *tmpgv;
3870
3871 EXTEND(SP, 1);
45bc9206 3872 PERL_FLUSHALL_FOR_CHILD;
a0d0e21e
LW		 3873 childpid = fork();
3874 if (childpid < 0)
3875 RETSETUNDEF;
3876 if (!childpid) {
3877 /*SUPPRESS 560*/
155aba94 3878 if ((tmpgv = gv_fetchpv("$", TRUE, SVt_PV)))
146174a9 3879 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3280af22 3880 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
a0d0e21e
LW		 3881 }
3882 PUSHi(childpid);
3883 RETURN;
3884#else
146174a9 3885# if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
39644a26 3886 dSP; dTARGET;
146174a9
CB		 3887 Pid_t childpid;
3888
3889 EXTEND(SP, 1);
3890 PERL_FLUSHALL_FOR_CHILD;
3891 childpid = PerlProc_fork();
60fa28ff
GS		 3892 if (childpid == -1)
3893 RETSETUNDEF;
146174a9
CB		 3894 PUSHi(childpid);
3895 RETURN;
3896# else
cea2e8a9 3897 DIE(aTHX_ PL_no_func, "Unsupported function fork");
146174a9 3898# endif
a0d0e21e
LW		 3899#endif
3900}
3901
3902PP(pp_wait)
3903{
301e8125 3904#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
39644a26 3905 dSP; dTARGET;
761237fe 3906 Pid_t childpid;
a0d0e21e 3907 int argflags;
a0d0e21e 3908
0a0ada86 3909#ifdef PERL_OLD_SIGNALS
44a8e56a 3910 childpid = wait4pid(-1, &argflags, 0);
0a0ada86
NIS		 3911#else
3912 while ((childpid = wait4pid(-1, &argflags, 0)) == -1 && errno == EINTR) {
3913 PERL_ASYNC_CHECK();
3914 }
3915#endif
68a29c53
GS		 3916# if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3917 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
3918 STATUS_NATIVE_SET((childpid && childpid != -1) ? argflags : -1);
3919# else
f86702cc 3920 STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
68a29c53 3921# endif
44a8e56a 3922 XPUSHi(childpid);
a0d0e21e
LW		 3923 RETURN;
3924#else
cea2e8a9 3925 DIE(aTHX_ PL_no_func, "Unsupported function wait");
a0d0e21e
LW		 3926#endif
3927}
3928
3929PP(pp_waitpid)
3930{
301e8125 3931#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
39644a26 3932 dSP; dTARGET;
761237fe 3933 Pid_t childpid;
a0d0e21e
LW		 3934 int optype;
3935 int argflags;
a0d0e21e 3936
a0d0e21e
LW		 3937 optype = POPi;
3938 childpid = TOPi;
0a0ada86 3939#ifdef PERL_OLD_SIGNALS
a0d0e21e 3940 childpid = wait4pid(childpid, &argflags, optype);
0a0ada86
NIS		 3941#else
3942 while ((childpid = wait4pid(childpid, &argflags, optype)) == -1 && errno == EINTR) {
3943 PERL_ASYNC_CHECK();
3944 }
3945#endif
68a29c53
GS		 3946# if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3947 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
3948 STATUS_NATIVE_SET((childpid && childpid != -1) ? argflags : -1);
3949# else
f86702cc 3950 STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
68a29c53 3951# endif
44a8e56a 3952 SETi(childpid);
a0d0e21e
LW		 3953 RETURN;
3954#else
cea2e8a9 3955 DIE(aTHX_ PL_no_func, "Unsupported function waitpid");
a0d0e21e
LW		 3956#endif
3957}
3958
3959PP(pp_system)
3960{
39644a26 3961 dSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e 3962 I32 value;
761237fe 3963 Pid_t childpid;
a0d0e21e
LW		 3964 int result;
3965 int status;
ff68c719 3966 Sigsave_t ihand,qhand; /* place to save signals during system() */
2d8e6c8d 3967 STRLEN n_a;
d5a9bfb0
IZ		 3968 I32 did_pipes = 0;
3969 int pp[2];
a0d0e21e 3970
a0d0e21e 3971 if (SP - MARK == 1) {
3280af22 3972 if (PL_tainting) {
516a5887 3973 (void)SvPV_nolen(TOPs); /* stringify for taint check */
a0d0e21e
LW		 3974 TAINT_ENV();
3975 TAINT_PROPER("system");
3976 }
3977 }
45bc9206 3978 PERL_FLUSHALL_FOR_CHILD;
64ca3a65 3979#if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) && !defined(__CYGWIN__) || defined(PERL_MICRO)
d5a9bfb0
IZ		 3980 if (PerlProc_pipe(pp) >= 0)
3981 did_pipes = 1;
a0d0e21e
LW		 3982 while ((childpid = vfork()) == -1) {
3983 if (errno != EAGAIN) {
3984 value = -1;
3985 SP = ORIGMARK;
3986 PUSHi(value);
d5a9bfb0
IZ		 3987 if (did_pipes) {
3988 PerlLIO_close(pp[0]);
3989 PerlLIO_close(pp[1]);
3990 }
a0d0e21e
LW		 3991 RETURN;
3992 }
3993 sleep(5);
3994 }
3995 if (childpid > 0) {
d5a9bfb0
IZ		 3996 if (did_pipes)
3997 PerlLIO_close(pp[1]);
64ca3a65 3998#ifndef PERL_MICRO
ff68c719 3999 rsignal_save(SIGINT, SIG_IGN, &ihand);
4000 rsignal_save(SIGQUIT, SIG_IGN, &qhand);
64ca3a65 4001#endif
748a9306
LW		 4002 do {
4003 result = wait4pid(childpid, &status, 0);
4004 } while (result == -1 && errno == EINTR);
64ca3a65 4005#ifndef PERL_MICRO
ff68c719 4006 (void)rsignal_restore(SIGINT, &ihand);
4007 (void)rsignal_restore(SIGQUIT, &qhand);
64ca3a65 4008#endif
91e9c03f 4009 STATUS_NATIVE_SET(result == -1 ? -1 : status);
a0d0e21e
LW		 4010 do_execfree(); /* free any memory child malloced on vfork */
4011 SP = ORIGMARK;
d5a9bfb0
IZ		 4012 if (did_pipes) {
4013 int errkid;
4014 int n = 0, n1;
4015
4016 while (n < sizeof(int)) {
4017 n1 = PerlLIO_read(pp[0],
4018 (void*)(((char*)&errkid)+n),
4019 (sizeof(int)) - n);
4020 if (n1 <= 0)
4021 break;
4022 n += n1;
4023 }
4024 PerlLIO_close(pp[0]);
4025 if (n) { /* Error */
4026 if (n != sizeof(int))
c529f79d 4027 DIE(aTHX_ "panic: kid popen errno read");
d5a9bfb0
IZ		 4028 errno = errkid; /* Propagate errno from kid */
4029 STATUS_CURRENT = -1;
4030 }
4031 }
ff0cee69 4032 PUSHi(STATUS_CURRENT);
a0d0e21e
LW		 4033 RETURN;
4034 }
d5a9bfb0
IZ		 4035 if (did_pipes) {
4036 PerlLIO_close(pp[0]);
4037#if defined(HAS_FCNTL) && defined(F_SETFD)
4038 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4039#endif
4040 }
533c011a 4041 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e 4042 SV *really = *++MARK;
d5a9bfb0 4043 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
a0d0e21e
LW		 4044 }
4045 else if (SP - MARK != 1)
d5a9bfb0 4046 value = (I32)do_aexec5(Nullsv, MARK, SP, pp[1], did_pipes);
a0d0e21e 4047 else {
d5a9bfb0 4048 value = (I32)do_exec3(SvPVx(sv_mortalcopy(*SP), n_a), pp[1], did_pipes);
a0d0e21e 4049 }
6ad3d225 4050 PerlProc__exit(-1);
c3293030 4051#else /* ! FORK or VMS or OS/2 */
922b1888
GS		 4052 PL_statusvalue = 0;
4053 result = 0;
911d147d 4054 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e 4055 SV *really = *++MARK;
c5be433b 4056 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
a0d0e21e
LW		 4057 }
4058 else if (SP - MARK != 1)
c5be433b 4059 value = (I32)do_aspawn(Nullsv, (void **)MARK, (void **)SP);
a0d0e21e 4060 else {
c5be433b 4061 value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
a0d0e21e 4062 }
922b1888
GS		 4063 if (PL_statusvalue == -1) /* hint that value must be returned as is */
4064 result = 1;
f86702cc 4065 STATUS_NATIVE_SET(value);
a0d0e21e
LW		 4066 do_execfree();
4067 SP = ORIGMARK;
922b1888 4068 PUSHi(result ? value : STATUS_CURRENT);
a0d0e21e
LW		 4069#endif /* !FORK or VMS */
4070 RETURN;
4071}
4072
4073PP(pp_exec)
4074{
39644a26 4075 dSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e 4076 I32 value;
2d8e6c8d 4077 STRLEN n_a;
a0d0e21e 4078
45bc9206 4079 PERL_FLUSHALL_FOR_CHILD;
533c011a 4080 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e
LW		 4081 SV *really = *++MARK;
4082 value = (I32)do_aexec(really, MARK, SP);
4083 }
4084 else if (SP - MARK != 1)
4085#ifdef VMS
4086 value = (I32)vms_do_aexec(Nullsv, MARK, SP);
4087#else
092bebab
JH		 4088# ifdef __OPEN_VM
4089 {
c5be433b 4090 (void ) do_aspawn(Nullsv, MARK, SP);
092bebab
JH		 4091 value = 0;
4092 }
4093# else
a0d0e21e 4094 value = (I32)do_aexec(Nullsv, MARK, SP);
092bebab 4095# endif
a0d0e21e
LW		 4096#endif
4097 else {
3280af22 4098 if (PL_tainting) {
516a5887 4099 (void)SvPV_nolen(*SP); /* stringify for taint check */
a0d0e21e
LW		 4100 TAINT_ENV();
4101 TAINT_PROPER("exec");
4102 }
4103#ifdef VMS
2d8e6c8d 4104 value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
a0d0e21e 4105#else
092bebab 4106# ifdef __OPEN_VM
c5be433b 4107 (void) do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
092bebab
JH		 4108 value = 0;
4109# else
2d8e6c8d 4110 value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
092bebab 4111# endif
a0d0e21e
LW		 4112#endif
4113 }
146174a9
CB		 4114
4115#if !defined(HAS_FORK) && defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4116 if (value >= 0)
4117 my_exit(value);
4118#endif
4119
a0d0e21e
LW		 4120 SP = ORIGMARK;
4121 PUSHi(value);
4122 RETURN;
4123}
4124
4125PP(pp_kill)
4126{
39644a26 4127 dSP; dMARK; dTARGET;
a0d0e21e
LW		 4128 I32 value;
4129#ifdef HAS_KILL
533c011a 4130 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 4131 SP = MARK;
4132 PUSHi(value);
4133 RETURN;
4134#else
cea2e8a9 4135 DIE(aTHX_ PL_no_func, "Unsupported function kill");
a0d0e21e
LW		 4136#endif
4137}
4138
4139PP(pp_getppid)
4140{
4141#ifdef HAS_GETPPID
39644a26 4142 dSP; dTARGET;
a0d0e21e
LW		 4143 XPUSHi( getppid() );
4144 RETURN;
4145#else
cea2e8a9 4146 DIE(aTHX_ PL_no_func, "getppid");
a0d0e21e
LW		 4147#endif
4148}
4149
4150PP(pp_getpgrp)
4151{
4152#ifdef HAS_GETPGRP
39644a26 4153 dSP; dTARGET;
d8a83dd3 4154 Pid_t pid;
9853a804 4155 Pid_t pgrp;
a0d0e21e
LW		 4156
4157 if (MAXARG < 1)
4158 pid = 0;
4159 else
4160 pid = SvIVx(POPs);
c3293030 4161#ifdef BSD_GETPGRP
9853a804 4162 pgrp = (I32)BSD_GETPGRP(pid);
a0d0e21e 4163#else
146174a9 4164 if (pid != 0 && pid != PerlProc_getpid())
cea2e8a9 4165 DIE(aTHX_ "POSIX getpgrp can't take an argument");
9853a804 4166 pgrp = getpgrp();
a0d0e21e 4167#endif
9853a804 4168 XPUSHi(pgrp);
a0d0e21e
LW		 4169 RETURN;
4170#else
cea2e8a9 4171 DIE(aTHX_ PL_no_func, "getpgrp()");
a0d0e21e
LW		 4172#endif
4173}
4174
4175PP(pp_setpgrp)
4176{
4177#ifdef HAS_SETPGRP
39644a26 4178 dSP; dTARGET;
d8a83dd3
JH		 4179 Pid_t pgrp;
4180 Pid_t pid;
a0d0e21e
LW		 4181 if (MAXARG < 2) {
4182 pgrp = 0;
4183 pid = 0;
4184 }
4185 else {
4186 pgrp = POPi;
4187 pid = TOPi;
4188 }
4189
4190 TAINT_PROPER("setpgrp");
c3293030
IZ		 4191#ifdef BSD_SETPGRP
4192 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
a0d0e21e 4193#else
146174a9
CB		 4194 if ((pgrp != 0 && pgrp != PerlProc_getpid())
4195 || (pid != 0 && pid != PerlProc_getpid()))
4196 {
4197 DIE(aTHX_ "setpgrp can't take arguments");
4198 }
a0d0e21e
LW		 4199 SETi( setpgrp() >= 0 );
4200#endif /* USE_BSDPGRP */
4201 RETURN;
4202#else
cea2e8a9 4203 DIE(aTHX_ PL_no_func, "setpgrp()");
a0d0e21e
LW		 4204#endif
4205}
4206
4207PP(pp_getpriority)
4208{
39644a26 4209 dSP; dTARGET;
a0d0e21e
LW		 4210 int which;
4211 int who;
4212#ifdef HAS_GETPRIORITY
4213 who = POPi;
4214 which = TOPi;
4215 SETi( getpriority(which, who) );
4216 RETURN;
4217#else
cea2e8a9 4218 DIE(aTHX_ PL_no_func, "getpriority()");
a0d0e21e
LW		 4219#endif
4220}
4221
4222PP(pp_setpriority)
4223{
39644a26 4224 dSP; dTARGET;
a0d0e21e
LW		 4225 int which;
4226 int who;
4227 int niceval;
4228#ifdef HAS_SETPRIORITY
4229 niceval = POPi;
4230 who = POPi;
4231 which = TOPi;
4232 TAINT_PROPER("setpriority");
4233 SETi( setpriority(which, who, niceval) >= 0 );
4234 RETURN;
4235#else
cea2e8a9 4236 DIE(aTHX_ PL_no_func, "setpriority()");
a0d0e21e
LW		 4237#endif
4238}
4239
4240/* Time calls. */
4241
4242PP(pp_time)
4243{
39644a26 4244 dSP; dTARGET;
cbdc8872 4245#ifdef BIG_TIME
4246 XPUSHn( time(Null(Time_t*)) );
4247#else
a0d0e21e 4248 XPUSHi( time(Null(Time_t*)) );
cbdc8872 4249#endif
a0d0e21e
LW		 4250 RETURN;
4251}
4252
cd52b7b2 4253/* XXX The POSIX name is CLK_TCK; it is to be preferred
4254 to HZ. Probably. For now, assume that if the system
4255 defines HZ, it does so correctly. (Will this break
4256 on VMS?)
4257 Probably we ought to use _sysconf(_SC_CLK_TCK), if
4258 it's supported. --AD 9/96.
4259*/
4260
a0d0e21e 4261#ifndef HZ
cd52b7b2 4262# ifdef CLK_TCK
4263# define HZ CLK_TCK
4264# else
4265# define HZ 60
4266# endif
a0d0e21e
LW		 4267#endif
4268
4269PP(pp_tms)
4270{
39644a26 4271 dSP;
a0d0e21e 4272
55497cff 4273#ifndef HAS_TIMES
cea2e8a9 4274 DIE(aTHX_ "times not implemented");
a0d0e21e
LW		 4275#else
4276 EXTEND(SP, 4);
4277
4278#ifndef VMS
3280af22 4279 (void)PerlProc_times(&PL_timesbuf);
a0d0e21e 4280#else
6b88bc9c 4281 (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
76e3520e
GS		 4282 /* struct tms, though same data */
4283 /* is returned. */
a0d0e21e
LW		 4284#endif
4285
65202027 4286 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_utime)/HZ)));
a0d0e21e 4287 if (GIMME == G_ARRAY) {
65202027
DS		 4288 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_stime)/HZ)));
4289 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cutime)/HZ)));
4290 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cstime)/HZ)));
a0d0e21e
LW		 4291 }
4292 RETURN;
55497cff 4293#endif /* HAS_TIMES */
a0d0e21e
LW		 4294}
4295
4296PP(pp_localtime)
4297{
cea2e8a9 4298 return pp_gmtime();
a0d0e21e
LW		 4299}
4300
4301PP(pp_gmtime)
4302{
39644a26 4303 dSP;
a0d0e21e
LW		 4304 Time_t when;
4305 struct tm *tmbuf;
4306 static char *dayname[] = {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4307 static char *monname[] = {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4308 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4309
4310 if (MAXARG < 1)
4311 (void)time(&when);
4312 else
cbdc8872 4313#ifdef BIG_TIME
4314 when = (Time_t)SvNVx(POPs);
4315#else
a0d0e21e 4316 when = (Time_t)SvIVx(POPs);
cbdc8872 4317#endif
a0d0e21e 4318
533c011a 4319 if (PL_op->op_type == OP_LOCALTIME)
a0d0e21e
LW		 4320 tmbuf = localtime(&when);
4321 else
4322 tmbuf = gmtime(&when);
4323
4324 EXTEND(SP, 9);
bbce6d69 4325 EXTEND_MORTAL(9);
a0d0e21e 4326 if (GIMME != G_ARRAY) {
46fc3d4c 4327 SV *tsv;
a0d0e21e
LW		 4328 if (!tmbuf)
4329 RETPUSHUNDEF;
be28567c 4330 tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %d",
f5a29b03
RB		 4331 dayname[tmbuf->tm_wday],
4332 monname[tmbuf->tm_mon],
be28567c
GS		 4333 tmbuf->tm_mday,
4334 tmbuf->tm_hour,
4335 tmbuf->tm_min,
4336 tmbuf->tm_sec,
4337 tmbuf->tm_year + 1900);
46fc3d4c 4338 PUSHs(sv_2mortal(tsv));
a0d0e21e
LW		 4339 }
4340 else if (tmbuf) {
c6419e06
JH		 4341 PUSHs(sv_2mortal(newSViv(tmbuf->tm_sec)));
4342 PUSHs(sv_2mortal(newSViv(tmbuf->tm_min)));
4343 PUSHs(sv_2mortal(newSViv(tmbuf->tm_hour)));
4344 PUSHs(sv_2mortal(newSViv(tmbuf->tm_mday)));
4345 PUSHs(sv_2mortal(newSViv(tmbuf->tm_mon)));
4346 PUSHs(sv_2mortal(newSViv(tmbuf->tm_year)));
4347 PUSHs(sv_2mortal(newSViv(tmbuf->tm_wday)));
4348 PUSHs(sv_2mortal(newSViv(tmbuf->tm_yday)));
4349 PUSHs(sv_2mortal(newSViv(tmbuf->tm_isdst)));
a0d0e21e
LW		 4350 }
4351 RETURN;
4352}
4353
4354PP(pp_alarm)
4355{
39644a26 4356 dSP; dTARGET;
a0d0e21e
LW		 4357 int anum;
4358#ifdef HAS_ALARM
4359 anum = POPi;
4360 anum = alarm((unsigned int)anum);
4361 EXTEND(SP, 1);
4362 if (anum < 0)
4363 RETPUSHUNDEF;
c6419e06 4364 PUSHi(anum);
a0d0e21e
LW		 4365 RETURN;
4366#else
cea2e8a9 4367 DIE(aTHX_ PL_no_func, "Unsupported function alarm");
a0d0e21e
LW		 4368#endif
4369}
4370
4371PP(pp_sleep)
4372{
39644a26 4373 dSP; dTARGET;
a0d0e21e
LW		 4374 I32 duration;
4375 Time_t lasttime;
4376 Time_t when;
4377
4378 (void)time(&lasttime);
4379 if (MAXARG < 1)
76e3520e 4380 PerlProc_pause();
a0d0e21e
LW		 4381 else {
4382 duration = POPi;
76e3520e 4383 PerlProc_sleep((unsigned int)duration);
a0d0e21e
LW		 4384 }
4385 (void)time(&when);
4386 XPUSHi(when - lasttime);
4387 RETURN;
4388}
4389
4390/* Shared memory. */
4391
4392PP(pp_shmget)
4393{
cea2e8a9 4394 return pp_semget();
a0d0e21e
LW		 4395}
4396
4397PP(pp_shmctl)
4398{
cea2e8a9 4399 return pp_semctl();
a0d0e21e
LW		 4400}
4401
4402PP(pp_shmread)
4403{
cea2e8a9 4404 return pp_shmwrite();
a0d0e21e
LW		 4405}
4406
4407PP(pp_shmwrite)
4408{
4409#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
39644a26 4410 dSP; dMARK; dTARGET;
533c011a 4411 I32 value = (I32)(do_shmio(PL_op->op_type, MARK, SP) >= 0);
a0d0e21e
LW		 4412 SP = MARK;
4413 PUSHi(value);
4414 RETURN;
4415#else
cea2e8a9 4416 return pp_semget();
a0d0e21e
LW		 4417#endif
4418}
4419
4420/* Message passing. */
4421
4422PP(pp_msgget)
4423{
cea2e8a9 4424 return pp_semget();
a0d0e21e
LW		 4425}
4426
4427PP(pp_msgctl)
4428{
cea2e8a9 4429 return pp_semctl();
a0d0e21e
LW		 4430}
4431
4432PP(pp_msgsnd)
4433{
4434#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
39644a26 4435 dSP; dMARK; dTARGET;
a0d0e21e
LW		 4436 I32 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4437 SP = MARK;
4438 PUSHi(value);
4439 RETURN;
4440#else
cea2e8a9 4441 return pp_semget();
a0d0e21e
LW		 4442#endif
4443}
4444
4445PP(pp_msgrcv)
4446{
4447#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
39644a26 4448 dSP; dMARK; dTARGET;
a0d0e21e
LW		 4449 I32 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4450 SP = MARK;
4451 PUSHi(value);
4452 RETURN;
4453#else
cea2e8a9 4454 return pp_semget();
a0d0e21e
LW		 4455#endif
4456}
4457
4458/* Semaphores. */
4459
4460PP(pp_semget)
4461{
4462#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
39644a26 4463 dSP; dMARK; dTARGET;
533c011a 4464 int anum = do_ipcget(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 4465 SP = MARK;
4466 if (anum == -1)
4467 RETPUSHUNDEF;
4468 PUSHi(anum);
4469 RETURN;
4470#else
cea2e8a9 4471 DIE(aTHX_ "System V IPC is not implemented on this machine");
a0d0e21e
LW		 4472#endif
4473}
4474
4475PP(pp_semctl)
4476{
4477#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
39644a26 4478 dSP; dMARK; dTARGET;
533c011a 4479 int anum = do_ipcctl(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 4480 SP = MARK;
4481 if (anum == -1)
4482 RETSETUNDEF;
4483 if (anum != 0) {
4484 PUSHi(anum);
4485 }
4486 else {
8903cb82 4487 PUSHp(zero_but_true, ZBTLEN);
a0d0e21e
LW		 4488 }
4489 RETURN;
4490#else
cea2e8a9 4491 return pp_semget();
a0d0e21e
LW		 4492#endif
4493}
4494
4495PP(pp_semop)
4496{
4497#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
39644a26 4498 dSP; dMARK; dTARGET;
a0d0e21e
LW		 4499 I32 value = (I32)(do_semop(MARK, SP) >= 0);
4500 SP = MARK;
4501 PUSHi(value);
4502 RETURN;
4503#else
cea2e8a9 4504 return pp_semget();
a0d0e21e
LW		 4505#endif
4506}
4507
4508/* Get system info. */
4509
4510PP(pp_ghbyname)
4511{
693762b4 4512#ifdef HAS_GETHOSTBYNAME
cea2e8a9 4513 return pp_ghostent();
a0d0e21e 4514#else
cea2e8a9 4515 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
a0d0e21e
LW		 4516#endif
4517}
4518
4519PP(pp_ghbyaddr)
4520{
693762b4 4521#ifdef HAS_GETHOSTBYADDR
cea2e8a9 4522 return pp_ghostent();
a0d0e21e 4523#else
cea2e8a9 4524 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
a0d0e21e
LW		 4525#endif
4526}
4527
4528PP(pp_ghostent)
4529{
39644a26 4530 dSP;
693762b4 4531#if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
533c011a 4532 I32 which = PL_op->op_type;
a0d0e21e
LW		 4533 register char **elem;
4534 register SV *sv;
dc45a647 4535#ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4599a1de
JH		 4536 struct hostent *PerlSock_gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4537 struct hostent *PerlSock_gethostbyname(Netdb_name_t);
6ad3d225 4538 struct hostent *PerlSock_gethostent(void);
a0d0e21e
LW		 4539#endif
4540 struct hostent *hent;
4541 unsigned long len;
2d8e6c8d 4542 STRLEN n_a;
a0d0e21e
LW		 4543
4544 EXTEND(SP, 10);
dc45a647
MB		 4545 if (which == OP_GHBYNAME)
4546#ifdef HAS_GETHOSTBYNAME
595ae481 4547 hent = PerlSock_gethostbyname(POPpbytex);
dc45a647 4548#else
cea2e8a9 4549 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
dc45a647 4550#endif
a0d0e21e 4551 else if (which == OP_GHBYADDR) {
dc45a647 4552#ifdef HAS_GETHOSTBYADDR
a0d0e21e 4553 int addrtype = POPi;
748a9306 4554 SV *addrsv = POPs;
a0d0e21e 4555 STRLEN addrlen;
595ae481 4556 Netdb_host_t addr = (Netdb_host_t) SvPVbyte(addrsv, addrlen);
a0d0e21e 4557
4599a1de 4558 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
dc45a647 4559#else
cea2e8a9 4560 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
dc45a647 4561#endif
a0d0e21e
LW		 4562 }
4563 else
4564#ifdef HAS_GETHOSTENT
6ad3d225 4565 hent = PerlSock_gethostent();
a0d0e21e 4566#else
cea2e8a9 4567 DIE(aTHX_ PL_no_sock_func, "gethostent");
a0d0e21e
LW		 4568#endif
4569
4570#ifdef HOST_NOT_FOUND
4571 if (!hent)
f86702cc 4572 STATUS_NATIVE_SET(h_errno);
a0d0e21e
LW		 4573#endif
4574
4575 if (GIMME != G_ARRAY) {
4576 PUSHs(sv = sv_newmortal());
4577 if (hent) {
4578 if (which == OP_GHBYNAME) {
fd0af264 4579 if (hent->h_addr)
4580 sv_setpvn(sv, hent->h_addr, hent->h_length);
a0d0e21e
LW		 4581 }
4582 else
4583 sv_setpv(sv, (char*)hent->h_name);
4584 }
4585 RETURN;
4586 }
4587
4588 if (hent) {
3280af22 4589 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4590 sv_setpv(sv, (char*)hent->h_name);
3280af22 4591 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 4592 for (elem = hent->h_aliases; elem && *elem; elem++) {
4593 sv_catpv(sv, *elem);
4594 if (elem[1])
4595 sv_catpvn(sv, " ", 1);
4596 }
3280af22 4597 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4598 sv_setiv(sv, (IV)hent->h_addrtype);
3280af22 4599 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4600 len = hent->h_length;
1e422769 4601 sv_setiv(sv, (IV)len);
a0d0e21e
LW		 4602#ifdef h_addr
4603 for (elem = hent->h_addr_list; elem && *elem; elem++) {
3280af22 4604 XPUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 4605 sv_setpvn(sv, *elem, len);
4606 }
4607#else
6b88bc9c 4608 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
fd0af264 4609 if (hent->h_addr)
4610 sv_setpvn(sv, hent->h_addr, len);
a0d0e21e
LW		 4611#endif /* h_addr */
4612 }
4613 RETURN;
4614#else
cea2e8a9 4615 DIE(aTHX_ PL_no_sock_func, "gethostent");
a0d0e21e
LW		 4616#endif
4617}
4618
4619PP(pp_gnbyname)
4620{
693762b4 4621#ifdef HAS_GETNETBYNAME
cea2e8a9 4622 return pp_gnetent();
a0d0e21e 4623#else
cea2e8a9 4624 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
a0d0e21e
LW		 4625#endif
4626}
4627
4628PP(pp_gnbyaddr)
4629{
693762b4 4630#ifdef HAS_GETNETBYADDR
cea2e8a9 4631 return pp_gnetent();
a0d0e21e 4632#else
cea2e8a9 4633 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
a0d0e21e
LW		 4634#endif
4635}
4636
4637PP(pp_gnetent)
4638{
39644a26 4639 dSP;
693762b4 4640#if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
533c011a 4641 I32 which = PL_op->op_type;
a0d0e21e
LW		 4642 register char **elem;
4643 register SV *sv;
dc45a647
MB		 4644#ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4645 struct netent *PerlSock_getnetbyaddr(Netdb_net_t, int);
4646 struct netent *PerlSock_getnetbyname(Netdb_name_t);
4647 struct netent *PerlSock_getnetent(void);
8ac85365 4648#endif
a0d0e21e 4649 struct netent *nent;
2d8e6c8d 4650 STRLEN n_a;
a0d0e21e
LW		 4651
4652 if (which == OP_GNBYNAME)
dc45a647 4653#ifdef HAS_GETNETBYNAME
42e0c139 4654 nent = PerlSock_getnetbyname(POPpbytex);
dc45a647 4655#else
cea2e8a9 4656 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
dc45a647 4657#endif
a0d0e21e 4658 else if (which == OP_GNBYADDR) {
dc45a647 4659#ifdef HAS_GETNETBYADDR
a0d0e21e 4660 int addrtype = POPi;
3bb7c1b4 4661 Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
76e3520e 4662 nent = PerlSock_getnetbyaddr(addr, addrtype);
dc45a647 4663#else
cea2e8a9 4664 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
dc45a647 4665#endif
a0d0e21e
LW		 4666 }
4667 else
dc45a647 4668#ifdef HAS_GETNETENT
76e3520e 4669 nent = PerlSock_getnetent();
dc45a647 4670#else
cea2e8a9 4671 DIE(aTHX_ PL_no_sock_func, "getnetent");
dc45a647 4672#endif
a0d0e21e
LW		 4673
4674 EXTEND(SP, 4);
4675 if (GIMME != G_ARRAY) {
4676 PUSHs(sv = sv_newmortal());
4677 if (nent) {
4678 if (which == OP_GNBYNAME)
1e422769 4679 sv_setiv(sv, (IV)nent->n_net);
a0d0e21e
LW		 4680 else
4681 sv_setpv(sv, nent->n_name);
4682 }
4683 RETURN;
4684 }
4685
4686 if (nent) {
3280af22 4687 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4688 sv_setpv(sv, nent->n_name);
3280af22 4689 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 4690 for (elem = nent->n_aliases; elem && *elem; elem++) {
a0d0e21e
LW		 4691 sv_catpv(sv, *elem);
4692 if (elem[1])
4693 sv_catpvn(sv, " ", 1);
4694 }
3280af22 4695 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4696 sv_setiv(sv, (IV)nent->n_addrtype);
3280af22 4697 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4698 sv_setiv(sv, (IV)nent->n_net);
a0d0e21e
LW		 4699 }
4700
4701 RETURN;
4702#else
cea2e8a9 4703 DIE(aTHX_ PL_no_sock_func, "getnetent");
a0d0e21e
LW		 4704#endif
4705}
4706
4707PP(pp_gpbyname)
4708{
693762b4 4709#ifdef HAS_GETPROTOBYNAME
cea2e8a9 4710 return pp_gprotoent();
a0d0e21e 4711#else
cea2e8a9 4712 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
a0d0e21e
LW		 4713#endif
4714}
4715
4716PP(pp_gpbynumber)
4717{
693762b4 4718#ifdef HAS_GETPROTOBYNUMBER
cea2e8a9 4719 return pp_gprotoent();
a0d0e21e 4720#else
cea2e8a9 4721 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
a0d0e21e
LW		 4722#endif
4723}
4724
4725PP(pp_gprotoent)
4726{
39644a26 4727 dSP;
693762b4 4728#if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
533c011a 4729 I32 which = PL_op->op_type;
a0d0e21e 4730 register char **elem;
301e8125 4731 register SV *sv;
dc45a647 4732#ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4599a1de 4733 struct protoent *PerlSock_getprotobyname(Netdb_name_t);
6ad3d225
GS		 4734 struct protoent *PerlSock_getprotobynumber(int);
4735 struct protoent *PerlSock_getprotoent(void);
8ac85365 4736#endif
a0d0e21e 4737 struct protoent *pent;
2d8e6c8d 4738 STRLEN n_a;
a0d0e21e
LW		 4739
4740 if (which == OP_GPBYNAME)
e5c9fcd0 4741#ifdef HAS_GETPROTOBYNAME
42e0c139 4742 pent = PerlSock_getprotobyname(POPpbytex);
e5c9fcd0 4743#else
cea2e8a9 4744 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
e5c9fcd0 4745#endif
a0d0e21e 4746 else if (which == OP_GPBYNUMBER)
e5c9fcd0 4747#ifdef HAS_GETPROTOBYNUMBER
6ad3d225 4748 pent = PerlSock_getprotobynumber(POPi);
e5c9fcd0 4749#else
cea2e8a9 4750 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
e5c9fcd0 4751#endif
a0d0e21e 4752 else
e5c9fcd0 4753#ifdef HAS_GETPROTOENT
6ad3d225 4754 pent = PerlSock_getprotoent();
e5c9fcd0 4755#else
cea2e8a9 4756 DIE(aTHX_ PL_no_sock_func, "getprotoent");
e5c9fcd0 4757#endif
a0d0e21e
LW		 4758
4759 EXTEND(SP, 3);
4760 if (GIMME != G_ARRAY) {
4761 PUSHs(sv = sv_newmortal());
4762 if (pent) {
4763 if (which == OP_GPBYNAME)
1e422769 4764 sv_setiv(sv, (IV)pent->p_proto);
a0d0e21e
LW		 4765 else
4766 sv_setpv(sv, pent->p_name);
4767 }
4768 RETURN;
4769 }
4770
4771 if (pent) {
3280af22 4772 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4773 sv_setpv(sv, pent->p_name);
3280af22 4774 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 4775 for (elem = pent->p_aliases; elem && *elem; elem++) {
a0d0e21e
LW		 4776 sv_catpv(sv, *elem);
4777 if (elem[1])
4778 sv_catpvn(sv, " ", 1);
4779 }
3280af22 4780 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4781 sv_setiv(sv, (IV)pent->p_proto);
a0d0e21e
LW		 4782 }
4783
4784 RETURN;
4785#else
cea2e8a9 4786 DIE(aTHX_ PL_no_sock_func, "getprotoent");
a0d0e21e
LW		 4787#endif
4788}
4789
4790PP(pp_gsbyname)
4791{
9ec75305 4792#ifdef HAS_GETSERVBYNAME
cea2e8a9 4793 return pp_gservent();
a0d0e21e 4794#else
cea2e8a9 4795 DIE(aTHX_ PL_no_sock_func, "getservbyname");
a0d0e21e
LW		 4796#endif
4797}
4798
4799PP(pp_gsbyport)
4800{
9ec75305 4801#ifdef HAS_GETSERVBYPORT
cea2e8a9 4802 return pp_gservent();
a0d0e21e 4803#else
cea2e8a9 4804 DIE(aTHX_ PL_no_sock_func, "getservbyport");
a0d0e21e
LW		 4805#endif
4806}
4807
4808PP(pp_gservent)
4809{
39644a26 4810 dSP;
693762b4 4811#if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
533c011a 4812 I32 which = PL_op->op_type;
a0d0e21e
LW		 4813 register char **elem;
4814 register SV *sv;
dc45a647 4815#ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4599a1de
JH		 4816 struct servent *PerlSock_getservbyname(Netdb_name_t, Netdb_name_t);
4817 struct servent *PerlSock_getservbyport(int, Netdb_name_t);
6ad3d225 4818 struct servent *PerlSock_getservent(void);
8ac85365 4819#endif
a0d0e21e 4820 struct servent *sent;
2d8e6c8d 4821 STRLEN n_a;
a0d0e21e
LW		 4822
4823 if (which == OP_GSBYNAME) {
dc45a647 4824#ifdef HAS_GETSERVBYNAME
42e0c139
AP		 4825 char *proto = POPpbytex;
4826 char *name = POPpbytex;
a0d0e21e
LW		 4827
4828 if (proto && !*proto)
4829 proto = Nullch;
4830
6ad3d225 4831 sent = PerlSock_getservbyname(name, proto);
dc45a647 4832#else
cea2e8a9 4833 DIE(aTHX_ PL_no_sock_func, "getservbyname");
dc45a647 4834#endif
a0d0e21e
LW		 4835 }
4836 else if (which == OP_GSBYPORT) {
dc45a647 4837#ifdef HAS_GETSERVBYPORT
42e0c139 4838 char *proto = POPpbytex;
36477c24 4839 unsigned short port = POPu;
a0d0e21e 4840
36477c24 4841#ifdef HAS_HTONS
6ad3d225 4842 port = PerlSock_htons(port);
36477c24 4843#endif
6ad3d225 4844 sent = PerlSock_getservbyport(port, proto);
dc45a647 4845#else
cea2e8a9 4846 DIE(aTHX_ PL_no_sock_func, "getservbyport");
dc45a647 4847#endif
a0d0e21e
LW		 4848 }
4849 else
e5c9fcd0 4850#ifdef HAS_GETSERVENT
6ad3d225 4851 sent = PerlSock_getservent();
e5c9fcd0 4852#else
cea2e8a9 4853 DIE(aTHX_ PL_no_sock_func, "getservent");
e5c9fcd0 4854#endif
a0d0e21e
LW		 4855
4856 EXTEND(SP, 4);
4857 if (GIMME != G_ARRAY) {
4858 PUSHs(sv = sv_newmortal());
4859 if (sent) {
4860 if (which == OP_GSBYNAME) {
4861#ifdef HAS_NTOHS
6ad3d225 4862 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
a0d0e21e 4863#else
1e422769 4864 sv_setiv(sv, (IV)(sent->s_port));
a0d0e21e
LW		 4865#endif
4866 }
4867 else
4868 sv_setpv(sv, sent->s_name);
4869 }
4870 RETURN;
4871 }
4872
4873 if (sent) {
3280af22 4874 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4875 sv_setpv(sv, sent->s_name);
3280af22 4876 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 4877 for (elem = sent->s_aliases; elem && *elem; elem++) {
a0d0e21e
LW		 4878 sv_catpv(sv, *elem);
4879 if (elem[1])
4880 sv_catpvn(sv, " ", 1);
4881 }
3280af22 4882 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4883#ifdef HAS_NTOHS
76e3520e 4884 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
a0d0e21e 4885#else
1e422769 4886 sv_setiv(sv, (IV)(sent->s_port));
a0d0e21e 4887#endif
3280af22 4888 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 4889 sv_setpv(sv, sent->s_proto);
4890 }
4891
4892 RETURN;
4893#else
cea2e8a9 4894 DIE(aTHX_ PL_no_sock_func, "getservent");
a0d0e21e
LW		 4895#endif
4896}
4897
4898PP(pp_shostent)
4899{
39644a26 4900 dSP;
693762b4 4901#ifdef HAS_SETHOSTENT
76e3520e 4902 PerlSock_sethostent(TOPi);
a0d0e21e
LW		 4903 RETSETYES;
4904#else
cea2e8a9 4905 DIE(aTHX_ PL_no_sock_func, "sethostent");
a0d0e21e
LW		 4906#endif
4907}
4908
4909PP(pp_snetent)
4910{
39644a26 4911 dSP;
693762b4 4912#ifdef HAS_SETNETENT
76e3520e 4913 PerlSock_setnetent(TOPi);
a0d0e21e
LW		 4914 RETSETYES;
4915#else
cea2e8a9 4916 DIE(aTHX_ PL_no_sock_func, "setnetent");
a0d0e21e
LW		 4917#endif
4918}
4919
4920PP(pp_sprotoent)
4921{
39644a26 4922 dSP;
693762b4 4923#ifdef HAS_SETPROTOENT
76e3520e 4924 PerlSock_setprotoent(TOPi);
a0d0e21e
LW		 4925 RETSETYES;
4926#else
cea2e8a9 4927 DIE(aTHX_ PL_no_sock_func, "setprotoent");
a0d0e21e
LW		 4928#endif
4929}
4930
4931PP(pp_sservent)
4932{
39644a26 4933 dSP;
693762b4 4934#ifdef HAS_SETSERVENT
76e3520e 4935 PerlSock_setservent(TOPi);
a0d0e21e
LW		 4936 RETSETYES;
4937#else
cea2e8a9 4938 DIE(aTHX_ PL_no_sock_func, "setservent");
a0d0e21e
LW		 4939#endif
4940}
4941
4942PP(pp_ehostent)
4943{
39644a26 4944 dSP;
693762b4 4945#ifdef HAS_ENDHOSTENT
76e3520e 4946 PerlSock_endhostent();
924508f0 4947 EXTEND(SP,1);
a0d0e21e
LW		 4948 RETPUSHYES;
4949#else
cea2e8a9 4950 DIE(aTHX_ PL_no_sock_func, "endhostent");
a0d0e21e
LW		 4951#endif
4952}
4953
4954PP(pp_enetent)
4955{
39644a26 4956 dSP;
693762b4 4957#ifdef HAS_ENDNETENT
76e3520e 4958 PerlSock_endnetent();
924508f0 4959 EXTEND(SP,1);
a0d0e21e
LW		 4960 RETPUSHYES;
4961#else
cea2e8a9 4962 DIE(aTHX_ PL_no_sock_func, "endnetent");
a0d0e21e
LW		 4963#endif
4964}
4965
4966PP(pp_eprotoent)
4967{
39644a26 4968 dSP;
693762b4 4969#ifdef HAS_ENDPROTOENT
76e3520e 4970 PerlSock_endprotoent();
924508f0 4971 EXTEND(SP,1);
a0d0e21e
LW		 4972 RETPUSHYES;
4973#else
cea2e8a9 4974 DIE(aTHX_ PL_no_sock_func, "endprotoent");
a0d0e21e
LW		 4975#endif
4976}
4977
4978PP(pp_eservent)
4979{
39644a26 4980 dSP;
693762b4 4981#ifdef HAS_ENDSERVENT
76e3520e 4982 PerlSock_endservent();
924508f0 4983 EXTEND(SP,1);
a0d0e21e
LW		 4984 RETPUSHYES;
4985#else
cea2e8a9 4986 DIE(aTHX_ PL_no_sock_func, "endservent");
a0d0e21e
LW		 4987#endif
4988}
4989
4990PP(pp_gpwnam)
4991{
4992#ifdef HAS_PASSWD
cea2e8a9 4993 return pp_gpwent();
a0d0e21e 4994#else
cea2e8a9 4995 DIE(aTHX_ PL_no_func, "getpwnam");
a0d0e21e
LW		 4996#endif
4997}
4998
4999PP(pp_gpwuid)
5000{
5001#ifdef HAS_PASSWD
cea2e8a9 5002 return pp_gpwent();
a0d0e21e 5003#else
cea2e8a9 5004 DIE(aTHX_ PL_no_func, "getpwuid");
a0d0e21e
LW		 5005#endif
5006}
5007
5008PP(pp_gpwent)
5009{
39644a26 5010 dSP;
0994c4d0 5011#ifdef HAS_PASSWD
533c011a 5012 I32 which = PL_op->op_type;
a0d0e21e 5013 register SV *sv;
2d8e6c8d 5014 STRLEN n_a;
e3aefe8d 5015 struct passwd *pwent = NULL;
301e8125 5016 /*
bcf53261
JH		 5017 * We currently support only the SysV getsp* shadow password interface.
5018 * The interface is declared in <shadow.h> and often one needs to link
5019 * with -lsecurity or some such.
5020 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5021 * (and SCO?)
5022 *
5023 * AIX getpwnam() is clever enough to return the encrypted password
5024 * only if the caller (euid?) is root.
5025 *
5026 * There are at least two other shadow password APIs. Many platforms
5027 * seem to contain more than one interface for accessing the shadow
5028 * password databases, possibly for compatibility reasons.
3813c136 5029 * The getsp*() is by far he simplest one, the other two interfaces
bcf53261
JH		 5030 * are much more complicated, but also very similar to each other.
5031 *
5032 * <sys/types.h>
5033 * <sys/security.h>
5034 * <prot.h>
5035 * struct pr_passwd *getprpw*();
5036 * The password is in
3813c136
JH		 5037 * char getprpw*(...).ufld.fd_encrypt[]
5038 * Mention HAS_GETPRPWNAM here so that Configure probes for it.
bcf53261
JH		 5039 *
5040 * <sys/types.h>
5041 * <sys/security.h>
5042 * <prot.h>
5043 * struct es_passwd *getespw*();
5044 * The password is in
5045 * char *(getespw*(...).ufld.fd_encrypt)
3813c136 5046 * Mention HAS_GETESPWNAM here so that Configure probes for it.
bcf53261 5047 *
3813c136 5048 * Mention I_PROT here so that Configure probes for it.
bcf53261
JH		 5049 *
5050 * In HP-UX for getprpw*() the manual page claims that one should include
5051 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5052 * if one includes <shadow.h> as that includes <hpsecurity.h>,
5053 * and pp_sys.c already includes <shadow.h> if there is such.
3813c136
JH		 5054 *
5055 * Note that <sys/security.h> is already probed for, but currently
5056 * it is only included in special cases.
301e8125 5057 *
bcf53261
JH		 5058 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5059 * be preferred interface, even though also the getprpw*() interface
5060 * is available) one needs to link with -lsecurity -ldb -laud -lm.
3813c136
JH		 5061 * One also needs to call set_auth_parameters() in main() before
5062 * doing anything else, whether one is using getespw*() or getprpw*().
5063 *
5064 * Note that accessing the shadow databases can be magnitudes
5065 * slower than accessing the standard databases.
bcf53261
JH		 5066 *
5067 * --jhi
5068 */
a0d0e21e 5069
e3aefe8d
JH		 5070 switch (which) {
5071 case OP_GPWNAM:
42e0c139 5072 pwent = getpwnam(POPpbytex);
e3aefe8d
JH		 5073 break;
5074 case OP_GPWUID:
5075 pwent = getpwuid((Uid_t)POPi);
5076 break;
5077 case OP_GPWENT:
1883634f 5078# ifdef HAS_GETPWENT
e3aefe8d 5079 pwent = getpwent();
1883634f 5080# else
a45d1c96 5081 DIE(aTHX_ PL_no_func, "getpwent");
1883634f 5082# endif
e3aefe8d
JH		 5083 break;
5084 }
8c0bfa08 5085
a0d0e21e
LW		 5086 EXTEND(SP, 10);
5087 if (GIMME != G_ARRAY) {
5088 PUSHs(sv = sv_newmortal());
5089 if (pwent) {
5090 if (which == OP_GPWNAM)
1883634f 5091# if Uid_t_sign <= 0
1e422769 5092 sv_setiv(sv, (IV)pwent->pw_uid);
1883634f 5093# else
23dcd6c8 5094 sv_setuv(sv, (UV)pwent->pw_uid);
1883634f 5095# endif
a0d0e21e
LW		 5096 else
5097 sv_setpv(sv, pwent->pw_name);
5098 }
5099 RETURN;
5100 }
5101
5102 if (pwent) {
3280af22 5103 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 5104 sv_setpv(sv, pwent->pw_name);
6ee623d5 5105
3280af22 5106 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
3813c136
JH		 5107 SvPOK_off(sv);
5108 /* If we have getspnam(), we try to dig up the shadow
5109 * password. If we are underprivileged, the shadow
5110 * interface will set the errno to EACCES or similar,
5111 * and return a null pointer. If this happens, we will
5112 * use the dummy password (usually "*" or "x") from the
5113 * standard password database.
5114 *
5115 * In theory we could skip the shadow call completely
5116 * if euid != 0 but in practice we cannot know which
5117 * security measures are guarding the shadow databases
5118 * on a random platform.
5119 *
5120 * Resist the urge to use additional shadow interfaces.
5121 * Divert the urge to writing an extension instead.
5122 *
5123 * --jhi */
e3aefe8d 5124# ifdef HAS_GETSPNAM
3813c136
JH		 5125 {
5126 struct spwd *spwent;
5127 int saverrno; /* Save and restore errno so that
5128 * underprivileged attempts seem
5129 * to have never made the unsccessful
5130 * attempt to retrieve the shadow password. */
5131
5132 saverrno = errno;
5133 spwent = getspnam(pwent->pw_name);
5134 errno = saverrno;
5135 if (spwent && spwent->sp_pwdp)
5136 sv_setpv(sv, spwent->sp_pwdp);
5137 }
f1066039 5138# endif
e020c87d 5139# ifdef PWPASSWD
3813c136
JH		 5140 if (!SvPOK(sv)) /* Use the standard password, then. */
5141 sv_setpv(sv, pwent->pw_passwd);
e020c87d 5142# endif
3813c136 5143
1883634f 5144# ifndef INCOMPLETE_TAINTS
3813c136
JH		 5145 /* passwd is tainted because user himself can diddle with it.
5146 * admittedly not much and in a very limited way, but nevertheless. */
2959b6e3 5147 SvTAINTED_on(sv);
1883634f 5148# endif
6ee623d5 5149
3280af22 5150 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1883634f 5151# if Uid_t_sign <= 0
1e422769 5152 sv_setiv(sv, (IV)pwent->pw_uid);
1883634f 5153# else
23dcd6c8 5154 sv_setuv(sv, (UV)pwent->pw_uid);
1883634f 5155# endif
6ee623d5 5156
3280af22 5157 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1883634f 5158# if Uid_t_sign <= 0
1e422769 5159 sv_setiv(sv, (IV)pwent->pw_gid);
1883634f 5160# else
23dcd6c8 5161 sv_setuv(sv, (UV)pwent->pw_gid);
1883634f 5162# endif
3813c136
JH		 5163 /* pw_change, pw_quota, and pw_age are mutually exclusive--
5164 * because of the poor interface of the Perl getpw*(),
5165 * not because there's some standard/convention saying so.
5166 * A better interface would have been to return a hash,
5167 * but we are accursed by our history, alas. --jhi. */
3280af22 5168 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1883634f 5169# ifdef PWCHANGE
1e422769 5170 sv_setiv(sv, (IV)pwent->pw_change);
6ee623d5 5171# else
1883634f
JH		 5172# ifdef PWQUOTA
5173 sv_setiv(sv, (IV)pwent->pw_quota);
5174# else
a1757be1 5175# ifdef PWAGE
a0d0e21e 5176 sv_setpv(sv, pwent->pw_age);
a1757be1 5177# endif
6ee623d5
GS		 5178# endif
5179# endif
6ee623d5 5180
3813c136
JH		 5181 /* pw_class and pw_comment are mutually exclusive--.
5182 * see the above note for pw_change, pw_quota, and pw_age. */
3280af22 5183 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1883634f 5184# ifdef PWCLASS
a0d0e21e 5185 sv_setpv(sv, pwent->pw_class);
1883634f
JH		 5186# else
5187# ifdef PWCOMMENT
a0d0e21e 5188 sv_setpv(sv, pwent->pw_comment);
1883634f 5189# endif
6ee623d5 5190# endif
6ee623d5 5191
3280af22 5192 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1883634f 5193# ifdef PWGECOS
a0d0e21e 5194 sv_setpv(sv, pwent->pw_gecos);
1883634f
JH		 5195# endif
5196# ifndef INCOMPLETE_TAINTS
d2719217 5197 /* pw_gecos is tainted because user himself can diddle with it. */
fb73857a 5198 SvTAINTED_on(sv);
1883634f 5199# endif
6ee623d5 5200
3280af22 5201 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 5202 sv_setpv(sv, pwent->pw_dir);
6ee623d5 5203
3280af22 5204 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 5205 sv_setpv(sv, pwent->pw_shell);
1883634f 5206# ifndef INCOMPLETE_TAINTS
4602f195
JH		 5207 /* pw_shell is tainted because user himself can diddle with it. */
5208 SvTAINTED_on(sv);
1883634f 5209# endif
6ee623d5 5210
1883634f 5211# ifdef PWEXPIRE
6b88bc9c 5212 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 5213 sv_setiv(sv, (IV)pwent->pw_expire);
1883634f 5214# endif
a0d0e21e
LW		 5215 }
5216 RETURN;
5217#else
cea2e8a9 5218 DIE(aTHX_ PL_no_func, "getpwent");
a0d0e21e
LW		 5219#endif
5220}
5221
5222PP(pp_spwent)
5223{
39644a26 5224 dSP;
d493b042 5225#if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
a0d0e21e
LW		 5226 setpwent();
5227 RETPUSHYES;
5228#else
cea2e8a9 5229 DIE(aTHX_ PL_no_func, "setpwent");
a0d0e21e
LW		 5230#endif
5231}
5232
5233PP(pp_epwent)
5234{
39644a26 5235 dSP;
28e8609d 5236#if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
a0d0e21e
LW		 5237 endpwent();
5238 RETPUSHYES;
5239#else
cea2e8a9 5240 DIE(aTHX_ PL_no_func, "endpwent");
a0d0e21e
LW		 5241#endif
5242}
5243
5244PP(pp_ggrnam)
5245{
5246#ifdef HAS_GROUP
cea2e8a9 5247 return pp_ggrent();
a0d0e21e 5248#else
cea2e8a9 5249 DIE(aTHX_ PL_no_func, "getgrnam");
a0d0e21e
LW		 5250#endif
5251}
5252
5253PP(pp_ggrgid)
5254{
5255#ifdef HAS_GROUP
cea2e8a9 5256 return pp_ggrent();
a0d0e21e 5257#else
cea2e8a9 5258 DIE(aTHX_ PL_no_func, "getgrgid");
a0d0e21e
LW		 5259#endif
5260}
5261
5262PP(pp_ggrent)
5263{
39644a26 5264 dSP;
0994c4d0 5265#ifdef HAS_GROUP
533c011a 5266 I32 which = PL_op->op_type;
a0d0e21e
LW		 5267 register char **elem;
5268 register SV *sv;
5269 struct group *grent;
2d8e6c8d 5270 STRLEN n_a;
a0d0e21e
LW		 5271
5272 if (which == OP_GGRNAM)
42e0c139 5273 grent = (struct group *)getgrnam(POPpbytex);
a0d0e21e
LW		 5274 else if (which == OP_GGRGID)
5275 grent = (struct group *)getgrgid(POPi);
5276 else
0994c4d0 5277#ifdef HAS_GETGRENT
a0d0e21e 5278 grent = (struct group *)getgrent();
0994c4d0
JH		 5279#else
5280 DIE(aTHX_ PL_no_func, "getgrent");
5281#endif
a0d0e21e
LW		 5282
5283 EXTEND(SP, 4);
5284 if (GIMME != G_ARRAY) {
5285 PUSHs(sv = sv_newmortal());
5286 if (grent) {
5287 if (which == OP_GGRNAM)
1e422769 5288 sv_setiv(sv, (IV)grent->gr_gid);
a0d0e21e
LW		 5289 else
5290 sv_setpv(sv, grent->gr_name);
5291 }
5292 RETURN;
5293 }
5294
5295 if (grent) {
3280af22 5296 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 5297 sv_setpv(sv, grent->gr_name);
28e8609d 5298
3280af22 5299 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
28e8609d 5300#ifdef GRPASSWD
a0d0e21e 5301 sv_setpv(sv, grent->gr_passwd);
28e8609d
JH		 5302#endif
5303
3280af22 5304 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 5305 sv_setiv(sv, (IV)grent->gr_gid);
28e8609d 5306
3280af22 5307 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 5308 for (elem = grent->gr_mem; elem && *elem; elem++) {
a0d0e21e
LW		 5309 sv_catpv(sv, *elem);
5310 if (elem[1])
5311 sv_catpvn(sv, " ", 1);
5312 }
5313 }
5314
5315 RETURN;
5316#else
cea2e8a9 5317 DIE(aTHX_ PL_no_func, "getgrent");
a0d0e21e
LW		 5318#endif
5319}
5320
5321PP(pp_sgrent)
5322{
39644a26 5323 dSP;
28e8609d 5324#if defined(HAS_GROUP) && defined(HAS_SETGRENT)
a0d0e21e
LW		 5325 setgrent();
5326 RETPUSHYES;
5327#else
cea2e8a9 5328 DIE(aTHX_ PL_no_func, "setgrent");
a0d0e21e
LW		 5329#endif
5330}
5331
5332PP(pp_egrent)
5333{
39644a26 5334 dSP;
28e8609d 5335#if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
a0d0e21e
LW		 5336 endgrent();
5337 RETPUSHYES;
5338#else
cea2e8a9 5339 DIE(aTHX_ PL_no_func, "endgrent");
a0d0e21e
LW		 5340#endif
5341}
5342
5343PP(pp_getlogin)
5344{
39644a26 5345 dSP; dTARGET;
a0d0e21e
LW		 5346#ifdef HAS_GETLOGIN
5347 char *tmps;
5348 EXTEND(SP, 1);
76e3520e 5349 if (!(tmps = PerlProc_getlogin()))
a0d0e21e
LW		 5350 RETPUSHUNDEF;
5351 PUSHp(tmps, strlen(tmps));
5352 RETURN;
5353#else
cea2e8a9 5354 DIE(aTHX_ PL_no_func, "getlogin");
a0d0e21e
LW		 5355#endif
5356}
5357
5358/* Miscellaneous. */
5359
5360PP(pp_syscall)
5361{
d2719217 5362#ifdef HAS_SYSCALL
39644a26 5363 dSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 5364 register I32 items = SP - MARK;
5365 unsigned long a[20];
5366 register I32 i = 0;
5367 I32 retval = -1;
2d8e6c8d 5368 STRLEN n_a;
a0d0e21e 5369
3280af22 5370 if (PL_tainting) {
a0d0e21e 5371 while (++MARK <= SP) {
bbce6d69 5372 if (SvTAINTED(*MARK)) {
5373 TAINT;
5374 break;
5375 }
a0d0e21e
LW		 5376 }
5377 MARK = ORIGMARK;
5378 TAINT_PROPER("syscall");
5379 }
5380
5381 /* This probably won't work on machines where sizeof(long) != sizeof(int)
5382 * or where sizeof(long) != sizeof(char*). But such machines will
5383 * not likely have syscall implemented either, so who cares?
5384 */
5385 while (++MARK <= SP) {
5386 if (SvNIOK(*MARK) || !i)
5387 a[i++] = SvIV(*MARK);
3280af22 5388 else if (*MARK == &PL_sv_undef)
748a9306 5389 a[i++] = 0;
301e8125 5390 else
2d8e6c8d 5391 a[i++] = (unsigned long)SvPV_force(*MARK, n_a);
a0d0e21e
LW		 5392 if (i > 15)
5393 break;
5394 }
5395 switch (items) {
5396 default:
cea2e8a9 5397 DIE(aTHX_ "Too many args to syscall");
a0d0e21e 5398 case 0:
cea2e8a9 5399 DIE(aTHX_ "Too few args to syscall");
a0d0e21e
LW		 5400 case 1:
5401 retval = syscall(a[0]);
5402 break;
5403 case 2:
5404 retval = syscall(a[0],a[1]);
5405 break;
5406 case 3:
5407 retval = syscall(a[0],a[1],a[2]);
5408 break;
5409 case 4:
5410 retval = syscall(a[0],a[1],a[2],a[3]);
5411 break;
5412 case 5:
5413 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5414 break;
5415 case 6:
5416 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5417 break;
5418 case 7:
5419 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5420 break;
5421 case 8:
5422 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5423 break;
5424#ifdef atarist
5425 case 9:
5426 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5427 break;
5428 case 10:
5429 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5430 break;
5431 case 11:
5432 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5433 a[10]);
5434 break;
5435 case 12:
5436 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5437 a[10],a[11]);
5438 break;
5439 case 13:
5440 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5441 a[10],a[11],a[12]);
5442 break;
5443 case 14:
5444 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5445 a[10],a[11],a[12],a[13]);
5446 break;
5447#endif /* atarist */
5448 }
5449 SP = ORIGMARK;
5450 PUSHi(retval);
5451 RETURN;
5452#else
cea2e8a9 5453 DIE(aTHX_ PL_no_func, "syscall");
a0d0e21e
LW		 5454#endif
5455}
5456
ff68c719 5457#ifdef FCNTL_EMULATE_FLOCK
301e8125 5458
ff68c719 5459/* XXX Emulate flock() with fcntl().
5460 What's really needed is a good file locking module.
5461*/
5462
cea2e8a9
GS		 5463static int
5464fcntl_emulate_flock(int fd, int operation)
ff68c719 5465{
5466 struct flock flock;
301e8125 5467
ff68c719 5468 switch (operation & ~LOCK_NB) {
5469 case LOCK_SH:
5470 flock.l_type = F_RDLCK;
5471 break;
5472 case LOCK_EX:
5473 flock.l_type = F_WRLCK;
5474 break;
5475 case LOCK_UN:
5476 flock.l_type = F_UNLCK;
5477 break;
5478 default:
5479 errno = EINVAL;
5480 return -1;
5481 }
5482 flock.l_whence = SEEK_SET;
d9b3e12d 5483 flock.l_start = flock.l_len = (Off_t)0;
301e8125 5484
ff68c719 5485 return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5486}
5487
5488#endif /* FCNTL_EMULATE_FLOCK */
5489
5490#ifdef LOCKF_EMULATE_FLOCK
16d20bd9
AD		 5491
5492/* XXX Emulate flock() with lockf(). This is just to increase
5493 portability of scripts. The calls are not completely
5494 interchangeable. What's really needed is a good file
5495 locking module.
5496*/
5497
76c32331 5498/* The lockf() constants might have been defined in <unistd.h>.
5499 Unfortunately, <unistd.h> causes troubles on some mixed
5500 (BSD/POSIX) systems, such as SunOS 4.1.3.
16d20bd9
AD		 5501
5502 Further, the lockf() constants aren't POSIX, so they might not be
5503 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5504 just stick in the SVID values and be done with it. Sigh.
5505*/
5506
5507# ifndef F_ULOCK
5508# define F_ULOCK 0 /* Unlock a previously locked region */
5509# endif
5510# ifndef F_LOCK
5511# define F_LOCK 1 /* Lock a region for exclusive use */
5512# endif
5513# ifndef F_TLOCK
5514# define F_TLOCK 2 /* Test and lock a region for exclusive use */
5515# endif
5516# ifndef F_TEST
5517# define F_TEST 3 /* Test a region for other processes locks */
5518# endif
5519
cea2e8a9
GS		 5520static int
5521lockf_emulate_flock(int fd, int operation)
16d20bd9
AD		 5522{
5523 int i;
84902520
TB		 5524 int save_errno;
5525 Off_t pos;
5526
5527 /* flock locks entire file so for lockf we need to do the same */
5528 save_errno = errno;
6ad3d225 5529 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
84902520 5530 if (pos > 0) /* is seekable and needs to be repositioned */
6ad3d225 5531 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
08b714dd 5532 pos = -1; /* seek failed, so don't seek back afterwards */
84902520
TB		 5533 errno = save_errno;
5534
16d20bd9
AD		 5535 switch (operation) {
5536
5537 /* LOCK_SH - get a shared lock */
5538 case LOCK_SH:
5539 /* LOCK_EX - get an exclusive lock */
5540 case LOCK_EX:
5541 i = lockf (fd, F_LOCK, 0);
5542 break;
5543
5544 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5545 case LOCK_SH|LOCK_NB:
5546 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5547 case LOCK_EX|LOCK_NB:
5548 i = lockf (fd, F_TLOCK, 0);
5549 if (i == -1)
5550 if ((errno == EAGAIN) || (errno == EACCES))
5551 errno = EWOULDBLOCK;
5552 break;
5553
ff68c719 5554 /* LOCK_UN - unlock (non-blocking is a no-op) */
16d20bd9 5555 case LOCK_UN:
ff68c719 5556 case LOCK_UN|LOCK_NB:
16d20bd9
AD		 5557 i = lockf (fd, F_ULOCK, 0);
5558 break;
5559
5560 /* Default - can't decipher operation */
5561 default:
5562 i = -1;
5563 errno = EINVAL;
5564 break;
5565 }
84902520
TB		 5566
5567 if (pos > 0) /* need to restore position of the handle */
6ad3d225 5568 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
84902520 5569
16d20bd9
AD		 5570 return (i);
5571}
ff68c719 5572
5573#endif /* LOCKF_EMULATE_FLOCK */
Unnamed repository; edit this file 'description' to name the repository.