X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/56a94ef2bbd8ca2d03b073fcb3c1f8f2e7eb3705..406d5545e79665094180534380eba323110f99bc:/pp_sys.c diff --git a/pp_sys.c b/pp_sys.c index 54c12b3..15b4d8b 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 @@ -193,6 +192,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... */ @@ -530,17 +533,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) { @@ -678,8 +695,6 @@ PP(pp_pipe_op) GV * const wgv = MUTABLE_GV(POPs); GV * const rgv = MUTABLE_GV(POPs); - assert (isGV_with_GP(rgv)); - assert (isGV_with_GP(wgv)); rstio = GvIOn(rgv); if (IoIFP(rstio)) do_close(rgv, FALSE); @@ -709,15 +724,15 @@ PP(pp_pipe_op) PerlLIO_close(fd[1]); goto badexit; } -#if defined(HAS_FCNTL) && defined(F_SETFD) +#if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC) /* ensure close-on-exec */ - if ((fcntl(fd[0], F_SETFD,fd[0] > PL_maxsysfd) < 0) || - (fcntl(fd[1], F_SETFD,fd[1] > PL_maxsysfd) < 0)) + if ((fd[0] > PL_maxsysfd && fcntl(fd[0], F_SETFD, FD_CLOEXEC) < 0) || + (fd[1] > PL_maxsysfd && fcntl(fd[1], F_SETFD, FD_CLOEXEC) < 0)) goto badexit; #endif RETPUSHYES; -badexit: + badexit: RETPUSHUNDEF; #else DIE(aTHX_ PL_no_func, "pipe"); @@ -743,6 +758,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. @@ -954,6 +985,9 @@ PP(pp_tie) RETURN; } + +/* also used for: pp_dbmclose() */ + PP(pp_untie) { dSP; @@ -1063,9 +1097,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); } @@ -1228,7 +1264,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,10 +1281,10 @@ PP(pp_sselect) =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 */ @@ -1416,8 +1452,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", @@ -1495,7 +1532,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 @@ -1604,6 +1647,9 @@ PP(pp_sysopen) RETURN; } + +/* also used for: pp_read() and pp_recv() (where supported) */ + PP(pp_sysread) { dSP; dMARK; dORIGMARK; dTARGET; @@ -1661,6 +1707,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); @@ -1750,7 +1801,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); @@ -1860,6 +1911,9 @@ PP(pp_sysread) RETPUSHUNDEF; } + +/* also used for: pp_send() where defined */ + PP(pp_syswrite) { dSP; dMARK; dORIGMARK; dTARGET; @@ -1917,6 +1971,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); @@ -2106,16 +2163,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; } } @@ -2158,6 +2219,9 @@ PP(pp_tell) RETURN; } + +/* also used for: pp_seek() */ + PP(pp_sysseek) { dSP; @@ -2249,13 +2313,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; + } } } } @@ -2272,10 +2341,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) @@ -2294,6 +2375,9 @@ PP(pp_truncate) } } + +/* also used for: pp_fcntl() */ + PP(pp_ioctl) { dSP; dTARGET; @@ -2428,8 +2512,9 @@ PP(pp_socket) if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd); RETPUSHUNDEF; } -#if defined(HAS_FCNTL) && defined(F_SETFD) - if (fcntl(fd, F_SETFD, fd > PL_maxsysfd) < 0) /* ensure close-on-exec */ +#if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC) + /* ensure close-on-exec */ + if (fd > PL_maxsysfd && fcntl(fd, F_SETFD, FD_CLOEXEC) < 0) RETPUSHUNDEF; #endif @@ -2474,10 +2559,10 @@ PP(pp_sockpair) if (!IoIFP(io2) && !IoOFP(io2)) PerlLIO_close(fd[1]); RETPUSHUNDEF; } -#if defined(HAS_FCNTL) && defined(F_SETFD) +#if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC) /* ensure close-on-exec */ - if ((fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd) < 0) || - (fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd) < 0)) + if ((fd[0] > PL_maxsysfd && fcntl(fd[0], F_SETFD, FD_CLOEXEC) < 0) || + (fd[1] > PL_maxsysfd && fcntl(fd[1], F_SETFD, FD_CLOEXEC) < 0)) RETPUSHUNDEF; #endif @@ -2489,6 +2574,8 @@ PP(pp_sockpair) #ifdef HAS_SOCKET +/* also used for: pp_connect() */ + PP(pp_bind) { dSP; @@ -2518,7 +2605,7 @@ PP(pp_bind) else RETPUSHUNDEF; -nuts: + nuts: report_evil_fh(gv); SETERRNO(EBADF,SS_IVCHAN); RETPUSHUNDEF; @@ -2539,7 +2626,7 @@ PP(pp_listen) else RETPUSHUNDEF; -nuts: + nuts: report_evil_fh(gv); SETERRNO(EBADF,SS_IVCHAN); RETPUSHUNDEF; @@ -2589,8 +2676,9 @@ PP(pp_accept) if (!IoIFP(nstio) && !IoOFP(nstio)) PerlLIO_close(fd); goto badexit; } -#if defined(HAS_FCNTL) && defined(F_SETFD) - if (fcntl(fd, F_SETFD, fd > PL_maxsysfd) < 0) /* ensure close-on-exec */ +#if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC) + /* ensure close-on-exec */ + if (fd > PL_maxsysfd && fcntl(fd, F_SETFD, FD_CLOEXEC) < 0) goto badexit; #endif @@ -2601,11 +2689,11 @@ PP(pp_accept) PUSHp(namebuf, len); RETURN; -nuts: + nuts: report_evil_fh(ggv); SETERRNO(EBADF,SS_IVCHAN); -badexit: + badexit: RETPUSHUNDEF; } @@ -2623,12 +2711,15 @@ 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) { dSP; @@ -2656,6 +2747,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); @@ -2695,14 +2791,17 @@ 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) { dSP; @@ -2756,10 +2855,10 @@ PP(pp_getpeername) PUSHs(sv); RETURN; -nuts: + nuts: report_evil_fh(gv); SETERRNO(EBADF,SS_IVCHAN); -nuts2: + nuts2: RETPUSHUNDEF; } @@ -2767,6 +2866,8 @@ nuts2: /* Stat calls. */ +/* also used for: pp_lstat() */ + PP(pp_stat) { dSP; @@ -2990,11 +3091,14 @@ S_try_amagic_ftest(pTHX_ char chr) { } +/* also used for: pp_fteexec() pp_fteread() pp_ftewrite() pp_ftrexec() + * pp_ftrwrite() */ + PP(pp_ftrread) { 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. */ @@ -3107,6 +3211,9 @@ PP(pp_ftrread) FT_RETURNNO; } + +/* also used for: pp_ftatime() pp_ftctime() pp_ftmtime() pp_ftsize() */ + PP(pp_ftis) { I32 result; @@ -3158,6 +3265,11 @@ 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) { I32 result; @@ -3279,6 +3391,7 @@ PP(pp_fttty) GV *gv; char *name = NULL; STRLEN namelen; + UV uv; tryAMAGICftest_MG('t'); @@ -3294,8 +3407,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) { @@ -3307,6 +3420,9 @@ PP(pp_fttty) FT_RETURNNO; } + +/* also used for: pp_ftbinary() */ + PP(pp_fttext) { I32 i; @@ -3434,7 +3550,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 */ @@ -3442,43 +3557,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_CTYPE - if (IN_LC_RUNTIME(LC_CTYPE) && isALPHA_LC(*s)) + 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 */ @@ -3499,12 +3624,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; @@ -3515,12 +3649,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; } @@ -3560,13 +3693,18 @@ 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) { dSP; dMARK; dTARGET; @@ -3594,17 +3732,20 @@ PP(pp_rename) { 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); @@ -3615,6 +3756,9 @@ PP(pp_rename) RETURN; } + +/* also used for: pp_symlink() */ + #if defined(HAS_LINK) || defined(HAS_SYMLINK) PP(pp_link) { @@ -3657,6 +3801,9 @@ PP(pp_link) RETURN; } #else + +/* also used for: pp_symlink() */ + PP(pp_link) { /* Have neither. */ @@ -3671,13 +3818,17 @@ PP(pp_readlink) 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 @@ -3756,7 +3907,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) @@ -3797,7 +3949,7 @@ PP(pp_mkdir) 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); @@ -3857,7 +4009,7 @@ PP(pp_open_dir) goto nope; RETPUSHYES; -nope: + nope: if (!errno) SETERRNO(EBADF,RMS_DIR); RETPUSHUNDEF; @@ -3877,7 +4029,7 @@ PP(pp_readdir) 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); @@ -3908,10 +4060,10 @@ PP(pp_readdir) RETURN; -nope: + nope: if (!errno) SETERRNO(EBADF,RMS_ISI); - if (GIMME == G_ARRAY) + if (gimme == G_ARRAY) RETURN; else RETPUSHUNDEF; @@ -3941,7 +4093,7 @@ PP(pp_telldir) PUSHi( PerlDir_tell(IoDIRP(io)) ); RETURN; -nope: + nope: if (!errno) SETERRNO(EBADF,RMS_ISI); RETPUSHUNDEF; @@ -3967,7 +4119,7 @@ PP(pp_seekdir) (void)PerlDir_seek(IoDIRP(io), along); RETPUSHYES; -nope: + nope: if (!errno) SETERRNO(EBADF,RMS_ISI); RETPUSHUNDEF; @@ -3991,7 +4143,7 @@ PP(pp_rewinddir) } (void)PerlDir_rewind(IoDIRP(io)); RETPUSHYES; -nope: + nope: if (!errno) SETERRNO(EBADF,RMS_ISI); RETPUSHUNDEF; @@ -4024,7 +4176,7 @@ PP(pp_closedir) IoDIRP(io) = 0; RETPUSHYES; -nope: + nope: if (!errno) SETERRNO(EBADF,RMS_IFI); RETPUSHUNDEF; @@ -4075,7 +4227,7 @@ PP(pp_fork) PUSHi(childpid); RETURN; #else -# if defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS) +# if (defined(USE_ITHREADS) && defined(PERL_IMPLICIT_SYS)) || defined(__amigaos4__) dSP; dTARGET; Pid_t childpid; @@ -4127,6 +4279,12 @@ PP(pp_waitpid) 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) @@ -4143,6 +4301,7 @@ PP(pp_waitpid) # else STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1); # endif +# endif /* __amigaos4__ */ SETi(result); RETURN; #else @@ -4159,7 +4318,11 @@ PP(pp_system) XPUSHi(-1); #else I32 value; +# ifdef __amigaos4__ + void * result; +# else int result; +# endif if (TAINTING_get) { TAINT_ENV(); @@ -4172,17 +4335,33 @@ PP(pp_system) 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) 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); @@ -4204,19 +4383,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); @@ -4245,18 +4432,26 @@ 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) { PerlLIO_close(pp[0]); -#if defined(HAS_FCNTL) && defined(F_SETFD) +#if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC) if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0) RETPUSHUNDEF; #endif @@ -4270,6 +4465,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 */ @@ -4319,6 +4515,7 @@ PP(pp_exec) MARK = ORIGMARK; TAINT_PROPER("exec"); } + PERL_FLUSHALL_FOR_CHILD; if (PL_op->op_flags & OPf_STACKED) { SV * const really = *++MARK; @@ -4337,7 +4534,6 @@ PP(pp_exec) value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP))); #endif } - SP = ORIGMARK; XPUSHi(value); RETURN; @@ -4383,10 +4579,11 @@ PP(pp_setpgrp) 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"); @@ -4465,7 +4662,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); @@ -4476,7 +4673,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); @@ -4497,6 +4694,9 @@ PP(pp_tms) /* Sun Dec 29 12:00:00 2147483647 */ #define TIME_UPPER_BOUND 67767976233316800.0 + +/* also used for: pp_localtime() */ + PP(pp_gmtime) { dSP; @@ -4517,11 +4717,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; + } } } @@ -4539,34 +4744,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 */ @@ -4592,13 +4797,30 @@ PP(pp_alarm) { #ifdef HAS_ALARM dSP; dTARGET; - int anum; - anum = POPi; - anum = alarm((unsigned int)anum); - if (anum < 0) - RETPUSHUNDEF; - PUSHi(anum); - RETURN; + /* 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 @@ -4616,7 +4838,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); @@ -4626,6 +4857,8 @@ 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) @@ -4658,6 +4891,8 @@ PP(pp_shmwrite) /* Semaphores. */ +/* also used for: pp_msgget() pp_shmget() */ + PP(pp_semget) { #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) @@ -4673,6 +4908,8 @@ PP(pp_semget) #endif } +/* also used for: pp_msgctl() pp_shmctl() */ + PP(pp_semctl) { #if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM) @@ -4680,7 +4917,7 @@ PP(pp_semctl) const int anum = do_ipcctl(PL_op->op_type, MARK, SP); SP = MARK; if (anum == -1) - RETSETUNDEF; + RETPUSHUNDEF; if (anum != 0) { PUSHi(anum); } @@ -4702,7 +4939,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); @@ -4718,6 +4955,8 @@ 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) @@ -4772,7 +5011,7 @@ PP(pp_ghostent) } #endif - if (GIMME != G_ARRAY) { + if (GIMME_V != G_ARRAY) { PUSHs(sv = sv_newmortal()); if (hent) { if (which == OP_GHBYNAME) { @@ -4808,6 +5047,8 @@ PP(pp_ghostent) #endif } +/* also used for: pp_gnbyaddr() pp_gnbyname() */ + PP(pp_gnetent) { #if defined(HAS_GETNETBYNAME) || defined(HAS_GETNETBYADDR) || defined(HAS_GETNETENT) @@ -4857,7 +5098,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) @@ -4881,6 +5122,9 @@ PP(pp_gnetent) #endif } + +/* also used for: pp_gpbyname() pp_gpbynumber() */ + PP(pp_gprotoent) { #if defined(HAS_GETPROTOBYNAME) || defined(HAS_GETPROTOBYNUMBER) || defined(HAS_GETPROTOENT) @@ -4918,7 +5162,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) @@ -4941,6 +5185,9 @@ PP(pp_gprotoent) #endif } + +/* also used for: pp_gsbyname() pp_gsbyport() */ + PP(pp_gservent) { #if defined(HAS_GETSERVBYNAME) || defined(HAS_GETSERVBYPORT) || defined(HAS_GETSERVENT) @@ -4981,7 +5228,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) { @@ -5006,6 +5253,9 @@ PP(pp_gservent) #endif } + +/* also used for: pp_snetent() pp_sprotoent() pp_sservent() */ + PP(pp_shostent) { dSP; @@ -5043,6 +5293,10 @@ PP(pp_shostent) RETSETYES; } + +/* also used for: pp_egrent() pp_enetent() pp_eprotoent() pp_epwent() + * pp_eservent() pp_sgrent() pp_spwent() */ + PP(pp_ehostent) { dSP; @@ -5108,6 +5362,9 @@ PP(pp_ehostent) RETPUSHYES; } + +/* also used for: pp_gpwnam() pp_gpwuid() */ + PP(pp_gpwent) { #ifdef HAS_PASSWD @@ -5207,7 +5464,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) @@ -5323,6 +5580,9 @@ PP(pp_gpwent) #endif } + +/* also used for: pp_ggrgid() pp_ggrnam() */ + PP(pp_ggrent) { #ifdef HAS_GROUP @@ -5335,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 @@ -5346,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); @@ -5601,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: */