X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/49561e08a01a67f5fd863f1978b62a9b241d66b6..cb3055457b8af3615b233f18a8ea27f325bca728:/pp_sys.c diff --git a/pp_sys.c b/pp_sys.c index 49122e6..8a6445e 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -30,7 +30,6 @@ #define PERL_IN_PP_SYS_C #include "perl.h" #include "time64.h" -#include "time64.c" #ifdef I_SHADOW /* Shadow password support for solaris - pdo@cs.umd.edu @@ -77,18 +76,16 @@ extern int h_errno; #ifdef HAS_PASSWD # ifdef I_PWD # include -# else -# if !defined(VMS) +# elif !defined(VMS) struct passwd *getpwnam (char *); struct passwd *getpwuid (Uid_t); -# endif # endif # ifdef HAS_GETPWENT -#ifndef getpwent +# ifndef getpwent struct passwd *getpwent (void); -#elif defined (VMS) && defined (my_getpwent) +# elif defined (VMS) && defined (my_getpwent) struct passwd *Perl_my_getpwent (pTHX); -#endif +# endif # endif #endif @@ -100,9 +97,9 @@ extern int h_errno; struct group *getgrgid (Gid_t); # endif # ifdef HAS_GETGRENT -#ifndef getgrent +# ifndef getgrent struct group *getgrent (void); -#endif +# endif # endif #endif @@ -119,12 +116,10 @@ extern int h_errno; # undef my_chsize # endif # define my_chsize PerlLIO_chsize +#elif defined(HAS_TRUNCATE) +# define my_chsize PerlLIO_chsize #else -# ifdef HAS_TRUNCATE -# define my_chsize PerlLIO_chsize -# else I32 my_chsize(int fd, Off_t length); -# endif #endif #ifdef HAS_FLOCK @@ -142,12 +137,10 @@ I32 my_chsize(int fd, Off_t length); # if defined(HAS_FCNTL) && defined(FCNTL_CAN_LOCK) # define FLOCK fcntl_emulate_flock # define FCNTL_EMULATE_FLOCK -# else /* no flock() or fcntl(F_SETLK,...) */ -# ifdef HAS_LOCKF -# define FLOCK lockf_emulate_flock -# define LOCKF_EMULATE_FLOCK -# endif /* lockf */ -# endif /* no flock() or fcntl(F_SETLK,...) */ +# elif defined(HAS_LOCKF) +# define FLOCK lockf_emulate_flock +# define LOCKF_EMULATE_FLOCK +# endif # ifdef FLOCK static int FLOCK (int, int); @@ -179,10 +172,6 @@ static const char zero_but_true[ZBTLEN + 1] = "0 but true"; # include #endif -#if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC) -# define FD_CLOEXEC 1 /* NeXT needs this */ -#endif - #include "reentr.h" #ifdef __Lynx__ @@ -197,6 +186,10 @@ void setservent(int); void endservent(void); #endif +#ifdef __amigaos4__ +# include "amigaos4/amigaio.h" +#endif + #undef PERL_EFF_ACCESS /* EFFective uid/gid ACCESS */ /* F_OK unused: if stat() cannot find it... */ @@ -220,8 +213,8 @@ void endservent(void); #endif #if !defined(PERL_EFF_ACCESS) && defined(HAS_ACCESSX) && defined(ACC_SELF) - /* AIX */ -# define PERL_EFF_ACCESS(p,f) (accessx((p), (f), ACC_SELF)) + /* AIX's accessx() doesn't declare its argument const, unlike every other platform */ +# define PERL_EFF_ACCESS(p,f) (accessx((char*)(p), (f), ACC_SELF)) #endif @@ -241,13 +234,11 @@ S_emulate_eaccess(pTHX_ const char* path, Mode_t mode) #if !defined(HAS_SETREUID) && !defined(HAS_SETRESUID) Perl_croak(aTHX_ "switching effective uid is not implemented"); #else -#ifdef HAS_SETREUID +# ifdef HAS_SETREUID if (setreuid(euid, ruid)) -#else -#ifdef HAS_SETRESUID +# elif defined(HAS_SETRESUID) if (setresuid(euid, ruid, (Uid_t)-1)) -#endif -#endif +# endif /* diag_listed_as: entering effective %s failed */ Perl_croak(aTHX_ "entering effective uid failed"); #endif @@ -255,13 +246,11 @@ S_emulate_eaccess(pTHX_ const char* path, Mode_t mode) #if !defined(HAS_SETREGID) && !defined(HAS_SETRESGID) Perl_croak(aTHX_ "switching effective gid is not implemented"); #else -#ifdef HAS_SETREGID +# ifdef HAS_SETREGID if (setregid(egid, rgid)) -#else -#ifdef HAS_SETRESGID +# elif defined(HAS_SETRESGID) if (setresgid(egid, rgid, (Gid_t)-1)) -#endif -#endif +# endif /* diag_listed_as: entering effective %s failed */ Perl_croak(aTHX_ "entering effective gid failed"); #endif @@ -270,21 +259,17 @@ S_emulate_eaccess(pTHX_ const char* path, Mode_t mode) #ifdef HAS_SETREUID if (setreuid(ruid, euid)) -#else -#ifdef HAS_SETRESUID +#elif defined(HAS_SETRESUID) if (setresuid(ruid, euid, (Uid_t)-1)) #endif -#endif /* diag_listed_as: leaving effective %s failed */ Perl_croak(aTHX_ "leaving effective uid failed"); #ifdef HAS_SETREGID if (setregid(rgid, egid)) -#else -#ifdef HAS_SETRESGID +#elif defined(HAS_SETRESGID) if (setresgid(rgid, egid, (Gid_t)-1)) #endif -#endif /* diag_listed_as: leaving effective %s failed */ Perl_croak(aTHX_ "leaving effective gid failed"); @@ -295,10 +280,10 @@ S_emulate_eaccess(pTHX_ const char* path, Mode_t mode) PP(pp_backtick) { - dVAR; dSP; dTARGET; + dSP; dTARGET; PerlIO *fp; const char * const tmps = POPpconstx; - const I32 gimme = GIMME_V; + const U8 gimme = GIMME_V; const char *mode = "r"; TAINT_PROPER("``"); @@ -321,7 +306,7 @@ PP(pp_backtick) ENTER_with_name("backtick"); SAVESPTR(PL_rs); PL_rs = &PL_sv_undef; - sv_setpvs(TARG, ""); /* note that this preserves previous buffer */ + SvPVCLEAR(TARG); /* note that this preserves previous buffer */ while (sv_gets(TARG, fp, SvCUR(TARG)) != NULL) NOOP; LEAVE_with_name("backtick"); @@ -356,7 +341,6 @@ PP(pp_backtick) PP(pp_glob) { - dVAR; OP *result; dSP; GV * const gv = (PL_op->op_flags & OPf_SPECIAL) ? NULL : (GV *)POPs; @@ -416,14 +400,13 @@ PP(pp_glob) PP(pp_rcatline) { - dVAR; PL_last_in_gv = cGVOP_gv; return do_readline(); } PP(pp_warn) { - dVAR; dSP; dMARK; + dSP; dMARK; SV *exsv; STRLEN len; if (SP - MARK > 1) { @@ -434,7 +417,7 @@ PP(pp_warn) } else if (SP == MARK) { exsv = &PL_sv_no; - EXTEND(SP, 1); + MEXTEND(SP, 1); SP = MARK + 1; } else { @@ -465,14 +448,14 @@ PP(pp_warn) } } if (SvROK(exsv) && !PL_warnhook) - Perl_warn(aTHX_ "%"SVf, SVfARG(exsv)); + Perl_warn(aTHX_ "%" SVf, SVfARG(exsv)); else warn_sv(exsv); RETSETYES; } PP(pp_die) { - dVAR; dSP; dMARK; + dSP; dMARK; SV *exsv; STRLEN len; #ifdef VMS @@ -515,7 +498,7 @@ PP(pp_die) } } } - else if (SvPOK(errsv) && SvCUR(errsv)) { + else if (SvOK(errsv) && (SvPV_nomg(errsv,len), len)) { exsv = sv_mortalcopy(errsv); sv_catpvs(exsv, "\t...propagated"); } @@ -523,7 +506,9 @@ PP(pp_die) exsv = newSVpvs_flags("Died", SVs_TEMP); } } - return die_sv(exsv); + die_sv(exsv); + NOT_REACHED; /* NOTREACHED */ + return NULL; /* avoid missing return from non-void function warning */ } /* I/O. */ @@ -534,17 +519,31 @@ Perl_tied_method(pTHX_ SV *methname, SV **sp, SV *const sv, { SV **orig_sp = sp; I32 ret_args; + SSize_t extend_size; PERL_ARGS_ASSERT_TIED_METHOD; /* Ensure that our flag bits do not overlap. */ - assert((TIED_METHOD_MORTALIZE_NOT_NEEDED & G_WANT) == 0); - assert((TIED_METHOD_ARGUMENTS_ON_STACK & G_WANT) == 0); - assert((TIED_METHOD_SAY & G_WANT) == 0); + STATIC_ASSERT_STMT((TIED_METHOD_MORTALIZE_NOT_NEEDED & G_WANT) == 0); + STATIC_ASSERT_STMT((TIED_METHOD_ARGUMENTS_ON_STACK & G_WANT) == 0); + STATIC_ASSERT_STMT((TIED_METHOD_SAY & G_WANT) == 0); PUTBACK; /* sp is at *foot* of args, so this pops args from old stack */ PUSHSTACKi(PERLSI_MAGIC); - EXTEND(SP, argc+1); /* object + args */ + /* extend for object + args. If argc might wrap/truncate when cast + * to SSize_t and incremented, set to -1, which will trigger a panic in + * EXTEND(). + * The weird way this is written is because g++ is dumb enough to + * warn "comparison is always false" on something like: + * + * sizeof(a) >= sizeof(b) && a >= B_t_MAX -1 + * + * (where the LH condition is false) + */ + extend_size = + (argc > (sizeof(argc) >= sizeof(SSize_t) ? SSize_t_MAX - 1 : argc)) + ? -1 : (SSize_t)argc + 1; + EXTEND(SP, extend_size); PUSHMARK(sp); PUSHs(SvTIED_obj(sv, mg)); if (flags & TIED_METHOD_ARGUMENTS_ON_STACK) { @@ -597,7 +596,7 @@ Perl_tied_method(pTHX_ SV *methname, SV **sp, SV *const sv, PP(pp_open) { - dVAR; dSP; + dSP; dMARK; dORIGMARK; dTARGET; SV *sv; @@ -616,8 +615,7 @@ PP(pp_open) IoFLAGS(GvIOp(gv)) &= ~IOf_UNTAINT; if (IoDIRP(io)) - Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED), - "Opening dirhandle %"HEKf" also as a file", + Perl_croak(aTHX_ "Cannot open %" HEKf " as a filehandle: it is already open as a dirhandle", HEKfARG(GvENAME_HEK(gv))); mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); @@ -638,12 +636,12 @@ PP(pp_open) } tmps = SvPV_const(sv, len); - ok = do_openn(gv, tmps, len, FALSE, O_RDONLY, 0, NULL, MARK+1, (SP-MARK)); + ok = do_open6(gv, tmps, len, NULL, MARK+1, (SP-MARK)); SP = ORIGMARK; if (ok) PUSHi( (I32)PL_forkprocess ); else if (PL_forkprocess == 0) /* we are a new child */ - PUSHi(0); + PUSHs(&PL_sv_zero); else RETPUSHUNDEF; RETURN; @@ -651,7 +649,9 @@ PP(pp_open) PP(pp_close) { - dVAR; dSP; + dSP; + /* pp_coreargs pushes a NULL to indicate no args passed to + * CORE::close() */ GV * const gv = MAXARG == 0 || (!TOPs && !POPs) ? PL_defoutgv : MUTABLE_GV(POPs); @@ -674,7 +674,6 @@ PP(pp_close) PP(pp_pipe_op) { #ifdef HAS_PIPE - dVAR; dSP; IO *rstio; IO *wstio; @@ -683,24 +682,19 @@ PP(pp_pipe_op) GV * const wgv = MUTABLE_GV(POPs); GV * const rgv = MUTABLE_GV(POPs); - if (!rgv || !wgv) - goto badexit; - - if (!isGV_with_GP(rgv) || !isGV_with_GP(wgv)) - DIE(aTHX_ PL_no_usym, "filehandle"); rstio = GvIOn(rgv); - wstio = GvIOn(wgv); - if (IoIFP(rstio)) do_close(rgv, FALSE); + + wstio = GvIOn(wgv); if (IoIFP(wstio)) do_close(wgv, FALSE); - if (PerlProc_pipe(fd) < 0) + if (PerlProc_pipe_cloexec(fd) < 0) goto badexit; - IoIFP(rstio) = PerlIO_fdopen(fd[0], "r"PIPE_OPEN_MODE); - IoOFP(wstio) = PerlIO_fdopen(fd[1], "w"PIPE_OPEN_MODE); + IoIFP(rstio) = PerlIO_fdopen(fd[0], "r" PIPE_OPEN_MODE); + IoOFP(wstio) = PerlIO_fdopen(fd[1], "w" PIPE_OPEN_MODE); IoOFP(rstio) = IoIFP(rstio); IoIFP(wstio) = IoOFP(wstio); IoTYPE(rstio) = IoTYPE_RDONLY; @@ -717,13 +711,9 @@ PP(pp_pipe_op) PerlLIO_close(fd[1]); goto badexit; } -#if defined(HAS_FCNTL) && defined(F_SETFD) - fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */ - fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */ -#endif RETPUSHYES; -badexit: + badexit: RETPUSHUNDEF; #else DIE(aTHX_ PL_no_func, "pipe"); @@ -732,7 +722,7 @@ badexit: PP(pp_fileno) { - dVAR; dSP; dTARGET; + dSP; dTARGET; GV *gv; IO *io; PerlIO *fp; @@ -749,6 +739,22 @@ PP(pp_fileno) return tied_method0(SV_CONST(FILENO), SP, MUTABLE_SV(io), mg); } + if (io && IoDIRP(io)) { +#if defined(HAS_DIRFD) || defined(HAS_DIR_DD_FD) + PUSHi(my_dirfd(IoDIRP(io))); + RETURN; +#elif defined(ENOTSUP) + errno = ENOTSUP; /* Operation not supported */ + RETPUSHUNDEF; +#elif defined(EOPNOTSUPP) + errno = EOPNOTSUPP; /* Operation not supported on socket */ + RETPUSHUNDEF; +#else + errno = EINVAL; /* Invalid argument */ + RETPUSHUNDEF; +#endif + } + if (!io || !(fp = IoIFP(io))) { /* Can't do this because people seem to do things like defined(fileno($foo)) to check whether $foo is a valid fh. @@ -764,7 +770,6 @@ PP(pp_fileno) PP(pp_umask) { - dVAR; dSP; #ifdef HAS_UMASK dTARGET; @@ -795,7 +800,7 @@ PP(pp_umask) PP(pp_binmode) { - dVAR; dSP; + dSP; GV *gv; IO *io; PerlIO *fp; @@ -856,7 +861,7 @@ PP(pp_binmode) PP(pp_tie) { - dVAR; dSP; dMARK; + dSP; dMARK; HV* stash; GV *gv = NULL; SV *sv; @@ -904,7 +909,7 @@ PP(pp_tie) vivify_defelem(varsv); varsv = LvTARG(varsv); } - /* FALL THROUGH */ + /* FALLTHROUGH */ default: methname = "TIESCALAR"; how = PERL_MAGIC_tiedscalar; @@ -928,10 +933,36 @@ PP(pp_tie) * (Sorry obfuscation writers. You're not going to be given this one.) */ stash = gv_stashsv(*MARK, 0); - if (!stash || !(gv = gv_fetchmethod(stash, methname))) { - DIE(aTHX_ "Can't locate object method \"%s\" via package \"%"SVf"\"", - methname, SVfARG(SvOK(*MARK) ? *MARK : &PL_sv_no)); - } + if (!stash) { + if (SvROK(*MARK)) + DIE(aTHX_ "Can't locate object method \"%s\" via package \"%" SVf "\"", + methname, SVfARG(*MARK)); + else if (isGV(*MARK)) { + /* If the glob doesn't name an existing package, using + * SVfARG(*MARK) would yield "*Foo::Bar" or *main::Foo. So + * generate the name for the error message explicitly. */ + SV *stashname = sv_2mortal(newSV(0)); + gv_fullname4(stashname, (GV *) *MARK, NULL, FALSE); + DIE(aTHX_ "Can't locate object method \"%s\" via package \"%" SVf "\"", + methname, SVfARG(stashname)); + } + else { + SV *stashname = !SvPOK(*MARK) ? &PL_sv_no + : SvCUR(*MARK) ? *MARK + : sv_2mortal(newSVpvs("main")); + DIE(aTHX_ "Can't locate object method \"%s\" via package \"%" SVf "\"" + " (perhaps you forgot to load \"%" SVf "\"?)", + methname, SVfARG(stashname), SVfARG(stashname)); + } + } + else if (!(gv = gv_fetchmethod(stash, methname))) { + /* The effective name can only be NULL for stashes that have + * been deleted from the symbol table, which this one can't + * be, since we just looked it up by name. + */ + DIE(aTHX_ "Can't locate object method \"%s\" via package \"%" HEKf "\"", + methname, HvENAME_HEK_NN(stash)); + } ENTER_with_name("call_TIE"); PUSHSTACKi(PERLSI_MAGIC); PUSHMARK(SP); @@ -961,9 +992,12 @@ PP(pp_tie) RETURN; } + +/* also used for: pp_dbmclose() */ + PP(pp_untie) { - dVAR; dSP; + dSP; MAGIC *mg; SV *sv = POPs; const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) @@ -977,7 +1011,7 @@ PP(pp_untie) if ((mg = SvTIED_mg(sv, how))) { SV * const obj = SvRV(SvTIED_obj(sv, mg)); - if (obj) { + if (obj && SvSTASH(obj)) { GV * const gv = gv_fetchmethod_autoload(SvSTASH(obj), "UNTIE", FALSE); CV *cv; if (gv && isGV(gv) && (cv = GvCV(gv))) { @@ -992,7 +1026,7 @@ PP(pp_untie) } else if (mg && SvREFCNT(obj) > 1) { Perl_ck_warner(aTHX_ packWARN(WARN_UNTIE), - "untie attempted while %"UVuf" inner references still exist", + "untie attempted while %" UVuf " inner references still exist", (UV)SvREFCNT(obj) - 1 ) ; } } @@ -1003,29 +1037,30 @@ PP(pp_untie) PP(pp_tied) { - dVAR; dSP; const MAGIC *mg; - SV *sv = POPs; + dTOPss; const char how = (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) ? PERL_MAGIC_tied : PERL_MAGIC_tiedscalar; if (isGV_with_GP(sv) && !SvFAKE(sv) && !(sv = MUTABLE_SV(GvIOp(sv)))) - RETPUSHUNDEF; + goto ret_undef; if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y' && - !(sv = defelem_target(sv, NULL))) RETPUSHUNDEF; + !(sv = defelem_target(sv, NULL))) goto ret_undef; if ((mg = SvTIED_mg(sv, how))) { - PUSHs(SvTIED_obj(sv, mg)); - RETURN; + SETs(SvTIED_obj(sv, mg)); + return NORMAL; /* PUTBACK not needed, pp_tied never moves SP */ } - RETPUSHUNDEF; + ret_undef: + SETs(&PL_sv_undef); + return NORMAL; } PP(pp_dbmopen) { - dVAR; dSP; + dSP; dPOPPOPssrl; HV* stash; GV *gv = NULL; @@ -1069,9 +1104,11 @@ PP(pp_dbmopen) PUTBACK; call_sv(MUTABLE_SV(GvCV(gv)), G_SCALAR); SPAGAIN; + if (sv_isobject(TOPs)) + goto retie; } - - if (sv_isobject(TOPs)) { + else { + retie: sv_unmagic(MUTABLE_SV(hv), PERL_MAGIC_tied); sv_magic(MUTABLE_SV(hv), TOPs, PERL_MAGIC_tied, NULL, 0); } @@ -1082,7 +1119,7 @@ PP(pp_dbmopen) PP(pp_sselect) { #ifdef HAS_SELECT - dVAR; dSP; dTARGET; + dSP; dTARGET; I32 i; I32 j; char *s; @@ -1094,6 +1131,7 @@ PP(pp_sselect) struct timeval *tbuf = &timebuf; I32 growsize; char *fd_sets[4]; + SV *svs[4]; #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678 I32 masksize; I32 offset; @@ -1109,7 +1147,7 @@ PP(pp_sselect) SP -= 4; for (i = 1; i <= 3; i++) { - SV * const sv = SP[i]; + SV * const sv = svs[i] = SP[i]; SvGETMAGIC(sv); if (!SvOK(sv)) continue; @@ -1122,9 +1160,14 @@ PP(pp_sselect) if (!SvPOKp(sv)) Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Non-string passed as bitmask"); - SvPV_force_nomg_nolen(sv); /* force string conversion */ + if (SvGAMAGIC(sv)) { + svs[i] = sv_newmortal(); + sv_copypv_nomg(svs[i], sv); + } + else + SvPV_force_nomg_nolen(sv); /* force string conversion */ } - j = SvCUR(sv); + j = SvCUR(svs[i]); if (maxlen < j) maxlen = j; } @@ -1154,7 +1197,7 @@ PP(pp_sselect) /* If SELECT_MIN_BITS is greater than one we most probably will want * to align the sizes with SELECT_MIN_BITS/8 because for example * in many little-endian (Intel, Alpha) systems (Linux, OS/2, Digital - * UNIX, Solaris, NeXT, Darwin) the smallest quantum select() operates + * UNIX, Solaris, Darwin) the smallest quantum select() operates * on (sets/tests/clears bits) is 32 bits. */ growsize = maxlen + (SELECT_MIN_BITS/8 - (maxlen % (SELECT_MIN_BITS/8))); # endif @@ -1173,7 +1216,7 @@ PP(pp_sselect) tbuf = NULL; for (i = 1; i <= 3; i++) { - sv = SP[i]; + sv = svs[i]; if (!SvOK(sv) || SvCUR(sv) == 0) { fd_sets[i] = 0; continue; @@ -1220,7 +1263,7 @@ PP(pp_sselect) #endif for (i = 1; i <= 3; i++) { if (fd_sets[i]) { - sv = SP[i]; + sv = svs[i]; #if BYTEORDER != 0x1234 && BYTEORDER != 0x12345678 s = SvPVX(sv); for (offset = 0; offset < growsize; offset += masksize) { @@ -1229,12 +1272,15 @@ PP(pp_sselect) } Safefree(fd_sets[i]); #endif - SvSETMAGIC(sv); + if (sv != SP[i]) + SvSetMagicSV(SP[i], sv); + else + SvSETMAGIC(sv); } } PUSHi(nfound); - if (GIMME == G_ARRAY && tbuf) { + if (GIMME_V == G_ARRAY && tbuf) { value = (NV)(timebuf.tv_sec) + (NV)(timebuf.tv_usec) / 1000000.0; mPUSHn(value); @@ -1246,12 +1292,15 @@ PP(pp_sselect) } /* + +=for apidoc_section $GV + =for apidoc setdefout -Sets PL_defoutgv, the default file handle for output, to the passed in -typeglob. As PL_defoutgv "owns" a reference on its typeglob, the reference +Sets C, the default file handle for output, to the passed in +typeglob. As C "owns" a reference on its typeglob, the reference count of the passed in typeglob is increased by one, and the reference count -of the typeglob that PL_defoutgv points to is decreased by one. +of the typeglob that C points to is decreased by one. =cut */ @@ -1259,16 +1308,18 @@ of the typeglob that PL_defoutgv points to is decreased by one. void Perl_setdefout(pTHX_ GV *gv) { - dVAR; + GV *oldgv = PL_defoutgv; + PERL_ARGS_ASSERT_SETDEFOUT; + SvREFCNT_inc_simple_void_NN(gv); - SvREFCNT_dec(PL_defoutgv); PL_defoutgv = gv; + SvREFCNT_dec(oldgv); } PP(pp_select) { - dVAR; dSP; dTARGET; + dSP; dTARGET; HV *hv; GV * const newdefout = (PL_op->op_private > 0) ? (MUTABLE_GV(POPs)) : NULL; GV * egv = GvEGVx(PL_defoutgv); @@ -1299,7 +1350,9 @@ PP(pp_select) PP(pp_getc) { - dVAR; dSP; dTARGET; + dSP; dTARGET; + /* pp_coreargs pushes a NULL to indicate no args passed to + * CORE::getc() */ GV * const gv = MAXARG==0 || (!TOPs && !POPs) ? PL_stdingv : MUTABLE_GV(POPs); IO *const io = GvIO(gv); @@ -1310,7 +1363,7 @@ PP(pp_getc) if (io) { const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); if (mg) { - const U32 gimme = GIMME_V; + const U8 gimme = GIMME_V; Perl_tied_method(aTHX_ SV_CONST(GETC), SP, MUTABLE_SV(io), mg, gimme, 0); if (gimme == G_SCALAR) { SPAGAIN; @@ -1338,6 +1391,7 @@ PP(pp_getc) } SvUTF8_on(TARG); } + else SvUTF8_off(TARG); PUSHTARG; RETURN; } @@ -1345,25 +1399,18 @@ PP(pp_getc) STATIC OP * S_doform(pTHX_ CV *cv, GV *gv, OP *retop) { - dVAR; PERL_CONTEXT *cx; - const I32 gimme = GIMME_V; + const U8 gimme = GIMME_V; PERL_ARGS_ASSERT_DOFORM; - if (cv && CvCLONE(cv)) + if (CvCLONE(cv)) cv = MUTABLE_CV(sv_2mortal(MUTABLE_SV(cv_clone(cv)))); - ENTER; - SAVETMPS; - - PUSHBLOCK(cx, CXt_FORMAT, PL_stack_sp); - PUSHFORMAT(cx, retop); - if (CvDEPTH(cv) >= 2) { - PERL_STACK_OVERFLOW_CHECK(); + cx = cx_pushblock(CXt_FORMAT, gimme, PL_stack_sp, PL_savestack_ix); + cx_pushformat(cx, cv, retop, gv); + if (CvDEPTH(cv) >= 2) pad_push(CvPADLIST(cv), CvDEPTH(cv)); - } - SAVECOMPPAD(); PAD_SET_CUR_NOSAVE(CvPADLIST(cv), CvDEPTH(cv)); setdefout(gv); /* locally select filehandle so $% et al work */ @@ -1372,17 +1419,15 @@ S_doform(pTHX_ CV *cv, GV *gv, OP *retop) PP(pp_enterwrite) { - dVAR; dSP; GV *gv; IO *io; GV *fgv; CV *cv = NULL; - SV *tmpsv = NULL; if (MAXARG == 0) { - gv = PL_defoutgv; EXTEND(SP, 1); + gv = PL_defoutgv; } else { gv = MUTABLE_GV(POPs); @@ -1402,9 +1447,9 @@ PP(pp_enterwrite) cv = GvFORM(fgv); if (!cv) { - tmpsv = sv_newmortal(); + SV * const tmpsv = sv_newmortal(); gv_efullname4(tmpsv, fgv, NULL, FALSE); - DIE(aTHX_ "Undefined format \"%"SVf"\" called", SVfARG(tmpsv)); + DIE(aTHX_ "Undefined format \"%" SVf "\" called", SVfARG(tmpsv)); } IoFLAGS(io) &= ~IOf_DIDTOP; RETURNOP(doform(cv,gv,PL_op->op_next)); @@ -1412,17 +1457,16 @@ PP(pp_enterwrite) PP(pp_leavewrite) { - dVAR; dSP; - GV * const gv = cxstack[cxstack_ix].blk_format.gv; + dSP; + GV * const gv = CX_CUR()->blk_format.gv; IO * const io = GvIOp(gv); PerlIO *ofp; PerlIO *fp; - SV **newsp; - I32 gimme; PERL_CONTEXT *cx; OP *retop; + bool is_return = cBOOL(PL_op->op_type == OP_RETURN); - if (!io || !(ofp = IoOFP(io))) + if (is_return || !io || !(ofp = IoOFP(io))) goto forget_top; DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n", @@ -1440,7 +1484,7 @@ PP(pp_leavewrite) SV *topname; if (!IoFMT_NAME(io)) IoFMT_NAME(io) = savepv(GvNAME(gv)); - topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%"HEKf"_TOP", + topname = sv_2mortal(Perl_newSVpvf(aTHX_ "%" HEKf "_TOP", HEKfARG(GvNAME_HEK(gv)))); topgv = gv_fetchsv(topname, 0, SVt_PVFM); if ((topgv && GvFORM(topgv)) || @@ -1459,10 +1503,11 @@ PP(pp_leavewrite) if (IoFLAGS(io) & IOf_DIDTOP) { /* Oh dear. It still doesn't fit. */ I32 lines = IoLINES_LEFT(io); const char *s = SvPVX_const(PL_formtarget); + const char *e = SvEND(PL_formtarget); if (lines <= 0) /* Yow, header didn't even fit!!! */ goto forget_top; while (lines-- > 0) { - s = strchr(s, '\n'); + s = (char *) memchr(s, '\n', e - s); if (!s) break; s++; @@ -1488,19 +1533,30 @@ PP(pp_leavewrite) if (!cv) { SV * const sv = sv_newmortal(); gv_efullname4(sv, fgv, NULL, FALSE); - DIE(aTHX_ "Undefined top format \"%"SVf"\" called", SVfARG(sv)); + DIE(aTHX_ "Undefined top format \"%" SVf "\" called", SVfARG(sv)); } return doform(cv, gv, PL_op); } forget_top: - POPBLOCK(cx,PL_curpm); + cx = CX_CUR(); + assert(CxTYPE(cx) == CXt_FORMAT); + SP = PL_stack_base + cx->blk_oldsp; /* ignore retval of formline */ + CX_LEAVE_SCOPE(cx); + cx_popformat(cx); + cx_popblock(cx); retop = cx->blk_sub.retop; - POPFORMAT(cx); - SP = newsp; /* ignore retval of formline */ - LEAVE; + CX_POP(cx); + + EXTEND(SP, 1); - if (!io || !(fp = IoOFP(io))) { + if (is_return) + /* XXX the semantics of doing 'return' in a format aren't documented. + * Currently we ignore any args to 'return' and just return + * a single undef in both scalar and list contexts + */ + PUSHs(&PL_sv_undef); + else if (!io || !(fp = IoOFP(io))) { if (io && IoIFP(io)) report_wrongway_fh(gv, '<'); else @@ -1523,13 +1579,12 @@ PP(pp_leavewrite) } } PL_formtarget = PL_bodytarget; - PERL_UNUSED_VAR(gimme); RETURNOP(retop); } PP(pp_prtf) { - dVAR; dSP; dMARK; dORIGMARK; + dSP; dMARK; dORIGMARK; PerlIO *fp; GV * const gv @@ -1590,7 +1645,6 @@ PP(pp_prtf) PP(pp_sysopen) { - dVAR; dSP; const int perm = (MAXARG > 3 && (TOPs || POPs)) ? POPi : 0666; const int mode = POPi; @@ -1600,8 +1654,7 @@ PP(pp_sysopen) /* Need TIEHANDLE method ? */ const char * const tmps = SvPV_const(sv, len); - /* FIXME? do_open should do const */ - if (do_open(gv, tmps, len, TRUE, mode, perm, NULL)) { + if (do_open_raw(gv, tmps, len, mode, perm, NULL)) { IoLINES(GvIOp(gv)) = 0; PUSHs(&PL_sv_yes); } @@ -1611,9 +1664,12 @@ PP(pp_sysopen) RETURN; } + +/* also used for: pp_read() and pp_recv() (where supported) */ + PP(pp_sysread) { - dVAR; dSP; dMARK; dORIGMARK; dTARGET; + dSP; dMARK; dORIGMARK; dTARGET; SSize_t offset; IO *io; char *buffer; @@ -1630,8 +1686,9 @@ PP(pp_sysread) bool charstart = FALSE; STRLEN charskip = 0; STRLEN skip = 0; - GV * const gv = MUTABLE_GV(*++MARK); + int fd; + if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD) && gv && (io = GvIO(gv)) ) { @@ -1647,7 +1704,7 @@ PP(pp_sysread) goto say_undef; bufsv = *++MARK; if (! SvOK(bufsv)) - sv_setpvs(bufsv, ""); + SvPVCLEAR(bufsv); length = SvIVx(*++MARK); if (length < 0) DIE(aTHX_ "Negative length"); @@ -1662,7 +1719,16 @@ PP(pp_sysread) SETERRNO(EBADF,RMS_IFI); goto say_undef; } + + /* Note that fd can here validly be -1, don't check it yet. */ + fd = PerlIO_fileno(IoIFP(io)); + if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) { + if (PL_op->op_type == OP_SYSREAD || PL_op->op_type == OP_RECV) { + Perl_croak(aTHX_ + "%s() isn't allowed on :utf8 handles", + OP_DESC(PL_op)); + } buffer = SvPVutf8_force(bufsv, blen); /* UTF-8 may not have been set if they are all low bytes */ SvUTF8_on(bufsv); @@ -1670,7 +1736,7 @@ PP(pp_sysread) } else { buffer = SvPV_force(bufsv, blen); - buffer_utf8 = !IN_BYTES && SvUTF8(bufsv); + buffer_utf8 = DO_UTF8(bufsv); } if (DO_UTF8(bufsv)) { blen = sv_len_utf8_nomg(bufsv); @@ -1685,6 +1751,10 @@ PP(pp_sysread) if (PL_op->op_type == OP_RECV) { Sock_size_t bufsize; char namebuf[MAXPATHLEN]; + if (fd < 0) { + SETERRNO(EBADF,SS_IVCHAN); + goto say_undef; + } #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__) bufsize = sizeof (struct sockaddr_in); #else @@ -1696,10 +1766,10 @@ PP(pp_sysread) #endif buffer = SvGROW(bufsv, (STRLEN)(length+1)); /* 'offset' means 'flags' here */ - count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset, + count = PerlSock_recvfrom(fd, buffer, length, offset, (struct sockaddr *)namebuf, &bufsize); if (count < 0) - RETPUSHUNDEF; + goto say_undef; /* MSG_TRUNC can give oversized count; quietly lose it */ if (count > length) count = length; @@ -1713,6 +1783,14 @@ PP(pp_sysread) if (!(IoFLAGS(io) & IOf_UNTAINT)) SvTAINTED_on(bufsv); SP = ORIGMARK; +#if defined(__CYGWIN__) + /* recvfrom() on cygwin doesn't set bufsize at all for + connected sockets, leaving us with trash in the returned + name, so use the same test as the Win32 code to check if it + wasn't set, and set it [perl #118843] */ + if (bufsize == sizeof namebuf) + bufsize = 0; +#endif sv_setpvn(TARG, namebuf, bufsize); PUSHs(TARG); RETURN; @@ -1730,13 +1808,17 @@ PP(pp_sysread) else offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer; } + more_bytes: + /* Reestablish the fd in case it shifted from underneath us. */ + fd = PerlIO_fileno(IoIFP(io)); + orig_size = SvCUR(bufsv); /* Allocating length + offset + 1 isn't perfect in the case of reading bytes from a byte file handle into a UTF8 buffer, but it won't harm us unduly. (should be 2 * length + offset + 1, or possibly something longer if - PL_encoding is true) */ + IN_ENCODING Is true) */ buffer = SvGROW(bufsv, (STRLEN)(length+offset+1)); if (offset > 0 && offset > (SSize_t)orig_size) { /* Zero any newly allocated space */ Zero(buffer+orig_size, offset-orig_size, char); @@ -1760,14 +1842,22 @@ PP(pp_sysread) if (PL_op->op_type == OP_SYSREAD) { #ifdef PERL_SOCK_SYSREAD_IS_RECV if (IoTYPE(io) == IoTYPE_SOCKET) { - count = PerlSock_recv(PerlIO_fileno(IoIFP(io)), - buffer, length, 0); + if (fd < 0) { + SETERRNO(EBADF,SS_IVCHAN); + count = -1; + } + else + count = PerlSock_recv(fd, buffer, length, 0); } else #endif { - count = PerlLIO_read(PerlIO_fileno(IoIFP(io)), - buffer, length); + if (fd < 0) { + SETERRNO(EBADF,RMS_IFI); + count = -1; + } + else + count = PerlLIO_read(fd, buffer, length); } } else @@ -1838,19 +1928,22 @@ PP(pp_sysread) RETPUSHUNDEF; } + +/* also used for: pp_send() where defined */ + PP(pp_syswrite) { - dVAR; dSP; dMARK; dORIGMARK; dTARGET; + dSP; dMARK; dORIGMARK; dTARGET; SV *bufsv; const char *buffer; SSize_t retval; STRLEN blen; - STRLEN orig_blen_bytes; const int op_type = PL_op->op_type; bool doing_utf8; U8 *tmpbuf = NULL; GV *const gv = MUTABLE_GV(*++MARK); IO *const io = GvIO(gv); + int fd; if (op_type == OP_SYSWRITE && io) { const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); @@ -1881,19 +1974,21 @@ PP(pp_syswrite) SETERRNO(EBADF,RMS_IFI); goto say_undef; } + fd = PerlIO_fileno(IoIFP(io)); + if (fd < 0) { + SETERRNO(EBADF,SS_IVCHAN); + retval = -1; + goto say_undef; + } /* Do this first to trigger any overloading. */ buffer = SvPV_const(bufsv, blen); - orig_blen_bytes = blen; doing_utf8 = DO_UTF8(bufsv); if (PerlIO_isutf8(IoIFP(io))) { - if (!SvUTF8(bufsv)) { - /* We don't modify the original scalar. */ - tmpbuf = bytes_to_utf8((const U8*) buffer, &blen); - buffer = (char *) tmpbuf; - doing_utf8 = TRUE; - } + Perl_croak(aTHX_ + "%s() isn't allowed on :utf8 handles", + OP_DESC(PL_op)); } else if (doing_utf8) { STRLEN tmplen = blen; @@ -1915,37 +2010,21 @@ PP(pp_syswrite) if (SP > MARK) { STRLEN mlen; char * const sockbuf = SvPVx(*++MARK, mlen); - retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen, + retval = PerlSock_sendto(fd, buffer, blen, flags, (struct sockaddr *)sockbuf, mlen); } else { - retval - = PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags); + retval = PerlSock_send(fd, buffer, blen, flags); } } else #endif { Size_t length = 0; /* This length is in characters. */ - STRLEN blen_chars; IV offset; - if (doing_utf8) { - if (tmpbuf) { - /* The SV is bytes, and we've had to upgrade it. */ - blen_chars = orig_blen_bytes; - } else { - /* The SV really is UTF-8. */ - /* Don't call sv_len_utf8 on a magical or overloaded - scalar, as we might get back a different result. */ - blen_chars = sv_or_pv_len_utf8(bufsv, buffer, blen); - } - } else { - blen_chars = blen; - } - if (MARK >= SP) { - length = blen_chars; + length = blen; } else { #if Size_t_size > IVSIZE length = (Size_t)SvNVx(*++MARK); @@ -1961,65 +2040,36 @@ PP(pp_syswrite) if (MARK < SP) { offset = SvIVx(*++MARK); if (offset < 0) { - if (-offset > (IV)blen_chars) { + if (-offset > (IV)blen) { Safefree(tmpbuf); DIE(aTHX_ "Offset outside string"); } - offset += blen_chars; - } else if (offset > (IV)blen_chars) { + offset += blen; + } else if (offset > (IV)blen) { Safefree(tmpbuf); DIE(aTHX_ "Offset outside string"); } } else offset = 0; - if (length > blen_chars - offset) - length = blen_chars - offset; - if (doing_utf8) { - /* Here we convert length from characters to bytes. */ - if (tmpbuf || SvGMAGICAL(bufsv) || SvAMAGIC(bufsv)) { - /* Either we had to convert the SV, or the SV is magical, or - the SV has overloading, in which case we can't or mustn't - or mustn't call it again. */ - - buffer = (const char*)utf8_hop((const U8 *)buffer, offset); - length = utf8_hop((U8 *)buffer, length) - (U8 *)buffer; - } else { - /* It's a real UTF-8 SV, and it's not going to change under - us. Take advantage of any cache. */ - I32 start = offset; - I32 len_I32 = length; - - /* Convert the start and end character positions to bytes. - Remember that the second argument to sv_pos_u2b is relative - to the first. */ - sv_pos_u2b(bufsv, &start, &len_I32); - - buffer += start; - length = len_I32; - } - } - else { - buffer = buffer+offset; - } + if (length > blen - offset) + length = blen - offset; + buffer = buffer+offset; + #ifdef PERL_SOCK_SYSWRITE_IS_SEND if (IoTYPE(io) == IoTYPE_SOCKET) { - retval = PerlSock_send(PerlIO_fileno(IoIFP(io)), - buffer, length, 0); + retval = PerlSock_send(fd, buffer, length, 0); } else #endif { /* See the note at doio.c:do_print about filesize limits. --jhi */ - retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)), - buffer, length); + retval = PerlLIO_write(fd, buffer, length); } } if (retval < 0) goto say_undef; SP = ORIGMARK; - if (doing_utf8) - retval = utf8_length((U8*)buffer, (U8*)buffer + retval); Safefree(tmpbuf); #if Size_t_size > IVSIZE @@ -2037,7 +2087,7 @@ PP(pp_syswrite) PP(pp_eof) { - dVAR; dSP; + dSP; GV *gv; IO *io; const MAGIC *mg; @@ -2071,7 +2121,7 @@ PP(pp_eof) } if (!gv) - RETPUSHNO; + RETPUSHYES; if ((io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) { return tied_method1(SV_CONST(EOF), SP, MUTABLE_SV(io), mg, newSVuv(which)); @@ -2079,17 +2129,21 @@ PP(pp_eof) if (!MAXARG && (PL_op->op_flags & OPf_SPECIAL)) { /* eof() */ if (io && !IoIFP(io)) { - if ((IoFLAGS(io) & IOf_START) && av_len(GvAVn(gv)) < 0) { + if ((IoFLAGS(io) & IOf_START) && av_count(GvAVn(gv)) == 0) { + SV ** svp; IoLINES(io) = 0; IoFLAGS(io) &= ~IOf_START; - do_open(gv, "-", 1, FALSE, O_RDONLY, 0, NULL); - if (GvSV(gv)) - sv_setpvs(GvSV(gv), "-"); + do_open6(gv, "-", 1, NULL, NULL, 0); + svp = &GvSV(gv); + if (*svp) { + SV * sv = *svp; + sv_setpvs(sv, "-"); + SvSETMAGIC(sv); + } else - GvSV(gv) = newSVpvs("-"); - SvSETMAGIC(GvSV(gv)); + *svp = newSVpvs("-"); } - else if (!nextargv(gv)) + else if (!nextargv(gv, FALSE)) RETPUSHYES; } } @@ -2100,7 +2154,7 @@ PP(pp_eof) PP(pp_tell) { - dVAR; dSP; dTARGET; + dSP; dTARGET; GV *gv; IO *io; @@ -2125,16 +2179,19 @@ PP(pp_tell) } #if LSEEKSIZE > IVSIZE - PUSHn( do_tell(gv) ); + PUSHn( (NV)do_tell(gv) ); #else - PUSHi( do_tell(gv) ); + PUSHi( (IV)do_tell(gv) ); #endif RETURN; } + +/* also used for: pp_seek() */ + PP(pp_sysseek) { - dVAR; dSP; + dSP; const int whence = POPi; #if LSEEKSIZE > IVSIZE const Off_t offset = (Off_t)SvNVx(POPs); @@ -2181,7 +2238,6 @@ PP(pp_sysseek) PP(pp_truncate) { - dVAR; dSP; /* There seems to be no consensus on the length type of truncate() * and ftruncate(), both off_t and size_t have supporters. In @@ -2219,13 +2275,24 @@ PP(pp_truncate) result = 0; } else { - PerlIO_flush(fp); + int fd = PerlIO_fileno(fp); + if (fd < 0) { + SETERRNO(EBADF,RMS_IFI); + result = 0; + } else { + if (len < 0) { + SETERRNO(EINVAL, LIB_INVARG); + result = 0; + } else { + PerlIO_flush(fp); #ifdef HAS_TRUNCATE - if (ftruncate(PerlIO_fileno(fp), len) < 0) + if (ftruncate(fd, len) < 0) #else - if (my_chsize(PerlIO_fileno(fp), len) < 0) + if (my_chsize(fd, len) < 0) #endif - result = 0; + result = 0; + } + } } } } @@ -2241,11 +2308,24 @@ PP(pp_truncate) result = 0; #else { - const int tmpfd = PerlLIO_open(name, O_RDWR); + int mode = O_RDWR; + int tmpfd; - if (tmpfd < 0) +#if defined(USE_64_BIT_RAWIO) && defined(O_LARGEFILE) + mode |= O_LARGEFILE; /* Transparently largefiley. */ +#endif +#ifdef O_BINARY + /* On open(), the Win32 CRT tries to seek around text + * files using 32-bit offsets, which causes the open() + * to fail on large files, so open in binary mode. + */ + mode |= O_BINARY; +#endif + tmpfd = PerlLIO_open_cloexec(name, mode); + + if (tmpfd < 0) { result = 0; - else { + } else { if (my_chsize(tmpfd, len) < 0) result = 0; PerlLIO_close(tmpfd); @@ -2262,18 +2342,21 @@ PP(pp_truncate) } } + +/* also used for: pp_fcntl() */ + PP(pp_ioctl) { - dVAR; dSP; dTARGET; + dSP; dTARGET; SV * const argsv = POPs; const unsigned int func = POPu; - const int optype = PL_op->op_type; + int optype; GV * const gv = MUTABLE_GV(POPs); - IO * const io = gv ? GvIOn(gv) : NULL; + IO * const io = GvIOn(gv); char *s; IV retval; - if (!io || !argsv || !IoIFP(io)) { + if (!IoIFP(io)) { report_evil_fh(gv); SETERRNO(EBADF,RMS_IFI); /* well, sort of... */ RETPUSHUNDEF; @@ -2296,6 +2379,7 @@ PP(pp_ioctl) s = INT2PTR(char*,retval); /* ouch */ } + optype = PL_op->op_type; TAINT_PROPER(PL_op_desc[optype]); if (optype == OP_IOCTL) @@ -2307,13 +2391,11 @@ PP(pp_ioctl) else #ifndef HAS_FCNTL DIE(aTHX_ "fcntl is not implemented"); -#else -#if defined(OS2) && defined(__EMX__) +#elif defined(OS2) && defined(__EMX__) retval = fcntl(PerlIO_fileno(IoIFP(io)), func, (int)s); #else retval = fcntl(PerlIO_fileno(IoIFP(io)), func, s); #endif -#endif #if defined(HAS_IOCTL) || defined(HAS_FCNTL) if (SvPOK(argsv)) { @@ -2339,7 +2421,7 @@ PP(pp_ioctl) PP(pp_flock) { #ifdef FLOCK - dVAR; dSP; dTARGET; + dSP; dTARGET; I32 value; const int argtype = POPi; GV * const gv = MUTABLE_GV(POPs); @@ -2359,7 +2441,7 @@ PP(pp_flock) PUSHi(value); RETURN; #else - DIE(aTHX_ PL_no_func, "flock()"); + DIE(aTHX_ PL_no_func, "flock"); #endif } @@ -2369,29 +2451,24 @@ PP(pp_flock) PP(pp_socket) { - dVAR; dSP; + dSP; const int protocol = POPi; const int type = POPi; const int domain = POPi; GV * const gv = MUTABLE_GV(POPs); - IO * const io = gv ? GvIOn(gv) : NULL; + IO * const io = GvIOn(gv); int fd; - if (!io) { - report_evil_fh(gv); - SETERRNO(EBADF,LIB_INVARG); - RETPUSHUNDEF; - } - if (IoIFP(io)) do_close(gv, FALSE); TAINT_PROPER("socket"); - fd = PerlSock_socket(domain, type, protocol); - if (fd < 0) + fd = PerlSock_socket_cloexec(domain, type, protocol); + if (fd < 0) { RETPUSHUNDEF; - IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); /* stdio gets confused about sockets */ - IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE); + } + IoIFP(io) = PerlIO_fdopen(fd, "r" SOCKET_OPEN_MODE); /* stdio gets confused about sockets */ + IoOFP(io) = PerlIO_fdopen(fd, "w" SOCKET_OPEN_MODE); IoTYPE(io) = IoTYPE_SOCKET; if (!IoIFP(io) || !IoOFP(io)) { if (IoIFP(io)) PerlIO_close(IoIFP(io)); @@ -2399,9 +2476,6 @@ PP(pp_socket) if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd); RETPUSHUNDEF; } -#if defined(HAS_FCNTL) && defined(F_SETFD) - fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */ -#endif RETPUSHYES; } @@ -2410,7 +2484,7 @@ PP(pp_socket) PP(pp_sockpair) { #if defined (HAS_SOCKETPAIR) || (defined (HAS_SOCKET) && defined(SOCK_DGRAM) && defined(AF_INET) && defined(PF_INET)) - dVAR; dSP; + dSP; int fd[2]; const int protocol = POPi; const int type = POPi; @@ -2427,13 +2501,13 @@ PP(pp_sockpair) do_close(gv2, FALSE); TAINT_PROPER("socketpair"); - if (PerlSock_socketpair(domain, type, protocol, fd) < 0) + if (PerlSock_socketpair_cloexec(domain, type, protocol, fd) < 0) RETPUSHUNDEF; - IoIFP(io1) = PerlIO_fdopen(fd[0], "r"SOCKET_OPEN_MODE); - IoOFP(io1) = PerlIO_fdopen(fd[0], "w"SOCKET_OPEN_MODE); + IoIFP(io1) = PerlIO_fdopen(fd[0], "r" SOCKET_OPEN_MODE); + IoOFP(io1) = PerlIO_fdopen(fd[0], "w" SOCKET_OPEN_MODE); IoTYPE(io1) = IoTYPE_SOCKET; - IoIFP(io2) = PerlIO_fdopen(fd[1], "r"SOCKET_OPEN_MODE); - IoOFP(io2) = PerlIO_fdopen(fd[1], "w"SOCKET_OPEN_MODE); + IoIFP(io2) = PerlIO_fdopen(fd[1], "r" SOCKET_OPEN_MODE); + IoOFP(io2) = PerlIO_fdopen(fd[1], "w" SOCKET_OPEN_MODE); IoTYPE(io2) = IoTYPE_SOCKET; if (!IoIFP(io1) || !IoOFP(io1) || !IoIFP(io2) || !IoOFP(io2)) { if (IoIFP(io1)) PerlIO_close(IoIFP(io1)); @@ -2444,10 +2518,6 @@ PP(pp_sockpair) if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]); RETPUSHUNDEF; } -#if defined(HAS_FCNTL) && defined(F_SETFD) - fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd); /* ensure close-on-exec */ - fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd); /* ensure close-on-exec */ -#endif RETPUSHYES; #else @@ -2457,9 +2527,11 @@ PP(pp_sockpair) #ifdef HAS_SOCKET +/* also used for: pp_connect() */ + PP(pp_bind) { - dVAR; dSP; + dSP; SV * const addrsv = POPs; /* OK, so on what platform does bind modify addr? */ const char *addr; @@ -2467,22 +2539,26 @@ PP(pp_bind) IO * const io = GvIOn(gv); STRLEN len; int op_type; + int fd; - if (!io || !IoIFP(io)) + if (!IoIFP(io)) goto nuts; + fd = PerlIO_fileno(IoIFP(io)); + if (fd < 0) + goto nuts; addr = SvPV_const(addrsv, len); op_type = PL_op->op_type; TAINT_PROPER(PL_op_desc[op_type]); if ((op_type == OP_BIND - ? PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) - : PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len)) + ? PerlSock_bind(fd, (struct sockaddr *)addr, len) + : PerlSock_connect(fd, (struct sockaddr *)addr, len)) >= 0) RETPUSHYES; else RETPUSHUNDEF; -nuts: + nuts: report_evil_fh(gv); SETERRNO(EBADF,SS_IVCHAN); RETPUSHUNDEF; @@ -2490,12 +2566,12 @@ nuts: PP(pp_listen) { - dVAR; dSP; + dSP; const int backlog = POPi; GV * const gv = MUTABLE_GV(POPs); - IO * const io = gv ? GvIOn(gv) : NULL; + IO * const io = GvIOn(gv); - if (!io || !IoIFP(io)) + if (!IoIFP(io)) goto nuts; if (PerlSock_listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0) @@ -2503,7 +2579,7 @@ PP(pp_listen) else RETPUSHUNDEF; -nuts: + nuts: report_evil_fh(gv); SETERRNO(EBADF,SS_IVCHAN); RETPUSHUNDEF; @@ -2511,9 +2587,8 @@ nuts: PP(pp_accept) { - dVAR; dSP; dTARGET; + dSP; dTARGET; IO *nstio; - IO *gstio; char namebuf[MAXPATHLEN]; #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__) Sock_size_t len = sizeof (struct sockaddr_in); @@ -2524,17 +2599,12 @@ PP(pp_accept) GV * const ngv = MUTABLE_GV(POPs); int fd; - if (!ngv) - goto badexit; - if (!ggv) - goto nuts; - - gstio = GvIO(ggv); + IO * const gstio = GvIO(ggv); if (!gstio || !IoIFP(gstio)) goto nuts; nstio = GvIOn(ngv); - fd = PerlSock_accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len); + fd = PerlSock_accept_cloexec(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *) namebuf, &len); #if defined(OEMVS) if (len == 0) { /* Some platforms indicate zero length when an AF_UNIX client is @@ -2550,8 +2620,8 @@ PP(pp_accept) goto badexit; if (IoIFP(nstio)) do_close(ngv, FALSE); - IoIFP(nstio) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE); - IoOFP(nstio) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE); + IoIFP(nstio) = PerlIO_fdopen(fd, "r" SOCKET_OPEN_MODE); + IoOFP(nstio) = PerlIO_fdopen(fd, "w" SOCKET_OPEN_MODE); IoTYPE(nstio) = IoTYPE_SOCKET; if (!IoIFP(nstio) || !IoOFP(nstio)) { if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio)); @@ -2559,9 +2629,6 @@ PP(pp_accept) if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd); goto badexit; } -#if defined(HAS_FCNTL) && defined(F_SETFD) - fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */ -#endif #ifdef __SCO_VERSION__ len = sizeof (struct sockaddr_in); /* OpenUNIX 8 somehow truncates info */ @@ -2570,37 +2637,40 @@ PP(pp_accept) PUSHp(namebuf, len); RETURN; -nuts: + nuts: report_evil_fh(ggv); SETERRNO(EBADF,SS_IVCHAN); -badexit: + badexit: RETPUSHUNDEF; } PP(pp_shutdown) { - dVAR; dSP; dTARGET; + dSP; dTARGET; const int how = POPi; GV * const gv = MUTABLE_GV(POPs); IO * const io = GvIOn(gv); - if (!io || !IoIFP(io)) + if (!IoIFP(io)) goto nuts; PUSHi( PerlSock_shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 ); RETURN; -nuts: + nuts: report_evil_fh(gv); SETERRNO(EBADF,SS_IVCHAN); RETPUSHUNDEF; } + +/* also used for: pp_gsockopt() */ + PP(pp_ssockopt) { - dVAR; dSP; + dSP; const int optype = PL_op->op_type; SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs; const unsigned int optname = (unsigned int) POPi; @@ -2610,10 +2680,12 @@ PP(pp_ssockopt) int fd; Sock_size_t len; - if (!io || !IoIFP(io)) + if (!IoIFP(io)) goto nuts; fd = PerlIO_fileno(IoIFP(io)); + if (fd < 0) + goto nuts; switch (optype) { case OP_GSOCKOPT: SvGROW(sv, 257); @@ -2623,35 +2695,26 @@ PP(pp_ssockopt) len = SvCUR(sv); if (PerlSock_getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0) goto nuts2; +#if defined(_AIX) + /* XXX Configure test: does getsockopt set the length properly? */ + if (len == 256) + len = sizeof(int); +#endif SvCUR_set(sv, len); *SvEND(sv) ='\0'; PUSHs(sv); break; case OP_SSOCKOPT: { -#if defined(__SYMBIAN32__) -# define SETSOCKOPT_OPTION_VALUE_T void * -#else -# define SETSOCKOPT_OPTION_VALUE_T const char * -#endif - /* XXX TODO: We need to have a proper type (a Configure probe, - * etc.) for what the C headers think of the third argument of - * setsockopt(), the option_value read-only buffer: is it - * a "char *", or a "void *", const or not. Some compilers - * don't take kindly to e.g. assuming that "char *" implicitly - * promotes to a "void *", or to explicitly promoting/demoting - * consts to non/vice versa. The "const void *" is the SUS - * definition, but that does not fly everywhere for the above - * reasons. */ - SETSOCKOPT_OPTION_VALUE_T buf; + const char *buf; int aint; if (SvPOKp(sv)) { STRLEN l; - buf = (SETSOCKOPT_OPTION_VALUE_T) SvPV_const(sv, l); + buf = SvPV_const(sv, l); len = l; } else { aint = (int)SvIV(sv); - buf = (SETSOCKOPT_OPTION_VALUE_T) &aint; + buf = (const char *) &aint; len = sizeof(int); } if (PerlSock_setsockopt(fd, lvl, optname, buf, len) < 0) @@ -2662,17 +2725,20 @@ PP(pp_ssockopt) } RETURN; -nuts: + nuts: report_evil_fh(gv); SETERRNO(EBADF,SS_IVCHAN); -nuts2: + nuts2: RETPUSHUNDEF; } + +/* also used for: pp_getsockname() */ + PP(pp_getpeername) { - dVAR; dSP; + dSP; const int optype = PL_op->op_type; GV * const gv = MUTABLE_GV(POPs); IO * const io = GvIOn(gv); @@ -2680,15 +2746,21 @@ PP(pp_getpeername) SV *sv; int fd; - if (!io || !IoIFP(io)) + if (!IoIFP(io)) goto nuts; - sv = sv_2mortal(newSV(257)); - (void)SvPOK_only(sv); +#ifdef HAS_SOCKADDR_STORAGE + len = sizeof(struct sockaddr_storage); +#else len = 256; +#endif + sv = sv_2mortal(newSV(len+1)); + (void)SvPOK_only(sv); SvCUR_set(sv, len); *SvEND(sv) ='\0'; fd = PerlIO_fileno(IoIFP(io)); + if (fd < 0) + goto nuts; switch (optype) { case OP_GETSOCKNAME: if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0) @@ -2721,10 +2793,10 @@ PP(pp_getpeername) PUSHs(sv); RETURN; -nuts: + nuts: report_evil_fh(gv); SETERRNO(EBADF,SS_IVCHAN); -nuts2: + nuts2: RETPUSHUNDEF; } @@ -2732,13 +2804,14 @@ nuts2: /* Stat calls. */ +/* also used for: pp_lstat() */ + PP(pp_stat) { - dVAR; dSP; GV *gv = NULL; IO *io = NULL; - I32 gimme; + U8 gimme; I32 max = 13; SV* sv; @@ -2748,7 +2821,7 @@ PP(pp_stat) if (gv != PL_defgv) { do_fstat_warning_check: Perl_ck_warner(aTHX_ packWARN(WARN_IO), - "lstat() on filehandle%s%"SVf, + "lstat() on filehandle%s%" SVf, gv ? " " : "", SVfARG(gv ? sv_2mortal(newSVhek(GvENAME_HEK(gv))) @@ -2758,31 +2831,40 @@ PP(pp_stat) Perl_croak(aTHX_ "The stat preceding lstat() wasn't an lstat"); } - if (gv != PL_defgv) { - bool havefp; + if (gv == PL_defgv) { + if (PL_laststatval < 0) + SETERRNO(EBADF,RMS_IFI); + } else { do_fstat_have_io: - havefp = FALSE; PL_laststype = OP_STAT; PL_statgv = gv ? gv : (GV *)io; - sv_setpvs(PL_statname, ""); + SvPVCLEAR(PL_statname); if(gv) { io = GvIO(gv); } if (io) { if (IoIFP(io)) { - PL_laststatval = - PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache); - havefp = TRUE; + int fd = PerlIO_fileno(IoIFP(io)); + if (fd < 0) { + report_evil_fh(gv); + PL_laststatval = -1; + SETERRNO(EBADF,RMS_IFI); + } else { + PL_laststatval = PerlLIO_fstat(fd, &PL_statcache); + } } else if (IoDIRP(io)) { PL_laststatval = PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache); - havefp = TRUE; } else { + report_evil_fh(gv); PL_laststatval = -1; + SETERRNO(EBADF,RMS_IFI); } - } - else PL_laststatval = -1; - if (PL_laststatval < 0 && !havefp) report_evil_fh(gv); + } else { + report_evil_fh(gv); + PL_laststatval = -1; + SETERRNO(EBADF,RMS_IFI); + } } if (PL_laststatval < 0) { @@ -2790,29 +2872,34 @@ PP(pp_stat) } } else { + const char *file; + const char *temp; + STRLEN len; if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) { io = MUTABLE_IO(SvRV(sv)); if (PL_op->op_type == OP_LSTAT) goto do_fstat_warning_check; goto do_fstat_have_io; } - SvTAINTED_off(PL_statname); /* previous tainting irrelevant */ - sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv)); + temp = SvPV_nomg_const(sv, len); + sv_setpv(PL_statname, temp); PL_statgv = NULL; PL_laststype = PL_op->op_type; - if (PL_op->op_type == OP_LSTAT) - PL_laststatval = PerlLIO_lstat(SvPV_nolen_const(PL_statname), &PL_statcache); + file = SvPV_nolen_const(PL_statname); + if (!IS_SAFE_PATHNAME(temp, len, OP_NAME(PL_op))) { + PL_laststatval = -1; + } + else if (PL_op->op_type == OP_LSTAT) + PL_laststatval = PerlLIO_lstat(file, &PL_statcache); else - PL_laststatval = PerlLIO_stat(SvPV_nolen_const(PL_statname), &PL_statcache); + PL_laststatval = PerlLIO_stat(file, &PL_statcache); if (PL_laststatval < 0) { - if (ckWARN(WARN_NEWLINE) && - strchr(SvPV_nolen_const(PL_statname), '\n')) - { + if (ckWARN(WARN_NEWLINE) && should_warn_nl(file)) { /* PL_warn_nl is constant */ - GCC_DIAG_IGNORE(-Wformat-nonliteral); + GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat"); - GCC_DIAG_RESTORE; + GCC_DIAG_RESTORE_STMT; } max = 0; } @@ -2828,15 +2915,63 @@ PP(pp_stat) EXTEND(SP, max); EXTEND_MORTAL(max); mPUSHi(PL_statcache.st_dev); -#if ST_INO_SIZE > IVSIZE - mPUSHn(PL_statcache.st_ino); -#else -# if ST_INO_SIGN <= 0 - mPUSHi(PL_statcache.st_ino); -# else - mPUSHu(PL_statcache.st_ino); -# endif -#endif + { + /* + * We try to represent st_ino as a native IV or UV where + * possible, but fall back to a decimal string where + * necessary. The code to generate these decimal strings + * is quite obtuse, because (a) we're portable to non-POSIX + * platforms where st_ino might be signed; (b) we didn't + * necessarily detect at Configure time whether st_ino is + * signed; (c) we're portable to non-POSIX platforms where + * ino_t isn't defined, so have no name for the type of + * st_ino; and (d) sprintf() doesn't necessarily support + * integers as large as st_ino. + */ + bool neg; + Stat_t s; + CLANG_DIAG_IGNORE_STMT(-Wtautological-compare); + GCC_DIAG_IGNORE_STMT(-Wtype-limits); + neg = PL_statcache.st_ino < 0; + GCC_DIAG_RESTORE_STMT; + CLANG_DIAG_RESTORE_STMT; + if (neg) { + s.st_ino = (IV)PL_statcache.st_ino; + if (LIKELY(s.st_ino == PL_statcache.st_ino)) { + mPUSHi(s.st_ino); + } else { + char buf[sizeof(s.st_ino)*3+1], *p; + s.st_ino = PL_statcache.st_ino; + for (p = buf + sizeof(buf); p != buf+1; ) { + Stat_t t; + t.st_ino = s.st_ino / 10; + *--p = '0' + (int)(t.st_ino*10 - s.st_ino); + s.st_ino = t.st_ino; + } + while (*p == '0') + p++; + *--p = '-'; + mPUSHp(p, buf+sizeof(buf) - p); + } + } else { + s.st_ino = (UV)PL_statcache.st_ino; + if (LIKELY(s.st_ino == PL_statcache.st_ino)) { + mPUSHu(s.st_ino); + } else { + char buf[sizeof(s.st_ino)*3], *p; + s.st_ino = PL_statcache.st_ino; + for (p = buf + sizeof(buf); p != buf; ) { + Stat_t t; + t.st_ino = s.st_ino / 10; + *--p = '0' + (int)(s.st_ino - t.st_ino*10); + s.st_ino = t.st_ino; + } + while (*p == '0') + p++; + mPUSHp(p, buf+sizeof(buf) - p); + } + } + } mPUSHu(PL_statcache.st_mode); mPUSHu(PL_statcache.st_nlink); @@ -2897,7 +3032,7 @@ S_ft_return_false(pTHX_ SV *ret) { PUTBACK; if (PL_op->op_private & OPpFT_STACKING) { - while (OP_IS_FILETEST(next->op_type) + while (next && OP_IS_FILETEST(next->op_type) && next->op_private & OPpFT_STACKED) next = next->op_next; } @@ -2929,11 +3064,10 @@ S_ft_return_true(pTHX_ SV *ret) { STATIC OP * S_try_amagic_ftest(pTHX_ char chr) { - dVAR; SV *const arg = *PL_stack_sp; assert(chr != '?'); - if (!(PL_op->op_private & OPpFT_STACKING)) SvGETMAGIC(arg); + if (!(PL_op->op_private & OPpFT_STACKED)) SvGETMAGIC(arg); if (SvAMAGIC(arg)) { @@ -2952,12 +3086,14 @@ S_try_amagic_ftest(pTHX_ char chr) { } +/* also used for: pp_fteexec() pp_fteread() pp_ftewrite() pp_ftrexec() + * pp_ftrwrite() */ + PP(pp_ftrread) { - dVAR; I32 result; /* Not const, because things tweak this below. Not bool, because there's - no guarantee that OPp_FT_ACCESS is <= CHAR_MAX */ + no guarantee that OPpFT_ACCESS is <= CHAR_MAX */ #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS) I32 use_access = PL_op->op_private & OPpFT_ACCESS; /* Giving some sort of initial value silences compilers. */ @@ -3016,7 +3152,7 @@ PP(pp_ftrread) access_mode = W_OK; #endif stat_mode = S_IWUSR; - /* fall through */ + /* FALLTHROUGH */ case OP_FTEREAD: #ifndef PERL_EFF_ACCESS @@ -3038,8 +3174,12 @@ PP(pp_ftrread) if (use_access) { #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS) - const char *name = SvPV_nolen(*PL_stack_sp); - if (effective) { + STRLEN len; + const char *name = SvPV(*PL_stack_sp, len); + if (!IS_SAFE_PATHNAME(name, len, OP_NAME(PL_op))) { + result = -1; + } + else if (effective) { # ifdef PERL_EFF_ACCESS result = PERL_EFF_ACCESS(name, access_mode); # else @@ -3070,9 +3210,11 @@ PP(pp_ftrread) FT_RETURNNO; } + +/* also used for: pp_ftatime() pp_ftctime() pp_ftmtime() pp_ftsize() */ + PP(pp_ftis) { - dVAR; I32 result; const int op_type = PL_op->op_type; char opchar = '?'; @@ -3117,14 +3259,18 @@ PP(pp_ftis) break; } SvSETMAGIC(TARG); - return SvTRUE_nomg(TARG) + return SvTRUE_nomg_NN(TARG) ? S_ft_return_true(aTHX_ TARG) : S_ft_return_false(aTHX_ TARG); } } + +/* also used for: pp_ftblk() pp_ftchr() pp_ftdir() pp_fteowned() + * pp_ftfile() pp_ftpipe() pp_ftsgid() pp_ftsock() + * pp_ftsuid() pp_ftsvtx() pp_ftzero() */ + PP(pp_ftrowned) { - dVAR; I32 result; char opchar = '?'; @@ -3144,24 +3290,6 @@ PP(pp_ftrowned) } tryAMAGICftest_MG(opchar); - /* I believe that all these three are likely to be defined on most every - system these days. */ -#ifndef S_ISUID - if(PL_op->op_type == OP_FTSUID) { - FT_RETURNNO; - } -#endif -#ifndef S_ISGID - if(PL_op->op_type == OP_FTSGID) { - FT_RETURNNO; - } -#endif -#ifndef S_ISVTX - if(PL_op->op_type == OP_FTSVTX) { - FT_RETURNNO; - } -#endif - result = my_stat_flags(0); if (result < 0) FT_RETURNUNDEF; @@ -3226,7 +3354,6 @@ PP(pp_ftrowned) PP(pp_ftlink) { - dVAR; I32 result; tryAMAGICftest_MG('l'); @@ -3241,11 +3368,11 @@ PP(pp_ftlink) PP(pp_fttty) { - dVAR; int fd; GV *gv; char *name = NULL; STRLEN namelen; + UV uv; tryAMAGICftest_MG('t'); @@ -3261,18 +3388,24 @@ PP(pp_fttty) if (GvIO(gv) && IoIFP(GvIOp(gv))) fd = PerlIO_fileno(IoIFP(GvIOp(gv))); - else if (name && isDIGIT(*name)) - fd = atoi(name); + else if (name && isDIGIT(*name) && grok_atoUV(name, &uv, NULL) && uv <= PERL_INT_MAX) + fd = (int)uv; else + fd = -1; + if (fd < 0) { + SETERRNO(EBADF,RMS_IFI); FT_RETURNUNDEF; + } if (PerlLIO_isatty(fd)) FT_RETURNYES; FT_RETURNNO; } + +/* also used for: pp_ftbinary() */ + PP(pp_fttext) { - dVAR; I32 i; SSize_t len; I32 odd = 0; @@ -3282,6 +3415,7 @@ PP(pp_fttext) SV *sv = NULL; GV *gv; PerlIO *fp; + const U8 * first_variant; tryAMAGICftest_MG(PL_op->op_type == OP_FTTEXT ? 'T' : 'B'); @@ -3307,15 +3441,21 @@ PP(pp_fttext) } else { PL_statgv = gv; - sv_setpvs(PL_statname, ""); + SvPVCLEAR(PL_statname); io = GvIO(PL_statgv); } PL_laststatval = -1; PL_laststype = OP_STAT; if (io && IoIFP(io)) { + int fd; if (! PerlIO_has_base(IoIFP(io))) DIE(aTHX_ "-T and -B not implemented on filehandles"); - PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache); + fd = PerlIO_fileno(IoIFP(io)); + if (fd < 0) { + SETERRNO(EBADF,RMS_IFI); + FT_RETURNUNDEF; + } + PL_laststatval = PerlLIO_fstat(fd, &PL_statcache); if (PL_laststatval < 0) FT_RETURNUNDEF; if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */ @@ -3328,9 +3468,10 @@ PP(pp_fttext) i = PerlIO_getc(IoIFP(io)); if (i != EOF) (void)PerlIO_ungetc(IoIFP(io),i); + else + /* null file is anything */ + FT_RETURNYES; } - if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */ - FT_RETURNYES; len = PerlIO_get_bufsiz(IoIFP(io)); s = (STDCHAR *) PerlIO_get_base(IoIFP(io)); /* sfio can have large buffers - limit to 512 */ @@ -3345,28 +3486,47 @@ PP(pp_fttext) } } else { - sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv)); + const char *file; + const char *temp; + STRLEN temp_len; + int fd; + + assert(sv); + temp = SvPV_nomg_const(sv, temp_len); + sv_setpv(PL_statname, temp); + if (!IS_SAFE_PATHNAME(temp, temp_len, OP_NAME(PL_op))) { + PL_laststatval = -1; + PL_laststype = OP_STAT; + FT_RETURNUNDEF; + } really_filename: + file = SvPVX_const(PL_statname); PL_statgv = NULL; - if (!(fp = PerlIO_open(SvPVX_const(PL_statname), "r"))) { + if (!(fp = PerlIO_open(file, "r"))) { if (!gv) { PL_laststatval = -1; PL_laststype = OP_STAT; } - if (ckWARN(WARN_NEWLINE) && strchr(SvPV_nolen_const(PL_statname), - '\n')) - { + if (ckWARN(WARN_NEWLINE) && should_warn_nl(file)) { /* PL_warn_nl is constant */ - GCC_DIAG_IGNORE(-Wformat-nonliteral); + GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open"); - GCC_DIAG_RESTORE; + GCC_DIAG_RESTORE_STMT; } FT_RETURNUNDEF; } PL_laststype = OP_STAT; - PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache); + fd = PerlIO_fileno(fp); + if (fd < 0) { + (void)PerlIO_close(fp); + SETERRNO(EBADF,RMS_IFI); + FT_RETURNUNDEF; + } + PL_laststatval = PerlLIO_fstat(fd, &PL_statcache); if (PL_laststatval < 0) { + dSAVE_ERRNO; (void)PerlIO_close(fp); + RESTORE_ERRNO; FT_RETURNUNDEF; } PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL); @@ -3381,7 +3541,6 @@ PP(pp_fttext) } /* now scan s to look for textiness */ - /* XXX ASCII dependent code */ #if defined(DOSISH) || defined(USEMYBINMODE) /* ignore trailing ^Z on short files */ @@ -3389,43 +3548,52 @@ PP(pp_fttext) --len; #endif + assert(len); + if (! is_utf8_invariant_string_loc((U8 *) s, len, &first_variant)) { + + /* Here contains a variant under UTF-8 . See if the entire string is + * UTF-8. */ + if (is_utf8_fixed_width_buf_flags(first_variant, + len - ((char *) first_variant - (char *) s), + 0)) + { + if (PL_op->op_type == OP_FTTEXT) { + FT_RETURNYES; + } + else { + FT_RETURNNO; + } + } + } + + /* Here, is not UTF-8 or is entirely ASCII. Look through the buffer for + * things that wouldn't be in ASCII text or rich ASCII text. Count these + * in 'odd' */ for (i = 0; i < len; i++, s++) { if (!*s) { /* null never allowed in text */ odd += len; break; } -#ifdef EBCDIC - else if (!(isPRINT(*s) || isSPACE(*s))) - odd++; -#else - else if (*s & 128) { -#ifdef USE_LOCALE - if (IN_LOCALE_RUNTIME && isALPHA_LC(*s)) +#ifdef USE_LOCALE_CTYPE + if (IN_LC_RUNTIME(LC_CTYPE)) { + if ( isPRINT_LC(*s) || isSPACE_LC(*s)) { continue; + } + } + else #endif - /* utf8 characters don't count as odd */ - if (UTF8_IS_START(*s)) { - int ulen = UTF8SKIP(s); - if (ulen < len - i) { - int j; - for (j = 1; j < ulen; j++) { - if (!UTF8_IS_CONTINUATION(s[j])) - goto not_utf8; - } - --ulen; /* loop does extra increment */ - s += ulen; - i += ulen; - continue; - } - } - not_utf8: - odd++; - } - else if (*s < 32 && - *s != '\n' && *s != '\r' && *s != '\b' && - *s != '\t' && *s != '\f' && *s != 27) - odd++; -#endif + if ( isPRINT_A(*s) + /* VT occurs so rarely in text, that we consider it odd */ + || (isSPACE_A(*s) && *s != VT_NATIVE) + + /* But there is a fair amount of backspaces and escapes in + * some text */ + || *s == '\b' + || *s == ESC_NATIVE) + { + continue; + } + odd++; } if ((odd * 3 > len) == (PL_op->op_type == OP_FTTEXT)) /* allow 1/3 odd */ @@ -3438,7 +3606,7 @@ PP(pp_fttext) PP(pp_chdir) { - dVAR; dSP; dTARGET; + dSP; dTARGET; const char *tmps = NULL; GV *gv = NULL; @@ -3446,15 +3614,25 @@ PP(pp_chdir) SV * const sv = POPs; if (PL_op->op_flags & OPf_SPECIAL) { gv = gv_fetchsv(sv, 0, SVt_PVIO); + if (!gv) { + if (ckWARN(WARN_UNOPENED)) { + Perl_warner(aTHX_ packWARN(WARN_UNOPENED), + "chdir() on unopened filehandle %" SVf, sv); + } + SETERRNO(EBADF,RMS_IFI); + PUSHs(&PL_sv_zero); + TAINT_PROPER("chdir"); + RETURN; + } } else if (!(gv = MAYBE_DEREF_GV(sv))) tmps = SvPV_nomg_const_nolen(sv); } - - if( !gv && (!tmps || !*tmps) ) { + else { HV * const table = GvHVn(PL_envgv); SV **svp; + EXTEND(SP, 1); if ( (svp = hv_fetchs(table, "HOME", FALSE)) || (svp = hv_fetchs(table, "LOGDIR", FALSE)) #ifdef VMS @@ -3462,12 +3640,11 @@ PP(pp_chdir) #endif ) { - if( MAXARG == 1 ) - deprecate("chdir('') or chdir(undef) as chdir()"); tmps = SvPV_nolen_const(*svp); } else { - PUSHi(0); + PUSHs(&PL_sv_zero); + SETERRNO(EINVAL, LIB_INVARG); TAINT_PROPER("chdir"); RETURN; } @@ -3481,19 +3658,19 @@ PP(pp_chdir) if (IoDIRP(io)) { PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0); } else if (IoIFP(io)) { - PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0); + int fd = PerlIO_fileno(IoIFP(io)); + if (fd < 0) { + goto nuts; + } + PUSHi(fchdir(fd) >= 0); } else { - report_evil_fh(gv); - SETERRNO(EBADF, RMS_IFI); - PUSHi(0); + goto nuts; } + } else { + goto nuts; } - else { - report_evil_fh(gv); - SETERRNO(EBADF,RMS_IFI); - PUSHi(0); - } + #else DIE(aTHX_ PL_no_func, "fchdir"); #endif @@ -3506,11 +3683,22 @@ PP(pp_chdir) hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD); #endif RETURN; + +#ifdef HAS_FCHDIR + nuts: + report_evil_fh(gv); + SETERRNO(EBADF,RMS_IFI); + PUSHs(&PL_sv_zero); + RETURN; +#endif } + +/* also used for: pp_chmod() pp_kill() pp_unlink() pp_utime() */ + PP(pp_chown) { - dVAR; dSP; dMARK; dTARGET; + dSP; dMARK; dTARGET; const I32 value = (I32)apply(PL_op->op_type, MARK, SP); SP = MARK; @@ -3521,7 +3709,7 @@ PP(pp_chown) PP(pp_chroot) { #ifdef HAS_CHROOT - dVAR; dSP; dTARGET; + dSP; dTARGET; char * const tmps = POPpx; TAINT_PROPER("chroot"); PUSHi( chroot(tmps) >= 0 ); @@ -3533,19 +3721,22 @@ PP(pp_chroot) PP(pp_rename) { - dVAR; dSP; dTARGET; + dSP; dTARGET; int anum; +#ifndef HAS_RENAME + Stat_t statbuf; +#endif const char * const tmps2 = POPpconstx; const char * const tmps = SvPV_nolen_const(TOPs); TAINT_PROPER("rename"); #ifdef HAS_RENAME anum = PerlLIO_rename(tmps, tmps2); #else - if (!(anum = PerlLIO_stat(tmps, &PL_statbuf))) { + if (!(anum = PerlLIO_stat(tmps, &statbuf))) { if (same_dirent(tmps2, tmps)) /* can always rename to same name */ anum = 1; else { - if (PerlProc_geteuid() || PerlLIO_stat(tmps2, &PL_statbuf) < 0 || !S_ISDIR(PL_statbuf.st_mode)) + if (PerlProc_geteuid() || PerlLIO_stat(tmps2, &statbuf) < 0 || !S_ISDIR(statbuf.st_mode)) (void)UNLINK(tmps2); if (!(anum = link(tmps, tmps2))) anum = UNLINK(tmps); @@ -3556,10 +3747,13 @@ PP(pp_rename) RETURN; } + +/* also used for: pp_symlink() */ + #if defined(HAS_LINK) || defined(HAS_SYMLINK) PP(pp_link) { - dVAR; dSP; dTARGET; + dSP; dTARGET; const int op_type = PL_op->op_type; int result; @@ -3577,20 +3771,16 @@ PP(pp_link) const char * const tmps = SvPV_nolen_const(TOPs); TAINT_PROPER(PL_op_desc[op_type]); result = -# if defined(HAS_LINK) -# if defined(HAS_SYMLINK) +# if defined(HAS_LINK) && defined(HAS_SYMLINK) /* Both present - need to choose which. */ (op_type == OP_LINK) ? - PerlLIO_link(tmps, tmps2) : symlink(tmps, tmps2); -# else + PerlLIO_link(tmps, tmps2) : PerlLIO_symlink(tmps, tmps2); +# elif defined(HAS_LINK) /* Only have link, so calls to pp_symlink will have DIE()d above. */ PerlLIO_link(tmps, tmps2); -# endif -# else -# if defined(HAS_SYMLINK) +# elif defined(HAS_SYMLINK) /* Only have symlink, so calls to pp_link will have DIE()d above. */ - symlink(tmps, tmps2); -# endif + PerlLIO_symlink(tmps, tmps2); # endif } @@ -3598,6 +3788,9 @@ PP(pp_link) RETURN; } #else + +/* also used for: pp_symlink() */ + PP(pp_link) { /* Have neither. */ @@ -3607,19 +3800,21 @@ PP(pp_link) PP(pp_readlink) { - dVAR; dSP; #ifdef HAS_SYMLINK dTARGET; const char *tmps; char buf[MAXPATHLEN]; - int len; + SSize_t len; TAINT; tmps = POPpconstx; - len = readlink(tmps, buf, sizeof(buf) - 1); + /* NOTE: if the length returned by readlink() is sizeof(buf) - 1, + * it is impossible to know whether the result was truncated. */ + len = PerlLIO_readlink(tmps, buf, sizeof(buf) - 1); if (len < 0) RETPUSHUNDEF; + buf[len] = '\0'; PUSHp(buf, len); RETURN; #else @@ -3698,7 +3893,8 @@ S_dooneliner(pTHX_ const char *cmd, const char *filename) return 0; } else { /* some mkdirs return no failure indication */ - anum = (PerlLIO_stat(save_filename, &PL_statbuf) >= 0); + Stat_t statbuf; + anum = (PerlLIO_stat(save_filename, &statbuf) >= 0); if (PL_op->op_type == OP_RMDIR) anum = !anum; if (anum) @@ -3735,11 +3931,11 @@ S_dooneliner(pTHX_ const char *cmd, const char *filename) PP(pp_mkdir) { - dVAR; dSP; dTARGET; + dSP; dTARGET; STRLEN len; const char *tmps; bool copy = FALSE; - const int mode = (MAXARG > 1 && (TOPs||((void)POPs,0))) ? POPi : 0777; + const unsigned int mode = (MAXARG > 1 && (TOPs||((void)POPs,0))) ? POPu : 0777; TRIMSLASHES(tmps,len,copy); @@ -3762,7 +3958,7 @@ PP(pp_mkdir) PP(pp_rmdir) { - dVAR; dSP; dTARGET; + dSP; dTARGET; STRLEN len; const char *tmps; bool copy = FALSE; @@ -3784,25 +3980,21 @@ PP(pp_rmdir) PP(pp_open_dir) { #if defined(Direntry_t) && defined(HAS_READDIR) - dVAR; dSP; + dSP; const char * const dirname = POPpconstx; GV * const gv = MUTABLE_GV(POPs); IO * const io = GvIOn(gv); - if (!io) - goto nope; - if ((IoIFP(io) || IoOFP(io))) - Perl_ck_warner_d(aTHX_ packWARN2(WARN_IO, WARN_DEPRECATED), - "Opening filehandle %"HEKf" also as a directory", - HEKfARG(GvENAME_HEK(gv)) ); + Perl_croak(aTHX_ "Cannot open %" HEKf " as a dirhandle: it is already open as a filehandle", + HEKfARG(GvENAME_HEK(gv))); if (IoDIRP(io)) PerlDir_close(IoDIRP(io)); if (!(IoDIRP(io) = PerlDir_open(dirname))) goto nope; RETPUSHYES; -nope: + nope: if (!errno) SETERRNO(EBADF,RMS_DIR); RETPUSHUNDEF; @@ -3819,18 +4011,17 @@ PP(pp_readdir) #if !defined(I_DIRENT) && !defined(VMS) Direntry_t *readdir (DIR *); #endif - dVAR; dSP; SV *sv; - const I32 gimme = GIMME; + const U8 gimme = GIMME_V; GV * const gv = MUTABLE_GV(POPs); const Direntry_t *dp; IO * const io = GvIOn(gv); - if (!io || !IoDIRP(io)) { + if (!IoDIRP(io)) { Perl_ck_warner(aTHX_ packWARN(WARN_IO), - "readdir() attempted on invalid dirhandle %"HEKf, + "readdir() attempted on invalid dirhandle %" HEKf, HEKfARG(GvENAME_HEK(gv))); goto nope; } @@ -3854,10 +4045,10 @@ PP(pp_readdir) RETURN; -nope: + nope: if (!errno) SETERRNO(EBADF,RMS_ISI); - if (GIMME == G_ARRAY) + if (gimme == G_ARRAY) RETURN; else RETPUSHUNDEF; @@ -3867,7 +4058,7 @@ nope: PP(pp_telldir) { #if defined(HAS_TELLDIR) || defined(telldir) - dVAR; dSP; dTARGET; + dSP; dTARGET; /* XXX does _anyone_ need this? --AD 2/20/1998 */ /* XXX netbsd still seemed to. XXX HAS_TELLDIR_PROTO is new style, NEED_TELLDIR_PROTO is old style. @@ -3878,16 +4069,16 @@ PP(pp_telldir) GV * const gv = MUTABLE_GV(POPs); IO * const io = GvIOn(gv); - if (!io || !IoDIRP(io)) { + if (!IoDIRP(io)) { Perl_ck_warner(aTHX_ packWARN(WARN_IO), - "telldir() attempted on invalid dirhandle %"HEKf, + "telldir() attempted on invalid dirhandle %" HEKf, HEKfARG(GvENAME_HEK(gv))); goto nope; } PUSHi( PerlDir_tell(IoDIRP(io)) ); RETURN; -nope: + nope: if (!errno) SETERRNO(EBADF,RMS_ISI); RETPUSHUNDEF; @@ -3899,21 +4090,21 @@ nope: PP(pp_seekdir) { #if defined(HAS_SEEKDIR) || defined(seekdir) - dVAR; dSP; + dSP; const long along = POPl; GV * const gv = MUTABLE_GV(POPs); IO * const io = GvIOn(gv); - if (!io || !IoDIRP(io)) { + if (!IoDIRP(io)) { Perl_ck_warner(aTHX_ packWARN(WARN_IO), - "seekdir() attempted on invalid dirhandle %"HEKf, + "seekdir() attempted on invalid dirhandle %" HEKf, HEKfARG(GvENAME_HEK(gv))); goto nope; } (void)PerlDir_seek(IoDIRP(io), along); RETPUSHYES; -nope: + nope: if (!errno) SETERRNO(EBADF,RMS_ISI); RETPUSHUNDEF; @@ -3925,19 +4116,19 @@ nope: PP(pp_rewinddir) { #if defined(HAS_REWINDDIR) || defined(rewinddir) - dVAR; dSP; + dSP; GV * const gv = MUTABLE_GV(POPs); IO * const io = GvIOn(gv); - if (!io || !IoDIRP(io)) { + if (!IoDIRP(io)) { Perl_ck_warner(aTHX_ packWARN(WARN_IO), - "rewinddir() attempted on invalid dirhandle %"HEKf, + "rewinddir() attempted on invalid dirhandle %" HEKf, HEKfARG(GvENAME_HEK(gv))); goto nope; } (void)PerlDir_rewind(IoDIRP(io)); RETPUSHYES; -nope: + nope: if (!errno) SETERRNO(EBADF,RMS_ISI); RETPUSHUNDEF; @@ -3949,13 +4140,13 @@ nope: PP(pp_closedir) { #if defined(Direntry_t) && defined(HAS_READDIR) - dVAR; dSP; + dSP; GV * const gv = MUTABLE_GV(POPs); IO * const io = GvIOn(gv); - if (!io || !IoDIRP(io)) { + if (!IoDIRP(io)) { Perl_ck_warner(aTHX_ packWARN(WARN_IO), - "closedir() attempted on invalid dirhandle %"HEKf, + "closedir() attempted on invalid dirhandle %" HEKf, HEKfARG(GvENAME_HEK(gv))); goto nope; } @@ -3970,7 +4161,7 @@ PP(pp_closedir) IoDIRP(io) = 0; RETPUSHYES; -nope: + nope: if (!errno) SETERRNO(EBADF,RMS_IFI); RETPUSHUNDEF; @@ -3984,7 +4175,7 @@ nope: PP(pp_fork) { #ifdef HAS_FORK - dVAR; dSP; dTARGET; + dSP; dTARGET; Pid_t childpid; #ifdef HAS_SIGPROCMASK sigset_t oldmask, newmask; @@ -4020,8 +4211,7 @@ PP(pp_fork) } PUSHi(childpid); RETURN; -#else -# if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS) +#elif (defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)) || defined(__amigaos4__) dSP; dTARGET; Pid_t childpid; @@ -4032,16 +4222,15 @@ PP(pp_fork) RETPUSHUNDEF; PUSHi(childpid); RETURN; -# else +#else DIE(aTHX_ PL_no_func, "fork"); -# endif #endif } PP(pp_wait) { #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__) - dVAR; dSP; dTARGET; + dSP; dTARGET; Pid_t childpid; int argflags; @@ -4069,10 +4258,16 @@ PP(pp_wait) PP(pp_waitpid) { #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__) - dVAR; dSP; dTARGET; + dSP; dTARGET; const int optype = POPi; const Pid_t pid = TOPi; Pid_t result; +#ifdef __amigaos4__ + int argflags = 0; + result = amigaos_waitpid(aTHX_ optype, pid, &argflags); + STATUS_NATIVE_CHILD_SET((result >= 0) ? argflags : -1); + result = result == 0 ? pid : -1; +#else int argflags; if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG) @@ -4089,6 +4284,7 @@ PP(pp_waitpid) # else STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1); # endif +# endif /* __amigaos4__ */ SETi(result); RETURN; #else @@ -4098,37 +4294,88 @@ PP(pp_waitpid) PP(pp_system) { - dVAR; dSP; dMARK; dORIGMARK; dTARGET; + dSP; dMARK; dORIGMARK; dTARGET; #if defined(__LIBCATAMOUNT__) PL_statusvalue = -1; SP = ORIGMARK; XPUSHi(-1); #else I32 value; +# ifdef __amigaos4__ + void * result; +# else int result; +# endif + + while (++MARK <= SP) { + SV *origsv = *MARK, *copysv; + STRLEN len; + char *pv; + SvGETMAGIC(origsv); +#if defined(WIN32) || defined(__VMS) + /* + * Because of a nasty platform-specific variation on the meaning + * of arguments to this op, we must preserve numeric arguments + * as numeric, not just retain the string value. + */ + if (SvNIOK(origsv) || SvNIOKp(origsv)) { + copysv = newSV_type(SVt_PVNV); + sv_2mortal(copysv); + if (SvPOK(origsv) || SvPOKp(origsv)) { + pv = SvPV_nomg(origsv, len); + sv_setpvn(copysv, pv, len); + SvPOK_off(copysv); + } + if (SvIOK(origsv) || SvIOKp(origsv)) + SvIV_set(copysv, SvIVX(origsv)); + if (SvNOK(origsv) || SvNOKp(origsv)) + SvNV_set(copysv, SvNVX(origsv)); + SvFLAGS(copysv) |= SvFLAGS(origsv) & + (SVf_IOK|SVf_NOK|SVf_POK|SVp_IOK|SVp_NOK|SVp_POK| + SVf_UTF8|SVf_IVisUV); + } else +#endif + { + pv = SvPV_nomg(origsv, len); + copysv = newSVpvn_flags(pv, len, + (SvFLAGS(origsv) & SVf_UTF8) | SVs_TEMP); + } + *MARK = copysv; + } + MARK = ORIGMARK; if (TAINTING_get) { TAINT_ENV(); - while (++MARK <= SP) { - (void)SvPV_nolen_const(*MARK); /* stringify for taint check */ - if (TAINT_get) - break; - } - MARK = ORIGMARK; TAINT_PROPER("system"); } PERL_FLUSHALL_FOR_CHILD; -#if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO) +#if (defined(HAS_FORK) || defined(__amigaos4__)) && !defined(VMS) && !defined(OS2) || defined(PERL_MICRO) { +#ifdef __amigaos4__ + struct UserData userdata; + pthread_t proc; +#else Pid_t childpid; +#endif int pp[2]; I32 did_pipes = 0; + bool child_success = FALSE; #ifdef HAS_SIGPROCMASK sigset_t newset, oldset; #endif - if (PerlProc_pipe(pp) >= 0) + if (PerlProc_pipe_cloexec(pp) >= 0) did_pipes = 1; +#ifdef __amigaos4__ + amigaos_fork_set_userdata(aTHX_ + &userdata, + did_pipes, + pp[1], + SP, + mark); + pthread_create(&proc,NULL,amigaos_system_child,(void *)&userdata); + child_success = proc > 0; +#else #ifdef HAS_SIGPROCMASK sigemptyset(&newset); sigaddset(&newset, SIGCHLD); @@ -4150,19 +4397,27 @@ PP(pp_system) } sleep(5); } - if (childpid > 0) { + child_success = childpid > 0; +#endif + if (child_success) { Sigsave_t ihand,qhand; /* place to save signals during system() */ int status; +#ifndef __amigaos4__ if (did_pipes) PerlLIO_close(pp[1]); +#endif #ifndef PERL_MICRO rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &ihand); rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qhand); #endif +#ifdef __amigaos4__ + result = pthread_join(proc, (void **)&status); +#else do { result = wait4pid(childpid, &status, 0); } while (result == -1 && errno == EINTR); +#endif #ifndef PERL_MICRO #ifdef HAS_SIGPROCMASK sigprocmask(SIG_SETMASK, &oldset, NULL); @@ -4171,15 +4426,13 @@ PP(pp_system) (void)rsignal_restore(SIGQUIT, &qhand); #endif STATUS_NATIVE_CHILD_SET(result == -1 ? -1 : status); - do_execfree(); /* free any memory child malloced on fork */ SP = ORIGMARK; if (did_pipes) { int errkid; unsigned n = 0; - SSize_t n1; while (n < sizeof(int)) { - n1 = PerlLIO_read(pp[0], + const SSize_t n1 = PerlLIO_read(pp[0], (void*)(((char*)&errkid)+n), (sizeof(int)) - n); if (n1 <= 0) @@ -4191,21 +4444,25 @@ PP(pp_system) if (n != sizeof(int)) DIE(aTHX_ "panic: kid popen errno read, n=%u", n); errno = errkid; /* Propagate errno from kid */ - STATUS_NATIVE_CHILD_SET(-1); +#ifdef __amigaos4__ + /* The pipe always has something in it + * so n alone is not enough. */ + if (errno > 0) +#endif + { + STATUS_NATIVE_CHILD_SET(-1); + } } } XPUSHi(STATUS_CURRENT); RETURN; } +#ifndef __amigaos4__ #ifdef HAS_SIGPROCMASK sigprocmask(SIG_SETMASK, &oldset, NULL); #endif - if (did_pipes) { + if (did_pipes) PerlLIO_close(pp[0]); -#if defined(HAS_FCNTL) && defined(F_SETFD) - fcntl(pp[1], F_SETFD, FD_CLOEXEC); -#endif - } if (PL_op->op_flags & OPf_STACKED) { SV * const really = *++MARK; value = (I32)do_aexec5(really, MARK, SP, pp[1], did_pipes); @@ -4215,6 +4472,7 @@ PP(pp_system) else { value = (I32)do_exec3(SvPVx_nolen(sv_mortalcopy(*SP)), pp[1], did_pipes); } +#endif /* __amigaos4__ */ PerlProc__exit(-1); } #else /* ! FORK or VMS or OS/2 */ @@ -4222,14 +4480,14 @@ PP(pp_system) result = 0; if (PL_op->op_flags & OPf_STACKED) { SV * const really = *++MARK; -# if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS) +# if defined(WIN32) || defined(OS2) || defined(__VMS) value = (I32)do_aspawn(really, MARK, SP); # else value = (I32)do_aspawn(really, (void **)MARK, (void **)SP); # endif } else if (SP - MARK != 1) { -# if defined(WIN32) || defined(OS2) || defined(__SYMBIAN32__) || defined(__VMS) +# if defined(WIN32) || defined(OS2) || defined(__VMS) value = (I32)do_aspawn(NULL, MARK, SP); # else value = (I32)do_aspawn(NULL, (void **)MARK, (void **)SP); @@ -4241,7 +4499,6 @@ PP(pp_system) if (PL_statusvalue == -1) /* hint that value must be returned as is */ result = 1; STATUS_NATIVE_CHILD_SET(value); - do_execfree(); SP = ORIGMARK; XPUSHi(result ? value : STATUS_CURRENT); #endif /* !FORK or VMS or OS/2 */ @@ -4251,7 +4508,7 @@ PP(pp_system) PP(pp_exec) { - dVAR; dSP; dMARK; dORIGMARK; dTARGET; + dSP; dMARK; dORIGMARK; dTARGET; I32 value; if (TAINTING_get) { @@ -4264,6 +4521,7 @@ PP(pp_exec) MARK = ORIGMARK; TAINT_PROPER("exec"); } + PERL_FLUSHALL_FOR_CHILD; if (PL_op->op_flags & OPf_STACKED) { SV * const really = *++MARK; @@ -4282,7 +4540,6 @@ PP(pp_exec) value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP))); #endif } - SP = ORIGMARK; XPUSHi(value); RETURN; @@ -4291,7 +4548,7 @@ PP(pp_exec) PP(pp_getppid) { #ifdef HAS_GETPPID - dVAR; dSP; dTARGET; + dSP; dTARGET; XPUSHi( getppid() ); RETURN; #else @@ -4302,7 +4559,7 @@ PP(pp_getppid) PP(pp_getpgrp) { #ifdef HAS_GETPGRP - dVAR; dSP; dTARGET; + dSP; dTARGET; Pid_t pgrp; const Pid_t pid = (MAXARG < 1) ? 0 : TOPs ? SvIVx(POPs) : ((void)POPs, 0); @@ -4317,21 +4574,22 @@ PP(pp_getpgrp) XPUSHi(pgrp); RETURN; #else - DIE(aTHX_ PL_no_func, "getpgrp()"); + DIE(aTHX_ PL_no_func, "getpgrp"); #endif } PP(pp_setpgrp) { #ifdef HAS_SETPGRP - dVAR; dSP; dTARGET; + dSP; dTARGET; Pid_t pgrp; Pid_t pid; pgrp = MAXARG == 2 && (TOPs||POPs) ? POPi : 0; - if (MAXARG > 0) pid = TOPs && TOPi; + if (MAXARG > 0) pid = TOPs ? TOPi : 0; else { pid = 0; - XPUSHi(-1); + EXTEND(SP,1); + SP++; } TAINT_PROPER("setpgrp"); @@ -4347,10 +4605,15 @@ PP(pp_setpgrp) #endif /* USE_BSDPGRP */ RETURN; #else - DIE(aTHX_ PL_no_func, "setpgrp()"); + DIE(aTHX_ PL_no_func, "setpgrp"); #endif } +/* + * The glibc headers typedef __priority_which_t to an enum under C, but + * under C++, it keeps it as int. -Wc++-compat doesn't know this, so we + * need to explicitly cast it to shut up the warning. + */ #if defined(__GLIBC__) && ((__GLIBC__ == 2 && __GLIBC_MINOR__ >= 3) || (__GLIBC__ > 2)) # define PRIORITY_WHICH_T(which) (__priority_which_t)which #else @@ -4360,20 +4623,20 @@ PP(pp_setpgrp) PP(pp_getpriority) { #ifdef HAS_GETPRIORITY - dVAR; dSP; dTARGET; + dSP; dTARGET; const int who = POPi; const int which = TOPi; SETi( getpriority(PRIORITY_WHICH_T(which), who) ); RETURN; #else - DIE(aTHX_ PL_no_func, "getpriority()"); + DIE(aTHX_ PL_no_func, "getpriority"); #endif } PP(pp_setpriority) { #ifdef HAS_SETPRIORITY - dVAR; dSP; dTARGET; + dSP; dTARGET; const int niceval = POPi; const int who = POPi; const int which = TOPi; @@ -4381,7 +4644,7 @@ PP(pp_setpriority) SETi( setpriority(PRIORITY_WHICH_T(which), who, niceval) >= 0 ); RETURN; #else - DIE(aTHX_ PL_no_func, "setpriority()"); + DIE(aTHX_ PL_no_func, "setpriority"); #endif } @@ -4391,11 +4654,11 @@ PP(pp_setpriority) PP(pp_time) { - dVAR; dSP; dTARGET; + dSP; dTARGET; #ifdef BIG_TIME - XPUSHn( time(NULL) ); + XPUSHn( (NV)time(NULL) ); #else - XPUSHi( time(NULL) ); + XPUSHu( (UV)time(NULL) ); #endif RETURN; } @@ -4403,38 +4666,31 @@ PP(pp_time) PP(pp_tms) { #ifdef HAS_TIMES - dVAR; dSP; + struct tms timesbuf; + EXTEND(SP, 4); -#ifndef VMS - (void)PerlProc_times(&PL_timesbuf); -#else - (void)PerlProc_times((tbuffer_t *)&PL_timesbuf); /* time.h uses different name for */ - /* struct tms, though same data */ - /* is returned. */ -#endif + (void)PerlProc_times(×buf); - mPUSHn(((NV)PL_timesbuf.tms_utime)/(NV)PL_clocktick); - if (GIMME == G_ARRAY) { - mPUSHn(((NV)PL_timesbuf.tms_stime)/(NV)PL_clocktick); - mPUSHn(((NV)PL_timesbuf.tms_cutime)/(NV)PL_clocktick); - mPUSHn(((NV)PL_timesbuf.tms_cstime)/(NV)PL_clocktick); + mPUSHn(((NV)timesbuf.tms_utime)/(NV)PL_clocktick); + if (GIMME_V == G_ARRAY) { + mPUSHn(((NV)timesbuf.tms_stime)/(NV)PL_clocktick); + mPUSHn(((NV)timesbuf.tms_cutime)/(NV)PL_clocktick); + mPUSHn(((NV)timesbuf.tms_cstime)/(NV)PL_clocktick); } RETURN; -#else -# ifdef PERL_MICRO +#elif defined(PERL_MICRO) dSP; mPUSHn(0.0); EXTEND(SP, 4); - if (GIMME == G_ARRAY) { + if (GIMME_V == G_ARRAY) { mPUSHn(0.0); mPUSHn(0.0); mPUSHn(0.0); } RETURN; -# else +#else DIE(aTHX_ "times not implemented"); -# endif #endif /* HAS_TIMES */ } @@ -4447,9 +4703,11 @@ PP(pp_tms) /* Sun Dec 29 12:00:00 2147483647 */ #define TIME_UPPER_BOUND 67767976233316800.0 + +/* also used for: pp_localtime() */ + PP(pp_gmtime) { - dVAR; dSP; Time64_T when; struct TM tmbuf; @@ -4468,11 +4726,16 @@ PP(pp_gmtime) } else { NV input = Perl_floor(POPn); + const bool pl_isnan = Perl_isnan(input); when = (Time64_T)input; - if (when != input) { + if (UNLIKELY(pl_isnan || when != input)) { /* diag_listed_as: gmtime(%f) too large */ Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), "%s(%.0" NVff ") too large", opname, input); + if (pl_isnan) { + err = NULL; + goto failed; + } } } @@ -4490,36 +4753,35 @@ PP(pp_gmtime) } else { if (PL_op->op_type == OP_LOCALTIME) - err = S_localtime64_r(&when, &tmbuf); + err = Perl_localtime64_r(&when, &tmbuf); else - err = S_gmtime64_r(&when, &tmbuf); + err = Perl_gmtime64_r(&when, &tmbuf); } if (err == NULL) { + /* diag_listed_as: gmtime(%f) failed */ /* XXX %lld broken for quads */ + failed: Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), "%s(%.0" NVff ") failed", opname, when); } - if (GIMME != G_ARRAY) { /* scalar context */ - SV *tsv; - /* XXX newSVpvf()'s %lld type is broken, so cheat with a double */ - double year = (double)tmbuf.tm_year + 1900; - + if (GIMME_V != G_ARRAY) { /* scalar context */ EXTEND(SP, 1); - EXTEND_MORTAL(1); if (err == NULL) RETPUSHUNDEF; - - tsv = Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %.0f", - dayname[tmbuf.tm_wday], - monname[tmbuf.tm_mon], - tmbuf.tm_mday, - tmbuf.tm_hour, - tmbuf.tm_min, - tmbuf.tm_sec, - year); - mPUSHs(tsv); + else { + dTARGET; + PUSHs(TARG); + Perl_sv_setpvf_mg(aTHX_ TARG, "%s %s %2d %02d:%02d:%02d %" IVdf, + dayname[tmbuf.tm_wday], + monname[tmbuf.tm_mon], + tmbuf.tm_mday, + tmbuf.tm_hour, + tmbuf.tm_min, + tmbuf.tm_sec, + (IV)tmbuf.tm_year + 1900); + } } else { /* list context */ if ( err == NULL ) @@ -4543,14 +4805,31 @@ PP(pp_gmtime) PP(pp_alarm) { #ifdef HAS_ALARM - dVAR; dSP; dTARGET; - int anum; - anum = POPi; - anum = alarm((unsigned int)anum); - if (anum < 0) - RETPUSHUNDEF; - PUSHi(anum); - RETURN; + dSP; dTARGET; + /* alarm() takes an unsigned int number of seconds, and return the + * unsigned int number of seconds remaining in the previous alarm + * (alarms don't stack). Therefore negative return values are not + * possible. */ + int anum = POPi; + if (anum < 0) { + /* Note that while the C library function alarm() as such has + * no errors defined (or in other words, properly behaving client + * code shouldn't expect any), alarm() being obsoleted by + * setitimer() and often being implemented in terms of + * setitimer(), can fail. */ + /* diag_listed_as: %s() with negative argument */ + Perl_ck_warner_d(aTHX_ packWARN(WARN_MISC), + "alarm() with negative argument"); + SETERRNO(EINVAL, LIB_INVARG); + RETPUSHUNDEF; + } + else { + unsigned int retval = alarm(anum); + if ((int)retval < 0) /* Strictly speaking "cannot happen". */ + RETPUSHUNDEF; + PUSHu(retval); + RETURN; + } #else DIE(aTHX_ PL_no_func, "alarm"); #endif @@ -4558,8 +4837,7 @@ PP(pp_alarm) PP(pp_sleep) { - dVAR; dSP; dTARGET; - I32 duration; + dSP; dTARGET; Time_t lasttime; Time_t when; @@ -4567,21 +4845,32 @@ PP(pp_sleep) if (MAXARG < 1 || (!TOPs && !POPs)) PerlProc_pause(); else { - duration = POPi; - PerlProc_sleep((unsigned int)duration); + const I32 duration = POPi; + if (duration < 0) { + /* diag_listed_as: %s() with negative argument */ + Perl_ck_warner_d(aTHX_ packWARN(WARN_MISC), + "sleep() with negative argument"); + SETERRNO(EINVAL, LIB_INVARG); + XPUSHs(&PL_sv_zero); + RETURN; + } else { + PerlProc_sleep((unsigned int)duration); + } } (void)time(&when); - XPUSHi(when - lasttime); + XPUSHu((UV)(when - lasttime)); RETURN; } /* Shared memory. */ /* Merged with some message passing. */ +/* also used for: pp_msgrcv() pp_msgsnd() pp_semop() pp_shmread() */ + PP(pp_shmwrite) { #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) - dVAR; dSP; dMARK; dTARGET; + dSP; dMARK; dTARGET; const int op_type = PL_op->op_type; I32 value; @@ -4610,10 +4899,12 @@ PP(pp_shmwrite) /* Semaphores. */ +/* also used for: pp_msgget() pp_shmget() */ + PP(pp_semget) { #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) - dVAR; dSP; dMARK; dTARGET; + dSP; dMARK; dTARGET; const int anum = do_ipcget(PL_op->op_type, MARK, SP); SP = MARK; if (anum == -1) @@ -4625,14 +4916,16 @@ PP(pp_semget) #endif } +/* also used for: pp_msgctl() pp_shmctl() */ + PP(pp_semctl) { #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) - dVAR; dSP; dMARK; dTARGET; + dSP; dMARK; dTARGET; const int anum = do_ipcctl(PL_op->op_type, MARK, SP); SP = MARK; if (anum == -1) - RETSETUNDEF; + RETPUSHUNDEF; if (anum != 0) { PUSHi(anum); } @@ -4652,8 +4945,6 @@ S_space_join_names_mortal(pTHX_ char *const *array) { SV *target; - PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL; - if (array && *array) { target = newSVpvs_flags("", SVs_TEMP); while (1) { @@ -4670,10 +4961,12 @@ S_space_join_names_mortal(pTHX_ char *const *array) /* Get system info. */ +/* also used for: pp_ghbyaddr() pp_ghbyname() */ + PP(pp_ghostent) { #if defined(HAS_GETHOSTBYNAME) || defined(HAS_GETHOSTBYADDR) || defined(HAS_GETHOSTENT) - dVAR; dSP; + dSP; I32 which = PL_op->op_type; char **elem; SV *sv; @@ -4724,7 +5017,7 @@ PP(pp_ghostent) } #endif - if (GIMME != G_ARRAY) { + if (GIMME_V != G_ARRAY) { PUSHs(sv = sv_newmortal()); if (hent) { if (which == OP_GHBYNAME) { @@ -4760,10 +5053,12 @@ PP(pp_ghostent) #endif } +/* also used for: pp_gnbyaddr() pp_gnbyname() */ + PP(pp_gnetent) { #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT) - dVAR; dSP; + dSP; I32 which = PL_op->op_type; SV *sv; #ifndef HAS_GETNET_PROTOS /* XXX Do we need individual probes? */ @@ -4809,7 +5104,7 @@ PP(pp_gnetent) #endif EXTEND(SP, 4); - if (GIMME != G_ARRAY) { + if (GIMME_V != G_ARRAY) { PUSHs(sv = sv_newmortal()); if (nent) { if (which == OP_GNBYNAME) @@ -4833,10 +5128,13 @@ PP(pp_gnetent) #endif } + +/* also used for: pp_gpbyname() pp_gpbynumber() */ + PP(pp_gprotoent) { #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT) - dVAR; dSP; + dSP; I32 which = PL_op->op_type; SV *sv; #ifndef HAS_GETPROTO_PROTOS /* XXX Do we need individual probes? */ @@ -4870,7 +5168,7 @@ PP(pp_gprotoent) #endif EXTEND(SP, 3); - if (GIMME != G_ARRAY) { + if (GIMME_V != G_ARRAY) { PUSHs(sv = sv_newmortal()); if (pent) { if (which == OP_GPBYNAME) @@ -4893,10 +5191,13 @@ PP(pp_gprotoent) #endif } + +/* also used for: pp_gsbyname() pp_gsbyport() */ + PP(pp_gservent) { #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT) - dVAR; dSP; + dSP; I32 which = PL_op->op_type; SV *sv; #ifndef HAS_GETSERV_PROTOS /* XXX Do we need individual probes? */ @@ -4933,7 +5234,7 @@ PP(pp_gservent) #endif EXTEND(SP, 4); - if (GIMME != G_ARRAY) { + if (GIMME_V != G_ARRAY) { PUSHs(sv = sv_newmortal()); if (sent) { if (which == OP_GSBYNAME) { @@ -4958,9 +5259,12 @@ PP(pp_gservent) #endif } + +/* also used for: pp_snetent() pp_sprotoent() pp_sservent() */ + PP(pp_shostent) { - dVAR; dSP; + dSP; const int stayopen = TOPi; switch(PL_op->op_type) { case OP_SHOSTENT: @@ -4970,8 +5274,8 @@ PP(pp_shostent) DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); #endif break; -#ifdef HAS_SETNETENT case OP_SNETENT: +#ifdef HAS_SETNETENT PerlSock_setnetent(stayopen); #else DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]); @@ -4995,9 +5299,13 @@ PP(pp_shostent) RETSETYES; } + +/* also used for: pp_egrent() pp_enetent() pp_eprotoent() pp_epwent() + * pp_eservent() pp_sgrent() pp_spwent() */ + PP(pp_ehostent) { - dVAR; dSP; + dSP; switch(PL_op->op_type) { case OP_EHOSTENT: #ifdef HAS_ENDHOSTENT @@ -5060,10 +5368,13 @@ PP(pp_ehostent) RETPUSHYES; } + +/* also used for: pp_gpwnam() pp_gpwuid() */ + PP(pp_gpwent) { #ifdef HAS_PASSWD - dVAR; dSP; + dSP; I32 which = PL_op->op_type; SV *sv; struct passwd *pwent = NULL; @@ -5116,7 +5427,7 @@ PP(pp_gpwent) * it is only included in special cases. * * In Digital UNIX/Tru64 if using the getespw*() (which seems to be - * be preferred interface, even though also the getprpw*() interface + * the preferred interface, even though also the getprpw*() interface * is available) one needs to link with -lsecurity -ldb -laud -lm. * One also needs to call set_auth_parameters() in main() before * doing anything else, whether one is using getespw*() or getprpw*(). @@ -5159,7 +5470,7 @@ PP(pp_gpwent) } EXTEND(SP, 10); - if (GIMME != G_ARRAY) { + if (GIMME_V != G_ARRAY) { PUSHs(sv = sv_newmortal()); if (pwent) { if (which == OP_GPWNAM) @@ -5225,30 +5536,24 @@ PP(pp_gpwent) * but we are accursed by our history, alas. --jhi. */ # ifdef PWCHANGE mPUSHi(pwent->pw_change); -# else -# ifdef PWQUOTA +# elif defined(PWQUOTA) mPUSHi(pwent->pw_quota); -# else -# ifdef PWAGE +# elif defined(PWAGE) mPUSHs(newSVpv(pwent->pw_age, 0)); -# else +# else /* I think that you can never get this compiled, but just in case. */ PUSHs(sv_mortalcopy(&PL_sv_no)); -# endif -# endif # endif /* pw_class and pw_comment are mutually exclusive--. * see the above note for pw_change, pw_quota, and pw_age. */ # ifdef PWCLASS mPUSHs(newSVpv(pwent->pw_class, 0)); -# else -# ifdef PWCOMMENT +# elif defined(PWCOMMENT) mPUSHs(newSVpv(pwent->pw_comment, 0)); -# else +# else /* I think that you can never get this compiled, but just in case. */ PUSHs(sv_mortalcopy(&PL_sv_no)); -# endif # endif # ifdef PWGECOS @@ -5275,10 +5580,13 @@ PP(pp_gpwent) #endif } + +/* also used for: pp_ggrgid() pp_ggrnam() */ + PP(pp_ggrent) { #ifdef HAS_GROUP - dVAR; dSP; + dSP; const I32 which = PL_op->op_type; const struct group *grent; @@ -5287,7 +5595,13 @@ PP(pp_ggrent) grent = (const struct group *)getgrnam(name); } else if (which == OP_GGRGID) { +#if Gid_t_sign == 1 + const Gid_t gid = POPu; +#elif Gid_t_sign == -1 const Gid_t gid = POPi; +#else +# error "Unexpected Gid_t_sign" +#endif grent = (const struct group *)getgrgid(gid); } else @@ -5298,7 +5612,7 @@ PP(pp_ggrent) #endif EXTEND(SP, 4); - if (GIMME != G_ARRAY) { + if (GIMME_V != G_ARRAY) { SV * const sv = sv_newmortal(); PUSHs(sv); @@ -5344,7 +5658,7 @@ PP(pp_ggrent) PP(pp_getlogin) { #ifdef HAS_GETLOGIN - dVAR; dSP; dTARGET; + dSP; dTARGET; char *tmps; EXTEND(SP, 1); if (!(tmps = PerlProc_getlogin())) @@ -5362,7 +5676,7 @@ PP(pp_getlogin) PP(pp_syscall) { #ifdef HAS_SYSCALL - dVAR; dSP; dMARK; dORIGMARK; dTARGET; + dSP; dMARK; dORIGMARK; dTARGET; I32 items = SP - MARK; unsigned long a[20]; I32 i = 0; @@ -5553,11 +5867,5 @@ lockf_emulate_flock(int fd, int operation) #endif /* LOCKF_EMULATE_FLOCK */ /* - * Local variables: - * c-indentation-style: bsd - * c-basic-offset: 4 - * indent-tabs-mode: nil - * End: - * * ex: set ts=8 sts=4 sw=4 et: */