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
ypcat working, but NIS not used
[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 3414 PUSHi(0);
b7ab37f8 3415 TAINT_PROPER("chdir");
389ec635
MS		 3416 RETURN;
3417 }
8ea155d1 3418 }
8ea155d1 3419
a0d0e21e 3420 TAINT_PROPER("chdir");
6ad3d225 3421 PUSHi( PerlDir_chdir(tmps) >= 0 );
748a9306
LW		 3422#ifdef VMS
3423 /* Clear the DEFAULT element of ENV so we'll get the new value
3424 * in the future. */
6b88bc9c 3425 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
748a9306 3426#endif
a0d0e21e
LW		 3427 RETURN;
3428}
3429
3430PP(pp_chown)
3431{
a0d0e21e 3432#ifdef HAS_CHOWN
76ffd3b9
IZ		 3433 dSP; dMARK; dTARGET;
3434 I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3435
a0d0e21e
LW		 3436 SP = MARK;
3437 PUSHi(value);
3438 RETURN;
3439#else
0322a713 3440 DIE(aTHX_ PL_no_func, "chown");
a0d0e21e
LW		 3441#endif
3442}
3443
3444PP(pp_chroot)
3445{
a0d0e21e 3446#ifdef HAS_CHROOT
76ffd3b9 3447 dSP; dTARGET;
2d8e6c8d 3448 STRLEN n_a;
d05c1ba0 3449 char *tmps = POPpx;
a0d0e21e
LW		 3450 TAINT_PROPER("chroot");
3451 PUSHi( chroot(tmps) >= 0 );
3452 RETURN;
3453#else
cea2e8a9 3454 DIE(aTHX_ PL_no_func, "chroot");
a0d0e21e
LW		 3455#endif
3456}
3457
3458PP(pp_unlink)
3459{
39644a26 3460 dSP; dMARK; dTARGET;
a0d0e21e 3461 I32 value;
533c011a 3462 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 3463 SP = MARK;
3464 PUSHi(value);
3465 RETURN;
3466}
3467
3468PP(pp_chmod)
3469{
39644a26 3470 dSP; dMARK; dTARGET;
a0d0e21e 3471 I32 value;
533c011a 3472 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 3473 SP = MARK;
3474 PUSHi(value);
3475 RETURN;
3476}
3477
3478PP(pp_utime)
3479{
39644a26 3480 dSP; dMARK; dTARGET;
a0d0e21e 3481 I32 value;
533c011a 3482 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 3483 SP = MARK;
3484 PUSHi(value);
3485 RETURN;
3486}
3487
3488PP(pp_rename)
3489{
39644a26 3490 dSP; dTARGET;
a0d0e21e 3491 int anum;
2d8e6c8d 3492 STRLEN n_a;
a0d0e21e 3493
2d8e6c8d
GS		 3494 char *tmps2 = POPpx;
3495 char *tmps = SvPV(TOPs, n_a);
a0d0e21e
LW		 3496 TAINT_PROPER("rename");
3497#ifdef HAS_RENAME
baed7233 3498 anum = PerlLIO_rename(tmps, tmps2);
a0d0e21e 3499#else
6b88bc9c 3500 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
ed969818
W		 3501 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3502 anum = 1;
3503 else {
3654eb6c 3504 if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
ed969818
W		 3505 (void)UNLINK(tmps2);
3506 if (!(anum = link(tmps, tmps2)))
3507 anum = UNLINK(tmps);
3508 }
a0d0e21e
LW		 3509 }
3510#endif
3511 SETi( anum >= 0 );
3512 RETURN;
3513}
3514
3515PP(pp_link)
3516{
a0d0e21e 3517#ifdef HAS_LINK
370f6000 3518 dSP; 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
52a55424
RG		 4033 if (PL_tainting) {
4034 SV *cmd = NULL;
4035 if (PL_op->op_flags & OPf_STACKED)
4036 cmd = *(MARK + 1);
4037 else if (SP - MARK != 1)
4038 cmd = *SP;
4039 if (cmd && *(SvPV_nolen(cmd)) != '/')
4040 TAINT_ENV();
4041 }
4042
d7e492a4
JH		 4043 if (PerlProc_pipe(pp) >= 0)
4044 did_pipes = 1;
52e18b1f 4045 while ((childpid = PerlProc_fork()) == -1) {
d7e492a4
JH		 4046 if (errno != EAGAIN) {
4047 value = -1;
4048 SP = ORIGMARK;
4049 PUSHi(value);
4050 if (did_pipes) {
4051 PerlLIO_close(pp[0]);
4052 PerlLIO_close(pp[1]);
4053 }
4054 RETURN;
4055 }
4056 sleep(5);
4057 }
4058 if (childpid > 0) {
4059 if (did_pipes)
4060 PerlLIO_close(pp[1]);
64ca3a65 4061#ifndef PERL_MICRO
d7e492a4
JH		 4062 rsignal_save(SIGINT, SIG_IGN, &ihand);
4063 rsignal_save(SIGQUIT, SIG_IGN, &qhand);
64ca3a65 4064#endif
d7e492a4
JH		 4065 do {
4066 result = wait4pid(childpid, &status, 0);
4067 } while (result == -1 && errno == EINTR);
64ca3a65 4068#ifndef PERL_MICRO
d7e492a4
JH		 4069 (void)rsignal_restore(SIGINT, &ihand);
4070 (void)rsignal_restore(SIGQUIT, &qhand);
4071#endif
4072 STATUS_NATIVE_SET(result == -1 ? -1 : status);
52e18b1f 4073 do_execfree(); /* free any memory child malloced on fork */
d7e492a4
JH		 4074 SP = ORIGMARK;
4075 if (did_pipes) {
4076 int errkid;
4077 int n = 0, n1;
4078
4079 while (n < sizeof(int)) {
4080 n1 = PerlLIO_read(pp[0],
4081 (void*)(((char*)&errkid)+n),
4082 (sizeof(int)) - n);
4083 if (n1 <= 0)
4084 break;
4085 n += n1;
4086 }
4087 PerlLIO_close(pp[0]);
4088 if (n) { /* Error */
4089 if (n != sizeof(int))
4090 DIE(aTHX_ "panic: kid popen errno read");
4091 errno = errkid; /* Propagate errno from kid */
4092 STATUS_CURRENT = -1;
4093 }
4094 }
4095 PUSHi(STATUS_CURRENT);
4096 RETURN;
4097 }
4098 if (did_pipes) {
4099 PerlLIO_close(pp[0]);
d5a9bfb0 4100#if defined(HAS_FCNTL) && defined(F_SETFD)
d7e492a4 4101 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
d5a9bfb0 4102#endif
d7e492a4 4103 }
d5a9bfb0 4104 }
533c011a 4105 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e 4106 SV *really = *++MARK;
d5a9bfb0 4107 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
a0d0e21e
LW		 4108 }
4109 else if (SP - MARK != 1)
d5a9bfb0 4110 value = (I32)do_aexec5(Nullsv, MARK, SP, pp[1], did_pipes);
a0d0e21e 4111 else {
d5a9bfb0 4112 value = (I32)do_exec3(SvPVx(sv_mortalcopy(*SP), n_a), pp[1], did_pipes);
a0d0e21e 4113 }
6ad3d225 4114 PerlProc__exit(-1);
c3293030 4115#else /* ! FORK or VMS or OS/2 */
922b1888
GS		 4116 PL_statusvalue = 0;
4117 result = 0;
911d147d 4118 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e 4119 SV *really = *++MARK;
c5be433b 4120 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
a0d0e21e
LW		 4121 }
4122 else if (SP - MARK != 1)
c5be433b 4123 value = (I32)do_aspawn(Nullsv, (void **)MARK, (void **)SP);
a0d0e21e 4124 else {
c5be433b 4125 value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
a0d0e21e 4126 }
922b1888
GS		 4127 if (PL_statusvalue == -1) /* hint that value must be returned as is */
4128 result = 1;
f86702cc 4129 STATUS_NATIVE_SET(value);
a0d0e21e
LW		 4130 do_execfree();
4131 SP = ORIGMARK;
922b1888 4132 PUSHi(result ? value : STATUS_CURRENT);
a0d0e21e
LW		 4133#endif /* !FORK or VMS */
4134 RETURN;
4135}
4136
4137PP(pp_exec)
4138{
39644a26 4139 dSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e 4140 I32 value;
2d8e6c8d 4141 STRLEN n_a;
a0d0e21e 4142
45bc9206 4143 PERL_FLUSHALL_FOR_CHILD;
533c011a 4144 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e
LW		 4145 SV *really = *++MARK;
4146 value = (I32)do_aexec(really, MARK, SP);
4147 }
4148 else if (SP - MARK != 1)
4149#ifdef VMS
4150 value = (I32)vms_do_aexec(Nullsv, MARK, SP);
4151#else
092bebab
JH		 4152# ifdef __OPEN_VM
4153 {
c5be433b 4154 (void ) do_aspawn(Nullsv, MARK, SP);
092bebab
JH		 4155 value = 0;
4156 }
4157# else
a0d0e21e 4158 value = (I32)do_aexec(Nullsv, MARK, SP);
092bebab 4159# endif
a0d0e21e
LW		 4160#endif
4161 else {
3280af22 4162 if (PL_tainting) {
516a5887 4163 (void)SvPV_nolen(*SP); /* stringify for taint check */
a0d0e21e
LW		 4164 TAINT_ENV();
4165 TAINT_PROPER("exec");
4166 }
4167#ifdef VMS
2d8e6c8d 4168 value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
a0d0e21e 4169#else
092bebab 4170# ifdef __OPEN_VM
c5be433b 4171 (void) do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
092bebab
JH		 4172 value = 0;
4173# else
2d8e6c8d 4174 value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
092bebab 4175# endif
a0d0e21e
LW		 4176#endif
4177 }
146174a9 4178
a0d0e21e
LW		 4179 SP = ORIGMARK;
4180 PUSHi(value);
4181 RETURN;
4182}
4183
4184PP(pp_kill)
4185{
9cad6237 4186#ifdef HAS_KILL
39644a26 4187 dSP; dMARK; dTARGET;
a0d0e21e 4188 I32 value;
533c011a 4189 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 4190 SP = MARK;
4191 PUSHi(value);
4192 RETURN;
4193#else
0322a713 4194 DIE(aTHX_ PL_no_func, "kill");
a0d0e21e
LW		 4195#endif
4196}
4197
4198PP(pp_getppid)
4199{
4200#ifdef HAS_GETPPID
39644a26 4201 dSP; dTARGET;
a0d0e21e
LW		 4202 XPUSHi( getppid() );
4203 RETURN;
4204#else
cea2e8a9 4205 DIE(aTHX_ PL_no_func, "getppid");
a0d0e21e
LW		 4206#endif
4207}
4208
4209PP(pp_getpgrp)
4210{
4211#ifdef HAS_GETPGRP
39644a26 4212 dSP; dTARGET;
d8a83dd3 4213 Pid_t pid;
9853a804 4214 Pid_t pgrp;
a0d0e21e
LW		 4215
4216 if (MAXARG < 1)
4217 pid = 0;
4218 else
4219 pid = SvIVx(POPs);
c3293030 4220#ifdef BSD_GETPGRP
9853a804 4221 pgrp = (I32)BSD_GETPGRP(pid);
a0d0e21e 4222#else
146174a9 4223 if (pid != 0 && pid != PerlProc_getpid())
cea2e8a9 4224 DIE(aTHX_ "POSIX getpgrp can't take an argument");
9853a804 4225 pgrp = getpgrp();
a0d0e21e 4226#endif
9853a804 4227 XPUSHi(pgrp);
a0d0e21e
LW		 4228 RETURN;
4229#else
cea2e8a9 4230 DIE(aTHX_ PL_no_func, "getpgrp()");
a0d0e21e
LW		 4231#endif
4232}
4233
4234PP(pp_setpgrp)
4235{
4236#ifdef HAS_SETPGRP
39644a26 4237 dSP; dTARGET;
d8a83dd3
JH		 4238 Pid_t pgrp;
4239 Pid_t pid;
a0d0e21e
LW		 4240 if (MAXARG < 2) {
4241 pgrp = 0;
4242 pid = 0;
4243 }
4244 else {
4245 pgrp = POPi;
4246 pid = TOPi;
4247 }
4248
4249 TAINT_PROPER("setpgrp");
c3293030
IZ		 4250#ifdef BSD_SETPGRP
4251 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
a0d0e21e 4252#else
146174a9
CB		 4253 if ((pgrp != 0 && pgrp != PerlProc_getpid())
4254 || (pid != 0 && pid != PerlProc_getpid()))
4255 {
4256 DIE(aTHX_ "setpgrp can't take arguments");
4257 }
a0d0e21e
LW		 4258 SETi( setpgrp() >= 0 );
4259#endif /* USE_BSDPGRP */
4260 RETURN;
4261#else
cea2e8a9 4262 DIE(aTHX_ PL_no_func, "setpgrp()");
a0d0e21e
LW		 4263#endif
4264}
4265
4266PP(pp_getpriority)
4267{
a0d0e21e 4268#ifdef HAS_GETPRIORITY
9cad6237 4269 dSP; dTARGET;
d05c1ba0
JH		 4270 int who = POPi;
4271 int which = TOPi;
a0d0e21e
LW		 4272 SETi( getpriority(which, who) );
4273 RETURN;
4274#else
cea2e8a9 4275 DIE(aTHX_ PL_no_func, "getpriority()");
a0d0e21e
LW		 4276#endif
4277}
4278
4279PP(pp_setpriority)
4280{
a0d0e21e 4281#ifdef HAS_SETPRIORITY
9cad6237 4282 dSP; dTARGET;
d05c1ba0
JH		 4283 int niceval = POPi;
4284 int who = POPi;
4285 int which = TOPi;
a0d0e21e
LW		 4286 TAINT_PROPER("setpriority");
4287 SETi( setpriority(which, who, niceval) >= 0 );
4288 RETURN;
4289#else
cea2e8a9 4290 DIE(aTHX_ PL_no_func, "setpriority()");
a0d0e21e
LW		 4291#endif
4292}
4293
4294/* Time calls. */
4295
4296PP(pp_time)
4297{
39644a26 4298 dSP; dTARGET;
cbdc8872 4299#ifdef BIG_TIME
4300 XPUSHn( time(Null(Time_t*)) );
4301#else
a0d0e21e 4302 XPUSHi( time(Null(Time_t*)) );
cbdc8872 4303#endif
a0d0e21e
LW		 4304 RETURN;
4305}
4306
cd52b7b2 4307/* XXX The POSIX name is CLK_TCK; it is to be preferred
4308 to HZ. Probably. For now, assume that if the system
4309 defines HZ, it does so correctly. (Will this break
4310 on VMS?)
4311 Probably we ought to use _sysconf(_SC_CLK_TCK), if
4312 it's supported. --AD 9/96.
4313*/
4314
a0d0e21e 4315#ifndef HZ
cd52b7b2 4316# ifdef CLK_TCK
4317# define HZ CLK_TCK
4318# else
4319# define HZ 60
4320# endif
a0d0e21e
LW		 4321#endif
4322
4323PP(pp_tms)
4324{
9cad6237 4325#ifdef HAS_TIMES
39644a26 4326 dSP;
a0d0e21e 4327 EXTEND(SP, 4);
a0d0e21e 4328#ifndef VMS
3280af22 4329 (void)PerlProc_times(&PL_timesbuf);
a0d0e21e 4330#else
6b88bc9c 4331 (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
76e3520e
GS		 4332 /* struct tms, though same data */
4333 /* is returned. */
a0d0e21e
LW		 4334#endif
4335
65202027 4336 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_utime)/HZ)));
a0d0e21e 4337 if (GIMME == G_ARRAY) {
65202027
DS		 4338 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_stime)/HZ)));
4339 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cutime)/HZ)));
4340 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cstime)/HZ)));
a0d0e21e
LW		 4341 }
4342 RETURN;
9cad6237
JH		 4343#else
4344 DIE(aTHX_ "times not implemented");
55497cff 4345#endif /* HAS_TIMES */
a0d0e21e
LW		 4346}
4347
4348PP(pp_localtime)
4349{
cea2e8a9 4350 return pp_gmtime();
a0d0e21e
LW		 4351}
4352
4353PP(pp_gmtime)
4354{
39644a26 4355 dSP;
a0d0e21e
LW		 4356 Time_t when;
4357 struct tm *tmbuf;
4358 static char *dayname[] = {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4359 static char *monname[] = {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4360 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4361
4362 if (MAXARG < 1)
4363 (void)time(&when);
4364 else
cbdc8872 4365#ifdef BIG_TIME
4366 when = (Time_t)SvNVx(POPs);
4367#else
a0d0e21e 4368 when = (Time_t)SvIVx(POPs);
cbdc8872 4369#endif
a0d0e21e 4370
533c011a 4371 if (PL_op->op_type == OP_LOCALTIME)
a0d0e21e
LW		 4372 tmbuf = localtime(&when);
4373 else
4374 tmbuf = gmtime(&when);
4375
a0d0e21e 4376 if (GIMME != G_ARRAY) {
46fc3d4c 4377 SV *tsv;
9a5ff6d9
AB		 4378 EXTEND(SP, 1);
4379 EXTEND_MORTAL(1);
a0d0e21e
LW		 4380 if (!tmbuf)
4381 RETPUSHUNDEF;
be28567c 4382 tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %d",
f5a29b03
RB		 4383 dayname[tmbuf->tm_wday],
4384 monname[tmbuf->tm_mon],
be28567c
GS		 4385 tmbuf->tm_mday,
4386 tmbuf->tm_hour,
4387 tmbuf->tm_min,
4388 tmbuf->tm_sec,
4389 tmbuf->tm_year + 1900);
46fc3d4c 4390 PUSHs(sv_2mortal(tsv));
a0d0e21e
LW		 4391 }
4392 else if (tmbuf) {
9a5ff6d9
AB		 4393 EXTEND(SP, 9);
4394 EXTEND_MORTAL(9);
4395 PUSHs(sv_2mortal(newSViv(tmbuf->tm_sec)));
c6419e06
JH		 4396 PUSHs(sv_2mortal(newSViv(tmbuf->tm_min)));
4397 PUSHs(sv_2mortal(newSViv(tmbuf->tm_hour)));
4398 PUSHs(sv_2mortal(newSViv(tmbuf->tm_mday)));
4399 PUSHs(sv_2mortal(newSViv(tmbuf->tm_mon)));
4400 PUSHs(sv_2mortal(newSViv(tmbuf->tm_year)));
4401 PUSHs(sv_2mortal(newSViv(tmbuf->tm_wday)));
4402 PUSHs(sv_2mortal(newSViv(tmbuf->tm_yday)));
4403 PUSHs(sv_2mortal(newSViv(tmbuf->tm_isdst)));
a0d0e21e
LW		 4404 }
4405 RETURN;
4406}
4407
4408PP(pp_alarm)
4409{
9cad6237 4410#ifdef HAS_ALARM
39644a26 4411 dSP; dTARGET;
a0d0e21e 4412 int anum;
a0d0e21e
LW		 4413 anum = POPi;
4414 anum = alarm((unsigned int)anum);
4415 EXTEND(SP, 1);
4416 if (anum < 0)
4417 RETPUSHUNDEF;
c6419e06 4418 PUSHi(anum);
a0d0e21e
LW		 4419 RETURN;
4420#else
0322a713 4421 DIE(aTHX_ PL_no_func, "alarm");
a0d0e21e
LW		 4422#endif
4423}
4424
4425PP(pp_sleep)
4426{
39644a26 4427 dSP; dTARGET;
a0d0e21e
LW		 4428 I32 duration;
4429 Time_t lasttime;
4430 Time_t when;
4431
4432 (void)time(&lasttime);
4433 if (MAXARG < 1)
76e3520e 4434 PerlProc_pause();
a0d0e21e
LW		 4435 else {
4436 duration = POPi;
76e3520e 4437 PerlProc_sleep((unsigned int)duration);
a0d0e21e
LW		 4438 }
4439 (void)time(&when);
4440 XPUSHi(when - lasttime);
4441 RETURN;
4442}
4443
4444/* Shared memory. */
4445
4446PP(pp_shmget)
4447{
cea2e8a9 4448 return pp_semget();
a0d0e21e
LW		 4449}
4450
4451PP(pp_shmctl)
4452{
cea2e8a9 4453 return pp_semctl();
a0d0e21e
LW		 4454}
4455
4456PP(pp_shmread)
4457{
cea2e8a9 4458 return pp_shmwrite();
a0d0e21e
LW		 4459}
4460
4461PP(pp_shmwrite)
4462{
4463#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
39644a26 4464 dSP; dMARK; dTARGET;
533c011a 4465 I32 value = (I32)(do_shmio(PL_op->op_type, MARK, SP) >= 0);
a0d0e21e
LW		 4466 SP = MARK;
4467 PUSHi(value);
4468 RETURN;
4469#else
cea2e8a9 4470 return pp_semget();
a0d0e21e
LW		 4471#endif
4472}
4473
4474/* Message passing. */
4475
4476PP(pp_msgget)
4477{
cea2e8a9 4478 return pp_semget();
a0d0e21e
LW		 4479}
4480
4481PP(pp_msgctl)
4482{
cea2e8a9 4483 return pp_semctl();
a0d0e21e
LW		 4484}
4485
4486PP(pp_msgsnd)
4487{
4488#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
39644a26 4489 dSP; dMARK; dTARGET;
a0d0e21e
LW		 4490 I32 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4491 SP = MARK;
4492 PUSHi(value);
4493 RETURN;
4494#else
cea2e8a9 4495 return pp_semget();
a0d0e21e
LW		 4496#endif
4497}
4498
4499PP(pp_msgrcv)
4500{
4501#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
39644a26 4502 dSP; dMARK; dTARGET;
a0d0e21e
LW		 4503 I32 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4504 SP = MARK;
4505 PUSHi(value);
4506 RETURN;
4507#else
cea2e8a9 4508 return pp_semget();
a0d0e21e
LW		 4509#endif
4510}
4511
4512/* Semaphores. */
4513
4514PP(pp_semget)
4515{
4516#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
39644a26 4517 dSP; dMARK; dTARGET;
533c011a 4518 int anum = do_ipcget(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 4519 SP = MARK;
4520 if (anum == -1)
4521 RETPUSHUNDEF;
4522 PUSHi(anum);
4523 RETURN;
4524#else
cea2e8a9 4525 DIE(aTHX_ "System V IPC is not implemented on this machine");
a0d0e21e
LW		 4526#endif
4527}
4528
4529PP(pp_semctl)
4530{
4531#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
39644a26 4532 dSP; dMARK; dTARGET;
533c011a 4533 int anum = do_ipcctl(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 4534 SP = MARK;
4535 if (anum == -1)
4536 RETSETUNDEF;
4537 if (anum != 0) {
4538 PUSHi(anum);
4539 }
4540 else {
8903cb82 4541 PUSHp(zero_but_true, ZBTLEN);
a0d0e21e
LW		 4542 }
4543 RETURN;
4544#else
cea2e8a9 4545 return pp_semget();
a0d0e21e
LW		 4546#endif
4547}
4548
4549PP(pp_semop)
4550{
4551#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
39644a26 4552 dSP; dMARK; dTARGET;
a0d0e21e
LW		 4553 I32 value = (I32)(do_semop(MARK, SP) >= 0);
4554 SP = MARK;
4555 PUSHi(value);
4556 RETURN;
4557#else
cea2e8a9 4558 return pp_semget();
a0d0e21e
LW		 4559#endif
4560}
4561
4562/* Get system info. */
4563
4564PP(pp_ghbyname)
4565{
693762b4 4566#ifdef HAS_GETHOSTBYNAME
cea2e8a9 4567 return pp_ghostent();
a0d0e21e 4568#else
cea2e8a9 4569 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
a0d0e21e
LW		 4570#endif
4571}
4572
4573PP(pp_ghbyaddr)
4574{
693762b4 4575#ifdef HAS_GETHOSTBYADDR
cea2e8a9 4576 return pp_ghostent();
a0d0e21e 4577#else
cea2e8a9 4578 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
a0d0e21e
LW		 4579#endif
4580}
4581
4582PP(pp_ghostent)
4583{
693762b4 4584#if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
9cad6237 4585 dSP;
533c011a 4586 I32 which = PL_op->op_type;
a0d0e21e
LW		 4587 register char **elem;
4588 register SV *sv;
dc45a647 4589#ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4599a1de
JH		 4590 struct hostent *PerlSock_gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4591 struct hostent *PerlSock_gethostbyname(Netdb_name_t);
6ad3d225 4592 struct hostent *PerlSock_gethostent(void);
a0d0e21e
LW		 4593#endif
4594 struct hostent *hent;
4595 unsigned long len;
2d8e6c8d 4596 STRLEN n_a;
a0d0e21e
LW		 4597
4598 EXTEND(SP, 10);
dc45a647
MB		 4599 if (which == OP_GHBYNAME)
4600#ifdef HAS_GETHOSTBYNAME
595ae481 4601 hent = PerlSock_gethostbyname(POPpbytex);
dc45a647 4602#else
cea2e8a9 4603 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
dc45a647 4604#endif
a0d0e21e 4605 else if (which == OP_GHBYADDR) {
dc45a647 4606#ifdef HAS_GETHOSTBYADDR
a0d0e21e 4607 int addrtype = POPi;
748a9306 4608 SV *addrsv = POPs;
a0d0e21e 4609 STRLEN addrlen;
595ae481 4610 Netdb_host_t addr = (Netdb_host_t) SvPVbyte(addrsv, addrlen);
a0d0e21e 4611
4599a1de 4612 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
dc45a647 4613#else
cea2e8a9 4614 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
dc45a647 4615#endif
a0d0e21e
LW		 4616 }
4617 else
4618#ifdef HAS_GETHOSTENT
6ad3d225 4619 hent = PerlSock_gethostent();
a0d0e21e 4620#else
cea2e8a9 4621 DIE(aTHX_ PL_no_sock_func, "gethostent");
a0d0e21e
LW		 4622#endif
4623
4624#ifdef HOST_NOT_FOUND
4625 if (!hent)
f86702cc 4626 STATUS_NATIVE_SET(h_errno);
a0d0e21e
LW		 4627#endif
4628
4629 if (GIMME != G_ARRAY) {
4630 PUSHs(sv = sv_newmortal());
4631 if (hent) {
4632 if (which == OP_GHBYNAME) {
fd0af264 4633 if (hent->h_addr)
4634 sv_setpvn(sv, hent->h_addr, hent->h_length);
a0d0e21e
LW		 4635 }
4636 else
4637 sv_setpv(sv, (char*)hent->h_name);
4638 }
4639 RETURN;
4640 }
4641
4642 if (hent) {
3280af22 4643 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4644 sv_setpv(sv, (char*)hent->h_name);
3280af22 4645 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 4646 for (elem = hent->h_aliases; elem && *elem; elem++) {
4647 sv_catpv(sv, *elem);
4648 if (elem[1])
4649 sv_catpvn(sv, " ", 1);
4650 }
3280af22 4651 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4652 sv_setiv(sv, (IV)hent->h_addrtype);
3280af22 4653 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4654 len = hent->h_length;
1e422769 4655 sv_setiv(sv, (IV)len);
a0d0e21e
LW		 4656#ifdef h_addr
4657 for (elem = hent->h_addr_list; elem && *elem; elem++) {
3280af22 4658 XPUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 4659 sv_setpvn(sv, *elem, len);
4660 }
4661#else
6b88bc9c 4662 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
fd0af264 4663 if (hent->h_addr)
4664 sv_setpvn(sv, hent->h_addr, len);
a0d0e21e
LW		 4665#endif /* h_addr */
4666 }
4667 RETURN;
4668#else
cea2e8a9 4669 DIE(aTHX_ PL_no_sock_func, "gethostent");
a0d0e21e
LW		 4670#endif
4671}
4672
4673PP(pp_gnbyname)
4674{
693762b4 4675#ifdef HAS_GETNETBYNAME
cea2e8a9 4676 return pp_gnetent();
a0d0e21e 4677#else
cea2e8a9 4678 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
a0d0e21e
LW		 4679#endif
4680}
4681
4682PP(pp_gnbyaddr)
4683{
693762b4 4684#ifdef HAS_GETNETBYADDR
cea2e8a9 4685 return pp_gnetent();
a0d0e21e 4686#else
cea2e8a9 4687 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
a0d0e21e
LW		 4688#endif
4689}
4690
4691PP(pp_gnetent)
4692{
693762b4 4693#if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
9cad6237 4694 dSP;
533c011a 4695 I32 which = PL_op->op_type;
a0d0e21e
LW		 4696 register char **elem;
4697 register SV *sv;
dc45a647
MB		 4698#ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4699 struct netent *PerlSock_getnetbyaddr(Netdb_net_t, int);
4700 struct netent *PerlSock_getnetbyname(Netdb_name_t);
4701 struct netent *PerlSock_getnetent(void);
8ac85365 4702#endif
a0d0e21e 4703 struct netent *nent;
2d8e6c8d 4704 STRLEN n_a;
a0d0e21e
LW		 4705
4706 if (which == OP_GNBYNAME)
dc45a647 4707#ifdef HAS_GETNETBYNAME
42e0c139 4708 nent = PerlSock_getnetbyname(POPpbytex);
dc45a647 4709#else
cea2e8a9 4710 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
dc45a647 4711#endif
a0d0e21e 4712 else if (which == OP_GNBYADDR) {
dc45a647 4713#ifdef HAS_GETNETBYADDR
a0d0e21e 4714 int addrtype = POPi;
3bb7c1b4 4715 Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
76e3520e 4716 nent = PerlSock_getnetbyaddr(addr, addrtype);
dc45a647 4717#else
cea2e8a9 4718 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
dc45a647 4719#endif
a0d0e21e
LW		 4720 }
4721 else
dc45a647 4722#ifdef HAS_GETNETENT
76e3520e 4723 nent = PerlSock_getnetent();
dc45a647 4724#else
cea2e8a9 4725 DIE(aTHX_ PL_no_sock_func, "getnetent");
dc45a647 4726#endif
a0d0e21e
LW		 4727
4728 EXTEND(SP, 4);
4729 if (GIMME != G_ARRAY) {
4730 PUSHs(sv = sv_newmortal());
4731 if (nent) {
4732 if (which == OP_GNBYNAME)
1e422769 4733 sv_setiv(sv, (IV)nent->n_net);
a0d0e21e
LW		 4734 else
4735 sv_setpv(sv, nent->n_name);
4736 }
4737 RETURN;
4738 }
4739
4740 if (nent) {
3280af22 4741 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4742 sv_setpv(sv, nent->n_name);
3280af22 4743 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 4744 for (elem = nent->n_aliases; elem && *elem; elem++) {
a0d0e21e
LW		 4745 sv_catpv(sv, *elem);
4746 if (elem[1])
4747 sv_catpvn(sv, " ", 1);
4748 }
3280af22 4749 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4750 sv_setiv(sv, (IV)nent->n_addrtype);
3280af22 4751 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4752 sv_setiv(sv, (IV)nent->n_net);
a0d0e21e
LW		 4753 }
4754
4755 RETURN;
4756#else
cea2e8a9 4757 DIE(aTHX_ PL_no_sock_func, "getnetent");
a0d0e21e
LW		 4758#endif
4759}
4760
4761PP(pp_gpbyname)
4762{
693762b4 4763#ifdef HAS_GETPROTOBYNAME
cea2e8a9 4764 return pp_gprotoent();
a0d0e21e 4765#else
cea2e8a9 4766 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
a0d0e21e
LW		 4767#endif
4768}
4769
4770PP(pp_gpbynumber)
4771{
693762b4 4772#ifdef HAS_GETPROTOBYNUMBER
cea2e8a9 4773 return pp_gprotoent();
a0d0e21e 4774#else
cea2e8a9 4775 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
a0d0e21e
LW		 4776#endif
4777}
4778
4779PP(pp_gprotoent)
4780{
693762b4 4781#if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
9cad6237 4782 dSP;
533c011a 4783 I32 which = PL_op->op_type;
a0d0e21e 4784 register char **elem;
301e8125 4785 register SV *sv;
dc45a647 4786#ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4599a1de 4787 struct protoent *PerlSock_getprotobyname(Netdb_name_t);
6ad3d225
GS		 4788 struct protoent *PerlSock_getprotobynumber(int);
4789 struct protoent *PerlSock_getprotoent(void);
8ac85365 4790#endif
a0d0e21e 4791 struct protoent *pent;
2d8e6c8d 4792 STRLEN n_a;
a0d0e21e
LW		 4793
4794 if (which == OP_GPBYNAME)
e5c9fcd0 4795#ifdef HAS_GETPROTOBYNAME
42e0c139 4796 pent = PerlSock_getprotobyname(POPpbytex);
e5c9fcd0 4797#else
cea2e8a9 4798 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
e5c9fcd0 4799#endif
a0d0e21e 4800 else if (which == OP_GPBYNUMBER)
e5c9fcd0 4801#ifdef HAS_GETPROTOBYNUMBER
6ad3d225 4802 pent = PerlSock_getprotobynumber(POPi);
e5c9fcd0 4803#else
cea2e8a9 4804 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
e5c9fcd0 4805#endif
a0d0e21e 4806 else
e5c9fcd0 4807#ifdef HAS_GETPROTOENT
6ad3d225 4808 pent = PerlSock_getprotoent();
e5c9fcd0 4809#else
cea2e8a9 4810 DIE(aTHX_ PL_no_sock_func, "getprotoent");
e5c9fcd0 4811#endif
a0d0e21e
LW		 4812
4813 EXTEND(SP, 3);
4814 if (GIMME != G_ARRAY) {
4815 PUSHs(sv = sv_newmortal());
4816 if (pent) {
4817 if (which == OP_GPBYNAME)
1e422769 4818 sv_setiv(sv, (IV)pent->p_proto);
a0d0e21e
LW		 4819 else
4820 sv_setpv(sv, pent->p_name);
4821 }
4822 RETURN;
4823 }
4824
4825 if (pent) {
3280af22 4826 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4827 sv_setpv(sv, pent->p_name);
3280af22 4828 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 4829 for (elem = pent->p_aliases; elem && *elem; elem++) {
a0d0e21e
LW		 4830 sv_catpv(sv, *elem);
4831 if (elem[1])
4832 sv_catpvn(sv, " ", 1);
4833 }
3280af22 4834 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4835 sv_setiv(sv, (IV)pent->p_proto);
a0d0e21e
LW		 4836 }
4837
4838 RETURN;
4839#else
cea2e8a9 4840 DIE(aTHX_ PL_no_sock_func, "getprotoent");
a0d0e21e
LW		 4841#endif
4842}
4843
4844PP(pp_gsbyname)
4845{
9ec75305 4846#ifdef HAS_GETSERVBYNAME
cea2e8a9 4847 return pp_gservent();
a0d0e21e 4848#else
cea2e8a9 4849 DIE(aTHX_ PL_no_sock_func, "getservbyname");
a0d0e21e
LW		 4850#endif
4851}
4852
4853PP(pp_gsbyport)
4854{
9ec75305 4855#ifdef HAS_GETSERVBYPORT
cea2e8a9 4856 return pp_gservent();
a0d0e21e 4857#else
cea2e8a9 4858 DIE(aTHX_ PL_no_sock_func, "getservbyport");
a0d0e21e
LW		 4859#endif
4860}
4861
4862PP(pp_gservent)
4863{
693762b4 4864#if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
9cad6237 4865 dSP;
533c011a 4866 I32 which = PL_op->op_type;
a0d0e21e
LW		 4867 register char **elem;
4868 register SV *sv;
dc45a647 4869#ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4599a1de
JH		 4870 struct servent *PerlSock_getservbyname(Netdb_name_t, Netdb_name_t);
4871 struct servent *PerlSock_getservbyport(int, Netdb_name_t);
6ad3d225 4872 struct servent *PerlSock_getservent(void);
8ac85365 4873#endif
a0d0e21e 4874 struct servent *sent;
2d8e6c8d 4875 STRLEN n_a;
a0d0e21e
LW		 4876
4877 if (which == OP_GSBYNAME) {
dc45a647 4878#ifdef HAS_GETSERVBYNAME
42e0c139
AP		 4879 char *proto = POPpbytex;
4880 char *name = POPpbytex;
a0d0e21e
LW		 4881
4882 if (proto && !*proto)
4883 proto = Nullch;
4884
6ad3d225 4885 sent = PerlSock_getservbyname(name, proto);
dc45a647 4886#else
cea2e8a9 4887 DIE(aTHX_ PL_no_sock_func, "getservbyname");
dc45a647 4888#endif
a0d0e21e
LW		 4889 }
4890 else if (which == OP_GSBYPORT) {
dc45a647 4891#ifdef HAS_GETSERVBYPORT
42e0c139 4892 char *proto = POPpbytex;
36477c24 4893 unsigned short port = POPu;
a0d0e21e 4894
36477c24 4895#ifdef HAS_HTONS
6ad3d225 4896 port = PerlSock_htons(port);
36477c24 4897#endif
6ad3d225 4898 sent = PerlSock_getservbyport(port, proto);
dc45a647 4899#else
cea2e8a9 4900 DIE(aTHX_ PL_no_sock_func, "getservbyport");
dc45a647 4901#endif
a0d0e21e
LW		 4902 }
4903 else
e5c9fcd0 4904#ifdef HAS_GETSERVENT
6ad3d225 4905 sent = PerlSock_getservent();
e5c9fcd0 4906#else
cea2e8a9 4907 DIE(aTHX_ PL_no_sock_func, "getservent");
e5c9fcd0 4908#endif
a0d0e21e
LW		 4909
4910 EXTEND(SP, 4);
4911 if (GIMME != G_ARRAY) {
4912 PUSHs(sv = sv_newmortal());
4913 if (sent) {
4914 if (which == OP_GSBYNAME) {
4915#ifdef HAS_NTOHS
6ad3d225 4916 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
a0d0e21e 4917#else
1e422769 4918 sv_setiv(sv, (IV)(sent->s_port));
a0d0e21e
LW		 4919#endif
4920 }
4921 else
4922 sv_setpv(sv, sent->s_name);
4923 }
4924 RETURN;
4925 }
4926
4927 if (sent) {
3280af22 4928 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4929 sv_setpv(sv, sent->s_name);
3280af22 4930 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 4931 for (elem = sent->s_aliases; elem && *elem; elem++) {
a0d0e21e
LW		 4932 sv_catpv(sv, *elem);
4933 if (elem[1])
4934 sv_catpvn(sv, " ", 1);
4935 }
3280af22 4936 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4937#ifdef HAS_NTOHS
76e3520e 4938 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
a0d0e21e 4939#else
1e422769 4940 sv_setiv(sv, (IV)(sent->s_port));
a0d0e21e 4941#endif
3280af22 4942 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 4943 sv_setpv(sv, sent->s_proto);
4944 }
4945
4946 RETURN;
4947#else
cea2e8a9 4948 DIE(aTHX_ PL_no_sock_func, "getservent");
a0d0e21e
LW		 4949#endif
4950}
4951
4952PP(pp_shostent)
4953{
693762b4 4954#ifdef HAS_SETHOSTENT
9cad6237 4955 dSP;
76e3520e 4956 PerlSock_sethostent(TOPi);
a0d0e21e
LW		 4957 RETSETYES;
4958#else
cea2e8a9 4959 DIE(aTHX_ PL_no_sock_func, "sethostent");
a0d0e21e
LW		 4960#endif
4961}
4962
4963PP(pp_snetent)
4964{
693762b4 4965#ifdef HAS_SETNETENT
9cad6237 4966 dSP;
76e3520e 4967 PerlSock_setnetent(TOPi);
a0d0e21e
LW		 4968 RETSETYES;
4969#else
cea2e8a9 4970 DIE(aTHX_ PL_no_sock_func, "setnetent");
a0d0e21e
LW		 4971#endif
4972}
4973
4974PP(pp_sprotoent)
4975{
693762b4 4976#ifdef HAS_SETPROTOENT
9cad6237 4977 dSP;
76e3520e 4978 PerlSock_setprotoent(TOPi);
a0d0e21e
LW		 4979 RETSETYES;
4980#else
cea2e8a9 4981 DIE(aTHX_ PL_no_sock_func, "setprotoent");
a0d0e21e
LW		 4982#endif
4983}
4984
4985PP(pp_sservent)
4986{
693762b4 4987#ifdef HAS_SETSERVENT
9cad6237 4988 dSP;
76e3520e 4989 PerlSock_setservent(TOPi);
a0d0e21e
LW		 4990 RETSETYES;
4991#else
cea2e8a9 4992 DIE(aTHX_ PL_no_sock_func, "setservent");
a0d0e21e
LW		 4993#endif
4994}
4995
4996PP(pp_ehostent)
4997{
693762b4 4998#ifdef HAS_ENDHOSTENT
9cad6237 4999 dSP;
76e3520e 5000 PerlSock_endhostent();
924508f0 5001 EXTEND(SP,1);
a0d0e21e
LW		 5002 RETPUSHYES;
5003#else
cea2e8a9 5004 DIE(aTHX_ PL_no_sock_func, "endhostent");
a0d0e21e
LW		 5005#endif
5006}
5007
5008PP(pp_enetent)
5009{
693762b4 5010#ifdef HAS_ENDNETENT
9cad6237 5011 dSP;
76e3520e 5012 PerlSock_endnetent();
924508f0 5013 EXTEND(SP,1);
a0d0e21e
LW		 5014 RETPUSHYES;
5015#else
cea2e8a9 5016 DIE(aTHX_ PL_no_sock_func, "endnetent");
a0d0e21e
LW		 5017#endif
5018}
5019
5020PP(pp_eprotoent)
5021{
693762b4 5022#ifdef HAS_ENDPROTOENT
9cad6237 5023 dSP;
76e3520e 5024 PerlSock_endprotoent();
924508f0 5025 EXTEND(SP,1);
a0d0e21e
LW		 5026 RETPUSHYES;
5027#else
cea2e8a9 5028 DIE(aTHX_ PL_no_sock_func, "endprotoent");
a0d0e21e
LW		 5029#endif
5030}
5031
5032PP(pp_eservent)
5033{
693762b4 5034#ifdef HAS_ENDSERVENT
9cad6237 5035 dSP;
76e3520e 5036 PerlSock_endservent();
924508f0 5037 EXTEND(SP,1);
a0d0e21e
LW		 5038 RETPUSHYES;
5039#else
cea2e8a9 5040 DIE(aTHX_ PL_no_sock_func, "endservent");
a0d0e21e
LW		 5041#endif
5042}
5043
5044PP(pp_gpwnam)
5045{
5046#ifdef HAS_PASSWD
cea2e8a9 5047 return pp_gpwent();
a0d0e21e 5048#else
cea2e8a9 5049 DIE(aTHX_ PL_no_func, "getpwnam");
a0d0e21e
LW		 5050#endif
5051}
5052
5053PP(pp_gpwuid)
5054{
5055#ifdef HAS_PASSWD
cea2e8a9 5056 return pp_gpwent();
a0d0e21e 5057#else
cea2e8a9 5058 DIE(aTHX_ PL_no_func, "getpwuid");
a0d0e21e
LW		 5059#endif
5060}
5061
5062PP(pp_gpwent)
5063{
0994c4d0 5064#ifdef HAS_PASSWD
9cad6237 5065 dSP;
533c011a 5066 I32 which = PL_op->op_type;
a0d0e21e 5067 register SV *sv;
2d8e6c8d 5068 STRLEN n_a;
e3aefe8d 5069 struct passwd *pwent = NULL;
301e8125 5070 /*
bcf53261
JH		 5071 * We currently support only the SysV getsp* shadow password interface.
5072 * The interface is declared in <shadow.h> and often one needs to link
5073 * with -lsecurity or some such.
5074 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5075 * (and SCO?)
5076 *
5077 * AIX getpwnam() is clever enough to return the encrypted password
5078 * only if the caller (euid?) is root.
5079 *
5080 * There are at least two other shadow password APIs. Many platforms
5081 * seem to contain more than one interface for accessing the shadow
5082 * password databases, possibly for compatibility reasons.
3813c136 5083 * The getsp*() is by far he simplest one, the other two interfaces
bcf53261
JH		 5084 * are much more complicated, but also very similar to each other.
5085 *
5086 * <sys/types.h>
5087 * <sys/security.h>
5088 * <prot.h>
5089 * struct pr_passwd *getprpw*();
5090 * The password is in
3813c136
JH		 5091 * char getprpw*(...).ufld.fd_encrypt[]
5092 * Mention HAS_GETPRPWNAM here so that Configure probes for it.
bcf53261
JH		 5093 *
5094 * <sys/types.h>
5095 * <sys/security.h>
5096 * <prot.h>
5097 * struct es_passwd *getespw*();
5098 * The password is in
5099 * char *(getespw*(...).ufld.fd_encrypt)
3813c136 5100 * Mention HAS_GETESPWNAM here so that Configure probes for it.
bcf53261 5101 *
3813c136 5102 * Mention I_PROT here so that Configure probes for it.
bcf53261
JH		 5103 *
5104 * In HP-UX for getprpw*() the manual page claims that one should include
5105 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5106 * if one includes <shadow.h> as that includes <hpsecurity.h>,
5107 * and pp_sys.c already includes <shadow.h> if there is such.
3813c136
JH		 5108 *
5109 * Note that <sys/security.h> is already probed for, but currently
5110 * it is only included in special cases.
301e8125 5111 *
bcf53261
JH		 5112 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5113 * be preferred interface, even though also the getprpw*() interface
5114 * is available) one needs to link with -lsecurity -ldb -laud -lm.
3813c136
JH		 5115 * One also needs to call set_auth_parameters() in main() before
5116 * doing anything else, whether one is using getespw*() or getprpw*().
5117 *
5118 * Note that accessing the shadow databases can be magnitudes
5119 * slower than accessing the standard databases.
bcf53261
JH		 5120 *
5121 * --jhi
5122 */
a0d0e21e 5123
e3aefe8d
JH		 5124 switch (which) {
5125 case OP_GPWNAM:
42e0c139 5126 pwent = getpwnam(POPpbytex);
e3aefe8d
JH		 5127 break;
5128 case OP_GPWUID:
5129 pwent = getpwuid((Uid_t)POPi);
5130 break;
5131 case OP_GPWENT:
1883634f 5132# ifdef HAS_GETPWENT
e3aefe8d 5133 pwent = getpwent();
1883634f 5134# else
a45d1c96 5135 DIE(aTHX_ PL_no_func, "getpwent");
1883634f 5136# endif
e3aefe8d
JH		 5137 break;
5138 }
8c0bfa08 5139
a0d0e21e
LW		 5140 EXTEND(SP, 10);
5141 if (GIMME != G_ARRAY) {
5142 PUSHs(sv = sv_newmortal());
5143 if (pwent) {
5144 if (which == OP_GPWNAM)
1883634f 5145# if Uid_t_sign <= 0
1e422769 5146 sv_setiv(sv, (IV)pwent->pw_uid);
1883634f 5147# else
23dcd6c8 5148 sv_setuv(sv, (UV)pwent->pw_uid);
1883634f 5149# endif
a0d0e21e
LW		 5150 else
5151 sv_setpv(sv, pwent->pw_name);
5152 }
5153 RETURN;
5154 }
5155
5156 if (pwent) {
3280af22 5157 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 5158 sv_setpv(sv, pwent->pw_name);
6ee623d5 5159
3280af22 5160 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
3813c136
JH		 5161 SvPOK_off(sv);
5162 /* If we have getspnam(), we try to dig up the shadow
5163 * password. If we are underprivileged, the shadow
5164 * interface will set the errno to EACCES or similar,
5165 * and return a null pointer. If this happens, we will
5166 * use the dummy password (usually "*" or "x") from the
5167 * standard password database.
5168 *
5169 * In theory we could skip the shadow call completely
5170 * if euid != 0 but in practice we cannot know which
5171 * security measures are guarding the shadow databases
5172 * on a random platform.
5173 *
5174 * Resist the urge to use additional shadow interfaces.
5175 * Divert the urge to writing an extension instead.
5176 *
5177 * --jhi */
e3aefe8d 5178# ifdef HAS_GETSPNAM
3813c136
JH		 5179 {
5180 struct spwd *spwent;
5181 int saverrno; /* Save and restore errno so that
5182 * underprivileged attempts seem
5183 * to have never made the unsccessful
5184 * attempt to retrieve the shadow password. */
5185
5186 saverrno = errno;
5187 spwent = getspnam(pwent->pw_name);
5188 errno = saverrno;
5189 if (spwent && spwent->sp_pwdp)
5190 sv_setpv(sv, spwent->sp_pwdp);
5191 }
f1066039 5192# endif
e020c87d 5193# ifdef PWPASSWD
3813c136
JH		 5194 if (!SvPOK(sv)) /* Use the standard password, then. */
5195 sv_setpv(sv, pwent->pw_passwd);
e020c87d 5196# endif
3813c136 5197
1883634f 5198# ifndef INCOMPLETE_TAINTS
3813c136
JH		 5199 /* passwd is tainted because user himself can diddle with it.
5200 * admittedly not much and in a very limited way, but nevertheless. */
2959b6e3 5201 SvTAINTED_on(sv);
1883634f 5202# endif
6ee623d5 5203
3280af22 5204 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1883634f 5205# if Uid_t_sign <= 0
1e422769 5206 sv_setiv(sv, (IV)pwent->pw_uid);
1883634f 5207# else
23dcd6c8 5208 sv_setuv(sv, (UV)pwent->pw_uid);
1883634f 5209# endif
6ee623d5 5210
3280af22 5211 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1883634f 5212# if Uid_t_sign <= 0
1e422769 5213 sv_setiv(sv, (IV)pwent->pw_gid);
1883634f 5214# else
23dcd6c8 5215 sv_setuv(sv, (UV)pwent->pw_gid);
1883634f 5216# endif
3813c136
JH		 5217 /* pw_change, pw_quota, and pw_age are mutually exclusive--
5218 * because of the poor interface of the Perl getpw*(),
5219 * not because there's some standard/convention saying so.
5220 * A better interface would have been to return a hash,
5221 * but we are accursed by our history, alas. --jhi. */
3280af22 5222 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1883634f 5223# ifdef PWCHANGE
1e422769 5224 sv_setiv(sv, (IV)pwent->pw_change);
6ee623d5 5225# else
1883634f
JH		 5226# ifdef PWQUOTA
5227 sv_setiv(sv, (IV)pwent->pw_quota);
5228# else
a1757be1 5229# ifdef PWAGE
a0d0e21e 5230 sv_setpv(sv, pwent->pw_age);
a1757be1 5231# endif
6ee623d5
GS		 5232# endif
5233# endif
6ee623d5 5234
3813c136
JH		 5235 /* pw_class and pw_comment are mutually exclusive--.
5236 * see the above note for pw_change, pw_quota, and pw_age. */
3280af22 5237 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1883634f 5238# ifdef PWCLASS
a0d0e21e 5239 sv_setpv(sv, pwent->pw_class);
1883634f
JH		 5240# else
5241# ifdef PWCOMMENT
a0d0e21e 5242 sv_setpv(sv, pwent->pw_comment);
1883634f 5243# endif
6ee623d5 5244# endif
6ee623d5 5245
3280af22 5246 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1883634f 5247# ifdef PWGECOS
a0d0e21e 5248 sv_setpv(sv, pwent->pw_gecos);
1883634f
JH		 5249# endif
5250# ifndef INCOMPLETE_TAINTS
d2719217 5251 /* pw_gecos is tainted because user himself can diddle with it. */
fb73857a 5252 SvTAINTED_on(sv);
1883634f 5253# endif
6ee623d5 5254
3280af22 5255 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 5256 sv_setpv(sv, pwent->pw_dir);
6ee623d5 5257
3280af22 5258 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 5259 sv_setpv(sv, pwent->pw_shell);
1883634f 5260# ifndef INCOMPLETE_TAINTS
4602f195
JH		 5261 /* pw_shell is tainted because user himself can diddle with it. */
5262 SvTAINTED_on(sv);
1883634f 5263# endif
6ee623d5 5264
1883634f 5265# ifdef PWEXPIRE
6b88bc9c 5266 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 5267 sv_setiv(sv, (IV)pwent->pw_expire);
1883634f 5268# endif
a0d0e21e
LW		 5269 }
5270 RETURN;
5271#else
cea2e8a9 5272 DIE(aTHX_ PL_no_func, "getpwent");
a0d0e21e
LW		 5273#endif
5274}
5275
5276PP(pp_spwent)
5277{
d493b042 5278#if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
9cad6237 5279 dSP;
a0d0e21e
LW		 5280 setpwent();
5281 RETPUSHYES;
5282#else
cea2e8a9 5283 DIE(aTHX_ PL_no_func, "setpwent");
a0d0e21e
LW		 5284#endif
5285}
5286
5287PP(pp_epwent)
5288{
28e8609d 5289#if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
9cad6237 5290 dSP;
a0d0e21e
LW		 5291 endpwent();
5292 RETPUSHYES;
5293#else
cea2e8a9 5294 DIE(aTHX_ PL_no_func, "endpwent");
a0d0e21e
LW		 5295#endif
5296}
5297
5298PP(pp_ggrnam)
5299{
5300#ifdef HAS_GROUP
cea2e8a9 5301 return pp_ggrent();
a0d0e21e 5302#else
cea2e8a9 5303 DIE(aTHX_ PL_no_func, "getgrnam");
a0d0e21e
LW		 5304#endif
5305}
5306
5307PP(pp_ggrgid)
5308{
5309#ifdef HAS_GROUP
cea2e8a9 5310 return pp_ggrent();
a0d0e21e 5311#else
cea2e8a9 5312 DIE(aTHX_ PL_no_func, "getgrgid");
a0d0e21e
LW		 5313#endif
5314}
5315
5316PP(pp_ggrent)
5317{
0994c4d0 5318#ifdef HAS_GROUP
9cad6237 5319 dSP;
533c011a 5320 I32 which = PL_op->op_type;
a0d0e21e
LW		 5321 register char **elem;
5322 register SV *sv;
5323 struct group *grent;
2d8e6c8d 5324 STRLEN n_a;
a0d0e21e
LW		 5325
5326 if (which == OP_GGRNAM)
42e0c139 5327 grent = (struct group *)getgrnam(POPpbytex);
a0d0e21e
LW		 5328 else if (which == OP_GGRGID)
5329 grent = (struct group *)getgrgid(POPi);
5330 else
0994c4d0 5331#ifdef HAS_GETGRENT
a0d0e21e 5332 grent = (struct group *)getgrent();
0994c4d0
JH		 5333#else
5334 DIE(aTHX_ PL_no_func, "getgrent");
5335#endif
a0d0e21e
LW		 5336
5337 EXTEND(SP, 4);
5338 if (GIMME != G_ARRAY) {
5339 PUSHs(sv = sv_newmortal());
5340 if (grent) {
5341 if (which == OP_GGRNAM)
1e422769 5342 sv_setiv(sv, (IV)grent->gr_gid);
a0d0e21e
LW		 5343 else
5344 sv_setpv(sv, grent->gr_name);
5345 }
5346 RETURN;
5347 }
5348
5349 if (grent) {
3280af22 5350 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 5351 sv_setpv(sv, grent->gr_name);
28e8609d 5352
3280af22 5353 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
28e8609d 5354#ifdef GRPASSWD
a0d0e21e 5355 sv_setpv(sv, grent->gr_passwd);
28e8609d
JH		 5356#endif
5357
3280af22 5358 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 5359 sv_setiv(sv, (IV)grent->gr_gid);
28e8609d 5360
3280af22 5361 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 5362 for (elem = grent->gr_mem; elem && *elem; elem++) {
a0d0e21e
LW		 5363 sv_catpv(sv, *elem);
5364 if (elem[1])
5365 sv_catpvn(sv, " ", 1);
5366 }
5367 }
5368
5369 RETURN;
5370#else
cea2e8a9 5371 DIE(aTHX_ PL_no_func, "getgrent");
a0d0e21e
LW		 5372#endif
5373}
5374
5375PP(pp_sgrent)
5376{
28e8609d 5377#if defined(HAS_GROUP) && defined(HAS_SETGRENT)
9cad6237 5378 dSP;
a0d0e21e
LW		 5379 setgrent();
5380 RETPUSHYES;
5381#else
cea2e8a9 5382 DIE(aTHX_ PL_no_func, "setgrent");
a0d0e21e
LW		 5383#endif
5384}
5385
5386PP(pp_egrent)
5387{
28e8609d 5388#if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
9cad6237 5389 dSP;
a0d0e21e
LW		 5390 endgrent();
5391 RETPUSHYES;
5392#else
cea2e8a9 5393 DIE(aTHX_ PL_no_func, "endgrent");
a0d0e21e
LW		 5394#endif
5395}
5396
5397PP(pp_getlogin)
5398{
a0d0e21e 5399#ifdef HAS_GETLOGIN
9cad6237 5400 dSP; dTARGET;
a0d0e21e
LW		 5401 char *tmps;
5402 EXTEND(SP, 1);
76e3520e 5403 if (!(tmps = PerlProc_getlogin()))
a0d0e21e
LW		 5404 RETPUSHUNDEF;
5405 PUSHp(tmps, strlen(tmps));
5406 RETURN;
5407#else
cea2e8a9 5408 DIE(aTHX_ PL_no_func, "getlogin");
a0d0e21e
LW		 5409#endif
5410}
5411
5412/* Miscellaneous. */
5413
5414PP(pp_syscall)
5415{
d2719217 5416#ifdef HAS_SYSCALL
39644a26 5417 dSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 5418 register I32 items = SP - MARK;
5419 unsigned long a[20];
5420 register I32 i = 0;
5421 I32 retval = -1;
2d8e6c8d 5422 STRLEN n_a;
a0d0e21e 5423
3280af22 5424 if (PL_tainting) {
a0d0e21e 5425 while (++MARK <= SP) {
bbce6d69 5426 if (SvTAINTED(*MARK)) {
5427 TAINT;
5428 break;
5429 }
a0d0e21e
LW		 5430 }
5431 MARK = ORIGMARK;
5432 TAINT_PROPER("syscall");
5433 }
5434
5435 /* This probably won't work on machines where sizeof(long) != sizeof(int)
5436 * or where sizeof(long) != sizeof(char*). But such machines will
5437 * not likely have syscall implemented either, so who cares?
5438 */
5439 while (++MARK <= SP) {
5440 if (SvNIOK(*MARK) || !i)
5441 a[i++] = SvIV(*MARK);
3280af22 5442 else if (*MARK == &PL_sv_undef)
748a9306 5443 a[i++] = 0;
301e8125 5444 else
2d8e6c8d 5445 a[i++] = (unsigned long)SvPV_force(*MARK, n_a);
a0d0e21e
LW		 5446 if (i > 15)
5447 break;
5448 }
5449 switch (items) {
5450 default:
cea2e8a9 5451 DIE(aTHX_ "Too many args to syscall");
a0d0e21e 5452 case 0:
cea2e8a9 5453 DIE(aTHX_ "Too few args to syscall");
a0d0e21e
LW		 5454 case 1:
5455 retval = syscall(a[0]);
5456 break;
5457 case 2:
5458 retval = syscall(a[0],a[1]);
5459 break;
5460 case 3:
5461 retval = syscall(a[0],a[1],a[2]);
5462 break;
5463 case 4:
5464 retval = syscall(a[0],a[1],a[2],a[3]);
5465 break;
5466 case 5:
5467 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5468 break;
5469 case 6:
5470 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5471 break;
5472 case 7:
5473 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5474 break;
5475 case 8:
5476 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5477 break;
5478#ifdef atarist
5479 case 9:
5480 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5481 break;
5482 case 10:
5483 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5484 break;
5485 case 11:
5486 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5487 a[10]);
5488 break;
5489 case 12:
5490 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5491 a[10],a[11]);
5492 break;
5493 case 13:
5494 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5495 a[10],a[11],a[12]);
5496 break;
5497 case 14:
5498 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5499 a[10],a[11],a[12],a[13]);
5500 break;
5501#endif /* atarist */
5502 }
5503 SP = ORIGMARK;
5504 PUSHi(retval);
5505 RETURN;
5506#else
cea2e8a9 5507 DIE(aTHX_ PL_no_func, "syscall");
a0d0e21e
LW		 5508#endif
5509}
5510
ff68c719 5511#ifdef FCNTL_EMULATE_FLOCK
301e8125 5512
ff68c719 5513/* XXX Emulate flock() with fcntl().
5514 What's really needed is a good file locking module.
5515*/
5516
cea2e8a9
GS		 5517static int
5518fcntl_emulate_flock(int fd, int operation)
ff68c719 5519{
5520 struct flock flock;
301e8125 5521
ff68c719 5522 switch (operation & ~LOCK_NB) {
5523 case LOCK_SH:
5524 flock.l_type = F_RDLCK;
5525 break;
5526 case LOCK_EX:
5527 flock.l_type = F_WRLCK;
5528 break;
5529 case LOCK_UN:
5530 flock.l_type = F_UNLCK;
5531 break;
5532 default:
5533 errno = EINVAL;
5534 return -1;
5535 }
5536 flock.l_whence = SEEK_SET;
d9b3e12d 5537 flock.l_start = flock.l_len = (Off_t)0;
301e8125 5538
ff68c719 5539 return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5540}
5541
5542#endif /* FCNTL_EMULATE_FLOCK */
5543
5544#ifdef LOCKF_EMULATE_FLOCK
16d20bd9
AD		 5545
5546/* XXX Emulate flock() with lockf(). This is just to increase
5547 portability of scripts. The calls are not completely
5548 interchangeable. What's really needed is a good file
5549 locking module.
5550*/
5551
76c32331 5552/* The lockf() constants might have been defined in <unistd.h>.
5553 Unfortunately, <unistd.h> causes troubles on some mixed
5554 (BSD/POSIX) systems, such as SunOS 4.1.3.
16d20bd9
AD		 5555
5556 Further, the lockf() constants aren't POSIX, so they might not be
5557 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5558 just stick in the SVID values and be done with it. Sigh.
5559*/
5560
5561# ifndef F_ULOCK
5562# define F_ULOCK 0 /* Unlock a previously locked region */
5563# endif
5564# ifndef F_LOCK
5565# define F_LOCK 1 /* Lock a region for exclusive use */
5566# endif
5567# ifndef F_TLOCK
5568# define F_TLOCK 2 /* Test and lock a region for exclusive use */
5569# endif
5570# ifndef F_TEST
5571# define F_TEST 3 /* Test a region for other processes locks */
5572# endif
5573
cea2e8a9
GS		 5574static int
5575lockf_emulate_flock(int fd, int operation)
16d20bd9
AD		 5576{
5577 int i;
84902520
TB		 5578 int save_errno;
5579 Off_t pos;
5580
5581 /* flock locks entire file so for lockf we need to do the same */
5582 save_errno = errno;
6ad3d225 5583 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
84902520 5584 if (pos > 0) /* is seekable and needs to be repositioned */
6ad3d225 5585 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
08b714dd 5586 pos = -1; /* seek failed, so don't seek back afterwards */
84902520
TB		 5587 errno = save_errno;
5588
16d20bd9
AD		 5589 switch (operation) {
5590
5591 /* LOCK_SH - get a shared lock */
5592 case LOCK_SH:
5593 /* LOCK_EX - get an exclusive lock */
5594 case LOCK_EX:
5595 i = lockf (fd, F_LOCK, 0);
5596 break;
5597
5598 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5599 case LOCK_SH|LOCK_NB:
5600 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5601 case LOCK_EX|LOCK_NB:
5602 i = lockf (fd, F_TLOCK, 0);
5603 if (i == -1)
5604 if ((errno == EAGAIN) || (errno == EACCES))
5605 errno = EWOULDBLOCK;
5606 break;
5607
ff68c719 5608 /* LOCK_UN - unlock (non-blocking is a no-op) */
16d20bd9 5609 case LOCK_UN:
ff68c719 5610 case LOCK_UN|LOCK_NB:
16d20bd9
AD		 5611 i = lockf (fd, F_ULOCK, 0);
5612 break;
5613
5614 /* Default - can't decipher operation */
5615 default:
5616 i = -1;
5617 errno = EINVAL;
5618 break;
5619 }
84902520
TB		 5620
5621 if (pos > 0) /* need to restore position of the handle */
6ad3d225 5622 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
84902520 5623
16d20bd9
AD		 5624 return (i);
5625}
ff68c719 5626
5627#endif /* LOCKF_EMULATE_FLOCK */
Unnamed repository; edit this file 'description' to name the repository.