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