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 #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 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 true if the supplied filename has a newline character
 328 immediately before the final NUL.
 329
 330 My original look at this incorrectly used the len from SvPV(), but
 331 that's incorrect, since we allow for a NUL in pv[len-1].
 332
 333 So instead, strlen() and work from there.
 334
 335 This allow for the user reading a filename, forgetting to chomp it,
 336 then calling:
 337
 338   open my $foo, "$file\0";
 339
 340 */
 341
 342 #ifdef PERL_CORE
 343
 344 PERL_STATIC_INLINE bool
 345 S_should_warn_nl(const char *pv) {
 346     STRLEN len;
 347
 348     PERL_ARGS_ASSERT_SHOULD_WARN_NL;
 349
 350     len = strlen(pv);
 351
 352     return len > 0 && pv[len-1] == '\n';
 353 }
 354
 355 #endif
 356
 357 /*
 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  */