This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Integrate with Sarathy.
[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) {
3280af22 1073 gv_efullname3(TARG, PL_defoutgv, Nullch);
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();
aac0dd9a 1179 gv_efullname3(tmpsv, fgv, Nullch);
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();
aac0dd9a 1260 gv_efullname3(tmpsv, fgv, Nullch);
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();
1278 gv_efullname3(sv, gv, Nullch);
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)) {
af8c498a
GS		 1348 gv_efullname3(sv, gv, Nullch);
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
CB		 1357 if (IoIFP(io)) {
1358 gv_efullname3(sv, gv, Nullch);
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();
1554 gv_efullname3(sv, gv, Nullch);
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;
cea2e8a9 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;
b4bcd662 3752#if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) && !defined(__CYGWIN__)
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]);
ff68c719 3771 rsignal_save(SIGINT, SIG_IGN, &ihand);
3772 rsignal_save(SIGQUIT, SIG_IGN, &qhand);
748a9306
LW		 3773 do {
3774 result = wait4pid(childpid, &status, 0);
3775 } while (result == -1 && errno == EINTR);
ff68c719 3776 (void)rsignal_restore(SIGINT, &ihand);
3777 (void)rsignal_restore(SIGQUIT, &qhand);
91e9c03f 3778 STATUS_NATIVE_SET(result == -1 ? -1 : status);
a0d0e21e
LW		 3779 do_execfree(); /* free any memory child malloced on vfork */
3780 SP = ORIGMARK;
d5a9bfb0
IZ		 3781 if (did_pipes) {
3782 int errkid;
3783 int n = 0, n1;
3784
3785 while (n < sizeof(int)) {
3786 n1 = PerlLIO_read(pp[0],
3787 (void*)(((char*)&errkid)+n),
3788 (sizeof(int)) - n);
3789 if (n1 <= 0)
3790 break;
3791 n += n1;
3792 }
3793 PerlLIO_close(pp[0]);
3794 if (n) { /* Error */
3795 if (n != sizeof(int))
c529f79d 3796 DIE(aTHX_ "panic: kid popen errno read");
d5a9bfb0
IZ		 3797 errno = errkid; /* Propagate errno from kid */
3798 STATUS_CURRENT = -1;
3799 }
3800 }
ff0cee69 3801 PUSHi(STATUS_CURRENT);
a0d0e21e
LW		 3802 RETURN;
3803 }
d5a9bfb0
IZ		 3804 if (did_pipes) {
3805 PerlLIO_close(pp[0]);
3806#if defined(HAS_FCNTL) && defined(F_SETFD)
3807 fcntl(pp[1], F_SETFD, FD_CLOEXEC);
3808#endif
3809 }
533c011a 3810 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e 3811 SV *really = *++MARK;
d5a9bfb0 3812 value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes);
a0d0e21e
LW		 3813 }
3814 else if (SP - MARK != 1)
d5a9bfb0 3815 value = (I32)do_aexec5(Nullsv, MARK, SP, pp[1], did_pipes);
a0d0e21e 3816 else {
d5a9bfb0 3817 value = (I32)do_exec3(SvPVx(sv_mortalcopy(*SP), n_a), pp[1], did_pipes);
a0d0e21e 3818 }
6ad3d225 3819 PerlProc__exit(-1);
c3293030 3820#else /* ! FORK or VMS or OS/2 */
911d147d 3821 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e 3822 SV *really = *++MARK;
c5be433b 3823 value = (I32)do_aspawn(really, (void **)MARK, (void **)SP);
a0d0e21e
LW		 3824 }
3825 else if (SP - MARK != 1)
c5be433b 3826 value = (I32)do_aspawn(Nullsv, (void **)MARK, (void **)SP);
a0d0e21e 3827 else {
c5be433b 3828 value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
a0d0e21e 3829 }
f86702cc 3830 STATUS_NATIVE_SET(value);
a0d0e21e
LW		 3831 do_execfree();
3832 SP = ORIGMARK;
ff0cee69 3833 PUSHi(STATUS_CURRENT);
a0d0e21e
LW		 3834#endif /* !FORK or VMS */
3835 RETURN;
3836}
3837
3838PP(pp_exec)
3839{
4e35701f 3840 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e 3841 I32 value;
2d8e6c8d 3842 STRLEN n_a;
a0d0e21e 3843
45bc9206 3844 PERL_FLUSHALL_FOR_CHILD;
533c011a 3845 if (PL_op->op_flags & OPf_STACKED) {
a0d0e21e
LW		 3846 SV *really = *++MARK;
3847 value = (I32)do_aexec(really, MARK, SP);
3848 }
3849 else if (SP - MARK != 1)
3850#ifdef VMS
3851 value = (I32)vms_do_aexec(Nullsv, MARK, SP);
3852#else
092bebab
JH		 3853# ifdef __OPEN_VM
3854 {
c5be433b 3855 (void ) do_aspawn(Nullsv, MARK, SP);
092bebab
JH		 3856 value = 0;
3857 }
3858# else
a0d0e21e 3859 value = (I32)do_aexec(Nullsv, MARK, SP);
092bebab 3860# endif
a0d0e21e
LW		 3861#endif
3862 else {
3280af22 3863 if (PL_tainting) {
2d8e6c8d 3864 char *junk = SvPV(*SP, n_a);
a0d0e21e
LW		 3865 TAINT_ENV();
3866 TAINT_PROPER("exec");
3867 }
3868#ifdef VMS
2d8e6c8d 3869 value = (I32)vms_do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
a0d0e21e 3870#else
092bebab 3871# ifdef __OPEN_VM
c5be433b 3872 (void) do_spawn(SvPVx(sv_mortalcopy(*SP), n_a));
092bebab
JH		 3873 value = 0;
3874# else
2d8e6c8d 3875 value = (I32)do_exec(SvPVx(sv_mortalcopy(*SP), n_a));
092bebab 3876# endif
a0d0e21e
LW		 3877#endif
3878 }
146174a9
CB		 3879
3880#if !defined(HAS_FORK) && defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
3881 if (value >= 0)
3882 my_exit(value);
3883#endif
3884
a0d0e21e
LW		 3885 SP = ORIGMARK;
3886 PUSHi(value);
3887 RETURN;
3888}
3889
3890PP(pp_kill)
3891{
4e35701f 3892 djSP; dMARK; dTARGET;
a0d0e21e
LW		 3893 I32 value;
3894#ifdef HAS_KILL
533c011a 3895 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 3896 SP = MARK;
3897 PUSHi(value);
3898 RETURN;
3899#else
cea2e8a9 3900 DIE(aTHX_ PL_no_func, "Unsupported function kill");
a0d0e21e
LW		 3901#endif
3902}
3903
3904PP(pp_getppid)
3905{
3906#ifdef HAS_GETPPID
4e35701f 3907 djSP; dTARGET;
a0d0e21e
LW		 3908 XPUSHi( getppid() );
3909 RETURN;
3910#else
cea2e8a9 3911 DIE(aTHX_ PL_no_func, "getppid");
a0d0e21e
LW		 3912#endif
3913}
3914
3915PP(pp_getpgrp)
3916{
3917#ifdef HAS_GETPGRP
4e35701f 3918 djSP; dTARGET;
d8a83dd3 3919 Pid_t pid;
9853a804 3920 Pid_t pgrp;
a0d0e21e
LW		 3921
3922 if (MAXARG < 1)
3923 pid = 0;
3924 else
3925 pid = SvIVx(POPs);
c3293030 3926#ifdef BSD_GETPGRP
9853a804 3927 pgrp = (I32)BSD_GETPGRP(pid);
a0d0e21e 3928#else
146174a9 3929 if (pid != 0 && pid != PerlProc_getpid())
cea2e8a9 3930 DIE(aTHX_ "POSIX getpgrp can't take an argument");
9853a804 3931 pgrp = getpgrp();
a0d0e21e 3932#endif
9853a804 3933 XPUSHi(pgrp);
a0d0e21e
LW		 3934 RETURN;
3935#else
cea2e8a9 3936 DIE(aTHX_ PL_no_func, "getpgrp()");
a0d0e21e
LW		 3937#endif
3938}
3939
3940PP(pp_setpgrp)
3941{
3942#ifdef HAS_SETPGRP
4e35701f 3943 djSP; dTARGET;
d8a83dd3
JH		 3944 Pid_t pgrp;
3945 Pid_t pid;
a0d0e21e
LW		 3946 if (MAXARG < 2) {
3947 pgrp = 0;
3948 pid = 0;
3949 }
3950 else {
3951 pgrp = POPi;
3952 pid = TOPi;
3953 }
3954
3955 TAINT_PROPER("setpgrp");
c3293030
IZ		 3956#ifdef BSD_SETPGRP
3957 SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
a0d0e21e 3958#else
146174a9
CB		 3959 if ((pgrp != 0 && pgrp != PerlProc_getpid())
3960 || (pid != 0 && pid != PerlProc_getpid()))
3961 {
3962 DIE(aTHX_ "setpgrp can't take arguments");
3963 }
a0d0e21e
LW		 3964 SETi( setpgrp() >= 0 );
3965#endif /* USE_BSDPGRP */
3966 RETURN;
3967#else
cea2e8a9 3968 DIE(aTHX_ PL_no_func, "setpgrp()");
a0d0e21e
LW		 3969#endif
3970}
3971
3972PP(pp_getpriority)
3973{
4e35701f 3974 djSP; dTARGET;
a0d0e21e
LW		 3975 int which;
3976 int who;
3977#ifdef HAS_GETPRIORITY
3978 who = POPi;
3979 which = TOPi;
3980 SETi( getpriority(which, who) );
3981 RETURN;
3982#else
cea2e8a9 3983 DIE(aTHX_ PL_no_func, "getpriority()");
a0d0e21e
LW		 3984#endif
3985}
3986
3987PP(pp_setpriority)
3988{
4e35701f 3989 djSP; dTARGET;
a0d0e21e
LW		 3990 int which;
3991 int who;
3992 int niceval;
3993#ifdef HAS_SETPRIORITY
3994 niceval = POPi;
3995 who = POPi;
3996 which = TOPi;
3997 TAINT_PROPER("setpriority");
3998 SETi( setpriority(which, who, niceval) >= 0 );
3999 RETURN;
4000#else
cea2e8a9 4001 DIE(aTHX_ PL_no_func, "setpriority()");
a0d0e21e
LW		 4002#endif
4003}
4004
4005/* Time calls. */
4006
4007PP(pp_time)
4008{
4e35701f 4009 djSP; dTARGET;
cbdc8872 4010#ifdef BIG_TIME
4011 XPUSHn( time(Null(Time_t*)) );
4012#else
a0d0e21e 4013 XPUSHi( time(Null(Time_t*)) );
cbdc8872 4014#endif
a0d0e21e
LW		 4015 RETURN;
4016}
4017
cd52b7b2 4018/* XXX The POSIX name is CLK_TCK; it is to be preferred
4019 to HZ. Probably. For now, assume that if the system
4020 defines HZ, it does so correctly. (Will this break
4021 on VMS?)
4022 Probably we ought to use _sysconf(_SC_CLK_TCK), if
4023 it's supported. --AD 9/96.
4024*/
4025
a0d0e21e 4026#ifndef HZ
cd52b7b2 4027# ifdef CLK_TCK
4028# define HZ CLK_TCK
4029# else
4030# define HZ 60
4031# endif
a0d0e21e
LW		 4032#endif
4033
4034PP(pp_tms)
4035{
4e35701f 4036 djSP;
a0d0e21e 4037
55497cff 4038#ifndef HAS_TIMES
cea2e8a9 4039 DIE(aTHX_ "times not implemented");
a0d0e21e
LW		 4040#else
4041 EXTEND(SP, 4);
4042
4043#ifndef VMS
3280af22 4044 (void)PerlProc_times(&PL_timesbuf);
a0d0e21e 4045#else
6b88bc9c 4046 (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */
76e3520e
GS		 4047 /* struct tms, though same data */
4048 /* is returned. */
a0d0e21e
LW		 4049#endif
4050
65202027 4051 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_utime)/HZ)));
a0d0e21e 4052 if (GIMME == G_ARRAY) {
65202027
DS		 4053 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_stime)/HZ)));
4054 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cutime)/HZ)));
4055 PUSHs(sv_2mortal(newSVnv(((NV)PL_timesbuf.tms_cstime)/HZ)));
a0d0e21e
LW		 4056 }
4057 RETURN;
55497cff 4058#endif /* HAS_TIMES */
a0d0e21e
LW		 4059}
4060
4061PP(pp_localtime)
4062{
cea2e8a9 4063 return pp_gmtime();
a0d0e21e
LW		 4064}
4065
4066PP(pp_gmtime)
4067{
4e35701f 4068 djSP;
a0d0e21e
LW		 4069 Time_t when;
4070 struct tm *tmbuf;
4071 static char *dayname[] = {"Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"};
4072 static char *monname[] = {"Jan", "Feb", "Mar", "Apr", "May", "Jun",
4073 "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"};
4074
4075 if (MAXARG < 1)
4076 (void)time(&when);
4077 else
cbdc8872 4078#ifdef BIG_TIME
4079 when = (Time_t)SvNVx(POPs);
4080#else
a0d0e21e 4081 when = (Time_t)SvIVx(POPs);
cbdc8872 4082#endif
a0d0e21e 4083
533c011a 4084 if (PL_op->op_type == OP_LOCALTIME)
a0d0e21e
LW		 4085 tmbuf = localtime(&when);
4086 else
4087 tmbuf = gmtime(&when);
4088
4089 EXTEND(SP, 9);
bbce6d69 4090 EXTEND_MORTAL(9);
a0d0e21e 4091 if (GIMME != G_ARRAY) {
46fc3d4c 4092 SV *tsv;
a0d0e21e
LW		 4093 if (!tmbuf)
4094 RETPUSHUNDEF;
be28567c 4095 tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %d",
f5a29b03
RB		 4096 dayname[tmbuf->tm_wday],
4097 monname[tmbuf->tm_mon],
be28567c
GS		 4098 tmbuf->tm_mday,
4099 tmbuf->tm_hour,
4100 tmbuf->tm_min,
4101 tmbuf->tm_sec,
4102 tmbuf->tm_year + 1900);
46fc3d4c 4103 PUSHs(sv_2mortal(tsv));
a0d0e21e
LW		 4104 }
4105 else if (tmbuf) {
c6419e06
JH		 4106 PUSHs(sv_2mortal(newSViv(tmbuf->tm_sec)));
4107 PUSHs(sv_2mortal(newSViv(tmbuf->tm_min)));
4108 PUSHs(sv_2mortal(newSViv(tmbuf->tm_hour)));
4109 PUSHs(sv_2mortal(newSViv(tmbuf->tm_mday)));
4110 PUSHs(sv_2mortal(newSViv(tmbuf->tm_mon)));
4111 PUSHs(sv_2mortal(newSViv(tmbuf->tm_year)));
4112 PUSHs(sv_2mortal(newSViv(tmbuf->tm_wday)));
4113 PUSHs(sv_2mortal(newSViv(tmbuf->tm_yday)));
4114 PUSHs(sv_2mortal(newSViv(tmbuf->tm_isdst)));
a0d0e21e
LW		 4115 }
4116 RETURN;
4117}
4118
4119PP(pp_alarm)
4120{
4e35701f 4121 djSP; dTARGET;
a0d0e21e
LW		 4122 int anum;
4123#ifdef HAS_ALARM
4124 anum = POPi;
4125 anum = alarm((unsigned int)anum);
4126 EXTEND(SP, 1);
4127 if (anum < 0)
4128 RETPUSHUNDEF;
c6419e06 4129 PUSHi(anum);
a0d0e21e
LW		 4130 RETURN;
4131#else
cea2e8a9 4132 DIE(aTHX_ PL_no_func, "Unsupported function alarm");
a0d0e21e
LW		 4133#endif
4134}
4135
4136PP(pp_sleep)
4137{
4e35701f 4138 djSP; dTARGET;
a0d0e21e
LW		 4139 I32 duration;
4140 Time_t lasttime;
4141 Time_t when;
4142
4143 (void)time(&lasttime);
4144 if (MAXARG < 1)
76e3520e 4145 PerlProc_pause();
a0d0e21e
LW		 4146 else {
4147 duration = POPi;
76e3520e 4148 PerlProc_sleep((unsigned int)duration);
a0d0e21e
LW		 4149 }
4150 (void)time(&when);
4151 XPUSHi(when - lasttime);
4152 RETURN;
4153}
4154
4155/* Shared memory. */
4156
4157PP(pp_shmget)
4158{
cea2e8a9 4159 return pp_semget();
a0d0e21e
LW		 4160}
4161
4162PP(pp_shmctl)
4163{
cea2e8a9 4164 return pp_semctl();
a0d0e21e
LW		 4165}
4166
4167PP(pp_shmread)
4168{
cea2e8a9 4169 return pp_shmwrite();
a0d0e21e
LW		 4170}
4171
4172PP(pp_shmwrite)
4173{
4174#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 4175 djSP; dMARK; dTARGET;
533c011a 4176 I32 value = (I32)(do_shmio(PL_op->op_type, MARK, SP) >= 0);
a0d0e21e
LW		 4177 SP = MARK;
4178 PUSHi(value);
4179 RETURN;
4180#else
cea2e8a9 4181 return pp_semget();
a0d0e21e
LW		 4182#endif
4183}
4184
4185/* Message passing. */
4186
4187PP(pp_msgget)
4188{
cea2e8a9 4189 return pp_semget();
a0d0e21e
LW		 4190}
4191
4192PP(pp_msgctl)
4193{
cea2e8a9 4194 return pp_semctl();
a0d0e21e
LW		 4195}
4196
4197PP(pp_msgsnd)
4198{
4199#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 4200 djSP; dMARK; dTARGET;
a0d0e21e
LW		 4201 I32 value = (I32)(do_msgsnd(MARK, SP) >= 0);
4202 SP = MARK;
4203 PUSHi(value);
4204 RETURN;
4205#else
cea2e8a9 4206 return pp_semget();
a0d0e21e
LW		 4207#endif
4208}
4209
4210PP(pp_msgrcv)
4211{
4212#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 4213 djSP; dMARK; dTARGET;
a0d0e21e
LW		 4214 I32 value = (I32)(do_msgrcv(MARK, SP) >= 0);
4215 SP = MARK;
4216 PUSHi(value);
4217 RETURN;
4218#else
cea2e8a9 4219 return pp_semget();
a0d0e21e
LW		 4220#endif
4221}
4222
4223/* Semaphores. */
4224
4225PP(pp_semget)
4226{
4227#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 4228 djSP; dMARK; dTARGET;
533c011a 4229 int anum = do_ipcget(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 4230 SP = MARK;
4231 if (anum == -1)
4232 RETPUSHUNDEF;
4233 PUSHi(anum);
4234 RETURN;
4235#else
cea2e8a9 4236 DIE(aTHX_ "System V IPC is not implemented on this machine");
a0d0e21e
LW		 4237#endif
4238}
4239
4240PP(pp_semctl)
4241{
4242#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 4243 djSP; dMARK; dTARGET;
533c011a 4244 int anum = do_ipcctl(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 4245 SP = MARK;
4246 if (anum == -1)
4247 RETSETUNDEF;
4248 if (anum != 0) {
4249 PUSHi(anum);
4250 }
4251 else {
8903cb82 4252 PUSHp(zero_but_true, ZBTLEN);
a0d0e21e
LW		 4253 }
4254 RETURN;
4255#else
cea2e8a9 4256 return pp_semget();
a0d0e21e
LW		 4257#endif
4258}
4259
4260PP(pp_semop)
4261{
4262#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
4e35701f 4263 djSP; dMARK; dTARGET;
a0d0e21e
LW		 4264 I32 value = (I32)(do_semop(MARK, SP) >= 0);
4265 SP = MARK;
4266 PUSHi(value);
4267 RETURN;
4268#else
cea2e8a9 4269 return pp_semget();
a0d0e21e
LW		 4270#endif
4271}
4272
4273/* Get system info. */
4274
4275PP(pp_ghbyname)
4276{
693762b4 4277#ifdef HAS_GETHOSTBYNAME
cea2e8a9 4278 return pp_ghostent();
a0d0e21e 4279#else
cea2e8a9 4280 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
a0d0e21e
LW		 4281#endif
4282}
4283
4284PP(pp_ghbyaddr)
4285{
693762b4 4286#ifdef HAS_GETHOSTBYADDR
cea2e8a9 4287 return pp_ghostent();
a0d0e21e 4288#else
cea2e8a9 4289 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
a0d0e21e
LW		 4290#endif
4291}
4292
4293PP(pp_ghostent)
4294{
4e35701f 4295 djSP;
693762b4 4296#if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT)
533c011a 4297 I32 which = PL_op->op_type;
a0d0e21e
LW		 4298 register char **elem;
4299 register SV *sv;
dc45a647 4300#ifndef HAS_GETHOST_PROTOS /* XXX Do we need individual probes? */
4599a1de
JH		 4301 struct hostent *PerlSock_gethostbyaddr(Netdb_host_t, Netdb_hlen_t, int);
4302 struct hostent *PerlSock_gethostbyname(Netdb_name_t);
6ad3d225 4303 struct hostent *PerlSock_gethostent(void);
a0d0e21e
LW		 4304#endif
4305 struct hostent *hent;
4306 unsigned long len;
2d8e6c8d 4307 STRLEN n_a;
a0d0e21e
LW		 4308
4309 EXTEND(SP, 10);
dc45a647
MB		 4310 if (which == OP_GHBYNAME)
4311#ifdef HAS_GETHOSTBYNAME
2d8e6c8d 4312 hent = PerlSock_gethostbyname(POPpx);
dc45a647 4313#else
cea2e8a9 4314 DIE(aTHX_ PL_no_sock_func, "gethostbyname");
dc45a647 4315#endif
a0d0e21e 4316 else if (which == OP_GHBYADDR) {
dc45a647 4317#ifdef HAS_GETHOSTBYADDR
a0d0e21e 4318 int addrtype = POPi;
748a9306 4319 SV *addrsv = POPs;
a0d0e21e 4320 STRLEN addrlen;
4599a1de 4321 Netdb_host_t addr = (Netdb_host_t) SvPV(addrsv, addrlen);
a0d0e21e 4322
4599a1de 4323 hent = PerlSock_gethostbyaddr(addr, (Netdb_hlen_t) addrlen, addrtype);
dc45a647 4324#else
cea2e8a9 4325 DIE(aTHX_ PL_no_sock_func, "gethostbyaddr");
dc45a647 4326#endif
a0d0e21e
LW		 4327 }
4328 else
4329#ifdef HAS_GETHOSTENT
6ad3d225 4330 hent = PerlSock_gethostent();
a0d0e21e 4331#else
cea2e8a9 4332 DIE(aTHX_ PL_no_sock_func, "gethostent");
a0d0e21e
LW		 4333#endif
4334
4335#ifdef HOST_NOT_FOUND
4336 if (!hent)
f86702cc 4337 STATUS_NATIVE_SET(h_errno);
a0d0e21e
LW		 4338#endif
4339
4340 if (GIMME != G_ARRAY) {
4341 PUSHs(sv = sv_newmortal());
4342 if (hent) {
4343 if (which == OP_GHBYNAME) {
fd0af264 4344 if (hent->h_addr)
4345 sv_setpvn(sv, hent->h_addr, hent->h_length);
a0d0e21e
LW		 4346 }
4347 else
4348 sv_setpv(sv, (char*)hent->h_name);
4349 }
4350 RETURN;
4351 }
4352
4353 if (hent) {
3280af22 4354 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4355 sv_setpv(sv, (char*)hent->h_name);
3280af22 4356 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 4357 for (elem = hent->h_aliases; elem && *elem; elem++) {
4358 sv_catpv(sv, *elem);
4359 if (elem[1])
4360 sv_catpvn(sv, " ", 1);
4361 }
3280af22 4362 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4363 sv_setiv(sv, (IV)hent->h_addrtype);
3280af22 4364 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4365 len = hent->h_length;
1e422769 4366 sv_setiv(sv, (IV)len);
a0d0e21e
LW		 4367#ifdef h_addr
4368 for (elem = hent->h_addr_list; elem && *elem; elem++) {
3280af22 4369 XPUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 4370 sv_setpvn(sv, *elem, len);
4371 }
4372#else
6b88bc9c 4373 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
fd0af264 4374 if (hent->h_addr)
4375 sv_setpvn(sv, hent->h_addr, len);
a0d0e21e
LW		 4376#endif /* h_addr */
4377 }
4378 RETURN;
4379#else
cea2e8a9 4380 DIE(aTHX_ PL_no_sock_func, "gethostent");
a0d0e21e
LW		 4381#endif
4382}
4383
4384PP(pp_gnbyname)
4385{
693762b4 4386#ifdef HAS_GETNETBYNAME
cea2e8a9 4387 return pp_gnetent();
a0d0e21e 4388#else
cea2e8a9 4389 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
a0d0e21e
LW		 4390#endif
4391}
4392
4393PP(pp_gnbyaddr)
4394{
693762b4 4395#ifdef HAS_GETNETBYADDR
cea2e8a9 4396 return pp_gnetent();
a0d0e21e 4397#else
cea2e8a9 4398 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
a0d0e21e
LW		 4399#endif
4400}
4401
4402PP(pp_gnetent)
4403{
4e35701f 4404 djSP;
693762b4 4405#if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT)
533c011a 4406 I32 which = PL_op->op_type;
a0d0e21e
LW		 4407 register char **elem;
4408 register SV *sv;
dc45a647
MB		 4409#ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */
4410 struct netent *PerlSock_getnetbyaddr(Netdb_net_t, int);
4411 struct netent *PerlSock_getnetbyname(Netdb_name_t);
4412 struct netent *PerlSock_getnetent(void);
8ac85365 4413#endif
a0d0e21e 4414 struct netent *nent;
2d8e6c8d 4415 STRLEN n_a;
a0d0e21e
LW		 4416
4417 if (which == OP_GNBYNAME)
dc45a647 4418#ifdef HAS_GETNETBYNAME
2d8e6c8d 4419 nent = PerlSock_getnetbyname(POPpx);
dc45a647 4420#else
cea2e8a9 4421 DIE(aTHX_ PL_no_sock_func, "getnetbyname");
dc45a647 4422#endif
a0d0e21e 4423 else if (which == OP_GNBYADDR) {
dc45a647 4424#ifdef HAS_GETNETBYADDR
a0d0e21e 4425 int addrtype = POPi;
4599a1de 4426 Netdb_net_t addr = (Netdb_net_t) U_L(POPn);
76e3520e 4427 nent = PerlSock_getnetbyaddr(addr, addrtype);
dc45a647 4428#else
cea2e8a9 4429 DIE(aTHX_ PL_no_sock_func, "getnetbyaddr");
dc45a647 4430#endif
a0d0e21e
LW		 4431 }
4432 else
dc45a647 4433#ifdef HAS_GETNETENT
76e3520e 4434 nent = PerlSock_getnetent();
dc45a647 4435#else
cea2e8a9 4436 DIE(aTHX_ PL_no_sock_func, "getnetent");
dc45a647 4437#endif
a0d0e21e
LW		 4438
4439 EXTEND(SP, 4);
4440 if (GIMME != G_ARRAY) {
4441 PUSHs(sv = sv_newmortal());
4442 if (nent) {
4443 if (which == OP_GNBYNAME)
1e422769 4444 sv_setiv(sv, (IV)nent->n_net);
a0d0e21e
LW		 4445 else
4446 sv_setpv(sv, nent->n_name);
4447 }
4448 RETURN;
4449 }
4450
4451 if (nent) {
3280af22 4452 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4453 sv_setpv(sv, nent->n_name);
3280af22 4454 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 4455 for (elem = nent->n_aliases; elem && *elem; elem++) {
a0d0e21e
LW		 4456 sv_catpv(sv, *elem);
4457 if (elem[1])
4458 sv_catpvn(sv, " ", 1);
4459 }
3280af22 4460 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4461 sv_setiv(sv, (IV)nent->n_addrtype);
3280af22 4462 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4463 sv_setiv(sv, (IV)nent->n_net);
a0d0e21e
LW		 4464 }
4465
4466 RETURN;
4467#else
cea2e8a9 4468 DIE(aTHX_ PL_no_sock_func, "getnetent");
a0d0e21e
LW		 4469#endif
4470}
4471
4472PP(pp_gpbyname)
4473{
693762b4 4474#ifdef HAS_GETPROTOBYNAME
cea2e8a9 4475 return pp_gprotoent();
a0d0e21e 4476#else
cea2e8a9 4477 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
a0d0e21e
LW		 4478#endif
4479}
4480
4481PP(pp_gpbynumber)
4482{
693762b4 4483#ifdef HAS_GETPROTOBYNUMBER
cea2e8a9 4484 return pp_gprotoent();
a0d0e21e 4485#else
cea2e8a9 4486 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
a0d0e21e
LW		 4487#endif
4488}
4489
4490PP(pp_gprotoent)
4491{
4e35701f 4492 djSP;
693762b4 4493#if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT)
533c011a 4494 I32 which = PL_op->op_type;
a0d0e21e 4495 register char **elem;
8ac85365 4496 register SV *sv;
dc45a647 4497#ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */
4599a1de 4498 struct protoent *PerlSock_getprotobyname(Netdb_name_t);
6ad3d225
GS		 4499 struct protoent *PerlSock_getprotobynumber(int);
4500 struct protoent *PerlSock_getprotoent(void);
8ac85365 4501#endif
a0d0e21e 4502 struct protoent *pent;
2d8e6c8d 4503 STRLEN n_a;
a0d0e21e
LW		 4504
4505 if (which == OP_GPBYNAME)
e5c9fcd0 4506#ifdef HAS_GETPROTOBYNAME
2d8e6c8d 4507 pent = PerlSock_getprotobyname(POPpx);
e5c9fcd0 4508#else
cea2e8a9 4509 DIE(aTHX_ PL_no_sock_func, "getprotobyname");
e5c9fcd0 4510#endif
a0d0e21e 4511 else if (which == OP_GPBYNUMBER)
e5c9fcd0 4512#ifdef HAS_GETPROTOBYNUMBER
6ad3d225 4513 pent = PerlSock_getprotobynumber(POPi);
e5c9fcd0 4514#else
cea2e8a9 4515 DIE(aTHX_ PL_no_sock_func, "getprotobynumber");
e5c9fcd0 4516#endif
a0d0e21e 4517 else
e5c9fcd0 4518#ifdef HAS_GETPROTOENT
6ad3d225 4519 pent = PerlSock_getprotoent();
e5c9fcd0 4520#else
cea2e8a9 4521 DIE(aTHX_ PL_no_sock_func, "getprotoent");
e5c9fcd0 4522#endif
a0d0e21e
LW		 4523
4524 EXTEND(SP, 3);
4525 if (GIMME != G_ARRAY) {
4526 PUSHs(sv = sv_newmortal());
4527 if (pent) {
4528 if (which == OP_GPBYNAME)
1e422769 4529 sv_setiv(sv, (IV)pent->p_proto);
a0d0e21e
LW		 4530 else
4531 sv_setpv(sv, pent->p_name);
4532 }
4533 RETURN;
4534 }
4535
4536 if (pent) {
3280af22 4537 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4538 sv_setpv(sv, pent->p_name);
3280af22 4539 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 4540 for (elem = pent->p_aliases; elem && *elem; elem++) {
a0d0e21e
LW		 4541 sv_catpv(sv, *elem);
4542 if (elem[1])
4543 sv_catpvn(sv, " ", 1);
4544 }
3280af22 4545 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4546 sv_setiv(sv, (IV)pent->p_proto);
a0d0e21e
LW		 4547 }
4548
4549 RETURN;
4550#else
cea2e8a9 4551 DIE(aTHX_ PL_no_sock_func, "getprotoent");
a0d0e21e
LW		 4552#endif
4553}
4554
4555PP(pp_gsbyname)
4556{
9ec75305 4557#ifdef HAS_GETSERVBYNAME
cea2e8a9 4558 return pp_gservent();
a0d0e21e 4559#else
cea2e8a9 4560 DIE(aTHX_ PL_no_sock_func, "getservbyname");
a0d0e21e
LW		 4561#endif
4562}
4563
4564PP(pp_gsbyport)
4565{
9ec75305 4566#ifdef HAS_GETSERVBYPORT
cea2e8a9 4567 return pp_gservent();
a0d0e21e 4568#else
cea2e8a9 4569 DIE(aTHX_ PL_no_sock_func, "getservbyport");
a0d0e21e
LW		 4570#endif
4571}
4572
4573PP(pp_gservent)
4574{
4e35701f 4575 djSP;
693762b4 4576#if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT)
533c011a 4577 I32 which = PL_op->op_type;
a0d0e21e
LW		 4578 register char **elem;
4579 register SV *sv;
dc45a647 4580#ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */
4599a1de
JH		 4581 struct servent *PerlSock_getservbyname(Netdb_name_t, Netdb_name_t);
4582 struct servent *PerlSock_getservbyport(int, Netdb_name_t);
6ad3d225 4583 struct servent *PerlSock_getservent(void);
8ac85365 4584#endif
a0d0e21e 4585 struct servent *sent;
2d8e6c8d 4586 STRLEN n_a;
a0d0e21e
LW		 4587
4588 if (which == OP_GSBYNAME) {
dc45a647 4589#ifdef HAS_GETSERVBYNAME
2d8e6c8d
GS		 4590 char *proto = POPpx;
4591 char *name = POPpx;
a0d0e21e
LW		 4592
4593 if (proto && !*proto)
4594 proto = Nullch;
4595
6ad3d225 4596 sent = PerlSock_getservbyname(name, proto);
dc45a647 4597#else
cea2e8a9 4598 DIE(aTHX_ PL_no_sock_func, "getservbyname");
dc45a647 4599#endif
a0d0e21e
LW		 4600 }
4601 else if (which == OP_GSBYPORT) {
dc45a647 4602#ifdef HAS_GETSERVBYPORT
2d8e6c8d 4603 char *proto = POPpx;
36477c24 4604 unsigned short port = POPu;
a0d0e21e 4605
36477c24 4606#ifdef HAS_HTONS
6ad3d225 4607 port = PerlSock_htons(port);
36477c24 4608#endif
6ad3d225 4609 sent = PerlSock_getservbyport(port, proto);
dc45a647 4610#else
cea2e8a9 4611 DIE(aTHX_ PL_no_sock_func, "getservbyport");
dc45a647 4612#endif
a0d0e21e
LW		 4613 }
4614 else
e5c9fcd0 4615#ifdef HAS_GETSERVENT
6ad3d225 4616 sent = PerlSock_getservent();
e5c9fcd0 4617#else
cea2e8a9 4618 DIE(aTHX_ PL_no_sock_func, "getservent");
e5c9fcd0 4619#endif
a0d0e21e
LW		 4620
4621 EXTEND(SP, 4);
4622 if (GIMME != G_ARRAY) {
4623 PUSHs(sv = sv_newmortal());
4624 if (sent) {
4625 if (which == OP_GSBYNAME) {
4626#ifdef HAS_NTOHS
6ad3d225 4627 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
a0d0e21e 4628#else
1e422769 4629 sv_setiv(sv, (IV)(sent->s_port));
a0d0e21e
LW		 4630#endif
4631 }
4632 else
4633 sv_setpv(sv, sent->s_name);
4634 }
4635 RETURN;
4636 }
4637
4638 if (sent) {
3280af22 4639 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4640 sv_setpv(sv, sent->s_name);
3280af22 4641 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 4642 for (elem = sent->s_aliases; elem && *elem; elem++) {
a0d0e21e
LW		 4643 sv_catpv(sv, *elem);
4644 if (elem[1])
4645 sv_catpvn(sv, " ", 1);
4646 }
3280af22 4647 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4648#ifdef HAS_NTOHS
76e3520e 4649 sv_setiv(sv, (IV)PerlSock_ntohs(sent->s_port));
a0d0e21e 4650#else
1e422769 4651 sv_setiv(sv, (IV)(sent->s_port));
a0d0e21e 4652#endif
3280af22 4653 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 4654 sv_setpv(sv, sent->s_proto);
4655 }
4656
4657 RETURN;
4658#else
cea2e8a9 4659 DIE(aTHX_ PL_no_sock_func, "getservent");
a0d0e21e
LW		 4660#endif
4661}
4662
4663PP(pp_shostent)
4664{
4e35701f 4665 djSP;
693762b4 4666#ifdef HAS_SETHOSTENT
76e3520e 4667 PerlSock_sethostent(TOPi);
a0d0e21e
LW		 4668 RETSETYES;
4669#else
cea2e8a9 4670 DIE(aTHX_ PL_no_sock_func, "sethostent");
a0d0e21e
LW		 4671#endif
4672}
4673
4674PP(pp_snetent)
4675{
4e35701f 4676 djSP;
693762b4 4677#ifdef HAS_SETNETENT
76e3520e 4678 PerlSock_setnetent(TOPi);
a0d0e21e
LW		 4679 RETSETYES;
4680#else
cea2e8a9 4681 DIE(aTHX_ PL_no_sock_func, "setnetent");
a0d0e21e
LW		 4682#endif
4683}
4684
4685PP(pp_sprotoent)
4686{
4e35701f 4687 djSP;
693762b4 4688#ifdef HAS_SETPROTOENT
76e3520e 4689 PerlSock_setprotoent(TOPi);
a0d0e21e
LW		 4690 RETSETYES;
4691#else
cea2e8a9 4692 DIE(aTHX_ PL_no_sock_func, "setprotoent");
a0d0e21e
LW		 4693#endif
4694}
4695
4696PP(pp_sservent)
4697{
4e35701f 4698 djSP;
693762b4 4699#ifdef HAS_SETSERVENT
76e3520e 4700 PerlSock_setservent(TOPi);
a0d0e21e
LW		 4701 RETSETYES;
4702#else
cea2e8a9 4703 DIE(aTHX_ PL_no_sock_func, "setservent");
a0d0e21e
LW		 4704#endif
4705}
4706
4707PP(pp_ehostent)
4708{
4e35701f 4709 djSP;
693762b4 4710#ifdef HAS_ENDHOSTENT
76e3520e 4711 PerlSock_endhostent();
924508f0 4712 EXTEND(SP,1);
a0d0e21e
LW		 4713 RETPUSHYES;
4714#else
cea2e8a9 4715 DIE(aTHX_ PL_no_sock_func, "endhostent");
a0d0e21e
LW		 4716#endif
4717}
4718
4719PP(pp_enetent)
4720{
4e35701f 4721 djSP;
693762b4 4722#ifdef HAS_ENDNETENT
76e3520e 4723 PerlSock_endnetent();
924508f0 4724 EXTEND(SP,1);
a0d0e21e
LW		 4725 RETPUSHYES;
4726#else
cea2e8a9 4727 DIE(aTHX_ PL_no_sock_func, "endnetent");
a0d0e21e
LW		 4728#endif
4729}
4730
4731PP(pp_eprotoent)
4732{
4e35701f 4733 djSP;
693762b4 4734#ifdef HAS_ENDPROTOENT
76e3520e 4735 PerlSock_endprotoent();
924508f0 4736 EXTEND(SP,1);
a0d0e21e
LW		 4737 RETPUSHYES;
4738#else
cea2e8a9 4739 DIE(aTHX_ PL_no_sock_func, "endprotoent");
a0d0e21e
LW		 4740#endif
4741}
4742
4743PP(pp_eservent)
4744{
4e35701f 4745 djSP;
693762b4 4746#ifdef HAS_ENDSERVENT
76e3520e 4747 PerlSock_endservent();
924508f0 4748 EXTEND(SP,1);
a0d0e21e
LW		 4749 RETPUSHYES;
4750#else
cea2e8a9 4751 DIE(aTHX_ PL_no_sock_func, "endservent");
a0d0e21e
LW		 4752#endif
4753}
4754
4755PP(pp_gpwnam)
4756{
4757#ifdef HAS_PASSWD
cea2e8a9 4758 return pp_gpwent();
a0d0e21e 4759#else
cea2e8a9 4760 DIE(aTHX_ PL_no_func, "getpwnam");
a0d0e21e
LW		 4761#endif
4762}
4763
4764PP(pp_gpwuid)
4765{
4766#ifdef HAS_PASSWD
cea2e8a9 4767 return pp_gpwent();
a0d0e21e 4768#else
cea2e8a9 4769 DIE(aTHX_ PL_no_func, "getpwuid");
a0d0e21e
LW		 4770#endif
4771}
4772
4773PP(pp_gpwent)
4774{
4e35701f 4775 djSP;
0994c4d0 4776#ifdef HAS_PASSWD
533c011a 4777 I32 which = PL_op->op_type;
a0d0e21e 4778 register SV *sv;
2d8e6c8d 4779 STRLEN n_a;
e3aefe8d 4780 struct passwd *pwent = NULL;
bcf53261
JH		 4781 /*
4782 * We currently support only the SysV getsp* shadow password interface.
4783 * The interface is declared in <shadow.h> and often one needs to link
4784 * with -lsecurity or some such.
4785 * This interface is used at least by Solaris, HP-UX, IRIX, and Linux.
4786 * (and SCO?)
4787 *
4788 * AIX getpwnam() is clever enough to return the encrypted password
4789 * only if the caller (euid?) is root.
4790 *
4791 * There are at least two other shadow password APIs. Many platforms
4792 * seem to contain more than one interface for accessing the shadow
4793 * password databases, possibly for compatibility reasons.
3813c136 4794 * The getsp*() is by far he simplest one, the other two interfaces
bcf53261
JH		 4795 * are much more complicated, but also very similar to each other.
4796 *
4797 * <sys/types.h>
4798 * <sys/security.h>
4799 * <prot.h>
4800 * struct pr_passwd *getprpw*();
4801 * The password is in
3813c136
JH		 4802 * char getprpw*(...).ufld.fd_encrypt[]
4803 * Mention HAS_GETPRPWNAM here so that Configure probes for it.
bcf53261
JH		 4804 *
4805 * <sys/types.h>
4806 * <sys/security.h>
4807 * <prot.h>
4808 * struct es_passwd *getespw*();
4809 * The password is in
4810 * char *(getespw*(...).ufld.fd_encrypt)
3813c136 4811 * Mention HAS_GETESPWNAM here so that Configure probes for it.
bcf53261 4812 *
3813c136 4813 * Mention I_PROT here so that Configure probes for it.
bcf53261
JH		 4814 *
4815 * In HP-UX for getprpw*() the manual page claims that one should include
4816 * <hpsecurity.h> instead of <sys/security.h>, but that is not needed
4817 * if one includes <shadow.h> as that includes <hpsecurity.h>,
4818 * and pp_sys.c already includes <shadow.h> if there is such.
3813c136
JH		 4819 *
4820 * Note that <sys/security.h> is already probed for, but currently
4821 * it is only included in special cases.
bcf53261
JH		 4822 *
4823 * In Digital UNIX/Tru64 if using the getespw*() (which seems to be
4824 * be preferred interface, even though also the getprpw*() interface
4825 * is available) one needs to link with -lsecurity -ldb -laud -lm.
3813c136
JH		 4826 * One also needs to call set_auth_parameters() in main() before
4827 * doing anything else, whether one is using getespw*() or getprpw*().
4828 *
4829 * Note that accessing the shadow databases can be magnitudes
4830 * slower than accessing the standard databases.
bcf53261
JH		 4831 *
4832 * --jhi
4833 */
a0d0e21e 4834
e3aefe8d
JH		 4835 switch (which) {
4836 case OP_GPWNAM:
4837 pwent = getpwnam(POPpx);
e3aefe8d
JH		 4838 break;
4839 case OP_GPWUID:
4840 pwent = getpwuid((Uid_t)POPi);
4841 break;
4842 case OP_GPWENT:
1883634f 4843# ifdef HAS_GETPWENT
e3aefe8d 4844 pwent = getpwent();
1883634f 4845# else
a45d1c96 4846 DIE(aTHX_ PL_no_func, "getpwent");
1883634f 4847# endif
e3aefe8d
JH		 4848 break;
4849 }
8c0bfa08 4850
a0d0e21e
LW		 4851 EXTEND(SP, 10);
4852 if (GIMME != G_ARRAY) {
4853 PUSHs(sv = sv_newmortal());
4854 if (pwent) {
4855 if (which == OP_GPWNAM)
1883634f 4856# if Uid_t_sign <= 0
1e422769 4857 sv_setiv(sv, (IV)pwent->pw_uid);
1883634f 4858# else
23dcd6c8 4859 sv_setuv(sv, (UV)pwent->pw_uid);
1883634f 4860# endif
a0d0e21e
LW		 4861 else
4862 sv_setpv(sv, pwent->pw_name);
4863 }
4864 RETURN;
4865 }
4866
4867 if (pwent) {
3280af22 4868 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4869 sv_setpv(sv, pwent->pw_name);
6ee623d5 4870
3280af22 4871 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
3813c136
JH		 4872 SvPOK_off(sv);
4873 /* If we have getspnam(), we try to dig up the shadow
4874 * password. If we are underprivileged, the shadow
4875 * interface will set the errno to EACCES or similar,
4876 * and return a null pointer. If this happens, we will
4877 * use the dummy password (usually "*" or "x") from the
4878 * standard password database.
4879 *
4880 * In theory we could skip the shadow call completely
4881 * if euid != 0 but in practice we cannot know which
4882 * security measures are guarding the shadow databases
4883 * on a random platform.
4884 *
4885 * Resist the urge to use additional shadow interfaces.
4886 * Divert the urge to writing an extension instead.
4887 *
4888 * --jhi */
e3aefe8d 4889# ifdef HAS_GETSPNAM
3813c136
JH		 4890 {
4891 struct spwd *spwent;
4892 int saverrno; /* Save and restore errno so that
4893 * underprivileged attempts seem
4894 * to have never made the unsccessful
4895 * attempt to retrieve the shadow password. */
4896
4897 saverrno = errno;
4898 spwent = getspnam(pwent->pw_name);
4899 errno = saverrno;
4900 if (spwent && spwent->sp_pwdp)
4901 sv_setpv(sv, spwent->sp_pwdp);
4902 }
f1066039 4903# endif
3813c136
JH		 4904 if (!SvPOK(sv)) /* Use the standard password, then. */
4905 sv_setpv(sv, pwent->pw_passwd);
4906
1883634f 4907# ifndef INCOMPLETE_TAINTS
3813c136
JH		 4908 /* passwd is tainted because user himself can diddle with it.
4909 * admittedly not much and in a very limited way, but nevertheless. */
2959b6e3 4910 SvTAINTED_on(sv);
1883634f 4911# endif
6ee623d5 4912
3280af22 4913 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1883634f 4914# if Uid_t_sign <= 0
1e422769 4915 sv_setiv(sv, (IV)pwent->pw_uid);
1883634f 4916# else
23dcd6c8 4917 sv_setuv(sv, (UV)pwent->pw_uid);
1883634f 4918# endif
6ee623d5 4919
3280af22 4920 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1883634f 4921# if Uid_t_sign <= 0
1e422769 4922 sv_setiv(sv, (IV)pwent->pw_gid);
1883634f 4923# else
23dcd6c8 4924 sv_setuv(sv, (UV)pwent->pw_gid);
1883634f 4925# endif
3813c136
JH		 4926 /* pw_change, pw_quota, and pw_age are mutually exclusive--
4927 * because of the poor interface of the Perl getpw*(),
4928 * not because there's some standard/convention saying so.
4929 * A better interface would have been to return a hash,
4930 * but we are accursed by our history, alas. --jhi. */
3280af22 4931 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1883634f 4932# ifdef PWCHANGE
1e422769 4933 sv_setiv(sv, (IV)pwent->pw_change);
6ee623d5 4934# else
1883634f
JH		 4935# ifdef PWQUOTA
4936 sv_setiv(sv, (IV)pwent->pw_quota);
4937# else
a1757be1 4938# ifdef PWAGE
a0d0e21e 4939 sv_setpv(sv, pwent->pw_age);
a1757be1 4940# endif
6ee623d5
GS		 4941# endif
4942# endif
6ee623d5 4943
3813c136
JH		 4944 /* pw_class and pw_comment are mutually exclusive--.
4945 * see the above note for pw_change, pw_quota, and pw_age. */
3280af22 4946 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1883634f 4947# ifdef PWCLASS
a0d0e21e 4948 sv_setpv(sv, pwent->pw_class);
1883634f
JH		 4949# else
4950# ifdef PWCOMMENT
a0d0e21e 4951 sv_setpv(sv, pwent->pw_comment);
1883634f 4952# endif
6ee623d5 4953# endif
6ee623d5 4954
3280af22 4955 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1883634f 4956# ifdef PWGECOS
a0d0e21e 4957 sv_setpv(sv, pwent->pw_gecos);
1883634f
JH		 4958# endif
4959# ifndef INCOMPLETE_TAINTS
d2719217 4960 /* pw_gecos is tainted because user himself can diddle with it. */
fb73857a 4961 SvTAINTED_on(sv);
1883634f 4962# endif
6ee623d5 4963
3280af22 4964 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4965 sv_setpv(sv, pwent->pw_dir);
6ee623d5 4966
3280af22 4967 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 4968 sv_setpv(sv, pwent->pw_shell);
1883634f 4969# ifndef INCOMPLETE_TAINTS
4602f195
JH		 4970 /* pw_shell is tainted because user himself can diddle with it. */
4971 SvTAINTED_on(sv);
1883634f 4972# endif
6ee623d5 4973
1883634f 4974# ifdef PWEXPIRE
6b88bc9c 4975 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 4976 sv_setiv(sv, (IV)pwent->pw_expire);
1883634f 4977# endif
a0d0e21e
LW		 4978 }
4979 RETURN;
4980#else
cea2e8a9 4981 DIE(aTHX_ PL_no_func, "getpwent");
a0d0e21e
LW		 4982#endif
4983}
4984
4985PP(pp_spwent)
4986{
4e35701f 4987 djSP;
d493b042 4988#if defined(HAS_PASSWD) && defined(HAS_SETPWENT)
a0d0e21e
LW		 4989 setpwent();
4990 RETPUSHYES;
4991#else
cea2e8a9 4992 DIE(aTHX_ PL_no_func, "setpwent");
a0d0e21e
LW		 4993#endif
4994}
4995
4996PP(pp_epwent)
4997{
4e35701f 4998 djSP;
28e8609d 4999#if defined(HAS_PASSWD) && defined(HAS_ENDPWENT)
a0d0e21e
LW		 5000 endpwent();
5001 RETPUSHYES;
5002#else
cea2e8a9 5003 DIE(aTHX_ PL_no_func, "endpwent");
a0d0e21e
LW		 5004#endif
5005}
5006
5007PP(pp_ggrnam)
5008{
5009#ifdef HAS_GROUP
cea2e8a9 5010 return pp_ggrent();
a0d0e21e 5011#else
cea2e8a9 5012 DIE(aTHX_ PL_no_func, "getgrnam");
a0d0e21e
LW		 5013#endif
5014}
5015
5016PP(pp_ggrgid)
5017{
5018#ifdef HAS_GROUP
cea2e8a9 5019 return pp_ggrent();
a0d0e21e 5020#else
cea2e8a9 5021 DIE(aTHX_ PL_no_func, "getgrgid");
a0d0e21e
LW		 5022#endif
5023}
5024
5025PP(pp_ggrent)
5026{
4e35701f 5027 djSP;
0994c4d0 5028#ifdef HAS_GROUP
533c011a 5029 I32 which = PL_op->op_type;
a0d0e21e
LW		 5030 register char **elem;
5031 register SV *sv;
5032 struct group *grent;
2d8e6c8d 5033 STRLEN n_a;
a0d0e21e
LW		 5034
5035 if (which == OP_GGRNAM)
2d8e6c8d 5036 grent = (struct group *)getgrnam(POPpx);
a0d0e21e
LW		 5037 else if (which == OP_GGRGID)
5038 grent = (struct group *)getgrgid(POPi);
5039 else
0994c4d0 5040#ifdef HAS_GETGRENT
a0d0e21e 5041 grent = (struct group *)getgrent();
0994c4d0
JH		 5042#else
5043 DIE(aTHX_ PL_no_func, "getgrent");
5044#endif
a0d0e21e
LW		 5045
5046 EXTEND(SP, 4);
5047 if (GIMME != G_ARRAY) {
5048 PUSHs(sv = sv_newmortal());
5049 if (grent) {
5050 if (which == OP_GGRNAM)
1e422769 5051 sv_setiv(sv, (IV)grent->gr_gid);
a0d0e21e
LW		 5052 else
5053 sv_setpv(sv, grent->gr_name);
5054 }
5055 RETURN;
5056 }
5057
5058 if (grent) {
3280af22 5059 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e 5060 sv_setpv(sv, grent->gr_name);
28e8609d 5061
3280af22 5062 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
28e8609d 5063#ifdef GRPASSWD
a0d0e21e 5064 sv_setpv(sv, grent->gr_passwd);
28e8609d
JH		 5065#endif
5066
3280af22 5067 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
1e422769 5068 sv_setiv(sv, (IV)grent->gr_gid);
28e8609d 5069
3280af22 5070 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
c90c0ff4 5071 for (elem = grent->gr_mem; elem && *elem; elem++) {
a0d0e21e
LW		 5072 sv_catpv(sv, *elem);
5073 if (elem[1])
5074 sv_catpvn(sv, " ", 1);
5075 }
5076 }
5077
5078 RETURN;
5079#else
cea2e8a9 5080 DIE(aTHX_ PL_no_func, "getgrent");
a0d0e21e
LW		 5081#endif
5082}
5083
5084PP(pp_sgrent)
5085{
4e35701f 5086 djSP;
28e8609d 5087#if defined(HAS_GROUP) && defined(HAS_SETGRENT)
a0d0e21e
LW		 5088 setgrent();
5089 RETPUSHYES;
5090#else
cea2e8a9 5091 DIE(aTHX_ PL_no_func, "setgrent");
a0d0e21e
LW		 5092#endif
5093}
5094
5095PP(pp_egrent)
5096{
4e35701f 5097 djSP;
28e8609d 5098#if defined(HAS_GROUP) && defined(HAS_ENDGRENT)
a0d0e21e
LW		 5099 endgrent();
5100 RETPUSHYES;
5101#else
cea2e8a9 5102 DIE(aTHX_ PL_no_func, "endgrent");
a0d0e21e
LW		 5103#endif
5104}
5105
5106PP(pp_getlogin)
5107{
4e35701f 5108 djSP; dTARGET;
a0d0e21e
LW		 5109#ifdef HAS_GETLOGIN
5110 char *tmps;
5111 EXTEND(SP, 1);
76e3520e 5112 if (!(tmps = PerlProc_getlogin()))
a0d0e21e
LW		 5113 RETPUSHUNDEF;
5114 PUSHp(tmps, strlen(tmps));
5115 RETURN;
5116#else
cea2e8a9 5117 DIE(aTHX_ PL_no_func, "getlogin");
a0d0e21e
LW		 5118#endif
5119}
5120
5121/* Miscellaneous. */
5122
5123PP(pp_syscall)
5124{
d2719217 5125#ifdef HAS_SYSCALL
4e35701f 5126 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 5127 register I32 items = SP - MARK;
5128 unsigned long a[20];
5129 register I32 i = 0;
5130 I32 retval = -1;
2d8e6c8d 5131 STRLEN n_a;
a0d0e21e 5132
3280af22 5133 if (PL_tainting) {
a0d0e21e 5134 while (++MARK <= SP) {
bbce6d69 5135 if (SvTAINTED(*MARK)) {
5136 TAINT;
5137 break;
5138 }
a0d0e21e
LW		 5139 }
5140 MARK = ORIGMARK;
5141 TAINT_PROPER("syscall");
5142 }
5143
5144 /* This probably won't work on machines where sizeof(long) != sizeof(int)
5145 * or where sizeof(long) != sizeof(char*). But such machines will
5146 * not likely have syscall implemented either, so who cares?
5147 */
5148 while (++MARK <= SP) {
5149 if (SvNIOK(*MARK) || !i)
5150 a[i++] = SvIV(*MARK);
3280af22 5151 else if (*MARK == &PL_sv_undef)
748a9306
LW		 5152 a[i++] = 0;
5153 else
2d8e6c8d 5154 a[i++] = (unsigned long)SvPV_force(*MARK, n_a);
a0d0e21e
LW		 5155 if (i > 15)
5156 break;
5157 }
5158 switch (items) {
5159 default:
cea2e8a9 5160 DIE(aTHX_ "Too many args to syscall");
a0d0e21e 5161 case 0:
cea2e8a9 5162 DIE(aTHX_ "Too few args to syscall");
a0d0e21e
LW		 5163 case 1:
5164 retval = syscall(a[0]);
5165 break;
5166 case 2:
5167 retval = syscall(a[0],a[1]);
5168 break;
5169 case 3:
5170 retval = syscall(a[0],a[1],a[2]);
5171 break;
5172 case 4:
5173 retval = syscall(a[0],a[1],a[2],a[3]);
5174 break;
5175 case 5:
5176 retval = syscall(a[0],a[1],a[2],a[3],a[4]);
5177 break;
5178 case 6:
5179 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5]);
5180 break;
5181 case 7:
5182 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6]);
5183 break;
5184 case 8:
5185 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7]);
5186 break;
5187#ifdef atarist
5188 case 9:
5189 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8]);
5190 break;
5191 case 10:
5192 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9]);
5193 break;
5194 case 11:
5195 retval = syscall(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8],a[9],
5196 a[10]);
5197 break;
5198 case 12:
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],a[11]);
5201 break;
5202 case 13:
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],a[12]);
5205 break;
5206 case 14:
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],a[13]);
5209 break;
5210#endif /* atarist */
5211 }
5212 SP = ORIGMARK;
5213 PUSHi(retval);
5214 RETURN;
5215#else
cea2e8a9 5216 DIE(aTHX_ PL_no_func, "syscall");
a0d0e21e
LW		 5217#endif
5218}
5219
ff68c719 5220#ifdef FCNTL_EMULATE_FLOCK
5221
5222/* XXX Emulate flock() with fcntl().
5223 What's really needed is a good file locking module.
5224*/
5225
cea2e8a9
GS		 5226static int
5227fcntl_emulate_flock(int fd, int operation)
ff68c719 5228{
5229 struct flock flock;
5230
5231 switch (operation & ~LOCK_NB) {
5232 case LOCK_SH:
5233 flock.l_type = F_RDLCK;
5234 break;
5235 case LOCK_EX:
5236 flock.l_type = F_WRLCK;
5237 break;
5238 case LOCK_UN:
5239 flock.l_type = F_UNLCK;
5240 break;
5241 default:
5242 errno = EINVAL;
5243 return -1;
5244 }
5245 flock.l_whence = SEEK_SET;
d9b3e12d 5246 flock.l_start = flock.l_len = (Off_t)0;
ff68c719 5247
5248 return fcntl(fd, (operation & LOCK_NB) ? F_SETLK : F_SETLKW, &flock);
5249}
5250
5251#endif /* FCNTL_EMULATE_FLOCK */
5252
5253#ifdef LOCKF_EMULATE_FLOCK
16d20bd9
AD		 5254
5255/* XXX Emulate flock() with lockf(). This is just to increase
5256 portability of scripts. The calls are not completely
5257 interchangeable. What's really needed is a good file
5258 locking module.
5259*/
5260
76c32331 5261/* The lockf() constants might have been defined in <unistd.h>.
5262 Unfortunately, <unistd.h> causes troubles on some mixed
5263 (BSD/POSIX) systems, such as SunOS 4.1.3.
16d20bd9
AD		 5264
5265 Further, the lockf() constants aren't POSIX, so they might not be
5266 visible if we're compiling with _POSIX_SOURCE defined. Thus, we'll
5267 just stick in the SVID values and be done with it. Sigh.
5268*/
5269
5270# ifndef F_ULOCK
5271# define F_ULOCK 0 /* Unlock a previously locked region */
5272# endif
5273# ifndef F_LOCK
5274# define F_LOCK 1 /* Lock a region for exclusive use */
5275# endif
5276# ifndef F_TLOCK
5277# define F_TLOCK 2 /* Test and lock a region for exclusive use */
5278# endif
5279# ifndef F_TEST
5280# define F_TEST 3 /* Test a region for other processes locks */
5281# endif
5282
cea2e8a9
GS		 5283static int
5284lockf_emulate_flock(int fd, int operation)
16d20bd9
AD		 5285{
5286 int i;
84902520
TB		 5287 int save_errno;
5288 Off_t pos;
5289
5290 /* flock locks entire file so for lockf we need to do the same */
5291 save_errno = errno;
6ad3d225 5292 pos = PerlLIO_lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
84902520 5293 if (pos > 0) /* is seekable and needs to be repositioned */
6ad3d225 5294 if (PerlLIO_lseek(fd, (Off_t)0, SEEK_SET) < 0)
08b714dd 5295 pos = -1; /* seek failed, so don't seek back afterwards */
84902520
TB		 5296 errno = save_errno;
5297
16d20bd9
AD		 5298 switch (operation) {
5299
5300 /* LOCK_SH - get a shared lock */
5301 case LOCK_SH:
5302 /* LOCK_EX - get an exclusive lock */
5303 case LOCK_EX:
5304 i = lockf (fd, F_LOCK, 0);
5305 break;
5306
5307 /* LOCK_SH|LOCK_NB - get a non-blocking shared lock */
5308 case LOCK_SH|LOCK_NB:
5309 /* LOCK_EX|LOCK_NB - get a non-blocking exclusive lock */
5310 case LOCK_EX|LOCK_NB:
5311 i = lockf (fd, F_TLOCK, 0);
5312 if (i == -1)
5313 if ((errno == EAGAIN) || (errno == EACCES))
5314 errno = EWOULDBLOCK;
5315 break;
5316
ff68c719 5317 /* LOCK_UN - unlock (non-blocking is a no-op) */
16d20bd9 5318 case LOCK_UN:
ff68c719 5319 case LOCK_UN|LOCK_NB:
16d20bd9
AD		 5320 i = lockf (fd, F_ULOCK, 0);
5321 break;
5322
5323 /* Default - can't decipher operation */
5324 default:
5325 i = -1;
5326 errno = EINVAL;
5327 break;
5328 }
84902520
TB		 5329
5330 if (pos > 0) /* need to restore position of the handle */
6ad3d225 5331 PerlLIO_lseek(fd, pos, SEEK_SET); /* ignore error here */
84902520 5332
16d20bd9
AD		 5333 return (i);
5334}
ff68c719 5335
5336#endif /* LOCKF_EMULATE_FLOCK */
Unnamed repository; edit this file 'description' to name the repository.