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