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