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