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