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