"Fossies" - the Fresh Open Source Software Archive

Member "install-tl-20200916/tlpkg/tlperl/lib/CORE/vutil.h" (10 Mar 2019, 7993 Bytes) of package /windows/misc/install-tl.zip:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) C and C++ source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file.

    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,27,9)
  227 #  define LC_NUMERIC_LOCK
  228 #  define LC_NUMERIC_UNLOCK
  229 #  if PERL_VERSION_LT(5,19,0)
  230 #    undef STORE_LC_NUMERIC_SET_STANDARD
  231 #    undef RESTORE_LC_NUMERIC
  232 #    undef DECLARATION_FOR_LC_NUMERIC_MANIPULATION
  233 #    ifdef USE_LOCALE
  234 #      define DECLARATION_FOR_LC_NUMERIC_MANIPULATION char *loc
  235 #      define STORE_NUMERIC_SET_STANDARD()\
  236      loc = savepv(setlocale(LC_NUMERIC, NULL));  \
  237      SAVEFREEPV(loc); \
  238      setlocale(LC_NUMERIC, "C");
  239 #      define RESTORE_LC_NUMERIC()\
  240      setlocale(LC_NUMERIC, loc);
  241 #    else
  242 #      define DECLARATION_FOR_LC_NUMERIC_MANIPULATION
  243 #      define STORE_LC_NUMERIC_SET_STANDARD()
  244 #      define RESTORE_LC_NUMERIC()
  245 #    endif
  246 #  endif
  247 #endif
  248 
  249 #ifndef LOCK_NUMERIC_STANDARD
  250 #  define LOCK_NUMERIC_STANDARD()
  251 #endif
  252 
  253 #ifndef UNLOCK_NUMERIC_STANDARD
  254 #  define UNLOCK_NUMERIC_STANDARD()
  255 #endif
  256 
  257 /* The names of these changed in 5.28 */
  258 #ifndef LOCK_LC_NUMERIC_STANDARD
  259 #  define LOCK_LC_NUMERIC_STANDARD() LOCK_NUMERIC_STANDARD()
  260 #endif
  261 #ifndef UNLOCK_LC_NUMERIC_STANDARD
  262 #  define UNLOCK_LC_NUMERIC_STANDARD() UNLOCK_NUMERIC_STANDARD()
  263 #endif
  264 
  265 /* ex: set ro: */