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