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