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