X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/91e4b3b3c17af0a2060f42742a68ebbbe15aa657..9e59c36b452568c56b99957f02b853c42e280f8a:/doio.c diff --git a/doio.c b/doio.c index f41a559..d95ad9c 100644 --- a/doio.c +++ b/doio.c @@ -772,7 +772,7 @@ S_openn_cleanup(pTHX_ GV *gv, IO *io, PerlIO *fp, char *mode, const char *oname, fd = PerlIO_fileno(fp); } #if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC) - if (fd > PL_maxsysfd && fcntl(fd, F_SETFD, FD_CLOEXEC) < 0) { + if (fd >= 0 && fd > PL_maxsysfd && fcntl(fd, F_SETFD, FD_CLOEXEC) < 0) { PerlLIO_close(fd); goto say_false; } @@ -835,6 +835,7 @@ Perl_nextargv(pTHX_ GV *gv, bool nomagicopen) if (!GvAV(gv)) return NULL; while (av_tindex(GvAV(gv)) >= 0) { + Stat_t statbuf; STRLEN oldlen; SV *const sv = av_shift(GvAV(gv)); SAVEFREESV(sv); @@ -976,13 +977,13 @@ Perl_nextargv(pTHX_ GV *gv, bool nomagicopen) setdefout(PL_argvoutgv); PL_lastfd = PerlIO_fileno(IoIFP(GvIOp(PL_argvoutgv))); if (PL_lastfd >= 0) { - (void)PerlLIO_fstat(PL_lastfd,&PL_statbuf); + (void)PerlLIO_fstat(PL_lastfd,&statbuf); #ifdef HAS_FCHMOD (void)fchmod(PL_lastfd,PL_filemode); #else (void)PerlLIO_chmod(PL_oldname,PL_filemode); #endif - if (fileuid != PL_statbuf.st_uid || filegid != PL_statbuf.st_gid) { + if (fileuid != statbuf.st_uid || filegid != statbuf.st_gid) { /* XXX silently ignore failures */ #ifdef HAS_FCHOWN PERL_UNUSED_RESULT(fchown(PL_lastfd,fileuid,filegid)); @@ -999,8 +1000,8 @@ Perl_nextargv(pTHX_ GV *gv, bool nomagicopen) if (ckWARN_d(WARN_INPLACE)) { const int eno = errno; - if (PerlLIO_stat(PL_oldname, &PL_statbuf) >= 0 - && !S_ISREG(PL_statbuf.st_mode)) { + if (PerlLIO_stat(PL_oldname, &statbuf) >= 0 + && !S_ISREG(statbuf.st_mode)) { Perl_warner(aTHX_ packWARN(WARN_INPLACE), "Can't do inplace edit: %s is not a regular file", PL_oldname); @@ -1528,14 +1529,10 @@ S_exec_failed(pTHX_ const char *cmd, int fd, int do_report) { const int e = errno; PERL_ARGS_ASSERT_EXEC_FAILED; -#ifdef __amigaos4__ - if (e) -#endif - { - if (ckWARN(WARN_EXEC)) - Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't exec \"%s\": %s", - cmd, Strerror(e)); - } + + if (ckWARN(WARN_EXEC)) + Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't exec \"%s\": %s", + cmd, Strerror(e)); if (do_report) { /* XXX silently ignore failures */ PERL_UNUSED_RESULT(PerlLIO_write(fd, (void*)&e, sizeof(int))); @@ -1543,14 +1540,12 @@ S_exec_failed(pTHX_ const char *cmd, int fd, int do_report) } } -DO_EXEC_TYPE +bool Perl_do_aexec5(pTHX_ SV *really, SV **mark, SV **sp, int fd, int do_report) { dVAR; - DO_EXEC_TYPE result = DO_EXEC_FAILURE; PERL_ARGS_ASSERT_DO_AEXEC5; - PERL_UNUSED_VAR(result); /* if DO_EXEC_TYPE is bool */ #if defined(__SYMBIAN32__) || defined(__LIBCATAMOUNT__) Perl_croak(aTHX_ "exec? I'm not *that* kind of operating system"); #else @@ -1574,20 +1569,16 @@ Perl_do_aexec5(pTHX_ SV *really, SV **mark, SV **sp, TAINT_ENV(); /* testing IFS here is overkill, probably */ PERL_FPU_PRE_EXEC if (really && *tmps) { - result = - (DO_EXEC_TYPE) - PerlProc_execvp(tmps,EXEC_ARGV_CAST(PL_Argv)); + PerlProc_execvp(tmps,EXEC_ARGV_CAST(PL_Argv)); } else { - result = - (DO_EXEC_TYPE) - PerlProc_execvp(PL_Argv[0],EXEC_ARGV_CAST(PL_Argv)); + PerlProc_execvp(PL_Argv[0],EXEC_ARGV_CAST(PL_Argv)); } PERL_FPU_POST_EXEC S_exec_failed(aTHX_ (really ? tmps : PL_Argv[0]), fd, do_report); } do_execfree(); #endif - return DO_EXEC_RETVAL(result); + return FALSE; } void @@ -1601,7 +1592,7 @@ Perl_do_execfree(pTHX) #ifdef PERL_DEFAULT_DO_EXEC3_IMPLEMENTATION -DO_EXEC_TYPE +bool Perl_do_exec3(pTHX_ const char *incmd, int fd, int do_report) { dVAR; @@ -1611,8 +1602,6 @@ Perl_do_exec3(pTHX_ const char *incmd, int fd, int do_report) char *cmd; /* Make a copy so we can change it */ const Size_t cmdlen = strlen(incmd) + 1; - DO_EXEC_TYPE result = DO_EXEC_FAILURE; - PERL_UNUSED_VAR(result); /* if DO_EXEC_TYPE is bool */ PERL_ARGS_ASSERT_DO_EXEC3; @@ -1648,14 +1637,12 @@ Perl_do_exec3(pTHX_ const char *incmd, int fd, int do_report) if (s[-1] == '\'') { *--s = '\0'; PERL_FPU_PRE_EXEC - result = - (DO_EXEC_TYPE) - PerlProc_execl(PL_cshname, "csh", flags, ncmd, (char*)NULL); + PerlProc_execl(PL_cshname, "csh", flags, ncmd, (char*)NULL); PERL_FPU_POST_EXEC *s = '\''; S_exec_failed(aTHX_ PL_cshname, fd, do_report); Safefree(buf); - return DO_EXEC_RETVAL(result); + return FALSE; } } } @@ -1699,16 +1686,11 @@ Perl_do_exec3(pTHX_ const char *incmd, int fd, int do_report) } doshell: PERL_FPU_PRE_EXEC - result = - (DO_EXEC_TYPE) - PerlProc_execl(PL_sh_path, "sh", "-c", cmd, (char *)NULL); + PerlProc_execl(PL_sh_path, "sh", "-c", cmd, (char *)NULL); PERL_FPU_POST_EXEC S_exec_failed(aTHX_ PL_sh_path, fd, do_report); -#if defined (__amigaos4__) - amigaos_post_exec(fd, do_report); -#endif Safefree(buf); - return DO_EXEC_RETVAL(result); + return FALSE; } } @@ -1728,9 +1710,7 @@ Perl_do_exec3(pTHX_ const char *incmd, int fd, int do_report) *a = NULL; if (PL_Argv[0]) { PERL_FPU_PRE_EXEC - result = - (DO_EXEC_TYPE) - PerlProc_execvp(PL_Argv[0],EXEC_ARGV_CAST(PL_Argv)); + PerlProc_execvp(PL_Argv[0],EXEC_ARGV_CAST(PL_Argv)); PERL_FPU_POST_EXEC if (errno == ENOEXEC) { /* for system V NIH syndrome */ do_execfree(); @@ -1740,15 +1720,11 @@ Perl_do_exec3(pTHX_ const char *incmd, int fd, int do_report) } do_execfree(); Safefree(buf); - return DO_EXEC_RETVAL(result); + return FALSE; } #endif /* OS2 || WIN32 */ -#ifdef VMS -#include /* for sys$delprc */ -#endif - I32 Perl_apply(pTHX_ I32 type, SV **mark, SV **sp) { @@ -1910,40 +1886,7 @@ nothing in the core. } APPLY_TAINT_PROPER(); tot = sp - mark; -#ifdef VMS - /* kill() doesn't do process groups (job trees?) under VMS */ - if (val == SIGKILL) { - /* Use native sys$delprc() to insure that target process is - * deleted; supervisor-mode images don't pay attention to - * CRTL's emulation of Unix-style signals and kill() - */ - while (++mark <= sp) { - I32 proc; - unsigned long int __vmssts; - SvGETMAGIC(*mark); - if (!(SvIOK(*mark) || SvNOK(*mark) || looks_like_number(*mark))) - Perl_croak(aTHX_ "Can't kill a non-numeric process ID"); - proc = SvIV_nomg(*mark); - APPLY_TAINT_PROPER(); - if (!((__vmssts = sys$delprc(&proc,0)) & 1)) { - tot--; - switch (__vmssts) { - case SS$_NONEXPR: - case SS$_NOSUCHNODE: - SETERRNO(ESRCH,__vmssts); - break; - case SS$_NOPRIV: - SETERRNO(EPERM,__vmssts); - break; - default: - SETERRNO(EVMSERR,__vmssts); - } - } - } - PERL_ASYNC_CHECK(); - break; - } -#endif + while (++mark <= sp) { Pid_t proc; SvGETMAGIC(*mark); @@ -1975,18 +1918,47 @@ nothing in the core. } else if (PL_unsafe) { if (UNLINK(s)) + { tot--; + } +#if defined(__amigaos4__) && defined(NEWLIB) + else + { + /* Under AmigaOS4 unlink only 'fails' if the + * filename is invalid. It may not remove the file + * if it's locked, so check if it's still around. */ + if ((access(s,F_OK) != -1)) + { + tot--; + } + } +#endif } else { /* don't let root wipe out directories without -U */ - if (PerlLIO_lstat(s,&PL_statbuf) < 0) - tot--; - else if (S_ISDIR(PL_statbuf.st_mode)) { + Stat_t statbuf; + if (PerlLIO_lstat(s, &statbuf) < 0) tot--; + else if (S_ISDIR(statbuf.st_mode)) { SETERRNO(EISDIR, SS_NOPRIV); + tot--; } else { if (UNLINK(s)) - tot--; + { + tot--; + } +#if defined(__amigaos4__) && defined(NEWLIB) + else + { + /* Under AmigaOS4 unlink only 'fails' if the filename is invalid */ + /* It may not remove the file if it's Locked, so check if it's still */ + /* arround */ + if((access(s,F_OK) != -1)) + { + tot--; + } + } +#endif } } } @@ -2544,7 +2516,8 @@ Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp) Function called by C to spawn a glob (or do the glob inside perl on VMS). This code used to be inline, but now perl uses C -this glob starter is only used by miniperl during the build process. +this glob starter is only used by miniperl during the build process, +or when PERL_EXTERNAL_GLOB is defined. Moving it away shrinks F; shrinking F helps speed perl up. =cut