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_SvPADTMP_on(SV *sv)
 160 {
 161     assert(!(SvFLAGS(sv) & SVs_PADMY));
 162     return SvFLAGS(sv) |= SVs_PADTMP;
 163 }
 164 PERL_STATIC_INLINE U32
 165 S_SvPADTMP_off(SV *sv)
 166 {
 167     assert(!(SvFLAGS(sv) & SVs_PADMY));
 168     return SvFLAGS(sv) &= ~SVs_PADTMP;
 169 }
 170 PERL_STATIC_INLINE U32
 171 S_SvPADSTALE_on(SV *sv)
 172 {
 173     assert(SvFLAGS(sv) & SVs_PADMY);
 174     return SvFLAGS(sv) |= SVs_PADSTALE;
 175 }
 176 PERL_STATIC_INLINE U32
 177 S_SvPADSTALE_off(SV *sv)
 178 {
 179     assert(SvFLAGS(sv) & SVs_PADMY);
 180     return SvFLAGS(sv) &= ~SVs_PADSTALE;
 181 }
 182 #if defined(PERL_CORE) || defined (PERL_EXT)
 183 PERL_STATIC_INLINE STRLEN
 184 S_sv_or_pv_pos_u2b(pTHX_ SV *sv, const char *pv, STRLEN pos, STRLEN *lenp)
 185 {
 186     PERL_ARGS_ASSERT_SV_OR_PV_POS_U2B;
 187     if (SvGAMAGIC(sv)) {
 188         U8 *hopped = utf8_hop((U8 *)pv, pos);
 189         if (lenp) *lenp = (STRLEN)(utf8_hop(hopped, *lenp) - hopped);
 190         return (STRLEN)(hopped - (U8 *)pv);
 191     }
 192     return sv_pos_u2b_flags(sv,pos,lenp,SV_CONST_RETURN);
 193 }
 194 #endif
 195
 196 /* ------------------------------- handy.h ------------------------------- */
 197
 198 /* saves machine code for a common noreturn idiom typically used in Newx*() */
 199 #ifdef GCC_DIAG_PRAGMA
 200 GCC_DIAG_IGNORE(-Wunused-function) /* Intentionally left semicolonless. */
 201 #endif
 202 static void
 203 S_croak_memory_wrap(void)
 204 {
 205     Perl_croak_nocontext("%s",PL_memory_wrap);
 206 }
 207 #ifdef GCC_DIAG_PRAGMA
 208 GCC_DIAG_RESTORE /* Intentionally left semicolonless. */
 209 #endif
 210
 211 /* ------------------------------- utf8.h ------------------------------- */
 212
 213 PERL_STATIC_INLINE void
 214 S_append_utf8_from_native_byte(const U8 byte, U8** dest)
 215 {
 216     /* Takes an input 'byte' (Latin1 or EBCDIC) and appends it to the UTF-8
 217      * encoded string at '*dest', updating '*dest' to include it */
 218
 219     PERL_ARGS_ASSERT_APPEND_UTF8_FROM_NATIVE_BYTE;
 220
 221     if (NATIVE_BYTE_IS_INVARIANT(byte))
 222         *(*dest)++ = byte;
 223     else {
 224         *(*dest)++ = UTF8_EIGHT_BIT_HI(byte);
 225         *(*dest)++ = UTF8_EIGHT_BIT_LO(byte);
 226     }
 227 }
 228
 229 /*
 230
 231 A helper function for the macro isUTF8_CHAR(), which should be used instead of
 232 this function.  The macro will handle smaller code points directly saving time,
 233 using this function as a fall-back for higher code points.
 234
 235 Tests if the first bytes of string C<s> form a valid UTF-8 character.  0 is
 236 returned if the bytes starting at C<s> up to but not including C<e> do not form a
 237 complete well-formed UTF-8 character; otherwise the number of bytes in the
 238 character is returned.
 239
 240 Note that an INVARIANT (i.e. ASCII on non-EBCDIC) character is a valid UTF-8
 241 character.
 242
 243 =cut */
 244 PERL_STATIC_INLINE STRLEN
 245 S__is_utf8_char_slow(const U8 *s, const U8 *e)
 246 {
 247     dTHX;   /* The function called below requires thread context */
 248
 249     STRLEN actual_len;
 250
 251     PERL_ARGS_ASSERT__IS_UTF8_CHAR_SLOW;
 252
 253     assert(e >= s);
 254     utf8n_to_uvchr(s, e - s, &actual_len, UTF8_CHECK_ONLY);
 255
 256     return (actual_len == (STRLEN) -1) ? 0 : actual_len;
 257 }
 258
 259 /* ------------------------------- perl.h ----------------------------- */
 260
 261 /*
 262 =head1 Miscellaneous Functions
 263
 264 =for apidoc AiR|bool|is_safe_syscall|const char *pv|STRLEN len|const char *what|const char *op_name
 265
 266 Test that the given C<pv> doesn't contain any internal C<NUL> characters.
 267 If it does, set C<errno> to ENOENT, optionally warn, and return FALSE.
 268
 269 Return TRUE if the name is safe.
 270
 271 Used by the IS_SAFE_SYSCALL() macro.
 272
 273 =cut
 274 */
 275
 276 PERL_STATIC_INLINE bool
 277 S_is_safe_syscall(pTHX_ const char *pv, STRLEN len, const char *what, const char *op_name) {
 278     /* While the Windows CE API provides only UCS-16 (or UTF-16) APIs
 279      * perl itself uses xce*() functions which accept 8-bit strings.
 280      */
 281
 282     PERL_ARGS_ASSERT_IS_SAFE_SYSCALL;
 283
 284     if (pv && len > 1) {
 285         char *null_at;
 286         if (UNLIKELY((null_at = (char *)memchr(pv, 0, len-1)) != NULL)) {
 287                 SETERRNO(ENOENT, LIB_INVARG);
 288                 Perl_ck_warner(aTHX_ packWARN(WARN_SYSCALLS),
 289                                    "Invalid \\0 character in %s for %s: %s\\0%s",
 290                                    what, op_name, pv, null_at+1);
 291                 return FALSE;
 292         }
 293     }
 294
 295     return TRUE;
 296 }
 297
 298 /*
 299
 300 Return true if the supplied filename has a newline character
 301 immediately before the final NUL.
 302
 303 My original look at this incorrectly used the len from SvPV(), but
 304 that's incorrect, since we allow for a NUL in pv[len-1].
 305
 306 So instead, strlen() and work from there.
 307
 308 This allow for the user reading a filename, forgetting to chomp it,
 309 then calling:
 310
 311   open my $foo, "$file\0";
 312
 313 */
 314
 315 #ifdef PERL_CORE
 316
 317 PERL_STATIC_INLINE bool
 318 S_should_warn_nl(const char *pv) {
 319     STRLEN len;
 320
 321     PERL_ARGS_ASSERT_SHOULD_WARN_NL;
 322
 323     len = strlen(pv);
 324
 325     return len > 0 && pv[len-1] == '\n';
 326 }
 327
 328 #endif
 329
 330 /* ------------------ pp.c, regcomp.c, toke.c, universal.c ------------ */
 331
 332 #define MAX_CHARSET_NAME_LENGTH 2
 333
 334 PERL_STATIC_INLINE const char *
 335 get_regex_charset_name(const U32 flags, STRLEN* const lenp)
 336 {
 337     /* Returns a string that corresponds to the name of the regex character set
 338      * given by 'flags', and *lenp is set the length of that string, which
 339      * cannot exceed MAX_CHARSET_NAME_LENGTH characters */
 340
 341     *lenp = 1;
 342     switch (get_regex_charset(flags)) {
 343         case REGEX_DEPENDS_CHARSET: return DEPENDS_PAT_MODS;
 344         case REGEX_LOCALE_CHARSET:  return LOCALE_PAT_MODS;
 345         case REGEX_UNICODE_CHARSET: return UNICODE_PAT_MODS;
 346         case REGEX_ASCII_RESTRICTED_CHARSET: return ASCII_RESTRICT_PAT_MODS;
 347         case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
 348             *lenp = 2;
 349             return ASCII_MORE_RESTRICT_PAT_MODS;
 350     }
 351     /* The NOT_REACHED; hides an assert() which has a rather complex
 352      * definition in perl.h. */
 353     NOT_REACHED; /* NOTREACHED */
 354     return "?";     /* Unknown */
 355 }
 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  */