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