X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl.c;h=9914935203ed8638132c5f3ac126392ac621e80f;hb=18aba96f40a877297fb70961dbd4be7bc6f1c199;hp=7156ba6ec5b4288cf02af78d4c82fd6d6541d99a;hpb=a05d7ebb5e798334196e3cff205b658506cc4384;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/perl.c b/perl.c
index 7156ba6..9914935 100644
--- a/perl.c
+++ b/perl.c
@@ -1,6 +1,7 @@
 /*    perl.c
  *
- *    Copyright (c) 1987-2002 Larry Wall
+ *    Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
+ *    2000, 2001, 2002, 2003, by Larry Wall and others
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -65,6 +66,7 @@ static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen);
 	    ALLOC_THREAD_KEY;			\
 	    PERL_SET_THX(my_perl);		\
 	    OP_REFCNT_INIT;			\
+	    MUTEX_INIT(&PL_dollarzero_mutex);	\
 	}					\
 	else {					\
 	    PERL_SET_THX(my_perl);		\
@@ -155,9 +157,6 @@ perl_construct(pTHXx)
 
    /* Init the real globals (and main thread)? */
     if (!PL_linestr) {
-#ifdef USE_ITHREADS
-	MUTEX_INIT(&PL_dollarzero_mutex);       /* for $0 modifying */
-#endif
 #ifdef PERL_FLEXIBLE_EXCEPTIONS
 	PL_protect = MEMBER_TO_FPTR(Perl_default_protect); /* for exceptions */
 #endif
@@ -274,6 +273,8 @@ perl_construct(pTHXx)
 #endif
 	 PL_clocktick = HZ;
 
+    PL_stashcache = newHV();
+
     ENTER;
 }
 
@@ -386,6 +387,9 @@ perl_destruct(pTHXx)
 
     Safefree(PL_exitlist);
 
+    PL_exitlist = NULL;
+    PL_exitlistlen = 0;
+
     if (destruct_level == 0){
 
 	DEBUG_P(debprofdump());
@@ -456,6 +460,9 @@ perl_destruct(pTHXx)
     PL_regex_pad = NULL;
 #endif
 
+    SvREFCNT_dec((SV*) PL_stashcache);
+    PL_stashcache = NULL;
+
     /* loosen bonds of global variables */
 
     if(PL_rsfp) {
@@ -782,7 +789,7 @@ perl_destruct(pTHXx)
     if (PL_reg_curpm)
 	Safefree(PL_reg_curpm);
     Safefree(PL_reg_poscache);
-    Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
+    free_tied_hv_pool();
     Safefree(PL_op_mask);
     Safefree(PL_psig_ptr);
     Safefree(PL_psig_name);
@@ -996,10 +1003,6 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
       reswitch:
 	switch (*s) {
 	case 'C':
-#ifdef	WIN32
-	    win32_argv2utf8(argc-1, argv+1);
-	    /* FALL THROUGH */
-#endif
 #ifndef PERL_STRICT_CR
 	case '\r':
 #endif
@@ -1024,6 +1027,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
 	case 'W':
 	case 'X':
 	case 'w':
+	case 'A':
 	    if ((s = moreswitches(s)))
 		goto reswitch;
 	    break;
@@ -1235,7 +1239,7 @@ print \"  \\@INC:\\n    @INC\\n\";");
 		d = s;
 		if (!*s)
 		    break;
-		if (!strchr("DIMUdmtw", *s))
+		if (!strchr("DIMUdmtwA", *s))
 		    Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
 		while (++s && *s) {
 		    if (isSPACE(*s)) {
@@ -1356,14 +1360,15 @@ print \"  \\@INC:\\n    @INC\\n\";");
      * PL_utf8locale is conditionally turned on by
      * locale.c:Perl_init_i18nl10n() if the environment
      * look like the user wants to use UTF-8. */
-    if (PL_unicode) { /* Requires init_predump_symbols(). */
-	 IO* io;
-	 PerlIO* fp;
-	 SV* sv;
-
+    if (PL_unicode) {
+	 /* Requires init_predump_symbols(). */
 	 if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
+	      IO* io;
+	      PerlIO* fp;
+	      SV* sv;
+
 	      /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR
-	       * and the default open discipline. */
+	       * and the default open disciplines. */
 	      if ((PL_unicode & PERL_UNICODE_STDIN_FLAG) &&
 		  PL_stdingv  && (io = GvIO(PL_stdingv)) &&
 		  (fp = IoIFP(io)))
@@ -1393,6 +1398,15 @@ print \"  \\@INC:\\n    @INC\\n\";");
 	 }
     }
 
+    if ((s = PerlEnv_getenv("PERL_SIGNALS"))) {
+	 if (strEQ(s, "unsafe"))
+	      PL_signals |=  PERL_SIGNALS_UNSAFE_FLAG;
+	 else if (strEQ(s, "safe"))
+	      PL_signals &= ~PERL_SIGNALS_UNSAFE_FLAG;
+	 else
+	      Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s);
+    }
+
     init_lexer();
 
     /* now parse the script */
@@ -2072,7 +2086,7 @@ Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
 
 Tells Perl to C<require> the file named by the string argument.  It is
 analogous to the Perl code C<eval "require '$file'">.  It's even
-implemented that way; consider using Perl_load_module instead.
+implemented that way; consider using load_module instead.
 
 =cut */
 
@@ -2153,24 +2167,47 @@ char *
 Perl_moreswitches(pTHX_ char *s)
 {
     STRLEN numlen;
-    U32 rschar;
+    UV rschar;
 
     switch (*s) {
     case '0':
     {
-        I32 flags = 0;
-	numlen = 4;
-	rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
-	SvREFCNT_dec(PL_rs);
-	if (rschar & ~((U8)~0))
-	    PL_rs = &PL_sv_undef;
-	else if (!rschar && numlen >= 2)
-	    PL_rs = newSVpvn("", 0);
-	else {
-	    char ch = (char)rschar;
-	    PL_rs = newSVpvn(&ch, 1);
-	}
-	return s + numlen;
+	 I32 flags = 0;
+
+	 SvREFCNT_dec(PL_rs);
+	 if (s[1] == 'x' && s[2]) {
+	      char *e;
+	      U8 *tmps;
+
+	      for (s += 2, e = s; *e; e++);
+	      numlen = e - s;
+	      flags = PERL_SCAN_SILENT_ILLDIGIT;
+	      rschar = (U32)grok_hex(s, &numlen, &flags, NULL);
+	      if (s + numlen < e) {
+		   rschar = 0; /* Grandfather -0xFOO as -0 -xFOO. */
+		   numlen = 0;
+		   s--;
+	      }
+	      PL_rs = newSVpvn("", 0);
+	      SvGROW(PL_rs, (STRLEN)(UNISKIP(rschar) + 1));
+	      tmps = (U8*)SvPVX(PL_rs);
+	      uvchr_to_utf8(tmps, rschar);
+	      SvCUR_set(PL_rs, UNISKIP(rschar));
+	      SvUTF8_on(PL_rs);
+	 }
+	 else {
+	      numlen = 4;
+	      rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
+	      if (rschar & ~((U8)~0))
+		   PL_rs = &PL_sv_undef;
+	      else if (!rschar && numlen >= 2)
+		   PL_rs = newSVpvn("", 0);
+	      else {
+		   char ch = (char)rschar;
+		   PL_rs = newSVpvn(&ch, 1);
+	      }
+	 }
+	 return s + numlen;
     }
     case 'C':
         s++;
@@ -2319,6 +2356,20 @@ Perl_moreswitches(pTHX_ char *s)
 	    }
 	}
 	return s;
+    case 'A':
+	forbid_setid("-A");
+	if (!PL_preambleav)
+	    PL_preambleav = newAV();
+	if (*++s) {
+	    SV *sv = newSVpvn("use assertions::activate split(/,/,q{",37);
+	    sv_catpv(sv,s);
+	    sv_catpv(sv,"})");
+	    s+=strlen(s);
+	    av_push(PL_preambleav, sv);
+	}
+	else
+	    av_push(PL_preambleav, newSVpvn("use assertions::activate",24));
+	return s;
     case 'M':
 	forbid_setid("-M");	/* XXX ? */
 	/* FALL THROUGH */
@@ -2419,7 +2470,7 @@ Perl_moreswitches(pTHX_ char *s)
 #endif
 
 	PerlIO_printf(PerlIO_stdout(),
-		      "\n\nCopyright 1987-2002, Larry Wall\n");
+		      "\n\nCopyright 1987-2003, Larry Wall\n");
 #ifdef MACOS_TRADITIONAL
 	PerlIO_printf(PerlIO_stdout(),
 		      "\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n"
@@ -2476,8 +2527,8 @@ Perl_moreswitches(pTHX_ char *s)
 		      "EPOC port by Olaf Flebbe, 1999-2002\n");
 #endif
 #ifdef UNDER_CE
-	printf("WINCE port by Rainer Keuchel, 2001-2002\n");
-	printf("Built on " __DATE__ " " __TIME__ "\n\n");
+	PerlIO_printf(PerlIO_stdout(),"WINCE port by Rainer Keuchel, 2001-2002\n");
+	PerlIO_printf(PerlIO_stdout(),"Built on " __DATE__ " " __TIME__ "\n\n");
 	wce_hitreturn();
 #endif
 #ifdef BINARY_BUILD_NOTICE
@@ -3265,6 +3316,8 @@ Perl_init_debugger(pTHX)
     sv_setiv(PL_DBtrace, 0);
     PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
     sv_setiv(PL_DBsignal, 0);
+    PL_DBassertion = GvSV((gv_fetchpv("assertion", GV_ADDMULTI, SVt_PV)));
+    sv_setiv(PL_DBassertion, 0);
     PL_curstash = ostash;
 }
 
@@ -3414,8 +3467,10 @@ Perl_init_argv_symbols(pTHX_ register int argc, register char **argv)
 	for (; argc > 0; argc--,argv++) {
 	    SV *sv = newSVpv(argv[0],0);
 	    av_push(GvAVn(PL_argvgv),sv);
-	    if (PL_unicode & PERL_UNICODE_ARGV_FLAG)
-		 SvUTF8_on(sv);
+	    if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
+		 if (PL_unicode & PERL_UNICODE_ARGV_FLAG)
+		      SvUTF8_on(sv);
+	    }
 	    if (PL_unicode & PERL_UNICODE_WIDESYSCALLS_FLAG) /* Sarathy? */
 		 (void)sv_utf8_decode(sv);
 	}