This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
perlapi: Reword description of is_utf8_valid_partial_char
[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 *
8 * This file is a home for static inline functions that cannot go in other
9 * headers files, because they depend on proto.h (included after most other
10 * headers) or struct definitions.
11 *
12 * Each section names the header file that the functions "belong" to.
13 */
27669aa4 14
be3a7a5d
KW
15/* ------------------------------- av.h ------------------------------- */
16
c70927a6 17PERL_STATIC_INLINE SSize_t
be3a7a5d
KW
18S_av_top_index(pTHX_ AV *av)
19{
20 PERL_ARGS_ASSERT_AV_TOP_INDEX;
21 assert(SvTYPE(av) == SVt_PVAV);
22
23 return AvFILL(av);
24}
25
1afe1db1
FC
26/* ------------------------------- cv.h ------------------------------- */
27
ae77754a
FC
28PERL_STATIC_INLINE GV *
29S_CvGV(pTHX_ CV *sv)
30{
31 return CvNAMED(sv)
32 ? Perl_cvgv_from_hek(aTHX_ sv)
33 : ((XPVCV*)MUTABLE_PTR(SvANY(sv)))->xcv_gv_u.xcv_gv;
34}
35
1afe1db1
FC
36PERL_STATIC_INLINE I32 *
37S_CvDEPTHp(const CV * const sv)
38{
39 assert(SvTYPE(sv) == SVt_PVCV || SvTYPE(sv) == SVt_PVFM);
8de47657 40 return &((XPVCV*)SvANY(sv))->xcv_depth;
1afe1db1
FC
41}
42
d16269d8
PM
43/*
44 CvPROTO returns the prototype as stored, which is not necessarily what
45 the interpreter should be using. Specifically, the interpreter assumes
46 that spaces have been stripped, which has been the case if the prototype
47 was added by toke.c, but is generally not the case if it was added elsewhere.
48 Since we can't enforce the spacelessness at assignment time, this routine
49 provides a temporary copy at parse time with spaces removed.
50 I<orig> is the start of the original buffer, I<len> is the length of the
51 prototype and will be updated when this returns.
52 */
53
5b67adb8 54#ifdef PERL_CORE
d16269d8
PM
55PERL_STATIC_INLINE char *
56S_strip_spaces(pTHX_ const char * orig, STRLEN * const len)
57{
58 SV * tmpsv;
59 char * tmps;
60 tmpsv = newSVpvn_flags(orig, *len, SVs_TEMP);
61 tmps = SvPVX(tmpsv);
62 while ((*len)--) {
63 if (!isSPACE(*orig))
64 *tmps++ = *orig;
65 orig++;
66 }
67 *tmps = '\0';
68 *len = tmps - SvPVX(tmpsv);
69 return SvPVX(tmpsv);
70}
5b67adb8 71#endif
d16269d8 72
25fdce4a
FC
73/* ------------------------------- mg.h ------------------------------- */
74
75#if defined(PERL_CORE) || defined(PERL_EXT)
76/* assumes get-magic and stringification have already occurred */
77PERL_STATIC_INLINE STRLEN
78S_MgBYTEPOS(pTHX_ MAGIC *mg, SV *sv, const char *s, STRLEN len)
79{
80 assert(mg->mg_type == PERL_MAGIC_regex_global);
81 assert(mg->mg_len != -1);
82 if (mg->mg_flags & MGf_BYTES || !DO_UTF8(sv))
83 return (STRLEN)mg->mg_len;
84 else {
85 const STRLEN pos = (STRLEN)mg->mg_len;
86 /* Without this check, we may read past the end of the buffer: */
87 if (pos > sv_or_pv_len_utf8(sv, s, len)) return len+1;
88 return sv_or_pv_pos_u2b(sv, s, pos, NULL);
89 }
90}
91#endif
92
03414f05
FC
93/* ------------------------------- pad.h ------------------------------ */
94
95#if defined(PERL_IN_PAD_C) || defined(PERL_IN_OP_C)
96PERL_STATIC_INLINE bool
97PadnameIN_SCOPE(const PADNAME * const pn, const U32 seq)
98{
99 /* is seq within the range _LOW to _HIGH ?
100 * This is complicated by the fact that PL_cop_seqmax
101 * may have wrapped around at some point */
102 if (COP_SEQ_RANGE_LOW(pn) == PERL_PADSEQ_INTRO)
103 return FALSE; /* not yet introduced */
104
105 if (COP_SEQ_RANGE_HIGH(pn) == PERL_PADSEQ_INTRO) {
106 /* in compiling scope */
107 if (
108 (seq > COP_SEQ_RANGE_LOW(pn))
109 ? (seq - COP_SEQ_RANGE_LOW(pn) < (U32_MAX >> 1))
110 : (COP_SEQ_RANGE_LOW(pn) - seq > (U32_MAX >> 1))
111 )
112 return TRUE;
113 }
114 else if (
115 (COP_SEQ_RANGE_LOW(pn) > COP_SEQ_RANGE_HIGH(pn))
116 ?
117 ( seq > COP_SEQ_RANGE_LOW(pn)
118 || seq <= COP_SEQ_RANGE_HIGH(pn))
119
120 : ( seq > COP_SEQ_RANGE_LOW(pn)
121 && seq <= COP_SEQ_RANGE_HIGH(pn))
122 )
123 return TRUE;
124 return FALSE;
125}
126#endif
127
33a4312b
FC
128/* ------------------------------- pp.h ------------------------------- */
129
130PERL_STATIC_INLINE I32
131S_TOPMARK(pTHX)
132{
133 DEBUG_s(DEBUG_v(PerlIO_printf(Perl_debug_log,
134 "MARK top %p %"IVdf"\n",
135 PL_markstack_ptr,
136 (IV)*PL_markstack_ptr)));
137 return *PL_markstack_ptr;
138}
139
140PERL_STATIC_INLINE I32
141S_POPMARK(pTHX)
142{
143 DEBUG_s(DEBUG_v(PerlIO_printf(Perl_debug_log,
144 "MARK pop %p %"IVdf"\n",
145 (PL_markstack_ptr-1),
146 (IV)*(PL_markstack_ptr-1))));
147 assert((PL_markstack_ptr > PL_markstack) || !"MARK underflow");
148 return *PL_markstack_ptr--;
149}
150
8d919b0a
FC
151/* ----------------------------- regexp.h ----------------------------- */
152
153PERL_STATIC_INLINE struct regexp *
154S_ReANY(const REGEXP * const re)
155{
156 assert(isREGEXP(re));
157 return re->sv_u.svu_rx;
158}
159
27669aa4
FC
160/* ------------------------------- sv.h ------------------------------- */
161
162PERL_STATIC_INLINE SV *
163S_SvREFCNT_inc(SV *sv)
164{
2439e033 165 if (LIKELY(sv != NULL))
27669aa4
FC
166 SvREFCNT(sv)++;
167 return sv;
168}
169PERL_STATIC_INLINE SV *
170S_SvREFCNT_inc_NN(SV *sv)
171{
172 SvREFCNT(sv)++;
173 return sv;
174}
175PERL_STATIC_INLINE void
176S_SvREFCNT_inc_void(SV *sv)
177{
2439e033 178 if (LIKELY(sv != NULL))
27669aa4
FC
179 SvREFCNT(sv)++;
180}
75e16a44
FC
181PERL_STATIC_INLINE void
182S_SvREFCNT_dec(pTHX_ SV *sv)
183{
2439e033 184 if (LIKELY(sv != NULL)) {
75a9bf96 185 U32 rc = SvREFCNT(sv);
79e2a32a 186 if (LIKELY(rc > 1))
75a9bf96
DM
187 SvREFCNT(sv) = rc - 1;
188 else
189 Perl_sv_free2(aTHX_ sv, rc);
75e16a44
FC
190 }
191}
541377b1
FC
192
193PERL_STATIC_INLINE void
4a9a56a7
DM
194S_SvREFCNT_dec_NN(pTHX_ SV *sv)
195{
196 U32 rc = SvREFCNT(sv);
79e2a32a 197 if (LIKELY(rc > 1))
4a9a56a7
DM
198 SvREFCNT(sv) = rc - 1;
199 else
200 Perl_sv_free2(aTHX_ sv, rc);
201}
202
203PERL_STATIC_INLINE void
541377b1
FC
204SvAMAGIC_on(SV *sv)
205{
206 assert(SvROK(sv));
207 if (SvOBJECT(SvRV(sv))) HvAMAGIC_on(SvSTASH(SvRV(sv)));
208}
209PERL_STATIC_INLINE void
210SvAMAGIC_off(SV *sv)
211{
212 if (SvROK(sv) && SvOBJECT(SvRV(sv)))
213 HvAMAGIC_off(SvSTASH(SvRV(sv)));
214}
215
216PERL_STATIC_INLINE U32
541377b1
FC
217S_SvPADSTALE_on(SV *sv)
218{
c0683843 219 assert(!(SvFLAGS(sv) & SVs_PADTMP));
541377b1
FC
220 return SvFLAGS(sv) |= SVs_PADSTALE;
221}
222PERL_STATIC_INLINE U32
223S_SvPADSTALE_off(SV *sv)
224{
c0683843 225 assert(!(SvFLAGS(sv) & SVs_PADTMP));
541377b1
FC
226 return SvFLAGS(sv) &= ~SVs_PADSTALE;
227}
25fdce4a 228#if defined(PERL_CORE) || defined (PERL_EXT)
4ddea69a 229PERL_STATIC_INLINE STRLEN
6964422a 230S_sv_or_pv_pos_u2b(pTHX_ SV *sv, const char *pv, STRLEN pos, STRLEN *lenp)
4ddea69a 231{
25fdce4a 232 PERL_ARGS_ASSERT_SV_OR_PV_POS_U2B;
4ddea69a
FC
233 if (SvGAMAGIC(sv)) {
234 U8 *hopped = utf8_hop((U8 *)pv, pos);
235 if (lenp) *lenp = (STRLEN)(utf8_hop(hopped, *lenp) - hopped);
236 return (STRLEN)(hopped - (U8 *)pv);
237 }
238 return sv_pos_u2b_flags(sv,pos,lenp,SV_CONST_RETURN);
239}
240#endif
f019c49e 241
d1decf2b
TC
242/* ------------------------------- handy.h ------------------------------- */
243
244/* saves machine code for a common noreturn idiom typically used in Newx*() */
c1d6452f 245#ifdef GCC_DIAG_PRAGMA
6ab56f1e 246GCC_DIAG_IGNORE(-Wunused-function) /* Intentionally left semicolonless. */
c1d6452f 247#endif
d1decf2b
TC
248static void
249S_croak_memory_wrap(void)
250{
251 Perl_croak_nocontext("%s",PL_memory_wrap);
252}
c1d6452f 253#ifdef GCC_DIAG_PRAGMA
6ab56f1e 254GCC_DIAG_RESTORE /* Intentionally left semicolonless. */
c1d6452f 255#endif
d1decf2b 256
a8a2ceaa
KW
257/* ------------------------------- utf8.h ------------------------------- */
258
2fe720e2
KW
259/*
260=head1 Unicode Support
261*/
262
55d09dc8
KW
263PERL_STATIC_INLINE void
264S_append_utf8_from_native_byte(const U8 byte, U8** dest)
265{
266 /* Takes an input 'byte' (Latin1 or EBCDIC) and appends it to the UTF-8
267 * encoded string at '*dest', updating '*dest' to include it */
268
55d09dc8
KW
269 PERL_ARGS_ASSERT_APPEND_UTF8_FROM_NATIVE_BYTE;
270
6f2d5cbc 271 if (NATIVE_BYTE_IS_INVARIANT(byte))
a09ec51a 272 *((*dest)++) = byte;
55d09dc8 273 else {
a09ec51a
KW
274 *((*dest)++) = UTF8_EIGHT_BIT_HI(byte);
275 *((*dest)++) = UTF8_EIGHT_BIT_LO(byte);
55d09dc8
KW
276 }
277}
278
e123187a 279/*
2fe720e2
KW
280=for apidoc valid_utf8_to_uvchr
281Like L</utf8_to_uvchr_buf>(), but should only be called when it is known that
282the next character in the input UTF-8 string C<s> is well-formed (I<e.g.>,
283it passes C<L</isUTF8_CHAR>>. Surrogates, non-character code points, and
284non-Unicode code points are allowed.
285
286=cut
287
288 */
289
290PERL_STATIC_INLINE UV
291Perl_valid_utf8_to_uvchr(const U8 *s, STRLEN *retlen)
292{
293 UV expectlen = UTF8SKIP(s);
294 const U8* send = s + expectlen;
295 UV uv = *s;
296
297 PERL_ARGS_ASSERT_VALID_UTF8_TO_UVCHR;
298
299 if (retlen) {
300 *retlen = expectlen;
301 }
302
303 /* An invariant is trivially returned */
304 if (expectlen == 1) {
305 return uv;
306 }
307
308 /* Remove the leading bits that indicate the number of bytes, leaving just
309 * the bits that are part of the value */
310 uv = NATIVE_UTF8_TO_I8(uv) & UTF_START_MASK(expectlen);
311
312 /* Now, loop through the remaining bytes, accumulating each into the
313 * working total as we go. (I khw tried unrolling the loop for up to 4
314 * bytes, but there was no performance improvement) */
315 for (++s; s < send; s++) {
316 uv = UTF8_ACCUMULATE(uv, *s);
317 }
318
319 return UNI_TO_NATIVE(uv);
320
321}
322
1e599354
KW
323/*
324=for apidoc is_utf8_invariant_string
325
326Returns true iff the first C<len> bytes of the string C<s> are the same
327regardless of the UTF-8 encoding of the string (or UTF-EBCDIC encoding on
328EBCDIC machines). That is, if they are UTF-8 invariant. On ASCII-ish
329machines, all the ASCII characters and only the ASCII characters fit this
330definition. On EBCDIC machines, the ASCII-range characters are invariant, but
331so also are the C1 controls and C<\c?> (which isn't in the ASCII range on
332EBCDIC).
333
334If C<len> is 0, it will be calculated using C<strlen(s)>, (which means if you
335use this option, that C<s> can't have embedded C<NUL> characters and has to
336have a terminating C<NUL> byte).
337
338See also L</is_utf8_string>(), L</is_utf8_string_loclen>(), and
339L</is_utf8_string_loc>().
340
341=cut
342*/
343
344PERL_STATIC_INLINE bool
345S_is_utf8_invariant_string(const U8* const s, const STRLEN len)
346{
347 const U8* const send = s + (len ? len : strlen((const char *)s));
348 const U8* x = s;
349
350 PERL_ARGS_ASSERT_IS_UTF8_INVARIANT_STRING;
351
352 for (; x < send; ++x) {
353 if (!UTF8_IS_INVARIANT(*x))
354 return FALSE;
355 }
356
357 return TRUE;
358}
359
7c93d8f0 360/*
5ff889fb
KW
361=for apidoc is_utf8_string
362
363Returns true if the first C<len> bytes of string C<s> form a valid
364UTF-8 string, false otherwise. If C<len> is 0, it will be calculated
365using C<strlen(s)> (which means if you use this option, that C<s> can't have
366embedded C<NUL> characters and has to have a terminating C<NUL> byte). Note
367that all characters being ASCII constitute 'a valid UTF-8 string'.
368
369See also L</is_utf8_invariant_string>(), L</is_utf8_string_loclen>(), and
370L</is_utf8_string_loc>().
371
372=cut
373*/
374
56e4cf64 375PERL_STATIC_INLINE bool
5ff889fb
KW
376Perl_is_utf8_string(const U8 *s, STRLEN len)
377{
35936d22
KW
378 /* This is now marked pure in embed.fnc, because isUTF8_CHAR now is pure.
379 * Be aware of possible changes to that */
380
5ff889fb
KW
381 const U8* const send = s + (len ? len : strlen((const char *)s));
382 const U8* x = s;
383
384 PERL_ARGS_ASSERT_IS_UTF8_STRING;
385
386 while (x < send) {
387 STRLEN len = isUTF8_CHAR(x, send);
388 if (UNLIKELY(! len)) {
389 return FALSE;
390 }
391 x += len;
392 }
393
394 return TRUE;
395}
396
397/*
398Implemented as a macro in utf8.h
399
400=for apidoc is_utf8_string_loc
401
402Like L</is_utf8_string> but stores the location of the failure (in the
403case of "utf8ness failure") or the location C<s>+C<len> (in the case of
404"utf8ness success") in the C<ep>.
405
406See also L</is_utf8_string_loclen>() and L</is_utf8_string>().
407
408=for apidoc is_utf8_string_loclen
409
410Like L</is_utf8_string>() but stores the location of the failure (in the
411case of "utf8ness failure") or the location C<s>+C<len> (in the case of
412"utf8ness success") in the C<ep>, and the number of UTF-8
413encoded characters in the C<el>.
414
415See also L</is_utf8_string_loc>() and L</is_utf8_string>().
416
417=cut
418*/
419
56e4cf64 420PERL_STATIC_INLINE bool
5ff889fb
KW
421Perl_is_utf8_string_loclen(const U8 *s, STRLEN len, const U8 **ep, STRLEN *el)
422{
423 const U8* const send = s + (len ? len : strlen((const char *)s));
424 const U8* x = s;
425 STRLEN outlen = 0;
426
427 PERL_ARGS_ASSERT_IS_UTF8_STRING_LOCLEN;
428
429 while (x < send) {
430 STRLEN len = isUTF8_CHAR(x, send);
431 if (UNLIKELY(! len)) {
432 break;
433 }
434 x += len;
435 outlen++;
436 }
437
438 if (el)
439 *el = outlen;
440
441 if (ep) {
442 *ep = x;
443 }
444
445 return (x == send);
446}
447
448/*
7c93d8f0
KW
449=for apidoc utf8_distance
450
451Returns the number of UTF-8 characters between the UTF-8 pointers C<a>
452and C<b>.
453
454WARNING: use only if you *know* that the pointers point inside the
455same UTF-8 buffer.
456
457=cut
458*/
459
460PERL_STATIC_INLINE IV
461Perl_utf8_distance(pTHX_ const U8 *a, const U8 *b)
462{
463 PERL_ARGS_ASSERT_UTF8_DISTANCE;
464
465 return (a < b) ? -1 * (IV) utf8_length(a, b) : (IV) utf8_length(b, a);
466}
467
468/*
469=for apidoc utf8_hop
470
471Return the UTF-8 pointer C<s> displaced by C<off> characters, either
472forward or backward.
473
474WARNING: do not use the following unless you *know* C<off> is within
475the UTF-8 data pointed to by C<s> *and* that on entry C<s> is aligned
476on the first byte of character or just after the last byte of a character.
477
478=cut
479*/
480
481PERL_STATIC_INLINE U8 *
482Perl_utf8_hop(const U8 *s, SSize_t off)
483{
484 PERL_ARGS_ASSERT_UTF8_HOP;
485
486 /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
487 * the bitops (especially ~) can create illegal UTF-8.
488 * In other words: in Perl UTF-8 is not just for Unicode. */
489
490 if (off >= 0) {
491 while (off--)
492 s += UTF8SKIP(s);
493 }
494 else {
495 while (off++) {
496 s--;
497 while (UTF8_IS_CONTINUATION(*s))
498 s--;
499 }
500 }
501 return (U8 *)s;
502}
503
4dab108f
KW
504/*
505
506=for apidoc is_utf8_valid_partial_char
507
6cbb9248
KW
508Returns 0 if the sequence of bytes starting at C<s> and looking no further than
509S<C<e - 1>> is the UTF-8 encoding, as extended by Perl, for one or more code
510points. Otherwise, it returns 1 if there exists at least one non-empty
511sequence of bytes that when appended to sequence C<s>, starting at position
512C<e> causes the entire sequence to be the well-formed UTF-8 of some code point;
513otherwise returns 0.
514
515In other words this returns TRUE if C<s> points to a partial UTF-8-encoded code
516point.
517
518This is useful when a fixed-length buffer is being tested for being well-formed
519UTF-8, but the final few bytes in it don't comprise a full character; that is,
520it is split somewhere in the middle of the final code point's UTF-8
521representation. (Presumably when the buffer is refreshed with the next chunk
522of data, the new first bytes will complete the partial code point.) This
523function is used to verify that the final bytes in the current buffer are in
524fact the legal beginning of some code point, so that if they aren't, the
525failure can be signalled without having to wait for the next read.
4dab108f
KW
526
527=cut
528*/
56e4cf64 529PERL_STATIC_INLINE bool
4dab108f
KW
530S_is_utf8_valid_partial_char(const U8 * const s, const U8 * const e)
531{
532
533 PERL_ARGS_ASSERT_IS_UTF8_VALID_PARTIAL_CHAR;
534
8875bd48 535 if (s >= e || s + UTF8SKIP(s) <= e) {
4dab108f
KW
536 return FALSE;
537 }
538
2b479609 539 return cBOOL(_is_utf8_char_helper(s, e, 0));
4dab108f
KW
540}
541
c8028aa6
TC
542/* ------------------------------- perl.h ----------------------------- */
543
544/*
dcccc8ff
KW
545=head1 Miscellaneous Functions
546
41188aa0 547=for apidoc AiR|bool|is_safe_syscall|const char *pv|STRLEN len|const char *what|const char *op_name
c8028aa6 548
6602b933 549Test that the given C<pv> doesn't contain any internal C<NUL> characters.
796b6530 550If it does, set C<errno> to C<ENOENT>, optionally warn, and return FALSE.
c8028aa6
TC
551
552Return TRUE if the name is safe.
553
796b6530 554Used by the C<IS_SAFE_SYSCALL()> macro.
c8028aa6
TC
555
556=cut
557*/
558
559PERL_STATIC_INLINE bool
41188aa0 560S_is_safe_syscall(pTHX_ const char *pv, STRLEN len, const char *what, const char *op_name) {
c8028aa6
TC
561 /* While the Windows CE API provides only UCS-16 (or UTF-16) APIs
562 * perl itself uses xce*() functions which accept 8-bit strings.
563 */
564
565 PERL_ARGS_ASSERT_IS_SAFE_SYSCALL;
566
6c4650b3 567 if (len > 1) {
c8028aa6 568 char *null_at;
41188aa0 569 if (UNLIKELY((null_at = (char *)memchr(pv, 0, len-1)) != NULL)) {
c8028aa6 570 SETERRNO(ENOENT, LIB_INVARG);
1d505182 571 Perl_ck_warner(aTHX_ packWARN(WARN_SYSCALLS),
c8028aa6 572 "Invalid \\0 character in %s for %s: %s\\0%s",
41188aa0 573 what, op_name, pv, null_at+1);
c8028aa6
TC
574 return FALSE;
575 }
576 }
577
578 return TRUE;
579}
580
581/*
7cb3f959
TC
582
583Return true if the supplied filename has a newline character
fa6c7d00 584immediately before the first (hopefully only) NUL.
7cb3f959
TC
585
586My original look at this incorrectly used the len from SvPV(), but
587that's incorrect, since we allow for a NUL in pv[len-1].
588
589So instead, strlen() and work from there.
590
591This allow for the user reading a filename, forgetting to chomp it,
592then calling:
593
594 open my $foo, "$file\0";
595
596*/
597
598#ifdef PERL_CORE
599
600PERL_STATIC_INLINE bool
601S_should_warn_nl(const char *pv) {
602 STRLEN len;
603
604 PERL_ARGS_ASSERT_SHOULD_WARN_NL;
605
606 len = strlen(pv);
607
608 return len > 0 && pv[len-1] == '\n';
609}
610
611#endif
612
81d52ecd
JH
613/* ------------------ pp.c, regcomp.c, toke.c, universal.c ------------ */
614
615#define MAX_CHARSET_NAME_LENGTH 2
616
617PERL_STATIC_INLINE const char *
618get_regex_charset_name(const U32 flags, STRLEN* const lenp)
619{
620 /* Returns a string that corresponds to the name of the regex character set
621 * given by 'flags', and *lenp is set the length of that string, which
622 * cannot exceed MAX_CHARSET_NAME_LENGTH characters */
623
624 *lenp = 1;
625 switch (get_regex_charset(flags)) {
626 case REGEX_DEPENDS_CHARSET: return DEPENDS_PAT_MODS;
627 case REGEX_LOCALE_CHARSET: return LOCALE_PAT_MODS;
628 case REGEX_UNICODE_CHARSET: return UNICODE_PAT_MODS;
629 case REGEX_ASCII_RESTRICTED_CHARSET: return ASCII_RESTRICT_PAT_MODS;
630 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
631 *lenp = 2;
632 return ASCII_MORE_RESTRICT_PAT_MODS;
633 }
634 /* The NOT_REACHED; hides an assert() which has a rather complex
635 * definition in perl.h. */
636 NOT_REACHED; /* NOTREACHED */
637 return "?"; /* Unknown */
638}
639
7cb3f959 640/*
ed382232
TC
641
642Return false if any get magic is on the SV other than taint magic.
643
644*/
645
646PERL_STATIC_INLINE bool
647S_sv_only_taint_gmagic(SV *sv) {
648 MAGIC *mg = SvMAGIC(sv);
649
650 PERL_ARGS_ASSERT_SV_ONLY_TAINT_GMAGIC;
651
652 while (mg) {
653 if (mg->mg_type != PERL_MAGIC_taint
654 && !(mg->mg_flags & MGf_GSKIP)
655 && mg->mg_virtual->svt_get) {
656 return FALSE;
657 }
658 mg = mg->mg_moremagic;
659 }
660
661 return TRUE;
662}
663
ed8ff0f3
DM
664/* ------------------ cop.h ------------------------------------------- */
665
666
667/* Enter a block. Push a new base context and return its address. */
668
669PERL_STATIC_INLINE PERL_CONTEXT *
670S_cx_pushblock(pTHX_ U8 type, U8 gimme, SV** sp, I32 saveix)
671{
672 PERL_CONTEXT * cx;
673
674 PERL_ARGS_ASSERT_CX_PUSHBLOCK;
675
676 CXINC;
677 cx = CX_CUR();
678 cx->cx_type = type;
679 cx->blk_gimme = gimme;
680 cx->blk_oldsaveix = saveix;
4caf7d8c 681 cx->blk_oldsp = (I32)(sp - PL_stack_base);
ed8ff0f3 682 cx->blk_oldcop = PL_curcop;
4caf7d8c 683 cx->blk_oldmarksp = (I32)(PL_markstack_ptr - PL_markstack);
ed8ff0f3
DM
684 cx->blk_oldscopesp = PL_scopestack_ix;
685 cx->blk_oldpm = PL_curpm;
ce8bb8d8 686 cx->blk_old_tmpsfloor = PL_tmps_floor;
ed8ff0f3
DM
687
688 PL_tmps_floor = PL_tmps_ix;
689 CX_DEBUG(cx, "PUSH");
690 return cx;
691}
692
693
694/* Exit a block (RETURN and LAST). */
695
696PERL_STATIC_INLINE void
697S_cx_popblock(pTHX_ PERL_CONTEXT *cx)
698{
699 PERL_ARGS_ASSERT_CX_POPBLOCK;
700
701 CX_DEBUG(cx, "POP");
702 /* these 3 are common to cx_popblock and cx_topblock */
703 PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp;
704 PL_scopestack_ix = cx->blk_oldscopesp;
705 PL_curpm = cx->blk_oldpm;
706
707 /* LEAVE_SCOPE() should have made this true. /(?{})/ cheats
708 * and leaves a CX entry lying around for repeated use, so
709 * skip for multicall */ \
710 assert( (CxTYPE(cx) == CXt_SUB && CxMULTICALL(cx))
711 || PL_savestack_ix == cx->blk_oldsaveix);
712 PL_curcop = cx->blk_oldcop;
ce8bb8d8 713 PL_tmps_floor = cx->blk_old_tmpsfloor;
ed8ff0f3
DM
714}
715
716/* Continue a block elsewhere (e.g. NEXT, REDO, GOTO).
717 * Whereas cx_popblock() restores the state to the point just before
718 * cx_pushblock() was called, cx_topblock() restores it to the point just
719 * *after* cx_pushblock() was called. */
720
721PERL_STATIC_INLINE void
722S_cx_topblock(pTHX_ PERL_CONTEXT *cx)
723{
724 PERL_ARGS_ASSERT_CX_TOPBLOCK;
725
726 CX_DEBUG(cx, "TOP");
727 /* these 3 are common to cx_popblock and cx_topblock */
728 PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp;
729 PL_scopestack_ix = cx->blk_oldscopesp;
730 PL_curpm = cx->blk_oldpm;
731
732 PL_stack_sp = PL_stack_base + cx->blk_oldsp;
733}
734
735
a73d8813
DM
736PERL_STATIC_INLINE void
737S_cx_pushsub(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, bool hasargs)
738{
739 U8 phlags = CX_PUSHSUB_GET_LVALUE_MASK(Perl_was_lvalue_sub);
740
741 PERL_ARGS_ASSERT_CX_PUSHSUB;
742
3f6bd23a 743 PERL_DTRACE_PROBE_ENTRY(cv);
a73d8813
DM
744 cx->blk_sub.cv = cv;
745 cx->blk_sub.olddepth = CvDEPTH(cv);
746 cx->blk_sub.prevcomppad = PL_comppad;
747 cx->cx_type |= (hasargs) ? CXp_HASARGS : 0;
748 cx->blk_sub.retop = retop;
749 SvREFCNT_inc_simple_void_NN(cv);
750 cx->blk_u16 = PL_op->op_private & (phlags|OPpDEREF);
751}
752
753
754/* subsets of cx_popsub() */
755
756PERL_STATIC_INLINE void
757S_cx_popsub_common(pTHX_ PERL_CONTEXT *cx)
758{
759 CV *cv;
760
761 PERL_ARGS_ASSERT_CX_POPSUB_COMMON;
762 assert(CxTYPE(cx) == CXt_SUB);
763
764 PL_comppad = cx->blk_sub.prevcomppad;
765 PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
766 cv = cx->blk_sub.cv;
767 CvDEPTH(cv) = cx->blk_sub.olddepth;
768 cx->blk_sub.cv = NULL;
769 SvREFCNT_dec(cv);
770}
771
772
773/* handle the @_ part of leaving a sub */
774
775PERL_STATIC_INLINE void
776S_cx_popsub_args(pTHX_ PERL_CONTEXT *cx)
777{
778 AV *av;
779
780 PERL_ARGS_ASSERT_CX_POPSUB_ARGS;
781 assert(CxTYPE(cx) == CXt_SUB);
782 assert(AvARRAY(MUTABLE_AV(
783 PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
784 CvDEPTH(cx->blk_sub.cv)])) == PL_curpad);
785
786 CX_POP_SAVEARRAY(cx);
787 av = MUTABLE_AV(PAD_SVl(0));
788 if (UNLIKELY(AvREAL(av)))
789 /* abandon @_ if it got reified */
790 clear_defarray(av, 0);
791 else {
792 CLEAR_ARGARRAY(av);
793 }
794}
795
796
797PERL_STATIC_INLINE void
798S_cx_popsub(pTHX_ PERL_CONTEXT *cx)
799{
800 PERL_ARGS_ASSERT_CX_POPSUB;
801 assert(CxTYPE(cx) == CXt_SUB);
802
3f6bd23a 803 PERL_DTRACE_PROBE_RETURN(cx->blk_sub.cv);
a73d8813
DM
804
805 if (CxHASARGS(cx))
806 cx_popsub_args(cx);
807 cx_popsub_common(cx);
808}
809
810
6a7d52cc
DM
811PERL_STATIC_INLINE void
812S_cx_pushformat(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, GV *gv)
813{
814 PERL_ARGS_ASSERT_CX_PUSHFORMAT;
815
816 cx->blk_format.cv = cv;
817 cx->blk_format.retop = retop;
818 cx->blk_format.gv = gv;
819 cx->blk_format.dfoutgv = PL_defoutgv;
820 cx->blk_format.prevcomppad = PL_comppad;
821 cx->blk_u16 = 0;
822
823 SvREFCNT_inc_simple_void_NN(cv);
824 CvDEPTH(cv)++;
825 SvREFCNT_inc_void(cx->blk_format.dfoutgv);
826}
827
828
829PERL_STATIC_INLINE void
830S_cx_popformat(pTHX_ PERL_CONTEXT *cx)
831{
832 CV *cv;
833 GV *dfout;
834
835 PERL_ARGS_ASSERT_CX_POPFORMAT;
836 assert(CxTYPE(cx) == CXt_FORMAT);
837
838 dfout = cx->blk_format.dfoutgv;
839 setdefout(dfout);
840 cx->blk_format.dfoutgv = NULL;
841 SvREFCNT_dec_NN(dfout);
842
843 PL_comppad = cx->blk_format.prevcomppad;
844 PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
845 cv = cx->blk_format.cv;
846 cx->blk_format.cv = NULL;
847 --CvDEPTH(cv);
848 SvREFCNT_dec_NN(cv);
849}
850
851
13febba5
DM
852PERL_STATIC_INLINE void
853S_cx_pusheval(pTHX_ PERL_CONTEXT *cx, OP *retop, SV *namesv)
854{
855 PERL_ARGS_ASSERT_CX_PUSHEVAL;
856
857 cx->blk_eval.retop = retop;
858 cx->blk_eval.old_namesv = namesv;
859 cx->blk_eval.old_eval_root = PL_eval_root;
860 cx->blk_eval.cur_text = PL_parser ? PL_parser->linestr : NULL;
861 cx->blk_eval.cv = NULL; /* later set by doeval_compile() */
862 cx->blk_eval.cur_top_env = PL_top_env;
863
864 assert(!(PL_in_eval & ~ 0x7F));
865 assert(!(PL_op->op_type & ~0x1FF));
866 cx->blk_u16 = (PL_in_eval & 0x7F) | ((U16)PL_op->op_type << 7);
867}
868
869
870PERL_STATIC_INLINE void
871S_cx_popeval(pTHX_ PERL_CONTEXT *cx)
872{
873 SV *sv;
874
875 PERL_ARGS_ASSERT_CX_POPEVAL;
876 assert(CxTYPE(cx) == CXt_EVAL);
877
878 PL_in_eval = CxOLD_IN_EVAL(cx);
879 PL_eval_root = cx->blk_eval.old_eval_root;
880 sv = cx->blk_eval.cur_text;
881 if (sv && SvSCREAM(sv)) {
882 cx->blk_eval.cur_text = NULL;
883 SvREFCNT_dec_NN(sv);
884 }
885
886 sv = cx->blk_eval.old_namesv;
2a1e0dfe
DM
887 if (sv) {
888 cx->blk_eval.old_namesv = NULL;
889 SvREFCNT_dec_NN(sv);
890 }
13febba5 891}
6a7d52cc 892
a73d8813 893
d1b6bf72
DM
894/* push a plain loop, i.e.
895 * { block }
896 * while (cond) { block }
897 * for (init;cond;continue) { block }
898 * This loop can be last/redo'ed etc.
899 */
900
901PERL_STATIC_INLINE void
902S_cx_pushloop_plain(pTHX_ PERL_CONTEXT *cx)
903{
904 PERL_ARGS_ASSERT_CX_PUSHLOOP_PLAIN;
905 cx->blk_loop.my_op = cLOOP;
906}
907
908
909/* push a true for loop, i.e.
910 * for var (list) { block }
911 */
912
913PERL_STATIC_INLINE void
914S_cx_pushloop_for(pTHX_ PERL_CONTEXT *cx, void *itervarp, SV* itersave)
915{
916 PERL_ARGS_ASSERT_CX_PUSHLOOP_FOR;
917
918 /* this one line is common with cx_pushloop_plain */
919 cx->blk_loop.my_op = cLOOP;
920
921 cx->blk_loop.itervar_u.svp = (SV**)itervarp;
922 cx->blk_loop.itersave = itersave;
923#ifdef USE_ITHREADS
924 cx->blk_loop.oldcomppad = PL_comppad;
925#endif
926}
927
928
929/* pop all loop types, including plain */
930
931PERL_STATIC_INLINE void
932S_cx_poploop(pTHX_ PERL_CONTEXT *cx)
933{
934 PERL_ARGS_ASSERT_CX_POPLOOP;
935
936 assert(CxTYPE_is_LOOP(cx));
937 if ( CxTYPE(cx) == CXt_LOOP_ARY
938 || CxTYPE(cx) == CXt_LOOP_LAZYSV)
939 {
940 /* Free ary or cur. This assumes that state_u.ary.ary
941 * aligns with state_u.lazysv.cur. See cx_dup() */
942 SV *sv = cx->blk_loop.state_u.lazysv.cur;
943 cx->blk_loop.state_u.lazysv.cur = NULL;
944 SvREFCNT_dec_NN(sv);
945 if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
946 sv = cx->blk_loop.state_u.lazysv.end;
947 cx->blk_loop.state_u.lazysv.end = NULL;
948 SvREFCNT_dec_NN(sv);
949 }
950 }
951 if (cx->cx_type & (CXp_FOR_PAD|CXp_FOR_GV)) {
952 SV *cursv;
953 SV **svp = (cx)->blk_loop.itervar_u.svp;
954 if ((cx->cx_type & CXp_FOR_GV))
955 svp = &GvSV((GV*)svp);
956 cursv = *svp;
957 *svp = cx->blk_loop.itersave;
958 cx->blk_loop.itersave = NULL;
959 SvREFCNT_dec(cursv);
960 }
961}
962
2a7b7c61
DM
963
964PERL_STATIC_INLINE void
965S_cx_pushwhen(pTHX_ PERL_CONTEXT *cx)
966{
967 PERL_ARGS_ASSERT_CX_PUSHWHEN;
968
969 cx->blk_givwhen.leave_op = cLOGOP->op_other;
970}
971
972
973PERL_STATIC_INLINE void
974S_cx_popwhen(pTHX_ PERL_CONTEXT *cx)
975{
976 PERL_ARGS_ASSERT_CX_POPWHEN;
977 assert(CxTYPE(cx) == CXt_WHEN);
978
979 PERL_UNUSED_ARG(cx);
59a14f30 980 PERL_UNUSED_CONTEXT;
2a7b7c61
DM
981 /* currently NOOP */
982}
983
984
985PERL_STATIC_INLINE void
986S_cx_pushgiven(pTHX_ PERL_CONTEXT *cx, SV *orig_defsv)
987{
988 PERL_ARGS_ASSERT_CX_PUSHGIVEN;
989
990 cx->blk_givwhen.leave_op = cLOGOP->op_other;
991 cx->blk_givwhen.defsv_save = orig_defsv;
992}
993
994
995PERL_STATIC_INLINE void
996S_cx_popgiven(pTHX_ PERL_CONTEXT *cx)
997{
998 SV *sv;
999
1000 PERL_ARGS_ASSERT_CX_POPGIVEN;
1001 assert(CxTYPE(cx) == CXt_GIVEN);
1002
1003 sv = GvSV(PL_defgv);
1004 GvSV(PL_defgv) = cx->blk_givwhen.defsv_save;
1005 cx->blk_givwhen.defsv_save = NULL;
1006 SvREFCNT_dec(sv);
1007}
1008
ed382232 1009/*
c8028aa6
TC
1010 * ex: set ts=8 sts=4 sw=4 et:
1011 */