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