#include <signal.h>
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)
{
dVAR;
- register IO * const io = GvIOn(gv);
+ IO * const io = GvIOn(gv);
PerlIO *saveifp = NULL;
PerlIO *saveofp = NULL;
int savefd = -1;
*--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,'&')) {
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 {
}
while (isSPACE(*type))
type++;
- if (num_svs && (SvIOK(*svp) || (SvPOK(*svp) && looks_like_number(*svp)))) {
+ if (num_svs && (
+ SvIOK(*svp)
+ || (SvPOKp(*svp) && looks_like_number(*svp))
+ )) {
fd = SvUV(*svp);
num_svs = 0;
}
char newname[FILENAME_MAX+1];
if (PerlIO_getname(fp, newname)) {
if (fd == PerlIO_fileno(PerlIO_stdout()))
- Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT", newname);
+ vmssetuserlnm("SYS$OUTPUT", newname);
if (fd == PerlIO_fileno(PerlIO_stderr()))
- Perl_vmssetuserlnm(aTHX_ "SYS$ERROR", newname);
+ vmssetuserlnm("SYS$ERROR", newname);
}
}
#endif
}
PerlIO *
-Perl_nextargv(pTHX_ register GV *gv)
+Perl_nextargv(pTHX_ GV *gv)
{
dVAR;
- register SV *sv;
+ SV *sv;
#ifndef FLEXFILENAMES
int filedev;
int fileino;
STRLEN oldlen;
sv = av_shift(GvAV(gv));
SAVEFREESV(sv);
+ SvTAINTED_off(GvSVn(gv)); /* previous tainting irrelevant */
sv_setsv(GvSVn(gv),sv);
SvSETMAGIC(GvSV(gv));
PL_oldname = SvPVx(GvSV(gv), oldlen);
}
#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",
{
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));
Perl_do_eof(pTHX_ GV *gv)
{
dVAR;
- register IO * const io = GvIO(gv);
+ IO * const io = GvIO(gv);
PERL_ARGS_ASSERT_DO_EOF;
{
dVAR;
IO *const io = GvIO(gv);
- register PerlIO *fp;
+ PerlIO *fp;
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);
{
dVAR;
IO *const io = GvIO(gv);
- register PerlIO *fp;
+ 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);
{
dVAR;
IO *const io = GvIO(gv);
- register PerlIO *fp;
+ PerlIO *fp;
PERL_ARGS_ASSERT_DO_SYSSEEK;
#endif /* !HAS_TRUNCATE && !HAS_CHSIZE */
bool
-Perl_do_print(pTHX_ register SV *sv, PerlIO *fp)
+Perl_do_print(pTHX_ SV *sv, PerlIO *fp)
{
dVAR;
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)));
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_EXEC), "Can't exec \"%s\": %s",
cmd, Strerror(e));
if (do_report) {
- PerlLIO_write(fd, (void*)&e, sizeof(int));
+ (void)PerlLIO_write(fd, (void*)&e, sizeof(int));
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;
Perl_do_exec3(pTHX_ const char *incmd, int fd, int do_report)
{
dVAR;
- register const char **a;
- register char *s;
+ const char **a;
+ char *s;
char *buf;
char *cmd;
/* Make a copy so we can change it */
goto doshell;
s = cmd;
- while (isALNUM(*s))
+ while (isWORDCHAR(*s))
s++; /* catch VAR=val gizmo */
if (*s == '=')
goto doshell;
#endif
I32
-Perl_apply(pTHX_ I32 type, register SV **mark, register SV **sp)
+Perl_apply(pTHX_ I32 type, SV **mark, SV **sp)
{
dVAR;
- register I32 val;
- register I32 tot = 0;
+ I32 val;
+ I32 tot = 0;
const char *const what = PL_op_name[type];
const char *s;
STRLEN len;
SV ** const oldmark = mark;
+ bool killgp = FALSE;
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. */
#define APPLY_TAINT_PROPER() \
STMT_START { \
- if (PL_tainted) { TAINT_PROPER(what); } \
+ if (TAINT_get) { TAINT_PROPER(what); } \
} STMT_END
/* This is a first heuristic; it doesn't catch tainting magic. */
- if (PL_tainting) {
+ if (TAINTING_get) {
while (++mark <= sp) {
if (SvTAINTED(*mark)) {
TAINT;
}
}
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--;
+ }
}
}
}
case OP_CHOWN:
APPLY_TAINT_PROPER();
if (sp - mark > 2) {
- register I32 val2;
+ I32 val2;
val = SvIVx(*++mark);
val2 = SvIVx(*++mark);
APPLY_TAINT_PROPER();
}
}
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--;
+ }
}
}
}
if (mark == sp)
break;
s = SvPVx_const(*++mark, len);
+ if (*s == '-' && isALPHA(s[1]))
+ {
+ s++;
+ len--;
+ killgp = TRUE;
+ }
if (isALPHA(*s)) {
if (*s == 'S' && s[1] == 'I' && s[2] == 'G') {
s += 3;
Perl_croak(aTHX_ "Unrecognized signal name \"%"SVf"\"", SVfARG(*mark));
}
else
+ {
val = SvIV(*mark);
+ if (val < 0)
+ {
+ killgp = TRUE;
+ val = -val;
+ }
+ }
APPLY_TAINT_PROPER();
tot = sp - mark;
#ifdef VMS
/* kill() doesn't do process groups (job trees?) under VMS */
- if (val < 0) val = -val;
if (val == SIGKILL) {
/* Use native sys$delprc() to insure that target process is
* deleted; supervisor-mode images don't pay attention to
*/
while (++mark <= sp) {
I32 proc;
- register unsigned long int __vmssts;
+ 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");
break;
}
#endif
- if (val < 0) {
- val = -val;
- while (++mark <= sp) {
- I32 proc;
- 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();
-#ifdef HAS_KILLPG
- if (PerlProc_killpg(proc,val)) /* BSD */
-#else
- if (PerlProc_kill(-proc,val)) /* SYSV */
-#endif
- tot--;
- }
- }
- else {
- while (++mark <= sp) {
- I32 proc;
- 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 (PerlProc_kill(proc, val))
- tot--;
+ while (++mark <= sp) {
+ Pid_t proc;
+ SvGETMAGIC(*mark);
+ if (!(SvNIOK(*mark) || looks_like_number(*mark)))
+ Perl_croak(aTHX_ "Can't kill a non-numeric process ID");
+ proc = SvIV_nomg(*mark);
+ if (killgp)
+ {
+ proc = -proc;
}
+ APPLY_TAINT_PROPER();
+ if (PerlProc_kill(proc, val))
+ tot--;
}
PERL_ASYNC_CHECK();
break;
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 (PerlProc_geteuid() || PL_unsafe) {
if (UNLINK(s))
tot--;
}
}
}
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
/* 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().
*/
PERL_UNUSED_ARG(mark);
/* diag_listed_as: msg%s not implemented */
Perl_croak(aTHX_ "msgsnd not implemented");
+ return -1;
#endif
}
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
PERL_UNUSED_ARG(mark);
/* diag_listed_as: msg%s not implemented */
Perl_croak(aTHX_ "msgrcv not implemented");
+ return -1;
#endif
}
if (optype == OP_SHMREAD) {
char *mbuf;
/* suppress warning when reading into undef var (tchrist 3/Mar/00) */
+ SvGETMAGIC(mstr);
+ SvUPGRADE(mstr, SVt_PV);
if (! SvOK(mstr))
sv_setpvs(mstr, "");
- SvUPGRADE(mstr, SVt_PV);
SvPOK_only(mstr);
mbuf = SvGROW(mstr, (STRLEN)msize+1);
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;
#else
/* diag_listed_as: shm%s not implemented */
Perl_croak(aTHX_ "shm I/O not implemented");
+ return -1;
#endif
}
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, */
{
GV * const envgv = gv_fetchpvs("ENV", 0, SVt_PVHV);
SV ** const home = hv_fetchs(GvHV(envgv), "HOME", 0);
+ SV ** const path = hv_fetchs(GvHV(envgv), "PATH", 0);
if (home && *home) SvGETMAGIC(*home);
+ if (path && *path) SvGETMAGIC(*path);
save_hash(gv_fetchpvs("ENV", 0, SVt_PVHV));
if (home && *home) SvSETMAGIC(*home);
+ if (path && *path) SvSETMAGIC(*path);
}
(void)do_open(PL_last_in_gv, (char*)SvPVX_const(tmpcmd), SvCUR(tmpcmd),
FALSE, O_RDONLY, 0, NULL);
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;
}
https://perl5.git.perl.org / perl5.git / blobdiff