+#ifdef PERL_MAD
+ /*
+ * Perl_madlex
+ * The intent of this yylex wrapper is to minimize the changes to the
+ * tokener when we aren't interested in collecting madprops. It remains
+ * to be seen how successful this strategy will be...
+ */
+
+int
+Perl_madlex(pTHX)
+{
+ int optype;
+ char *s = PL_bufptr;
+
+ /* make sure thiswhite is initialized */
+ thiswhite = 0;
+ thismad = 0;
+
+ /* just do what yylex would do on pending identifier; leave thiswhite alone */
+ if (PL_pending_ident)
+ return S_pending_ident(aTHX);
+
+ /* previous token ate up our whitespace? */
+ if (!PL_lasttoke && nextwhite) {
+ thiswhite = nextwhite;
+ nextwhite = 0;
+ }
+
+ /* isolate the token, and figure out where it is without whitespace */
+ realtokenstart = -1;
+ thistoken = 0;
+ optype = yylex();
+ s = PL_bufptr;
+ assert(curforce < 0);
+
+ if (!thismad || thismad->mad_key == '^') { /* not forced already? */
+ if (!thistoken) {
+ if (realtokenstart < 0 || !CopLINE(PL_curcop))
+ thistoken = newSVpvn("",0);
+ else {
+ char *tstart = SvPVX(PL_linestr) + realtokenstart;
+ thistoken = newSVpvn(tstart, s - tstart);
+ }
+ }
+ if (thismad) /* install head */
+ CURMAD('X', thistoken);
+ }
+
+ /* last whitespace of a sublex? */
+ if (optype == ')' && endwhite) {
+ CURMAD('X', endwhite);
+ }
+
+ if (!thismad) {
+
+ /* if no whitespace and we're at EOF, bail. Otherwise fake EOF below. */
+ if (!thiswhite && !endwhite && !optype) {
+ sv_free(thistoken);
+ thistoken = 0;
+ return 0;
+ }
+
+ /* put off final whitespace till peg */
+ if (optype == ';' && !PL_rsfp) {
+ nextwhite = thiswhite;
+ thiswhite = 0;
+ }
+ else if (thisopen) {
+ CURMAD('q', thisopen);
+ if (thistoken)
+ sv_free(thistoken);
+ thistoken = 0;
+ }
+ else {
+ /* Store actual token text as madprop X */
+ CURMAD('X', thistoken);
+ }
+
+ if (thiswhite) {
+ /* add preceding whitespace as madprop _ */
+ CURMAD('_', thiswhite);
+ }
+
+ if (thisstuff) {
+ /* add quoted material as madprop = */
+ CURMAD('=', thisstuff);
+ }
+
+ if (thisclose) {
+ /* add terminating quote as madprop Q */
+ CURMAD('Q', thisclose);
+ }
+ }
+
+ /* special processing based on optype */
+
+ switch (optype) {
+
+ /* opval doesn't need a TOKEN since it can already store mp */
+ case WORD:
+ case METHOD:
+ case FUNCMETH:
+ case THING:
+ case PMFUNC:
+ case PRIVATEREF:
+ case FUNC0SUB:
+ case UNIOPSUB:
+ case LSTOPSUB:
+ if (yylval.opval)
+ append_madprops(thismad, yylval.opval, 0);
+ thismad = 0;
+ return optype;
+
+ /* fake EOF */
+ case 0:
+ optype = PEG;
+ if (endwhite) {
+ addmad(newMADsv('p', endwhite), &thismad, 0);
+ endwhite = 0;
+ }
+ break;
+
+ case ']':
+ case '}':
+ if (faketokens)
+ break;
+ /* remember any fake bracket that lexer is about to discard */
+ if (PL_lex_brackets == 1 &&
+ ((expectation)PL_lex_brackstack[0] & XFAKEBRACK))
+ {
+ s = PL_bufptr;
+ while (s < PL_bufend && (*s == ' ' || *s == '\t'))
+ s++;
+ if (*s == '}') {
+ thiswhite = newSVpvn(PL_bufptr, ++s - PL_bufptr);
+ addmad(newMADsv('#', thiswhite), &thismad, 0);
+ thiswhite = 0;
+ PL_bufptr = s - 1;
+ break; /* don't bother looking for trailing comment */
+ }
+ else
+ s = PL_bufptr;
+ }
+ if (optype == ']')
+ break;
+ /* FALLTHROUGH */
+
+ /* attach a trailing comment to its statement instead of next token */
+ case ';':
+ if (faketokens)
+ break;
+ if (PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == optype) {
+ s = PL_bufptr;
+ while (s < PL_bufend && (*s == ' ' || *s == '\t'))
+ s++;
+ if (*s == '\n' || *s == '#') {
+ while (s < PL_bufend && *s != '\n')
+ s++;
+ if (s < PL_bufend)
+ s++;
+ thiswhite = newSVpvn(PL_bufptr, s - PL_bufptr);
+ addmad(newMADsv('#', thiswhite), &thismad, 0);
+ thiswhite = 0;
+ PL_bufptr = s;
+ }
+ }
+ break;
+
+ /* pval */
+ case LABEL:
+ break;
+
+ /* ival */
+ default:
+ break;
+
+ }
+
+ /* Create new token struct. Note: opvals return early above. */
+ yylval.tkval = newTOKEN(optype, yylval, thismad);
+ thismad = 0;
+ return optype;
+}
+#endif
+