diff options
| -rw-r--r-- | XSUB.h | 2 | ||||
| -rw-r--r-- | cop.h | 1 | ||||
| -rw-r--r-- | embed.h | 2 | ||||
| -rwxr-xr-x | embed.pl | 6 | ||||
| -rw-r--r-- | ext/File/Glob/bsd_glob.c | 217 | ||||
| -rw-r--r-- | perl.c | 28 | ||||
| -rw-r--r--[-rwxr-xr-x] | perlapi.c | 8 | ||||
| -rw-r--r--[-rwxr-xr-x] | perlapi.h | 0 | ||||
| -rw-r--r-- | pp_ctl.c | 6 | ||||
| -rw-r--r-- | proto.h | 4 | ||||
| -rw-r--r-- | scope.c | 11 | ||||
| -rw-r--r-- | scope.h | 66 | ||||
| -rwxr-xr-x[-rw-r--r--] | t/op/filetest.t | 0 | ||||
| -rwxr-xr-x | t/op/runlevel.t | 14 | ||||
| -rwxr-xr-x[-rw-r--r--] | t/op/subst_amp.t | 0 | ||||
| -rw-r--r-- | util.c | 6 | ||||
| -rw-r--r-- | utils/h2xs.PL | 18 | ||||
| -rw-r--r-- | win32/Makefile | 17 | ||||
| -rw-r--r-- | win32/makefile.mk | 16 |
19 files changed, 242 insertions, 180 deletions
@@ -203,7 +203,7 @@ # define read PerlLIO_read # define rename PerlLIO_rename # define setmode PerlLIO_setmode -# define stat PerlLIO_stat +# define stat(buf,sb) PerlLIO_stat(buf,sb) # define tmpnam PerlLIO_tmpnam # define umask PerlLIO_umask # define unlink PerlLIO_unlink @@ -296,7 +296,6 @@ struct context { #define G_NOARGS 8 /* Don't construct a @_ array. */ #define G_KEEPERR 16 /* Append errors to $@, don't overwrite it */ #define G_NODEBUG 32 /* Disable debugging at toplevel. */ -#define G_NOCATCH 64 /* Don't do CATCH_SET() */ /* flag bits for PL_in_eval */ #define EVAL_NULL 0 /* not in an eval */ @@ -2102,7 +2102,7 @@ #define do_pmop_dump(a,b,c) Perl_do_pmop_dump(aTHX_ a,b,c) #define do_sv_dump(a,b,c,d,e,f,g) Perl_do_sv_dump(aTHX_ a,b,c,d,e,f,g) #define magic_dump(a) Perl_magic_dump(aTHX_ a) -#define vdefault_protect(a,b,c) Perl_vdefault_protect(aTHX_ a,b,c) +#define vdefault_protect(a,b,c,d) Perl_vdefault_protect(aTHX_ a,b,c,d) #define reginitcolors() Perl_reginitcolors(aTHX) #define sv_2pv_nolen(a) Perl_sv_2pv_nolen(aTHX_ a) #define sv_pv(a) Perl_sv_pv(aTHX_ a) @@ -1756,8 +1756,10 @@ p |void |do_pmop_dump |I32 level|PerlIO *file|PMOP *pm p |void |do_sv_dump |I32 level|PerlIO *file|SV *sv|I32 nest \ |I32 maxnest|bool dumpops|STRLEN pvlim p |void |magic_dump |MAGIC *mg -p |void* |default_protect|int *excpt|protect_body_t body|... -p |void* |vdefault_protect|int *excpt|protect_body_t body|va_list *args +p |void* |default_protect|volatile JMPENV *je|int *excpt \ + |protect_body_t body|... +p |void* |vdefault_protect|volatile JMPENV *je|int *excpt \ + |protect_body_t body|va_list *args p |void |reginitcolors p |char* |sv_2pv_nolen |SV* sv p |char* |sv_pv |SV *sv diff --git a/ext/File/Glob/bsd_glob.c b/ext/File/Glob/bsd_glob.c index 38ace47ca5..3ff4c9203d 100644 --- a/ext/File/Glob/bsd_glob.c +++ b/ext/File/Glob/bsd_glob.c @@ -71,6 +71,8 @@ static char sccsid[] = "@(#)glob.c 8.3 (Berkeley) 10/13/93"; #include <EXTERN.h> #include <perl.h> +#include <XSUB.h> + #include "bsd_glob.h" #ifdef I_PWD # include <pwd.h> @@ -89,23 +91,23 @@ static char sccsid[] = "@(#)glob.c 8.3 (Berkeley) 10/13/93"; # endif #endif -#define DOLLAR '$' -#define DOT '.' -#define EOS '\0' -#define LBRACKET '[' -#define NOT '!' -#define QUESTION '?' -#define QUOTE '\\' -#define RANGE '-' -#define RBRACKET ']' -#define SEP '/' -#define STAR '*' -#define TILDE '~' -#define UNDERSCORE '_' -#define LBRACE '{' -#define RBRACE '}' -#define SLASH '/' -#define COMMA ',' +#define BG_DOLLAR '$' +#define BG_DOT '.' +#define BG_EOS '\0' +#define BG_LBRACKET '[' +#define BG_NOT '!' +#define BG_QUESTION '?' +#define BG_QUOTE '\\' +#define BG_RANGE '-' +#define BG_RBRACKET ']' +#define BG_SEP '/' +#define BG_STAR '*' +#define BG_TILDE '~' +#define BG_UNDERSCORE '_' +#define BG_LBRACE '{' +#define BG_RBRACE '}' +#define BG_SLASH '/' +#define BG_COMMA ',' #ifndef GLOB_DEBUG @@ -161,6 +163,18 @@ static int match(Char *, Char *, Char *); static void qprintf(const char *, Char *); #endif /* GLOB_DEBUG */ +#ifdef PERL_IMPLICIT_CONTEXT +static Direntry_t * my_readdir(DIR*); + +static Direntry_t * +my_readdir(DIR *d) +{ + return PerlDir_read(d); +} +#else +#define my_readdir readdir +#endif + int bsd_glob(const char *pattern, int flags, int (*errfunc)(const char *, int), glob_t *pglob) @@ -184,10 +198,10 @@ bsd_glob(const char *pattern, int flags, bufend = bufnext + MAXPATHLEN; if (flags & GLOB_QUOTE) { /* Protect the quoted characters. */ - while (bufnext < bufend && (c = *patnext++) != EOS) - if (c == QUOTE) { - if ((c = *patnext++) == EOS) { - c = QUOTE; + while (bufnext < bufend && (c = *patnext++) != BG_EOS) + if (c == BG_QUOTE) { + if ((c = *patnext++) == BG_EOS) { + c = BG_QUOTE; --patnext; } *bufnext++ = c | M_PROTECT; @@ -196,9 +210,9 @@ bsd_glob(const char *pattern, int flags, *bufnext++ = c; } else - while (bufnext < bufend && (c = *patnext++) != EOS) + while (bufnext < bufend && (c = *patnext++) != BG_EOS) *bufnext++ = c; - *bufnext = EOS; + *bufnext = BG_EOS; if (flags & GLOB_BRACE) return globexp1(patbuf, pglob); @@ -217,10 +231,10 @@ static int globexp1(const Char *pattern, glob_t *pglob) int rv; /* Protect a single {}, for find(1), like csh */ - if (pattern[0] == LBRACE && pattern[1] == RBRACE && pattern[2] == EOS) + if (pattern[0] == BG_LBRACE && pattern[1] == BG_RBRACE && pattern[2] == BG_EOS) return glob0(pattern, pglob); - while ((ptr = (const Char *) g_strchr((Char *) ptr, LBRACE)) != NULL) + while ((ptr = (const Char *) g_strchr((Char *) ptr, BG_LBRACE)) != NULL) if (!globexp2(ptr, pattern, pglob, &rv)) return rv; @@ -248,59 +262,59 @@ static int globexp2(const Char *ptr, const Char *pattern, /* Find the balanced brace */ for (i = 0, pe = ++ptr; *pe; pe++) - if (*pe == LBRACKET) { + if (*pe == BG_LBRACKET) { /* Ignore everything between [] */ - for (pm = pe++; *pe != RBRACKET && *pe != EOS; pe++) + for (pm = pe++; *pe != BG_RBRACKET && *pe != BG_EOS; pe++) continue; - if (*pe == EOS) { + if (*pe == BG_EOS) { /* - * We could not find a matching RBRACKET. - * Ignore and just look for RBRACE + * We could not find a matching BG_RBRACKET. + * Ignore and just look for BG_RBRACE */ pe = pm; } } - else if (*pe == LBRACE) + else if (*pe == BG_LBRACE) i++; - else if (*pe == RBRACE) { + else if (*pe == BG_RBRACE) { if (i == 0) break; i--; } /* Non matching braces; just glob the pattern */ - if (i != 0 || *pe == EOS) { + if (i != 0 || *pe == BG_EOS) { *rv = glob0(patbuf, pglob); return 0; } for (i = 0, pl = pm = ptr; pm <= pe; pm++) switch (*pm) { - case LBRACKET: + case BG_LBRACKET: /* Ignore everything between [] */ - for (pl = pm++; *pm != RBRACKET && *pm != EOS; pm++) + for (pl = pm++; *pm != BG_RBRACKET && *pm != BG_EOS; pm++) continue; - if (*pm == EOS) { + if (*pm == BG_EOS) { /* - * We could not find a matching RBRACKET. - * Ignore and just look for RBRACE + * We could not find a matching BG_RBRACKET. + * Ignore and just look for BG_RBRACE */ pm = pl; } break; - case LBRACE: + case BG_LBRACE: i++; break; - case RBRACE: + case BG_RBRACE: if (i) { i--; break; } /* FALLTHROUGH */ - case COMMA: - if (i && *pm == COMMA) + case BG_COMMA: + if (i && *pm == BG_COMMA) break; else { /* Append the current string */ @@ -310,7 +324,7 @@ static int globexp2(const Char *ptr, const Char *pattern, * Append the rest of the pattern after the * closing brace */ - for (pl = pe + 1; (*lm++ = *pl++) != EOS;) + for (pl = pe + 1; (*lm++ = *pl++) != BG_EOS;) continue; /* Expand the current pattern */ @@ -344,17 +358,17 @@ globtilde(const Char *pattern, Char *patbuf, glob_t *pglob) const Char *p; Char *b; - if (*pattern != TILDE || !(pglob->gl_flags & GLOB_TILDE)) + if (*pattern != BG_TILDE || !(pglob->gl_flags & GLOB_TILDE)) return pattern; /* Copy up to the end of the string or / */ - for (p = pattern + 1, h = (char *) patbuf; *p && *p != SLASH; + for (p = pattern + 1, h = (char *) patbuf; *p && *p != BG_SLASH; *h++ = *p++) continue; - *h = EOS; + *h = BG_EOS; - if (((char *) patbuf)[0] == EOS) { + if (((char *) patbuf)[0] == BG_EOS) { /* * handle a plain ~ or ~/ by expanding $HOME * first and then trying the password file @@ -389,7 +403,7 @@ globtilde(const Char *pattern, Char *patbuf, glob_t *pglob) continue; /* Append the rest of the pattern */ - while ((*b++ = *p++) != EOS) + while ((*b++ = *p++) != BG_EOS) continue; return patbuf; @@ -417,40 +431,40 @@ glob0(const Char *pattern, glob_t *pglob) bufnext = patbuf; /* We don't need to check for buffer overflow any more. */ - while ((c = *qpatnext++) != EOS) { + while ((c = *qpatnext++) != BG_EOS) { switch (c) { - case LBRACKET: + case BG_LBRACKET: c = *qpatnext; - if (c == NOT) + if (c == BG_NOT) ++qpatnext; - if (*qpatnext == EOS || - g_strchr((Char *) qpatnext+1, RBRACKET) == NULL) { - *bufnext++ = LBRACKET; - if (c == NOT) + if (*qpatnext == BG_EOS || + g_strchr((Char *) qpatnext+1, BG_RBRACKET) == NULL) { + *bufnext++ = BG_LBRACKET; + if (c == BG_NOT) --qpatnext; break; } *bufnext++ = M_SET; - if (c == NOT) + if (c == BG_NOT) *bufnext++ = M_NOT; c = *qpatnext++; do { *bufnext++ = CHAR(c); - if (*qpatnext == RANGE && - (c = qpatnext[1]) != RBRACKET) { + if (*qpatnext == BG_RANGE && + (c = qpatnext[1]) != BG_RBRACKET) { *bufnext++ = M_RNG; *bufnext++ = CHAR(c); qpatnext += 2; } - } while ((c = *qpatnext++) != RBRACKET); + } while ((c = *qpatnext++) != BG_RBRACKET); pglob->gl_flags |= GLOB_MAGCHAR; *bufnext++ = M_END; break; - case QUESTION: + case BG_QUESTION: pglob->gl_flags |= GLOB_MAGCHAR; *bufnext++ = M_ONE; break; - case STAR: + case BG_STAR: pglob->gl_flags |= GLOB_MAGCHAR; /* collapse adjacent stars to one, * to avoid exponential behavior @@ -463,7 +477,7 @@ glob0(const Char *pattern, glob_t *pglob) break; } } - *bufnext = EOS; + *bufnext = BG_EOS; #ifdef GLOB_DEBUG qprintf("glob0:", patbuf); #endif /* GLOB_DEBUG */ @@ -509,7 +523,7 @@ glob1(Char *pattern, glob_t *pglob) Char pathbuf[MAXPATHLEN+1]; /* A null pathname is invalid -- POSIX 1003.1 sect. 2.4. */ - if (*pattern == EOS) + if (*pattern == BG_EOS) return(0); return(glob2(pathbuf, pathbuf, pattern, pglob)); } @@ -531,21 +545,19 @@ glob2(Char *pathbuf, Char *pathend, Char *pattern, glob_t *pglob) * segment with meta character found. */ for (anymeta = 0;;) { - if (*pattern == EOS) { /* End of pattern? */ - *pathend = EOS; + if (*pattern == BG_EOS) { /* End of pattern? */ + *pathend = BG_EOS; -#ifdef HAS_LSTAT if (g_lstat(pathbuf, &sb, pglob)) return(0); -#endif /* HAS_LSTAT */ if (((pglob->gl_flags & GLOB_MARK) && - pathend[-1] != SEP) && (S_ISDIR(sb.st_mode) + pathend[-1] != BG_SEP) && (S_ISDIR(sb.st_mode) || (S_ISLNK(sb.st_mode) && (g_stat(pathbuf, &sb, pglob) == 0) && S_ISDIR(sb.st_mode)))) { - *pathend++ = SEP; - *pathend = EOS; + *pathend++ = BG_SEP; + *pathend = BG_EOS; } ++pglob->gl_matchc; #ifdef GLOB_DEBUG @@ -557,7 +569,7 @@ glob2(Char *pathbuf, Char *pathend, Char *pattern, glob_t *pglob) /* Find end of next segment, copy tentatively to pathend. */ q = pathend; p = pattern; - while (*p != EOS && *p != SEP) { + while (*p != BG_EOS && *p != BG_SEP) { if (ismeta(*p)) anymeta = 1; *q++ = *p++; @@ -566,7 +578,7 @@ glob2(Char *pathbuf, Char *pathend, Char *pattern, glob_t *pglob) if (!anymeta) { /* No expansion, do next segment. */ pathend = q; pattern = p; - while (*pattern == SEP) + while (*pattern == BG_SEP) *pathend++ = *pattern++; } else /* Need expansion, recurse. */ return(glob3(pathbuf, pathend, pattern, p, pglob)); @@ -591,7 +603,7 @@ glob3(Char *pathbuf, Char *pathend, Char *pattern, */ Direntry_t *(*readdirfunc)(); - *pathend = EOS; + *pathend = BG_EOS; errno = 0; if ((dirp = g_opendir(pathbuf, pglob)) == NULL) { @@ -611,19 +623,19 @@ glob3(Char *pathbuf, Char *pathend, Char *pattern, if (pglob->gl_flags & GLOB_ALTDIRFUNC) readdirfunc = pglob->gl_readdir; else - readdirfunc = readdir; + readdirfunc = my_readdir; while ((dp = (*readdirfunc)(dirp))) { register U8 *sc; register Char *dc; - /* Initial DOT must be matched literally. */ - if (dp->d_name[0] == DOT && *pattern != DOT) + /* Initial BG_DOT must be matched literally. */ + if (dp->d_name[0] == BG_DOT && *pattern != BG_DOT) continue; for (sc = (U8 *) dp->d_name, dc = pathend; - (*dc++ = *sc++) != EOS;) + (*dc++ = *sc++) != BG_EOS;) continue; if (!match(pathend, pattern, restpattern)) { - *pathend = EOS; + *pathend = BG_EOS; continue; } err = glob2(pathbuf, --dc, restpattern, pglob); @@ -634,7 +646,7 @@ glob3(Char *pathbuf, Char *pathend, Char *pattern, if (pglob->gl_flags & GLOB_ALTDIRFUNC) (*pglob->gl_closedir)(dirp); else - closedir(dirp); + PerlDir_close(dirp); return(err); } @@ -658,7 +670,6 @@ globextend(const Char *path, glob_t *pglob) { register char **pathv; register int i; - Size_t newsize; char *copy; const Char *p; @@ -667,12 +678,13 @@ globextend(const Char *path, glob_t *pglob) for (p = path; *p; p++) (void)printf("%c", CHAR(*p)); printf("\n"); -#endif GLOB_DEBUG +#endif /* GLOB_DEBUG */ - newsize = sizeof(*pathv) * (2 + pglob->gl_pathc + pglob->gl_offs); - pathv = pglob->gl_pathv ? - realloc((char *)pglob->gl_pathv, newsize) : - malloc(newsize); + if (pglob->gl_pathv) + pathv = Renew(pglob->gl_pathv, + (2 + pglob->gl_pathc + pglob->gl_offs),char*); + else + New(0,pathv,(2 + pglob->gl_pathc + pglob->gl_offs),char*); if (pathv == NULL) return(GLOB_NOSPACE); @@ -686,7 +698,8 @@ globextend(const Char *path, glob_t *pglob) for (p = path; *p++;) continue; - if ((copy = malloc(p - path)) != NULL) { + New(0, copy, p-path, char); + if (copy != NULL) { g_Ctoc(path, copy); pathv[pglob->gl_offs + pglob->gl_pathc++] = copy; } @@ -714,17 +727,17 @@ match(register Char *name, register Char *pat, register Char *patend) do if (match(name, pat, patend)) return(1); - while (*name++ != EOS); + while (*name++ != BG_EOS); return(0); case M_ONE: - if (*name++ == EOS) + if (*name++ == BG_EOS) return(0); break; case M_SET: ok = 0; - if ((k = *name++) == EOS) + if ((k = *name++) == BG_EOS) return(0); - if ((negate_range = ((*pat & M_MASK) == M_NOT)) != EOS) + if ((negate_range = ((*pat & M_MASK) == M_NOT)) != BG_EOS) ++pat; while (((c = *pat++) & M_MASK) != M_END) if ((*pat & M_MASK) == M_RNG) { @@ -742,7 +755,7 @@ match(register Char *name, register Char *pat, register Char *patend) break; } } - return(*name == EOS); + return(*name == BG_EOS); } /* Free allocated data belonging to a glob_t structure. */ @@ -756,8 +769,8 @@ bsd_globfree(glob_t *pglob) pp = pglob->gl_pathv + pglob->gl_offs; for (i = pglob->gl_pathc; i--; ++pp) if (*pp) - free(*pp); - free(pglob->gl_pathv); + Safefree(*pp); + Safefree(pglob->gl_pathv); } } @@ -773,11 +786,10 @@ g_opendir(register Char *str, glob_t *pglob) if (pglob->gl_flags & GLOB_ALTDIRFUNC) return((*pglob->gl_opendir)(buf)); - - return(opendir(buf)); + else + return(PerlDir_open(buf)); } -#ifdef HAS_LSTAT static int g_lstat(register Char *fn, Stat_t *sb, glob_t *pglob) { @@ -786,9 +798,12 @@ g_lstat(register Char *fn, Stat_t *sb, glob_t *pglob) g_Ctoc(fn, buf); if (pglob->gl_flags & GLOB_ALTDIRFUNC) return((*pglob->gl_lstat)(buf, sb)); - return(lstat(buf, sb)); -} +#ifdef HAS_LSTAT + return(PerlLIO_lstat(buf, sb)); +#else + return(PerlLIO_stat(buf, sb)); #endif /* HAS_LSTAT */ +} static int g_stat(register Char *fn, Stat_t *sb, glob_t *pglob) @@ -798,7 +813,7 @@ g_stat(register Char *fn, Stat_t *sb, glob_t *pglob) g_Ctoc(fn, buf); if (pglob->gl_flags & GLOB_ALTDIRFUNC) return((*pglob->gl_stat)(buf, sb)); - return(stat(buf, sb)); + return(PerlLIO_stat(buf, sb)); } static Char * @@ -820,7 +835,7 @@ g_strcat(Char *dst, const Char *src) while (*dst++) continue; --dst; - while((*dst++ = *src++) != EOS) + while((*dst++ = *src++) != BG_EOS) continue; return (sdst); @@ -832,7 +847,7 @@ g_Ctoc(register const Char *str, char *buf) { register char *dc; - for (dc = buf; (*dc++ = *str++) != EOS;) + for (dc = buf; (*dc++ = *str++) != BG_EOS;) continue; } @@ -590,6 +590,7 @@ perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env) dTHR; I32 oldscope; int ret; + dJMPENV; #ifdef USE_THREADS dTHX; #endif @@ -638,7 +639,8 @@ setuid perl scripts securely.\n"); oldscope = PL_scopestack_ix; PL_dowarn = G_WARN_OFF; - CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_parse_body), env, xsinit); + CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_parse_body), + env, xsinit); switch (ret) { case 0: return 0; @@ -1005,6 +1007,7 @@ perl_run(pTHXx) dTHR; I32 oldscope; int ret; + dJMPENV; #ifdef USE_THREADS dTHX; #endif @@ -1012,7 +1015,7 @@ perl_run(pTHXx) oldscope = PL_scopestack_ix; redo_body: - CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_run_body), oldscope); + CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_run_body), oldscope); switch (ret) { case 1: cxstack_ix = -1; /* start context stack again */ @@ -1206,6 +1209,7 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags) bool oldcatch = CATCH_GET; int ret; OP* oldop = PL_op; + dJMPENV; if (flags & G_DISCARD) { ENTER; @@ -1237,16 +1241,10 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags) PL_op->op_private |= OPpENTERSUB_DB; if (!(flags & G_EVAL)) { - /* G_NOCATCH is a hack for perl_vdie using this path to call - a __DIE__ handler */ - if (!(flags & G_NOCATCH)) { - CATCH_SET(TRUE); - } + CATCH_SET(TRUE); call_xbody((OP*)&myop, FALSE); retval = PL_stack_sp - (PL_stack_base + oldmark); - if (!(flags & G_NOCATCH)) { - CATCH_SET(FALSE); - } + CATCH_SET(FALSE); } else { cLOGOP->op_other = PL_op; @@ -1273,7 +1271,8 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags) PL_markstack_ptr++; redo_body: - CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_call_body), (OP*)&myop, FALSE); + CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body), + (OP*)&myop, FALSE); switch (ret) { case 0: retval = PL_stack_sp - (PL_stack_base + oldmark); @@ -1371,6 +1370,7 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags) I32 oldscope; int ret; OP* oldop = PL_op; + dJMPENV; if (flags & G_DISCARD) { ENTER; @@ -1395,7 +1395,8 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags) myop.op_flags |= OPf_SPECIAL; redo_body: - CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_call_body), (OP*)&myop, TRUE); + CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body), + (OP*)&myop, TRUE); switch (ret) { case 0: retval = PL_stack_sp - (PL_stack_base + oldmark); @@ -2990,11 +2991,12 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList) CV *cv; STRLEN len; int ret; + dJMPENV; while (AvFILL(paramList) >= 0) { cv = (CV*)av_shift(paramList); SAVEFREESV(cv); - CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_call_list_body), cv); + CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_list_body), cv); switch (ret) { case 0: (void)SvPV(atsv, len); diff --git a/perlapi.c b/perlapi.c index ac38dffdfb..99a549b403 100755..100644 --- a/perlapi.c +++ b/perlapi.c @@ -4754,12 +4754,12 @@ Perl_magic_dump(pTHXo_ MAGIC *mg) #undef Perl_default_protect void* -Perl_default_protect(pTHXo_ int *excpt, protect_body_t body, ...) +Perl_default_protect(pTHXo_ volatile JMPENV *je, int *excpt, protect_body_t body, ...) { void* retval; va_list args; va_start(args, body); - retval = ((CPerlObj*)pPerl)->Perl_vdefault_protect(excpt, body, &args); + retval = ((CPerlObj*)pPerl)->Perl_vdefault_protect(je, excpt, body, &args); va_end(args); return retval; @@ -4767,9 +4767,9 @@ Perl_default_protect(pTHXo_ int *excpt, protect_body_t body, ...) #undef Perl_vdefault_protect void* -Perl_vdefault_protect(pTHXo_ int *excpt, protect_body_t body, va_list *args) +Perl_vdefault_protect(pTHXo_ volatile JMPENV *je, int *excpt, protect_body_t body, va_list *args) { - return ((CPerlObj*)pPerl)->Perl_vdefault_protect(excpt, body, args); + return ((CPerlObj*)pPerl)->Perl_vdefault_protect(je, excpt, body, args); } #undef Perl_reginitcolors diff --git a/perlapi.h b/perlapi.h index 0dac61aa75..0dac61aa75 100755..100644 --- a/perlapi.h +++ b/perlapi.h @@ -2436,18 +2436,20 @@ S_docatch(pTHX_ OP *o) dTHR; int ret; OP *oldop = PL_op; + volatile PERL_SI *cursi = PL_curstackinfo; + dJMPENV; #ifdef DEBUGGING assert(CATCH_GET == TRUE); #endif PL_op = o; redo_body: - CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_docatch_body)); + CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body)); switch (ret) { case 0: break; case 3: - if (PL_restartop) { + if (PL_restartop && cursi == PL_curstackinfo) { PL_op = PL_restartop; PL_restartop = 0; goto redo_body; @@ -724,8 +724,8 @@ VIRTUAL void Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, OP *o); VIRTUAL void Perl_do_pmop_dump(pTHX_ I32 level, PerlIO *file, PMOP *pm); VIRTUAL void Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim); VIRTUAL void Perl_magic_dump(pTHX_ MAGIC *mg); -VIRTUAL void* Perl_default_protect(pTHX_ int *excpt, protect_body_t body, ...); -VIRTUAL void* Perl_vdefault_protect(pTHX_ int *excpt, protect_body_t body, va_list *args); +VIRTUAL void* Perl_default_protect(pTHX_ volatile JMPENV *je, int *excpt, protect_body_t body, ...); +VIRTUAL void* Perl_vdefault_protect(pTHX_ volatile JMPENV *je, int *excpt, protect_body_t body, va_list *args); VIRTUAL void Perl_reginitcolors(pTHX); VIRTUAL char* Perl_sv_2pv_nolen(pTHX_ SV* sv); VIRTUAL char* Perl_sv_pv(pTHX_ SV *sv); @@ -17,26 +17,27 @@ #include "perl.h" void * -Perl_default_protect(pTHX_ int *excpt, protect_body_t body, ...) +Perl_default_protect(pTHX_ volatile JMPENV *pcur_env, int *excpt, + protect_body_t body, ...) { void *ret; va_list args; va_start(args, body); - ret = vdefault_protect(excpt, body, &args); + ret = vdefault_protect(pcur_env, excpt, body, &args); va_end(args); return ret; } void * -Perl_vdefault_protect(pTHX_ int *excpt, protect_body_t body, va_list *args) +Perl_vdefault_protect(pTHX_ volatile JMPENV *pcur_env, int *excpt, + protect_body_t body, va_list *args) { dTHR; - dJMPENV; int ex; void *ret; DEBUG_l(Perl_deb(aTHX_ "Setting up local jumplevel %p, was %p\n", - &cur_env, PL_top_env)); + pcur_env, PL_top_env)); JMPENV_PUSH(ex); if (ex) ret = NULL; @@ -148,6 +148,7 @@ struct jmpenv { int je_ret; /* last exception thrown */ bool je_mustcatch; /* need to call longjmp()? */ void (*je_throw)(int v); /* last for bincompat */ + bool je_noset; /* no need for setjmp() */ }; typedef struct jmpenv JMPENV; @@ -157,7 +158,8 @@ typedef struct jmpenv JMPENV; * body of protected processing. */ typedef void *(CPERLscope(*protect_body_t)) (pTHX_ va_list); -typedef void *(CPERLscope(*protect_proc_t)) (pTHX_ int *, protect_body_t, ...); +typedef void *(CPERLscope(*protect_proc_t)) (pTHX_ volatile JMPENV *pcur_env, + int *, protect_body_t, ...); /* * How to build the first jmpenv. @@ -175,6 +177,7 @@ typedef void *(CPERLscope(*protect_proc_t)) (pTHX_ int *, protect_body_t, ...); PL_start_env.je_throw = NULL; \ PL_start_env.je_ret = -1; \ PL_start_env.je_mustcatch = TRUE; \ + PL_start_env.je_noset = 0; \ PL_top_env = &PL_start_env; \ } STMT_END @@ -216,43 +219,49 @@ typedef void *(CPERLscope(*protect_proc_t)) (pTHX_ int *, protect_body_t, ...); * JMPENV_POP; // don't forget this! */ -#define dJMPENV JMPENV cur_env +#define dJMPENV JMPENV cur_env; \ + volatile JMPENV *pcur_env = ((cur_env.je_noset = 0),&cur_env) -#define JMPENV_PUSH_INIT_ENV(cur_env,THROWFUNC) \ +#define JMPENV_PUSH_INIT_ENV(ce,THROWFUNC) \ STMT_START { \ - cur_env.je_throw = (THROWFUNC); \ - cur_env.je_ret = -1; \ - cur_env.je_mustcatch = FALSE; \ - cur_env.je_prev = PL_top_env; \ - PL_top_env = &cur_env; \ + (ce).je_throw = (THROWFUNC); \ + (ce).je_ret = -1; \ + (ce).je_mustcatch = FALSE; \ + (ce).je_prev = PL_top_env; \ + PL_top_env = &(ce); \ OP_REG_TO_MEM; \ } STMT_END -#define JMPENV_PUSH_INIT(THROWFUNC) JMPENV_PUSH_INIT_ENV(cur_env,THROWFUNC) +#define JMPENV_PUSH_INIT(THROWFUNC) JMPENV_PUSH_INIT_ENV(*(JMPENV*)pcur_env,THROWFUNC) -#define JMPENV_POST_CATCH_ENV(cur_env) \ +#define JMPENV_POST_CATCH_ENV(ce) \ STMT_START { \ OP_MEM_TO_REG; \ - PL_top_env = &cur_env; \ + PL_top_env = &(ce); \ } STMT_END -#define JMPENV_POST_CATCH JMPENV_POST_CATCH_ENV(cur_env) +#define JMPENV_POST_CATCH JMPENV_POST_CATCH_ENV(*(JMPENV*)pcur_env) -#define JMPENV_PUSH_ENV(cur_env,v) \ - STMT_START { \ - JMPENV_PUSH_INIT_ENV(cur_env,NULL); \ - EXCEPT_SET_ENV(cur_env,PerlProc_setjmp(cur_env.je_buf, 1)); \ - JMPENV_POST_CATCH_ENV(cur_env); \ - (v) = EXCEPT_GET_ENV(cur_env); \ +#define JMPENV_PUSH_ENV(ce,v) \ + STMT_START { \ + if (!(ce).je_noset) { \ + JMPENV_PUSH_INIT_ENV(ce,NULL); \ + EXCEPT_SET_ENV(ce,PerlProc_setjmp((ce).je_buf, 1));\ + (ce).je_noset = 1; \ + } \ + else \ + EXCEPT_SET_ENV(ce,0); \ + JMPENV_POST_CATCH_ENV(ce); \ + (v) = EXCEPT_GET_ENV(ce); \ } STMT_END -#define JMPENV_PUSH(v) JMPENV_PUSH_ENV(cur_env,v) +#define JMPENV_PUSH(v) JMPENV_PUSH_ENV(*(JMPENV*)pcur_env,v) -#define JMPENV_POP_ENV(cur_env) \ - STMT_START { PL_top_env = cur_env.je_prev; } STMT_END +#define JMPENV_POP_ENV(ce) \ + STMT_START { PL_top_env = (ce).je_prev; } STMT_END -#define JMPENV_POP JMPENV_POP_ENV(cur_env) +#define JMPENV_POP JMPENV_POP_ENV(*(JMPENV*)pcur_env) #define JMPENV_JUMP(v) \ STMT_START { \ @@ -269,11 +278,10 @@ typedef void *(CPERLscope(*protect_proc_t)) (pTHX_ int *, protect_body_t, ...); PerlProc_exit(1); \ } STMT_END -#define EXCEPT_GET_ENV(cur_env) (cur_env.je_ret) -#define EXCEPT_GET EXCEPT_GET_ENV(cur_env) -#define EXCEPT_SET_ENV(cur_env,v) (cur_env.je_ret = (v)) -#define EXCEPT_SET(v) EXCEPT_SET_ENV(cur_env,v) +#define EXCEPT_GET_ENV(ce) ((ce).je_ret) +#define EXCEPT_GET EXCEPT_GET_ENV(*(JMPENV*)pcur_env) +#define EXCEPT_SET_ENV(ce,v) ((ce).je_ret = (v)) +#define EXCEPT_SET(v) EXCEPT_SET_ENV(*(JMPENV*)pcur_env,v) -#define CATCH_GET (PL_top_env->je_mustcatch) -#define CATCH_SET(v) (PL_top_env->je_mustcatch = (v)) - +#define CATCH_GET (PL_top_env->je_mustcatch) +#define CATCH_SET(v) (PL_top_env->je_mustcatch = (v)) diff --git a/t/op/filetest.t b/t/op/filetest.t index e00d5fb7b0..e00d5fb7b0 100644..100755 --- a/t/op/filetest.t +++ b/t/op/filetest.t diff --git a/t/op/runlevel.t b/t/op/runlevel.t index a1551775e3..1dc2a234b2 100755 --- a/t/op/runlevel.t +++ b/t/op/runlevel.t @@ -335,3 +335,17 @@ tie my @bar, 'TEST'; print join('|', @bar[0..3]), "\n"; EXPECT foo|fee|fie|foe +######## +package TH; +sub TIEHASH { bless {}, TH } +sub STORE { eval { print "@_[1,2]\n" }; die "bar\n" } +tie %h, TH; +eval { $h{A} = 1; print "never\n"; }; +print $@; +eval { $h{B} = 2; }; +print $@; +EXPECT +A 1 +bar +B 2 +bar diff --git a/t/op/subst_amp.t b/t/op/subst_amp.t index e2e7c0e542..e2e7c0e542 100644..100755 --- a/t/op/subst_amp.t +++ b/t/op/subst_amp.t @@ -1495,11 +1495,7 @@ Perl_vdie(pTHX_ const char* pat, va_list *args) PUSHMARK(SP); XPUSHs(msg); PUTBACK; - /* HACK - REVISIT - avoid CATCH_SET(TRUE) in call_sv() - or we come back here due to a JMPENV_JMP() and do - a POPSTACK - but die_where() will have already done - one as it unwound - NI-S 1999/08/14 */ - call_sv((SV*)cv, G_DISCARD|G_NOCATCH); + call_sv((SV*)cv, G_DISCARD); POPSTACK; LEAVE; } diff --git a/utils/h2xs.PL b/utils/h2xs.PL index 730a730e26..7d72e8a1a8 100644 --- a/utils/h2xs.PL +++ b/utils/h2xs.PL @@ -630,13 +630,14 @@ warn "Writing $ext$modpname/$modfname.pm\n"; print PM <<"END"; package $module; +require 5.005_62; use strict; END if( $opt_X || $opt_c || $opt_A ){ # we won't have our own AUTOLOAD(), so won't have $AUTOLOAD print PM <<'END'; -use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); +our @EXPORT_OK; END } else{ @@ -644,7 +645,7 @@ else{ # will want Carp. print PM <<'END'; use Carp; -use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $AUTOLOAD); +our @EXPORT_OK; END } @@ -669,7 +670,7 @@ unless ($opt_A) { # no autoloader whatsoever. } # Determine @ISA. -my $myISA = '@ISA = qw(Exporter'; # We seem to always want this. +my $myISA = 'our @ISA = qw(Exporter'; # We seem to always want this. $myISA .= ' DynaLoader' unless $opt_X; # no XS $myISA .= ');'; print PM "\n$myISA\n\n"; @@ -684,16 +685,16 @@ print PM<<"END"; # This allows declaration use $module ':all'; # If you do not need this, moving things directly into \@EXPORT or \@EXPORT_OK # will save memory. -%EXPORT_TAGS = ( 'all' => [ qw( +our %EXPORT_TAGS = ( 'all' => [ qw( @exported_names ) ] ); -\@EXPORT_OK = ( \@{ \$EXPORT_TAGS{'all'} } ); - -\@EXPORT = ( +our \@EXPORT_OK = ( \@{ \$EXPORT_TAGS{'all'} } ); +our \@EXPORT = qw( + @const_names ); -\$VERSION = '$TEMPLATE_VERSION'; +our \$VERSION = '$TEMPLATE_VERSION'; END @@ -704,6 +705,7 @@ sub AUTOLOAD { # to the AUTOLOAD in AutoLoader. my \$constname; + our $AUTOLOAD; (\$constname = \$AUTOLOAD) =~ s/.*:://; croak "&$module::constant not defined" if \$constname eq 'constant'; my \$val = constant(\$constname, \@_ ? \$_[0] : 0); diff --git a/win32/Makefile b/win32/Makefile index 57e9d440c3..def59fc757 100644 --- a/win32/Makefile +++ b/win32/Makefile @@ -546,7 +546,7 @@ SETARGV_OBJ = setargv$(o) !ENDIF DYNAMIC_EXT = Socket IO Fcntl Opcode SDBM_File POSIX attrs Thread B re \ - Data/Dumper Devel/Peek ByteLoader Devel/DProf + Data/Dumper Devel/Peek ByteLoader Devel/DProf File/Glob STATIC_EXT = DynaLoader NONXS_EXT = Errno @@ -566,6 +566,7 @@ ERRNO = $(EXTDIR)\Errno\Errno PEEK = $(EXTDIR)\Devel\Peek\Peek BYTELOADER = $(EXTDIR)\ByteLoader\ByteLoader DPROF = $(EXTDIR)\Devel\DProf\DProf +GLOB = $(EXTDIR)\File\Glob\Glob SOCKET_DLL = $(AUTODIR)\Socket\Socket.dll FCNTL_DLL = $(AUTODIR)\Fcntl\Fcntl.dll @@ -581,6 +582,7 @@ PEEK_DLL = $(AUTODIR)\Devel\Peek\Peek.dll RE_DLL = $(AUTODIR)\re\re.dll BYTELOADER_DLL = $(AUTODIR)\ByteLoader\ByteLoader.dll DPROF_DLL = $(AUTODIR)\Devel\DProf\DProf.dll +GLOB_DLL = $(AUTODIR)\File\Glob\Glob.dll ERRNO_PM = $(LIBDIR)\Errno.pm @@ -598,7 +600,8 @@ EXTENSION_C = \ $(PEEK).c \ $(B).c \ $(BYTELOADER).c \ - $(DPROF).c + $(DPROF).c \ + $(GLOB).c EXTENSION_DLL = \ $(SOCKET_DLL) \ @@ -614,7 +617,8 @@ EXTENSION_DLL = \ $(RE_DLL) \ $(THREAD_DLL) \ $(BYTELOADER_DLL) \ - $(DPROF_DLL) + $(DPROF_DLL) \ + $(GLOB_DLL) EXTENSION_PM = \ $(ERRNO_PM) @@ -823,6 +827,12 @@ $(DPROF_DLL): $(PERLEXE) $(DPROF).xs $(MAKE) cd ..\..\..\win32 +$(GLOB_DLL): $(PERLEXE) $(GLOB).xs + cd $(EXTDIR)\File\$(*B) + ..\..\..\miniperl -I..\..\..\lib Makefile.PL INSTALLDIRS=perl + $(MAKE) + cd ..\..\..\win32 + $(PEEK_DLL): $(PERLEXE) $(PEEK).xs cd $(EXTDIR)\Devel\$(*B) ..\..\..\miniperl -I..\..\..\lib Makefile.PL INSTALLDIRS=perl @@ -929,6 +939,7 @@ distclean: clean -del /f $(LIBDIR)\B.pm $(LIBDIR)\O.pm $(LIBDIR)\re.pm -del /f $(LIBDIR)\Data\Dumper.pm $(LIBDIR)\ByteLoader.pm -del /f $(LIBDIR)\Devel\Peek.pm $(LIBDIR)\Devel\DProf.pm + -del /f $(LIBDIR)\File\Glob.pm -rmdir /s /q $(LIBDIR)\IO || rmdir /s $(LIBDIR)\IO -rmdir /s /q $(LIBDIR)\Thread || rmdir /s $(LIBDIR)\Thread -rmdir /s /q $(LIBDIR)\B || rmdir /s $(LIBDIR)\B diff --git a/win32/makefile.mk b/win32/makefile.mk index ceb5be0b05..a9d69833b4 100644 --- a/win32/makefile.mk +++ b/win32/makefile.mk @@ -663,7 +663,7 @@ SETARGV_OBJ = setargv$(o) .ENDIF DYNAMIC_EXT = Socket IO Fcntl Opcode SDBM_File POSIX attrs Thread B re \ - Data/Dumper Devel/Peek ByteLoader Devel/DProf + Data/Dumper Devel/Peek ByteLoader Devel/DProf File/Glob STATIC_EXT = DynaLoader NONXS_EXT = Errno @@ -683,6 +683,7 @@ ERRNO = $(EXTDIR)\Errno\Errno PEEK = $(EXTDIR)\Devel\Peek\Peek BYTELOADER = $(EXTDIR)\ByteLoader\ByteLoader DPROF = $(EXTDIR)\Devel\DProf\DProf +GLOB = $(EXTDIR)\File\Glob\Glob SOCKET_DLL = $(AUTODIR)\Socket\Socket.dll FCNTL_DLL = $(AUTODIR)\Fcntl\Fcntl.dll @@ -698,6 +699,7 @@ PEEK_DLL = $(AUTODIR)\Devel\Peek\Peek.dll RE_DLL = $(AUTODIR)\re\re.dll BYTELOADER_DLL = $(AUTODIR)\ByteLoader\ByteLoader.dll DPROF_DLL = $(AUTODIR)\Devel\DProf\DProf.dll +GLOB_DLL = $(AUTODIR)\File\Glob\Glob.dll ERRNO_PM = $(LIBDIR)\Errno.pm @@ -715,7 +717,8 @@ EXTENSION_C = \ $(PEEK).c \ $(B).c \ $(BYTELOADER).c \ - $(DPROF).c + $(DPROF).c \ + $(GLOB).c EXTENSION_DLL = \ $(SOCKET_DLL) \ @@ -731,7 +734,8 @@ EXTENSION_DLL = \ $(RE_DLL) \ $(THREAD_DLL) \ $(BYTELOADER_DLL) \ - $(DPROF_DLL) + $(DPROF_DLL) \ + $(GLOB_DLL) EXTENSION_PM = \ $(ERRNO_PM) @@ -1005,6 +1009,11 @@ $(DPROF_DLL): $(PERLEXE) $(DPROF).xs ..\..\..\miniperl -I..\..\..\lib Makefile.PL INSTALLDIRS=perl cd $(EXTDIR)\Devel\$(*B) && $(MAKE) +$(GLOB_DLL): $(PERLEXE) $(GLOB).xs + cd $(EXTDIR)\File\$(*B) && \ + ..\..\..\miniperl -I..\..\..\lib Makefile.PL INSTALLDIRS=perl + cd $(EXTDIR)\File\$(*B) && $(MAKE) + $(PEEK_DLL): $(PERLEXE) $(PEEK).xs cd $(EXTDIR)\Devel\$(*B) && \ ..\..\..\miniperl -I..\..\..\lib Makefile.PL INSTALLDIRS=perl @@ -1095,6 +1104,7 @@ distclean: clean -del /f $(LIBDIR)\B.pm $(LIBDIR)\O.pm $(LIBDIR)\re.pm -del /f $(LIBDIR)\Data\Dumper.pm $(LIBDIR)\ByteLoader.pm -del /f $(LIBDIR)\Devel\Peek.pm $(LIBDIR)\Devel\DProf.pm + -del /f $(LIBDIR)\File\Glob.pm -rmdir /s /q $(LIBDIR)\IO || rmdir /s $(LIBDIR)\IO -rmdir /s /q $(LIBDIR)\Thread || rmdir /s $(LIBDIR)\Thread -rmdir /s /q $(LIBDIR)\B || rmdir /s $(LIBDIR)\B |