This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
perlapi: Minor clarifications to sv_utf8_decode
[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{
c41b2540 293 const UV expectlen = UTF8SKIP(s);
2fe720e2
KW
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
82c5d941 326Returns TRUE if the first C<len> bytes of the string C<s> are the same
1e599354 327regardless of the UTF-8 encoding of the string (or UTF-EBCDIC encoding on
82c5d941
KW
328EBCDIC machines); otherwise it returns FALSE. That is, it returns TRUE if they
329are UTF-8 invariant. On ASCII-ish machines, all the ASCII characters and only
330the ASCII characters fit this definition. On EBCDIC machines, the ASCII-range
331characters are invariant, but so also are the C1 controls.
1e599354
KW
332
333If C<len> is 0, it will be calculated using C<strlen(s)>, (which means if you
334use this option, that C<s> can't have embedded C<NUL> characters and has to
335have a terminating C<NUL> byte).
336
337See also L</is_utf8_string>(), L</is_utf8_string_loclen>(), and
338L</is_utf8_string_loc>().
339
340=cut
341*/
342
343PERL_STATIC_INLINE bool
344S_is_utf8_invariant_string(const U8* const s, const STRLEN len)
345{
346 const U8* const send = s + (len ? len : strlen((const char *)s));
347 const U8* x = s;
348
349 PERL_ARGS_ASSERT_IS_UTF8_INVARIANT_STRING;
350
351 for (; x < send; ++x) {
352 if (!UTF8_IS_INVARIANT(*x))
353 return FALSE;
354 }
355
356 return TRUE;
357}
358
7c93d8f0 359/*
5ff889fb
KW
360=for apidoc is_utf8_string
361
82c5d941
KW
362Returns TRUE if the first C<len> bytes of string C<s> form a valid
363Perl-extended-UTF-8 string; returns FALSE otherwise. If C<len> is 0, it will
364be calculated using C<strlen(s)> (which means if you use this option, that C<s>
365can't have embedded C<NUL> characters and has to have a terminating C<NUL>
366byte). Note that all characters being ASCII constitute 'a valid UTF-8 string'.
367
368Code points above Unicode, surrogates, and non-character code points are
369considered valid by this function.
5ff889fb
KW
370
371See also L</is_utf8_invariant_string>(), L</is_utf8_string_loclen>(), and
372L</is_utf8_string_loc>().
373
374=cut
375*/
376
56e4cf64 377PERL_STATIC_INLINE bool
c41b2540 378Perl_is_utf8_string(const U8 *s, const STRLEN len)
5ff889fb 379{
35936d22
KW
380 /* This is now marked pure in embed.fnc, because isUTF8_CHAR now is pure.
381 * Be aware of possible changes to that */
382
5ff889fb
KW
383 const U8* const send = s + (len ? len : strlen((const char *)s));
384 const U8* x = s;
385
386 PERL_ARGS_ASSERT_IS_UTF8_STRING;
387
388 while (x < send) {
c41b2540
KW
389 const STRLEN cur_len = isUTF8_CHAR(x, send);
390 if (UNLIKELY(! cur_len)) {
5ff889fb
KW
391 return FALSE;
392 }
c41b2540 393 x += cur_len;
5ff889fb
KW
394 }
395
396 return TRUE;
397}
398
399/*
400Implemented as a macro in utf8.h
401
402=for apidoc is_utf8_string_loc
403
404Like L</is_utf8_string> but stores the location of the failure (in the
405case of "utf8ness failure") or the location C<s>+C<len> (in the case of
82c5d941 406"utf8ness success") in the C<ep> pointer.
5ff889fb
KW
407
408See also L</is_utf8_string_loclen>() and L</is_utf8_string>().
409
410=for apidoc is_utf8_string_loclen
411
412Like L</is_utf8_string>() but stores the location of the failure (in the
413case of "utf8ness failure") or the location C<s>+C<len> (in the case of
414"utf8ness success") in the C<ep>, and the number of UTF-8
82c5d941 415encoded characters in the C<el> pointer.
5ff889fb
KW
416
417See also L</is_utf8_string_loc>() and L</is_utf8_string>().
418
419=cut
420*/
421
56e4cf64 422PERL_STATIC_INLINE bool
c41b2540 423Perl_is_utf8_string_loclen(const U8 *s, const STRLEN len, const U8 **ep, STRLEN *el)
5ff889fb
KW
424{
425 const U8* const send = s + (len ? len : strlen((const char *)s));
426 const U8* x = s;
427 STRLEN outlen = 0;
428
429 PERL_ARGS_ASSERT_IS_UTF8_STRING_LOCLEN;
430
431 while (x < send) {
c41b2540
KW
432 const STRLEN cur_len = isUTF8_CHAR(x, send);
433 if (UNLIKELY(! cur_len)) {
5ff889fb
KW
434 break;
435 }
c41b2540 436 x += cur_len;
5ff889fb
KW
437 outlen++;
438 }
439
440 if (el)
441 *el = outlen;
442
443 if (ep) {
444 *ep = x;
445 }
446
447 return (x == send);
448}
449
450/*
7c93d8f0
KW
451=for apidoc utf8_distance
452
453Returns the number of UTF-8 characters between the UTF-8 pointers C<a>
454and C<b>.
455
456WARNING: use only if you *know* that the pointers point inside the
457same UTF-8 buffer.
458
459=cut
460*/
461
462PERL_STATIC_INLINE IV
463Perl_utf8_distance(pTHX_ const U8 *a, const U8 *b)
464{
465 PERL_ARGS_ASSERT_UTF8_DISTANCE;
466
467 return (a < b) ? -1 * (IV) utf8_length(a, b) : (IV) utf8_length(b, a);
468}
469
470/*
471=for apidoc utf8_hop
472
473Return the UTF-8 pointer C<s> displaced by C<off> characters, either
474forward or backward.
475
476WARNING: do not use the following unless you *know* C<off> is within
477the UTF-8 data pointed to by C<s> *and* that on entry C<s> is aligned
478on the first byte of character or just after the last byte of a character.
479
480=cut
481*/
482
483PERL_STATIC_INLINE U8 *
484Perl_utf8_hop(const U8 *s, SSize_t off)
485{
486 PERL_ARGS_ASSERT_UTF8_HOP;
487
488 /* Note: cannot use UTF8_IS_...() too eagerly here since e.g
489 * the bitops (especially ~) can create illegal UTF-8.
490 * In other words: in Perl UTF-8 is not just for Unicode. */
491
492 if (off >= 0) {
493 while (off--)
494 s += UTF8SKIP(s);
495 }
496 else {
497 while (off++) {
498 s--;
499 while (UTF8_IS_CONTINUATION(*s))
500 s--;
501 }
502 }
503 return (U8 *)s;
504}
505
4dab108f
KW
506/*
507
508=for apidoc is_utf8_valid_partial_char
509
6cbb9248
KW
510Returns 0 if the sequence of bytes starting at C<s> and looking no further than
511S<C<e - 1>> is the UTF-8 encoding, as extended by Perl, for one or more code
512points. Otherwise, it returns 1 if there exists at least one non-empty
513sequence of bytes that when appended to sequence C<s>, starting at position
514C<e> causes the entire sequence to be the well-formed UTF-8 of some code point;
515otherwise returns 0.
516
517In other words this returns TRUE if C<s> points to a partial UTF-8-encoded code
518point.
519
520This is useful when a fixed-length buffer is being tested for being well-formed
521UTF-8, but the final few bytes in it don't comprise a full character; that is,
522it is split somewhere in the middle of the final code point's UTF-8
523representation. (Presumably when the buffer is refreshed with the next chunk
524of data, the new first bytes will complete the partial code point.) This
525function is used to verify that the final bytes in the current buffer are in
526fact the legal beginning of some code point, so that if they aren't, the
527failure can be signalled without having to wait for the next read.
4dab108f
KW
528
529=cut
530*/
f1c999a7
KW
531#define is_utf8_valid_partial_char(s, e) is_utf8_valid_partial_char_flags(s, e, 0)
532
533/*
534
535=for apidoc is_utf8_valid_partial_char_flags
536
537Like C<L</is_utf8_valid_partial_char>>, it returns a boolean giving whether
538or not the input is a valid UTF-8 encoded partial character, but it takes an
539extra parameter, C<flags>, which can further restrict which code points are
540considered valid.
541
542If C<flags> is 0, this behaves identically to
543C<L</is_utf8_valid_partial_char>>. Otherwise C<flags> can be any combination
544of the C<UTF8_DISALLOW_I<foo>> flags accepted by C<L</utf8n_to_uvchr>>. If
545there is any sequence of bytes that can complete the input partial character in
546such a way that a non-prohibited character is formed, the function returns
547TRUE; otherwise FALSE. Non characters cannot be determined based on partial
548character input. But many of the other possible excluded types can be
549determined from just the first one or two bytes.
550
551=cut
552 */
553
56e4cf64 554PERL_STATIC_INLINE bool
f1c999a7 555S_is_utf8_valid_partial_char_flags(const U8 * const s, const U8 * const e, const U32 flags)
4dab108f 556{
f1c999a7 557 PERL_ARGS_ASSERT_IS_UTF8_VALID_PARTIAL_CHAR_FLAGS;
4dab108f 558
f1c999a7
KW
559 assert(0 == (flags & ~(UTF8_DISALLOW_ILLEGAL_INTERCHANGE
560 |UTF8_DISALLOW_ABOVE_31_BIT)));
4dab108f 561
8875bd48 562 if (s >= e || s + UTF8SKIP(s) <= e) {
4dab108f
KW
563 return FALSE;
564 }
565
f1c999a7 566 return cBOOL(_is_utf8_char_helper(s, e, flags));
4dab108f
KW
567}
568
c8028aa6
TC
569/* ------------------------------- perl.h ----------------------------- */
570
571/*
dcccc8ff
KW
572=head1 Miscellaneous Functions
573
41188aa0 574=for apidoc AiR|bool|is_safe_syscall|const char *pv|STRLEN len|const char *what|const char *op_name
c8028aa6 575
6602b933 576Test that the given C<pv> doesn't contain any internal C<NUL> characters.
796b6530 577If it does, set C<errno> to C<ENOENT>, optionally warn, and return FALSE.
c8028aa6
TC
578
579Return TRUE if the name is safe.
580
796b6530 581Used by the C<IS_SAFE_SYSCALL()> macro.
c8028aa6
TC
582
583=cut
584*/
585
586PERL_STATIC_INLINE bool
41188aa0 587S_is_safe_syscall(pTHX_ const char *pv, STRLEN len, const char *what, const char *op_name) {
c8028aa6
TC
588 /* While the Windows CE API provides only UCS-16 (or UTF-16) APIs
589 * perl itself uses xce*() functions which accept 8-bit strings.
590 */
591
592 PERL_ARGS_ASSERT_IS_SAFE_SYSCALL;
593
6c4650b3 594 if (len > 1) {
c8028aa6 595 char *null_at;
41188aa0 596 if (UNLIKELY((null_at = (char *)memchr(pv, 0, len-1)) != NULL)) {
c8028aa6 597 SETERRNO(ENOENT, LIB_INVARG);
1d505182 598 Perl_ck_warner(aTHX_ packWARN(WARN_SYSCALLS),
c8028aa6 599 "Invalid \\0 character in %s for %s: %s\\0%s",
41188aa0 600 what, op_name, pv, null_at+1);
c8028aa6
TC
601 return FALSE;
602 }
603 }
604
605 return TRUE;
606}
607
608/*
7cb3f959
TC
609
610Return true if the supplied filename has a newline character
fa6c7d00 611immediately before the first (hopefully only) NUL.
7cb3f959
TC
612
613My original look at this incorrectly used the len from SvPV(), but
614that's incorrect, since we allow for a NUL in pv[len-1].
615
616So instead, strlen() and work from there.
617
618This allow for the user reading a filename, forgetting to chomp it,
619then calling:
620
621 open my $foo, "$file\0";
622
623*/
624
625#ifdef PERL_CORE
626
627PERL_STATIC_INLINE bool
628S_should_warn_nl(const char *pv) {
629 STRLEN len;
630
631 PERL_ARGS_ASSERT_SHOULD_WARN_NL;
632
633 len = strlen(pv);
634
635 return len > 0 && pv[len-1] == '\n';
636}
637
638#endif
639
81d52ecd
JH
640/* ------------------ pp.c, regcomp.c, toke.c, universal.c ------------ */
641
642#define MAX_CHARSET_NAME_LENGTH 2
643
644PERL_STATIC_INLINE const char *
645get_regex_charset_name(const U32 flags, STRLEN* const lenp)
646{
647 /* Returns a string that corresponds to the name of the regex character set
648 * given by 'flags', and *lenp is set the length of that string, which
649 * cannot exceed MAX_CHARSET_NAME_LENGTH characters */
650
651 *lenp = 1;
652 switch (get_regex_charset(flags)) {
653 case REGEX_DEPENDS_CHARSET: return DEPENDS_PAT_MODS;
654 case REGEX_LOCALE_CHARSET: return LOCALE_PAT_MODS;
655 case REGEX_UNICODE_CHARSET: return UNICODE_PAT_MODS;
656 case REGEX_ASCII_RESTRICTED_CHARSET: return ASCII_RESTRICT_PAT_MODS;
657 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
658 *lenp = 2;
659 return ASCII_MORE_RESTRICT_PAT_MODS;
660 }
661 /* The NOT_REACHED; hides an assert() which has a rather complex
662 * definition in perl.h. */
663 NOT_REACHED; /* NOTREACHED */
664 return "?"; /* Unknown */
665}
666
7cb3f959 667/*
ed382232
TC
668
669Return false if any get magic is on the SV other than taint magic.
670
671*/
672
673PERL_STATIC_INLINE bool
674S_sv_only_taint_gmagic(SV *sv) {
675 MAGIC *mg = SvMAGIC(sv);
676
677 PERL_ARGS_ASSERT_SV_ONLY_TAINT_GMAGIC;
678
679 while (mg) {
680 if (mg->mg_type != PERL_MAGIC_taint
681 && !(mg->mg_flags & MGf_GSKIP)
682 && mg->mg_virtual->svt_get) {
683 return FALSE;
684 }
685 mg = mg->mg_moremagic;
686 }
687
688 return TRUE;
689}
690
ed8ff0f3
DM
691/* ------------------ cop.h ------------------------------------------- */
692
693
694/* Enter a block. Push a new base context and return its address. */
695
696PERL_STATIC_INLINE PERL_CONTEXT *
697S_cx_pushblock(pTHX_ U8 type, U8 gimme, SV** sp, I32 saveix)
698{
699 PERL_CONTEXT * cx;
700
701 PERL_ARGS_ASSERT_CX_PUSHBLOCK;
702
703 CXINC;
704 cx = CX_CUR();
705 cx->cx_type = type;
706 cx->blk_gimme = gimme;
707 cx->blk_oldsaveix = saveix;
4caf7d8c 708 cx->blk_oldsp = (I32)(sp - PL_stack_base);
ed8ff0f3 709 cx->blk_oldcop = PL_curcop;
4caf7d8c 710 cx->blk_oldmarksp = (I32)(PL_markstack_ptr - PL_markstack);
ed8ff0f3
DM
711 cx->blk_oldscopesp = PL_scopestack_ix;
712 cx->blk_oldpm = PL_curpm;
ce8bb8d8 713 cx->blk_old_tmpsfloor = PL_tmps_floor;
ed8ff0f3
DM
714
715 PL_tmps_floor = PL_tmps_ix;
716 CX_DEBUG(cx, "PUSH");
717 return cx;
718}
719
720
721/* Exit a block (RETURN and LAST). */
722
723PERL_STATIC_INLINE void
724S_cx_popblock(pTHX_ PERL_CONTEXT *cx)
725{
726 PERL_ARGS_ASSERT_CX_POPBLOCK;
727
728 CX_DEBUG(cx, "POP");
729 /* these 3 are common to cx_popblock and cx_topblock */
730 PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp;
731 PL_scopestack_ix = cx->blk_oldscopesp;
732 PL_curpm = cx->blk_oldpm;
733
734 /* LEAVE_SCOPE() should have made this true. /(?{})/ cheats
735 * and leaves a CX entry lying around for repeated use, so
736 * skip for multicall */ \
737 assert( (CxTYPE(cx) == CXt_SUB && CxMULTICALL(cx))
738 || PL_savestack_ix == cx->blk_oldsaveix);
739 PL_curcop = cx->blk_oldcop;
ce8bb8d8 740 PL_tmps_floor = cx->blk_old_tmpsfloor;
ed8ff0f3
DM
741}
742
743/* Continue a block elsewhere (e.g. NEXT, REDO, GOTO).
744 * Whereas cx_popblock() restores the state to the point just before
745 * cx_pushblock() was called, cx_topblock() restores it to the point just
746 * *after* cx_pushblock() was called. */
747
748PERL_STATIC_INLINE void
749S_cx_topblock(pTHX_ PERL_CONTEXT *cx)
750{
751 PERL_ARGS_ASSERT_CX_TOPBLOCK;
752
753 CX_DEBUG(cx, "TOP");
754 /* these 3 are common to cx_popblock and cx_topblock */
755 PL_markstack_ptr = PL_markstack + cx->blk_oldmarksp;
756 PL_scopestack_ix = cx->blk_oldscopesp;
757 PL_curpm = cx->blk_oldpm;
758
759 PL_stack_sp = PL_stack_base + cx->blk_oldsp;
760}
761
762
a73d8813
DM
763PERL_STATIC_INLINE void
764S_cx_pushsub(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, bool hasargs)
765{
766 U8 phlags = CX_PUSHSUB_GET_LVALUE_MASK(Perl_was_lvalue_sub);
767
768 PERL_ARGS_ASSERT_CX_PUSHSUB;
769
3f6bd23a 770 PERL_DTRACE_PROBE_ENTRY(cv);
a73d8813
DM
771 cx->blk_sub.cv = cv;
772 cx->blk_sub.olddepth = CvDEPTH(cv);
773 cx->blk_sub.prevcomppad = PL_comppad;
774 cx->cx_type |= (hasargs) ? CXp_HASARGS : 0;
775 cx->blk_sub.retop = retop;
776 SvREFCNT_inc_simple_void_NN(cv);
777 cx->blk_u16 = PL_op->op_private & (phlags|OPpDEREF);
778}
779
780
781/* subsets of cx_popsub() */
782
783PERL_STATIC_INLINE void
784S_cx_popsub_common(pTHX_ PERL_CONTEXT *cx)
785{
786 CV *cv;
787
788 PERL_ARGS_ASSERT_CX_POPSUB_COMMON;
789 assert(CxTYPE(cx) == CXt_SUB);
790
791 PL_comppad = cx->blk_sub.prevcomppad;
792 PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
793 cv = cx->blk_sub.cv;
794 CvDEPTH(cv) = cx->blk_sub.olddepth;
795 cx->blk_sub.cv = NULL;
796 SvREFCNT_dec(cv);
797}
798
799
800/* handle the @_ part of leaving a sub */
801
802PERL_STATIC_INLINE void
803S_cx_popsub_args(pTHX_ PERL_CONTEXT *cx)
804{
805 AV *av;
806
807 PERL_ARGS_ASSERT_CX_POPSUB_ARGS;
808 assert(CxTYPE(cx) == CXt_SUB);
809 assert(AvARRAY(MUTABLE_AV(
810 PadlistARRAY(CvPADLIST(cx->blk_sub.cv))[
811 CvDEPTH(cx->blk_sub.cv)])) == PL_curpad);
812
813 CX_POP_SAVEARRAY(cx);
814 av = MUTABLE_AV(PAD_SVl(0));
815 if (UNLIKELY(AvREAL(av)))
816 /* abandon @_ if it got reified */
817 clear_defarray(av, 0);
818 else {
819 CLEAR_ARGARRAY(av);
820 }
821}
822
823
824PERL_STATIC_INLINE void
825S_cx_popsub(pTHX_ PERL_CONTEXT *cx)
826{
827 PERL_ARGS_ASSERT_CX_POPSUB;
828 assert(CxTYPE(cx) == CXt_SUB);
829
3f6bd23a 830 PERL_DTRACE_PROBE_RETURN(cx->blk_sub.cv);
a73d8813
DM
831
832 if (CxHASARGS(cx))
833 cx_popsub_args(cx);
834 cx_popsub_common(cx);
835}
836
837
6a7d52cc
DM
838PERL_STATIC_INLINE void
839S_cx_pushformat(pTHX_ PERL_CONTEXT *cx, CV *cv, OP *retop, GV *gv)
840{
841 PERL_ARGS_ASSERT_CX_PUSHFORMAT;
842
843 cx->blk_format.cv = cv;
844 cx->blk_format.retop = retop;
845 cx->blk_format.gv = gv;
846 cx->blk_format.dfoutgv = PL_defoutgv;
847 cx->blk_format.prevcomppad = PL_comppad;
848 cx->blk_u16 = 0;
849
850 SvREFCNT_inc_simple_void_NN(cv);
851 CvDEPTH(cv)++;
852 SvREFCNT_inc_void(cx->blk_format.dfoutgv);
853}
854
855
856PERL_STATIC_INLINE void
857S_cx_popformat(pTHX_ PERL_CONTEXT *cx)
858{
859 CV *cv;
860 GV *dfout;
861
862 PERL_ARGS_ASSERT_CX_POPFORMAT;
863 assert(CxTYPE(cx) == CXt_FORMAT);
864
865 dfout = cx->blk_format.dfoutgv;
866 setdefout(dfout);
867 cx->blk_format.dfoutgv = NULL;
868 SvREFCNT_dec_NN(dfout);
869
870 PL_comppad = cx->blk_format.prevcomppad;
871 PL_curpad = LIKELY(PL_comppad) ? AvARRAY(PL_comppad) : NULL;
872 cv = cx->blk_format.cv;
873 cx->blk_format.cv = NULL;
874 --CvDEPTH(cv);
875 SvREFCNT_dec_NN(cv);
876}
877
878
13febba5
DM
879PERL_STATIC_INLINE void
880S_cx_pusheval(pTHX_ PERL_CONTEXT *cx, OP *retop, SV *namesv)
881{
882 PERL_ARGS_ASSERT_CX_PUSHEVAL;
883
884 cx->blk_eval.retop = retop;
885 cx->blk_eval.old_namesv = namesv;
886 cx->blk_eval.old_eval_root = PL_eval_root;
887 cx->blk_eval.cur_text = PL_parser ? PL_parser->linestr : NULL;
888 cx->blk_eval.cv = NULL; /* later set by doeval_compile() */
889 cx->blk_eval.cur_top_env = PL_top_env;
890
891 assert(!(PL_in_eval & ~ 0x7F));
892 assert(!(PL_op->op_type & ~0x1FF));
893 cx->blk_u16 = (PL_in_eval & 0x7F) | ((U16)PL_op->op_type << 7);
894}
895
896
897PERL_STATIC_INLINE void
898S_cx_popeval(pTHX_ PERL_CONTEXT *cx)
899{
900 SV *sv;
901
902 PERL_ARGS_ASSERT_CX_POPEVAL;
903 assert(CxTYPE(cx) == CXt_EVAL);
904
905 PL_in_eval = CxOLD_IN_EVAL(cx);
906 PL_eval_root = cx->blk_eval.old_eval_root;
907 sv = cx->blk_eval.cur_text;
908 if (sv && SvSCREAM(sv)) {
909 cx->blk_eval.cur_text = NULL;
910 SvREFCNT_dec_NN(sv);
911 }
912
913 sv = cx->blk_eval.old_namesv;
2a1e0dfe
DM
914 if (sv) {
915 cx->blk_eval.old_namesv = NULL;
916 SvREFCNT_dec_NN(sv);
917 }
13febba5 918}
6a7d52cc 919
a73d8813 920
d1b6bf72
DM
921/* push a plain loop, i.e.
922 * { block }
923 * while (cond) { block }
924 * for (init;cond;continue) { block }
925 * This loop can be last/redo'ed etc.
926 */
927
928PERL_STATIC_INLINE void
929S_cx_pushloop_plain(pTHX_ PERL_CONTEXT *cx)
930{
931 PERL_ARGS_ASSERT_CX_PUSHLOOP_PLAIN;
932 cx->blk_loop.my_op = cLOOP;
933}
934
935
936/* push a true for loop, i.e.
937 * for var (list) { block }
938 */
939
940PERL_STATIC_INLINE void
941S_cx_pushloop_for(pTHX_ PERL_CONTEXT *cx, void *itervarp, SV* itersave)
942{
943 PERL_ARGS_ASSERT_CX_PUSHLOOP_FOR;
944
945 /* this one line is common with cx_pushloop_plain */
946 cx->blk_loop.my_op = cLOOP;
947
948 cx->blk_loop.itervar_u.svp = (SV**)itervarp;
949 cx->blk_loop.itersave = itersave;
950#ifdef USE_ITHREADS
951 cx->blk_loop.oldcomppad = PL_comppad;
952#endif
953}
954
955
956/* pop all loop types, including plain */
957
958PERL_STATIC_INLINE void
959S_cx_poploop(pTHX_ PERL_CONTEXT *cx)
960{
961 PERL_ARGS_ASSERT_CX_POPLOOP;
962
963 assert(CxTYPE_is_LOOP(cx));
964 if ( CxTYPE(cx) == CXt_LOOP_ARY
965 || CxTYPE(cx) == CXt_LOOP_LAZYSV)
966 {
967 /* Free ary or cur. This assumes that state_u.ary.ary
968 * aligns with state_u.lazysv.cur. See cx_dup() */
969 SV *sv = cx->blk_loop.state_u.lazysv.cur;
970 cx->blk_loop.state_u.lazysv.cur = NULL;
971 SvREFCNT_dec_NN(sv);
972 if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
973 sv = cx->blk_loop.state_u.lazysv.end;
974 cx->blk_loop.state_u.lazysv.end = NULL;
975 SvREFCNT_dec_NN(sv);
976 }
977 }
978 if (cx->cx_type & (CXp_FOR_PAD|CXp_FOR_GV)) {
979 SV *cursv;
980 SV **svp = (cx)->blk_loop.itervar_u.svp;
981 if ((cx->cx_type & CXp_FOR_GV))
982 svp = &GvSV((GV*)svp);
983 cursv = *svp;
984 *svp = cx->blk_loop.itersave;
985 cx->blk_loop.itersave = NULL;
986 SvREFCNT_dec(cursv);
987 }
988}
989
2a7b7c61
DM
990
991PERL_STATIC_INLINE void
992S_cx_pushwhen(pTHX_ PERL_CONTEXT *cx)
993{
994 PERL_ARGS_ASSERT_CX_PUSHWHEN;
995
996 cx->blk_givwhen.leave_op = cLOGOP->op_other;
997}
998
999
1000PERL_STATIC_INLINE void
1001S_cx_popwhen(pTHX_ PERL_CONTEXT *cx)
1002{
1003 PERL_ARGS_ASSERT_CX_POPWHEN;
1004 assert(CxTYPE(cx) == CXt_WHEN);
1005
1006 PERL_UNUSED_ARG(cx);
59a14f30 1007 PERL_UNUSED_CONTEXT;
2a7b7c61
DM
1008 /* currently NOOP */
1009}
1010
1011
1012PERL_STATIC_INLINE void
1013S_cx_pushgiven(pTHX_ PERL_CONTEXT *cx, SV *orig_defsv)
1014{
1015 PERL_ARGS_ASSERT_CX_PUSHGIVEN;
1016
1017 cx->blk_givwhen.leave_op = cLOGOP->op_other;
1018 cx->blk_givwhen.defsv_save = orig_defsv;
1019}
1020
1021
1022PERL_STATIC_INLINE void
1023S_cx_popgiven(pTHX_ PERL_CONTEXT *cx)
1024{
1025 SV *sv;
1026
1027 PERL_ARGS_ASSERT_CX_POPGIVEN;
1028 assert(CxTYPE(cx) == CXt_GIVEN);
1029
1030 sv = GvSV(PL_defgv);
1031 GvSV(PL_defgv) = cx->blk_givwhen.defsv_save;
1032 cx->blk_givwhen.defsv_save = NULL;
1033 SvREFCNT_dec(sv);
1034}
1035
ed382232 1036/*
c8028aa6
TC
1037 * ex: set ts=8 sts=4 sw=4 et:
1038 */