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