[p5sagit/Devel-Declare.git] / stolen_chunk_of_toke.c

/*    stolen_chunk_of_toke.c - from perl 5.8.8 toke.c
 *
 *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
 *    2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
 *
 *    You may distribute under the terms of either the GNU General Public
 *    License or the Artistic License, as specified in the README file.
 *
 */

/*
 *   "It all comes from here, the stench and the peril."  --Frodo
 */

/*
 *   this is all blatantly stolen. I sincerely hopes it doesn't fuck anything
 *   up but if it does blame me (Matt S Trout), not the poor original authors
 */

/* the following #defines are stolen from assorted headers, not toke.c */

#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 MEM_WRAP_CHECK_(n,t) MEM_WRAP_CHECK(n,t),
#define Newx(v,n,t) (v = (MEM_WRAP_CHECK_(n,t) (t*)safemalloc((MEM_SIZE)((n)*sizeof(t)))))


#define LEX_NORMAL    10 /* normal code (ie not within "...")     */
#define LEX_INTERPNORMAL   9 /* code within a string, eg "$foo[$x+1]" */
#define LEX_INTERPCASEMOD  8 /* expecting a \U, \Q or \E etc          */
#define LEX_INTERPPUSH     7 /* starting a new sublex parse level     */
#define LEX_INTERPSTART    6 /* expecting the start of a $var         */

           /* at end of code, eg "$x" followed by:  */
#define LEX_INTERPEND    5 /* ... eg not one of [, { or ->          */
#define LEX_INTERPENDMAYBE   4 /* ... eg one of [, { or ->              */

#define LEX_INTERPCONCAT   3 /* expecting anything, eg at start of
                string or after \E, $foo, etc       */
#define LEX_INTERPCONST    2 /* NOT USED */
#define LEX_FORMLINE     1 /* expecting a format line               */
#define LEX_KNOWNEXT     0 /* next token known; just return it      */

static const char ident_too_long[] =
  "Identifier too long";
static const char c_without_g[] =
  "Use of /c modifier is meaningless without /g";
static const char c_in_subst[] =
  "Use of /c modifier is meaningless in s///";

#ifdef USE_UTF8_SCRIPTS
#   define UTF (!IN_BYTES)
#else
#   define UTF ((PL_linestr && DO_UTF8(PL_linestr)) || (PL_hints & HINT_UTF8))
#endif

/* Invoke the idxth filter function for the current rsfp.	 */
/* maxlen 0 = read one text line */
I32
Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
{
    filter_t funcp;
    SV *datasv = NULL;

    if (!PL_rsfp_filters)
	return -1;
    if (idx > AvFILLp(PL_rsfp_filters)) {       /* Any more filters?	*/
	/* Provide a default input filter to make life easy.	*/
	/* Note that we append to the line. This is handy.	*/
	DEBUG_P(PerlIO_printf(Perl_debug_log,
			      "filter_read %d: from rsfp\n", idx));
	if (maxlen) {
 	    /* Want a block */
	    int len ;
	    const int old_len = SvCUR(buf_sv);

	    /* ensure buf_sv is large enough */
	    SvGROW(buf_sv, (STRLEN)(old_len + maxlen)) ;
	    if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
		if (PerlIO_error(PL_rsfp))
	            return -1;		/* error */
	        else
		    return 0 ;		/* end of file */
	    }
	    SvCUR_set(buf_sv, old_len + len) ;
	} else {
	    /* Want a line */
            if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
		if (PerlIO_error(PL_rsfp))
	            return -1;		/* error */
	        else
		    return 0 ;		/* end of file */
	    }
	}
	return SvCUR(buf_sv);
    }
    /* Skip this filter slot if filter has been deleted	*/
    if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
	DEBUG_P(PerlIO_printf(Perl_debug_log,
			      "filter_read %d: skipped (filter deleted)\n",
			      idx));
	return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
    }
    /* Get function pointer hidden within datasv	*/
    funcp = DPTR2FPTR(filter_t, IoANY(datasv));
    DEBUG_P(PerlIO_printf(Perl_debug_log,
			  "filter_read %d: via function %p (%s)\n",
			  idx, datasv, SvPV_nolen_const(datasv)));
    /* Call function. The function is expected to 	*/
    /* call "FILTER_READ(idx+1, buf_sv)" first.		*/
    /* Return: <0:error, =0:eof, >0:not eof 		*/
    return (*funcp)(aTHX_ idx, buf_sv, maxlen);
}

STATIC char *
S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
{
#ifdef PERL_CR_FILTER
    if (!PL_rsfp_filters) {
	filter_add(S_cr_textfilter,NULL);
    }
#endif
    if (PL_rsfp_filters) {
	if (!append)
            SvCUR_set(sv, 0);	/* start with empty line	*/
        if (FILTER_READ(0, sv, 0) > 0)
            return ( SvPVX(sv) ) ;
        else
	    return Nullch ;
    }
    else
        return (sv_gets(sv, fp, append));
}

/*
 * S_skipspace
 * Called to gobble the appropriate amount and type of whitespace.
 * Skips comments as well.
 */

STATIC char *
S_skipspace(pTHX_ register char *s)
{
    if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
	while (s < PL_bufend && SPACE_OR_TAB(*s))
	    s++;
	return s;
    }
    for (;;) {
	STRLEN prevlen;
	SSize_t oldprevlen, oldoldprevlen;
	SSize_t oldloplen = 0, oldunilen = 0;
	while (s < PL_bufend && isSPACE(*s)) {
	    if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
		incline(s);
	}

	/* comment */
	if (s < PL_bufend && *s == '#') {
	    while (s < PL_bufend && *s != '\n')
		s++;
	    if (s < PL_bufend) {
		s++;
		if (PL_in_eval && !PL_rsfp) {
		    incline(s);
		    continue;
		}
	    }
	}

	/* only continue to recharge the buffer if we're at the end
	 * of the buffer, we're not reading from a source filter, and
	 * we're in normal lexing mode
	 */
	if (s < PL_bufend || !PL_rsfp || PL_sublex_info.sub_inwhat ||
		PL_lex_state == LEX_FORMLINE)
	    return s;

	/* try to recharge the buffer */
	if ((s = filter_gets(PL_linestr, PL_rsfp,
			     (prevlen = SvCUR(PL_linestr)))) == Nullch)
	{
	    /* end of file.  Add on the -p or -n magic */
	    if (PL_minus_p) {
		sv_setpv(PL_linestr,
			 ";}continue{print or die qq(-p destination: $!\\n);}");
		PL_minus_n = PL_minus_p = 0;
	    }
	    else if (PL_minus_n) {
		sv_setpvn(PL_linestr, ";}", 2);
		PL_minus_n = 0;
	    }
	    else
		sv_setpvn(PL_linestr,";", 1);

	    /* reset variables for next time we lex */
	    PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart
		= SvPVX(PL_linestr);
	    PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
	    PL_last_lop = PL_last_uni = Nullch;

	    /* Close the filehandle.  Could be from -P preprocessor,
	     * 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())
		PerlIO_clearerr(PL_rsfp);
	    else
		(void)PerlIO_close(PL_rsfp);
	    PL_rsfp = Nullfp;
	    return s;
	}

	/* not at end of file, so we only read another line */
	/* make corresponding updates to old pointers, for yyerror() */
	oldprevlen = PL_oldbufptr - PL_bufend;
	oldoldprevlen = PL_oldoldbufptr - PL_bufend;
	if (PL_last_uni)
	    oldunilen = PL_last_uni - PL_bufend;
	if (PL_last_lop)
	    oldloplen = PL_last_lop - PL_bufend;
	PL_linestart = PL_bufptr = s + prevlen;
	PL_bufend = s + SvCUR(PL_linestr);
	s = PL_bufptr;
	PL_oldbufptr = s + oldprevlen;
	PL_oldoldbufptr = s + oldoldprevlen;
	if (PL_last_uni)
	    PL_last_uni = s + oldunilen;
	if (PL_last_lop)
	    PL_last_lop = s + oldloplen;
	incline(s);

	/* debugger active and we're not compiling the debugger code,
	 * so store the line into the debugger's array of lines
	 */
	if (PERLDB_LINE && PL_curstash != PL_debstash) {
	    SV * const sv = NEWSV(85,0);

	    sv_upgrade(sv, SVt_PVMG);
	    sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
            (void)SvIOK_on(sv);
            SvIV_set(sv, 0);
	    av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
	}
    }
}

STATIC char *
S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
{
    register char *d = dest;
    register char * const e = d + destlen - 3;  /* two-character token, ending NUL */
    for (;;) {
	if (d >= e)
	    Perl_croak(aTHX_ ident_too_long);
	if (isALNUM(*s))	/* UTF handled below */
	    *d++ = *s++;
	else if (*s == '\'' && allow_package && isIDFIRST_lazy_if(s+1,UTF)) {
	    *d++ = ':';
	    *d++ = ':';
	    s++;
	}
	else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
	    *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 {
	    *d = '\0';
	    *slp = d - dest;
	    return s;
	}
    }
}

/*
 * S_incline
 * This subroutine has nothing to do with tilting, whether at windmills
 * or pinball tables.  Its name is short for "increment line".  It
 * increments the current line number in CopLINE(PL_curcop) and checks
 * to see whether the line starts with a comment of the form
 *    # line 500 "foo.pm"
 * If so, it sets the current line number and file to the values in the comment.
 */

STATIC void
S_incline(pTHX_ char *s)
{
    char *t;
    char *n;
    char *e;
    char ch;

    CopLINE_inc(PL_curcop);
    if (*s++ != '#')
	return;
    while (SPACE_OR_TAB(*s)) s++;
    if (strnEQ(s, "line", 4))
	s += 4;
    else
	return;
    if (SPACE_OR_TAB(*s))
	s++;
    else
	return;
    while (SPACE_OR_TAB(*s)) s++;
    if (!isDIGIT(*s))
	return;
    n = s;
    while (isDIGIT(*s))
	s++;
    while (SPACE_OR_TAB(*s))
	s++;
    if (*s == '"' && (t = strchr(s+1, '"'))) {
	s++;
	e = t + 1;
    }
    else {
	for (t = s; !isSPACE(*t); t++) ;
	e = t;
    }
    while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
	e++;
    if (*e != '\n' && *e != '\0')
	return;		/* false alarm */

    ch = *t;
    *t = '\0';
    if (t - s > 0) {
#ifndef USE_ITHREADS
	const char *cf = CopFILE(PL_curcop);
	if (cf && strlen(cf) > 7 && strnEQ(cf, "(eval ", 6)) {
	    /* must copy *{"::_<(eval N)[oldfilename:L]"}
	     * to *{"::_<newfilename"} */
	    char smallbuf[256], smallbuf2[256];
	    char *tmpbuf, *tmpbuf2;
	    GV **gvp, *gv2;
	    STRLEN tmplen = strlen(cf);
	    STRLEN tmplen2 = strlen(s);
	    if (tmplen + 3 < sizeof smallbuf)
		tmpbuf = smallbuf;
	    else
		Newx(tmpbuf, tmplen + 3, char);
	    if (tmplen2 + 3 < sizeof smallbuf2)
		tmpbuf2 = smallbuf2;
	    else
		Newx(tmpbuf2, tmplen2 + 3, char);
	    tmpbuf[0] = tmpbuf2[0] = '_';
	    tmpbuf[1] = tmpbuf2[1] = '<';
	    memcpy(tmpbuf + 2, cf, ++tmplen);
	    memcpy(tmpbuf2 + 2, s, ++tmplen2);
	    ++tmplen; ++tmplen2;
	    gvp = (GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, FALSE);
	    if (gvp) {
		gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE);
		if (!isGV(gv2))
		    gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
		/* adjust ${"::_<newfilename"} to store the new file name */
		GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
		GvHV(gv2) = (HV*)SvREFCNT_inc(GvHV(*gvp));
		GvAV(gv2) = (AV*)SvREFCNT_inc(GvAV(*gvp));
	    }
	    if (tmpbuf != smallbuf) Safefree(tmpbuf);
	    if (tmpbuf2 != smallbuf2) Safefree(tmpbuf2);
	}
#endif
	CopFILE_free(PL_curcop);
	CopFILE_set(PL_curcop, s);
    }
    *t = ch;
    CopLINE_set(PL_curcop, atoi(n)-1);
}
Commit	Line	Data
e807ee50	1	/* stolen_chunk_of_toke.c - from perl 5.8.8 toke.c
	2	*
	3	* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
	4	* 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
	5	*
	6	* You may distribute under the terms of either the GNU General Public
	7	* License or the Artistic License, as specified in the README file.
	8	*
	9	*/
	10
	11	/*
	12	* "It all comes from here, the stench and the peril." --Frodo
	13	*/
	14
	15	/*
	16	* this is all blatantly stolen. I sincerely hopes it doesn't fuck anything
	17	* up but if it does blame me (Matt S Trout), not the poor original authors
	18	*/
	19
	20	/* the following #defines are stolen from assorted headers, not toke.c */
	21
	22	#define DPTR2FPTR(t,p) ((t)PTR2nat(p)) /* data pointer to function pointer */
	23	#define FPTR2DPTR(t,p) ((t)PTR2nat(p)) /* function pointer to data pointer */
	24	#define MEM_WRAP_CHECK_(n,t) MEM_WRAP_CHECK(n,t),
	25	#define Newx(v,n,t) (v = (MEM_WRAP_CHECK_(n,t) (t)safemalloc((MEM_SIZE)((n)sizeof(t)))))
	26
	27
	28	#define LEX_NORMAL 10 /* normal code (ie not within "...") */
	29	#define LEX_INTERPNORMAL 9 /* code within a string, eg "$foo[$x+1]" */
	30	#define LEX_INTERPCASEMOD 8 /* expecting a \U, \Q or \E etc */
	31	#define LEX_INTERPPUSH 7 /* starting a new sublex parse level */
	32	#define LEX_INTERPSTART 6 /* expecting the start of a $var */
	33
	34	/* at end of code, eg "$x" followed by: */
	35	#define LEX_INTERPEND 5 /* ... eg not one of [, { or -> */
	36	#define LEX_INTERPENDMAYBE 4 /* ... eg one of [, { or -> */
	37
	38	#define LEX_INTERPCONCAT 3 /* expecting anything, eg at start of
	39	string or after \E, $foo, etc */
	40	#define LEX_INTERPCONST 2 /* NOT USED */
	41	#define LEX_FORMLINE 1 /* expecting a format line */
	42	#define LEX_KNOWNEXT 0 /* next token known; just return it */
	43
	44	static const char ident_too_long[] =
	45	"Identifier too long";
	46	static const char c_without_g[] =
	47	"Use of /c modifier is meaningless without /g";
	48	static const char c_in_subst[] =
	49	"Use of /c modifier is meaningless in s///";
	50
	51	#ifdef USE_UTF8_SCRIPTS
	52	# define UTF (!IN_BYTES)
	53	#else
	54	# define UTF ((PL_linestr && DO_UTF8(PL_linestr)) \|\| (PL_hints & HINT_UTF8))
	55	#endif
	56
	57	/* Invoke the idxth filter function for the current rsfp. */
	58	/* maxlen 0 = read one text line */
	59	I32
	60	Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
	61	{
	62	filter_t funcp;
	63	SV *datasv = NULL;
	64
65	if (!PL_rsfp_filters)
66	return -1;
67	if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */
68	/* Provide a default input filter to make life easy. */
69	/* Note that we append to the line. This is handy. */
70	DEBUG_P(PerlIO_printf(Perl_debug_log,
71	"filter_read %d: from rsfp\n", idx));
72	if (maxlen) {
73	/* Want a block */
74	int len ;
75	const int old_len = SvCUR(buf_sv);
76
77	/* ensure buf_sv is large enough */
78	SvGROW(buf_sv, (STRLEN)(old_len + maxlen)) ;
79	if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
80	if (PerlIO_error(PL_rsfp))
81	return -1; /* error */
82	else
83	return 0 ; /* end of file */
84	}
85	SvCUR_set(buf_sv, old_len + len) ;
86	} else {
87	/* Want a line */
88	if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
89	if (PerlIO_error(PL_rsfp))
90	return -1; /* error */
91	else
92	return 0 ; /* end of file */
93	}
94	}
95	return SvCUR(buf_sv);
96	}
97	/* Skip this filter slot if filter has been deleted */
98	if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
99	DEBUG_P(PerlIO_printf(Perl_debug_log,
100	"filter_read %d: skipped (filter deleted)\n",
101	idx));
102	return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
103	}
104	/* Get function pointer hidden within datasv */
105	funcp = DPTR2FPTR(filter_t, IoANY(datasv));
106	DEBUG_P(PerlIO_printf(Perl_debug_log,
107	"filter_read %d: via function %p (%s)\n",
108	idx, datasv, SvPV_nolen_const(datasv)));
109	/* Call function. The function is expected to */
110	/* call "FILTER_READ(idx+1, buf_sv)" first. */
111	/* Return: <0:error, =0:eof, >0:not eof */
112	return (*funcp)(aTHX_ idx, buf_sv, maxlen);
113	}
114
115	STATIC char *
116	S_filter_gets(pTHX_ register SV sv, register PerlIO fp, STRLEN append)
117	{
118	#ifdef PERL_CR_FILTER
119	if (!PL_rsfp_filters) {
120	filter_add(S_cr_textfilter,NULL);
121	}
122	#endif
123	if (PL_rsfp_filters) {
124	if (!append)
125	SvCUR_set(sv, 0); /* start with empty line */
126	if (FILTER_READ(0, sv, 0) > 0)
127	return ( SvPVX(sv) ) ;
128	else
129	return Nullch ;
130	}
131	else
132	return (sv_gets(sv, fp, append));
133	}
134
135	/*
136	* S_skipspace
137	* Called to gobble the appropriate amount and type of whitespace.
138	* Skips comments as well.
139	*/
140
141	STATIC char *
142	S_skipspace(pTHX_ register char *s)
143	{
144	if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
145	while (s < PL_bufend && SPACE_OR_TAB(*s))
146	s++;
147	return s;
148	}
149	for (;;) {
150	STRLEN prevlen;
151	SSize_t oldprevlen, oldoldprevlen;
152	SSize_t oldloplen = 0, oldunilen = 0;
153	while (s < PL_bufend && isSPACE(*s)) {
154	if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
155	incline(s);
156	}
157
158	/* comment */
159	if (s < PL_bufend && *s == '#') {
160	while (s < PL_bufend && *s != '\n')
161	s++;
162	if (s < PL_bufend) {
163	s++;
164	if (PL_in_eval && !PL_rsfp) {
165	incline(s);
166	continue;
167	}
168	}
169	}
170
171	/* only continue to recharge the buffer if we're at the end
172	* of the buffer, we're not reading from a source filter, and
173	* we're in normal lexing mode
174	*/
175	if (s < PL_bufend \|\| !PL_rsfp \|\| PL_sublex_info.sub_inwhat \|\|
176	PL_lex_state == LEX_FORMLINE)
177	return s;
178
179	/* try to recharge the buffer */
180	if ((s = filter_gets(PL_linestr, PL_rsfp,
181	(prevlen = SvCUR(PL_linestr)))) == Nullch)
182	{
183	/* end of file. Add on the -p or -n magic */
184	if (PL_minus_p) {
185	sv_setpv(PL_linestr,
186	";}continue{print or die qq(-p destination: $!\\n);}");
187	PL_minus_n = PL_minus_p = 0;
188	}
189	else if (PL_minus_n) {
190	sv_setpvn(PL_linestr, ";}", 2);
191	PL_minus_n = 0;
192	}
193	else
194	sv_setpvn(PL_linestr,";", 1);
195
196	/* reset variables for next time we lex */
197	PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart
198	= SvPVX(PL_linestr);
199	PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
200	PL_last_lop = PL_last_uni = Nullch;
201
202	/* Close the filehandle. Could be from -P preprocessor,
203	* STDIN, or a regular file. If we were reading code from
204	* STDIN (because the commandline held no -e or filename)
205	* then we don't close it, we reset it so the code can
206	* read from STDIN too.
207	*/
208
209	if (PL_preprocess && !PL_in_eval)
210	(void)PerlProc_pclose(PL_rsfp);
211	else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
212	PerlIO_clearerr(PL_rsfp);
213	else
214	(void)PerlIO_close(PL_rsfp);
215	PL_rsfp = Nullfp;
216	return s;
217	}
218
219	/* not at end of file, so we only read another line */
220	/* make corresponding updates to old pointers, for yyerror() */
221	oldprevlen = PL_oldbufptr - PL_bufend;
222	oldoldprevlen = PL_oldoldbufptr - PL_bufend;
223	if (PL_last_uni)
224	oldunilen = PL_last_uni - PL_bufend;
225	if (PL_last_lop)
226	oldloplen = PL_last_lop - PL_bufend;
227	PL_linestart = PL_bufptr = s + prevlen;
228	PL_bufend = s + SvCUR(PL_linestr);
229	s = PL_bufptr;
230	PL_oldbufptr = s + oldprevlen;
231	PL_oldoldbufptr = s + oldoldprevlen;
232	if (PL_last_uni)
233	PL_last_uni = s + oldunilen;
234	if (PL_last_lop)
235	PL_last_lop = s + oldloplen;
236	incline(s);
237
238	/* debugger active and we're not compiling the debugger code,
239	* so store the line into the debugger's array of lines
240	*/
241	if (PERLDB_LINE && PL_curstash != PL_debstash) {
242	SV * const sv = NEWSV(85,0);
243
244	sv_upgrade(sv, SVt_PVMG);
245	sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
246	(void)SvIOK_on(sv);
247	SvIV_set(sv, 0);
248	av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
249	}
250	}
251	}
252
253	STATIC char *
254	S_scan_word(pTHX_ register char s, char dest, STRLEN destlen, int allow_package, STRLEN *slp)
255	{
256	register char *d = dest;
257	register char * const e = d + destlen - 3; /* two-character token, ending NUL */
258	for (;;) {
259	if (d >= e)
260	Perl_croak(aTHX_ ident_too_long);
261	if (isALNUM(s)) / UTF handled below */
262	d++ = s++;
263	else if (*s == '\'' && allow_package && isIDFIRST_lazy_if(s+1,UTF)) {
264	*d++ = ':';
265	*d++ = ':';
266	s++;
267	}
268	else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
269	d++ = s++;
270	d++ = s++;
271	}
272	else if (UTF && UTF8_IS_START(s) && isALNUM_utf8((U8)s)) {
273	char *t = s + UTF8SKIP(s);
274	while (UTF8_IS_CONTINUED(t) && is_utf8_mark((U8)t))
275	t += UTF8SKIP(t);
276	if (d + (t - s) > e)
277	Perl_croak(aTHX_ ident_too_long);
278	Copy(s, d, t - s, char);
279	d += t - s;
280	s = t;
281	}
282	else {
283	*d = '\0';
284	*slp = d - dest;
285	return s;
286	}
287	}
288	}
289
290	/*
291	* S_incline
292	* This subroutine has nothing to do with tilting, whether at windmills
293	* or pinball tables. Its name is short for "increment line". It
294	* increments the current line number in CopLINE(PL_curcop) and checks
295	* to see whether the line starts with a comment of the form
296	* # line 500 "foo.pm"
297	* If so, it sets the current line number and file to the values in the comment.
298	*/
299
300	STATIC void
301	S_incline(pTHX_ char *s)
302	{
303	char *t;
304	char *n;
305	char *e;
306	char ch;
307
308	CopLINE_inc(PL_curcop);
309	if (*s++ != '#')
310	return;
311	while (SPACE_OR_TAB(*s)) s++;
312	if (strnEQ(s, "line", 4))
313	s += 4;
314	else
315	return;
316	if (SPACE_OR_TAB(*s))
317	s++;
318	else
319	return;
320	while (SPACE_OR_TAB(*s)) s++;
321	if (!isDIGIT(*s))
322	return;
323	n = s;
324	while (isDIGIT(*s))
325	s++;
326	while (SPACE_OR_TAB(*s))
327	s++;
328	if (*s == '"' && (t = strchr(s+1, '"'))) {
329	s++;
330	e = t + 1;
331	}
332	else {
333	for (t = s; !isSPACE(*t); t++) ;
334	e = t;
335	}
336	while (SPACE_OR_TAB(e) \|\| e == '\r' \|\| *e == '\f')
337	e++;
338	if (e != '\n' && e != '\0')
339	return; /* false alarm */
340
341	ch = *t;
342	*t = '\0';
343	if (t - s > 0) {
344	#ifndef USE_ITHREADS
345	const char *cf = CopFILE(PL_curcop);
346	if (cf && strlen(cf) > 7 && strnEQ(cf, "(eval ", 6)) {
347	/* must copy *{"::_<(eval N)[oldfilename:L]"}
348	* to {"::_<newfilename"} /
349	char smallbuf[256], smallbuf2[256];
350	char tmpbuf, tmpbuf2;
351	GV *gvp, gv2;
352	STRLEN tmplen = strlen(cf);
353	STRLEN tmplen2 = strlen(s);
354	if (tmplen + 3 < sizeof smallbuf)
355	tmpbuf = smallbuf;
356	else
357	Newx(tmpbuf, tmplen + 3, char);
358	if (tmplen2 + 3 < sizeof smallbuf2)
359	tmpbuf2 = smallbuf2;
360	else
361	Newx(tmpbuf2, tmplen2 + 3, char);
362	tmpbuf[0] = tmpbuf2[0] = '_';
363	tmpbuf[1] = tmpbuf2[1] = '<';
364	memcpy(tmpbuf + 2, cf, ++tmplen);
365	memcpy(tmpbuf2 + 2, s, ++tmplen2);
366	++tmplen; ++tmplen2;
367	gvp = (GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, FALSE);
368	if (gvp) {
369	gv2 = (GV*)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE);
370	if (!isGV(gv2))
371	gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
372	/* adjust ${"::_<newfilename"} to store the new file name */
373	GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
374	GvHV(gv2) = (HV)SvREFCNT_inc(GvHV(gvp));
375	GvAV(gv2) = (AV)SvREFCNT_inc(GvAV(gvp));
376	}
377	if (tmpbuf != smallbuf) Safefree(tmpbuf);
378	if (tmpbuf2 != smallbuf2) Safefree(tmpbuf2);
379	}
380	#endif
381	CopFILE_free(PL_curcop);
382	CopFILE_set(PL_curcop, s);
383	}
384	*t = ch;
385	CopLINE_set(PL_curcop, atoi(n)-1);
386	}