}
}
+/*
+ scan_const
+
+ Extracts a pattern, double-quoted string, or transliteration. This
+ is terrifying code.
+
+ It looks at lex_inwhat and lex_inpat to find out whether it's
+ processing a pattern (lex_inpat is true), a transliteration
+ (lex_inwhat & OP_TRANS is true), or a double-quoted string.
+
+ In patterns:
+ backslashes:
+ double-quoted style: \r and \n
+ regexp special ones: \D \s
+ constants: \x3
+ backrefs: \1 (deprecated in substitution replacements)
+ case and quoting: \U \Q \E
+ stops on @ and $, but not for $ as tail anchor
+
+ In transliterations:
+ characters are VERY literal, except for - not at the start or end
+ of the string, which indicates a range. scan_const expands the
+ range to the full set of intermediate characters.
+
+ In double-quoted strings:
+ backslashes:
+ double-quoted style: \r and \n
+ constants: \x3
+ backrefs: \1 (deprecated)
+ case and quoting: \U \Q \E
+ stops on @ and $
+
+ scan_const does *not* construct ops to handle interpolated strings.
+ It stops processing as soon as it finds an embedded $ or @ variable
+ and leaves it to the caller to work out what's going on.
+
+ @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @:foo.
+
+ $ in pattern could be $foo or could be tail anchor. Assumption:
+ it's a tail anchor if $ is the last thing in the string, or if it's
+ followed by one of ")| \n\t"
+
+ \1 (backreferences) are turned into $1
+
+ The structure of the code is
+ while (there's a character to process) {
+ handle transliteration ranges
+ skip regexp comments
+ skip # initiated comments in //x patterns
+ check for embedded @foo
+ check for embedded scalars
+ if (backslash) {
+ leave intact backslashes from leave (below)
+ deprecate \1 in strings and sub replacements
+ handle string-changing backslashes \l \U \Q \E, etc.
+ switch (what was escaped) {
+ handle - in a transliteration (becomes a literal -)
+ handle \132 octal characters
+ handle 0x15 hex characters
+ handle \cV (control V)
+ handle printf backslashes (\f, \r, \n, etc)
+ } (end switch)
+ } (end if backslash)
+ } (end while character to read)
+
+*/
+
static char *
scan_const(char *start)
{
- register char *send = bufend;
- SV *sv = NEWSV(93, send - start);
- register char *s = start;
- register char *d = SvPVX(sv);
- bool dorange = FALSE;
- I32 len;
+ register char *send = bufend; /* end of the constant */
+ SV *sv = NEWSV(93, send - start); /* sv for the constant */
+ register char *s = start; /* start of the constant */
+ register char *d = SvPVX(sv); /* destination for copies */
+ bool dorange = FALSE; /* are we in a translit range? */
+ I32 len; /* ? */
+
+ /*
+ leave is the set of acceptably-backslashed characters.
+
+ I do *not* understand why there's the double hook here.
+ */
char *leaveit =
lex_inpat
? "\\.^$@AGZdDwWsSbB+*?|()-nrtfeaxc0123456789[{]} \t\n\r\f\v#"
: "";
while (s < send || dorange) {
+ /* get transliterations out of the way (they're most literal) */
if (lex_inwhat == OP_TRANS) {
+ /* expand a range A-Z to the full set of characters. AIE! */
if (dorange) {
- I32 i;
- I32 max;
- i = d - SvPVX(sv);
- SvGROW(sv, SvLEN(sv) + 256);
- d = SvPVX(sv) + i;
- d -= 2;
- max = (U8)d[1];
+ I32 i; /* current expanded character */
+ I32 max; /* last character in range */
+
+ i = d - SvPVX(sv); /* remember current offset */
+ SvGROW(sv, SvLEN(sv) + 256); /* expand the sv -- there'll never be more'n 256 chars in a range for it to grow by */
+ d = SvPVX(sv) + i; /* restore d after the grow potentially has changed the ptr */
+ d -= 2; /* eat the first char and the - */
+
+ max = (U8)d[1]; /* last char in range */
+
for (i = (U8)*d; i <= max; i++)
*d++ = i;
+
+ /* mark the range as done, and continue */
dorange = FALSE;
continue;
}
+
+ /* range begins (ignore - as first or last char) */
else if (*s == '-' && s+1 < send && s != start) {
dorange = TRUE;
s++;
}
}
+
+ /* if we get here, we're not doing a transliteration */
+
+ /* skip for regexp comments /(?#comment)/ */
else if (*s == '(' && lex_inpat && s[1] == '?') {
if (s[2] == '#') {
while (s < send && *s != ')')
*d++ = *s++;
}
}
+
+ /* likewise skip #-initiated comments in //x patterns */
else if (*s == '#' && lex_inpat &&
((PMOP*)lex_inpat)->op_pmflags & PMf_EXTENDED) {
while (s+1 < send && *s != '\n')
*d++ = *s++;
}
+
+ /* check for embedded arrays (@foo, @:foo, @'foo, @{foo}, @$foo) */
else if (*s == '@' && s[1] && (isALNUM(s[1]) || strchr(":'{$", s[1])))
break;
+
+ /* check for embedded scalars. only stop if we're sure it's a
+ variable.
+ */
else if (*s == '$') {
if (!lex_inpat) /* not a regexp, so $ must be var */
break;
if (s + 1 < send && !strchr("()| \n\t", s[1]))
break; /* in regexp, $ might be tail anchor */
}
+
+ /* backslashes */
if (*s == '\\' && s+1 < send) {
s++;
+
+ /* some backslashes we leave behind */
if (*s && strchr(leaveit, *s)) {
*d++ = '\\';
*d++ = *s++;
continue;
}
+
+ /* deprecate \1 in strings and substitution replacements */
if (lex_inwhat == OP_SUBST && !lex_inpat &&
isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
{
*--s = '$';
break;
}
+
+ /* string-change backslash escapes */
if (lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
--s;
break;
}
+
+ /* if we get here, it's either a quoted -, or a digit */
switch (*s) {
+
+ /* quoted - in transliterations */
case '-':
if (lex_inwhat == OP_TRANS) {
*d++ = *s++;
continue;
}
/* FALL THROUGH */
+ /* default action is to copy the quoted character */
default:
*d++ = *s++;
continue;
+
+ /* \132 indicates an octal constant */
case '0': case '1': case '2': case '3':
case '4': case '5': case '6': case '7':
*d++ = scan_oct(s, 3, &len);
s += len;
continue;
+
+ /* \x24 indicates a hex constant */
case 'x':
*d++ = scan_hex(++s, 2, &len);
s += len;
continue;
+
+ /* \c is a control character */
case 'c':
s++;
len = *s++;
*d++ = toCTRL(len);
continue;
+
+ /* printf-style backslashes, formfeeds, newlines, etc */
case 'b':
*d++ = '\b';
break;
case 'a':
*d++ = '\007';
break;
- }
+ } /* end switch */
+
s++;
continue;
- }
+ } /* end if (backslash) */
+
*d++ = *s++;
- }
+ } /* while loop to process each character */
+
+ /* terminate the string and set up the sv */
*d = '\0';
SvCUR_set(sv, d - SvPVX(sv));
SvPOK_on(sv);
+ /* shrink the sv if we allocated more than we used */
if (SvCUR(sv) + 5 < SvLEN(sv)) {
SvLEN_set(sv, SvCUR(sv) + 1);
Renew(SvPVX(sv), SvLEN(sv), char);
}
+
+ /* ??? */
if (s > bufptr)
yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
else
else
return 0 ; /* end of file */
}
-
}
return SvCUR(buf_sv);
}
EXT int yychar; /* last token */
+/*
+ yylex
+
+ Works out what to call the token just pulled out of the input
+ stream. The yacc parser takes care of taking the ops we return and
+ stitching them into a tree.
+
+ Returns:
+ PRIVATEREF
+
+ Structure:
+ if read an identifier
+ if we're in a my declaration
+ croak if they tried to say my($foo::bar)
+ build the ops for a my() declaration
+ if it's an access to a my() variable
+ are we in a sort block?
+ croak if my($a); $a <=> $b
+ build ops for access to a my() variable
+ if in a dq string, and they've said @foo and we can't find @foo
+ croak
+ build ops for a bareword
+ if we already built the token before, use it.
+*/
+
int
yylex(void)
{
GV *gv = Nullgv;
GV **gvp = 0;
+ /* check if there's an identifier for us to look at */
if (pending_ident) {
+ /* pit holds the identifier we read and pending_ident is reset */
char pit = pending_ident;
pending_ident = 0;
+ /* if we're in a my(), we can't allow dynamics here.
+ $foo'bar has already been turned into $foo::bar, so
+ just check for colons.
+
+ if it's a legal name, the OP is a PADANY.
+ */
if (in_my) {
if (strchr(tokenbuf,':'))
croak(no_myglob,tokenbuf);
+
yylval.opval = newOP(OP_PADANY, 0);
yylval.opval->op_targ = pad_allocmy(tokenbuf);
return PRIVATEREF;
}
+ /*
+ build the ops for accesses to a my() variable.
+
+ Deny my($a) or my($b) in a sort block, *if* $a or $b is
+ then used in a comparison. This catches most, but not
+ all cases. For instance, it catches
+ sort { my($a); $a <=> $b }
+ but not
+ sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
+ (although why you'd do that is anyone's guess).
+ */
+
if (!strchr(tokenbuf,':')) {
#ifdef USE_THREADS
/* Check for single character per-thread SVs */
}
#endif /* USE_THREADS */
if ((tmp = pad_findmy(tokenbuf)) != NOT_IN_PAD) {
+ /* if it's a sort block and they're naming $a or $b */
if (last_lop_op == OP_SORT &&
tokenbuf[0] == '$' &&
(tokenbuf[1] == 'a' || tokenbuf[1] == 'b')
}
}
- /* Force them to make up their mind on "@foo". */
+ /*
+ Whine if they've said @foo in a doublequoted string,
+ and @foo isn't a variable we can find in the symbol
+ table.
+ */
if (pit == '@' && lex_state != LEX_NORMAL && !lex_brackets) {
GV *gv = gv_fetchpv(tokenbuf+1, FALSE, SVt_PVAV);
if (!gv || ((tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
tokenbuf, tokenbuf));
}
+ /* build ops for a bareword */
yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(tokenbuf+1, 0));
yylval.opval->op_private = OPpCONST_ENTERED;
gv_fetchpv(tokenbuf+1, in_eval ? GV_ADDMULTI : TRUE,
return WORD;
}
+ /* no identifier pending identification */
+
switch (lex_state) {
#ifdef COMMENTARY
case LEX_NORMAL: /* Some compilers will produce faster */
break;
#endif
+ /* when we're already built the next token, just pull it out the queue */
case LEX_KNOWNEXT:
nexttoke--;
yylval = nextval[nexttoke];
}
return(nexttype[nexttoke]);
+ /* interpolated case modifiers like \L \U, including \Q and \E.
+ when we get here, bufptr is at the \
+ */
case LEX_INTERPCASEMOD:
#ifdef DEBUGGING
if (bufptr != bufend && *bufptr != '\\')
croak("panic: INTERPCASEMOD");
#endif
- if (bufptr == bufend || bufptr[1] == 'E') {
+ /* handle \E or end of string */
+ if (bufptr == bufend || bufptr[1] == 'E') {
char oldmod;
+
+ /* if at a \E */
if (lex_casemods) {
oldmod = lex_casestack[--lex_casemods];
lex_casestack[lex_casemods] = '\0';
+
if (bufptr != bufend && strchr("LUQ", oldmod)) {
bufptr += 2;
lex_state = LEX_INTERPCONCAT;
return s;
}
+/* scan_inputsymbol
+ takes: current position in input buffer
+ returns: new position in input buffer
+ side-effects: yylval and lex_op are set.
+
+ This code handles:
+
+ <> read from ARGV
+ <FH> read from filehandle
+ <pkg::FH> read from package qualified filehandle
+ <pkg'FH> read from package qualified filehandle
+ <$fh> read from filehandle in $fh
+ <*.h> filename glob
+
+*/
+
static char *
scan_inputsymbol(char *start)
{
- register char *s = start;
+ register char *s = start; /* current position in buffer */
register char *d;
register char *e;
I32 len;
- d = tokenbuf;
- e = tokenbuf + sizeof tokenbuf;
- s = delimcpy(d, e, s + 1, bufend, '>', &len);
+ d = tokenbuf; /* start of temp holding space */
+ e = tokenbuf + sizeof tokenbuf; /* end of temp holding space */
+ s = delimcpy(d, e, s + 1, bufend, '>', &len); /* extract until > */
+
+ /* die if we didn't have space for the contents of the <>,
+ or if it didn't end
+ */
+
if (len >= sizeof tokenbuf)
croak("Excessively long <> operator");
if (s >= bufend)
croak("Unterminated <> operator");
+
s++;
+
+ /* check for <$fh>
+ Remember, only scalar variables are interpreted as filehandles by
+ this code. Anything more complex (e.g., <$fh{$num}>) will be
+ treated as a glob() call.
+ This code makes use of the fact that except for the $ at the front,
+ a scalar variable and a filehandle look the same.
+ */
if (*d == '$' && d[1]) d++;
+
+ /* allow <Pkg'VALUE> or <Pkg::VALUE> */
while (*d && (isALNUM(*d) || *d == '\'' || *d == ':'))
d++;
+
+ /* If we've tried to read what we allow filehandles to look like, and
+ there's still text left, then it must be a glob() and not a getline.
+ Use scan_str to pull out the stuff between the <> and treat it
+ as nothing more than a string.
+ */
+
if (d - tokenbuf != len) {
yylval.ival = OP_GLOB;
set_csh();
s = scan_str(start);
if (!s)
- croak("Glob not terminated");
+ croak("Glob not terminated");
return s;
}
else {
+ /* we're in a filehandle read situation */
d = tokenbuf;
+
+ /* turn <> into <ARGV> */
if (!len)
(void)strcpy(d,"ARGV");
+
+ /* if <$fh>, create the ops to turn the variable into a
+ filehandle
+ */
if (*d == '$') {
I32 tmp;
+
+ /* try to find it in the pad for this block, otherwise find
+ add symbol table ops
+ */
if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
OP *o = newOP(OP_PADSV, 0);
o->op_targ = tmp;
newUNOP(OP_RV2SV, 0,
newGVOP(OP_GV, 0, gv))));
}
+ /* we created the ops in lex_op, so make yylval.ival a null op */
yylval.ival = OP_NULL;
}
+
+ /* If it's none of the above, it must be a literal filehandle
+ (<Foo::BAR> or <FOO>) so build a simple readline OP */
else {
GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
yylval.ival = OP_NULL;
}
}
+
return s;
}
+
+/* scan_str
+ takes: start position in buffer
+ returns: position to continue reading from buffer
+ side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
+ updates the read buffer.
+
+ This subroutine pulls a string out of the input. It is called for:
+ q single quotes q(literal text)
+ ' single quotes 'literal text'
+ qq double quotes qq(interpolate $here please)
+ " double quotes "interpolate $here please"
+ qx backticks qx(/bin/ls -l)
+ ` backticks `/bin/ls -l`
+ qw quote words @EXPORT_OK = qw( func() $spam )
+ m// regexp match m/this/
+ s/// regexp substitute s/this/that/
+ tr/// string transliterate tr/this/that/
+ y/// string transliterate y/this/that/
+ ($*@) sub prototypes sub foo ($)
+ <> readline or globs <FOO>, <>, <$fh>, or <*.c>
+
+ In most of these cases (all but <>, patterns and transliterate)
+ yylex() calls scan_str(). m// makes yylex() call scan_pat() which
+ calls scan_str(). s/// makes yylex() call scan_subst() which calls
+ scan_str(). tr/// and y/// make yylex() call scan_trans() which
+ calls scan_str().
+
+ It skips whitespace before the string starts, and treats the first
+ character as the delimiter. If the delimiter is one of ([{< then
+ the corresponding "close" character )]}> is used as the closing
+ delimiter. It allows quoting of delimiters, and if the string has
+ balanced delimiters ([{<>}]) it allows nesting.
+
+ The lexer always reads these strings into lex_stuff, except in the
+ case of the operators which take *two* arguments (s/// and tr///)
+ when it checks to see if lex_stuff is full (presumably with the 1st
+ arg to s or tr) and if so puts the string into lex_repl.
+
+*/
+
static char *
scan_str(char *start)
{
dTHR;
- SV *sv;
- char *tmps;
- register char *s = start;
- register char term;
- register char *to;
- I32 brackets = 1;
-
+ SV *sv; /* scalar value: string */
+ char *tmps; /* temp string, used for delimiter matching */
+ register char *s = start; /* current position in the buffer */
+ register char term; /* terminating character */
+ register char *to; /* current position in the sv's data */
+ I32 brackets = 1; /* bracket nesting level */
+
+ /* skip space before the delimiter */
if (isSPACE(*s))
s = skipspace(s);
+
+ /* mark where we are, in case we need to report errors */
CLINE;
+
+ /* after skipping whitespace, the next character is the terminator */
term = *s;
+ /* mark where we are */
multi_start = curcop->cop_line;
multi_open = term;
+
+ /* find corresponding closing delimiter */
if (term && (tmps = strchr("([{< )]}> )]}>",term)))
term = tmps[5];
multi_close = term;
+ /* create a new SV to hold the contents. 87 is leak category, I'm
+ assuming. 80 is the SV's initial length. What a random number. */
sv = NEWSV(87,80);
sv_upgrade(sv, SVt_PVIV);
SvIVX(sv) = term;
(void)SvPOK_only(sv); /* validate pointer */
+
+ /* move past delimiter and try to read a complete string */
s++;
for (;;) {
+ /* extend sv if need be */
SvGROW(sv, SvCUR(sv) + (bufend - s) + 1);
+ /* set 'to' to the next character in the sv's string */
to = SvPVX(sv)+SvCUR(sv);
+
+ /* if open delimiter is the close delimiter read unbridle */
if (multi_open == multi_close) {
for (; s < bufend; s++,to++) {
+ /* embedded newlines increment the current line number */
if (*s == '\n' && !rsfp)
curcop->cop_line++;
+ /* handle quoted delimiters */
if (*s == '\\' && s+1 < bufend && term != '\\') {
if (s[1] == term)
s++;
+ /* any other quotes are simply copied straight through */
else
*to++ = *s++;
}
+ /* terminate when run out of buffer (the for() condition), or
+ have found the terminator */
else if (*s == term)
break;
*to = *s;
}
}
+
+ /* if the terminator isn't the same as the start character (e.g.,
+ matched brackets), we have to allow more in the quoting, and
+ be prepared for nested brackets.
+ */
else {
+ /* read until we run out of string, or we find the terminator */
for (; s < bufend; s++,to++) {
+ /* embedded newlines increment the line count */
if (*s == '\n' && !rsfp)
curcop->cop_line++;
+ /* backslashes can escape the open or closing characters */
if (*s == '\\' && s+1 < bufend) {
if ((s[1] == multi_open) || (s[1] == multi_close))
s++;
else
*to++ = *s++;
}
+ /* allow nested opens and closes */
else if (*s == multi_close && --brackets <= 0)
break;
else if (*s == multi_open)
*to = *s;
}
}
+ /* terminate the copied string and update the sv's end-of-string */
*to = '\0';
SvCUR_set(sv, to - SvPVX(sv));
- if (s < bufend) break; /* string ends on this line? */
+ /*
+ * this next chunk reads more into the buffer if we're not done yet
+ */
+
+ if (s < bufend) break; /* handle case where we are done yet :-) */
+ /* if we're out of file, or a read fails, bail and reset the current
+ line marker so we can report where the unterminated string began
+ */
if (!rsfp ||
!(oldoldbufptr = oldbufptr = s = linestart = filter_gets(linestr, rsfp, 0))) {
sv_free(sv);
curcop->cop_line = multi_start;
return Nullch;
}
+ /* we read a line, so increment our line counter */
curcop->cop_line++;
+
+ /* update debugger info */
if (PERLDB_LINE && curstash != debstash) {
SV *sv = NEWSV(88,0);
av_store(GvAV(curcop->cop_filegv),
(I32)curcop->cop_line, sv);
}
+
+ /* having changed the buffer, we must update bufend */
bufend = SvPVX(linestr) + SvCUR(linestr);
}
+
+ /* at this point, we have successfully read the delimited string */
+
multi_end = curcop->cop_line;
s++;
+
+ /* if we allocated too much space, give some back */
if (SvCUR(sv) + 5 < SvLEN(sv)) {
SvLEN_set(sv, SvCUR(sv) + 1);
Renew(SvPVX(sv), SvLEN(sv), char);
}
+
+ /* decide whether this is the first or second quoted string we've read
+ for this op
+ */
+
if (lex_stuff)
lex_repl = sv;
else
return s;
}
+/*
+ scan_num
+ takes: pointer to position in buffer
+ returns: pointer to new position in buffer
+ side-effects: builds ops for the constant in yylval.op
+
+ Read a number in any of the formats that Perl accepts:
+
+ 0(x[0-7A-F]+)|([0-7]+)
+ [\d_]+(\.[\d_]*)?[Ee](\d+)
+
+ Underbars (_) are allowed in decimal numbers. If -w is on,
+ underbars before a decimal point must be at three digit intervals.
+
+ Like most scan_ routines, it uses the tokenbuf buffer to hold the
+ thing it reads.
+
+ If it reads a number without a decimal point or an exponent, it will
+ try converting the number to an integer and see if it can do so
+ without loss of precision.
+*/
+
char *
scan_num(char *start)
{
- register char *s = start;
- register char *d;
- register char *e;
- I32 tryiv;
- double value;
- SV *sv;
- I32 floatit;
- char *lastub = 0;
+ register char *s = start; /* current position in buffer */
+ register char *d; /* destination in temp buffer */
+ register char *e; /* end of temp buffer */
+ I32 tryiv; /* used to see if it can be an int */
+ double value; /* number read, as a double */
+ SV *sv; /* place to put the converted number */
+ I32 floatit; /* boolean: int or float? */
+ char *lastub = 0; /* position of last underbar */
static char number_too_long[] = "Number too long";
+ /* We use the first character to decide what type of number this is */
+
switch (*s) {
default:
- croak("panic: scan_num");
+ croak("panic: scan_num");
+
+ /* if it starts with a 0, it could be an octal number, a decimal in
+ 0.13 disguise, or a hexadecimal number.
+ */
case '0':
{
+ /* variables:
+ u holds the "number so far"
+ shift the power of 2 of the base (hex == 4, octal == 3)
+ overflowed was the number more than we can hold?
+
+ Shift is used when we add a digit. It also serves as an "are
+ we in octal or hex?" indicator to disallow hex characters when
+ in octal mode.
+ */
UV u;
I32 shift;
bool overflowed = FALSE;
+ /* check for hex */
if (s[1] == 'x') {
shift = 4;
s += 2;
}
+ /* check for a decimal in disguise */
else if (s[1] == '.')
goto decimal;
+ /* so it must be octal */
else
shift = 3;
u = 0;
+
+ /* read the rest of the octal number */
for (;;) {
- UV n, b;
+ UV n, b; /* n is used in the overflow test, b is the digit we're adding on */
switch (*s) {
+
+ /* if we don't mention it, we're done */
default:
goto out;
+
+ /* _ are ignored */
case '_':
s++;
break;
+
+ /* 8 and 9 are not octal */
case '8': case '9':
if (shift != 4)
yyerror("Illegal octal digit");
/* FALL THROUGH */
+
+ /* octal digits */
case '0': case '1': case '2': case '3': case '4':
case '5': case '6': case '7':
- b = *s++ & 15;
+ b = *s++ & 15; /* ASCII digit -> value of digit */
goto digit;
+
+ /* hex digits */
case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
+ /* make sure they said 0x */
if (shift != 4)
goto out;
b = (*s++ & 7) + 9;
+
+ /* Prepare to put the digit we have onto the end
+ of the number so far. We check for overflows.
+ */
+
digit:
- n = u << shift;
+ n = u << shift; /* make room for the digit */
if (!overflowed && (n >> shift) != u) {
warn("Integer overflow in %s number",
(shift == 4) ? "hex" : "octal");
overflowed = TRUE;
}
- u = n | b;
+ u = n | b; /* add the digit to the end */
break;
}
}
+
+ /* if we get here, we had success: make a scalar value from
+ the number.
+ */
out:
sv = NEWSV(92,0);
sv_setuv(sv, u);
}
break;
+
+ /*
+ handle decimal numbers.
+ we're also sent here when we read a 0 as the first digit
+ */
case '1': case '2': case '3': case '4': case '5':
case '6': case '7': case '8': case '9': case '.':
decimal:
d = tokenbuf;
e = tokenbuf + sizeof tokenbuf - 6; /* room for various punctuation */
floatit = FALSE;
+
+ /* read next group of digits and _ and copy into d */
while (isDIGIT(*s) || *s == '_') {
+ /* skip underscores, checking for misplaced ones
+ if -w is on
+ */
if (*s == '_') {
if (dowarn && lastub && s - lastub != 3)
warn("Misplaced _ in number");
lastub = ++s;
}
else {
+ /* check for end of fixed-length buffer */
if (d >= e)
croak(number_too_long);
+ /* if we're ok, copy the character */
*d++ = *s++;
}
}
+
+ /* final misplaced underbar check */
if (dowarn && lastub && s - lastub != 3)
warn("Misplaced _ in number");
+
+ /* read a decimal portion if there is one. avoid
+ 3..5 being interpreted as the number 3. followed
+ by .5
+ */
if (*s == '.' && s[1] != '.') {
floatit = TRUE;
*d++ = *s++;
+
+ /* copy, ignoring underbars, until we run out of
+ digits. Note: no misplaced underbar checks!
+ */
for (; isDIGIT(*s) || *s == '_'; s++) {
+ /* fixed length buffer check */
if (d >= e)
croak(number_too_long);
if (*s != '_')
*d++ = *s;
}
}
+
+ /* read exponent part, if present */
if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
floatit = TRUE;
s++;
+
+ /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
*d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
+
+ /* allow positive or negative exponent */
if (*s == '+' || *s == '-')
*d++ = *s++;
+
+ /* read digits of exponent (no underbars :-) */
while (isDIGIT(*s)) {
if (d >= e)
croak(number_too_long);
*d++ = *s++;
}
}
+
+ /* terminate the string */
*d = '\0';
+
+ /* make an sv from the string */
sv = NEWSV(92,0);
+ /* reset numeric locale in case we were earlier left in Swaziland */
SET_NUMERIC_STANDARD();
value = atof(tokenbuf);
+
+ /*
+ See if we can make do with an integer value without loss of
+ precision. We use I_V to cast to an int, because some
+ compilers have issues. Then we try casting it back and see
+ if it was the same. We only do this if we know we
+ specifically read an integer.
+
+ Note: if floatit is true, then we don't need to do the
+ conversion at all.
+ */
tryiv = I_V(value);
if (!floatit && (double)tryiv == value)
sv_setiv(sv, tryiv);
break;
}
+ /* make the op for the constant and return */
+
yylval.opval = newSVOP(OP_CONST, 0, sv);
return s;
projects / p5sagit/p5-mst-13.2.git / commitdiff