Add VMS symbol shortening to PL_bincompat_options.

[perl5.git] / util.c

diff --git a/util.c b/util.c
index 16fae9a..20429f7 100644 (file)
--- a/util.c
+++ b/util.c
@@ -6472,7 +6472,7 @@ Perl_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p,
 {
     SV *sv;
     const char *vn = NULL;
-    const char *module = SvPV_nolen_const(PL_stack_base[ax]);
+    SV *const module = PL_stack_base[ax];
 
     PERL_ARGS_ASSERT_XS_VERSION_BOOTCHECK;
 
@@ -6480,35 +6480,70 @@ Perl_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p,
        sv = PL_stack_base[ax + 1];
     else {
        /* XXX GV_ADDWARN */
-       sv = get_sv(Perl_form(aTHX_ "%s::%s", module, vn = "XS_VERSION"), 0);
-       if (!sv || !SvOK(sv))
-           sv = get_sv(Perl_form(aTHX_ "%s::%s", module, vn = "VERSION"), 0);
+       vn = "XS_VERSION";
+       sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", module, vn), 0);
+       if (!sv || !SvOK(sv)) {
+           vn = "VERSION";
+           sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", module, vn), 0);
+       }
     }
     if (sv) {
-       SV *xpt = NULL;
-       SV *xssv = Perl_newSVpvn(aTHX_ xs_p, xs_len);
+       SV *xssv = Perl_newSVpvn_flags(aTHX_ xs_p, xs_len, SVs_TEMP);
        SV *pmsv = sv_derived_from(sv, "version")
-           ? SvREFCNT_inc_simple_NN(sv)
-           : new_version(sv);
+           ? sv : sv_2mortal(new_version(sv));
        xssv = upg_version(xssv, 0);
        if ( vcmp(pmsv,xssv) ) {
-           xpt = Perl_newSVpvf(aTHX_ "%s object version %"SVf
-                               " does not match %s%s%s%s %"SVf,
-                               module,
-                               SVfARG(Perl_sv_2mortal(aTHX_ vstringify(xssv))),
-                               vn ? "$" : "", vn ? module : "",
-                               vn ? "::" : "",
-                               vn ? vn : "bootstrap parameter",
-                               SVfARG(Perl_sv_2mortal(aTHX_ vstringify(pmsv))));
+           SV *string = vstringify(xssv);
+           SV *xpt = Perl_newSVpvf(aTHX_ "%"SVf" object version %"SVf
+                                   " does not match ", module, string);
+
+           SvREFCNT_dec(string);
+           string = vstringify(pmsv);
+
+           if (vn) {
+               Perl_sv_catpvf(aTHX_ xpt, "$%"SVf"::%s %"SVf, module, vn,
+                              string);
+           } else {
+               Perl_sv_catpvf(aTHX_ xpt, "bootstrap parameter %"SVf, string);
+           }
+           SvREFCNT_dec(string);
+
            Perl_sv_2mortal(aTHX_ xpt);
-       }
-       SvREFCNT_dec(xssv);
-       SvREFCNT_dec(pmsv);
-       if (xpt)
            Perl_croak_sv(aTHX_ xpt);
+       }
     }
 }
 
+void
+Perl_xs_apiversion_bootcheck(pTHX_ SV *module, const char *api_p,
+                            STRLEN api_len)
+{
+    SV *xpt = NULL;
+    SV *compver = Perl_newSVpvn_flags(aTHX_ api_p, api_len, SVs_TEMP);
+    SV *runver;
+
+    PERL_ARGS_ASSERT_XS_APIVERSION_BOOTCHECK;
+
+    /* This might croak  */
+    compver = upg_version(compver, 0);
+    /* This should never croak */
+    runver = new_version(PL_apiversion);
+    if (vcmp(compver, runver)) {
+       SV *compver_string = vstringify(compver);
+       SV *runver_string = vstringify(runver);
+       xpt = Perl_newSVpvf(aTHX_ "Perl API version %"SVf
+                           " of %"SVf" does not match %"SVf,
+                           compver_string, module, runver_string);
+       Perl_sv_2mortal(aTHX_ xpt);
+
+       SvREFCNT_dec(compver_string);
+       SvREFCNT_dec(runver_string);
+    }
+    SvREFCNT_dec(runver);
+    if (xpt)
+       Perl_croak_sv(aTHX_ xpt);
+}
+
 #ifndef HAS_STRLCAT
 Size_t
 Perl_my_strlcat(char *dst, const char *src, Size_t size)