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