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
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. */
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();
return 0;
}
- if (main_root)
+ 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;
time(&basetime);
+ mustcatch = FALSE;
switch (Sigsetjmp(top_env,1)) {
case 1:
if (doextract)
find_beginning();
- compcv = (CV*)NEWSV(1104,0);
+ main_cv = compcv = (CV*)NEWSV(1104,0);
sv_upgrade((SV *)compcv, SVt_PVCV);
CvUNIQUE_on(compcv);
runops();
}
else if (main_start) {
+ CvDEPTH(main_cv) = 1;
op = main_start;
runops();
}
{
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)))
goto cleanup;
}
}
+ else
+ mustcatch = TRUE;
if (op == (OP*)&myop)
op = pp_entersub();
}
Copy(oldtop, top_env, 1, Sigjmp_buf);
}
+ else
+ mustcatch = oldmustcatch;
+
if (flags & G_DISCARD) {
stack_sp = stack_base + oldmark;
retval = 0;
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;
# 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
}
(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");
+ 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
}
}
*/
if (addsubdirs) {
struct stat tmpstatbuf;
+#ifdef VMS
+ char *unix;
+ STRLEN len;
- /* .../archname/version if -d .../archname/auto */
+ 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);
if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
av_push(GvAVn(incgv),
newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
- /* .../archname/version if -d .../archname/version/auto */
+ /* .../archname if -d .../archname/auto */
sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
strlen(patchlevel) + 1, "", 0);
if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
{
#ifdef VMS
if (vaxc$errno & 1) {
- if (GETSTATUS_NATIVE & 1) /* fortuitiously includes "-1" */
- SETSTATUS_NATIVE(44);
+ if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
+ STATUS_NATIVE_SET(44);
}
else {
- if (!vaxc$errno && errno) /* someone must have set $^E = 0 */
- SETSTATUS_NATIVE(44);
+ if (!vaxc$errno && errno) /* unlikely */
+ STATUS_NATIVE_SET(44);
else
- SETSTATUS_NATIVE(vaxc$errno);
+ STATUS_NATIVE_SET(vaxc$errno);
}
#else
if (errno & 255)
POPBLOCK(cx,curpm);
LEAVE;
}
+
Siglongjmp(top_env, 2);
}