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