This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
For lexical subs, reify CvGV from CvSTASH and CvNAME_HEK
[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
8d919b0a
FC
93/* ----------------------------- regexp.h ----------------------------- */
94
95PERL_STATIC_INLINE struct regexp *
96S_ReANY(const REGEXP * const re)
97{
98 assert(isREGEXP(re));
99 return re->sv_u.svu_rx;
100}
101
27669aa4
FC
102/* ------------------------------- sv.h ------------------------------- */
103
104PERL_STATIC_INLINE SV *
105S_SvREFCNT_inc(SV *sv)
106{
2439e033 107 if (LIKELY(sv != NULL))
27669aa4
FC
108 SvREFCNT(sv)++;
109 return sv;
110}
111PERL_STATIC_INLINE SV *
112S_SvREFCNT_inc_NN(SV *sv)
113{
114 SvREFCNT(sv)++;
115 return sv;
116}
117PERL_STATIC_INLINE void
118S_SvREFCNT_inc_void(SV *sv)
119{
2439e033 120 if (LIKELY(sv != NULL))
27669aa4
FC
121 SvREFCNT(sv)++;
122}
75e16a44
FC
123PERL_STATIC_INLINE void
124S_SvREFCNT_dec(pTHX_ SV *sv)
125{
2439e033 126 if (LIKELY(sv != NULL)) {
75a9bf96 127 U32 rc = SvREFCNT(sv);
79e2a32a 128 if (LIKELY(rc > 1))
75a9bf96
DM
129 SvREFCNT(sv) = rc - 1;
130 else
131 Perl_sv_free2(aTHX_ sv, rc);
75e16a44
FC
132 }
133}
541377b1
FC
134
135PERL_STATIC_INLINE void
4a9a56a7
DM
136S_SvREFCNT_dec_NN(pTHX_ SV *sv)
137{
138 U32 rc = SvREFCNT(sv);
79e2a32a 139 if (LIKELY(rc > 1))
4a9a56a7
DM
140 SvREFCNT(sv) = rc - 1;
141 else
142 Perl_sv_free2(aTHX_ sv, rc);
143}
144
145PERL_STATIC_INLINE void
541377b1
FC
146SvAMAGIC_on(SV *sv)
147{
148 assert(SvROK(sv));
149 if (SvOBJECT(SvRV(sv))) HvAMAGIC_on(SvSTASH(SvRV(sv)));
150}
151PERL_STATIC_INLINE void
152SvAMAGIC_off(SV *sv)
153{
154 if (SvROK(sv) && SvOBJECT(SvRV(sv)))
155 HvAMAGIC_off(SvSTASH(SvRV(sv)));
156}
157
158PERL_STATIC_INLINE U32
159S_SvPADTMP_on(SV *sv)
160{
161 assert(!(SvFLAGS(sv) & SVs_PADMY));
162 return SvFLAGS(sv) |= SVs_PADTMP;
163}
164PERL_STATIC_INLINE U32
165S_SvPADTMP_off(SV *sv)
166{
167 assert(!(SvFLAGS(sv) & SVs_PADMY));
168 return SvFLAGS(sv) &= ~SVs_PADTMP;
169}
170PERL_STATIC_INLINE U32
171S_SvPADSTALE_on(SV *sv)
172{
173 assert(SvFLAGS(sv) & SVs_PADMY);
174 return SvFLAGS(sv) |= SVs_PADSTALE;
175}
176PERL_STATIC_INLINE U32
177S_SvPADSTALE_off(SV *sv)
178{
179 assert(SvFLAGS(sv) & SVs_PADMY);
180 return SvFLAGS(sv) &= ~SVs_PADSTALE;
181}
25fdce4a 182#if defined(PERL_CORE) || defined (PERL_EXT)
4ddea69a 183PERL_STATIC_INLINE STRLEN
6964422a 184S_sv_or_pv_pos_u2b(pTHX_ SV *sv, const char *pv, STRLEN pos, STRLEN *lenp)
4ddea69a 185{
25fdce4a 186 PERL_ARGS_ASSERT_SV_OR_PV_POS_U2B;
4ddea69a
FC
187 if (SvGAMAGIC(sv)) {
188 U8 *hopped = utf8_hop((U8 *)pv, pos);
189 if (lenp) *lenp = (STRLEN)(utf8_hop(hopped, *lenp) - hopped);
190 return (STRLEN)(hopped - (U8 *)pv);
191 }
192 return sv_pos_u2b_flags(sv,pos,lenp,SV_CONST_RETURN);
193}
194#endif
f019c49e 195
d1decf2b
TC
196/* ------------------------------- handy.h ------------------------------- */
197
198/* saves machine code for a common noreturn idiom typically used in Newx*() */
c1d6452f 199#ifdef GCC_DIAG_PRAGMA
6ab56f1e 200GCC_DIAG_IGNORE(-Wunused-function) /* Intentionally left semicolonless. */
c1d6452f 201#endif
d1decf2b
TC
202static void
203S_croak_memory_wrap(void)
204{
205 Perl_croak_nocontext("%s",PL_memory_wrap);
206}
c1d6452f 207#ifdef GCC_DIAG_PRAGMA
6ab56f1e 208GCC_DIAG_RESTORE /* Intentionally left semicolonless. */
c1d6452f 209#endif
d1decf2b 210
a8a2ceaa
KW
211/* ------------------------------- utf8.h ------------------------------- */
212
55d09dc8
KW
213PERL_STATIC_INLINE void
214S_append_utf8_from_native_byte(const U8 byte, U8** dest)
215{
216 /* Takes an input 'byte' (Latin1 or EBCDIC) and appends it to the UTF-8
217 * encoded string at '*dest', updating '*dest' to include it */
218
55d09dc8
KW
219 PERL_ARGS_ASSERT_APPEND_UTF8_FROM_NATIVE_BYTE;
220
6f2d5cbc 221 if (NATIVE_BYTE_IS_INVARIANT(byte))
9ff651ce 222 *(*dest)++ = byte;
55d09dc8 223 else {
9ff651ce
KW
224 *(*dest)++ = UTF8_EIGHT_BIT_HI(byte);
225 *(*dest)++ = UTF8_EIGHT_BIT_LO(byte);
55d09dc8
KW
226 }
227}
228
e123187a 229/*
f2645549 230
6302f837
KW
231A helper function for the macro isUTF8_CHAR(), which should be used instead of
232this function. The macro will handle smaller code points directly saving time,
233using this function as a fall-back for higher code points.
f2645549 234
6302f837
KW
235Tests if the first bytes of string C<s> form a valid UTF-8 character. 0 is
236returned if the bytes starting at C<s> up to but not including C<e> do not form a
237complete well-formed UTF-8 character; otherwise the number of bytes in the
238character is returned.
f2645549 239
6302f837
KW
240Note that an INVARIANT (i.e. ASCII on non-EBCDIC) character is a valid UTF-8
241character.
e123187a
KW
242
243=cut */
244PERL_STATIC_INLINE STRLEN
6302f837 245S__is_utf8_char_slow(const U8 *s, const U8 *e)
e123187a
KW
246{
247 dTHX; /* The function called below requires thread context */
248
249 STRLEN actual_len;
250
251 PERL_ARGS_ASSERT__IS_UTF8_CHAR_SLOW;
252
6302f837
KW
253 assert(e >= s);
254 utf8n_to_uvchr(s, e - s, &actual_len, UTF8_CHECK_ONLY);
e123187a
KW
255
256 return (actual_len == (STRLEN) -1) ? 0 : actual_len;
257}
258
c8028aa6
TC
259/* ------------------------------- perl.h ----------------------------- */
260
261/*
dcccc8ff
KW
262=head1 Miscellaneous Functions
263
41188aa0 264=for apidoc AiR|bool|is_safe_syscall|const char *pv|STRLEN len|const char *what|const char *op_name
c8028aa6 265
6602b933 266Test that the given C<pv> doesn't contain any internal C<NUL> characters.
c8028aa6
TC
267If it does, set C<errno> to ENOENT, optionally warn, and return FALSE.
268
269Return TRUE if the name is safe.
270
271Used by the IS_SAFE_SYSCALL() macro.
272
273=cut
274*/
275
276PERL_STATIC_INLINE bool
41188aa0 277S_is_safe_syscall(pTHX_ const char *pv, STRLEN len, const char *what, const char *op_name) {
c8028aa6
TC
278 /* While the Windows CE API provides only UCS-16 (or UTF-16) APIs
279 * perl itself uses xce*() functions which accept 8-bit strings.
280 */
281
282 PERL_ARGS_ASSERT_IS_SAFE_SYSCALL;
283
41188aa0 284 if (pv && len > 1) {
c8028aa6 285 char *null_at;
41188aa0 286 if (UNLIKELY((null_at = (char *)memchr(pv, 0, len-1)) != NULL)) {
c8028aa6 287 SETERRNO(ENOENT, LIB_INVARG);
1d505182 288 Perl_ck_warner(aTHX_ packWARN(WARN_SYSCALLS),
c8028aa6 289 "Invalid \\0 character in %s for %s: %s\\0%s",
41188aa0 290 what, op_name, pv, null_at+1);
c8028aa6
TC
291 return FALSE;
292 }
293 }
294
295 return TRUE;
296}
297
298/*
7cb3f959
TC
299
300Return true if the supplied filename has a newline character
301immediately before the final NUL.
302
303My original look at this incorrectly used the len from SvPV(), but
304that's incorrect, since we allow for a NUL in pv[len-1].
305
306So instead, strlen() and work from there.
307
308This allow for the user reading a filename, forgetting to chomp it,
309then calling:
310
311 open my $foo, "$file\0";
312
313*/
314
315#ifdef PERL_CORE
316
317PERL_STATIC_INLINE bool
318S_should_warn_nl(const char *pv) {
319 STRLEN len;
320
321 PERL_ARGS_ASSERT_SHOULD_WARN_NL;
322
323 len = strlen(pv);
324
325 return len > 0 && pv[len-1] == '\n';
326}
327
328#endif
329
81d52ecd
JH
330/* ------------------ pp.c, regcomp.c, toke.c, universal.c ------------ */
331
332#define MAX_CHARSET_NAME_LENGTH 2
333
334PERL_STATIC_INLINE const char *
335get_regex_charset_name(const U32 flags, STRLEN* const lenp)
336{
337 /* Returns a string that corresponds to the name of the regex character set
338 * given by 'flags', and *lenp is set the length of that string, which
339 * cannot exceed MAX_CHARSET_NAME_LENGTH characters */
340
341 *lenp = 1;
342 switch (get_regex_charset(flags)) {
343 case REGEX_DEPENDS_CHARSET: return DEPENDS_PAT_MODS;
344 case REGEX_LOCALE_CHARSET: return LOCALE_PAT_MODS;
345 case REGEX_UNICODE_CHARSET: return UNICODE_PAT_MODS;
346 case REGEX_ASCII_RESTRICTED_CHARSET: return ASCII_RESTRICT_PAT_MODS;
347 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
348 *lenp = 2;
349 return ASCII_MORE_RESTRICT_PAT_MODS;
350 }
351 /* The NOT_REACHED; hides an assert() which has a rather complex
352 * definition in perl.h. */
353 NOT_REACHED; /* NOTREACHED */
354 return "?"; /* Unknown */
355}
356
7cb3f959 357/*
c8028aa6
TC
358 * Local variables:
359 * c-indentation-style: bsd
360 * c-basic-offset: 4
361 * indent-tabs-mode: nil
362 * End:
363 *
364 * ex: set ts=8 sts=4 sw=4 et:
365 */