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
$ref1 == $ref2 without NV_PRESERVES_UV
[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
57171420
BS		 2208 if (IoIFP(io))
2209 do_close(gv, FALSE);
2210
a0d0e21e 2211 TAINT_PROPER("socket");
6ad3d225 2212 fd = PerlSock_socket(domain, type, protocol);
a0d0e21e
LW		 2213 if (fd < 0)
2214 RETPUSHUNDEF;
760ac839
LW		 2215 IoIFP(io) = PerlIO_fdopen(fd, "r"); /* stdio gets confused about sockets */
2216 IoOFP(io) = PerlIO_fdopen(fd, "w");
50952442 2217 IoTYPE(io) = IoTYPE_SOCKET;
a0d0e21e 2218 if (!IoIFP(io) || !IoOFP(io)) {
760ac839
LW		 2219 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2220 if (IoOFP(io)) PerlIO_close(IoOFP(io));
6ad3d225 2221 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
a0d0e21e
LW		 2222 RETPUSHUNDEF;
2223 }
8d2a6795
GS		 2224#if defined(HAS_FCNTL) && defined(F_SETFD)
2225 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2226#endif
a0d0e21e 2227
d5ff79b3
OF		 2228#ifdef EPOC
2229 setbuf( IoIFP(io), NULL); /* EPOC gets confused about sockets */
2230#endif
2231
a0d0e21e
LW		 2232 RETPUSHYES;
2233#else
cea2e8a9 2234 DIE(aTHX_ PL_no_sock_func, "socket");
a0d0e21e
LW		 2235#endif
2236}
2237
2238PP(pp_sockpair)
2239{
39644a26 2240 dSP;
a0d0e21e
LW		 2241#ifdef HAS_SOCKETPAIR
2242 GV *gv1;
2243 GV *gv2;
2244 register IO *io1;
2245 register IO *io2;
2246 int protocol = POPi;
2247 int type = POPi;
2248 int domain = POPi;
2249 int fd[2];
2250
2251 gv2 = (GV*)POPs;
2252 gv1 = (GV*)POPs;
c289d2f7
JH		 2253 io1 = gv1 ? GvIOn(gv1) : NULL;
2254 io2 = gv2 ? GvIOn(gv2) : NULL;
2255 if (!gv1 || !gv2 || !io1 || !io2) {
2256 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
2257 if (!gv1 || !io1)
2258 report_evil_fh(gv1, io1, PL_op->op_type);
2259 if (!gv2 || !io2)
2260 report_evil_fh(gv1, io2, PL_op->op_type);
2261 }
2262 if (IoIFP(io1))
2263 do_close(gv1, FALSE);
2264 if (IoIFP(io2))
2265 do_close(gv2, FALSE);
a0d0e21e 2266 RETPUSHUNDEF;
c289d2f7 2267 }
a0d0e21e 2268
57171420
BS		 2269 if (IoIFP(io))
2270 do_close(gv, FALSE);
2271
a0d0e21e 2272 TAINT_PROPER("socketpair");
6ad3d225 2273 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
a0d0e21e 2274 RETPUSHUNDEF;
760ac839
LW		 2275 IoIFP(io1) = PerlIO_fdopen(fd[0], "r");
2276 IoOFP(io1) = PerlIO_fdopen(fd[0], "w");
50952442 2277 IoTYPE(io1) = IoTYPE_SOCKET;
760ac839
LW		 2278 IoIFP(io2) = PerlIO_fdopen(fd[1], "r");
2279 IoOFP(io2) = PerlIO_fdopen(fd[1], "w");
50952442 2280 IoTYPE(io2) = IoTYPE_SOCKET;
a0d0e21e 2281 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
760ac839
LW		 2282 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2283 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
6ad3d225 2284 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
760ac839
LW		 2285 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2286 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
6ad3d225 2287 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
a0d0e21e
LW		 2288 RETPUSHUNDEF;
2289 }
8d2a6795
GS		 2290#if defined(HAS_FCNTL) && defined(F_SETFD)
2291 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
2292 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
2293#endif
a0d0e21e
LW		 2294
2295 RETPUSHYES;
2296#else
cea2e8a9 2297 DIE(aTHX_ PL_no_sock_func, "socketpair");
a0d0e21e
LW		 2298#endif
2299}
2300
2301PP(pp_bind)
2302{
39644a26 2303 dSP;
a0d0e21e 2304#ifdef HAS_SOCKET
eec2d3df
GS		 2305#ifdef MPE /* Requires PRIV mode to bind() to ports < 1024 */
2306 extern GETPRIVMODE();
2307 extern GETUSERMODE();
2308#endif
748a9306 2309 SV *addrsv = POPs;
a0d0e21e
LW		 2310 char *addr;
2311 GV *gv = (GV*)POPs;
2312 register IO *io = GvIOn(gv);
2313 STRLEN len;
eec2d3df
GS		 2314 int bind_ok = 0;
2315#ifdef MPE
2316 int mpeprivmode = 0;
2317#endif
a0d0e21e
LW		 2318
2319 if (!io || !IoIFP(io))
2320 goto nuts;
2321
748a9306 2322 addr = SvPV(addrsv, len);
a0d0e21e 2323 TAINT_PROPER("bind");
eec2d3df
GS		 2324#ifdef MPE /* Deal with MPE bind() peculiarities */
2325 if (((struct sockaddr *)addr)->sa_family == AF_INET) {
2326 /* The address *MUST* stupidly be zero. */
2327 ((struct sockaddr_in *)addr)->sin_addr.s_addr = INADDR_ANY;
2328 /* PRIV mode is required to bind() to ports < 1024. */
2329 if (((struct sockaddr_in *)addr)->sin_port < 1024 &&
2330 ((struct sockaddr_in *)addr)->sin_port > 0) {
2331 GETPRIVMODE(); /* If this fails, we are aborted by MPE/iX. */
2332 mpeprivmode = 1;
2333 }
2334 }
2335#endif /* MPE */
2336 if (PerlSock_bind(PerlIO_fileno(IoIFP(io)),
2337 (struct sockaddr *)addr, len) >= 0)
2338 bind_ok = 1;
2339
2340#ifdef MPE /* Switch back to USER mode */
2341 if (mpeprivmode)
2342 GETUSERMODE();
2343#endif /* MPE */
2344
2345 if (bind_ok)
a0d0e21e
LW		 2346 RETPUSHYES;
2347 else
2348 RETPUSHUNDEF;
2349
2350nuts:
599cee73 2351 if (ckWARN(WARN_CLOSED))
bc37a18f 2352 report_evil_fh(gv, io, PL_op->op_type);
748a9306 2353 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2354 RETPUSHUNDEF;
2355#else
cea2e8a9 2356 DIE(aTHX_ PL_no_sock_func, "bind");
a0d0e21e
LW		 2357#endif
2358}
2359
2360PP(pp_connect)
2361{
39644a26 2362 dSP;
a0d0e21e 2363#ifdef HAS_SOCKET
748a9306 2364 SV *addrsv = POPs;
a0d0e21e
LW		 2365 char *addr;
2366 GV *gv = (GV*)POPs;
2367 register IO *io = GvIOn(gv);
2368 STRLEN len;
2369
2370 if (!io || !IoIFP(io))
2371 goto nuts;
2372
748a9306 2373 addr = SvPV(addrsv, len);
a0d0e21e 2374 TAINT_PROPER("connect");
6ad3d225 2375 if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
a0d0e21e
LW		 2376 RETPUSHYES;
2377 else
2378 RETPUSHUNDEF;
2379
2380nuts:
599cee73 2381 if (ckWARN(WARN_CLOSED))
bc37a18f 2382 report_evil_fh(gv, io, PL_op->op_type);
748a9306 2383 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2384 RETPUSHUNDEF;
2385#else
cea2e8a9 2386 DIE(aTHX_ PL_no_sock_func, "connect");
a0d0e21e
LW		 2387#endif
2388}
2389
2390PP(pp_listen)
2391{
39644a26 2392 dSP;
a0d0e21e
LW		 2393#ifdef HAS_SOCKET
2394 int backlog = POPi;
2395 GV *gv = (GV*)POPs;
c289d2f7 2396 register IO *io = gv ? GvIOn(gv) : NULL;
a0d0e21e 2397
c289d2f7 2398 if (!gv || !io || !IoIFP(io))
a0d0e21e
LW		 2399 goto nuts;
2400
6ad3d225 2401 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
a0d0e21e
LW		 2402 RETPUSHYES;
2403 else
2404 RETPUSHUNDEF;
2405
2406nuts:
599cee73 2407 if (ckWARN(WARN_CLOSED))
bc37a18f 2408 report_evil_fh(gv, io, PL_op->op_type);
748a9306 2409 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2410 RETPUSHUNDEF;
2411#else
cea2e8a9 2412 DIE(aTHX_ PL_no_sock_func, "listen");
a0d0e21e
LW		 2413#endif
2414}
2415
2416PP(pp_accept)
2417{
39644a26 2418 dSP; dTARGET;
a0d0e21e
LW		 2419#ifdef HAS_SOCKET
2420 GV *ngv;
2421 GV *ggv;
2422 register IO *nstio;
2423 register IO *gstio;
4633a7c4 2424 struct sockaddr saddr; /* use a struct to avoid alignment problems */
1e422769 2425 Sock_size_t len = sizeof saddr;
a0d0e21e
LW		 2426 int fd;
2427
2428 ggv = (GV*)POPs;
2429 ngv = (GV*)POPs;
2430
2431 if (!ngv)
2432 goto badexit;
2433 if (!ggv)
2434 goto nuts;
2435
2436 gstio = GvIO(ggv);
2437 if (!gstio || !IoIFP(gstio))
2438 goto nuts;
2439
2440 nstio = GvIOn(ngv);
2441 if (IoIFP(nstio))
2442 do_close(ngv, FALSE);
2443
6ad3d225 2444 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *)&saddr, &len);
a0d0e21e
LW		 2445 if (fd < 0)
2446 goto badexit;
760ac839
LW		 2447 IoIFP(nstio) = PerlIO_fdopen(fd, "r");
2448 IoOFP(nstio) = PerlIO_fdopen(fd, "w");
50952442 2449 IoTYPE(nstio) = IoTYPE_SOCKET;
a0d0e21e 2450 if (!IoIFP(nstio) || !IoOFP(nstio)) {
760ac839
LW		 2451 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2452 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
6ad3d225 2453 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
a0d0e21e
LW		 2454 goto badexit;
2455 }
8d2a6795
GS		 2456#if defined(HAS_FCNTL) && defined(F_SETFD)
2457 fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2458#endif
a0d0e21e 2459
ed79a026 2460#ifdef EPOC
a9f1f6b0
OF		 2461 len = sizeof saddr; /* EPOC somehow truncates info */
2462 setbuf( IoIFP(nstio), NULL); /* EPOC gets confused about sockets */
ed79a026
OF		 2463#endif
2464
d3b9c689
RG		 2465#if defined(I_SYS_UN) && defined(__linux__)
2466 /* see the comment in pp_sysread */
2467 if (saddr.sa_family == AF_UNIX)
2468 len = sizeof(struct sockaddr_un);
2469#endif
2470
748a9306 2471 PUSHp((char *)&saddr, len);
a0d0e21e
LW		 2472 RETURN;
2473
2474nuts:
599cee73 2475 if (ckWARN(WARN_CLOSED))
bc37a18f 2476 report_evil_fh(ggv, ggv ? GvIO(ggv) : 0, PL_op->op_type);
748a9306 2477 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2478
2479badexit:
2480 RETPUSHUNDEF;
2481
2482#else
cea2e8a9 2483 DIE(aTHX_ PL_no_sock_func, "accept");
a0d0e21e
LW		 2484#endif
2485}
2486
2487PP(pp_shutdown)
2488{
39644a26 2489 dSP; dTARGET;
a0d0e21e
LW		 2490#ifdef HAS_SOCKET
2491 int how = POPi;
2492 GV *gv = (GV*)POPs;
2493 register IO *io = GvIOn(gv);
2494
2495 if (!io || !IoIFP(io))
2496 goto nuts;
2497
6ad3d225 2498 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
a0d0e21e
LW		 2499 RETURN;
2500
2501nuts:
599cee73 2502 if (ckWARN(WARN_CLOSED))
bc37a18f 2503 report_evil_fh(gv, io, PL_op->op_type);
748a9306 2504 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2505 RETPUSHUNDEF;
2506#else
cea2e8a9 2507 DIE(aTHX_ PL_no_sock_func, "shutdown");
a0d0e21e
LW		 2508#endif
2509}
2510
2511PP(pp_gsockopt)
2512{
2513#ifdef HAS_SOCKET
cea2e8a9 2514 return pp_ssockopt();
a0d0e21e 2515#else
cea2e8a9 2516 DIE(aTHX_ PL_no_sock_func, "getsockopt");
a0d0e21e
LW		 2517#endif
2518}
2519
2520PP(pp_ssockopt)
2521{
39644a26 2522 dSP;
a0d0e21e 2523#ifdef HAS_SOCKET
533c011a 2524 int optype = PL_op->op_type;
a0d0e21e
LW		 2525 SV *sv;
2526 int fd;
2527 unsigned int optname;
2528 unsigned int lvl;
2529 GV *gv;
2530 register IO *io;
1e422769 2531 Sock_size_t len;
a0d0e21e
LW		 2532
2533 if (optype == OP_GSOCKOPT)
2534 sv = sv_2mortal(NEWSV(22, 257));
2535 else
2536 sv = POPs;
2537 optname = (unsigned int) POPi;
2538 lvl = (unsigned int) POPi;
2539
2540 gv = (GV*)POPs;
2541 io = GvIOn(gv);
2542 if (!io || !IoIFP(io))
2543 goto nuts;
2544
760ac839 2545 fd = PerlIO_fileno(IoIFP(io));
a0d0e21e
LW		 2546 switch (optype) {
2547 case OP_GSOCKOPT:
748a9306 2548 SvGROW(sv, 257);
a0d0e21e 2549 (void)SvPOK_only(sv);
748a9306
LW		 2550 SvCUR_set(sv,256);
2551 *SvEND(sv) ='\0';
1e422769 2552 len = SvCUR(sv);
6ad3d225 2553 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
a0d0e21e 2554 goto nuts2;
1e422769 2555 SvCUR_set(sv, len);
748a9306 2556 *SvEND(sv) ='\0';
a0d0e21e
LW		 2557 PUSHs(sv);
2558 break;
2559 case OP_SSOCKOPT: {
1e422769 2560 char *buf;
2561 int aint;
2562 if (SvPOKp(sv)) {
2d8e6c8d
GS		 2563 STRLEN l;
2564 buf = SvPV(sv, l);
2565 len = l;
1e422769 2566 }
56ee1660 2567 else {
a0d0e21e
LW		 2568 aint = (int)SvIV(sv);
2569 buf = (char*)&aint;
2570 len = sizeof(int);
2571 }
6ad3d225 2572 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
a0d0e21e 2573 goto nuts2;
3280af22 2574 PUSHs(&PL_sv_yes);
a0d0e21e
LW		 2575 }
2576 break;
2577 }
2578 RETURN;
2579
2580nuts:
599cee73 2581 if (ckWARN(WARN_CLOSED))
bc37a18f 2582 report_evil_fh(gv, io, optype);
748a9306 2583 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2584nuts2:
2585 RETPUSHUNDEF;
2586
2587#else
cea2e8a9 2588 DIE(aTHX_ PL_no_sock_func, "setsockopt");
a0d0e21e
LW		 2589#endif
2590}
2591
2592PP(pp_getsockname)
2593{
2594#ifdef HAS_SOCKET
cea2e8a9 2595 return pp_getpeername();
a0d0e21e 2596#else
cea2e8a9 2597 DIE(aTHX_ PL_no_sock_func, "getsockname");
a0d0e21e
LW		 2598#endif
2599}
2600
2601PP(pp_getpeername)
2602{
39644a26 2603 dSP;
a0d0e21e 2604#ifdef HAS_SOCKET
533c011a 2605 int optype = PL_op->op_type;
a0d0e21e
LW		 2606 SV *sv;
2607 int fd;
2608 GV *gv = (GV*)POPs;
2609 register IO *io = GvIOn(gv);
1e422769 2610 Sock_size_t len;
a0d0e21e
LW		 2611
2612 if (!io || !IoIFP(io))
2613 goto nuts;
2614
2615 sv = sv_2mortal(NEWSV(22, 257));
748a9306 2616 (void)SvPOK_only(sv);
1e422769 2617 len = 256;
2618 SvCUR_set(sv, len);
748a9306 2619 *SvEND(sv) ='\0';
760ac839 2620 fd = PerlIO_fileno(IoIFP(io));
a0d0e21e
LW		 2621 switch (optype) {
2622 case OP_GETSOCKNAME:
6ad3d225 2623 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
a0d0e21e
LW		 2624 goto nuts2;
2625 break;
2626 case OP_GETPEERNAME:
6ad3d225 2627 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
a0d0e21e 2628 goto nuts2;
490ab354
JH		 2629#if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2630 {
2631 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";
2632 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2633 if (((struct sockaddr *)SvPVX(sv))->sa_family == AF_INET &&
2634 !memcmp((char *)SvPVX(sv) + sizeof(u_short), nowhere,
2635 sizeof(u_short) + sizeof(struct in_addr))) {
301e8125 2636 goto nuts2;
490ab354
JH		 2637 }
2638 }
2639#endif
a0d0e21e
LW		 2640 break;
2641 }
13826f2c
CS		 2642#ifdef BOGUS_GETNAME_RETURN
2643 /* Interactive Unix, getpeername() and getsockname()
2644 does not return valid namelen */
1e422769 2645 if (len == BOGUS_GETNAME_RETURN)
2646 len = sizeof(struct sockaddr);
13826f2c 2647#endif
d3b9c689
RG		 2648#if defined(I_SYS_UN) && defined(__linux__)
2649 /* see the comment in pp_sysread */
2650 if (((struct sockaddr *)SvPVX(sv))->sa_family == AF_UNIX)
2651 len = sizeof(struct sockaddr_un);
2652#endif
1e422769 2653 SvCUR_set(sv, len);
748a9306 2654 *SvEND(sv) ='\0';
a0d0e21e
LW		 2655 PUSHs(sv);
2656 RETURN;
2657
2658nuts:
599cee73 2659 if (ckWARN(WARN_CLOSED))
bc37a18f 2660 report_evil_fh(gv, io, optype);
748a9306 2661 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2662nuts2:
2663 RETPUSHUNDEF;
2664
2665#else
cea2e8a9 2666 DIE(aTHX_ PL_no_sock_func, "getpeername");
a0d0e21e
LW		 2667#endif
2668}
2669
2670/* Stat calls. */
2671
2672PP(pp_lstat)
2673{
cea2e8a9 2674 return pp_stat();
a0d0e21e
LW		 2675}
2676
2677PP(pp_stat)
2678{
39644a26 2679 dSP;
2dd78f96 2680 GV *gv;
54310121 2681 I32 gimme;
a0d0e21e 2682 I32 max = 13;
2d8e6c8d 2683 STRLEN n_a;
a0d0e21e 2684
533c011a 2685 if (PL_op->op_flags & OPf_REF) {
2dd78f96 2686 gv = cGVOP_gv;
8a4e5b40
DD		 2687 if (PL_op->op_type == OP_LSTAT) {
2688 if (PL_laststype != OP_LSTAT)
2689 Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2690 if (ckWARN(WARN_IO) && gv != PL_defgv)
2691 Perl_warner(aTHX_ WARN_IO,
2dd78f96 2692 "lstat() on filehandle %s", GvENAME(gv));
8a4e5b40
DD		 2693 /* Perl_my_lstat (-l) croak's on filehandle, why warn here? */
2694 }
2695
748a9306 2696 do_fstat:
2dd78f96 2697 if (gv != PL_defgv) {
3280af22 2698 PL_laststype = OP_STAT;
2dd78f96 2699 PL_statgv = gv;
3280af22 2700 sv_setpv(PL_statname, "");
2dd78f96
JH		 2701 PL_laststatval = (GvIO(gv) && IoIFP(GvIOp(gv))
2702 ? PerlLIO_fstat(PerlIO_fileno(IoIFP(GvIOn(gv))), &PL_statcache) : -1);
a0d0e21e 2703 }
9ddeeac9 2704 if (PL_laststatval < 0) {
2dd78f96
JH		 2705 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
2706 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
a0d0e21e 2707 max = 0;
9ddeeac9 2708 }
a0d0e21e
LW		 2709 }
2710 else {
748a9306
LW		 2711 SV* sv = POPs;
2712 if (SvTYPE(sv) == SVt_PVGV) {
2dd78f96 2713 gv = (GV*)sv;
748a9306
LW		 2714 goto do_fstat;
2715 }
2716 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2dd78f96 2717 gv = (GV*)SvRV(sv);
748a9306
LW		 2718 goto do_fstat;
2719 }
2d8e6c8d 2720 sv_setpv(PL_statname, SvPV(sv,n_a));
3280af22 2721 PL_statgv = Nullgv;
a0d0e21e 2722#ifdef HAS_LSTAT
533c011a
NIS		 2723 PL_laststype = PL_op->op_type;
2724 if (PL_op->op_type == OP_LSTAT)
2d8e6c8d 2725 PL_laststatval = PerlLIO_lstat(SvPV(PL_statname, n_a), &PL_statcache);
a0d0e21e
LW		 2726 else
2727#endif
2d8e6c8d 2728 PL_laststatval = PerlLIO_stat(SvPV(PL_statname, n_a), &PL_statcache);
3280af22 2729 if (PL_laststatval < 0) {
2d8e6c8d 2730 if (ckWARN(WARN_NEWLINE) && strchr(SvPV(PL_statname, n_a), '\n'))
cea2e8a9 2731 Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "stat");
a0d0e21e
LW		 2732 max = 0;
2733 }
2734 }
2735
54310121 2736 gimme = GIMME_V;
2737 if (gimme != G_ARRAY) {
2738 if (gimme != G_VOID)
2739 XPUSHs(boolSV(max));
2740 RETURN;
a0d0e21e
LW		 2741 }
2742 if (max) {
36477c24 2743 EXTEND(SP, max);
2744 EXTEND_MORTAL(max);
1ff81528
PL		 2745 PUSHs(sv_2mortal(newSViv(PL_statcache.st_dev)));
2746 PUSHs(sv_2mortal(newSViv(PL_statcache.st_ino)));
b448e4fe
JH		 2747 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_mode)));
2748 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_nlink)));
146174a9
CB		 2749#if Uid_t_size > IVSIZE
2750 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_uid)));
2751#else
23dcd6c8 2752# if Uid_t_sign <= 0
1ff81528 2753 PUSHs(sv_2mortal(newSViv(PL_statcache.st_uid)));
23dcd6c8
JH		 2754# else
2755 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_uid)));
2756# endif
146174a9 2757#endif
301e8125 2758#if Gid_t_size > IVSIZE
146174a9
CB		 2759 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_gid)));
2760#else
23dcd6c8 2761# if Gid_t_sign <= 0
1ff81528 2762 PUSHs(sv_2mortal(newSViv(PL_statcache.st_gid)));
23dcd6c8
JH		 2763# else
2764 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_gid)));
2765# endif
146174a9 2766#endif
cbdc8872 2767#ifdef USE_STAT_RDEV
1ff81528 2768 PUSHs(sv_2mortal(newSViv(PL_statcache.st_rdev)));
cbdc8872 2769#else
79cb57f6 2770 PUSHs(sv_2mortal(newSVpvn("", 0)));
cbdc8872 2771#endif
146174a9
CB		 2772#if Off_t_size > IVSIZE
2773 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_size)));
2774#else
1ff81528 2775 PUSHs(sv_2mortal(newSViv(PL_statcache.st_size)));
146174a9 2776#endif
cbdc8872 2777#ifdef BIG_TIME
172ae379
JH		 2778 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_atime)));
2779 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_mtime)));
2780 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_ctime)));
cbdc8872 2781#else
1ff81528
PL		 2782 PUSHs(sv_2mortal(newSViv(PL_statcache.st_atime)));
2783 PUSHs(sv_2mortal(newSViv(PL_statcache.st_mtime)));
2784 PUSHs(sv_2mortal(newSViv(PL_statcache.st_ctime)));
cbdc8872 2785#endif
a0d0e21e 2786#ifdef USE_STAT_BLOCKS
b448e4fe
JH		 2787 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blksize)));
2788 PUSHs(sv_2mortal(newSVuv(PL_statcache.st_blocks)));
a0d0e21e 2789#else
79cb57f6
GS		 2790 PUSHs(sv_2mortal(newSVpvn("", 0)));
2791 PUSHs(sv_2mortal(newSVpvn("", 0)));
a0d0e21e
LW		 2792#endif
2793 }
2794 RETURN;
2795}
2796
2797PP(pp_ftrread)
2798{
5ff3f7a4 2799 I32 result;
39644a26 2800 dSP;
5ff3f7a4 2801#if defined(HAS_ACCESS) && defined(R_OK)
2d8e6c8d 2802 STRLEN n_a;
5ff3f7a4 2803 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2804 result = access(TOPpx, R_OK);
5ff3f7a4
GS		 2805 if (result == 0)
2806 RETPUSHYES;
2807 if (result < 0)
2808 RETPUSHUNDEF;
2809 RETPUSHNO;
22865c03
GS		 2810 }
2811 else
cea2e8a9 2812 result = my_stat();
5ff3f7a4 2813#else
cea2e8a9 2814 result = my_stat();
5ff3f7a4 2815#endif
22865c03 2816 SPAGAIN;
a0d0e21e
LW		 2817 if (result < 0)
2818 RETPUSHUNDEF;
3280af22 2819 if (cando(S_IRUSR, 0, &PL_statcache))
a0d0e21e
LW		 2820 RETPUSHYES;
2821 RETPUSHNO;
2822}
2823
2824PP(pp_ftrwrite)
2825{
5ff3f7a4 2826 I32 result;
39644a26 2827 dSP;
5ff3f7a4 2828#if defined(HAS_ACCESS) && defined(W_OK)
2d8e6c8d 2829 STRLEN n_a;
5ff3f7a4 2830 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2831 result = access(TOPpx, W_OK);
5ff3f7a4
GS		 2832 if (result == 0)
2833 RETPUSHYES;
2834 if (result < 0)
2835 RETPUSHUNDEF;
2836 RETPUSHNO;
22865c03
GS		 2837 }
2838 else
cea2e8a9 2839 result = my_stat();
5ff3f7a4 2840#else
cea2e8a9 2841 result = my_stat();
5ff3f7a4 2842#endif
22865c03 2843 SPAGAIN;
a0d0e21e
LW		 2844 if (result < 0)
2845 RETPUSHUNDEF;
3280af22 2846 if (cando(S_IWUSR, 0, &PL_statcache))
a0d0e21e
LW		 2847 RETPUSHYES;
2848 RETPUSHNO;
2849}
2850
2851PP(pp_ftrexec)
2852{
5ff3f7a4 2853 I32 result;
39644a26 2854 dSP;
5ff3f7a4 2855#if defined(HAS_ACCESS) && defined(X_OK)
2d8e6c8d 2856 STRLEN n_a;
5ff3f7a4 2857 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2858 result = access(TOPpx, X_OK);
5ff3f7a4
GS		 2859 if (result == 0)
2860 RETPUSHYES;
2861 if (result < 0)
2862 RETPUSHUNDEF;
2863 RETPUSHNO;
22865c03
GS		 2864 }
2865 else
cea2e8a9 2866 result = my_stat();
5ff3f7a4 2867#else
cea2e8a9 2868 result = my_stat();
5ff3f7a4 2869#endif
22865c03 2870 SPAGAIN;
a0d0e21e
LW		 2871 if (result < 0)
2872 RETPUSHUNDEF;
3280af22 2873 if (cando(S_IXUSR, 0, &PL_statcache))
a0d0e21e
LW		 2874 RETPUSHYES;
2875 RETPUSHNO;
2876}
2877
2878PP(pp_fteread)
2879{
5ff3f7a4 2880 I32 result;
39644a26 2881 dSP;
5ff3f7a4 2882#ifdef PERL_EFF_ACCESS_R_OK
2d8e6c8d 2883 STRLEN n_a;
5ff3f7a4 2884 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2885 result = PERL_EFF_ACCESS_R_OK(TOPpx);
5ff3f7a4
GS		 2886 if (result == 0)
2887 RETPUSHYES;
2888 if (result < 0)
2889 RETPUSHUNDEF;
2890 RETPUSHNO;
22865c03
GS		 2891 }
2892 else
cea2e8a9 2893 result = my_stat();
5ff3f7a4 2894#else
cea2e8a9 2895 result = my_stat();
5ff3f7a4 2896#endif
22865c03 2897 SPAGAIN;
a0d0e21e
LW		 2898 if (result < 0)
2899 RETPUSHUNDEF;
3280af22 2900 if (cando(S_IRUSR, 1, &PL_statcache))
a0d0e21e
LW		 2901 RETPUSHYES;
2902 RETPUSHNO;
2903}
2904
2905PP(pp_ftewrite)
2906{
5ff3f7a4 2907 I32 result;
39644a26 2908 dSP;
5ff3f7a4 2909#ifdef PERL_EFF_ACCESS_W_OK
2d8e6c8d 2910 STRLEN n_a;
5ff3f7a4 2911 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2912 result = PERL_EFF_ACCESS_W_OK(TOPpx);
5ff3f7a4
GS		 2913 if (result == 0)
2914 RETPUSHYES;
2915 if (result < 0)
2916 RETPUSHUNDEF;
2917 RETPUSHNO;
22865c03
GS		 2918 }
2919 else
cea2e8a9 2920 result = my_stat();
5ff3f7a4 2921#else
cea2e8a9 2922 result = my_stat();
5ff3f7a4 2923#endif
22865c03 2924 SPAGAIN;
a0d0e21e
LW		 2925 if (result < 0)
2926 RETPUSHUNDEF;
3280af22 2927 if (cando(S_IWUSR, 1, &PL_statcache))
a0d0e21e
LW		 2928 RETPUSHYES;
2929 RETPUSHNO;
2930}
2931
2932PP(pp_fteexec)
2933{
5ff3f7a4 2934 I32 result;
39644a26 2935 dSP;
5ff3f7a4 2936#ifdef PERL_EFF_ACCESS_X_OK
2d8e6c8d 2937 STRLEN n_a;
5ff3f7a4 2938 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2939 result = PERL_EFF_ACCESS_X_OK(TOPpx);
5ff3f7a4
GS		 2940 if (result == 0)
2941 RETPUSHYES;
2942 if (result < 0)
2943 RETPUSHUNDEF;
2944 RETPUSHNO;
22865c03
GS		 2945 }
2946 else
cea2e8a9 2947 result = my_stat();
5ff3f7a4 2948#else
cea2e8a9 2949 result = my_stat();
5ff3f7a4 2950#endif
22865c03 2951 SPAGAIN;
a0d0e21e
LW		 2952 if (result < 0)
2953 RETPUSHUNDEF;
3280af22 2954 if (cando(S_IXUSR, 1, &PL_statcache))
a0d0e21e
LW		 2955 RETPUSHYES;
2956 RETPUSHNO;
2957}
2958
2959PP(pp_ftis)
2960{
cea2e8a9 2961 I32 result = my_stat();
39644a26 2962 dSP;
a0d0e21e
LW		 2963 if (result < 0)
2964 RETPUSHUNDEF;
2965 RETPUSHYES;
2966}
2967
2968PP(pp_fteowned)
2969{
cea2e8a9 2970 return pp_ftrowned();
a0d0e21e
LW		 2971}
2972
2973PP(pp_ftrowned)
2974{
cea2e8a9 2975 I32 result = my_stat();
39644a26 2976 dSP;
a0d0e21e
LW		 2977 if (result < 0)
2978 RETPUSHUNDEF;
146174a9
CB		 2979 if (PL_statcache.st_uid == (PL_op->op_type == OP_FTEOWNED ?
2980 PL_euid : PL_uid) )
a0d0e21e
LW		 2981 RETPUSHYES;
2982 RETPUSHNO;
2983}
2984
2985PP(pp_ftzero)
2986{
cea2e8a9 2987 I32 result = my_stat();
39644a26 2988 dSP;
a0d0e21e
LW		 2989 if (result < 0)
2990 RETPUSHUNDEF;
146174a9 2991 if (PL_statcache.st_size == 0)
a0d0e21e
LW		 2992 RETPUSHYES;
2993 RETPUSHNO;
2994}
2995
2996PP(pp_ftsize)
2997{
cea2e8a9 2998 I32 result = my_stat();
39644a26 2999 dSP; dTARGET;
a0d0e21e
LW		 3000 if (result < 0)
3001 RETPUSHUNDEF;
146174a9
CB		 3002#if Off_t_size > IVSIZE
3003 PUSHn(PL_statcache.st_size);
3004#else
3280af22 3005 PUSHi(PL_statcache.st_size);
146174a9 3006#endif
a0d0e21e
LW		 3007 RETURN;
3008}
3009
3010PP(pp_ftmtime)
3011{
cea2e8a9 3012 I32 result = my_stat();
39644a26 3013 dSP; dTARGET;
a0d0e21e
LW		 3014 if (result < 0)
3015 RETPUSHUNDEF;
c6419e06 3016 PUSHn( (PL_basetime - PL_statcache.st_mtime) / 86400.0 );
a0d0e21e
LW		 3017 RETURN;
3018}
3019
3020PP(pp_ftatime)
3021{
cea2e8a9 3022 I32 result = my_stat();
39644a26 3023 dSP; dTARGET;
a0d0e21e
LW		 3024 if (result < 0)
3025 RETPUSHUNDEF;
c6419e06 3026 PUSHn( (PL_basetime - PL_statcache.st_atime) / 86400.0 );
a0d0e21e
LW		 3027 RETURN;
3028}
3029
3030PP(pp_ftctime)
3031{
cea2e8a9 3032 I32 result = my_stat();
39644a26 3033 dSP; dTARGET;
a0d0e21e
LW		 3034 if (result < 0)
3035 RETPUSHUNDEF;
c6419e06 3036 PUSHn( (PL_basetime - PL_statcache.st_ctime) / 86400.0 );
a0d0e21e
LW		 3037 RETURN;
3038}
3039
3040PP(pp_ftsock)
3041{
cea2e8a9 3042 I32 result = my_stat();
39644a26 3043 dSP;
a0d0e21e
LW		 3044 if (result < 0)
3045 RETPUSHUNDEF;
3280af22 3046 if (S_ISSOCK(PL_statcache.st_mode))
a0d0e21e
LW		 3047 RETPUSHYES;
3048 RETPUSHNO;
3049}
3050
3051PP(pp_ftchr)
3052{
cea2e8a9 3053 I32 result = my_stat();
39644a26 3054 dSP;
a0d0e21e
LW		 3055 if (result < 0)
3056 RETPUSHUNDEF;
3280af22 3057 if (S_ISCHR(PL_statcache.st_mode))
a0d0e21e
LW		 3058 RETPUSHYES;
3059 RETPUSHNO;
3060}
3061
3062PP(pp_ftblk)
3063{
cea2e8a9 3064 I32 result = my_stat();
39644a26 3065 dSP;
a0d0e21e
LW		 3066 if (result < 0)
3067 RETPUSHUNDEF;
3280af22 3068 if (S_ISBLK(PL_statcache.st_mode))
a0d0e21e
LW		 3069 RETPUSHYES;
3070 RETPUSHNO;
3071}
3072
3073PP(pp_ftfile)
3074{
cea2e8a9 3075 I32 result = my_stat();
39644a26 3076 dSP;
a0d0e21e
LW		 3077 if (result < 0)
3078 RETPUSHUNDEF;
3280af22 3079 if (S_ISREG(PL_statcache.st_mode))
a0d0e21e
LW		 3080 RETPUSHYES;
3081 RETPUSHNO;
3082}
3083
3084PP(pp_ftdir)
3085{
cea2e8a9 3086 I32 result = my_stat();
39644a26 3087 dSP;
a0d0e21e
LW		 3088 if (result < 0)
3089 RETPUSHUNDEF;
3280af22 3090 if (S_ISDIR(PL_statcache.st_mode))
a0d0e21e
LW		 3091 RETPUSHYES;
3092 RETPUSHNO;
3093}
3094
3095PP(pp_ftpipe)
3096{
cea2e8a9 3097 I32 result = my_stat();
39644a26 3098 dSP;
a0d0e21e
LW		 3099 if (result < 0)
3100 RETPUSHUNDEF;
3280af22 3101 if (S_ISFIFO(PL_statcache.st_mode))
a0d0e21e
LW		 3102 RETPUSHYES;
3103 RETPUSHNO;
3104}
3105
3106PP(pp_ftlink)
3107{
cea2e8a9 3108 I32 result = my_lstat();
39644a26 3109 dSP;
a0d0e21e
LW		 3110 if (result < 0)
3111 RETPUSHUNDEF;
3280af22 3112 if (S_ISLNK(PL_statcache.st_mode))
a0d0e21e
LW		 3113 RETPUSHYES;
3114 RETPUSHNO;
3115}
3116
3117PP(pp_ftsuid)
3118{
39644a26 3119 dSP;
a0d0e21e 3120#ifdef S_ISUID
cea2e8a9 3121 I32 result = my_stat();
a0d0e21e
LW		 3122 SPAGAIN;
3123 if (result < 0)
3124 RETPUSHUNDEF;
3280af22 3125 if (PL_statcache.st_mode & S_ISUID)
a0d0e21e
LW		 3126 RETPUSHYES;
3127#endif
3128 RETPUSHNO;
3129}
3130
3131PP(pp_ftsgid)
3132{
39644a26 3133 dSP;
a0d0e21e 3134#ifdef S_ISGID
cea2e8a9 3135 I32 result = my_stat();
a0d0e21e
LW		 3136 SPAGAIN;
3137 if (result < 0)
3138 RETPUSHUNDEF;
3280af22 3139 if (PL_statcache.st_mode & S_ISGID)
a0d0e21e
LW		 3140 RETPUSHYES;
3141#endif
3142 RETPUSHNO;
3143}
3144
3145PP(pp_ftsvtx)
3146{
39644a26 3147 dSP;
a0d0e21e 3148#ifdef S_ISVTX
cea2e8a9 3149 I32 result = my_stat();
a0d0e21e
LW		 3150 SPAGAIN;
3151 if (result < 0)
3152 RETPUSHUNDEF;
3280af22 3153 if (PL_statcache.st_mode & S_ISVTX)
a0d0e21e
LW		 3154 RETPUSHYES;
3155#endif
3156 RETPUSHNO;
3157}
3158
3159PP(pp_fttty)
3160{
39644a26 3161 dSP;
a0d0e21e
LW		 3162 int fd;
3163 GV *gv;
fb73857a 3164 char *tmps = Nullch;
2d8e6c8d 3165 STRLEN n_a;
fb73857a 3166
533c011a 3167 if (PL_op->op_flags & OPf_REF)
146174a9 3168 gv = cGVOP_gv;
fb73857a 3169 else if (isGV(TOPs))
3170 gv = (GV*)POPs;
3171 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3172 gv = (GV*)SvRV(POPs);
a0d0e21e 3173 else
2d8e6c8d 3174 gv = gv_fetchpv(tmps = POPpx, FALSE, SVt_PVIO);
fb73857a 3175
a0d0e21e 3176 if (GvIO(gv) && IoIFP(GvIOp(gv)))
760ac839 3177 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
fb73857a 3178 else if (tmps && isDIGIT(*tmps))
a0d0e21e
LW		 3179 fd = atoi(tmps);
3180 else
3181 RETPUSHUNDEF;
6ad3d225 3182 if (PerlLIO_isatty(fd))
a0d0e21e
LW		 3183 RETPUSHYES;
3184 RETPUSHNO;
3185}
3186
16d20bd9
AD		 3187#if defined(atarist) /* this will work with atariST. Configure will
3188 make guesses for other systems. */
3189# define FILE_base(f) ((f)->_base)
3190# define FILE_ptr(f) ((f)->_ptr)
3191# define FILE_cnt(f) ((f)->_cnt)
3192# define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
a0d0e21e
LW		 3193#endif
3194
3195PP(pp_fttext)
3196{
39644a26 3197 dSP;
a0d0e21e
LW		 3198 I32 i;
3199 I32 len;
3200 I32 odd = 0;
3201 STDCHAR tbuf[512];
3202 register STDCHAR *s;
3203 register IO *io;
5f05dabc 3204 register SV *sv;
3205 GV *gv;
2d8e6c8d 3206 STRLEN n_a;
146174a9 3207 PerlIO *fp;
a0d0e21e 3208
533c011a 3209 if (PL_op->op_flags & OPf_REF)
146174a9 3210 gv = cGVOP_gv;
5f05dabc 3211 else if (isGV(TOPs))
3212 gv = (GV*)POPs;
3213 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
3214 gv = (GV*)SvRV(POPs);
3215 else
3216 gv = Nullgv;
3217
3218 if (gv) {
a0d0e21e 3219 EXTEND(SP, 1);
3280af22
NIS		 3220 if (gv == PL_defgv) {
3221 if (PL_statgv)
3222 io = GvIO(PL_statgv);
a0d0e21e 3223 else {
3280af22 3224 sv = PL_statname;
a0d0e21e
LW		 3225 goto really_filename;
3226 }
3227 }
3228 else {
3280af22
NIS		 3229 PL_statgv = gv;
3230 PL_laststatval = -1;
3231 sv_setpv(PL_statname, "");
3232 io = GvIO(PL_statgv);
a0d0e21e
LW		 3233 }
3234 if (io && IoIFP(io)) {
5f05dabc 3235 if (! PerlIO_has_base(IoIFP(io)))
cea2e8a9 3236 DIE(aTHX_ "-T and -B not implemented on filehandles");
3280af22
NIS		 3237 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3238 if (PL_laststatval < 0)
5f05dabc 3239 RETPUSHUNDEF;
9cbac4c7 3240 if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
533c011a 3241 if (PL_op->op_type == OP_FTTEXT)
a0d0e21e
LW		 3242 RETPUSHNO;
3243 else
3244 RETPUSHYES;
9cbac4c7 3245 }
a20bf0c3 3246 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
760ac839 3247 i = PerlIO_getc(IoIFP(io));
a0d0e21e 3248 if (i != EOF)
760ac839 3249 (void)PerlIO_ungetc(IoIFP(io),i);
a0d0e21e 3250 }
a20bf0c3 3251 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
a0d0e21e 3252 RETPUSHYES;
a20bf0c3
JH		 3253 len = PerlIO_get_bufsiz(IoIFP(io));
3254 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
760ac839
LW		 3255 /* sfio can have large buffers - limit to 512 */
3256 if (len > 512)
3257 len = 512;
a0d0e21e
LW		 3258 }
3259 else {
2dd78f96 3260 if (ckWARN2(WARN_UNOPENED,WARN_CLOSED)) {
146174a9 3261 gv = cGVOP_gv;
2dd78f96 3262 report_evil_fh(gv, GvIO(gv), PL_op->op_type);
146174a9 3263 }
748a9306 3264 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW		 3265 RETPUSHUNDEF;
3266 }
3267 }
3268 else {
3269 sv = POPs;
5f05dabc 3270 really_filename:
3280af22
NIS		 3271 PL_statgv = Nullgv;
3272 PL_laststatval = -1;
2d8e6c8d 3273 sv_setpv(PL_statname, SvPV(sv, n_a));
146174a9 3274 if (!(fp = PerlIO_open(SvPVX(PL_statname), "r"))) {
2d8e6c8d 3275 if (ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, n_a), '\n'))
cea2e8a9 3276 Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "open");
a0d0e21e
LW		 3277 RETPUSHUNDEF;
3278 }
146174a9
CB		 3279 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3280 if (PL_laststatval < 0) {
3281 (void)PerlIO_close(fp);
5f05dabc 3282 RETPUSHUNDEF;
146174a9 3283 }
60382766 3284 PerlIO_binmode(aTHX_ fp, '<', O_BINARY, Nullch);
146174a9
CB		 3285 len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3286 (void)PerlIO_close(fp);
a0d0e21e 3287 if (len <= 0) {
533c011a 3288 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
a0d0e21e
LW		 3289 RETPUSHNO; /* special case NFS directories */
3290 RETPUSHYES; /* null file is anything */
3291 }
3292 s = tbuf;
3293 }
3294
3295 /* now scan s to look for textiness */
4633a7c4 3296 /* XXX ASCII dependent code */
a0d0e21e 3297
146174a9
CB		 3298#if defined(DOSISH) || defined(USEMYBINMODE)
3299 /* ignore trailing ^Z on short files */
3300 if (len && len < sizeof(tbuf) && tbuf[len-1] == 26)
3301 --len;
3302#endif
3303
a0d0e21e
LW		 3304 for (i = 0; i < len; i++, s++) {
3305 if (!*s) { /* null never allowed in text */
3306 odd += len;
3307 break;
3308 }
9d116dd7 3309#ifdef EBCDIC
301e8125 3310 else if (!(isPRINT(*s) || isSPACE(*s)))
9d116dd7
JH		 3311 odd++;
3312#else
146174a9
CB		 3313 else if (*s & 128) {
3314#ifdef USE_LOCALE
b3f66c68
GS		 3315 if ((PL_op->op_private & OPpLOCALE) && isALPHA_LC(*s))
3316 continue;
3317#endif
3318 /* utf8 characters don't count as odd */
fd400ab9 3319 if (UTF8_IS_START(*s)) {
b3f66c68
GS		 3320 int ulen = UTF8SKIP(s);
3321 if (ulen < len - i) {
3322 int j;
3323 for (j = 1; j < ulen; j++) {
fd400ab9 3324 if (!UTF8_IS_CONTINUATION(s[j]))
b3f66c68
GS		 3325 goto not_utf8;
3326 }
3327 --ulen; /* loop does extra increment */
3328 s += ulen;
3329 i += ulen;
3330 continue;
3331 }
3332 }
3333 not_utf8:
3334 odd++;
146174a9 3335 }
a0d0e21e
LW		 3336 else if (*s < 32 &&
3337 *s != '\n' && *s != '\r' && *s != '\b' &&
3338 *s != '\t' && *s != '\f' && *s != 27)
3339 odd++;
9d116dd7 3340#endif
a0d0e21e
LW		 3341 }
3342
533c011a 3343 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
a0d0e21e
LW		 3344 RETPUSHNO;
3345 else
3346 RETPUSHYES;
3347}
3348
3349PP(pp_ftbinary)
3350{
cea2e8a9 3351 return pp_fttext();
a0d0e21e
LW		 3352}
3353
3354/* File calls. */
3355
3356PP(pp_chdir)
3357{
39644a26 3358 dSP; dTARGET;
a0d0e21e
LW		 3359 char *tmps;
3360 SV **svp;
2d8e6c8d 3361 STRLEN n_a;
a0d0e21e
LW		 3362
3363 if (MAXARG < 1)
3364 tmps = Nullch;
3365 else
2d8e6c8d 3366 tmps = POPpx;
a0d0e21e 3367 if (!tmps || !*tmps) {
3280af22 3368 svp = hv_fetch(GvHVn(PL_envgv), "HOME", 4, FALSE);
a0d0e21e 3369 if (svp)
2d8e6c8d 3370 tmps = SvPV(*svp, n_a);
a0d0e21e
LW		 3371 }
3372 if (!tmps || !*tmps) {
3280af22 3373 svp = hv_fetch(GvHVn(PL_envgv), "LOGDIR", 6, FALSE);
a0d0e21e 3374 if (svp)
2d8e6c8d 3375 tmps = SvPV(*svp, n_a);
a0d0e21e 3376 }
491527d0
GS		 3377#ifdef VMS
3378 if (!tmps || !*tmps) {
6b88bc9c 3379 svp = hv_fetch(GvHVn(PL_envgv), "SYS$LOGIN", 9, FALSE);
491527d0 3380 if (svp)
2d8e6c8d 3381 tmps = SvPV(*svp, n_a);
491527d0
GS		 3382 }
3383#endif
a0d0e21e 3384 TAINT_PROPER("chdir");
6ad3d225 3385 PUSHi( PerlDir_chdir(tmps) >= 0 );
748a9306
LW		 3386#ifdef VMS
3387 /* Clear the DEFAULT element of ENV so we'll get the new value
3388 * in the future. */
6b88bc9c 3389 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
748a9306 3390#endif
a0d0e21e
LW		 3391 RETURN;
3392}
3393
3394PP(pp_chown)
3395{
39644a26 3396 dSP; dMARK; dTARGET;
a0d0e21e
LW		 3397 I32 value;
3398#ifdef HAS_CHOWN
533c011a 3399 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 3400 SP = MARK;
3401 PUSHi(value);
3402 RETURN;
3403#else
cea2e8a9 3404 DIE(aTHX_ PL_no_func, "Unsupported function chown");
a0d0e21e
LW		 3405#endif
3406}
3407
3408PP(pp_chroot)
3409{
39644a26 3410 dSP; dTARGET;
a0d0e21e
LW		 3411 char *tmps;
3412#ifdef HAS_CHROOT
2d8e6c8d
GS		 3413 STRLEN n_a;
3414 tmps = POPpx;
a0d0e21e
LW		 3415 TAINT_PROPER("chroot");
3416 PUSHi( chroot(tmps) >= 0 );
3417 RETURN;
3418#else
cea2e8a9 3419 DIE(aTHX_ PL_no_func, "chroot");
a0d0e21e
LW		 3420#endif
3421}
3422
3423PP(pp_unlink)
3424{
39644a26 3425 dSP; dMARK; dTARGET;
a0d0e21e 3426 I32 value;
533c011a 3427 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 3428 SP = MARK;
3429 PUSHi(value);
3430 RETURN;
3431}
3432
3433PP(pp_chmod)
3434{
39644a26 3435 dSP; dMARK; dTARGET;
a0d0e21e 3436 I32 value;
533c011a 3437 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 3438 SP = MARK;
3439 PUSHi(value);
3440 RETURN;
3441}
3442
3443PP(pp_utime)
3444{
39644a26 3445 dSP; dMARK; dTARGET;
a0d0e21e 3446 I32 value;
533c011a 3447 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 3448 SP = MARK;
3449 PUSHi(value);
3450 RETURN;
3451}
3452
3453PP(pp_rename)
3454{
39644a26 3455 dSP; dTARGET;
a0d0e21e 3456 int anum;
2d8e6c8d 3457 STRLEN n_a;
a0d0e21e 3458
2d8e6c8d
GS		 3459 char *tmps2 = POPpx;
3460 char *tmps = SvPV(TOPs, n_a);
a0d0e21e
LW		 3461 TAINT_PROPER("rename");
3462#ifdef HAS_RENAME
baed7233 3463 anum = PerlLIO_rename(tmps, tmps2);
a0d0e21e 3464#else
6b88bc9c 3465 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
ed969818
W		 3466 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3467 anum = 1;
3468 else {
3654eb6c 3469 if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
ed969818
W		 3470 (void)UNLINK(tmps2);
3471 if (!(anum = link(tmps, tmps2)))
3472 anum = UNLINK(tmps);
3473 }
a0d0e21e
LW		 3474 }
3475#endif
3476 SETi( anum >= 0 );
3477 RETURN;
3478}
3479
3480PP(pp_link)
3481{
39644a26 3482 dSP; dTARGET;
a0d0e21e 3483#ifdef HAS_LINK
2d8e6c8d
GS		 3484 STRLEN n_a;
3485 char *tmps2 = POPpx;
3486 char *tmps = SvPV(TOPs, n_a);
a0d0e21e 3487 TAINT_PROPER("link");
146174a9 3488 SETi( PerlLIO_link(tmps, tmps2) >= 0 );
a0d0e21e 3489#else
cea2e8a9 3490 DIE(aTHX_ PL_no_func, "Unsupported function link");
a0d0e21e
LW		 3491#endif
3492 RETURN;
3493}
3494
3495PP(pp_symlink)
3496{
39644a26 3497 dSP; dTARGET;
a0d0e21e 3498#ifdef HAS_SYMLINK
2d8e6c8d
GS		 3499 STRLEN n_a;
3500 char *tmps2 = POPpx;
3501 char *tmps = SvPV(TOPs, n_a);
a0d0e21e
LW		 3502 TAINT_PROPER("symlink");
3503 SETi( symlink(tmps, tmps2) >= 0 );
3504 RETURN;
3505#else
cea2e8a9 3506 DIE(aTHX_ PL_no_func, "symlink");
a0d0e21e
LW		 3507#endif
3508}
3509
3510PP(pp_readlink)
3511{
39644a26 3512 dSP; dTARGET;
a0d0e21e
LW		 3513#ifdef HAS_SYMLINK
3514 char *tmps;
46fc3d4c 3515 char buf[MAXPATHLEN];
a0d0e21e 3516 int len;
2d8e6c8d 3517 STRLEN n_a;
46fc3d4c 3518
fb73857a 3519#ifndef INCOMPLETE_TAINTS
3520 TAINT;
3521#endif
2d8e6c8d 3522 tmps = POPpx;
a0d0e21e
LW		 3523 len = readlink(tmps, buf, sizeof buf);
3524 EXTEND(SP, 1);
3525 if (len < 0)
3526 RETPUSHUNDEF;
3527 PUSHp(buf, len);
3528 RETURN;
3529#else
3530 EXTEND(SP, 1);
3531 RETSETUNDEF; /* just pretend it's a normal file */
3532#endif
3533}
3534
3535#if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
ba106d47 3536STATIC int
cea2e8a9 3537S_dooneliner(pTHX_ char *cmd, char *filename)
a0d0e21e 3538{
1e422769 3539 char *save_filename = filename;
3540 char *cmdline;
3541 char *s;
760ac839 3542 PerlIO *myfp;
1e422769 3543 int anum = 1;
a0d0e21e 3544
1e422769 3545 New(666, cmdline, strlen(cmd) + (strlen(filename) * 2) + 10, char);
3546 strcpy(cmdline, cmd);
3547 strcat(cmdline, " ");
3548 for (s = cmdline + strlen(cmdline); *filename; ) {
a0d0e21e
LW		 3549 *s++ = '\\';
3550 *s++ = *filename++;
3551 }
3552 strcpy(s, " 2>&1");
6ad3d225 3553 myfp = PerlProc_popen(cmdline, "r");
1e422769 3554 Safefree(cmdline);
3555
a0d0e21e 3556 if (myfp) {
1e422769 3557 SV *tmpsv = sv_newmortal();
6b88bc9c 3558 /* Need to save/restore 'PL_rs' ?? */
760ac839 3559 s = sv_gets(tmpsv, myfp, 0);
6ad3d225 3560 (void)PerlProc_pclose(myfp);
a0d0e21e 3561 if (s != Nullch) {
1e422769 3562 int e;
3563 for (e = 1;
a0d0e21e 3564#ifdef HAS_SYS_ERRLIST
1e422769 3565 e <= sys_nerr
3566#endif
3567 ; e++)
3568 {
3569 /* you don't see this */
3570 char *errmsg =
3571#ifdef HAS_SYS_ERRLIST
3572 sys_errlist[e]
a0d0e21e 3573#else
1e422769 3574 strerror(e)
a0d0e21e 3575#endif
1e422769 3576 ;
3577 if (!errmsg)
3578 break;
3579 if (instr(s, errmsg)) {
3580 SETERRNO(e,0);
3581 return 0;
3582 }
a0d0e21e 3583 }
748a9306 3584 SETERRNO(0,0);
a0d0e21e
LW		 3585#ifndef EACCES
3586#define EACCES EPERM
3587#endif
1e422769 3588 if (instr(s, "cannot make"))
748a9306 3589 SETERRNO(EEXIST,RMS$_FEX);
1e422769 3590 else if (instr(s, "existing file"))
748a9306 3591 SETERRNO(EEXIST,RMS$_FEX);
1e422769 3592 else if (instr(s, "ile exists"))
748a9306 3593 SETERRNO(EEXIST,RMS$_FEX);
1e422769 3594 else if (instr(s, "non-exist"))
748a9306 3595 SETERRNO(ENOENT,RMS$_FNF);
1e422769 3596 else if (instr(s, "does not exist"))
748a9306 3597 SETERRNO(ENOENT,RMS$_FNF);
1e422769 3598 else if (instr(s, "not empty"))
748a9306 3599 SETERRNO(EBUSY,SS$_DEVOFFLINE);
1e422769 3600 else if (instr(s, "cannot access"))
748a9306 3601 SETERRNO(EACCES,RMS$_PRV);
a0d0e21e 3602 else
748a9306 3603 SETERRNO(EPERM,RMS$_PRV);
a0d0e21e
LW		 3604 return 0;
3605 }
3606 else { /* some mkdirs return no failure indication */
6b88bc9c 3607 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
911d147d 3608 if (PL_op->op_type == OP_RMDIR)
a0d0e21e
LW		 3609 anum = !anum;
3610 if (anum)
748a9306 3611 SETERRNO(0,0);
a0d0e21e 3612 else
748a9306 3613 SETERRNO(EACCES,RMS$_PRV); /* a guess */
a0d0e21e
LW		 3614 }
3615 return anum;
3616 }
3617 else
3618 return 0;
3619}
3620#endif
3621
3622PP(pp_mkdir)
3623{
39644a26 3624 dSP; dTARGET;
5a211162 3625 int mode;
a0d0e21e
LW		 3626#ifndef HAS_MKDIR
3627 int oldumask;
3628#endif
df25ddba 3629 STRLEN len;
5a211162 3630 char *tmps;
df25ddba 3631 bool copy = FALSE;
5a211162
GS		 3632
3633 if (MAXARG > 1)
3634 mode = POPi;
3635 else
3636 mode = 0777;
3637
df25ddba
JH		 3638 tmps = SvPV(TOPs, len);
3639 /* Different operating and file systems take differently to
16ac3975
JH		 3640 * trailing slashes. According to POSIX 1003.1 1996 Edition
3641 * any number of trailing slashes should be allowed.
3642 * Thusly we snip them away so that even non-conforming
3643 * systems are happy. */
3644 /* We should probably do this "filtering" for all
3645 * the functions that expect (potentially) directory names:
3646 * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3647 * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3648 if (len > 1 && tmps[len-1] == '/') {
3649 while (tmps[len] == '/' && len > 1)
3650 len--;
3651 tmps = savepvn(tmps, len);
df25ddba
JH		 3652 copy = TRUE;
3653 }
a0d0e21e
LW		 3654
3655 TAINT_PROPER("mkdir");
3656#ifdef HAS_MKDIR
6ad3d225 3657 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
a0d0e21e
LW		 3658#else
3659 SETi( dooneliner("mkdir", tmps) );
6ad3d225
GS		 3660 oldumask = PerlLIO_umask(0);
3661 PerlLIO_umask(oldumask);
3662 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
a0d0e21e 3663#endif
df25ddba
JH		 3664 if (copy)
3665 Safefree(tmps);
a0d0e21e
LW		 3666 RETURN;
3667}
3668
3669PP(pp_rmdir)
3670{
39644a26 3671 dSP; dTARGET;
a0d0e21e 3672 char *tmps;
2d8e6c8d 3673 STRLEN n_a;
a0d0e21e 3674
2d8e6c8d 3675 tmps = POPpx;
a0d0e21e
LW		 3676 TAINT_PROPER("rmdir");
3677#ifdef HAS_RMDIR
6ad3d225 3678 XPUSHi( PerlDir_rmdir(tmps) >= 0 );
a0d0e21e
LW		 3679#else
3680 XPUSHi( dooneliner("rmdir", tmps) );
3681#endif
3682 RETURN;
3683}
3684
3685/* Directory calls. */
3686
3687PP(pp_open_dir)
3688{
39644a26 3689 dSP;
a0d0e21e 3690#if defined(Direntry_t) && defined(HAS_READDIR)
2d8e6c8d
GS		 3691 STRLEN n_a;
3692 char *dirname = POPpx;
a0d0e21e
LW		 3693 GV *gv = (GV*)POPs;
3694 register IO *io = GvIOn(gv);
3695
3696 if (!io)
3697 goto nope;
3698
3699 if (IoDIRP(io))
6ad3d225
GS		 3700 PerlDir_close(IoDIRP(io));
3701 if (!(IoDIRP(io) = PerlDir_open(dirname)))
a0d0e21e
LW		 3702 goto nope;
3703
3704 RETPUSHYES;
3705nope:
3706 if (!errno)
748a9306 3707 SETERRNO(EBADF,RMS$_DIR);
a0d0e21e
LW		 3708 RETPUSHUNDEF;
3709#else
cea2e8a9 3710 DIE(aTHX_ PL_no_dir_func, "opendir");
a0d0e21e
LW		 3711#endif
3712}
3713
3714PP(pp_readdir)
3715{
39644a26 3716 dSP;
a0d0e21e
LW		 3717#if defined(Direntry_t) && defined(HAS_READDIR)
3718#ifndef I_DIRENT
20ce7b12 3719 Direntry_t *readdir (DIR *);
a0d0e21e
LW		 3720#endif
3721 register Direntry_t *dp;
3722 GV *gv = (GV*)POPs;
3723 register IO *io = GvIOn(gv);
fb73857a 3724 SV *sv;
a0d0e21e
LW		 3725
3726 if (!io || !IoDIRP(io))
3727 goto nope;
3728
3729 if (GIMME == G_ARRAY) {
3730 /*SUPPRESS 560*/
155aba94 3731 while ((dp = (Direntry_t *)PerlDir_read(IoDIRP(io)))) {
a0d0e21e 3732#ifdef DIRNAMLEN
79cb57f6 3733 sv = newSVpvn(dp->d_name, dp->d_namlen);
a0d0e21e 3734#else
fb73857a 3735 sv = newSVpv(dp->d_name, 0);
3736#endif
3737#ifndef INCOMPLETE_TAINTS
26fb8f1f
GS		 3738 if (!(IoFLAGS(io) & IOf_UNTAINT))
3739 SvTAINTED_on(sv);
a0d0e21e 3740#endif
fb73857a 3741 XPUSHs(sv_2mortal(sv));
a0d0e21e
LW		 3742 }
3743 }
3744 else {
6ad3d225 3745 if (!(dp = (Direntry_t *)PerlDir_read(IoDIRP(io))))
a0d0e21e
LW		 3746 goto nope;
3747#ifdef DIRNAMLEN
79cb57f6 3748 sv = newSVpvn(dp->d_name, dp->d_namlen);
a0d0e21e 3749#else
fb73857a 3750 sv = newSVpv(dp->d_name, 0);
a0d0e21e 3751#endif
fb73857a 3752#ifndef INCOMPLETE_TAINTS
26fb8f1f
GS		 3753 if (!(IoFLAGS(io) & IOf_UNTAINT))
3754 SvTAINTED_on(sv);
fb73857a 3755#endif
3756 XPUSHs(sv_2mortal(sv));
a0d0e21e
LW		 3757 }
3758 RETURN;
3759
3760nope:
3761 if (!errno)
748a9306 3762 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 3763 if (GIMME == G_ARRAY)
3764 RETURN;
3765 else
3766 RETPUSHUNDEF;
3767#else
cea2e8a9 3768 DIE(aTHX_ PL_no_dir_func, "readdir");
a0d0e21e
LW		 3769#endif
3770}
3771
3772PP(pp_telldir)
3773{
39644a26 3774 dSP; dTARGET;
a0d0e21e 3775#if defined(HAS_TELLDIR) || defined(telldir)
968dcd91
JH		 3776 /* XXX does _anyone_ need this? --AD 2/20/1998 */
3777 /* XXX netbsd still seemed to.
3778 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3779 --JHI 1999-Feb-02 */
3780# if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
20ce7b12 3781 long telldir (DIR *);
dfe9444c 3782# endif
a0d0e21e
LW		 3783 GV *gv = (GV*)POPs;
3784 register IO *io = GvIOn(gv);
3785
3786 if (!io || !IoDIRP(io))
3787 goto nope;
3788
6ad3d225 3789 PUSHi( PerlDir_tell(IoDIRP(io)) );
a0d0e21e
LW		 3790 RETURN;
3791nope:
3792 if (!errno)
748a9306 3793 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 3794 RETPUSHUNDEF;
3795#else
cea2e8a9 3796 DIE(aTHX_ PL_no_dir_func, "telldir");
a0d0e21e
LW		 3797#endif
3798}
3799
3800PP(pp_seekdir)
3801{
39644a26 3802 dSP;
a0d0e21e
LW		 3803#if defined(HAS_SEEKDIR) || defined(seekdir)
3804 long along = POPl;
3805 GV *gv = (GV*)POPs;
3806 register IO *io = GvIOn(gv);
3807
3808 if (!io || !IoDIRP(io))
3809 goto nope;
3810
6ad3d225 3811 (void)PerlDir_seek(IoDIRP(io), along);
a0d0e21e
LW		 3812
3813 RETPUSHYES;
3814nope:
3815 if (!errno)
748a9306 3816 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 3817 RETPUSHUNDEF;
3818#else
cea2e8a9 3819 DIE(aTHX_ PL_no_dir_func, "seekdir");
a0d0e21e
LW		 3820#endif
3821}
3822
3823PP(pp_rewinddir)
3824{
39644a26 3825 dSP;
a0d0e21e
LW		 3826#if defined(HAS_REWINDDIR) || defined(rewinddir)
3827 GV *gv = (GV*)POPs;
3828 register IO *io = GvIOn(gv);
3829
3830 if (!io || !IoDIRP(io))
3831 goto nope;
3832
6ad3d225 3833 (void)PerlDir_rewind(IoDIRP(io));
a0d0e21e
LW		 3834 RETPUSHYES;
3835nope:
3836 if (!errno)
748a9306 3837 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 3838 RETPUSHUNDEF;
3839#else
cea2e8a9 3840 DIE(aTHX_ PL_no_dir_func, "rewinddir");
a0d0e21e
LW		 3841#endif
3842}
3843
3844PP(pp_closedir)
3845{
39644a26 3846 dSP;
a0d0e21e
LW		 3847#if defined(Direntry_t) && defined(HAS_READDIR)
3848 GV *gv = (GV*)POPs;
3849 register IO *io = GvIOn(gv);
3850
3851 if (!io || !IoDIRP(io))
3852 goto nope;
3853
3854#ifdef VOID_CLOSEDIR
6ad3d225 3855 PerlDir_close(IoDIRP(io));
a0d0e21e 3856#else
6ad3d225 3857 if (PerlDir_close(IoDIRP(io)) < 0) {
748a9306 3858 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
a0d0e21e 3859 goto nope;
748a9306 3860 }
a0d0e21e
LW		 3861#endif
3862 IoDIRP(io) = 0;
3863
3864 RETPUSHYES;
3865nope:
3866 if (!errno)
748a9306 3867 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW		 3868 RETPUSHUNDEF;
3869#else
cea2e8a9 3870 DIE(aTHX_ PL_no_dir_func, "closedir");
a0d0e21e
LW		 3871#endif
3872}
3873
3874/* Process control. */
3875
3876PP(pp_fork)
3877{
44a8e56a 3878#ifdef HAS_FORK
39644a26 3879 dSP; dTARGET;
761237fe 3880 Pid_t childpid;
a0d0e21e
LW		 3881 GV *tmpgv;
3882
3883 EXTEND(SP, 1);
45bc9206 3884 PERL_FLUSHALL_FOR_CHILD;
a0d0e21e
LW		 3885 childpid = fork();
3886 if (childpid < 0)
3887 RETSETUNDEF;
3888 if (!childpid) {
3889 /*SUPPRESS 560*/
155aba94 3890 if ((tmpgv = gv_fetchpv("$", TRUE, SVt_PV)))
146174a9 3891 sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
3280af22 3892 hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
a0d0e21e
LW		 3893 }
3894 PUSHi(childpid);
3895 RETURN;
3896#else
146174a9 3897# if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
39644a26 3898 dSP; dTARGET;
146174a9
CB		 3899 Pid_t childpid;
3900
3901 EXTEND(SP, 1);
3902 PERL_FLUSHALL_FOR_CHILD;
3903 childpid = PerlProc_fork();
60fa28ff
GS		 3904 if (childpid == -1)
3905 RETSETUNDEF;
146174a9
CB		 3906 PUSHi(childpid);
3907 RETURN;
3908# else
cea2e8a9 3909 DIE(aTHX_ PL_no_func, "Unsupported function fork");
146174a9 3910# endif
a0d0e21e
LW		 3911#endif
3912}
3913
3914PP(pp_wait)
3915{
301e8125 3916#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
39644a26 3917 dSP; dTARGET;
761237fe 3918 Pid_t childpid;
a0d0e21e 3919 int argflags;
a0d0e21e 3920
44a8e56a 3921 childpid = wait4pid(-1, &argflags, 0);
68a29c53
GS		 3922# if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3923 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
3924 STATUS_NATIVE_SET((childpid && childpid != -1) ? argflags : -1);
3925# else
f86702cc 3926 STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
68a29c53 3927# endif
44a8e56a 3928 XPUSHi(childpid);
a0d0e21e
LW		 3929 RETURN;
3930#else
cea2e8a9 3931 DIE(aTHX_ PL_no_func, "Unsupported function wait");
a0d0e21e
LW		 3932#endif
3933}
3934
3935PP(pp_waitpid)
3936{
301e8125 3937#if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
39644a26 3938 dSP; dTARGET;
761237fe 3939 Pid_t childpid;
a0d0e21e
LW		 3940 int optype;
3941 int argflags;
a0d0e21e 3942
a0d0e21e
LW		 3943 optype = POPi;
3944 childpid = TOPi;
3945 childpid = wait4pid(childpid, &argflags, optype);
68a29c53
GS		 3946# if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3947 /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
3948 STATUS_NATIVE_SET((childpid && childpid != -1) ? argflags : -1);
3949# else
f86702cc 3950 STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
68a29c53 3951# endif
44a8e56a 3952 SETi(childpid);
a0d0e21e
LW		 3953 RETURN;
3954#else
cea2e8a9 3955 DIE(aTHX_ PL_no_func, "Unsupported function waitpid");
a0d0e21e
LW		 3956#endif
3957}
3958
3959PP(pp_system)
3960{
39644a26 3961 dSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e 3962 I32 value;
761237fe 3963 Pid_t childpid;
a0d0e21e
LW		 3964 int result;
3965 int status;
ff68c719 3966 Sigsave_t ihand,qhand; /* place to save signals during system() */
2d8e6c8d 3967 STRLEN n_a;
d5a9bfb0
IZ		 3968 I32 did_pipes = 0;
3969 int pp[2];
a0d0e21e 3970
a0d0e21e 3971 if (SP - MARK == 1) {
3280af22 3972 if (PL_tainting) {
2d8e6c8d 3973 char *junk = SvPV(TOPs, n_a);
a0d0e21e
LW		 3974 TAINT_ENV();
3975 TAINT_PROPER("system");
3976 }
3977 }
45bc9206 3978 PERL_FLUSHALL_FOR_CHILD;
64ca3a65 3979#if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) && !defined(__CYGWIN__) || defined(PERL_MICRO)
d5a9bfb0
IZ		 3980 if (PerlProc_pipe(pp) >= 0)
3981 did_pipes = 1;
a0d0e21e
LW		 3982 while ((childpid = vfork()) == -1) {
3983 if (errno != EAGAIN) {
3984 value = -1;
3985 SP = ORIGMARK;
3986 PUSHi(value);
d5a9bfb0
IZ		 3987 if (did_pipes) {
3988 PerlLIO_close(pp[0]);
3989 PerlLIO_close(pp[1]);
3990 }
a0d0e21e
LW		 3991 RETURN;
3992 }
3993 sleep(5);
3994 }
3995 if (childpid > 0) {
d5a9bfb0
IZ		 3996 if (did_pipes)
3997 PerlLIO_close(pp[1]);
64ca3a65 3998#ifndef PERL_MICRO
ff68c719 3999 rsignal_save(SIGINT, SIG_IGN, &ihand);
4000 rsignal_save(SIGQUIT, SIG_IGN, &qhand);
64ca3a65 4001#endif
748a9306
LW		 4002 do {
4003 result = wait4pid(childpid, &status, 0);
4004 } while (result == -1 && errno == EINTR);
64ca3a65 4005#ifndef PERL_MICRO
ff68c719 4006 (void)rsignal_restore(SIGINT, &ihand);
4007 (void)rsignal_restore(SIGQUIT, &qhand);
64ca3a65 4008#endif
91e9c03f 4009 STATUS_NATIVE_SET(result == -1 ? -1 : status);
a0d0e21e
LW		 4010 do_execfree(); /* free any memory child malloced on vfork */
4011 SP = ORIGMARK;
d5a9bfb0
IZ		 4012 if (did_pipes) {
4013 int errkid;
4014 int n = 0, n1;
4015
4016 while (n < sizeof(int)) {
4017 n1 = PerlLIO_read(pp[0],
4018 (void*)(((char*)&errkid)+n),
4019 (sizeof(int)) - n);
4020 if (n1 <= 0)
4021 break;
4022 n += n1;
4023 }
4024 PerlLIO_close(pp[0]);
4025 if (n) { /* Error */
4026 if (n != sizeof(int))
c529f79d 4027 DIE(aTHX_ "panic: kid popen errno read");
d5a9bfb0
IZ		 4028 errno = errkid; /* Propagate errno from kid */
4029 STATUS_CURRENT = -1;
4030 }
4031 }
ff0cee69 4032 PUSHi(STATUS_CURRENT);
a0d0e21e
LW		 4033 RETURN;
4034 }
d5a9bfb0
IZ		 4035 if (did_pipes) {
4036 PerlLIO_close(pp[0]);
4037#if defined(HAS_FCNTL) && defined(F_SETFD)
4038 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
4039#endif
4040 }
533c011a 4041 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e 4042 SV *really = *++MARK;
d5a9bfb0 4043 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
a0d0e21e
LW		 4044 }
4045 else if (SP - MARK != 1)
d5a9bfb0 4046 value = (I32)do_aexec5(Nullsv, MARK, SP, pp[1], did_pipes);
a0d0e21e 4047 else {
d5a9bfb0 4048 value = (I32)do_exec3(SvPVx(sv_mortalcopy(*SP), n_a), pp[1], did_pipes);
a0d0e21e 4049 }
6ad3d225 4050 PerlProc__exit(-1);
c3293030 4051#else /* ! FORK or VMS or OS/2 */
922b1888
GS		 4052 PL_statusvalue = 0;
4053 result = 0;
911d147d 4054 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e 4055 SV *really = *++MARK;
c5be433b 4056 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
a0d0e21e
LW		 4057 }
4058 else if (SP - MARK != 1)
c5be433b 4059 value = (I32)do_aspawn(Nullsv, (void **)MARK, (void **)SP);
a0d0e21e 4060 else {
c5be433b 4061 value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
a0d0e21e 4062 }
922b1888
GS		 4063 if (PL_statusvalue == -1) /* hint that value must be returned as is */
4064 result = 1;
f86702cc 4065 STATUS_NATIVE_SET(value);
a0d0e21e
LW		 4066 do_execfree();
4067 SP = ORIGMARK;
922b1888 4068 PUSHi(result ? value : STATUS_CURRENT);
a0d0e21e
LW		 4069#endif /* !FORK or VMS */
4070 RETURN;
4071}
4072
4073PP(pp_exec)
4074{
39644a26 4075 dSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e 4076 I32 value;
2d8e6c8d 4077 STRLEN n_a;
a0d0e21e 4078
45bc9206 4079 PERL_FLUSHALL_FOR_CHILD;
533c011a 4080 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e
LW		 4081 SV *really = *++MARK;
4082 value = (I32)do_aexec(really, MARK, SP);
4083 }
4084 else if (SP - MARK != 1)
4085#ifdef VMS
4086 value = (I32)vms_do_aexec(Nullsv, MARK, SP);
4087#else
092bebab
JH		 4088# ifdef __OPEN_VM
4089 {
c5be433b 4090 (void ) do_aspawn(Nullsv, MARK, SP);
092bebab
JH		 4091 value = 0;
4092 }
4093# else
a0d0e21e 4094 value = (I32)do_aexec(Nullsv, MARK, SP);
092bebab 4095# endif
a0d0e21e
LW		 4096#endif
4097 else {
3280af22 4098 if (PL_tainting) {
2d8e6c8d 4099 char *junk = SvPV(*SP, n_a);
a0d0e21e
LW		 4100 TAINT_ENV();
4101 TAINT_PROPER("exec");
4102 }
4103#ifdef VMS
2d8e6c8d 4104 value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
a0d0e21e 4105#else
092bebab 4106# ifdef __OPEN_VM
c5be433b 4107 (void) do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
092bebab
JH		 4108 value = 0;
4109# else
2d8e6c8d 4110 value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
092bebab 4111# endif
a0d0e21e
LW		 4112#endif
4113 }
146174a9
CB		 4114
4115#if !defined(HAS_FORK) && defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4116 if (value >= 0)
4117 my_exit(value);
4118#endif
4119
a0d0e21e
LW		 4120 SP = ORIGMARK;
4121 PUSHi(value);
4122 RETURN;
4123}
4124
4125PP(pp_kill)
4126{
39644a26 4127 dSP; dMARK; dTARGET;
a0d0e21e
LW		 4128 I32 value;
4129#ifdef HAS_KILL
533c011a 4130 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 4131 SP = MARK;
4132 PUSHi(value);
4133 RETURN;
4134#else
cea2e8a9 4135 DIE(aTHX_ PL_no_func, "Unsupported function kill");
a0d0e21e
LW		 4136#endif
4137}
4138
4139PP(pp_getppid)
4140{
4141#ifdef HAS_GETPPID
39644a26 4142 dSP; dTARGET;
a0d0e21e
LW		 4143 XPUSHi( getppid() );
4144 RETURN;
4145#else
cea2e8a9 4146 DIE(aTHX_ PL_no_func, "getppid");
a0d0e21e
LW		 4147#endif
4148}
4149
4150PP(pp_getpgrp)
4151{
4152#ifdef HAS_GETPGRP
39644a26 4153 dSP; dTARGET;
d8a83dd3 4154 Pid_t pid;
9853a804 4155 Pid_t pgrp;
a0d0e21e
LW		 4156
4157 if (MAXARG < 1)
4158 pid = 0;
4159 else
4160 pid = SvIVx(POPs);
c3293030 4161#ifdef BSD_GETPGRP
9853a804 4162 pgrp = (I32)BSD_GETPGRP(pid);
a0d0e21e 4163#else
146174a9 4164 if (pid != 0 && pid != PerlProc_getpid())
cea2e8a9 4165 DIE(aTHX_ "POSIX getpgrp can't take an argument");
9853a804 4166 pgrp = getpgrp();
a0d0e21e 4167#endif
9853a804 4168 XPUSHi(pgrp);
a0d0e21e
LW		 4169 RETURN;
4170#else
cea2e8a9 4171 DIE(aTHX_ PL_no_func, "getpgrp()");
a0d0e21e
LW		 4172#endif
4173}
4174
4175PP(pp_setpgrp)
4176{
4177#ifdef HAS_SETPGRP
39644a26 4178 dSP; dTARGET;
d8a83dd3
JH		 4179 Pid_t pgrp;
4180 Pid_t pid;
a0d0e21e
LW		 4181 if (MAXARG < 2) {
4182 pgrp = 0;
4183 pid = 0;
4184 }
4185 else {
4186 pgrp = POPi;
4187 pid = TOPi;
4188 }
4189
4190 TAINT_PROPER("setpgrp");
c3293030
IZ		 4191#ifdef BSD_SETPGRP
4192 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
a0d0e21e 4193#else
146174a9
CB		 4194 if ((pgrp != 0 && pgrp != PerlProc_getpid())
4195 || (pid != 0 && pid != PerlProc_getpid()))
4196 {
4197 DIE(aTHX_ "setpgrp can't take arguments");
4198 }
a0d0e21e
LW		 4199 SETi( setpgrp() >= 0 );
4200#endif /* USE_BSDPGRP */
4201 RETURN;
4202#else
cea2e8a9 4203 DIE(aTHX_ PL_no_func, "setpgrp()");
a0d0e21e
LW		 4204#endif
4205}
4206
4207PP(pp_getpriority)
4208{
39644a26 4209 dSP; dTARGET;
a0d0e21e
LW		 4210 int which;
4211 int who;
4212#ifdef HAS_GETPRIORITY
4213 who = POPi;
4214 which = TOPi;
4215 SETi( getpriority(which, who) );
4216 RETURN;
4217#else
cea2e8a9 4218 DIE(aTHX_ PL_no_func, "getpriority()");
a0d0e21e
LW		 4219#endif
4220}
4221
4222PP(pp_setpriority)
4223{
39644a26 4224 dSP; dTARGET;
a0d0e21e
LW		 4225 int which;
4226 int who;
4227 int niceval;
4228#ifdef HAS_SETPRIORITY
4229 niceval = POPi;
4230 who = POPi;
4231 which = TOPi;
4232 TAINT_PROPER("setpriority");
4233 SETi( setpriority(which, who, niceval) >= 0 );
4234 RETURN;
4235#else
cea2e8a9 4236 DIE(aTHX_ PL_no_func, "setpriority()");
a0d0e21e
LW		 4237#endif
4238}
4239
4240/* Time calls. */
4241
4242PP(pp_time)
4243{
39644a26 4244 dSP; dTARGET;
cbdc8872 4245#ifdef BIG_TIME
4246 XPUSHn( time(Null(Time_t*)) );
4247#else
a0d0e21e 4248 XPUSHi( time(Null(Time_t*)) );
cbdc8872 4249#endif
a0d0e21e
LW		 4250 RETURN;
4251}
4252
cd52b7b2 4253/* XXX The POSIX name is CLK_TCK; it is to be preferred
4254 to HZ. Probably. For now, assume that if the system
4255 defines HZ, it does so correctly. (Will this break
4256 on VMS?)
4257 Probably we ought to use _sysconf(_SC_CLK_TCK), if
4258 it's supported. --AD 9/96.
4259*/
4260
a0d0e21e 4261#ifndef HZ
cd52b7b2 4262# ifdef CLK_TCK
4263# define HZ CLK_TCK
4264# else
4265# define HZ 60
4266# endif
a0d0e21e
LW		 4267#endif
4268
4269PP(pp_tms)
4270{
39644a26 4271 dSP;
a0d0e21e 4272
55497cff 4273#ifndef HAS_TIMES
cea2e8a9 4274 DIE(aTHX_ "times not implemented");
a0d0e21e
LW		 4275#else
4276 EXTEND(SP, 4);
4277
4278#ifndef VMS
3280af22 4279 (void)PerlProc_times(&PL_timesbuf);
a0d0e21e 4280#else
6b88bc9c 4281 (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
76e3520e
GS		 4282 /* struct tms, though same data */
4283 /* is returned. */
a0d0e21e
LW		 4284#endif
4285
65202027 4286 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_utime)/HZ)));
a0d0e21e 4287 if (GIMME == G_ARRAY) {
65202027
DS		 4288 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_stime)/HZ)));
4289 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cutime)/HZ)));
4290 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cstime)/HZ)));
a0d0e21e
LW		 4291 }
4292 RETURN;
55497cff 4293#endif /* HAS_TIMES */
a0d0e21e
LW		 4294}
4295
4296PP(pp_localtime)
4297{
cea2e8a9 4298 return pp_gmtime();
a0d0e21e
LW		 4299}
4300
4301PP(pp_gmtime)
4302{
39644a26 4303 dSP;
a0d0e21e
LW		 4304 Time_t when;
4305 struct tm *tmbuf;
4306 static char *dayname[] = {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4307 static char *monname[] = {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4308 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4309
4310 if (MAXARG < 1)
4311 (void)time(&when);
4312 else
cbdc8872 4313#ifdef BIG_TIME
4314 when = (Time_t)SvNVx(POPs);
4315#else
a0d0e21e 4316 when = (Time_t)SvIVx(POPs);
cbdc8872 4317#endif
a0d0e21e 4318
533c011a 4319 if (PL_op->op_type == OP_LOCALTIME)
a0d0e21e
LW		 4320 tmbuf = localtime(&when);
4321 else
4322 tmbuf = gmtime(&when);
4323
4324 EXTEND(SP, 9);
bbce6d69 4325 EXTEND_MORTAL(9);
a0d0e21e 4326 if (GIMME != G_ARRAY) {
46fc3d4c 4327 SV *tsv;
a0d0e21e
LW		 4328 if (!tmbuf)
4329 RETPUSHUNDEF;
be28567c 4330 tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %d",
f5a29b03
RB		 4331 dayname[tmbuf->tm_wday],
4332 monname[tmbuf->tm_mon],
be28567c
GS		 4333 tmbuf->tm_mday,
4334 tmbuf->tm_hour,
4335 tmbuf->tm_min,
4336 tmbuf->tm_sec,
4337 tmbuf->tm_year + 1900);
46fc3d4c 4338 PUSHs(sv_2mortal(tsv));
a0d0e21e
LW		 4339 }
4340 else if (tmbuf) {
c6419e06
JH		 4341 PUSHs(sv_2mortal(newSViv(tmbuf->tm_sec)));
4342 PUSHs(sv_2mortal(newSViv(tmbuf->tm_min)));
4343 PUSHs(sv_2mortal(newSViv(tmbuf->tm_hour)));
4344 PUSHs(sv_2mortal(newSViv(tmbuf->tm_mday)));
4345 PUSHs(sv_2mortal(newSViv(tmbuf->tm_mon)));
4346 PUSHs(sv_2mortal(newSViv(tmbuf->tm_year)));
4347 PUSHs(sv_2mortal(newSViv(tmbuf->tm_wday)));
4348 PUSHs(sv_2mortal(newSViv(tmbuf->tm_yday)));
4349 PUSHs(sv_2mortal(newSViv(tmbuf->tm_isdst)));
a0d0e21e
LW		 4350 }
4351 RETURN;
4352}
4353
4354PP(pp_alarm)
4355{
39644a26 4356 dSP; dTARGET;
a0d0e21e
LW		 4357 int anum;
4358#ifdef HAS_ALARM
4359 anum = POPi;
4360 anum = alarm((unsigned int)anum);
4361 EXTEND(SP, 1);
4362 if (anum < 0)
4363 RETPUSHUNDEF;
c6419e06 4364 PUSHi(anum);
a0d0e21e
LW		 4365 RETURN;
4366#else
cea2e8a9 4367 DIE(aTHX_ PL_no_func, "Unsupported function alarm");
a0d0e21e
LW		 4368#endif
4369}
4370
4371PP(pp_sleep)
4372{
39644a26 4373 dSP; dTARGET;
a0d0e21e
LW		 4374 I32 duration;
4375 Time_t lasttime;
4376 Time_t when;
4377
4378 (void)time(&lasttime);
4379 if (MAXARG < 1)
76e3520e 4380 PerlProc_pause();
a0d0e21e
LW		 4381 else {
4382 duration = POPi;
76e3520e 4383 PerlProc_sleep((unsigned int)duration);
a0d0e21e
LW		 4384 }
4385 (void)time(&when);
4386 XPUSHi(when - lasttime);
4387 RETURN;
4388}
4389
4390/* Shared memory. */
4391
4392PP(pp_shmget)
4393{
cea2e8a9 4394 return pp_semget();
a0d0e21e
LW		 4395}
4396
4397PP(pp_shmctl)
4398{
cea2e8a9 4399 return pp_semctl();
a0d0e21e
LW		 4400}
4401
4402PP(pp_shmread)
4403{
cea2e8a9 4404 return pp_shmwrite();
a0d0e21e
LW		 4405}
4406
4407PP(pp_shmwrite)
4408{
4409#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
39644a26 4410 dSP; dMARK; dTARGET;
533c011a 4411 I32 value = (I32)(do_shmio(PL_op->op_type, MARK, SP) >= 0);
a0d0e21e
LW		 4412 SP = MARK;
4413 PUSHi(value);
4414 RETURN;
4415#else
cea2e8a9 4416 return pp_semget();
a0d0e21e
LW		 4417#endif
4418}
4419
4420/* Message passing. */
4421
4422PP(pp_msgget)
4423{
cea2e8a9 4424 return pp_semget();
a0d0e21e
LW		 4425}
4426
4427PP(pp_msgctl)
4428{
cea2e8a9 4429 return pp_semctl();
a0d0e21e
LW		 4430}
4431
4432PP(pp_msgsnd)
4433{
4434#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
39644a26 4435 dSP; dMARK; dTARGET;
a0d0e21e
LW		 4436 I32 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4437 SP = MARK;
4438 PUSHi(value);
4439 RETURN;
4440#else
cea2e8a9 4441 return pp_semget();
a0d0e21e
LW		 4442#endif
4443}
4444
4445PP(pp_msgrcv)
4446{
4447#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
39644a26 4448 dSP; dMARK; dTARGET;
a0d0e21e
LW		 4449 I32 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4450 SP = MARK;
4451 PUSHi(value);
4452 RETURN;
4453#else
cea2e8a9 4454 return pp_semget();
a0d0e21e
LW		 4455#endif
4456}
4457
4458/* Semaphores. */
4459
4460PP(pp_semget)
4461{
4462#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
39644a26 4463 dSP; dMARK; dTARGET;
533c011a 4464 int anum = do_ipcget(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 4465 SP = MARK;
4466 if (anum == -1)
4467 RETPUSHUNDEF;
4468 PUSHi(anum);
4469 RETURN;
4470#else
cea2e8a9 4471 DIE(aTHX_ "System V IPC is not implemented on this machine");
a0d0e21e
LW		 4472#endif
4473}
4474
4475PP(pp_semctl)
4476{
4477#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
39644a26 4478 dSP; dMARK; dTARGET;
533c011a 4479 int anum = do_ipcctl(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 4480 SP = MARK;
4481 if (anum == -1)
4482 RETSETUNDEF;
4483 if (anum != 0) {
4484 PUSHi(anum);
4485 }
4486 else {
8903cb82 4487 PUSHp(zero_but_true, ZBTLEN);
a0d0e21e
LW		 4488 }
4489 RETURN;
4490#else
cea2e8a9 4491 return pp_semget();
a0d0e21e
LW		 4492#endif
4493}
4494
4495PP(pp_semop)
4496{
4497#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
39644a26 4498 dSP; dMARK; dTARGET;
a0d0e21e
LW		 4499 I32 value = (I32)(do_semop(MARK, SP) >= 0);
4500 SP = MARK;
4501 PUSHi(value);
4502 RETURN;
4503#else
cea2e8a9 4504 return pp_semget();
a0d0e21e
LW		 4505#endif
4506}
4507
4508/* Get system info. */
4509
4510PP(pp_ghbyname)
4511{
693762b4 4512#ifdef HAS_GETHOSTBYNAME
cea2e8a9 4513 return pp_ghostent();
a0d0e21e 4514#else
cea2e8a9 4515 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
a0d0e21e
LW		 4516#endif
4517}
4518
4519PP(pp_ghbyaddr)
4520{
693762b4 4521#ifdef HAS_GETHOSTBYADDR
cea2e8a9 4522 return pp_ghostent();
a0d0e21e 4523#else
cea2e8a9 4524 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
a0d0e21e
LW		 4525#endif
4526}
4527
4528PP(pp_ghostent)
4529{
39644a26 4530 dSP;
693762b4 4531#if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
533c011a 4532 I32 which = PL_op->op_type;
a0d0e21e
LW		 4533 register char **elem;
4534 register SV *sv;
dc45a647 4535#ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4599a1de
JH		 4536 struct hostent *PerlSock_gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4537 struct hostent *PerlSock_gethostbyname(Netdb_name_t);
6ad3d225 4538 struct hostent *PerlSock_gethostent(void);
a0d0e21e
LW		 4539#endif
4540 struct hostent *hent;
4541 unsigned long len;
2d8e6c8d 4542 STRLEN n_a;
a0d0e21e
LW		 4543
4544 EXTEND(SP, 10);
dc45a647
MB		 4545 if (which == OP_GHBYNAME)
4546#ifdef HAS_GETHOSTBYNAME
595ae481 4547 hent = PerlSock_gethostbyname(POPpbytex);
dc45a647 4548#else
cea2e8a9 4549 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
dc45a647 4550#endif
a0d0e21e 4551 else if (which == OP_GHBYADDR) {
dc45a647 4552#ifdef HAS_GETHOSTBYADDR
a0d0e21e 4553 int addrtype = POPi;
748a9306 4554 SV *addrsv = POPs;
a0d0e21e 4555 STRLEN addrlen;
595ae481 4556 Netdb_host_t addr = (Netdb_host_t) SvPVbyte(addrsv, addrlen);
a0d0e21e 4557
4599a1de 4558 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
dc45a647 4559#else
cea2e8a9 4560 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
dc45a647 4561#endif
a0d0e21e
LW		 4562 }
4563 else
4564#ifdef HAS_GETHOSTENT
6ad3d225 4565 hent = PerlSock_gethostent();
a0d0e21e 4566#else
cea2e8a9 4567 DIE(aTHX_ PL_no_sock_func, "gethostent");
a0d0e21e
LW		 4568#endif
4569
4570#ifdef HOST_NOT_FOUND
4571 if (!hent)
f86702cc 4572 STATUS_NATIVE_SET(h_errno);
a0d0e21e
LW		 4573#endif
4574
4575 if (GIMME != G_ARRAY) {
4576 PUSHs(sv = sv_newmortal());
4577 if (hent) {
4578 if (which == OP_GHBYNAME) {
fd0af264 4579 if (hent->h_addr)
4580 sv_setpvn(sv, hent->h_addr, hent->h_length);
a0d0e21e
LW		 4581 }
4582 else
4583 sv_setpv(sv, (char*)hent->h_name);
4584 }
4585 RETURN;
4586 }
4587
4588 if (hent) {
3280af22 4589 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4590 sv_setpv(sv, (char*)hent->h_name);
3280af22 4591 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 4592 for (elem = hent->h_aliases; elem && *elem; elem++) {
4593 sv_catpv(sv, *elem);
4594 if (elem[1])
4595 sv_catpvn(sv, " ", 1);
4596 }
3280af22 4597 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4598 sv_setiv(sv, (IV)hent->h_addrtype);
3280af22 4599 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4600 len = hent->h_length;
1e422769 4601 sv_setiv(sv, (IV)len);
a0d0e21e
LW		 4602#ifdef h_addr
4603 for (elem = hent->h_addr_list; elem && *elem; elem++) {
3280af22 4604 XPUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 4605 sv_setpvn(sv, *elem, len);
4606 }
4607#else
6b88bc9c 4608 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
fd0af264 4609 if (hent->h_addr)
4610 sv_setpvn(sv, hent->h_addr, len);
a0d0e21e
LW		 4611#endif /* h_addr */
4612 }
4613 RETURN;
4614#else
cea2e8a9 4615 DIE(aTHX_ PL_no_sock_func, "gethostent");
a0d0e21e
LW		 4616#endif
4617}
4618
4619PP(pp_gnbyname)
4620{
693762b4 4621#ifdef HAS_GETNETBYNAME
cea2e8a9 4622 return pp_gnetent();
a0d0e21e 4623#else
cea2e8a9 4624 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
a0d0e21e
LW		 4625#endif
4626}
4627
4628PP(pp_gnbyaddr)
4629{
693762b4 4630#ifdef HAS_GETNETBYADDR
cea2e8a9 4631 return pp_gnetent();
a0d0e21e 4632#else
cea2e8a9 4633 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
a0d0e21e
LW		 4634#endif
4635}
4636
4637PP(pp_gnetent)
4638{
39644a26 4639 dSP;
693762b4 4640#if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
533c011a 4641 I32 which = PL_op->op_type;
a0d0e21e
LW		 4642 register char **elem;
4643 register SV *sv;
dc45a647
MB		 4644#ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4645 struct netent *PerlSock_getnetbyaddr(Netdb_net_t, int);
4646 struct netent *PerlSock_getnetbyname(Netdb_name_t);
4647 struct netent *PerlSock_getnetent(void);
8ac85365 4648#endif
a0d0e21e 4649 struct netent *nent;
2d8e6c8d 4650 STRLEN n_a;
a0d0e21e
LW		 4651
4652 if (which == OP_GNBYNAME)
dc45a647 4653#ifdef HAS_GETNETBYNAME
42e0c139 4654 nent = PerlSock_getnetbyname(POPpbytex);
dc45a647 4655#else
cea2e8a9 4656 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
dc45a647 4657#endif
a0d0e21e 4658 else if (which == OP_GNBYADDR) {
dc45a647 4659#ifdef HAS_GETNETBYADDR
a0d0e21e 4660 int addrtype = POPi;
4599a1de 4661 Netdb_net_t addr = (Netdb_net_t) U_L(POPn);
76e3520e 4662 nent = PerlSock_getnetbyaddr(addr, addrtype);
dc45a647 4663#else
cea2e8a9 4664 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
dc45a647 4665#endif
a0d0e21e
LW		 4666 }
4667 else
dc45a647 4668#ifdef HAS_GETNETENT
76e3520e 4669 nent = PerlSock_getnetent();
dc45a647 4670#else
cea2e8a9 4671 DIE(aTHX_ PL_no_sock_func, "getnetent");
dc45a647 4672#endif
a0d0e21e
LW		 4673
4674 EXTEND(SP, 4);
4675 if (GIMME != G_ARRAY) {
4676 PUSHs(sv = sv_newmortal());
4677 if (nent) {
4678 if (which == OP_GNBYNAME)
1e422769 4679 sv_setiv(sv, (IV)nent->n_net);
a0d0e21e
LW		 4680 else
4681 sv_setpv(sv, nent->n_name);
4682 }
4683 RETURN;
4684 }
4685
4686 if (nent) {
3280af22 4687 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4688 sv_setpv(sv, nent->n_name);
3280af22 4689 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 4690 for (elem = nent->n_aliases; elem && *elem; elem++) {
a0d0e21e
LW		 4691 sv_catpv(sv, *elem);
4692 if (elem[1])
4693 sv_catpvn(sv, " ", 1);
4694 }
3280af22 4695 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4696 sv_setiv(sv, (IV)nent->n_addrtype);
3280af22 4697 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4698 sv_setiv(sv, (IV)nent->n_net);
a0d0e21e
LW		 4699 }
4700
4701 RETURN;
4702#else
cea2e8a9 4703 DIE(aTHX_ PL_no_sock_func, "getnetent");
a0d0e21e
LW		 4704#endif
4705}
4706
4707PP(pp_gpbyname)
4708{
693762b4 4709#ifdef HAS_GETPROTOBYNAME
cea2e8a9 4710 return pp_gprotoent();
a0d0e21e 4711#else
cea2e8a9 4712 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
a0d0e21e
LW		 4713#endif
4714}
4715
4716PP(pp_gpbynumber)
4717{
693762b4 4718#ifdef HAS_GETPROTOBYNUMBER
cea2e8a9 4719 return pp_gprotoent();
a0d0e21e 4720#else
cea2e8a9 4721 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
a0d0e21e
LW		 4722#endif
4723}
4724
4725PP(pp_gprotoent)
4726{
39644a26 4727 dSP;
693762b4 4728#if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
533c011a 4729 I32 which = PL_op->op_type;
a0d0e21e 4730 register char **elem;
301e8125 4731 register SV *sv;
dc45a647 4732#ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4599a1de 4733 struct protoent *PerlSock_getprotobyname(Netdb_name_t);
6ad3d225
GS		 4734 struct protoent *PerlSock_getprotobynumber(int);
4735 struct protoent *PerlSock_getprotoent(void);
8ac85365 4736#endif
a0d0e21e 4737 struct protoent *pent;
2d8e6c8d 4738 STRLEN n_a;
a0d0e21e
LW		 4739
4740 if (which == OP_GPBYNAME)
e5c9fcd0 4741#ifdef HAS_GETPROTOBYNAME
42e0c139 4742 pent = PerlSock_getprotobyname(POPpbytex);
e5c9fcd0 4743#else
cea2e8a9 4744 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
e5c9fcd0 4745#endif
a0d0e21e 4746 else if (which == OP_GPBYNUMBER)
e5c9fcd0 4747#ifdef HAS_GETPROTOBYNUMBER
6ad3d225 4748 pent = PerlSock_getprotobynumber(POPi);
e5c9fcd0 4749#else
cea2e8a9 4750 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
e5c9fcd0 4751#endif
a0d0e21e 4752 else
e5c9fcd0 4753#ifdef HAS_GETPROTOENT
6ad3d225 4754 pent = PerlSock_getprotoent();
e5c9fcd0 4755#else
cea2e8a9 4756 DIE(aTHX_ PL_no_sock_func, "getprotoent");
e5c9fcd0 4757#endif
a0d0e21e
LW		 4758
4759 EXTEND(SP, 3);
4760 if (GIMME != G_ARRAY) {
4761 PUSHs(sv = sv_newmortal());
4762 if (pent) {
4763 if (which == OP_GPBYNAME)
1e422769 4764 sv_setiv(sv, (IV)pent->p_proto);
a0d0e21e
LW		 4765 else
4766 sv_setpv(sv, pent->p_name);
4767 }
4768 RETURN;
4769 }
4770
4771 if (pent) {
3280af22 4772 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4773 sv_setpv(sv, pent->p_name);
3280af22 4774 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 4775 for (elem = pent->p_aliases; elem && *elem; elem++) {
a0d0e21e
LW		 4776 sv_catpv(sv, *elem);
4777 if (elem[1])
4778 sv_catpvn(sv, " ", 1);
4779 }
3280af22 4780 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4781 sv_setiv(sv, (IV)pent->p_proto);
a0d0e21e
LW		 4782 }
4783
4784 RETURN;
4785#else
cea2e8a9 4786 DIE(aTHX_ PL_no_sock_func, "getprotoent");
a0d0e21e
LW		 4787#endif
4788}
4789
4790PP(pp_gsbyname)
4791{
9ec75305 4792#ifdef HAS_GETSERVBYNAME
cea2e8a9 4793 return pp_gservent();
a0d0e21e 4794#else
cea2e8a9 4795 DIE(aTHX_ PL_no_sock_func, "getservbyname");
a0d0e21e
LW		 4796#endif
4797}
4798
4799PP(pp_gsbyport)
4800{
9ec75305 4801#ifdef HAS_GETSERVBYPORT
cea2e8a9 4802 return pp_gservent();
a0d0e21e 4803#else
cea2e8a9 4804 DIE(aTHX_ PL_no_sock_func, "getservbyport");
a0d0e21e
LW		 4805#endif
4806}
4807
4808PP(pp_gservent)
4809{
39644a26 4810 dSP;
693762b4 4811#if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
533c011a 4812 I32 which = PL_op->op_type;
a0d0e21e
LW		 4813 register char **elem;
4814 register SV *sv;
dc45a647 4815#ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4599a1de
JH		 4816 struct servent *PerlSock_getservbyname(Netdb_name_t, Netdb_name_t);
4817 struct servent *PerlSock_getservbyport(int, Netdb_name_t);
6ad3d225 4818 struct servent *PerlSock_getservent(void);
8ac85365 4819#endif
a0d0e21e 4820 struct servent *sent;
2d8e6c8d 4821 STRLEN n_a;
a0d0e21e
LW		 4822
4823 if (which == OP_GSBYNAME) {
dc45a647 4824#ifdef HAS_GETSERVBYNAME
42e0c139
AP		 4825 char *proto = POPpbytex;
4826 char *name = POPpbytex;
a0d0e21e
LW		 4827
4828 if (proto && !*proto)
4829 proto = Nullch;
4830
6ad3d225 4831 sent = PerlSock_getservbyname(name, proto);
dc45a647 4832#else
cea2e8a9 4833 DIE(aTHX_ PL_no_sock_func, "getservbyname");
dc45a647 4834#endif
a0d0e21e
LW		 4835 }
4836 else if (which == OP_GSBYPORT) {
dc45a647 4837#ifdef HAS_GETSERVBYPORT
42e0c139 4838 char *proto = POPpbytex;
36477c24 4839 unsigned short port = POPu;
a0d0e21e 4840
36477c24 4841#ifdef HAS_HTONS
6ad3d225 4842 port = PerlSock_htons(port);
36477c24 4843#endif
6ad3d225 4844 sent = PerlSock_getservbyport(port, proto);
dc45a647 4845#else
cea2e8a9 4846 DIE(aTHX_ PL_no_sock_func, "getservbyport");
dc45a647 4847#endif
a0d0e21e
LW		 4848 }
4849 else
e5c9fcd0 4850#ifdef HAS_GETSERVENT
6ad3d225 4851 sent = PerlSock_getservent();
e5c9fcd0 4852#else
cea2e8a9 4853 DIE(aTHX_ PL_no_sock_func, "getservent");
e5c9fcd0 4854#endif
a0d0e21e
LW		 4855
4856 EXTEND(SP, 4);
4857 if (GIMME != G_ARRAY) {
4858 PUSHs(sv = sv_newmortal());
4859 if (sent) {
4860 if (which == OP_GSBYNAME) {
4861#ifdef HAS_NTOHS
6ad3d225 4862 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
a0d0e21e 4863#else
1e422769 4864 sv_setiv(sv, (IV)(sent->s_port));
a0d0e21e
LW		 4865#endif
4866 }
4867 else
4868 sv_setpv(sv, sent->s_name);
4869 }
4870 RETURN;
4871 }
4872
4873 if (sent) {
3280af22 4874 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4875 sv_setpv(sv, sent->s_name);
3280af22 4876 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 4877 for (elem = sent->s_aliases; elem && *elem; elem++) {
a0d0e21e
LW		 4878 sv_catpv(sv, *elem);
4879 if (elem[1])
4880 sv_catpvn(sv, " ", 1);
4881 }
3280af22 4882 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4883#ifdef HAS_NTOHS
76e3520e 4884 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
a0d0e21e 4885#else
1e422769 4886 sv_setiv(sv, (IV)(sent->s_port));
a0d0e21e 4887#endif
3280af22 4888 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 4889 sv_setpv(sv, sent->s_proto);
4890 }
4891
4892 RETURN;
4893#else
cea2e8a9 4894 DIE(aTHX_ PL_no_sock_func, "getservent");
a0d0e21e
LW		 4895#endif
4896}
4897
4898PP(pp_shostent)
4899{
39644a26 4900 dSP;
693762b4 4901#ifdef HAS_SETHOSTENT
76e3520e 4902 PerlSock_sethostent(TOPi);
a0d0e21e
LW		 4903 RETSETYES;
4904#else
cea2e8a9 4905 DIE(aTHX_ PL_no_sock_func, "sethostent");
a0d0e21e
LW		 4906#endif
4907}
4908
4909PP(pp_snetent)
4910{
39644a26 4911 dSP;
693762b4 4912#ifdef HAS_SETNETENT
76e3520e 4913 PerlSock_setnetent(TOPi);
a0d0e21e
LW		 4914 RETSETYES;
4915#else
cea2e8a9 4916 DIE(aTHX_ PL_no_sock_func, "setnetent");
a0d0e21e
LW		 4917#endif
4918}
4919
4920PP(pp_sprotoent)
4921{
39644a26 4922 dSP;
693762b4 4923#ifdef HAS_SETPROTOENT
76e3520e 4924 PerlSock_setprotoent(TOPi);
a0d0e21e
LW		 4925 RETSETYES;
4926#else
cea2e8a9 4927 DIE(aTHX_ PL_no_sock_func, "setprotoent");
a0d0e21e
LW		 4928#endif
4929}
4930
4931PP(pp_sservent)
4932{
39644a26 4933 dSP;
693762b4 4934#ifdef HAS_SETSERVENT
76e3520e 4935 PerlSock_setservent(TOPi);
a0d0e21e
LW		 4936 RETSETYES;
4937#else
cea2e8a9 4938 DIE(aTHX_ PL_no_sock_func, "setservent");
a0d0e21e
LW		 4939#endif
4940}
4941
4942PP(pp_ehostent)
4943{
39644a26 4944 dSP;
693762b4 4945#ifdef HAS_ENDHOSTENT
76e3520e 4946 PerlSock_endhostent();
924508f0 4947 EXTEND(SP,1);
a0d0e21e
LW		 4948 RETPUSHYES;
4949#else
cea2e8a9 4950 DIE(aTHX_ PL_no_sock_func, "endhostent");
a0d0e21e
LW		 4951#endif
4952}
4953
4954PP(pp_enetent)
4955{
39644a26 4956 dSP;
693762b4 4957#ifdef HAS_ENDNETENT
76e3520e 4958 PerlSock_endnetent();
924508f0 4959 EXTEND(SP,1);
a0d0e21e
LW		 4960 RETPUSHYES;
4961#else
cea2e8a9 4962 DIE(aTHX_ PL_no_sock_func, "endnetent");
a0d0e21e
LW		 4963#endif
4964}
4965
4966PP(pp_eprotoent)
4967{
39644a26 4968 dSP;
693762b4 4969#ifdef HAS_ENDPROTOENT
76e3520e 4970 PerlSock_endprotoent();
924508f0 4971 EXTEND(SP,1);
a0d0e21e
LW		 4972 RETPUSHYES;
4973#else
cea2e8a9 4974 DIE(aTHX_ PL_no_sock_func, "endprotoent");
a0d0e21e
LW		 4975#endif
4976}
4977
4978PP(pp_eservent)
4979{
39644a26 4980 dSP;
693762b4 4981#ifdef HAS_ENDSERVENT
76e3520e 4982 PerlSock_endservent();
924508f0 4983 EXTEND(SP,1);
a0d0e21e
LW		 4984 RETPUSHYES;
4985#else
cea2e8a9 4986 DIE(aTHX_ PL_no_sock_func, "endservent");
a0d0e21e
LW		 4987#endif
4988}
4989
4990PP(pp_gpwnam)
4991{
4992#ifdef HAS_PASSWD
cea2e8a9 4993 return pp_gpwent();
a0d0e21e 4994#else
cea2e8a9 4995 DIE(aTHX_ PL_no_func, "getpwnam");
a0d0e21e
LW		 4996#endif
4997}
4998
4999PP(pp_gpwuid)
5000{
5001#ifdef HAS_PASSWD
cea2e8a9 5002 return pp_gpwent();
a0d0e21e 5003#else
cea2e8a9 5004 DIE(aTHX_ PL_no_func, "getpwuid");
a0d0e21e
LW		 5005#endif
5006}
5007
5008PP(pp_gpwent)
5009{
39644a26 5010 dSP;
0994c4d0 5011#ifdef HAS_PASSWD
533c011a 5012 I32 which = PL_op->op_type;
a0d0e21e 5013 register SV *sv;
2d8e6c8d 5014 STRLEN n_a;
e3aefe8d 5015 struct passwd *pwent = NULL;
301e8125 5016 /*
bcf53261
JH		 5017 * We currently support only the SysV getsp* shadow password interface.
5018 * The interface is declared in <shadow.h> and often one needs to link
5019 * with -lsecurity or some such.
5020 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
5021 * (and SCO?)
5022 *
5023 * AIX getpwnam() is clever enough to return the encrypted password
5024 * only if the caller (euid?) is root.
5025 *
5026 * There are at least two other shadow password APIs. Many platforms
5027 * seem to contain more than one interface for accessing the shadow
5028 * password databases, possibly for compatibility reasons.
3813c136 5029 * The getsp*() is by far he simplest one, the other two interfaces
bcf53261
JH		 5030 * are much more complicated, but also very similar to each other.
5031 *
5032 * <sys/types.h>
5033 * <sys/security.h>
5034 * <prot.h>
5035 * struct pr_passwd *getprpw*();
5036 * The password is in
3813c136
JH		 5037 * char getprpw*(...).ufld.fd_encrypt[]
5038 * Mention HAS_GETPRPWNAM here so that Configure probes for it.
bcf53261
JH		 5039 *
5040 * <sys/types.h>
5041 * <sys/security.h>
5042 * <prot.h>
5043 * struct es_passwd *getespw*();
5044 * The password is in
5045 * char *(getespw*(...).ufld.fd_encrypt)
3813c136 5046 * Mention HAS_GETESPWNAM here so that Configure probes for it.
bcf53261 5047 *
3813c136 5048 * Mention I_PROT here so that Configure probes for it.
bcf53261
JH		 5049 *
5050 * In HP-UX for getprpw*() the manual page claims that one should include
5051 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
5052 * if one includes <shadow.h> as that includes <hpsecurity.h>,
5053 * and pp_sys.c already includes <shadow.h> if there is such.
3813c136
JH		 5054 *
5055 * Note that <sys/security.h> is already probed for, but currently
5056 * it is only included in special cases.
301e8125 5057 *
bcf53261
JH		 5058 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
5059 * be preferred interface, even though also the getprpw*() interface
5060 * is available) one needs to link with -lsecurity -ldb -laud -lm.
3813c136
JH		 5061 * One also needs to call set_auth_parameters() in main() before
5062 * doing anything else, whether one is using getespw*() or getprpw*().
5063 *
5064 * Note that accessing the shadow databases can be magnitudes
5065 * slower than accessing the standard databases.
bcf53261
JH		 5066 *
5067 * --jhi
5068 */
a0d0e21e 5069
e3aefe8d
JH		 5070 switch (which) {
5071 case OP_GPWNAM:
42e0c139 5072 pwent = getpwnam(POPpbytex);
e3aefe8d
JH		 5073 break;
5074 case OP_GPWUID:
5075 pwent = getpwuid((Uid_t)POPi);
5076 break;
5077 case OP_GPWENT:
1883634f 5078# ifdef HAS_GETPWENT
e3aefe8d 5079 pwent = getpwent();
1883634f 5080# else
a45d1c96 5081 DIE(aTHX_ PL_no_func, "getpwent");
1883634f 5082# endif
e3aefe8d
JH		 5083 break;
5084 }
8c0bfa08 5085
a0d0e21e
LW		 5086 EXTEND(SP, 10);
5087 if (GIMME != G_ARRAY) {
5088 PUSHs(sv = sv_newmortal());
5089 if (pwent) {
5090 if (which == OP_GPWNAM)
1883634f 5091# if Uid_t_sign <= 0
1e422769 5092 sv_setiv(sv, (IV)pwent->pw_uid);
1883634f 5093# else
23dcd6c8 5094 sv_setuv(sv, (UV)pwent->pw_uid);
1883634f 5095# endif
a0d0e21e
LW		 5096 else
5097 sv_setpv(sv, pwent->pw_name);
5098 }
5099 RETURN;
5100 }
5101
5102 if (pwent) {
3280af22 5103 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 5104 sv_setpv(sv, pwent->pw_name);
6ee623d5 5105
3280af22 5106 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
3813c136
JH		 5107 SvPOK_off(sv);
5108 /* If we have getspnam(), we try to dig up the shadow
5109 * password. If we are underprivileged, the shadow
5110 * interface will set the errno to EACCES or similar,
5111 * and return a null pointer. If this happens, we will
5112 * use the dummy password (usually "*" or "x") from the
5113 * standard password database.
5114 *
5115 * In theory we could skip the shadow call completely
5116 * if euid != 0 but in practice we cannot know which
5117 * security measures are guarding the shadow databases
5118 * on a random platform.
5119 *
5120 * Resist the urge to use additional shadow interfaces.
5121 * Divert the urge to writing an extension instead.
5122 *
5123 * --jhi */
e3aefe8d 5124# ifdef HAS_GETSPNAM
3813c136
JH		 5125 {
5126 struct spwd *spwent;
5127 int saverrno; /* Save and restore errno so that
5128 * underprivileged attempts seem
5129 * to have never made the unsccessful
5130 * attempt to retrieve the shadow password. */
5131
5132 saverrno = errno;
5133 spwent = getspnam(pwent->pw_name);
5134 errno = saverrno;
5135 if (spwent && spwent->sp_pwdp)
5136 sv_setpv(sv, spwent->sp_pwdp);
5137 }
f1066039 5138# endif
e020c87d 5139# ifdef PWPASSWD
3813c136
JH		 5140 if (!SvPOK(sv)) /* Use the standard password, then. */
5141 sv_setpv(sv, pwent->pw_passwd);
e020c87d 5142# endif
3813c136 5143
1883634f 5144# ifndef INCOMPLETE_TAINTS
3813c136
JH		 5145 /* passwd is tainted because user himself can diddle with it.
5146 * admittedly not much and in a very limited way, but nevertheless. */
2959b6e3 5147 SvTAINTED_on(sv);
1883634f 5148# endif
6ee623d5 5149
3280af22 5150 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1883634f 5151# if Uid_t_sign <= 0
1e422769 5152 sv_setiv(sv, (IV)pwent->pw_uid);
1883634f 5153# else
23dcd6c8 5154 sv_setuv(sv, (UV)pwent->pw_uid);
1883634f 5155# endif
6ee623d5 5156
3280af22 5157 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1883634f 5158# if Uid_t_sign <= 0
1e422769 5159 sv_setiv(sv, (IV)pwent->pw_gid);
1883634f 5160# else
23dcd6c8 5161 sv_setuv(sv, (UV)pwent->pw_gid);
1883634f 5162# endif
3813c136
JH		 5163 /* pw_change, pw_quota, and pw_age are mutually exclusive--
5164 * because of the poor interface of the Perl getpw*(),
5165 * not because there's some standard/convention saying so.
5166 * A better interface would have been to return a hash,
5167 * but we are accursed by our history, alas. --jhi. */
3280af22 5168 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1883634f 5169# ifdef PWCHANGE
1e422769 5170 sv_setiv(sv, (IV)pwent->pw_change);
6ee623d5 5171# else
1883634f
JH		 5172# ifdef PWQUOTA
5173 sv_setiv(sv, (IV)pwent->pw_quota);
5174# else
a1757be1 5175# ifdef PWAGE
a0d0e21e 5176 sv_setpv(sv, pwent->pw_age);
a1757be1 5177# endif
6ee623d5
GS		 5178# endif
5179# endif
6ee623d5 5180
3813c136
JH		 5181 /* pw_class and pw_comment are mutually exclusive--.
5182 * see the above note for pw_change, pw_quota, and pw_age. */
3280af22 5183 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1883634f 5184# ifdef PWCLASS
a0d0e21e 5185 sv_setpv(sv, pwent->pw_class);
1883634f
JH		 5186# else
5187# ifdef PWCOMMENT
a0d0e21e 5188 sv_setpv(sv, pwent->pw_comment);
1883634f 5189# endif
6ee623d5 5190# endif
6ee623d5 5191
3280af22 5192 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1883634f 5193# ifdef PWGECOS
a0d0e21e 5194 sv_setpv(sv, pwent->pw_gecos);
1883634f
JH		 5195# endif
5196# ifndef INCOMPLETE_TAINTS
d2719217 5197 /* pw_gecos is tainted because user himself can diddle with it. */
fb73857a 5198 SvTAINTED_on(sv);
1883634f 5199# endif
6ee623d5 5200
3280af22 5201 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 5202 sv_setpv(sv, pwent->pw_dir);
6ee623d5 5203
3280af22 5204 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 5205 sv_setpv(sv, pwent->pw_shell);
1883634f 5206# ifndef INCOMPLETE_TAINTS
4602f195
JH		 5207 /* pw_shell is tainted because user himself can diddle with it. */
5208 SvTAINTED_on(sv);
1883634f 5209# endif
6ee623d5 5210
1883634f 5211# ifdef PWEXPIRE
6b88bc9c 5212 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 5213 sv_setiv(sv, (IV)pwent->pw_expire);
1883634f 5214# endif
a0d0e21e
LW		 5215 }
5216 RETURN;
5217#else
cea2e8a9 5218 DIE(aTHX_ PL_no_func, "getpwent");
a0d0e21e
LW		 5219#endif
5220}
5221
5222PP(pp_spwent)
5223{
39644a26 5224 dSP;
d493b042 5225#if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
a0d0e21e
LW		 5226 setpwent();
5227 RETPUSHYES;
5228#else
cea2e8a9 5229 DIE(aTHX_ PL_no_func, "setpwent");
a0d0e21e
LW		 5230#endif
5231}
5232
5233PP(pp_epwent)
5234{
39644a26 5235 dSP;
28e8609d 5236#if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
a0d0e21e
LW		 5237 endpwent();
5238 RETPUSHYES;
5239#else
cea2e8a9 5240 DIE(aTHX_ PL_no_func, "endpwent");
a0d0e21e
LW		 5241#endif
5242}
5243
5244PP(pp_ggrnam)
5245{
5246#ifdef HAS_GROUP
cea2e8a9 5247 return pp_ggrent();
a0d0e21e 5248#else
cea2e8a9 5249 DIE(aTHX_ PL_no_func, "getgrnam");
a0d0e21e
LW		 5250#endif
5251}
5252
5253PP(pp_ggrgid)
5254{
5255#ifdef HAS_GROUP
cea2e8a9 5256 return pp_ggrent();
a0d0e21e 5257#else
cea2e8a9 5258 DIE(aTHX_ PL_no_func, "getgrgid");
a0d0e21e
LW		 5259#endif
5260}
5261
5262PP(pp_ggrent)
5263{
39644a26 5264 dSP;
0994c4d0 5265#ifdef HAS_GROUP
533c011a 5266 I32 which = PL_op->op_type;
a0d0e21e
LW		 5267 register char **elem;
5268 register SV *sv;
5269 struct group *grent;
2d8e6c8d 5270 STRLEN n_a;
a0d0e21e
LW		 5271
5272 if (which == OP_GGRNAM)
42e0c139 5273 grent = (struct group *)getgrnam(POPpbytex);
a0d0e21e
LW		 5274 else if (which == OP_GGRGID)
5275 grent = (struct group *)getgrgid(POPi);
5276 else
0994c4d0 5277#ifdef HAS_GETGRENT
a0d0e21e 5278 grent = (struct group *)getgrent();
0994c4d0
JH		 5279#else
5280 DIE(aTHX_ PL_no_func, "getgrent");
5281#endif
a0d0e21e
LW		 5282
5283 EXTEND(SP, 4);
5284 if (GIMME != G_ARRAY) {
5285 PUSHs(sv = sv_newmortal());
5286 if (grent) {
5287 if (which == OP_GGRNAM)
1e422769 5288 sv_setiv(sv, (IV)grent->gr_gid);
a0d0e21e
LW		 5289 else
5290 sv_setpv(sv, grent->gr_name);
5291 }
5292 RETURN;
5293 }
5294
5295 if (grent) {
3280af22 5296 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 5297 sv_setpv(sv, grent->gr_name);
28e8609d 5298
3280af22 5299 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
28e8609d 5300#ifdef GRPASSWD
a0d0e21e 5301 sv_setpv(sv, grent->gr_passwd);
28e8609d
JH		 5302#endif
5303
3280af22 5304 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 5305 sv_setiv(sv, (IV)grent->gr_gid);
28e8609d 5306
3280af22 5307 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 5308 for (elem = grent->gr_mem; elem && *elem; elem++) {
a0d0e21e
LW		 5309 sv_catpv(sv, *elem);
5310 if (elem[1])
5311 sv_catpvn(sv, " ", 1);
5312 }
5313 }
5314
5315 RETURN;
5316#else
cea2e8a9 5317 DIE(aTHX_ PL_no_func, "getgrent");
a0d0e21e
LW		 5318#endif
5319}
5320
5321PP(pp_sgrent)
5322{
39644a26 5323 dSP;
28e8609d 5324#if defined(HAS_GROUP) && defined(HAS_SETGRENT)
a0d0e21e
LW		 5325 setgrent();
5326 RETPUSHYES;
5327#else
cea2e8a9 5328 DIE(aTHX_ PL_no_func, "setgrent");
a0d0e21e
LW		 5329#endif
5330}
5331
5332PP(pp_egrent)
5333{
39644a26 5334 dSP;
28e8609d 5335#if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
a0d0e21e
LW		 5336 endgrent();
5337 RETPUSHYES;
5338#else
cea2e8a9 5339 DIE(aTHX_ PL_no_func, "endgrent");
a0d0e21e
LW		 5340#endif
5341}
5342
5343PP(pp_getlogin)
5344{
39644a26 5345 dSP; dTARGET;
a0d0e21e
LW		 5346#ifdef HAS_GETLOGIN
5347 char *tmps;
5348 EXTEND(SP, 1);
76e3520e 5349 if (!(tmps = PerlProc_getlogin()))
a0d0e21e
LW		 5350 RETPUSHUNDEF;
5351 PUSHp(tmps, strlen(tmps));
5352 RETURN;
5353#else
cea2e8a9 5354 DIE(aTHX_ PL_no_func, "getlogin");
a0d0e21e
LW		 5355#endif
5356}
5357
5358/* Miscellaneous. */
5359
5360PP(pp_syscall)
5361{
d2719217 5362#ifdef HAS_SYSCALL
39644a26 5363 dSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 5364 register I32 items = SP - MARK;
5365 unsigned long a[20];
5366 register I32 i = 0;
5367 I32 retval = -1;
2d8e6c8d 5368 STRLEN n_a;
a0d0e21e 5369
3280af22 5370 if (PL_tainting) {
a0d0e21e 5371 while (++MARK <= SP) {
bbce6d69 5372 if (SvTAINTED(*MARK)) {
5373 TAINT;
5374 break;
5375 }
a0d0e21e
LW		 5376 }
5377 MARK = ORIGMARK;
5378 TAINT_PROPER("syscall");
5379 }
5380
5381 /* This probably won't work on machines where sizeof(long) != sizeof(int)
5382 * or where sizeof(long) != sizeof(char*). But such machines will
5383 * not likely have syscall implemented either, so who cares?
5384 */
5385 while (++MARK <= SP) {
5386 if (SvNIOK(*MARK) || !i)
5387 a[i++] = SvIV(*MARK);
3280af22 5388 else if (*MARK == &PL_sv_undef)
748a9306 5389 a[i++] = 0;
301e8125 5390 else
2d8e6c8d 5391 a[i++] = (unsigned long)SvPV_force(*MARK, n_a);
a0d0e21e
LW		 5392 if (i > 15)
5393 break;
5394 }
5395 switch (items) {
5396 default:
cea2e8a9 5397 DIE(aTHX_ "Too many args to syscall");
a0d0e21e 5398 case 0:
cea2e8a9 5399 DIE(aTHX_ "Too few args to syscall");
a0d0e21e
LW		 5400 case 1:
5401 retval = syscall(a[0]);
5402 break;
5403 case 2:
5404 retval = syscall(a[0],a[1]);
5405 break;
5406 case 3:
5407 retval = syscall(a[0],a[1],a[2]);
5408 break;
5409 case 4:
5410 retval = syscall(a[0],a[1],a[2],a[3]);
5411 break;
5412 case 5:
5413 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5414 break;
5415 case 6:
5416 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5417 break;
5418 case 7:
5419 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5420 break;
5421 case 8:
5422 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5423 break;
5424#ifdef atarist
5425 case 9:
5426 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5427 break;
5428 case 10:
5429 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5430 break;
5431 case 11:
5432 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5433 a[10]);
5434 break;
5435 case 12:
5436 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5437 a[10],a[11]);
5438 break;
5439 case 13:
5440 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5441 a[10],a[11],a[12]);
5442 break;
5443 case 14:
5444 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5445 a[10],a[11],a[12],a[13]);
5446 break;
5447#endif /* atarist */
5448 }
5449 SP = ORIGMARK;
5450 PUSHi(retval);
5451 RETURN;
5452#else
cea2e8a9 5453 DIE(aTHX_ PL_no_func, "syscall");
a0d0e21e
LW		 5454#endif
5455}
5456
ff68c719 5457#ifdef FCNTL_EMULATE_FLOCK
301e8125 5458
ff68c719 5459/* XXX Emulate flock() with fcntl().
5460 What's really needed is a good file locking module.
5461*/
5462
cea2e8a9
GS		 5463static int
5464fcntl_emulate_flock(int fd, int operation)
ff68c719 5465{
5466 struct flock flock;
301e8125 5467
ff68c719 5468 switch (operation & ~LOCK_NB) {
5469 case LOCK_SH:
5470 flock.l_type = F_RDLCK;
5471 break;
5472 case LOCK_EX:
5473 flock.l_type = F_WRLCK;
5474 break;
5475 case LOCK_UN:
5476 flock.l_type = F_UNLCK;
5477 break;
5478 default:
5479 errno = EINVAL;
5480 return -1;
5481 }
5482 flock.l_whence = SEEK_SET;
d9b3e12d 5483 flock.l_start = flock.l_len = (Off_t)0;
301e8125 5484
ff68c719 5485 return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5486}
5487
5488#endif /* FCNTL_EMULATE_FLOCK */
5489
5490#ifdef LOCKF_EMULATE_FLOCK
16d20bd9
AD		 5491
5492/* XXX Emulate flock() with lockf(). This is just to increase
5493 portability of scripts. The calls are not completely
5494 interchangeable. What's really needed is a good file
5495 locking module.
5496*/
5497
76c32331 5498/* The lockf() constants might have been defined in <unistd.h>.
5499 Unfortunately, <unistd.h> causes troubles on some mixed
5500 (BSD/POSIX) systems, such as SunOS 4.1.3.
16d20bd9
AD		 5501
5502 Further, the lockf() constants aren't POSIX, so they might not be
5503 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5504 just stick in the SVID values and be done with it. Sigh.
5505*/
5506
5507# ifndef F_ULOCK
5508# define F_ULOCK 0 /* Unlock a previously locked region */
5509# endif
5510# ifndef F_LOCK
5511# define F_LOCK 1 /* Lock a region for exclusive use */
5512# endif
5513# ifndef F_TLOCK
5514# define F_TLOCK 2 /* Test and lock a region for exclusive use */
5515# endif
5516# ifndef F_TEST
5517# define F_TEST 3 /* Test a region for other processes locks */
5518# endif
5519
cea2e8a9
GS		 5520static int
5521lockf_emulate_flock(int fd, int operation)
16d20bd9
AD		 5522{
5523 int i;
84902520
TB		 5524 int save_errno;
5525 Off_t pos;
5526
5527 /* flock locks entire file so for lockf we need to do the same */
5528 save_errno = errno;
6ad3d225 5529 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
84902520 5530 if (pos > 0) /* is seekable and needs to be repositioned */
6ad3d225 5531 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
08b714dd 5532 pos = -1; /* seek failed, so don't seek back afterwards */
84902520
TB		 5533 errno = save_errno;
5534
16d20bd9
AD		 5535 switch (operation) {
5536
5537 /* LOCK_SH - get a shared lock */
5538 case LOCK_SH:
5539 /* LOCK_EX - get an exclusive lock */
5540 case LOCK_EX:
5541 i = lockf (fd, F_LOCK, 0);
5542 break;
5543
5544 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5545 case LOCK_SH|LOCK_NB:
5546 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5547 case LOCK_EX|LOCK_NB:
5548 i = lockf (fd, F_TLOCK, 0);
5549 if (i == -1)
5550 if ((errno == EAGAIN) || (errno == EACCES))
5551 errno = EWOULDBLOCK;
5552 break;
5553
ff68c719 5554 /* LOCK_UN - unlock (non-blocking is a no-op) */
16d20bd9 5555 case LOCK_UN:
ff68c719 5556 case LOCK_UN|LOCK_NB:
16d20bd9
AD		 5557 i = lockf (fd, F_ULOCK, 0);
5558 break;
5559
5560 /* Default - can't decipher operation */
5561 default:
5562 i = -1;
5563 errno = EINVAL;
5564 break;
5565 }
84902520
TB		 5566
5567 if (pos > 0) /* need to restore position of the handle */
6ad3d225 5568 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
84902520 5569
16d20bd9
AD		 5570 return (i);
5571}
ff68c719 5572
5573#endif /* LOCKF_EMULATE_FLOCK */
Unnamed repository; edit this file 'description' to name the repository.