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