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