Clean up and document API for hashes

[p5sagit/p5-mst-13.2.git] / perl.c

diff --git a/perl.c b/perl.c
index be2f7d8..9f3942e 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -496,6 +496,7 @@ setuid perl scripts securely.\n");
     main_cv = Nullcv;
 
     time(&basetime);
+    mustcatch = FALSE;
 
     switch (Sigsetjmp(top_env,1)) {
     case 1:
@@ -948,31 +949,36 @@ I32 flags;                /* See G_* flags in cop.h */
 {
     LOGOP myop;                /* fake syntax tree node */
     SV** sp = stack_sp;
-    I32 oldmark = TOPMARK;
+    I32 oldmark;
     I32 retval;
     Sigjmp_buf oldtop;
     I32 oldscope;
     static CV *DBcv;
-    
+    bool oldmustcatch = mustcatch;
+
     if (flags & G_DISCARD) {
        ENTER;
        SAVETMPS;
     }
 
+    Zero(&myop, 1, LOGOP);
+    if (flags & G_NOARGS) {
+       PUSHMARK(sp);
+    }
+    else
+       myop.op_flags |= OPf_STACKED;
+    myop.op_next = Nullop;
+    myop.op_flags |= OPf_KNOW;
+    if (flags & G_ARRAY)
+       myop.op_flags |= OPf_LIST;
     SAVESPTR(op);
     op = (OP*)&myop;
-    Zero(op, 1, LOGOP);
+
     EXTEND(stack_sp, 1);
     *++stack_sp = sv;
+    oldmark = TOPMARK;
     oldscope = scopestack_ix;
 
-    if (!(flags & G_NOARGS))
-       myop.op_flags = OPf_STACKED;
-    myop.op_next = Nullop;
-    myop.op_flags |= OPf_KNOW;
-    if (flags & G_ARRAY)
-      myop.op_flags |= OPf_LIST;
-
     if (perldb && curstash != debstash
           /* Handle first BEGIN of -d. */
          && (DBcv || (DBcv = GvCV(DBsub)))
@@ -1039,6 +1045,8 @@ I32 flags;                /* See G_* flags in cop.h */
            goto cleanup;
        }
     }
+    else
+       mustcatch = TRUE;
 
     if (op == (OP*)&myop)
        op = pp_entersub();
@@ -1065,6 +1073,9 @@ I32 flags;                /* See G_* flags in cop.h */
        }
        Copy(oldtop, top_env, 1, Sigjmp_buf);
     }
+    else
+       mustcatch = oldmustcatch;
+
     if (flags & G_DISCARD) {
        stack_sp = stack_base + oldmark;
        retval = 0;
@@ -1435,13 +1446,13 @@ GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n")
     case '\n':
     case '\t':
        break;
-    case 'P':
-       if (preprocess)
-           return s+1;
 #ifdef ALTERNATE_SHEBANG
     case 'S':                  /* OS/2 needs -S on "extproc" line. */
        break;
 #endif
+    case 'P':
+       if (preprocess)
+           return s+1;
        /* FALL THROUGH */
     default:
        croak("Can't emulate -%.1s on #! line",s);
@@ -1471,9 +1482,9 @@ my_unexec()
 #  ifdef VMS
 #    include <lib$routines.h>
      lib$signal(SS$_DEBUG);  /* ssdef.h #included from vmsish.h */
-#else
+#  else
     ABORT();           /* for use with undump */
-#endif
+#  endif
 #endif
 }
 
@@ -2336,6 +2347,11 @@ int addsubdirs;
                          + sizeof("//auto"));
            New(55, archpat_auto, len, char);
            sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
+#ifdef VMS
+       for (len = sizeof(ARCHNAME) + 2;
+            archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
+               if (archpat_auto[len] == '.') archpat_auto[len] = '_';
+#endif
        }
     }
 
@@ -2367,7 +2383,20 @@ int addsubdirs;
         */
        if (addsubdirs) {
            struct stat tmpstatbuf;
+#ifdef VMS
+           char *unix;
+           STRLEN len;
 
+           if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
+               len = strlen(unix);
+               while (unix[len-1] == '/') len--;  /* Cosmetic */
+               sv_usepvn(libdir,unix,len);
+           }
+           else
+               PerlIO_printf(PerlIO_stderr(),
+                             "Failed to unixify @INC element \"%s\"\n",
+                             SvPV(libdir,na));
+#endif
            /* .../archname/version if -d .../archname/version/auto */
            sv_setsv(subdir, libdir);
            sv_catpv(subdir, archpat_auto);