This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Some SvREFCNT_foo are no longer macros
[perl5.git] / inline.h
CommitLineData
25468daa
FC
1/* inline.h
2 *
3 * Copyright (C) 2012 by Larry Wall and others
4 *
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
7 *
8ed185f9
KW
8 * This file contains tables and code adapted from
9 * http://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which requires this
10 * copyright notice:
11
12Copyright (c) 2008-2009 Bjoern Hoehrmann <bjoern@hoehrmann.de>
13
14Permission is hereby granted, free of charge, to any person obtaining a copy of
15this software and associated documentation files (the "Software"), to deal in
16the Software without restriction, including without limitation the rights to
17use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies
18of the Software, and to permit persons to whom the Software is furnished to do
19so, subject to the following conditions:
20
21The above copyright notice and this permission notice shall be included in all
22copies or substantial portions of the Software.
23
24THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
25IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
26FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
27AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
28LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
29OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
30SOFTWARE.
31
32 *
25468daa 33 * This file is a home for static inline functions that cannot go in other
e15e54ff 34 * header files, because they depend on proto.h (included after most other
25468daa
FC
35 * headers) or struct definitions.
36 *
37 * Each section names the header file that the functions "belong" to.
38 */
27669aa4 39
be3a7a5d
KW
40/* ------------------------------- av.h ------------------------------- */
41
c70927a6 42PERL_STATIC_INLINE SSize_t
c9182d9c 43Perl_av_top_index(pTHX_ AV *av)
be3a7a5d
KW
44{
45 PERL_ARGS_ASSERT_AV_TOP_INDEX;
46 assert(SvTYPE(av) == SVt_PVAV);
47
48 return AvFILL(av);
49}
50
1afe1db1
FC
51/* ------------------------------- cv.h ------------------------------- */
52
ae77754a 53PERL_STATIC_INLINE GV *
c9182d9c 54Perl_CvGV(pTHX_ CV *sv)
ae77754a
FC
55{
56 return CvNAMED(sv)
57 ? Perl_cvgv_from_hek(aTHX_ sv)
58 : ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_gv_u.xcv_gv;
59}
60
1afe1db1 61PERL_STATIC_INLINE I32 *
c9182d9c 62Perl_CvDEPTHp(const CV * const sv)
1afe1db1
FC
63{
64 assert(SvTYPE(sv) == SVt_PVCV || SvTYPE(sv) == SVt_PVFM);
8de47657 65 return &((XPVCV*)SvANY(sv))->xcv_depth;
1afe1db1
FC
66}
67
d16269d8
PM
68/*
69 CvPROTO returns the prototype as stored, which is not necessarily what
70 the interpreter should be using. Specifically, the interpreter assumes
71 that spaces have been stripped, which has been the case if the prototype
72 was added by toke.c, but is generally not the case if it was added elsewhere.
73 Since we can't enforce the spacelessness at assignment time, this routine
74 provides a temporary copy at parse time with spaces removed.
75 I<orig> is the start of the original buffer, I<len> is the length of the
76 prototype and will be updated when this returns.
77 */
78
5b67adb8 79#ifdef PERL_CORE
d16269d8
PM
80PERL_STATIC_INLINE char *
81S_strip_spaces(pTHX_ const char * orig, STRLEN * const len)
82{
83 SV * tmpsv;
84 char * tmps;
85 tmpsv = newSVpvn_flags(orig, *len, SVs_TEMP);
86 tmps = SvPVX(tmpsv);
87 while ((*len)--) {
88 if (!isSPACE(*orig))
89 *tmps++ = *orig;
90 orig++;
91 }
92 *tmps = '\0';
93 *len = tmps - SvPVX(tmpsv);
94 return SvPVX(tmpsv);
95}
5b67adb8 96#endif
d16269d8 97
25fdce4a
FC
98/* ------------------------------- mg.h ------------------------------- */
99
100#if defined(PERL_CORE) || defined(PERL_EXT)
101/* assumes get-magic and stringification have already occurred */
102PERL_STATIC_INLINE STRLEN
103S_MgBYTEPOS(pTHX_ MAGIC *mg, SV *sv, const char *s, STRLEN len)
104{
105 assert(mg->mg_type == PERL_MAGIC_regex_global);
106 assert(mg->mg_len != -1);
107 if (mg->mg_flags & MGf_BYTES || !DO_UTF8(sv))
108 return (STRLEN)mg->mg_len;
109 else {
110 const STRLEN pos = (STRLEN)mg->mg_len;
111 /* Without this check, we may read past the end of the buffer: */
112 if (pos > sv_or_pv_len_utf8(sv, s, len)) return len+1;
113 return sv_or_pv_pos_u2b(sv, s, pos, NULL);
114 }
115}
116#endif
117
03414f05
FC
118/* ------------------------------- pad.h ------------------------------ */
119
120#if defined(PERL_IN_PAD_C) || defined(PERL_IN_OP_C)
121PERL_STATIC_INLINE bool
122PadnameIN_SCOPE(const PADNAME * const pn, const U32 seq)
123{
124 /* is seq within the range _LOW to _HIGH ?
125 * This is complicated by the fact that PL_cop_seqmax
126 * may have wrapped around at some point */
127 if (COP_SEQ_RANGE_LOW(pn) == PERL_PADSEQ_INTRO)
128 return FALSE; /* not yet introduced */
129
130 if (COP_SEQ_RANGE_HIGH(pn) == PERL_PADSEQ_INTRO) {
131 /* in compiling scope */
132 if (
133 (seq > COP_SEQ_RANGE_LOW(pn))
134 ? (seq - COP_SEQ_RANGE_LOW(pn) < (U32_MAX >> 1))
135 : (COP_SEQ_RANGE_LOW(pn) - seq > (U32_MAX >> 1))
136 )
137 return TRUE;
138 }
139 else if (
140 (COP_SEQ_RANGE_LOW(pn) > COP_SEQ_RANGE_HIGH(pn))
141 ?
142 ( seq > COP_SEQ_RANGE_LOW(pn)
143 || seq <= COP_SEQ_RANGE_HIGH(pn))
144
145 : ( seq > COP_SEQ_RANGE_LOW(pn)
146 && seq <= COP_SEQ_RANGE_HIGH(pn))
147 )
148 return TRUE;
149 return FALSE;
150}
151#endif
152
33a4312b
FC
153/* ------------------------------- pp.h ------------------------------- */
154
155PERL_STATIC_INLINE I32
c9182d9c 156Perl_TOPMARK(pTHX)
33a4312b
FC
157{
158 DEBUG_s(DEBUG_v(PerlIO_printf(Perl_debug_log,
147e3846 159 "MARK top %p %" IVdf "\n",
33a4312b
FC
160 PL_markstack_ptr,
161 (IV)*PL_markstack_ptr)));
162 return *PL_markstack_ptr;
163}
164
165PERL_STATIC_INLINE I32
c9182d9c 166Perl_POPMARK(pTHX)
33a4312b
FC
167{
168 DEBUG_s(DEBUG_v(PerlIO_printf(Perl_debug_log,
147e3846 169 "MARK pop %p %" IVdf "\n",
33a4312b
FC
170 (PL_markstack_ptr-1),
171 (IV)*(PL_markstack_ptr-1))));
172 assert((PL_markstack_ptr > PL_markstack) || !"MARK underflow");
173 return *PL_markstack_ptr--;
174}
175
8d919b0a
FC
176/* ----------------------------- regexp.h ----------------------------- */
177
178PERL_STATIC_INLINE struct regexp *
c9182d9c 179Perl_ReANY(const REGEXP * const re)
8d919b0a 180{
df6b4bd5 181 XPV* const p = (XPV*)SvANY(re);
8d919b0a 182 assert(isREGEXP(re));
df6b4bd5
DM
183 return SvTYPE(re) == SVt_PVLV ? p->xpv_len_u.xpvlenu_rx
184 : (struct regexp *)p;
8d919b0a
FC
185}
186
27669aa4
FC
187/* ------------------------------- sv.h ------------------------------- */
188
189PERL_STATIC_INLINE SV *
c9182d9c 190Perl_SvREFCNT_inc(SV *sv)
27669aa4 191{
2439e033 192 if (LIKELY(sv != NULL))
27669aa4
FC
193 SvREFCNT(sv)++;
194 return sv;
195}
196PERL_STATIC_INLINE SV *
c9182d9c 197Perl_SvREFCNT_inc_NN(SV *sv)
27669aa4 198{
3f2f854a
KW
199 PERL_ARGS_ASSERT_SVREFCNT_INC_NN;
200
27669aa4
FC
201 SvREFCNT(sv)++;
202 return sv;
203}
204PERL_STATIC_INLINE void
c9182d9c 205Perl_SvREFCNT_inc_void(SV *sv)
27669aa4 206{
2439e033 207 if (LIKELY(sv != NULL))
27669aa4
FC
208 SvREFCNT(sv)++;
209}
75e16a44 210PERL_STATIC_INLINE void
c9182d9c 211Perl_SvREFCNT_dec(pTHX_ SV *sv)
75e16a44 212{
2439e033 213 if (LIKELY(sv != NULL)) {
75a9bf96 214 U32 rc = SvREFCNT(sv);
79e2a32a 215 if (LIKELY(rc > 1))
75a9bf96
DM
216 SvREFCNT(sv) = rc - 1;
217 else
218 Perl_sv_free2(aTHX_ sv, rc);
75e16a44
FC
219 }
220}
541377b1
FC
221
222PERL_STATIC_INLINE void
c9182d9c 223Perl_SvREFCNT_dec_NN(pTHX_ SV *sv)
4a9a56a7
DM
224{
225 U32 rc = SvREFCNT(sv);
3f2f854a
KW
226
227 PERL_ARGS_ASSERT_SVREFCNT_DEC_NN;
228
79e2a32a 229 if (LIKELY(rc > 1))
4a9a56a7
DM
230 SvREFCNT(sv) = rc - 1;
231 else
232 Perl_sv_free2(aTHX_ sv, rc);
233}
234
235PERL_STATIC_INLINE void
541377b1
FC
236SvAMAGIC_on(SV *sv)
237{
238 assert(SvROK(sv));
239 if (SvOBJECT(SvRV(sv))) HvAMAGIC_on(SvSTASH(SvRV(sv)));
240}
241PERL_STATIC_INLINE void
242SvAMAGIC_off(SV *sv)
243{
244 if (SvROK(sv) && SvOBJECT(SvRV(sv)))
245 HvAMAGIC_off(SvSTASH(SvRV(sv)));
246}
247
248PERL_STATIC_INLINE U32
c9182d9c 249Perl_SvPADSTALE_on(SV *sv)
541377b1 250{
c0683843 251 assert(!(SvFLAGS(sv) & SVs_PADTMP));
541377b1
FC
252 return SvFLAGS(sv) |= SVs_PADSTALE;
253}
254PERL_STATIC_INLINE U32
c9182d9c 255Perl_SvPADSTALE_off(SV *sv)
541377b1 256{
c0683843 257 assert(!(SvFLAGS(sv) & SVs_PADTMP));
541377b1
FC
258 return SvFLAGS(sv) &= ~SVs_PADSTALE;
259}
25fdce4a 260#if defined(PERL_CORE) || defined (PERL_EXT)
4ddea69a 261PERL_STATIC_INLINE STRLEN
6964422a 262S_sv_or_pv_pos_u2b(pTHX_ SV *sv, const char *pv, STRLEN pos, STRLEN *lenp)
4ddea69a 263{
25fdce4a 264 PERL_ARGS_ASSERT_SV_OR_PV_POS_U2B;
4ddea69a
FC
265 if (SvGAMAGIC(sv)) {
266 U8 *hopped = utf8_hop((U8 *)pv, pos);
267 if (lenp) *lenp = (STRLEN)(utf8_hop(hopped, *lenp) - hopped);
268 return (STRLEN)(hopped - (U8 *)pv);
269 }
270 return sv_pos_u2b_flags(sv,pos,lenp,SV_CONST_RETURN);
271}
272#endif
f019c49e 273
d1decf2b
TC
274/* ------------------------------- handy.h ------------------------------- */
275
276/* saves machine code for a common noreturn idiom typically used in Newx*() */
7347ee54 277GCC_DIAG_IGNORE_DECL(-Wunused-function);
d1decf2b 278static void
c9182d9c 279Perl_croak_memory_wrap(void)
d1decf2b
TC
280{
281 Perl_croak_nocontext("%s",PL_memory_wrap);
282}
7347ee54 283GCC_DIAG_RESTORE_DECL;
d1decf2b 284
a8a2ceaa
KW
285/* ------------------------------- utf8.h ------------------------------- */
286
2fe720e2
KW
287/*
288=head1 Unicode Support
289*/
290
55d09dc8 291PERL_STATIC_INLINE void
c9182d9c 292Perl_append_utf8_from_native_byte(const U8 byte, U8** dest)
55d09dc8
KW
293{
294 /* Takes an input 'byte' (Latin1 or EBCDIC) and appends it to the UTF-8
295 * encoded string at '*dest', updating '*dest' to include it */
296
55d09dc8
KW
297 PERL_ARGS_ASSERT_APPEND_UTF8_FROM_NATIVE_BYTE;
298
6f2d5cbc 299 if (NATIVE_BYTE_IS_INVARIANT(byte))
a09ec51a 300 *((*dest)++) = byte;
55d09dc8 301 else {
a09ec51a
KW
302 *((*dest)++) = UTF8_EIGHT_BIT_HI(byte);
303 *((*dest)++) = UTF8_EIGHT_BIT_LO(byte);
55d09dc8
KW
304 }
305}
306
e123187a 307/*
2fe720e2 308=for apidoc valid_utf8_to_uvchr
09232555
KW
309Like C<L<perlapi/utf8_to_uvchr_buf>>, but should only be called when it is
310known that the next character in the input UTF-8 string C<s> is well-formed
311(I<e.g.>, it passes C<L<perlapi/isUTF8_CHAR>>. Surrogates, non-character code
312points, and non-Unicode code points are allowed.
2fe720e2
KW
313
314=cut
315
316 */
317
318PERL_STATIC_INLINE UV
319Perl_valid_utf8_to_uvchr(const U8 *s, STRLEN *retlen)
320{
c41b2540 321 const UV expectlen = UTF8SKIP(s);
2fe720e2
KW
322 const U8* send = s + expectlen;
323 UV uv = *s;
324
325 PERL_ARGS_ASSERT_VALID_UTF8_TO_UVCHR;
326
327 if (retlen) {
328 *retlen = expectlen;
329 }
330
331 /* An invariant is trivially returned */
332 if (expectlen == 1) {
333 return uv;
334 }
335
336 /* Remove the leading bits that indicate the number of bytes, leaving just
337 * the bits that are part of the value */
338 uv = NATIVE_UTF8_TO_I8(uv) & UTF_START_MASK(expectlen);
339
340 /* Now, loop through the remaining bytes, accumulating each into the
341 * working total as we go. (I khw tried unrolling the loop for up to 4
342 * bytes, but there was no performance improvement) */
343 for (++s; s < send; s++) {
344 uv = UTF8_ACCUMULATE(uv, *s);
345 }
346
347 return UNI_TO_NATIVE(uv);
348
349}
350
1e599354
KW
351/*
352=for apidoc is_utf8_invariant_string
353
82c5d941 354Returns TRUE if the first C<len> bytes of the string C<s> are the same
1e599354 355regardless of the UTF-8 encoding of the string (or UTF-EBCDIC encoding on
82c5d941
KW
356EBCDIC machines); otherwise it returns FALSE. That is, it returns TRUE if they
357are UTF-8 invariant. On ASCII-ish machines, all the ASCII characters and only
358the ASCII characters fit this definition. On EBCDIC machines, the ASCII-range
359characters are invariant, but so also are the C1 controls.
1e599354
KW
360
361If C<len> is 0, it will be calculated using C<strlen(s)>, (which means if you
362use this option, that C<s> can't have embedded C<NUL> characters and has to
363have a terminating C<NUL> byte).
364
9f2abfde
KW
365See also
366C<L</is_utf8_string>>,
367C<L</is_utf8_string_flags>>,
368C<L</is_utf8_string_loc>>,
369C<L</is_utf8_string_loc_flags>>,
370C<L</is_utf8_string_loclen>>,
371C<L</is_utf8_string_loclen_flags>>,
8bc127bf
KW
372C<L</is_utf8_fixed_width_buf_flags>>,
373C<L</is_utf8_fixed_width_buf_loc_flags>>,
374C<L</is_utf8_fixed_width_buf_loclen_flags>>,
9f2abfde
KW
375C<L</is_strict_utf8_string>>,
376C<L</is_strict_utf8_string_loc>>,
377C<L</is_strict_utf8_string_loclen>>,
378C<L</is_c9strict_utf8_string>>,
379C<L</is_c9strict_utf8_string_loc>>,
380and
381C<L</is_c9strict_utf8_string_loclen>>.
1e599354
KW
382
383=cut
0cbf5865
KW
384
385*/
386
387#define is_utf8_invariant_string(s, len) \
388 is_utf8_invariant_string_loc(s, len, NULL)
389
390/*
391=for apidoc is_utf8_invariant_string_loc
392
393Like C<L</is_utf8_invariant_string>> but upon failure, stores the location of
394the first UTF-8 variant character in the C<ep> pointer; if all characters are
395UTF-8 invariant, this function does not change the contents of C<*ep>.
396
397=cut
398
1e599354
KW
399*/
400
401PERL_STATIC_INLINE bool
c9182d9c 402Perl_is_utf8_invariant_string_loc(const U8* const s, STRLEN len, const U8 ** ep)
1e599354 403{
e17544a6 404 const U8* send;
1e599354
KW
405 const U8* x = s;
406
0cbf5865
KW
407 PERL_ARGS_ASSERT_IS_UTF8_INVARIANT_STRING_LOC;
408
e17544a6
KW
409 if (len == 0) {
410 len = strlen((const char *)s);
411 }
412
413 send = s + len;
414
4ab2fd9b 415/* This looks like 0x010101... */
2c5c8af5 416# define PERL_COUNT_MULTIPLIER (~ (UINTMAX_C(0)) / 0xFF)
4ab2fd9b
KW
417
418/* This looks like 0x808080... */
2c5c8af5 419# define PERL_VARIANTS_WORD_MASK (PERL_COUNT_MULTIPLIER * 0x80)
e099ea69 420# define PERL_WORDSIZE sizeof(PERL_UINTMAX_T)
2c5c8af5 421# define PERL_WORD_BOUNDARY_MASK (PERL_WORDSIZE - 1)
e17544a6 422
099e59a4
KW
423/* Evaluates to 0 if 'x' is at a word boundary; otherwise evaluates to 1, by
424 * or'ing together the lowest bits of 'x'. Hopefully the final term gets
425 * optimized out completely on a 32-bit system, and its mask gets optimized out
426 * on a 64-bit system */
2c5c8af5 427# define PERL_IS_SUBWORD_ADDR(x) (1 & ( PTR2nat(x) \
5eabe374
KW
428 | ( PTR2nat(x) >> 1) \
429 | ( ( (PTR2nat(x) \
430 & PERL_WORD_BOUNDARY_MASK) >> 2))))
099e59a4 431
3f515a2e
KW
432#ifndef EBCDIC
433
099e59a4
KW
434 /* Do the word-at-a-time iff there is at least one usable full word. That
435 * means that after advancing to a word boundary, there still is at least a
436 * full word left. The number of bytes needed to advance is 'wordsize -
437 * offset' unless offset is 0. */
438 if ((STRLEN) (send - x) >= PERL_WORDSIZE
439
440 /* This term is wordsize if subword; 0 if not */
441 + PERL_WORDSIZE * PERL_IS_SUBWORD_ADDR(x)
442
443 /* 'offset' */
444 - (PTR2nat(x) & PERL_WORD_BOUNDARY_MASK))
445 {
b40579ff 446
46bb68f6
KW
447 /* Process per-byte until reach word boundary. XXX This loop could be
448 * eliminated if we knew that this platform had fast unaligned reads */
b40579ff 449 while (PTR2nat(x) & PERL_WORD_BOUNDARY_MASK) {
46bb68f6
KW
450 if (! UTF8_IS_INVARIANT(*x)) {
451 if (ep) {
452 *ep = x;
453 }
e17544a6 454
46bb68f6
KW
455 return FALSE;
456 }
457 x++;
e17544a6 458 }
e17544a6 459
099e59a4
KW
460 /* Here, we know we have at least one full word to process. Process
461 * per-word as long as we have at least a full word left */
462 do {
4ab2fd9b 463 if ((* (PERL_UINTMAX_T *) x) & PERL_VARIANTS_WORD_MASK) {
e17544a6 464
46bb68f6
KW
465 /* Found a variant. Just return if caller doesn't want its
466 * exact position */
467 if (! ep) {
468 return FALSE;
469 }
e17544a6 470
2c5c8af5
KW
471# if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678 \
472 || BYTEORDER == 0x4321 || BYTEORDER == 0x87654321
1d2af574 473
73f0a2eb 474 *ep = x + variant_byte_number(* (PERL_UINTMAX_T *) x);
1d2af574
KW
475 assert(*ep >= s && *ep < send);
476
477 return FALSE;
478
2c5c8af5 479# else /* If weird byte order, drop into next loop to do byte-at-a-time
1d2af574
KW
480 checks. */
481
46bb68f6 482 break;
2c5c8af5 483# endif
46bb68f6 484 }
1d2af574 485
46bb68f6 486 x += PERL_WORDSIZE;
1d2af574 487
099e59a4 488 } while (x + PERL_WORDSIZE <= send);
b40579ff 489 }
e17544a6 490
0b08cab0 491#endif /* End of ! EBCDIC */
e17544a6
KW
492
493 /* Process per-byte */
494 while (x < send) {
495 if (! UTF8_IS_INVARIANT(*x)) {
496 if (ep) {
497 *ep = x;
498 }
0cbf5865 499
e17544a6 500 return FALSE;
0cbf5865 501 }
1e599354 502
e17544a6 503 x++;
1e599354
KW
504 }
505
506 return TRUE;
507}
508
23a7ee81
KW
509#ifndef EBCDIC
510
1d2af574 511PERL_STATIC_INLINE unsigned int
73f0a2eb 512Perl_variant_byte_number(PERL_UINTMAX_T word)
1d2af574
KW
513{
514
515 /* This returns the position in a word (0..7) of the first variant byte in
516 * it. This is a helper function. Note that there are no branches */
517
518 assert(word);
519
520 /* Get just the msb bits of each byte */
521 word &= PERL_VARIANTS_WORD_MASK;
522
597ee3f4
KW
523# ifdef USING_MSVC6 /* VC6 has some issues with the normal code, and the
524 easiest thing is to hide that from the callers */
525 {
526 unsigned int i;
527 const U8 * s = (U8 *) &word;
528 dTHX;
529
530 for (i = 0; i < sizeof(word); i++ ) {
531 if (s[i]) {
532 return i;
533 }
534 }
535
536 Perl_croak(aTHX_ "panic: %s: %d: unexpected zero word\n",
537 __FILE__, __LINE__);
538 }
539
540# elif BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
1d2af574
KW
541
542 /* Bytes are stored like
543 * Byte8 ... Byte2 Byte1
544 * 63..56...15...8 7...0
545 *
546 * Isolate the lsb;
547 * https://stackoverflow.com/questions/757059/position-of-least-significant-bit-that-is-set
548 *
549 * The word will look this this, with a rightmost set bit in position 's':
550 * ('x's are don't cares)
551 * s
552 * x..x100..0
553 * x..xx10..0 Right shift (rightmost 0 is shifted off)
554 * x..xx01..1 Subtract 1, turns all the trailing zeros into 1's and
555 * the 1 just to their left into a 0; the remainder is
556 * untouched
4fa92663
KW
557 * 0..0011..1 The xor with the original, x..xx10..0, clears that
558 * remainder, sets the bottom to all 1
1d2af574
KW
559 * 0..0100..0 Add 1 to clear the word except for the bit in 's'
560 *
561 * Another method is to do 'word &= -word'; but it generates a compiler
562 * message on some platforms about taking the negative of an unsigned */
563
564 word >>= 1;
565 word = 1 + (word ^ (word - 1));
566
567# elif BYTEORDER == 0x4321 || BYTEORDER == 0x87654321
568
569 /* Bytes are stored like
570 * Byte1 Byte2 ... Byte8
571 * 63..56 55..47 ... 7...0
572 *
573 * Isolate the msb; http://codeforces.com/blog/entry/10330
574 *
575 * Only the most significant set bit matters. Or'ing word with its right
576 * shift of 1 makes that bit and the next one to its right both 1. Then
577 * right shifting by 2 makes for 4 1-bits in a row. ... We end with the
578 * msb and all to the right being 1. */
579 word |= word >> 1;
580 word |= word >> 2;
581 word |= word >> 4;
582 word |= word >> 8;
583 word |= word >> 16;
584 word |= word >> 32; /* This should get optimized out on 32-bit systems. */
585
586 /* Then subtracting the right shift by 1 clears all but the left-most of
587 * the 1 bits, which is our desired result */
588 word -= (word >> 1);
589
590# else
591# error Unexpected byte order
592# endif
593
7cf2d6c7
KW
594 /* Here 'word' has a single bit set: the msb of the first byte in which it
595 * is set. Calculate that position in the word. We can use this
1d2af574 596 * specialized solution: https://stackoverflow.com/a/32339674/1626653,
67e12c5c
KW
597 * assumes an 8-bit byte. (On a 32-bit machine, the larger numbers should
598 * just get shifted off at compile time) */
599 word = (word >> 7) * ((UINTMAX_C( 7) << 56) | (UINTMAX_C(15) << 48)
600 | (UINTMAX_C(23) << 40) | (UINTMAX_C(31) << 32)
601 | (39 << 24) | (47 << 16)
602 | (55 << 8) | (63 << 0));
1d2af574
KW
603 word >>= PERL_WORDSIZE * 7; /* >> by either 56 or 24 */
604
605 /* Here, word contains the position 7..63 of that bit. Convert to 0..7 */
606 word = ((word + 1) >> 3) - 1;
607
608# if BYTEORDER == 0x4321 || BYTEORDER == 0x87654321
609
610 /* And invert the result */
611 word = CHARBITS - word - 1;
612
613# endif
614
615 return (unsigned int) word;
616}
617
23a7ee81 618#endif
03c1e4ab
KW
619#if defined(PERL_CORE) || defined(PERL_EXT)
620
621/*
622=for apidoc variant_under_utf8_count
623
624This function looks at the sequence of bytes between C<s> and C<e>, which are
625assumed to be encoded in ASCII/Latin1, and returns how many of them would
626change should the string be translated into UTF-8. Due to the nature of UTF-8,
627each of these would occupy two bytes instead of the single one in the input
628string. Thus, this function returns the precise number of bytes the string
629would expand by when translated to UTF-8.
630
631Unlike most of the other functions that have C<utf8> in their name, the input
632to this function is NOT a UTF-8-encoded string. The function name is slightly
633I<odd> to emphasize this.
634
635This function is internal to Perl because khw thinks that any XS code that
636would want this is probably operating too close to the internals. Presenting a
637valid use case could change that.
638
639See also
640C<L<perlapi/is_utf8_invariant_string>>
641and
642C<L<perlapi/is_utf8_invariant_string_loc>>,
643
644=cut
645
646*/
647
648PERL_STATIC_INLINE Size_t
649S_variant_under_utf8_count(const U8* const s, const U8* const e)
650{
651 const U8* x = s;
652 Size_t count = 0;
653
654 PERL_ARGS_ASSERT_VARIANT_UNDER_UTF8_COUNT;
655
656# ifndef EBCDIC
657
5d0379de
KW
658 /* Test if the string is long enough to use word-at-a-time. (Logic is the
659 * same as for is_utf8_invariant_string()) */
03c1e4ab
KW
660 if ((STRLEN) (e - x) >= PERL_WORDSIZE
661 + PERL_WORDSIZE * PERL_IS_SUBWORD_ADDR(x)
662 - (PTR2nat(x) & PERL_WORD_BOUNDARY_MASK))
663 {
664
665 /* Process per-byte until reach word boundary. XXX This loop could be
666 * eliminated if we knew that this platform had fast unaligned reads */
667 while (PTR2nat(x) & PERL_WORD_BOUNDARY_MASK) {
668 count += ! UTF8_IS_INVARIANT(*x++);
669 }
670
671 /* Process per-word as long as we have at least a full word left */
74472cc2
KW
672 do { /* Commit 03c1e4ab1d6ee9062fb3f94b0ba31db6698724b1 contains an
673 explanation of how this works */
e5863284
KW
674 PERL_UINTMAX_T increment
675 = ((((* (PERL_UINTMAX_T *) x) & PERL_VARIANTS_WORD_MASK) >> 7)
03c1e4ab
KW
676 * PERL_COUNT_MULTIPLIER)
677 >> ((PERL_WORDSIZE - 1) * CHARBITS);
e5863284 678 count += (Size_t) increment;
03c1e4ab
KW
679 x += PERL_WORDSIZE;
680 } while (x + PERL_WORDSIZE <= e);
681 }
682
683# endif
684
685 /* Process per-byte */
686 while (x < e) {
687 if (! UTF8_IS_INVARIANT(*x)) {
688 count++;
689 }
690
691 x++;
692 }
693
694 return count;
695}
696
697#endif
698
aff4cafe
KW
699#ifndef PERL_IN_REGEXEC_C /* Keep these around for that file */
700# undef PERL_WORDSIZE
701# undef PERL_COUNT_MULTIPLIER
702# undef PERL_WORD_BOUNDARY_MASK
703# undef PERL_VARIANTS_WORD_MASK
704#endif
03c1e4ab 705
7c93d8f0 706/*
5ff889fb
KW
707=for apidoc is_utf8_string
708
82c5d941
KW
709Returns TRUE if the first C<len> bytes of string C<s> form a valid
710Perl-extended-UTF-8 string; returns FALSE otherwise. If C<len> is 0, it will
711be calculated using C<strlen(s)> (which means if you use this option, that C<s>
712can't have embedded C<NUL> characters and has to have a terminating C<NUL>
713byte). Note that all characters being ASCII constitute 'a valid UTF-8 string'.
714
2717076a
KW
715This function considers Perl's extended UTF-8 to be valid. That means that
716code points above Unicode, surrogates, and non-character code points are
9f2abfde
KW
717considered valid by this function. Use C<L</is_strict_utf8_string>>,
718C<L</is_c9strict_utf8_string>>, or C<L</is_utf8_string_flags>> to restrict what
719code points are considered valid.
5ff889fb 720
9f2abfde
KW
721See also
722C<L</is_utf8_invariant_string>>,
0cbf5865 723C<L</is_utf8_invariant_string_loc>>,
9f2abfde
KW
724C<L</is_utf8_string_loc>>,
725C<L</is_utf8_string_loclen>>,
8bc127bf
KW
726C<L</is_utf8_fixed_width_buf_flags>>,
727C<L</is_utf8_fixed_width_buf_loc_flags>>,
728C<L</is_utf8_fixed_width_buf_loclen_flags>>,
5ff889fb
KW
729
730=cut
731*/
732
dd237e82 733#define is_utf8_string(s, len) is_utf8_string_loclen(s, len, NULL, NULL)
5ff889fb 734
c9cd936b
KW
735#if defined(PERL_CORE) || defined (PERL_EXT)
736
737/*
738=for apidoc is_utf8_non_invariant_string
739
740Returns TRUE if L<perlapi/is_utf8_invariant_string> returns FALSE for the first
741C<len> bytes of the string C<s>, but they are, nonetheless, legal Perl-extended
742UTF-8; otherwise returns FALSE.
743
744A TRUE return means that at least one code point represented by the sequence
745either is a wide character not representable as a single byte, or the
746representation differs depending on whether the sequence is encoded in UTF-8 or
747not.
748
749See also
750C<L<perlapi/is_utf8_invariant_string>>,
751C<L<perlapi/is_utf8_string>>
752
753=cut
754
755This is commonly used to determine if a SV's UTF-8 flag should be turned on.
b3b93dfe
KW
756It generally needn't be if its string is entirely UTF-8 invariant, and it
757shouldn't be if it otherwise contains invalid UTF-8.
c9cd936b
KW
758
759It is an internal function because khw thinks that XS code shouldn't be working
760at this low a level. A valid use case could change that.
761
762*/
763
764PERL_STATIC_INLINE bool
765S_is_utf8_non_invariant_string(const U8* const s, STRLEN len)
766{
767 const U8 * first_variant;
768
769 PERL_ARGS_ASSERT_IS_UTF8_NON_INVARIANT_STRING;
770
771 if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
772 return FALSE;
773 }
774
775 return is_utf8_string(first_variant, len - (first_variant - s));
776}
777
778#endif
779
5ff889fb 780/*
9f2abfde
KW
781=for apidoc is_strict_utf8_string
782
783Returns TRUE if the first C<len> bytes of string C<s> form a valid
784UTF-8-encoded string that is fully interchangeable by any application using
785Unicode rules; otherwise it returns FALSE. If C<len> is 0, it will be
786calculated using C<strlen(s)> (which means if you use this option, that C<s>
787can't have embedded C<NUL> characters and has to have a terminating C<NUL>
788byte). Note that all characters being ASCII constitute 'a valid UTF-8 string'.
789
790This function returns FALSE for strings containing any
791code points above the Unicode max of 0x10FFFF, surrogate code points, or
792non-character code points.
793
794See also
795C<L</is_utf8_invariant_string>>,
0cbf5865 796C<L</is_utf8_invariant_string_loc>>,
9f2abfde
KW
797C<L</is_utf8_string>>,
798C<L</is_utf8_string_flags>>,
799C<L</is_utf8_string_loc>>,
800C<L</is_utf8_string_loc_flags>>,
801C<L</is_utf8_string_loclen>>,
802C<L</is_utf8_string_loclen_flags>>,
8bc127bf
KW
803C<L</is_utf8_fixed_width_buf_flags>>,
804C<L</is_utf8_fixed_width_buf_loc_flags>>,
805C<L</is_utf8_fixed_width_buf_loclen_flags>>,
9f2abfde
KW
806C<L</is_strict_utf8_string_loc>>,
807C<L</is_strict_utf8_string_loclen>>,
808C<L</is_c9strict_utf8_string>>,
809C<L</is_c9strict_utf8_string_loc>>,
810and
811C<L</is_c9strict_utf8_string_loclen>>.
812
813=cut
814*/
815
dd237e82 816#define is_strict_utf8_string(s, len) is_strict_utf8_string_loclen(s, len, NULL, NULL)
9f2abfde
KW
817
818/*
819=for apidoc is_c9strict_utf8_string
820
821Returns TRUE if the first C<len> bytes of string C<s> form a valid
822UTF-8-encoded string that conforms to
823L<Unicode Corrigendum #9|http://www.unicode.org/versions/corrigendum9.html>;
824otherwise it returns FALSE. If C<len> is 0, it will be calculated using
825C<strlen(s)> (which means if you use this option, that C<s> can't have embedded
826C<NUL> characters and has to have a terminating C<NUL> byte). Note that all
827characters being ASCII constitute 'a valid UTF-8 string'.
828
829This function returns FALSE for strings containing any code points above the
830Unicode max of 0x10FFFF or surrogate code points, but accepts non-character
831code points per
832L<Corrigendum #9|http://www.unicode.org/versions/corrigendum9.html>.
833
834See also
835C<L</is_utf8_invariant_string>>,
0cbf5865 836C<L</is_utf8_invariant_string_loc>>,
9f2abfde
KW
837C<L</is_utf8_string>>,
838C<L</is_utf8_string_flags>>,
839C<L</is_utf8_string_loc>>,
840C<L</is_utf8_string_loc_flags>>,
841C<L</is_utf8_string_loclen>>,
842C<L</is_utf8_string_loclen_flags>>,
8bc127bf
KW
843C<L</is_utf8_fixed_width_buf_flags>>,
844C<L</is_utf8_fixed_width_buf_loc_flags>>,
845C<L</is_utf8_fixed_width_buf_loclen_flags>>,
9f2abfde
KW
846C<L</is_strict_utf8_string>>,
847C<L</is_strict_utf8_string_loc>>,
848C<L</is_strict_utf8_string_loclen>>,
849C<L</is_c9strict_utf8_string_loc>>,
850and
851C<L</is_c9strict_utf8_string_loclen>>.
852
853=cut
854*/
855
dd237e82 856#define is_c9strict_utf8_string(s, len) is_c9strict_utf8_string_loclen(s, len, NULL, 0)
9f2abfde
KW
857
858/*
859=for apidoc is_utf8_string_flags
860
861Returns TRUE if the first C<len> bytes of string C<s> form a valid
862UTF-8 string, subject to the restrictions imposed by C<flags>;
863returns FALSE otherwise. If C<len> is 0, it will be calculated
864using C<strlen(s)> (which means if you use this option, that C<s> can't have
865embedded C<NUL> characters and has to have a terminating C<NUL> byte). Note
866that all characters being ASCII constitute 'a valid UTF-8 string'.
867
868If C<flags> is 0, this gives the same results as C<L</is_utf8_string>>; if
869C<flags> is C<UTF8_DISALLOW_ILLEGAL_INTERCHANGE>, this gives the same results
870as C<L</is_strict_utf8_string>>; and if C<flags> is
871C<UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE>, this gives the same results as
872C<L</is_c9strict_utf8_string>>. Otherwise C<flags> may be any
873combination of the C<UTF8_DISALLOW_I<foo>> flags understood by
874C<L</utf8n_to_uvchr>>, with the same meanings.
875
876See also
877C<L</is_utf8_invariant_string>>,
0cbf5865 878C<L</is_utf8_invariant_string_loc>>,
9f2abfde
KW
879C<L</is_utf8_string>>,
880C<L</is_utf8_string_loc>>,
881C<L</is_utf8_string_loc_flags>>,
882C<L</is_utf8_string_loclen>>,
883C<L</is_utf8_string_loclen_flags>>,
8bc127bf
KW
884C<L</is_utf8_fixed_width_buf_flags>>,
885C<L</is_utf8_fixed_width_buf_loc_flags>>,
886C<L</is_utf8_fixed_width_buf_loclen_flags>>,
9f2abfde
KW
887C<L</is_strict_utf8_string>>,
888C<L</is_strict_utf8_string_loc>>,
889C<L</is_strict_utf8_string_loclen>>,
890C<L</is_c9strict_utf8_string>>,
891C<L</is_c9strict_utf8_string_loc>>,
892and
893C<L</is_c9strict_utf8_string_loclen>>.
894
895=cut
896*/
897
898PERL_STATIC_INLINE bool
c9182d9c 899Perl_is_utf8_string_flags(const U8 *s, STRLEN len, const U32 flags)
9f2abfde 900{
33756530 901 const U8 * first_variant;
9f2abfde
KW
902
903 PERL_ARGS_ASSERT_IS_UTF8_STRING_FLAGS;
904 assert(0 == (flags & ~(UTF8_DISALLOW_ILLEGAL_INTERCHANGE
d044b7a7 905 |UTF8_DISALLOW_PERL_EXTENDED)));
9f2abfde 906
f60f61fd
KW
907 if (len == 0) {
908 len = strlen((const char *)s);
909 }
910
9f2abfde
KW
911 if (flags == 0) {
912 return is_utf8_string(s, len);
913 }
914
d044b7a7 915 if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED)
9f2abfde
KW
916 == UTF8_DISALLOW_ILLEGAL_INTERCHANGE)
917 {
918 return is_strict_utf8_string(s, len);
919 }
920
d044b7a7 921 if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED)
9f2abfde
KW
922 == UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE)
923 {
924 return is_c9strict_utf8_string(s, len);
925 }
926
33756530
KW
927 if (! is_utf8_invariant_string_loc(s, len, &first_variant)) {
928 const U8* const send = s + len;
929 const U8* x = first_variant;
930
a0d7f935
KW
931 while (x < send) {
932 STRLEN cur_len = isUTF8_CHAR_flags(x, send, flags);
933 if (UNLIKELY(! cur_len)) {
934 return FALSE;
935 }
936 x += cur_len;
9f2abfde 937 }
33756530 938 }
9f2abfde
KW
939
940 return TRUE;
941}
942
943/*
5ff889fb
KW
944
945=for apidoc is_utf8_string_loc
946
2717076a 947Like C<L</is_utf8_string>> but stores the location of the failure (in the
5ff889fb 948case of "utf8ness failure") or the location C<s>+C<len> (in the case of
82c5d941 949"utf8ness success") in the C<ep> pointer.
5ff889fb 950
2717076a 951See also C<L</is_utf8_string_loclen>>.
5ff889fb 952
3964c812
KW
953=cut
954*/
955
956#define is_utf8_string_loc(s, len, ep) is_utf8_string_loclen(s, len, ep, 0)
957
958/*
959
5ff889fb
KW
960=for apidoc is_utf8_string_loclen
961
2717076a 962Like C<L</is_utf8_string>> but stores the location of the failure (in the
5ff889fb 963case of "utf8ness failure") or the location C<s>+C<len> (in the case of
9f2abfde 964"utf8ness success") in the C<ep> pointer, and the number of UTF-8
82c5d941 965encoded characters in the C<el> pointer.
5ff889fb 966
2717076a 967See also C<L</is_utf8_string_loc>>.
5ff889fb
KW
968
969=cut
970*/
971
56e4cf64 972PERL_STATIC_INLINE bool
33756530 973Perl_is_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
5ff889fb 974{
33756530 975 const U8 * first_variant;
5ff889fb
KW
976
977 PERL_ARGS_ASSERT_IS_UTF8_STRING_LOCLEN;
978
33756530
KW
979 if (len == 0) {
980 len = strlen((const char *) s);
981 }
982
983 if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
984 if (el)
985 *el = len;
986
987 if (ep) {
988 *ep = s + len;
989 }
990
991 return TRUE;
992 }
993
994 {
995 const U8* const send = s + len;
996 const U8* x = first_variant;
997 STRLEN outlen = first_variant - s;
998
a0d7f935
KW
999 while (x < send) {
1000 const STRLEN cur_len = isUTF8_CHAR(x, send);
1001 if (UNLIKELY(! cur_len)) {
1002 break;
1003 }
1004 x += cur_len;
1005 outlen++;
5ff889fb 1006 }
5ff889fb 1007
a0d7f935
KW
1008 if (el)
1009 *el = outlen;
5ff889fb 1010
a0d7f935
KW
1011 if (ep) {
1012 *ep = x;
1013 }
5ff889fb 1014
a0d7f935 1015 return (x == send);
33756530 1016 }
5ff889fb
KW
1017}
1018
1019/*
9f2abfde 1020
44170c9a 1021=for apidoc isUTF8_CHAR
8ed185f9
KW
1022
1023Evaluates to non-zero if the first few bytes of the string starting at C<s> and
1024looking no further than S<C<e - 1>> are well-formed UTF-8, as extended by Perl,
1025that represents some code point; otherwise it evaluates to 0. If non-zero, the
1026value gives how many bytes starting at C<s> comprise the code point's
1027representation. Any bytes remaining before C<e>, but beyond the ones needed to
1028form the first code point in C<s>, are not examined.
1029
13aab5dd 1030The code point can be any that will fit in an IV on this machine, using Perl's
8ed185f9
KW
1031extension to official UTF-8 to represent those higher than the Unicode maximum
1032of 0x10FFFF. That means that this macro is used to efficiently decide if the
1033next few bytes in C<s> is legal UTF-8 for a single character.
1034
1035Use C<L</isSTRICT_UTF8_CHAR>> to restrict the acceptable code points to those
1036defined by Unicode to be fully interchangeable across applications;
1037C<L</isC9_STRICT_UTF8_CHAR>> to use the L<Unicode Corrigendum
1038#9|http://www.unicode.org/versions/corrigendum9.html> definition of allowable
1039code points; and C<L</isUTF8_CHAR_flags>> for a more customized definition.
1040
1041Use C<L</is_utf8_string>>, C<L</is_utf8_string_loc>>, and
1042C<L</is_utf8_string_loclen>> to check entire strings.
1043
13aab5dd
KW
1044Note also that a UTF-8 "invariant" character (i.e. ASCII on non-EBCDIC
1045machines) is a valid UTF-8 character.
8ed185f9
KW
1046
1047=cut
1048
1049This uses an adaptation of the table and algorithm given in
1050http://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which provides comprehensive
1051documentation of the original version. A copyright notice for the original
1052version is given at the beginning of this file. The Perl adapation is
71525f77 1053documented at the definition of PL_extended_utf8_dfa_tab[].
8ed185f9
KW
1054
1055*/
1056
1057PERL_STATIC_INLINE Size_t
c9182d9c 1058Perl_isUTF8_CHAR(const U8 * const s0, const U8 * const e)
8ed185f9
KW
1059{
1060 const U8 * s = s0;
1061 UV state = 0;
1062
1063 PERL_ARGS_ASSERT_ISUTF8_CHAR;
1064
1065 /* This dfa is fast. If it accepts the input, it was for a well-formed,
1066 * code point, which can be returned immediately. Otherwise, it is either
1067 * malformed, or for the start byte FF which the dfa doesn't handle (except
1068 * on 32-bit ASCII platforms where it trivially is an error). Call a
1069 * helper function for the other platforms. */
1070
1071 while (s < e && LIKELY(state != 1)) {
71525f77 1072 state = PL_extended_utf8_dfa_tab[256
8ed185f9 1073 + state
71525f77 1074 + PL_extended_utf8_dfa_tab[*s]];
8ed185f9
KW
1075 if (state != 0) {
1076 s++;
1077 continue;
1078 }
1079
1080 return s - s0 + 1;
1081 }
1082
1083#if defined(UV_IS_QUAD) || defined(EBCDIC)
1084
1085 if (NATIVE_UTF8_TO_I8(*s0) == 0xFF && e - s0 >= UTF8_MAXBYTES) {
1376b35c 1086 return is_utf8_char_helper(s0, e, 0);
8ed185f9
KW
1087 }
1088
1089#endif
1090
1091 return 0;
1092}
1093
1094/*
1095
67049a5f
KW
1096=for apidoc isSTRICT_UTF8_CHAR
1097
1098Evaluates to non-zero if the first few bytes of the string starting at C<s> and
1099looking no further than S<C<e - 1>> are well-formed UTF-8 that represents some
1100Unicode code point completely acceptable for open interchange between all
1101applications; otherwise it evaluates to 0. If non-zero, the value gives how
1102many bytes starting at C<s> comprise the code point's representation. Any
1103bytes remaining before C<e>, but beyond the ones needed to form the first code
1104point in C<s>, are not examined.
1105
1106The largest acceptable code point is the Unicode maximum 0x10FFFF, and must not
1107be a surrogate nor a non-character code point. Thus this excludes any code
1108point from Perl's extended UTF-8.
1109
1110This is used to efficiently decide if the next few bytes in C<s> is
1111legal Unicode-acceptable UTF-8 for a single character.
1112
1113Use C<L</isC9_STRICT_UTF8_CHAR>> to use the L<Unicode Corrigendum
1114#9|http://www.unicode.org/versions/corrigendum9.html> definition of allowable
1115code points; C<L</isUTF8_CHAR>> to check for Perl's extended UTF-8;
1116and C<L</isUTF8_CHAR_flags>> for a more customized definition.
1117
1118Use C<L</is_strict_utf8_string>>, C<L</is_strict_utf8_string_loc>>, and
1119C<L</is_strict_utf8_string_loclen>> to check entire strings.
1120
1121=cut
1122
1123This uses an adaptation of the tables and algorithm given in
1124http://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which provides comprehensive
1125documentation of the original version. A copyright notice for the original
1126version is given at the beginning of this file. The Perl adapation is
1127documented at the definition of strict_extended_utf8_dfa_tab[].
1128
1129*/
1130
1131PERL_STATIC_INLINE Size_t
c9182d9c 1132Perl_isSTRICT_UTF8_CHAR(const U8 * const s0, const U8 * const e)
67049a5f
KW
1133{
1134 const U8 * s = s0;
1135 UV state = 0;
1136
1137 PERL_ARGS_ASSERT_ISSTRICT_UTF8_CHAR;
1138
1139 while (s < e && LIKELY(state != 1)) {
71525f77 1140 state = PL_strict_utf8_dfa_tab[256 + state + PL_strict_utf8_dfa_tab[*s]];
67049a5f
KW
1141
1142 if (state != 0) {
1143 s++;
1144 continue;
1145 }
1146
1147 return s - s0 + 1;
1148 }
1149
1150#ifndef EBCDIC
1151
1152 /* The dfa above drops out for certain Hanguls; handle them specially */
1153 if (is_HANGUL_ED_utf8_safe(s0, e)) {
1154 return 3;
1155 }
1156
1157#endif
1158
1159 return 0;
1160}
1161
1162/*
1163
44170c9a 1164=for apidoc isC9_STRICT_UTF8_CHAR
c5bfbb64
KW
1165
1166Evaluates to non-zero if the first few bytes of the string starting at C<s> and
1167looking no further than S<C<e - 1>> are well-formed UTF-8 that represents some
1168Unicode non-surrogate code point; otherwise it evaluates to 0. If non-zero,
1169the value gives how many bytes starting at C<s> comprise the code point's
1170representation. Any bytes remaining before C<e>, but beyond the ones needed to
1171form the first code point in C<s>, are not examined.
1172
1173The largest acceptable code point is the Unicode maximum 0x10FFFF. This
1174differs from C<L</isSTRICT_UTF8_CHAR>> only in that it accepts non-character
1175code points. This corresponds to
1176L<Unicode Corrigendum #9|http://www.unicode.org/versions/corrigendum9.html>.
1177which said that non-character code points are merely discouraged rather than
1178completely forbidden in open interchange. See
1179L<perlunicode/Noncharacter code points>.
1180
1181Use C<L</isUTF8_CHAR>> to check for Perl's extended UTF-8; and
1182C<L</isUTF8_CHAR_flags>> for a more customized definition.
1183
1184Use C<L</is_c9strict_utf8_string>>, C<L</is_c9strict_utf8_string_loc>>, and
1185C<L</is_c9strict_utf8_string_loclen>> to check entire strings.
1186
1187=cut
1188
1189This uses an adaptation of the tables and algorithm given in
1190http://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which provides comprehensive
1191documentation of the original version. A copyright notice for the original
1192version is given at the beginning of this file. The Perl adapation is
71525f77 1193documented at the definition of PL_c9_utf8_dfa_tab[].
c5bfbb64
KW
1194
1195*/
1196
1197PERL_STATIC_INLINE Size_t
c9182d9c 1198Perl_isC9_STRICT_UTF8_CHAR(const U8 * const s0, const U8 * const e)
c5bfbb64
KW
1199{
1200 const U8 * s = s0;
1201 UV state = 0;
1202
1203 PERL_ARGS_ASSERT_ISC9_STRICT_UTF8_CHAR;
1204
1205 while (s < e && LIKELY(state != 1)) {
71525f77 1206 state = PL_c9_utf8_dfa_tab[256 + state + PL_c9_utf8_dfa_tab[*s]];
c5bfbb64
KW
1207
1208 if (state != 0) {
1209 s++;
1210 continue;
1211 }
1212
1213 return s - s0 + 1;
1214 }
1215
1216 return 0;
1217}
1218
1219/*
1220
9f2abfde
KW
1221=for apidoc is_strict_utf8_string_loc
1222
1223Like C<L</is_strict_utf8_string>> but stores the location of the failure (in the
1224case of "utf8ness failure") or the location C<s>+C<len> (in the case of
1225"utf8ness success") in the C<ep> pointer.
1226
1227See also C<L</is_strict_utf8_string_loclen>>.
1228
1229=cut
1230*/
1231
1232#define is_strict_utf8_string_loc(s, len, ep) \
1233 is_strict_utf8_string_loclen(s, len, ep, 0)
1234
1235/*
1236
1237=for apidoc is_strict_utf8_string_loclen
1238
1239Like C<L</is_strict_utf8_string>> but stores the location of the failure (in the
1240case of "utf8ness failure") or the location C<s>+C<len> (in the case of
1241"utf8ness success") in the C<ep> pointer, and the number of UTF-8
1242encoded characters in the C<el> pointer.
1243
1244See also C<L</is_strict_utf8_string_loc>>.
1245
1246=cut
1247*/
1248
1249PERL_STATIC_INLINE bool
c9182d9c 1250Perl_is_strict_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
9f2abfde 1251{
33756530 1252 const U8 * first_variant;
9f2abfde
KW
1253
1254 PERL_ARGS_ASSERT_IS_STRICT_UTF8_STRING_LOCLEN;
1255
33756530
KW
1256 if (len == 0) {
1257 len = strlen((const char *) s);
1258 }
1259
1260 if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
1261 if (el)
1262 *el = len;
1263
1264 if (ep) {
1265 *ep = s + len;
1266 }
1267
1268 return TRUE;
1269 }
1270
1271 {
1272 const U8* const send = s + len;
1273 const U8* x = first_variant;
1274 STRLEN outlen = first_variant - s;
1275
a0d7f935
KW
1276 while (x < send) {
1277 const STRLEN cur_len = isSTRICT_UTF8_CHAR(x, send);
1278 if (UNLIKELY(! cur_len)) {
1279 break;
1280 }
1281 x += cur_len;
1282 outlen++;
9f2abfde 1283 }
9f2abfde 1284
a0d7f935
KW
1285 if (el)
1286 *el = outlen;
9f2abfde 1287
a0d7f935
KW
1288 if (ep) {
1289 *ep = x;
1290 }
9f2abfde 1291
a0d7f935 1292 return (x == send);
33756530 1293 }
9f2abfde
KW
1294}
1295
1296/*
1297
1298=for apidoc is_c9strict_utf8_string_loc
1299
1300Like C<L</is_c9strict_utf8_string>> but stores the location of the failure (in
1301the case of "utf8ness failure") or the location C<s>+C<len> (in the case of
1302"utf8ness success") in the C<ep> pointer.
1303
1304See also C<L</is_c9strict_utf8_string_loclen>>.
1305
1306=cut
1307*/
1308
1309#define is_c9strict_utf8_string_loc(s, len, ep) \
1310 is_c9strict_utf8_string_loclen(s, len, ep, 0)
1311
1312/*
1313
1314=for apidoc is_c9strict_utf8_string_loclen
1315
1316Like C<L</is_c9strict_utf8_string>> but stores the location of the failure (in
1317the case of "utf8ness failure") or the location C<s>+C<len> (in the case of
1318"utf8ness success") in the C<ep> pointer, and the number of UTF-8 encoded
1319characters in the C<el> pointer.
1320
1321See also C<L</is_c9strict_utf8_string_loc>>.
1322
1323=cut
1324*/
1325
1326PERL_STATIC_INLINE bool
c9182d9c 1327Perl_is_c9strict_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
9f2abfde 1328{
33756530 1329 const U8 * first_variant;
9f2abfde
KW
1330
1331 PERL_ARGS_ASSERT_IS_C9STRICT_UTF8_STRING_LOCLEN;
1332
33756530
KW
1333 if (len == 0) {
1334 len = strlen((const char *) s);
1335 }
1336
1337 if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
1338 if (el)
1339 *el = len;
1340
1341 if (ep) {
1342 *ep = s + len;
1343 }
1344
1345 return TRUE;
1346 }
1347
1348 {
1349 const U8* const send = s + len;
1350 const U8* x = first_variant;
1351 STRLEN outlen = first_variant - s;
1352
a0d7f935
KW
1353 while (x < send) {
1354 const STRLEN cur_len = isC9_STRICT_UTF8_CHAR(x, send);
1355 if (UNLIKELY(! cur_len)) {
1356 break;
1357 }
1358 x += cur_len;
1359 outlen++;
9f2abfde 1360 }
9f2abfde 1361
a0d7f935
KW
1362 if (el)
1363 *el = outlen;
9f2abfde 1364
a0d7f935
KW
1365 if (ep) {
1366 *ep = x;
1367 }
9f2abfde 1368
a0d7f935 1369 return (x == send);
33756530 1370 }
9f2abfde
KW
1371}
1372
1373/*
1374
1375=for apidoc is_utf8_string_loc_flags
1376
1377Like C<L</is_utf8_string_flags>> but stores the location of the failure (in the
1378case of "utf8ness failure") or the location C<s>+C<len> (in the case of
1379"utf8ness success") in the C<ep> pointer.
1380
1381See also C<L</is_utf8_string_loclen_flags>>.
1382
1383=cut
1384*/
1385
1386#define is_utf8_string_loc_flags(s, len, ep, flags) \
1387 is_utf8_string_loclen_flags(s, len, ep, 0, flags)
1388
1389
1390/* The above 3 actual functions could have been moved into the more general one
1391 * just below, and made #defines that call it with the right 'flags'. They are
1392 * currently kept separate to increase their chances of getting inlined */
1393
1394/*
1395
1396=for apidoc is_utf8_string_loclen_flags
1397
1398Like C<L</is_utf8_string_flags>> but stores the location of the failure (in the
1399case of "utf8ness failure") or the location C<s>+C<len> (in the case of
1400"utf8ness success") in the C<ep> pointer, and the number of UTF-8
1401encoded characters in the C<el> pointer.
1402
1403See also C<L</is_utf8_string_loc_flags>>.
1404
1405=cut
1406*/
1407
1408PERL_STATIC_INLINE bool
c9182d9c 1409Perl_is_utf8_string_loclen_flags(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el, const U32 flags)
9f2abfde 1410{
33756530 1411 const U8 * first_variant;
9f2abfde
KW
1412
1413 PERL_ARGS_ASSERT_IS_UTF8_STRING_LOCLEN_FLAGS;
1414 assert(0 == (flags & ~(UTF8_DISALLOW_ILLEGAL_INTERCHANGE
d044b7a7 1415 |UTF8_DISALLOW_PERL_EXTENDED)));
9f2abfde 1416
f60f61fd 1417 if (len == 0) {
a0d7f935 1418 len = strlen((const char *) s);
f60f61fd
KW
1419 }
1420
9f2abfde
KW
1421 if (flags == 0) {
1422 return is_utf8_string_loclen(s, len, ep, el);
1423 }
1424
d044b7a7 1425 if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED)
9f2abfde
KW
1426 == UTF8_DISALLOW_ILLEGAL_INTERCHANGE)
1427 {
1428 return is_strict_utf8_string_loclen(s, len, ep, el);
1429 }
1430
d044b7a7 1431 if ((flags & ~UTF8_DISALLOW_PERL_EXTENDED)
9f2abfde
KW
1432 == UTF8_DISALLOW_ILLEGAL_C9_INTERCHANGE)
1433 {
1434 return is_c9strict_utf8_string_loclen(s, len, ep, el);
1435 }
1436
33756530
KW
1437 if (is_utf8_invariant_string_loc(s, len, &first_variant)) {
1438 if (el)
1439 *el = len;
1440
1441 if (ep) {
1442 *ep = s + len;
1443 }
1444
1445 return TRUE;
1446 }
1447
1448 {
1449 const U8* send = s + len;
1450 const U8* x = first_variant;
1451 STRLEN outlen = first_variant - s;
1452
a0d7f935
KW
1453 while (x < send) {
1454 const STRLEN cur_len = isUTF8_CHAR_flags(x, send, flags);
1455 if (UNLIKELY(! cur_len)) {
1456 break;
1457 }
1458 x += cur_len;
1459 outlen++;
9f2abfde 1460 }
9f2abfde 1461
a0d7f935
KW
1462 if (el)
1463 *el = outlen;
9f2abfde 1464
a0d7f935
KW
1465 if (ep) {
1466 *ep = x;
1467 }
9f2abfde 1468
a0d7f935 1469 return (x == send);
33756530 1470 }
9f2abfde
KW
1471}
1472
1473/*
7c93d8f0
KW
1474=for apidoc utf8_distance
1475
1476Returns the number of UTF-8 characters between the UTF-8 pointers C<a>
1477and C<b>.
1478
1479WARNING: use only if you *know* that the pointers point inside the
1480same UTF-8 buffer.
1481
1482=cut
1483*/
1484
1485PERL_STATIC_INLINE IV
1486Perl_utf8_distance(pTHX_ const U8 *a, const U8 *b)
1487{
1488 PERL_ARGS_ASSERT_UTF8_DISTANCE;
1489
1490 return (a < b) ? -1 * (IV) utf8_length(a, b) : (IV) utf8_length(b, a);
1491}
1492
1493/*
1494=for apidoc utf8_hop
1495
1496Return the UTF-8 pointer C<s> displaced by C<off> characters, either
1497forward or backward.
1498
1499WARNING: do not use the following unless you *know* C<off> is within
1500the UTF-8 data pointed to by C<s> *and* that on entry C<s> is aligned
1501on the first byte of character or just after the last byte of a character.
1502
1503=cut
1504*/
1505
1506PERL_STATIC_INLINE U8 *
1507Perl_utf8_hop(const U8 *s, SSize_t off)
1508{
1509 PERL_ARGS_ASSERT_UTF8_HOP;
1510
1511 /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
1512 * the bitops (especially ~) can create illegal UTF-8.
1513 * In other words: in Perl UTF-8 is not just for Unicode. */
1514
1515 if (off >= 0) {
1516 while (off--)
1517 s += UTF8SKIP(s);
1518 }
1519 else {
1520 while (off++) {
1521 s--;
1522 while (UTF8_IS_CONTINUATION(*s))
1523 s--;
1524 }
1525 }
e099ea69 1526 GCC_DIAG_IGNORE(-Wcast-qual)
7c93d8f0 1527 return (U8 *)s;
e099ea69 1528 GCC_DIAG_RESTORE
7c93d8f0
KW
1529}
1530
4dab108f 1531/*
65df57a8
TC
1532=for apidoc utf8_hop_forward
1533
1534Return the UTF-8 pointer C<s> displaced by up to C<off> characters,
1535forward.
1536
1537C<off> must be non-negative.
1538
1539C<s> must be before or equal to C<end>.
1540
1541When moving forward it will not move beyond C<end>.
1542
1543Will not exceed this limit even if the string is not valid "UTF-8".
1544
1545=cut
1546*/
1547
1548PERL_STATIC_INLINE U8 *
1549Perl_utf8_hop_forward(const U8 *s, SSize_t off, const U8 *end)
1550{
1551 PERL_ARGS_ASSERT_UTF8_HOP_FORWARD;
1552
1553 /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
1554 * the bitops (especially ~) can create illegal UTF-8.
1555 * In other words: in Perl UTF-8 is not just for Unicode. */
1556
1557 assert(s <= end);
1558 assert(off >= 0);
1559
1560 while (off--) {
1561 STRLEN skip = UTF8SKIP(s);
de979548 1562 if ((STRLEN)(end - s) <= skip) {
e099ea69 1563 GCC_DIAG_IGNORE(-Wcast-qual)
65df57a8 1564 return (U8 *)end;
e099ea69 1565 GCC_DIAG_RESTORE
de979548 1566 }
65df57a8
TC
1567 s += skip;
1568 }
1569
e099ea69 1570 GCC_DIAG_IGNORE(-Wcast-qual)
65df57a8 1571 return (U8 *)s;
e099ea69 1572 GCC_DIAG_RESTORE
65df57a8
TC
1573}
1574
1575/*
1576=for apidoc utf8_hop_back
1577
1578Return the UTF-8 pointer C<s> displaced by up to C<off> characters,
1579backward.
1580
1581C<off> must be non-positive.
1582
1583C<s> must be after or equal to C<start>.
1584
1585When moving backward it will not move before C<start>.
1586
1587Will not exceed this limit even if the string is not valid "UTF-8".
1588
1589=cut
1590*/
1591
1592PERL_STATIC_INLINE U8 *
1593Perl_utf8_hop_back(const U8 *s, SSize_t off, const U8 *start)
1594{
1595 PERL_ARGS_ASSERT_UTF8_HOP_BACK;
1596
1597 /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
1598 * the bitops (especially ~) can create illegal UTF-8.
1599 * In other words: in Perl UTF-8 is not just for Unicode. */
1600
1601 assert(start <= s);
1602 assert(off <= 0);
1603
1604 while (off++ && s > start) {
e7185695 1605 do {
65df57a8 1606 s--;
e7185695 1607 } while (UTF8_IS_CONTINUATION(*s) && s > start);
65df57a8
TC
1608 }
1609
e099ea69 1610 GCC_DIAG_IGNORE(-Wcast-qual)
65df57a8 1611 return (U8 *)s;
e099ea69 1612 GCC_DIAG_RESTORE
65df57a8
TC
1613}
1614
1615/*
1616=for apidoc utf8_hop_safe
1617
1618Return the UTF-8 pointer C<s> displaced by up to C<off> characters,
1619either forward or backward.
1620
1621When moving backward it will not move before C<start>.
1622
1623When moving forward it will not move beyond C<end>.
1624
1625Will not exceed those limits even if the string is not valid "UTF-8".
1626
1627=cut
1628*/
1629
1630PERL_STATIC_INLINE U8 *
1631Perl_utf8_hop_safe(const U8 *s, SSize_t off, const U8 *start, const U8 *end)
1632{
1633 PERL_ARGS_ASSERT_UTF8_HOP_SAFE;
1634
1635 /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
1636 * the bitops (especially ~) can create illegal UTF-8.
1637 * In other words: in Perl UTF-8 is not just for Unicode. */
1638
1639 assert(start <= s && s <= end);
1640
1641 if (off >= 0) {
1642 return utf8_hop_forward(s, off, end);
1643 }
1644 else {
1645 return utf8_hop_back(s, off, start);
1646 }
1647}
1648
1649/*
4dab108f
KW
1650
1651=for apidoc is_utf8_valid_partial_char
1652
6cbb9248
KW
1653Returns 0 if the sequence of bytes starting at C<s> and looking no further than
1654S<C<e - 1>> is the UTF-8 encoding, as extended by Perl, for one or more code
1655points. Otherwise, it returns 1 if there exists at least one non-empty
1656sequence of bytes that when appended to sequence C<s>, starting at position
1657C<e> causes the entire sequence to be the well-formed UTF-8 of some code point;
1658otherwise returns 0.
1659
1660In other words this returns TRUE if C<s> points to a partial UTF-8-encoded code
1661point.
1662
1663This is useful when a fixed-length buffer is being tested for being well-formed
1664UTF-8, but the final few bytes in it don't comprise a full character; that is,
1665it is split somewhere in the middle of the final code point's UTF-8
1666representation. (Presumably when the buffer is refreshed with the next chunk
1667of data, the new first bytes will complete the partial code point.) This
1668function is used to verify that the final bytes in the current buffer are in
1669fact the legal beginning of some code point, so that if they aren't, the
1670failure can be signalled without having to wait for the next read.
4dab108f
KW
1671
1672=cut
1673*/
2717076a
KW
1674#define is_utf8_valid_partial_char(s, e) \
1675 is_utf8_valid_partial_char_flags(s, e, 0)
f1c999a7
KW
1676
1677/*
1678
1679=for apidoc is_utf8_valid_partial_char_flags
1680
1681Like C<L</is_utf8_valid_partial_char>>, it returns a boolean giving whether
1682or not the input is a valid UTF-8 encoded partial character, but it takes an
1683extra parameter, C<flags>, which can further restrict which code points are
1684considered valid.
1685
1686If C<flags> is 0, this behaves identically to
1687C<L</is_utf8_valid_partial_char>>. Otherwise C<flags> can be any combination
1688of the C<UTF8_DISALLOW_I<foo>> flags accepted by C<L</utf8n_to_uvchr>>. If
1689there is any sequence of bytes that can complete the input partial character in
1690such a way that a non-prohibited character is formed, the function returns
2717076a
KW
1691TRUE; otherwise FALSE. Non character code points cannot be determined based on
1692partial character input. But many of the other possible excluded types can be
f1c999a7
KW
1693determined from just the first one or two bytes.
1694
1695=cut
1696 */
1697
56e4cf64 1698PERL_STATIC_INLINE bool
c9182d9c 1699Perl_is_utf8_valid_partial_char_flags(const U8 * const s, const U8 * const e, const U32 flags)
4dab108f 1700{
f1c999a7 1701 PERL_ARGS_ASSERT_IS_UTF8_VALID_PARTIAL_CHAR_FLAGS;
4dab108f 1702
f1c999a7 1703 assert(0 == (flags & ~(UTF8_DISALLOW_ILLEGAL_INTERCHANGE
d044b7a7 1704 |UTF8_DISALLOW_PERL_EXTENDED)));
4dab108f 1705
8875bd48 1706 if (s >= e || s + UTF8SKIP(s) <= e) {
4dab108f
KW
1707 return FALSE;
1708 }
1709
1376b35c 1710 return cBOOL(is_utf8_char_helper(s, e, flags));
4dab108f
KW
1711}
1712
8bc127bf
KW
1713/*
1714
1715=for apidoc is_utf8_fixed_width_buf_flags
1716
1717Returns TRUE if the fixed-width buffer starting at C<s> with length C<len>
1718is entirely valid UTF-8, subject to the restrictions given by C<flags>;
1719otherwise it returns FALSE.
1720
1721If C<flags> is 0, any well-formed UTF-8, as extended by Perl, is accepted
1722without restriction. If the final few bytes of the buffer do not form a
1723complete code point, this will return TRUE anyway, provided that
1724C<L</is_utf8_valid_partial_char_flags>> returns TRUE for them.
1725
1726If C<flags> in non-zero, it can be any combination of the
1727C<UTF8_DISALLOW_I<foo>> flags accepted by C<L</utf8n_to_uvchr>>, and with the
1728same meanings.
1729
1730This function differs from C<L</is_utf8_string_flags>> only in that the latter
1731returns FALSE if the final few bytes of the string don't form a complete code
1732point.
1733
1734=cut
1735 */
1736#define is_utf8_fixed_width_buf_flags(s, len, flags) \
1737 is_utf8_fixed_width_buf_loclen_flags(s, len, 0, 0, flags)
1738
1739/*
1740
1741=for apidoc is_utf8_fixed_width_buf_loc_flags
1742
1743Like C<L</is_utf8_fixed_width_buf_flags>> but stores the location of the
1744failure in the C<ep> pointer. If the function returns TRUE, C<*ep> will point
1745to the beginning of any partial character at the end of the buffer; if there is
1746no partial character C<*ep> will contain C<s>+C<len>.
1747
1748See also C<L</is_utf8_fixed_width_buf_loclen_flags>>.
1749
1750=cut
1751*/
1752
1753#define is_utf8_fixed_width_buf_loc_flags(s, len, loc, flags) \
1754 is_utf8_fixed_width_buf_loclen_flags(s, len, loc, 0, flags)
1755
1756/*
1757
1758=for apidoc is_utf8_fixed_width_buf_loclen_flags
1759
1760Like C<L</is_utf8_fixed_width_buf_loc_flags>> but stores the number of
1761complete, valid characters found in the C<el> pointer.
1762
1763=cut
1764*/
1765
1766PERL_STATIC_INLINE bool
c9182d9c 1767Perl_is_utf8_fixed_width_buf_loclen_flags(const U8 * const s,
33756530 1768 STRLEN len,
8bc127bf
KW
1769 const U8 **ep,
1770 STRLEN *el,
1771 const U32 flags)
1772{
1773 const U8 * maybe_partial;
1774
1775 PERL_ARGS_ASSERT_IS_UTF8_FIXED_WIDTH_BUF_LOCLEN_FLAGS;
1776
1777 if (! ep) {
1778 ep = &maybe_partial;
1779 }
1780
1781 /* If it's entirely valid, return that; otherwise see if the only error is
1782 * that the final few bytes are for a partial character */
1783 return is_utf8_string_loclen_flags(s, len, ep, el, flags)
1784 || is_utf8_valid_partial_char_flags(*ep, s + len, flags);
1785}
1786
e6a4ffc3 1787PERL_STATIC_INLINE UV
c9182d9c 1788Perl_utf8n_to_uvchr_msgs(const U8 *s,
e6a4ffc3
KW
1789 STRLEN curlen,
1790 STRLEN *retlen,
1791 const U32 flags,
1792 U32 * errors,
1793 AV ** msgs)
1794{
1795 /* This is the inlined portion of utf8n_to_uvchr_msgs. It handles the
1796 * simple cases, and, if necessary calls a helper function to deal with the
1797 * more complex ones. Almost all well-formed non-problematic code points
1798 * are considered simple, so that it's unlikely that the helper function
1799 * will need to be called.
1800 *
1801 * This is an adaptation of the tables and algorithm given in
1802 * http://bjoern.hoehrmann.de/utf-8/decoder/dfa/, which provides
1803 * comprehensive documentation of the original version. A copyright notice
1804 * for the original version is given at the beginning of this file. The
71525f77 1805 * Perl adapation is documented at the definition of PL_strict_utf8_dfa_tab[].
e6a4ffc3
KW
1806 */
1807
1808 const U8 * const s0 = s;
1809 const U8 * send = s0 + curlen;
f73cfe7d 1810 UV uv = 0; /* The 0 silences some stupid compilers */
e6a4ffc3
KW
1811 UV state = 0;
1812
1813 PERL_ARGS_ASSERT_UTF8N_TO_UVCHR_MSGS;
1814
1815 /* This dfa is fast. If it accepts the input, it was for a well-formed,
1816 * non-problematic code point, which can be returned immediately.
1817 * Otherwise we call a helper function to figure out the more complicated
1818 * cases. */
1819
1820 while (s < send && LIKELY(state != 1)) {
71525f77 1821 UV type = PL_strict_utf8_dfa_tab[*s];
e6a4ffc3
KW
1822
1823 uv = (state == 0)
1824 ? ((0xff >> type) & NATIVE_UTF8_TO_I8(*s))
1825 : UTF8_ACCUMULATE(uv, *s);
71525f77 1826 state = PL_strict_utf8_dfa_tab[256 + state + type];
e6a4ffc3
KW
1827
1828 if (state != 0) {
1829 s++;
1830 continue;
1831 }
1832
1833 if (retlen) {
1834 *retlen = s - s0 + 1;
1835 }
1836 if (errors) {
1837 *errors = 0;
1838 }
1839 if (msgs) {
1840 *msgs = NULL;
1841 }
1842
cfebc7aa 1843 return UNI_TO_NATIVE(uv);
e6a4ffc3
KW
1844 }
1845
1846 /* Here is potentially problematic. Use the full mechanism */
1847 return _utf8n_to_uvchr_msgs_helper(s0, curlen, retlen, flags, errors, msgs);
1848}
1849
82651abe 1850PERL_STATIC_INLINE UV
9a9a6c98 1851Perl_utf8_to_uvchr_buf_helper(pTHX_ const U8 *s, const U8 *send, STRLEN *retlen)
82651abe 1852{
9a9a6c98 1853 PERL_ARGS_ASSERT_UTF8_TO_UVCHR_BUF_HELPER;
82651abe
KW
1854
1855 assert(s < send);
1856
1857 if (! ckWARN_d(WARN_UTF8)) {
3eaa7592
KW
1858
1859 /* EMPTY is not really allowed, and asserts on debugging builds. But
1860 * on non-debugging we have to deal with it, and this causes it to
1861 * return the REPLACEMENT CHARACTER, as the documentation indicates */
82651abe 1862 return utf8n_to_uvchr(s, send - s, retlen,
3eaa7592 1863 (UTF8_ALLOW_ANY | UTF8_ALLOW_EMPTY));
82651abe
KW
1864 }
1865 else {
1866 UV ret = utf8n_to_uvchr(s, send - s, retlen, 0);
1867 if (retlen && ret == 0 && *s != '\0') {
1868 *retlen = (STRLEN) -1;
1869 }
1870
1871 return ret;
1872 }
1873}
1874
c8028aa6
TC
1875/* ------------------------------- perl.h ----------------------------- */
1876
1877/*
dcccc8ff
KW
1878=head1 Miscellaneous Functions
1879
44170c9a 1880=for apidoc is_safe_syscall
c8028aa6 1881
6602b933 1882Test that the given C<pv> doesn't contain any internal C<NUL> characters.
796b6530 1883If it does, set C<errno> to C<ENOENT>, optionally warn, and return FALSE.
c8028aa6
TC
1884
1885Return TRUE if the name is safe.
1886
796b6530 1887Used by the C<IS_SAFE_SYSCALL()> macro.
c8028aa6
TC
1888
1889=cut
1890*/
1891
1892PERL_STATIC_INLINE bool
c9182d9c 1893Perl_is_safe_syscall(pTHX_ const char *pv, STRLEN len, const char *what, const char *op_name) {
c8028aa6
TC
1894 /* While the Windows CE API provides only UCS-16 (or UTF-16) APIs
1895 * perl itself uses xce*() functions which accept 8-bit strings.
1896 */
1897
1898 PERL_ARGS_ASSERT_IS_SAFE_SYSCALL;
1899
6c4650b3 1900 if (len > 1) {
c8028aa6 1901 char *null_at;
41188aa0 1902 if (UNLIKELY((null_at = (char *)memchr(pv, 0, len-1)) != NULL)) {
c8028aa6 1903 SETERRNO(ENOENT, LIB_INVARG);
1d505182 1904 Perl_ck_warner(aTHX_ packWARN(WARN_SYSCALLS),
c8028aa6 1905 "Invalid \\0 character in %s for %s: %s\\0%s",
41188aa0 1906 what, op_name, pv, null_at+1);
c8028aa6
TC
1907 return FALSE;
1908 }
1909 }
1910
1911 return TRUE;
1912}
1913
1914/*
7cb3f959
TC
1915
1916Return true if the supplied filename has a newline character
fa6c7d00 1917immediately before the first (hopefully only) NUL.
7cb3f959
TC
1918
1919My original look at this incorrectly used the len from SvPV(), but
1920that's incorrect, since we allow for a NUL in pv[len-1].
1921
1922So instead, strlen() and work from there.
1923
1924This allow for the user reading a filename, forgetting to chomp it,
1925then calling:
1926
1927 open my $foo, "$file\0";
1928
1929*/
1930
1931#ifdef PERL_CORE
1932
1933PERL_STATIC_INLINE bool
1934S_should_warn_nl(const char *pv) {
1935 STRLEN len;
1936
1937 PERL_ARGS_ASSERT_SHOULD_WARN_NL;
1938
1939 len = strlen(pv);
1940
1941 return len > 0 && pv[len-1] == '\n';
1942}
1943
1944#endif
1945
3a019afd
KW
1946#if defined(PERL_IN_PP_C) || defined(PERL_IN_PP_HOT_C)
1947
1948PERL_STATIC_INLINE bool
1949S_lossless_NV_to_IV(const NV nv, IV *ivp)
1950{
1951 /* This function determines if the input NV 'nv' may be converted without
1952 * loss of data to an IV. If not, it returns FALSE taking no other action.
1953 * But if it is possible, it does the conversion, returning TRUE, and
1954 * storing the converted result in '*ivp' */
1955
1956 PERL_ARGS_ASSERT_LOSSLESS_NV_TO_IV;
1957
1958# if defined(Perl_isnan)
1959
1960 if (UNLIKELY(Perl_isnan(nv))) {
1961 return FALSE;
1962 }
1963
1964# endif
1965
1966 if (UNLIKELY(nv < IV_MIN) || UNLIKELY(nv > IV_MAX)) {
1967 return FALSE;
1968 }
1969
1970 if ((IV) nv != nv) {
1971 return FALSE;
1972 }
1973
1974 *ivp = (IV) nv;
1975 return TRUE;
1976}
1977
1978#endif
1979
81d52ecd
JH
1980/* ------------------ pp.c, regcomp.c, toke.c, universal.c ------------ */
1981
1982#define MAX_CHARSET_NAME_LENGTH 2
1983
1984PERL_STATIC_INLINE const char *
1985get_regex_charset_name(const U32 flags, STRLEN* const lenp)
1986{
1987 /* Returns a string that corresponds to the name of the regex character set
1988 * given by 'flags', and *lenp is set the length of that string, which
1989 * cannot exceed MAX_CHARSET_NAME_LENGTH characters */
1990
1991 *lenp = 1;
1992 switch (get_regex_charset(flags)) {
1993 case REGEX_DEPENDS_CHARSET: return DEPENDS_PAT_MODS;
1994 case REGEX_LOCALE_CHARSET: return LOCALE_PAT_MODS;
1995 case REGEX_UNICODE_CHARSET: return UNICODE_PAT_MODS;
1996 case REGEX_ASCII_RESTRICTED_CHARSET: return ASCII_RESTRICT_PAT_MODS;
1997 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
1998 *lenp = 2;
1999 return ASCII_MORE_RESTRICT_PAT_MODS;
2000 }
2001 /* The NOT_REACHED; hides an assert() which has a rather complex
2002 * definition in perl.h. */
2003 NOT_REACHED; /* NOTREACHED */
2004 return "?"; /* Unknown */
2005}
2006
7cb3f959 2007/*
ed382232
TC
2008
2009Return false if any get magic is on the SV other than taint magic.
2010
2011*/
2012
2013PERL_STATIC_INLINE bool
c9182d9c 2014Perl_sv_only_taint_gmagic(SV *sv) {
ed382232
TC
2015 MAGIC *mg = SvMAGIC(sv);
2016
2017 PERL_ARGS_ASSERT_SV_ONLY_TAINT_GMAGIC;
2018
2019 while (mg) {
2020 if (mg->mg_type != PERL_MAGIC_taint
2021 && !(mg->mg_flags & MGf_GSKIP)
2022 && mg->mg_virtual->svt_get) {
2023 return FALSE;
2024 }
2025 mg = mg->mg_moremagic;
2026 }
2027
2028 return TRUE;
2029}
2030
ed8ff0f3
DM
2031/* ------------------ cop.h ------------------------------------------- */
2032
2033
2034/* Enter a block. Push a new base context and return its address. */
2035
2036PERL_STATIC_INLINE PERL_CONTEXT *
c9182d9c 2037Perl_cx_pushblock(pTHX_ U8 type, U8 gimme, SV** sp, I32 saveix)
ed8ff0f3
DM
2038{
2039 PERL_CONTEXT * cx;
2040
2041 PERL_ARGS_ASSERT_CX_PUSHBLOCK;
2042
2043 CXINC;
2044 cx = CX_CUR();
2045 cx->cx_type = type;
2046 cx->blk_gimme = gimme;
2047 cx->blk_oldsaveix = saveix;
4caf7d8c 2048 cx->blk_oldsp = (I32)(sp - PL_stack_base);
ed8ff0f3 2049 cx->blk_oldcop = PL_curcop;
4caf7d8c 2050 cx->blk_oldmarksp = (I32)(PL_markstack_ptr - PL_markstack);
ed8ff0f3
DM
2051 cx->blk_oldscopesp = PL_scopestack_ix;
2052 cx->blk_oldpm = PL_curpm;
ce8bb8d8 2053 cx->blk_old_tmpsfloor = PL_tmps_floor;
ed8ff0f3
DM
2054
2055 PL_tmps_floor = PL_tmps_ix;
2056 CX_DEBUG(cx, "PUSH");
2057 return cx;
2058}
2059
2060
2061/* Exit a block (RETURN and LAST). */
2062
2063PERL_STATIC_INLINE void
c9182d9c 2064Perl_cx_popblock(pTHX_ PERL_CONTEXT *cx)
ed8ff0f3
DM
2065{
2066 PERL_ARGS_ASSERT_CX_POPBLOCK;
2067
2068 CX_DEBUG(cx, "POP");
2069 /* these 3 are common to cx_popblock and cx_topblock */
2070 PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp;
2071 PL_scopestack_ix = cx->blk_oldscopesp;
2072 PL_curpm = cx->blk_oldpm;
2073
2074 /* LEAVE_SCOPE() should have made this true. /(?{})/ cheats
2075 * and leaves a CX entry lying around for repeated use, so
2076 * skip for multicall */ \
2077 assert( (CxTYPE(cx) == CXt_SUB && CxMULTICALL(cx))
2078 || PL_savestack_ix == cx->blk_oldsaveix);
2079 PL_curcop = cx->blk_oldcop;
ce8bb8d8 2080 PL_tmps_floor = cx->blk_old_tmpsfloor;
ed8ff0f3
DM
2081}
2082
2083/* Continue a block elsewhere (e.g. NEXT, REDO, GOTO).
2084 * Whereas cx_popblock() restores the state to the point just before
2085 * cx_pushblock() was called, cx_topblock() restores it to the point just
2086 * *after* cx_pushblock() was called. */
2087
2088PERL_STATIC_INLINE void
c9182d9c 2089Perl_cx_topblock(pTHX_ PERL_CONTEXT *cx)
ed8ff0f3
DM
2090{
2091 PERL_ARGS_ASSERT_CX_TOPBLOCK;
2092
2093 CX_DEBUG(cx, "TOP");
2094 /* these 3 are common to cx_popblock and cx_topblock */
2095 PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp;
2096 PL_scopestack_ix = cx->blk_oldscopesp;
2097 PL_curpm = cx->blk_oldpm;
2098
2099 PL_stack_sp = PL_stack_base + cx->blk_oldsp;
2100}
2101
2102
a73d8813 2103PERL_STATIC_INLINE void
c9182d9c 2104Perl_cx_pushsub(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, bool hasargs)
a73d8813
DM
2105{
2106 U8 phlags = CX_PUSHSUB_GET_LVALUE_MASK(Perl_was_lvalue_sub);
2107
2108 PERL_ARGS_ASSERT_CX_PUSHSUB;
2109
3f6bd23a 2110 PERL_DTRACE_PROBE_ENTRY(cv);
a73d8813
DM
2111 cx->blk_sub.cv = cv;
2112 cx->blk_sub.olddepth = CvDEPTH(cv);
2113 cx->blk_sub.prevcomppad = PL_comppad;
2114 cx->cx_type |= (hasargs) ? CXp_HASARGS : 0;
2115 cx->blk_sub.retop = retop;
2116 SvREFCNT_inc_simple_void_NN(cv);
2117 cx->blk_u16 = PL_op->op_private & (phlags|OPpDEREF);
2118}
2119
2120
2121/* subsets of cx_popsub() */
2122
2123PERL_STATIC_INLINE void
c9182d9c 2124Perl_cx_popsub_common(pTHX_ PERL_CONTEXT *cx)
a73d8813
DM
2125{
2126 CV *cv;
2127
2128 PERL_ARGS_ASSERT_CX_POPSUB_COMMON;
2129 assert(CxTYPE(cx) == CXt_SUB);
2130
2131 PL_comppad = cx->blk_sub.prevcomppad;
2132 PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
2133 cv = cx->blk_sub.cv;
2134 CvDEPTH(cv) = cx->blk_sub.olddepth;
2135 cx->blk_sub.cv = NULL;
2136 SvREFCNT_dec(cv);
2137}
2138
2139
2140/* handle the @_ part of leaving a sub */
2141
2142PERL_STATIC_INLINE void
c9182d9c 2143Perl_cx_popsub_args(pTHX_ PERL_CONTEXT *cx)
a73d8813
DM
2144{
2145 AV *av;
2146
2147 PERL_ARGS_ASSERT_CX_POPSUB_ARGS;
2148 assert(CxTYPE(cx) == CXt_SUB);
2149 assert(AvARRAY(MUTABLE_AV(
2150 PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
2151 CvDEPTH(cx->blk_sub.cv)])) == PL_curpad);
2152
2153 CX_POP_SAVEARRAY(cx);
2154 av = MUTABLE_AV(PAD_SVl(0));
2155 if (UNLIKELY(AvREAL(av)))
2156 /* abandon @_ if it got reified */
2157 clear_defarray(av, 0);
2158 else {
2159 CLEAR_ARGARRAY(av);
2160 }
2161}
2162
2163
2164PERL_STATIC_INLINE void
c9182d9c 2165Perl_cx_popsub(pTHX_ PERL_CONTEXT *cx)
a73d8813
DM
2166{
2167 PERL_ARGS_ASSERT_CX_POPSUB;
2168 assert(CxTYPE(cx) == CXt_SUB);
2169
3f6bd23a 2170 PERL_DTRACE_PROBE_RETURN(cx->blk_sub.cv);
a73d8813
DM
2171
2172 if (CxHASARGS(cx))
2173 cx_popsub_args(cx);
2174 cx_popsub_common(cx);
2175}
2176
2177
6a7d52cc 2178PERL_STATIC_INLINE void
c9182d9c 2179Perl_cx_pushformat(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, GV *gv)
6a7d52cc
DM
2180{
2181 PERL_ARGS_ASSERT_CX_PUSHFORMAT;
2182
2183 cx->blk_format.cv = cv;
2184 cx->blk_format.retop = retop;
2185 cx->blk_format.gv = gv;
2186 cx->blk_format.dfoutgv = PL_defoutgv;
2187 cx->blk_format.prevcomppad = PL_comppad;
2188 cx->blk_u16 = 0;
2189
2190 SvREFCNT_inc_simple_void_NN(cv);
2191 CvDEPTH(cv)++;
2192 SvREFCNT_inc_void(cx->blk_format.dfoutgv);
2193}
2194
2195
2196PERL_STATIC_INLINE void
c9182d9c 2197Perl_cx_popformat(pTHX_ PERL_CONTEXT *cx)
6a7d52cc
DM
2198{
2199 CV *cv;
2200 GV *dfout;
2201
2202 PERL_ARGS_ASSERT_CX_POPFORMAT;
2203 assert(CxTYPE(cx) == CXt_FORMAT);
2204
2205 dfout = cx->blk_format.dfoutgv;
2206 setdefout(dfout);
2207 cx->blk_format.dfoutgv = NULL;
2208 SvREFCNT_dec_NN(dfout);
2209
2210 PL_comppad = cx->blk_format.prevcomppad;
2211 PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
2212 cv = cx->blk_format.cv;
2213 cx->blk_format.cv = NULL;
2214 --CvDEPTH(cv);
2215 SvREFCNT_dec_NN(cv);
2216}
2217
2218
13febba5 2219PERL_STATIC_INLINE void
c9182d9c 2220Perl_cx_pusheval(pTHX_ PERL_CONTEXT *cx, OP *retop, SV *namesv)
13febba5
DM
2221{
2222 PERL_ARGS_ASSERT_CX_PUSHEVAL;
2223
2224 cx->blk_eval.retop = retop;
2225 cx->blk_eval.old_namesv = namesv;
2226 cx->blk_eval.old_eval_root = PL_eval_root;
2227 cx->blk_eval.cur_text = PL_parser ? PL_parser->linestr : NULL;
2228 cx->blk_eval.cv = NULL; /* later set by doeval_compile() */
2229 cx->blk_eval.cur_top_env = PL_top_env;
2230
4c57ced5 2231 assert(!(PL_in_eval & ~ 0x3F));
13febba5 2232 assert(!(PL_op->op_type & ~0x1FF));
4c57ced5 2233 cx->blk_u16 = (PL_in_eval & 0x3F) | ((U16)PL_op->op_type << 7);
13febba5
DM
2234}
2235
2236
2237PERL_STATIC_INLINE void
c9182d9c 2238Perl_cx_popeval(pTHX_ PERL_CONTEXT *cx)
13febba5
DM
2239{
2240 SV *sv;
2241
2242 PERL_ARGS_ASSERT_CX_POPEVAL;
2243 assert(CxTYPE(cx) == CXt_EVAL);
2244
2245 PL_in_eval = CxOLD_IN_EVAL(cx);
4c57ced5 2246 assert(!(PL_in_eval & 0xc0));
13febba5
DM
2247 PL_eval_root = cx->blk_eval.old_eval_root;
2248 sv = cx->blk_eval.cur_text;
4c57ced5 2249 if (sv && CxEVAL_TXT_REFCNTED(cx)) {
13febba5
DM
2250 cx->blk_eval.cur_text = NULL;
2251 SvREFCNT_dec_NN(sv);
2252 }
2253
2254 sv = cx->blk_eval.old_namesv;
2a1e0dfe
DM
2255 if (sv) {
2256 cx->blk_eval.old_namesv = NULL;
2257 SvREFCNT_dec_NN(sv);
2258 }
13febba5 2259}
6a7d52cc 2260
a73d8813 2261
d1b6bf72
DM
2262/* push a plain loop, i.e.
2263 * { block }
2264 * while (cond) { block }
2265 * for (init;cond;continue) { block }
2266 * This loop can be last/redo'ed etc.
2267 */
2268
2269PERL_STATIC_INLINE void
c9182d9c 2270Perl_cx_pushloop_plain(pTHX_ PERL_CONTEXT *cx)
d1b6bf72
DM
2271{
2272 PERL_ARGS_ASSERT_CX_PUSHLOOP_PLAIN;
2273 cx->blk_loop.my_op = cLOOP;
2274}
2275
2276
2277/* push a true for loop, i.e.
2278 * for var (list) { block }
2279 */
2280
2281PERL_STATIC_INLINE void
c9182d9c 2282Perl_cx_pushloop_for(pTHX_ PERL_CONTEXT *cx, void *itervarp, SV* itersave)
d1b6bf72
DM
2283{
2284 PERL_ARGS_ASSERT_CX_PUSHLOOP_FOR;
2285
2286 /* this one line is common with cx_pushloop_plain */
2287 cx->blk_loop.my_op = cLOOP;
2288
2289 cx->blk_loop.itervar_u.svp = (SV**)itervarp;
2290 cx->blk_loop.itersave = itersave;
2291#ifdef USE_ITHREADS
2292 cx->blk_loop.oldcomppad = PL_comppad;
2293#endif
2294}
2295
2296
2297/* pop all loop types, including plain */
2298
2299PERL_STATIC_INLINE void
c9182d9c 2300Perl_cx_poploop(pTHX_ PERL_CONTEXT *cx)
d1b6bf72
DM
2301{
2302 PERL_ARGS_ASSERT_CX_POPLOOP;
2303
2304 assert(CxTYPE_is_LOOP(cx));
2305 if ( CxTYPE(cx) == CXt_LOOP_ARY
2306 || CxTYPE(cx) == CXt_LOOP_LAZYSV)
2307 {
2308 /* Free ary or cur. This assumes that state_u.ary.ary
2309 * aligns with state_u.lazysv.cur. See cx_dup() */
2310 SV *sv = cx->blk_loop.state_u.lazysv.cur;
2311 cx->blk_loop.state_u.lazysv.cur = NULL;
2312 SvREFCNT_dec_NN(sv);
2313 if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
2314 sv = cx->blk_loop.state_u.lazysv.end;
2315 cx->blk_loop.state_u.lazysv.end = NULL;
2316 SvREFCNT_dec_NN(sv);
2317 }
2318 }
2319 if (cx->cx_type & (CXp_FOR_PAD|CXp_FOR_GV)) {
2320 SV *cursv;
2321 SV **svp = (cx)->blk_loop.itervar_u.svp;
2322 if ((cx->cx_type & CXp_FOR_GV))
2323 svp = &GvSV((GV*)svp);
2324 cursv = *svp;
2325 *svp = cx->blk_loop.itersave;
2326 cx->blk_loop.itersave = NULL;
2327 SvREFCNT_dec(cursv);
2328 }
2329}
2330
2a7b7c61
DM
2331
2332PERL_STATIC_INLINE void
c9182d9c 2333Perl_cx_pushwhen(pTHX_ PERL_CONTEXT *cx)
2a7b7c61 2334{
7896dde7 2335 PERL_ARGS_ASSERT_CX_PUSHWHEN;
2a7b7c61 2336
7896dde7 2337 cx->blk_givwhen.leave_op = cLOGOP->op_other;
2a7b7c61
DM
2338}
2339
2340
2341PERL_STATIC_INLINE void
c9182d9c 2342Perl_cx_popwhen(pTHX_ PERL_CONTEXT *cx)
2a7b7c61 2343{
7896dde7
Z
2344 PERL_ARGS_ASSERT_CX_POPWHEN;
2345 assert(CxTYPE(cx) == CXt_WHEN);
2a7b7c61
DM
2346
2347 PERL_UNUSED_ARG(cx);
59a14f30 2348 PERL_UNUSED_CONTEXT;
2a7b7c61
DM
2349 /* currently NOOP */
2350}
2351
2352
7896dde7 2353PERL_STATIC_INLINE void
c9182d9c 2354Perl_cx_pushgiven(pTHX_ PERL_CONTEXT *cx, SV *orig_defsv)
7896dde7
Z
2355{
2356 PERL_ARGS_ASSERT_CX_PUSHGIVEN;
2357
2358 cx->blk_givwhen.leave_op = cLOGOP->op_other;
2359 cx->blk_givwhen.defsv_save = orig_defsv;
2360}
2361
2362
2363PERL_STATIC_INLINE void
c9182d9c 2364Perl_cx_popgiven(pTHX_ PERL_CONTEXT *cx)
7896dde7
Z
2365{
2366 SV *sv;
2367
2368 PERL_ARGS_ASSERT_CX_POPGIVEN;
2369 assert(CxTYPE(cx) == CXt_GIVEN);
2370
2371 sv = GvSV(PL_defgv);
2372 GvSV(PL_defgv) = cx->blk_givwhen.defsv_save;
2373 cx->blk_givwhen.defsv_save = NULL;
2374 SvREFCNT_dec(sv);
2375}
2376
ec2c235b
KW
2377/* ------------------ util.h ------------------------------------------- */
2378
2379/*
2380=head1 Miscellaneous Functions
2381
2382=for apidoc foldEQ
2383
2384Returns true if the leading C<len> bytes of the strings C<s1> and C<s2> are the
2385same
2386case-insensitively; false otherwise. Uppercase and lowercase ASCII range bytes
2387match themselves and their opposite case counterparts. Non-cased and non-ASCII
2388range bytes match only themselves.
2389
2390=cut
2391*/
2392
2393PERL_STATIC_INLINE I32
2394Perl_foldEQ(const char *s1, const char *s2, I32 len)
2395{
2396 const U8 *a = (const U8 *)s1;
2397 const U8 *b = (const U8 *)s2;
2398
2399 PERL_ARGS_ASSERT_FOLDEQ;
2400
2401 assert(len >= 0);
2402
2403 while (len--) {
2404 if (*a != *b && *a != PL_fold[*b])
2405 return 0;
2406 a++,b++;
2407 }
2408 return 1;
2409}
2410
0f9cb40c 2411PERL_STATIC_INLINE I32
ec2c235b
KW
2412Perl_foldEQ_latin1(const char *s1, const char *s2, I32 len)
2413{
79a1fabd
KW
2414 /* Compare non-UTF-8 using Unicode (Latin1) semantics. Works on all folds
2415 * representable without UTF-8, except for LATIN_SMALL_LETTER_SHARP_S, and
2416 * does not check for this. Nor does it check that the strings each have
2417 * at least 'len' characters. */
ec2c235b
KW
2418
2419 const U8 *a = (const U8 *)s1;
2420 const U8 *b = (const U8 *)s2;
2421
2422 PERL_ARGS_ASSERT_FOLDEQ_LATIN1;
2423
2424 assert(len >= 0);
2425
2426 while (len--) {
2427 if (*a != *b && *a != PL_fold_latin1[*b]) {
2428 return 0;
2429 }
2430 a++, b++;
2431 }
2432 return 1;
2433}
2434
2435/*
2436=for apidoc foldEQ_locale
2437
2438Returns true if the leading C<len> bytes of the strings C<s1> and C<s2> are the
2439same case-insensitively in the current locale; false otherwise.
2440
2441=cut
2442*/
2443
0f9cb40c 2444PERL_STATIC_INLINE I32
ec2c235b
KW
2445Perl_foldEQ_locale(const char *s1, const char *s2, I32 len)
2446{
2447 dVAR;
2448 const U8 *a = (const U8 *)s1;
2449 const U8 *b = (const U8 *)s2;
2450
2451 PERL_ARGS_ASSERT_FOLDEQ_LOCALE;
2452
2453 assert(len >= 0);
2454
2455 while (len--) {
2456 if (*a != *b && *a != PL_fold_locale[*b])
2457 return 0;
2458 a++,b++;
2459 }
2460 return 1;
2461}
2462
6dba01e2
KW
2463#if ! defined (HAS_MEMRCHR) && (defined(PERL_CORE) || defined(PERL_EXT))
2464
2465PERL_STATIC_INLINE void *
2466S_my_memrchr(const char * s, const char c, const STRLEN len)
2467{
2468 /* memrchr(), since many platforms lack it */
2469
2470 const char * t = s + len - 1;
2471
2472 PERL_ARGS_ASSERT_MY_MEMRCHR;
2473
2474 while (t >= s) {
2475 if (*t == c) {
2476 return (void *) t;
2477 }
2478 t--;
2479 }
2480
2481 return NULL;
2482}
2483
2484#endif
2485
ed382232 2486/*
c8028aa6
TC
2487 * ex: set ts=8 sts=4 sw=4 et:
2488 */