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