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