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
A proof of the dangers of package; ?
[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
3877 EXTEND(SP, 1);
45bc9206 3878 PERL_FLUSHALL_FOR_CHILD;
a0d0e21e
LW		 3879 childpid = fork();
3880 if (childpid < 0)
3881 RETSETUNDEF;
3882 if (!childpid) {
3883 /*SUPPRESS 560*/
155aba94 3884 if ((tmpgv = gv_fetchpv("$", TRUE, SVt_PV)))
146174a9 3885 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3280af22 3886 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
a0d0e21e
LW		 3887 }
3888 PUSHi(childpid);
3889 RETURN;
3890#else
146174a9 3891# if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
39644a26 3892 dSP; dTARGET;
146174a9
CB		 3893 Pid_t childpid;
3894
3895 EXTEND(SP, 1);
3896 PERL_FLUSHALL_FOR_CHILD;
3897 childpid = PerlProc_fork();
60fa28ff
GS		 3898 if (childpid == -1)
3899 RETSETUNDEF;
146174a9
CB		 3900 PUSHi(childpid);
3901 RETURN;
3902# else
0322a713 3903 DIE(aTHX_ PL_no_func, "fork");
146174a9 3904# endif
a0d0e21e
LW		 3905#endif
3906}
3907
3908PP(pp_wait)
3909{
301e8125 3910#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
39644a26 3911 dSP; dTARGET;
761237fe 3912 Pid_t childpid;
a0d0e21e 3913 int argflags;
a0d0e21e 3914
0a0ada86 3915#ifdef PERL_OLD_SIGNALS
44a8e56a 3916 childpid = wait4pid(-1, &argflags, 0);
0a0ada86
NIS		 3917#else
3918 while ((childpid = wait4pid(-1, &argflags, 0)) == -1 && errno == EINTR) {
3919 PERL_ASYNC_CHECK();
3920 }
3921#endif
68a29c53
GS		 3922# if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3923 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
3924 STATUS_NATIVE_SET((childpid && childpid != -1) ? argflags : -1);
3925# else
f86702cc 3926 STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
68a29c53 3927# endif
44a8e56a 3928 XPUSHi(childpid);
a0d0e21e
LW		 3929 RETURN;
3930#else
0322a713 3931 DIE(aTHX_ PL_no_func, "wait");
a0d0e21e
LW		 3932#endif
3933}
3934
3935PP(pp_waitpid)
3936{
301e8125 3937#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
39644a26 3938 dSP; dTARGET;
761237fe 3939 Pid_t childpid;
a0d0e21e
LW		 3940 int optype;
3941 int argflags;
a0d0e21e 3942
a0d0e21e
LW		 3943 optype = POPi;
3944 childpid = TOPi;
0a0ada86 3945#ifdef PERL_OLD_SIGNALS
a0d0e21e 3946 childpid = wait4pid(childpid, &argflags, optype);
0a0ada86
NIS		 3947#else
3948 while ((childpid = wait4pid(childpid, &argflags, optype)) == -1 && errno == EINTR) {
3949 PERL_ASYNC_CHECK();
3950 }
3951#endif
68a29c53
GS		 3952# if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3953 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
3954 STATUS_NATIVE_SET((childpid && childpid != -1) ? argflags : -1);
3955# else
f86702cc 3956 STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
68a29c53 3957# endif
44a8e56a 3958 SETi(childpid);
a0d0e21e
LW		 3959 RETURN;
3960#else
0322a713 3961 DIE(aTHX_ PL_no_func, "waitpid");
a0d0e21e
LW		 3962#endif
3963}
3964
3965PP(pp_system)
3966{
39644a26 3967 dSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e 3968 I32 value;
2d8e6c8d 3969 STRLEN n_a;
76ffd3b9 3970 int result;
e7766f89
JH		 3971 int pp[2];
3972 I32 did_pipes = 0;
a0d0e21e 3973
a0d0e21e 3974 if (SP - MARK == 1) {
3280af22 3975 if (PL_tainting) {
516a5887 3976 (void)SvPV_nolen(TOPs); /* stringify for taint check */
a0d0e21e
LW		 3977 TAINT_ENV();
3978 TAINT_PROPER("system");
3979 }
3980 }
45bc9206 3981 PERL_FLUSHALL_FOR_CHILD;
273b0206 3982#if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
d7e492a4
JH		 3983 {
3984 Pid_t childpid;
3985 int status;
3986 Sigsave_t ihand,qhand; /* place to save signals during system() */
3987
3988 if (PerlProc_pipe(pp) >= 0)
3989 did_pipes = 1;
3990 while ((childpid = vfork()) == -1) {
3991 if (errno != EAGAIN) {
3992 value = -1;
3993 SP = ORIGMARK;
3994 PUSHi(value);
3995 if (did_pipes) {
3996 PerlLIO_close(pp[0]);
3997 PerlLIO_close(pp[1]);
3998 }
3999 RETURN;
4000 }
4001 sleep(5);
4002 }
4003 if (childpid > 0) {
4004 if (did_pipes)
4005 PerlLIO_close(pp[1]);
64ca3a65 4006#ifndef PERL_MICRO
d7e492a4
JH		 4007 rsignal_save(SIGINT, SIG_IGN, &ihand);
4008 rsignal_save(SIGQUIT, SIG_IGN, &qhand);
64ca3a65 4009#endif
d7e492a4
JH		 4010 do {
4011 result = wait4pid(childpid, &status, 0);
4012 } while (result == -1 && errno == EINTR);
64ca3a65 4013#ifndef PERL_MICRO
d7e492a4
JH		 4014 (void)rsignal_restore(SIGINT, &ihand);
4015 (void)rsignal_restore(SIGQUIT, &qhand);
4016#endif
4017 STATUS_NATIVE_SET(result == -1 ? -1 : status);
4018 do_execfree(); /* free any memory child malloced on vfork */
4019 SP = ORIGMARK;
4020 if (did_pipes) {
4021 int errkid;
4022 int n = 0, n1;
4023
4024 while (n < sizeof(int)) {
4025 n1 = PerlLIO_read(pp[0],
4026 (void*)(((char*)&errkid)+n),
4027 (sizeof(int)) - n);
4028 if (n1 <= 0)
4029 break;
4030 n += n1;
4031 }
4032 PerlLIO_close(pp[0]);
4033 if (n) { /* Error */
4034 if (n != sizeof(int))
4035 DIE(aTHX_ "panic: kid popen errno read");
4036 errno = errkid; /* Propagate errno from kid */
4037 STATUS_CURRENT = -1;
4038 }
4039 }
4040 PUSHi(STATUS_CURRENT);
4041 RETURN;
4042 }
4043 if (did_pipes) {
4044 PerlLIO_close(pp[0]);
d5a9bfb0 4045#if defined(HAS_FCNTL) && defined(F_SETFD)
d7e492a4 4046 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
d5a9bfb0 4047#endif
d7e492a4 4048 }
d5a9bfb0 4049 }
533c011a 4050 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e 4051 SV *really = *++MARK;
d5a9bfb0 4052 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
a0d0e21e
LW		 4053 }
4054 else if (SP - MARK != 1)
d5a9bfb0 4055 value = (I32)do_aexec5(Nullsv, MARK, SP, pp[1], did_pipes);
a0d0e21e 4056 else {
d5a9bfb0 4057 value = (I32)do_exec3(SvPVx(sv_mortalcopy(*SP), n_a), pp[1], did_pipes);
a0d0e21e 4058 }
6ad3d225 4059 PerlProc__exit(-1);
c3293030 4060#else /* ! FORK or VMS or OS/2 */
922b1888
GS		 4061 PL_statusvalue = 0;
4062 result = 0;
911d147d 4063 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e 4064 SV *really = *++MARK;
c5be433b 4065 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
a0d0e21e
LW		 4066 }
4067 else if (SP - MARK != 1)
c5be433b 4068 value = (I32)do_aspawn(Nullsv, (void **)MARK, (void **)SP);
a0d0e21e 4069 else {
c5be433b 4070 value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
a0d0e21e 4071 }
922b1888
GS		 4072 if (PL_statusvalue == -1) /* hint that value must be returned as is */
4073 result = 1;
f86702cc 4074 STATUS_NATIVE_SET(value);
a0d0e21e
LW		 4075 do_execfree();
4076 SP = ORIGMARK;
922b1888 4077 PUSHi(result ? value : STATUS_CURRENT);
a0d0e21e
LW		 4078#endif /* !FORK or VMS */
4079 RETURN;
4080}
4081
4082PP(pp_exec)
4083{
39644a26 4084 dSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e 4085 I32 value;
2d8e6c8d 4086 STRLEN n_a;
a0d0e21e 4087
45bc9206 4088 PERL_FLUSHALL_FOR_CHILD;
533c011a 4089 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e
LW		 4090 SV *really = *++MARK;
4091 value = (I32)do_aexec(really, MARK, SP);
4092 }
4093 else if (SP - MARK != 1)
4094#ifdef VMS
4095 value = (I32)vms_do_aexec(Nullsv, MARK, SP);
4096#else
092bebab
JH		 4097# ifdef __OPEN_VM
4098 {
c5be433b 4099 (void ) do_aspawn(Nullsv, MARK, SP);
092bebab
JH		 4100 value = 0;
4101 }
4102# else
a0d0e21e 4103 value = (I32)do_aexec(Nullsv, MARK, SP);
092bebab 4104# endif
a0d0e21e
LW		 4105#endif
4106 else {
3280af22 4107 if (PL_tainting) {
516a5887 4108 (void)SvPV_nolen(*SP); /* stringify for taint check */
a0d0e21e
LW		 4109 TAINT_ENV();
4110 TAINT_PROPER("exec");
4111 }
4112#ifdef VMS
2d8e6c8d 4113 value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
a0d0e21e 4114#else
092bebab 4115# ifdef __OPEN_VM
c5be433b 4116 (void) do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
092bebab
JH		 4117 value = 0;
4118# else
2d8e6c8d 4119 value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
092bebab 4120# endif
a0d0e21e
LW		 4121#endif
4122 }
146174a9
CB		 4123
4124#if !defined(HAS_FORK) && defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4125 if (value >= 0)
4126 my_exit(value);
4127#endif
4128
a0d0e21e
LW		 4129 SP = ORIGMARK;
4130 PUSHi(value);
4131 RETURN;
4132}
4133
4134PP(pp_kill)
4135{
9cad6237 4136#ifdef HAS_KILL
39644a26 4137 dSP; dMARK; dTARGET;
a0d0e21e 4138 I32 value;
533c011a 4139 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 4140 SP = MARK;
4141 PUSHi(value);
4142 RETURN;
4143#else
0322a713 4144 DIE(aTHX_ PL_no_func, "kill");
a0d0e21e
LW		 4145#endif
4146}
4147
4148PP(pp_getppid)
4149{
4150#ifdef HAS_GETPPID
39644a26 4151 dSP; dTARGET;
a0d0e21e
LW		 4152 XPUSHi( getppid() );
4153 RETURN;
4154#else
cea2e8a9 4155 DIE(aTHX_ PL_no_func, "getppid");
a0d0e21e
LW		 4156#endif
4157}
4158
4159PP(pp_getpgrp)
4160{
4161#ifdef HAS_GETPGRP
39644a26 4162 dSP; dTARGET;
d8a83dd3 4163 Pid_t pid;
9853a804 4164 Pid_t pgrp;
a0d0e21e
LW		 4165
4166 if (MAXARG < 1)
4167 pid = 0;
4168 else
4169 pid = SvIVx(POPs);
c3293030 4170#ifdef BSD_GETPGRP
9853a804 4171 pgrp = (I32)BSD_GETPGRP(pid);
a0d0e21e 4172#else
146174a9 4173 if (pid != 0 && pid != PerlProc_getpid())
cea2e8a9 4174 DIE(aTHX_ "POSIX getpgrp can't take an argument");
9853a804 4175 pgrp = getpgrp();
a0d0e21e 4176#endif
9853a804 4177 XPUSHi(pgrp);
a0d0e21e
LW		 4178 RETURN;
4179#else
cea2e8a9 4180 DIE(aTHX_ PL_no_func, "getpgrp()");
a0d0e21e
LW		 4181#endif
4182}
4183
4184PP(pp_setpgrp)
4185{
4186#ifdef HAS_SETPGRP
39644a26 4187 dSP; dTARGET;
d8a83dd3
JH		 4188 Pid_t pgrp;
4189 Pid_t pid;
a0d0e21e
LW		 4190 if (MAXARG < 2) {
4191 pgrp = 0;
4192 pid = 0;
4193 }
4194 else {
4195 pgrp = POPi;
4196 pid = TOPi;
4197 }
4198
4199 TAINT_PROPER("setpgrp");
c3293030
IZ		 4200#ifdef BSD_SETPGRP
4201 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
a0d0e21e 4202#else
146174a9
CB		 4203 if ((pgrp != 0 && pgrp != PerlProc_getpid())
4204 || (pid != 0 && pid != PerlProc_getpid()))
4205 {
4206 DIE(aTHX_ "setpgrp can't take arguments");
4207 }
a0d0e21e
LW		 4208 SETi( setpgrp() >= 0 );
4209#endif /* USE_BSDPGRP */
4210 RETURN;
4211#else
cea2e8a9 4212 DIE(aTHX_ PL_no_func, "setpgrp()");
a0d0e21e
LW		 4213#endif
4214}
4215
4216PP(pp_getpriority)
4217{
a0d0e21e 4218#ifdef HAS_GETPRIORITY
9cad6237 4219 dSP; dTARGET;
d05c1ba0
JH		 4220 int who = POPi;
4221 int which = TOPi;
a0d0e21e
LW		 4222 SETi( getpriority(which, who) );
4223 RETURN;
4224#else
cea2e8a9 4225 DIE(aTHX_ PL_no_func, "getpriority()");
a0d0e21e
LW		 4226#endif
4227}
4228
4229PP(pp_setpriority)
4230{
a0d0e21e 4231#ifdef HAS_SETPRIORITY
9cad6237 4232 dSP; dTARGET;
d05c1ba0
JH		 4233 int niceval = POPi;
4234 int who = POPi;
4235 int which = TOPi;
a0d0e21e
LW		 4236 TAINT_PROPER("setpriority");
4237 SETi( setpriority(which, who, niceval) >= 0 );
4238 RETURN;
4239#else
cea2e8a9 4240 DIE(aTHX_ PL_no_func, "setpriority()");
a0d0e21e
LW		 4241#endif
4242}
4243
4244/* Time calls. */
4245
4246PP(pp_time)
4247{
39644a26 4248 dSP; dTARGET;
cbdc8872 4249#ifdef BIG_TIME
4250 XPUSHn( time(Null(Time_t*)) );
4251#else
a0d0e21e 4252 XPUSHi( time(Null(Time_t*)) );
cbdc8872 4253#endif
a0d0e21e
LW		 4254 RETURN;
4255}
4256
cd52b7b2 4257/* XXX The POSIX name is CLK_TCK; it is to be preferred
4258 to HZ. Probably. For now, assume that if the system
4259 defines HZ, it does so correctly. (Will this break
4260 on VMS?)
4261 Probably we ought to use _sysconf(_SC_CLK_TCK), if
4262 it's supported. --AD 9/96.
4263*/
4264
a0d0e21e 4265#ifndef HZ
cd52b7b2 4266# ifdef CLK_TCK
4267# define HZ CLK_TCK
4268# else
4269# define HZ 60
4270# endif
a0d0e21e
LW		 4271#endif
4272
4273PP(pp_tms)
4274{
9cad6237 4275#ifdef HAS_TIMES
39644a26 4276 dSP;
a0d0e21e 4277 EXTEND(SP, 4);
a0d0e21e 4278#ifndef VMS
3280af22 4279 (void)PerlProc_times(&PL_timesbuf);
a0d0e21e 4280#else
6b88bc9c 4281 (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
76e3520e
GS		 4282 /* struct tms, though same data */
4283 /* is returned. */
a0d0e21e
LW		 4284#endif
4285
65202027 4286 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_utime)/HZ)));
a0d0e21e 4287 if (GIMME == G_ARRAY) {
65202027
DS		 4288 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_stime)/HZ)));
4289 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cutime)/HZ)));
4290 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cstime)/HZ)));
a0d0e21e
LW		 4291 }
4292 RETURN;
9cad6237
JH		 4293#else
4294 DIE(aTHX_ "times not implemented");
55497cff 4295#endif /* HAS_TIMES */
a0d0e21e
LW		 4296}
4297
4298PP(pp_localtime)
4299{
cea2e8a9 4300 return pp_gmtime();
a0d0e21e
LW		 4301}
4302
4303PP(pp_gmtime)
4304{
39644a26 4305 dSP;
a0d0e21e
LW		 4306 Time_t when;
4307 struct tm *tmbuf;
4308 static char *dayname[] = {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4309 static char *monname[] = {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4310 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4311
4312 if (MAXARG < 1)
4313 (void)time(&when);
4314 else
cbdc8872 4315#ifdef BIG_TIME
4316 when = (Time_t)SvNVx(POPs);
4317#else
a0d0e21e 4318 when = (Time_t)SvIVx(POPs);
cbdc8872 4319#endif
a0d0e21e 4320
533c011a 4321 if (PL_op->op_type == OP_LOCALTIME)
a0d0e21e
LW		 4322 tmbuf = localtime(&when);
4323 else
4324 tmbuf = gmtime(&when);
4325
4326 EXTEND(SP, 9);
bbce6d69 4327 EXTEND_MORTAL(9);
a0d0e21e 4328 if (GIMME != G_ARRAY) {
46fc3d4c 4329 SV *tsv;
a0d0e21e
LW		 4330 if (!tmbuf)
4331 RETPUSHUNDEF;
be28567c 4332 tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %d",
f5a29b03
RB		 4333 dayname[tmbuf->tm_wday],
4334 monname[tmbuf->tm_mon],
be28567c
GS		 4335 tmbuf->tm_mday,
4336 tmbuf->tm_hour,
4337 tmbuf->tm_min,
4338 tmbuf->tm_sec,
4339 tmbuf->tm_year + 1900);
46fc3d4c 4340 PUSHs(sv_2mortal(tsv));
a0d0e21e
LW		 4341 }
4342 else if (tmbuf) {
c6419e06
JH		 4343 PUSHs(sv_2mortal(newSViv(tmbuf->tm_sec)));
4344 PUSHs(sv_2mortal(newSViv(tmbuf->tm_min)));
4345 PUSHs(sv_2mortal(newSViv(tmbuf->tm_hour)));
4346 PUSHs(sv_2mortal(newSViv(tmbuf->tm_mday)));
4347 PUSHs(sv_2mortal(newSViv(tmbuf->tm_mon)));
4348 PUSHs(sv_2mortal(newSViv(tmbuf->tm_year)));
4349 PUSHs(sv_2mortal(newSViv(tmbuf->tm_wday)));
4350 PUSHs(sv_2mortal(newSViv(tmbuf->tm_yday)));
4351 PUSHs(sv_2mortal(newSViv(tmbuf->tm_isdst)));
a0d0e21e
LW		 4352 }
4353 RETURN;
4354}
4355
4356PP(pp_alarm)
4357{
9cad6237 4358#ifdef HAS_ALARM
39644a26 4359 dSP; dTARGET;
a0d0e21e 4360 int anum;
a0d0e21e
LW		 4361 anum = POPi;
4362 anum = alarm((unsigned int)anum);
4363 EXTEND(SP, 1);
4364 if (anum < 0)
4365 RETPUSHUNDEF;
c6419e06 4366 PUSHi(anum);
a0d0e21e
LW		 4367 RETURN;
4368#else
0322a713 4369 DIE(aTHX_ PL_no_func, "alarm");
a0d0e21e
LW		 4370#endif
4371}
4372
4373PP(pp_sleep)
4374{
39644a26 4375 dSP; dTARGET;
a0d0e21e
LW		 4376 I32 duration;
4377 Time_t lasttime;
4378 Time_t when;
4379
4380 (void)time(&lasttime);
4381 if (MAXARG < 1)
76e3520e 4382 PerlProc_pause();
a0d0e21e
LW		 4383 else {
4384 duration = POPi;
76e3520e 4385 PerlProc_sleep((unsigned int)duration);
a0d0e21e
LW		 4386 }
4387 (void)time(&when);
4388 XPUSHi(when - lasttime);
4389 RETURN;
4390}
4391
4392/* Shared memory. */
4393
4394PP(pp_shmget)
4395{
cea2e8a9 4396 return pp_semget();
a0d0e21e
LW		 4397}
4398
4399PP(pp_shmctl)
4400{
cea2e8a9 4401 return pp_semctl();
a0d0e21e
LW		 4402}
4403
4404PP(pp_shmread)
4405{
cea2e8a9 4406 return pp_shmwrite();
a0d0e21e
LW		 4407}
4408
4409PP(pp_shmwrite)
4410{
4411#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
39644a26 4412 dSP; dMARK; dTARGET;
533c011a 4413 I32 value = (I32)(do_shmio(PL_op->op_type, MARK, SP) >= 0);
a0d0e21e
LW		 4414 SP = MARK;
4415 PUSHi(value);
4416 RETURN;
4417#else
cea2e8a9 4418 return pp_semget();
a0d0e21e
LW		 4419#endif
4420}
4421
4422/* Message passing. */
4423
4424PP(pp_msgget)
4425{
cea2e8a9 4426 return pp_semget();
a0d0e21e
LW		 4427}
4428
4429PP(pp_msgctl)
4430{
cea2e8a9 4431 return pp_semctl();
a0d0e21e
LW		 4432}
4433
4434PP(pp_msgsnd)
4435{
4436#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
39644a26 4437 dSP; dMARK; dTARGET;
a0d0e21e
LW		 4438 I32 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4439 SP = MARK;
4440 PUSHi(value);
4441 RETURN;
4442#else
cea2e8a9 4443 return pp_semget();
a0d0e21e
LW		 4444#endif
4445}
4446
4447PP(pp_msgrcv)
4448{
4449#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
39644a26 4450 dSP; dMARK; dTARGET;
a0d0e21e
LW		 4451 I32 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4452 SP = MARK;
4453 PUSHi(value);
4454 RETURN;
4455#else
cea2e8a9 4456 return pp_semget();
a0d0e21e
LW		 4457#endif
4458}
4459
4460/* Semaphores. */
4461
4462PP(pp_semget)
4463{
4464#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
39644a26 4465 dSP; dMARK; dTARGET;
533c011a 4466 int anum = do_ipcget(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 4467 SP = MARK;
4468 if (anum == -1)
4469 RETPUSHUNDEF;
4470 PUSHi(anum);
4471 RETURN;
4472#else
cea2e8a9 4473 DIE(aTHX_ "System V IPC is not implemented on this machine");
a0d0e21e
LW		 4474#endif
4475}
4476
4477PP(pp_semctl)
4478{
4479#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
39644a26 4480 dSP; dMARK; dTARGET;
533c011a 4481 int anum = do_ipcctl(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 4482 SP = MARK;
4483 if (anum == -1)
4484 RETSETUNDEF;
4485 if (anum != 0) {
4486 PUSHi(anum);
4487 }
4488 else {
8903cb82 4489 PUSHp(zero_but_true, ZBTLEN);
a0d0e21e
LW		 4490 }
4491 RETURN;
4492#else
cea2e8a9 4493 return pp_semget();
a0d0e21e
LW		 4494#endif
4495}
4496
4497PP(pp_semop)
4498{
4499#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
39644a26 4500 dSP; dMARK; dTARGET;
a0d0e21e
LW		 4501 I32 value = (I32)(do_semop(MARK, SP) >= 0);
4502 SP = MARK;
4503 PUSHi(value);
4504 RETURN;
4505#else
cea2e8a9 4506 return pp_semget();
a0d0e21e
LW		 4507#endif
4508}
4509
4510/* Get system info. */
4511
4512PP(pp_ghbyname)
4513{
693762b4 4514#ifdef HAS_GETHOSTBYNAME
cea2e8a9 4515 return pp_ghostent();
a0d0e21e 4516#else
cea2e8a9 4517 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
a0d0e21e
LW		 4518#endif
4519}
4520
4521PP(pp_ghbyaddr)
4522{
693762b4 4523#ifdef HAS_GETHOSTBYADDR
cea2e8a9 4524 return pp_ghostent();
a0d0e21e 4525#else
cea2e8a9 4526 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
a0d0e21e
LW		 4527#endif
4528}
4529
4530PP(pp_ghostent)
4531{
693762b4 4532#if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
9cad6237 4533 dSP;
533c011a 4534 I32 which = PL_op->op_type;
a0d0e21e
LW		 4535 register char **elem;
4536 register SV *sv;
dc45a647 4537#ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4599a1de
JH		 4538 struct hostent *PerlSock_gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4539 struct hostent *PerlSock_gethostbyname(Netdb_name_t);
6ad3d225 4540 struct hostent *PerlSock_gethostent(void);
a0d0e21e
LW		 4541#endif
4542 struct hostent *hent;
4543 unsigned long len;
2d8e6c8d 4544 STRLEN n_a;
a0d0e21e
LW		 4545
4546 EXTEND(SP, 10);
dc45a647
MB		 4547 if (which == OP_GHBYNAME)
4548#ifdef HAS_GETHOSTBYNAME
595ae481 4549 hent = PerlSock_gethostbyname(POPpbytex);
dc45a647 4550#else
cea2e8a9 4551 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
dc45a647 4552#endif
a0d0e21e 4553 else if (which == OP_GHBYADDR) {
dc45a647 4554#ifdef HAS_GETHOSTBYADDR
a0d0e21e 4555 int addrtype = POPi;
748a9306 4556 SV *addrsv = POPs;
a0d0e21e 4557 STRLEN addrlen;
595ae481 4558 Netdb_host_t addr = (Netdb_host_t) SvPVbyte(addrsv, addrlen);
a0d0e21e 4559
4599a1de 4560 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
dc45a647 4561#else
cea2e8a9 4562 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
dc45a647 4563#endif
a0d0e21e
LW		 4564 }
4565 else
4566#ifdef HAS_GETHOSTENT
6ad3d225 4567 hent = PerlSock_gethostent();
a0d0e21e 4568#else
cea2e8a9 4569 DIE(aTHX_ PL_no_sock_func, "gethostent");
a0d0e21e
LW		 4570#endif
4571
4572#ifdef HOST_NOT_FOUND
4573 if (!hent)
f86702cc 4574 STATUS_NATIVE_SET(h_errno);
a0d0e21e
LW		 4575#endif
4576
4577 if (GIMME != G_ARRAY) {
4578 PUSHs(sv = sv_newmortal());
4579 if (hent) {
4580 if (which == OP_GHBYNAME) {
fd0af264 4581 if (hent->h_addr)
4582 sv_setpvn(sv, hent->h_addr, hent->h_length);
a0d0e21e
LW		 4583 }
4584 else
4585 sv_setpv(sv, (char*)hent->h_name);
4586 }
4587 RETURN;
4588 }
4589
4590 if (hent) {
3280af22 4591 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4592 sv_setpv(sv, (char*)hent->h_name);
3280af22 4593 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 4594 for (elem = hent->h_aliases; elem && *elem; elem++) {
4595 sv_catpv(sv, *elem);
4596 if (elem[1])
4597 sv_catpvn(sv, " ", 1);
4598 }
3280af22 4599 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4600 sv_setiv(sv, (IV)hent->h_addrtype);
3280af22 4601 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4602 len = hent->h_length;
1e422769 4603 sv_setiv(sv, (IV)len);
a0d0e21e
LW		 4604#ifdef h_addr
4605 for (elem = hent->h_addr_list; elem && *elem; elem++) {
3280af22 4606 XPUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 4607 sv_setpvn(sv, *elem, len);
4608 }
4609#else
6b88bc9c 4610 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
fd0af264 4611 if (hent->h_addr)
4612 sv_setpvn(sv, hent->h_addr, len);
a0d0e21e
LW		 4613#endif /* h_addr */
4614 }
4615 RETURN;
4616#else
cea2e8a9 4617 DIE(aTHX_ PL_no_sock_func, "gethostent");
a0d0e21e
LW		 4618#endif
4619}
4620
4621PP(pp_gnbyname)
4622{
693762b4 4623#ifdef HAS_GETNETBYNAME
cea2e8a9 4624 return pp_gnetent();
a0d0e21e 4625#else
cea2e8a9 4626 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
a0d0e21e
LW		 4627#endif
4628}
4629
4630PP(pp_gnbyaddr)
4631{
693762b4 4632#ifdef HAS_GETNETBYADDR
cea2e8a9 4633 return pp_gnetent();
a0d0e21e 4634#else
cea2e8a9 4635 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
a0d0e21e
LW		 4636#endif
4637}
4638
4639PP(pp_gnetent)
4640{
693762b4 4641#if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
9cad6237 4642 dSP;
533c011a 4643 I32 which = PL_op->op_type;
a0d0e21e
LW		 4644 register char **elem;
4645 register SV *sv;
dc45a647
MB		 4646#ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4647 struct netent *PerlSock_getnetbyaddr(Netdb_net_t, int);
4648 struct netent *PerlSock_getnetbyname(Netdb_name_t);
4649 struct netent *PerlSock_getnetent(void);
8ac85365 4650#endif
a0d0e21e 4651 struct netent *nent;
2d8e6c8d 4652 STRLEN n_a;
a0d0e21e
LW		 4653
4654 if (which == OP_GNBYNAME)
dc45a647 4655#ifdef HAS_GETNETBYNAME
42e0c139 4656 nent = PerlSock_getnetbyname(POPpbytex);
dc45a647 4657#else
cea2e8a9 4658 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
dc45a647 4659#endif
a0d0e21e 4660 else if (which == OP_GNBYADDR) {
dc45a647 4661#ifdef HAS_GETNETBYADDR
a0d0e21e 4662 int addrtype = POPi;
3bb7c1b4 4663 Netdb_net_t addr = (Netdb_net_t) (U32)POPu;
76e3520e 4664 nent = PerlSock_getnetbyaddr(addr, addrtype);
dc45a647 4665#else
cea2e8a9 4666 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
dc45a647 4667#endif
a0d0e21e
LW		 4668 }
4669 else
dc45a647 4670#ifdef HAS_GETNETENT
76e3520e 4671 nent = PerlSock_getnetent();
dc45a647 4672#else
cea2e8a9 4673 DIE(aTHX_ PL_no_sock_func, "getnetent");
dc45a647 4674#endif
a0d0e21e
LW		 4675
4676 EXTEND(SP, 4);
4677 if (GIMME != G_ARRAY) {
4678 PUSHs(sv = sv_newmortal());
4679 if (nent) {
4680 if (which == OP_GNBYNAME)
1e422769 4681 sv_setiv(sv, (IV)nent->n_net);
a0d0e21e
LW		 4682 else
4683 sv_setpv(sv, nent->n_name);
4684 }
4685 RETURN;
4686 }
4687
4688 if (nent) {
3280af22 4689 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4690 sv_setpv(sv, nent->n_name);
3280af22 4691 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 4692 for (elem = nent->n_aliases; elem && *elem; elem++) {
a0d0e21e
LW		 4693 sv_catpv(sv, *elem);
4694 if (elem[1])
4695 sv_catpvn(sv, " ", 1);
4696 }
3280af22 4697 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4698 sv_setiv(sv, (IV)nent->n_addrtype);
3280af22 4699 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4700 sv_setiv(sv, (IV)nent->n_net);
a0d0e21e
LW		 4701 }
4702
4703 RETURN;
4704#else
cea2e8a9 4705 DIE(aTHX_ PL_no_sock_func, "getnetent");
a0d0e21e
LW		 4706#endif
4707}
4708
4709PP(pp_gpbyname)
4710{
693762b4 4711#ifdef HAS_GETPROTOBYNAME
cea2e8a9 4712 return pp_gprotoent();
a0d0e21e 4713#else
cea2e8a9 4714 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
a0d0e21e
LW		 4715#endif
4716}
4717
4718PP(pp_gpbynumber)
4719{
693762b4 4720#ifdef HAS_GETPROTOBYNUMBER
cea2e8a9 4721 return pp_gprotoent();
a0d0e21e 4722#else
cea2e8a9 4723 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
a0d0e21e
LW		 4724#endif
4725}
4726
4727PP(pp_gprotoent)
4728{
693762b4 4729#if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
9cad6237 4730 dSP;
533c011a 4731 I32 which = PL_op->op_type;
a0d0e21e 4732 register char **elem;
301e8125 4733 register SV *sv;
dc45a647 4734#ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4599a1de 4735 struct protoent *PerlSock_getprotobyname(Netdb_name_t);
6ad3d225
GS		 4736 struct protoent *PerlSock_getprotobynumber(int);
4737 struct protoent *PerlSock_getprotoent(void);
8ac85365 4738#endif
a0d0e21e 4739 struct protoent *pent;
2d8e6c8d 4740 STRLEN n_a;
a0d0e21e
LW		 4741
4742 if (which == OP_GPBYNAME)
e5c9fcd0 4743#ifdef HAS_GETPROTOBYNAME
42e0c139 4744 pent = PerlSock_getprotobyname(POPpbytex);
e5c9fcd0 4745#else
cea2e8a9 4746 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
e5c9fcd0 4747#endif
a0d0e21e 4748 else if (which == OP_GPBYNUMBER)
e5c9fcd0 4749#ifdef HAS_GETPROTOBYNUMBER
6ad3d225 4750 pent = PerlSock_getprotobynumber(POPi);
e5c9fcd0 4751#else
cea2e8a9 4752 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
e5c9fcd0 4753#endif
a0d0e21e 4754 else
e5c9fcd0 4755#ifdef HAS_GETPROTOENT
6ad3d225 4756 pent = PerlSock_getprotoent();
e5c9fcd0 4757#else
cea2e8a9 4758 DIE(aTHX_ PL_no_sock_func, "getprotoent");
e5c9fcd0 4759#endif
a0d0e21e
LW		 4760
4761 EXTEND(SP, 3);
4762 if (GIMME != G_ARRAY) {
4763 PUSHs(sv = sv_newmortal());
4764 if (pent) {
4765 if (which == OP_GPBYNAME)
1e422769 4766 sv_setiv(sv, (IV)pent->p_proto);
a0d0e21e
LW		 4767 else
4768 sv_setpv(sv, pent->p_name);
4769 }
4770 RETURN;
4771 }
4772
4773 if (pent) {
3280af22 4774 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4775 sv_setpv(sv, pent->p_name);
3280af22 4776 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 4777 for (elem = pent->p_aliases; elem && *elem; elem++) {
a0d0e21e
LW		 4778 sv_catpv(sv, *elem);
4779 if (elem[1])
4780 sv_catpvn(sv, " ", 1);
4781 }
3280af22 4782 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4783 sv_setiv(sv, (IV)pent->p_proto);
a0d0e21e
LW		 4784 }
4785
4786 RETURN;
4787#else
cea2e8a9 4788 DIE(aTHX_ PL_no_sock_func, "getprotoent");
a0d0e21e
LW		 4789#endif
4790}
4791
4792PP(pp_gsbyname)
4793{
9ec75305 4794#ifdef HAS_GETSERVBYNAME
cea2e8a9 4795 return pp_gservent();
a0d0e21e 4796#else
cea2e8a9 4797 DIE(aTHX_ PL_no_sock_func, "getservbyname");
a0d0e21e
LW		 4798#endif
4799}
4800
4801PP(pp_gsbyport)
4802{
9ec75305 4803#ifdef HAS_GETSERVBYPORT
cea2e8a9 4804 return pp_gservent();
a0d0e21e 4805#else
cea2e8a9 4806 DIE(aTHX_ PL_no_sock_func, "getservbyport");
a0d0e21e
LW		 4807#endif
4808}
4809
4810PP(pp_gservent)
4811{
693762b4 4812#if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
9cad6237 4813 dSP;
533c011a 4814 I32 which = PL_op->op_type;
a0d0e21e
LW		 4815 register char **elem;
4816 register SV *sv;
dc45a647 4817#ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4599a1de
JH		 4818 struct servent *PerlSock_getservbyname(Netdb_name_t, Netdb_name_t);
4819 struct servent *PerlSock_getservbyport(int, Netdb_name_t);
6ad3d225 4820 struct servent *PerlSock_getservent(void);
8ac85365 4821#endif
a0d0e21e 4822 struct servent *sent;
2d8e6c8d 4823 STRLEN n_a;
a0d0e21e
LW		 4824
4825 if (which == OP_GSBYNAME) {
dc45a647 4826#ifdef HAS_GETSERVBYNAME
42e0c139
AP		 4827 char *proto = POPpbytex;
4828 char *name = POPpbytex;
a0d0e21e
LW		 4829
4830 if (proto && !*proto)
4831 proto = Nullch;
4832
6ad3d225 4833 sent = PerlSock_getservbyname(name, proto);
dc45a647 4834#else
cea2e8a9 4835 DIE(aTHX_ PL_no_sock_func, "getservbyname");
dc45a647 4836#endif
a0d0e21e
LW		 4837 }
4838 else if (which == OP_GSBYPORT) {
dc45a647 4839#ifdef HAS_GETSERVBYPORT
42e0c139 4840 char *proto = POPpbytex;
36477c24 4841 unsigned short port = POPu;
a0d0e21e 4842
36477c24 4843#ifdef HAS_HTONS
6ad3d225 4844 port = PerlSock_htons(port);
36477c24 4845#endif
6ad3d225 4846 sent = PerlSock_getservbyport(port, proto);
dc45a647 4847#else
cea2e8a9 4848 DIE(aTHX_ PL_no_sock_func, "getservbyport");
dc45a647 4849#endif
a0d0e21e
LW		 4850 }
4851 else
e5c9fcd0 4852#ifdef HAS_GETSERVENT
6ad3d225 4853 sent = PerlSock_getservent();
e5c9fcd0 4854#else
cea2e8a9 4855 DIE(aTHX_ PL_no_sock_func, "getservent");
e5c9fcd0 4856#endif
a0d0e21e
LW		 4857
4858 EXTEND(SP, 4);
4859 if (GIMME != G_ARRAY) {
4860 PUSHs(sv = sv_newmortal());
4861 if (sent) {
4862 if (which == OP_GSBYNAME) {
4863#ifdef HAS_NTOHS
6ad3d225 4864 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
a0d0e21e 4865#else
1e422769 4866 sv_setiv(sv, (IV)(sent->s_port));
a0d0e21e
LW		 4867#endif
4868 }
4869 else
4870 sv_setpv(sv, sent->s_name);
4871 }
4872 RETURN;
4873 }
4874
4875 if (sent) {
3280af22 4876 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4877 sv_setpv(sv, sent->s_name);
3280af22 4878 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 4879 for (elem = sent->s_aliases; elem && *elem; elem++) {
a0d0e21e
LW		 4880 sv_catpv(sv, *elem);
4881 if (elem[1])
4882 sv_catpvn(sv, " ", 1);
4883 }
3280af22 4884 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4885#ifdef HAS_NTOHS
76e3520e 4886 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
a0d0e21e 4887#else
1e422769 4888 sv_setiv(sv, (IV)(sent->s_port));
a0d0e21e 4889#endif
3280af22 4890 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 4891 sv_setpv(sv, sent->s_proto);
4892 }
4893
4894 RETURN;
4895#else
cea2e8a9 4896 DIE(aTHX_ PL_no_sock_func, "getservent");
a0d0e21e
LW		 4897#endif
4898}
4899
4900PP(pp_shostent)
4901{
693762b4 4902#ifdef HAS_SETHOSTENT
9cad6237 4903 dSP;
76e3520e 4904 PerlSock_sethostent(TOPi);
a0d0e21e
LW		 4905 RETSETYES;
4906#else
cea2e8a9 4907 DIE(aTHX_ PL_no_sock_func, "sethostent");
a0d0e21e
LW		 4908#endif
4909}
4910
4911PP(pp_snetent)
4912{
693762b4 4913#ifdef HAS_SETNETENT
9cad6237 4914 dSP;
76e3520e 4915 PerlSock_setnetent(TOPi);
a0d0e21e
LW		 4916 RETSETYES;
4917#else
cea2e8a9 4918 DIE(aTHX_ PL_no_sock_func, "setnetent");
a0d0e21e
LW		 4919#endif
4920}
4921
4922PP(pp_sprotoent)
4923{
693762b4 4924#ifdef HAS_SETPROTOENT
9cad6237 4925 dSP;
76e3520e 4926 PerlSock_setprotoent(TOPi);
a0d0e21e
LW		 4927 RETSETYES;
4928#else
cea2e8a9 4929 DIE(aTHX_ PL_no_sock_func, "setprotoent");
a0d0e21e
LW		 4930#endif
4931}
4932
4933PP(pp_sservent)
4934{
693762b4 4935#ifdef HAS_SETSERVENT
9cad6237 4936 dSP;
76e3520e 4937 PerlSock_setservent(TOPi);
a0d0e21e
LW		 4938 RETSETYES;
4939#else
cea2e8a9 4940 DIE(aTHX_ PL_no_sock_func, "setservent");
a0d0e21e
LW		 4941#endif
4942}
4943
4944PP(pp_ehostent)
4945{
693762b4 4946#ifdef HAS_ENDHOSTENT
9cad6237 4947 dSP;
76e3520e 4948 PerlSock_endhostent();
924508f0 4949 EXTEND(SP,1);
a0d0e21e
LW		 4950 RETPUSHYES;
4951#else
cea2e8a9 4952 DIE(aTHX_ PL_no_sock_func, "endhostent");
a0d0e21e
LW		 4953#endif
4954}
4955
4956PP(pp_enetent)
4957{
693762b4 4958#ifdef HAS_ENDNETENT
9cad6237 4959 dSP;
76e3520e 4960 PerlSock_endnetent();
924508f0 4961 EXTEND(SP,1);
a0d0e21e
LW		 4962 RETPUSHYES;
4963#else
cea2e8a9 4964 DIE(aTHX_ PL_no_sock_func, "endnetent");
a0d0e21e
LW		 4965#endif
4966}
4967
4968PP(pp_eprotoent)
4969{
693762b4 4970#ifdef HAS_ENDPROTOENT
9cad6237 4971 dSP;
76e3520e 4972 PerlSock_endprotoent();
924508f0 4973 EXTEND(SP,1);
a0d0e21e
LW		 4974 RETPUSHYES;
4975#else
cea2e8a9 4976 DIE(aTHX_ PL_no_sock_func, "endprotoent");
a0d0e21e
LW		 4977#endif
4978}
4979
4980PP(pp_eservent)
4981{
693762b4 4982#ifdef HAS_ENDSERVENT
9cad6237 4983 dSP;
76e3520e 4984 PerlSock_endservent();
924508f0 4985 EXTEND(SP,1);
a0d0e21e
LW		 4986 RETPUSHYES;
4987#else
cea2e8a9 4988 DIE(aTHX_ PL_no_sock_func, "endservent");
a0d0e21e
LW		 4989#endif
4990}
4991
4992PP(pp_gpwnam)
4993{
4994#ifdef HAS_PASSWD
cea2e8a9 4995 return pp_gpwent();
a0d0e21e 4996#else
cea2e8a9 4997 DIE(aTHX_ PL_no_func, "getpwnam");
a0d0e21e
LW		 4998#endif
4999}
5000
5001PP(pp_gpwuid)
5002{
5003#ifdef HAS_PASSWD
cea2e8a9 5004 return pp_gpwent();
a0d0e21e 5005#else
cea2e8a9 5006 DIE(aTHX_ PL_no_func, "getpwuid");
a0d0e21e
LW		 5007#endif
5008}
5009
5010PP(pp_gpwent)
5011{
0994c4d0 5012#ifdef HAS_PASSWD
9cad6237 5013 dSP;
533c011a 5014 I32 which = PL_op->op_type;
a0d0e21e 5015 register SV *sv;
2d8e6c8d 5016 STRLEN n_a;
e3aefe8d 5017 struct passwd *pwent = NULL;
301e8125 5018 /*
bcf53261
JH		 5019 * We currently support only the SysV getsp* shadow password interface.
5020 * The interface is declared in <shadow.h> and often one needs to link
5021 * with -lsecurity or some such.
5022 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5023 * (and SCO?)
5024 *
5025 * AIX getpwnam() is clever enough to return the encrypted password
5026 * only if the caller (euid?) is root.
5027 *
5028 * There are at least two other shadow password APIs. Many platforms
5029 * seem to contain more than one interface for accessing the shadow
5030 * password databases, possibly for compatibility reasons.
3813c136 5031 * The getsp*() is by far he simplest one, the other two interfaces
bcf53261
JH		 5032 * are much more complicated, but also very similar to each other.
5033 *
5034 * <sys/types.h>
5035 * <sys/security.h>
5036 * <prot.h>
5037 * struct pr_passwd *getprpw*();
5038 * The password is in
3813c136
JH		 5039 * char getprpw*(...).ufld.fd_encrypt[]
5040 * Mention HAS_GETPRPWNAM here so that Configure probes for it.
bcf53261
JH		 5041 *
5042 * <sys/types.h>
5043 * <sys/security.h>
5044 * <prot.h>
5045 * struct es_passwd *getespw*();
5046 * The password is in
5047 * char *(getespw*(...).ufld.fd_encrypt)
3813c136 5048 * Mention HAS_GETESPWNAM here so that Configure probes for it.
bcf53261 5049 *
3813c136 5050 * Mention I_PROT here so that Configure probes for it.
bcf53261
JH		 5051 *
5052 * In HP-UX for getprpw*() the manual page claims that one should include
5053 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5054 * if one includes <shadow.h> as that includes <hpsecurity.h>,
5055 * and pp_sys.c already includes <shadow.h> if there is such.
3813c136
JH		 5056 *
5057 * Note that <sys/security.h> is already probed for, but currently
5058 * it is only included in special cases.
301e8125 5059 *
bcf53261
JH		 5060 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5061 * be preferred interface, even though also the getprpw*() interface
5062 * is available) one needs to link with -lsecurity -ldb -laud -lm.
3813c136
JH		 5063 * One also needs to call set_auth_parameters() in main() before
5064 * doing anything else, whether one is using getespw*() or getprpw*().
5065 *
5066 * Note that accessing the shadow databases can be magnitudes
5067 * slower than accessing the standard databases.
bcf53261
JH		 5068 *
5069 * --jhi
5070 */
a0d0e21e 5071
e3aefe8d
JH		 5072 switch (which) {
5073 case OP_GPWNAM:
42e0c139 5074 pwent = getpwnam(POPpbytex);
e3aefe8d
JH		 5075 break;
5076 case OP_GPWUID:
5077 pwent = getpwuid((Uid_t)POPi);
5078 break;
5079 case OP_GPWENT:
1883634f 5080# ifdef HAS_GETPWENT
e3aefe8d 5081 pwent = getpwent();
1883634f 5082# else
a45d1c96 5083 DIE(aTHX_ PL_no_func, "getpwent");
1883634f 5084# endif
e3aefe8d
JH		 5085 break;
5086 }
8c0bfa08 5087
a0d0e21e
LW		 5088 EXTEND(SP, 10);
5089 if (GIMME != G_ARRAY) {
5090 PUSHs(sv = sv_newmortal());
5091 if (pwent) {
5092 if (which == OP_GPWNAM)
1883634f 5093# if Uid_t_sign <= 0
1e422769 5094 sv_setiv(sv, (IV)pwent->pw_uid);
1883634f 5095# else
23dcd6c8 5096 sv_setuv(sv, (UV)pwent->pw_uid);
1883634f 5097# endif
a0d0e21e
LW		 5098 else
5099 sv_setpv(sv, pwent->pw_name);
5100 }
5101 RETURN;
5102 }
5103
5104 if (pwent) {
3280af22 5105 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 5106 sv_setpv(sv, pwent->pw_name);
6ee623d5 5107
3280af22 5108 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
3813c136
JH		 5109 SvPOK_off(sv);
5110 /* If we have getspnam(), we try to dig up the shadow
5111 * password. If we are underprivileged, the shadow
5112 * interface will set the errno to EACCES or similar,
5113 * and return a null pointer. If this happens, we will
5114 * use the dummy password (usually "*" or "x") from the
5115 * standard password database.
5116 *
5117 * In theory we could skip the shadow call completely
5118 * if euid != 0 but in practice we cannot know which
5119 * security measures are guarding the shadow databases
5120 * on a random platform.
5121 *
5122 * Resist the urge to use additional shadow interfaces.
5123 * Divert the urge to writing an extension instead.
5124 *
5125 * --jhi */
e3aefe8d 5126# ifdef HAS_GETSPNAM
3813c136
JH		 5127 {
5128 struct spwd *spwent;
5129 int saverrno; /* Save and restore errno so that
5130 * underprivileged attempts seem
5131 * to have never made the unsccessful
5132 * attempt to retrieve the shadow password. */
5133
5134 saverrno = errno;
5135 spwent = getspnam(pwent->pw_name);
5136 errno = saverrno;
5137 if (spwent && spwent->sp_pwdp)
5138 sv_setpv(sv, spwent->sp_pwdp);
5139 }
f1066039 5140# endif
e020c87d 5141# ifdef PWPASSWD
3813c136
JH		 5142 if (!SvPOK(sv)) /* Use the standard password, then. */
5143 sv_setpv(sv, pwent->pw_passwd);
e020c87d 5144# endif
3813c136 5145
1883634f 5146# ifndef INCOMPLETE_TAINTS
3813c136
JH		 5147 /* passwd is tainted because user himself can diddle with it.
5148 * admittedly not much and in a very limited way, but nevertheless. */
2959b6e3 5149 SvTAINTED_on(sv);
1883634f 5150# endif
6ee623d5 5151
3280af22 5152 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1883634f 5153# if Uid_t_sign <= 0
1e422769 5154 sv_setiv(sv, (IV)pwent->pw_uid);
1883634f 5155# else
23dcd6c8 5156 sv_setuv(sv, (UV)pwent->pw_uid);
1883634f 5157# endif
6ee623d5 5158
3280af22 5159 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1883634f 5160# if Uid_t_sign <= 0
1e422769 5161 sv_setiv(sv, (IV)pwent->pw_gid);
1883634f 5162# else
23dcd6c8 5163 sv_setuv(sv, (UV)pwent->pw_gid);
1883634f 5164# endif
3813c136
JH		 5165 /* pw_change, pw_quota, and pw_age are mutually exclusive--
5166 * because of the poor interface of the Perl getpw*(),
5167 * not because there's some standard/convention saying so.
5168 * A better interface would have been to return a hash,
5169 * but we are accursed by our history, alas. --jhi. */
3280af22 5170 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1883634f 5171# ifdef PWCHANGE
1e422769 5172 sv_setiv(sv, (IV)pwent->pw_change);
6ee623d5 5173# else
1883634f
JH		 5174# ifdef PWQUOTA
5175 sv_setiv(sv, (IV)pwent->pw_quota);
5176# else
a1757be1 5177# ifdef PWAGE
a0d0e21e 5178 sv_setpv(sv, pwent->pw_age);
a1757be1 5179# endif
6ee623d5
GS		 5180# endif
5181# endif
6ee623d5 5182
3813c136
JH		 5183 /* pw_class and pw_comment are mutually exclusive--.
5184 * see the above note for pw_change, pw_quota, and pw_age. */
3280af22 5185 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1883634f 5186# ifdef PWCLASS
a0d0e21e 5187 sv_setpv(sv, pwent->pw_class);
1883634f
JH		 5188# else
5189# ifdef PWCOMMENT
a0d0e21e 5190 sv_setpv(sv, pwent->pw_comment);
1883634f 5191# endif
6ee623d5 5192# endif
6ee623d5 5193
3280af22 5194 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1883634f 5195# ifdef PWGECOS
a0d0e21e 5196 sv_setpv(sv, pwent->pw_gecos);
1883634f
JH		 5197# endif
5198# ifndef INCOMPLETE_TAINTS
d2719217 5199 /* pw_gecos is tainted because user himself can diddle with it. */
fb73857a 5200 SvTAINTED_on(sv);
1883634f 5201# endif
6ee623d5 5202
3280af22 5203 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 5204 sv_setpv(sv, pwent->pw_dir);
6ee623d5 5205
3280af22 5206 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 5207 sv_setpv(sv, pwent->pw_shell);
1883634f 5208# ifndef INCOMPLETE_TAINTS
4602f195
JH		 5209 /* pw_shell is tainted because user himself can diddle with it. */
5210 SvTAINTED_on(sv);
1883634f 5211# endif
6ee623d5 5212
1883634f 5213# ifdef PWEXPIRE
6b88bc9c 5214 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 5215 sv_setiv(sv, (IV)pwent->pw_expire);
1883634f 5216# endif
a0d0e21e
LW		 5217 }
5218 RETURN;
5219#else
cea2e8a9 5220 DIE(aTHX_ PL_no_func, "getpwent");
a0d0e21e
LW		 5221#endif
5222}
5223
5224PP(pp_spwent)
5225{
d493b042 5226#if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
9cad6237 5227 dSP;
a0d0e21e
LW		 5228 setpwent();
5229 RETPUSHYES;
5230#else
cea2e8a9 5231 DIE(aTHX_ PL_no_func, "setpwent");
a0d0e21e
LW		 5232#endif
5233}
5234
5235PP(pp_epwent)
5236{
28e8609d 5237#if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
9cad6237 5238 dSP;
a0d0e21e
LW		 5239 endpwent();
5240 RETPUSHYES;
5241#else
cea2e8a9 5242 DIE(aTHX_ PL_no_func, "endpwent");
a0d0e21e
LW		 5243#endif
5244}
5245
5246PP(pp_ggrnam)
5247{
5248#ifdef HAS_GROUP
cea2e8a9 5249 return pp_ggrent();
a0d0e21e 5250#else
cea2e8a9 5251 DIE(aTHX_ PL_no_func, "getgrnam");
a0d0e21e
LW		 5252#endif
5253}
5254
5255PP(pp_ggrgid)
5256{
5257#ifdef HAS_GROUP
cea2e8a9 5258 return pp_ggrent();
a0d0e21e 5259#else
cea2e8a9 5260 DIE(aTHX_ PL_no_func, "getgrgid");
a0d0e21e
LW		 5261#endif
5262}
5263
5264PP(pp_ggrent)
5265{
0994c4d0 5266#ifdef HAS_GROUP
9cad6237 5267 dSP;
533c011a 5268 I32 which = PL_op->op_type;
a0d0e21e
LW		 5269 register char **elem;
5270 register SV *sv;
5271 struct group *grent;
2d8e6c8d 5272 STRLEN n_a;
a0d0e21e
LW		 5273
5274 if (which == OP_GGRNAM)
42e0c139 5275 grent = (struct group *)getgrnam(POPpbytex);
a0d0e21e
LW		 5276 else if (which == OP_GGRGID)
5277 grent = (struct group *)getgrgid(POPi);
5278 else
0994c4d0 5279#ifdef HAS_GETGRENT
a0d0e21e 5280 grent = (struct group *)getgrent();
0994c4d0
JH		 5281#else
5282 DIE(aTHX_ PL_no_func, "getgrent");
5283#endif
a0d0e21e
LW		 5284
5285 EXTEND(SP, 4);
5286 if (GIMME != G_ARRAY) {
5287 PUSHs(sv = sv_newmortal());
5288 if (grent) {
5289 if (which == OP_GGRNAM)
1e422769 5290 sv_setiv(sv, (IV)grent->gr_gid);
a0d0e21e
LW		 5291 else
5292 sv_setpv(sv, grent->gr_name);
5293 }
5294 RETURN;
5295 }
5296
5297 if (grent) {
3280af22 5298 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 5299 sv_setpv(sv, grent->gr_name);
28e8609d 5300
3280af22 5301 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
28e8609d 5302#ifdef GRPASSWD
a0d0e21e 5303 sv_setpv(sv, grent->gr_passwd);
28e8609d
JH		 5304#endif
5305
3280af22 5306 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 5307 sv_setiv(sv, (IV)grent->gr_gid);
28e8609d 5308
3280af22 5309 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 5310 for (elem = grent->gr_mem; elem && *elem; elem++) {
a0d0e21e
LW		 5311 sv_catpv(sv, *elem);
5312 if (elem[1])
5313 sv_catpvn(sv, " ", 1);
5314 }
5315 }
5316
5317 RETURN;
5318#else
cea2e8a9 5319 DIE(aTHX_ PL_no_func, "getgrent");
a0d0e21e
LW		 5320#endif
5321}
5322
5323PP(pp_sgrent)
5324{
28e8609d 5325#if defined(HAS_GROUP) && defined(HAS_SETGRENT)
9cad6237 5326 dSP;
a0d0e21e
LW		 5327 setgrent();
5328 RETPUSHYES;
5329#else
cea2e8a9 5330 DIE(aTHX_ PL_no_func, "setgrent");
a0d0e21e
LW		 5331#endif
5332}
5333
5334PP(pp_egrent)
5335{
28e8609d 5336#if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
9cad6237 5337 dSP;
a0d0e21e
LW		 5338 endgrent();
5339 RETPUSHYES;
5340#else
cea2e8a9 5341 DIE(aTHX_ PL_no_func, "endgrent");
a0d0e21e
LW		 5342#endif
5343}
5344
5345PP(pp_getlogin)
5346{
a0d0e21e 5347#ifdef HAS_GETLOGIN
9cad6237 5348 dSP; dTARGET;
a0d0e21e
LW		 5349 char *tmps;
5350 EXTEND(SP, 1);
76e3520e 5351 if (!(tmps = PerlProc_getlogin()))
a0d0e21e
LW		 5352 RETPUSHUNDEF;
5353 PUSHp(tmps, strlen(tmps));
5354 RETURN;
5355#else
cea2e8a9 5356 DIE(aTHX_ PL_no_func, "getlogin");
a0d0e21e
LW		 5357#endif
5358}
5359
5360/* Miscellaneous. */
5361
5362PP(pp_syscall)
5363{
d2719217 5364#ifdef HAS_SYSCALL
39644a26 5365 dSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 5366 register I32 items = SP - MARK;
5367 unsigned long a[20];
5368 register I32 i = 0;
5369 I32 retval = -1;
2d8e6c8d 5370 STRLEN n_a;
a0d0e21e 5371
3280af22 5372 if (PL_tainting) {
a0d0e21e 5373 while (++MARK <= SP) {
bbce6d69 5374 if (SvTAINTED(*MARK)) {
5375 TAINT;
5376 break;
5377 }
a0d0e21e
LW		 5378 }
5379 MARK = ORIGMARK;
5380 TAINT_PROPER("syscall");
5381 }
5382
5383 /* This probably won't work on machines where sizeof(long) != sizeof(int)
5384 * or where sizeof(long) != sizeof(char*). But such machines will
5385 * not likely have syscall implemented either, so who cares?
5386 */
5387 while (++MARK <= SP) {
5388 if (SvNIOK(*MARK) || !i)
5389 a[i++] = SvIV(*MARK);
3280af22 5390 else if (*MARK == &PL_sv_undef)
748a9306 5391 a[i++] = 0;
301e8125 5392 else
2d8e6c8d 5393 a[i++] = (unsigned long)SvPV_force(*MARK, n_a);
a0d0e21e
LW		 5394 if (i > 15)
5395 break;
5396 }
5397 switch (items) {
5398 default:
cea2e8a9 5399 DIE(aTHX_ "Too many args to syscall");
a0d0e21e 5400 case 0:
cea2e8a9 5401 DIE(aTHX_ "Too few args to syscall");
a0d0e21e
LW		 5402 case 1:
5403 retval = syscall(a[0]);
5404 break;
5405 case 2:
5406 retval = syscall(a[0],a[1]);
5407 break;
5408 case 3:
5409 retval = syscall(a[0],a[1],a[2]);
5410 break;
5411 case 4:
5412 retval = syscall(a[0],a[1],a[2],a[3]);
5413 break;
5414 case 5:
5415 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5416 break;
5417 case 6:
5418 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5419 break;
5420 case 7:
5421 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5422 break;
5423 case 8:
5424 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5425 break;
5426#ifdef atarist
5427 case 9:
5428 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5429 break;
5430 case 10:
5431 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5432 break;
5433 case 11:
5434 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5435 a[10]);
5436 break;
5437 case 12:
5438 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5439 a[10],a[11]);
5440 break;
5441 case 13:
5442 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5443 a[10],a[11],a[12]);
5444 break;
5445 case 14:
5446 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5447 a[10],a[11],a[12],a[13]);
5448 break;
5449#endif /* atarist */
5450 }
5451 SP = ORIGMARK;
5452 PUSHi(retval);
5453 RETURN;
5454#else
cea2e8a9 5455 DIE(aTHX_ PL_no_func, "syscall");
a0d0e21e
LW		 5456#endif
5457}
5458
ff68c719 5459#ifdef FCNTL_EMULATE_FLOCK
301e8125 5460
ff68c719 5461/* XXX Emulate flock() with fcntl().
5462 What's really needed is a good file locking module.
5463*/
5464
cea2e8a9
GS		 5465static int
5466fcntl_emulate_flock(int fd, int operation)
ff68c719 5467{
5468 struct flock flock;
301e8125 5469
ff68c719 5470 switch (operation & ~LOCK_NB) {
5471 case LOCK_SH:
5472 flock.l_type = F_RDLCK;
5473 break;
5474 case LOCK_EX:
5475 flock.l_type = F_WRLCK;
5476 break;
5477 case LOCK_UN:
5478 flock.l_type = F_UNLCK;
5479 break;
5480 default:
5481 errno = EINVAL;
5482 return -1;
5483 }
5484 flock.l_whence = SEEK_SET;
d9b3e12d 5485 flock.l_start = flock.l_len = (Off_t)0;
301e8125 5486
ff68c719 5487 return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5488}
5489
5490#endif /* FCNTL_EMULATE_FLOCK */
5491
5492#ifdef LOCKF_EMULATE_FLOCK
16d20bd9
AD		 5493
5494/* XXX Emulate flock() with lockf(). This is just to increase
5495 portability of scripts. The calls are not completely
5496 interchangeable. What's really needed is a good file
5497 locking module.
5498*/
5499
76c32331 5500/* The lockf() constants might have been defined in <unistd.h>.
5501 Unfortunately, <unistd.h> causes troubles on some mixed
5502 (BSD/POSIX) systems, such as SunOS 4.1.3.
16d20bd9
AD		 5503
5504 Further, the lockf() constants aren't POSIX, so they might not be
5505 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5506 just stick in the SVID values and be done with it. Sigh.
5507*/
5508
5509# ifndef F_ULOCK
5510# define F_ULOCK 0 /* Unlock a previously locked region */
5511# endif
5512# ifndef F_LOCK
5513# define F_LOCK 1 /* Lock a region for exclusive use */
5514# endif
5515# ifndef F_TLOCK
5516# define F_TLOCK 2 /* Test and lock a region for exclusive use */
5517# endif
5518# ifndef F_TEST
5519# define F_TEST 3 /* Test a region for other processes locks */
5520# endif
5521
cea2e8a9
GS		 5522static int
5523lockf_emulate_flock(int fd, int operation)
16d20bd9
AD		 5524{
5525 int i;
84902520
TB		 5526 int save_errno;
5527 Off_t pos;
5528
5529 /* flock locks entire file so for lockf we need to do the same */
5530 save_errno = errno;
6ad3d225 5531 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
84902520 5532 if (pos > 0) /* is seekable and needs to be repositioned */
6ad3d225 5533 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
08b714dd 5534 pos = -1; /* seek failed, so don't seek back afterwards */
84902520
TB		 5535 errno = save_errno;
5536
16d20bd9
AD		 5537 switch (operation) {
5538
5539 /* LOCK_SH - get a shared lock */
5540 case LOCK_SH:
5541 /* LOCK_EX - get an exclusive lock */
5542 case LOCK_EX:
5543 i = lockf (fd, F_LOCK, 0);
5544 break;
5545
5546 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5547 case LOCK_SH|LOCK_NB:
5548 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5549 case LOCK_EX|LOCK_NB:
5550 i = lockf (fd, F_TLOCK, 0);
5551 if (i == -1)
5552 if ((errno == EAGAIN) || (errno == EACCES))
5553 errno = EWOULDBLOCK;
5554 break;
5555
ff68c719 5556 /* LOCK_UN - unlock (non-blocking is a no-op) */
16d20bd9 5557 case LOCK_UN:
ff68c719 5558 case LOCK_UN|LOCK_NB:
16d20bd9
AD		 5559 i = lockf (fd, F_ULOCK, 0);
5560 break;
5561
5562 /* Default - can't decipher operation */
5563 default:
5564 i = -1;
5565 errno = EINVAL;
5566 break;
5567 }
84902520
TB		 5568
5569 if (pos > 0) /* need to restore position of the handle */
6ad3d225 5570 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
84902520 5571
16d20bd9
AD		 5572 return (i);
5573}
ff68c719 5574
5575#endif /* LOCKF_EMULATE_FLOCK */
Unnamed repository; edit this file 'description' to name the repository.