projects / p5sagit/p5-mst-13.2.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw
Integrate with Sarathy.
[p5sagit/p5-mst-13.2.git] / perl.c
diff --git a/perl.c b/perl.c
index 95ec5e1..7f1e3f6 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -203,14 +203,29 @@ perl_construct(pTHXx)
     init_i18nl10n(1);
     SET_NUMERIC_STANDARD();
 
+    {
+       U8 *s;
+       PL_patchlevel = NEWSV(0,4);
+       SvUPGRADE(PL_patchlevel, SVt_PVNV);
+       if (PERL_REVISION > 127 || PERL_VERSION > 127 || PERL_SUBVERSION > 127)
+           SvGROW(PL_patchlevel,24);
+       s = (U8*)SvPVX(PL_patchlevel);
+       s = uv_to_utf8(s, (UV)PERL_REVISION);
+       s = uv_to_utf8(s, (UV)PERL_VERSION);
+       s = uv_to_utf8(s, (UV)PERL_SUBVERSION);
+       *s = '\0';
+       SvCUR_set(PL_patchlevel, s - (U8*)SvPVX(PL_patchlevel));
+       SvPOK_on(PL_patchlevel);
+       SvNVX(PL_patchlevel) = (NV)PERL_REVISION
+                               + ((NV)PERL_VERSION / (NV)1000)
 #if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
-    sprintf(PL_patchlevel, "%7.5f",   (double) PERL_REVISION
-                               + ((double) PERL_VERSION / (double) 1000)
-                               + ((double) PERL_SUBVERSION / (double) 100000));
-#else
-    sprintf(PL_patchlevel, "%5.3f", (double) PERL_REVISION +
-                               ((double) PERL_VERSION / (double) 1000));
+                               + ((NV)PERL_SUBVERSION / (NV)1000000)
 #endif
+                               ;
+       SvNOK_on(PL_patchlevel);        /* dual valued */
+       SvUTF8_on(PL_patchlevel);
+       SvREADONLY_on(PL_patchlevel);
+    }
 
 #if defined(LOCAL_PATCH_COUNT)
     PL_localpatches = local_patches;   /* For possible -v */
@@ -393,6 +408,7 @@ perl_destruct(pTHXx)
 
     Safefree(PL_inplace);
     PL_inplace = Nullch;
+    SvREFCNT_dec(PL_patchlevel);
 
     if (PL_e_script) {
        SvREFCNT_dec(PL_e_script);
@@ -437,11 +453,11 @@ perl_destruct(pTHXx)
     /* startup and shutdown function lists */
     SvREFCNT_dec(PL_beginav);
     SvREFCNT_dec(PL_endav);
-    SvREFCNT_dec(PL_stopav);
+    SvREFCNT_dec(PL_checkav);
     SvREFCNT_dec(PL_initav);
     PL_beginav = Nullav;
     PL_endav = Nullav;
-    PL_stopav = Nullav;
+    PL_checkav = Nullav;
     PL_initav = Nullav;
 
     /* shortcuts just get cleared */
@@ -598,7 +614,6 @@ perl_destruct(pTHXx)
 
     /* No SVs have survived, need to clean out */
     Safefree(PL_origfilename);
-    Safefree(PL_archpat_auto);
     Safefree(PL_reg_start_tmp);
     if (PL_reg_curpm)
        Safefree(PL_reg_curpm);
@@ -727,8 +742,8 @@ setuid perl scripts securely.\n");
                env, xsinit);
     switch (ret) {
     case 0:
-       if (PL_stopav)
-           call_list(oldscope, PL_stopav);
+       if (PL_checkav)
+           call_list(oldscope, PL_checkav);
        return 0;
     case 1:
        STATUS_ALL_FAILURE;
@@ -739,8 +754,8 @@ setuid perl scripts securely.\n");
            LEAVE;
        FREETMPS;
        PL_curstash = PL_defstash;
-       if (PL_stopav)
-           call_list(oldscope, PL_stopav);
+       if (PL_checkav)
+           call_list(oldscope, PL_checkav);
        return STATUS_NATIVE_EXPORT;
     case 3:
        PerlIO_printf(Perl_error_log, "panic: top_env\n");
@@ -884,6 +899,21 @@ S_parse_body(pTHX_ va_list args)
 #  ifdef USE_THREADS
                sv_catpv(PL_Sv," USE_THREADS");
 #  endif
+#  ifdef USE_ITHREADS
+               sv_catpv(PL_Sv," USE_ITHREADS");
+#  endif
+#  ifdef USE_64_BITS
+               sv_catpv(PL_Sv," USE_64_BITS");
+#  endif
+#  ifdef USE_LONG_DOUBLE
+               sv_catpv(PL_Sv," USE_LONG_DOUBLE");
+#  endif
+#  ifdef USE_LARGE_FILES
+               sv_catpv(PL_Sv," USE_LARGE_FILES");
+#  endif
+#  ifdef USE_SOCKS
+               sv_catpv(PL_Sv," USE_SOCKS");
+#  endif
 #  ifdef PERL_OBJECT
                sv_catpv(PL_Sv," PERL_OBJECT");
 #  endif
@@ -1850,13 +1880,8 @@ Perl_moreswitches(pTHX_ char *s)
        s++;
        return s;
     case 'v':
-#if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
-       printf("\nThis is perl, version %d.%03d_%02d built for %s",
-           PERL_REVISION, PERL_VERSION, PERL_SUBVERSION, ARCHNAME);
-#else
-       printf("\nThis is perl, version %s built for %s",
-               PL_patchlevel, ARCHNAME);
-#endif
+       printf("\nThis is perl, v%"UVuf".%"UVuf".%"UVuf" built for %s",
+              (UV)PERL_REVISION, (UV)PERL_VERSION, (UV)PERL_SUBVERSION, ARCHNAME);
 #if defined(LOCAL_PATCH_COUNT)
        if (LOCAL_PATCH_COUNT > 0)
            printf("\n(with %d registered patch%s, see perl -V for more detail)",
@@ -2169,7 +2194,7 @@ sed %s -e \"/^[^#]/b\" \
  -e \"/^#[     ]*undef[        ]/b\" \
  -e \"/^#[     ]*endif/b\" \
  -e \"s/^#.*//\" \
- %s | %_ -C %_ %s",
+ %s | %"SVf" -C %"SVf" %s",
          (PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
 #else
 #  ifdef __OPEN_VM
@@ -2185,7 +2210,7 @@ sed %s -e \"/^[^#]/b\" \
  -e '/^#[      ]*undef[        ]/b' \
  -e '/^#[      ]*endif/b' \
  -e 's/^[      ]*#.*//' \
- %s | %_ %_ %s",
+ %s | %"SVf" %"SVf" %s",
 #  else
        Perl_sv_setpvf(aTHX_ cmd, "\
 %s %s -e '/^[^#]/b' \
@@ -2199,7 +2224,7 @@ sed %s -e \"/^[^#]/b\" \
  -e '/^#[      ]*undef[        ]/b' \
  -e '/^#[      ]*endif/b' \
  -e 's/^[      ]*#.*//' \
- %s | %_ -C %_ %s",
+ %s | %"SVf" -C %"SVf" %s",
 #  endif
 #ifdef LOC_SED
          LOC_SED,
@@ -2252,7 +2277,9 @@ sed %s -e \"/^[^#]/b\" \
            PL_statbuf.st_mode & (S_ISUID|S_ISGID))
        {
            /* try again */
-           PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
+           PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
+                                    (int)PERL_REVISION, (int)PERL_VERSION,
+                                    (int)PERL_SUBVERSION), PL_origargv);
            Perl_croak(aTHX_ "Can't do setuid\n");
        }
 #endif
@@ -2499,7 +2526,9 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
            (void)PerlIO_close(PL_rsfp);
 #ifndef IAMSUID
            /* try again */
-           PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
+           PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
+                                    (int)PERL_REVISION, (int)PERL_VERSION,
+                                    (int)PERL_SUBVERSION), PL_origargv);
 #endif
            Perl_croak(aTHX_ "Can't do setuid\n");
        }
@@ -2581,7 +2610,9 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
 #if defined(HAS_FCNTL) && defined(F_SETFD)
     fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0);   /* ensure no close-on-exec */
 #endif
-    PerlProc_execv(Perl_form(aTHX_ "%s/perl%s", BIN_EXP, PL_patchlevel), PL_origargv);/* try again */
+    PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
+                            (int)PERL_REVISION, (int)PERL_VERSION,
+                            (int)PERL_SUBVERSION), PL_origargv);/* try again */
     Perl_croak(aTHX_ "Can't do setuid\n");
 #endif /* IAMSUID */
 #else /* !DOSUID */
@@ -2811,7 +2842,7 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register
        for (; argc > 0 && **argv == '-'; argc--,argv++) {
            if (!argv[0][1])
                break;
-           if (argv[0][1] == '-') {
+           if (argv[0][1] == '-' && !argv[0][2]) {
                argc--,argv++;
                break;
            }
@@ -2978,17 +3009,6 @@ S_incpush(pTHX_ char *p, int addsubdirs)
 
     if (addsubdirs) {
        subdir = sv_newmortal();
-       if (!PL_archpat_auto) {
-           STRLEN len = (sizeof(ARCHNAME) + strlen(PL_patchlevel)
-                         + sizeof("//auto"));
-           New(55, PL_archpat_auto, len, char);
-           sprintf(PL_archpat_auto, "/%s/%s/auto", ARCHNAME, PL_patchlevel);
-#ifdef VMS
-       for (len = sizeof(ARCHNAME) + 2;
-            PL_archpat_auto[len] != '\0' && PL_archpat_auto[len] != '/'; len++)
-               if (PL_archpat_auto[len] == '.') PL_archpat_auto[len] = '_';
-#endif
-       }
     }
 
     /* Break at all separators */
@@ -3034,16 +3054,16 @@ S_incpush(pTHX_ char *p, int addsubdirs)
                              SvPV(libdir,len));
 #endif
            /* .../archname/version if -d .../archname/version/auto */
-           sv_setsv(subdir, libdir);
-           sv_catpv(subdir, PL_archpat_auto);
+           Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/%s/"PERL_FS_VER_FMT"/auto", libdir,
+                          ARCHNAME, (int)PERL_REVISION,
+                          (int)PERL_VERSION, (int)PERL_SUBVERSION);
            if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
                  S_ISDIR(tmpstatbuf.st_mode))
                av_push(GvAVn(PL_incgv),
                        newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
 
            /* .../archname if -d .../archname/auto */
-           sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
-                     strlen(PL_patchlevel) + 1, "", 0);
+           Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/%s/auto", libdir, ARCHNAME);
            if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
                  S_ISDIR(tmpstatbuf.st_mode))
                av_push(GvAVn(PL_incgv),
@@ -3160,7 +3180,7 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
                else
                    Perl_sv_catpvf(aTHX_ atsv,
                                   "%s failed--call queue aborted",
-                                  paramList == PL_stopav ? "STOP"
+                                  paramList == PL_checkav ? "CHECK"
                                   : paramList == PL_initav ? "INIT"
                                   : "END");
                while (PL_scopestack_ix > oldscope)
@@ -3184,7 +3204,7 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
                    Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
                else
                    Perl_croak(aTHX_ "%s failed--call queue aborted",
-                              paramList == PL_stopav ? "STOP"
+                              paramList == PL_checkav ? "CHECK"
                               : paramList == PL_initav ? "INIT"
                               : "END");
            }
Unnamed repository; edit this file to name it for gitweb.