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