This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Revert bootstrapping to non-ASCII platforms
[perl5.git] / inline.h
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  */
14
15 /* ------------------------------- av.h ------------------------------- */
16
17 PERL_STATIC_INLINE SSize_t
18 S_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
26 /* ------------------------------- cv.h ------------------------------- */
27
28 PERL_STATIC_INLINE I32 *
29 S_CvDEPTHp(const CV * const sv)
30 {
31     assert(SvTYPE(sv) == SVt_PVCV || SvTYPE(sv) == SVt_PVFM);
32     return &((XPVCV*)SvANY(sv))->xcv_depth;
33 }
34
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
46 #ifdef PERL_CORE
47 PERL_STATIC_INLINE char *
48 S_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 }
63 #endif
64
65 /* ------------------------------- mg.h ------------------------------- */
66
67 #if defined(PERL_CORE) || defined(PERL_EXT)
68 /* assumes get-magic and stringification have already occurred */
69 PERL_STATIC_INLINE STRLEN
70 S_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
85 /* ----------------------------- regexp.h ----------------------------- */
86
87 PERL_STATIC_INLINE struct regexp *
88 S_ReANY(const REGEXP * const re)
89 {
90     assert(isREGEXP(re));
91     return re->sv_u.svu_rx;
92 }
93
94 /* ------------------------------- sv.h ------------------------------- */
95
96 PERL_STATIC_INLINE SV *
97 S_SvREFCNT_inc(SV *sv)
98 {
99     if (LIKELY(sv != NULL))
100         SvREFCNT(sv)++;
101     return sv;
102 }
103 PERL_STATIC_INLINE SV *
104 S_SvREFCNT_inc_NN(SV *sv)
105 {
106     SvREFCNT(sv)++;
107     return sv;
108 }
109 PERL_STATIC_INLINE void
110 S_SvREFCNT_inc_void(SV *sv)
111 {
112     if (LIKELY(sv != NULL))
113         SvREFCNT(sv)++;
114 }
115 PERL_STATIC_INLINE void
116 S_SvREFCNT_dec(pTHX_ SV *sv)
117 {
118     if (LIKELY(sv != NULL)) {
119         U32 rc = SvREFCNT(sv);
120         if (LIKELY(rc > 1))
121             SvREFCNT(sv) = rc - 1;
122         else
123             Perl_sv_free2(aTHX_ sv, rc);
124     }
125 }
126
127 PERL_STATIC_INLINE void
128 S_SvREFCNT_dec_NN(pTHX_ SV *sv)
129 {
130     U32 rc = SvREFCNT(sv);
131     if (LIKELY(rc > 1))
132         SvREFCNT(sv) = rc - 1;
133     else
134         Perl_sv_free2(aTHX_ sv, rc);
135 }
136
137 PERL_STATIC_INLINE void
138 SvAMAGIC_on(SV *sv)
139 {
140     assert(SvROK(sv));
141     if (SvOBJECT(SvRV(sv))) HvAMAGIC_on(SvSTASH(SvRV(sv)));
142 }
143 PERL_STATIC_INLINE void
144 SvAMAGIC_off(SV *sv)
145 {
146     if (SvROK(sv) && SvOBJECT(SvRV(sv)))
147         HvAMAGIC_off(SvSTASH(SvRV(sv)));
148 }
149
150 PERL_STATIC_INLINE U32
151 S_SvPADTMP_on(SV *sv)
152 {
153     assert(!(SvFLAGS(sv) & SVs_PADMY));
154     return SvFLAGS(sv) |= SVs_PADTMP;
155 }
156 PERL_STATIC_INLINE U32
157 S_SvPADTMP_off(SV *sv)
158 {
159     assert(!(SvFLAGS(sv) & SVs_PADMY));
160     return SvFLAGS(sv) &= ~SVs_PADTMP;
161 }
162 PERL_STATIC_INLINE U32
163 S_SvPADSTALE_on(SV *sv)
164 {
165     assert(SvFLAGS(sv) & SVs_PADMY);
166     return SvFLAGS(sv) |= SVs_PADSTALE;
167 }
168 PERL_STATIC_INLINE U32
169 S_SvPADSTALE_off(SV *sv)
170 {
171     assert(SvFLAGS(sv) & SVs_PADMY);
172     return SvFLAGS(sv) &= ~SVs_PADSTALE;
173 }
174 #if defined(PERL_CORE) || defined (PERL_EXT)
175 PERL_STATIC_INLINE STRLEN
176 S_sv_or_pv_pos_u2b(pTHX_ SV *sv, const char *pv, STRLEN pos, STRLEN *lenp)
177 {
178     PERL_ARGS_ASSERT_SV_OR_PV_POS_U2B;
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
187
188 /* ------------------------------- handy.h ------------------------------- */
189
190 /* saves machine code for a common noreturn idiom typically used in Newx*() */
191 #ifdef __clang__
192 #pragma clang diagnostic push
193 #pragma clang diagnostic ignored "-Wunused-function"
194 #endif
195 static void
196 S_croak_memory_wrap(void)
197 {
198     Perl_croak_nocontext("%s",PL_memory_wrap);
199 }
200 #ifdef __clang__
201 #pragma clang diagnostic pop
202 #endif
203
204 /* ------------------------------- utf8.h ------------------------------- */
205
206 PERL_STATIC_INLINE void
207 S_append_utf8_from_native_byte(const U8 byte, U8** dest)
208 {
209     /* Takes an input 'byte' (Latin1 or EBCDIC) and appends it to the UTF-8
210      * encoded string at '*dest', updating '*dest' to include it */
211
212     PERL_ARGS_ASSERT_APPEND_UTF8_FROM_NATIVE_BYTE;
213
214     if (NATIVE_BYTE_IS_INVARIANT(byte))
215         *(*dest)++ = byte;
216     else {
217         *(*dest)++ = UTF8_EIGHT_BIT_HI(byte);
218         *(*dest)++ = UTF8_EIGHT_BIT_LO(byte);
219     }
220 }
221
222 /* These two exist only to replace the macros they formerly were so that their
223  * use can be deprecated */
224
225 PERL_STATIC_INLINE bool
226 S_isIDFIRST_lazy(pTHX_ const char* p)
227 {
228     PERL_ARGS_ASSERT_ISIDFIRST_LAZY;
229
230     return isIDFIRST_lazy_if(p,1);
231 }
232
233 PERL_STATIC_INLINE bool
234 S_isALNUM_lazy(pTHX_ const char* p)
235 {
236     PERL_ARGS_ASSERT_ISALNUM_LAZY;
237
238     return isALNUM_lazy_if(p,1);
239 }
240
241 /* ------------------------------- perl.h ----------------------------- */
242
243 /*
244 =for apidoc AiR|bool|is_safe_syscall|const char *pv|STRLEN len|const char *what|const char *op_name
245
246 Test that the given C<pv> doesn't contain any internal C<NUL> characters.
247 If it does, set C<errno> to ENOENT, optionally warn, and return FALSE.
248
249 Return TRUE if the name is safe.
250
251 Used by the IS_SAFE_SYSCALL() macro.
252
253 =cut
254 */
255
256 PERL_STATIC_INLINE bool
257 S_is_safe_syscall(pTHX_ const char *pv, STRLEN len, const char *what, const char *op_name) {
258     /* While the Windows CE API provides only UCS-16 (or UTF-16) APIs
259      * perl itself uses xce*() functions which accept 8-bit strings.
260      */
261
262     PERL_ARGS_ASSERT_IS_SAFE_SYSCALL;
263
264     if (pv && len > 1) {
265         char *null_at;
266         if (UNLIKELY((null_at = (char *)memchr(pv, 0, len-1)) != NULL)) {
267                 SETERRNO(ENOENT, LIB_INVARG);
268                 Perl_ck_warner(aTHX_ packWARN(WARN_SYSCALLS),
269                                    "Invalid \\0 character in %s for %s: %s\\0%s",
270                                    what, op_name, pv, null_at+1);
271                 return FALSE;
272         }
273     }
274
275     return TRUE;
276 }
277
278 /*
279
280 Return true if the supplied filename has a newline character
281 immediately before the final NUL.
282
283 My original look at this incorrectly used the len from SvPV(), but
284 that's incorrect, since we allow for a NUL in pv[len-1].
285
286 So instead, strlen() and work from there.
287
288 This allow for the user reading a filename, forgetting to chomp it,
289 then calling:
290
291   open my $foo, "$file\0";
292
293 */
294
295 #ifdef PERL_CORE
296
297 PERL_STATIC_INLINE bool
298 S_should_warn_nl(const char *pv) {
299     STRLEN len;
300
301     PERL_ARGS_ASSERT_SHOULD_WARN_NL;
302
303     len = strlen(pv);
304
305     return len > 0 && pv[len-1] == '\n';
306 }
307
308 #endif
309
310 /*
311  * Local variables:
312  * c-indentation-style: bsd
313  * c-basic-offset: 4
314  * indent-tabs-mode: nil
315  * End:
316  *
317  * ex: set ts=8 sts=4 sw=4 et:
318  */