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