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