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