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