X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl.c;h=be11625eb839cb317dcec6118470a803147bc043;hb=0e455d2b24396ba08377dc3cf2d01e6db5f47048;hp=2c7a4c19ec6092e067a9b72501af6cfa35017adf;hpb=efa50c51e3301a2ca8be765fedfdae78eff1615b;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/perl.c b/perl.c
index 2c7a4c1..be11625 100644
--- a/perl.c
+++ b/perl.c
@@ -26,6 +26,7 @@
 #define PERL_IN_PERL_C
 #include "perl.h"
 #include "patchlevel.h"			/* for local_patches */
+#include "XSUB.h"
 
 #ifdef NETWARE
 #include "nwutil.h"	
@@ -985,7 +986,6 @@ perl_destruct(pTHXx)
 
     /* clear utf8 character classes */
     SvREFCNT_dec(PL_utf8_alnum);
-    SvREFCNT_dec(PL_utf8_alnumc);
     SvREFCNT_dec(PL_utf8_ascii);
     SvREFCNT_dec(PL_utf8_alpha);
     SvREFCNT_dec(PL_utf8_space);
@@ -1005,7 +1005,6 @@ perl_destruct(pTHXx)
     SvREFCNT_dec(PL_utf8_idstart);
     SvREFCNT_dec(PL_utf8_idcont);
     PL_utf8_alnum	= NULL;
-    PL_utf8_alnumc	= NULL;
     PL_utf8_ascii	= NULL;
     PL_utf8_alpha	= NULL;
     PL_utf8_space	= NULL;
@@ -1228,16 +1227,18 @@ perl_destruct(pTHXx)
     Safefree(PL_reg_poscache);
     free_tied_hv_pool();
     Safefree(PL_op_mask);
-    Safefree(PL_psig_ptr);
-    PL_psig_ptr = (SV**)NULL;
     Safefree(PL_psig_name);
     PL_psig_name = (SV**)NULL;
-#ifdef MULTIPLICITY
-    Safefree(my_perl->Ibitcount);
-    my_perl->Ibitcount = NULL;
-#endif
+    PL_psig_ptr = (SV**)NULL;
     Safefree(PL_psig_pend);
     PL_psig_pend = (int*)NULL;
+    {
+	/* We need to NULL PL_psig_pend first, so that
+	   signal handlers know not to use it */
+	int *psig_save = PL_psig_pend;
+	PL_psig_pend = (int*)NULL;
+	Safefree(psig_save);
+    }
     PL_formfeed = NULL;
     nuke_stacks();
     PL_tainting = FALSE;
@@ -1626,6 +1627,92 @@ perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
     return ret;
 }
 
+/* This needs to stay in perl.c, as perl.c is compiled with different flags for
+   miniperl, and we need to see those flags reflected in the values here.  */
+
+/* What this returns is subject to change.  Use the public interface in Config.
+ */
+static void
+S_Internals_V(pTHX_ CV *cv)
+{
+    dXSARGS;
+#ifdef LOCAL_PATCH_COUNT
+    const int local_patch_count = LOCAL_PATCH_COUNT;
+#else
+    const int local_patch_count = 0;
+#endif
+    const int entries = 4 + local_patch_count;
+    int i;
+    static char non_bincompat_options[] = 
+#  ifdef DEBUGGING
+			     " DEBUGGING"
+#  endif
+#  ifdef NO_MATHOMS
+                            " NO_MATHOMS"
+#  endif
+#  ifdef PERL_DISABLE_PMC
+			     " PERL_DISABLE_PMC"
+#  endif
+#  ifdef PERL_DONT_CREATE_GVSV
+			     " PERL_DONT_CREATE_GVSV"
+#  endif
+#  ifdef PERL_IS_MINIPERL
+			     " PERL_IS_MINIPERL"
+#  endif
+#  ifdef PERL_MALLOC_WRAP
+			     " PERL_MALLOC_WRAP"
+#  endif
+#  ifdef PERL_MEM_LOG
+			     " PERL_MEM_LOG"
+#  endif
+#  ifdef PERL_MEM_LOG_NOIMPL
+			     " PERL_MEM_LOG_NOIMPL"
+#  endif
+#  ifdef PERL_USE_DEVEL
+			     " PERL_USE_DEVEL"
+#  endif
+#  ifdef PERL_USE_SAFE_PUTENV
+			     " PERL_USE_SAFE_PUTENV"
+#  endif
+#  ifdef USE_SITECUSTOMIZE
+			     " USE_SITECUSTOMIZE"
+#  endif	       
+#  ifdef USE_FAST_STDIO
+			     " USE_FAST_STDIO"
+#  endif	       
+	;
+    PERL_UNUSED_ARG(cv);
+    PERL_UNUSED_ARG(items);
+
+    EXTEND(SP, entries);
+
+    PUSHs(sv_2mortal(newSVpv(PL_bincompat_options, 0)));
+    PUSHs(Perl_newSVpvn_flags(aTHX_ non_bincompat_options,
+			      sizeof(non_bincompat_options) - 1, SVs_TEMP));
+
+#ifdef __DATE__
+#  ifdef __TIME__
+    PUSHs(Perl_newSVpvn_flags(aTHX_
+			      STR_WITH_LEN("Compiled at " __DATE__ " " __TIME__),
+			      SVs_TEMP));
+#  else
+    PUSHs(Perl_newSVpvn_flags(aTHX_ STR_WITH_LEN("Compiled on " __DATE__),
+			      SVs_TEMP));
+#  endif
+#else
+    PUSHs(&PL_sv_undef);
+#endif
+
+    PUSHs(Perl_newSVpvn_flags(aTHX_ STR_WITH_LEN(OSNAME), SVs_TEMP));
+
+    for (i = 1; i <= local_patch_count; i++) {
+	/* This will be an undef, if PL_localpatches[i] is NULL.  */
+	PUSHs(sv_2mortal(newSVpv(PL_localpatches[i], 0)));
+    }
+
+    XSRETURN(entries);
+}
+
 #define INCPUSH_UNSHIFT			0x01
 #define INCPUSH_ADD_OLD_VERS		0x02
 #define INCPUSH_ADD_VERSIONED_SUB_DIRS	0x04
@@ -1757,103 +1844,17 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
 	    {
 		SV *opts_prog;
 
-		Perl_av_create_and_push(aTHX_ &PL_preambleav, newSVpvs("use Config;"));
 		if (*++s != ':')  {
-		    /* Can't do newSVpvs() as that would involve pre-processor
-		       condititionals inside a macro expansion.  */
-		    opts_prog = Perl_newSVpv(aTHX_ "$_ = join ' ', sort qw("
-#  ifdef DEBUGGING
-			     " DEBUGGING"
-#  endif
-#  ifdef NO_MATHOMS
-                            " NO_MATHOMS"
-#  endif
-#  ifdef PERL_DONT_CREATE_GVSV
-			     " PERL_DONT_CREATE_GVSV"
-#  endif
-#  ifdef PERL_MALLOC_WRAP
-			     " PERL_MALLOC_WRAP"
-#  endif
-#  ifdef PERL_MEM_LOG
-			     " PERL_MEM_LOG"
-#  endif
-#  ifdef PERL_MEM_LOG_ENV
-			     " PERL_MEM_LOG_ENV"
-#  endif
-#  ifdef PERL_MEM_LOG_ENV_FD
-			     " PERL_MEM_LOG_ENV_FD"
-#  endif
-#  ifdef PERL_MEM_LOG_STDERR
-			     " PERL_MEM_LOG_STDERR"
-#  endif
-#  ifdef PERL_MEM_LOG_TIMESTAMP
-			     " PERL_MEM_LOG_TIMESTAMP"
-#  endif
-#  ifdef PERL_USE_DEVEL
-			     " PERL_USE_DEVEL"
-#  endif
-#  ifdef PERL_USE_SAFE_PUTENV
-			     " PERL_USE_SAFE_PUTENV"
-#  endif
-#  ifdef USE_SITECUSTOMIZE
-			     " USE_SITECUSTOMIZE"
-#  endif	       
-#  ifdef USE_FAST_STDIO
-			     " USE_FAST_STDIO"
-#  endif	       
-					     , 0);
-
-		    sv_catpv(opts_prog, PL_bincompat_options);
-		    /* Terminate the qw(, and then wrap at 76 columns.  */
-		    sv_catpvs(opts_prog, "); s/(?=.{53})(.{1,53}) /$1\\n                        /mg;print Config::myconfig(),");
-#ifdef VMS
-		    sv_catpvs(opts_prog,"\"\\nCharacteristics of this PERLSHR image: \\n");
-#else
-		    sv_catpvs(opts_prog,"\"\\nCharacteristics of this binary (from libperl): \\n");
-#endif
-		    sv_catpvs(opts_prog,"  Compile-time options: $_\\n\",");
-
-#if defined(LOCAL_PATCH_COUNT)
-		    if (LOCAL_PATCH_COUNT > 0) {
-			int i;
-			sv_catpvs(opts_prog,
-				 "\"  Locally applied patches:\\n\",");
-			for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
-			    if (PL_localpatches[i])
-				Perl_sv_catpvf(aTHX_ opts_prog,"q%c\t%s\n%c,",
-				    0, PL_localpatches[i], 0);
-			}
-		    }
-#endif
-		    Perl_sv_catpvf(aTHX_ opts_prog,
-				   "\"  Built under %s\\n",OSNAME);
-#ifdef __DATE__
-#  ifdef __TIME__
-		    sv_catpvs(opts_prog,
-			      "  Compiled at " __DATE__ " " __TIME__ "\\n\"");
-#  else
-		    sv_catpvs(opts_prog, "  Compiled on " __DATE__ "\\n\"");
-#  endif
-#endif
-		    sv_catpvs(opts_prog, "; $\"=\"\\n    \"; "
-			     "@env = map { \"$_=\\\"$ENV{$_}\\\"\" } "
-			     "sort grep {/^PERL/} keys %ENV; ");
-#ifdef __CYGWIN__
-		    sv_catpvs(opts_prog,
-			     "push @env, \"CYGWIN=\\\"$ENV{CYGWIN}\\\"\";");
-#endif
-		    sv_catpvs(opts_prog, 
-			     "print \"  \\%ENV:\\n    @env\\n\" if @env;"
-			     "print \"  \\@INC:\\n    @INC\\n\";");
+		    opts_prog = newSVpvs("use Config; Config::_V()");
 		}
 		else {
 		    ++s;
 		    opts_prog = Perl_newSVpvf(aTHX_
-					      "Config::config_vars(qw%c%s%c)",
+					      "use Config; Config::config_vars(qw%c%s%c)",
 					      0, s, 0);
 		    s += strlen(s);
 		}
-		av_push(PL_preambleav, opts_prog);
+		Perl_av_create_and_push(aTHX_ &PL_preambleav, opts_prog);
 		/* don't look for script or read stdin */
 		scriptname = BIT_BUCKET;
 		goto reswitch;
@@ -1946,10 +1947,15 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
     }
     }
 
-#ifdef USE_SITECUSTOMIZE
+#if defined(USE_SITECUSTOMIZE) && !defined(PERL_IS_MINIPERL)
     if (!minus_f) {
+	/* SITELIB_EXP is a function call on Win32.
+	   The games with local $! are to avoid setting errno if there is no
+	   sitecustomize script.  */
+	const char *const sitelib = SITELIB_EXP;
 	(void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav,
-					     Perl_newSVpvf(aTHX_ "BEGIN { do '%s/sitecustomize.pl' }", SITELIB_EXP));
+					     Perl_newSVpvf(aTHX_
+							   "BEGIN { do {local $!; -f '%s/sitecustomize.pl'} && do '%s/sitecustomize.pl' }", sitelib, sitelib));
     }
 #endif
 
@@ -2022,6 +2028,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
     boot_core_PerlIO();
     boot_core_UNIVERSAL();
     boot_core_mro();
+    newXS("Internals::V", S_Internals_V, __FILE__);
 
     if (xsinit)
 	(*xsinit)(aTHX);	/* in case linked C routines want magical variables */
@@ -2053,6 +2060,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
 #if defined(__SYMBIAN32__)
     PL_unicode = PERL_UNICODE_STD_FLAG; /* See PERL_SYMBIAN_CONSOLE_UTF8. */
 #endif
+#  ifndef PERL_IS_MINIPERL
     if (PL_unicode) {
 	 /* Requires init_predump_symbols(). */
 	 if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
@@ -2091,6 +2099,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
 	      }
 	 }
     }
+#endif
 
     {
 	const char *s;
@@ -2257,8 +2266,9 @@ S_run_body(pTHX_ I32 oldscope)
 	    exit(0);	/* less likely to core dump than my_exit(0) */
 	}
 #endif
-	DEBUG_x(dump_all());
 #ifdef DEBUGGING
+	if (DEBUG_x_TEST || DEBUG_B_TEST)
+	    dump_all_perl(!DEBUG_B_TEST);
 	if (!DEBUG_q_TEST)
 	  PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
 #endif
@@ -2488,9 +2498,13 @@ Perl_call_method(pTHX_ const char *methname, I32 flags)
                		/* name of the subroutine */
           		/* See G_* flags in cop.h */
 {
+    STRLEN len;
     PERL_ARGS_ASSERT_CALL_METHOD;
 
-    return call_sv(sv_2mortal(newSVpv(methname,0)), flags | G_METHOD);
+    len = strlen(methname);
+
+    /* XXX: sv_2mortal(newSVpvn_share(methname, len)) can be faster */
+    return call_sv(newSVpvn_flags(methname, len, SVs_TEMP), flags | G_METHOD);
 }
 
 /* May be called with any of a CV, a GV, or an SV containing the name. */
@@ -2867,6 +2881,8 @@ Perl_get_debug_opts(pTHX_ const char **s, bool givehelp)
       "  C  Copy On Write",
       "  A  Consistency checks on internal structures",
       "  q  quiet - currently only suppresses the 'EXECUTING' message",
+      "  M  trace smart match resolution",
+      "  B  dump suBroutine definitions, including special Blocks like BEGIN",
       NULL
     };
     int i = 0;
@@ -2875,7 +2891,7 @@ Perl_get_debug_opts(pTHX_ const char **s, bool givehelp)
 
     if (isALPHA(**s)) {
 	/* if adding extra options, remember to update DEBUG_MASK */
-	static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAq";
+	static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAqMB";
 
 	for (; isALNUM(**s); (*s)++) {
 	    const char * const d = strchr(debopts,**s);
@@ -3278,10 +3294,6 @@ Perl_moreswitches(pTHX_ const char *s)
 	PerlIO_printf(PerlIO_stdout(),
 		      "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
 #endif
-#ifdef __MINT__
-	PerlIO_printf(PerlIO_stdout(),
-		      "MiNT port by Guido Flohr, 1997-1999\n");
-#endif
 #ifdef EPOC
 	PerlIO_printf(PerlIO_stdout(),
 		      "EPOC port by Olaf Flebbe, 1999-2002\n");
@@ -3940,11 +3952,6 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register
 
     if ((tmpgv = gv_fetchpvs("0", GV_ADD|GV_NOTQUAL, SVt_PV))) {
 	sv_setpv(GvSV(tmpgv),PL_origfilename);
-	{
-	    GV * const gv = gv_fetchpv("0", GV_ADD, SVt_PV);
-	    if (gv)
-		sv_magic(GvSV(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, "0", 1);
-	}
     }
     if ((PL_envgv = gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV))) {
 	HV *hv;
@@ -4058,6 +4065,10 @@ S_init_perllib(pTHX)
 #endif /* VMS */
     }
 
+#ifndef PERL_IS_MINIPERL
+    /* miniperl gets just -I..., the split of $ENV{PERL5LIB}, and "." in @INC
+       (and not the architecture specific directories from $ENV{PERL5LIB}) */
+
 /* Use the ~-expanded versions of APPLLIB (undocumented),
     ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB
 */
@@ -4188,6 +4199,7 @@ S_init_perllib(pTHX)
 		      INCPUSH_ADD_OLD_VERS|INCPUSH_ADD_ARCHONLY_SUB_DIRS
 		      |INCPUSH_CAN_RELOCATE);
 #endif
+#endif /* !PERL_IS_MINIPERL */
 
     if (!PL_tainting)
 	S_incpush(aTHX_ STR_WITH_LEN("."), 0);