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 #ifdef BOOTSTRAP_CHARSET 205 static bool 206 S_bootstrap_ctype(U8 character, UV classnum, bool full_Latin1) 207 { 208 /* See comments in handy.h. This is placed in this file primarily to avoid 209 * having to have an entry for it in embed.fnc */ 210 211 dTHX; 212 213 if (! full_Latin1 && ! isASCII(character)) { 214 return FALSE; 215 } 216 217 switch (classnum) { 218 case _CC_ALPHANUMERIC: return isALPHANUMERIC_L1(character); 219 case _CC_ALPHA: return isALPHA_L1(character); 220 case _CC_ASCII: return isASCII_L1(character); 221 case _CC_BLANK: return isBLANK_L1(character); 222 case _CC_CASED: return isLOWER_L1(character) 223 || isUPPER_L1(character); 224 case _CC_CNTRL: return isCNTRL_L1(character); 225 case _CC_DIGIT: return isDIGIT_L1(character); 226 case _CC_GRAPH: return isGRAPH_L1(character); 227 case _CC_LOWER: return isLOWER_L1(character); 228 case _CC_PRINT: return isPRINT_L1(character); 229 case _CC_PSXSPC: return isPSXSPC_L1(character); 230 case _CC_PUNCT: return isPUNCT_L1(character); 231 case _CC_SPACE: return isSPACE_L1(character); 232 case _CC_UPPER: return isUPPER_L1(character); 233 case _CC_WORDCHAR: return isWORDCHAR_L1(character); 234 case _CC_XDIGIT: return isXDIGIT_L1(character); 235 case _CC_VERTSPACE: return isSPACE_L1(character) && ! isBLANK_L1(character); 236 case _CC_IDFIRST: return isIDFIRST_L1(character); 237 case _CC_QUOTEMETA: return _isQUOTEMETA(character); 238 case _CC_CHARNAME_CONT: return isCHARNAME_CONT(character); 239 case _CC_NONLATIN1_FOLD: return _HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(character); 240 case _CC_NON_FINAL_FOLD: return _IS_NON_FINAL_FOLD_ONLY_FOR_USE_BY_REGCOMP_DOT_C(character); 241 case _CC_IS_IN_SOME_FOLD: return _IS_IN_SOME_FOLD_ONLY_FOR_USE_BY_REGCOMP_DOT_C(character); 242 case _CC_BACKSLASH_FOO_LBRACE_IS_META: return 0; 243 244 245 default: break; 246 } 247 Perl_croak(aTHX_ "panic: bootstrap_ctype() has an unexpected character class '%" UVxf "'", classnum); 248 } 249 #endif 250 251 /* ------------------------------- utf8.h ------------------------------- */ 252 253 PERL_STATIC_INLINE void 254 S_append_utf8_from_native_byte(const U8 byte, U8** dest) 255 { 256 /* Takes an input 'byte' (Latin1 or EBCDIC) and appends it to the UTF-8 257 * encoded string at '*dest', updating '*dest' to include it */ 258 259 PERL_ARGS_ASSERT_APPEND_UTF8_FROM_NATIVE_BYTE; 260 261 if (NATIVE_BYTE_IS_INVARIANT(byte)) 262 *(*dest)++ = byte; 263 else { 264 *(*dest)++ = UTF8_EIGHT_BIT_HI(byte); 265 *(*dest)++ = UTF8_EIGHT_BIT_LO(byte); 266 } 267 } 268 269 /* These two exist only to replace the macros they formerly were so that their 270 * use can be deprecated */ 271 272 PERL_STATIC_INLINE bool 273 S_isIDFIRST_lazy(pTHX_ const char* p) 274 { 275 PERL_ARGS_ASSERT_ISIDFIRST_LAZY; 276 277 return isIDFIRST_lazy_if(p,1); 278 } 279 280 PERL_STATIC_INLINE bool 281 S_isALNUM_lazy(pTHX_ const char* p) 282 { 283 PERL_ARGS_ASSERT_ISALNUM_LAZY; 284 285 return isALNUM_lazy_if(p,1); 286 } 287 288 /* ------------------------------- perl.h ----------------------------- */ 289 290 /* 291 =for apidoc AiR|bool|is_safe_syscall|const char *pv|STRLEN len|const char *what|const char *op_name 292 293 Test that the given C<pv> doesn't contain any internal C<NUL> characters. 294 If it does, set C<errno> to ENOENT, optionally warn, and return FALSE. 295 296 Return TRUE if the name is safe. 297 298 Used by the IS_SAFE_SYSCALL() macro. 299 300 =cut 301 */ 302 303 PERL_STATIC_INLINE bool 304 S_is_safe_syscall(pTHX_ const char *pv, STRLEN len, const char *what, const char *op_name) { 305 /* While the Windows CE API provides only UCS-16 (or UTF-16) APIs 306 * perl itself uses xce*() functions which accept 8-bit strings. 307 */ 308 309 PERL_ARGS_ASSERT_IS_SAFE_SYSCALL; 310 311 if (pv && len > 1) { 312 char *null_at; 313 if (UNLIKELY((null_at = (char *)memchr(pv, 0, len-1)) != NULL)) { 314 SETERRNO(ENOENT, LIB_INVARG); 315 Perl_ck_warner(aTHX_ packWARN(WARN_SYSCALLS), 316 "Invalid \\0 character in %s for %s: %s\\0%s", 317 what, op_name, pv, null_at+1); 318 return FALSE; 319 } 320 } 321 322 return TRUE; 323 } 324 325 /* 326 327 Return false if any get magic is on the SV other than taint magic. 328 329 */ 330 331 PERL_STATIC_INLINE bool 332 S_sv_only_taint_gmagic(SV *sv) { 333 MAGIC *mg = SvMAGIC(sv); 334 335 PERL_ARGS_ASSERT_SV_ONLY_TAINT_GMAGIC; 336 337 while (mg) { 338 if (mg->mg_type != PERL_MAGIC_taint 339 && !(mg->mg_flags & MGf_GSKIP) 340 && mg->mg_virtual->svt_get) { 341 return FALSE; 342 } 343 mg = mg->mg_moremagic; 344 } 345 346 return TRUE; 347 } 348 349 /* 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 */ 358