X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/4b523e790cc5594fb19013dc23adfb6a5b34f824..3e41ecc92174a108aa69c527c9e59d41d45ed39b:/pp_sys.c diff --git a/pp_sys.c b/pp_sys.c index beca14a..74c8900 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... */ @@ -294,7 +297,7 @@ PP(pp_backtick) 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("``"); @@ -317,7 +320,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"); @@ -459,7 +462,7 @@ 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; } @@ -530,6 +533,7 @@ 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; @@ -540,7 +544,20 @@ Perl_tied_method(pTHX_ SV *methname, SV **sp, SV *const sv, 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) { @@ -612,8 +629,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); @@ -678,8 +694,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); @@ -691,8 +705,8 @@ PP(pp_pipe_op) if (PerlProc_pipe(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; @@ -709,10 +723,10 @@ 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; @@ -937,10 +951,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); @@ -1004,7 +1044,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 ) ; } } @@ -1266,10 +1306,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 */ @@ -1277,10 +1317,13 @@ of the typeglob that PL_defoutgv points to is decreased by one. void Perl_setdefout(pTHX_ GV *gv) { + 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) @@ -1327,7 +1370,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; @@ -1364,23 +1407,17 @@ STATIC OP * S_doform(pTHX_ CV *cv, GV *gv, OP *retop) { PERL_CONTEXT *cx; - const I32 gimme = GIMME_V; + const U8 gimme = GIMME_V; PERL_ARGS_ASSERT_DOFORM; 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 */ @@ -1394,7 +1431,6 @@ PP(pp_enterwrite) IO *io; GV *fgv; CV *cv = NULL; - SV *tmpsv = NULL; if (MAXARG == 0) { EXTEND(SP, 1); @@ -1418,9 +1454,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)); @@ -1429,16 +1465,15 @@ PP(pp_enterwrite) PP(pp_leavewrite) { dSP; - GV * const gv = cxstack[cxstack_ix].blk_format.gv; + 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", @@ -1456,7 +1491,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)) || @@ -1504,19 +1539,28 @@ 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); - 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 @@ -1539,7 +1583,6 @@ PP(pp_leavewrite) } } PL_formtarget = PL_bodytarget; - PERL_UNUSED_VAR(gimme); RETURNOP(retop); } @@ -1615,7 +1658,7 @@ PP(pp_sysopen) /* Need TIEHANDLE method ? */ const char * const tmps = SvPV_const(sv, len); - if (do_open_raw(gv, tmps, len, mode, perm)) { + if (do_open_raw(gv, tmps, len, mode, perm, NULL)) { IoLINES(GvIOp(gv)) = 0; PUSHs(&PL_sv_yes); } @@ -1665,7 +1708,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"); @@ -1685,6 +1728,12 @@ 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_d(aTHX_ packWARN(WARN_DEPRECATED), + "%s() is deprecated on :utf8 handles. " + "This will be a fatal error in Perl 5.30", + 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); @@ -1944,6 +1993,10 @@ PP(pp_syswrite) doing_utf8 = DO_UTF8(bufsv); if (PerlIO_isutf8(IoIFP(io))) { + Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED), + "%s() is deprecated on :utf8 handles. " + "This will be a fatal error in Perl 5.30", + OP_DESC(PL_op)); if (!SvUTF8(bufsv)) { /* We don't modify the original scalar. */ tmpbuf = bytes_to_utf8((const U8*) buffer, &blen); @@ -2283,13 +2336,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; + } } } } @@ -2465,11 +2523,10 @@ PP(pp_socket) TAINT_PROPER("socket"); fd = PerlSock_socket(domain, type, protocol); if (fd < 0) { - SETERRNO(EBADF,RMS_IFI); 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)); @@ -2477,8 +2534,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 @@ -2508,11 +2566,11 @@ PP(pp_sockpair) TAINT_PROPER("socketpair"); if (PerlSock_socketpair(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)); @@ -2523,10 +2581,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 @@ -2631,8 +2689,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)); @@ -2640,8 +2698,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 @@ -2836,7 +2895,7 @@ PP(pp_stat) dSP; GV *gv = NULL; IO *io = NULL; - I32 gimme; + U8 gimme; I32 max = 13; SV* sv; @@ -2846,7 +2905,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))) @@ -2862,7 +2921,7 @@ PP(pp_stat) havefp = FALSE; PL_laststype = OP_STAT; PL_statgv = gv ? gv : (GV *)io; - sv_setpvs(PL_statname, ""); + SvPVCLEAR(PL_statname); if(gv) { io = GvIO(gv); } @@ -3422,7 +3481,7 @@ PP(pp_fttext) } else { PL_statgv = gv; - sv_setpvs(PL_statname, ""); + SvPVCLEAR(PL_statname); io = GvIO(PL_statgv); } PL_laststatval = -1; @@ -3497,8 +3556,9 @@ PP(pp_fttext) } PL_laststatval = PerlLIO_fstat(fd, &PL_statcache); if (PL_laststatval < 0) { + dSAVE_ERRNO; (void)PerlIO_close(fp); - SETERRNO(EBADF,RMS_IFI); + RESTORE_ERRNO; FT_RETURNUNDEF; } PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL); @@ -3521,15 +3581,11 @@ PP(pp_fttext) #endif assert(len); - if (! is_invariant_string((U8 *) s, len)) { - const U8 *ep; + if (! is_utf8_invariant_string((U8 *) s, len)) { /* 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)) - { + * UTF-8. */ + if (is_utf8_fixed_width_buf_flags((U8 *) s, len, 0)) { if (PL_op->op_type == OP_FTTEXT) { FT_RETURNYES; } @@ -3555,14 +3611,14 @@ PP(pp_fttext) } else #endif - if (isPRINT_A(*s) - /* VT occurs so rarely in text, that we consider it odd */ - || (isSPACE_A(*s) && *s != VT_NATIVE) + 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) + || *s == '\b' + || *s == ESC_NATIVE) { continue; } @@ -3587,15 +3643,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); + 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; + EXTEND(SP, 1); if ( (svp = hv_fetchs(table, "HOME", FALSE)) || (svp = hv_fetchs(table, "LOGDIR", FALSE)) #ifdef VMS @@ -3603,12 +3669,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; } @@ -3687,17 +3752,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); @@ -3859,7 +3927,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) @@ -3900,7 +3969,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); @@ -3951,9 +4020,8 @@ PP(pp_open_dir) IO * const io = GvIOn(gv); 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))) @@ -3980,14 +4048,14 @@ PP(pp_readdir) dSP; SV *sv; - const I32 gimme = GIMME_V; + const U8 gimme = GIMME_V; GV * const gv = MUTABLE_GV(POPs); const Direntry_t *dp; IO * const io = GvIOn(gv); 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; } @@ -4037,7 +4105,7 @@ PP(pp_telldir) 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; } @@ -4063,7 +4131,7 @@ PP(pp_seekdir) 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; } @@ -4088,7 +4156,7 @@ PP(pp_rewinddir) 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; } @@ -4112,7 +4180,7 @@ PP(pp_closedir) 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; } @@ -4178,7 +4246,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; @@ -4230,6 +4298,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) @@ -4246,6 +4320,7 @@ PP(pp_waitpid) # else STATUS_NATIVE_CHILD_SET((result > 0) ? argflags : -1); # endif +# endif /* __amigaos4__ */ SETi(result); RETURN; #else @@ -4262,7 +4337,11 @@ PP(pp_system) XPUSHi(-1); #else I32 value; +# ifdef __amigaos4__ + void * result; +# else int result; +# endif if (TAINTING_get) { TAINT_ENV(); @@ -4275,17 +4354,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); @@ -4307,19 +4402,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); @@ -4333,10 +4436,9 @@ PP(pp_system) 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) @@ -4348,18 +4450,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 @@ -4373,6 +4483,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 */ @@ -4422,6 +4533,7 @@ PP(pp_exec) MARK = ORIGMARK; TAINT_PROPER("exec"); } + PERL_FLUSHALL_FOR_CHILD; if (PL_op->op_flags & OPf_STACKED) { SV * const really = *++MARK; @@ -4440,7 +4552,6 @@ PP(pp_exec) value = (I32)do_exec(SvPVx_nolen(sv_mortalcopy(*SP))); #endif } - SP = ORIGMARK; XPUSHi(value); RETURN; @@ -4651,9 +4762,9 @@ 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) { @@ -4671,7 +4782,7 @@ PP(pp_gmtime) else { dTARGET; PUSHs(TARG); - Perl_sv_setpvf_mg(aTHX_ TARG, "%s %s %2d %02d:%02d:%02d %"IVdf, + Perl_sv_setpvf_mg(aTHX_ TARG, "%s %s %2d %02d:%02d:%02d %" IVdf, dayname[tmbuf.tm_wday], monname[tmbuf.tm_mon], tmbuf.tm_mday, @@ -4704,13 +4815,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 @@ -4719,7 +4847,6 @@ PP(pp_alarm) PP(pp_sleep) { dSP; dTARGET; - I32 duration; Time_t lasttime; Time_t when; @@ -4727,8 +4854,17 @@ 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); + XPUSHi(0); + RETURN; + } else { + PerlProc_sleep((unsigned int)duration); + } } (void)time(&when); XPUSHi(when - lasttime); @@ -4818,9 +4954,7 @@ S_space_join_names_mortal(pTHX_ char *const *array) { SV *target; - PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL; - - if (*array) { + if (array && *array) { target = newSVpvs_flags("", SVs_TEMP); while (1) { sv_catpv(target, *array); @@ -5476,7 +5610,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