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