Integrate:

[perl5.git] / perl.c

diff --git a/perl.c b/perl.c
index d19ae96..989d1e3 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -1,6 +1,7 @@
 /*    perl.c
  *
- *    Copyright (c) 1987-2003 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.
@@ -75,6 +76,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);              \
@@ -193,10 +195,6 @@ perl_construct(pTHXx)
        thr = init_main_thread();
 #endif /* USE_5005THREADS */
 
-#if defined(USE_5005THREADS) || defined(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
@@ -316,6 +314,8 @@ perl_construct(pTHXx)
 #endif
         PL_clocktick = HZ;
 
+    PL_stashcache = newHV();
+
     ENTER;
 }
 
@@ -500,6 +500,9 @@ perl_destruct(pTHXx)
 
     Safefree(PL_exitlist);
 
+    PL_exitlist = NULL;
+    PL_exitlistlen = 0;
+
     if (destruct_level == 0){
 
        DEBUG_P(debprofdump());
@@ -570,6 +573,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) {
@@ -896,7 +902,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);
@@ -1127,10 +1133,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
@@ -2213,7 +2215,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 */
 
@@ -2294,24 +2296,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++;
@@ -2617,8 +2642,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
@@ -3607,6 +3632,10 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register
     char *s;
     SV *sv;
     GV* tmpgv;
+#ifdef NEED_ENVIRON_DUP_FOR_MODIFY
+    char **dup_env_base = 0;
+    int dup_env_count = 0;
+#endif
 
     PL_toptarget = NEWSV(0,0);
     sv_upgrade(PL_toptarget, SVt_PVFM);
@@ -3661,6 +3690,26 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register
        {
            environ[0] = Nullch;
        }
+#ifdef NEED_ENVIRON_DUP_FOR_MODIFY
+       {
+           char **env_base;
+           for (env_base = env; *env; env++) 
+               dup_env_count++;
+           if ((dup_env_base = (char **)
+                safesysmalloc( sizeof(char *) * (dup_env_count+1) ))) {
+               char **dup_env;
+               for (env = env_base, dup_env = dup_env_base;
+                    *env;
+                    env++, dup_env++) {
+                   /* With environ one needs to use safesysmalloc(). */
+                   *dup_env = safesysmalloc(strlen(*env) + 1);
+                   (void)strcpy(*dup_env, *env);
+               }
+               *dup_env = Nullch;
+               env = dup_env_base;
+           } /* else what? */
+       }
+#endif /* NEED_ENVIRON_DUP_FOR_MODIFY */
        if (env)
          for (; *env; env++) {
            if (!(s = strchr(*env,'=')))
@@ -3675,6 +3724,14 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register
            if (env != environ)
                mg_set(sv);
          }
+#ifdef NEED_ENVIRON_DUP_FOR_MODIFY
+       if (dup_env_base) {
+           char **dup_env;
+           for (dup_env = dup_env_base; *dup_env; dup_env++)
+               safesysfree(*dup_env);
+           safesysfree(dup_env_base);
+       }
+#endif /* NEED_ENVIRON_DUP_FOR_MODIFY */
 #endif /* USE_ENVIRON_ARRAY */
     }
     TAINT_NOT;
@@ -4071,7 +4128,6 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
            atsv = ERRSV;
            (void)SvPV(atsv, len);
            if (len) {
-               STRLEN n_a;
                PL_curcop = &PL_compiling;
                CopLINE_set(PL_curcop, oldline);
                if (paramList == PL_beginav)
@@ -4085,7 +4141,7 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
                while (PL_scopestack_ix > oldscope)
                    LEAVE;
                JMPENV_POP;
-               Perl_croak(aTHX_ "%s", SvPVx(atsv, n_a));
+               Perl_croak(aTHX_ "%"SVf"", atsv);
            }
            break;
        case 1: