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