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