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