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