This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Make PadnameIN_SCOPE() name begin with S_
[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
c9182d9c 1895Perl_is_safe_syscall(pTHX_ const char *pv, STRLEN len, const char *what, const char *op_name) {
c8028aa6
TC
1896 /* While the Windows CE API provides only UCS-16 (or UTF-16) APIs
1897 * perl itself uses xce*() functions which accept 8-bit strings.
1898 */
1899
1900 PERL_ARGS_ASSERT_IS_SAFE_SYSCALL;
1901
6c4650b3 1902 if (len > 1) {
c8028aa6 1903 char *null_at;
41188aa0 1904 if (UNLIKELY((null_at = (char *)memchr(pv, 0, len-1)) != NULL)) {
c8028aa6 1905 SETERRNO(ENOENT, LIB_INVARG);
1d505182 1906 Perl_ck_warner(aTHX_ packWARN(WARN_SYSCALLS),
c8028aa6 1907 "Invalid \\0 character in %s for %s: %s\\0%s",
41188aa0 1908 what, op_name, pv, null_at+1);
c8028aa6
TC
1909 return FALSE;
1910 }
1911 }
1912
1913 return TRUE;
1914}
1915
1916/*
7cb3f959
TC
1917
1918Return true if the supplied filename has a newline character
fa6c7d00 1919immediately before the first (hopefully only) NUL.
7cb3f959
TC
1920
1921My original look at this incorrectly used the len from SvPV(), but
1922that's incorrect, since we allow for a NUL in pv[len-1].
1923
1924So instead, strlen() and work from there.
1925
1926This allow for the user reading a filename, forgetting to chomp it,
1927then calling:
1928
1929 open my $foo, "$file\0";
1930
1931*/
1932
1933#ifdef PERL_CORE
1934
1935PERL_STATIC_INLINE bool
1936S_should_warn_nl(const char *pv) {
1937 STRLEN len;
1938
1939 PERL_ARGS_ASSERT_SHOULD_WARN_NL;
1940
1941 len = strlen(pv);
1942
1943 return len > 0 && pv[len-1] == '\n';
1944}
1945
1946#endif
1947
3a019afd
KW
1948#if defined(PERL_IN_PP_C) || defined(PERL_IN_PP_HOT_C)
1949
1950PERL_STATIC_INLINE bool
1951S_lossless_NV_to_IV(const NV nv, IV *ivp)
1952{
1953 /* This function determines if the input NV 'nv' may be converted without
1954 * loss of data to an IV. If not, it returns FALSE taking no other action.
1955 * But if it is possible, it does the conversion, returning TRUE, and
1956 * storing the converted result in '*ivp' */
1957
1958 PERL_ARGS_ASSERT_LOSSLESS_NV_TO_IV;
1959
1960# if defined(Perl_isnan)
1961
1962 if (UNLIKELY(Perl_isnan(nv))) {
1963 return FALSE;
1964 }
1965
1966# endif
1967
1968 if (UNLIKELY(nv < IV_MIN) || UNLIKELY(nv > IV_MAX)) {
1969 return FALSE;
1970 }
1971
1972 if ((IV) nv != nv) {
1973 return FALSE;
1974 }
1975
1976 *ivp = (IV) nv;
1977 return TRUE;
1978}
1979
1980#endif
1981
81d52ecd
JH
1982/* ------------------ pp.c, regcomp.c, toke.c, universal.c ------------ */
1983
1984#define MAX_CHARSET_NAME_LENGTH 2
1985
1986PERL_STATIC_INLINE const char *
1987get_regex_charset_name(const U32 flags, STRLEN* const lenp)
1988{
1989 /* Returns a string that corresponds to the name of the regex character set
1990 * given by 'flags', and *lenp is set the length of that string, which
1991 * cannot exceed MAX_CHARSET_NAME_LENGTH characters */
1992
1993 *lenp = 1;
1994 switch (get_regex_charset(flags)) {
1995 case REGEX_DEPENDS_CHARSET: return DEPENDS_PAT_MODS;
1996 case REGEX_LOCALE_CHARSET: return LOCALE_PAT_MODS;
1997 case REGEX_UNICODE_CHARSET: return UNICODE_PAT_MODS;
1998 case REGEX_ASCII_RESTRICTED_CHARSET: return ASCII_RESTRICT_PAT_MODS;
1999 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
2000 *lenp = 2;
2001 return ASCII_MORE_RESTRICT_PAT_MODS;
2002 }
2003 /* The NOT_REACHED; hides an assert() which has a rather complex
2004 * definition in perl.h. */
2005 NOT_REACHED; /* NOTREACHED */
2006 return "?"; /* Unknown */
2007}
2008
7cb3f959 2009/*
ed382232
TC
2010
2011Return false if any get magic is on the SV other than taint magic.
2012
2013*/
2014
2015PERL_STATIC_INLINE bool
c9182d9c 2016Perl_sv_only_taint_gmagic(SV *sv) {
ed382232
TC
2017 MAGIC *mg = SvMAGIC(sv);
2018
2019 PERL_ARGS_ASSERT_SV_ONLY_TAINT_GMAGIC;
2020
2021 while (mg) {
2022 if (mg->mg_type != PERL_MAGIC_taint
2023 && !(mg->mg_flags & MGf_GSKIP)
2024 && mg->mg_virtual->svt_get) {
2025 return FALSE;
2026 }
2027 mg = mg->mg_moremagic;
2028 }
2029
2030 return TRUE;
2031}
2032
ed8ff0f3
DM
2033/* ------------------ cop.h ------------------------------------------- */
2034
2035
2036/* Enter a block. Push a new base context and return its address. */
2037
2038PERL_STATIC_INLINE PERL_CONTEXT *
c9182d9c 2039Perl_cx_pushblock(pTHX_ U8 type, U8 gimme, SV** sp, I32 saveix)
ed8ff0f3
DM
2040{
2041 PERL_CONTEXT * cx;
2042
2043 PERL_ARGS_ASSERT_CX_PUSHBLOCK;
2044
2045 CXINC;
2046 cx = CX_CUR();
2047 cx->cx_type = type;
2048 cx->blk_gimme = gimme;
2049 cx->blk_oldsaveix = saveix;
4caf7d8c 2050 cx->blk_oldsp = (I32)(sp - PL_stack_base);
ed8ff0f3 2051 cx->blk_oldcop = PL_curcop;
4caf7d8c 2052 cx->blk_oldmarksp = (I32)(PL_markstack_ptr - PL_markstack);
ed8ff0f3
DM
2053 cx->blk_oldscopesp = PL_scopestack_ix;
2054 cx->blk_oldpm = PL_curpm;
ce8bb8d8 2055 cx->blk_old_tmpsfloor = PL_tmps_floor;
ed8ff0f3
DM
2056
2057 PL_tmps_floor = PL_tmps_ix;
2058 CX_DEBUG(cx, "PUSH");
2059 return cx;
2060}
2061
2062
2063/* Exit a block (RETURN and LAST). */
2064
2065PERL_STATIC_INLINE void
c9182d9c 2066Perl_cx_popblock(pTHX_ PERL_CONTEXT *cx)
ed8ff0f3
DM
2067{
2068 PERL_ARGS_ASSERT_CX_POPBLOCK;
2069
2070 CX_DEBUG(cx, "POP");
2071 /* these 3 are common to cx_popblock and cx_topblock */
2072 PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp;
2073 PL_scopestack_ix = cx->blk_oldscopesp;
2074 PL_curpm = cx->blk_oldpm;
2075
2076 /* LEAVE_SCOPE() should have made this true. /(?{})/ cheats
2077 * and leaves a CX entry lying around for repeated use, so
2078 * skip for multicall */ \
2079 assert( (CxTYPE(cx) == CXt_SUB && CxMULTICALL(cx))
2080 || PL_savestack_ix == cx->blk_oldsaveix);
2081 PL_curcop = cx->blk_oldcop;
ce8bb8d8 2082 PL_tmps_floor = cx->blk_old_tmpsfloor;
ed8ff0f3
DM
2083}
2084
2085/* Continue a block elsewhere (e.g. NEXT, REDO, GOTO).
2086 * Whereas cx_popblock() restores the state to the point just before
2087 * cx_pushblock() was called, cx_topblock() restores it to the point just
2088 * *after* cx_pushblock() was called. */
2089
2090PERL_STATIC_INLINE void
c9182d9c 2091Perl_cx_topblock(pTHX_ PERL_CONTEXT *cx)
ed8ff0f3
DM
2092{
2093 PERL_ARGS_ASSERT_CX_TOPBLOCK;
2094
2095 CX_DEBUG(cx, "TOP");
2096 /* these 3 are common to cx_popblock and cx_topblock */
2097 PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp;
2098 PL_scopestack_ix = cx->blk_oldscopesp;
2099 PL_curpm = cx->blk_oldpm;
2100
2101 PL_stack_sp = PL_stack_base + cx->blk_oldsp;
2102}
2103
2104
a73d8813 2105PERL_STATIC_INLINE void
c9182d9c 2106Perl_cx_pushsub(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, bool hasargs)
a73d8813
DM
2107{
2108 U8 phlags = CX_PUSHSUB_GET_LVALUE_MASK(Perl_was_lvalue_sub);
2109
2110 PERL_ARGS_ASSERT_CX_PUSHSUB;
2111
3f6bd23a 2112 PERL_DTRACE_PROBE_ENTRY(cv);
a73d8813
DM
2113 cx->blk_sub.cv = cv;
2114 cx->blk_sub.olddepth = CvDEPTH(cv);
2115 cx->blk_sub.prevcomppad = PL_comppad;
2116 cx->cx_type |= (hasargs) ? CXp_HASARGS : 0;
2117 cx->blk_sub.retop = retop;
2118 SvREFCNT_inc_simple_void_NN(cv);
2119 cx->blk_u16 = PL_op->op_private & (phlags|OPpDEREF);
2120}
2121
2122
2123/* subsets of cx_popsub() */
2124
2125PERL_STATIC_INLINE void
c9182d9c 2126Perl_cx_popsub_common(pTHX_ PERL_CONTEXT *cx)
a73d8813
DM
2127{
2128 CV *cv;
2129
2130 PERL_ARGS_ASSERT_CX_POPSUB_COMMON;
2131 assert(CxTYPE(cx) == CXt_SUB);
2132
2133 PL_comppad = cx->blk_sub.prevcomppad;
2134 PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
2135 cv = cx->blk_sub.cv;
2136 CvDEPTH(cv) = cx->blk_sub.olddepth;
2137 cx->blk_sub.cv = NULL;
2138 SvREFCNT_dec(cv);
2139}
2140
2141
2142/* handle the @_ part of leaving a sub */
2143
2144PERL_STATIC_INLINE void
c9182d9c 2145Perl_cx_popsub_args(pTHX_ PERL_CONTEXT *cx)
a73d8813
DM
2146{
2147 AV *av;
2148
2149 PERL_ARGS_ASSERT_CX_POPSUB_ARGS;
2150 assert(CxTYPE(cx) == CXt_SUB);
2151 assert(AvARRAY(MUTABLE_AV(
2152 PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
2153 CvDEPTH(cx->blk_sub.cv)])) == PL_curpad);
2154
2155 CX_POP_SAVEARRAY(cx);
2156 av = MUTABLE_AV(PAD_SVl(0));
2157 if (UNLIKELY(AvREAL(av)))
2158 /* abandon @_ if it got reified */
2159 clear_defarray(av, 0);
2160 else {
2161 CLEAR_ARGARRAY(av);
2162 }
2163}
2164
2165
2166PERL_STATIC_INLINE void
c9182d9c 2167Perl_cx_popsub(pTHX_ PERL_CONTEXT *cx)
a73d8813
DM
2168{
2169 PERL_ARGS_ASSERT_CX_POPSUB;
2170 assert(CxTYPE(cx) == CXt_SUB);
2171
3f6bd23a 2172 PERL_DTRACE_PROBE_RETURN(cx->blk_sub.cv);
a73d8813
DM
2173
2174 if (CxHASARGS(cx))
2175 cx_popsub_args(cx);
2176 cx_popsub_common(cx);
2177}
2178
2179
6a7d52cc 2180PERL_STATIC_INLINE void
c9182d9c 2181Perl_cx_pushformat(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, GV *gv)
6a7d52cc
DM
2182{
2183 PERL_ARGS_ASSERT_CX_PUSHFORMAT;
2184
2185 cx->blk_format.cv = cv;
2186 cx->blk_format.retop = retop;
2187 cx->blk_format.gv = gv;
2188 cx->blk_format.dfoutgv = PL_defoutgv;
2189 cx->blk_format.prevcomppad = PL_comppad;
2190 cx->blk_u16 = 0;
2191
2192 SvREFCNT_inc_simple_void_NN(cv);
2193 CvDEPTH(cv)++;
2194 SvREFCNT_inc_void(cx->blk_format.dfoutgv);
2195}
2196
2197
2198PERL_STATIC_INLINE void
c9182d9c 2199Perl_cx_popformat(pTHX_ PERL_CONTEXT *cx)
6a7d52cc
DM
2200{
2201 CV *cv;
2202 GV *dfout;
2203
2204 PERL_ARGS_ASSERT_CX_POPFORMAT;
2205 assert(CxTYPE(cx) == CXt_FORMAT);
2206
2207 dfout = cx->blk_format.dfoutgv;
2208 setdefout(dfout);
2209 cx->blk_format.dfoutgv = NULL;
2210 SvREFCNT_dec_NN(dfout);
2211
2212 PL_comppad = cx->blk_format.prevcomppad;
2213 PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
2214 cv = cx->blk_format.cv;
2215 cx->blk_format.cv = NULL;
2216 --CvDEPTH(cv);
2217 SvREFCNT_dec_NN(cv);
2218}
2219
2220
13febba5 2221PERL_STATIC_INLINE void
c9182d9c 2222Perl_cx_pusheval(pTHX_ PERL_CONTEXT *cx, OP *retop, SV *namesv)
13febba5
DM
2223{
2224 PERL_ARGS_ASSERT_CX_PUSHEVAL;
2225
2226 cx->blk_eval.retop = retop;
2227 cx->blk_eval.old_namesv = namesv;
2228 cx->blk_eval.old_eval_root = PL_eval_root;
2229 cx->blk_eval.cur_text = PL_parser ? PL_parser->linestr : NULL;
2230 cx->blk_eval.cv = NULL; /* later set by doeval_compile() */
2231 cx->blk_eval.cur_top_env = PL_top_env;
2232
4c57ced5 2233 assert(!(PL_in_eval & ~ 0x3F));
13febba5 2234 assert(!(PL_op->op_type & ~0x1FF));
4c57ced5 2235 cx->blk_u16 = (PL_in_eval & 0x3F) | ((U16)PL_op->op_type << 7);
13febba5
DM
2236}
2237
2238
2239PERL_STATIC_INLINE void
c9182d9c 2240Perl_cx_popeval(pTHX_ PERL_CONTEXT *cx)
13febba5
DM
2241{
2242 SV *sv;
2243
2244 PERL_ARGS_ASSERT_CX_POPEVAL;
2245 assert(CxTYPE(cx) == CXt_EVAL);
2246
2247 PL_in_eval = CxOLD_IN_EVAL(cx);
4c57ced5 2248 assert(!(PL_in_eval & 0xc0));
13febba5
DM
2249 PL_eval_root = cx->blk_eval.old_eval_root;
2250 sv = cx->blk_eval.cur_text;
4c57ced5 2251 if (sv && CxEVAL_TXT_REFCNTED(cx)) {
13febba5
DM
2252 cx->blk_eval.cur_text = NULL;
2253 SvREFCNT_dec_NN(sv);
2254 }
2255
2256 sv = cx->blk_eval.old_namesv;
2a1e0dfe
DM
2257 if (sv) {
2258 cx->blk_eval.old_namesv = NULL;
2259 SvREFCNT_dec_NN(sv);
2260 }
13febba5 2261}
6a7d52cc 2262
a73d8813 2263
d1b6bf72
DM
2264/* push a plain loop, i.e.
2265 * { block }
2266 * while (cond) { block }
2267 * for (init;cond;continue) { block }
2268 * This loop can be last/redo'ed etc.
2269 */
2270
2271PERL_STATIC_INLINE void
c9182d9c 2272Perl_cx_pushloop_plain(pTHX_ PERL_CONTEXT *cx)
d1b6bf72
DM
2273{
2274 PERL_ARGS_ASSERT_CX_PUSHLOOP_PLAIN;
2275 cx->blk_loop.my_op = cLOOP;
2276}
2277
2278
2279/* push a true for loop, i.e.
2280 * for var (list) { block }
2281 */
2282
2283PERL_STATIC_INLINE void
c9182d9c 2284Perl_cx_pushloop_for(pTHX_ PERL_CONTEXT *cx, void *itervarp, SV* itersave)
d1b6bf72
DM
2285{
2286 PERL_ARGS_ASSERT_CX_PUSHLOOP_FOR;
2287
2288 /* this one line is common with cx_pushloop_plain */
2289 cx->blk_loop.my_op = cLOOP;
2290
2291 cx->blk_loop.itervar_u.svp = (SV**)itervarp;
2292 cx->blk_loop.itersave = itersave;
2293#ifdef USE_ITHREADS
2294 cx->blk_loop.oldcomppad = PL_comppad;
2295#endif
2296}
2297
2298
2299/* pop all loop types, including plain */
2300
2301PERL_STATIC_INLINE void
c9182d9c 2302Perl_cx_poploop(pTHX_ PERL_CONTEXT *cx)
d1b6bf72
DM
2303{
2304 PERL_ARGS_ASSERT_CX_POPLOOP;
2305
2306 assert(CxTYPE_is_LOOP(cx));
2307 if ( CxTYPE(cx) == CXt_LOOP_ARY
2308 || CxTYPE(cx) == CXt_LOOP_LAZYSV)
2309 {
2310 /* Free ary or cur. This assumes that state_u.ary.ary
2311 * aligns with state_u.lazysv.cur. See cx_dup() */
2312 SV *sv = cx->blk_loop.state_u.lazysv.cur;
2313 cx->blk_loop.state_u.lazysv.cur = NULL;
2314 SvREFCNT_dec_NN(sv);
2315 if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
2316 sv = cx->blk_loop.state_u.lazysv.end;
2317 cx->blk_loop.state_u.lazysv.end = NULL;
2318 SvREFCNT_dec_NN(sv);
2319 }
2320 }
2321 if (cx->cx_type & (CXp_FOR_PAD|CXp_FOR_GV)) {
2322 SV *cursv;
2323 SV **svp = (cx)->blk_loop.itervar_u.svp;
2324 if ((cx->cx_type & CXp_FOR_GV))
2325 svp = &GvSV((GV*)svp);
2326 cursv = *svp;
2327 *svp = cx->blk_loop.itersave;
2328 cx->blk_loop.itersave = NULL;
2329 SvREFCNT_dec(cursv);
2330 }
2331}
2332
2a7b7c61
DM
2333
2334PERL_STATIC_INLINE void
c9182d9c 2335Perl_cx_pushwhen(pTHX_ PERL_CONTEXT *cx)
2a7b7c61 2336{
7896dde7 2337 PERL_ARGS_ASSERT_CX_PUSHWHEN;
2a7b7c61 2338
7896dde7 2339 cx->blk_givwhen.leave_op = cLOGOP->op_other;
2a7b7c61
DM
2340}
2341
2342
2343PERL_STATIC_INLINE void
c9182d9c 2344Perl_cx_popwhen(pTHX_ PERL_CONTEXT *cx)
2a7b7c61 2345{
7896dde7
Z
2346 PERL_ARGS_ASSERT_CX_POPWHEN;
2347 assert(CxTYPE(cx) == CXt_WHEN);
2a7b7c61
DM
2348
2349 PERL_UNUSED_ARG(cx);
59a14f30 2350 PERL_UNUSED_CONTEXT;
2a7b7c61
DM
2351 /* currently NOOP */
2352}
2353
2354
7896dde7 2355PERL_STATIC_INLINE void
c9182d9c 2356Perl_cx_pushgiven(pTHX_ PERL_CONTEXT *cx, SV *orig_defsv)
7896dde7
Z
2357{
2358 PERL_ARGS_ASSERT_CX_PUSHGIVEN;
2359
2360 cx->blk_givwhen.leave_op = cLOGOP->op_other;
2361 cx->blk_givwhen.defsv_save = orig_defsv;
2362}
2363
2364
2365PERL_STATIC_INLINE void
c9182d9c 2366Perl_cx_popgiven(pTHX_ PERL_CONTEXT *cx)
7896dde7
Z
2367{
2368 SV *sv;
2369
2370 PERL_ARGS_ASSERT_CX_POPGIVEN;
2371 assert(CxTYPE(cx) == CXt_GIVEN);
2372
2373 sv = GvSV(PL_defgv);
2374 GvSV(PL_defgv) = cx->blk_givwhen.defsv_save;
2375 cx->blk_givwhen.defsv_save = NULL;
2376 SvREFCNT_dec(sv);
2377}
2378
ec2c235b
KW
2379/* ------------------ util.h ------------------------------------------- */
2380
2381/*
2382=head1 Miscellaneous Functions
2383
2384=for apidoc foldEQ
2385
2386Returns true if the leading C<len> bytes of the strings C<s1> and C<s2> are the
2387same
2388case-insensitively; false otherwise. Uppercase and lowercase ASCII range bytes
2389match themselves and their opposite case counterparts. Non-cased and non-ASCII
2390range bytes match only themselves.
2391
2392=cut
2393*/
2394
2395PERL_STATIC_INLINE I32
2396Perl_foldEQ(const char *s1, const char *s2, I32 len)
2397{
2398 const U8 *a = (const U8 *)s1;
2399 const U8 *b = (const U8 *)s2;
2400
2401 PERL_ARGS_ASSERT_FOLDEQ;
2402
2403 assert(len >= 0);
2404
2405 while (len--) {
2406 if (*a != *b && *a != PL_fold[*b])
2407 return 0;
2408 a++,b++;
2409 }
2410 return 1;
2411}
2412
0f9cb40c 2413PERL_STATIC_INLINE I32
ec2c235b
KW
2414Perl_foldEQ_latin1(const char *s1, const char *s2, I32 len)
2415{
79a1fabd
KW
2416 /* Compare non-UTF-8 using Unicode (Latin1) semantics. Works on all folds
2417 * representable without UTF-8, except for LATIN_SMALL_LETTER_SHARP_S, and
2418 * does not check for this. Nor does it check that the strings each have
2419 * at least 'len' characters. */
ec2c235b
KW
2420
2421 const U8 *a = (const U8 *)s1;
2422 const U8 *b = (const U8 *)s2;
2423
2424 PERL_ARGS_ASSERT_FOLDEQ_LATIN1;
2425
2426 assert(len >= 0);
2427
2428 while (len--) {
2429 if (*a != *b && *a != PL_fold_latin1[*b]) {
2430 return 0;
2431 }
2432 a++, b++;
2433 }
2434 return 1;
2435}
2436
2437/*
2438=for apidoc foldEQ_locale
2439
2440Returns true if the leading C<len> bytes of the strings C<s1> and C<s2> are the
2441same case-insensitively in the current locale; false otherwise.
2442
2443=cut
2444*/
2445
0f9cb40c 2446PERL_STATIC_INLINE I32
ec2c235b
KW
2447Perl_foldEQ_locale(const char *s1, const char *s2, I32 len)
2448{
2449 dVAR;
2450 const U8 *a = (const U8 *)s1;
2451 const U8 *b = (const U8 *)s2;
2452
2453 PERL_ARGS_ASSERT_FOLDEQ_LOCALE;
2454
2455 assert(len >= 0);
2456
2457 while (len--) {
2458 if (*a != *b && *a != PL_fold_locale[*b])
2459 return 0;
2460 a++,b++;
2461 }
2462 return 1;
2463}
2464
6dba01e2
KW
2465#if ! defined (HAS_MEMRCHR) && (defined(PERL_CORE) || defined(PERL_EXT))
2466
2467PERL_STATIC_INLINE void *
2468S_my_memrchr(const char * s, const char c, const STRLEN len)
2469{
2470 /* memrchr(), since many platforms lack it */
2471
2472 const char * t = s + len - 1;
2473
2474 PERL_ARGS_ASSERT_MY_MEMRCHR;
2475
2476 while (t >= s) {
2477 if (*t == c) {
2478 return (void *) t;
2479 }
2480 t--;
2481 }
2482
2483 return NULL;
2484}
2485
2486#endif
2487
ed382232 2488/*
c8028aa6
TC
2489 * ex: set ts=8 sts=4 sw=4 et:
2490 */