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
(retracted by #12485)
[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 }
b3fe4827 471 DIE(aTHX_ Nullformat);
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);
a385c4e7 1425 SETERRNO(EBADF,VMS_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 }
a385c4e7 1447 SETERRNO(EBADF,IoIFP(io)?VMS_RMS_FAC:VMS_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)
a385c4e7 2083 SETERRNO(EBADF,VMS_RMS_IFI);
d05c1ba0
JH		 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);
a385c4e7 2110 SETERRNO(EBADF,VMS_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",
53e06cf0 2153 OP_NAME(PL_op));
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;
a385c4e7 2198 SETERRNO(EBADF,VMS_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);
a385c4e7 2228 SETERRNO(EBADF,VMS_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);
a385c4e7 2379 SETERRNO(EBADF,VMS_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);
a385c4e7 2409 SETERRNO(EBADF,VMS_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);
a385c4e7 2435 SETERRNO(EBADF,VMS_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);
a385c4e7 2497 SETERRNO(EBADF,VMS_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);
a385c4e7 2524 SETERRNO(EBADF,VMS_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);
a385c4e7 2603 SETERRNO(EBADF,VMS_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);
a385c4e7 2676 SETERRNO(EBADF,VMS_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 }
a385c4e7 3279 SETERRNO(EBADF,VMS_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 3377
35ae6b54
MS		 3378 if( MAXARG == 1 )
3379 tmps = POPpx;
3380 else
3381 tmps = 0;
3382
3383 if( !tmps || !*tmps ) {
3384 if ( (svp = hv_fetch(GvHVn(PL_envgv), "HOME", 4, FALSE))
3385 || (svp = hv_fetch(GvHVn(PL_envgv), "LOGDIR", 6, FALSE))
491527d0 3386#ifdef VMS
35ae6b54 3387 || (svp = hv_fetch(GvHVn(PL_envgv), "SYS$LOGIN", 9, FALSE))
491527d0 3388#endif
35ae6b54
MS		 3389 )
3390 {
3391 if( MAXARG == 1 )
3392 deprecate("chdir('') or chdir(undef) as chdir()");
3393 tmps = SvPV(*svp, n_a);
3394 }
3395 else {
389ec635
MS		 3396 PUSHi(0);
3397 RETURN;
3398 }
8ea155d1 3399 }
8ea155d1 3400
a0d0e21e 3401 TAINT_PROPER("chdir");
6ad3d225 3402 PUSHi( PerlDir_chdir(tmps) >= 0 );
748a9306
LW		 3403#ifdef VMS
3404 /* Clear the DEFAULT element of ENV so we'll get the new value
3405 * in the future. */
6b88bc9c 3406 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
748a9306 3407#endif
a0d0e21e
LW		 3408 RETURN;
3409}
3410
3411PP(pp_chown)
3412{
a0d0e21e 3413#ifdef HAS_CHOWN
76ffd3b9
IZ		 3414 dSP; dMARK; dTARGET;
3415 I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3416
a0d0e21e
LW		 3417 SP = MARK;
3418 PUSHi(value);
3419 RETURN;
3420#else
0322a713 3421 DIE(aTHX_ PL_no_func, "chown");
a0d0e21e
LW		 3422#endif
3423}
3424
3425PP(pp_chroot)
3426{
a0d0e21e 3427#ifdef HAS_CHROOT
76ffd3b9 3428 dSP; dTARGET;
2d8e6c8d 3429 STRLEN n_a;
d05c1ba0 3430 char *tmps = POPpx;
a0d0e21e
LW		 3431 TAINT_PROPER("chroot");
3432 PUSHi( chroot(tmps) >= 0 );
3433 RETURN;
3434#else
cea2e8a9 3435 DIE(aTHX_ PL_no_func, "chroot");
a0d0e21e
LW		 3436#endif
3437}
3438
3439PP(pp_unlink)
3440{
39644a26 3441 dSP; dMARK; dTARGET;
a0d0e21e 3442 I32 value;
533c011a 3443 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 3444 SP = MARK;
3445 PUSHi(value);
3446 RETURN;
3447}
3448
3449PP(pp_chmod)
3450{
39644a26 3451 dSP; dMARK; dTARGET;
a0d0e21e 3452 I32 value;
533c011a 3453 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 3454 SP = MARK;
3455 PUSHi(value);
3456 RETURN;
3457}
3458
3459PP(pp_utime)
3460{
39644a26 3461 dSP; dMARK; dTARGET;
a0d0e21e 3462 I32 value;
533c011a 3463 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 3464 SP = MARK;
3465 PUSHi(value);
3466 RETURN;
3467}
3468
3469PP(pp_rename)
3470{
39644a26 3471 dSP; dTARGET;
a0d0e21e 3472 int anum;
2d8e6c8d 3473 STRLEN n_a;
a0d0e21e 3474
2d8e6c8d
GS		 3475 char *tmps2 = POPpx;
3476 char *tmps = SvPV(TOPs, n_a);
a0d0e21e
LW		 3477 TAINT_PROPER("rename");
3478#ifdef HAS_RENAME
baed7233 3479 anum = PerlLIO_rename(tmps, tmps2);
a0d0e21e 3480#else
6b88bc9c 3481 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
ed969818
W		 3482 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3483 anum = 1;
3484 else {
3654eb6c 3485 if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
ed969818
W		 3486 (void)UNLINK(tmps2);
3487 if (!(anum = link(tmps, tmps2)))
3488 anum = UNLINK(tmps);
3489 }
a0d0e21e
LW		 3490 }
3491#endif
3492 SETi( anum >= 0 );
3493 RETURN;
3494}
3495
3496PP(pp_link)
3497{
1bce926b 3498 dSP;
a0d0e21e 3499#ifdef HAS_LINK
1bce926b 3500 dTARGET;
2d8e6c8d
GS		 3501 STRLEN n_a;
3502 char *tmps2 = POPpx;
3503 char *tmps = SvPV(TOPs, n_a);
a0d0e21e 3504 TAINT_PROPER("link");
146174a9 3505 SETi( PerlLIO_link(tmps, tmps2) >= 0 );
65850d11 3506 RETURN;
a0d0e21e 3507#else
0322a713 3508 DIE(aTHX_ PL_no_func, "link");
a0d0e21e 3509#endif
a0d0e21e
LW		 3510}
3511
3512PP(pp_symlink)
3513{
a0d0e21e 3514#ifdef HAS_SYMLINK
9cad6237 3515 dSP; dTARGET;
2d8e6c8d
GS		 3516 STRLEN n_a;
3517 char *tmps2 = POPpx;
3518 char *tmps = SvPV(TOPs, n_a);
a0d0e21e
LW		 3519 TAINT_PROPER("symlink");
3520 SETi( symlink(tmps, tmps2) >= 0 );
3521 RETURN;
3522#else
cea2e8a9 3523 DIE(aTHX_ PL_no_func, "symlink");
a0d0e21e
LW		 3524#endif
3525}
3526
3527PP(pp_readlink)
3528{
76ffd3b9 3529 dSP;
a0d0e21e 3530#ifdef HAS_SYMLINK
76ffd3b9 3531 dTARGET;
a0d0e21e 3532 char *tmps;
46fc3d4c 3533 char buf[MAXPATHLEN];
a0d0e21e 3534 int len;
2d8e6c8d 3535 STRLEN n_a;
46fc3d4c 3536
fb73857a 3537#ifndef INCOMPLETE_TAINTS
3538 TAINT;
3539#endif
2d8e6c8d 3540 tmps = POPpx;
97dcea33 3541 len = readlink(tmps, buf, sizeof(buf) - 1);
a0d0e21e
LW		 3542 EXTEND(SP, 1);
3543 if (len < 0)
3544 RETPUSHUNDEF;
3545 PUSHp(buf, len);
3546 RETURN;
3547#else
3548 EXTEND(SP, 1);
3549 RETSETUNDEF; /* just pretend it's a normal file */
3550#endif
3551}
3552
3553#if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
ba106d47 3554STATIC int
cea2e8a9 3555S_dooneliner(pTHX_ char *cmd, char *filename)
a0d0e21e 3556{
1e422769 3557 char *save_filename = filename;
3558 char *cmdline;
3559 char *s;
760ac839 3560 PerlIO *myfp;
1e422769 3561 int anum = 1;
a0d0e21e 3562
1e422769 3563 New(666, cmdline, strlen(cmd) + (strlen(filename) * 2) + 10, char);
3564 strcpy(cmdline, cmd);
3565 strcat(cmdline, " ");
3566 for (s = cmdline + strlen(cmdline); *filename; ) {
a0d0e21e
LW		 3567 *s++ = '\\';
3568 *s++ = *filename++;
3569 }
3570 strcpy(s, " 2>&1");
6ad3d225 3571 myfp = PerlProc_popen(cmdline, "r");
1e422769 3572 Safefree(cmdline);
3573
a0d0e21e 3574 if (myfp) {
1e422769 3575 SV *tmpsv = sv_newmortal();
6b88bc9c 3576 /* Need to save/restore 'PL_rs' ?? */
760ac839 3577 s = sv_gets(tmpsv, myfp, 0);
6ad3d225 3578 (void)PerlProc_pclose(myfp);
a0d0e21e 3579 if (s != Nullch) {
1e422769 3580 int e;
3581 for (e = 1;
a0d0e21e 3582#ifdef HAS_SYS_ERRLIST
1e422769 3583 e <= sys_nerr
3584#endif
3585 ; e++)
3586 {
3587 /* you don't see this */
3588 char *errmsg =
3589#ifdef HAS_SYS_ERRLIST
3590 sys_errlist[e]
a0d0e21e 3591#else
1e422769 3592 strerror(e)
a0d0e21e 3593#endif
1e422769 3594 ;
3595 if (!errmsg)
3596 break;
3597 if (instr(s, errmsg)) {
3598 SETERRNO(e,0);
3599 return 0;
3600 }
a0d0e21e 3601 }
748a9306 3602 SETERRNO(0,0);
a0d0e21e
LW		 3603#ifndef EACCES
3604#define EACCES EPERM
3605#endif
1e422769 3606 if (instr(s, "cannot make"))
748a9306 3607 SETERRNO(EEXIST,RMS$_FEX);
1e422769 3608 else if (instr(s, "existing file"))
748a9306 3609 SETERRNO(EEXIST,RMS$_FEX);
1e422769 3610 else if (instr(s, "ile exists"))
748a9306 3611 SETERRNO(EEXIST,RMS$_FEX);
1e422769 3612 else if (instr(s, "non-exist"))
748a9306 3613 SETERRNO(ENOENT,RMS$_FNF);
1e422769 3614 else if (instr(s, "does not exist"))
748a9306 3615 SETERRNO(ENOENT,RMS$_FNF);
1e422769 3616 else if (instr(s, "not empty"))
748a9306 3617 SETERRNO(EBUSY,SS$_DEVOFFLINE);
1e422769 3618 else if (instr(s, "cannot access"))
748a9306 3619 SETERRNO(EACCES,RMS$_PRV);
a0d0e21e 3620 else
748a9306 3621 SETERRNO(EPERM,RMS$_PRV);
a0d0e21e
LW		 3622 return 0;
3623 }
3624 else { /* some mkdirs return no failure indication */
6b88bc9c 3625 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
911d147d 3626 if (PL_op->op_type == OP_RMDIR)
a0d0e21e
LW		 3627 anum = !anum;
3628 if (anum)
748a9306 3629 SETERRNO(0,0);
a0d0e21e 3630 else
748a9306 3631 SETERRNO(EACCES,RMS$_PRV); /* a guess */
a0d0e21e
LW		 3632 }
3633 return anum;
3634 }
3635 else
3636 return 0;
3637}
3638#endif
3639
3640PP(pp_mkdir)
3641{
39644a26 3642 dSP; dTARGET;
5a211162 3643 int mode;
a0d0e21e
LW		 3644#ifndef HAS_MKDIR
3645 int oldumask;
3646#endif
df25ddba 3647 STRLEN len;
5a211162 3648 char *tmps;
df25ddba 3649 bool copy = FALSE;
5a211162
GS		 3650
3651 if (MAXARG > 1)
3652 mode = POPi;
3653 else
3654 mode = 0777;
3655
df25ddba
JH		 3656 tmps = SvPV(TOPs, len);
3657 /* Different operating and file systems take differently to
16ac3975
JH		 3658 * trailing slashes. According to POSIX 1003.1 1996 Edition
3659 * any number of trailing slashes should be allowed.
3660 * Thusly we snip them away so that even non-conforming
3661 * systems are happy. */
3662 /* We should probably do this "filtering" for all
3663 * the functions that expect (potentially) directory names:
3664 * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3665 * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3666 if (len > 1 && tmps[len-1] == '/') {
3667 while (tmps[len] == '/' && len > 1)
3668 len--;
3669 tmps = savepvn(tmps, len);
df25ddba
JH		 3670 copy = TRUE;
3671 }
a0d0e21e
LW		 3672
3673 TAINT_PROPER("mkdir");
3674#ifdef HAS_MKDIR
6ad3d225 3675 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
a0d0e21e
LW		 3676#else
3677 SETi( dooneliner("mkdir", tmps) );
6ad3d225
GS		 3678 oldumask = PerlLIO_umask(0);
3679 PerlLIO_umask(oldumask);
3680 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
a0d0e21e 3681#endif
df25ddba
JH		 3682 if (copy)
3683 Safefree(tmps);
a0d0e21e
LW		 3684 RETURN;
3685}
3686
3687PP(pp_rmdir)
3688{
39644a26 3689 dSP; dTARGET;
a0d0e21e 3690 char *tmps;
2d8e6c8d 3691 STRLEN n_a;
a0d0e21e 3692
2d8e6c8d 3693 tmps = POPpx;
a0d0e21e
LW		 3694 TAINT_PROPER("rmdir");
3695#ifdef HAS_RMDIR
6ad3d225 3696 XPUSHi( PerlDir_rmdir(tmps) >= 0 );
a0d0e21e
LW		 3697#else
3698 XPUSHi( dooneliner("rmdir", tmps) );
3699#endif
3700 RETURN;
3701}
3702
3703/* Directory calls. */
3704
3705PP(pp_open_dir)
3706{
a0d0e21e 3707#if defined(Direntry_t) && defined(HAS_READDIR)
9cad6237 3708 dSP;
2d8e6c8d
GS		 3709 STRLEN n_a;
3710 char *dirname = POPpx;
a0d0e21e
LW		 3711 GV *gv = (GV*)POPs;
3712 register IO *io = GvIOn(gv);
3713
3714 if (!io)
3715 goto nope;
3716
3717 if (IoDIRP(io))
6ad3d225
GS		 3718 PerlDir_close(IoDIRP(io));
3719 if (!(IoDIRP(io) = PerlDir_open(dirname)))
a0d0e21e
LW		 3720 goto nope;
3721
3722 RETPUSHYES;
3723nope:
3724 if (!errno)
748a9306 3725 SETERRNO(EBADF,RMS$_DIR);
a0d0e21e
LW		 3726 RETPUSHUNDEF;
3727#else
cea2e8a9 3728 DIE(aTHX_ PL_no_dir_func, "opendir");
a0d0e21e
LW		 3729#endif
3730}
3731
3732PP(pp_readdir)
3733{
a0d0e21e 3734#if defined(Direntry_t) && defined(HAS_READDIR)
9cad6237 3735 dSP;
fd8cd3a3 3736#if !defined(I_DIRENT) && !defined(VMS)
20ce7b12 3737 Direntry_t *readdir (DIR *);
a0d0e21e
LW		 3738#endif
3739 register Direntry_t *dp;
3740 GV *gv = (GV*)POPs;
3741 register IO *io = GvIOn(gv);
fb73857a 3742 SV *sv;
a0d0e21e
LW		 3743
3744 if (!io || !IoDIRP(io))
3745 goto nope;
3746
3747 if (GIMME == G_ARRAY) {
3748 /*SUPPRESS 560*/
155aba94 3749 while ((dp = (Direntry_t *)PerlDir_read(IoDIRP(io)))) {
a0d0e21e 3750#ifdef DIRNAMLEN
79cb57f6 3751 sv = newSVpvn(dp->d_name, dp->d_namlen);
a0d0e21e 3752#else
fb73857a 3753 sv = newSVpv(dp->d_name, 0);
3754#endif
3755#ifndef INCOMPLETE_TAINTS
26fb8f1f
GS		 3756 if (!(IoFLAGS(io) & IOf_UNTAINT))
3757 SvTAINTED_on(sv);
a0d0e21e 3758#endif
fb73857a 3759 XPUSHs(sv_2mortal(sv));
a0d0e21e
LW		 3760 }
3761 }
3762 else {
6ad3d225 3763 if (!(dp = (Direntry_t *)PerlDir_read(IoDIRP(io))))
a0d0e21e
LW		 3764 goto nope;
3765#ifdef DIRNAMLEN
79cb57f6 3766 sv = newSVpvn(dp->d_name, dp->d_namlen);
a0d0e21e 3767#else
fb73857a 3768 sv = newSVpv(dp->d_name, 0);
a0d0e21e 3769#endif
fb73857a 3770#ifndef INCOMPLETE_TAINTS
26fb8f1f
GS		 3771 if (!(IoFLAGS(io) & IOf_UNTAINT))
3772 SvTAINTED_on(sv);
fb73857a 3773#endif
3774 XPUSHs(sv_2mortal(sv));
a0d0e21e
LW		 3775 }
3776 RETURN;
3777
3778nope:
3779 if (!errno)
748a9306 3780 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 3781 if (GIMME == G_ARRAY)
3782 RETURN;
3783 else
3784 RETPUSHUNDEF;
3785#else
cea2e8a9 3786 DIE(aTHX_ PL_no_dir_func, "readdir");
a0d0e21e
LW		 3787#endif
3788}
3789
3790PP(pp_telldir)
3791{
a0d0e21e 3792#if defined(HAS_TELLDIR) || defined(telldir)
9cad6237 3793 dSP; dTARGET;
968dcd91
JH		 3794 /* XXX does _anyone_ need this? --AD 2/20/1998 */
3795 /* XXX netbsd still seemed to.
3796 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3797 --JHI 1999-Feb-02 */
3798# if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
20ce7b12 3799 long telldir (DIR *);
dfe9444c 3800# endif
a0d0e21e
LW		 3801 GV *gv = (GV*)POPs;
3802 register IO *io = GvIOn(gv);
3803
3804 if (!io || !IoDIRP(io))
3805 goto nope;
3806
6ad3d225 3807 PUSHi( PerlDir_tell(IoDIRP(io)) );
a0d0e21e
LW		 3808 RETURN;
3809nope:
3810 if (!errno)
748a9306 3811 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 3812 RETPUSHUNDEF;
3813#else
cea2e8a9 3814 DIE(aTHX_ PL_no_dir_func, "telldir");
a0d0e21e
LW		 3815#endif
3816}
3817
3818PP(pp_seekdir)
3819{
a0d0e21e 3820#if defined(HAS_SEEKDIR) || defined(seekdir)
9cad6237 3821 dSP;
a0d0e21e
LW		 3822 long along = POPl;
3823 GV *gv = (GV*)POPs;
3824 register IO *io = GvIOn(gv);
3825
3826 if (!io || !IoDIRP(io))
3827 goto nope;
3828
6ad3d225 3829 (void)PerlDir_seek(IoDIRP(io), along);
a0d0e21e
LW		 3830
3831 RETPUSHYES;
3832nope:
3833 if (!errno)
748a9306 3834 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 3835 RETPUSHUNDEF;
3836#else
cea2e8a9 3837 DIE(aTHX_ PL_no_dir_func, "seekdir");
a0d0e21e
LW		 3838#endif
3839}
3840
3841PP(pp_rewinddir)
3842{
a0d0e21e 3843#if defined(HAS_REWINDDIR) || defined(rewinddir)
9cad6237 3844 dSP;
a0d0e21e
LW		 3845 GV *gv = (GV*)POPs;
3846 register IO *io = GvIOn(gv);
3847
3848 if (!io || !IoDIRP(io))
3849 goto nope;
3850
6ad3d225 3851 (void)PerlDir_rewind(IoDIRP(io));
a0d0e21e
LW		 3852 RETPUSHYES;
3853nope:
3854 if (!errno)
748a9306 3855 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 3856 RETPUSHUNDEF;
3857#else
cea2e8a9 3858 DIE(aTHX_ PL_no_dir_func, "rewinddir");
a0d0e21e
LW		 3859#endif
3860}
3861
3862PP(pp_closedir)
3863{
a0d0e21e 3864#if defined(Direntry_t) && defined(HAS_READDIR)
9cad6237 3865 dSP;
a0d0e21e
LW		 3866 GV *gv = (GV*)POPs;
3867 register IO *io = GvIOn(gv);
3868
3869 if (!io || !IoDIRP(io))
3870 goto nope;
3871
3872#ifdef VOID_CLOSEDIR
6ad3d225 3873 PerlDir_close(IoDIRP(io));
a0d0e21e 3874#else
6ad3d225 3875 if (PerlDir_close(IoDIRP(io)) < 0) {
748a9306 3876 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
a0d0e21e 3877 goto nope;
748a9306 3878 }
a0d0e21e
LW		 3879#endif
3880 IoDIRP(io) = 0;
3881
3882 RETPUSHYES;
3883nope:
3884 if (!errno)
a385c4e7 3885 SETERRNO(EBADF,VMS_RMS_IFI);
a0d0e21e
LW		 3886 RETPUSHUNDEF;
3887#else
cea2e8a9 3888 DIE(aTHX_ PL_no_dir_func, "closedir");
a0d0e21e
LW		 3889#endif
3890}
3891
3892/* Process control. */
3893
3894PP(pp_fork)
3895{
44a8e56a 3896#ifdef HAS_FORK
39644a26 3897 dSP; dTARGET;
761237fe 3898 Pid_t childpid;
a0d0e21e
LW		 3899 GV *tmpgv;
3900
3901 EXTEND(SP, 1);
45bc9206 3902 PERL_FLUSHALL_FOR_CHILD;
52e18b1f 3903 childpid = PerlProc_fork();
a0d0e21e
LW		 3904 if (childpid < 0)
3905 RETSETUNDEF;
3906 if (!childpid) {
3907 /*SUPPRESS 560*/
155aba94 3908 if ((tmpgv = gv_fetchpv("$", TRUE, SVt_PV)))
146174a9 3909 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3280af22 3910 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
a0d0e21e
LW		 3911 }
3912 PUSHi(childpid);
3913 RETURN;
3914#else
146174a9 3915# if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
39644a26 3916 dSP; dTARGET;
146174a9
CB		 3917 Pid_t childpid;
3918
3919 EXTEND(SP, 1);
3920 PERL_FLUSHALL_FOR_CHILD;
3921 childpid = PerlProc_fork();
60fa28ff
GS		 3922 if (childpid == -1)
3923 RETSETUNDEF;
146174a9
CB		 3924 PUSHi(childpid);
3925 RETURN;
3926# else
0322a713 3927 DIE(aTHX_ PL_no_func, "fork");
146174a9 3928# endif
a0d0e21e
LW		 3929#endif
3930}
3931
3932PP(pp_wait)
3933{
301e8125 3934#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
39644a26 3935 dSP; dTARGET;
761237fe 3936 Pid_t childpid;
a0d0e21e 3937 int argflags;
a0d0e21e 3938
0a0ada86 3939#ifdef PERL_OLD_SIGNALS
44a8e56a 3940 childpid = wait4pid(-1, &argflags, 0);
0a0ada86
NIS		 3941#else
3942 while ((childpid = wait4pid(-1, &argflags, 0)) == -1 && errno == EINTR) {
3943 PERL_ASYNC_CHECK();
3944 }
3945#endif
68a29c53
GS		 3946# if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3947 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
3948 STATUS_NATIVE_SET((childpid && childpid != -1) ? argflags : -1);
3949# else
f86702cc 3950 STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
68a29c53 3951# endif
44a8e56a 3952 XPUSHi(childpid);
a0d0e21e
LW		 3953 RETURN;
3954#else
0322a713 3955 DIE(aTHX_ PL_no_func, "wait");
a0d0e21e
LW		 3956#endif
3957}
3958
3959PP(pp_waitpid)
3960{
301e8125 3961#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
39644a26 3962 dSP; dTARGET;
761237fe 3963 Pid_t childpid;
a0d0e21e
LW		 3964 int optype;
3965 int argflags;
a0d0e21e 3966
a0d0e21e
LW		 3967 optype = POPi;
3968 childpid = TOPi;
0a0ada86 3969#ifdef PERL_OLD_SIGNALS
a0d0e21e 3970 childpid = wait4pid(childpid, &argflags, optype);
0a0ada86
NIS		 3971#else
3972 while ((childpid = wait4pid(childpid, &argflags, optype)) == -1 && errno == EINTR) {
3973 PERL_ASYNC_CHECK();
3974 }
3975#endif
68a29c53
GS		 3976# if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3977 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
3978 STATUS_NATIVE_SET((childpid && childpid != -1) ? argflags : -1);
3979# else
f86702cc 3980 STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
68a29c53 3981# endif
44a8e56a 3982 SETi(childpid);
a0d0e21e
LW		 3983 RETURN;
3984#else
0322a713 3985 DIE(aTHX_ PL_no_func, "waitpid");
a0d0e21e
LW		 3986#endif
3987}
3988
3989PP(pp_system)
3990{
39644a26 3991 dSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e 3992 I32 value;
2d8e6c8d 3993 STRLEN n_a;
76ffd3b9 3994 int result;
e7766f89
JH		 3995 int pp[2];
3996 I32 did_pipes = 0;
a0d0e21e 3997
a0d0e21e 3998 if (SP - MARK == 1) {
3280af22 3999 if (PL_tainting) {
516a5887 4000 (void)SvPV_nolen(TOPs); /* stringify for taint check */
a0d0e21e
LW		 4001 TAINT_ENV();
4002 TAINT_PROPER("system");
4003 }
4004 }
45bc9206 4005 PERL_FLUSHALL_FOR_CHILD;
273b0206 4006#if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
d7e492a4
JH		 4007 {
4008 Pid_t childpid;
4009 int status;
4010 Sigsave_t ihand,qhand; /* place to save signals during system() */
4011
4012 if (PerlProc_pipe(pp) >= 0)
4013 did_pipes = 1;
52e18b1f 4014 while ((childpid = PerlProc_fork()) == -1) {
d7e492a4
JH		 4015 if (errno != EAGAIN) {
4016 value = -1;
4017 SP = ORIGMARK;
4018 PUSHi(value);
4019 if (did_pipes) {
4020 PerlLIO_close(pp[0]);
4021 PerlLIO_close(pp[1]);
4022 }
4023 RETURN;
4024 }
4025 sleep(5);
4026 }
4027 if (childpid > 0) {
4028 if (did_pipes)
4029 PerlLIO_close(pp[1]);
64ca3a65 4030#ifndef PERL_MICRO
d7e492a4
JH		 4031 rsignal_save(SIGINT, SIG_IGN, &ihand);
4032 rsignal_save(SIGQUIT, SIG_IGN, &qhand);
64ca3a65 4033#endif
d7e492a4
JH		 4034 do {
4035 result = wait4pid(childpid, &status, 0);
4036 } while (result == -1 && errno == EINTR);
64ca3a65 4037#ifndef PERL_MICRO
d7e492a4
JH		 4038 (void)rsignal_restore(SIGINT, &ihand);
4039 (void)rsignal_restore(SIGQUIT, &qhand);
4040#endif
4041 STATUS_NATIVE_SET(result == -1 ? -1 : status);
52e18b1f 4042 do_execfree(); /* free any memory child malloced on fork */
d7e492a4
JH		 4043 SP = ORIGMARK;
4044 if (did_pipes) {
4045 int errkid;
4046 int n = 0, n1;
4047
4048 while (n < sizeof(int)) {
4049 n1 = PerlLIO_read(pp[0],
4050 (void*)(((char*)&errkid)+n),
4051 (sizeof(int)) - n);
4052 if (n1 <= 0)
4053 break;
4054 n += n1;
4055 }
4056 PerlLIO_close(pp[0]);
4057 if (n) { /* Error */
4058 if (n != sizeof(int))
4059 DIE(aTHX_ "panic: kid popen errno read");
4060 errno = errkid; /* Propagate errno from kid */
4061 STATUS_CURRENT = -1;
4062 }
4063 }
4064 PUSHi(STATUS_CURRENT);
4065 RETURN;
4066 }
4067 if (did_pipes) {
4068 PerlLIO_close(pp[0]);
d5a9bfb0 4069#if defined(HAS_FCNTL) && defined(F_SETFD)
d7e492a4 4070 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
d5a9bfb0 4071#endif
d7e492a4 4072 }
d5a9bfb0 4073 }
533c011a 4074 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e 4075 SV *really = *++MARK;
d5a9bfb0 4076 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
a0d0e21e
LW		 4077 }
4078 else if (SP - MARK != 1)
d5a9bfb0 4079 value = (I32)do_aexec5(Nullsv, MARK, SP, pp[1], did_pipes);
a0d0e21e 4080 else {
d5a9bfb0 4081 value = (I32)do_exec3(SvPVx(sv_mortalcopy(*SP), n_a), pp[1], did_pipes);
a0d0e21e 4082 }
6ad3d225 4083 PerlProc__exit(-1);
c3293030 4084#else /* ! FORK or VMS or OS/2 */
922b1888
GS		 4085 PL_statusvalue = 0;
4086 result = 0;
911d147d 4087 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e 4088 SV *really = *++MARK;
c5be433b 4089 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
a0d0e21e
LW		 4090 }
4091 else if (SP - MARK != 1)
c5be433b 4092 value = (I32)do_aspawn(Nullsv, (void **)MARK, (void **)SP);
a0d0e21e 4093 else {
c5be433b 4094 value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
a0d0e21e 4095 }
922b1888
GS		 4096 if (PL_statusvalue == -1) /* hint that value must be returned as is */
4097 result = 1;
f86702cc 4098 STATUS_NATIVE_SET(value);
a0d0e21e
LW		 4099 do_execfree();
4100 SP = ORIGMARK;
922b1888 4101 PUSHi(result ? value : STATUS_CURRENT);
a0d0e21e
LW		 4102#endif /* !FORK or VMS */
4103 RETURN;
4104}
4105
4106PP(pp_exec)
4107{
39644a26 4108 dSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e 4109 I32 value;
2d8e6c8d 4110 STRLEN n_a;
a0d0e21e 4111
45bc9206 4112 PERL_FLUSHALL_FOR_CHILD;
533c011a 4113 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e
LW		 4114 SV *really = *++MARK;
4115 value = (I32)do_aexec(really, MARK, SP);
4116 }
4117 else if (SP - MARK != 1)
4118#ifdef VMS
4119 value = (I32)vms_do_aexec(Nullsv, MARK, SP);
4120#else
092bebab
JH		 4121# ifdef __OPEN_VM
4122 {
c5be433b 4123 (void ) do_aspawn(Nullsv, MARK, SP);
092bebab
JH		 4124 value = 0;
4125 }
4126# else
a0d0e21e 4127 value = (I32)do_aexec(Nullsv, MARK, SP);
092bebab 4128# endif
a0d0e21e
LW		 4129#endif
4130 else {
3280af22 4131 if (PL_tainting) {
516a5887 4132 (void)SvPV_nolen(*SP); /* stringify for taint check */
a0d0e21e
LW		 4133 TAINT_ENV();
4134 TAINT_PROPER("exec");
4135 }
4136#ifdef VMS
2d8e6c8d 4137 value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
a0d0e21e 4138#else
092bebab 4139# ifdef __OPEN_VM
c5be433b 4140 (void) do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
092bebab
JH		 4141 value = 0;
4142# else
2d8e6c8d 4143 value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
092bebab 4144# endif
a0d0e21e
LW		 4145#endif
4146 }
146174a9 4147
a0d0e21e
LW		 4148 SP = ORIGMARK;
4149 PUSHi(value);
4150 RETURN;
4151}
4152
4153PP(pp_kill)
4154{
9cad6237 4155#ifdef HAS_KILL
39644a26 4156 dSP; dMARK; dTARGET;
a0d0e21e 4157 I32 value;
533c011a 4158 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 4159 SP = MARK;
4160 PUSHi(value);
4161 RETURN;
4162#else
0322a713 4163 DIE(aTHX_ PL_no_func, "kill");
a0d0e21e
LW		 4164#endif
4165}
4166
4167PP(pp_getppid)
4168{
4169#ifdef HAS_GETPPID
39644a26 4170 dSP; dTARGET;
a0d0e21e
LW		 4171 XPUSHi( getppid() );
4172 RETURN;
4173#else
cea2e8a9 4174 DIE(aTHX_ PL_no_func, "getppid");
a0d0e21e
LW		 4175#endif
4176}
4177
4178PP(pp_getpgrp)
4179{
4180#ifdef HAS_GETPGRP
39644a26 4181 dSP; dTARGET;
d8a83dd3 4182 Pid_t pid;
9853a804 4183 Pid_t pgrp;
a0d0e21e
LW		 4184
4185 if (MAXARG < 1)
4186 pid = 0;
4187 else
4188 pid = SvIVx(POPs);
c3293030 4189#ifdef BSD_GETPGRP
9853a804 4190 pgrp = (I32)BSD_GETPGRP(pid);
a0d0e21e 4191#else
146174a9 4192 if (pid != 0 && pid != PerlProc_getpid())
cea2e8a9 4193 DIE(aTHX_ "POSIX getpgrp can't take an argument");
9853a804 4194 pgrp = getpgrp();
a0d0e21e 4195#endif
9853a804 4196 XPUSHi(pgrp);
a0d0e21e
LW		 4197 RETURN;
4198#else
cea2e8a9 4199 DIE(aTHX_ PL_no_func, "getpgrp()");
a0d0e21e
LW		 4200#endif
4201}
4202
4203PP(pp_setpgrp)
4204{
4205#ifdef HAS_SETPGRP
39644a26 4206 dSP; dTARGET;
d8a83dd3
JH		 4207 Pid_t pgrp;
4208 Pid_t pid;
a0d0e21e
LW		 4209 if (MAXARG < 2) {
4210 pgrp = 0;
4211 pid = 0;
4212 }
4213 else {
4214 pgrp = POPi;
4215 pid = TOPi;
4216 }
4217
4218 TAINT_PROPER("setpgrp");
c3293030
IZ		 4219#ifdef BSD_SETPGRP
4220 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
a0d0e21e 4221#else
146174a9
CB		 4222 if ((pgrp != 0 && pgrp != PerlProc_getpid())
4223 || (pid != 0 && pid != PerlProc_getpid()))
4224 {
4225 DIE(aTHX_ "setpgrp can't take arguments");
4226 }
a0d0e21e
LW		 4227 SETi( setpgrp() >= 0 );
4228#endif /* USE_BSDPGRP */
4229 RETURN;
4230#else
cea2e8a9 4231 DIE(aTHX_ PL_no_func, "setpgrp()");
a0d0e21e
LW		 4232#endif
4233}
4234
4235PP(pp_getpriority)
4236{
a0d0e21e 4237#ifdef HAS_GETPRIORITY
9cad6237 4238 dSP; dTARGET;
d05c1ba0
JH		 4239 int who = POPi;
4240 int which = TOPi;
a0d0e21e
LW		 4241 SETi( getpriority(which, who) );
4242 RETURN;
4243#else
cea2e8a9 4244 DIE(aTHX_ PL_no_func, "getpriority()");
a0d0e21e
LW		 4245#endif
4246}
4247
4248PP(pp_setpriority)
4249{
a0d0e21e 4250#ifdef HAS_SETPRIORITY
9cad6237 4251 dSP; dTARGET;
d05c1ba0
JH		 4252 int niceval = POPi;
4253 int who = POPi;
4254 int which = TOPi;
a0d0e21e
LW		 4255 TAINT_PROPER("setpriority");
4256 SETi( setpriority(which, who, niceval) >= 0 );
4257 RETURN;
4258#else
cea2e8a9 4259 DIE(aTHX_ PL_no_func, "setpriority()");
a0d0e21e
LW		 4260#endif
4261}
4262
4263/* Time calls. */
4264
4265PP(pp_time)
4266{
39644a26 4267 dSP; dTARGET;
cbdc8872 4268#ifdef BIG_TIME
4269 XPUSHn( time(Null(Time_t*)) );
4270#else
a0d0e21e 4271 XPUSHi( time(Null(Time_t*)) );
cbdc8872 4272#endif
a0d0e21e
LW		 4273 RETURN;
4274}
4275
cd52b7b2 4276/* XXX The POSIX name is CLK_TCK; it is to be preferred
4277 to HZ. Probably. For now, assume that if the system
4278 defines HZ, it does so correctly. (Will this break
4279 on VMS?)
4280 Probably we ought to use _sysconf(_SC_CLK_TCK), if
4281 it's supported. --AD 9/96.
4282*/
4283
a0d0e21e 4284#ifndef HZ
cd52b7b2 4285# ifdef CLK_TCK
4286# define HZ CLK_TCK
4287# else
4288# define HZ 60
4289# endif
a0d0e21e
LW		 4290#endif
4291
4292PP(pp_tms)
4293{
9cad6237 4294#ifdef HAS_TIMES
39644a26 4295 dSP;
a0d0e21e 4296 EXTEND(SP, 4);
a0d0e21e 4297#ifndef VMS
3280af22 4298 (void)PerlProc_times(&PL_timesbuf);
a0d0e21e 4299#else
6b88bc9c 4300 (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
76e3520e
GS		 4301 /* struct tms, though same data */
4302 /* is returned. */
a0d0e21e
LW		 4303#endif
4304
65202027 4305 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_utime)/HZ)));
a0d0e21e 4306 if (GIMME == G_ARRAY) {
65202027
DS		 4307 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_stime)/HZ)));
4308 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cutime)/HZ)));
4309 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cstime)/HZ)));
a0d0e21e
LW		 4310 }
4311 RETURN;
9cad6237
JH		 4312#else
4313 DIE(aTHX_ "times not implemented");
55497cff 4314#endif /* HAS_TIMES */
a0d0e21e
LW		 4315}
4316
4317PP(pp_localtime)
4318{
cea2e8a9 4319 return pp_gmtime();
a0d0e21e
LW		 4320}
4321
4322PP(pp_gmtime)
4323{
39644a26 4324 dSP;
a0d0e21e
LW		 4325 Time_t when;
4326 struct tm *tmbuf;
4327 static char *dayname[] = {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4328 static char *monname[] = {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4329 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4330
4331 if (MAXARG < 1)
4332 (void)time(&when);
4333 else
cbdc8872 4334#ifdef BIG_TIME
4335 when = (Time_t)SvNVx(POPs);
4336#else
a0d0e21e 4337 when = (Time_t)SvIVx(POPs);
cbdc8872 4338#endif
a0d0e21e 4339
533c011a 4340 if (PL_op->op_type == OP_LOCALTIME)
a0d0e21e
LW		 4341 tmbuf = localtime(&when);
4342 else
4343 tmbuf = gmtime(&when);
4344
a0d0e21e 4345 if (GIMME != G_ARRAY) {
46fc3d4c 4346 SV *tsv;
9a5ff6d9
AB		 4347 EXTEND(SP, 1);
4348 EXTEND_MORTAL(1);
a0d0e21e
LW		 4349 if (!tmbuf)
4350 RETPUSHUNDEF;
be28567c 4351 tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %d",
f5a29b03
RB		 4352 dayname[tmbuf->tm_wday],
4353 monname[tmbuf->tm_mon],
be28567c
GS		 4354 tmbuf->tm_mday,
4355 tmbuf->tm_hour,
4356 tmbuf->tm_min,
4357 tmbuf->tm_sec,
4358 tmbuf->tm_year + 1900);
46fc3d4c 4359 PUSHs(sv_2mortal(tsv));
a0d0e21e
LW		 4360 }
4361 else if (tmbuf) {
9a5ff6d9
AB		 4362 EXTEND(SP, 9);
4363 EXTEND_MORTAL(9);
4364 PUSHs(sv_2mortal(newSViv(tmbuf->tm_sec)));
c6419e06
JH		 4365 PUSHs(sv_2mortal(newSViv(tmbuf->tm_min)));
4366 PUSHs(sv_2mortal(newSViv(tmbuf->tm_hour)));
4367 PUSHs(sv_2mortal(newSViv(tmbuf->tm_mday)));
4368 PUSHs(sv_2mortal(newSViv(tmbuf->tm_mon)));
4369 PUSHs(sv_2mortal(newSViv(tmbuf->tm_year)));
4370 PUSHs(sv_2mortal(newSViv(tmbuf->tm_wday)));
4371 PUSHs(sv_2mortal(newSViv(tmbuf->tm_yday)));
4372 PUSHs(sv_2mortal(newSViv(tmbuf->tm_isdst)));
a0d0e21e
LW		 4373 }
4374 RETURN;
4375}
4376
4377PP(pp_alarm)
4378{
9cad6237 4379#ifdef HAS_ALARM
39644a26 4380 dSP; dTARGET;
a0d0e21e 4381 int anum;
a0d0e21e
LW		 4382 anum = POPi;
4383 anum = alarm((unsigned int)anum);
4384 EXTEND(SP, 1);
4385 if (anum < 0)
4386 RETPUSHUNDEF;
c6419e06 4387 PUSHi(anum);
a0d0e21e
LW		 4388 RETURN;
4389#else
0322a713 4390 DIE(aTHX_ PL_no_func, "alarm");
a0d0e21e
LW		 4391#endif
4392}
4393
4394PP(pp_sleep)
4395{
39644a26 4396 dSP; dTARGET;
a0d0e21e
LW		 4397 I32 duration;
4398 Time_t lasttime;
4399 Time_t when;
4400
4401 (void)time(&lasttime);
4402 if (MAXARG < 1)
76e3520e 4403 PerlProc_pause();
a0d0e21e
LW		 4404 else {
4405 duration = POPi;
76e3520e 4406 PerlProc_sleep((unsigned int)duration);
a0d0e21e
LW		 4407 }
4408 (void)time(&when);
4409 XPUSHi(when - lasttime);
4410 RETURN;
4411}
4412
4413/* Shared memory. */
4414
4415PP(pp_shmget)
4416{
cea2e8a9 4417 return pp_semget();
a0d0e21e
LW		 4418}
4419
4420PP(pp_shmctl)
4421{
cea2e8a9 4422 return pp_semctl();
a0d0e21e
LW		 4423}
4424
4425PP(pp_shmread)
4426{
cea2e8a9 4427 return pp_shmwrite();
a0d0e21e
LW		 4428}
4429
4430PP(pp_shmwrite)
4431{
4432#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
39644a26 4433 dSP; dMARK; dTARGET;
533c011a 4434 I32 value = (I32)(do_shmio(PL_op->op_type, MARK, SP) >= 0);
a0d0e21e
LW		 4435 SP = MARK;
4436 PUSHi(value);
4437 RETURN;
4438#else
cea2e8a9 4439 return pp_semget();
a0d0e21e
LW		 4440#endif
4441}
4442
4443/* Message passing. */
4444
4445PP(pp_msgget)
4446{
cea2e8a9 4447 return pp_semget();
a0d0e21e
LW		 4448}
4449
4450PP(pp_msgctl)
4451{
cea2e8a9 4452 return pp_semctl();
a0d0e21e
LW		 4453}
4454
4455PP(pp_msgsnd)
4456{
4457#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
39644a26 4458 dSP; dMARK; dTARGET;
a0d0e21e
LW		 4459 I32 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4460 SP = MARK;
4461 PUSHi(value);
4462 RETURN;
4463#else
cea2e8a9 4464 return pp_semget();
a0d0e21e
LW		 4465#endif
4466}
4467
4468PP(pp_msgrcv)
4469{
4470#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
39644a26 4471 dSP; dMARK; dTARGET;
a0d0e21e
LW		 4472 I32 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4473 SP = MARK;
4474 PUSHi(value);
4475 RETURN;
4476#else
cea2e8a9 4477 return pp_semget();
a0d0e21e
LW		 4478#endif
4479}
4480
4481/* Semaphores. */
4482
4483PP(pp_semget)
4484{
4485#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
39644a26 4486 dSP; dMARK; dTARGET;
533c011a 4487 int anum = do_ipcget(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 4488 SP = MARK;
4489 if (anum == -1)
4490 RETPUSHUNDEF;
4491 PUSHi(anum);
4492 RETURN;
4493#else
cea2e8a9 4494 DIE(aTHX_ "System V IPC is not implemented on this machine");
a0d0e21e
LW		 4495#endif
4496}
4497
4498PP(pp_semctl)
4499{
4500#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
39644a26 4501 dSP; dMARK; dTARGET;
533c011a 4502 int anum = do_ipcctl(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 4503 SP = MARK;
4504 if (anum == -1)
4505 RETSETUNDEF;
4506 if (anum != 0) {
4507 PUSHi(anum);
4508 }
4509 else {
8903cb82 4510 PUSHp(zero_but_true, ZBTLEN);
a0d0e21e
LW		 4511 }
4512 RETURN;
4513#else
cea2e8a9 4514 return pp_semget();
a0d0e21e
LW		 4515#endif
4516}
4517
4518PP(pp_semop)
4519{
4520#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
39644a26 4521 dSP; dMARK; dTARGET;
a0d0e21e
LW		 4522 I32 value = (I32)(do_semop(MARK, SP) >= 0);
4523 SP = MARK;
4524 PUSHi(value);
4525 RETURN;
4526#else
cea2e8a9 4527 return pp_semget();
a0d0e21e
LW		 4528#endif
4529}
4530
4531/* Get system info. */
4532
4533PP(pp_ghbyname)
4534{
693762b4 4535#ifdef HAS_GETHOSTBYNAME
cea2e8a9 4536 return pp_ghostent();
a0d0e21e 4537#else
cea2e8a9 4538 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
a0d0e21e
LW		 4539#endif
4540}
4541
4542PP(pp_ghbyaddr)
4543{
693762b4 4544#ifdef HAS_GETHOSTBYADDR
cea2e8a9 4545 return pp_ghostent();
a0d0e21e 4546#else
cea2e8a9 4547 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
a0d0e21e
LW		 4548#endif
4549}
4550
4551PP(pp_ghostent)
4552{
693762b4 4553#if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
9cad6237 4554 dSP;
533c011a 4555 I32 which = PL_op->op_type;
a0d0e21e
LW		 4556 register char **elem;
4557 register SV *sv;
dc45a647 4558#ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4599a1de
JH		 4559 struct hostent *PerlSock_gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4560 struct hostent *PerlSock_gethostbyname(Netdb_name_t);
6ad3d225 4561 struct hostent *PerlSock_gethostent(void);
a0d0e21e
LW		 4562#endif
4563 struct hostent *hent;
4564 unsigned long len;
2d8e6c8d 4565 STRLEN n_a;
a0d0e21e
LW		 4566
4567 EXTEND(SP, 10);
dc45a647
MB		 4568 if (which == OP_GHBYNAME)
4569#ifdef HAS_GETHOSTBYNAME
595ae481 4570 hent = PerlSock_gethostbyname(POPpbytex);
dc45a647 4571#else
cea2e8a9 4572 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
dc45a647 4573#endif
a0d0e21e 4574 else if (which == OP_GHBYADDR) {
dc45a647 4575#ifdef HAS_GETHOSTBYADDR
a0d0e21e 4576 int addrtype = POPi;
748a9306 4577 SV *addrsv = POPs;
a0d0e21e 4578 STRLEN addrlen;
595ae481 4579 Netdb_host_t addr = (Netdb_host_t) SvPVbyte(addrsv, addrlen);
a0d0e21e 4580
4599a1de 4581 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
dc45a647 4582#else
cea2e8a9 4583 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
dc45a647 4584#endif
a0d0e21e
LW		 4585 }
4586 else
4587#ifdef HAS_GETHOSTENT
6ad3d225 4588 hent = PerlSock_gethostent();
a0d0e21e 4589#else
cea2e8a9 4590 DIE(aTHX_ PL_no_sock_func, "gethostent");
a0d0e21e
LW		 4591#endif
4592
4593#ifdef HOST_NOT_FOUND
4594 if (!hent)
f86702cc 4595 STATUS_NATIVE_SET(h_errno);
a0d0e21e
LW		 4596#endif
4597
4598 if (GIMME != G_ARRAY) {
4599 PUSHs(sv = sv_newmortal());
4600 if (hent) {
4601 if (which == OP_GHBYNAME) {
fd0af264 4602 if (hent->h_addr)
4603 sv_setpvn(sv, hent->h_addr, hent->h_length);
a0d0e21e
LW		 4604 }
4605 else
4606 sv_setpv(sv, (char*)hent->h_name);
4607 }
4608 RETURN;
4609 }
4610
4611 if (hent) {
3280af22 4612 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4613 sv_setpv(sv, (char*)hent->h_name);
3280af22 4614 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 4615 for (elem = hent->h_aliases; elem && *elem; elem++) {
4616 sv_catpv(sv, *elem);
4617 if (elem[1])
4618 sv_catpvn(sv, " ", 1);
4619 }
3280af22 4620 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4621 sv_setiv(sv, (IV)hent->h_addrtype);
3280af22 4622 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4623 len = hent->h_length;
1e422769 4624 sv_setiv(sv, (IV)len);
a0d0e21e
LW		 4625#ifdef h_addr
4626 for (elem = hent->h_addr_list; elem && *elem; elem++) {
3280af22 4627 XPUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 4628 sv_setpvn(sv, *elem, len);
4629 }
4630#else
6b88bc9c 4631 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
fd0af264 4632 if (hent->h_addr)
4633 sv_setpvn(sv, hent->h_addr, len);
a0d0e21e
LW		 4634#endif /* h_addr */
4635 }
4636 RETURN;
4637#else
cea2e8a9 4638 DIE(aTHX_ PL_no_sock_func, "gethostent");
a0d0e21e
LW		 4639#endif
4640}
4641
4642PP(pp_gnbyname)
4643{
693762b4 4644#ifdef HAS_GETNETBYNAME
cea2e8a9 4645 return pp_gnetent();
a0d0e21e 4646#else
cea2e8a9 4647 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
a0d0e21e
LW		 4648#endif
4649}
4650
4651PP(pp_gnbyaddr)
4652{
693762b4 4653#ifdef HAS_GETNETBYADDR
cea2e8a9 4654 return pp_gnetent();
a0d0e21e 4655#else
cea2e8a9 4656 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
a0d0e21e
LW		 4657#endif
4658}
4659
4660PP(pp_gnetent)
4661{
693762b4 4662#if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
9cad6237 4663 dSP;
533c011a 4664 I32 which = PL_op->op_type;
a0d0e21e
LW		 4665 register char **elem;
4666 register SV *sv;
dc45a647
MB		 4667#ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4668 struct netent *PerlSock_getnetbyaddr(Netdb_net_t, int);
4669 struct netent *PerlSock_getnetbyname(Netdb_name_t);
4670 struct netent *PerlSock_getnetent(void);
8ac85365 4671#endif
a0d0e21e 4672 struct netent *nent;
2d8e6c8d 4673 STRLEN n_a;
a0d0e21e
LW		 4674
4675 if (which == OP_GNBYNAME)
dc45a647 4676#ifdef HAS_GETNETBYNAME
42e0c139 4677 nent = PerlSock_getnetbyname(POPpbytex);
dc45a647 4678#else
cea2e8a9 4679 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
dc45a647 4680#endif
a0d0e21e 4681 else if (which == OP_GNBYADDR) {
dc45a647 4682#ifdef HAS_GETNETBYADDR
a0d0e21e 4683 int addrtype = POPi;
3bb7c1b4 4684 Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
76e3520e 4685 nent = PerlSock_getnetbyaddr(addr, addrtype);
dc45a647 4686#else
cea2e8a9 4687 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
dc45a647 4688#endif
a0d0e21e
LW		 4689 }
4690 else
dc45a647 4691#ifdef HAS_GETNETENT
76e3520e 4692 nent = PerlSock_getnetent();
dc45a647 4693#else
cea2e8a9 4694 DIE(aTHX_ PL_no_sock_func, "getnetent");
dc45a647 4695#endif
a0d0e21e
LW		 4696
4697 EXTEND(SP, 4);
4698 if (GIMME != G_ARRAY) {
4699 PUSHs(sv = sv_newmortal());
4700 if (nent) {
4701 if (which == OP_GNBYNAME)
1e422769 4702 sv_setiv(sv, (IV)nent->n_net);
a0d0e21e
LW		 4703 else
4704 sv_setpv(sv, nent->n_name);
4705 }
4706 RETURN;
4707 }
4708
4709 if (nent) {
3280af22 4710 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4711 sv_setpv(sv, nent->n_name);
3280af22 4712 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 4713 for (elem = nent->n_aliases; elem && *elem; elem++) {
a0d0e21e
LW		 4714 sv_catpv(sv, *elem);
4715 if (elem[1])
4716 sv_catpvn(sv, " ", 1);
4717 }
3280af22 4718 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4719 sv_setiv(sv, (IV)nent->n_addrtype);
3280af22 4720 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4721 sv_setiv(sv, (IV)nent->n_net);
a0d0e21e
LW		 4722 }
4723
4724 RETURN;
4725#else
cea2e8a9 4726 DIE(aTHX_ PL_no_sock_func, "getnetent");
a0d0e21e
LW		 4727#endif
4728}
4729
4730PP(pp_gpbyname)
4731{
693762b4 4732#ifdef HAS_GETPROTOBYNAME
cea2e8a9 4733 return pp_gprotoent();
a0d0e21e 4734#else
cea2e8a9 4735 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
a0d0e21e
LW		 4736#endif
4737}
4738
4739PP(pp_gpbynumber)
4740{
693762b4 4741#ifdef HAS_GETPROTOBYNUMBER
cea2e8a9 4742 return pp_gprotoent();
a0d0e21e 4743#else
cea2e8a9 4744 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
a0d0e21e
LW		 4745#endif
4746}
4747
4748PP(pp_gprotoent)
4749{
693762b4 4750#if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
9cad6237 4751 dSP;
533c011a 4752 I32 which = PL_op->op_type;
a0d0e21e 4753 register char **elem;
301e8125 4754 register SV *sv;
dc45a647 4755#ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4599a1de 4756 struct protoent *PerlSock_getprotobyname(Netdb_name_t);
6ad3d225
GS		 4757 struct protoent *PerlSock_getprotobynumber(int);
4758 struct protoent *PerlSock_getprotoent(void);
8ac85365 4759#endif
a0d0e21e 4760 struct protoent *pent;
2d8e6c8d 4761 STRLEN n_a;
a0d0e21e
LW		 4762
4763 if (which == OP_GPBYNAME)
e5c9fcd0 4764#ifdef HAS_GETPROTOBYNAME
42e0c139 4765 pent = PerlSock_getprotobyname(POPpbytex);
e5c9fcd0 4766#else
cea2e8a9 4767 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
e5c9fcd0 4768#endif
a0d0e21e 4769 else if (which == OP_GPBYNUMBER)
e5c9fcd0 4770#ifdef HAS_GETPROTOBYNUMBER
6ad3d225 4771 pent = PerlSock_getprotobynumber(POPi);
e5c9fcd0 4772#else
cea2e8a9 4773 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
e5c9fcd0 4774#endif
a0d0e21e 4775 else
e5c9fcd0 4776#ifdef HAS_GETPROTOENT
6ad3d225 4777 pent = PerlSock_getprotoent();
e5c9fcd0 4778#else
cea2e8a9 4779 DIE(aTHX_ PL_no_sock_func, "getprotoent");
e5c9fcd0 4780#endif
a0d0e21e
LW		 4781
4782 EXTEND(SP, 3);
4783 if (GIMME != G_ARRAY) {
4784 PUSHs(sv = sv_newmortal());
4785 if (pent) {
4786 if (which == OP_GPBYNAME)
1e422769 4787 sv_setiv(sv, (IV)pent->p_proto);
a0d0e21e
LW		 4788 else
4789 sv_setpv(sv, pent->p_name);
4790 }
4791 RETURN;
4792 }
4793
4794 if (pent) {
3280af22 4795 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4796 sv_setpv(sv, pent->p_name);
3280af22 4797 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 4798 for (elem = pent->p_aliases; elem && *elem; elem++) {
a0d0e21e
LW		 4799 sv_catpv(sv, *elem);
4800 if (elem[1])
4801 sv_catpvn(sv, " ", 1);
4802 }
3280af22 4803 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4804 sv_setiv(sv, (IV)pent->p_proto);
a0d0e21e
LW		 4805 }
4806
4807 RETURN;
4808#else
cea2e8a9 4809 DIE(aTHX_ PL_no_sock_func, "getprotoent");
a0d0e21e
LW		 4810#endif
4811}
4812
4813PP(pp_gsbyname)
4814{
9ec75305 4815#ifdef HAS_GETSERVBYNAME
cea2e8a9 4816 return pp_gservent();
a0d0e21e 4817#else
cea2e8a9 4818 DIE(aTHX_ PL_no_sock_func, "getservbyname");
a0d0e21e
LW		 4819#endif
4820}
4821
4822PP(pp_gsbyport)
4823{
9ec75305 4824#ifdef HAS_GETSERVBYPORT
cea2e8a9 4825 return pp_gservent();
a0d0e21e 4826#else
cea2e8a9 4827 DIE(aTHX_ PL_no_sock_func, "getservbyport");
a0d0e21e
LW		 4828#endif
4829}
4830
4831PP(pp_gservent)
4832{
693762b4 4833#if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
9cad6237 4834 dSP;
533c011a 4835 I32 which = PL_op->op_type;
a0d0e21e
LW		 4836 register char **elem;
4837 register SV *sv;
dc45a647 4838#ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4599a1de
JH		 4839 struct servent *PerlSock_getservbyname(Netdb_name_t, Netdb_name_t);
4840 struct servent *PerlSock_getservbyport(int, Netdb_name_t);
6ad3d225 4841 struct servent *PerlSock_getservent(void);
8ac85365 4842#endif
a0d0e21e 4843 struct servent *sent;
2d8e6c8d 4844 STRLEN n_a;
a0d0e21e
LW		 4845
4846 if (which == OP_GSBYNAME) {
dc45a647 4847#ifdef HAS_GETSERVBYNAME
42e0c139
AP		 4848 char *proto = POPpbytex;
4849 char *name = POPpbytex;
a0d0e21e
LW		 4850
4851 if (proto && !*proto)
4852 proto = Nullch;
4853
6ad3d225 4854 sent = PerlSock_getservbyname(name, proto);
dc45a647 4855#else
cea2e8a9 4856 DIE(aTHX_ PL_no_sock_func, "getservbyname");
dc45a647 4857#endif
a0d0e21e
LW		 4858 }
4859 else if (which == OP_GSBYPORT) {
dc45a647 4860#ifdef HAS_GETSERVBYPORT
42e0c139 4861 char *proto = POPpbytex;
36477c24 4862 unsigned short port = POPu;
a0d0e21e 4863
36477c24 4864#ifdef HAS_HTONS
6ad3d225 4865 port = PerlSock_htons(port);
36477c24 4866#endif
6ad3d225 4867 sent = PerlSock_getservbyport(port, proto);
dc45a647 4868#else
cea2e8a9 4869 DIE(aTHX_ PL_no_sock_func, "getservbyport");
dc45a647 4870#endif
a0d0e21e
LW		 4871 }
4872 else
e5c9fcd0 4873#ifdef HAS_GETSERVENT
6ad3d225 4874 sent = PerlSock_getservent();
e5c9fcd0 4875#else
cea2e8a9 4876 DIE(aTHX_ PL_no_sock_func, "getservent");
e5c9fcd0 4877#endif
a0d0e21e
LW		 4878
4879 EXTEND(SP, 4);
4880 if (GIMME != G_ARRAY) {
4881 PUSHs(sv = sv_newmortal());
4882 if (sent) {
4883 if (which == OP_GSBYNAME) {
4884#ifdef HAS_NTOHS
6ad3d225 4885 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
a0d0e21e 4886#else
1e422769 4887 sv_setiv(sv, (IV)(sent->s_port));
a0d0e21e
LW		 4888#endif
4889 }
4890 else
4891 sv_setpv(sv, sent->s_name);
4892 }
4893 RETURN;
4894 }
4895
4896 if (sent) {
3280af22 4897 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4898 sv_setpv(sv, sent->s_name);
3280af22 4899 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 4900 for (elem = sent->s_aliases; elem && *elem; elem++) {
a0d0e21e
LW		 4901 sv_catpv(sv, *elem);
4902 if (elem[1])
4903 sv_catpvn(sv, " ", 1);
4904 }
3280af22 4905 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4906#ifdef HAS_NTOHS
76e3520e 4907 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
a0d0e21e 4908#else
1e422769 4909 sv_setiv(sv, (IV)(sent->s_port));
a0d0e21e 4910#endif
3280af22 4911 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 4912 sv_setpv(sv, sent->s_proto);
4913 }
4914
4915 RETURN;
4916#else
cea2e8a9 4917 DIE(aTHX_ PL_no_sock_func, "getservent");
a0d0e21e
LW		 4918#endif
4919}
4920
4921PP(pp_shostent)
4922{
693762b4 4923#ifdef HAS_SETHOSTENT
9cad6237 4924 dSP;
76e3520e 4925 PerlSock_sethostent(TOPi);
a0d0e21e
LW		 4926 RETSETYES;
4927#else
cea2e8a9 4928 DIE(aTHX_ PL_no_sock_func, "sethostent");
a0d0e21e
LW		 4929#endif
4930}
4931
4932PP(pp_snetent)
4933{
693762b4 4934#ifdef HAS_SETNETENT
9cad6237 4935 dSP;
76e3520e 4936 PerlSock_setnetent(TOPi);
a0d0e21e
LW		 4937 RETSETYES;
4938#else
cea2e8a9 4939 DIE(aTHX_ PL_no_sock_func, "setnetent");
a0d0e21e
LW		 4940#endif
4941}
4942
4943PP(pp_sprotoent)
4944{
693762b4 4945#ifdef HAS_SETPROTOENT
9cad6237 4946 dSP;
76e3520e 4947 PerlSock_setprotoent(TOPi);
a0d0e21e
LW		 4948 RETSETYES;
4949#else
cea2e8a9 4950 DIE(aTHX_ PL_no_sock_func, "setprotoent");
a0d0e21e
LW		 4951#endif
4952}
4953
4954PP(pp_sservent)
4955{
693762b4 4956#ifdef HAS_SETSERVENT
9cad6237 4957 dSP;
76e3520e 4958 PerlSock_setservent(TOPi);
a0d0e21e
LW		 4959 RETSETYES;
4960#else
cea2e8a9 4961 DIE(aTHX_ PL_no_sock_func, "setservent");
a0d0e21e
LW		 4962#endif
4963}
4964
4965PP(pp_ehostent)
4966{
693762b4 4967#ifdef HAS_ENDHOSTENT
9cad6237 4968 dSP;
76e3520e 4969 PerlSock_endhostent();
924508f0 4970 EXTEND(SP,1);
a0d0e21e
LW		 4971 RETPUSHYES;
4972#else
cea2e8a9 4973 DIE(aTHX_ PL_no_sock_func, "endhostent");
a0d0e21e
LW		 4974#endif
4975}
4976
4977PP(pp_enetent)
4978{
693762b4 4979#ifdef HAS_ENDNETENT
9cad6237 4980 dSP;
76e3520e 4981 PerlSock_endnetent();
924508f0 4982 EXTEND(SP,1);
a0d0e21e
LW		 4983 RETPUSHYES;
4984#else
cea2e8a9 4985 DIE(aTHX_ PL_no_sock_func, "endnetent");
a0d0e21e
LW		 4986#endif
4987}
4988
4989PP(pp_eprotoent)
4990{
693762b4 4991#ifdef HAS_ENDPROTOENT
9cad6237 4992 dSP;
76e3520e 4993 PerlSock_endprotoent();
924508f0 4994 EXTEND(SP,1);
a0d0e21e
LW		 4995 RETPUSHYES;
4996#else
cea2e8a9 4997 DIE(aTHX_ PL_no_sock_func, "endprotoent");
a0d0e21e
LW		 4998#endif
4999}
5000
5001PP(pp_eservent)
5002{
693762b4 5003#ifdef HAS_ENDSERVENT
9cad6237 5004 dSP;
76e3520e 5005 PerlSock_endservent();
924508f0 5006 EXTEND(SP,1);
a0d0e21e
LW		 5007 RETPUSHYES;
5008#else
cea2e8a9 5009 DIE(aTHX_ PL_no_sock_func, "endservent");
a0d0e21e
LW		 5010#endif
5011}
5012
5013PP(pp_gpwnam)
5014{
5015#ifdef HAS_PASSWD
cea2e8a9 5016 return pp_gpwent();
a0d0e21e 5017#else
cea2e8a9 5018 DIE(aTHX_ PL_no_func, "getpwnam");
a0d0e21e
LW		 5019#endif
5020}
5021
5022PP(pp_gpwuid)
5023{
5024#ifdef HAS_PASSWD
cea2e8a9 5025 return pp_gpwent();
a0d0e21e 5026#else
cea2e8a9 5027 DIE(aTHX_ PL_no_func, "getpwuid");
a0d0e21e
LW		 5028#endif
5029}
5030
5031PP(pp_gpwent)
5032{
0994c4d0 5033#ifdef HAS_PASSWD
9cad6237 5034 dSP;
533c011a 5035 I32 which = PL_op->op_type;
a0d0e21e 5036 register SV *sv;
2d8e6c8d 5037 STRLEN n_a;
e3aefe8d 5038 struct passwd *pwent = NULL;
301e8125 5039 /*
bcf53261
JH		 5040 * We currently support only the SysV getsp* shadow password interface.
5041 * The interface is declared in <shadow.h> and often one needs to link
5042 * with -lsecurity or some such.
5043 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5044 * (and SCO?)
5045 *
5046 * AIX getpwnam() is clever enough to return the encrypted password
5047 * only if the caller (euid?) is root.
5048 *
5049 * There are at least two other shadow password APIs. Many platforms
5050 * seem to contain more than one interface for accessing the shadow
5051 * password databases, possibly for compatibility reasons.
3813c136 5052 * The getsp*() is by far he simplest one, the other two interfaces
bcf53261
JH		 5053 * are much more complicated, but also very similar to each other.
5054 *
5055 * <sys/types.h>
5056 * <sys/security.h>
5057 * <prot.h>
5058 * struct pr_passwd *getprpw*();
5059 * The password is in
3813c136
JH		 5060 * char getprpw*(...).ufld.fd_encrypt[]
5061 * Mention HAS_GETPRPWNAM here so that Configure probes for it.
bcf53261
JH		 5062 *
5063 * <sys/types.h>
5064 * <sys/security.h>
5065 * <prot.h>
5066 * struct es_passwd *getespw*();
5067 * The password is in
5068 * char *(getespw*(...).ufld.fd_encrypt)
3813c136 5069 * Mention HAS_GETESPWNAM here so that Configure probes for it.
bcf53261 5070 *
3813c136 5071 * Mention I_PROT here so that Configure probes for it.
bcf53261
JH		 5072 *
5073 * In HP-UX for getprpw*() the manual page claims that one should include
5074 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5075 * if one includes <shadow.h> as that includes <hpsecurity.h>,
5076 * and pp_sys.c already includes <shadow.h> if there is such.
3813c136
JH		 5077 *
5078 * Note that <sys/security.h> is already probed for, but currently
5079 * it is only included in special cases.
301e8125 5080 *
bcf53261
JH		 5081 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5082 * be preferred interface, even though also the getprpw*() interface
5083 * is available) one needs to link with -lsecurity -ldb -laud -lm.
3813c136
JH		 5084 * One also needs to call set_auth_parameters() in main() before
5085 * doing anything else, whether one is using getespw*() or getprpw*().
5086 *
5087 * Note that accessing the shadow databases can be magnitudes
5088 * slower than accessing the standard databases.
bcf53261
JH		 5089 *
5090 * --jhi
5091 */
a0d0e21e 5092
e3aefe8d
JH		 5093 switch (which) {
5094 case OP_GPWNAM:
42e0c139 5095 pwent = getpwnam(POPpbytex);
e3aefe8d
JH		 5096 break;
5097 case OP_GPWUID:
5098 pwent = getpwuid((Uid_t)POPi);
5099 break;
5100 case OP_GPWENT:
1883634f 5101# ifdef HAS_GETPWENT
e3aefe8d 5102 pwent = getpwent();
1883634f 5103# else
a45d1c96 5104 DIE(aTHX_ PL_no_func, "getpwent");
1883634f 5105# endif
e3aefe8d
JH		 5106 break;
5107 }
8c0bfa08 5108
a0d0e21e
LW		 5109 EXTEND(SP, 10);
5110 if (GIMME != G_ARRAY) {
5111 PUSHs(sv = sv_newmortal());
5112 if (pwent) {
5113 if (which == OP_GPWNAM)
1883634f 5114# if Uid_t_sign <= 0
1e422769 5115 sv_setiv(sv, (IV)pwent->pw_uid);
1883634f 5116# else
23dcd6c8 5117 sv_setuv(sv, (UV)pwent->pw_uid);
1883634f 5118# endif
a0d0e21e
LW		 5119 else
5120 sv_setpv(sv, pwent->pw_name);
5121 }
5122 RETURN;
5123 }
5124
5125 if (pwent) {
3280af22 5126 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 5127 sv_setpv(sv, pwent->pw_name);
6ee623d5 5128
3280af22 5129 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
3813c136
JH		 5130 SvPOK_off(sv);
5131 /* If we have getspnam(), we try to dig up the shadow
5132 * password. If we are underprivileged, the shadow
5133 * interface will set the errno to EACCES or similar,
5134 * and return a null pointer. If this happens, we will
5135 * use the dummy password (usually "*" or "x") from the
5136 * standard password database.
5137 *
5138 * In theory we could skip the shadow call completely
5139 * if euid != 0 but in practice we cannot know which
5140 * security measures are guarding the shadow databases
5141 * on a random platform.
5142 *
5143 * Resist the urge to use additional shadow interfaces.
5144 * Divert the urge to writing an extension instead.
5145 *
5146 * --jhi */
e3aefe8d 5147# ifdef HAS_GETSPNAM
3813c136
JH		 5148 {
5149 struct spwd *spwent;
5150 int saverrno; /* Save and restore errno so that
5151 * underprivileged attempts seem
5152 * to have never made the unsccessful
5153 * attempt to retrieve the shadow password. */
5154
5155 saverrno = errno;
5156 spwent = getspnam(pwent->pw_name);
5157 errno = saverrno;
5158 if (spwent && spwent->sp_pwdp)
5159 sv_setpv(sv, spwent->sp_pwdp);
5160 }
f1066039 5161# endif
e020c87d 5162# ifdef PWPASSWD
3813c136
JH		 5163 if (!SvPOK(sv)) /* Use the standard password, then. */
5164 sv_setpv(sv, pwent->pw_passwd);
e020c87d 5165# endif
3813c136 5166
1883634f 5167# ifndef INCOMPLETE_TAINTS
3813c136
JH		 5168 /* passwd is tainted because user himself can diddle with it.
5169 * admittedly not much and in a very limited way, but nevertheless. */
2959b6e3 5170 SvTAINTED_on(sv);
1883634f 5171# endif
6ee623d5 5172
3280af22 5173 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1883634f 5174# if Uid_t_sign <= 0
1e422769 5175 sv_setiv(sv, (IV)pwent->pw_uid);
1883634f 5176# else
23dcd6c8 5177 sv_setuv(sv, (UV)pwent->pw_uid);
1883634f 5178# endif
6ee623d5 5179
3280af22 5180 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1883634f 5181# if Uid_t_sign <= 0
1e422769 5182 sv_setiv(sv, (IV)pwent->pw_gid);
1883634f 5183# else
23dcd6c8 5184 sv_setuv(sv, (UV)pwent->pw_gid);
1883634f 5185# endif
3813c136
JH		 5186 /* pw_change, pw_quota, and pw_age are mutually exclusive--
5187 * because of the poor interface of the Perl getpw*(),
5188 * not because there's some standard/convention saying so.
5189 * A better interface would have been to return a hash,
5190 * but we are accursed by our history, alas. --jhi. */
3280af22 5191 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1883634f 5192# ifdef PWCHANGE
1e422769 5193 sv_setiv(sv, (IV)pwent->pw_change);
6ee623d5 5194# else
1883634f
JH		 5195# ifdef PWQUOTA
5196 sv_setiv(sv, (IV)pwent->pw_quota);
5197# else
a1757be1 5198# ifdef PWAGE
a0d0e21e 5199 sv_setpv(sv, pwent->pw_age);
a1757be1 5200# endif
6ee623d5
GS		 5201# endif
5202# endif
6ee623d5 5203
3813c136
JH		 5204 /* pw_class and pw_comment are mutually exclusive--.
5205 * see the above note for pw_change, pw_quota, and pw_age. */
3280af22 5206 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1883634f 5207# ifdef PWCLASS
a0d0e21e 5208 sv_setpv(sv, pwent->pw_class);
1883634f
JH		 5209# else
5210# ifdef PWCOMMENT
a0d0e21e 5211 sv_setpv(sv, pwent->pw_comment);
1883634f 5212# endif
6ee623d5 5213# endif
6ee623d5 5214
3280af22 5215 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1883634f 5216# ifdef PWGECOS
a0d0e21e 5217 sv_setpv(sv, pwent->pw_gecos);
1883634f
JH		 5218# endif
5219# ifndef INCOMPLETE_TAINTS
d2719217 5220 /* pw_gecos is tainted because user himself can diddle with it. */
fb73857a 5221 SvTAINTED_on(sv);
1883634f 5222# endif
6ee623d5 5223
3280af22 5224 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 5225 sv_setpv(sv, pwent->pw_dir);
6ee623d5 5226
3280af22 5227 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 5228 sv_setpv(sv, pwent->pw_shell);
1883634f 5229# ifndef INCOMPLETE_TAINTS
4602f195
JH		 5230 /* pw_shell is tainted because user himself can diddle with it. */
5231 SvTAINTED_on(sv);
1883634f 5232# endif
6ee623d5 5233
1883634f 5234# ifdef PWEXPIRE
6b88bc9c 5235 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 5236 sv_setiv(sv, (IV)pwent->pw_expire);
1883634f 5237# endif
a0d0e21e
LW		 5238 }
5239 RETURN;
5240#else
cea2e8a9 5241 DIE(aTHX_ PL_no_func, "getpwent");
a0d0e21e
LW		 5242#endif
5243}
5244
5245PP(pp_spwent)
5246{
d493b042 5247#if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
9cad6237 5248 dSP;
a0d0e21e
LW		 5249 setpwent();
5250 RETPUSHYES;
5251#else
cea2e8a9 5252 DIE(aTHX_ PL_no_func, "setpwent");
a0d0e21e
LW		 5253#endif
5254}
5255
5256PP(pp_epwent)
5257{
28e8609d 5258#if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
9cad6237 5259 dSP;
a0d0e21e
LW		 5260 endpwent();
5261 RETPUSHYES;
5262#else
cea2e8a9 5263 DIE(aTHX_ PL_no_func, "endpwent");
a0d0e21e
LW		 5264#endif
5265}
5266
5267PP(pp_ggrnam)
5268{
5269#ifdef HAS_GROUP
cea2e8a9 5270 return pp_ggrent();
a0d0e21e 5271#else
cea2e8a9 5272 DIE(aTHX_ PL_no_func, "getgrnam");
a0d0e21e
LW		 5273#endif
5274}
5275
5276PP(pp_ggrgid)
5277{
5278#ifdef HAS_GROUP
cea2e8a9 5279 return pp_ggrent();
a0d0e21e 5280#else
cea2e8a9 5281 DIE(aTHX_ PL_no_func, "getgrgid");
a0d0e21e
LW		 5282#endif
5283}
5284
5285PP(pp_ggrent)
5286{
0994c4d0 5287#ifdef HAS_GROUP
9cad6237 5288 dSP;
533c011a 5289 I32 which = PL_op->op_type;
a0d0e21e
LW		 5290 register char **elem;
5291 register SV *sv;
5292 struct group *grent;
2d8e6c8d 5293 STRLEN n_a;
a0d0e21e
LW		 5294
5295 if (which == OP_GGRNAM)
42e0c139 5296 grent = (struct group *)getgrnam(POPpbytex);
a0d0e21e
LW		 5297 else if (which == OP_GGRGID)
5298 grent = (struct group *)getgrgid(POPi);
5299 else
0994c4d0 5300#ifdef HAS_GETGRENT
a0d0e21e 5301 grent = (struct group *)getgrent();
0994c4d0
JH		 5302#else
5303 DIE(aTHX_ PL_no_func, "getgrent");
5304#endif
a0d0e21e
LW		 5305
5306 EXTEND(SP, 4);
5307 if (GIMME != G_ARRAY) {
5308 PUSHs(sv = sv_newmortal());
5309 if (grent) {
5310 if (which == OP_GGRNAM)
1e422769 5311 sv_setiv(sv, (IV)grent->gr_gid);
a0d0e21e
LW		 5312 else
5313 sv_setpv(sv, grent->gr_name);
5314 }
5315 RETURN;
5316 }
5317
5318 if (grent) {
3280af22 5319 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 5320 sv_setpv(sv, grent->gr_name);
28e8609d 5321
3280af22 5322 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
28e8609d 5323#ifdef GRPASSWD
a0d0e21e 5324 sv_setpv(sv, grent->gr_passwd);
28e8609d
JH		 5325#endif
5326
3280af22 5327 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 5328 sv_setiv(sv, (IV)grent->gr_gid);
28e8609d 5329
3280af22 5330 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 5331 for (elem = grent->gr_mem; elem && *elem; elem++) {
a0d0e21e
LW		 5332 sv_catpv(sv, *elem);
5333 if (elem[1])
5334 sv_catpvn(sv, " ", 1);
5335 }
5336 }
5337
5338 RETURN;
5339#else
cea2e8a9 5340 DIE(aTHX_ PL_no_func, "getgrent");
a0d0e21e
LW		 5341#endif
5342}
5343
5344PP(pp_sgrent)
5345{
28e8609d 5346#if defined(HAS_GROUP) && defined(HAS_SETGRENT)
9cad6237 5347 dSP;
a0d0e21e
LW		 5348 setgrent();
5349 RETPUSHYES;
5350#else
cea2e8a9 5351 DIE(aTHX_ PL_no_func, "setgrent");
a0d0e21e
LW		 5352#endif
5353}
5354
5355PP(pp_egrent)
5356{
28e8609d 5357#if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
9cad6237 5358 dSP;
a0d0e21e
LW		 5359 endgrent();
5360 RETPUSHYES;
5361#else
cea2e8a9 5362 DIE(aTHX_ PL_no_func, "endgrent");
a0d0e21e
LW		 5363#endif
5364}
5365
5366PP(pp_getlogin)
5367{
a0d0e21e 5368#ifdef HAS_GETLOGIN
9cad6237 5369 dSP; dTARGET;
a0d0e21e
LW		 5370 char *tmps;
5371 EXTEND(SP, 1);
76e3520e 5372 if (!(tmps = PerlProc_getlogin()))
a0d0e21e
LW		 5373 RETPUSHUNDEF;
5374 PUSHp(tmps, strlen(tmps));
5375 RETURN;
5376#else
cea2e8a9 5377 DIE(aTHX_ PL_no_func, "getlogin");
a0d0e21e
LW		 5378#endif
5379}
5380
5381/* Miscellaneous. */
5382
5383PP(pp_syscall)
5384{
d2719217 5385#ifdef HAS_SYSCALL
39644a26 5386 dSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 5387 register I32 items = SP - MARK;
5388 unsigned long a[20];
5389 register I32 i = 0;
5390 I32 retval = -1;
2d8e6c8d 5391 STRLEN n_a;
a0d0e21e 5392
3280af22 5393 if (PL_tainting) {
a0d0e21e 5394 while (++MARK <= SP) {
bbce6d69 5395 if (SvTAINTED(*MARK)) {
5396 TAINT;
5397 break;
5398 }
a0d0e21e
LW		 5399 }
5400 MARK = ORIGMARK;
5401 TAINT_PROPER("syscall");
5402 }
5403
5404 /* This probably won't work on machines where sizeof(long) != sizeof(int)
5405 * or where sizeof(long) != sizeof(char*). But such machines will
5406 * not likely have syscall implemented either, so who cares?
5407 */
5408 while (++MARK <= SP) {
5409 if (SvNIOK(*MARK) || !i)
5410 a[i++] = SvIV(*MARK);
3280af22 5411 else if (*MARK == &PL_sv_undef)
748a9306 5412 a[i++] = 0;
301e8125 5413 else
2d8e6c8d 5414 a[i++] = (unsigned long)SvPV_force(*MARK, n_a);
a0d0e21e
LW		 5415 if (i > 15)
5416 break;
5417 }
5418 switch (items) {
5419 default:
cea2e8a9 5420 DIE(aTHX_ "Too many args to syscall");
a0d0e21e 5421 case 0:
cea2e8a9 5422 DIE(aTHX_ "Too few args to syscall");
a0d0e21e
LW		 5423 case 1:
5424 retval = syscall(a[0]);
5425 break;
5426 case 2:
5427 retval = syscall(a[0],a[1]);
5428 break;
5429 case 3:
5430 retval = syscall(a[0],a[1],a[2]);
5431 break;
5432 case 4:
5433 retval = syscall(a[0],a[1],a[2],a[3]);
5434 break;
5435 case 5:
5436 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5437 break;
5438 case 6:
5439 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5440 break;
5441 case 7:
5442 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5443 break;
5444 case 8:
5445 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5446 break;
5447#ifdef atarist
5448 case 9:
5449 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5450 break;
5451 case 10:
5452 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5453 break;
5454 case 11:
5455 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5456 a[10]);
5457 break;
5458 case 12:
5459 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5460 a[10],a[11]);
5461 break;
5462 case 13:
5463 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5464 a[10],a[11],a[12]);
5465 break;
5466 case 14:
5467 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5468 a[10],a[11],a[12],a[13]);
5469 break;
5470#endif /* atarist */
5471 }
5472 SP = ORIGMARK;
5473 PUSHi(retval);
5474 RETURN;
5475#else
cea2e8a9 5476 DIE(aTHX_ PL_no_func, "syscall");
a0d0e21e
LW		 5477#endif
5478}
5479
ff68c719 5480#ifdef FCNTL_EMULATE_FLOCK
301e8125 5481
ff68c719 5482/* XXX Emulate flock() with fcntl().
5483 What's really needed is a good file locking module.
5484*/
5485
cea2e8a9
GS		 5486static int
5487fcntl_emulate_flock(int fd, int operation)
ff68c719 5488{
5489 struct flock flock;
301e8125 5490
ff68c719 5491 switch (operation & ~LOCK_NB) {
5492 case LOCK_SH:
5493 flock.l_type = F_RDLCK;
5494 break;
5495 case LOCK_EX:
5496 flock.l_type = F_WRLCK;
5497 break;
5498 case LOCK_UN:
5499 flock.l_type = F_UNLCK;
5500 break;
5501 default:
5502 errno = EINVAL;
5503 return -1;
5504 }
5505 flock.l_whence = SEEK_SET;
d9b3e12d 5506 flock.l_start = flock.l_len = (Off_t)0;
301e8125 5507
ff68c719 5508 return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5509}
5510
5511#endif /* FCNTL_EMULATE_FLOCK */
5512
5513#ifdef LOCKF_EMULATE_FLOCK
16d20bd9
AD		 5514
5515/* XXX Emulate flock() with lockf(). This is just to increase
5516 portability of scripts. The calls are not completely
5517 interchangeable. What's really needed is a good file
5518 locking module.
5519*/
5520
76c32331 5521/* The lockf() constants might have been defined in <unistd.h>.
5522 Unfortunately, <unistd.h> causes troubles on some mixed
5523 (BSD/POSIX) systems, such as SunOS 4.1.3.
16d20bd9
AD		 5524
5525 Further, the lockf() constants aren't POSIX, so they might not be
5526 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5527 just stick in the SVID values and be done with it. Sigh.
5528*/
5529
5530# ifndef F_ULOCK
5531# define F_ULOCK 0 /* Unlock a previously locked region */
5532# endif
5533# ifndef F_LOCK
5534# define F_LOCK 1 /* Lock a region for exclusive use */
5535# endif
5536# ifndef F_TLOCK
5537# define F_TLOCK 2 /* Test and lock a region for exclusive use */
5538# endif
5539# ifndef F_TEST
5540# define F_TEST 3 /* Test a region for other processes locks */
5541# endif
5542
cea2e8a9
GS		 5543static int
5544lockf_emulate_flock(int fd, int operation)
16d20bd9
AD		 5545{
5546 int i;
84902520
TB		 5547 int save_errno;
5548 Off_t pos;
5549
5550 /* flock locks entire file so for lockf we need to do the same */
5551 save_errno = errno;
6ad3d225 5552 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
84902520 5553 if (pos > 0) /* is seekable and needs to be repositioned */
6ad3d225 5554 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
08b714dd 5555 pos = -1; /* seek failed, so don't seek back afterwards */
84902520
TB		 5556 errno = save_errno;
5557
16d20bd9
AD		 5558 switch (operation) {
5559
5560 /* LOCK_SH - get a shared lock */
5561 case LOCK_SH:
5562 /* LOCK_EX - get an exclusive lock */
5563 case LOCK_EX:
5564 i = lockf (fd, F_LOCK, 0);
5565 break;
5566
5567 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5568 case LOCK_SH|LOCK_NB:
5569 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5570 case LOCK_EX|LOCK_NB:
5571 i = lockf (fd, F_TLOCK, 0);
5572 if (i == -1)
5573 if ((errno == EAGAIN) || (errno == EACCES))
5574 errno = EWOULDBLOCK;
5575 break;
5576
ff68c719 5577 /* LOCK_UN - unlock (non-blocking is a no-op) */
16d20bd9 5578 case LOCK_UN:
ff68c719 5579 case LOCK_UN|LOCK_NB:
16d20bd9
AD		 5580 i = lockf (fd, F_ULOCK, 0);
5581 break;
5582
5583 /* Default - can't decipher operation */
5584 default:
5585 i = -1;
5586 errno = EINVAL;
5587 break;
5588 }
84902520
TB		 5589
5590 if (pos > 0) /* need to restore position of the handle */
6ad3d225 5591 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
84902520 5592
16d20bd9
AD		 5593 return (i);
5594}
ff68c719 5595
5596#endif /* LOCKF_EMULATE_FLOCK */
Unnamed repository; edit this file 'description' to name the repository.