five bytes or more.
=cut */
-STATIC STRLEN
+PERL_STATIC_INLINE STRLEN
S_is_utf8_char_slow(const U8 *s, const STRLEN len)
{
dTHX; /* The function called below requires thread context */
}
bool
+Perl_is_uni_alnumc(pTHX_ UV c)
+{
+ U8 tmpbuf[UTF8_MAXBYTES+1];
+ uvchr_to_utf8(tmpbuf, c);
+ return is_utf8_alnumc(tmpbuf);
+}
+
+bool /* Internal function so we can deprecate the external one, and call
+ this one from other deprecated functions in this file */
+S_is_utf8_idfirst(pTHX_ const U8 *p)
+{
+ dVAR;
+
+ if (*p == '_')
+ return TRUE;
+ /* is_utf8_idstart would be more logical. */
+ return is_utf8_common(p, &PL_utf8_idstart, "IdStart");
+}
+
+bool
Perl_is_uni_idfirst(pTHX_ UV c)
{
U8 tmpbuf[UTF8_MAXBYTES+1];
uvchr_to_utf8(tmpbuf, c);
- return is_utf8_idfirst(tmpbuf);
+ return S_is_utf8_idfirst(aTHX_ tmpbuf);
+}
+
+bool
+Perl__is_uni_perl_idstart(pTHX_ UV c)
+{
+ U8 tmpbuf[UTF8_MAXBYTES+1];
+ uvchr_to_utf8(tmpbuf, c);
+ return _is_utf8_perl_idstart(tmpbuf);
}
bool
bool
Perl_is_uni_blank(pTHX_ UV c)
{
- U8 tmpbuf[UTF8_MAXBYTES+1];
- uvchr_to_utf8(tmpbuf, c);
- return is_utf8_blank(tmpbuf);
+ return isBLANK_uni(c);
}
bool
Perl_is_uni_space(pTHX_ UV c)
{
- U8 tmpbuf[UTF8_MAXBYTES+1];
- uvchr_to_utf8(tmpbuf, c);
- return is_utf8_space(tmpbuf);
+ return isSPACE_uni(c);
}
bool
bool
Perl_is_uni_xdigit(pTHX_ UV c)
{
- U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
- uvchr_to_utf8(tmpbuf, c);
- return is_utf8_xdigit(tmpbuf);
+ return isXDIGIT_uni(c);
}
UV
}
}
-/* for now these all assume no locale info available for Unicode > 255; and
- * the corresponding macros in handy.h (like isALNUM_LC_uvchr) should have been
- * called instead, so that these don't get called for < 255 */
-
bool
Perl_is_uni_alnum_lc(pTHX_ UV c)
{
- return is_uni_alnum(c); /* XXX no locale support yet */
+ if (c < 256) {
+ return isALNUM_LC(UNI_TO_NATIVE(c));
+ }
+ return is_uni_alnum(c);
+}
+
+bool
+Perl_is_uni_alnumc_lc(pTHX_ UV c)
+{
+ if (c < 256) {
+ return isALNUMC_LC(UNI_TO_NATIVE(c));
+ }
+ return is_uni_alnumc(c);
}
bool
Perl_is_uni_idfirst_lc(pTHX_ UV c)
{
- return is_uni_idfirst(c); /* XXX no locale support yet */
+ if (c < 256) {
+ return isIDFIRST_LC(UNI_TO_NATIVE(c));
+ }
+ return _is_uni_perl_idstart(c);
}
bool
Perl_is_uni_alpha_lc(pTHX_ UV c)
{
- return is_uni_alpha(c); /* XXX no locale support yet */
+ if (c < 256) {
+ return isALPHA_LC(UNI_TO_NATIVE(c));
+ }
+ return is_uni_alpha(c);
}
bool
Perl_is_uni_ascii_lc(pTHX_ UV c)
{
- return is_uni_ascii(c); /* XXX no locale support yet */
+ if (c < 256) {
+ return isASCII_LC(UNI_TO_NATIVE(c));
+ }
+ return 0;
}
bool
Perl_is_uni_blank_lc(pTHX_ UV c)
{
- return is_uni_blank(c); /* XXX no locale support yet */
+ if (c < 256) {
+ return isBLANK_LC(UNI_TO_NATIVE(c));
+ }
+ return isBLANK_uni(c);
}
bool
Perl_is_uni_space_lc(pTHX_ UV c)
{
- return is_uni_space(c); /* XXX no locale support yet */
+ if (c < 256) {
+ return isSPACE_LC(UNI_TO_NATIVE(c));
+ }
+ return isSPACE_uni(c);
}
bool
Perl_is_uni_digit_lc(pTHX_ UV c)
{
- return is_uni_digit(c); /* XXX no locale support yet */
+ if (c < 256) {
+ return isDIGIT_LC(UNI_TO_NATIVE(c));
+ }
+ return is_uni_digit(c);
}
bool
Perl_is_uni_upper_lc(pTHX_ UV c)
{
- return is_uni_upper(c); /* XXX no locale support yet */
+ if (c < 256) {
+ return isUPPER_LC(UNI_TO_NATIVE(c));
+ }
+ return is_uni_upper(c);
}
bool
Perl_is_uni_lower_lc(pTHX_ UV c)
{
- return is_uni_lower(c); /* XXX no locale support yet */
+ if (c < 256) {
+ return isLOWER_LC(UNI_TO_NATIVE(c));
+ }
+ return is_uni_lower(c);
}
bool
Perl_is_uni_cntrl_lc(pTHX_ UV c)
{
- return is_uni_cntrl(c); /* XXX no locale support yet */
+ if (c < 256) {
+ return isCNTRL_LC(UNI_TO_NATIVE(c));
+ }
+ return 0;
}
bool
Perl_is_uni_graph_lc(pTHX_ UV c)
{
- return is_uni_graph(c); /* XXX no locale support yet */
+ if (c < 256) {
+ return isGRAPH_LC(UNI_TO_NATIVE(c));
+ }
+ return is_uni_graph(c);
}
bool
Perl_is_uni_print_lc(pTHX_ UV c)
{
- return is_uni_print(c); /* XXX no locale support yet */
+ if (c < 256) {
+ return isPRINT_LC(UNI_TO_NATIVE(c));
+ }
+ return is_uni_print(c);
}
bool
Perl_is_uni_punct_lc(pTHX_ UV c)
{
- return is_uni_punct(c); /* XXX no locale support yet */
+ if (c < 256) {
+ return isPUNCT_LC(UNI_TO_NATIVE(c));
+ }
+ return is_uni_punct(c);
}
bool
Perl_is_uni_xdigit_lc(pTHX_ UV c)
{
- return is_uni_xdigit(c); /* XXX no locale support yet */
+ if (c < 256) {
+ return isXDIGIT_LC(UNI_TO_NATIVE(c));
+ }
+ return isXDIGIT_uni(c);
}
U32
return (U32)to_uni_lower(c, tmpbuf, &len);
}
-static bool
+PERL_STATIC_INLINE bool
S_is_utf8_common(pTHX_ const U8 *const p, SV **swash,
const char *const swashname)
{
}
bool
+Perl_is_utf8_alnumc(pTHX_ const U8 *p)
+{
+ dVAR;
+
+ PERL_ARGS_ASSERT_IS_UTF8_ALNUMC;
+
+ return is_utf8_common(p, &PL_utf8_alnumc, "IsAlnum");
+}
+
+bool
Perl_is_utf8_idfirst(pTHX_ const U8 *p) /* The naming is historical. */
{
dVAR;
PERL_ARGS_ASSERT_IS_UTF8_IDFIRST;
- if (*p == '_')
- return TRUE;
- /* is_utf8_idstart would be more logical. */
- return is_utf8_common(p, &PL_utf8_idstart, "IdStart");
+ return S_is_utf8_idfirst(aTHX_ p);
}
bool
}
bool
-Perl__is_utf8__perl_idstart(pTHX_ const U8 *p)
+Perl__is_utf8_perl_idstart(pTHX_ const U8 *p)
{
dVAR;
- PERL_ARGS_ASSERT__IS_UTF8__PERL_IDSTART;
+ PERL_ARGS_ASSERT__IS_UTF8_PERL_IDSTART;
return is_utf8_common(p, &PL_utf8_perl_idstart, "_Perl_IDStart");
}
PERL_ARGS_ASSERT_IS_UTF8_BLANK;
- return is_utf8_common(p, &PL_utf8_blank, "XPosixBlank");
+ return isBLANK_utf8(p);
}
bool
PERL_ARGS_ASSERT_IS_UTF8_SPACE;
- return is_utf8_common(p, &PL_utf8_space, "IsXPerlSpace");
+ return isSPACE_utf8(p);
}
bool
PERL_ARGS_ASSERT_IS_UTF8_CNTRL;
- if (isASCII(*p)) {
- return isCNTRL_A(*p);
- }
-
- /* All controls are in Latin1 */
- if (! UTF8_IS_DOWNGRADEABLE_START(*p)) {
- return 0;
- }
- return isCNTRL_L1(TWO_BYTE_UTF8_TO_UNI(*p, *(p+1)));
+ return isCNTRL_utf8(p);
}
bool
PERL_ARGS_ASSERT_IS_UTF8_XDIGIT;
- return is_utf8_common(p, &PL_utf8_xdigit, "IsXDigit");
+ return is_XDIGIT_utf8(p);
}
bool
* by calling utf8_heavy.pl in the general case. The returned value may be
* the swash's inversion list instead if the input parameters allow it.
* Which is returned should be immaterial to callers, as the only
- * operations permitted on a swash, swash_fetch() and
- * _get_swash_invlist(), handle both these transparently.
+ * operations permitted on a swash, swash_fetch(), _get_swash_invlist(),
+ * and swash_to_invlist() handle both these transparently.
*
* This interface should only be used by functions that won't destroy or
* adversely change the swash, as doing so affects all other uses of the
method = gv_fetchmeth(stash, "SWASHNEW", 8, -1);
if (!method) { /* demand load utf8 */
ENTER;
- errsv_save = newSVsv(ERRSV);
- SAVEFREESV(errsv_save);
+ if ((errsv_save = GvSV(PL_errgv))) SAVEFREESV(errsv_save);
+ GvSV(PL_errgv) = NULL;
/* It is assumed that callers of this routine are not passing in
* any user derived data. */
/* Need to do this after save_re_context() as it will set
#endif
Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn(pkg,pkg_len),
NULL);
- if (!SvTRUE(ERRSV))
- sv_setsv(ERRSV, errsv_save);
+ {
+ /* Not ERRSV, as there is no need to vivify a scalar we are
+ about to discard. */
+ SV * const errsv = GvSV(PL_errgv);
+ if (!SvTRUE(errsv)) {
+ GvSV(PL_errgv) = SvREFCNT_inc_simple(errsv_save);
+ SvREFCNT_dec(errsv);
+ }
+ }
LEAVE;
}
SPAGAIN;
mPUSHi(minbits);
mPUSHi(none);
PUTBACK;
- errsv_save = newSVsv(ERRSV);
- SAVEFREESV(errsv_save);
+ if ((errsv_save = GvSV(PL_errgv))) SAVEFREESV(errsv_save);
+ GvSV(PL_errgv) = NULL;
/* If we already have a pointer to the method, no need to use
* call_method() to repeat the lookup. */
- if (method ? call_sv(MUTABLE_SV(method), G_SCALAR)
+ if (method
+ ? call_sv(MUTABLE_SV(method), G_SCALAR)
: call_sv(newSVpvs_flags("SWASHNEW", SVs_TEMP), G_SCALAR | G_METHOD))
{
retval = *PL_stack_sp--;
SvREFCNT_inc(retval);
}
- if (!SvTRUE(ERRSV))
- sv_setsv(ERRSV, errsv_save);
+ {
+ /* Not ERRSV. See above. */
+ SV * const errsv = GvSV(PL_errgv);
+ if (!SvTRUE(errsv)) {
+ GvSV(PL_errgv) = SvREFCNT_inc_simple(errsv_save);
+ SvREFCNT_dec(errsv);
+ }
+ }
LEAVE;
POPSTACK;
if (IN_PERL_COMPILETIME) {
* we are going to return a swash */
if ((int) _invlist_len(invlist) > invlist_swash_boundary) {
swash_hv = newHV();
- retval = newRV_inc(MUTABLE_SV(swash_hv));
+ retval = newRV_noinc(MUTABLE_SV(swash_hv));
}
swash_invlist = invlist;
}
{
Perl_croak(aTHX_ "panic: hv_store() unexpectedly failed");
}
+ /* We just stole a reference count. */
+ if (swash_invlist_unclaimed) swash_invlist_unclaimed = FALSE;
+ else SvREFCNT_inc_simple_void_NN(swash_invlist);
}
+ /* Use the inversion list stand-alone if small enough */
if ((int) _invlist_len(swash_invlist) <= invlist_swash_boundary) {
SvREFCNT_dec(retval);
if (!swash_invlist_unclaimed)
STRLEN lcur;
HV *const hv = MUTABLE_HV(SvRV(swash));
- /* The string containing the main body of the table */
+ /* The string containing the main body of the table. This will have its
+ * assertion fail if the swash has been converted to its inversion list */
SV** const listsvp = hv_fetchs(hv, "LIST", FALSE);
SV** const typesvp = hv_fetchs(hv, "TYPE", FALSE);
HV *const hv = MUTABLE_HV(SvRV(swash));
UV elements = 0; /* Number of elements in the inversion list */
U8 empty[] = "";
+ SV** listsvp;
+ SV** typesvp;
+ SV** bitssvp;
+ SV** extssvp;
+ SV** invert_it_svp;
- /* The string containing the main body of the table */
- SV** const listsvp = hv_fetchs(hv, "LIST", FALSE);
- SV** const typesvp = hv_fetchs(hv, "TYPE", FALSE);
- SV** const bitssvp = hv_fetchs(hv, "BITS", FALSE);
- SV** const extssvp = hv_fetchs(hv, "EXTRAS", FALSE);
- SV** const invert_it_svp = hv_fetchs(hv, "INVERT_IT", FALSE);
-
- const U8* const typestr = (U8*)SvPV_nolen(*typesvp);
- const STRLEN bits = SvUV(*bitssvp);
- const STRLEN octets = bits >> 3; /* if bits == 1, then octets == 0 */
+ U8* typestr;
+ STRLEN bits;
+ STRLEN octets; /* if bits == 1, then octets == 0 */
U8 *x, *xend;
STRLEN xcur;
PERL_ARGS_ASSERT__SWASH_TO_INVLIST;
+ /* If not a hash, it must be the swash's inversion list instead */
+ if (SvTYPE(hv) != SVt_PVHV) {
+ return (SV*) hv;
+ }
+
+ /* The string containing the main body of the table */
+ listsvp = hv_fetchs(hv, "LIST", FALSE);
+ typesvp = hv_fetchs(hv, "TYPE", FALSE);
+ bitssvp = hv_fetchs(hv, "BITS", FALSE);
+ extssvp = hv_fetchs(hv, "EXTRAS", FALSE);
+ invert_it_svp = hv_fetchs(hv, "INVERT_IT", FALSE);
+
+ typestr = (U8*)SvPV_nolen(*typesvp);
+ bits = SvUV(*bitssvp);
+ octets = bits >> 3; /* if bits == 1, then octets == 0 */
+
/* read $swash->{LIST} */
if (SvPOK(*listsvp)) {
l = (U8*)SvPV(*listsvp, lcur);
_invlist_union(invlist, other, &invlist);
break;
case '!':
- _invlist_invert(other);
- _invlist_union(invlist, other, &invlist);
+ _invlist_union_maybe_complement_2nd(invlist, other, TRUE, &invlist);
break;
case '-':
_invlist_subtract(invlist, other, &invlist);
}
bool
-Perl_check_utf8_print(pTHX_ register const U8* s, const STRLEN len)
+Perl_check_utf8_print(pTHX_ const U8* s, const STRLEN len)
{
/* May change: warns if surrogates, non-character code points, or
* non-Unicode code points are in s which has length len bytes. Returns
* FOLDEQ_S2_ALREADY_FOLDED Similarly.
*/
I32
-Perl_foldEQ_utf8_flags(pTHX_ const char *s1, char **pe1, register UV l1, bool u1, const char *s2, char **pe2, register UV l2, bool u2, U32 flags)
+Perl_foldEQ_utf8_flags(pTHX_ const char *s1, char **pe1, UV l1, bool u1, const char *s2, char **pe2, UV l2, bool u2, U32 flags)
{
dVAR;
const U8 *p1 = (const U8*)s1; /* Point to current char */
f1 = (U8 *) p1;
n1 = UTF8SKIP(f1);
}
-
else {
/* If in locale matching, we use two sets of rules, depending
* on if the code point is above or below 255. Here, we test
https://perl5.git.perl.org / perl5.git / blobdiff