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