vutil.h

   1 /* This file is part of the "version" CPAN distribution.  Please avoid
   2    editing it in the perl core. */
   3
   4 /* The MUTABLE_*() macros cast pointers to the types shown, in such a way
   5  * (compiler permitting) that casting away const-ness will give a warning;
   6  * e.g.:
   7  *
   8  * const SV *sv = ...;
   9  * AV *av1 = (AV*)sv;        <== BAD:  the const has been silently cast away
  10  * AV *av2 = MUTABLE_AV(sv); <== GOOD: it may warn
  11  */
  12
  13 #ifndef MUTABLE_PTR
  14 #  if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
  15 #    define MUTABLE_PTR(p) ({ void *_p = (p); _p; })
  16 #  else
  17 #    define MUTABLE_PTR(p) ((void *) (p))
  18 #  endif
  19 #endif
  20
  21 #ifndef MUTABLE_AV
  22 #  define MUTABLE_AV(p) ((AV *)MUTABLE_PTR(p))
  23 #endif
  24 #ifndef MUTABLE_CV
  25 #  define MUTABLE_CV(p) ((CV *)MUTABLE_PTR(p))
  26 #endif
  27 #ifndef MUTABLE_GV
  28 #  define MUTABLE_GV(p) ((GV *)MUTABLE_PTR(p))
  29 #endif
  30 #ifndef MUTABLE_HV
  31 #  define MUTABLE_HV(p) ((HV *)MUTABLE_PTR(p))
  32 #endif
  33 #ifndef MUTABLE_IO
  34 #  define MUTABLE_IO(p) ((IO *)MUTABLE_PTR(p))
  35 #endif
  36 #ifndef MUTABLE_SV
  37 #  define MUTABLE_SV(p) ((SV *)MUTABLE_PTR(p))
  38 #endif
  39
  40 #ifndef SvPVx_nolen_const
  41 #  if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)
  42 #    define SvPVx_nolen_const(sv) ({SV *_sv = (sv); SvPV_nolen_const(_sv); })
  43 #  else
  44 #    define SvPVx_nolen_const(sv) (SvPV_nolen_const(sv))
  45 #  endif
  46 #endif
  47
  48 #ifndef PERL_ARGS_ASSERT_CK_WARNER
  49 static void Perl_ck_warner(pTHX_ U32 err, const char* pat, ...);
  50
  51 #  ifdef vwarner
  52 static
  53 void
  54 Perl_ck_warner(pTHX_ U32 err, const char* pat, ...)
  55 {
  56   va_list args;
  57
  58   PERL_UNUSED_ARG(err);
  59   if (ckWARN(err)) {
  60     va_list args;
  61     va_start(args, pat);
  62     vwarner(err, pat, &args);
  63     va_end(args);
  64   }
  65 }
  66 #  else
  67 /* yes this replicates my_warner */
  68 static
  69 void
  70 Perl_ck_warner(pTHX_ U32 err, const char* pat, ...)
  71 {
  72   SV *sv;
  73   va_list args;
  74
  75   PERL_UNUSED_ARG(err);
  76
  77   va_start(args, pat);
  78   sv = vnewSVpvf(pat, &args);
  79   va_end(args);
  80   sv_2mortal(sv);
  81   warn("%s", SvPV_nolen(sv));
  82 }
  83 #  endif
  84 #endif
  85
  86 #if PERL_VERSION_LT(5,15,4)
  87 #  define ISA_VERSION_OBJ(v) (sv_isobject(v) && sv_derived_from(v,"version"))
  88 #else
  89 #  define ISA_VERSION_OBJ(v) (sv_isobject(v) && sv_derived_from_pvn(v,"version",7,0))
  90 #endif
  91
  92 #ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE
  93 #define PERL_ARGS_ASSERT_CROAK_XS_USAGE assert(cv); assert(params)
  94
  95 /* prototype to pass -Wmissing-prototypes */
  96 STATIC void
  97 S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params);
  98
  99 STATIC void
 100 S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params)
 101 {
 102     const GV *const gv = CvGV(cv);
 103
 104     PERL_ARGS_ASSERT_CROAK_XS_USAGE;
 105
 106     if (gv) {
 107         const char *const gvname = GvNAME(gv);
 108         const HV *const stash = GvSTASH(gv);
 109         const char *const hvname = stash ? HvNAME(stash) : NULL;
 110
 111         if (hvname)
 112             Perl_croak_nocontext("Usage: %s::%s(%s)", hvname, gvname, params);
 113         else
 114             Perl_croak_nocontext("Usage: %s(%s)", gvname, params);
 115     } else {
 116         /* Pants. I don't think that it should be possible to get here. */
 117         Perl_croak_nocontext("Usage: CODE(0x%" UVxf ")(%s)", PTR2UV(cv), params);
 118     }
 119 }
 120
 121 #ifdef PERL_IMPLICIT_CONTEXT
 122 #define croak_xs_usage(a,b)     S_croak_xs_usage(aTHX_ a,b)
 123 #else
 124 #define croak_xs_usage          S_croak_xs_usage
 125 #endif
 126
 127 #endif
 128
 129 #if PERL_VERSION_GE(5,9,0) && !defined(PERL_CORE)
 130
 131 #  define VUTIL_REPLACE_CORE 1
 132
 133 static const char * Perl_scan_version2(pTHX_ const char *s, SV *rv, bool qv);
 134 static SV * Perl_new_version2(pTHX_ SV *ver);
 135 static SV * Perl_upg_version2(pTHX_ SV *sv, bool qv);
 136 static SV * Perl_vstringify2(pTHX_ SV *vs);
 137 static SV * Perl_vverify2(pTHX_ SV *vs);
 138 static SV * Perl_vnumify2(pTHX_ SV *vs);
 139 static SV * Perl_vnormal2(pTHX_ SV *vs);
 140 static SV * Perl_vstringify2(pTHX_ SV *vs);
 141 static int Perl_vcmp2(pTHX_ SV *lsv, SV *rsv);
 142 static const char * Perl_prescan_version2(pTHX_ const char *s, bool strict, const char** errstr, bool *sqv, int *ssaw_decimal, int *swidth, bool *salpha);
 143
 144 #  define SCAN_VERSION(a,b,c)   Perl_scan_version2(aTHX_ a,b,c)
 145 #  define NEW_VERSION(a)        Perl_new_version2(aTHX_ a)
 146 #  define UPG_VERSION(a,b)      Perl_upg_version2(aTHX_ a, b)
 147 #  define VSTRINGIFY(a)         Perl_vstringify2(aTHX_ a)
 148 #  define VVERIFY(a)            Perl_vverify2(aTHX_ a)
 149 #  define VNUMIFY(a)            Perl_vnumify2(aTHX_ a)
 150 #  define VNORMAL(a)            Perl_vnormal2(aTHX_ a)
 151 #  define VCMP(a,b)             Perl_vcmp2(aTHX_ a,b)
 152 #  define PRESCAN_VERSION(a,b,c,d,e,f,g)        Perl_prescan_version2(aTHX_ a,b,c,d,e,f,g)
 153 #  undef is_LAX_VERSION
 154 #  define is_LAX_VERSION(a,b) \
 155         (a != Perl_prescan_version2(aTHX_ a, FALSE, b, NULL, NULL, NULL, NULL))
 156 #  undef is_STRICT_VERSION
 157 #  define is_STRICT_VERSION(a,b) \
 158         (a != Perl_prescan_version2(aTHX_ a, TRUE, b, NULL, NULL, NULL, NULL))
 159
 160 #else
 161
 162 const char * Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv);
 163 SV * Perl_new_version(pTHX_ SV *ver);
 164 SV * Perl_upg_version(pTHX_ SV *sv, bool qv);
 165 SV * Perl_vverify(pTHX_ SV *vs);
 166 SV * Perl_vnumify(pTHX_ SV *vs);
 167 SV * Perl_vnormal(pTHX_ SV *vs);
 168 SV * Perl_vstringify(pTHX_ SV *vs);
 169 int Perl_vcmp(pTHX_ SV *lsv, SV *rsv);
 170 const char * Perl_prescan_version(pTHX_ const char *s, bool strict, const char** errstr, bool *sqv, int *ssaw_decimal, int *swidth, bool *salpha);
 171
 172 #  define SCAN_VERSION(a,b,c)   Perl_scan_version(aTHX_ a,b,c)
 173 #  define NEW_VERSION(a)        Perl_new_version(aTHX_ a)
 174 #  define UPG_VERSION(a,b)      Perl_upg_version(aTHX_ a, b)
 175 #  define VSTRINGIFY(a)         Perl_vstringify(aTHX_ a)
 176 #  define VVERIFY(a)            Perl_vverify(aTHX_ a)
 177 #  define VNUMIFY(a)            Perl_vnumify(aTHX_ a)
 178 #  define VNORMAL(a)            Perl_vnormal(aTHX_ a)
 179 #  define VCMP(a,b)             Perl_vcmp(aTHX_ a,b)
 180
 181 #  define PRESCAN_VERSION(a,b,c,d,e,f,g)        Perl_prescan_version(aTHX_ a,b,c,d,e,f,g)
 182 #  ifndef is_LAX_VERSION
 183 #    define is_LAX_VERSION(a,b) \
 184         (a != Perl_prescan_version(aTHX_ a, FALSE, b, NULL, NULL, NULL, NULL))
 185 #  endif
 186 #  ifndef is_STRICT_VERSION
 187 #    define is_STRICT_VERSION(a,b) \
 188         (a != Perl_prescan_version(aTHX_ a, TRUE, b, NULL, NULL, NULL, NULL))
 189 #  endif
 190
 191 #endif
 192
 193 #if PERL_VERSION_LT(5,11,4)
 194 #  define BADVERSION(a,b,c) \
 195         if (b) { \
 196             *b = c; \
 197         } \
 198         return a;
 199
 200 #  define PERL_ARGS_ASSERT_PRESCAN_VERSION      \
 201         assert(s); assert(sqv); assert(ssaw_decimal);\
 202         assert(swidth); assert(salpha);
 203
 204 #  define PERL_ARGS_ASSERT_SCAN_VERSION \
 205         assert(s); assert(rv)
 206 #  define PERL_ARGS_ASSERT_NEW_VERSION  \
 207         assert(ver)
 208 #  define PERL_ARGS_ASSERT_UPG_VERSION  \
 209         assert(ver)
 210 #  define PERL_ARGS_ASSERT_VVERIFY      \
 211         assert(vs)
 212 #  define PERL_ARGS_ASSERT_VNUMIFY      \
 213         assert(vs)
 214 #  define PERL_ARGS_ASSERT_VNORMAL      \
 215         assert(vs)
 216 #  define PERL_ARGS_ASSERT_VSTRINGIFY   \
 217         assert(vs)
 218 #  define PERL_ARGS_ASSERT_VCMP \
 219         assert(lhv); assert(rhv)
 220 #  define PERL_ARGS_ASSERT_CK_WARNER      \
 221         assert(pat)
 222 #endif
 223
 224
 225 #if PERL_VERSION_LT(5,27,9)
 226 #  define LC_NUMERIC_LOCK(cond)
 227 #  define LC_NUMERIC_UNLOCK
 228 #  if PERL_VERSION_LT(5,19,0)
 229 #    undef STORE_LC_NUMERIC_SET_STANDARD
 230 #    undef RESTORE_LC_NUMERIC
 231 #    undef DECLARATION_FOR_LC_NUMERIC_MANIPULATION
 232 #    ifdef USE_LOCALE
 233 #      define DECLARATION_FOR_LC_NUMERIC_MANIPULATION char *loc
 234 #      define STORE_NUMERIC_SET_STANDARD()\
 235          loc = savepv(setlocale(LC_NUMERIC, NULL));  \
 236          SAVEFREEPV(loc); \
 237          setlocale(LC_NUMERIC, "C");
 238 #      define RESTORE_LC_NUMERIC()\
 239          setlocale(LC_NUMERIC, loc);
 240 #    else
 241 #      define DECLARATION_FOR_LC_NUMERIC_MANIPULATION
 242 #      define STORE_LC_NUMERIC_SET_STANDARD()
 243 #      define RESTORE_LC_NUMERIC()
 244 #    endif
 245 #  endif
 246 #endif
 247
 248 #ifndef LOCK_NUMERIC_STANDARD
 249 #  define LOCK_NUMERIC_STANDARD()
 250 #endif
 251
 252 #ifndef UNLOCK_NUMERIC_STANDARD
 253 #  define UNLOCK_NUMERIC_STANDARD()
 254 #endif
 255
 256 /* The names of these changed in 5.28 */
 257 #ifndef LOCK_LC_NUMERIC_STANDARD
 258 #  define LOCK_LC_NUMERIC_STANDARD() LOCK_NUMERIC_STANDARD()
 259 #endif
 260 #ifndef UNLOCK_LC_NUMERIC_STANDARD
 261 #  define UNLOCK_LC_NUMERIC_STANDARD() UNLOCK_NUMERIC_STANDARD()
 262 #endif
 263
 264 /* ex: set ro: */