| 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 | static const char * Perl_scan_version2(pTHX_ const char *s, SV *rv, bool qv); |
| 135 | static SV * Perl_new_version2(pTHX_ SV *ver); |
| 136 | static SV * Perl_upg_version2(pTHX_ SV *sv, bool qv); |
| 137 | static SV * Perl_vstringify2(pTHX_ SV *vs); |
| 138 | static SV * Perl_vverify2(pTHX_ SV *vs); |
| 139 | static SV * Perl_vnumify2(pTHX_ SV *vs); |
| 140 | static SV * Perl_vnormal2(pTHX_ SV *vs); |
| 141 | static SV * Perl_vstringify2(pTHX_ SV *vs); |
| 142 | static int Perl_vcmp2(pTHX_ SV *lsv, SV *rsv); |
| 143 | static 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 |
| 242 | |
| 243 | #ifndef LOCK_NUMERIC_STANDARD |
| 244 | #define LOCK_NUMERIC_STANDARD() |
| 245 | #endif |
| 246 | |
| 247 | #ifndef UNLOCK_NUMERIC_STANDARD |
| 248 | #define UNLOCK_NUMERIC_STANDARD() |
| 249 | #endif |
| 250 | |
| 251 | /* ex: set ro: */ |