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