Clean up and document API for hashes

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

diff --git a/perl.c b/perl.c
index 1e3c6fd..9f3942e 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -198,12 +198,18 @@ register PerlInterpreter *sv_interp;
     LEAVE;
     FREETMPS;
 
-    /* We must account for everything.  First the syntax tree. */
+    /* We must account for everything.  */
+
+    /* Destroy the main CV and syntax tree */
     if (main_root) {
        curpad = AvARRAY(comppad);
        op_free(main_root);
-       main_root = 0;
+       main_root = Nullop;
     }
+    main_start = Nullop;
+    SvREFCNT_dec(main_cv);
+    main_cv = Nullcv;
+
     if (sv_objcount) {
        /*
         * Try to destruct global references.  We do this first so that the
@@ -349,13 +355,17 @@ register PerlInterpreter *sv_interp;
     FREETMPS;
     if (destruct_level >= 2) {
        if (scopestack_ix != 0)
-           warn("Unbalanced scopes: %d more ENTERs than LEAVEs\n", scopestack_ix);
+           warn("Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
+                (long)scopestack_ix);
        if (savestack_ix != 0)
-           warn("Unbalanced saves: %d more saves than restores\n", savestack_ix);
+           warn("Unbalanced saves: %ld more saves than restores\n",
+                (long)savestack_ix);
        if (tmps_floor != -1)
-           warn("Unbalanced tmps: %d more allocs than frees\n", tmps_floor + 1);
+           warn("Unbalanced tmps: %ld more allocs than frees\n",
+                (long)tmps_floor + 1);
        if (cxstack_ix != -1)
-           warn("Unbalanced context: %d more PUSHes than POPs\n", cxstack_ix + 1);
+           warn("Unbalanced context: %ld more PUSHes than POPs\n",
+                (long)cxstack_ix + 1);
     }
 
     /* Now absolutely destruct everything, somehow or other, loops or no. */
@@ -399,7 +409,7 @@ register PerlInterpreter *sv_interp;
     SvREFCNT_dec(strtab);
 
     if (sv_count != 0)
-       warn("Scalars leaked: %d\n", sv_count);
+       warn("Scalars leaked: %ld\n", (long)sv_count);
 
     sv_free_arenas();
 
@@ -476,13 +486,17 @@ setuid perl scripts securely.\n");
        return 0;
     }
 
-    SvREFCNT_dec(main_cv);
-    if (main_root)
+    if (main_root) {
+       curpad = AvARRAY(comppad);
        op_free(main_root);
-    main_cv = 0;
-    main_start = main_root = 0;
+       main_root = Nullop;
+    }
+    main_start = Nullop;
+    SvREFCNT_dec(main_cv);
+    main_cv = Nullcv;
 
     time(&basetime);
+    mustcatch = FALSE;
 
     switch (Sigsetjmp(top_env,1)) {
     case 1:
@@ -935,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)))
@@ -1026,6 +1045,8 @@ I32 flags;                /* See G_* flags in cop.h */
            goto cleanup;
        }
     }
+    else
+       mustcatch = TRUE;
 
     if (op == (OP*)&myop)
        op = pp_entersub();
@@ -1052,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;
@@ -1422,6 +1446,10 @@ GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n")
     case '\n':
     case '\t':
        break;
+#ifdef ALTERNATE_SHEBANG
+    case 'S':                  /* OS/2 needs -S on "extproc" line. */
+       break;
+#endif
     case 'P':
        if (preprocess)
            return s+1;
@@ -1454,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
 }
 
@@ -1785,12 +1813,12 @@ char *scriptname;
                (void)PerlIO_close(rsfp);
                if (rsfp = my_popen("/bin/mail root","w")) {    /* heh, heh */
                    PerlIO_printf(rsfp,
-"User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\
-(Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n",
-                       uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino,
-                       statbuf.st_dev, statbuf.st_ino,
+"User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
+(Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
+                       (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
+                       (long)statbuf.st_dev, (long)statbuf.st_ino,
                        SvPVX(GvSV(curcop->cop_filegv)),
-                       statbuf.st_uid, statbuf.st_gid);
+                       (long)statbuf.st_uid, (long)statbuf.st_gid);
                    (void)my_pclose(rsfp);
                }
                croak("Permission denied\n");
@@ -2319,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
        }
     }
 
@@ -2350,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);
@@ -2471,7 +2517,7 @@ my_failure_exit()
            STATUS_NATIVE_SET(44);
     }
     else {
-       if (!vaxc$errno && errno)       /* someone must have set $^E = 0 */
+       if (!vaxc$errno && errno)       /* unlikely */
            STATUS_NATIVE_SET(44);
        else
            STATUS_NATIVE_SET(vaxc$errno);
@@ -2508,5 +2554,6 @@ my_exit_jump()
        POPBLOCK(cx,curpm);
        LEAVE;
     }
+
     Siglongjmp(top_env, 2);
 }