vutil.h

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