path: root/dquote_static.c

/*    dquote_static.c
 *
 * This file contains static functions that are related to
 * parsing double-quotish expressions, but are used in more than
 * one file.
 *
 * It is currently #included by regcomp.c and toke.c.
*/

#define PERL_IN_DQUOTE_STATIC_C
#include "embed.h"

/*
 - regcurly - a little FSA that accepts {\d+,?\d*}
    Pulled from regcomp.c.
 */
PERL_STATIC_INLINE I32
S_regcurly(pTHX_ const char *s)
{
    PERL_ARGS_ASSERT_REGCURLY;

    if (*s++ != '{')
	return FALSE;
    if (!isDIGIT(*s))
	return FALSE;
    while (isDIGIT(*s))
	s++;
    if (*s == ',') {
	s++;
	while (isDIGIT(*s))
	    s++;
    }
    if (*s != '}')
	return FALSE;
    return TRUE;
}

/* XXX Add documentation after final interface and behavior is decided */
/* May want to show context for error, so would pass Perl_bslash_c(pTHX_ const char* current, const char* start, const bool output_warning)
    U8 source = *current;
*/

STATIC char
S_grok_bslash_c(pTHX_ const char source, const bool utf8, const bool output_warning)
{

    U8 result;

    if (utf8) {
	/* Trying to deprecate non-ASCII usages.  This construct has never
	 * worked for a utf8 variant.  So, even though are accepting non-ASCII
	 * Latin1 in 5.14, no need to make them work under utf8 */
	if (! isASCII(source)) {
	    Perl_croak(aTHX_ "Character following \"\\c\" must be ASCII");
	}
    }

    result = toCTRL(source);
    if (! isASCII(source)) {
	    Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
			    "Character following \"\\c\" must be ASCII");
    }
    else if (! isCNTRL(result) && output_warning) {
	if (source == '{') {
	    Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
			    "\"\\c{\" is deprecated and is more clearly written as \";\"");
	}
	else {
	    U8 clearer[3];
	    U8 i = 0;
	    if (! isWORDCHAR(result)) {
		clearer[i++] = '\\';
	    }
	    clearer[i++] = result;
	    clearer[i++] = '\0';

	    Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
			    "\"\\c%c\" is more clearly written simply as \"%s\"",
			    source,
			    clearer);
	}
    }

    return result;
}

STATIC bool
S_grok_bslash_o(pTHX_ char **s, UV *uv, const char** error_msg,
                      const bool output_warning)
{

/*  Documentation to be supplied when interface nailed down finally
 *  This returns FALSE if there is an error which the caller need not recover
 *  from; , otherwise TRUE.  In either case the caller should look at *len
 *  On input:
 *	s   is the address of a pointer to a NULL terminated string that begins
 *	    with 'o', and the previous character was a backslash.  At exit, *s
 *	    will be advanced to the byte just after those absorbed by this
 *	    function.  Hence the caller can continue parsing from there.  In
 *	    the case of an error, this routine has generally positioned *s to
 *	    point just to the right of the first bad spot, so that a message
 *	    that has a "<--" to mark the spot will be correctly positioned.
 *	uv  points to a UV that will hold the output value, valid only if the
 *	    return from the function is TRUE
 *      error_msg is a pointer that will be set to an internal buffer giving an
 *	    error message upon failure (the return is FALSE).  Untouched if
 *	    function succeeds
 *	output_warning says whether to output any warning messages, or suppress
 *	    them
 */
    char* e;
    STRLEN numbers_len;
    I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
		| PERL_SCAN_DISALLOW_PREFIX
		/* XXX Until the message is improved in grok_oct, handle errors
		 * ourselves */
	        | PERL_SCAN_SILENT_ILLDIGIT;

    PERL_ARGS_ASSERT_GROK_BSLASH_O;


    assert(**s == 'o');
    (*s)++;

    if (**s != '{') {
	*error_msg = "Missing braces on \\o{}";
	return FALSE;
    }

    e = strchr(*s, '}');
    if (!e) {
        (*s)++;  /* Move past the '{' */
        *error_msg = "Missing right brace on \\o{";
	return FALSE;
    }

    (*s)++;    /* Point to expected first digit (could be first byte of utf8
                  sequence if not a digit) */
    numbers_len = e - *s;
    if (numbers_len == 0) {
        (*s)++;    /* Move past the } */
	*error_msg = "Number with no digits";
	return FALSE;
    }

    *uv = grok_oct(*s, &numbers_len, &flags, NULL);
    /* Note that if has non-octal, will ignore everything starting with that up
     * to the '}' */

    if (output_warning && numbers_len != (STRLEN) (e - *s)) {
	Perl_ck_warner(aTHX_ packWARN(WARN_DIGIT),
	/* diag_listed_as: Non-octal character '%c'.  Resolved as "%s" */
		       "Non-octal character '%c'.  Resolved as \"\\o{%.*s}\"",
		       *(*s + numbers_len),
		       (int) numbers_len,
		       *s);
    }

    /* Return past the '}' */
    *s = e + 1;

    return TRUE;
}

PERL_STATIC_INLINE bool
S_grok_bslash_x(pTHX_ char **s, UV *uv, const char** error_msg,
                      const bool output_warning)
{

/*  Documentation to be supplied when interface nailed down finally
 *  This returns FALSE if there is an error which the caller need not recover
 *  from; , otherwise TRUE.  In either case the caller should look at *len
 *  On input:
 *	s   is the address of a pointer to a NULL terminated string that begins
 *	    with 'x', and the previous character was a backslash.  At exit, *s
 *	    will be advanced to the byte just after those absorbed by this
 *	    function.  Hence the caller can continue parsing from there.  In
 *	    the case of an error, this routine has generally positioned *s to
 *	    point just to the right of the first bad spot, so that a message
 *	    that has a "<--" to mark the spot will be correctly positioned.
 *	uv  points to a UV that will hold the output value, valid only if the
 *	    return from the function is TRUE
 *      error_msg is a pointer that will be set to an internal buffer giving an
 *	    error message upon failure (the return is FALSE).  Untouched if
 *	    function succeeds
 *	output_warning says whether to output any warning messages, or suppress
 *	    them
 */
    char* e;
    STRLEN numbers_len;
    I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
		| PERL_SCAN_DISALLOW_PREFIX;

    PERL_ARGS_ASSERT_GROK_BSLASH_X;

    PERL_UNUSED_ARG(output_warning);

    assert(**s == 'x');
    (*s)++;

    if (**s != '{') {
       I32 flags = PERL_SCAN_DISALLOW_PREFIX;
       STRLEN len = 2;
	*uv = grok_hex(*s, &len, &flags, NULL);
	*s += len;
	return TRUE;
    }

    e = strchr(*s, '}');
    if (!e) {
        (*s)++;  /* Move past the '{' */
        /* XXX The corresponding message above for \o is just '\\o{'; other
         * messages for other constructs include the '}', so are inconsistent.
         */
	*error_msg = "Missing right brace on \\x{}";
	return FALSE;
    }

    (*s)++;    /* Point to expected first digit (could be first byte of utf8
                  sequence if not a digit) */
    numbers_len = e - *s;
    *uv = grok_hex(*s, &numbers_len, &flags, NULL);
    /* Note that if has non-hex, will ignore everything starting with that up
     * to the '}' */

    /* Return past the '}' */
    *s = e + 1;

    return TRUE;
}

/*
 * Local variables:
 * c-indentation-style: bsd
 * c-basic-offset: 4
 * indent-tabs-mode: nil
 * End:
 *
 * ex: set ts=8 sts=4 sw=4 et:
 */