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 #define PERL_VERSION_DECIMAL(r,v,s) (r*1000000 + v*1000 + s)
  79 #define PERL_DECIMAL_VERSION \
  80         PERL_VERSION_DECIMAL(PERL_REVISION,PERL_VERSION,PERL_SUBVERSION)
  81 #define PERL_VERSION_LT(r,v,s) \
  82         (PERL_DECIMAL_VERSION < PERL_VERSION_DECIMAL(r,v,s))
  83 #define PERL_VERSION_GE(r,v,s) \
  84         (PERL_DECIMAL_VERSION >= PERL_VERSION_DECIMAL(r,v,s))
  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
  93 #ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE
  94 #define PERL_ARGS_ASSERT_CROAK_XS_USAGE assert(cv); assert(params)
  95
  96 /* prototype to pass -Wmissing-prototypes */
  97 STATIC void
  98 S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params);
  99
 100 STATIC void
 101 S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params)
 102 {
 103     const GV *const gv = CvGV(cv);
 104
 105     PERL_ARGS_ASSERT_CROAK_XS_USAGE;
 106
 107     if (gv) {
 108         const char *const gvname = GvNAME(gv);
 109         const HV *const stash = GvSTASH(gv);
 110         const char *const hvname = stash ? HvNAME(stash) : NULL;
 111
 112         if (hvname)
 113             Perl_croak_nocontext("Usage: %s::%s(%s)", hvname, gvname, params);
 114         else
 115             Perl_croak_nocontext("Usage: %s(%s)", gvname, params);
 116     } else {
 117         /* Pants. I don't think that it should be possible to get here. */
 118         Perl_croak_nocontext("Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params);
 119     }
 120 }
 121
 122 #ifdef PERL_IMPLICIT_CONTEXT
 123 #define croak_xs_usage(a,b)     S_croak_xs_usage(aTHX_ a,b)
 124 #else
 125 #define croak_xs_usage          S_croak_xs_usage
 126 #endif
 127
 128 #endif
 129
 130 #if PERL_VERSION_GE(5,9,0) && !defined(PERL_CORE)
 131
 132 #  define VUTIL_REPLACE_CORE 1
 133
 134 const char * Perl_scan_version2(pTHX_ const char *s, SV *rv, bool qv);
 135 SV * Perl_new_version2(pTHX_ SV *ver);
 136 SV * Perl_upg_version2(pTHX_ SV *sv, bool qv);
 137 SV * Perl_vstringify2(pTHX_ SV *vs);
 138 SV * Perl_vverify2(pTHX_ SV *vs);
 139 SV * Perl_vnumify2(pTHX_ SV *vs);
 140 SV * Perl_vnormal2(pTHX_ SV *vs);
 141 SV * Perl_vstringify2(pTHX_ SV *vs);
 142 int Perl_vcmp2(pTHX_ SV *lsv, SV *rsv);
 143 const char * Perl_prescan_version2(pTHX_ const char *s, bool strict, const char** errstr, bool *sqv, int *ssaw_decimal, int *swidth, bool *salpha);
 144
 145 #  define SCAN_VERSION(a,b,c)   Perl_scan_version2(aTHX_ a,b,c)
 146 #  define NEW_VERSION(a)        Perl_new_version2(aTHX_ a)
 147 #  define UPG_VERSION(a,b)      Perl_upg_version2(aTHX_ a, b)
 148 #  define VSTRINGIFY(a)         Perl_vstringify2(aTHX_ a)
 149 #  define VVERIFY(a)            Perl_vverify2(aTHX_ a)
 150 #  define VNUMIFY(a)            Perl_vnumify2(aTHX_ a)
 151 #  define VNORMAL(a)            Perl_vnormal2(aTHX_ a)
 152 #  define VCMP(a,b)             Perl_vcmp2(aTHX_ a,b)
 153 #  define PRESCAN_VERSION(a,b,c,d,e,f,g)        Perl_prescan_version2(aTHX_ a,b,c,d,e,f,g)
 154 #  undef is_LAX_VERSION
 155 #  define is_LAX_VERSION(a,b) \
 156         (a != Perl_prescan_version2(aTHX_ a, FALSE, b, NULL, NULL, NULL, NULL))
 157 #  undef is_STRICT_VERSION
 158 #  define is_STRICT_VERSION(a,b) \
 159         (a != Perl_prescan_version2(aTHX_ a, TRUE, b, NULL, NULL, NULL, NULL))
 160
 161 #else
 162
 163 const char * Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv);
 164 SV * Perl_new_version(pTHX_ SV *ver);
 165 SV * Perl_upg_version(pTHX_ SV *sv, bool qv);
 166 SV * Perl_vverify(pTHX_ SV *vs);
 167 SV * Perl_vnumify(pTHX_ SV *vs);
 168 SV * Perl_vnormal(pTHX_ SV *vs);
 169 SV * Perl_vstringify(pTHX_ SV *vs);
 170 int Perl_vcmp(pTHX_ SV *lsv, SV *rsv);
 171 const char * Perl_prescan_version(pTHX_ const char *s, bool strict, const char** errstr, bool *sqv, int *ssaw_decimal, int *swidth, bool *salpha);
 172
 173 #  define SCAN_VERSION(a,b,c)   Perl_scan_version(aTHX_ a,b,c)
 174 #  define NEW_VERSION(a)        Perl_new_version(aTHX_ a)
 175 #  define UPG_VERSION(a,b)      Perl_upg_version(aTHX_ a, b)
 176 #  define VSTRINGIFY(a)         Perl_vstringify(aTHX_ a)
 177 #  define VVERIFY(a)            Perl_vverify(aTHX_ a)
 178 #  define VNUMIFY(a)            Perl_vnumify(aTHX_ a)
 179 #  define VNORMAL(a)            Perl_vnormal(aTHX_ a)
 180 #  define VCMP(a,b)             Perl_vcmp(aTHX_ a,b)
 181
 182 #  define PRESCAN_VERSION(a,b,c,d,e,f,g)        Perl_prescan_version(aTHX_ a,b,c,d,e,f,g)
 183 #  ifndef is_LAX_VERSION
 184 #    define is_LAX_VERSION(a,b) \
 185         (a != Perl_prescan_version(aTHX_ a, FALSE, b, NULL, NULL, NULL, NULL))
 186 #  endif
 187 #  ifndef is_STRICT_VERSION
 188 #    define is_STRICT_VERSION(a,b) \
 189         (a != Perl_prescan_version(aTHX_ a, TRUE, b, NULL, NULL, NULL, NULL))
 190 #  endif
 191
 192 #endif
 193
 194 #if PERL_VERSION_LT(5,11,4)
 195 #  define BADVERSION(a,b,c) \
 196         if (b) { \
 197             *b = c; \
 198         } \
 199         return a;
 200
 201 #  define PERL_ARGS_ASSERT_PRESCAN_VERSION      \
 202         assert(s); assert(sqv); assert(ssaw_decimal);\
 203         assert(swidth); assert(salpha);
 204
 205 #  define PERL_ARGS_ASSERT_SCAN_VERSION \
 206         assert(s); assert(rv)
 207 #  define PERL_ARGS_ASSERT_NEW_VERSION  \
 208         assert(ver)
 209 #  define PERL_ARGS_ASSERT_UPG_VERSION  \
 210         assert(ver)
 211 #  define PERL_ARGS_ASSERT_VVERIFY      \
 212         assert(vs)
 213 #  define PERL_ARGS_ASSERT_VNUMIFY      \
 214         assert(vs)
 215 #  define PERL_ARGS_ASSERT_VNORMAL      \
 216         assert(vs)
 217 #  define PERL_ARGS_ASSERT_VSTRINGIFY   \
 218         assert(vs)
 219 #  define PERL_ARGS_ASSERT_VCMP \
 220         assert(lhv); assert(rhv)
 221 #  define PERL_ARGS_ASSERT_CK_WARNER      \
 222         assert(pat)
 223 #endif
 224
 225
 226 #if PERL_VERSION_LT(5,19,0)
 227 # undef STORE_NUMERIC_LOCAL_SET_STANDARD
 228 # undef RESTORE_NUMERIC_LOCAL
 229 # ifdef USE_LOCALE
 230 #  define STORE_NUMERIC_LOCAL_SET_STANDARD()\
 231         char *loc = savepv(setlocale(LC_NUMERIC, NULL)); \
 232         SAVEFREEPV(loc); \
 233         setlocale(LC_NUMERIC, "C");
 234
 235 #  define RESTORE_NUMERIC_LOCAL()\
 236         setlocale(LC_NUMERIC, loc);
 237 # else
 238 #  define STORE_NUMERIC_LOCAL_SET_STANDARD()
 239 #  define RESTORE_NUMERIC_LOCAL()
 240 # endif
 241 #endif