[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 PTR2nat(p)       (PTRV)(p)       /* pointer to integer of PTRSIZE */
#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)))))

/* On MacOS, respect nonbreaking spaces */
#ifdef MACOS_TRADITIONAL
#define SPACE_OR_TAB(c) ((c)==' '||(c)=='\312'||(c)=='\t')
#else
#define SPACE_OR_TAB(c) ((c)==' '||(c)=='\t')
#endif

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