X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/375ed12a42c6092b1af1d8e395bf3dadd9a66e48..dc83bf8e644104953efa0f771ec775aba638af5a:/pp_sys.c diff --git a/pp_sys.c b/pp_sys.c index 1ee3ba2..dc1b3ce 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 @@ -179,10 +178,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__ @@ -295,7 +290,7 @@ 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; @@ -356,7 +351,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 +410,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) { @@ -472,7 +465,7 @@ PP(pp_warn) PP(pp_die) { - dVAR; dSP; dMARK; + dSP; dMARK; SV *exsv; STRLEN len; #ifdef VMS @@ -523,7 +516,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. */ @@ -538,9 +533,9 @@ Perl_tied_method(pTHX_ SV *methname, SV **sp, SV *const sv, 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); @@ -597,7 +592,7 @@ Perl_tied_method(pTHX_ SV *methname, SV **sp, SV *const sv, PP(pp_open) { - dVAR; dSP; + dSP; dMARK; dORIGMARK; dTARGET; SV *sv; @@ -651,7 +646,7 @@ PP(pp_open) PP(pp_close) { - dVAR; dSP; + dSP; GV * const gv = MAXARG == 0 || (!TOPs && !POPs) ? PL_defoutgv : MUTABLE_GV(POPs); @@ -674,7 +669,6 @@ PP(pp_close) PP(pp_pipe_op) { #ifdef HAS_PIPE - dVAR; dSP; IO *rstio; IO *wstio; @@ -722,7 +716,7 @@ PP(pp_pipe_op) #endif RETPUSHYES; -badexit: + badexit: RETPUSHUNDEF; #else DIE(aTHX_ PL_no_func, "pipe"); @@ -731,7 +725,7 @@ badexit: PP(pp_fileno) { - dVAR; dSP; dTARGET; + dSP; dTARGET; GV *gv; IO *io; PerlIO *fp; @@ -748,6 +742,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. @@ -763,7 +773,6 @@ PP(pp_fileno) PP(pp_umask) { - dVAR; dSP; #ifdef HAS_UMASK dTARGET; @@ -794,7 +803,7 @@ PP(pp_umask) PP(pp_binmode) { - dVAR; dSP; + dSP; GV *gv; IO *io; PerlIO *fp; @@ -855,7 +864,7 @@ PP(pp_binmode) PP(pp_tie) { - dVAR; dSP; dMARK; + dSP; dMARK; HV* stash; GV *gv = NULL; SV *sv; @@ -903,7 +912,7 @@ PP(pp_tie) vivify_defelem(varsv); varsv = LvTARG(varsv); } - /* FALL THROUGH */ + /* FALLTHROUGH */ default: methname = "TIESCALAR"; how = PERL_MAGIC_tiedscalar; @@ -960,9 +969,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) @@ -1002,29 +1014,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; @@ -1068,9 +1081,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); } @@ -1081,7 +1096,7 @@ PP(pp_dbmopen) PP(pp_sselect) { #ifdef HAS_SELECT - dVAR; dSP; dTARGET; + dSP; dTARGET; I32 i; I32 j; char *s; @@ -1153,7 +1168,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 @@ -1233,7 +1248,7 @@ PP(pp_sselect) } 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); @@ -1245,6 +1260,9 @@ PP(pp_sselect) } /* + +=head1 GV Functions + =for apidoc setdefout Sets PL_defoutgv, the default file handle for output, to the passed in @@ -1258,7 +1276,6 @@ of the typeglob that PL_defoutgv points to is decreased by one. void Perl_setdefout(pTHX_ GV *gv) { - dVAR; PERL_ARGS_ASSERT_SETDEFOUT; SvREFCNT_inc_simple_void_NN(gv); SvREFCNT_dec(PL_defoutgv); @@ -1267,7 +1284,7 @@ Perl_setdefout(pTHX_ GV *gv) 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); @@ -1298,7 +1315,7 @@ PP(pp_select) PP(pp_getc) { - dVAR; dSP; dTARGET; + dSP; dTARGET; GV * const gv = MAXARG==0 || (!TOPs && !POPs) ? PL_stdingv : MUTABLE_GV(POPs); IO *const io = GvIO(gv); @@ -1345,7 +1362,6 @@ PP(pp_getc) STATIC OP * S_doform(pTHX_ CV *cv, GV *gv, OP *retop) { - dVAR; PERL_CONTEXT *cx; const I32 gimme = GIMME_V; @@ -1372,7 +1388,6 @@ S_doform(pTHX_ CV *cv, GV *gv, OP *retop) PP(pp_enterwrite) { - dVAR; dSP; GV *gv; IO *io; @@ -1412,7 +1427,7 @@ PP(pp_enterwrite) PP(pp_leavewrite) { - dVAR; dSP; + dSP; GV * const gv = cxstack[cxstack_ix].blk_format.gv; IO * const io = GvIOp(gv); PerlIO *ofp; @@ -1421,8 +1436,9 @@ PP(pp_leavewrite) 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", @@ -1500,7 +1516,13 @@ PP(pp_leavewrite) SP = newsp; /* ignore retval of formline */ LEAVE; - 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 @@ -1529,7 +1551,7 @@ PP(pp_leavewrite) PP(pp_prtf) { - dVAR; dSP; dMARK; dORIGMARK; + dSP; dMARK; dORIGMARK; PerlIO *fp; GV * const gv @@ -1590,7 +1612,6 @@ PP(pp_prtf) PP(pp_sysopen) { - dVAR; dSP; const int perm = (MAXARG > 3 && (TOPs || POPs)) ? POPi : 0666; const int mode = POPi; @@ -1610,9 +1631,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; @@ -1667,6 +1691,11 @@ PP(pp_sysread) 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_ck_warner(aTHX_ packWARN(WARN_DEPRECATED), + "%s() is deprecated 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); @@ -1756,7 +1785,7 @@ PP(pp_sysread) 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); @@ -1866,9 +1895,12 @@ 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; @@ -1923,6 +1955,9 @@ PP(pp_syswrite) doing_utf8 = DO_UTF8(bufsv); if (PerlIO_isutf8(IoIFP(io))) { + Perl_ck_warner(aTHX_ packWARN(WARN_DEPRECATED), + "%s() is deprecated on :utf8 handles", + OP_DESC(PL_op)); if (!SvUTF8(bufsv)) { /* We don't modify the original scalar. */ tmpbuf = bytes_to_utf8((const U8*) buffer, &blen); @@ -2069,7 +2104,7 @@ PP(pp_syswrite) PP(pp_eof) { - dVAR; dSP; + dSP; GV *gv; IO *io; const MAGIC *mg; @@ -2112,16 +2147,20 @@ PP(pp_eof) if (!MAXARG && (PL_op->op_flags & OPf_SPECIAL)) { /* eof() */ if (io && !IoIFP(io)) { if ((IoFLAGS(io) & IOf_START) && av_tindex(GvAVn(gv)) < 0) { + SV ** svp; IoLINES(io) = 0; IoFLAGS(io) &= ~IOf_START; do_open6(gv, "-", 1, NULL, NULL, 0); - if (GvSV(gv)) - sv_setpvs(GvSV(gv), "-"); + 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; } } @@ -2132,7 +2171,7 @@ PP(pp_eof) PP(pp_tell) { - dVAR; dSP; dTARGET; + dSP; dTARGET; GV *gv; IO *io; @@ -2164,9 +2203,12 @@ PP(pp_tell) 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); @@ -2213,7 +2255,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 @@ -2256,13 +2297,18 @@ PP(pp_truncate) SETERRNO(EBADF,RMS_IFI); result = 0; } else { - PerlIO_flush(fp); + if (len < 0) { + SETERRNO(EINVAL, LIB_INVARG); + result = 0; + } else { + PerlIO_flush(fp); #ifdef HAS_TRUNCATE - if (ftruncate(fd, len) < 0) + if (ftruncate(fd, len) < 0) #else - if (my_chsize(fd, len) < 0) + if (my_chsize(fd, len) < 0) #endif - result = 0; + result = 0; + } } } } @@ -2279,10 +2325,22 @@ PP(pp_truncate) result = 0; #else { - const int tmpfd = PerlLIO_open(name, O_RDWR); + int mode = O_RDWR; + int tmpfd; + +#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(name, mode); if (tmpfd < 0) { - SETERRNO(EBADF,RMS_IFI); result = 0; } else { if (my_chsize(tmpfd, len) < 0) @@ -2301,9 +2359,12 @@ 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; int optype; @@ -2379,7 +2440,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); @@ -2399,7 +2460,7 @@ PP(pp_flock) PUSHi(value); RETURN; #else - DIE(aTHX_ PL_no_func, "flock()"); + DIE(aTHX_ PL_no_func, "flock"); #endif } @@ -2409,7 +2470,7 @@ PP(pp_flock) PP(pp_socket) { - dVAR; dSP; + dSP; const int protocol = POPi; const int type = POPi; const int domain = POPi; @@ -2447,7 +2508,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; @@ -2496,9 +2557,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; @@ -2525,7 +2588,7 @@ PP(pp_bind) else RETPUSHUNDEF; -nuts: + nuts: report_evil_fh(gv); SETERRNO(EBADF,SS_IVCHAN); RETPUSHUNDEF; @@ -2533,7 +2596,7 @@ nuts: PP(pp_listen) { - dVAR; dSP; + dSP; const int backlog = POPi; GV * const gv = MUTABLE_GV(POPs); IO * const io = GvIOn(gv); @@ -2546,7 +2609,7 @@ PP(pp_listen) else RETPUSHUNDEF; -nuts: + nuts: report_evil_fh(gv); SETERRNO(EBADF,SS_IVCHAN); RETPUSHUNDEF; @@ -2554,7 +2617,7 @@ nuts: PP(pp_accept) { - dVAR; dSP; dTARGET; + dSP; dTARGET; IO *nstio; char namebuf[MAXPATHLEN]; #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__) @@ -2608,18 +2671,18 @@ 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); @@ -2630,15 +2693,18 @@ PP(pp_shutdown) 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; @@ -2663,6 +2729,11 @@ 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); @@ -2702,17 +2773,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); @@ -2763,10 +2837,10 @@ PP(pp_getpeername) PUSHs(sv); RETURN; -nuts: + nuts: report_evil_fh(gv); SETERRNO(EBADF,SS_IVCHAN); -nuts2: + nuts2: RETPUSHUNDEF; } @@ -2774,9 +2848,10 @@ nuts2: /* Stat calls. */ +/* also used for: pp_lstat() */ + PP(pp_stat) { - dVAR; dSP; GV *gv = NULL; IO *io = NULL; @@ -2976,7 +3051,6 @@ 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 != '?'); @@ -2999,12 +3073,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. */ @@ -3063,7 +3139,7 @@ PP(pp_ftrread) access_mode = W_OK; #endif stat_mode = S_IWUSR; - /* fall through */ + /* FALLTHROUGH */ case OP_FTEREAD: #ifndef PERL_EFF_ACCESS @@ -3117,9 +3193,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 = '?'; @@ -3169,9 +3247,13 @@ PP(pp_ftis) } } + +/* 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 = '?'; @@ -3273,7 +3355,6 @@ PP(pp_ftrowned) PP(pp_ftlink) { - dVAR; I32 result; tryAMAGICftest_MG('l'); @@ -3288,11 +3369,11 @@ PP(pp_ftlink) PP(pp_fttty) { - dVAR; int fd; GV *gv; char *name = NULL; STRLEN namelen; + UV uv; tryAMAGICftest_MG('t'); @@ -3308,8 +3389,8 @@ 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 FT_RETURNUNDEF; if (fd < 0) { @@ -3321,9 +3402,11 @@ PP(pp_fttty) FT_RETURNNO; } + +/* also used for: pp_ftbinary() */ + PP(pp_fttext) { - dVAR; I32 i; SSize_t len; I32 odd = 0; @@ -3406,6 +3489,7 @@ PP(pp_fttext) const char *file; int fd; + assert(sv); sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv)); really_filename: file = SvPVX_const(PL_statname); @@ -3448,7 +3532,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 */ @@ -3456,43 +3539,53 @@ PP(pp_fttext) --len; #endif + assert(len); + if (! is_invariant_string((U8 *) s, len)) { + const U8 *ep; + + /* Here contains a variant under UTF-8 . See if the entire string is + * UTF-8. But the buffer may end in a partial character, so consider + * it UTF-8 if the first non-UTF8 char is an ending partial */ + if (is_utf8_string_loc((U8 *) s, len, &ep) + || ep + UTF8SKIP(ep) > (U8 *) (s + len)) + { + 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 */ @@ -3505,7 +3598,7 @@ PP(pp_fttext) PP(pp_chdir) { - dVAR; dSP; dTARGET; + dSP; dTARGET; const char *tmps = NULL; GV *gv = NULL; @@ -3513,12 +3606,21 @@ 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); + PUSHi(0); + 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; @@ -3529,12 +3631,11 @@ PP(pp_chdir) #endif ) { - if( MAXARG == 1 ) - deprecate("chdir('') or chdir(undef) as chdir()"); tmps = SvPV_nolen_const(*svp); } else { PUSHi(0); + SETERRNO(EINVAL, LIB_INVARG); TAINT_PROPER("chdir"); RETURN; } @@ -3574,16 +3675,21 @@ PP(pp_chdir) #endif RETURN; +#ifdef HAS_FCHDIR nuts: report_evil_fh(gv); SETERRNO(EBADF,RMS_IFI); PUSHi(0); 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; @@ -3594,7 +3700,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 ); @@ -3606,7 +3712,7 @@ PP(pp_chroot) PP(pp_rename) { - dVAR; dSP; dTARGET; + dSP; dTARGET; int anum; const char * const tmps2 = POPpconstx; const char * const tmps = SvPV_nolen_const(TOPs); @@ -3629,10 +3735,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; @@ -3671,6 +3780,9 @@ PP(pp_link) RETURN; } #else + +/* also used for: pp_symlink() */ + PP(pp_link) { /* Have neither. */ @@ -3680,19 +3792,22 @@ 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; + /* NOTE: if the length returned by readlink() is sizeof(buf) - 1, + * it is impossible to know whether the result was truncated. */ len = readlink(tmps, buf, sizeof(buf) - 1); if (len < 0) RETPUSHUNDEF; + if (len != -1) + buf[len] = '\0'; PUSHp(buf, len); RETURN; #else @@ -3808,11 +3923,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); @@ -3835,7 +3950,7 @@ PP(pp_mkdir) PP(pp_rmdir) { - dVAR; dSP; dTARGET; + dSP; dTARGET; STRLEN len; const char *tmps; bool copy = FALSE; @@ -3857,7 +3972,7 @@ 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); @@ -3872,7 +3987,7 @@ PP(pp_open_dir) goto nope; RETPUSHYES; -nope: + nope: if (!errno) SETERRNO(EBADF,RMS_DIR); RETPUSHUNDEF; @@ -3889,11 +4004,10 @@ PP(pp_readdir) #if !defined(I_DIRENT) && !defined(VMS) Direntry_t *readdir (DIR *); #endif - dVAR; dSP; SV *sv; - const I32 gimme = GIMME; + const I32 gimme = GIMME_V; GV * const gv = MUTABLE_GV(POPs); const Direntry_t *dp; IO * const io = GvIOn(gv); @@ -3924,10 +4038,10 @@ PP(pp_readdir) RETURN; -nope: + nope: if (!errno) SETERRNO(EBADF,RMS_ISI); - if (GIMME == G_ARRAY) + if (gimme == G_ARRAY) RETURN; else RETPUSHUNDEF; @@ -3937,7 +4051,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. @@ -3957,7 +4071,7 @@ PP(pp_telldir) PUSHi( PerlDir_tell(IoDIRP(io)) ); RETURN; -nope: + nope: if (!errno) SETERRNO(EBADF,RMS_ISI); RETPUSHUNDEF; @@ -3969,7 +4083,7 @@ 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); @@ -3983,7 +4097,7 @@ PP(pp_seekdir) (void)PerlDir_seek(IoDIRP(io), along); RETPUSHYES; -nope: + nope: if (!errno) SETERRNO(EBADF,RMS_ISI); RETPUSHUNDEF; @@ -3995,7 +4109,7 @@ nope: PP(pp_rewinddir) { #if defined(HAS_REWINDDIR) || defined(rewinddir) - dVAR; dSP; + dSP; GV * const gv = MUTABLE_GV(POPs); IO * const io = GvIOn(gv); @@ -4007,7 +4121,7 @@ PP(pp_rewinddir) } (void)PerlDir_rewind(IoDIRP(io)); RETPUSHYES; -nope: + nope: if (!errno) SETERRNO(EBADF,RMS_ISI); RETPUSHUNDEF; @@ -4019,7 +4133,7 @@ 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); @@ -4040,7 +4154,7 @@ PP(pp_closedir) IoDIRP(io) = 0; RETPUSHYES; -nope: + nope: if (!errno) SETERRNO(EBADF,RMS_IFI); RETPUSHUNDEF; @@ -4054,7 +4168,7 @@ nope: PP(pp_fork) { #ifdef HAS_FORK - dVAR; dSP; dTARGET; + dSP; dTARGET; Pid_t childpid; #ifdef HAS_SIGPROCMASK sigset_t oldmask, newmask; @@ -4111,7 +4225,7 @@ PP(pp_fork) PP(pp_wait) { #if (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(__LIBCATAMOUNT__) - dVAR; dSP; dTARGET; + dSP; dTARGET; Pid_t childpid; int argflags; @@ -4139,7 +4253,7 @@ 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; @@ -4168,7 +4282,7 @@ PP(pp_waitpid) PP(pp_system) { - dVAR; dSP; dMARK; dORIGMARK; dTARGET; + dSP; dMARK; dORIGMARK; dTARGET; #if defined(__LIBCATAMOUNT__) PL_statusvalue = -1; SP = ORIGMARK; @@ -4322,7 +4436,7 @@ PP(pp_system) PP(pp_exec) { - dVAR; dSP; dMARK; dORIGMARK; dTARGET; + dSP; dMARK; dORIGMARK; dTARGET; I32 value; if (TAINTING_get) { @@ -4362,7 +4476,7 @@ PP(pp_exec) PP(pp_getppid) { #ifdef HAS_GETPPID - dVAR; dSP; dTARGET; + dSP; dTARGET; XPUSHi( getppid() ); RETURN; #else @@ -4373,7 +4487,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); @@ -4388,21 +4502,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"); @@ -4418,7 +4533,7 @@ PP(pp_setpgrp) #endif /* USE_BSDPGRP */ RETURN; #else - DIE(aTHX_ PL_no_func, "setpgrp()"); + DIE(aTHX_ PL_no_func, "setpgrp"); #endif } @@ -4431,20 +4546,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; @@ -4452,7 +4567,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 } @@ -4462,7 +4577,7 @@ PP(pp_setpriority) PP(pp_time) { - dVAR; dSP; dTARGET; + dSP; dTARGET; #ifdef BIG_TIME XPUSHn( time(NULL) ); #else @@ -4474,7 +4589,6 @@ PP(pp_time) PP(pp_tms) { #ifdef HAS_TIMES - dVAR; dSP; struct tms timesbuf; @@ -4482,7 +4596,7 @@ PP(pp_tms) (void)PerlProc_times(×buf); mPUSHn(((NV)timesbuf.tms_utime)/(NV)PL_clocktick); - if (GIMME == G_ARRAY) { + 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); @@ -4493,7 +4607,7 @@ PP(pp_tms) 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); @@ -4514,9 +4628,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; @@ -4535,11 +4651,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; + } } } @@ -4557,34 +4678,34 @@ 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 */ + if (GIMME_V != G_ARRAY) { /* scalar context */ EXTEND(SP, 1); - EXTEND_MORTAL(1); if (err == NULL) RETPUSHUNDEF; else { - mPUSHs(Perl_newSVpvf(aTHX_ "%s %s %2d %02d:%02d:%02d %.0f", + 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, - /* XXX newSVpvf()'s %lld type is broken, - * so cheat with a double */ - (double)tmbuf.tm_year + 1900)); + (IV)tmbuf.tm_year + 1900); } } else { /* list context */ @@ -4609,14 +4730,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 @@ -4624,7 +4762,7 @@ PP(pp_alarm) PP(pp_sleep) { - dVAR; dSP; dTARGET; + dSP; dTARGET; I32 duration; Time_t lasttime; Time_t when; @@ -4634,7 +4772,16 @@ PP(pp_sleep) PerlProc_pause(); else { duration = POPi; - PerlProc_sleep((unsigned int)duration); + 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); + XPUSHi(0); + RETURN; + } else { + PerlProc_sleep((unsigned int)duration); + } } (void)time(&when); XPUSHi(when - lasttime); @@ -4644,10 +4791,12 @@ PP(pp_sleep) /* 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; @@ -4676,10 +4825,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) @@ -4691,14 +4842,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); } @@ -4720,7 +4873,7 @@ S_space_join_names_mortal(pTHX_ char *const *array) PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL; - if (array && *array) { + if (*array) { target = newSVpvs_flags("", SVs_TEMP); while (1) { sv_catpv(target, *array); @@ -4736,10 +4889,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; @@ -4790,7 +4945,7 @@ PP(pp_ghostent) } #endif - if (GIMME != G_ARRAY) { + if (GIMME_V != G_ARRAY) { PUSHs(sv = sv_newmortal()); if (hent) { if (which == OP_GHBYNAME) { @@ -4826,10 +4981,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? */ @@ -4875,7 +5032,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) @@ -4899,10 +5056,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? */ @@ -4936,7 +5096,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) @@ -4959,10 +5119,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? */ @@ -4999,7 +5162,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) { @@ -5024,9 +5187,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: @@ -5061,9 +5227,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 @@ -5126,10 +5296,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; @@ -5225,7 +5398,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) @@ -5341,10 +5514,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; @@ -5353,7 +5529,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 @@ -5364,7 +5546,7 @@ PP(pp_ggrent) #endif EXTEND(SP, 4); - if (GIMME != G_ARRAY) { + if (GIMME_V != G_ARRAY) { SV * const sv = sv_newmortal(); PUSHs(sv); @@ -5410,7 +5592,7 @@ PP(pp_ggrent) PP(pp_getlogin) { #ifdef HAS_GETLOGIN - dVAR; dSP; dTARGET; + dSP; dTARGET; char *tmps; EXTEND(SP, 1); if (!(tmps = PerlProc_getlogin())) @@ -5428,7 +5610,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; @@ -5619,11 +5801,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: */