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
allocate sufficient buffer sizes for 64-bit wide utf8 characters
[perl5.git] / pp_sys.c
</
CommitLineData
a0d0e21e
LW		 1/* pp_sys.c
2 *
3818b22b 3 * Copyright (c) 1991-2000, 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.
24 * the API is from SysV. --jhi */
5b3db61d
DL		 25#ifdef __hpux__
26/* There is a MAXINT coming from <shadow.h> <- <hpsecurity.h> <- <values.h>
27 * and another MAXINT from "perl.h" <- <sys/param.h>. */
28#undef MAXINT
29#endif
8c0bfa08
PB		 30#include <shadow.h>
31#endif
32
76c32331 33/* XXX If this causes problems, set i_unistd=undef in the hint file. */
34#ifdef I_UNISTD
35# include <unistd.h>
36#endif
37
8ac85365
NIS		 38#ifdef HAS_SYSCALL
39#ifdef __cplusplus
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
LW		 51
52#if defined(HAS_SOCKET) && !defined(VMS) /* VMS handles sockets via vmsish.h */
53# include <sys/socket.h>
29209bc5 54# if defined(USE_SOCKS) && defined(I_SOCKS)
86959918
JH		 55# include <socks.h>
56# endif
3fd537d4
JH		 57# ifdef I_NETDB
58# include <netdb.h>
59# endif
a0d0e21e
LW		 60# ifndef ENOTSOCK
61# ifdef I_NET_ERRNO
62# include <net/errno.h>
63# endif
64# endif
65#endif
66
67#ifdef HAS_SELECT
68#ifdef I_SYS_SELECT
a0d0e21e
LW		 69#include <sys/select.h>
70#endif
71#endif
a0d0e21e 72
dc45a647
MB		 73/* XXX Configure test needed.
74 h_errno might not be a simple 'int', especially for multi-threaded
5ff3f7a4
GS		 75 applications, see "extern int errno in perl.h". Creating such
76 a test requires taking into account the differences between
77 compiling multithreaded and singlethreaded ($ccflags et al).
78 HOST_NOT_FOUND is typically defined in <netdb.h>.
dc45a647 79*/
df4e335f 80#if defined(HOST_NOT_FOUND) && !defined(h_errno) && !defined(__CYGWIN__)
a0d0e21e
LW		 81extern int h_errno;
82#endif
83
84#ifdef HAS_PASSWD
85# ifdef I_PWD
86# include <pwd.h>
87# else
20ce7b12
GS		 88 struct passwd *getpwnam (char *);
89 struct passwd *getpwuid (Uid_t);
a0d0e21e 90# endif
28e8609d 91# ifdef HAS_GETPWENT
20ce7b12 92 struct passwd *getpwent (void);
28e8609d 93# endif
a0d0e21e
LW		 94#endif
95
96#ifdef HAS_GROUP
97# ifdef I_GRP
98# include <grp.h>
99# else
20ce7b12
GS		 100 struct group *getgrnam (char *);
101 struct group *getgrgid (Gid_t);
a0d0e21e 102# endif
28e8609d 103# ifdef HAS_GETGRENT
20ce7b12 104 struct group *getgrent (void);
28e8609d 105# endif
a0d0e21e
LW		 106#endif
107
108#ifdef I_UTIME
3730b96e 109# if defined(_MSC_VER) || defined(__MINGW32__)
3fe9a6f1 110# include <sys/utime.h>
111# else
112# include <utime.h>
113# endif
a0d0e21e
LW		 114#endif
115#ifdef I_FCNTL
116#include <fcntl.h>
117#endif
118#ifdef I_SYS_FILE
119#include <sys/file.h>
120#endif
121
54310121 122/* Put this after #includes because fork and vfork prototypes may conflict. */
123#ifndef HAS_VFORK
124# define vfork fork
125#endif
126
d574b85e
CS		 127/* Put this after #includes because <unistd.h> defines _XOPEN_*. */
128#ifndef Sock_size_t
137443ea 129# if _XOPEN_VERSION >= 5 || defined(_XOPEN_SOURCE_EXTENDED) || defined(__GLIBC__)
d574b85e
CS		 130# define Sock_size_t Size_t
131# else
132# define Sock_size_t int
133# endif
54310121 134#endif
135
cbdc8872 136#ifdef HAS_CHSIZE
cd52b7b2 137# ifdef my_chsize /* Probably #defined to Perl_my_chsize in embed.h */
138# undef my_chsize
139# endif
6ad3d225 140# define my_chsize PerlLIO_chsize
cbdc8872 141#endif
142
ff68c719 143#ifdef HAS_FLOCK
144# define FLOCK flock
145#else /* no flock() */
146
36477c24 147 /* fcntl.h might not have been included, even if it exists, because
148 the current Configure only sets I_FCNTL if it's needed to pick up
149 the *_OK constants. Make sure it has been included before testing
150 the fcntl() locking constants. */
151# if defined(HAS_FCNTL) && !defined(I_FCNTL)
152# include <fcntl.h>
153# endif
154
ff68c719 155# if defined(HAS_FCNTL) && defined(F_SETLK) && defined (F_SETLKW)
156# define FLOCK fcntl_emulate_flock
157# define FCNTL_EMULATE_FLOCK
158# else /* no flock() or fcntl(F_SETLK,...) */
159# ifdef HAS_LOCKF
160# define FLOCK lockf_emulate_flock
161# define LOCKF_EMULATE_FLOCK
162# endif /* lockf */
163# endif /* no flock() or fcntl(F_SETLK,...) */
164
165# ifdef FLOCK
20ce7b12 166 static int FLOCK (int, int);
ff68c719 167
168 /*
169 * These are the flock() constants. Since this sytems doesn't have
170 * flock(), the values of the constants are probably not available.
171 */
172# ifndef LOCK_SH
173# define LOCK_SH 1
174# endif
175# ifndef LOCK_EX
176# define LOCK_EX 2
177# endif
178# ifndef LOCK_NB
179# define LOCK_NB 4
180# endif
181# ifndef LOCK_UN
182# define LOCK_UN 8
183# endif
184# endif /* emulating flock() */
185
186#endif /* no flock() */
55497cff 187
85ab1d1d
JH		 188#define ZBTLEN 10
189static char zero_but_true[ZBTLEN + 1] = "0 but true";
190
5ff3f7a4
GS		 191#if defined(I_SYS_ACCESS) && !defined(R_OK)
192# include <sys/access.h>
193#endif
194
37bd1396
GS		 195#if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
196# define FD_CLOEXEC 1 /* NeXT needs this */
197#endif
198
5ff3f7a4
GS		 199#undef PERL_EFF_ACCESS_R_OK /* EFFective uid/gid ACCESS R_OK */
200#undef PERL_EFF_ACCESS_W_OK
201#undef PERL_EFF_ACCESS_X_OK
202
203/* F_OK unused: if stat() cannot find it... */
204
205#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_ACCESS) && defined(EFF_ONLY_OK) && !defined(NO_EFF_ONLY_OK)
c955f117 206 /* Digital UNIX (when the EFF_ONLY_OK gets fixed), UnixWare */
5ff3f7a4
GS		 207# define PERL_EFF_ACCESS_R_OK(p) (access((p), R_OK | EFF_ONLY_OK))
208# define PERL_EFF_ACCESS_W_OK(p) (access((p), W_OK | EFF_ONLY_OK))
209# define PERL_EFF_ACCESS_X_OK(p) (access((p), X_OK | EFF_ONLY_OK))
210#endif
211
212#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_EACCESS)
5ff3f7a4
GS		 213# if defined(I_SYS_SECURITY)
214# include <sys/security.h>
215# endif
c955f117
JH		 216 /* XXX Configure test needed for eaccess */
217# ifdef ACC_SELF
218 /* HP SecureWare */
219# define PERL_EFF_ACCESS_R_OK(p) (eaccess((p), R_OK, ACC_SELF))
220# define PERL_EFF_ACCESS_W_OK(p) (eaccess((p), W_OK, ACC_SELF))
221# define PERL_EFF_ACCESS_X_OK(p) (eaccess((p), X_OK, ACC_SELF))
222# else
223 /* SCO */
224# define PERL_EFF_ACCESS_R_OK(p) (eaccess((p), R_OK))
225# define PERL_EFF_ACCESS_W_OK(p) (eaccess((p), W_OK))
226# define PERL_EFF_ACCESS_X_OK(p) (eaccess((p), X_OK))
227# endif
5ff3f7a4
GS		 228#endif
229
230#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_ACCESSX) && defined(ACC_SELF)
c955f117 231 /* AIX */
5ff3f7a4
GS		 232# define PERL_EFF_ACCESS_R_OK(p) (accessx((p), R_OK, ACC_SELF))
233# define PERL_EFF_ACCESS_W_OK(p) (accessx((p), W_OK, ACC_SELF))
234# define PERL_EFF_ACCESS_X_OK(p) (accessx((p), X_OK, ACC_SELF))
235#endif
236
327c3667
GS		 237#if !defined(PERL_EFF_ACCESS_R_OK) && defined(HAS_ACCESS) \
238 && (defined(HAS_SETREUID) || defined(HAS_SETRESUID) \
239 || defined(HAS_SETREGID) || defined(HAS_SETRESGID))
5ff3f7a4 240/* The Hard Way. */
327c3667 241STATIC int
7f4774ae 242S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
ba106d47 243{
5ff3f7a4
GS		 244 Uid_t ruid = getuid();
245 Uid_t euid = geteuid();
246 Gid_t rgid = getgid();
247 Gid_t egid = getegid();
248 int res;
249
1feb2720 250 LOCK_CRED_MUTEX;
5ff3f7a4 251#if !defined(HAS_SETREUID) && !defined(HAS_SETRESUID)
cea2e8a9 252 Perl_croak(aTHX_ "switching effective uid is not implemented");
5ff3f7a4
GS		 253#else
254#ifdef HAS_SETREUID
255 if (setreuid(euid, ruid))
256#else
257#ifdef HAS_SETRESUID
258 if (setresuid(euid, ruid, (Uid_t)-1))
259#endif
260#endif
cea2e8a9 261 Perl_croak(aTHX_ "entering effective uid failed");
5ff3f7a4
GS		 262#endif
263
264#if !defined(HAS_SETREGID) && !defined(HAS_SETRESGID)
cea2e8a9 265 Perl_croak(aTHX_ "switching effective gid is not implemented");
5ff3f7a4
GS		 266#else
267#ifdef HAS_SETREGID
268 if (setregid(egid, rgid))
269#else
270#ifdef HAS_SETRESGID
271 if (setresgid(egid, rgid, (Gid_t)-1))
272#endif
273#endif
cea2e8a9 274 Perl_croak(aTHX_ "entering effective gid failed");
5ff3f7a4
GS		 275#endif
276
277 res = access(path, mode);
278
279#ifdef HAS_SETREUID
280 if (setreuid(ruid, euid))
281#else
282#ifdef HAS_SETRESUID
283 if (setresuid(ruid, euid, (Uid_t)-1))
284#endif
285#endif
cea2e8a9 286 Perl_croak(aTHX_ "leaving effective uid failed");
5ff3f7a4
GS		 287
288#ifdef HAS_SETREGID
289 if (setregid(rgid, egid))
290#else
291#ifdef HAS_SETRESGID
292 if (setresgid(rgid, egid, (Gid_t)-1))
293#endif
294#endif
cea2e8a9 295 Perl_croak(aTHX_ "leaving effective gid failed");
1feb2720 296 UNLOCK_CRED_MUTEX;
5ff3f7a4
GS		 297
298 return res;
299}
300# define PERL_EFF_ACCESS_R_OK(p) (emulate_eaccess((p), R_OK))
301# define PERL_EFF_ACCESS_W_OK(p) (emulate_eaccess((p), W_OK))
302# define PERL_EFF_ACCESS_X_OK(p) (emulate_eaccess((p), X_OK))
303#endif
304
305#if !defined(PERL_EFF_ACCESS_R_OK)
327c3667 306STATIC int
7f4774ae 307S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
ba106d47 308{
cea2e8a9 309 Perl_croak(aTHX_ "switching effective uid is not implemented");
5ff3f7a4
GS		 310 /*NOTREACHED*/
311 return -1;
312}
313#endif
314
a0d0e21e
LW		 315PP(pp_backtick)
316{
4e35701f 317 djSP; dTARGET;
760ac839 318 PerlIO *fp;
2d8e6c8d
GS		 319 STRLEN n_a;
320 char *tmps = POPpx;
54310121 321 I32 gimme = GIMME_V;
322
a0d0e21e 323 TAINT_PROPER("``");
6ad3d225 324 fp = PerlProc_popen(tmps, "r");
a0d0e21e 325 if (fp) {
54310121 326 if (gimme == G_VOID) {
96827780
MB		 327 char tmpbuf[256];
328 while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0)
54310121 329 /*SUPPRESS 530*/
330 ;
331 }
332 else if (gimme == G_SCALAR) {
aa689395 333 sv_setpv(TARG, ""); /* note that this preserves previous buffer */
a0d0e21e
LW		 334 while (sv_gets(TARG, fp, SvCUR(TARG)) != Nullch)
335 /*SUPPRESS 530*/
336 ;
337 XPUSHs(TARG);
aa689395 338 SvTAINTED_on(TARG);
a0d0e21e
LW		 339 }
340 else {
341 SV *sv;
342
343 for (;;) {
8d6dde3e 344 sv = NEWSV(56, 79);
a0d0e21e
LW		 345 if (sv_gets(sv, fp, 0) == Nullch) {
346 SvREFCNT_dec(sv);
347 break;
348 }
349 XPUSHs(sv_2mortal(sv));
350 if (SvLEN(sv) - SvCUR(sv) > 20) {
351 SvLEN_set(sv, SvCUR(sv)+1);
352 Renew(SvPVX(sv), SvLEN(sv), char);
353 }
aa689395 354 SvTAINTED_on(sv);
a0d0e21e
LW		 355 }
356 }
6ad3d225 357 STATUS_NATIVE_SET(PerlProc_pclose(fp));
aa689395 358 TAINT; /* "I believe that this is not gratuitous!" */
a0d0e21e
LW		 359 }
360 else {
f86702cc 361 STATUS_NATIVE_SET(-1);
54310121 362 if (gimme == G_SCALAR)
a0d0e21e
LW		 363 RETPUSHUNDEF;
364 }
365
366 RETURN;
367}
368
369PP(pp_glob)
370{
371 OP *result;
f5284f61
IZ		 372 tryAMAGICunTARGET(iter, -1);
373
a0d0e21e 374 ENTER;
a0d0e21e 375
c90c0ff4 376#ifndef VMS
3280af22 377 if (PL_tainting) {
7bac28a0 378 /*
379 * The external globbing program may use things we can't control,
380 * so for security reasons we must assume the worst.
381 */
382 TAINT;
22c35a8c 383 taint_proper(PL_no_security, "glob");
7bac28a0 384 }
c90c0ff4 385#endif /* !VMS */
7bac28a0 386
3280af22
NIS		 387 SAVESPTR(PL_last_in_gv); /* We don't want this to be permanent. */
388 PL_last_in_gv = (GV*)*PL_stack_sp--;
a0d0e21e 389
3280af22 390 SAVESPTR(PL_rs); /* This is not permanent, either. */
79cb57f6 391 PL_rs = sv_2mortal(newSVpvn("\000", 1));
c07a80fd 392#ifndef DOSISH
393#ifndef CSH
6b88bc9c 394 *SvPVX(PL_rs) = '\n';
a0d0e21e 395#endif /* !CSH */
55497cff 396#endif /* !DOSISH */
c07a80fd 397
a0d0e21e
LW		 398 result = do_readline();
399 LEAVE;
400 return result;
401}
402
15e52e56 403#if 0 /* XXX never used! */
a0d0e21e
LW		 404PP(pp_indread)
405{
2d8e6c8d
GS		 406 STRLEN n_a;
407 PL_last_in_gv = gv_fetchpv(SvPVx(GvSV((GV*)(*PL_stack_sp--)), n_a), TRUE,SVt_PVIO);
a0d0e21e
LW		 408 return do_readline();
409}
15e52e56 410#endif
a0d0e21e
LW		 411
412PP(pp_rcatline)
413{
638eceb6 414 PL_last_in_gv = cGVOP_gv;
a0d0e21e
LW		 415 return do_readline();
416}
417
418PP(pp_warn)
419{
4e35701f 420 djSP; dMARK;
06bf62c7 421 SV *tmpsv;
a0d0e21e 422 char *tmps;
06bf62c7 423 STRLEN len;
a0d0e21e
LW		 424 if (SP - MARK != 1) {
425 dTARGET;
3280af22 426 do_join(TARG, &PL_sv_no, MARK, SP);
06bf62c7 427 tmpsv = TARG;
a0d0e21e
LW		 428 SP = MARK + 1;
429 }
430 else {
06bf62c7 431 tmpsv = TOPs;
a0d0e21e 432 }
06bf62c7
GS		 433 tmps = SvPV(tmpsv, len);
434 if (!tmps || !len) {
4e6ea2c3
GS		 435 SV *error = ERRSV;
436 (void)SvUPGRADE(error, SVt_PV);
437 if (SvPOK(error) && SvCUR(error))
438 sv_catpv(error, "\t...caught");
06bf62c7
GS		 439 tmpsv = error;
440 tmps = SvPV(tmpsv, len);
a0d0e21e 441 }
06bf62c7
GS		 442 if (!tmps || !len)
443 tmpsv = sv_2mortal(newSVpvn("Warning: something's wrong", 26));
444
894356b3 445 Perl_warn(aTHX_ "%"SVf, tmpsv);
a0d0e21e
LW		 446 RETSETYES;
447}
448
449PP(pp_die)
450{
4e35701f 451 djSP; dMARK;
a0d0e21e 452 char *tmps;
06bf62c7
GS		 453 SV *tmpsv;
454 STRLEN len;
455 bool multiarg = 0;
a0d0e21e
LW		 456 if (SP - MARK != 1) {
457 dTARGET;
3280af22 458 do_join(TARG, &PL_sv_no, MARK, SP);
06bf62c7
GS		 459 tmpsv = TARG;
460 tmps = SvPV(tmpsv, len);
461 multiarg = 1;
a0d0e21e
LW		 462 SP = MARK + 1;
463 }
464 else {
4e6ea2c3 465 tmpsv = TOPs;
06bf62c7 466 tmps = SvROK(tmpsv) ? Nullch : SvPV(tmpsv, len);
a0d0e21e 467 }
06bf62c7 468 if (!tmps || !len) {
4e6ea2c3
GS		 469 SV *error = ERRSV;
470 (void)SvUPGRADE(error, SVt_PV);
06bf62c7
GS		 471 if (multiarg ? SvROK(error) : SvROK(tmpsv)) {
472 if (!multiarg)
4e6ea2c3 473 SvSetSV(error,tmpsv);
06bf62c7 474 else if (sv_isobject(error)) {
05423cc9
GS		 475 HV *stash = SvSTASH(SvRV(error));
476 GV *gv = gv_fetchmethod(stash, "PROPAGATE");
477 if (gv) {
ed094faf 478 SV *file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0));
57843af0 479 SV *line = sv_2mortal(newSViv(CopLINE(PL_curcop)));
05423cc9
GS		 480 EXTEND(SP, 3);
481 PUSHMARK(SP);
482 PUSHs(error);
483 PUSHs(file);
484 PUSHs(line);
485 PUTBACK;
864dbfa3
GS		 486 call_sv((SV*)GvCV(gv),
487 G_SCALAR|G_EVAL|G_KEEPERR);
3280af22 488 sv_setsv(error,*PL_stack_sp--);
05423cc9
GS		 489 }
490 }
cea2e8a9 491 DIE(aTHX_ Nullch);
4e6ea2c3
GS		 492 }
493 else {
494 if (SvPOK(error) && SvCUR(error))
495 sv_catpv(error, "\t...propagated");
06bf62c7
GS		 496 tmpsv = error;
497 tmps = SvPV(tmpsv, len);
4e6ea2c3 498 }
a0d0e21e 499 }
06bf62c7
GS		 500 if (!tmps || !len)
501 tmpsv = sv_2mortal(newSVpvn("Died", 4));
502
894356b3 503 DIE(aTHX_ "%"SVf, tmpsv);
a0d0e21e
LW		 504}
505
506/* I/O. */
507
508PP(pp_open)
509{
4e35701f 510 djSP; dTARGET;
a0d0e21e
LW		 511 GV *gv;
512 SV *sv;
6170680b
IZ		 513 SV *name;
514 I32 have_name = 0;
a0d0e21e
LW		 515 char *tmps;
516 STRLEN len;
4592e6ca 517 MAGIC *mg;
a0d0e21e 518
6170680b
IZ		 519 if (MAXARG > 2) {
520 name = POPs;
521 have_name = 1;
522 }
a0d0e21e
LW		 523 if (MAXARG > 1)
524 sv = POPs;
5f05dabc 525 if (!isGV(TOPs))
cea2e8a9 526 DIE(aTHX_ PL_no_usym, "filehandle");
5f05dabc 527 if (MAXARG <= 1)
528 sv = GvSV(TOPs);
a0d0e21e 529 gv = (GV*)POPs;
5f05dabc 530 if (!isGV(gv))
cea2e8a9 531 DIE(aTHX_ PL_no_usym, "filehandle");
36477c24 532 if (GvIOp(gv))
533 IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
853846ea 534
4592e6ca
NIS		 535 if (mg = SvTIED_mg((SV*)gv, 'q')) {
536 PUSHMARK(SP);
537 XPUSHs(SvTIED_obj((SV*)gv, mg));
538 XPUSHs(sv);
6170680b
IZ		 539 if (have_name)
540 XPUSHs(name);
4592e6ca
NIS		 541 PUTBACK;
542 ENTER;
864dbfa3 543 call_method("OPEN", G_SCALAR);
4592e6ca
NIS		 544 LEAVE;
545 SPAGAIN;
546 RETURN;
547 }
548
a0d0e21e 549 tmps = SvPV(sv, len);
6170680b 550 if (do_open9(gv, tmps, len, FALSE, O_RDONLY, 0, Nullfp, name, have_name))
3280af22
NIS		 551 PUSHi( (I32)PL_forkprocess );
552 else if (PL_forkprocess == 0) /* we are a new child */
a0d0e21e
LW		 553 PUSHi(0);
554 else
555 RETPUSHUNDEF;
556 RETURN;
557}
558
559PP(pp_close)
560{
4e35701f 561 djSP;
a0d0e21e 562 GV *gv;
1d603a67 563 MAGIC *mg;
a0d0e21e
LW		 564
565 if (MAXARG == 0)
3280af22 566 gv = PL_defoutgv;
a0d0e21e
LW		 567 else
568 gv = (GV*)POPs;
1d603a67 569
33c27489 570 if (mg = SvTIED_mg((SV*)gv, 'q')) {
1d603a67 571 PUSHMARK(SP);
33c27489 572 XPUSHs(SvTIED_obj((SV*)gv, mg));
1d603a67
GB		 573 PUTBACK;
574 ENTER;
864dbfa3 575 call_method("CLOSE", G_SCALAR);
1d603a67
GB		 576 LEAVE;
577 SPAGAIN;
578 RETURN;
579 }
a0d0e21e 580 EXTEND(SP, 1);
54310121 581 PUSHs(boolSV(do_close(gv, TRUE)));
a0d0e21e
LW		 582 RETURN;
583}
584
585PP(pp_pipe_op)
586{
4e35701f 587 djSP;
a0d0e21e
LW		 588#ifdef HAS_PIPE
589 GV *rgv;
590 GV *wgv;
591 register IO *rstio;
592 register IO *wstio;
593 int fd[2];
594
595 wgv = (GV*)POPs;
596 rgv = (GV*)POPs;
597
598 if (!rgv || !wgv)
599 goto badexit;
600
4633a7c4 601 if (SvTYPE(rgv) != SVt_PVGV || SvTYPE(wgv) != SVt_PVGV)
cea2e8a9 602 DIE(aTHX_ PL_no_usym, "filehandle");
a0d0e21e
LW		 603 rstio = GvIOn(rgv);
604 wstio = GvIOn(wgv);
605
606 if (IoIFP(rstio))
607 do_close(rgv, FALSE);
608 if (IoIFP(wstio))
609 do_close(wgv, FALSE);
610
6ad3d225 611 if (PerlProc_pipe(fd) < 0)
a0d0e21e
LW		 612 goto badexit;
613
760ac839
LW		 614 IoIFP(rstio) = PerlIO_fdopen(fd[0], "r");
615 IoOFP(wstio) = PerlIO_fdopen(fd[1], "w");
a0d0e21e
LW		 616 IoIFP(wstio) = IoOFP(wstio);
617 IoTYPE(rstio) = '<';
618 IoTYPE(wstio) = '>';
619
620 if (!IoIFP(rstio) || !IoOFP(wstio)) {
760ac839 621 if (IoIFP(rstio)) PerlIO_close(IoIFP(rstio));
6ad3d225 622 else PerlLIO_close(fd[0]);
760ac839 623 if (IoOFP(wstio)) PerlIO_close(IoOFP(wstio));
6ad3d225 624 else PerlLIO_close(fd[1]);
a0d0e21e
LW		 625 goto badexit;
626 }
4771b018
GS		 627#if defined(HAS_FCNTL) && defined(F_SETFD)
628 fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
629 fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
630#endif
a0d0e21e
LW		 631 RETPUSHYES;
632
633badexit:
634 RETPUSHUNDEF;
635#else
cea2e8a9 636 DIE(aTHX_ PL_no_func, "pipe");
a0d0e21e
LW		 637#endif
638}
639
640PP(pp_fileno)
641{
4e35701f 642 djSP; dTARGET;
a0d0e21e
LW		 643 GV *gv;
644 IO *io;
760ac839 645 PerlIO *fp;
4592e6ca
NIS		 646 MAGIC *mg;
647
a0d0e21e
LW		 648 if (MAXARG < 1)
649 RETPUSHUNDEF;
650 gv = (GV*)POPs;
4592e6ca
NIS		 651
652 if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
653 PUSHMARK(SP);
654 XPUSHs(SvTIED_obj((SV*)gv, mg));
655 PUTBACK;
656 ENTER;
864dbfa3 657 call_method("FILENO", G_SCALAR);
4592e6ca
NIS		 658 LEAVE;
659 SPAGAIN;
660 RETURN;
661 }
662
a0d0e21e
LW		 663 if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io)))
664 RETPUSHUNDEF;
760ac839 665 PUSHi(PerlIO_fileno(fp));
a0d0e21e
LW		 666 RETURN;
667}
668
669PP(pp_umask)
670{
4e35701f 671 djSP; dTARGET;
761237fe 672 Mode_t anum;
a0d0e21e
LW		 673
674#ifdef HAS_UMASK
675 if (MAXARG < 1) {
6ad3d225
GS		 676 anum = PerlLIO_umask(0);
677 (void)PerlLIO_umask(anum);
a0d0e21e
LW		 678 }
679 else
6ad3d225 680 anum = PerlLIO_umask(POPi);
a0d0e21e
LW		 681 TAINT_PROPER("umask");
682 XPUSHi(anum);
683#else
eec2d3df
GS		 684 /* Only DIE if trying to restrict permissions on `user' (self).
685 * Otherwise it's harmless and more useful to just return undef
686 * since 'group' and 'other' concepts probably don't exist here. */
687 if (MAXARG >= 1 && (POPi & 0700))
cea2e8a9 688 DIE(aTHX_ "umask not implemented");
6b88bc9c 689 XPUSHs(&PL_sv_undef);
a0d0e21e
LW		 690#endif
691 RETURN;
692}
693
694PP(pp_binmode)
695{
4e35701f 696 djSP;
a0d0e21e
LW		 697 GV *gv;
698 IO *io;
760ac839 699 PerlIO *fp;
4592e6ca 700 MAGIC *mg;
a0d0e21e
LW		 701
702 if (MAXARG < 1)
703 RETPUSHUNDEF;
704
4592e6ca
NIS		 705 gv = (GV*)POPs;
706
707 if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
708 PUSHMARK(SP);
709 XPUSHs(SvTIED_obj((SV*)gv, mg));
710 PUTBACK;
711 ENTER;
864dbfa3 712 call_method("BINMODE", G_SCALAR);
4592e6ca
NIS		 713 LEAVE;
714 SPAGAIN;
715 RETURN;
716 }
a0d0e21e
LW		 717
718 EXTEND(SP, 1);
719 if (!(io = GvIO(gv)) || !(fp = IoIFP(io)))
55497cff 720 RETPUSHUNDEF;
a0d0e21e 721
491527d0 722 if (do_binmode(fp,IoTYPE(io),TRUE))
a0d0e21e
LW		 723 RETPUSHYES;
724 else
725 RETPUSHUNDEF;
a0d0e21e
LW		 726}
727
b8e3bfaf 728
a0d0e21e
LW		 729PP(pp_tie)
730{
4e35701f 731 djSP;
e336de0d 732 dMARK;
a0d0e21e
LW		 733 SV *varsv;
734 HV* stash;
735 GV *gv;
a0d0e21e 736 SV *sv;
3280af22 737 I32 markoff = MARK - PL_stack_base;
a0d0e21e 738 char *methname;
6b05c17a 739 int how = 'P';
e336de0d 740 U32 items;
2d8e6c8d 741 STRLEN n_a;
a0d0e21e 742
e336de0d 743 varsv = *++MARK;
6b05c17a
NIS		 744 switch(SvTYPE(varsv)) {
745 case SVt_PVHV:
746 methname = "TIEHASH";
747 break;
748 case SVt_PVAV:
749 methname = "TIEARRAY";
750 break;
751 case SVt_PVGV:
752 methname = "TIEHANDLE";
753 how = 'q';
754 break;
755 default:
756 methname = "TIESCALAR";
757 how = 'q';
758 break;
759 }
e336de0d
GS		 760 items = SP - MARK++;
761 if (sv_isobject(*MARK)) {
6b05c17a 762 ENTER;
e788e7d3 763 PUSHSTACKi(PERLSI_MAGIC);
e336de0d
GS		 764 PUSHMARK(SP);
765 EXTEND(SP,items);
766 while (items--)
767 PUSHs(*MARK++);
768 PUTBACK;
864dbfa3 769 call_method(methname, G_SCALAR);
6b05c17a
NIS		 770 }
771 else {
864dbfa3 772 /* Not clear why we don't call call_method here too.
6b05c17a
NIS		 773 * perhaps to get different error message ?
774 */
e336de0d 775 stash = gv_stashsv(*MARK, FALSE);
6b05c17a 776 if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
cea2e8a9 777 DIE(aTHX_ "Can't locate object method \"%s\" via package \"%s\"",
2d8e6c8d 778 methname, SvPV(*MARK,n_a));
6b05c17a
NIS		 779 }
780 ENTER;
e788e7d3 781 PUSHSTACKi(PERLSI_MAGIC);
e336de0d
GS		 782 PUSHMARK(SP);
783 EXTEND(SP,items);
784 while (items--)
785 PUSHs(*MARK++);
786 PUTBACK;
864dbfa3 787 call_sv((SV*)GvCV(gv), G_SCALAR);
6b05c17a 788 }
a0d0e21e
LW		 789 SPAGAIN;
790
791 sv = TOPs;
d3acc0f7 792 POPSTACK;
a0d0e21e 793 if (sv_isobject(sv)) {
33c27489
GS		 794 sv_unmagic(varsv, how);
795 sv_magic(varsv, (SvRV(sv) == varsv ? Nullsv : sv), how, Nullch, 0);
a0d0e21e
LW		 796 }
797 LEAVE;
3280af22 798 SP = PL_stack_base + markoff;
a0d0e21e
LW		 799 PUSHs(sv);
800 RETURN;
801}
802
803PP(pp_untie)
804{
4e35701f 805 djSP;
33c27489
GS		 806 SV *sv = POPs;
807 char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) ? 'P' : 'q';
55497cff 808
599cee73 809 if (ckWARN(WARN_UNTIE)) {
cbdc8872 810 MAGIC * mg ;
33c27489 811 if (mg = SvTIED_mg(sv, how)) {
b9c39e73 812 if (mg && SvREFCNT(SvRV(mg->mg_obj)) > 1)
cf2093f6 813 Perl_warner(aTHX_ WARN_UNTIE,
57def98f 814 "untie attempted while %"UVuf" inner references still exist",
cf2093f6 815 (UV)SvREFCNT(SvRV(mg->mg_obj)) - 1 ) ;
cbdc8872 816 }
817 }
818
33c27489 819 sv_unmagic(sv, how);
55497cff 820 RETPUSHYES;
a0d0e21e
LW		 821}
822
c07a80fd 823PP(pp_tied)
824{
4e35701f 825 djSP;
33c27489
GS		 826 SV *sv = POPs;
827 char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) ? 'P' : 'q';
828 MAGIC *mg;
c07a80fd 829
33c27489
GS		 830 if (mg = SvTIED_mg(sv, how)) {
831 SV *osv = SvTIED_obj(sv, mg);
832 if (osv == mg->mg_obj)
833 osv = sv_mortalcopy(osv);
834 PUSHs(osv);
835 RETURN;
c07a80fd 836 }
c07a80fd 837 RETPUSHUNDEF;
838}
839
a0d0e21e
LW		 840PP(pp_dbmopen)
841{
4e35701f 842 djSP;
a0d0e21e
LW		 843 HV *hv;
844 dPOPPOPssrl;
845 HV* stash;
846 GV *gv;
a0d0e21e
LW		 847 SV *sv;
848
849 hv = (HV*)POPs;
850
3280af22 851 sv = sv_mortalcopy(&PL_sv_no);
a0d0e21e
LW		 852 sv_setpv(sv, "AnyDBM_File");
853 stash = gv_stashsv(sv, FALSE);
8ebc5c01 854 if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
a0d0e21e 855 PUTBACK;
864dbfa3 856 require_pv("AnyDBM_File.pm");
a0d0e21e 857 SPAGAIN;
8ebc5c01 858 if (!(gv = gv_fetchmethod(stash, "TIEHASH")))
cea2e8a9 859 DIE(aTHX_ "No dbm on this machine");
a0d0e21e
LW		 860 }
861
57d3b86d 862 ENTER;
924508f0 863 PUSHMARK(SP);
6b05c17a 864
924508f0 865 EXTEND(SP, 5);
a0d0e21e
LW		 866 PUSHs(sv);
867 PUSHs(left);
868 if (SvIV(right))
869 PUSHs(sv_2mortal(newSViv(O_RDWR|O_CREAT)));
870 else
871 PUSHs(sv_2mortal(newSViv(O_RDWR)));
872 PUSHs(right);
57d3b86d 873 PUTBACK;
864dbfa3 874 call_sv((SV*)GvCV(gv), G_SCALAR);
a0d0e21e
LW		 875 SPAGAIN;
876
877 if (!sv_isobject(TOPs)) {
924508f0
GS		 878 SP--;
879 PUSHMARK(SP);
a0d0e21e
LW		 880 PUSHs(sv);
881 PUSHs(left);
882 PUSHs(sv_2mortal(newSViv(O_RDONLY)));
883 PUSHs(right);
a0d0e21e 884 PUTBACK;
864dbfa3 885 call_sv((SV*)GvCV(gv), G_SCALAR);
a0d0e21e
LW		 886 SPAGAIN;
887 }
888
6b05c17a
NIS		 889 if (sv_isobject(TOPs)) {
890 sv_unmagic((SV *) hv, 'P');
a0d0e21e 891 sv_magic((SV*)hv, TOPs, 'P', Nullch, 0);
6b05c17a 892 }
a0d0e21e
LW		 893 LEAVE;
894 RETURN;
895}
896
897PP(pp_dbmclose)
898{
cea2e8a9 899 return pp_untie();
a0d0e21e
LW		 900}
901
902PP(pp_sselect)
903{
4e35701f 904 djSP; dTARGET;
a0d0e21e
LW		 905#ifdef HAS_SELECT
906 register I32 i;
907 register I32 j;
908 register char *s;
909 register SV *sv;
65202027 910 NV value;
a0d0e21e
LW		 911 I32 maxlen = 0;
912 I32 nfound;
913 struct timeval timebuf;
914 struct timeval *tbuf = &timebuf;
915 I32 growsize;
916 char *fd_sets[4];
2d8e6c8d 917 STRLEN n_a;
a0d0e21e
LW		 918#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
919 I32 masksize;
920 I32 offset;
921 I32 k;
922
923# if BYTEORDER & 0xf0000
924# define ORDERBYTE (0x88888888 - BYTEORDER)
925# else
926# define ORDERBYTE (0x4444 - BYTEORDER)
927# endif
928
929#endif
930
931 SP -= 4;
932 for (i = 1; i <= 3; i++) {
933 if (!SvPOK(SP[i]))
934 continue;
935 j = SvCUR(SP[i]);
936 if (maxlen < j)
937 maxlen = j;
938 }
939
5ff3f7a4 940/* little endians can use vecs directly */
a0d0e21e 941#if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
5ff3f7a4 942# if SELECT_MIN_BITS > 1
f2da832e
JH		 943 /* If SELECT_MIN_BITS is greater than one we most probably will want
944 * to align the sizes with SELECT_MIN_BITS/8 because for example
945 * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
8f1f23e8
W		 946 * UNIX, Solaris, NeXT, Rhapsody) the smallest quantum select() operates
947 * on (sets/tests/clears bits) is 32 bits. */
f2da832e 948 growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
5ff3f7a4 949# else
4633a7c4 950 growsize = sizeof(fd_set);
5ff3f7a4
GS		 951# endif
952# else
953# ifdef NFDBITS
a0d0e21e 954
5ff3f7a4
GS		 955# ifndef NBBY
956# define NBBY 8
957# endif
a0d0e21e
LW		 958
959 masksize = NFDBITS / NBBY;
5ff3f7a4 960# else
a0d0e21e 961 masksize = sizeof(long); /* documented int, everyone seems to use long */
5ff3f7a4 962# endif
a0d0e21e
LW		 963 growsize = maxlen + (masksize - (maxlen % masksize));
964 Zero(&fd_sets[0], 4, char*);
965#endif
966
967 sv = SP[4];
968 if (SvOK(sv)) {
969 value = SvNV(sv);
970 if (value < 0.0)
971 value = 0.0;
972 timebuf.tv_sec = (long)value;
65202027 973 value -= (NV)timebuf.tv_sec;
a0d0e21e
LW		 974 timebuf.tv_usec = (long)(value * 1000000.0);
975 }
976 else
977 tbuf = Null(struct timeval*);
978
979 for (i = 1; i <= 3; i++) {
980 sv = SP[i];
981 if (!SvOK(sv)) {
982 fd_sets[i] = 0;
983 continue;
984 }
985 else if (!SvPOK(sv))
2d8e6c8d 986 SvPV_force(sv,n_a); /* force string conversion */
a0d0e21e
LW		 987 j = SvLEN(sv);
988 if (j < growsize) {
989 Sv_Grow(sv, growsize);
a0d0e21e 990 }
c07a80fd 991 j = SvCUR(sv);
992 s = SvPVX(sv) + j;
993 while (++j <= growsize) {
994 *s++ = '\0';
995 }
996
a0d0e21e
LW		 997#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
998 s = SvPVX(sv);
999 New(403, fd_sets[i], growsize, char);
1000 for (offset = 0; offset < growsize; offset += masksize) {
1001 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1002 fd_sets[i][j+offset] = s[(k % masksize) + offset];
1003 }
1004#else
1005 fd_sets[i] = SvPVX(sv);
1006#endif
1007 }
1008
6ad3d225 1009 nfound = PerlSock_select(
a0d0e21e
LW		 1010 maxlen * 8,
1011 (Select_fd_set_t) fd_sets[1],
1012 (Select_fd_set_t) fd_sets[2],
1013 (Select_fd_set_t) fd_sets[3],
1014 tbuf);
1015 for (i = 1; i <= 3; i++) {
1016 if (fd_sets[i]) {
1017 sv = SP[i];
1018#if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1019 s = SvPVX(sv);
1020 for (offset = 0; offset < growsize; offset += masksize) {
1021 for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1022 s[(k % masksize) + offset] = fd_sets[i][j+offset];
1023 }
1024 Safefree(fd_sets[i]);
1025#endif
1026 SvSETMAGIC(sv);
1027 }
1028 }
1029
1030 PUSHi(nfound);
1031 if (GIMME == G_ARRAY && tbuf) {
65202027
DS		 1032 value = (NV)(timebuf.tv_sec) +
1033 (NV)(timebuf.tv_usec) / 1000000.0;
3280af22 1034 PUSHs(sv = sv_mortalcopy(&PL_sv_no));
a0d0e21e
LW		 1035 sv_setnv(sv, value);
1036 }
1037 RETURN;
1038#else
cea2e8a9 1039 DIE(aTHX_ "select not implemented");
a0d0e21e
LW		 1040#endif
1041}
1042
4633a7c4 1043void
864dbfa3 1044Perl_setdefout(pTHX_ GV *gv)
4633a7c4 1045{
11343788 1046 dTHR;
4633a7c4
LW		 1047 if (gv)
1048 (void)SvREFCNT_inc(gv);
3280af22
NIS		 1049 if (PL_defoutgv)
1050 SvREFCNT_dec(PL_defoutgv);
1051 PL_defoutgv = gv;
4633a7c4
LW		 1052}
1053
a0d0e21e
LW		 1054PP(pp_select)
1055{
4e35701f 1056 djSP; dTARGET;
4633a7c4
LW		 1057 GV *newdefout, *egv;
1058 HV *hv;
1059
533c011a 1060 newdefout = (PL_op->op_private > 0) ? ((GV *) POPs) : (GV *) NULL;
4633a7c4 1061
3280af22 1062 egv = GvEGV(PL_defoutgv);
4633a7c4 1063 if (!egv)
3280af22 1064 egv = PL_defoutgv;
4633a7c4
LW		 1065 hv = GvSTASH(egv);
1066 if (! hv)
3280af22 1067 XPUSHs(&PL_sv_undef);
4633a7c4 1068 else {
cbdc8872 1069 GV **gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
f86702cc 1070 if (gvp && *gvp == egv) {
3280af22 1071 gv_efullname3(TARG, PL_defoutgv, Nullch);
f86702cc 1072 XPUSHTARG;
1073 }
1074 else {
1075 XPUSHs(sv_2mortal(newRV((SV*)egv)));
1076 }
4633a7c4
LW		 1077 }
1078
1079 if (newdefout) {
ded8aa31
GS		 1080 if (!GvIO(newdefout))
1081 gv_IOadd(newdefout);
4633a7c4
LW		 1082 setdefout(newdefout);
1083 }
1084
a0d0e21e
LW		 1085 RETURN;
1086}
1087
1088PP(pp_getc)
1089{
4e35701f 1090 djSP; dTARGET;
a0d0e21e 1091 GV *gv;
2ae324a7 1092 MAGIC *mg;
a0d0e21e
LW		 1093
1094 if (MAXARG <= 0)
3280af22 1095 gv = PL_stdingv;
a0d0e21e
LW		 1096 else
1097 gv = (GV*)POPs;
2ae324a7 1098
33c27489 1099 if (mg = SvTIED_mg((SV*)gv, 'q')) {
54310121 1100 I32 gimme = GIMME_V;
2ae324a7 1101 PUSHMARK(SP);
33c27489 1102 XPUSHs(SvTIED_obj((SV*)gv, mg));
2ae324a7 1103 PUTBACK;
1104 ENTER;
864dbfa3 1105 call_method("GETC", gimme);
2ae324a7 1106 LEAVE;
1107 SPAGAIN;
54310121 1108 if (gimme == G_SCALAR)
1109 SvSetMagicSV_nosteal(TARG, TOPs);
2ae324a7 1110 RETURN;
1111 }
9bc64814 1112 if (!gv || do_eof(gv)) /* make sure we have fp with something */
a0d0e21e 1113 RETPUSHUNDEF;
bbce6d69 1114 TAINT;
a0d0e21e 1115 sv_setpv(TARG, " ");
9bc64814 1116 *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
a0d0e21e
LW		 1117 PUSHTARG;
1118 RETURN;
1119}
1120
1121PP(pp_read)
1122{
cea2e8a9 1123 return pp_sysread();
a0d0e21e
LW		 1124}
1125
76e3520e 1126STATIC OP *
cea2e8a9 1127S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
a0d0e21e 1128{
11343788 1129 dTHR;
c09156bb 1130 register PERL_CONTEXT *cx;
54310121 1131 I32 gimme = GIMME_V;
a0d0e21e
LW		 1132 AV* padlist = CvPADLIST(cv);
1133 SV** svp = AvARRAY(padlist);
1134
1135 ENTER;
1136 SAVETMPS;
1137
1138 push_return(retop);
7766f137 1139 PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
a0d0e21e 1140 PUSHFORMAT(cx);
7766f137 1141 SAVEVPTR(PL_curpad);
3280af22 1142 PL_curpad = AvARRAY((AV*)svp[1]);
a0d0e21e 1143
4633a7c4 1144 setdefout(gv); /* locally select filehandle so $% et al work */
a0d0e21e
LW		 1145 return CvSTART(cv);
1146}
1147
1148PP(pp_enterwrite)
1149{
4e35701f 1150 djSP;
a0d0e21e
LW		 1151 register GV *gv;
1152 register IO *io;
1153 GV *fgv;
1154 CV *cv;
1155
1156 if (MAXARG == 0)
3280af22 1157 gv = PL_defoutgv;
a0d0e21e
LW		 1158 else {
1159 gv = (GV*)POPs;
1160 if (!gv)
3280af22 1161 gv = PL_defoutgv;
a0d0e21e
LW		 1162 }
1163 EXTEND(SP, 1);
1164 io = GvIO(gv);
1165 if (!io) {
1166 RETPUSHNO;
1167 }
1168 if (IoFMT_GV(io))
1169 fgv = IoFMT_GV(io);
1170 else
1171 fgv = gv;
1172
1173 cv = GvFORM(fgv);
a0d0e21e
LW		 1174 if (!cv) {
1175 if (fgv) {
748a9306 1176 SV *tmpsv = sv_newmortal();
aac0dd9a 1177 gv_efullname3(tmpsv, fgv, Nullch);
cea2e8a9 1178 DIE(aTHX_ "Undefined format \"%s\" called",SvPVX(tmpsv));
a0d0e21e 1179 }
cea2e8a9 1180 DIE(aTHX_ "Not a format reference");
a0d0e21e 1181 }
44a8e56a 1182 if (CvCLONE(cv))
1183 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
a0d0e21e 1184
44a8e56a 1185 IoFLAGS(io) &= ~IOf_DIDTOP;
533c011a 1186 return doform(cv,gv,PL_op->op_next);
a0d0e21e
LW		 1187}
1188
1189PP(pp_leavewrite)
1190{
4e35701f 1191 djSP;
a0d0e21e
LW		 1192 GV *gv = cxstack[cxstack_ix].blk_sub.gv;
1193 register IO *io = GvIOp(gv);
760ac839
LW		 1194 PerlIO *ofp = IoOFP(io);
1195 PerlIO *fp;
a0d0e21e
LW		 1196 SV **newsp;
1197 I32 gimme;
c09156bb 1198 register PERL_CONTEXT *cx;
a0d0e21e 1199
760ac839 1200 DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
3280af22
NIS		 1201 (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1202 if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
1203 PL_formtarget != PL_toptarget)
a0d0e21e 1204 {
4633a7c4
LW		 1205 GV *fgv;
1206 CV *cv;
a0d0e21e
LW		 1207 if (!IoTOP_GV(io)) {
1208 GV *topgv;
46fc3d4c 1209 SV *topname;
a0d0e21e
LW		 1210
1211 if (!IoTOP_NAME(io)) {
1212 if (!IoFMT_NAME(io))
1213 IoFMT_NAME(io) = savepv(GvNAME(gv));
cea2e8a9 1214 topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%s_TOP", IoFMT_NAME(io)));
46fc3d4c 1215 topgv = gv_fetchpv(SvPVX(topname), FALSE, SVt_PVFM);
748a9306 1216 if ((topgv && GvFORM(topgv)) ||
a0d0e21e 1217 !gv_fetchpv("top",FALSE,SVt_PVFM))
46fc3d4c 1218 IoTOP_NAME(io) = savepv(SvPVX(topname));
a0d0e21e
LW		 1219 else
1220 IoTOP_NAME(io) = savepv("top");
1221 }
1222 topgv = gv_fetchpv(IoTOP_NAME(io),FALSE, SVt_PVFM);
1223 if (!topgv || !GvFORM(topgv)) {
1224 IoLINES_LEFT(io) = 100000000;
1225 goto forget_top;
1226 }
1227 IoTOP_GV(io) = topgv;
1228 }
748a9306
LW		 1229 if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1230 I32 lines = IoLINES_LEFT(io);
3280af22 1231 char *s = SvPVX(PL_formtarget);
8e07c86e
AD		 1232 if (lines <= 0) /* Yow, header didn't even fit!!! */
1233 goto forget_top;
748a9306
LW		 1234 while (lines-- > 0) {
1235 s = strchr(s, '\n');
1236 if (!s)
1237 break;
1238 s++;
1239 }
1240 if (s) {
3280af22
NIS		 1241 PerlIO_write(ofp, SvPVX(PL_formtarget), s - SvPVX(PL_formtarget));
1242 sv_chop(PL_formtarget, s);
1243 FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
748a9306
LW		 1244 }
1245 }
a0d0e21e 1246 if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
3280af22 1247 PerlIO_write(ofp, SvPVX(PL_formfeed), SvCUR(PL_formfeed));
a0d0e21e
LW		 1248 IoLINES_LEFT(io) = IoPAGE_LEN(io);
1249 IoPAGE(io)++;
3280af22 1250 PL_formtarget = PL_toptarget;
748a9306 1251 IoFLAGS(io) |= IOf_DIDTOP;
4633a7c4
LW		 1252 fgv = IoTOP_GV(io);
1253 if (!fgv)
cea2e8a9 1254 DIE(aTHX_ "bad top format reference");
4633a7c4
LW		 1255 cv = GvFORM(fgv);
1256 if (!cv) {
1257 SV *tmpsv = sv_newmortal();
aac0dd9a 1258 gv_efullname3(tmpsv, fgv, Nullch);
cea2e8a9 1259 DIE(aTHX_ "Undefined top format \"%s\" called",SvPVX(tmpsv));
4633a7c4 1260 }
44a8e56a 1261 if (CvCLONE(cv))
1262 cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
533c011a 1263 return doform(cv,gv,PL_op);
a0d0e21e
LW		 1264 }
1265
1266 forget_top:
3280af22 1267 POPBLOCK(cx,PL_curpm);
a0d0e21e
LW		 1268 POPFORMAT(cx);
1269 LEAVE;
1270
1271 fp = IoOFP(io);
1272 if (!fp) {
599cee73 1273 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
69282e91
GS		 1274 if (IoIFP(io)) {
1275 SV* sv = sv_newmortal();
1276 gv_efullname3(sv, gv, Nullch);
af8c498a
GS		 1277 Perl_warner(aTHX_ WARN_IO,
1278 "Filehandle %s opened only for input",
1279 SvPV_nolen(sv));
69282e91 1280 }
599cee73 1281 else if (ckWARN(WARN_CLOSED))
69282e91 1282 report_closed_fh(gv, io, "write", "filehandle");
a0d0e21e 1283 }
3280af22 1284 PUSHs(&PL_sv_no);
a0d0e21e
LW		 1285 }
1286 else {
3280af22 1287 if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
599cee73 1288 if (ckWARN(WARN_IO))
cea2e8a9 1289 Perl_warner(aTHX_ WARN_IO, "page overflow");
a0d0e21e 1290 }
3280af22 1291 if (!PerlIO_write(ofp, SvPVX(PL_formtarget), SvCUR(PL_formtarget)) ||
760ac839 1292 PerlIO_error(fp))
3280af22 1293 PUSHs(&PL_sv_no);
a0d0e21e 1294 else {
3280af22
NIS		 1295 FmLINES(PL_formtarget) = 0;
1296 SvCUR_set(PL_formtarget, 0);
1297 *SvEND(PL_formtarget) = '\0';
a0d0e21e 1298 if (IoFLAGS(io) & IOf_FLUSH)
760ac839 1299 (void)PerlIO_flush(fp);
3280af22 1300 PUSHs(&PL_sv_yes);
a0d0e21e
LW		 1301 }
1302 }
3280af22 1303 PL_formtarget = PL_bodytarget;
a0d0e21e
LW		 1304 PUTBACK;
1305 return pop_return();
1306}
1307
1308PP(pp_prtf)
1309{
4e35701f 1310 djSP; dMARK; dORIGMARK;
a0d0e21e
LW		 1311 GV *gv;
1312 IO *io;
760ac839 1313 PerlIO *fp;
26db47c4 1314 SV *sv;
46fc3d4c 1315 MAGIC *mg;
2d8e6c8d 1316 STRLEN n_a;
a0d0e21e 1317
533c011a 1318 if (PL_op->op_flags & OPf_STACKED)
a0d0e21e
LW		 1319 gv = (GV*)*++MARK;
1320 else
3280af22 1321 gv = PL_defoutgv;
46fc3d4c 1322
33c27489 1323 if (mg = SvTIED_mg((SV*)gv, 'q')) {
46fc3d4c 1324 if (MARK == ORIGMARK) {
4352c267 1325 MEXTEND(SP, 1);
46fc3d4c 1326 ++MARK;
1327 Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1328 ++SP;
1329 }
1330 PUSHMARK(MARK - 1);
33c27489 1331 *MARK = SvTIED_obj((SV*)gv, mg);
46fc3d4c 1332 PUTBACK;
1333 ENTER;
864dbfa3 1334 call_method("PRINTF", G_SCALAR);
46fc3d4c 1335 LEAVE;
1336 SPAGAIN;
1337 MARK = ORIGMARK + 1;
1338 *MARK = *SP;
1339 SP = MARK;
1340 RETURN;
1341 }
1342
26db47c4 1343 sv = NEWSV(0,0);
a0d0e21e 1344 if (!(io = GvIO(gv))) {
599cee73 1345 if (ckWARN(WARN_UNOPENED)) {
af8c498a
GS		 1346 gv_efullname3(sv, gv, Nullch);
1347 Perl_warner(aTHX_ WARN_UNOPENED,
1348 "Filehandle %s never opened", SvPV(sv,n_a));
748a9306
LW		 1349 }
1350 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW		 1351 goto just_say_no;
1352 }
1353 else if (!(fp = IoOFP(io))) {
599cee73 1354 if (ckWARN2(WARN_CLOSED,WARN_IO)) {
69282e91
GS		 1355 if (IoIFP(io)) {
1356 gv_efullname3(sv, gv, Nullch);
af8c498a
GS		 1357 Perl_warner(aTHX_ WARN_IO,
1358 "Filehandle %s opened only for input",
1359 SvPV(sv,n_a));
69282e91 1360 }
599cee73 1361 else if (ckWARN(WARN_CLOSED))
69282e91 1362 report_closed_fh(gv, io, "printf", "filehandle");
a0d0e21e 1363 }
748a9306 1364 SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
a0d0e21e
LW		 1365 goto just_say_no;
1366 }
1367 else {
1368 do_sprintf(sv, SP - MARK, MARK + 1);
1369 if (!do_print(sv, fp))
1370 goto just_say_no;
1371
1372 if (IoFLAGS(io) & IOf_FLUSH)
760ac839 1373 if (PerlIO_flush(fp) == EOF)
a0d0e21e
LW		 1374 goto just_say_no;
1375 }
1376 SvREFCNT_dec(sv);
1377 SP = ORIGMARK;
3280af22 1378 PUSHs(&PL_sv_yes);
a0d0e21e
LW		 1379 RETURN;
1380
1381 just_say_no:
1382 SvREFCNT_dec(sv);
1383 SP = ORIGMARK;
3280af22 1384 PUSHs(&PL_sv_undef);
a0d0e21e
LW		 1385 RETURN;
1386}
1387
c07a80fd 1388PP(pp_sysopen)
1389{
4e35701f 1390 djSP;
c07a80fd 1391 GV *gv;
c07a80fd 1392 SV *sv;
1393 char *tmps;
1394 STRLEN len;
1395 int mode, perm;
1396
1397 if (MAXARG > 3)
1398 perm = POPi;
1399 else
1400 perm = 0666;
1401 mode = POPi;
1402 sv = POPs;
1403 gv = (GV *)POPs;
1404
4592e6ca
NIS		 1405 /* Need TIEHANDLE method ? */
1406
c07a80fd 1407 tmps = SvPV(sv, len);
1408 if (do_open(gv, tmps, len, TRUE, mode, perm, Nullfp)) {
1409 IoLINES(GvIOp(gv)) = 0;
3280af22 1410 PUSHs(&PL_sv_yes);
c07a80fd 1411 }
1412 else {
3280af22 1413 PUSHs(&PL_sv_undef);
c07a80fd 1414 }
1415 RETURN;
1416}
1417
a0d0e21e
LW		 1418PP(pp_sysread)
1419{
4e35701f 1420 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 1421 int offset;
1422 GV *gv;
1423 IO *io;
1424 char *buffer;
5b54f415 1425 SSize_t length;
1e422769 1426 Sock_size_t bufsize;
748a9306 1427 SV *bufsv;
a0d0e21e 1428 STRLEN blen;
2ae324a7 1429 MAGIC *mg;
a0d0e21e
LW		 1430
1431 gv = (GV*)*++MARK;
533c011a 1432 if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD) &&
33c27489 1433 (mg = SvTIED_mg((SV*)gv, 'q')))
137443ea 1434 {
2ae324a7 1435 SV *sv;
1436
1437 PUSHMARK(MARK-1);
33c27489 1438 *MARK = SvTIED_obj((SV*)gv, mg);
2ae324a7 1439 ENTER;
864dbfa3 1440 call_method("READ", G_SCALAR);
2ae324a7 1441 LEAVE;
1442 SPAGAIN;
1443 sv = POPs;
1444 SP = ORIGMARK;
1445 PUSHs(sv);
1446 RETURN;
1447 }
1448
a0d0e21e
LW		 1449 if (!gv)
1450 goto say_undef;
748a9306 1451 bufsv = *++MARK;
ff68c719 1452 if (! SvOK(bufsv))
1453 sv_setpvn(bufsv, "", 0);
748a9306 1454 buffer = SvPV_force(bufsv, blen);
a0d0e21e
LW		 1455 length = SvIVx(*++MARK);
1456 if (length < 0)
cea2e8a9 1457 DIE(aTHX_ "Negative length");
748a9306 1458 SETERRNO(0,0);
a0d0e21e
LW		 1459 if (MARK < SP)
1460 offset = SvIVx(*++MARK);
1461 else
1462 offset = 0;
1463 io = GvIO(gv);
1464 if (!io || !IoIFP(io))
1465 goto say_undef;
1466#ifdef HAS_SOCKET
533c011a 1467 if (PL_op->op_type == OP_RECV) {
46fc3d4c 1468 char namebuf[MAXPATHLEN];
eec2d3df 1469#if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(MPE)
490ab354
JH		 1470 bufsize = sizeof (struct sockaddr_in);
1471#else
46fc3d4c 1472 bufsize = sizeof namebuf;
490ab354 1473#endif
abf95952
IZ		 1474#ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1475 if (bufsize >= 256)
1476 bufsize = 255;
1477#endif
626727d5
GS		 1478#ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1479 if (bufsize >= 256)
1480 bufsize = 255;
1481#endif
748a9306 1482 buffer = SvGROW(bufsv, length+1);
bbce6d69 1483 /* 'offset' means 'flags' here */
6ad3d225 1484 length = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
46fc3d4c 1485 (struct sockaddr *)namebuf, &bufsize);
a0d0e21e
LW		 1486 if (length < 0)
1487 RETPUSHUNDEF;
748a9306
LW		 1488 SvCUR_set(bufsv, length);
1489 *SvEND(bufsv) = '\0';
1490 (void)SvPOK_only(bufsv);
1491 SvSETMAGIC(bufsv);
aac0dd9a 1492 /* This should not be marked tainted if the fp is marked clean */
bbce6d69 1493 if (!(IoFLAGS(io) & IOf_UNTAINT))
1494 SvTAINTED_on(bufsv);
a0d0e21e 1495 SP = ORIGMARK;
46fc3d4c 1496 sv_setpvn(TARG, namebuf, bufsize);
a0d0e21e
LW		 1497 PUSHs(TARG);
1498 RETURN;
1499 }
1500#else
911d147d 1501 if (PL_op->op_type == OP_RECV)
cea2e8a9 1502 DIE(aTHX_ PL_no_sock_func, "recv");
a0d0e21e 1503#endif
bbce6d69 1504 if (offset < 0) {
1505 if (-offset > blen)
cea2e8a9 1506 DIE(aTHX_ "Offset outside string");
bbce6d69 1507 offset += blen;
1508 }
cd52b7b2 1509 bufsize = SvCUR(bufsv);
748a9306 1510 buffer = SvGROW(bufsv, length+offset+1);
cd52b7b2 1511 if (offset > bufsize) { /* Zero any newly allocated space */
1512 Zero(buffer+bufsize, offset-bufsize, char);
1513 }
533c011a 1514 if (PL_op->op_type == OP_SYSREAD) {
a7092146
GS		 1515#ifdef PERL_SOCK_SYSREAD_IS_RECV
1516 if (IoTYPE(io) == 's') {
1517 length = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
1518 buffer+offset, length, 0);
1519 }
1520 else
1521#endif
1522 {
1523 length = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
1524 buffer+offset, length);
1525 }
a0d0e21e
LW		 1526 }
1527 else
1528#ifdef HAS_SOCKET__bad_code_maybe
1529 if (IoTYPE(io) == 's') {
46fc3d4c 1530 char namebuf[MAXPATHLEN];
490ab354
JH		 1531#if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
1532 bufsize = sizeof (struct sockaddr_in);
1533#else
46fc3d4c 1534 bufsize = sizeof namebuf;
490ab354 1535#endif
6ad3d225 1536 length = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer+offset, length, 0,
46fc3d4c 1537 (struct sockaddr *)namebuf, &bufsize);
a0d0e21e
LW		 1538 }
1539 else
1540#endif
3b02c43c 1541 {
760ac839 1542 length = PerlIO_read(IoIFP(io), buffer+offset, length);
3b02c43c 1543 /* fread() returns 0 on both error and EOF */
5c7a8c78 1544 if (length == 0 && PerlIO_error(IoIFP(io)))
3b02c43c
GS		 1545 length = -1;
1546 }
af8c498a 1547 if (length < 0) {
767a6a26
PM		 1548 if ((IoTYPE(io) == '>' || IoIFP(io) == PerlIO_stdout()
1549 || IoIFP(io) == PerlIO_stderr()) && ckWARN(WARN_IO))
af8c498a
GS		 1550 {
1551 SV* sv = sv_newmortal();
1552 gv_efullname3(sv, gv, Nullch);
1553 Perl_warner(aTHX_ WARN_IO, "Filehandle %s opened only for output",
1554 SvPV_nolen(sv));
1555 }
a0d0e21e 1556 goto say_undef;
af8c498a 1557 }
748a9306
LW		 1558 SvCUR_set(bufsv, length+offset);
1559 *SvEND(bufsv) = '\0';
1560 (void)SvPOK_only(bufsv);
1561 SvSETMAGIC(bufsv);
aac0dd9a 1562 /* This should not be marked tainted if the fp is marked clean */
bbce6d69 1563 if (!(IoFLAGS(io) & IOf_UNTAINT))
1564 SvTAINTED_on(bufsv);
a0d0e21e
LW		 1565 SP = ORIGMARK;
1566 PUSHi(length);
1567 RETURN;
1568
1569 say_undef:
1570 SP = ORIGMARK;
1571 RETPUSHUNDEF;
1572}
1573
1574PP(pp_syswrite)
1575{
092bebab
JH		 1576 djSP;
1577 int items = (SP - PL_stack_base) - TOPMARK;
1578 if (items == 2) {
9f089d78 1579 SV *sv;
092bebab 1580 EXTEND(SP, 1);
9f089d78
SB		 1581 sv = sv_2mortal(newSViv(sv_len(*SP)));
1582 PUSHs(sv);
092bebab
JH		 1583 PUTBACK;
1584 }
cea2e8a9 1585 return pp_send();
a0d0e21e
LW		 1586}
1587
1588PP(pp_send)
1589{
4e35701f 1590 djSP; dMARK; dORIGMARK; dTARGET;
a0d0e21e
LW		 1591 GV *gv;
1592 IO *io;
1eeb0f31 1593 Off_t offset;
748a9306 1594 SV *bufsv;
a0d0e21e 1595 char *buffer;
1eeb0f31 1596 Off_t length;
a0d0e21e 1597 STRLEN blen;
1d603a67 1598 MAGIC *mg;
a0d0e21e
LW		 1599
1600 gv = (GV*)*++MARK;
33c27489 1601 if (PL_op->op_type == OP_SYSWRITE && (mg = SvTIED_mg((SV*)gv, 'q'))) {
1d603a67
GB		 1602 SV *sv;
1603
1604 PUSHMARK(MARK-1);
33c27489 1605 *MARK = SvTIED_obj((SV*)gv, mg);
1d603a67 1606 ENTER;
864dbfa3 1607 call_method("WRITE", G_SCALAR);
1d603a67
GB		 1608 LEAVE;
1609 SPAGAIN;
1610 sv = POPs;
1611 SP = ORIGMARK;
1612 PUSHs(sv);
1613 RETURN;
1614 }
a0d0e21e
LW		 1615 if (!gv)
1616 goto say_undef;
748a9306
LW		 1617 bufsv = *++MARK;
1618 buffer = SvPV(bufsv, blen);
1eeb0f31
JH		 1619#if Off_t_SIZE > IVSIZE
1620 length = SvNVx(*++MARK);
1621#else
a0d0e21e 1622 length = SvIVx(*++MARK);
1eeb0f31 1623#endif
a0d0e21e 1624 if (length < 0)
cea2e8a9 1625 DIE(aTHX_ "Negative length");
748a9306 1626 SETERRNO(0,0);
a0d0e21e
LW		 1627 io = GvIO(gv);
1628 if (!io || !IoIFP(io)) {
1629 length = -1;
599cee73 1630 if (ckWARN(WARN_CLOSED)) {
533c011a 1631 if (PL_op->op_type == OP_SYSWRITE)
69282e91 1632 report_closed_fh(gv, io, "syswrite", "filehandle");
a0d0e21e 1633 else
69282e91 1634 report_closed_fh(gv, io, "send", "socket");
a0d0e21e
LW		 1635 }
1636 }
533c011a 1637 else if (PL_op->op_type == OP_SYSWRITE) {
bbce6d69 1638 if (MARK < SP) {
1eeb0f31
JH		 1639#if Off_t_SIZE > IVSIZE
1640 offset = SvNVx(*++MARK);
1641#else
a0d0e21e 1642 offset = SvIVx(*++MARK);
1eeb0f31 1643#endif
bbce6d69 1644 if (offset < 0) {
1645 if (-offset > blen)
cea2e8a9 1646 DIE(aTHX_ "Offset outside string");
bbce6d69 1647 offset += blen;
fb73857a 1648 } else if (offset >= blen && blen > 0)
cea2e8a9 1649 DIE(aTHX_ "Offset outside string");
bbce6d69 1650 } else
a0d0e21e
LW		 1651 offset = 0;
1652 if (length > blen - offset)
1653 length = blen - offset;
a7092146
GS		 1654#ifdef PERL_SOCK_SYSWRITE_IS_SEND
1655 if (IoTYPE(io) == 's') {
1656 length = PerlSock_send(PerlIO_fileno(IoIFP(io)),
1657 buffer+offset, length, 0);
1658 }
1659 else
1660#endif
1661 {
94e4c244 1662 /* See the note at doio.c:do_print about filesize limits. --jhi */
a7092146
GS		 1663 length = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
1664 buffer+offset, length);
1665 }
a0d0e21e
LW		 1666 }
1667#ifdef HAS_SOCKET
1668 else if (SP > MARK) {
1669 char *sockbuf;
1670 STRLEN mlen;
1671 sockbuf = SvPVx(*++MARK, mlen);
6ad3d225 1672 length = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen, length,
a0d0e21e
LW		 1673 (struct sockaddr *)sockbuf, mlen);
1674 }
1675 else
6ad3d225 1676 length = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, length);
490ab354 1677
a0d0e21e
LW		 1678#else
1679 else
cea2e8a9 1680 DIE(aTHX_ PL_no_sock_func, "send");
a0d0e21e
LW		 1681#endif
1682 if (length < 0)
1683 goto say_undef;
1684 SP = ORIGMARK;
1685 PUSHi(length);
1686 RETURN;
1687
1688 say_undef:
1689 SP = ORIGMARK;
1690 RETPUSHUNDEF;
1691}
1692
1693PP(pp_recv)
1694{
cea2e8a9 1695 return pp_sysread();
a0d0e21e
LW		 1696}
1697
1698PP(pp_eof)
1699{
4e35701f 1700 djSP;
a0d0e21e 1701 GV *gv;
4592e6ca 1702 MAGIC *mg;
a0d0e21e 1703
db7ec623
GS		 1704 if (MAXARG <= 0) {
1705 if (PL_op->op_flags & OPf_SPECIAL) { /* eof() */
1706 IO *io;
1707 gv = PL_last_in_gv = PL_argvgv;
1708 io = GvIO(gv);
1709 if (io && !IoIFP(io)) {
1710 if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
1711 IoLINES(io) = 0;
1712 IoFLAGS(io) &= ~IOf_START;
1713 do_open(gv, "-", 1, FALSE, O_RDONLY, 0, Nullfp);
1714 sv_setpvn(GvSV(gv), "-", 1);
1715 SvSETMAGIC(GvSV(gv));
1716 }
1717 else if (!nextargv(gv))
1718 RETPUSHYES;
1719 }
1720 }
1721 else
1722 gv = PL_last_in_gv; /* eof */
1723 }
a0d0e21e 1724 else
db7ec623 1725 gv = PL_last_in_gv = (GV*)POPs; /* eof(FH) */
4592e6ca
NIS		 1726
1727 if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
1728 PUSHMARK(SP);
1729 XPUSHs(SvTIED_obj((SV*)gv, mg));
1730 PUTBACK;
1731 ENTER;
864dbfa3 1732 call_method("EOF", G_SCALAR);
4592e6ca
NIS		 1733 LEAVE;
1734 SPAGAIN;
1735 RETURN;
1736 }
1737
54310121 1738 PUSHs(boolSV(!gv || do_eof(gv)));
a0d0e21e
LW		 1739 RETURN;
1740}
1741
1742PP(pp_tell)
1743{
4e35701f 1744 djSP; dTARGET;
4592e6ca
NIS		 1745 GV *gv;
1746 MAGIC *mg;
a0d0e21e
LW		 1747
1748 if (MAXARG <= 0)
3280af22 1749 gv = PL_last_in_gv;
a0d0e21e 1750 else
3280af22 1751 gv = PL_last_in_gv = (GV*)POPs;
4592e6ca
NIS		 1752
1753 if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
1754 PUSHMARK(SP);
1755 XPUSHs(SvTIED_obj((SV*)gv, mg));
1756 PUTBACK;
1757 ENTER;
864dbfa3 1758 call_method("TELL", G_SCALAR);
4592e6ca
NIS		 1759 LEAVE;
1760 SPAGAIN;
1761 RETURN;
1762 }
1763
e0a10278
JH		 1764#if LSEEKSIZE > IVSIZE
1765 PUSHn( do_tell(gv) );
1766#else
a0d0e21e 1767 PUSHi( do_tell(gv) );
e0a10278 1768#endif
a0d0e21e
LW		 1769 RETURN;
1770}
1771
1772PP(pp_seek)
1773{
cea2e8a9 1774 return pp_sysseek();
137443ea 1775}
1776
1777PP(pp_sysseek)
1778{
4e35701f 1779 djSP;
a0d0e21e
LW		 1780 GV *gv;
1781 int whence = POPi;
e0a10278
JH		 1782#if LSEEKSIZE > IVSIZE
1783 Off_t offset = (Off_t)SvNVx(POPs);
1784#else
d9b3e12d 1785 Off_t offset = (Off_t)SvIVx(POPs);
e0a10278 1786#endif
4592e6ca 1787 MAGIC *mg;
a0d0e21e 1788
3280af22 1789 gv = PL_last_in_gv = (GV*)POPs;
4592e6ca
NIS		 1790
1791 if (gv && (mg = SvTIED_mg((SV*)gv, 'q'))) {
1792 PUSHMARK(SP);
1793 XPUSHs(SvTIED_obj((SV*)gv, mg));
3dc6ede7
JH		 1794#if LSEEKSIZE > IVSIZE
1795 XPUSHs(sv_2mortal(newSVnv((NV) offset)));
1796#else
4592e6ca 1797 XPUSHs(sv_2mortal(newSViv((IV) offset)));
3dc6ede7 1798#endif
4592e6ca
NIS		 1799 XPUSHs(sv_2mortal(newSViv((IV) whence)));
1800 PUTBACK;
1801 ENTER;
864dbfa3 1802 call_method("SEEK", G_SCALAR);
4592e6ca
NIS		 1803 LEAVE;
1804 SPAGAIN;
1805 RETURN;
1806 }
1807
533c011a 1808 if (PL_op->op_type == OP_SEEK)
8903cb82 1809 PUSHs(boolSV(do_seek(gv, offset, whence)));
1810 else {
97cc44eb 1811 Off_t n = do_sysseek(gv, offset, whence);
e0a10278
JH		 1812 if (n < 0)
1813 PUSHs(&PL_sv_undef);
1814 else {
1815 SV* sv = n ?
1816#if LSEEKSIZE > IVSIZE
1817 newSVnv((NV)n)
1818#else
1819 newSViv((IV)n)
1820#endif
1821 : newSVpvn(zero_but_true, ZBTLEN);
1822 PUSHs(sv_2mortal(sv));
1823 }
8903cb82 1824 }
a0d0e21e
LW		 1825 RETURN;
1826}
1827
1828PP(pp_truncate)
1829{
4e35701f 1830 djSP;
a0d0e21e
LW		 1831 Off_t len = (Off_t)POPn;
1832 int result = 1;
1833 GV *tmpgv;
2d8e6c8d 1834 STRLEN n_a;
a0d0e21e 1835
748a9306 1836 SETERRNO(0,0);
5d94fbed 1837#if defined(HAS_TRUNCATE) || defined(HAS_CHSIZE) || defined(F_FREESP)
533c011a 1838 if (PL_op->op_flags & OPf_SPECIAL) {
2d8e6c8d 1839 tmpgv = gv_fetchpv(POPpx, FALSE, SVt_PVIO);
cbdc8872 1840 do_ftruncate:
1e422769 1841 TAINT_PROPER("truncate");
2f3b6ae4
GS		 1842 if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv)))
1843 result = 0;
1844 else {
1845 PerlIO_flush(IoIFP(GvIOp(tmpgv)));
cbdc8872 1846#ifdef HAS_TRUNCATE
2f3b6ae4 1847 if (ftruncate(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
cbdc8872 1848#else
2f3b6ae4 1849 if (my_chsize(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
cbdc8872 1850#endif
2f3b6ae4
GS		 1851 result = 0;
1852 }
a0d0e21e
LW		 1853 }
1854 else {
cbdc8872 1855 SV *sv = POPs;
1e422769 1856 char *name;
2d8e6c8d 1857 STRLEN n_a;
1e422769 1858
cbdc8872 1859 if (SvTYPE(sv) == SVt_PVGV) {
1860 tmpgv = (GV*)sv; /* *main::FRED for example */
1861 goto do_ftruncate;
1862 }
1863 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
1864 tmpgv = (GV*) SvRV(sv); /* \*main::FRED for example */
1865 goto do_ftruncate;
1866 }
1e422769 1867
2d8e6c8d 1868 name = SvPV(sv, n_a);
1e422769 1869 TAINT_PROPER("truncate");
cbdc8872 1870#ifdef HAS_TRUNCATE
1e422769 1871 if (truncate(name, len) < 0)
a0d0e21e 1872 result = 0;
cbdc8872 1873#else
1874 {
1875 int tmpfd;
6ad3d225 1876 if ((tmpfd = PerlLIO_open(name, O_RDWR)) < 0)
bbce6d69 1877 result = 0;
cbdc8872 1878 else {
1879 if (my_chsize(tmpfd, len) < 0)
1880 result = 0;
6ad3d225 1881 PerlLIO_close(tmpfd);
cbdc8872 1882 }
a0d0e21e 1883 }
a0d0e21e 1884#endif
cbdc8872 1885 }
a0d0e21e
LW		 1886
1887 if (result)
1888 RETPUSHYES;
1889 if (!errno)
748a9306 1890 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW		 1891 RETPUSHUNDEF;
1892#else
cea2e8a9 1893 DIE(aTHX_ "truncate not implemented");
a0d0e21e
LW		 1894#endif
1895}
1896
1897PP(pp_fcntl)
1898{
cea2e8a9 1899 return pp_ioctl();
a0d0e21e
LW		 1900}
1901
1902PP(pp_ioctl)
1903{
4e35701f 1904 djSP; dTARGET;
748a9306 1905 SV *argsv = POPs;
a0d0e21e 1906 unsigned int func = U_I(POPn);
533c011a 1907 int optype = PL_op->op_type;
a0d0e21e 1908 char *s;
324aa91a 1909 IV retval;
a0d0e21e
LW		 1910 GV *gv = (GV*)POPs;
1911 IO *io = GvIOn(gv);
1912
748a9306
LW		 1913 if (!io || !argsv || !IoIFP(io)) {
1914 SETERRNO(EBADF,RMS$_IFI); /* well, sort of... */
a0d0e21e
LW		 1915 RETPUSHUNDEF;
1916 }
1917
748a9306 1918 if (SvPOK(argsv) || !SvNIOK(argsv)) {
a0d0e21e 1919 STRLEN len;
324aa91a 1920 STRLEN need;
748a9306 1921 s = SvPV_force(argsv, len);
324aa91a
HF		 1922 need = IOCPARM_LEN(func);
1923 if (len < need) {
1924 s = Sv_Grow(argsv, need + 1);
1925 SvCUR_set(argsv, need);
a0d0e21e
LW		 1926 }
1927
748a9306 1928 s[SvCUR(argsv)] = 17; /* a little sanity check here */
a0d0e21e
LW		 1929 }
1930 else {
748a9306 1931 retval = SvIV(argsv);
56431972 1932 s = INT2PTR(char*,retval); /* ouch */
a0d0e21e
LW		 1933 }
1934
1935 TAINT_PROPER(optype == OP_IOCTL ? "ioctl" : "fcntl");
1936
1937 if (optype == OP_IOCTL)
1938#ifdef HAS_IOCTL
76e3520e 1939 retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
a0d0e21e 1940#else
cea2e8a9 1941 DIE(aTHX_ "ioctl is not implemented");
a0d0e21e
LW		 1942#endif
1943 else
55497cff 1944#ifdef HAS_FCNTL
1945#if defined(OS2) && defined(__EMX__)
760ac839 1946 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
55497cff 1947#else
760ac839 1948 retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
55497cff 1949#endif
1950#else
cea2e8a9 1951 DIE(aTHX_ "fcntl is not implemented");
a0d0e21e
LW		 1952#endif
1953
748a9306
LW		 1954 if (SvPOK(argsv)) {
1955 if (s[SvCUR(argsv)] != 17)
cea2e8a9 1956 DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
22c35a8c 1957 PL_op_name[optype]);
748a9306
LW		 1958 s[SvCUR(argsv)] = 0; /* put our null back */
1959 SvSETMAGIC(argsv); /* Assume it has changed */
a0d0e21e
LW		 1960 }
1961
1962 if (retval == -1)
1963 RETPUSHUNDEF;
1964 if (retval != 0) {
1965 PUSHi(retval);
1966 }
1967 else {
8903cb82 1968 PUSHp(zero_but_true, ZBTLEN);
a0d0e21e
LW		 1969 }
1970 RETURN;
1971}
1972
1973PP(pp_flock)
1974{
4e35701f 1975 djSP; dTARGET;
a0d0e21e
LW		 1976 I32 value;
1977 int argtype;
1978 GV *gv;
760ac839 1979 PerlIO *fp;
16d20bd9 1980
ff68c719 1981#ifdef FLOCK
a0d0e21e
LW		 1982 argtype = POPi;
1983 if (MAXARG <= 0)
3280af22 1984 gv = PL_last_in_gv;
a0d0e21e
LW		 1985 else
1986 gv = (GV*)POPs;
1987 if (gv && GvIO(gv))
1988 fp = IoIFP(GvIOp(gv));
1989 else
1990 fp = Nullfp;
1991 if (fp) {
68dc0745 1992 (void)PerlIO_flush(fp);
76e3520e 1993 value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
a0d0e21e 1994 }
69282e91 1995 else {
a0d0e21e 1996 value = 0;
69282e91
GS		 1997 SETERRNO(EBADF,RMS$_IFI);
1998 if (ckWARN(WARN_CLOSED))
1999 report_closed_fh(gv, GvIO(gv), "flock", "filehandle");
2000 }
a0d0e21e
LW		 2001 PUSHi(value);
2002 RETURN;
2003#else
cea2e8a9 2004 DIE(aTHX_ PL_no_func, "flock()");
a0d0e21e
LW		 2005#endif
2006}
2007
2008/* Sockets. */
2009
2010PP(pp_socket)
2011{
4e35701f 2012 djSP;
a0d0e21e
LW		 2013#ifdef HAS_SOCKET
2014 GV *gv;
2015 register IO *io;
2016 int protocol = POPi;
2017 int type = POPi;
2018 int domain = POPi;
2019 int fd;
2020
2021 gv = (GV*)POPs;
2022
2023 if (!gv) {
748a9306 2024 SETERRNO(EBADF,LIB$_INVARG);
a0d0e21e
LW		 2025 RETPUSHUNDEF;
2026 }
2027
2028 io = GvIOn(gv);
2029 if (IoIFP(io))
2030 do_close(gv, FALSE);
2031
2032 TAINT_PROPER("socket");
6ad3d225 2033 fd = PerlSock_socket(domain, type, protocol);
a0d0e21e
LW		 2034 if (fd < 0)
2035 RETPUSHUNDEF;
760ac839
LW		 2036 IoIFP(io) = PerlIO_fdopen(fd, "r"); /* stdio gets confused about sockets */
2037 IoOFP(io) = PerlIO_fdopen(fd, "w");
a0d0e21e
LW		 2038 IoTYPE(io) = 's';
2039 if (!IoIFP(io) || !IoOFP(io)) {
760ac839
LW		 2040 if (IoIFP(io)) PerlIO_close(IoIFP(io));
2041 if (IoOFP(io)) PerlIO_close(IoOFP(io));
6ad3d225 2042 if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
a0d0e21e
LW		 2043 RETPUSHUNDEF;
2044 }
2045
2046 RETPUSHYES;
2047#else
cea2e8a9 2048 DIE(aTHX_ PL_no_sock_func, "socket");
a0d0e21e
LW		 2049#endif
2050}
2051
2052PP(pp_sockpair)
2053{
4e35701f 2054 djSP;
a0d0e21e
LW		 2055#ifdef HAS_SOCKETPAIR
2056 GV *gv1;
2057 GV *gv2;
2058 register IO *io1;
2059 register IO *io2;
2060 int protocol = POPi;
2061 int type = POPi;
2062 int domain = POPi;
2063 int fd[2];
2064
2065 gv2 = (GV*)POPs;
2066 gv1 = (GV*)POPs;
2067 if (!gv1 || !gv2)
2068 RETPUSHUNDEF;
2069
2070 io1 = GvIOn(gv1);
2071 io2 = GvIOn(gv2);
2072 if (IoIFP(io1))
2073 do_close(gv1, FALSE);
2074 if (IoIFP(io2))
2075 do_close(gv2, FALSE);
2076
2077 TAINT_PROPER("socketpair");
6ad3d225 2078 if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
a0d0e21e 2079 RETPUSHUNDEF;
760ac839
LW		 2080 IoIFP(io1) = PerlIO_fdopen(fd[0], "r");
2081 IoOFP(io1) = PerlIO_fdopen(fd[0], "w");
a0d0e21e 2082 IoTYPE(io1) = 's';
760ac839
LW		 2083 IoIFP(io2) = PerlIO_fdopen(fd[1], "r");
2084 IoOFP(io2) = PerlIO_fdopen(fd[1], "w");
a0d0e21e
LW		 2085 IoTYPE(io2) = 's';
2086 if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
760ac839
LW		 2087 if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2088 if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
6ad3d225 2089 if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
760ac839
LW		 2090 if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2091 if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
6ad3d225 2092 if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
a0d0e21e
LW		 2093 RETPUSHUNDEF;
2094 }
2095
2096 RETPUSHYES;
2097#else
cea2e8a9 2098 DIE(aTHX_ PL_no_sock_func, "socketpair");
a0d0e21e
LW		 2099#endif
2100}
2101
2102PP(pp_bind)
2103{
4e35701f 2104 djSP;
a0d0e21e 2105#ifdef HAS_SOCKET
eec2d3df
GS		 2106#ifdef MPE /* Requires PRIV mode to bind() to ports < 1024 */
2107 extern GETPRIVMODE();
2108 extern GETUSERMODE();
2109#endif
748a9306 2110 SV *addrsv = POPs;
a0d0e21e
LW		 2111 char *addr;
2112 GV *gv = (GV*)POPs;
2113 register IO *io = GvIOn(gv);
2114 STRLEN len;
eec2d3df
GS		 2115 int bind_ok = 0;
2116#ifdef MPE
2117 int mpeprivmode = 0;
2118#endif
a0d0e21e
LW		 2119
2120 if (!io || !IoIFP(io))
2121 goto nuts;
2122
748a9306 2123 addr = SvPV(addrsv, len);
a0d0e21e 2124 TAINT_PROPER("bind");
eec2d3df
GS		 2125#ifdef MPE /* Deal with MPE bind() peculiarities */
2126 if (((struct sockaddr *)addr)->sa_family == AF_INET) {
2127 /* The address *MUST* stupidly be zero. */
2128 ((struct sockaddr_in *)addr)->sin_addr.s_addr = INADDR_ANY;
2129 /* PRIV mode is required to bind() to ports < 1024. */
2130 if (((struct sockaddr_in *)addr)->sin_port < 1024 &&
2131 ((struct sockaddr_in *)addr)->sin_port > 0) {
2132 GETPRIVMODE(); /* If this fails, we are aborted by MPE/iX. */
2133 mpeprivmode = 1;
2134 }
2135 }
2136#endif /* MPE */
2137 if (PerlSock_bind(PerlIO_fileno(IoIFP(io)),
2138 (struct sockaddr *)addr, len) >= 0)
2139 bind_ok = 1;
2140
2141#ifdef MPE /* Switch back to USER mode */
2142 if (mpeprivmode)
2143 GETUSERMODE();
2144#endif /* MPE */
2145
2146 if (bind_ok)
a0d0e21e
LW		 2147 RETPUSHYES;
2148 else
2149 RETPUSHUNDEF;
2150
2151nuts:
599cee73 2152 if (ckWARN(WARN_CLOSED))
69282e91 2153 report_closed_fh(gv, io, "bind", "socket");
748a9306 2154 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2155 RETPUSHUNDEF;
2156#else
cea2e8a9 2157 DIE(aTHX_ PL_no_sock_func, "bind");
a0d0e21e
LW		 2158#endif
2159}
2160
2161PP(pp_connect)
2162{
4e35701f 2163 djSP;
a0d0e21e 2164#ifdef HAS_SOCKET
748a9306 2165 SV *addrsv = POPs;
a0d0e21e
LW		 2166 char *addr;
2167 GV *gv = (GV*)POPs;
2168 register IO *io = GvIOn(gv);
2169 STRLEN len;
2170
2171 if (!io || !IoIFP(io))
2172 goto nuts;
2173
748a9306 2174 addr = SvPV(addrsv, len);
a0d0e21e 2175 TAINT_PROPER("connect");
6ad3d225 2176 if (PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
a0d0e21e
LW		 2177 RETPUSHYES;
2178 else
2179 RETPUSHUNDEF;
2180
2181nuts:
599cee73 2182 if (ckWARN(WARN_CLOSED))
69282e91 2183 report_closed_fh(gv, io, "connect", "socket");
748a9306 2184 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2185 RETPUSHUNDEF;
2186#else
cea2e8a9 2187 DIE(aTHX_ PL_no_sock_func, "connect");
a0d0e21e
LW		 2188#endif
2189}
2190
2191PP(pp_listen)
2192{
4e35701f 2193 djSP;
a0d0e21e
LW		 2194#ifdef HAS_SOCKET
2195 int backlog = POPi;
2196 GV *gv = (GV*)POPs;
2197 register IO *io = GvIOn(gv);
2198
2199 if (!io || !IoIFP(io))
2200 goto nuts;
2201
6ad3d225 2202 if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
a0d0e21e
LW		 2203 RETPUSHYES;
2204 else
2205 RETPUSHUNDEF;
2206
2207nuts:
599cee73 2208 if (ckWARN(WARN_CLOSED))
69282e91 2209 report_closed_fh(gv, io, "listen", "socket");
748a9306 2210 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2211 RETPUSHUNDEF;
2212#else
cea2e8a9 2213 DIE(aTHX_ PL_no_sock_func, "listen");
a0d0e21e
LW		 2214#endif
2215}
2216
2217PP(pp_accept)
2218{
4e35701f 2219 djSP; dTARGET;
a0d0e21e
LW		 2220#ifdef HAS_SOCKET
2221 GV *ngv;
2222 GV *ggv;
2223 register IO *nstio;
2224 register IO *gstio;
4633a7c4 2225 struct sockaddr saddr; /* use a struct to avoid alignment problems */
1e422769 2226 Sock_size_t len = sizeof saddr;
a0d0e21e
LW		 2227 int fd;
2228
2229 ggv = (GV*)POPs;
2230 ngv = (GV*)POPs;
2231
2232 if (!ngv)
2233 goto badexit;
2234 if (!ggv)
2235 goto nuts;
2236
2237 gstio = GvIO(ggv);
2238 if (!gstio || !IoIFP(gstio))
2239 goto nuts;
2240
2241 nstio = GvIOn(ngv);
2242 if (IoIFP(nstio))
2243 do_close(ngv, FALSE);
2244
6ad3d225 2245 fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *)&saddr, &len);
a0d0e21e
LW		 2246 if (fd < 0)
2247 goto badexit;
760ac839
LW		 2248 IoIFP(nstio) = PerlIO_fdopen(fd, "r");
2249 IoOFP(nstio) = PerlIO_fdopen(fd, "w");
a0d0e21e
LW		 2250 IoTYPE(nstio) = 's';
2251 if (!IoIFP(nstio) || !IoOFP(nstio)) {
760ac839
LW		 2252 if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2253 if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
6ad3d225 2254 if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
a0d0e21e
LW		 2255 goto badexit;
2256 }
2257
748a9306 2258 PUSHp((char *)&saddr, len);
a0d0e21e
LW		 2259 RETURN;
2260
2261nuts:
599cee73 2262 if (ckWARN(WARN_CLOSED))
69282e91 2263 report_closed_fh(ggv, ggv ? GvIO(ggv) : 0, "accept", "socket");
748a9306 2264 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2265
2266badexit:
2267 RETPUSHUNDEF;
2268
2269#else
cea2e8a9 2270 DIE(aTHX_ PL_no_sock_func, "accept");
a0d0e21e
LW		 2271#endif
2272}
2273
2274PP(pp_shutdown)
2275{
4e35701f 2276 djSP; dTARGET;
a0d0e21e
LW		 2277#ifdef HAS_SOCKET
2278 int how = POPi;
2279 GV *gv = (GV*)POPs;
2280 register IO *io = GvIOn(gv);
2281
2282 if (!io || !IoIFP(io))
2283 goto nuts;
2284
6ad3d225 2285 PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
a0d0e21e
LW		 2286 RETURN;
2287
2288nuts:
599cee73 2289 if (ckWARN(WARN_CLOSED))
69282e91 2290 report_closed_fh(gv, io, "shutdown", "socket");
748a9306 2291 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2292 RETPUSHUNDEF;
2293#else
cea2e8a9 2294 DIE(aTHX_ PL_no_sock_func, "shutdown");
a0d0e21e
LW		 2295#endif
2296}
2297
2298PP(pp_gsockopt)
2299{
2300#ifdef HAS_SOCKET
cea2e8a9 2301 return pp_ssockopt();
a0d0e21e 2302#else
cea2e8a9 2303 DIE(aTHX_ PL_no_sock_func, "getsockopt");
a0d0e21e
LW		 2304#endif
2305}
2306
2307PP(pp_ssockopt)
2308{
4e35701f 2309 djSP;
a0d0e21e 2310#ifdef HAS_SOCKET
533c011a 2311 int optype = PL_op->op_type;
a0d0e21e
LW		 2312 SV *sv;
2313 int fd;
2314 unsigned int optname;
2315 unsigned int lvl;
2316 GV *gv;
2317 register IO *io;
1e422769 2318 Sock_size_t len;
a0d0e21e
LW		 2319
2320 if (optype == OP_GSOCKOPT)
2321 sv = sv_2mortal(NEWSV(22, 257));
2322 else
2323 sv = POPs;
2324 optname = (unsigned int) POPi;
2325 lvl = (unsigned int) POPi;
2326
2327 gv = (GV*)POPs;
2328 io = GvIOn(gv);
2329 if (!io || !IoIFP(io))
2330 goto nuts;
2331
760ac839 2332 fd = PerlIO_fileno(IoIFP(io));
a0d0e21e
LW		 2333 switch (optype) {
2334 case OP_GSOCKOPT:
748a9306 2335 SvGROW(sv, 257);
a0d0e21e 2336 (void)SvPOK_only(sv);
748a9306
LW		 2337 SvCUR_set(sv,256);
2338 *SvEND(sv) ='\0';
1e422769 2339 len = SvCUR(sv);
6ad3d225 2340 if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
a0d0e21e 2341 goto nuts2;
1e422769 2342 SvCUR_set(sv, len);
748a9306 2343 *SvEND(sv) ='\0';
a0d0e21e
LW		 2344 PUSHs(sv);
2345 break;
2346 case OP_SSOCKOPT: {
1e422769 2347 char *buf;
2348 int aint;
2349 if (SvPOKp(sv)) {
2d8e6c8d
GS		 2350 STRLEN l;
2351 buf = SvPV(sv, l);
2352 len = l;
1e422769 2353 }
56ee1660 2354 else {
a0d0e21e
LW		 2355 aint = (int)SvIV(sv);
2356 buf = (char*)&aint;
2357 len = sizeof(int);
2358 }
6ad3d225 2359 if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
a0d0e21e 2360 goto nuts2;
3280af22 2361 PUSHs(&PL_sv_yes);
a0d0e21e
LW		 2362 }
2363 break;
2364 }
2365 RETURN;
2366
2367nuts:
599cee73 2368 if (ckWARN(WARN_CLOSED))
69282e91
GS		 2369 report_closed_fh(gv, io,
2370 optype == OP_GSOCKOPT ? "getsockopt" : "setsockopt",
2371 "socket");
748a9306 2372 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2373nuts2:
2374 RETPUSHUNDEF;
2375
2376#else
cea2e8a9 2377 DIE(aTHX_ PL_no_sock_func, "setsockopt");
a0d0e21e
LW		 2378#endif
2379}
2380
2381PP(pp_getsockname)
2382{
2383#ifdef HAS_SOCKET
cea2e8a9 2384 return pp_getpeername();
a0d0e21e 2385#else
cea2e8a9 2386 DIE(aTHX_ PL_no_sock_func, "getsockname");
a0d0e21e
LW		 2387#endif
2388}
2389
2390PP(pp_getpeername)
2391{
4e35701f 2392 djSP;
a0d0e21e 2393#ifdef HAS_SOCKET
533c011a 2394 int optype = PL_op->op_type;
a0d0e21e
LW		 2395 SV *sv;
2396 int fd;
2397 GV *gv = (GV*)POPs;
2398 register IO *io = GvIOn(gv);
1e422769 2399 Sock_size_t len;
a0d0e21e
LW		 2400
2401 if (!io || !IoIFP(io))
2402 goto nuts;
2403
2404 sv = sv_2mortal(NEWSV(22, 257));
748a9306 2405 (void)SvPOK_only(sv);
1e422769 2406 len = 256;
2407 SvCUR_set(sv, len);
748a9306 2408 *SvEND(sv) ='\0';
760ac839 2409 fd = PerlIO_fileno(IoIFP(io));
a0d0e21e
LW		 2410 switch (optype) {
2411 case OP_GETSOCKNAME:
6ad3d225 2412 if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
a0d0e21e
LW		 2413 goto nuts2;
2414 break;
2415 case OP_GETPEERNAME:
6ad3d225 2416 if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
a0d0e21e 2417 goto nuts2;
490ab354
JH		 2418#if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2419 {
2420 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";
2421 /* If the call succeeded, make sure we don't have a zeroed port/addr */
2422 if (((struct sockaddr *)SvPVX(sv))->sa_family == AF_INET &&
2423 !memcmp((char *)SvPVX(sv) + sizeof(u_short), nowhere,
2424 sizeof(u_short) + sizeof(struct in_addr))) {
2425 goto nuts2;
2426 }
2427 }
2428#endif
a0d0e21e
LW		 2429 break;
2430 }
13826f2c
CS		 2431#ifdef BOGUS_GETNAME_RETURN
2432 /* Interactive Unix, getpeername() and getsockname()
2433 does not return valid namelen */
1e422769 2434 if (len == BOGUS_GETNAME_RETURN)
2435 len = sizeof(struct sockaddr);
13826f2c 2436#endif
1e422769 2437 SvCUR_set(sv, len);
748a9306 2438 *SvEND(sv) ='\0';
a0d0e21e
LW		 2439 PUSHs(sv);
2440 RETURN;
2441
2442nuts:
599cee73 2443 if (ckWARN(WARN_CLOSED))
69282e91
GS		 2444 report_closed_fh(gv, io,
2445 optype == OP_GETSOCKNAME ? "getsockname"
2446 : "getpeername",
2447 "socket");
748a9306 2448 SETERRNO(EBADF,SS$_IVCHAN);
a0d0e21e
LW		 2449nuts2:
2450 RETPUSHUNDEF;
2451
2452#else
cea2e8a9 2453 DIE(aTHX_ PL_no_sock_func, "getpeername");
a0d0e21e
LW		 2454#endif
2455}
2456
2457/* Stat calls. */
2458
2459PP(pp_lstat)
2460{
cea2e8a9 2461 return pp_stat();
a0d0e21e
LW		 2462}
2463
2464PP(pp_stat)
2465{
4e35701f 2466 djSP;
a0d0e21e 2467 GV *tmpgv;
54310121 2468 I32 gimme;
a0d0e21e 2469 I32 max = 13;
2d8e6c8d 2470 STRLEN n_a;
a0d0e21e 2471
533c011a 2472 if (PL_op->op_flags & OPf_REF) {
638eceb6 2473 tmpgv = cGVOP_gv;
748a9306 2474 do_fstat:
3280af22
NIS		 2475 if (tmpgv != PL_defgv) {
2476 PL_laststype = OP_STAT;
2477 PL_statgv = tmpgv;
2478 sv_setpv(PL_statname, "");
2479 PL_laststatval = (GvIO(tmpgv) && IoIFP(GvIOp(tmpgv))
2480 ? PerlLIO_fstat(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), &PL_statcache) : -1);
a0d0e21e 2481 }
3280af22 2482 if (PL_laststatval < 0)
a0d0e21e
LW		 2483 max = 0;
2484 }
2485 else {
748a9306
LW		 2486 SV* sv = POPs;
2487 if (SvTYPE(sv) == SVt_PVGV) {
2488 tmpgv = (GV*)sv;
2489 goto do_fstat;
2490 }
2491 else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
2492 tmpgv = (GV*)SvRV(sv);
2493 goto do_fstat;
2494 }
2d8e6c8d 2495 sv_setpv(PL_statname, SvPV(sv,n_a));
3280af22 2496 PL_statgv = Nullgv;
a0d0e21e 2497#ifdef HAS_LSTAT
533c011a
NIS		 2498 PL_laststype = PL_op->op_type;
2499 if (PL_op->op_type == OP_LSTAT)
2d8e6c8d 2500 PL_laststatval = PerlLIO_lstat(SvPV(PL_statname, n_a), &PL_statcache);
a0d0e21e
LW		 2501 else
2502#endif
2d8e6c8d 2503 PL_laststatval = PerlLIO_stat(SvPV(PL_statname, n_a), &PL_statcache);
3280af22 2504 if (PL_laststatval < 0) {
2d8e6c8d 2505 if (ckWARN(WARN_NEWLINE) && strchr(SvPV(PL_statname, n_a), '\n'))
cea2e8a9 2506 Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "stat");
a0d0e21e
LW		 2507 max = 0;
2508 }
2509 }
2510
54310121 2511 gimme = GIMME_V;
2512 if (gimme != G_ARRAY) {
2513 if (gimme != G_VOID)
2514 XPUSHs(boolSV(max));
2515 RETURN;
a0d0e21e
LW		 2516 }
2517 if (max) {
36477c24 2518 EXTEND(SP, max);
2519 EXTEND_MORTAL(max);
1ff81528
PL		 2520 PUSHs(sv_2mortal(newSViv(PL_statcache.st_dev)));
2521 PUSHs(sv_2mortal(newSViv(PL_statcache.st_ino)));
2522 PUSHs(sv_2mortal(newSViv(PL_statcache.st_mode)));
2523 PUSHs(sv_2mortal(newSViv(PL_statcache.st_nlink)));
887d2938
JH		 2524#if Uid_t_size > IVSIZE
2525 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_uid)));
2526#else
1ff81528 2527 PUSHs(sv_2mortal(newSViv(PL_statcache.st_uid)));
887d2938
JH		 2528#endif
2529#if Gid_t_size > IVSIZE
2530 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_gid)));
2531#else
1ff81528 2532 PUSHs(sv_2mortal(newSViv(PL_statcache.st_gid)));
887d2938 2533#endif
cbdc8872 2534#ifdef USE_STAT_RDEV
1ff81528 2535 PUSHs(sv_2mortal(newSViv(PL_statcache.st_rdev)));
cbdc8872 2536#else
79cb57f6 2537 PUSHs(sv_2mortal(newSVpvn("", 0)));
cbdc8872 2538#endif
e0a10278 2539#if Off_t_size > IVSIZE
887d2938
JH		 2540 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_size)));
2541#else
1ff81528 2542 PUSHs(sv_2mortal(newSViv(PL_statcache.st_size)));
887d2938 2543#endif
cbdc8872 2544#ifdef BIG_TIME
172ae379
JH		 2545 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_atime)));
2546 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_mtime)));
2547 PUSHs(sv_2mortal(newSVnv(PL_statcache.st_ctime)));
cbdc8872 2548#else
1ff81528
PL		 2549 PUSHs(sv_2mortal(newSViv(PL_statcache.st_atime)));
2550 PUSHs(sv_2mortal(newSViv(PL_statcache.st_mtime)));
2551 PUSHs(sv_2mortal(newSViv(PL_statcache.st_ctime)));
cbdc8872 2552#endif
a0d0e21e 2553#ifdef USE_STAT_BLOCKS
1ff81528
PL		 2554 PUSHs(sv_2mortal(newSViv(PL_statcache.st_blksize)));
2555 PUSHs(sv_2mortal(newSViv(PL_statcache.st_blocks)));
a0d0e21e 2556#else
79cb57f6
GS		 2557 PUSHs(sv_2mortal(newSVpvn("", 0)));
2558 PUSHs(sv_2mortal(newSVpvn("", 0)));
a0d0e21e
LW		 2559#endif
2560 }
2561 RETURN;
2562}
2563
2564PP(pp_ftrread)
2565{
5ff3f7a4 2566 I32 result;
4e35701f 2567 djSP;
5ff3f7a4 2568#if defined(HAS_ACCESS) && defined(R_OK)
2d8e6c8d 2569 STRLEN n_a;
5ff3f7a4 2570 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2571 result = access(TOPpx, R_OK);
5ff3f7a4
GS		 2572 if (result == 0)
2573 RETPUSHYES;
2574 if (result < 0)
2575 RETPUSHUNDEF;
2576 RETPUSHNO;
22865c03
GS		 2577 }
2578 else
cea2e8a9 2579 result = my_stat();
5ff3f7a4 2580#else
cea2e8a9 2581 result = my_stat();
5ff3f7a4 2582#endif
22865c03 2583 SPAGAIN;
a0d0e21e
LW		 2584 if (result < 0)
2585 RETPUSHUNDEF;
3280af22 2586 if (cando(S_IRUSR, 0, &PL_statcache))
a0d0e21e
LW		 2587 RETPUSHYES;
2588 RETPUSHNO;
2589}
2590
2591PP(pp_ftrwrite)
2592{
5ff3f7a4 2593 I32 result;
4e35701f 2594 djSP;
5ff3f7a4 2595#if defined(HAS_ACCESS) && defined(W_OK)
2d8e6c8d 2596 STRLEN n_a;
5ff3f7a4 2597 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2598 result = access(TOPpx, W_OK);
5ff3f7a4
GS		 2599 if (result == 0)
2600 RETPUSHYES;
2601 if (result < 0)
2602 RETPUSHUNDEF;
2603 RETPUSHNO;
22865c03
GS		 2604 }
2605 else
cea2e8a9 2606 result = my_stat();
5ff3f7a4 2607#else
cea2e8a9 2608 result = my_stat();
5ff3f7a4 2609#endif
22865c03 2610 SPAGAIN;
a0d0e21e
LW		 2611 if (result < 0)
2612 RETPUSHUNDEF;
3280af22 2613 if (cando(S_IWUSR, 0, &PL_statcache))
a0d0e21e
LW		 2614 RETPUSHYES;
2615 RETPUSHNO;
2616}
2617
2618PP(pp_ftrexec)
2619{
5ff3f7a4 2620 I32 result;
4e35701f 2621 djSP;
5ff3f7a4 2622#if defined(HAS_ACCESS) && defined(X_OK)
2d8e6c8d 2623 STRLEN n_a;
5ff3f7a4 2624 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2625 result = access(TOPpx, X_OK);
5ff3f7a4
GS		 2626 if (result == 0)
2627 RETPUSHYES;
2628 if (result < 0)
2629 RETPUSHUNDEF;
2630 RETPUSHNO;
22865c03
GS		 2631 }
2632 else
cea2e8a9 2633 result = my_stat();
5ff3f7a4 2634#else
cea2e8a9 2635 result = my_stat();
5ff3f7a4 2636#endif
22865c03 2637 SPAGAIN;
a0d0e21e
LW		 2638 if (result < 0)
2639 RETPUSHUNDEF;
3280af22 2640 if (cando(S_IXUSR, 0, &PL_statcache))
a0d0e21e
LW		 2641 RETPUSHYES;
2642 RETPUSHNO;
2643}
2644
2645PP(pp_fteread)
2646{
5ff3f7a4 2647 I32 result;
4e35701f 2648 djSP;
5ff3f7a4 2649#ifdef PERL_EFF_ACCESS_R_OK
2d8e6c8d 2650 STRLEN n_a;
5ff3f7a4 2651 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2652 result = PERL_EFF_ACCESS_R_OK(TOPpx);
5ff3f7a4
GS		 2653 if (result == 0)
2654 RETPUSHYES;
2655 if (result < 0)
2656 RETPUSHUNDEF;
2657 RETPUSHNO;
22865c03
GS		 2658 }
2659 else
cea2e8a9 2660 result = my_stat();
5ff3f7a4 2661#else
cea2e8a9 2662 result = my_stat();
5ff3f7a4 2663#endif
22865c03 2664 SPAGAIN;
a0d0e21e
LW		 2665 if (result < 0)
2666 RETPUSHUNDEF;
3280af22 2667 if (cando(S_IRUSR, 1, &PL_statcache))
a0d0e21e
LW		 2668 RETPUSHYES;
2669 RETPUSHNO;
2670}
2671
2672PP(pp_ftewrite)
2673{
5ff3f7a4 2674 I32 result;
4e35701f 2675 djSP;
5ff3f7a4 2676#ifdef PERL_EFF_ACCESS_W_OK
2d8e6c8d 2677 STRLEN n_a;
5ff3f7a4 2678 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2679 result = PERL_EFF_ACCESS_W_OK(TOPpx);
5ff3f7a4
GS		 2680 if (result == 0)
2681 RETPUSHYES;
2682 if (result < 0)
2683 RETPUSHUNDEF;
2684 RETPUSHNO;
22865c03
GS		 2685 }
2686 else
cea2e8a9 2687 result = my_stat();
5ff3f7a4 2688#else
cea2e8a9 2689 result = my_stat();
5ff3f7a4 2690#endif
22865c03 2691 SPAGAIN;
a0d0e21e
LW		 2692 if (result < 0)
2693 RETPUSHUNDEF;
3280af22 2694 if (cando(S_IWUSR, 1, &PL_statcache))
a0d0e21e
LW		 2695 RETPUSHYES;
2696 RETPUSHNO;
2697}
2698
2699PP(pp_fteexec)
2700{
5ff3f7a4 2701 I32 result;
4e35701f 2702 djSP;
5ff3f7a4 2703#ifdef PERL_EFF_ACCESS_X_OK
2d8e6c8d 2704 STRLEN n_a;
5ff3f7a4 2705 if ((PL_hints & HINT_FILETEST_ACCESS) && SvPOK(TOPs)) {
2d8e6c8d 2706 result = PERL_EFF_ACCESS_X_OK(TOPpx);
5ff3f7a4
GS		 2707 if (result == 0)
2708 RETPUSHYES;
2709 if (result < 0)
2710 RETPUSHUNDEF;
2711 RETPUSHNO;
22865c03
GS		 2712 }
2713 else
cea2e8a9 2714 result = my_stat();
5ff3f7a4 2715#else
cea2e8a9 2716 result = my_stat();
5ff3f7a4 2717#endif
22865c03 2718 SPAGAIN;
a0d0e21e
LW		 2719 if (result < 0)
2720 RETPUSHUNDEF;
3280af22 2721 if (cando(S_IXUSR, 1, &PL_statcache))
a0d0e21e
LW		 2722 RETPUSHYES;
2723 RETPUSHNO;
2724}
2725
2726PP(pp_ftis)
2727{
cea2e8a9 2728 I32 result = my_stat();
4e35701f 2729 djSP;
a0d0e21e
LW		 2730 if (result < 0)
2731 RETPUSHUNDEF;
2732 RETPUSHYES;
2733}
2734
2735PP(pp_fteowned)
2736{
cea2e8a9 2737 return pp_ftrowned();
a0d0e21e
LW		 2738}
2739
2740PP(pp_ftrowned)
2741{
cea2e8a9 2742 I32 result = my_stat();
4e35701f 2743 djSP;
a0d0e21e
LW		 2744 if (result < 0)
2745 RETPUSHUNDEF;
887d2938
JH		 2746 if (PL_statcache.st_uid == (PL_op->op_type == OP_FTEOWNED ?
2747 PL_euid : PL_uid) )
a0d0e21e
LW		 2748 RETPUSHYES;
2749 RETPUSHNO;
2750}
2751
2752PP(pp_ftzero)
2753{
cea2e8a9 2754 I32 result = my_stat();
4e35701f 2755 djSP;
a0d0e21e
LW		 2756 if (result < 0)
2757 RETPUSHUNDEF;
887d2938 2758 if (PL_statcache.st_size == 0)
a0d0e21e
LW		 2759 RETPUSHYES;
2760 RETPUSHNO;
2761}
2762
2763PP(pp_ftsize)
2764{
cea2e8a9 2765 I32 result = my_stat();
4e35701f 2766 djSP; dTARGET;
a0d0e21e
LW		 2767 if (result < 0)
2768 RETPUSHUNDEF;
e0a10278 2769#if Off_t_size > IVSIZE
887d2938
JH		 2770 PUSHn(PL_statcache.st_size);
2771#else
3280af22 2772 PUSHi(PL_statcache.st_size);
887d2938 2773#endif
a0d0e21e
LW		 2774 RETURN;
2775}
2776
2777PP(pp_ftmtime)
2778{
cea2e8a9 2779 I32 result = my_stat();
4e35701f 2780 djSP; dTARGET;
a0d0e21e
LW		 2781 if (result < 0)
2782 RETPUSHUNDEF;
c6419e06 2783 PUSHn( (PL_basetime - PL_statcache.st_mtime) / 86400.0 );
a0d0e21e
LW		 2784 RETURN;
2785}
2786
2787PP(pp_ftatime)
2788{
cea2e8a9 2789 I32 result = my_stat();
4e35701f 2790 djSP; dTARGET;
a0d0e21e
LW		 2791 if (result < 0)
2792 RETPUSHUNDEF;
c6419e06 2793 PUSHn( (PL_basetime - PL_statcache.st_atime) / 86400.0 );
a0d0e21e
LW		 2794 RETURN;
2795}
2796
2797PP(pp_ftctime)
2798{
cea2e8a9 2799 I32 result = my_stat();
4e35701f 2800 djSP; dTARGET;
a0d0e21e
LW		 2801 if (result < 0)
2802 RETPUSHUNDEF;
c6419e06 2803 PUSHn( (PL_basetime - PL_statcache.st_ctime) / 86400.0 );
a0d0e21e
LW		 2804 RETURN;
2805}
2806
2807PP(pp_ftsock)
2808{
cea2e8a9 2809 I32 result = my_stat();
4e35701f 2810 djSP;
a0d0e21e
LW		 2811 if (result < 0)
2812 RETPUSHUNDEF;
3280af22 2813 if (S_ISSOCK(PL_statcache.st_mode))
a0d0e21e
LW		 2814 RETPUSHYES;
2815 RETPUSHNO;
2816}
2817
2818PP(pp_ftchr)
2819{
cea2e8a9 2820 I32 result = my_stat();
4e35701f 2821 djSP;
a0d0e21e
LW		 2822 if (result < 0)
2823 RETPUSHUNDEF;
3280af22 2824 if (S_ISCHR(PL_statcache.st_mode))
a0d0e21e
LW		 2825 RETPUSHYES;
2826 RETPUSHNO;
2827}
2828
2829PP(pp_ftblk)
2830{
cea2e8a9 2831 I32 result = my_stat();
4e35701f 2832 djSP;
a0d0e21e
LW		 2833 if (result < 0)
2834 RETPUSHUNDEF;
3280af22 2835 if (S_ISBLK(PL_statcache.st_mode))
a0d0e21e
LW		 2836 RETPUSHYES;
2837 RETPUSHNO;
2838}
2839
2840PP(pp_ftfile)
2841{
cea2e8a9 2842 I32 result = my_stat();
4e35701f 2843 djSP;
a0d0e21e
LW		 2844 if (result < 0)
2845 RETPUSHUNDEF;
3280af22 2846 if (S_ISREG(PL_statcache.st_mode))
a0d0e21e
LW		 2847 RETPUSHYES;
2848 RETPUSHNO;
2849}
2850
2851PP(pp_ftdir)
2852{
cea2e8a9 2853 I32 result = my_stat();
4e35701f 2854 djSP;
a0d0e21e
LW		 2855 if (result < 0)
2856 RETPUSHUNDEF;
3280af22 2857 if (S_ISDIR(PL_statcache.st_mode))
a0d0e21e
LW		 2858 RETPUSHYES;
2859 RETPUSHNO;
2860}
2861
2862PP(pp_ftpipe)
2863{
cea2e8a9 2864 I32 result = my_stat();
4e35701f 2865 djSP;
a0d0e21e
LW		 2866 if (result < 0)
2867 RETPUSHUNDEF;
3280af22 2868 if (S_ISFIFO(PL_statcache.st_mode))
a0d0e21e
LW		 2869 RETPUSHYES;
2870 RETPUSHNO;
2871}
2872
2873PP(pp_ftlink)
2874{
cea2e8a9 2875 I32 result = my_lstat();
4e35701f 2876 djSP;
a0d0e21e
LW		 2877 if (result < 0)
2878 RETPUSHUNDEF;
3280af22 2879 if (S_ISLNK(PL_statcache.st_mode))
a0d0e21e
LW		 2880 RETPUSHYES;
2881 RETPUSHNO;
2882}
2883
2884PP(pp_ftsuid)
2885{
4e35701f 2886 djSP;
a0d0e21e 2887#ifdef S_ISUID
cea2e8a9 2888 I32 result = my_stat();
a0d0e21e
LW		 2889 SPAGAIN;
2890 if (result < 0)
2891 RETPUSHUNDEF;
3280af22 2892 if (PL_statcache.st_mode & S_ISUID)
a0d0e21e
LW		 2893 RETPUSHYES;
2894#endif
2895 RETPUSHNO;
2896}
2897
2898PP(pp_ftsgid)
2899{
4e35701f 2900 djSP;
a0d0e21e 2901#ifdef S_ISGID
cea2e8a9 2902 I32 result = my_stat();
a0d0e21e
LW		 2903 SPAGAIN;
2904 if (result < 0)
2905 RETPUSHUNDEF;
3280af22 2906 if (PL_statcache.st_mode & S_ISGID)
a0d0e21e
LW		 2907 RETPUSHYES;
2908#endif
2909 RETPUSHNO;
2910}
2911
2912PP(pp_ftsvtx)
2913{
4e35701f 2914 djSP;
a0d0e21e 2915#ifdef S_ISVTX
cea2e8a9 2916 I32 result = my_stat();
a0d0e21e
LW		 2917 SPAGAIN;
2918 if (result < 0)
2919 RETPUSHUNDEF;
3280af22 2920 if (PL_statcache.st_mode & S_ISVTX)
a0d0e21e
LW		 2921 RETPUSHYES;
2922#endif
2923 RETPUSHNO;
2924}
2925
2926PP(pp_fttty)
2927{
4e35701f 2928 djSP;
a0d0e21e
LW		 2929 int fd;
2930 GV *gv;
fb73857a 2931 char *tmps = Nullch;
2d8e6c8d 2932 STRLEN n_a;
fb73857a 2933
533c011a 2934 if (PL_op->op_flags & OPf_REF)
638eceb6 2935 gv = cGVOP_gv;
fb73857a 2936 else if (isGV(TOPs))
2937 gv = (GV*)POPs;
2938 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
2939 gv = (GV*)SvRV(POPs);
a0d0e21e 2940 else
2d8e6c8d 2941 gv = gv_fetchpv(tmps = POPpx, FALSE, SVt_PVIO);
fb73857a 2942
a0d0e21e 2943 if (GvIO(gv) && IoIFP(GvIOp(gv)))
760ac839 2944 fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
fb73857a 2945 else if (tmps && isDIGIT(*tmps))
a0d0e21e
LW		 2946 fd = atoi(tmps);
2947 else
2948 RETPUSHUNDEF;
6ad3d225 2949 if (PerlLIO_isatty(fd))
a0d0e21e
LW		 2950 RETPUSHYES;
2951 RETPUSHNO;
2952}
2953
16d20bd9
AD		 2954#if defined(atarist) /* this will work with atariST. Configure will
2955 make guesses for other systems. */
2956# define FILE_base(f) ((f)->_base)
2957# define FILE_ptr(f) ((f)->_ptr)
2958# define FILE_cnt(f) ((f)->_cnt)
2959# define FILE_bufsiz(f) ((f)->_cnt + ((f)->_ptr - (f)->_base))
a0d0e21e
LW		 2960#endif
2961
2962PP(pp_fttext)
2963{
4e35701f 2964 djSP;
a0d0e21e
LW		 2965 I32 i;
2966 I32 len;
2967 I32 odd = 0;
2968 STDCHAR tbuf[512];
2969 register STDCHAR *s;
2970 register IO *io;
5f05dabc 2971 register SV *sv;
2972 GV *gv;
2d8e6c8d 2973 STRLEN n_a;
887d2938 2974 PerlIO *fp;
a0d0e21e 2975
533c011a 2976 if (PL_op->op_flags & OPf_REF)
638eceb6 2977 gv = cGVOP_gv;
5f05dabc 2978 else if (isGV(TOPs))
2979 gv = (GV*)POPs;
2980 else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
2981 gv = (GV*)SvRV(POPs);
2982 else
2983 gv = Nullgv;
2984
2985 if (gv) {
a0d0e21e 2986 EXTEND(SP, 1);
3280af22
NIS		 2987 if (gv == PL_defgv) {
2988 if (PL_statgv)
2989 io = GvIO(PL_statgv);
a0d0e21e 2990 else {
3280af22 2991 sv = PL_statname;
a0d0e21e
LW		 2992 goto really_filename;
2993 }
2994 }
2995 else {
3280af22
NIS		 2996 PL_statgv = gv;
2997 PL_laststatval = -1;
2998 sv_setpv(PL_statname, "");
2999 io = GvIO(PL_statgv);
a0d0e21e
LW		 3000 }
3001 if (io && IoIFP(io)) {
5f05dabc 3002 if (! PerlIO_has_base(IoIFP(io)))
cea2e8a9 3003 DIE(aTHX_ "-T and -B not implemented on filehandles");
3280af22
NIS		 3004 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3005 if (PL_laststatval < 0)
5f05dabc 3006 RETPUSHUNDEF;
3280af22 3007 if (S_ISDIR(PL_statcache.st_mode)) /* handle NFS glitch */
533c011a 3008 if (PL_op->op_type == OP_FTTEXT)
a0d0e21e
LW		 3009 RETPUSHNO;
3010 else
3011 RETPUSHYES;
a20bf0c3 3012 if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
760ac839 3013 i = PerlIO_getc(IoIFP(io));
a0d0e21e 3014 if (i != EOF)
760ac839 3015 (void)PerlIO_ungetc(IoIFP(io),i);
a0d0e21e 3016 }
a20bf0c3 3017 if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
a0d0e21e 3018 RETPUSHYES;
a20bf0c3
JH		 3019 len = PerlIO_get_bufsiz(IoIFP(io));
3020 s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
760ac839
LW		 3021 /* sfio can have large buffers - limit to 512 */
3022 if (len > 512)
3023 len = 512;
a0d0e21e
LW		 3024 }
3025 else {
7766f137 3026 if (ckWARN(WARN_UNOPENED)) {
638eceb6 3027 gv = cGVOP_gv;
cea2e8a9 3028 Perl_warner(aTHX_ WARN_UNOPENED, "Test on unopened file <%s>",
7766f137
GS		 3029 GvENAME(gv));
3030 }
748a9306 3031 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW		 3032 RETPUSHUNDEF;
3033 }
3034 }
3035 else {
3036 sv = POPs;
5f05dabc 3037 really_filename:
3280af22
NIS		 3038 PL_statgv = Nullgv;
3039 PL_laststatval = -1;
2d8e6c8d 3040 sv_setpv(PL_statname, SvPV(sv, n_a));
887d2938 3041 if (!(fp = PerlIO_open(SvPVX(PL_statname), "r"))) {
2d8e6c8d 3042 if (ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, n_a), '\n'))
cea2e8a9 3043 Perl_warner(aTHX_ WARN_NEWLINE, PL_warn_nl, "open");
a0d0e21e
LW		 3044 RETPUSHUNDEF;
3045 }
887d2938
JH		 3046 PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3047 if (PL_laststatval < 0) {
3048 (void)PerlIO_close(fp);
5f05dabc 3049 RETPUSHUNDEF;
887d2938
JH		 3050 }
3051 do_binmode(fp, '<', TRUE);
3052 len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3053 (void)PerlIO_close(fp);
a0d0e21e 3054 if (len <= 0) {
533c011a 3055 if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
a0d0e21e
LW		 3056 RETPUSHNO; /* special case NFS directories */
3057 RETPUSHYES; /* null file is anything */
3058 }
3059 s = tbuf;
3060 }
3061
3062 /* now scan s to look for textiness */
4633a7c4 3063 /* XXX ASCII dependent code */
a0d0e21e 3064
887d2938
JH		 3065#if defined(DOSISH) || defined(USEMYBINMODE)
3066 /* ignore trailing ^Z on short files */
3067 if (len && len < sizeof(tbuf) && tbuf[len-1] == 26)
3068 --len;
3069#endif
3070
a0d0e21e
LW		 3071 for (i = 0; i < len; i++, s++) {
3072 if (!*s) { /* null never allowed in text */
3073 odd += len;
3074 break;
3075 }
9d116dd7
JH		 3076#ifdef EBCDIC
3077 else if (!(isPRINT(*s) || isSPACE(*s)))
3078 odd++;
3079#else
887d2938
JH		 3080 else if (*s & 128) {
3081#ifdef USE_LOCALE
3082 if (!(PL_op->op_private & OPpLOCALE) || !isALPHA_LC(*s))
3083#endif
3084 odd++;
3085 }
a0d0e21e
LW		 3086 else if (*s < 32 &&
3087 *s != '\n' && *s != '\r' && *s != '\b' &&
3088 *s != '\t' && *s != '\f' && *s != 27)
3089 odd++;
9d116dd7 3090#endif
a0d0e21e
LW		 3091 }
3092
533c011a 3093 if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
a0d0e21e
LW		 3094 RETPUSHNO;
3095 else
3096 RETPUSHYES;
3097}
3098
3099PP(pp_ftbinary)
3100{
cea2e8a9 3101 return pp_fttext();
a0d0e21e
LW		 3102}
3103
3104/* File calls. */
3105
3106PP(pp_chdir)
3107{
4e35701f 3108 djSP; dTARGET;
a0d0e21e
LW		 3109 char *tmps;
3110 SV **svp;
2d8e6c8d 3111 STRLEN n_a;
a0d0e21e
LW		 3112
3113 if (MAXARG < 1)
3114 tmps = Nullch;
3115 else
2d8e6c8d 3116 tmps = POPpx;
a0d0e21e 3117 if (!tmps || !*tmps) {
3280af22 3118 svp = hv_fetch(GvHVn(PL_envgv), "HOME", 4, FALSE);
a0d0e21e 3119 if (svp)
2d8e6c8d 3120 tmps = SvPV(*svp, n_a);
a0d0e21e
LW		 3121 }
3122 if (!tmps || !*tmps) {
3280af22 3123 svp = hv_fetch(GvHVn(PL_envgv), "LOGDIR", 6, FALSE);
a0d0e21e 3124 if (svp)
2d8e6c8d 3125 tmps = SvPV(*svp, n_a);
a0d0e21e 3126 }
491527d0
GS		 3127#ifdef VMS
3128 if (!tmps || !*tmps) {
6b88bc9c 3129 svp = hv_fetch(GvHVn(PL_envgv), "SYS$LOGIN", 9, FALSE);
491527d0 3130 if (svp)
2d8e6c8d 3131 tmps = SvPV(*svp, n_a);
491527d0
GS		 3132 }
3133#endif
a0d0e21e 3134 TAINT_PROPER("chdir");
6ad3d225 3135 PUSHi( PerlDir_chdir(tmps) >= 0 );
748a9306
LW		 3136#ifdef VMS
3137 /* Clear the DEFAULT element of ENV so we'll get the new value
3138 * in the future. */
6b88bc9c 3139 hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
748a9306 3140#endif
a0d0e21e
LW		 3141 RETURN;
3142}
3143
3144PP(pp_chown)
3145{
4e35701f 3146 djSP; dMARK; dTARGET;
a0d0e21e
LW		 3147 I32 value;
3148#ifdef HAS_CHOWN
533c011a 3149 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 3150 SP = MARK;
3151 PUSHi(value);
3152 RETURN;
3153#else
cea2e8a9 3154 DIE(aTHX_ PL_no_func, "Unsupported function chown");
a0d0e21e
LW		 3155#endif
3156}
3157
3158PP(pp_chroot)
3159{
4e35701f 3160 djSP; dTARGET;
a0d0e21e
LW		 3161 char *tmps;
3162#ifdef HAS_CHROOT
2d8e6c8d
GS		 3163 STRLEN n_a;
3164 tmps = POPpx;
a0d0e21e
LW		 3165 TAINT_PROPER("chroot");
3166 PUSHi( chroot(tmps) >= 0 );
3167 RETURN;
3168#else
cea2e8a9 3169 DIE(aTHX_ PL_no_func, "chroot");
a0d0e21e
LW		 3170#endif
3171}
3172
3173PP(pp_unlink)
3174{
4e35701f 3175 djSP; dMARK; dTARGET;
a0d0e21e 3176 I32 value;
533c011a 3177 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 3178 SP = MARK;
3179 PUSHi(value);
3180 RETURN;
3181}
3182
3183PP(pp_chmod)
3184{
4e35701f 3185 djSP; dMARK; dTARGET;
a0d0e21e 3186 I32 value;
533c011a 3187 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 3188 SP = MARK;
3189 PUSHi(value);
3190 RETURN;
3191}
3192
3193PP(pp_utime)
3194{
4e35701f 3195 djSP; dMARK; dTARGET;
a0d0e21e 3196 I32 value;
533c011a 3197 value = (I32)apply(PL_op->op_type, MARK, SP);
a0d0e21e
LW		 3198 SP = MARK;
3199 PUSHi(value);
3200 RETURN;
3201}
3202
3203PP(pp_rename)
3204{
4e35701f 3205 djSP; dTARGET;
a0d0e21e 3206 int anum;
2d8e6c8d 3207 STRLEN n_a;
a0d0e21e 3208
2d8e6c8d
GS		 3209 char *tmps2 = POPpx;
3210 char *tmps = SvPV(TOPs, n_a);
a0d0e21e
LW		 3211 TAINT_PROPER("rename");
3212#ifdef HAS_RENAME
baed7233 3213 anum = PerlLIO_rename(tmps, tmps2);
a0d0e21e 3214#else
6b88bc9c 3215 if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
ed969818
W		 3216 if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3217 anum = 1;
3218 else {
3654eb6c 3219 if (PL_euid || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
ed969818
W		 3220 (void)UNLINK(tmps2);
3221 if (!(anum = link(tmps, tmps2)))
3222 anum = UNLINK(tmps);
3223 }
a0d0e21e
LW		 3224 }
3225#endif
3226 SETi( anum >= 0 );
3227 RETURN;
3228}
3229
3230PP(pp_link)
3231{
4e35701f 3232 djSP; dTARGET;
a0d0e21e 3233#ifdef HAS_LINK
2d8e6c8d
GS		 3234 STRLEN n_a;
3235 char *tmps2 = POPpx;
3236 char *tmps = SvPV(TOPs, n_a);
a0d0e21e 3237 TAINT_PROPER("link");
6b980173 3238 SETi( PerlLIO_link(tmps, tmps2) >= 0 );
a0d0e21e 3239#else
cea2e8a9 3240 DIE(aTHX_ PL_no_func, "Unsupported function link");
a0d0e21e
LW		 3241#endif
3242 RETURN;
3243}
3244
3245PP(pp_symlink)
3246{
4e35701f 3247 djSP; dTARGET;
a0d0e21e 3248#ifdef HAS_SYMLINK
2d8e6c8d
GS		 3249 STRLEN n_a;
3250 char *tmps2 = POPpx;
3251 char *tmps = SvPV(TOPs, n_a);
a0d0e21e
LW		 3252 TAINT_PROPER("symlink");
3253 SETi( symlink(tmps, tmps2) >= 0 );
3254 RETURN;
3255#else
cea2e8a9 3256 DIE(aTHX_ PL_no_func, "symlink");
a0d0e21e
LW		 3257#endif
3258}
3259
3260PP(pp_readlink)
3261{
4e35701f 3262 djSP; dTARGET;
a0d0e21e
LW		 3263#ifdef HAS_SYMLINK
3264 char *tmps;
46fc3d4c 3265 char buf[MAXPATHLEN];
a0d0e21e 3266 int len;
2d8e6c8d 3267 STRLEN n_a;
46fc3d4c 3268
fb73857a 3269#ifndef INCOMPLETE_TAINTS
3270 TAINT;
3271#endif
2d8e6c8d 3272 tmps = POPpx;
a0d0e21e
LW		 3273 len = readlink(tmps, buf, sizeof buf);
3274 EXTEND(SP, 1);
3275 if (len < 0)
3276 RETPUSHUNDEF;
3277 PUSHp(buf, len);
3278 RETURN;
3279#else
3280 EXTEND(SP, 1);
3281 RETSETUNDEF; /* just pretend it's a normal file */
3282#endif
3283}
3284
3285#if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
ba106d47 3286STATIC int
cea2e8a9 3287S_dooneliner(pTHX_ char *cmd, char *filename)
a0d0e21e 3288{
1e422769 3289 char *save_filename = filename;
3290 char *cmdline;
3291 char *s;
760ac839 3292 PerlIO *myfp;
1e422769 3293 int anum = 1;
a0d0e21e 3294
1e422769 3295 New(666, cmdline, strlen(cmd) + (strlen(filename) * 2) + 10, char);
3296 strcpy(cmdline, cmd);
3297 strcat(cmdline, " ");
3298 for (s = cmdline + strlen(cmdline); *filename; ) {
a0d0e21e
LW		 3299 *s++ = '\\';
3300 *s++ = *filename++;
3301 }
3302 strcpy(s, " 2>&1");
6ad3d225 3303 myfp = PerlProc_popen(cmdline, "r");
1e422769 3304 Safefree(cmdline);
3305
a0d0e21e 3306 if (myfp) {
1e422769 3307 SV *tmpsv = sv_newmortal();
6b88bc9c 3308 /* Need to save/restore 'PL_rs' ?? */
760ac839 3309 s = sv_gets(tmpsv, myfp, 0);
6ad3d225 3310 (void)PerlProc_pclose(myfp);
a0d0e21e 3311 if (s != Nullch) {
1e422769 3312 int e;
3313 for (e = 1;
a0d0e21e 3314#ifdef HAS_SYS_ERRLIST
1e422769 3315 e <= sys_nerr
3316#endif
3317 ; e++)
3318 {
3319 /* you don't see this */
3320 char *errmsg =
3321#ifdef HAS_SYS_ERRLIST
3322 sys_errlist[e]
a0d0e21e 3323#else
1e422769 3324 strerror(e)
a0d0e21e 3325#endif
1e422769 3326 ;
3327 if (!errmsg)
3328 break;
3329 if (instr(s, errmsg)) {
3330 SETERRNO(e,0);
3331 return 0;
3332 }
a0d0e21e 3333 }
748a9306 3334 SETERRNO(0,0);
a0d0e21e
LW		 3335#ifndef EACCES
3336#define EACCES EPERM
3337#endif
1e422769 3338 if (instr(s, "cannot make"))
748a9306 3339 SETERRNO(EEXIST,RMS$_FEX);
1e422769 3340 else if (instr(s, "existing file"))
748a9306 3341 SETERRNO(EEXIST,RMS$_FEX);
1e422769 3342 else if (instr(s, "ile exists"))
748a9306 3343 SETERRNO(EEXIST,RMS$_FEX);
1e422769 3344 else if (instr(s, "non-exist"))
748a9306 3345 SETERRNO(ENOENT,RMS$_FNF);
1e422769 3346 else if (instr(s, "does not exist"))
748a9306 3347 SETERRNO(ENOENT,RMS$_FNF);
1e422769 3348 else if (instr(s, "not empty"))
748a9306 3349 SETERRNO(EBUSY,SS$_DEVOFFLINE);
1e422769 3350 else if (instr(s, "cannot access"))
748a9306 3351 SETERRNO(EACCES,RMS$_PRV);
a0d0e21e 3352 else
748a9306 3353 SETERRNO(EPERM,RMS$_PRV);
a0d0e21e
LW		 3354 return 0;
3355 }
3356 else { /* some mkdirs return no failure indication */
6b88bc9c 3357 anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
911d147d 3358 if (PL_op->op_type == OP_RMDIR)
a0d0e21e
LW		 3359 anum = !anum;
3360 if (anum)
748a9306 3361 SETERRNO(0,0);
a0d0e21e 3362 else
748a9306 3363 SETERRNO(EACCES,RMS$_PRV); /* a guess */
a0d0e21e
LW		 3364 }
3365 return anum;
3366 }
3367 else
3368 return 0;
3369}
3370#endif
3371
3372PP(pp_mkdir)
3373{
4e35701f 3374 djSP; dTARGET;
a0d0e21e
LW		 3375 int mode = POPi;
3376#ifndef HAS_MKDIR
3377 int oldumask;
3378#endif
2d8e6c8d
GS		 3379 STRLEN n_a;
3380 char *tmps = SvPV(TOPs, n_a);
a0d0e21e
LW		 3381
3382 TAINT_PROPER("mkdir");
3383#ifdef HAS_MKDIR
6ad3d225 3384 SETi( PerlDir_mkdir(tmps, mode) >= 0 );
a0d0e21e
LW		 3385#else
3386 SETi( dooneliner("mkdir", tmps) );
6ad3d225
GS		 3387 oldumask = PerlLIO_umask(0);
3388 PerlLIO_umask(oldumask);
3389 PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
a0d0e21e
LW		 3390#endif
3391 RETURN;
3392}
3393
3394PP(pp_rmdir)
3395{
4e35701f 3396 djSP; dTARGET;
a0d0e21e 3397 char *tmps;
2d8e6c8d 3398 STRLEN n_a;
a0d0e21e 3399
2d8e6c8d 3400 tmps = POPpx;
a0d0e21e
LW		 3401 TAINT_PROPER("rmdir");
3402#ifdef HAS_RMDIR
6ad3d225 3403 XPUSHi( PerlDir_rmdir(tmps) >= 0 );
a0d0e21e
LW		 3404#else
3405 XPUSHi( dooneliner("rmdir", tmps) );
3406#endif
3407 RETURN;
3408}
3409
3410/* Directory calls. */
3411
3412PP(pp_open_dir)
3413{
4e35701f 3414 djSP;
a0d0e21e 3415#if defined(Direntry_t) && defined(HAS_READDIR)
2d8e6c8d
GS		 3416 STRLEN n_a;
3417 char *dirname = POPpx;
a0d0e21e
LW		 3418 GV *gv = (GV*)POPs;
3419 register IO *io = GvIOn(gv);
3420
3421 if (!io)
3422 goto nope;
3423
3424 if (IoDIRP(io))
6ad3d225
GS		 3425 PerlDir_close(IoDIRP(io));
3426 if (!(IoDIRP(io) = PerlDir_open(dirname)))
a0d0e21e
LW		 3427 goto nope;
3428
3429 RETPUSHYES;
3430nope:
3431 if (!errno)
748a9306 3432 SETERRNO(EBADF,RMS$_DIR);
a0d0e21e
LW		 3433 RETPUSHUNDEF;
3434#else
cea2e8a9 3435 DIE(aTHX_ PL_no_dir_func, "opendir");
a0d0e21e
LW		 3436#endif
3437}
3438
3439PP(pp_readdir)
3440{
4e35701f 3441 djSP;
a0d0e21e
LW		 3442#if defined(Direntry_t) && defined(HAS_READDIR)
3443#ifndef I_DIRENT
20ce7b12 3444 Direntry_t *readdir (DIR *);
a0d0e21e
LW		 3445#endif
3446 register Direntry_t *dp;
3447 GV *gv = (GV*)POPs;
3448 register IO *io = GvIOn(gv);
fb73857a 3449 SV *sv;
a0d0e21e
LW		 3450
3451 if (!io || !IoDIRP(io))
3452 goto nope;
3453
3454 if (GIMME == G_ARRAY) {
3455 /*SUPPRESS 560*/
6ad3d225 3456 while (dp = (Direntry_t *)PerlDir_read(IoDIRP(io))) {
a0d0e21e 3457#ifdef DIRNAMLEN
79cb57f6 3458 sv = newSVpvn(dp->d_name, dp->d_namlen);
a0d0e21e 3459#else
fb73857a 3460 sv = newSVpv(dp->d_name, 0);
3461#endif
3462#ifndef INCOMPLETE_TAINTS
3463 SvTAINTED_on(sv);
a0d0e21e 3464#endif
fb73857a 3465 XPUSHs(sv_2mortal(sv));
a0d0e21e
LW		 3466 }
3467 }
3468 else {
6ad3d225 3469 if (!(dp = (Direntry_t *)PerlDir_read(IoDIRP(io))))
a0d0e21e
LW		 3470 goto nope;
3471#ifdef DIRNAMLEN
79cb57f6 3472 sv = newSVpvn(dp->d_name, dp->d_namlen);
a0d0e21e 3473#else
fb73857a 3474 sv = newSVpv(dp->d_name, 0);
a0d0e21e 3475#endif
fb73857a 3476#ifndef INCOMPLETE_TAINTS
3477 SvTAINTED_on(sv);
3478#endif
3479 XPUSHs(sv_2mortal(sv));
a0d0e21e
LW		 3480 }
3481 RETURN;
3482
3483nope:
3484 if (!errno)
748a9306 3485 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 3486 if (GIMME == G_ARRAY)
3487 RETURN;
3488 else
3489 RETPUSHUNDEF;
3490#else
cea2e8a9 3491 DIE(aTHX_ PL_no_dir_func, "readdir");
a0d0e21e
LW		 3492#endif
3493}
3494
3495PP(pp_telldir)
3496{
4e35701f 3497 djSP; dTARGET;
a0d0e21e 3498#if defined(HAS_TELLDIR) || defined(telldir)
968dcd91
JH		 3499 /* XXX does _anyone_ need this? --AD 2/20/1998 */
3500 /* XXX netbsd still seemed to.
3501 XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3502 --JHI 1999-Feb-02 */
3503# if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
20ce7b12 3504 long telldir (DIR *);
dfe9444c 3505# endif
a0d0e21e
LW		 3506 GV *gv = (GV*)POPs;
3507 register IO *io = GvIOn(gv);
3508
3509 if (!io || !IoDIRP(io))
3510 goto nope;
3511
6ad3d225 3512 PUSHi( PerlDir_tell(IoDIRP(io)) );
a0d0e21e
LW		 3513 RETURN;
3514nope:
3515 if (!errno)
748a9306 3516 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 3517 RETPUSHUNDEF;
3518#else
cea2e8a9 3519 DIE(aTHX_ PL_no_dir_func, "telldir");
a0d0e21e
LW		 3520#endif
3521}
3522
3523PP(pp_seekdir)
3524{
4e35701f 3525 djSP;
a0d0e21e
LW		 3526#if defined(HAS_SEEKDIR) || defined(seekdir)
3527 long along = POPl;
3528 GV *gv = (GV*)POPs;
3529 register IO *io = GvIOn(gv);
3530
3531 if (!io || !IoDIRP(io))
3532 goto nope;
3533
6ad3d225 3534 (void)PerlDir_seek(IoDIRP(io), along);
a0d0e21e
LW		 3535
3536 RETPUSHYES;
3537nope:
3538 if (!errno)
748a9306 3539 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 3540 RETPUSHUNDEF;
3541#else
cea2e8a9 3542 DIE(aTHX_ PL_no_dir_func, "seekdir");
a0d0e21e
LW		 3543#endif
3544}
3545
3546PP(pp_rewinddir)
3547{
4e35701f 3548 djSP;
a0d0e21e
LW		 3549#if defined(HAS_REWINDDIR) || defined(rewinddir)
3550 GV *gv = (GV*)POPs;
3551 register IO *io = GvIOn(gv);
3552
3553 if (!io || !IoDIRP(io))
3554 goto nope;
3555
6ad3d225 3556 (void)PerlDir_rewind(IoDIRP(io));
a0d0e21e
LW		 3557 RETPUSHYES;
3558nope:
3559 if (!errno)
748a9306 3560 SETERRNO(EBADF,RMS$_ISI);
a0d0e21e
LW		 3561 RETPUSHUNDEF;
3562#else
cea2e8a9 3563 DIE(aTHX_ PL_no_dir_func, "rewinddir");
a0d0e21e
LW		 3564#endif
3565}
3566
3567PP(pp_closedir)
3568{
4e35701f 3569 djSP;
a0d0e21e
LW		 3570#if defined(Direntry_t) && defined(HAS_READDIR)
3571 GV *gv = (GV*)POPs;
3572 register IO *io = GvIOn(gv);
3573
3574 if (!io || !IoDIRP(io))
3575 goto nope;
3576
3577#ifdef VOID_CLOSEDIR
6ad3d225 3578 PerlDir_close(IoDIRP(io));
a0d0e21e 3579#else
6ad3d225 3580 if (PerlDir_close(IoDIRP(io)) < 0) {
748a9306 3581 IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
a0d0e21e 3582 goto nope;
748a9306 3583 }
a0d0e21e
LW		 3584#endif
3585 IoDIRP(io) = 0;
3586
3587 RETPUSHYES;
3588nope:
3589 if (!errno)
748a9306 3590 SETERRNO(EBADF,RMS$_IFI);
a0d0e21e
LW		 3591 RETPUSHUNDEF;
3592#else
cea2e8a9 3593 DIE(aTHX_ PL_no_dir_func, "closedir");
a0d0e21e
LW		 3594#endif