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