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