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