File Coverage

pp_sys.c
Criterion Covered Total %
statement 1935 2194 88.2
branch 1846 2716 68.0
condition n/a
subroutine n/a
total 3781 4910 77.0


line stmt bran cond sub time code
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           #include "time64.c"
34            
35           #ifdef I_SHADOW
36           /* Shadow password support for solaris - pdo@cs.umd.edu
37           * Not just Solaris: at least HP-UX, IRIX, Linux.
38           * The API is from SysV.
39           *
40           * There are at least two more shadow interfaces,
41           * see the comments in pp_gpwent().
42           *
43           * --jhi */
44           # ifdef __hpux__
45           /* There is a MAXINT coming from <- <-
46           * and another MAXINT from "perl.h" <- . */
47           # undef MAXINT
48           # endif
49           # include
50           #endif
51            
52           #ifdef I_SYS_RESOURCE
53           # include
54           #endif
55            
56           #ifdef NETWARE
57           NETDB_DEFINE_CONTEXT
58           #endif
59            
60           #ifdef HAS_SELECT
61           # ifdef I_SYS_SELECT
62           # include
63           # endif
64           #endif
65            
66           /* XXX Configure test needed.
67           h_errno might not be a simple 'int', especially for multi-threaded
68           applications, see "extern int errno in perl.h". Creating such
69           a test requires taking into account the differences between
70           compiling multithreaded and singlethreaded ($ccflags et al).
71           HOST_NOT_FOUND is typically defined in .
72           */
73           #if defined(HOST_NOT_FOUND) && !defined(h_errno) && !defined(__CYGWIN__)
74           extern int h_errno;
75           #endif
76            
77           #ifdef HAS_PASSWD
78           # ifdef I_PWD
79           # include
80           # else
81           # if !defined(VMS)
82           struct passwd *getpwnam (char *);
83           struct passwd *getpwuid (Uid_t);
84           # endif
85           # endif
86           # ifdef HAS_GETPWENT
87           #ifndef getpwent
88           struct passwd *getpwent (void);
89           #elif defined (VMS) && defined (my_getpwent)
90           struct passwd *Perl_my_getpwent (pTHX);
91           #endif
92           # endif
93           #endif
94            
95           #ifdef HAS_GROUP
96           # ifdef I_GRP
97           # include
98           # else
99           struct group *getgrnam (char *);
100           struct group *getgrgid (Gid_t);
101           # endif
102           # ifdef HAS_GETGRENT
103           #ifndef getgrent
104           struct group *getgrent (void);
105           #endif
106           # endif
107           #endif
108            
109           #ifdef I_UTIME
110           # if defined(_MSC_VER) || defined(__MINGW32__)
111           # include
112           # else
113           # include
114           # endif
115           #endif
116            
117           #ifdef HAS_CHSIZE
118           # ifdef my_chsize /* Probably #defined to Perl_my_chsize in embed.h */
119           # undef my_chsize
120           # endif
121           # define my_chsize PerlLIO_chsize
122           #else
123           # ifdef HAS_TRUNCATE
124           # define my_chsize PerlLIO_chsize
125           # else
126           I32 my_chsize(int fd, Off_t length);
127           # endif
128           #endif
129            
130           #ifdef HAS_FLOCK
131           # define FLOCK flock
132           #else /* no flock() */
133            
134           /* fcntl.h might not have been included, even if it exists, because
135           the current Configure only sets I_FCNTL if it's needed to pick up
136           the *_OK constants. Make sure it has been included before testing
137           the fcntl() locking constants. */
138           # if defined(HAS_FCNTL) && !defined(I_FCNTL)
139           # include
140           # endif
141            
142           # if defined(HAS_FCNTL) && defined(FCNTL_CAN_LOCK)
143           # define FLOCK fcntl_emulate_flock
144           # define FCNTL_EMULATE_FLOCK
145           # else /* no flock() or fcntl(F_SETLK,...) */
146           # ifdef HAS_LOCKF
147           # define FLOCK lockf_emulate_flock
148           # define LOCKF_EMULATE_FLOCK
149           # endif /* lockf */
150           # endif /* no flock() or fcntl(F_SETLK,...) */
151            
152           # ifdef FLOCK
153           static int FLOCK (int, int);
154            
155           /*
156           * These are the flock() constants. Since this sytems doesn't have
157           * flock(), the values of the constants are probably not available.
158           */
159           # ifndef LOCK_SH
160           # define LOCK_SH 1
161           # endif
162           # ifndef LOCK_EX
163           # define LOCK_EX 2
164           # endif
165           # ifndef LOCK_NB
166           # define LOCK_NB 4
167           # endif
168           # ifndef LOCK_UN
169           # define LOCK_UN 8
170           # endif
171           # endif /* emulating flock() */
172            
173           #endif /* no flock() */
174            
175           #define ZBTLEN 10
176           static const char zero_but_true[ZBTLEN + 1] = "0 but true";
177            
178           #if defined(I_SYS_ACCESS) && !defined(R_OK)
179           # include
180           #endif
181            
182           #if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
183           # define FD_CLOEXEC 1 /* NeXT needs this */
184           #endif
185            
186           #include "reentr.h"
187            
188           #ifdef __Lynx__
189           /* Missing protos on LynxOS */
190           void sethostent(int);
191           void endhostent(void);
192           void setnetent(int);
193           void endnetent(void);
194           void setprotoent(int);
195           void endprotoent(void);
196           void setservent(int);
197           void endservent(void);
198           #endif
199            
200           #undef PERL_EFF_ACCESS /* EFFective uid/gid ACCESS */
201            
202           /* F_OK unused: if stat() cannot find it... */
203            
204           #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) && defined(EFF_ONLY_OK) && !defined(NO_EFF_ONLY_OK)
205           /* Digital UNIX (when the EFF_ONLY_OK gets fixed), UnixWare */
206           # define PERL_EFF_ACCESS(p,f) (access((p), (f) | EFF_ONLY_OK))
207           #endif
208            
209           #if !defined(PERL_EFF_ACCESS) && defined(HAS_EACCESS)
210           # ifdef I_SYS_SECURITY
211           # include
212           # endif
213           # ifdef ACC_SELF
214           /* HP SecureWare */
215           # define PERL_EFF_ACCESS(p,f) (eaccess((p), (f), ACC_SELF))
216           # else
217           /* SCO */
218           # define PERL_EFF_ACCESS(p,f) (eaccess((p), (f)))
219           # endif
220           #endif
221            
222           #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESSX) && defined(ACC_SELF)
223           /* AIX */
224           # define PERL_EFF_ACCESS(p,f) (accessx((p), (f), ACC_SELF))
225           #endif
226            
227            
228           #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESS) \
229           && (defined(HAS_SETREUID) || defined(HAS_SETRESUID) \
230           || defined(HAS_SETREGID) || defined(HAS_SETRESGID))
231           /* The Hard Way. */
232           STATIC int
233           S_emulate_eaccess(pTHX_ const char* path, Mode_t mode)
234           {
235           const Uid_t ruid = getuid();
236           const Uid_t euid = geteuid();
237           const Gid_t rgid = getgid();
238           const Gid_t egid = getegid();
239           int res;
240            
241           #if !defined(HAS_SETREUID) && !defined(HAS_SETRESUID)
242           Perl_croak(aTHX_ "switching effective uid is not implemented");
243           #else
244           #ifdef HAS_SETREUID
245           if (setreuid(euid, ruid))
246           #else
247           #ifdef HAS_SETRESUID
248           if (setresuid(euid, ruid, (Uid_t)-1))
249           #endif
250           #endif
251           /* diag_listed_as: entering effective %s failed */
252           Perl_croak(aTHX_ "entering effective uid failed");
253           #endif
254            
255           #if !defined(HAS_SETREGID) && !defined(HAS_SETRESGID)
256           Perl_croak(aTHX_ "switching effective gid is not implemented");
257           #else
258           #ifdef HAS_SETREGID
259           if (setregid(egid, rgid))
260           #else
261           #ifdef HAS_SETRESGID
262           if (setresgid(egid, rgid, (Gid_t)-1))
263           #endif
264           #endif
265           /* diag_listed_as: entering effective %s failed */
266           Perl_croak(aTHX_ "entering effective gid failed");
267           #endif
268            
269           res = access(path, mode);
270            
271           #ifdef HAS_SETREUID
272           if (setreuid(ruid, euid))
273           #else
274           #ifdef HAS_SETRESUID
275           if (setresuid(ruid, euid, (Uid_t)-1))
276           #endif
277           #endif
278           /* diag_listed_as: leaving effective %s failed */
279           Perl_croak(aTHX_ "leaving effective uid failed");
280            
281           #ifdef HAS_SETREGID
282           if (setregid(rgid, egid))
283           #else
284           #ifdef HAS_SETRESGID
285           if (setresgid(rgid, egid, (Gid_t)-1))
286           #endif
287           #endif
288           /* diag_listed_as: leaving effective %s failed */
289           Perl_croak(aTHX_ "leaving effective gid failed");
290            
291           return res;
292           }
293           # define PERL_EFF_ACCESS(p,f) (S_emulate_eaccess(aTHX_ (p), (f)))
294           #endif
295            
296 13022         PP(pp_backtick)
297           {
298 13022         dVAR; dSP; dTARGET;
299           PerlIO *fp;
300 13022 100       const char * const tmps = POPpconstx;
301 13022 100       const I32 gimme = GIMME_V;
302           const char *mode = "r";
303            
304 13022 100       TAINT_PROPER("``");
305 13014 50       if (PL_op->op_private & OPpOPEN_IN_RAW)
306           mode = "rb";
307 13014 50       else if (PL_op->op_private & OPpOPEN_IN_CRLF)
308           mode = "rt";
309 13014         fp = PerlProc_popen(tmps, mode);
310 13014 100       if (fp) {
311 13010         const char * const type = Perl_PerlIO_context_layers(aTHX_ NULL);
312 13010 100       if (type && *type)
    50        
313 10         PerlIO_apply_layers(aTHX_ fp,mode,type);
314            
315 13010 100       if (gimme == G_VOID) {
316           char tmpbuf[256];
317 32 100       while (PerlIO_read(fp, tmpbuf, sizeof tmpbuf) > 0)
318           NOOP;
319           }
320 12992 100       else if (gimme == G_SCALAR) {
321 12740         ENTER_with_name("backtick");
322 12740         SAVESPTR(PL_rs);
323 12740         PL_rs = &PL_sv_undef;
324 12740         sv_setpvs(TARG, ""); /* note that this preserves previous buffer */
325 18806 100       while (sv_gets(TARG, fp, SvCUR(TARG)) != NULL)
326           NOOP;
327 12738         LEAVE_with_name("backtick");
328 12738 50       XPUSHs(TARG);
329 14998 50       SvTAINTED_on(TARG);
330           }
331           else {
332           for (;;) {
333 4772         SV * const sv = newSV(79);
334 4772 100       if (sv_gets(sv, fp, 0) == NULL) {
335 252         SvREFCNT_dec(sv);
336 252         break;
337           }
338 4520 50       mXPUSHs(sv);
339 4520 100       if (SvLEN(sv) - SvCUR(sv) > 20) {
340 4424         SvPV_shrink_to_cur(sv);
341           }
342 4520 50       SvTAINTED_on(sv);
343           }
344           }
345 13008 50       STATUS_NATIVE_CHILD_SET(PerlProc_pclose(fp));
    50        
    50        
    50        
    0        
346 13008         TAINT; /* "I believe that this is not gratuitous!" */
347           }
348           else {
349 4 50       STATUS_NATIVE_CHILD_SET(-1);
    0        
    0        
    0        
    0        
350 4 50       if (gimme == G_SCALAR)
351 4         RETPUSHUNDEF;
352           }
353            
354 13010         RETURN;
355           }
356            
357 18388         PP(pp_glob)
358           {
359           dVAR;
360           OP *result;
361 18388         dSP;
362 18388 100       GV * const gv = (PL_op->op_flags & OPf_SPECIAL) ? NULL : (GV *)POPs;
363            
364 18388         PUTBACK;
365            
366           /* make a copy of the pattern if it is gmagical, to ensure that magic
367           * is called once and only once */
368 18388 50       if (SvGMAGICAL(TOPs)) TOPs = sv_2mortal(newSVsv(TOPs));
369            
370 18388 100       tryAMAGICunTARGETlist(iter_amg, (PL_op->op_flags & OPf_SPECIAL));
    50        
    0        
    0        
    0        
    0        
    0        
    0        
    0        
    0        
    0        
    0        
    0        
    0        
371            
372 18388 100       if (PL_op->op_flags & OPf_SPECIAL) {
373           /* call Perl-level glob function instead. Stack args are:
374           * MARK, wildcard
375           * and following OPs should be: gv(CORE::GLOBAL::glob), entersub
376           * */
377 16184         return NORMAL;
378           }
379 2204 100       if (PL_globhook) {
380 1766         PL_globhook(aTHX);
381 1766         return NORMAL;
382           }
383            
384           /* Note that we only ever get here if File::Glob fails to load
385           * without at the same time croaking, for some reason, or if
386           * perl was built with PERL_EXTERNAL_GLOB */
387            
388 438         ENTER_with_name("glob");
389            
390           #ifndef VMS
391 438 50       if (TAINTING_get) {
392           /*
393           * The external globbing program may use things we can't control,
394           * so for security reasons we must assume the worst.
395           */
396 0         TAINT;
397 0         taint_proper(PL_no_security, "glob");
398           }
399           #endif /* !VMS */
400            
401 438         SAVESPTR(PL_last_in_gv); /* We don't want this to be permanent. */
402 438         PL_last_in_gv = gv;
403            
404 438         SAVESPTR(PL_rs); /* This is not permanent, either. */
405 438         PL_rs = newSVpvs_flags("\000", SVs_TEMP);
406           #ifndef DOSISH
407           #ifndef CSH
408 438         *SvPVX(PL_rs) = '\n';
409           #endif /* !CSH */
410           #endif /* !DOSISH */
411            
412 438         result = do_readline();
413 438         LEAVE_with_name("glob");
414 9413         return result;
415           }
416            
417 3500         PP(pp_rcatline)
418           {
419           dVAR;
420 3500         PL_last_in_gv = cGVOP_gv;
421 3500         return do_readline();
422           }
423            
424 24357         PP(pp_warn)
425           {
426 24357         dVAR; dSP; dMARK;
427           SV *exsv;
428           STRLEN len;
429 24357 100       if (SP - MARK > 1) {
430 42         dTARGET;
431 42         do_join(TARG, &PL_sv_no, MARK, SP);
432           exsv = TARG;
433 42         SP = MARK + 1;
434           }
435 24329 100       else if (SP == MARK) {
    50        
436           exsv = &PL_sv_no;
437 14         EXTEND(SP, 1);
438 28         SP = MARK + 1;
439           }
440           else {
441 24287         exsv = TOPs;
442 24287 100       if (SvGMAGICAL(exsv)) exsv = sv_mortalcopy(exsv);
443           }
444            
445 24353 100       if (SvROK(exsv) || (SvPV_const(exsv, len), len)) {
    100        
    100        
446           /* well-formed exception supplied */
447           }
448 38 100       else {
449 38 50       SV * const errsv = ERRSV;
450 23         SvGETMAGIC(errsv);
451 38 100       if (SvROK(errsv)) {
452 6 100       if (SvGMAGICAL(errsv)) {
453 2         exsv = sv_newmortal();
454 2         sv_setsv_nomg(exsv, errsv);
455           }
456           else exsv = errsv;
457           }
458 32 100       else if (SvPOKp(errsv) ? SvCUR(errsv) : SvNIOKp(errsv)) {
    100        
459 12         exsv = sv_newmortal();
460 12         sv_setsv_nomg(exsv, errsv);
461 12         sv_catpvs(exsv, "\t...caught");
462           }
463           else {
464 20         exsv = newSVpvs_flags("Warning: something's wrong", SVs_TEMP);
465           }
466           }
467 24353 100       if (SvROK(exsv) && !PL_warnhook)
    100        
468 2         Perl_warn(aTHX_ "%"SVf, SVfARG(exsv));
469 24351         else warn_sv(exsv);
470 24347         RETSETYES;
471           }
472            
473 27552         PP(pp_die)
474           {
475 27552         dVAR; dSP; dMARK;
476           SV *exsv;
477           STRLEN len;
478           #ifdef VMS
479           VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
480           #endif
481 27552 100       if (SP - MARK != 1) {
482 262         dTARGET;
483 262         do_join(TARG, &PL_sv_no, MARK, SP);
484           exsv = TARG;
485 262         SP = MARK + 1;
486           }
487           else {
488 27290         exsv = TOPs;
489           }
490            
491 27552 100       if (SvROK(exsv) || (SvPV_const(exsv, len), len)) {
    50        
    100        
492           /* well-formed exception supplied */
493           }
494 254 50       else {
495 254 50       SV * const errsv = ERRSV;
496 127         SvGETMAGIC(errsv);
497 254 100       if (SvROK(errsv)) {
498           exsv = errsv;
499 4 100       if (sv_isobject(exsv)) {
500 2         HV * const stash = SvSTASH(SvRV(exsv));
501 2         GV * const gv = gv_fetchmethod(stash, "PROPAGATE");
502 4         if (gv) {
503 2 50       SV * const file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0));
504 2         SV * const line = sv_2mortal(newSVuv(CopLINE(PL_curcop)));
505 1         EXTEND(SP, 3);
506 2 50       PUSHMARK(SP);
507 2         PUSHs(exsv);
508 2         PUSHs(file);
509 2         PUSHs(line);
510 2         PUTBACK;
511 2         call_sv(MUTABLE_SV(GvCV(gv)),
512           G_SCALAR|G_EVAL|G_KEEPERR);
513 2         exsv = sv_mortalcopy(*PL_stack_sp--);
514           }
515           }
516           }
517 250 100       else if (SvPOK(errsv) && SvCUR(errsv)) {
    100        
518 2         exsv = sv_mortalcopy(errsv);
519 2         sv_catpvs(exsv, "\t...propagated");
520           }
521           else {
522 248         exsv = newSVpvs_flags("Died", SVs_TEMP);
523           }
524           }
525 27552         return die_sv(exsv);
526           }
527            
528           /* I/O. */
529            
530           OP *
531 202610         Perl_tied_method(pTHX_ SV *methname, SV **sp, SV *const sv,
532           const MAGIC *const mg, const U32 flags, U32 argc, ...)
533 202610 100       {
534           SV **orig_sp = sp;
535           I32 ret_args;
536            
537           PERL_ARGS_ASSERT_TIED_METHOD;
538            
539           /* Ensure that our flag bits do not overlap. */
540           assert((TIED_METHOD_MORTALIZE_NOT_NEEDED & G_WANT) == 0);
541           assert((TIED_METHOD_ARGUMENTS_ON_STACK & G_WANT) == 0);
542           assert((TIED_METHOD_SAY & G_WANT) == 0);
543            
544 202610         PUTBACK; /* sp is at *foot* of args, so this pops args from old stack */
545 202610 50       PUSHSTACKi(PERLSI_MAGIC);
546 101325         EXTEND(SP, argc+1); /* object + args */
547 202610 50       PUSHMARK(sp);
548 202610 100       PUSHs(SvTIED_obj(sv, mg));
549 202610 100       if (flags & TIED_METHOD_ARGUMENTS_ON_STACK) {
550 193492 50       Copy(orig_sp + 2, sp + 1, argc, SV*); /* copy args to new stack */
551 193492         sp += argc;
552           }
553 9118 100       else if (argc) {
554 142         const U32 mortalize_not_needed
555           = flags & TIED_METHOD_MORTALIZE_NOT_NEEDED;
556           va_list args;
557 142         va_start(args, argc);
558           do {
559 234 50       SV *const arg = va_arg(args, SV *);
560 234 50       if(mortalize_not_needed)
561 0         PUSHs(arg);
562           else
563 234         mPUSHs(arg);
564 234 100       } while (--argc);
565 142         va_end(args);
566           }
567            
568 202610         PUTBACK;
569 202610         ENTER_with_name("call_tied_method");
570 202610 100       if (flags & TIED_METHOD_SAY) {
571           /* local $\ = "\n" */
572 2         SAVEGENERICSV(PL_ors_sv);
573 2         PL_ors_sv = newSVpvs("\n");
574           }
575 202610         ret_args = call_sv(methname, (flags & G_WANT)|G_METHOD_NAMED);
576 202466         SPAGAIN;
577           orig_sp = sp;
578 202466 50       POPSTACK;
579 202466         SPAGAIN;
580 303418 100       if (ret_args) { /* copy results back to original stack */
    50        
581 100952         EXTEND(sp, ret_args);
582 201904 50       Copy(orig_sp - ret_args + 1, sp + 1, ret_args, SV*);
583 201904         sp += ret_args;
584 201904         PUTBACK;
585           }
586 202466         LEAVE_with_name("call_tied_method");
587 202466         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            
597 4858141         PP(pp_open)
598           {
599 4858141         dVAR; dSP;
600 4858141         dMARK; dORIGMARK;
601 4858141         dTARGET;
602           SV *sv;
603           IO *io;
604           const char *tmps;
605           STRLEN len;
606           bool ok;
607            
608 4858141         GV * const gv = MUTABLE_GV(*++MARK);
609            
610 4858141 50       if (!isGV(gv) && !(SvTYPE(gv) == SVt_PVLV && isGV_with_GP(gv)))
    0        
    0        
    0        
611 0         DIE(aTHX_ PL_no_usym, "filehandle");
612            
613 4858141 100       if ((io = GvIOp(gv))) {
614           const MAGIC *mg;
615 47016         IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT;
616            
617 47016 100       if (IoDIRP(io))
618 22         Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
619           "Opening dirhandle %"HEKf" also as a file",
620 22 50       HEKfARG(GvENAME_HEK(gv)));
621            
622 47016 100       mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
623 47016 100       if (mg) {
624           /* Method's args are same as ours ... */
625           /* ... except handle is replaced by the object */
626 4 100       return Perl_tied_method(aTHX_ SV_CONST(OPEN), mark - 1, MUTABLE_SV(io), mg,
627           G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
628 4         sp - mark);
629           }
630           }
631            
632 4858137 100       if (MARK < SP) {
633 4858091         sv = *++MARK;
634           }
635           else {
636 46 100       sv = GvSVn(gv);
637           }
638            
639 4858137 100       tmps = SvPV_const(sv, len);
640 4858137         ok = do_openn(gv, tmps, len, FALSE, O_RDONLY, 0, NULL, MARK+1, (SP-MARK));
641 4858117         SP = ORIGMARK;
642 4858117 100       if (ok)
643 3170021 50       PUSHi( (I32)PL_forkprocess );
644 1688096 100       else if (PL_forkprocess == 0) /* we are a new child */
645 8 50       PUSHi(0);
646           else
647 1688088         RETPUSHUNDEF;
648 4014075         RETURN;
649           }
650            
651 2437848         PP(pp_close)
652           {
653 2437848         dVAR; dSP;
654           GV * const gv =
655 2437848 100       MAXARG == 0 || (!TOPs && !POPs) ? PL_defoutgv : MUTABLE_GV(POPs);
    100        
    50        
656            
657 2437849 100       if (MAXARG == 0)
    50        
658 1         EXTEND(SP, 1);
659            
660 2437848 50       if (gv) {
661 2437848 50       IO * const io = GvIO(gv);
    100        
    50        
662 2437848 100       if (io) {
663 2437820 100       const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
664 2437820 100       if (mg) {
665 234 100       return tied_method0(SV_CONST(CLOSE), SP, MUTABLE_SV(io), mg);
666           }
667           }
668           }
669 2437614 100       PUSHs(boolSV(do_close(gv, TRUE)));
670 2437725         RETURN;
671           }
672            
673 2636         PP(pp_pipe_op)
674           {
675           #ifdef HAS_PIPE
676           dVAR;
677 2636         dSP;
678           IO *rstio;
679           IO *wstio;
680           int fd[2];
681            
682 2636         GV * const wgv = MUTABLE_GV(POPs);
683 2636         GV * const rgv = MUTABLE_GV(POPs);
684            
685 2636 50       if (!rgv || !wgv)
686           goto badexit;
687            
688 2636 50       if (!isGV_with_GP(rgv) || !isGV_with_GP(wgv))
    50        
    50        
    50        
689 0         DIE(aTHX_ PL_no_usym, "filehandle");
690 2636 50       rstio = GvIOn(rgv);
    50        
    50        
    100        
691 2636 50       wstio = GvIOn(wgv);
    50        
    50        
    100        
692            
693 2636 100       if (IoIFP(rstio))
694 14         do_close(rgv, FALSE);
695 2636 100       if (IoIFP(wstio))
696 14         do_close(wgv, FALSE);
697            
698 2636 50       if (PerlProc_pipe(fd) < 0)
699           goto badexit;
700            
701 2636         IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"PIPE_OPEN_MODE);
702 2636         IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"PIPE_OPEN_MODE);
703 2636         IoOFP(rstio) = IoIFP(rstio);
704 2636         IoIFP(wstio) = IoOFP(wstio);
705 2636         IoTYPE(rstio) = IoTYPE_RDONLY;
706 2636         IoTYPE(wstio) = IoTYPE_WRONLY;
707            
708 2636 50       if (!IoIFP(rstio) || !IoOFP(wstio)) {
    50        
709 0 0       if (IoIFP(rstio))
710 0         PerlIO_close(IoIFP(rstio));
711           else
712 0         PerlLIO_close(fd[0]);
713 0 0       if (IoOFP(wstio))
714 0         PerlIO_close(IoOFP(wstio));
715           else
716 0         PerlLIO_close(fd[1]);
717           goto badexit;
718           }
719           #if defined(HAS_FCNTL) && defined(F_SETFD)
720 2636         fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
721 2636         fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
722           #endif
723 2636         RETPUSHYES;
724            
725           badexit:
726 1318         RETPUSHUNDEF;
727           #else
728           DIE(aTHX_ PL_no_func, "pipe");
729           #endif
730           }
731            
732 9726         PP(pp_fileno)
733           {
734 9726         dVAR; dSP; dTARGET;
735           GV *gv;
736           IO *io;
737           PerlIO *fp;
738           const MAGIC *mg;
739            
740 9726 50       if (MAXARG < 1)
741 0         RETPUSHUNDEF;
742 9726         gv = MUTABLE_GV(POPs);
743 9726 50       io = GvIO(gv);
    100        
    50        
744            
745 9726 100       if (io
746 9594 100       && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
    100        
747           {
748 22 100       return tied_method0(SV_CONST(FILENO), SP, MUTABLE_SV(io), mg);
749           }
750            
751 9704 100       if (!io || !(fp = IoIFP(io))) {
    100        
752           /* Can't do this because people seem to do things like
753           defined(fileno($foo)) to check whether $foo is a valid fh.
754            
755           report_evil_fh(gv);
756           */
757 242         RETPUSHUNDEF;
758           }
759            
760 9462 50       PUSHi(PerlIO_fileno(fp));
761 9594         RETURN;
762           }
763            
764 612         PP(pp_umask)
765           {
766           dVAR;
767 612         dSP;
768           #ifdef HAS_UMASK
769 612         dTARGET;
770           Mode_t anum;
771            
772 612 100       if (MAXARG < 1 || (!TOPs && !POPs)) {
    100        
    50        
773 476         anum = PerlLIO_umask(022);
774           /* setting it to 022 between the two calls to umask avoids
775           * to have a window where the umask is set to 0 -- meaning
776           * that another thread could create world-writeable files. */
777 476 100       if (anum != 022)
778 412         (void)PerlLIO_umask(anum);
779           }
780           else
781 136 100       anum = PerlLIO_umask(POPi);
782 612 50       TAINT_PROPER("umask");
783 612 50       XPUSHi(anum);
    50        
784           #else
785           /* Only DIE if trying to restrict permissions on "user" (self).
786           * Otherwise it's harmless and more useful to just return undef
787           * since 'group' and 'other' concepts probably don't exist here. */
788           if (MAXARG >= 1 && (TOPs||POPs) && (POPi & 0700))
789           DIE(aTHX_ "umask not implemented");
790           XPUSHs(&PL_sv_undef);
791           #endif
792 612         RETURN;
793           }
794            
795 3113021         PP(pp_binmode)
796           {
797 3113021         dVAR; dSP;
798           GV *gv;
799           IO *io;
800           PerlIO *fp;
801           SV *discp = NULL;
802            
803 3113021 50       if (MAXARG < 1)
804 0         RETPUSHUNDEF;
805 3113021 100       if (MAXARG > 1) {
806 11430         discp = POPs;
807           }
808            
809 3113021         gv = MUTABLE_GV(POPs);
810 3113021 50       io = GvIO(gv);
    100        
    50        
811            
812 3113021 100       if (io) {
813 3113017 100       const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
814 3113017 100       if (mg) {
815           /* This takes advantage of the implementation of the varargs
816           function, which I don't think that the optimiser will be able to
817           figure out. Although, as it's a static function, in theory it
818           could. */
819 2 50       return Perl_tied_method(aTHX_ SV_CONST(BINMODE), SP, MUTABLE_SV(io), mg,
820           G_SCALAR|TIED_METHOD_MORTALIZE_NOT_NEEDED,
821           discp ? 1 : 0, discp);
822           }
823           }
824            
825 3113019 100       if (!io || !(fp = IoIFP(io))) {
    100        
826 20         report_evil_fh(gv);
827 20         SETERRNO(EBADF,RMS_IFI);
828 20         RETPUSHUNDEF;
829           }
830            
831 3112999         PUTBACK;
832           {
833 3112999         STRLEN len = 0;
834           const char *d = NULL;
835           int mode;
836 3112999 100       if (discp)
837 11424 100       d = SvPV_const(discp, len);
838 3112999         mode = mode_from_discipline(d, len);
839 3112999 100       if (PerlIO_binmode(aTHX_ fp, IoTYPE(io), mode, d)) {
840 3112995 100       if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
    100        
841 16 50       if (!PerlIO_binmode(aTHX_ IoOFP(io), IoTYPE(io), mode, d)) {
842 0         SPAGAIN;
843 0         RETPUSHUNDEF;
844           }
845           }
846 3112995         SPAGAIN;
847 3112995         RETPUSHYES;
848           }
849           else {
850 4         SPAGAIN;
851 1557051         RETPUSHUNDEF;
852           }
853           }
854           }
855            
856 59888         PP(pp_tie)
857           {
858 59888         dVAR; dSP; dMARK;
859           HV* stash;
860           GV *gv = NULL;
861           SV *sv;
862 59888         const I32 markoff = MARK - PL_stack_base;
863           const char *methname;
864           int how = PERL_MAGIC_tied;
865           U32 items;
866 59888         SV *varsv = *++MARK;
867            
868 59888         switch(SvTYPE(varsv)) {
869           case SVt_PVHV:
870           {
871           HE *entry;
872           methname = "TIEHASH";
873 20312 100       if (HvLAZYDEL(varsv) && (entry = HvEITER((HV *)varsv))) {
    50        
874 2         HvLAZYDEL_off(varsv);
875 2         hv_free_ent((HV *)varsv, entry);
876           }
877 20312         HvEITER_set(MUTABLE_HV(varsv), 0);
878 20312         break;
879           }
880           case SVt_PVAV:
881           methname = "TIEARRAY";
882 6186 100       if (!AvREAL(varsv)) {
883 4 50       if (!AvREIFY(varsv))
884 0         Perl_croak(aTHX_ "Cannot tie unreifiable array");
885 4         av_clear((AV *)varsv);
886 4         AvREIFY_off(varsv);
887 4         AvREAL_on(varsv);
888           }
889           break;
890           case SVt_PVGV:
891           case SVt_PVLV:
892 32298 100       if (isGV_with_GP(varsv) && !SvFAKE(varsv)) {
    50        
    100        
893           methname = "TIEHANDLE";
894           how = PERL_MAGIC_tiedscalar;
895           /* For tied filehandles, we apply tiedscalar magic to the IO
896           slot of the GP rather than the GV itself. AMS 20010812 */
897 32292 100       if (!GvIOp(varsv))
898 31820         GvIOp(varsv) = newIO();
899 32292         varsv = MUTABLE_SV(GvIOp(varsv));
900 32292         break;
901           }
902 6 100       if (SvTYPE(varsv) == SVt_PVLV && LvTYPE(varsv) == 'y') {
    50        
903 2         vivify_defelem(varsv);
904 2         varsv = LvTARG(varsv);
905           }
906           /* FALL THROUGH */
907           default:
908           methname = "TIESCALAR";
909           how = PERL_MAGIC_tiedscalar;
910           break;
911           }
912 59888         items = SP - MARK++;
913 119772 100       if (sv_isobject(*MARK)) { /* Calls GET magic. */
    50        
    50        
914 29664         ENTER_with_name("call_TIE");
915 29664 50       PUSHSTACKi(PERLSI_MAGIC);
916 29664 50       PUSHMARK(SP);
917 29664         EXTEND(SP,(I32)items);
918 59328 100       while (items--)
919 29664         PUSHs(*MARK++);
920 29664         PUTBACK;
921 29664         call_method(methname, G_SCALAR);
922           }
923           else {
924           /* Can't use call_method here, else this: fileno FOO; tie @a, "FOO"
925           * will attempt to invoke IO::File::TIEARRAY, with (best case) the
926           * wrong error message, and worse case, supreme action at a distance.
927           * (Sorry obfuscation writers. You're not going to be given this one.)
928           */
929 30224         stash = gv_stashsv(*MARK, 0);
930 30224 100       if (!stash || !(gv = gv_fetchmethod(stash, methname))) {
    100        
931 6 100       DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"",
932 4 50       methname, SVfARG(SvOK(*MARK) ? *MARK : &PL_sv_no));
    50        
933           }
934 30220         ENTER_with_name("call_TIE");
935 30220 100       PUSHSTACKi(PERLSI_MAGIC);
936 30220 50       PUSHMARK(SP);
937 30220         EXTEND(SP,(I32)items);
938 86982 100       while (items--)
939 56762         PUSHs(*MARK++);
940 30220         PUTBACK;
941 30220         call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
942           }
943 59876         SPAGAIN;
944            
945 59876         sv = TOPs;
946 59876 50       POPSTACK;
947 59876 100       if (sv_isobject(sv)) {
948 59854         sv_unmagic(varsv, how);
949           /* Croak if a self-tie on an aggregate is attempted. */
950 59859 100       if (varsv == SvRV(sv) &&
    100        
951 10         (SvTYPE(varsv) == SVt_PVAV ||
952           SvTYPE(varsv) == SVt_PVHV))
953 2         Perl_croak(aTHX_
954           "Self-ties of arrays and hashes are not supported");
955 59852 100       sv_magic(varsv, (SvRV(sv) == varsv ? NULL : sv), how, NULL, 0);
956           }
957 59868         LEAVE_with_name("call_TIE");
958 59868         SP = PL_stack_base + markoff;
959 59868         PUSHs(sv);
960 59868         RETURN;
961           }
962            
963 30872         PP(pp_untie)
964           {
965 30872         dVAR; dSP;
966           MAGIC *mg;
967 30872         SV *sv = POPs;
968 30872 100       const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
969           ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
970            
971 30872 100       if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
    50        
    100        
    50        
972 0         RETPUSHYES;
973            
974 30872 100       if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y' &&
    50        
    100        
975 2         !(sv = defelem_target(sv, NULL))) RETPUSHUNDEF;
976            
977 30870 100       if ((mg = SvTIED_mg(sv, how))) {
    100        
978 30684 100       SV * const obj = SvRV(SvTIED_obj(sv, mg));
979 30684 100       if (obj) {
980 30680         GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE);
981           CV *cv;
982 30680 100       if (gv && isGV(gv) && (cv = GvCV(gv))) {
    50        
    50        
983 24520 50       PUSHMARK(SP);
984 24520 50       PUSHs(SvTIED_obj(MUTABLE_SV(gv), mg));
985 24520 50       mXPUSHi(SvREFCNT(obj) - 1);
986 24520         PUTBACK;
987 24520         ENTER_with_name("call_UNTIE");
988 24520         call_sv(MUTABLE_SV(cv), G_VOID);
989 24520         LEAVE_with_name("call_UNTIE");
990 24520         SPAGAIN;
991           }
992 6160 50       else if (mg && SvREFCNT(obj) > 1) {
    100        
993 24         Perl_ck_warner(aTHX_ packWARN(WARN_UNTIE),
994           "untie attempted while %"UVuf" inner references still exist",
995 24         (UV)SvREFCNT(obj) - 1 ) ;
996           }
997           }
998           }
999 30870         sv_unmagic(sv, how) ;
1000 30871         RETPUSHYES;
1001           }
1002            
1003 6710         PP(pp_tied)
1004           {
1005           dVAR;
1006 6710         dSP;
1007           const MAGIC *mg;
1008 6710         SV *sv = POPs;
1009 6710 100       const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
1010           ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar;
1011            
1012 6710 100       if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv))))
    50        
    100        
    100        
1013 2         RETPUSHUNDEF;
1014            
1015 6708 100       if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y' &&
    50        
    100        
1016 2         !(sv = defelem_target(sv, NULL))) RETPUSHUNDEF;
1017            
1018 6706 100       if ((mg = SvTIED_mg(sv, how))) {
    100        
1019 2804 50       PUSHs(SvTIED_obj(sv, mg));
1020 2804         RETURN;
1021           }
1022 5306         RETPUSHUNDEF;
1023           }
1024            
1025 18         PP(pp_dbmopen)
1026 14 50       {
1027 18         dVAR; dSP;
1028 18         dPOPPOPssrl;
1029           HV* stash;
1030           GV *gv = NULL;
1031            
1032 18         HV * const hv = MUTABLE_HV(POPs);
1033 18         SV * const sv = newSVpvs_flags("AnyDBM_File", SVs_TEMP);
1034 18         stash = gv_stashsv(sv, 0);
1035 18 100       if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
    100        
1036 8         PUTBACK;
1037 8         require_pv("AnyDBM_File.pm");
1038 8         SPAGAIN;
1039 8 100       if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH")))
    100        
1040 4         DIE(aTHX_ "No dbm on this machine");
1041           }
1042            
1043 14         ENTER;
1044 14 50       PUSHMARK(SP);
1045            
1046 7         EXTEND(SP, 5);
1047 14         PUSHs(sv);
1048 14         PUSHs(left);
1049 14 100       if (SvIV(right))
    100        
1050 12         mPUSHu(O_RDWR|O_CREAT);
1051           else
1052           {
1053 2         mPUSHu(O_RDWR);
1054 2 50       if (!SvOK(right)) right = &PL_sv_no;
    50        
    50        
1055           }
1056 14         PUSHs(right);
1057 14         PUTBACK;
1058 14         call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
1059 14         SPAGAIN;
1060            
1061 14 100       if (!sv_isobject(TOPs)) {
1062 8         SP--;
1063 8 50       PUSHMARK(SP);
1064 8         PUSHs(sv);
1065 8         PUSHs(left);
1066 8         mPUSHu(O_RDONLY);
1067 8         PUSHs(right);
1068 8         PUTBACK;
1069 8         call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR);
1070 8         SPAGAIN;
1071           }
1072            
1073 14 100       if (sv_isobject(TOPs)) {
1074 6         sv_unmagic(MUTABLE_SV(hv), PERL_MAGIC_tied);
1075 6         sv_magic(MUTABLE_SV(hv), TOPs, PERL_MAGIC_tied, NULL, 0);
1076           }
1077 14         LEAVE;
1078 14         RETURN;
1079           }
1080            
1081 9530         PP(pp_sselect)
1082           {
1083           #ifdef HAS_SELECT
1084 9530         dVAR; dSP; dTARGET;
1085           I32 i;
1086           I32 j;
1087           char *s;
1088           SV *sv;
1089           NV value;
1090           I32 maxlen = 0;
1091           I32 nfound;
1092           struct timeval timebuf;
1093           struct timeval *tbuf = &timebuf;
1094           I32 growsize;
1095           char *fd_sets[4];
1096           #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1097           I32 masksize;
1098           I32 offset;
1099           I32 k;
1100            
1101           # if BYTEORDER & 0xf0000
1102           # define ORDERBYTE (0x88888888 - BYTEORDER)
1103           # else
1104           # define ORDERBYTE (0x4444 - BYTEORDER)
1105           # endif
1106            
1107           #endif
1108            
1109 9530         SP -= 4;
1110 52400 100       for (i = 1; i <= 3; i++) {
    100        
1111 28584         SV * const sv = SP[i];
1112 14294         SvGETMAGIC(sv);
1113 28584 100       if (!SvOK(sv))
    50        
    50        
1114 19034         continue;
1115 9550 100       if (SvREADONLY(sv)) {
1116 18 50       if (!(SvPOK(sv) && SvCUR(sv) == 0))
    100        
1117 6         Perl_croak_no_modify();
1118           }
1119 9532 100       else if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
1120 9544 100       if (!SvPOK(sv)) {
1121 2 50       if (!SvPOKp(sv))
1122 2         Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
1123           "Non-string passed as bitmask");
1124 2 50       SvPV_force_nomg_nolen(sv); /* force string conversion */
1125           }
1126 9544         j = SvCUR(sv);
1127 9544 100       if (maxlen < j)
1128           maxlen = j;
1129           }
1130            
1131           /* little endians can use vecs directly */
1132           #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1133           # ifdef NFDBITS
1134            
1135           # ifndef NBBY
1136           # define NBBY 8
1137           # endif
1138            
1139           masksize = NFDBITS / NBBY;
1140           # else
1141           masksize = sizeof(long); /* documented int, everyone seems to use long */
1142           # endif
1143           Zero(&fd_sets[0], 4, char*);
1144           #endif
1145            
1146           # if SELECT_MIN_BITS == 1
1147           growsize = sizeof(fd_set);
1148           # else
1149           # if defined(__GLIBC__) && defined(__FD_SETSIZE)
1150           # undef SELECT_MIN_BITS
1151           # define SELECT_MIN_BITS __FD_SETSIZE
1152           # endif
1153           /* If SELECT_MIN_BITS is greater than one we most probably will want
1154           * to align the sizes with SELECT_MIN_BITS/8 because for example
1155           * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital
1156           * UNIX, Solaris, NeXT, Darwin) the smallest quantum select() operates
1157           * on (sets/tests/clears bits) is 32 bits. */
1158 9524         growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8)));
1159           # endif
1160            
1161 9524         sv = SP[4];
1162 9524 100       if (SvOK(sv)) {
    50        
    50        
1163 830 100       value = SvNV(sv);
1164 830 50       if (value < 0.0)
1165           value = 0.0;
1166 830         timebuf.tv_sec = (long)value;
1167 830         value -= (NV)timebuf.tv_sec;
1168 830         timebuf.tv_usec = (long)(value * 1000000.0);
1169           }
1170           else
1171           tbuf = NULL;
1172            
1173 38096 100       for (i = 1; i <= 3; i++) {
1174 28572         sv = SP[i];
1175 28572 100       if (!SvOK(sv) || SvCUR(sv) == 0) {
    50        
    50        
    100        
1176 19082         fd_sets[i] = 0;
1177 19082         continue;
1178           }
1179           assert(SvPOK(sv));
1180 9490         j = SvLEN(sv);
1181 9490 100       if (j < growsize) {
1182 158         Sv_Grow(sv, growsize);
1183           }
1184 9490         j = SvCUR(sv);
1185 9490         s = SvPVX(sv) + j;
1186 1218197 100       while (++j <= growsize) {
1187 1203962         *s++ = '\0';
1188           }
1189            
1190           #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1191           s = SvPVX(sv);
1192           Newx(fd_sets[i], growsize, char);
1193           for (offset = 0; offset < growsize; offset += masksize) {
1194           for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1195           fd_sets[i][j+offset] = s[(k % masksize) + offset];
1196           }
1197           #else
1198 9490         fd_sets[i] = SvPVX(sv);
1199           #endif
1200           }
1201            
1202           #ifdef PERL_IRIX5_SELECT_TIMEVAL_VOID_CAST
1203           /* Can't make just the (void*) conditional because that would be
1204           * cpp #if within cpp macro, and not all compilers like that. */
1205           nfound = PerlSock_select(
1206           maxlen * 8,
1207           (Select_fd_set_t) fd_sets[1],
1208           (Select_fd_set_t) fd_sets[2],
1209           (Select_fd_set_t) fd_sets[3],
1210           (void*) tbuf); /* Workaround for compiler bug. */
1211           #else
1212 9524         nfound = PerlSock_select(
1213           maxlen * 8,
1214           (Select_fd_set_t) fd_sets[1],
1215           (Select_fd_set_t) fd_sets[2],
1216           (Select_fd_set_t) fd_sets[3],
1217           tbuf);
1218           #endif
1219 38096 100       for (i = 1; i <= 3; i++) {
1220 28572 100       if (fd_sets[i]) {
1221 9490         sv = SP[i];
1222           #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678
1223           s = SvPVX(sv);
1224           for (offset = 0; offset < growsize; offset += masksize) {
1225           for (j = 0, k=ORDERBYTE; j < masksize; j++, (k >>= 4))
1226           s[(k % masksize) + offset] = fd_sets[i][j+offset];
1227           }
1228           Safefree(fd_sets[i]);
1229           #endif
1230 9490 100       SvSETMAGIC(sv);
1231           }
1232           }
1233            
1234 9524 50       PUSHi(nfound);
1235 9524 100       if (GIMME == G_ARRAY && tbuf) {
    50        
    0        
1236 0         value = (NV)(timebuf.tv_sec) +
1237 0         (NV)(timebuf.tv_usec) / 1000000.0;
1238 0         mPUSHn(value);
1239           }
1240 9524         RETURN;
1241           #else
1242           DIE(aTHX_ "select not implemented");
1243           #endif
1244           }
1245            
1246           /*
1247           =for apidoc setdefout
1248            
1249           Sets PL_defoutgv, the default file handle for output, to the passed in
1250           typeglob. As PL_defoutgv "owns" a reference on its typeglob, the reference
1251           count of the passed in typeglob is increased by one, and the reference count
1252           of the typeglob that PL_defoutgv points to is decreased by one.
1253            
1254           =cut
1255           */
1256            
1257           void
1258 72298         Perl_setdefout(pTHX_ GV *gv)
1259           {
1260           dVAR;
1261           PERL_ARGS_ASSERT_SETDEFOUT;
1262 72298         SvREFCNT_inc_simple_void_NN(gv);
1263 72298         SvREFCNT_dec(PL_defoutgv);
1264 72298         PL_defoutgv = gv;
1265 72298         }
1266            
1267 47276         PP(pp_select)
1268           {
1269 47276         dVAR; dSP; dTARGET;
1270           HV *hv;
1271 47276 100       GV * const newdefout = (PL_op->op_private > 0) ? (MUTABLE_GV(POPs)) : NULL;
1272 47276 50       GV * egv = GvEGVx(PL_defoutgv);
    50        
1273           GV * const *gvp;
1274            
1275 47276 50       if (!egv)
1276 0         egv = PL_defoutgv;
1277 47276 50       hv = isGV_with_GP(egv) ? GvSTASH(egv) : NULL;
    50        
1278 47274 50       gvp = hv && HvENAME(hv)
    50        
    100        
    50        
    50        
    50        
    50        
1279 47270 100       ? (GV**)hv_fetch(hv, GvNAME(egv), HEK_UTF8(GvNAME_HEK(egv)) ? -GvNAMELEN(egv) : GvNAMELEN(egv), FALSE)
1280 94546 100       : NULL;
1281 47276 100       if (gvp && *gvp == egv) {
    100        
1282 33282         gv_efullname4(TARG, PL_defoutgv, NULL, TRUE);
1283 33282 50       XPUSHTARG;
    50        
1284           }
1285           else {
1286 13994 50       mXPUSHs(newRV(MUTABLE_SV(egv)));
1287           }
1288            
1289 47276 100       if (newdefout) {
1290 46358 50       if (!GvIO(newdefout))
    50        
    50        
    100        
1291 156         gv_IOadd(newdefout);
1292 46358         setdefout(newdefout);
1293           }
1294            
1295 47276         RETURN;
1296           }
1297            
1298 32974         PP(pp_getc)
1299           {
1300 32974         dVAR; dSP; dTARGET;
1301           GV * const gv =
1302 32974 50       MAXARG==0 || (!TOPs && !POPs) ? PL_stdingv : MUTABLE_GV(POPs);
    100        
    50        
1303 32974 50       IO *const io = GvIO(gv);
    100        
    50        
1304            
1305 32974 50       if (MAXARG == 0)
    0        
1306 0         EXTEND(SP, 1);
1307            
1308 32974 100       if (io) {
1309 32972 100       const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1310 32972 100       if (mg) {
1311 76 50       const U32 gimme = GIMME_V;
1312 76 100       Perl_tied_method(aTHX_ SV_CONST(GETC), SP, MUTABLE_SV(io), mg, gimme, 0);
1313 66 50       if (gimme == G_SCALAR) {
1314 66         SPAGAIN;
1315 66 50       SvSetMagicSV_nosteal(TARG, TOPs);
    50        
1316           }
1317 66         return NORMAL;
1318           }
1319           }
1320 32898 50       if (!gv || do_eof(gv)) { /* make sure we have fp with something */
    100        
1321 22 100       if (!io || (!IoIFP(io) && IoTYPE(io) != IoTYPE_WRONLY))
    100        
    50        
1322 14         report_evil_fh(gv);
1323 22         SETERRNO(EBADF,RMS_IFI);
1324 22         RETPUSHUNDEF;
1325           }
1326 32876         TAINT;
1327 32876         sv_setpvs(TARG, " ");
1328 32876         *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
1329 32876 100       if (PerlIO_isutf8(IoIFP(GvIOp(gv)))) {
1330           /* Find out how many bytes the char needs */
1331 16406         Size_t len = UTF8SKIP(SvPVX_const(TARG));
1332 16406 100       if (len > 1) {
1333 16148 50       SvGROW(TARG,len+1);
    50        
1334 16148         len = PerlIO_read(IoIFP(GvIOp(gv)),SvPVX(TARG)+1,len-1);
1335 16148         SvCUR_set(TARG,1+len);
1336           }
1337 16406         SvUTF8_on(TARG);
1338           }
1339 32876 50       PUSHTARG;
1340 32920         RETURN;
1341           }
1342            
1343           STATIC OP *
1344 828         S_doform(pTHX_ CV *cv, GV *gv, OP *retop)
1345           {
1346           dVAR;
1347           PERL_CONTEXT *cx;
1348 828 100       const I32 gimme = GIMME_V;
1349            
1350           PERL_ARGS_ASSERT_DOFORM;
1351            
1352 828 50       if (cv && CvCLONE(cv))
    100        
1353 334         cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv))));
1354            
1355 824         ENTER;
1356 824         SAVETMPS;
1357            
1358 824 50       PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp);
1359 1648 100       PUSHFORMAT(cx, retop);
1360 824 100       if (CvDEPTH(cv) >= 2) {
1361           PERL_STACK_OVERFLOW_CHECK();
1362 20         pad_push(CvPADLIST(cv), CvDEPTH(cv));
1363           }
1364 824         SAVECOMPPAD();
1365 1648         PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv));
1366            
1367 824         setdefout(gv); /* locally select filehandle so $% et al work */
1368 824         return CvSTART(cv);
1369           }
1370            
1371 818         PP(pp_enterwrite)
1372           {
1373           dVAR;
1374 818         dSP;
1375           GV *gv;
1376           IO *io;
1377           GV *fgv;
1378           CV *cv = NULL;
1379           SV *tmpsv = NULL;
1380            
1381 1038 100       if (MAXARG == 0) {
    50        
1382 440         gv = PL_defoutgv;
1383 220         EXTEND(SP, 1);
1384           }
1385           else {
1386 378         gv = MUTABLE_GV(POPs);
1387 378 100       if (!gv)
1388 2         gv = PL_defoutgv;
1389           }
1390 818 50       io = GvIO(gv);
    50        
    50        
1391 818 50       if (!io) {
1392 0         RETPUSHNO;
1393           }
1394 818 100       if (IoFMT_GV(io))
1395 308         fgv = IoFMT_GV(io);
1396           else
1397           fgv = gv;
1398            
1399           assert(fgv);
1400            
1401 818         cv = GvFORM(fgv);
1402 818 100       if (!cv) {
1403 20         tmpsv = sv_newmortal();
1404 20         gv_efullname4(tmpsv, fgv, NULL, FALSE);
1405 20         DIE(aTHX_ "Undefined format \"%"SVf"\" called", SVfARG(tmpsv));
1406           }
1407 798         IoFLAGS(io) &= ~IOf_DIDTOP;
1408 798         RETURNOP(doform(cv,gv,PL_op->op_next));
1409           }
1410            
1411 758         PP(pp_leavewrite)
1412           {
1413           dVAR; dSP;
1414 758         GV * const gv = cxstack[cxstack_ix].blk_format.gv;
1415 758         IO * const io = GvIOp(gv);
1416           PerlIO *ofp;
1417           PerlIO *fp;
1418           SV **newsp;
1419           I32 gimme;
1420           PERL_CONTEXT *cx;
1421           OP *retop;
1422            
1423 758 100       if (!io || !(ofp = IoOFP(io)))
    100        
1424           goto forget_top;
1425            
1426           DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
1427           (long)IoLINES_LEFT(io), (long)FmLINES(PL_formtarget)));
1428            
1429 688 100       if (IoLINES_LEFT(io) < FmLINES(PL_formtarget) &&
    50        
1430 184         PL_formtarget != PL_toptarget)
1431           {
1432           GV *fgv;
1433           CV *cv;
1434 184 100       if (!IoTOP_GV(io)) {
1435           GV *topgv;
1436            
1437 138 100       if (!IoTOP_NAME(io)) {
1438           SV *topname;
1439 128 100       if (!IoFMT_NAME(io))
1440 108         IoFMT_NAME(io) = savepv(GvNAME(gv));
1441 128         topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%"HEKf"_TOP",
1442           HEKfARG(GvNAME_HEK(gv))));
1443 128         topgv = gv_fetchsv(topname, 0, SVt_PVFM);
1444 254 100       if ((topgv && GvFORM(topgv)) ||
1445 126         !gv_fetchpvs("top", GV_NOTQUAL, SVt_PVFM))
1446 128         IoTOP_NAME(io) = savesvpv(topname);
1447           else
1448 0         IoTOP_NAME(io) = savepvs("top");
1449           }
1450 138         topgv = gv_fetchpv(IoTOP_NAME(io), 0, SVt_PVFM);
1451 138 100       if (!topgv || !GvFORM(topgv)) {
    50        
1452 136         IoLINES_LEFT(io) = IoPAGE_LEN(io);
1453 136         goto forget_top;
1454           }
1455 2         IoTOP_GV(io) = topgv;
1456           }
1457 48 100       if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */
1458 22         I32 lines = IoLINES_LEFT(io);
1459 22         const char *s = SvPVX_const(PL_formtarget);
1460 22 100       if (lines <= 0) /* Yow, header didn't even fit!!! */
1461           goto forget_top;
1462 60 100       while (lines-- > 0) {
1463 42         s = strchr(s, '\n');
1464 42 50       if (!s)
1465           break;
1466 42         s++;
1467           }
1468 18 50       if (s) {
1469 18         const STRLEN save = SvCUR(PL_formtarget);
1470 18         SvCUR_set(PL_formtarget, s - SvPVX_const(PL_formtarget));
1471 18         do_print(PL_formtarget, ofp);
1472 18         SvCUR_set(PL_formtarget, save);
1473 18         sv_chop(PL_formtarget, s);
1474 18         FmLINES(PL_formtarget) -= IoLINES_LEFT(io);
1475           }
1476           }
1477 44 100       if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
    100        
1478 28         do_print(GvSV(gv_fetchpvs("\f", GV_ADD, SVt_PV)), ofp);
1479 44         IoLINES_LEFT(io) = IoPAGE_LEN(io);
1480 44         IoPAGE(io)++;
1481 44         PL_formtarget = PL_toptarget;
1482 44         IoFLAGS(io) |= IOf_DIDTOP;
1483 44         fgv = IoTOP_GV(io);
1484           assert(fgv); /* IoTOP_GV(io) should have been set above */
1485 44         cv = GvFORM(fgv);
1486 44 100       if (!cv) {
1487 14         SV * const sv = sv_newmortal();
1488 14         gv_efullname4(sv, fgv, NULL, FALSE);
1489 14         DIE(aTHX_ "Undefined top format \"%"SVf"\" called", SVfARG(sv));
1490           }
1491 30         return doform(cv, gv, PL_op);
1492           }
1493            
1494           forget_top:
1495 714         POPBLOCK(cx,PL_curpm);
1496 714         retop = cx->blk_sub.retop;
1497 1071 50       POPFORMAT(cx);
    100        
1498           SP = newsp; /* ignore retval of formline */
1499 714         LEAVE;
1500            
1501 714 100       if (!io || !(fp = IoOFP(io))) {
    100        
1502 162 100       if (io && IoIFP(io))
    100        
1503 4         report_wrongway_fh(gv, '<');
1504           else
1505 158         report_evil_fh(gv);
1506 162         PUSHs(&PL_sv_no);
1507           }
1508           else {
1509 552 100       if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
1510 4         Perl_ck_warner(aTHX_ packWARN(WARN_IO), "page overflow");
1511           }
1512 552 50       if (!do_print(PL_formtarget, fp))
1513 0         PUSHs(&PL_sv_no);
1514           else {
1515 552         FmLINES(PL_formtarget) = 0;
1516 552         SvCUR_set(PL_formtarget, 0);
1517 552         *SvEND(PL_formtarget) = '\0';
1518 552 100       if (IoFLAGS(io) & IOf_FLUSH)
1519 18         (void)PerlIO_flush(fp);
1520 552         PUSHs(&PL_sv_yes);
1521           }
1522           }
1523 714         PL_formtarget = PL_bodytarget;
1524           PERL_UNUSED_VAR(gimme);
1525 729         RETURNOP(retop);
1526           }
1527            
1528 451198         PP(pp_prtf)
1529           {
1530 451198         dVAR; dSP; dMARK; dORIGMARK;
1531           PerlIO *fp;
1532            
1533           GV * const gv
1534 451198 100       = (PL_op->op_flags & OPf_STACKED) ? MUTABLE_GV(*++MARK) : PL_defoutgv;
1535 451198 50       IO *const io = GvIO(gv);
    50        
    50        
1536            
1537           /* Treat empty list as "" */
1538 451198 100       if (MARK == SP) XPUSHs(&PL_sv_no);
    50        
1539            
1540 451198 100       if (io) {
1541 451190 100       const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1542 451190 100       if (mg) {
1543 132 100       if (MARK == ORIGMARK) {
1544 52 50       MEXTEND(SP, 1);
1545 52         ++MARK;
1546 52 50       Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
1547 52         ++SP;
1548           }
1549 132 100       return Perl_tied_method(aTHX_ SV_CONST(PRINTF), mark - 1, MUTABLE_SV(io),
1550           mg,
1551           G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1552 132         sp - mark);
1553           }
1554           }
1555            
1556 451066 100       if (!io) {
1557 8         report_evil_fh(gv);
1558 4         SETERRNO(EBADF,RMS_IFI);
1559 4         goto just_say_no;
1560           }
1561 451058 100       else if (!(fp = IoOFP(io))) {
1562 14 100       if (IoIFP(io))
1563 6         report_wrongway_fh(gv, '<');
1564 8 100       else if (ckWARN(WARN_CLOSED))
1565 4         report_evil_fh(gv);
1566 14         SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
1567 14         goto just_say_no;
1568           }
1569           else {
1570 451044         SV *sv = sv_newmortal();
1571 451044         do_sprintf(sv, SP - MARK, MARK + 1);
1572 451038 50       if (!do_print(sv, fp))
1573           goto just_say_no;
1574            
1575 451034 100       if (IoFLAGS(io) & IOf_FLUSH)
1576 526 50       if (PerlIO_flush(fp) == EOF)
1577           goto just_say_no;
1578           }
1579 451034         SP = ORIGMARK;
1580 451034         PUSHs(&PL_sv_yes);
1581 451034         RETURN;
1582            
1583           just_say_no:
1584 18         SP = ORIGMARK;
1585 18         PUSHs(&PL_sv_undef);
1586 225596         RETURN;
1587           }
1588            
1589 6456         PP(pp_sysopen)
1590           {
1591           dVAR;
1592 6456         dSP;
1593 6456 100       const int perm = (MAXARG > 3 && (TOPs || POPs)) ? POPi : 0666;
    100        
    50        
    100        
1594 6456 100       const int mode = POPi;
1595 6456         SV * const sv = POPs;
1596 6456         GV * const gv = MUTABLE_GV(POPs);
1597           STRLEN len;
1598            
1599           /* Need TIEHANDLE method ? */
1600 6456 100       const char * const tmps = SvPV_const(sv, len);
1601           /* FIXME? do_open should do const */
1602 6456 100       if (do_open(gv, tmps, len, TRUE, mode, perm, NULL)) {
1603 6448         IoLINES(GvIOp(gv)) = 0;
1604 6448         PUSHs(&PL_sv_yes);
1605           }
1606           else {
1607 8         PUSHs(&PL_sv_undef);
1608           }
1609 6456         RETURN;
1610           }
1611            
1612 272986         PP(pp_sysread)
1613           {
1614 272986         dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1615           SSize_t offset;
1616           IO *io;
1617           char *buffer;
1618           STRLEN orig_size;
1619           SSize_t length;
1620           SSize_t count;
1621           SV *bufsv;
1622           STRLEN blen;
1623           int fp_utf8;
1624           int buffer_utf8;
1625           SV *read_target;
1626           Size_t got = 0;
1627           Size_t wanted;
1628           bool charstart = FALSE;
1629           STRLEN charskip = 0;
1630           STRLEN skip = 0;
1631            
1632 272986         GV * const gv = MUTABLE_GV(*++MARK);
1633 272986 100       if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
1634 272970 50       && gv && (io = GvIO(gv)) )
    50        
    100        
    50        
    100        
1635           {
1636 272960 100       const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1637 272960 100       if (mg) {
1638 156 100       return Perl_tied_method(aTHX_ SV_CONST(READ), mark - 1, MUTABLE_SV(io), mg,
1639           G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1640 156         sp - mark);
1641           }
1642           }
1643            
1644 272830 50       if (!gv)
1645           goto say_undef;
1646 272830         bufsv = *++MARK;
1647 272830 100       if (! SvOK(bufsv))
    50        
    50        
1648 38212         sv_setpvs(bufsv, "");
1649 272830 100       length = SvIVx(*++MARK);
1650 272830 100       if (length < 0)
1651 2         DIE(aTHX_ "Negative length");
1652 272828         SETERRNO(0,0);
1653 272828 100       if (MARK < SP)
1654 222838 100       offset = SvIVx(*++MARK);
1655           else
1656           offset = 0;
1657 272828 50       io = GvIO(gv);
    100        
    50        
1658 272828 100       if (!io || !IoIFP(io)) {
    100        
1659 20         report_evil_fh(gv);
1660 20         SETERRNO(EBADF,RMS_IFI);
1661 20         goto say_undef;
1662           }
1663 272808 100       if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
    50        
1664 1644 100       buffer = SvPVutf8_force(bufsv, blen);
1665           /* UTF-8 may not have been set if they are all low bytes */
1666 1644         SvUTF8_on(bufsv);
1667 1644         buffer_utf8 = 0;
1668           }
1669           else {
1670 271164 100       buffer = SvPV_force(bufsv, blen);
1671 271164 100       buffer_utf8 = !IN_BYTES && SvUTF8(bufsv);
    100        
1672           }
1673 272808 100       if (DO_UTF8(bufsv)) {
    50        
1674 2156         blen = sv_len_utf8_nomg(bufsv);
1675           }
1676            
1677           charstart = TRUE;
1678           charskip = 0;
1679           skip = 0;
1680 272808         wanted = length;
1681            
1682           #ifdef HAS_SOCKET
1683 272808 100       if (PL_op->op_type == OP_RECV) {
1684           Sock_size_t bufsize;
1685           char namebuf[MAXPATHLEN];
1686           #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
1687           bufsize = sizeof (struct sockaddr_in);
1688           #else
1689 16         bufsize = sizeof namebuf;
1690           #endif
1691           #ifdef OS2 /* At least Warp3+IAK: only the first byte of bufsize set */
1692           if (bufsize >= 256)
1693           bufsize = 255;
1694           #endif
1695 16 50       buffer = SvGROW(bufsv, (STRLEN)(length+1));
    100        
1696           /* 'offset' means 'flags' here */
1697 16         count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
1698           (struct sockaddr *)namebuf, &bufsize);
1699 16 100       if (count < 0)
1700 4         RETPUSHUNDEF;
1701           /* MSG_TRUNC can give oversized count; quietly lose it */
1702 12 50       if (count > length)
1703           count = length;
1704 12         SvCUR_set(bufsv, count);
1705 12         *SvEND(bufsv) = '\0';
1706 12         (void)SvPOK_only(bufsv);
1707 12 50       if (fp_utf8)
1708 0         SvUTF8_on(bufsv);
1709 12 50       SvSETMAGIC(bufsv);
1710           /* This should not be marked tainted if the fp is marked clean */
1711 12 50       if (!(IoFLAGS(io) & IOf_UNTAINT))
1712 12 50       SvTAINTED_on(bufsv);
1713 12         SP = ORIGMARK;
1714 12         sv_setpvn(TARG, namebuf, bufsize);
1715 12         PUSHs(TARG);
1716 12         RETURN;
1717           }
1718           #endif
1719 272792 100       if (offset < 0) {
1720 1284 100       if (-offset > (SSize_t)blen)
1721 2         DIE(aTHX_ "Offset outside string");
1722 1282         offset += blen;
1723           }
1724 272790 100       if (DO_UTF8(bufsv)) {
    50        
1725           /* convert offset-as-chars to offset-as-bytes */
1726 2156 100       if (offset >= (SSize_t)blen)
1727 266         offset += SvCUR(bufsv) - blen;
1728           else
1729 138170         offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
1730           }
1731           more_bytes:
1732 274450         orig_size = SvCUR(bufsv);
1733           /* Allocating length + offset + 1 isn't perfect in the case of reading
1734           bytes from a byte file handle into a UTF8 buffer, but it won't harm us
1735           unduly.
1736           (should be 2 * length + offset + 1, or possibly something longer if
1737           PL_encoding is true) */
1738 274450 50       buffer = SvGROW(bufsv, (STRLEN)(length+offset+1));
    100        
1739 274450 100       if (offset > 0 && offset > (SSize_t)orig_size) { /* Zero any newly allocated space */
1740 324         Zero(buffer+orig_size, offset-orig_size, char);
1741           }
1742 274450         buffer = buffer + offset;
1743 274962         if (!buffer_utf8) {
1744           read_target = bufsv;
1745           } else {
1746           /* Best to read the bytes into a new SV, upgrade that to UTF8, then
1747           concatenate it to the current buffer. */
1748            
1749           /* Truncate the existing buffer to the start of where we will be
1750           reading to: */
1751 512         SvCUR_set(bufsv, offset);
1752            
1753 512         read_target = sv_newmortal();
1754 768         SvUPGRADE(read_target, SVt_PV);
1755 512 50       buffer = SvGROW(read_target, (STRLEN)(length + 1));
    50        
1756           }
1757            
1758 274450 100       if (PL_op->op_type == OP_SYSREAD) {
1759           #ifdef PERL_SOCK_SYSREAD_IS_RECV
1760           if (IoTYPE(io) == IoTYPE_SOCKET) {
1761           count = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
1762           buffer, length, 0);
1763           }
1764           else
1765           #endif
1766           {
1767 20350         count = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
1768           buffer, length);
1769           }
1770           }
1771           else
1772           #ifdef HAS_SOCKET__bad_code_maybe
1773           if (IoTYPE(io) == IoTYPE_SOCKET) {
1774           Sock_size_t bufsize;
1775           char namebuf[MAXPATHLEN];
1776           #if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
1777           bufsize = sizeof (struct sockaddr_in);
1778           #else
1779           bufsize = sizeof namebuf;
1780           #endif
1781           count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, 0,
1782           (struct sockaddr *)namebuf, &bufsize);
1783           }
1784           else
1785           #endif
1786           {
1787 254100         count = PerlIO_read(IoIFP(io), buffer, length);
1788           /* PerlIO_read() - like fread() returns 0 on both error and EOF */
1789 254098 100       if (count == 0 && PerlIO_error(IoIFP(io)))
    100        
1790           count = -1;
1791           }
1792 274448 100       if (count < 0) {
1793 26 100       if (IoTYPE(io) == IoTYPE_WRONLY)
1794 4         report_wrongway_fh(gv, '>');
1795           goto say_undef;
1796           }
1797 274422         SvCUR_set(read_target, count+(buffer - SvPVX_const(read_target)));
1798 274422         *SvEND(read_target) = '\0';
1799 274422         (void)SvPOK_only(read_target);
1800 276064 100       if (fp_utf8 && !IN_BYTES) {
    50        
1801           /* Look at utf8 we got back and count the characters */
1802 3302         const char *bend = buffer + count;
1803 8143 100       while (buffer < bend) {
1804 4016 100       if (charstart) {
1805 3190         skip = UTF8SKIP(buffer);
1806           charskip = 0;
1807           }
1808 4016 100       if (buffer - charskip + skip > bend) {
1809           /* partial character - try for rest of it */
1810 826         length = skip - (bend-buffer);
1811 826         offset = bend - SvPVX_const(bufsv);
1812           charstart = FALSE;
1813 826         charskip += count;
1814 826         goto more_bytes;
1815           }
1816           else {
1817 3190         got++;
1818 3190         buffer += skip;
1819           charstart = TRUE;
1820           charskip = 0;
1821           }
1822           }
1823           /* If we have not 'got' the number of _characters_ we 'wanted' get some more
1824           provided amount read (count) was what was requested (length)
1825           */
1826 2476 100       if (got < wanted && count == length) {
1827 834         length = wanted - got;
1828 834         offset = bend - SvPVX_const(bufsv);
1829 834         goto more_bytes;
1830           }
1831           /* return value is character count */
1832 1642         count = got;
1833 1642         SvUTF8_on(bufsv);
1834           }
1835 271120 100       else if (buffer_utf8) {
1836           /* Let svcatsv upgrade the bytes we read in to utf8.
1837           The buffer is a mortal so will be freed soon. */
1838 512         sv_catsv_nomg(bufsv, read_target);
1839           }
1840 272762 100       SvSETMAGIC(bufsv);
1841           /* This should not be marked tainted if the fp is marked clean */
1842 272762 50       if (!(IoFLAGS(io) & IOf_UNTAINT))
1843 272762 50       SvTAINTED_on(bufsv);
1844 272762         SP = ORIGMARK;
1845 272762 50       PUSHi(count);
1846 272762         RETURN;
1847            
1848           say_undef:
1849 46         SP = ORIGMARK;
1850 136503         RETPUSHUNDEF;
1851           }
1852            
1853 7578         PP(pp_syswrite)
1854           {
1855 7578         dVAR; dSP; dMARK; dORIGMARK; dTARGET;
1856           SV *bufsv;
1857           const char *buffer;
1858           SSize_t retval;
1859           STRLEN blen;
1860           STRLEN orig_blen_bytes;
1861 7578         const int op_type = PL_op->op_type;
1862           bool doing_utf8;
1863           U8 *tmpbuf = NULL;
1864 7578         GV *const gv = MUTABLE_GV(*++MARK);
1865 7578 50       IO *const io = GvIO(gv);
    100        
    50        
1866            
1867 7578 100       if (op_type == OP_SYSWRITE && io) {
1868 7528 100       const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
1869 7528 100       if (mg) {
1870 26 100       if (MARK == SP - 1) {
1871 2         SV *sv = *SP;
1872 2 50       mXPUSHi(sv_len(sv));
1873 2         PUTBACK;
1874           }
1875            
1876 26 100       return Perl_tied_method(aTHX_ SV_CONST(WRITE), mark - 1, MUTABLE_SV(io), mg,
1877           G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK,
1878 26         sp - mark);
1879           }
1880           }
1881 7552 50       if (!gv)
1882           goto say_undef;
1883            
1884 7552         bufsv = *++MARK;
1885            
1886 7552         SETERRNO(0,0);
1887 7552 100       if (!io || !IoIFP(io) || IoTYPE(io) == IoTYPE_RDONLY) {
    100        
    100        
1888           retval = -1;
1889 48 100       if (io && IoIFP(io))
    100        
1890 4         report_wrongway_fh(gv, '<');
1891           else
1892 44         report_evil_fh(gv);
1893 48         SETERRNO(EBADF,RMS_IFI);
1894 48         goto say_undef;
1895           }
1896            
1897           /* Do this first to trigger any overloading. */
1898 7504 100       buffer = SvPV_const(bufsv, blen);
1899 7504         orig_blen_bytes = blen;
1900 7504 100       doing_utf8 = DO_UTF8(bufsv);
    50        
1901            
1902 7504 100       if (PerlIO_isutf8(IoIFP(io))) {
1903 124 100       if (!SvUTF8(bufsv)) {
1904           /* We don't modify the original scalar. */
1905 56         tmpbuf = bytes_to_utf8((const U8*) buffer, &blen);
1906           buffer = (char *) tmpbuf;
1907 56         doing_utf8 = TRUE;
1908           }
1909           }
1910 7380 100       else if (doing_utf8) {
1911 24         STRLEN tmplen = blen;
1912 24         U8 * const result = bytes_from_utf8((const U8*) buffer, &tmplen, &doing_utf8);
1913 24 50       if (!doing_utf8) {
1914           tmpbuf = result;
1915           buffer = (char *) tmpbuf;
1916 24         blen = tmplen;
1917           }
1918           else {
1919           assert((char *)result == buffer);
1920 0 0       Perl_croak(aTHX_ "Wide character in %s", OP_DESC(PL_op));
    0        
1921           }
1922           }
1923            
1924           #ifdef HAS_SOCKET
1925 7504 100       if (op_type == OP_SEND) {
1926 14 50       const int flags = SvIVx(*++MARK);
1927 14 100       if (SP > MARK) {
1928           STRLEN mlen;
1929 4 50       char * const sockbuf = SvPVx(*++MARK, mlen);
1930 4         retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
1931           flags, (struct sockaddr *)sockbuf, mlen);
1932           }
1933           else {
1934           retval
1935 10         = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags);
1936           }
1937           }
1938           else
1939           #endif
1940           {
1941           Size_t length = 0; /* This length is in characters. */
1942           STRLEN blen_chars;
1943           IV offset;
1944            
1945 7490 100       if (doing_utf8) {
1946 124 100       if (tmpbuf) {
1947           /* The SV is bytes, and we've had to upgrade it. */
1948           blen_chars = orig_blen_bytes;
1949           } else {
1950           /* The SV really is UTF-8. */
1951           /* Don't call sv_len_utf8 on a magical or overloaded
1952           scalar, as we might get back a different result. */
1953 68 50       blen_chars = sv_or_pv_len_utf8(bufsv, buffer, blen);
    100        
    50        
    50        
1954           }
1955           } else {
1956 7366         blen_chars = blen;
1957           }
1958            
1959 7490 100       if (MARK >= SP) {
1960           length = blen_chars;
1961           } else {
1962           #if Size_t_size > IVSIZE
1963           length = (Size_t)SvNVx(*++MARK);
1964           #else
1965 3472 50       length = (Size_t)SvIVx(*++MARK);
1966           #endif
1967 3472 100       if ((SSize_t)length < 0) {
1968 2         Safefree(tmpbuf);
1969 2         DIE(aTHX_ "Negative length");
1970           }
1971           }
1972            
1973 7488 100       if (MARK < SP) {
1974 3400 50       offset = SvIVx(*++MARK);
1975 3400 100       if (offset < 0) {
1976 4 100       if (-offset > (IV)blen_chars) {
1977 2         Safefree(tmpbuf);
1978 2         DIE(aTHX_ "Offset outside string");
1979           }
1980 2         offset += blen_chars;
1981 3396 100       } else if (offset > (IV)blen_chars) {
1982 6         Safefree(tmpbuf);
1983 6         DIE(aTHX_ "Offset outside string");
1984           }
1985           } else
1986           offset = 0;
1987 7480 100       if (length > blen_chars - offset)
1988 4         length = blen_chars - offset;
1989 7480 100       if (doing_utf8) {
1990           /* Here we convert length from characters to bytes. */
1991 124 100       if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) {
    50        
    100        
    50        
    50        
1992           /* Either we had to convert the SV, or the SV is magical, or
1993           the SV has overloading, in which case we can't or mustn't
1994           or mustn't call it again. */
1995            
1996 80         buffer = (const char*)utf8_hop((const U8 *)buffer, offset);
1997 80         length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer;
1998           } else {
1999           /* It's a real UTF-8 SV, and it's not going to change under
2000           us. Take advantage of any cache. */
2001 44         I32 start = offset;
2002 44         I32 len_I32 = length;
2003            
2004           /* Convert the start and end character positions to bytes.
2005           Remember that the second argument to sv_pos_u2b is relative
2006           to the first. */
2007 44         sv_pos_u2b(bufsv, &start, &len_I32);
2008            
2009 44         buffer += start;
2010 44         length = len_I32;
2011           }
2012           }
2013           else {
2014 7356         buffer = buffer+offset;
2015           }
2016           #ifdef PERL_SOCK_SYSWRITE_IS_SEND
2017           if (IoTYPE(io) == IoTYPE_SOCKET) {
2018           retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
2019           buffer, length, 0);
2020           }
2021           else
2022           #endif
2023           {
2024           /* See the note at doio.c:do_print about filesize limits. --jhi */
2025 7480         retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
2026           buffer, length);
2027           }
2028           }
2029            
2030 7494 100       if (retval < 0)
2031           goto say_undef;
2032 7490         SP = ORIGMARK;
2033 7490 100       if (doing_utf8)
2034 124         retval = utf8_length((U8*)buffer, (U8*)buffer + retval);
2035            
2036 7490         Safefree(tmpbuf);
2037           #if Size_t_size > IVSIZE
2038           PUSHn(retval);
2039           #else
2040 7490 50       PUSHi(retval);
2041           #endif
2042 7490         RETURN;
2043            
2044           say_undef:
2045 52         Safefree(tmpbuf);
2046 52         SP = ORIGMARK;
2047 3810         RETPUSHUNDEF;
2048           }
2049            
2050 2278         PP(pp_eof)
2051           {
2052 2278         dVAR; dSP;
2053           GV *gv;
2054           IO *io;
2055           const MAGIC *mg;
2056           /*
2057           * in Perl 5.12 and later, the additional parameter is a bitmask:
2058           * 0 = eof
2059           * 1 = eof(FH)
2060           * 2 = eof() <- ARGV magic
2061           *
2062           * I'll rely on the compiler's trace flow analysis to decide whether to
2063           * actually assign this out here, or punt it into the only block where it is
2064           * used. Doing it out here is DRY on the condition logic.
2065           */
2066           unsigned int which;
2067            
2068 2612 100       if (MAXARG) {
    50        
2069 1610         gv = PL_last_in_gv = MUTABLE_GV(POPs); /* eof(FH) */
2070           which = 1;
2071           }
2072           else {
2073 334         EXTEND(SP, 1);
2074            
2075 668 100       if (PL_op->op_flags & OPf_SPECIAL) {
2076 22 50       gv = PL_last_in_gv = GvEGVx(PL_argvgv); /* eof() - ARGV magic */
    50        
2077           which = 2;
2078           }
2079           else {
2080 646         gv = PL_last_in_gv; /* eof */
2081           which = 0;
2082           }
2083           }
2084            
2085 2278 50       if (!gv)
2086 0         RETPUSHNO;
2087            
2088 2278 50       if ((io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) {
    50        
    50        
    100        
    100        
    100        
2089 50 100       return tied_method1(SV_CONST(EOF), SP, MUTABLE_SV(io), mg, newSVuv(which));
2090           }
2091            
2092 2228 100       if (!MAXARG && (PL_op->op_flags & OPf_SPECIAL)) { /* eof() */
    100        
2093 20 50       if (io && !IoIFP(io)) {
    100        
2094 6 100       if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) {
    50        
    50        
2095 4         IoLINES(io) = 0;
2096 4         IoFLAGS(io) &= ~IOf_START;
2097 4         do_open(gv, "-", 1, FALSE, O_RDONLY, 0, NULL);
2098 4 100       if (GvSV(gv))
2099 2         sv_setpvs(GvSV(gv), "-");
2100           else
2101 2         GvSV(gv) = newSVpvs("-");
2102 4 50       SvSETMAGIC(GvSV(gv));
2103           }
2104 2 50       else if (!nextargv(gv))
2105 0         RETPUSHYES;
2106           }
2107           }
2108            
2109 2228 100       PUSHs(boolSV(do_eof(gv)));
2110 2253         RETURN;
2111           }
2112            
2113 10494         PP(pp_tell)
2114           {
2115 10494         dVAR; dSP; dTARGET;
2116           GV *gv;
2117           IO *io;
2118            
2119 10513 100       if (MAXARG != 0 && (TOPs || POPs))
    100        
    50        
    50        
2120 10456         PL_last_in_gv = MUTABLE_GV(POPs);
2121           else
2122 19         EXTEND(SP, 1);
2123 10494         gv = PL_last_in_gv;
2124            
2125 10494 100       io = GvIO(gv);
    100        
    50        
2126 10494 100       if (io) {
2127 10484 100       const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2128 10484 100       if (mg) {
2129 228 100       return tied_method0(SV_CONST(TELL), SP, MUTABLE_SV(io), mg);
2130           }
2131           }
2132 10 100       else if (!gv) {
2133 6 50       if (!errno)
2134 0         SETERRNO(EBADF,RMS_IFI);
2135 6 50       PUSHi(-1);
2136 6         RETURN;
2137           }
2138            
2139           #if LSEEKSIZE > IVSIZE
2140           PUSHn( do_tell(gv) );
2141           #else
2142 10260 50       PUSHi( do_tell(gv) );
2143           #endif
2144 10365         RETURN;
2145           }
2146            
2147 61146         PP(pp_sysseek)
2148           {
2149 61146         dVAR; dSP;
2150 61146 100       const int whence = POPi;
2151           #if LSEEKSIZE > IVSIZE
2152           const Off_t offset = (Off_t)SvNVx(POPs);
2153           #else
2154 61146 100       const Off_t offset = (Off_t)SvIVx(POPs);
2155           #endif
2156            
2157 61146         GV * const gv = PL_last_in_gv = MUTABLE_GV(POPs);
2158 61146 50       IO *const io = GvIO(gv);
    100        
    50        
2159            
2160 61146 100       if (io) {
2161 61134 100       const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
2162 61134 100       if (mg) {
2163           #if LSEEKSIZE > IVSIZE
2164           SV *const offset_sv = newSVnv((NV) offset);
2165           #else
2166 92         SV *const offset_sv = newSViv(offset);
2167           #endif
2168            
2169 92 100       return tied_method2(SV_CONST(SEEK), SP, MUTABLE_SV(io), mg, offset_sv,
2170           newSViv(whence));
2171           }
2172           }
2173            
2174 61054 100       if (PL_op->op_type == OP_SEEK)
2175 60830 100       PUSHs(boolSV(do_seek(gv, offset, whence)));
2176           else {
2177 224         const Off_t sought = do_sysseek(gv, offset, whence);
2178 224 100       if (sought < 0)
2179 14         PUSHs(&PL_sv_undef);
2180           else {
2181           SV* const sv = sought ?
2182           #if LSEEKSIZE > IVSIZE
2183           newSVnv((NV)sought)
2184           #else
2185           newSViv(sought)
2186           #endif
2187 210 100       : newSVpvn(zero_but_true, ZBTLEN);
2188 210         mPUSHs(sv);
2189           }
2190           }
2191 61075         RETURN;
2192           }
2193            
2194 327024         PP(pp_truncate)
2195           {
2196           dVAR;
2197 327024         dSP;
2198           /* There seems to be no consensus on the length type of truncate()
2199           * and ftruncate(), both off_t and size_t have supporters. In
2200           * general one would think that when using large files, off_t is
2201           * at least as wide as size_t, so using an off_t should be okay. */
2202           /* XXX Configure probe for the length type of *truncate() needed XXX */
2203           Off_t len;
2204            
2205           #if Off_t_size > IVSIZE
2206           len = (Off_t)POPn;
2207           #else
2208 327024 50       len = (Off_t)POPi;
2209           #endif
2210           /* Checking for length < 0 is problematic as the type might or
2211           * might not be signed: if it is not, clever compilers will moan. */
2212           /* XXX Configure probe for the signedness of the length type of *truncate() needed? XXX */
2213 327024         SETERRNO(0,0);
2214           {
2215 327024         SV * const sv = POPs;
2216           int result = 1;
2217           GV *tmpgv;
2218           IO *io;
2219            
2220 656304 100       if (PL_op->op_flags & OPf_SPECIAL
    100        
2221 485665         ? (tmpgv = gv_fetchsv(sv, 0, SVt_PVIO), 1)
2222 4512 50       : !!(tmpgv = MAYBE_DEREF_GV(sv)) ) {
    100        
    50        
    100        
    100        
    50        
    100        
    50        
    100        
2223 327012 100       io = GvIO(tmpgv);
    50        
    50        
2224 327012 100       if (!io)
2225           result = 0;
2226           else {
2227           PerlIO *fp;
2228           do_ftruncate_io:
2229 327004 50       TAINT_PROPER("truncate");
2230 327004 100       if (!(fp = IoIFP(io))) {
2231           result = 0;
2232           }
2233           else {
2234 327000         PerlIO_flush(fp);
2235           #ifdef HAS_TRUNCATE
2236 327000 100       if (ftruncate(PerlIO_fileno(fp), len) < 0)
2237           #else
2238           if (my_chsize(PerlIO_fileno(fp), len) < 0)
2239           #endif
2240           result = 0;
2241           }
2242           }
2243           }
2244 12 100       else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
    100        
2245 2         io = MUTABLE_IO(SvRV(sv)); /* *main::FRED{IO} for example */
2246 2         goto do_ftruncate_io;
2247           }
2248           else {
2249 10 100       const char * const name = SvPV_nomg_const_nolen(sv);
2250 10 50       TAINT_PROPER("truncate");
2251           #ifdef HAS_TRUNCATE
2252 10 100       if (truncate(name, len) < 0)
2253           result = 0;
2254           #else
2255           {
2256           const int tmpfd = PerlLIO_open(name, O_RDWR);
2257            
2258           if (tmpfd < 0)
2259           result = 0;
2260           else {
2261           if (my_chsize(tmpfd, len) < 0)
2262           result = 0;
2263           PerlLIO_close(tmpfd);
2264           }
2265           }
2266           #endif
2267           }
2268            
2269 327024 100       if (result)
2270 327002         RETPUSHYES;
2271 22 100       if (!errno)
2272 14         SETERRNO(EBADF,RMS_IFI);
2273 163882         RETPUSHUNDEF;
2274           }
2275           }
2276            
2277 134         PP(pp_ioctl)
2278           {
2279 134         dVAR; dSP; dTARGET;
2280 134         SV * const argsv = POPs;
2281 134 50       const unsigned int func = POPu;
2282 134         const int optype = PL_op->op_type;
2283 134         GV * const gv = MUTABLE_GV(POPs);
2284 134 50       IO * const io = gv ? GvIOn(gv) : NULL;
    50        
    50        
    50        
    50        
2285           char *s;
2286           IV retval;
2287            
2288 134 50       if (!io || !argsv || !IoIFP(io)) {
    100        
2289 2         report_evil_fh(gv);
2290 2         SETERRNO(EBADF,RMS_IFI); /* well, sort of... */
2291 2         RETPUSHUNDEF;
2292           }
2293            
2294 132 50       if (SvPOK(argsv) || !SvNIOK(argsv)) {
    50        
2295           STRLEN len;
2296           STRLEN need;
2297 0 0       s = SvPV_force(argsv, len);
2298 0         need = IOCPARM_LEN(func);
2299 0 0       if (len < need) {
2300 0         s = Sv_Grow(argsv, need + 1);
2301 0         SvCUR_set(argsv, need);
2302           }
2303            
2304 0         s[SvCUR(argsv)] = 17; /* a little sanity check here */
2305           }
2306           else {
2307 132 50       retval = SvIV(argsv);
2308 132         s = INT2PTR(char*,retval); /* ouch */
2309           }
2310            
2311 132 50       TAINT_PROPER(PL_op_desc[optype]);
2312            
2313 132 50       if (optype == OP_IOCTL)
2314           #ifdef HAS_IOCTL
2315 0         retval = PerlLIO_ioctl(PerlIO_fileno(IoIFP(io)), func, s);
2316           #else
2317           DIE(aTHX_ "ioctl is not implemented");
2318           #endif
2319           else
2320           #ifndef HAS_FCNTL
2321           DIE(aTHX_ "fcntl is not implemented");
2322           #else
2323           #if defined(OS2) && defined(__EMX__)
2324           retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s);
2325           #else
2326 132         retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s);
2327           #endif
2328           #endif
2329            
2330           #if defined(HAS_IOCTL) || defined(HAS_FCNTL)
2331 132 50       if (SvPOK(argsv)) {
2332 0 0       if (s[SvCUR(argsv)] != 17)
2333 0 0       DIE(aTHX_ "Possible memory corruption: %s overflowed 3rd argument",
2334 0 0       OP_NAME(PL_op));
2335 0         s[SvCUR(argsv)] = 0; /* put our null back */
2336 0 0       SvSETMAGIC(argsv); /* Assume it has changed */
2337           }
2338            
2339 132 50       if (retval == -1)
2340 0         RETPUSHUNDEF;
2341 132 100       if (retval != 0) {
2342 66 50       PUSHi(retval);
2343           }
2344           else {
2345 66 50       PUSHp(zero_but_true, ZBTLEN);
2346           }
2347           #endif
2348 133         RETURN;
2349           }
2350            
2351 2323956         PP(pp_flock)
2352           {
2353           #ifdef FLOCK
2354 2323956         dVAR; dSP; dTARGET;
2355           I32 value;
2356 2323956 100       const int argtype = POPi;
2357 2323956         GV * const gv = MUTABLE_GV(POPs);
2358 2323956 50       IO *const io = GvIO(gv);
    100        
    50        
2359 2323956 100       PerlIO *const fp = io ? IoIFP(io) : NULL;
2360            
2361           /* XXX Looks to me like io is always NULL at this point */
2362 2323956 100       if (fp) {
2363 2323938         (void)PerlIO_flush(fp);
2364 2323938         value = (I32)(PerlLIO_flock(PerlIO_fileno(fp), argtype) >= 0);
2365           }
2366           else {
2367 18         report_evil_fh(gv);
2368           value = 0;
2369 18         SETERRNO(EBADF,RMS_IFI);
2370           }
2371 2323956 50       PUSHi(value);
2372 2323956         RETURN;
2373           #else
2374           DIE(aTHX_ PL_no_func, "flock()");
2375           #endif
2376           }
2377            
2378           /* Sockets. */
2379            
2380           #ifdef HAS_SOCKET
2381            
2382 120         PP(pp_socket)
2383           {
2384 120         dVAR; dSP;
2385 120 100       const int protocol = POPi;
2386 120 100       const int type = POPi;
2387 120 100       const int domain = POPi;
2388 120         GV * const gv = MUTABLE_GV(POPs);
2389 120 50       IO * const io = gv ? GvIOn(gv) : NULL;
    50        
    50        
    50        
    100        
2390           int fd;
2391            
2392 120 50       if (!io) {
2393 0         report_evil_fh(gv);
2394 0 0       if (io && IoIFP(io))
    0        
2395 0         do_close(gv, FALSE);
2396 0         SETERRNO(EBADF,LIB_INVARG);
2397 0         RETPUSHUNDEF;
2398           }
2399            
2400 120 100       if (IoIFP(io))
2401 4         do_close(gv, FALSE);
2402            
2403 120 50       TAINT_PROPER("socket");
2404 120         fd = PerlSock_socket(domain, type, protocol);
2405 120 100       if (fd < 0)
2406 2         RETPUSHUNDEF;
2407 118         IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */
2408 118         IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2409 118         IoTYPE(io) = IoTYPE_SOCKET;
2410 118 50       if (!IoIFP(io) || !IoOFP(io)) {
    50        
2411 0 0       if (IoIFP(io)) PerlIO_close(IoIFP(io));
2412 0 0       if (IoOFP(io)) PerlIO_close(IoOFP(io));
2413 0 0       if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
    0        
2414 0         RETPUSHUNDEF;
2415           }
2416           #if defined(HAS_FCNTL) && defined(F_SETFD)
2417 118         fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2418           #endif
2419            
2420 119         RETPUSHYES;
2421           }
2422           #endif
2423            
2424 52         PP(pp_sockpair)
2425           {
2426           #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET))
2427 52         dVAR; dSP;
2428 52 100       const int protocol = POPi;
2429 52 100       const int type = POPi;
2430 52 100       const int domain = POPi;
2431 52         GV * const gv2 = MUTABLE_GV(POPs);
2432 52         GV * const gv1 = MUTABLE_GV(POPs);
2433 52 50       IO * const io1 = gv1 ? GvIOn(gv1) : NULL;
    50        
    50        
    50        
    100        
2434 52 50       IO * const io2 = gv2 ? GvIOn(gv2) : NULL;
    50        
    50        
    50        
    100        
2435           int fd[2];
2436            
2437 52 50       if (!io1)
2438 0         report_evil_fh(gv1);
2439 52 50       if (!io2)
2440 0         report_evil_fh(gv2);
2441            
2442 52 50       if (io1 && IoIFP(io1))
    50        
2443 0         do_close(gv1, FALSE);
2444 52 50       if (io2 && IoIFP(io2))
    50        
2445 0         do_close(gv2, FALSE);
2446            
2447 52 50       if (!io1 || !io2)
2448 0         RETPUSHUNDEF;
2449            
2450 52 50       TAINT_PROPER("socketpair");
2451 52 100       if (PerlSock_socketpair(domain, type, protocol, fd) < 0)
2452 4         RETPUSHUNDEF;
2453 48         IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE);
2454 48         IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE);
2455 48         IoTYPE(io1) = IoTYPE_SOCKET;
2456 48         IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE);
2457 48         IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE);
2458 48         IoTYPE(io2) = IoTYPE_SOCKET;
2459 48 50       if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) {
    50        
    50        
    50        
2460 0 0       if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
2461 0 0       if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
2462 0 0       if (!IoIFP(io1) && !IoOFP(io1)) PerlLIO_close(fd[0]);
    0        
2463 0 0       if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
2464 0 0       if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
2465 0 0       if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]);
    0        
2466 0         RETPUSHUNDEF;
2467           }
2468           #if defined(HAS_FCNTL) && defined(F_SETFD)
2469 48         fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */
2470 48         fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */
2471           #endif
2472            
2473 50         RETPUSHYES;
2474           #else
2475           DIE(aTHX_ PL_no_sock_func, "socketpair");
2476           #endif
2477           }
2478            
2479           #ifdef HAS_SOCKET
2480            
2481 194         PP(pp_bind)
2482           {
2483 194         dVAR; dSP;
2484 194         SV * const addrsv = POPs;
2485           /* OK, so on what platform does bind modify addr? */
2486           const char *addr;
2487 194         GV * const gv = MUTABLE_GV(POPs);
2488 194 50       IO * const io = GvIOn(gv);
    100        
    50        
    100        
2489           STRLEN len;
2490 192         const int op_type = PL_op->op_type;
2491            
2492 192 50       if (!io || !IoIFP(io))
    100        
2493           goto nuts;
2494            
2495 120 50       addr = SvPV_const(addrsv, len);
2496 120 50       TAINT_PROPER(PL_op_desc[op_type]);
2497 120 100       if ((op_type == OP_BIND
2498 56         ? PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len)
2499 64         : PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len))
2500 240 100       >= 0)
2501 90         RETPUSHYES;
2502           else
2503 30         RETPUSHUNDEF;
2504            
2505           nuts:
2506 72         report_evil_fh(gv);
2507 72         SETERRNO(EBADF,SS_IVCHAN);
2508 132         RETPUSHUNDEF;
2509           }
2510            
2511 74         PP(pp_listen)
2512           {
2513 74         dVAR; dSP;
2514 74 50       const int backlog = POPi;
2515 74         GV * const gv = MUTABLE_GV(POPs);
2516 74 50       IO * const io = gv ? GvIOn(gv) : NULL;
    50        
    50        
    50        
    50        
2517            
2518 74 50       if (!io || !IoIFP(io))
    100        
2519           goto nuts;
2520            
2521 42 50       if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
2522 42         RETPUSHYES;
2523           else
2524 0         RETPUSHUNDEF;
2525            
2526           nuts:
2527 32         report_evil_fh(gv);
2528 32         SETERRNO(EBADF,SS_IVCHAN);
2529 53         RETPUSHUNDEF;
2530           }
2531            
2532 80         PP(pp_accept)
2533           {
2534 80         dVAR; dSP; dTARGET;
2535           IO *nstio;
2536           IO *gstio;
2537           char namebuf[MAXPATHLEN];
2538           #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
2539           Sock_size_t len = sizeof (struct sockaddr_in);
2540           #else
2541 80         Sock_size_t len = sizeof namebuf;
2542           #endif
2543 80         GV * const ggv = MUTABLE_GV(POPs);
2544 80         GV * const ngv = MUTABLE_GV(POPs);
2545           int fd;
2546            
2547 80 50       if (!ngv)
2548           goto badexit;
2549 80 50       if (!ggv)
2550           goto nuts;
2551            
2552 80 50       gstio = GvIO(ggv);
    100        
    50        
2553 80 100       if (!gstio || !IoIFP(gstio))
    100        
2554           goto nuts;
2555            
2556 40 50       nstio = GvIOn(ngv);
    50        
    50        
    50        
2557 40         fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len);
2558           #if defined(OEMVS)
2559           if (len == 0) {
2560           /* Some platforms indicate zero length when an AF_UNIX client is
2561           * not bound. Simulate a non-zero-length sockaddr structure in
2562           * this case. */
2563           namebuf[0] = 0; /* sun_len */
2564           namebuf[1] = AF_UNIX; /* sun_family */
2565           len = 2;
2566           }
2567           #endif
2568            
2569 40 50       if (fd < 0)
2570           goto badexit;
2571 40 50       if (IoIFP(nstio))
2572 0         do_close(ngv, FALSE);
2573 40         IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);
2574 40         IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
2575 40         IoTYPE(nstio) = IoTYPE_SOCKET;
2576 40 50       if (!IoIFP(nstio) || !IoOFP(nstio)) {
    50        
2577 0 0       if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
2578 0 0       if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
2579 0 0       if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd);
    0        
2580           goto badexit;
2581           }
2582           #if defined(HAS_FCNTL) && defined(F_SETFD)
2583 40         fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
2584           #endif
2585            
2586           #ifdef __SCO_VERSION__
2587           len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */
2588           #endif
2589            
2590 40 50       PUSHp(namebuf, len);
2591 40         RETURN;
2592            
2593           nuts:
2594 40         report_evil_fh(ggv);
2595 40         SETERRNO(EBADF,SS_IVCHAN);
2596            
2597           badexit:
2598 60         RETPUSHUNDEF;
2599            
2600           }
2601            
2602 38         PP(pp_shutdown)
2603           {
2604 38         dVAR; dSP; dTARGET;
2605 38 50       const int how = POPi;
2606 38         GV * const gv = MUTABLE_GV(POPs);
2607 38 50       IO * const io = GvIOn(gv);
    50        
    50        
    50        
2608            
2609 38 50       if (!io || !IoIFP(io))
    100        
2610           goto nuts;
2611            
2612 6 50       PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
2613 6         RETURN;
2614            
2615           nuts:
2616 32         report_evil_fh(gv);
2617 32         SETERRNO(EBADF,SS_IVCHAN);
2618 35         RETPUSHUNDEF;
2619           }
2620            
2621 84         PP(pp_ssockopt)
2622           {
2623 84         dVAR; dSP;
2624 84         const int optype = PL_op->op_type;
2625 84 100       SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
2626 84 50       const unsigned int optname = (unsigned int) POPi;
2627 84 50       const unsigned int lvl = (unsigned int) POPi;
2628 84         GV * const gv = MUTABLE_GV(POPs);
2629 84 50       IO * const io = GvIOn(gv);
    50        
    50        
    50        
2630           int fd;
2631           Sock_size_t len;
2632            
2633 84 50       if (!io || !IoIFP(io))
    100        
2634           goto nuts;
2635            
2636 20         fd = PerlIO_fileno(IoIFP(io));
2637 20         switch (optype) {
2638           case OP_GSOCKOPT:
2639 20 50       SvGROW(sv, 257);
    50        
2640 20         (void)SvPOK_only(sv);
2641 20         SvCUR_set(sv,256);
2642 20         *SvEND(sv) ='\0';
2643 20         len = SvCUR(sv);
2644 20 50       if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
2645           goto nuts2;
2646 20         SvCUR_set(sv, len);
2647 20         *SvEND(sv) ='\0';
2648 20         PUSHs(sv);
2649 20         break;
2650           case OP_SSOCKOPT: {
2651           #if defined(__SYMBIAN32__)
2652           # define SETSOCKOPT_OPTION_VALUE_T void *
2653           #else
2654           # define SETSOCKOPT_OPTION_VALUE_T const char *
2655           #endif
2656           /* XXX TODO: We need to have a proper type (a Configure probe,
2657           * etc.) for what the C headers think of the third argument of
2658           * setsockopt(), the option_value read-only buffer: is it
2659           * a "char *", or a "void *", const or not. Some compilers
2660           * don't take kindly to e.g. assuming that "char *" implicitly
2661           * promotes to a "void *", or to explicitly promoting/demoting
2662           * consts to non/vice versa. The "const void *" is the SUS
2663           * definition, but that does not fly everywhere for the above
2664           * reasons. */
2665           SETSOCKOPT_OPTION_VALUE_T buf;
2666           int aint;
2667 0 0       if (SvPOKp(sv)) {
2668           STRLEN l;
2669 0 0       buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l);
2670 0         len = l;
2671           }
2672           else {
2673 0 0       aint = (int)SvIV(sv);
2674           buf = (SETSOCKOPT_OPTION_VALUE_T) &aint;
2675 0         len = sizeof(int);
2676           }
2677 0 0       if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0)
2678           goto nuts2;
2679 0         PUSHs(&PL_sv_yes);
2680           }
2681 0         break;
2682           }
2683 20         RETURN;
2684            
2685           nuts:
2686 64         report_evil_fh(gv);
2687 64         SETERRNO(EBADF,SS_IVCHAN);
2688           nuts2:
2689 74         RETPUSHUNDEF;
2690            
2691           }
2692            
2693 144         PP(pp_getpeername)
2694           {
2695 144         dVAR; dSP;
2696 144         const int optype = PL_op->op_type;
2697 144         GV * const gv = MUTABLE_GV(POPs);
2698 144 50       IO * const io = GvIOn(gv);
    50        
    50        
    50        
2699           Sock_size_t len;
2700           SV *sv;
2701           int fd;
2702            
2703 144 50       if (!io || !IoIFP(io))
    100        
2704           goto nuts;
2705            
2706 80         sv = sv_2mortal(newSV(257));
2707 80         (void)SvPOK_only(sv);
2708 80         len = 256;
2709 80         SvCUR_set(sv, len);
2710 80         *SvEND(sv) ='\0';
2711 80         fd = PerlIO_fileno(IoIFP(io));
2712 80         switch (optype) {
2713           case OP_GETSOCKNAME:
2714 50 50       if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2715           goto nuts2;
2716           break;
2717           case OP_GETPEERNAME:
2718 30 100       if (PerlSock_getpeername(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
2719           goto nuts2;
2720           #if defined(VMS_DO_SOCKETS) && defined (DECCRTL_SOCKETS)
2721           {
2722           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";
2723           /* If the call succeeded, make sure we don't have a zeroed port/addr */
2724           if (((struct sockaddr *)SvPVX_const(sv))->sa_family == AF_INET &&
2725           !memcmp(SvPVX_const(sv) + sizeof(u_short), nowhere,
2726           sizeof(u_short) + sizeof(struct in_addr))) {
2727           goto nuts2;
2728           }
2729           }
2730           #endif
2731           break;
2732           }
2733           #ifdef BOGUS_GETNAME_RETURN
2734           /* Interactive Unix, getpeername() and getsockname()
2735           does not return valid namelen */
2736           if (len == BOGUS_GETNAME_RETURN)
2737           len = sizeof(struct sockaddr);
2738           #endif
2739 66         SvCUR_set(sv, len);
2740 66         *SvEND(sv) ='\0';
2741 66         PUSHs(sv);
2742 66         RETURN;
2743            
2744           nuts:
2745 64         report_evil_fh(gv);
2746 64         SETERRNO(EBADF,SS_IVCHAN);
2747           nuts2:
2748 111         RETPUSHUNDEF;
2749           }
2750            
2751           #endif
2752            
2753           /* Stat calls. */
2754            
2755 592536         PP(pp_stat)
2756           {
2757           dVAR;
2758 592536         dSP;
2759           GV *gv = NULL;
2760           IO *io = NULL;
2761           I32 gimme;
2762           I32 max = 13;
2763           SV* sv;
2764            
2765 1183934 100       if (PL_op->op_flags & OPf_REF ? (gv = cGVOP_gv, 1)
    100        
2766 591398 100       : !!(sv=POPs, gv = MAYBE_DEREF_GV(sv))) {
    100        
    50        
    100        
    100        
    50        
    100        
    50        
    100        
2767 1646 100       if (PL_op->op_type == OP_LSTAT) {
2768 38 100       if (gv != PL_defgv) {
2769           do_fstat_warning_check:
2770 44 100       Perl_ck_warner(aTHX_ packWARN(WARN_IO),
    100        
2771           "lstat() on filehandle%s%"SVf,
2772           gv ? " " : "",
2773 20 50       SVfARG(gv
2774           ? sv_2mortal(newSVhek(GvENAME_HEK(gv)))
2775           : &PL_sv_no));
2776 18 100       } else if (PL_laststype != OP_LSTAT)
2777           /* diag_listed_as: The stat preceding %s wasn't an lstat */
2778 12         Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat");
2779           }
2780            
2781 1638 100       if (gv != PL_defgv) {
2782           bool havefp;
2783           do_fstat_have_io:
2784           havefp = FALSE;
2785 548         PL_laststype = OP_STAT;
2786 548 100       PL_statgv = gv ? gv : (GV *)io;
2787 548         sv_setpvs(PL_statname, "");
2788 548 100       if(gv) {
2789 534 50       io = GvIO(gv);
    50        
    50        
2790           }
2791 548 100       if (io) {
2792 544 100       if (IoIFP(io)) {
2793 526         PL_laststatval =
2794 526         PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
2795           havefp = TRUE;
2796 18 100       } else if (IoDIRP(io)) {
2797 4         PL_laststatval =
2798 4         PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
2799           havefp = TRUE;
2800           } else {
2801 14         PL_laststatval = -1;
2802           }
2803           }
2804 4         else PL_laststatval = -1;
2805 548 100       if (PL_laststatval < 0 && !havefp) report_evil_fh(gv);
    50        
2806           }
2807            
2808 1648 100       if (PL_laststatval < 0) {
2809           max = 0;
2810           }
2811           }
2812           else {
2813 590890 100       if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) {
    100        
2814 14         io = MUTABLE_IO(SvRV(sv));
2815 14 100       if (PL_op->op_type == OP_LSTAT)
2816           goto do_fstat_warning_check;
2817           goto do_fstat_have_io;
2818           }
2819          
2820 590876 100       SvTAINTED_off(PL_statname); /* previous tainting irrelevant */
2821 590876 100       sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
2822 590876         PL_statgv = NULL;
2823 590876         PL_laststype = PL_op->op_type;
2824 590876 100       if (PL_op->op_type == OP_LSTAT)
2825 1105692 50       PL_laststatval = PerlLIO_lstat(SvPV_nolen_const(PL_statname), &PL_statcache);
2826           else
2827 76060 50       PL_laststatval = PerlLIO_stat(SvPV_nolen_const(PL_statname), &PL_statcache);
2828 590876 100       if (PL_laststatval < 0) {
2829 3914 100       if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), '\n'))
    50        
    100        
2830 6         Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
2831           max = 0;
2832           }
2833           }
2834            
2835 592524 100       gimme = GIMME_V;
2836 592524 100       if (gimme != G_ARRAY) {
2837 536 100       if (gimme != G_VOID)
2838 308 50       XPUSHs(boolSV(max));
    100        
2839 536         RETURN;
2840           }
2841 886043 100       if (max) {
    50        
2842 294055         EXTEND(SP, max);
2843 588110 50       EXTEND_MORTAL(max);
2844 588110         mPUSHi(PL_statcache.st_dev);
2845           #if ST_INO_SIZE > IVSIZE
2846           mPUSHn(PL_statcache.st_ino);
2847           #else
2848           # if ST_INO_SIGN <= 0
2849           mPUSHi(PL_statcache.st_ino);
2850           # else
2851 588110         mPUSHu(PL_statcache.st_ino);
2852           # endif
2853           #endif
2854 588110         mPUSHu(PL_statcache.st_mode);
2855 588110         mPUSHu(PL_statcache.st_nlink);
2856          
2857 588110         sv_setuid(PUSHmortal, PL_statcache.st_uid);
2858 588110         sv_setgid(PUSHmortal, PL_statcache.st_gid);
2859            
2860           #ifdef USE_STAT_RDEV
2861 588110         mPUSHi(PL_statcache.st_rdev);
2862           #else
2863           PUSHs(newSVpvs_flags("", SVs_TEMP));
2864           #endif
2865           #if Off_t_size > IVSIZE
2866           mPUSHn(PL_statcache.st_size);
2867           #else
2868 588110         mPUSHi(PL_statcache.st_size);
2869           #endif
2870           #ifdef BIG_TIME
2871           mPUSHn(PL_statcache.st_atime);
2872           mPUSHn(PL_statcache.st_mtime);
2873           mPUSHn(PL_statcache.st_ctime);
2874           #else
2875 588110         mPUSHi(PL_statcache.st_atime);
2876 588110         mPUSHi(PL_statcache.st_mtime);
2877 588110         mPUSHi(PL_statcache.st_ctime);
2878           #endif
2879           #ifdef USE_STAT_BLOCKS
2880 588110         mPUSHu(PL_statcache.st_blksize);
2881 588110         mPUSHu(PL_statcache.st_blocks);
2882           #else
2883           PUSHs(newSVpvs_flags("", SVs_TEMP));
2884           PUSHs(newSVpvs_flags("", SVs_TEMP));
2885           #endif
2886           }
2887 592256         RETURN;
2888           }
2889            
2890           /* All filetest ops avoid manipulating the perl stack pointer in their main
2891           bodies (since commit d2c4d2d1e22d3125), and return using either
2892           S_ft_return_false() or S_ft_return_true(). These two helper functions are
2893           the only two which manipulate the perl stack. To ensure that no stack
2894           manipulation macros are used, the filetest ops avoid defining a local copy
2895           of the stack pointer with dSP. */
2896            
2897           /* If the next filetest is stacked up with this one
2898           (PL_op->op_private & OPpFT_STACKING), we leave
2899           the original argument on the stack for success,
2900           and skip the stacked operators on failure.
2901           The next few macros/functions take care of this.
2902           */
2903            
2904           static OP *
2905 746048         S_ft_return_false(pTHX_ SV *ret) {
2906 746048         OP *next = NORMAL;
2907 746048         dSP;
2908            
2909 746048 100       if (PL_op->op_flags & OPf_REF) XPUSHs(ret);
    50        
2910 693784         else SETs(ret);
2911 746048         PUTBACK;
2912            
2913 746048 100       if (PL_op->op_private & OPpFT_STACKING) {
2914 28 100       while (OP_IS_FILETEST(next->op_type)
2915 14 50       && next->op_private & OPpFT_STACKED)
2916 14         next = next->op_next;
2917           }
2918 746048         return next;
2919           }
2920            
2921           PERL_STATIC_INLINE OP *
2922 808876         S_ft_return_true(pTHX_ SV *ret) {
2923 808876         dSP;
2924 808876 100       if (PL_op->op_flags & OPf_REF)
2925 56820 50       XPUSHs(PL_op->op_private & OPpFT_STACKING ? (SV *)cGVOP_gv : (ret));
    100        
2926 752056 100       else if (!(PL_op->op_private & OPpFT_STACKING))
2927 751860         SETs(ret);
2928 808876         PUTBACK;
2929 808876         return NORMAL;
2930           }
2931            
2932           #define FT_RETURNNO return S_ft_return_false(aTHX_ &PL_sv_no)
2933           #define FT_RETURNUNDEF return S_ft_return_false(aTHX_ &PL_sv_undef)
2934           #define FT_RETURNYES return S_ft_return_true(aTHX_ &PL_sv_yes)
2935            
2936           #define tryAMAGICftest_MG(chr) STMT_START { \
2937           if ( (SvFLAGS(*PL_stack_sp) & (SVf_ROK|SVs_GMG)) \
2938           && PL_op->op_flags & OPf_KIDS) { \
2939           OP *next = S_try_amagic_ftest(aTHX_ chr); \
2940           if (next) return next; \
2941           } \
2942           } STMT_END
2943            
2944           STATIC OP *
2945 7038         S_try_amagic_ftest(pTHX_ char chr) {
2946           dVAR;
2947 7038         SV *const arg = *PL_stack_sp;
2948            
2949           assert(chr != '?');
2950 7038 100       if (!(PL_op->op_private & OPpFT_STACKING)) SvGETMAGIC(arg);
    100        
2951            
2952 7036 100       if (SvAMAGIC(arg))
    100        
    100        
2953           {
2954 2852         const char tmpchr = chr;
2955 2852         SV * const tmpsv = amagic_call(arg,
2956           newSVpvn_flags(&tmpchr, 1, SVs_TEMP),
2957           ftest_amg, AMGf_unary);
2958            
2959 2846 100       if (!tmpsv)
2960           return NULL;
2961            
2962 8687 0       return SvTRUE(tmpsv)
    0        
    0        
    50        
    100        
    100        
    50        
    100        
    100        
    100        
    100        
    50        
    100        
    0        
2963 8681 50       ? S_ft_return_true(aTHX_ tmpsv) : S_ft_return_false(aTHX_ tmpsv);
    50        
    50        
    100        
    50        
2964           }
2965           return NULL;
2966           }
2967            
2968            
2969 43586         PP(pp_ftrread)
2970           {
2971           dVAR;
2972           I32 result;
2973           /* Not const, because things tweak this below. Not bool, because there's
2974           no guarantee that OPp_FT_ACCESS is <= CHAR_MAX */
2975           #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
2976 43586         I32 use_access = PL_op->op_private & OPpFT_ACCESS;
2977           /* Giving some sort of initial value silences compilers. */
2978           # ifdef R_OK
2979           int access_mode = R_OK;
2980           # else
2981           int access_mode = 0;
2982           # endif
2983           #else
2984           /* access_mode is never used, but leaving use_access in makes the
2985           conditional compiling below much clearer. */
2986           I32 use_access = 0;
2987           #endif
2988           Mode_t stat_mode = S_IRUSR;
2989            
2990           bool effective = FALSE;
2991           char opchar = '?';
2992            
2993 43586 50       switch (PL_op->op_type) {
2994           case OP_FTRREAD: opchar = 'R'; break;
2995           case OP_FTRWRITE: opchar = 'W'; break;
2996           case OP_FTREXEC: opchar = 'X'; break;
2997           case OP_FTEREAD: opchar = 'r'; break;
2998           case OP_FTEWRITE: opchar = 'w'; break;
2999           case OP_FTEEXEC: opchar = 'x'; break;
3000           }
3001 43586 100       tryAMAGICftest_MG(opchar);
    100        
    100        
3002            
3003 42864 100       switch (PL_op->op_type) {
3004           case OP_FTRREAD:
3005           #if !(defined(HAS_ACCESS) && defined(R_OK))
3006           use_access = 0;
3007           #endif
3008           break;
3009            
3010           case OP_FTRWRITE:
3011           #if defined(HAS_ACCESS) && defined(W_OK)
3012           access_mode = W_OK;
3013           #else
3014           use_access = 0;
3015           #endif
3016           stat_mode = S_IWUSR;
3017           break;
3018            
3019           case OP_FTREXEC:
3020           #if defined(HAS_ACCESS) && defined(X_OK)
3021           access_mode = X_OK;
3022           #else
3023           use_access = 0;
3024           #endif
3025           stat_mode = S_IXUSR;
3026           break;
3027            
3028           case OP_FTEWRITE:
3029           #ifdef PERL_EFF_ACCESS
3030           access_mode = W_OK;
3031           #endif
3032           stat_mode = S_IWUSR;
3033           /* fall through */
3034            
3035           case OP_FTEREAD:
3036           #ifndef PERL_EFF_ACCESS
3037           use_access = 0;
3038           #endif
3039           effective = TRUE;
3040           break;
3041            
3042           case OP_FTEEXEC:
3043           #ifdef PERL_EFF_ACCESS
3044           access_mode = X_OK;
3045           #else
3046           use_access = 0;
3047           #endif
3048           stat_mode = S_IXUSR;
3049           effective = TRUE;
3050           break;
3051           }
3052            
3053 42864 50       if (use_access) {
3054           #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
3055 0 0       const char *name = SvPV_nolen(*PL_stack_sp);
3056 0 0       if (effective) {
3057           # ifdef PERL_EFF_ACCESS
3058 0         result = PERL_EFF_ACCESS(name, access_mode);
3059           # else
3060           DIE(aTHX_ "panic: attempt to call PERL_EFF_ACCESS in %s",
3061           OP_NAME(PL_op));
3062           # endif
3063           }
3064           else {
3065           # ifdef HAS_ACCESS
3066 0         result = access(name, access_mode);
3067           # else
3068           DIE(aTHX_ "panic: attempt to call access() in %s", OP_NAME(PL_op));
3069           # endif
3070           }
3071 0 0       if (result == 0)
3072 0         FT_RETURNYES;
3073 0 0       if (result < 0)
3074 0         FT_RETURNUNDEF;
3075 0         FT_RETURNNO;
3076           #endif
3077           }
3078            
3079 42864         result = my_stat_flags(0);
3080 42860 100       if (result < 0)
3081 5636         FT_RETURNUNDEF;
3082 37224 100       if (cando(stat_mode, effective, &PL_statcache))
3083 24152         FT_RETURNYES;
3084 28506         FT_RETURNNO;
3085           }
3086            
3087 648172         PP(pp_ftis)
3088           {
3089           dVAR;
3090           I32 result;
3091 648172         const int op_type = PL_op->op_type;
3092           char opchar = '?';
3093            
3094 648172 50       switch (op_type) {
3095           case OP_FTIS: opchar = 'e'; break;
3096           case OP_FTSIZE: opchar = 's'; break;
3097           case OP_FTMTIME: opchar = 'M'; break;
3098           case OP_FTCTIME: opchar = 'C'; break;
3099           case OP_FTATIME: opchar = 'A'; break;
3100           }
3101 648172 100       tryAMAGICftest_MG(opchar);
    100        
    100        
3102            
3103 647666         result = my_stat_flags(0);
3104 647666 100       if (result < 0)
3105 55387         FT_RETURNUNDEF;
3106 592279 100       if (op_type == OP_FTIS)
3107 458101         FT_RETURNYES;
3108           {
3109           /* You can't dTARGET inside OP_FTIS, because you'll get
3110           "panic: pad_sv po" - the op is not flagged to have a target. */
3111 134178         dTARGET;
3112 134178         switch (op_type) {
3113           case OP_FTSIZE:
3114           #if Off_t_size > IVSIZE
3115           sv_setnv(TARG, (NV)PL_statcache.st_size);
3116           #else
3117 133118         sv_setiv(TARG, (IV)PL_statcache.st_size);
3118           #endif
3119 133118         break;
3120           case OP_FTMTIME:
3121 938         sv_setnv(TARG,
3122           ((NV)PL_basetime - PL_statcache.st_mtime) / 86400.0 );
3123 938         break;
3124           case OP_FTATIME:
3125 60         sv_setnv(TARG,
3126           ((NV)PL_basetime - PL_statcache.st_atime) / 86400.0 );
3127 60         break;
3128           case OP_FTCTIME:
3129 62         sv_setnv(TARG,
3130           ((NV)PL_basetime - PL_statcache.st_ctime) / 86400.0 );
3131 62         break;
3132           }
3133 134178 50       SvSETMAGIC(TARG);
3134 589923 0       return SvTRUE_nomg(TARG)
    0        
    0        
    0        
    0        
    0        
    0        
    100        
    100        
    100        
    100        
    100        
    0        
3135 403973 50       ? S_ft_return_true(aTHX_ TARG) : S_ft_return_false(aTHX_ TARG);
    50        
    50        
    50        
3136           }
3137           }
3138            
3139 469378         PP(pp_ftrowned)
3140           {
3141           dVAR;
3142           I32 result;
3143           char opchar = '?';
3144            
3145 469378 50       switch (PL_op->op_type) {
3146           case OP_FTROWNED: opchar = 'O'; break;
3147           case OP_FTEOWNED: opchar = 'o'; break;
3148           case OP_FTZERO: opchar = 'z'; break;
3149           case OP_FTSOCK: opchar = 'S'; break;
3150           case OP_FTCHR: opchar = 'c'; break;
3151           case OP_FTBLK: opchar = 'b'; break;
3152           case OP_FTFILE: opchar = 'f'; break;
3153           case OP_FTDIR: opchar = 'd'; break;
3154           case OP_FTPIPE: opchar = 'p'; break;
3155           case OP_FTSUID: opchar = 'u'; break;
3156           case OP_FTSGID: opchar = 'g'; break;
3157           case OP_FTSVTX: opchar = 'k'; break;
3158           }
3159 469378 100       tryAMAGICftest_MG(opchar);
    100        
    100        
3160            
3161           /* I believe that all these three are likely to be defined on most every
3162           system these days. */
3163           #ifndef S_ISUID
3164           if(PL_op->op_type == OP_FTSUID) {
3165           FT_RETURNNO;
3166           }
3167           #endif
3168           #ifndef S_ISGID
3169           if(PL_op->op_type == OP_FTSGID) {
3170           FT_RETURNNO;
3171           }
3172           #endif
3173           #ifndef S_ISVTX
3174           if(PL_op->op_type == OP_FTSVTX) {
3175           FT_RETURNNO;
3176           }
3177           #endif
3178            
3179 468150         result = my_stat_flags(0);
3180 468150 100       if (result < 0)
3181 78263         FT_RETURNUNDEF;
3182 389887         switch (PL_op->op_type) {
3183           case OP_FTROWNED:
3184 58 50       if (PL_statcache.st_uid == PerlProc_getuid())
3185 58         FT_RETURNYES;
3186           break;
3187           case OP_FTEOWNED:
3188 60 50       if (PL_statcache.st_uid == PerlProc_geteuid())
3189 60         FT_RETURNYES;
3190           break;
3191           case OP_FTZERO:
3192 992 100       if (PL_statcache.st_size == 0)
3193 44         FT_RETURNYES;
3194           break;
3195           case OP_FTSOCK:
3196 456 100       if (S_ISSOCK(PL_statcache.st_mode))
3197 4         FT_RETURNYES;
3198           break;
3199           case OP_FTCHR:
3200 470 100       if (S_ISCHR(PL_statcache.st_mode))
3201 310         FT_RETURNYES;
3202           break;
3203           case OP_FTBLK:
3204 454 100       if (S_ISBLK(PL_statcache.st_mode))
3205 62         FT_RETURNYES;
3206           break;
3207           case OP_FTFILE:
3208 187559 100       if (S_ISREG(PL_statcache.st_mode))
3209 167301         FT_RETURNYES;
3210           break;
3211           case OP_FTDIR:
3212 197046 100       if (S_ISDIR(PL_statcache.st_mode))
3213 140506         FT_RETURNYES;
3214           break;
3215           case OP_FTPIPE:
3216 72 100       if (S_ISFIFO(PL_statcache.st_mode))
3217 2         FT_RETURNYES;
3218           break;
3219           #ifdef S_ISUID
3220           case OP_FTSUID:
3221 984 100       if (PL_statcache.st_mode & S_ISUID)
3222 2         FT_RETURNYES;
3223           break;
3224           #endif
3225           #ifdef S_ISGID
3226           case OP_FTSGID:
3227 866 50       if (PL_statcache.st_mode & S_ISGID)
3228 0         FT_RETURNYES;
3229           break;
3230           #endif
3231           #ifdef S_ISVTX
3232           case OP_FTSVTX:
3233 870 100       if (PL_statcache.st_mode & S_ISVTX)
3234 4         FT_RETURNYES;
3235           break;
3236           #endif
3237           }
3238 277434         FT_RETURNNO;
3239           }
3240            
3241 388892         PP(pp_ftlink)
3242           {
3243           dVAR;
3244           I32 result;
3245            
3246 388892 100       tryAMAGICftest_MG('l');
    50        
    100        
3247 388790         result = my_lstat_flags(0);
3248            
3249 388776 100       if (result < 0)
3250 44         FT_RETURNUNDEF;
3251 388732 100       if (S_ISLNK(PL_statcache.st_mode))
3252 56         FT_RETURNYES;
3253 388777         FT_RETURNNO;
3254           }
3255            
3256 856         PP(pp_fttty)
3257           {
3258           dVAR;
3259           int fd;
3260           GV *gv;
3261           char *name = NULL;
3262           STRLEN namelen;
3263            
3264 856 100       tryAMAGICftest_MG('t');
    100        
    100        
3265            
3266 844 100       if (PL_op->op_flags & OPf_REF)
3267 48         gv = cGVOP_gv;
3268           else {
3269 796         SV *tmpsv = *PL_stack_sp;
3270 796 100       if (!(gv = MAYBE_DEREF_GV_nomg(tmpsv))) {
    50        
    100        
    100        
    50        
    100        
    50        
    100        
    100        
3271 26 100       name = SvPV_nomg(tmpsv, namelen);
3272 26         gv = gv_fetchpvn_flags(name, namelen, SvUTF8(tmpsv), SVt_PVIO);
3273           }
3274           }
3275            
3276 844 100       if (GvIO(gv) && IoIFP(GvIOp(gv)))
    50        
    50        
    50        
    100        
3277 770         fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
3278 74 100       else if (name && isDIGIT(*name))
    100        
3279 2         fd = atoi(name);
3280           else
3281 72         FT_RETURNUNDEF;
3282 772 100       if (PerlLIO_isatty(fd))
3283 32         FT_RETURNYES;
3284 797         FT_RETURNNO;
3285           }
3286            
3287 4068         PP(pp_fttext)
3288           {
3289           dVAR;
3290           I32 i;
3291           I32 len;
3292           I32 odd = 0;
3293           STDCHAR tbuf[512];
3294           STDCHAR *s;
3295           IO *io;
3296           SV *sv = NULL;
3297           GV *gv;
3298           PerlIO *fp;
3299            
3300 4068 100       tryAMAGICftest_MG(PL_op->op_type == OP_FTTEXT ? 'T' : 'B');
    100        
    100        
    100        
3301            
3302 4044 100       if (PL_op->op_flags & OPf_REF)
3303 2284         gv = cGVOP_gv;
3304 1760 100       else if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t))
3305           == OPpFT_STACKED)
3306 4         gv = PL_defgv;
3307           else {
3308 1756         sv = *PL_stack_sp;
3309 1756 100       gv = MAYBE_DEREF_GV_nomg(sv);
    50        
    100        
    100        
    50        
    50        
    50        
    50        
3310           }
3311            
3312 4044 100       if (gv) {
3313 2302 100       if (gv == PL_defgv) {
3314 2250 100       if (PL_statgv)
3315 10         io = SvTYPE(PL_statgv) == SVt_PVIO
3316           ? (IO *)PL_statgv
3317 10 100       : GvIO(PL_statgv);
    50        
    50        
    50        
3318           else {
3319           goto really_filename;
3320           }
3321           }
3322           else {
3323 52         PL_statgv = gv;
3324 52         sv_setpvs(PL_statname, "");
3325 52 50       io = GvIO(PL_statgv);
    50        
    50        
3326           }
3327 62         PL_laststatval = -1;
3328 62         PL_laststype = OP_STAT;
3329 62 50       if (io && IoIFP(io)) {
    100        
3330 38 50       if (! PerlIO_has_base(IoIFP(io)))
3331 0         DIE(aTHX_ "-T and -B not implemented on filehandles");
3332 57         PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
3333 38 50       if (PL_laststatval < 0)
3334 0         FT_RETURNUNDEF;
3335 38 50       if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
3336 0 0       if (PL_op->op_type == OP_FTTEXT)
3337 0         FT_RETURNNO;
3338           else
3339 0         FT_RETURNYES;
3340           }
3341 38 100       if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
3342 20         i = PerlIO_getc(IoIFP(io));
3343 20 100       if (i != EOF)
3344 12         (void)PerlIO_ungetc(IoIFP(io),i);
3345           }
3346 38 100       if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
3347 8         FT_RETURNYES;
3348 30         len = PerlIO_get_bufsiz(IoIFP(io));
3349 30         s = (STDCHAR *) PerlIO_get_base(IoIFP(io));
3350           /* sfio can have large buffers - limit to 512 */
3351 30 50       if (len > 512)
3352           len = 512;
3353           }
3354           else {
3355 24         SETERRNO(EBADF,RMS_IFI);
3356 24         report_evil_fh(gv);
3357 22         SETERRNO(EBADF,RMS_IFI);
3358 22         FT_RETURNUNDEF;
3359           }
3360           }
3361           else {
3362 1742 100       sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
3363           really_filename:
3364 3982         PL_statgv = NULL;
3365 3982 100       if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) {
3366 32 100       if (!gv) {
3367 22         PL_laststatval = -1;
3368 22         PL_laststype = OP_STAT;
3369           }
3370 32 100       if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname),
    50        
    100        
3371           '\n'))
3372 2         Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open");
3373 32         FT_RETURNUNDEF;
3374           }
3375 3950         PL_laststype = OP_STAT;
3376 5925         PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
3377 3950 50       if (PL_laststatval < 0) {
3378 0         (void)PerlIO_close(fp);
3379 0         FT_RETURNUNDEF;
3380           }
3381 3950         PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
3382 3950         len = PerlIO_read(fp, tbuf, sizeof(tbuf));
3383 3950         (void)PerlIO_close(fp);
3384 3950 100       if (len <= 0) {
3385 630 100       if (S_ISDIR(PL_statcache.st_mode) && PL_op->op_type == OP_FTTEXT)
    100        
3386 558         FT_RETURNNO; /* special case NFS directories */
3387 72         FT_RETURNYES; /* null file is anything */
3388           }
3389           s = tbuf;
3390           }
3391            
3392           /* now scan s to look for textiness */
3393           /* XXX ASCII dependent code */
3394            
3395           #if defined(DOSISH) || defined(USEMYBINMODE)
3396           /* ignore trailing ^Z on short files */
3397           if (len && len < (I32)sizeof(tbuf) && tbuf[len-1] == 26)
3398           --len;
3399           #endif
3400            
3401 906530 100       for (i = 0; i < len; i++, s++) {
3402 903228 100       if (!*s) { /* null never allowed in text */
3403 48         odd += len;
3404 48         break;
3405           }
3406           #ifdef EBCDIC
3407           else if (!(isPRINT(*s) || isSPACE(*s)))
3408           odd++;
3409           #else
3410 903180 100       else if (*s & 128) {
3411           #ifdef USE_LOCALE
3412 56 50       if (IN_LOCALE_RUNTIME && isALPHA_LC(*s))
    0        
3413 0         continue;
3414           #endif
3415           /* utf8 characters don't count as odd */
3416 56 50       if (UTF8_IS_START(*s)) {
3417 56         int ulen = UTF8SKIP(s);
3418 56 50       if (ulen < len - i) {
3419           int j;
3420 84 100       for (j = 1; j < ulen; j++) {
3421 56 50       if (!UTF8_IS_CONTINUATION(s[j]))
3422           goto not_utf8;
3423           }
3424 56         --ulen; /* loop does extra increment */
3425 56         s += ulen;
3426 56         i += ulen;
3427 56         continue;
3428           }
3429           }
3430           not_utf8:
3431 0         odd++;
3432           }
3433 903124 100       else if (*s < 32 &&
3434 47419 100       *s != '\n' && *s != '\r' && *s != '\b' &&
    50        
    100        
3435 15889 50       *s != '\t' && *s != '\f' && *s != 27)
    50        
3436 132         odd++;
3437           #endif
3438           }
3439            
3440 3350 100       if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */
3441 862         FT_RETURNNO;
3442           else
3443 3275         FT_RETURNYES;
3444           }
3445            
3446           /* File calls. */
3447            
3448 78112         PP(pp_chdir)
3449           {
3450 78112         dVAR; dSP; dTARGET;
3451           const char *tmps = NULL;
3452           GV *gv = NULL;
3453            
3454 78112 100       if( MAXARG == 1 ) {
3455 78104         SV * const sv = POPs;
3456 78104 100       if (PL_op->op_flags & OPf_SPECIAL) {
3457 16         gv = gv_fetchsv(sv, 0, SVt_PVIO);
3458           }
3459 78088 100       else if (!(gv = MAYBE_DEREF_GV(sv)))
    50        
    0        
    100        
    100        
    50        
    100        
    50        
    100        
    100        
3460 78076 100       tmps = SvPV_nomg_const_nolen(sv);
3461           }
3462            
3463 78112 100       if( !gv && (!tmps || !*tmps) ) {
    100        
    100        
3464 16 50       HV * const table = GvHVn(PL_envgv);
3465           SV **svp;
3466            
3467 16 100       if ( (svp = hv_fetchs(table, "HOME", FALSE))
3468 10 100       || (svp = hv_fetchs(table, "LOGDIR", FALSE))
3469           #ifdef VMS
3470           || (svp = hv_fetchs(table, "SYS$LOGIN", FALSE))
3471           #endif
3472           )
3473           {
3474 12 100       if( MAXARG == 1 )
3475 8         deprecate("chdir('') or chdir(undef) as chdir()");
3476 12 50       tmps = SvPV_nolen_const(*svp);
3477           }
3478           else {
3479 4 50       PUSHi(0);
3480 4 50       TAINT_PROPER("chdir");
3481 4         RETURN;
3482           }
3483           }
3484            
3485 78108 100       TAINT_PROPER("chdir");
3486 78106 100       if (gv) {
3487           #ifdef HAS_FCHDIR
3488 28 50       IO* const io = GvIO(gv);
    50        
    50        
3489 28 50       if (io) {
3490 28 100       if (IoDIRP(io)) {
3491 6 50       PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
3492 22 100       } else if (IoIFP(io)) {
3493 6 50       PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
3494           }
3495           else {
3496 16         report_evil_fh(gv);
3497 16         SETERRNO(EBADF, RMS_IFI);
3498 16 50       PUSHi(0);
3499           }
3500           }
3501           else {
3502 0         report_evil_fh(gv);
3503 0         SETERRNO(EBADF,RMS_IFI);
3504 0 0       PUSHi(0);
3505           }
3506           #else
3507           DIE(aTHX_ PL_no_func, "fchdir");
3508           #endif
3509           }
3510           else
3511 78078 100       PUSHi( PerlDir_chdir(tmps) >= 0 );
3512           #ifdef VMS
3513           /* Clear the DEFAULT element of ENV so we'll get the new value
3514           * in the future. */
3515           hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
3516           #endif
3517 78108         RETURN;
3518           }
3519            
3520 186792         PP(pp_chown)
3521           {
3522 186792         dVAR; dSP; dMARK; dTARGET;
3523 186792         const I32 value = (I32)apply(PL_op->op_type, MARK, SP);
3524            
3525           SP = MARK;
3526 186784 50       XPUSHi(value);
    50        
3527 186784         RETURN;
3528           }
3529            
3530 0         PP(pp_chroot)
3531           {
3532           #ifdef HAS_CHROOT
3533 0         dVAR; dSP; dTARGET;
3534 0 0       char * const tmps = POPpx;
3535 0 0       TAINT_PROPER("chroot");
3536 0 0       PUSHi( chroot(tmps) >= 0 );
3537 0         RETURN;
3538           #else
3539           DIE(aTHX_ PL_no_func, "chroot");
3540           #endif
3541           }
3542            
3543 314151         PP(pp_rename)
3544           {
3545 314151         dVAR; dSP; dTARGET;
3546           int anum;
3547 314151 50       const char * const tmps2 = POPpconstx;
3548 314151 50       const char * const tmps = SvPV_nolen_const(TOPs);
3549 314151 50       TAINT_PROPER("rename");
3550           #ifdef HAS_RENAME
3551 314151         anum = PerlLIO_rename(tmps, tmps2);
3552           #else
3553           if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) {
3554           if (same_dirent(tmps2, tmps)) /* can always rename to same name */
3555           anum = 1;
3556           else {
3557           if (PerlProc_geteuid() || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode))
3558           (void)UNLINK(tmps2);
3559           if (!(anum = link(tmps, tmps2)))
3560           anum = UNLINK(tmps);
3561           }
3562           }
3563           #endif
3564 314151 50       SETi( anum >= 0 );
3565 314151         RETURN;
3566           }
3567            
3568           #if defined(HAS_LINK) || defined(HAS_SYMLINK)
3569 124         PP(pp_link)
3570           {
3571 124         dVAR; dSP; dTARGET;
3572 124         const int op_type = PL_op->op_type;
3573           int result;
3574            
3575           # ifndef HAS_LINK
3576           if (op_type == OP_LINK)
3577           DIE(aTHX_ PL_no_func, "link");
3578           # endif
3579           # ifndef HAS_SYMLINK
3580           if (op_type == OP_SYMLINK)
3581           DIE(aTHX_ PL_no_func, "symlink");
3582           # endif
3583            
3584           {
3585 124 50       const char * const tmps2 = POPpconstx;
3586 124 50       const char * const tmps = SvPV_nolen_const(TOPs);
3587 124 50       TAINT_PROPER(PL_op_desc[op_type]);
3588           result =
3589           # if defined(HAS_LINK)
3590           # if defined(HAS_SYMLINK)
3591           /* Both present - need to choose which. */
3592           (op_type == OP_LINK) ?
3593 124 100       PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2);
3594           # else
3595           /* Only have link, so calls to pp_symlink will have DIE()d above. */
3596           PerlLIO_link(tmps, tmps2);
3597           # endif
3598           # else
3599           # if defined(HAS_SYMLINK)
3600           /* Only have symlink, so calls to pp_link will have DIE()d above. */
3601           symlink(tmps, tmps2);
3602           # endif
3603           # endif
3604           }
3605            
3606 124 50       SETi( result >= 0 );
3607 124         RETURN;
3608           }
3609           #else
3610           PP(pp_link)
3611           {
3612           /* Have neither. */
3613           DIE(aTHX_ PL_no_func, PL_op_desc[PL_op->op_type]);
3614           }
3615           #endif
3616            
3617 94         PP(pp_readlink)
3618           {
3619           dVAR;
3620 94         dSP;
3621           #ifdef HAS_SYMLINK
3622 94         dTARGET;
3623           const char *tmps;
3624           char buf[MAXPATHLEN];
3625           int len;
3626            
3627           #ifndef INCOMPLETE_TAINTS
3628 94         TAINT;
3629           #endif
3630 94 100       tmps = POPpconstx;
3631 94         len = readlink(tmps, buf, sizeof(buf) - 1);
3632 94 100       if (len < 0)
3633 52         RETPUSHUNDEF;
3634 42 50       PUSHp(buf, len);
3635 68         RETURN;
3636           #else
3637           EXTEND(SP, 1);
3638           RETSETUNDEF; /* just pretend it's a normal file */
3639           #endif
3640           }
3641            
3642           #if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
3643           STATIC int
3644           S_dooneliner(pTHX_ const char *cmd, const char *filename)
3645           {
3646           char * const save_filename = filename;
3647           char *cmdline;
3648           char *s;
3649           PerlIO *myfp;
3650           int anum = 1;
3651           Size_t size = strlen(cmd) + (strlen(filename) * 2) + 10;
3652            
3653           PERL_ARGS_ASSERT_DOONELINER;
3654            
3655           Newx(cmdline, size, char);
3656           my_strlcpy(cmdline, cmd, size);
3657           my_strlcat(cmdline, " ", size);
3658           for (s = cmdline + strlen(cmdline); *filename; ) {
3659           *s++ = '\\';
3660           *s++ = *filename++;
3661           }
3662           if (s - cmdline < size)
3663           my_strlcpy(s, " 2>&1", size - (s - cmdline));
3664           myfp = PerlProc_popen(cmdline, "r");
3665           Safefree(cmdline);
3666            
3667           if (myfp) {
3668           SV * const tmpsv = sv_newmortal();
3669           /* Need to save/restore 'PL_rs' ?? */
3670           s = sv_gets(tmpsv, myfp, 0);
3671           (void)PerlProc_pclose(myfp);
3672           if (s != NULL) {
3673           int e;
3674           for (e = 1;
3675           #ifdef HAS_SYS_ERRLIST
3676           e <= sys_nerr
3677           #endif
3678           ; e++)
3679           {
3680           /* you don't see this */
3681           const char * const errmsg = Strerror(e) ;
3682           if (!errmsg)
3683           break;
3684           if (instr(s, errmsg)) {
3685           SETERRNO(e,0);
3686           return 0;
3687           }
3688           }
3689           SETERRNO(0,0);
3690           #ifndef EACCES
3691           #define EACCES EPERM
3692           #endif
3693           if (instr(s, "cannot make"))
3694           SETERRNO(EEXIST,RMS_FEX);
3695           else if (instr(s, "existing file"))
3696           SETERRNO(EEXIST,RMS_FEX);
3697           else if (instr(s, "ile exists"))
3698           SETERRNO(EEXIST,RMS_FEX);
3699           else if (instr(s, "non-exist"))
3700           SETERRNO(ENOENT,RMS_FNF);
3701           else if (instr(s, "does not exist"))
3702           SETERRNO(ENOENT,RMS_FNF);
3703           else if (instr(s, "not empty"))
3704           SETERRNO(EBUSY,SS_DEVOFFLINE);
3705           else if (instr(s, "cannot access"))
3706           SETERRNO(EACCES,RMS_PRV);
3707           else
3708           SETERRNO(EPERM,RMS_PRV);
3709           return 0;
3710           }
3711           else { /* some mkdirs return no failure indication */
3712           anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0);
3713           if (PL_op->op_type == OP_RMDIR)
3714           anum = !anum;
3715           if (anum)
3716           SETERRNO(0,0);
3717           else
3718           SETERRNO(EACCES,RMS_PRV); /* a guess */
3719           }
3720           return anum;
3721           }
3722           else
3723           return 0;
3724           }
3725           #endif
3726            
3727           /* This macro removes trailing slashes from a directory name.
3728           * Different operating and file systems take differently to
3729           * trailing slashes. According to POSIX 1003.1 1996 Edition
3730           * any number of trailing slashes should be allowed.
3731           * Thusly we snip them away so that even non-conforming
3732           * systems are happy.
3733           * We should probably do this "filtering" for all
3734           * the functions that expect (potentially) directory names:
3735           * -d, chdir(), chmod(), chown(), chroot(), fcntl()?,
3736           * (mkdir()), opendir(), rename(), rmdir(), stat(). --jhi */
3737            
3738           #define TRIMSLASHES(tmps,len,copy) (tmps) = SvPV_const(TOPs, (len)); \
3739           if ((len) > 1 && (tmps)[(len)-1] == '/') { \
3740           do { \
3741           (len)--; \
3742           } while ((len) > 1 && (tmps)[(len)-1] == '/'); \
3743           (tmps) = savepvn((tmps), (len)); \
3744           (copy) = TRUE; \
3745           }
3746            
3747 24694         PP(pp_mkdir)
3748           {
3749 24694         dVAR; dSP; dTARGET;
3750           STRLEN len;
3751           const char *tmps;
3752           bool copy = FALSE;
3753 24694 100       const int mode = (MAXARG > 1 && (TOPs||((void)POPs,0))) ? POPi : 0777;
    100        
    50        
3754            
3755 24696 50       TRIMSLASHES(tmps,len,copy);
    100        
    100        
    50        
    100        
3756            
3757 24694 100       TAINT_PROPER("mkdir");
3758           #ifdef HAS_MKDIR
3759 24694 50       SETi( PerlDir_mkdir(tmps, mode) >= 0 );
3760           #else
3761           {
3762           int oldumask;
3763           SETi( dooneliner("mkdir", tmps) );
3764           oldumask = PerlLIO_umask(0);
3765           PerlLIO_umask(oldumask);
3766           PerlLIO_chmod(tmps, (mode & ~oldumask) & 0777);
3767           }
3768           #endif
3769 24694 100       if (copy)
3770 144         Safefree(tmps);
3771 24694         RETURN;
3772           }
3773            
3774 3112         PP(pp_rmdir)
3775           {
3776 3112         dVAR; dSP; dTARGET;
3777           STRLEN len;
3778           const char *tmps;
3779           bool copy = FALSE;
3780            
3781 3114 50       TRIMSLASHES(tmps,len,copy);
    100        
    100        
    50        
    100        
3782 3112 50       TAINT_PROPER("rmdir");
3783           #ifdef HAS_RMDIR
3784 3112 50       SETi( PerlDir_rmdir(tmps) >= 0 );
3785           #else
3786           SETi( dooneliner("rmdir", tmps) );
3787           #endif
3788 3112 100       if (copy)
3789 2         Safefree(tmps);
3790 3112         RETURN;
3791           }
3792            
3793           /* Directory calls. */
3794            
3795 70181         PP(pp_open_dir)
3796           {
3797           #if defined(Direntry_t) && defined(HAS_READDIR)
3798 70181         dVAR; dSP;
3799 70181 50       const char * const dirname = POPpconstx;
3800 70181         GV * const gv = MUTABLE_GV(POPs);
3801 70181 50       IO * const io = GvIOn(gv);
    50        
    50        
    100        
3802            
3803 70181 50       if (!io)
3804           goto nope;
3805            
3806 70181 100       if ((IoIFP(io) || IoOFP(io)))
    50        
3807 16         Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED),
3808           "Opening filehandle %"HEKf" also as a directory",
3809 16 50       HEKfARG(GvENAME_HEK(gv)) );
3810 70181 100       if (IoDIRP(io))
3811 64         PerlDir_close(IoDIRP(io));
3812 70181 100       if (!(IoDIRP(io) = PerlDir_open(dirname)))
3813           goto nope;
3814            
3815 70171         RETPUSHYES;
3816           nope:
3817 10 50       if (!errno)
3818 0         SETERRNO(EBADF,RMS_DIR);
3819 35275         RETPUSHUNDEF;
3820           #else
3821           DIE(aTHX_ PL_no_dir_func, "opendir");
3822           #endif
3823           }
3824            
3825 525497         PP(pp_readdir)
3826           {
3827           #if !defined(Direntry_t) || !defined(HAS_READDIR)
3828           DIE(aTHX_ PL_no_dir_func, "readdir");
3829           #else
3830           #if !defined(I_DIRENT) && !defined(VMS)
3831           Direntry_t *readdir (DIR *);
3832           #endif
3833           dVAR;
3834 525497         dSP;
3835            
3836           SV *sv;
3837 525497 100       const I32 gimme = GIMME;
    100        
3838 525497         GV * const gv = MUTABLE_GV(POPs);
3839           const Direntry_t *dp;
3840 525497 50       IO * const io = GvIOn(gv);
    50        
    50        
    100        
3841            
3842 525497 50       if (!io || !IoDIRP(io)) {
    100        
3843 262935         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3844           "readdir() attempted on invalid dirhandle %"HEKf,
3845 14 50       HEKfARG(GvENAME_HEK(gv)));
3846 14         goto nope;
3847           }
3848            
3849           do {
3850 3022729         dp = (Direntry_t *)PerlDir_read(IoDIRP(io));
3851 3022729 100       if (!dp)
3852           break;
3853           #ifdef DIRNAMLEN
3854           sv = newSVpvn(dp->d_name, dp->d_namlen);
3855           #else
3856 2967780         sv = newSVpv(dp->d_name, 0);
3857           #endif
3858           #ifndef INCOMPLETE_TAINTS
3859 2967780 50       if (!(IoFLAGS(io) & IOf_UNTAINT))
3860 2967780 100       SvTAINTED_on(sv);
3861           #endif
3862 2967780 100       mXPUSHs(sv);
3863 2967780 100       } while (gimme == G_ARRAY);
3864            
3865 525483 100       if (!dp && gimme != G_ARRAY)
3866           goto nope;
3867            
3868 525245         RETURN;
3869            
3870           nope:
3871 252 100       if (!errno)
3872 20         SETERRNO(EBADF,RMS_ISI);
3873 252 100       if (GIMME == G_ARRAY)
    100        
3874 2         RETURN;
3875           else
3876 263053         RETPUSHUNDEF;
3877           #endif
3878           }
3879            
3880 12         PP(pp_telldir)
3881           {
3882           #if defined(HAS_TELLDIR) || defined(telldir)
3883 12         dVAR; dSP; dTARGET;
3884           /* XXX does _anyone_ need this? --AD 2/20/1998 */
3885           /* XXX netbsd still seemed to.
3886           XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style.
3887           --JHI 1999-Feb-02 */
3888           # if !defined(HAS_TELLDIR_PROTO) || defined(NEED_TELLDIR_PROTO)
3889           long telldir (DIR *);
3890           # endif
3891 12         GV * const gv = MUTABLE_GV(POPs);
3892 12 50       IO * const io = GvIOn(gv);
    50        
    50        
    100        
3893            
3894 12 50       if (!io || !IoDIRP(io)) {
    50        
3895 12         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3896           "telldir() attempted on invalid dirhandle %"HEKf,
3897 12 50       HEKfARG(GvENAME_HEK(gv)));
3898 12         goto nope;
3899           }
3900            
3901 0 0       PUSHi( PerlDir_tell(IoDIRP(io)) );
3902 0         RETURN;
3903           nope:
3904 12 100       if (!errno)
3905 2         SETERRNO(EBADF,RMS_ISI);
3906 12         RETPUSHUNDEF;
3907           #else
3908           DIE(aTHX_ PL_no_dir_func, "telldir");
3909           #endif
3910           }
3911            
3912 8         PP(pp_seekdir)
3913           {
3914           #if defined(HAS_SEEKDIR) || defined(seekdir)
3915 8         dVAR; dSP;
3916 8 50       const long along = POPl;
3917 8         GV * const gv = MUTABLE_GV(POPs);
3918 8 50       IO * const io = GvIOn(gv);
    50        
    50        
    50        
3919            
3920 8 50       if (!io || !IoDIRP(io)) {
    50        
3921 8         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3922           "seekdir() attempted on invalid dirhandle %"HEKf,
3923 8 50       HEKfARG(GvENAME_HEK(gv)));
3924 8         goto nope;
3925           }
3926 0         (void)PerlDir_seek(IoDIRP(io), along);
3927            
3928 0         RETPUSHYES;
3929           nope:
3930 8 50       if (!errno)
3931 0         SETERRNO(EBADF,RMS_ISI);
3932 8         RETPUSHUNDEF;
3933           #else
3934           DIE(aTHX_ PL_no_dir_func, "seekdir");
3935           #endif
3936           }
3937            
3938 30         PP(pp_rewinddir)
3939           {
3940           #if defined(HAS_REWINDDIR) || defined(rewinddir)
3941 30         dVAR; dSP;
3942 30         GV * const gv = MUTABLE_GV(POPs);
3943 30 50       IO * const io = GvIOn(gv);
    50        
    50        
    50        
3944            
3945 30 50       if (!io || !IoDIRP(io)) {
    100        
3946 12         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3947           "rewinddir() attempted on invalid dirhandle %"HEKf,
3948 12 50       HEKfARG(GvENAME_HEK(gv)));
3949 12         goto nope;
3950           }
3951 18         (void)PerlDir_rewind(IoDIRP(io));
3952 18         RETPUSHYES;
3953           nope:
3954 12 100       if (!errno)
3955 4         SETERRNO(EBADF,RMS_ISI);
3956 21         RETPUSHUNDEF;
3957           #else
3958           DIE(aTHX_ PL_no_dir_func, "rewinddir");
3959           #endif
3960           }
3961            
3962 66345         PP(pp_closedir)
3963           {
3964           #if defined(Direntry_t) && defined(HAS_READDIR)
3965 66345         dVAR; dSP;
3966 66345         GV * const gv = MUTABLE_GV(POPs);
3967 66345 50       IO * const io = GvIOn(gv);
    50        
    50        
    50        
3968            
3969 66345 50       if (!io || !IoDIRP(io)) {
    100        
3970 760         Perl_ck_warner(aTHX_ packWARN(WARN_IO),
3971           "closedir() attempted on invalid dirhandle %"HEKf,
3972 760 50       HEKfARG(GvENAME_HEK(gv)));
3973 760         goto nope;
3974           }
3975           #ifdef VOID_CLOSEDIR
3976           PerlDir_close(IoDIRP(io));
3977           #else
3978 65585 50       if (PerlDir_close(IoDIRP(io)) < 0) {
3979 0         IoDIRP(io) = 0; /* Don't try to close again--coredumps on SysV */
3980 0         goto nope;
3981           }
3982           #endif
3983 65585         IoDIRP(io) = 0;
3984            
3985 65585         RETPUSHYES;
3986           nope:
3987 760 100       if (!errno)
3988 748         SETERRNO(EBADF,RMS_IFI);
3989 33732         RETPUSHUNDEF;
3990           #else
3991           DIE(aTHX_ PL_no_dir_func, "closedir");
3992           #endif
3993           }
3994            
3995           /* Process control. */
3996            
3997 1376         PP(pp_fork)
3998 1376 50       {
3999           #ifdef HAS_FORK
4000 1376         dVAR; dSP; dTARGET;
4001           Pid_t childpid;
4002           #if defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO)
4003           sigset_t oldmask, newmask;
4004           #endif
4005            
4006 688         EXTEND(SP, 1);
4007 1376         PERL_FLUSHALL_FOR_CHILD;
4008           #if defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO)
4009 1376         sigfillset(&newmask);
4010 1376         sigprocmask(SIG_SETMASK, &newmask, &oldmask);
4011           #endif
4012 1376         childpid = PerlProc_fork();
4013 1376 100       if (childpid == 0) {
4014           int sig;
4015 142         PL_sig_pending = 0;
4016 142 100       if (PL_psig_pend)
4017 3699 100       for (sig = 1; sig < SIG_SIZE; sig++)
4018 3672         PL_psig_pend[sig] = 0;
4019           }
4020           #if defined(HAS_SIGPROCMASK) && !defined(PERL_MICRO)
4021           {
4022 1376         dSAVE_ERRNO;
4023 1376         sigprocmask(SIG_SETMASK, &oldmask, NULL);
4024 1376         RESTORE_ERRNO;
4025           }
4026           #endif
4027 1376 100       if (childpid < 0)
4028 2         RETPUSHUNDEF;
4029           if (!childpid) {
4030           #ifdef PERL_USES_PL_PIDSTATUS
4031           hv_clear(PL_pidstatus); /* no kids, so don't wait for 'em */
4032           #endif
4033           }
4034 1374 50       PUSHi(childpid);
4035 1375         RETURN;
4036           #else
4037           # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4038           dSP; dTARGET;
4039           Pid_t childpid;
4040            
4041           EXTEND(SP, 1);
4042           PERL_FLUSHALL_FOR_CHILD;
4043           childpid = PerlProc_fork();
4044           if (childpid == -1)
4045           RETPUSHUNDEF;
4046           PUSHi(childpid);
4047           RETURN;
4048           # else
4049           DIE(aTHX_ PL_no_func, "fork");
4050           # endif
4051           #endif
4052           }
4053            
4054 186         PP(pp_wait)
4055           {
4056           #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4057 186         dVAR; dSP; dTARGET;
4058           Pid_t childpid;
4059           int argflags;
4060            
4061 186 50       if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4062 0         childpid = wait4pid(-1, &argflags, 0);
4063           else {
4064 192         while ((childpid = wait4pid(-1, &argflags, 0)) == -1 &&
4065 6         errno == EINTR) {
4066 93 0       PERL_ASYNC_CHECK();
4067           }
4068           }
4069           # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4070           /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4071           STATUS_NATIVE_CHILD_SET((childpid && childpid != -1) ? argflags : -1);
4072           # else
4073 186 100       STATUS_NATIVE_CHILD_SET((childpid > 0) ? argflags : -1);
    100        
    100        
    100        
    100        
    50        
4074           # endif
4075 186 50       XPUSHi(childpid);
    50        
4076 186         RETURN;
4077           #else
4078           DIE(aTHX_ PL_no_func, "wait");
4079           #endif
4080           }
4081            
4082 1748         PP(pp_waitpid)
4083           {
4084           #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__)
4085 1748         dVAR; dSP; dTARGET;
4086 1748 50       const int optype = POPi;
4087 1748 50       const Pid_t pid = TOPi;
4088           Pid_t result;
4089           int argflags;
4090            
4091 1748 50       if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
4092 0         result = wait4pid(pid, &argflags, optype);
4093           else {
4094 1776         while ((result = wait4pid(pid, &argflags, optype)) == -1 &&
4095 28         errno == EINTR) {
4096 874 0       PERL_ASYNC_CHECK();
4097           }
4098           }
4099           # if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)
4100           /* 0 and -1 are both error returns (the former applies to WNOHANG case) */
4101           STATUS_NATIVE_CHILD_SET((result && result != -1) ? argflags : -1);
4102           # else
4103 1748 100       STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1);
    100        
    50        
    50        
    50        
    0        
4104           # endif
4105 1748 50       SETi(result);
4106 1748         RETURN;
4107           #else
4108           DIE(aTHX_ PL_no_func, "waitpid");
4109           #endif
4110           }
4111            
4112 3446         PP(pp_system)
4113           {
4114 3446         dVAR; dSP; dMARK; dORIGMARK; dTARGET;
4115           #if defined(__LIBCATAMOUNT__)
4116           PL_statusvalue = -1;
4117           SP = ORIGMARK;
4118           XPUSHi(-1);
4119           #else
4120           I32 value;
4121           int result;
4122            
4123 3446 50       if (TAINTING_get) {
4124 0 0       TAINT_ENV();
4125 0 0       while (++MARK <= SP) {
4126 0 0       (void)SvPV_nolen_const(*MARK); /* stringify for taint check */
4127 0 0       if (TAINT_get)
4128           break;
4129           }
4130 0         MARK = ORIGMARK;
4131 0 0       TAINT_PROPER("system");
4132           }
4133 3446         PERL_FLUSHALL_FOR_CHILD;
4134           #if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO)
4135           {
4136           Pid_t childpid;