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