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