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