X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/284167a54e2da949b77d1e736a8b0a0d21210803..56e971472aeadd8c59894759279df45820a0c18d:/doio.c diff --git a/doio.c b/doio.c index eedd374..81abd9c 100644 --- a/doio.c +++ b/doio.c @@ -61,7 +61,7 @@ #include bool -Perl_do_openn(pTHX_ GV *gv, register const char *oname, I32 len, int as_raw, +Perl_do_openn(pTHX_ GV *gv, const char *oname, I32 len, int as_raw, int rawmode, int rawperm, PerlIO *supplied_fp, SV **svp, I32 num_svs) { @@ -206,6 +206,8 @@ Perl_do_openn(pTHX_ GV *gv, register const char *oname, I32 len, int as_raw, *--tend = '\0'; if (num_svs) { + const char *p; + STRLEN nlen = 0; /* New style explicit name, type is just mode and layer info */ #ifdef USE_STDIO if (SvROK(*svp) && !strchr(oname,'&')) { @@ -216,8 +218,13 @@ Perl_do_openn(pTHX_ GV *gv, register const char *oname, I32 len, int as_raw, goto say_false; } #endif /* USE_STDIO */ - name = (SvOK(*svp) || SvGMAGICAL(*svp)) ? - savesvpv (*svp) : savepvs (""); + p = (SvOK(*svp) || SvGMAGICAL(*svp)) ? SvPV(*svp, nlen) : NULL; + + if (p && !IS_SAFE_PATHNAME(p, nlen, "open")) + goto say_false; + + name = p ? savepvn(p, nlen) : savepvs(""); + SAVEFREEPV(name); } else { @@ -352,13 +359,6 @@ Perl_do_openn(pTHX_ GV *gv, register const char *oname, I32 len, int as_raw, * be optimized away on most platforms; * only Solaris and Linux seem to flush * on that. --jhi */ -#ifdef USE_SFIO - /* sfio fails to clear error on next - sfwrite, contrary to documentation. - -- Nicholas Clark */ - if (PerlIO_seek(that_fp, 0, SEEK_CUR) == -1) - PerlIO_clearerr(that_fp); -#endif /* On the other hand, do all platforms * take gracefully to flushing a read-only * filehandle? Perhaps we should do @@ -538,7 +538,11 @@ Perl_do_openn(pTHX_ GV *gv, register const char *oname, I32 len, int as_raw, && strchr(oname, '\n') ) + { + GCC_DIAG_IGNORE(-Wformat-nonliteral); /* PL_warn_nl is constant */ Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "open"); + GCC_DIAG_RESTORE; + } goto say_false; } @@ -706,7 +710,7 @@ say_false: } PerlIO * -Perl_nextargv(pTHX_ register GV *gv) +Perl_nextargv(pTHX_ GV *gv) { dVAR; SV *sv; @@ -743,7 +747,7 @@ Perl_nextargv(pTHX_ register GV *gv) PL_filemode = 0; if (!GvAV(gv)) return NULL; - while (av_len(GvAV(gv)) >= 0) { + while (av_tindex(GvAV(gv)) >= 0) { STRLEN oldlen; sv = av_shift(GvAV(gv)); SAVEFREESV(sv); @@ -806,7 +810,7 @@ Perl_nextargv(pTHX_ register GV *gv) } #endif #ifdef HAS_RENAME -#if !defined(DOSISH) && !defined(__CYGWIN__) && !defined(EPOC) +#if !defined(DOSISH) && !defined(__CYGWIN__) if (PerlLIO_rename(PL_oldname,SvPVX_const(sv)) < 0) { Perl_ck_warner_d(aTHX_ packWARN(WARN_INPLACE), "Can't rename %s to %"SVf": %s, skipping file", @@ -872,13 +876,16 @@ Perl_nextargv(pTHX_ register GV *gv) (void)PerlLIO_chmod(PL_oldname,PL_filemode); #endif if (fileuid != PL_statbuf.st_uid || filegid != PL_statbuf.st_gid) { + int rc = 0; #ifdef HAS_FCHOWN - (void)fchown(PL_lastfd,fileuid,filegid); + rc = fchown(PL_lastfd,fileuid,filegid); #else #ifdef HAS_CHOWN - (void)PerlLIO_chown(PL_oldname,fileuid,filegid); + rc = PerlLIO_chown(PL_oldname,fileuid,filegid); #endif #endif + /* XXX silently ignore failures */ + PERL_UNUSED_VAR(rc); } } return IoIFP(GvIOp(gv)); @@ -908,7 +915,7 @@ Perl_nextargv(pTHX_ register GV *gv) { GV * const oldout = MUTABLE_GV(av_pop(PL_argvout_stack)); setdefout(oldout); - SvREFCNT_dec(oldout); + SvREFCNT_dec_NN(oldout); return NULL; } setdefout(gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO)); @@ -1045,10 +1052,6 @@ Perl_do_tell(pTHX_ GV *gv) PERL_ARGS_ASSERT_DO_TELL; if (io && (fp = IoIFP(io))) { -#ifdef ULTRIX_STDIO_BOTCH - if (PerlIO_eof(fp)) - (void)PerlIO_seek(fp, 0L, 2); /* ultrix 1.2 workaround */ -#endif return PerlIO_tell(fp); } report_evil_fh(gv); @@ -1064,10 +1067,6 @@ Perl_do_seek(pTHX_ GV *gv, Off_t pos, int whence) PerlIO *fp; if (io && (fp = IoIFP(io))) { -#ifdef ULTRIX_STDIO_BOTCH - if (PerlIO_eof(fp)) - (void)PerlIO_seek(fp, 0L, 2); /* ultrix 1.2 workaround */ -#endif return PerlIO_seek(fp, pos, whence) >= 0; } report_evil_fh(gv); @@ -1199,7 +1198,7 @@ my_chsize(int fd, Off_t length) #endif /* !HAS_TRUNCATE && !HAS_CHSIZE */ bool -Perl_do_print(pTHX_ register SV *sv, PerlIO *fp) +Perl_do_print(pTHX_ SV *sv, PerlIO *fp) { dVAR; @@ -1322,8 +1321,11 @@ Perl_my_stat_flags(pTHX_ const U32 flags) s = SvPVX_const(PL_statname); /* s now NUL-terminated */ PL_laststype = OP_STAT; PL_laststatval = PerlLIO_stat(s, &PL_statcache); - if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && strchr(s, '\n')) + if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && strchr(s, '\n')) { + GCC_DIAG_IGNORE(-Wformat-nonliteral); /* PL_warn_nl is constant */ Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat"); + GCC_DIAG_RESTORE; + } return PL_laststatval; } } @@ -1333,17 +1335,20 @@ I32 Perl_my_lstat_flags(pTHX_ const U32 flags) { dVAR; - static const char no_prev_lstat[] = "The stat preceding -l _ wasn't an lstat"; + static const char* const no_prev_lstat = "The stat preceding -l _ wasn't an lstat"; dSP; const char *file; + SV* const sv = TOPs; + bool isio = FALSE; if (PL_op->op_flags & OPf_REF) { if (cGVOP_gv == PL_defgv) { if (PL_laststype != OP_LSTAT) - Perl_croak(aTHX_ no_prev_lstat); + Perl_croak(aTHX_ "%s", no_prev_lstat); return PL_laststatval; } PL_laststatval = -1; if (ckWARN(WARN_IO)) { + /* diag_listed_as: Use of -l on filehandle%s */ Perl_warner(aTHX_ packWARN(WARN_IO), "Use of -l on filehandle %"HEKf, HEKfARG(GvENAME_HEK(cGVOP_gv))); @@ -1353,17 +1358,37 @@ Perl_my_lstat_flags(pTHX_ const U32 flags) if ((PL_op->op_private & (OPpFT_STACKED|OPpFT_AFTER_t)) == OPpFT_STACKED) { if (PL_laststype != OP_LSTAT) - Perl_croak(aTHX_ no_prev_lstat); + Perl_croak(aTHX_ "%s", no_prev_lstat); return PL_laststatval; - } + } PL_laststype = OP_LSTAT; PL_statgv = NULL; - file = SvPV_flags_const_nolen(TOPs, flags); + if ( ( (SvROK(sv) && ( isGV_with_GP(SvRV(sv)) + || (isio = SvTYPE(SvRV(sv)) == SVt_PVIO) ) + ) + || isGV_with_GP(sv) + ) + && ckWARN(WARN_IO)) { + if (isio) + /* diag_listed_as: Use of -l on filehandle%s */ + Perl_warner(aTHX_ packWARN(WARN_IO), + "Use of -l on filehandle"); + else + /* diag_listed_as: Use of -l on filehandle%s */ + Perl_warner(aTHX_ packWARN(WARN_IO), + "Use of -l on filehandle %"HEKf, + GvENAME_HEK((const GV *) + (SvROK(sv) ? SvRV(sv) : sv))); + } + file = SvPV_flags_const_nolen(sv, flags); sv_setpv(PL_statname,file); PL_laststatval = PerlLIO_lstat(file,&PL_statcache); - if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && strchr(file, '\n')) - Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "lstat"); + if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && strchr(file, '\n')) { + GCC_DIAG_IGNORE(-Wformat-nonliteral); /* PL_warn_nl is constant */ + Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "lstat"); + GCC_DIAG_RESTORE; + } return PL_laststatval; } @@ -1376,13 +1401,15 @@ S_exec_failed(pTHX_ const char *cmd, int fd, int do_report) Perl_warner(aTHX_ packWARN(WARN_EXEC), "Can't exec \"%s\": %s", cmd, Strerror(e)); if (do_report) { - PerlLIO_write(fd, (void*)&e, sizeof(int)); + int rc = PerlLIO_write(fd, (void*)&e, sizeof(int)); + /* silently ignore failures */ + PERL_UNUSED_VAR(rc); PerlLIO_close(fd); } } bool -Perl_do_aexec5(pTHX_ SV *really, register SV **mark, register SV **sp, +Perl_do_aexec5(pTHX_ SV *really, SV **mark, SV **sp, int fd, int do_report) { dVAR; @@ -1499,7 +1526,7 @@ Perl_do_exec3(pTHX_ const char *incmd, int fd, int do_report) goto doshell; s = cmd; - while (isALNUM(*s)) + while (isWORDCHAR(*s)) s++; /* catch VAR=val gizmo */ if (*s == '=') goto doshell; @@ -1571,7 +1598,7 @@ Perl_do_exec3(pTHX_ const char *incmd, int fd, int do_report) #endif I32 -Perl_apply(pTHX_ I32 type, register SV **mark, register SV **sp) +Perl_apply(pTHX_ I32 type, SV **mark, SV **sp) { dVAR; I32 val; @@ -1584,6 +1611,8 @@ Perl_apply(pTHX_ I32 type, register SV **mark, register SV **sp) PERL_ARGS_ASSERT_APPLY; + PERL_UNUSED_VAR(what); /* may not be used depending on compile options */ + /* Doing this ahead of the switch statement preserves the old behaviour, where attempting to use kill as a taint test test would fail on platforms where kill was not defined. */ @@ -1636,10 +1665,12 @@ Perl_apply(pTHX_ I32 type, register SV **mark, register SV **sp) } } else { - const char *name = SvPV_nomg_const_nolen(*mark); + const char *name = SvPV_nomg_const(*mark, len); APPLY_TAINT_PROPER(); - if (PerlLIO_chmod(name, val)) - tot--; + if (!IS_SAFE_PATHNAME(name, len, "chmod") || + PerlLIO_chmod(name, val)) { + tot--; + } } } } @@ -1670,10 +1701,12 @@ Perl_apply(pTHX_ I32 type, register SV **mark, register SV **sp) } } else { - const char *name = SvPV_nomg_const_nolen(*mark); + const char *name = SvPV_nomg_const(*mark, len); APPLY_TAINT_PROPER(); - if (PerlLIO_chown(name, val, val2)) + if (!IS_SAFE_PATHNAME(name, len, "chown") || + PerlLIO_chown(name, val, val2)) { tot--; + } } } } @@ -1771,15 +1804,22 @@ nothing in the core. APPLY_TAINT_PROPER(); tot = sp - mark; while (++mark <= sp) { - s = SvPV_nolen_const(*mark); + s = SvPV_const(*mark, len); APPLY_TAINT_PROPER(); - if (PerlProc_geteuid() || PL_unsafe) { + if (!IS_SAFE_PATHNAME(s, len, "unlink")) { + tot--; + } + else if (PL_unsafe) { if (UNLINK(s)) tot--; } else { /* don't let root wipe out directories without -U */ - if (PerlLIO_lstat(s,&PL_statbuf) < 0 || S_ISDIR(PL_statbuf.st_mode)) + if (PerlLIO_lstat(s,&PL_statbuf) < 0) + tot--; + else if (S_ISDIR(PL_statbuf.st_mode)) { tot--; + SETERRNO(EISDIR, SS$_NOPRIV); + } else { if (UNLINK(s)) tot--; @@ -1849,8 +1889,12 @@ nothing in the core. } } else { - const char * const name = SvPV_nomg_const_nolen(*mark); + const char * const name = SvPV_nomg_const(*mark, len); APPLY_TAINT_PROPER(); + if (!IS_SAFE_PATHNAME(name, len, "utime")) { + tot--; + } + else #ifdef HAS_FUTIMES if (utimes(name, (struct timeval *)utbufp)) #else @@ -1874,7 +1918,7 @@ nothing in the core. /* Do the permissions allow some operation? Assumes statcache already set. */ #ifndef VMS /* VMS' cando is in vms.c */ bool -Perl_cando(pTHX_ Mode_t mode, bool effective, register const Stat_t *statbufp) +Perl_cando(pTHX_ Mode_t mode, bool effective, const Stat_t *statbufp) /* effective is a flag, true for EUID, or for checking if the effective gid * is in the list of groups returned from getgroups(). */ @@ -2104,11 +2148,16 @@ Perl_do_ipcctl(pTHX_ I32 optype, SV **mark, SV **sp) #ifdef Semctl union semun unsemds; + if(cmd == SETVAL) { + unsemds.val = PTR2nat(a); + } + else { #ifdef EXTRA_F_IN_SEMUN_BUF - unsemds.buff = (struct semid_ds *)a; + unsemds.buff = (struct semid_ds *)a; #else - unsemds.buf = (struct semid_ds *)a; + unsemds.buf = (struct semid_ds *)a; #endif + } ret = Semctl(id, n, cmd, unsemds); #else /* diag_listed_as: sem%s not implemented */ @@ -2155,6 +2204,7 @@ Perl_do_msgsnd(pTHX_ SV **mark, SV **sp) PERL_UNUSED_ARG(mark); /* diag_listed_as: msg%s not implemented */ Perl_croak(aTHX_ "msgsnd not implemented"); + return -1; #endif } @@ -2186,10 +2236,8 @@ Perl_do_msgrcv(pTHX_ SV **mark, SV **sp) if (ret >= 0) { SvCUR_set(mstr, sizeof(long)+ret); *SvEND(mstr) = '\0'; -#ifndef INCOMPLETE_TAINTS /* who knows who has been playing with this message? */ SvTAINTED_on(mstr); -#endif } return ret; #else @@ -2197,6 +2245,7 @@ Perl_do_msgrcv(pTHX_ SV **mark, SV **sp) PERL_UNUSED_ARG(mark); /* diag_listed_as: msg%s not implemented */ Perl_croak(aTHX_ "msgrcv not implemented"); + return -1; #endif } @@ -2237,15 +2286,6 @@ Perl_do_semop(pTHX_ SV **mark, SV **sp) t++; } result = semop(id, temps, nsops); - t = temps; - o = ops; - i = nsops; - while (i--) { - *o++ = t->sem_num; - *o++ = t->sem_op; - *o++ = t->sem_flg; - t++; - } Safefree(temps); return result; } @@ -2295,10 +2335,8 @@ Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp) SvCUR_set(mstr, msize); *SvEND(mstr) = '\0'; SvSETMAGIC(mstr); -#ifndef INCOMPLETE_TAINTS /* who knows who has been playing with this shared memory? */ SvTAINTED_on(mstr); -#endif } else { STRLEN len; @@ -2313,6 +2351,7 @@ Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp) #else /* diag_listed_as: shm%s not implemented */ Perl_croak(aTHX_ "shm I/O not implemented"); + return -1; #endif } @@ -2324,7 +2363,7 @@ Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp) =for apidoc start_glob 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 +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. Moving it away shrinks pp_hot.c; shrinking pp_hot.c helps speed perl up. @@ -2337,9 +2376,14 @@ Perl_start_glob (pTHX_ SV *tmpglob, IO *io) dVAR; SV * const tmpcmd = newSV(0); PerlIO *fp; + STRLEN len; + const char *s = SvPV(tmpglob, len); PERL_ARGS_ASSERT_START_GLOB; + if (!IS_SAFE_SYSCALL(s, len, "pattern", "glob")) + return NULL; + ENTER; SAVEFREESV(tmpcmd); #ifdef VMS /* expand the wildcards right here, rather than opening a pipe, */ @@ -2377,11 +2421,7 @@ Perl_vms_start_glob #else sv_setpv(tmpcmd, "echo "); sv_catsv(tmpcmd, tmpglob); -#if 'z' - 'a' == 25 - sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\012\\012\\012\\012'|"); -#else sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\n\\n\\n\\n'|"); -#endif #endif /* !CSH */ #endif /* !DOSISH */ { @@ -2399,6 +2439,12 @@ Perl_vms_start_glob fp = IoIFP(io); #endif /* !VMS */ LEAVE; + + if (!fp && ckWARN(WARN_GLOB)) { + Perl_warner(aTHX_ packWARN(WARN_GLOB), "glob failed (can't start child: %s)", + Strerror(errno)); + } + return fp; }