source: vendor/perl/5.8.8/pp_sys.c

Last change on this file was 3181, checked in by bird, 18 years ago

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