X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=stolen_chunk_of_toke.c;h=85f714e59d5db573eb0728734f024b857113a8c4;hb=83061eab49f1e62e0e97f4808d76b9196aa6e089;hp=0daee6336cd964a2dfab36abd6e83ee81b315ba1;hpb=14ab3472d828e17e875019680713603aa13412e6;p=p5sagit%2FDevel-Declare.git diff --git a/stolen_chunk_of_toke.c b/stolen_chunk_of_toke.c index 0daee63..85f714e 100644 --- a/stolen_chunk_of_toke.c +++ b/stolen_chunk_of_toke.c @@ -19,6 +19,19 @@ /* the following #defines are stolen from assorted headers, not toke.c (mst) */ +#define skipspace(a) S_skipspace(aTHX_ a) +#define incline(a) S_incline(aTHX_ a) +#define filter_gets(a,b,c) S_filter_gets(aTHX_ a,b,c) +#define scan_str(a,b,c) S_scan_str(aTHX_ a,b,c) +#define scan_word(a,b,c,d,e) S_scan_word(aTHX_ a,b,c,d,e) +#define scan_ident(a,b,c,d,e) S_scan_ident(aTHX_ a,b,c,d,e) + +STATIC void S_incline(pTHX_ char *s); +STATIC char* S_skipspace(pTHX_ char *s); +STATIC char * S_filter_gets(pTHX_ SV *sv, PerlIO *fp, STRLEN append); +STATIC char* S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims); +STATIC char* S_scan_word(pTHX_ char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp); + #define DPTR2FPTR(t,p) ((t)PTR2nat(p)) /* data pointer to function pointer */ #define FPTR2DPTR(t,p) ((t)PTR2nat(p)) /* function pointer to data pointer */ #define PTR2nat(p) (PTRV)(p) /* pointer to integer of PTRSIZE */ @@ -40,6 +53,8 @@ (MEM_SIZE)((n))))); \ } STMT_END +#define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x))) + /* On MacOS, respect nonbreaking spaces */ #ifdef MACOS_TRADITIONAL #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\312'||(c)=='\t') @@ -127,9 +142,6 @@ # define PL_nexttype (PL_parser->nexttype) # define PL_nextval (PL_parser->nextval) /* end of backcompat macros form 5.9 toke.c (mst) */ -/* we also need this because we define PERL_CORE so handy.h doesn't provide - it for us (mst) */ -#define NEWSV(x,len) newSV(len) #endif /* when ccflags include -DDEBUGGING we need this for earlier 5.8 perls */ @@ -297,16 +309,20 @@ S_skipspace(pTHX_ register char *s) PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); PL_last_lop = PL_last_uni = Nullch; - /* Close the filehandle. Could be from -P preprocessor, + /* In perl versions previous to p4-rawid: //depot/perl@32954 -P + * preprocessors were supported here. We don't support -P at all, even + * on perls that support it, and use the following chunk from blead + * perl. (rafl) + */ + + /* Close the filehandle. Could be from * STDIN, or a regular file. If we were reading code from * STDIN (because the commandline held no -e or filename) * then we don't close it, we reset it so the code can * read from STDIN too. */ - if (PL_preprocess && !PL_in_eval) - (void)PerlProc_pclose(PL_rsfp); - else if ((PerlIO*)PL_rsfp == PerlIO_stdin()) + if ((PerlIO*)PL_rsfp == PerlIO_stdin()) PerlIO_clearerr(PL_rsfp); else (void)PerlIO_close(PL_rsfp); @@ -395,20 +411,12 @@ S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_packag * If so, it sets the current line number and file to the values in the comment. */ -/* 5.9+ make the char *s in S_incline const and declare it in proto.h so we - need to do the same to avoid a prototype mismatch (mst) */ -#ifdef PERL_5_9_PLUS -#define S_INCLINE_CONST const -#else -#define S_INCLINE_CONST -#endif - STATIC void -S_incline(pTHX_ S_INCLINE_CONST char *s) +S_incline(pTHX_ char *s) { char *t; - S_INCLINE_CONST char *n; - S_INCLINE_CONST char *e; + char *n; + char *e; char ch; CopLINE_inc(PL_curcop); @@ -436,8 +444,7 @@ S_incline(pTHX_ S_INCLINE_CONST char *s) e = t + 1; } else { - /* explicitly cast to char * in case S_INCLINE_CONST in force (mst) */ - for (t = (char *)s; !isSPACE(*t); t++) ; + for (t = s; !isSPACE(*t); t++) ; e = t; } while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f') @@ -844,3 +851,178 @@ S_force_next(pTHX_ I32 type) PL_lex_state = LEX_KNOWNEXT; } } + +#define XFAKEBRACK 128 + +STATIC char * +S_scan_ident(pTHX_ register char *s, register const char *send, char *dest, STRLEN destlen, I32 ck_uni) +{ + register char *d; + register char *e; + char *bracket = Nullch; + char funny = *s++; + + if (isSPACE(*s)) + s = skipspace(s); + d = dest; + e = d + destlen - 3; /* two-character token, ending NUL */ + if (isDIGIT(*s)) { + while (isDIGIT(*s)) { + if (d >= e) + Perl_croak(aTHX_ ident_too_long); + *d++ = *s++; + } + } + else { + for (;;) { + if (d >= e) + Perl_croak(aTHX_ ident_too_long); + if (isALNUM(*s)) /* UTF handled below */ + *d++ = *s++; + else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) { + *d++ = ':'; + *d++ = ':'; + s++; + } + else if (*s == ':' && s[1] == ':') { + *d++ = *s++; + *d++ = *s++; + } + else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) { + char *t = s + UTF8SKIP(s); + while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t)) + t += UTF8SKIP(t); + if (d + (t - s) > e) + Perl_croak(aTHX_ ident_too_long); + Copy(s, d, t - s, char); + d += t - s; + s = t; + } + else + break; + } + } + *d = '\0'; + d = dest; + if (*d) { + if (PL_lex_state != LEX_NORMAL) + PL_lex_state = LEX_INTERPENDMAYBE; + return s; + } + if (*s == '$' && s[1] && + (isALNUM_lazy_if(s+1,UTF) || s[1] == '$' || s[1] == '{' || strnEQ(s+1,"::",2)) ) + { + return s; + } + if (*s == '{') { + bracket = s; + s++; + } + /* we always call this with ck_uni == 0 (rafl) */ + /* + else if (ck_uni) + check_uni(); + */ + if (s < send) + *d = *s++; + d[1] = '\0'; + if (*d == '^' && *s && isCONTROLVAR(*s)) { + *d = toCTRL(*s); + s++; + } + if (bracket) { + if (isSPACE(s[-1])) { + while (s < send) { + const char ch = *s++; + if (!SPACE_OR_TAB(ch)) { + *d = ch; + break; + } + } + } + if (isIDFIRST_lazy_if(d,UTF)) { + d++; + if (UTF) { + e = s; + while ((e < send && isALNUM_lazy_if(e,UTF)) || *e == ':') { + e += UTF8SKIP(e); + while (e < send && UTF8_IS_CONTINUED(*e) && is_utf8_mark((U8*)e)) + e += UTF8SKIP(e); + } + Copy(s, d, e - s, char); + d += e - s; + s = e; + } + else { + while ((isALNUM(*s) || *s == ':') && d < e) + *d++ = *s++; + if (d >= e) + Perl_croak(aTHX_ ident_too_long); + } + *d = '\0'; + while (s < send && SPACE_OR_TAB(*s)) s++; + if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) { + /* we don't want perl to guess what is meant. the keyword + * parser decides that later. (rafl) + */ + /* + if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) { + const char *brack = *s == '[' ? "[...]" : "{...}"; + Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS), + "Ambiguous use of %c{%s%s} resolved to %c%s%s", + funny, dest, brack, funny, dest, brack); + } + */ + bracket++; + PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK); + return s; + } + } + /* Handle extended ${^Foo} variables + * 1999-02-27 mjd-perl-patch@plover.com */ + else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */ + && isALNUM(*s)) + { + d++; + while (isALNUM(*s) && d < e) { + *d++ = *s++; + } + if (d >= e) + Perl_croak(aTHX_ ident_too_long); + *d = '\0'; + } + if (*s == '}') { + s++; + if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) { + PL_lex_state = LEX_INTERPEND; + PL_expect = XREF; + } + if (funny == '#') + funny = '@'; + /* we don't want perl to guess what is meant. the keyword + * parser decides that later. (rafl) + */ + /* + if (PL_lex_state == LEX_NORMAL) { + if (ckWARN(WARN_AMBIGUOUS) && + (keyword(dest, d - dest) || get_cv(dest, FALSE))) + { + Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS), + "Ambiguous use of %c{%s} resolved to %c%s", + funny, dest, funny, dest); + } + } + */ + } + else { + s = bracket; /* let the parser handle it */ + *dest = '\0'; + } + } + /* don't intuit. we really just want the string. (rafl) */ + /* + else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s)) + PL_lex_state = LEX_INTERPEND; + */ + return s; +}