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