This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
back out previous change (it breaks PERL_OBJECT)
authorGurusamy Sarathy <gsar@cpan.org>
Mon, 15 Jun 1998 08:51:54 +0000 (08:51 +0000)
committerGurusamy Sarathy <gsar@cpan.org>
Mon, 15 Jun 1998 08:51:54 +0000 (08:51 +0000)
p4raw-id: //depot/perl@1136

17 files changed:
ObjXSub.h
cc_runtime.h
embed.h
embedvar.h
global.sym
interp.sym
intrpvar.h
objpp.h
perl.c
perl.h
pod/perldiag.pod
pod/perlguts.pod
pp_ctl.c
proto.h
scope.c
scope.h
util.c

index 5bdac21..605ef1c 100644 (file)
--- a/ObjXSub.h
+++ b/ObjXSub.h
 #define top_env                        pPerl->Perl_top_env
 #undef  toptarget
 #define toptarget              pPerl->Perl_toptarget
-#undef  tryblock_function
-#define tryblock_function      pPerl->Perl_tryblock_function
 #undef  uid
 #define uid                    pPerl->Perl_uid
 #undef  unsafe
 #define ingroup             pPerl->Perl_ingroup
 #undef  init_stacks
 #define init_stacks         pPerl->Perl_init_stacks
-#undef  install_tryblock_method
-#define install_tryblock_method        pPerl->Perl_install_tryblock_method
 #undef  instr
 #define instr               pPerl->Perl_instr
 #undef  intro_my
index 7d28ff5..fe830c0 100644 (file)
 /* Anyone using eval "" deserves this mess */
 #define PP_EVAL(ppaddr, nxt) do {              \
        dJMPENV;                                \
-       int jmpstat;                            \
+       int ret;                                \
        PUTBACK;                                \
-       JMPENV_PUSH(jmpstat);                   \
-       switch (jmpstat) {                      \
-       case JMP_NORMAL:                        \
+       JMPENV_PUSH(ret);                       \
+       switch (ret) {                          \
+       case 0:                                 \
            op = ppaddr(ARGS);                  \
            retstack[retstack_ix - 1] = Nullop; \
            if (op != nxt) runops();            \
            JMPENV_POP;                         \
            break;                              \
-       case JMP_ABNORMAL: JMPENV_POP; JMPENV_JUMP(JMP_ABNORMAL);       \
-       case JMP_MYEXIT: JMPENV_POP; JMPENV_JUMP(JMP_MYEXIT);   \
-       case JMP_EXCEPTION:                                     \
+       case 1: JMPENV_POP; JMPENV_JUMP(1);     \
+       case 2: JMPENV_POP; JMPENV_JUMP(2);     \
+       case 3:                                 \
            JMPENV_POP;                         \
            if (restartop != nxt)               \
-               JMPENV_JUMP(JMP_EXCEPTION);                     \
+               JMPENV_JUMP(3);                 \
        }                                       \
        op = nxt;                               \
        SPAGAIN;                                \
@@ -64,8 +64,8 @@
        int ret;                                \
        JMPENV_PUSH(ret);                       \
        switch (ret) {                          \
-       case JMP_ABNORMAL: JMPENV_POP; JMPENV_JUMP(JMP_ABNORMAL);       \
-       case JMP_MYEXIT: JMPENV_POP; JMPENV_JUMP(JMP_MYEXIT);   \
-       case JMP_EXCEPTION: JMPENV_POP; SPAGAIN; goto label;\
+       case 1: JMPENV_POP; JMPENV_JUMP(1);     \
+       case 2: JMPENV_POP; JMPENV_JUMP(2);     \
+       case 3: JMPENV_POP; SPAGAIN; goto label;\
        }                                       \
     } while (0)
diff --git a/embed.h b/embed.h
index bca4108..c5b537e 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define ingroup                        Perl_ingroup
 #define init_stacks            Perl_init_stacks
 #define init_thread_intern     Perl_init_thread_intern
-#define install_tryblock_method        Perl_install_tryblock_method
 #define instr                  Perl_instr
 #define intro_my               Perl_intro_my
 #define intuit_more            Perl_intuit_more
index 2441767..2e64829 100644 (file)
 #define tainting               (curinterp->Itainting)
 #define threadnum              (curinterp->Ithreadnum)
 #define thrsv                  (curinterp->Ithrsv)
-#define tryblock_function      (curinterp->Itryblock_function)
 #define unsafe                 (curinterp->Iunsafe)
 #define warnhook               (curinterp->Iwarnhook)
 
 #define Itainting              tainting
 #define Ithreadnum             threadnum
 #define Ithrsv                 thrsv
-#define Itryblock_function     tryblock_function
 #define Iunsafe                        unsafe
 #define Iwarnhook              warnhook
 
 #define tainting               Perl_tainting
 #define threadnum              Perl_threadnum
 #define thrsv                  Perl_thrsv
-#define tryblock_function      Perl_tryblock_function
 #define unsafe                 Perl_unsafe
 #define warnhook               Perl_warnhook
 
index a455804..9b3308f 100644 (file)
@@ -367,7 +367,6 @@ ibcmp
 ibcmp_locale
 ingroup
 init_stacks
-install_tryblock_method
 instr
 intro_my
 intuit_more
index 344af2c..7bbb11e 100644 (file)
@@ -186,6 +186,5 @@ tmps_max
 tmps_stack
 top_env
 toptarget
-tryblock_function
 unsafe
 warnhook
index 9f5f41b..74c914b 100644 (file)
@@ -152,8 +152,6 @@ PERLVAR(Iors,               char *)         /* $\ */
 PERLVAR(Iorslen,       STRLEN)         
 PERLVAR(Iofmt,         char *)         /* $# */
 
-PERLVAR(Itryblock_function,    tryblock_f)     /* see scope.h */
-
 /* interpreter atexit processing */
 PERLVARI(Iexitlist,    PerlExitListEntry *, NULL)      /* list of exit functions */
 PERLVARI(Iexitlistlen, I32, 0)                         /* length of same */
diff --git a/objpp.h b/objpp.h
index ba192d2..757a65b 100644 (file)
--- a/objpp.h
+++ b/objpp.h
 #define init_postdump_symbols  CPerlObj::init_postdump_symbols
 #undef  init_stacks
 #define init_stacks       CPerlObj::Perl_init_stacks
-#undef  install_tryblock_method
-#define install_tryblock_method        CPerlObj::Perl_install_tryblock_method
 #undef  intro_my
 #define intro_my          CPerlObj::Perl_intro_my
 #undef  nuke_stacks
diff --git a/perl.c b/perl.c
index a119a45..7b76edf 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -214,8 +214,10 @@ perl_construct(register PerlInterpreter *sv_interp)
     init_ids();
     lex_state = LEX_NOTPARSING;
 
-    install_tryblock_method(0);     /* default to set/longjmp style tryblock */
-    JMPENV_TOPINIT(start_env);
+    start_env.je_prev = NULL;
+    start_env.je_ret = -1;
+    start_env.je_mustcatch = TRUE;
+    top_env     = &start_env;
     STATUS_ALL_SUCCESS;
 
     SET_NUMERIC_STANDARD();
@@ -608,17 +610,6 @@ perl_atexit(void (*fn) (void *), void *ptr)
     ++exitlistlen;
 }
 
-struct try_parse_locals {
-    void (*xsinit)();
-    int argc;
-    char **argv;
-    char **env;
-    I32 oldscope;
-    int ret;
-};
-typedef struct try_parse_locals TRY_PARSE_LOCALS;
-static TRYVTBL PerlParseVtbl;
-
 int
 #ifdef PERL_OBJECT
 CPerlObj::perl_parse(void (*xsinit) (CPerlObj*), int argc, char **argv, char **env)
@@ -627,11 +618,16 @@ perl_parse(PerlInterpreter *sv_interp, void (*xsinit) (void), int argc, char **a
 #endif
 {
     dTHR;
-    TRY_PARSE_LOCALS locals;
-    locals.xsinit = xsinit;
-    locals.argc = argc;
-    locals.argv = argv;
-    locals.env = env;
+    register SV *sv;
+    register char *s;
+    char *scriptname = NULL;
+    VOL bool dosearch = FALSE;
+    char *validarg = "";
+    I32 oldscope;
+    AV* comppadlist;
+    dJMPENV;
+    int ret;
+    int fdscript = -1;
 
 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
 #ifdef IAMSUID
@@ -679,72 +675,455 @@ setuid perl scripts securely.\n");
     main_cv = Nullcv;
 
     time(&basetime);
-    locals.oldscope = scopestack_ix;
+    oldscope = scopestack_ix;
 
-    TRYBLOCK(PerlParseVtbl, locals);
-    return locals.ret;
-}
+    JMPENV_PUSH(ret);
+    switch (ret) {
+    case 1:
+       STATUS_ALL_FAILURE;
+       /* FALL THROUGH */
+    case 2:
+       /* my_exit() was called */
+       while (scopestack_ix > oldscope)
+           LEAVE;
+       FREETMPS;
+       curstash = defstash;
+       if (endav)
+           call_list(oldscope, endav);
+       JMPENV_POP;
+       return STATUS_NATIVE_EXPORT;
+    case 3:
+       JMPENV_POP;
+       PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
+       return 1;
+    }
 
-struct try_run_locals {
-    I32 oldscope;
-    int ret;
-};
-typedef struct try_run_locals TRY_RUN_LOCALS;
-static TRYVTBL PerlRunVtbl;
+    sv_setpvn(linestr,"",0);
+    sv = newSVpv("",0);                /* first used for -I flags */
+    SAVEFREESV(sv);
+    init_main_stash();
 
-int
-#ifdef PERL_OBJECT
-CPerlObj::perl_run(void)
-#else
-perl_run(PerlInterpreter *sv_interp)
+    for (argc--,argv++; argc > 0; argc--,argv++) {
+       if (argv[0][0] != '-' || !argv[0][1])
+           break;
+#ifdef DOSUID
+    if (*validarg)
+       validarg = " PHOOEY ";
+    else
+       validarg = argv[0];
 #endif
-{
-    dTHR;
-    TRY_RUN_LOCALS locals;
+       s = argv[0]+1;
+      reswitch:
+       switch (*s) {
+       case ' ':
+       case '0':
+       case 'F':
+       case 'a':
+       case 'c':
+       case 'd':
+       case 'D':
+       case 'h':
+       case 'i':
+       case 'l':
+       case 'M':
+       case 'm':
+       case 'n':
+       case 'p':
+       case 's':
+       case 'u':
+       case 'U':
+       case 'v':
+       case 'w':
+           if (s = moreswitches(s))
+               goto reswitch;
+           break;
 
-#ifndef PERL_OBJECT
-    if (!(curinterp = sv_interp))
-       return 255;
-#endif
+       case 'T':
+           tainting = TRUE;
+           s++;
+           goto reswitch;
 
-    locals.oldscope = scopestack_ix;
-    TRYBLOCK(PerlRunVtbl, locals);
-    return locals.ret;
-}
+       case 'e':
+           if (euid != uid || egid != gid)
+               croak("No -e allowed in setuid scripts");
+           if (!e_script) {
+               e_script = newSVpv("",0);
+               filter_add(read_e_script, NULL);
+           }
+           if (*++s)
+               sv_catpv(e_script, s);
+           else if (argv[1]) {
+               sv_catpv(e_script, argv[1]);
+               argc--,argv++;
+           }
+           else
+               croak("No code specified for -e");
+           sv_catpv(e_script, "\n");
+           break;
 
-SV*
-perl_get_sv(char *name, I32 create)
-{
-    GV *gv;
-#ifdef USE_THREADS
-    if (name[1] == '\0' && !isALPHA(name[0])) {
-       PADOFFSET tmp = find_threadsv(name);
-       if (tmp != NOT_IN_PAD) {
-           dTHR;
-           return THREADSV(tmp);
+       case 'I':       /* -I handled both here and in moreswitches() */
+           forbid_setid("-I");
+           if (!*++s && (s=argv[1]) != Nullch) {
+               argc--,argv++;
+           }
+           while (s && isSPACE(*s))
+               ++s;
+           if (s && *s) {
+               char *e, *p;
+               for (e = s; *e && !isSPACE(*e); e++) ;
+               p = savepvn(s, e-s);
+               incpush(p, TRUE);
+               sv_catpv(sv,"-I");
+               sv_catpv(sv,p);
+               sv_catpv(sv," ");
+               Safefree(p);
+           }   /* XXX else croak? */
+           break;
+       case 'P':
+           forbid_setid("-P");
+           preprocess = TRUE;
+           s++;
+           goto reswitch;
+       case 'S':
+           forbid_setid("-S");
+           dosearch = TRUE;
+           s++;
+           goto reswitch;
+       case 'V':
+           if (!preambleav)
+               preambleav = newAV();
+           av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
+           if (*++s != ':')  {
+               Sv = newSVpv("print myconfig();",0);
+#ifdef VMS
+               sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
+#else
+               sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
+#endif
+#if defined(DEBUGGING) || defined(NO_EMBED) || defined(MULTIPLICITY)
+               sv_catpv(Sv,"\"  Compile-time options:");
+#  ifdef DEBUGGING
+               sv_catpv(Sv," DEBUGGING");
+#  endif
+#  ifdef NO_EMBED
+               sv_catpv(Sv," NO_EMBED");
+#  endif
+#  ifdef MULTIPLICITY
+               sv_catpv(Sv," MULTIPLICITY");
+#  endif
+               sv_catpv(Sv,"\\n\",");
+#endif
+#if defined(LOCAL_PATCH_COUNT)
+               if (LOCAL_PATCH_COUNT > 0) {
+                   int i;
+                   sv_catpv(Sv,"\"  Locally applied patches:\\n\",");
+                   for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
+                       if (localpatches[i])
+                           sv_catpvf(Sv,"\"  \\t%s\\n\",",localpatches[i]);
+                   }
+               }
+#endif
+               sv_catpvf(Sv,"\"  Built under %s\\n\"",OSNAME);
+#ifdef __DATE__
+#  ifdef __TIME__
+               sv_catpvf(Sv,",\"  Compiled at %s %s\\n\"",__DATE__,__TIME__);
+#  else
+               sv_catpvf(Sv,",\"  Compiled on %s\\n\"",__DATE__);
+#  endif
+#endif
+               sv_catpv(Sv, "; \
+$\"=\"\\n    \"; \
+@env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
+print \"  \\%ENV:\\n    @env\\n\" if @env; \
+print \"  \\@INC:\\n    @INC\\n\";");
+           }
+           else {
+               Sv = newSVpv("config_vars(qw(",0);
+               sv_catpv(Sv, ++s);
+               sv_catpv(Sv, "))");
+               s += strlen(s);
+           }
+           av_push(preambleav, Sv);
+           scriptname = BIT_BUCKET;    /* don't look for script or read stdin */
+           goto reswitch;
+       case 'x':
+           doextract = TRUE;
+           s++;
+           if (*s)
+               cddir = savepv(s);
+           break;
+       case 0:
+           break;
+       case '-':
+           if (!*++s || isSPACE(*s)) {
+               argc--,argv++;
+               goto switch_end;
+           }
+           /* catch use of gnu style long options */
+           if (strEQ(s, "version")) {
+               s = "v";
+               goto reswitch;
+           }
+           if (strEQ(s, "help")) {
+               s = "h";
+               goto reswitch;
+           }
+           s--;
+           /* FALL THROUGH */
+       default:
+           croak("Unrecognized switch: -%s  (-h will show valid options)",s);
        }
     }
-#endif /* USE_THREADS */
-    gv = gv_fetchpv(name, create, SVt_PV);
-    if (gv)
-       return GvSV(gv);
-    return Nullsv;
-}
+  switch_end:
 
-AV*
-perl_get_av(char *name, I32 create)
-{
-    GV* gv = gv_fetchpv(name, create, SVt_PVAV);
-    if (create)
-       return GvAVn(gv);
-    if (gv)
-       return GvAV(gv);
-    return Nullav;
-}
+    if (!tainting && (s = PerlEnv_getenv("PERL5OPT"))) {
+       while (s && *s) {
+           while (isSPACE(*s))
+               s++;
+           if (*s == '-') {
+               s++;
+               if (isSPACE(*s))
+                   continue;
+           }
+           if (!*s)
+               break;
+           if (!strchr("DIMUdmw", *s))
+               croak("Illegal switch in PERL5OPT: -%c", *s);
+           s = moreswitches(s);
+       }
+    }
 
-HV*
-perl_get_hv(char *name, I32 create)
-{
+    if (!scriptname)
+       scriptname = argv[0];
+    if (e_script) {
+       argc++,argv--;
+       scriptname = BIT_BUCKET;        /* don't look for script or read stdin */
+    }
+    else if (scriptname == Nullch) {
+#ifdef MSDOS
+       if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
+           moreswitches("h");
+#endif
+       scriptname = "-";
+    }
+
+    init_perllib();
+
+    open_script(scriptname,dosearch,sv,&fdscript);
+
+    validate_suid(validarg, scriptname,fdscript);
+
+    if (doextract)
+       find_beginning();
+
+    main_cv = compcv = (CV*)NEWSV(1104,0);
+    sv_upgrade((SV *)compcv, SVt_PVCV);
+    CvUNIQUE_on(compcv);
+
+    comppad = newAV();
+    av_push(comppad, Nullsv);
+    curpad = AvARRAY(comppad);
+    comppad_name = newAV();
+    comppad_name_fill = 0;
+    min_intro_pending = 0;
+    padix = 0;
+#ifdef USE_THREADS
+    av_store(comppad_name, 0, newSVpv("@_", 2));
+    curpad[0] = (SV*)newAV();
+    SvPADMY_on(curpad[0]);     /* XXX Needed? */
+    CvOWNER(compcv) = 0;
+    New(666, CvMUTEXP(compcv), 1, perl_mutex);
+    MUTEX_INIT(CvMUTEXP(compcv));
+#endif /* USE_THREADS */
+
+    comppadlist = newAV();
+    AvREAL_off(comppadlist);
+    av_store(comppadlist, 0, (SV*)comppad_name);
+    av_store(comppadlist, 1, (SV*)comppad);
+    CvPADLIST(compcv) = comppadlist;
+
+    boot_core_UNIVERSAL();
+
+    if (xsinit)
+       (*xsinit)(PERL_OBJECT_THIS);    /* in case linked C routines want magical variables */
+#if defined(VMS) || defined(WIN32) || defined(DJGPP)
+    init_os_extras();
+#endif
+
+    init_predump_symbols();
+    /* init_postdump_symbols not currently designed to be called */
+    /* more than once (ENV isn't cleared first, for example)    */
+    /* But running with -u leaves %ENV & @ARGV undefined!    XXX */
+    if (!do_undump)
+       init_postdump_symbols(argc,argv,env);
+
+    init_lexer();
+
+    /* now parse the script */
+
+    SETERRNO(0,SS$_NORMAL);
+    error_count = 0;
+    if (yyparse() || error_count) {
+       if (minus_c)
+           croak("%s had compilation errors.\n", origfilename);
+       else {
+           croak("Execution of %s aborted due to compilation errors.\n",
+               origfilename);
+       }
+    }
+    curcop->cop_line = 0;
+    curstash = defstash;
+    preprocess = FALSE;
+    if (e_script) {
+       SvREFCNT_dec(e_script);
+       e_script = Nullsv;
+    }
+
+    /* now that script is parsed, we can modify record separator */
+    SvREFCNT_dec(rs);
+    rs = SvREFCNT_inc(nrs);
+    sv_setsv(perl_get_sv("/", TRUE), rs);
+    if (do_undump)
+       my_unexec();
+
+    if (dowarn)
+       gv_check(defstash);
+
+    LEAVE;
+    FREETMPS;
+
+#ifdef MYMALLOC
+    if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
+       dump_mstats("after compilation:");
+#endif
+
+    ENTER;
+    restartop = 0;
+    JMPENV_POP;
+    return 0;
+}
+
+int
+#ifdef PERL_OBJECT
+CPerlObj::perl_run(void)
+#else
+perl_run(PerlInterpreter *sv_interp)
+#endif
+{
+    dSP;
+    I32 oldscope;
+    dJMPENV;
+    int ret;
+
+#ifndef PERL_OBJECT
+    if (!(curinterp = sv_interp))
+       return 255;
+#endif
+
+    oldscope = scopestack_ix;
+
+    JMPENV_PUSH(ret);
+    switch (ret) {
+    case 1:
+       cxstack_ix = -1;                /* start context stack again */
+       break;
+    case 2:
+       /* my_exit() was called */
+       while (scopestack_ix > oldscope)
+           LEAVE;
+       FREETMPS;
+       curstash = defstash;
+       if (endav)
+           call_list(oldscope, endav);
+#ifdef MYMALLOC
+       if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
+           dump_mstats("after execution:  ");
+#endif
+       JMPENV_POP;
+       return STATUS_NATIVE_EXPORT;
+    case 3:
+       if (!restartop) {
+           PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
+           FREETMPS;
+           JMPENV_POP;
+           return 1;
+       }
+       POPSTACK_TO(mainstack);
+       break;
+    }
+
+    DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
+                    sawampersand ? "Enabling" : "Omitting"));
+
+    if (!restartop) {
+       DEBUG_x(dump_all());
+       DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
+#ifdef USE_THREADS
+       DEBUG_L(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
+                             (unsigned long) thr));
+#endif /* USE_THREADS */       
+
+       if (minus_c) {
+           PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
+           my_exit(0);
+       }
+       if (PERLDB_SINGLE && DBsingle)
+          sv_setiv(DBsingle, 1); 
+       if (initav)
+           call_list(oldscope, initav);
+    }
+
+    /* do it */
+
+    if (restartop) {
+       op = restartop;
+       restartop = 0;
+       CALLRUNOPS();
+    }
+    else if (main_start) {
+       CvDEPTH(main_cv) = 1;
+       op = main_start;
+       CALLRUNOPS();
+    }
+
+    my_exit(0);
+    /* NOTREACHED */
+    return 0;
+}
+
+SV*
+perl_get_sv(char *name, I32 create)
+{
+    GV *gv;
+#ifdef USE_THREADS
+    if (name[1] == '\0' && !isALPHA(name[0])) {
+       PADOFFSET tmp = find_threadsv(name);
+       if (tmp != NOT_IN_PAD) {
+           dTHR;
+           return THREADSV(tmp);
+       }
+    }
+#endif /* USE_THREADS */
+    gv = gv_fetchpv(name, create, SVt_PV);
+    if (gv)
+       return GvSV(gv);
+    return Nullsv;
+}
+
+AV*
+perl_get_av(char *name, I32 create)
+{
+    GV* gv = gv_fetchpv(name, create, SVt_PVAV);
+    if (create)
+       return GvAVn(gv);
+    if (gv)
+       return GvAV(gv);
+    return Nullav;
+}
+
+HV*
+perl_get_hv(char *name, I32 create)
+{
     GV* gv = gv_fetchpv(name, create, SVt_PVHV);
     if (create)
        return GvHVn(gv);
@@ -826,7 +1205,7 @@ perl_call_sv(SV *sv, I32 flags)
     I32 oldscope;
     bool oldcatch = CATCH_GET;
     dJMPENV;
-    int jmpstat;
+    int ret;
     OP* oldop = op;
 
     if (flags & G_DISCARD) {
@@ -882,14 +1261,14 @@ perl_call_sv(SV *sv, I32 flags)
        }
        markstack_ptr++;
 
-       JMPENV_PUSH(jmpstat);
-       switch (jmpstat) {
-       case JMP_NORMAL:
+       JMPENV_PUSH(ret);
+       switch (ret) {
+       case 0:
            break;
-       case JMP_ABNORMAL:
+       case 1:
            STATUS_ALL_FAILURE;
            /* FALL THROUGH */
-       case JMP_MYEXIT:
+       case 2:
            /* my_exit() was called */
            curstash = defstash;
            FREETMPS;
@@ -898,7 +1277,7 @@ perl_call_sv(SV *sv, I32 flags)
                croak("Callback called exit");
            my_exit_jump();
            /* NOTREACHED */
-       case JMP_EXCEPTION:
+       case 3:
            if (restartop) {
                op = restartop;
                restartop = 0;
@@ -968,7 +1347,7 @@ perl_eval_sv(SV *sv, I32 flags)
     I32 retval;
     I32 oldscope;
     dJMPENV;
-    int jmpstat;
+    int ret;
     OP* oldop = op;
 
     if (flags & G_DISCARD) {
@@ -993,14 +1372,14 @@ perl_eval_sv(SV *sv, I32 flags)
     if (flags & G_KEEPERR)
        myop.op_flags |= OPf_SPECIAL;
 
-    JMPENV_PUSH(jmpstat);
-    switch (jmpstat) {
-    case JMP_NORMAL:
+    JMPENV_PUSH(ret);
+    switch (ret) {
+    case 0:
        break;
-    case JMP_ABNORMAL:
+    case 1:
        STATUS_ALL_FAILURE;
        /* FALL THROUGH */
-    case JMP_MYEXIT:
+    case 2:
        /* my_exit() was called */
        curstash = defstash;
        FREETMPS;
@@ -1009,7 +1388,7 @@ perl_eval_sv(SV *sv, I32 flags)
            croak("Callback called exit");
        my_exit_jump();
        /* NOTREACHED */
-    case JMP_EXCEPTION:
+    case 3:
        if (restartop) {
            op = restartop;
            restartop = 0;
@@ -2350,16 +2729,16 @@ call_list(I32 oldscope, AV *paramList)
     line_t oldline = curcop->cop_line;
     STRLEN len;
     dJMPENV;
-    int jmpstat;
+    int ret;
 
     while (AvFILL(paramList) >= 0) {
        CV *cv = (CV*)av_shift(paramList);
 
        SAVEFREESV(cv);
 
-       JMPENV_PUSH(jmpstat);
-       switch (jmpstat) {
-       case JMP_NORMAL: {
+       JMPENV_PUSH(ret);
+       switch (ret) {
+       case 0: {
                SV* atsv = ERRSV;
                PUSHMARK(stack_sp);
                perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
@@ -2378,10 +2757,10 @@ call_list(I32 oldscope, AV *paramList)
                }
            }
            break;
-       case JMP_ABNORMAL:
+       case 1:
            STATUS_ALL_FAILURE;
            /* FALL THROUGH */
-       case JMP_MYEXIT:
+       case 2:
            /* my_exit() was called */
            while (scopestack_ix > oldscope)
                LEAVE;
@@ -2400,7 +2779,7 @@ call_list(I32 oldscope, AV *paramList)
            }
            my_exit_jump();
            /* NOTREACHED */
-       case JMP_EXCEPTION:
+       case 3:
            if (!restartop) {
                PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
                FREETMPS;
@@ -2409,7 +2788,7 @@ call_list(I32 oldscope, AV *paramList)
            JMPENV_POP;
            curcop = &compiling;
            curcop->cop_line = oldline;
-           JMPENV_JUMP(JMP_EXCEPTION);
+           JMPENV_JUMP(3);
        }
        JMPENV_POP;
     }
@@ -2488,14 +2867,18 @@ my_exit_jump(void)
        LEAVE;
     }
 
-    JMPENV_JUMP(JMP_MYEXIT);
+    JMPENV_JUMP(2);
 }
 
 
 #include "XSUB.h"
 
 static I32
-read_e_script(CPERLarg_ int idx, SV *buf_sv, int maxlen)
+#ifdef PERL_OBJECT
+read_e_script(CPerlObj *pPerl, int idx, SV *buf_sv, int maxlen)
+#else
+read_e_script(int idx, SV *buf_sv, int maxlen)
+#endif
 {
     char *p, *nl;
     p  = SvPVX(e_script);
@@ -2508,461 +2891,4 @@ read_e_script(CPERLarg_ int idx, SV *buf_sv, int maxlen)
     return 1;
 }
 
-/******************************************* perl_parse TRYBLOCK branches */
-
-#define TRY_LOCAL(name) ((TRY_PARSE_LOCALS*)locals)->name
 
-static void
-try_parse_normal0(CPERLarg_ void *locals)
-{
-    dTHR;
-    register SV *sv;
-    register char *s;
-    char *scriptname = NULL;
-    VOL bool dosearch = FALSE;
-    char *validarg = "";
-    AV* comppadlist;
-    int fdscript = -1;
-
-    void (*xsinit)() = TRY_LOCAL(xsinit);
-    int argc = TRY_LOCAL(argc);
-    char **argv = TRY_LOCAL(argv);
-    char **env = TRY_LOCAL(env);
-
-    sv_setpvn(linestr,"",0);
-    sv = newSVpv("",0);                /* first used for -I flags */
-    SAVEFREESV(sv);
-    init_main_stash();
-
-    for (argc--,argv++; argc > 0; argc--,argv++) {
-       if (argv[0][0] != '-' || !argv[0][1])
-           break;
-#ifdef DOSUID
-    if (*validarg)
-       validarg = " PHOOEY ";
-    else
-       validarg = argv[0];
-#endif
-       s = argv[0]+1;
-      reswitch:
-       switch (*s) {
-       case ' ':
-       case '0':
-       case 'F':
-       case 'a':
-       case 'c':
-       case 'd':
-       case 'D':
-       case 'h':
-       case 'i':
-       case 'l':
-       case 'M':
-       case 'm':
-       case 'n':
-       case 'p':
-       case 's':
-       case 'u':
-       case 'U':
-       case 'v':
-       case 'w':
-           if (s = moreswitches(s))
-               goto reswitch;
-           break;
-
-       case 'T':
-           tainting = TRUE;
-           s++;
-           goto reswitch;
-
-       case 'e':
-           if (euid != uid || egid != gid)
-               croak("No -e allowed in setuid scripts");
-           if (!e_script) {
-               e_script = newSVpv("",0);
-               filter_add(read_e_script, NULL);
-           }
-           if (*++s)
-               sv_catpv(e_script, s);
-           else if (argv[1]) {
-               sv_catpv(e_script, argv[1]);
-               argc--,argv++;
-           }
-           else
-               croak("No code specified for -e");
-           sv_catpv(e_script, "\n");
-           break;
-
-       case 'I':       /* -I handled both here and in moreswitches() */
-           forbid_setid("-I");
-           if (!*++s && (s=argv[1]) != Nullch) {
-               argc--,argv++;
-           }
-           while (s && isSPACE(*s))
-               ++s;
-           if (s && *s) {
-               char *e, *p;
-               for (e = s; *e && !isSPACE(*e); e++) ;
-               p = savepvn(s, e-s);
-               incpush(p, TRUE);
-               sv_catpv(sv,"-I");
-               sv_catpv(sv,p);
-               sv_catpv(sv," ");
-               Safefree(p);
-           }   /* XXX else croak? */
-           break;
-       case 'P':
-           forbid_setid("-P");
-           preprocess = TRUE;
-           s++;
-           goto reswitch;
-       case 'S':
-           forbid_setid("-S");
-           dosearch = TRUE;
-           s++;
-           goto reswitch;
-       case 'V':
-           if (!preambleav)
-               preambleav = newAV();
-           av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
-           if (*++s != ':')  {
-               Sv = newSVpv("print myconfig();",0);
-#ifdef VMS
-               sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
-#else
-               sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
-#endif
-#if defined(DEBUGGING) || defined(NO_EMBED) || defined(MULTIPLICITY)
-               sv_catpv(Sv,"\"  Compile-time options:");
-#  ifdef DEBUGGING
-               sv_catpv(Sv," DEBUGGING");
-#  endif
-#  ifdef NO_EMBED
-               sv_catpv(Sv," NO_EMBED");
-#  endif
-#  ifdef MULTIPLICITY
-               sv_catpv(Sv," MULTIPLICITY");
-#  endif
-               sv_catpv(Sv,"\\n\",");
-#endif
-#if defined(LOCAL_PATCH_COUNT)
-               if (LOCAL_PATCH_COUNT > 0) {
-                   int i;
-                   sv_catpv(Sv,"\"  Locally applied patches:\\n\",");
-                   for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
-                       if (localpatches[i])
-                           sv_catpvf(Sv,"\"  \\t%s\\n\",",localpatches[i]);
-                   }
-               }
-#endif
-               sv_catpvf(Sv,"\"  Built under %s\\n\"",OSNAME);
-#ifdef __DATE__
-#  ifdef __TIME__
-               sv_catpvf(Sv,",\"  Compiled at %s %s\\n\"",__DATE__,__TIME__);
-#  else
-               sv_catpvf(Sv,",\"  Compiled on %s\\n\"",__DATE__);
-#  endif
-#endif
-               sv_catpv(Sv, "; \
-$\"=\"\\n    \"; \
-@env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
-print \"  \\%ENV:\\n    @env\\n\" if @env; \
-print \"  \\@INC:\\n    @INC\\n\";");
-           }
-           else {
-               Sv = newSVpv("config_vars(qw(",0);
-               sv_catpv(Sv, ++s);
-               sv_catpv(Sv, "))");
-               s += strlen(s);
-           }
-           av_push(preambleav, Sv);
-           scriptname = BIT_BUCKET;    /* don't look for script or read stdin */
-           goto reswitch;
-       case 'x':
-           doextract = TRUE;
-           s++;
-           if (*s)
-               cddir = savepv(s);
-           break;
-       case 0:
-           break;
-       case '-':
-           if (!*++s || isSPACE(*s)) {
-               argc--,argv++;
-               goto switch_end;
-           }
-           /* catch use of gnu style long options */
-           if (strEQ(s, "version")) {
-               s = "v";
-               goto reswitch;
-           }
-           if (strEQ(s, "help")) {
-               s = "h";
-               goto reswitch;
-           }
-           s--;
-           /* FALL THROUGH */
-       default:
-           croak("Unrecognized switch: -%s  (-h will show valid options)",s);
-       }
-    }
-  switch_end:
-
-    if (!tainting && (s = PerlEnv_getenv("PERL5OPT"))) {
-       while (s && *s) {
-           while (isSPACE(*s))
-               s++;
-           if (*s == '-') {
-               s++;
-               if (isSPACE(*s))
-                   continue;
-           }
-           if (!*s)
-               break;
-           if (!strchr("DIMUdmw", *s))
-               croak("Illegal switch in PERL5OPT: -%c", *s);
-           s = moreswitches(s);
-       }
-    }
-
-    if (!scriptname)
-       scriptname = argv[0];
-    if (e_script) {
-       argc++,argv--;
-       scriptname = BIT_BUCKET;        /* don't look for script or read stdin */
-    }
-    else if (scriptname == Nullch) {
-#ifdef MSDOS
-       if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
-           moreswitches("h");
-#endif
-       scriptname = "-";
-    }
-
-    init_perllib();
-
-    open_script(scriptname,dosearch,sv,&fdscript);
-
-    validate_suid(validarg, scriptname,fdscript);
-
-    if (doextract)
-       find_beginning();
-
-    main_cv = compcv = (CV*)NEWSV(1104,0);
-    sv_upgrade((SV *)compcv, SVt_PVCV);
-    CvUNIQUE_on(compcv);
-
-    comppad = newAV();
-    av_push(comppad, Nullsv);
-    curpad = AvARRAY(comppad);
-    comppad_name = newAV();
-    comppad_name_fill = 0;
-    min_intro_pending = 0;
-    padix = 0;
-#ifdef USE_THREADS
-    av_store(comppad_name, 0, newSVpv("@_", 2));
-    curpad[0] = (SV*)newAV();
-    SvPADMY_on(curpad[0]);     /* XXX Needed? */
-    CvOWNER(compcv) = 0;
-    New(666, CvMUTEXP(compcv), 1, perl_mutex);
-    MUTEX_INIT(CvMUTEXP(compcv));
-#endif /* USE_THREADS */
-
-    comppadlist = newAV();
-    AvREAL_off(comppadlist);
-    av_store(comppadlist, 0, (SV*)comppad_name);
-    av_store(comppadlist, 1, (SV*)comppad);
-    CvPADLIST(compcv) = comppadlist;
-
-    boot_core_UNIVERSAL();
-
-    if (xsinit)
-       (*xsinit)(PERL_OBJECT_THIS);    /* in case linked C routines want magical variables */
-#if defined(VMS) || defined(WIN32) || defined(DJGPP)
-    init_os_extras();
-#endif
-
-    init_predump_symbols();
-    /* init_postdump_symbols not currently designed to be called */
-    /* more than once (ENV isn't cleared first, for example)    */
-    /* But running with -u leaves %ENV & @ARGV undefined!    XXX */
-    if (!do_undump)
-       init_postdump_symbols(argc,argv,env);
-
-    init_lexer();
-
-    /* now parse the script */
-
-    SETERRNO(0,SS$_NORMAL);
-    error_count = 0;
-    if (yyparse() || error_count) {
-       if (minus_c)
-           croak("%s had compilation errors.\n", origfilename);
-       else {
-           croak("Execution of %s aborted due to compilation errors.\n",
-               origfilename);
-       }
-    }
-    curcop->cop_line = 0;
-    curstash = defstash;
-    preprocess = FALSE;
-    if (e_script) {
-       SvREFCNT_dec(e_script);
-       e_script = Nullsv;
-    }
-
-    /* now that script is parsed, we can modify record separator */
-    SvREFCNT_dec(rs);
-    rs = SvREFCNT_inc(nrs);
-    sv_setsv(perl_get_sv("/", TRUE), rs);
-    if (do_undump)
-       my_unexec();
-
-    if (dowarn)
-       gv_check(defstash);
-
-    LEAVE;
-    FREETMPS;
-
-#ifdef MYMALLOC
-    if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
-       dump_mstats("after compilation:");
-#endif
-
-    ENTER;
-    restartop = 0;
-    TRY_LOCAL(ret) = 0;
-}
-
-static void
-try_parse_exception1(CPERLarg_ void *locals)
-{
-    PerlIO_printf(PerlIO_stderr(), no_top_env);
-    TRY_LOCAL(ret) = 1;
-}
-
-static void
-try_parse_myexit0(CPERLarg_ void *locals)
-{
-    dTHR;
-    I32 oldscope = TRY_LOCAL(oldscope);
-    while (scopestack_ix > oldscope)
-       LEAVE;
-    FREETMPS;
-    curstash = defstash;
-    if (endav)
-       call_list(oldscope, endav);
-    TRY_LOCAL(ret) = STATUS_NATIVE_EXPORT;
-}
-
-static void
-try_parse_abnormal0(CPERLarg_ void *locals)
-{
-    STATUS_ALL_FAILURE;
-    try_parse_myexit0(locals);
-}
-
-#undef TRY_LOCAL
-static TRYVTBL PerlParseVtbl = {
-    "perl_parse",
-    try_parse_normal0,         0,
-    try_parse_abnormal0,       0,
-    0,                         try_parse_exception1,
-    try_parse_myexit0,         0,
-};
-
-/******************************************* perl_run TRYBLOCK branches */
-
-#define TRY_LOCAL(name) ((TRY_RUN_LOCALS*)locals)->name
-
-static void
-try_run_normal0(CPERLarg_ void *locals)
-{
-    dTHR;
-    I32 oldscope = TRY_LOCAL(oldscope);
-
-    DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
-                    sawampersand ? "Enabling" : "Omitting"));
-
-    if (!restartop) {
-       DEBUG_x(dump_all());
-       DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
-#ifdef USE_THREADS
-       DEBUG_L(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
-                             (unsigned long) thr));
-#endif /* USE_THREADS */       
-
-       if (minus_c) {
-           PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
-           my_exit(0);
-       }
-       if (PERLDB_SINGLE && DBsingle)
-          sv_setiv(DBsingle, 1); 
-       if (initav)
-           call_list(oldscope, initav);
-    }
-
-    /* do it */
-
-    if (restartop) {
-       op = restartop;
-       restartop = 0;
-       CALLRUNOPS();
-    }
-    else if (main_start) {
-       CvDEPTH(main_cv) = 1;
-       op = main_start;
-       CALLRUNOPS();
-    }
-
-    my_exit(0);
-}
-
-static void
-try_run_abnormal0(CPERLarg_ void *locals)
-{
-    dTHR;
-    cxstack_ix = -1;           /* start context stack again */
-    try_run_normal0(locals);
-}
-
-static void
-try_run_exception0(CPERLarg_ void *locals)
-{
-    dSP;
-    if (!restartop) {
-       PerlIO_printf(PerlIO_stderr(), no_restartop);
-       FREETMPS;
-       TRY_LOCAL(ret) = 1;
-    } else {
-       POPSTACK_TO(mainstack);
-       try_run_normal0(locals);
-    }
-}
-
-static void
-try_run_myexit0(CPERLarg_ void *locals)
-{
-    dTHR;
-    I32 oldscope = TRY_LOCAL(oldscope);
-
-    while (scopestack_ix > oldscope)
-       LEAVE;
-    FREETMPS;
-    curstash = defstash;
-    if (endav)
-       call_list(oldscope, endav);
-#ifdef MYMALLOC
-    if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
-       dump_mstats("after execution:  ");
-#endif
-    TRY_LOCAL(ret) = STATUS_NATIVE_EXPORT;
-}
-
-#undef TRY_LOCAL
-static TRYVTBL PerlRunVtbl = {
-    "perl_run",
-    try_run_normal0,   0,
-    try_run_abnormal0, 0,
-    try_run_exception0,        0,
-    try_run_myexit0,   0
-};
diff --git a/perl.h b/perl.h
index b8a5cb7..60f7dd5 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -104,7 +104,6 @@ class CPerlObj;
 #define STATIC
 #define CPERLscope(x) CPerlObj::x
 #define CPERLproto CPerlObj *
-#define CPERLproto_ CPERLproto,
 #define _CPERLproto ,CPERLproto
 #define CPERLarg CPerlObj *pPerl
 #define CPERLarg_ CPERLarg,
@@ -119,7 +118,6 @@ class CPerlObj;
 #define STATIC static
 #define CPERLscope(x) x
 #define CPERLproto
-#define CPERLproto_
 #define _CPERLproto
 #define CPERLarg void
 #define CPERLarg_
@@ -1640,10 +1638,6 @@ EXTCONST char no_func[]
   INIT("The %s function is unimplemented");
 EXTCONST char no_myglob[]
   INIT("\"my\" variable %s can't be in a package");
-EXTCONST char no_restartop[]
-  INIT("panic: restartop\n");
-EXTCONST char no_top_env[]
-  INIT("panic: top_env\n");
 
 #ifdef DOINIT
 EXT char *sig_name[] = { SIG_NAME };
index e35ad46..8dd2f82 100644 (file)
@@ -1380,11 +1380,6 @@ ignored.
 (F) Your machine apparently doesn't implement ioctl(), which is pretty
 strange for a machine that supports C.
 
-=item JMPENV_JUMP(%d) is bogus
-
-(S) Either some extension is trying to raise an exception type that is not
-supported by the JMPENV API, or memory has been corrupted.  See L<perlguts>.
-
 =item junk on end of regexp
 
 (P) The regular expression parser is confused.
@@ -1920,9 +1915,7 @@ was string.
 
 =item panic: top_env
 
-(X) An attempt was made to throw some sort of exception when there
-was no exception stack.  Either perl failed to initialize properly, or
-the JMPENV API is being misused.  See L<perlguts>.
+(P) The compiler attempted to do a goto, or something weird like that.
 
 =item panic: yylex
 
index dce6ca5..fb52ecf 100644 (file)
@@ -1252,79 +1252,6 @@ is being used.
 
 For a complete description of the PerlIO abstraction, consult L<perlapio>.
 
-=head2 Exception Trapping (JMPENV API)
-
-As of 5.005, the internal exception trapping mechanism is replaceable
-at run-time.
-
-For a concrete example of usage, see perl.c in the perl source
-distribution.  Only a general outline is presented here.
-
-The C<TRYBLOCK()> macro is used to set up a exception handling switch.
-C<TRYBLOCK()> takes two arguments.  The first argument is a table of
-exception handlers:
-
-  struct tryvtbl {
-    /* [0] executed before JMPENV_POP
-       [1] executed after JMPENV_POP
-           (NULL pointers are OK) */
-    char *try_context;
-    void (*try_normal    [2]) _((CPERLproto_ void*));
-    void (*try_abnormal  [2]) _((CPERLproto_ void*));
-    void (*try_exception [2]) _((CPERLproto_ void*));
-    void (*try_myexit    [2]) _((CPERLproto_ void*));
-  };
-  typedef struct tryvtbl TRYVTBL;
-
-Each of the functions correspond to the exception types that
-are currently supported.  The two functions in each array are meant
-to be run before and after the exception context is exited, respectively,
-via C<JMPENV_POP()>.
-
-The second argument to C<TRYBLOCK()> is an opaque pointer that is passed
-as a first argument to each of the handler functions.  This is usually
-a structure specific to each particular exception switch containing both
-the return value and the arguments to the handler functions.
-
-Any of the handler function pointers can be C<NULL> except for
-C<try_normal[0]>, which is the only thing executed by C<TRYBLOCK()>
-after setting up the exception context.  Any code executed by
-C<try_normal[0]> is free to throw one of the three supported exceptions
-using C<JMPENV_JUMP()>.  C<JMPENV_JUMP()> can be called with one of the
-following values:
-
-  #define JMP_ABNORMAL 1       /* shouldn't happen */
-  #define JMP_MYEXIT   2       /* exit */
-  #define JMP_EXCEPTION        3       /* die */
-
-Control then resumes at the exception switch, which calls the handler
-corresponding to the type of exception that was thrown.  More exceptions
-can be thrown while in the handler, and the process repeats until one of
-the handlers return normally.
-
-In other words, depending on how C<JMPENV_JUMP()> is called, either
-C<try_abnormal[0]>, C<try_exception[0]>, or C<try_myexit[0]> are executed.
-If C<JMPENV_JUMP()> is invoked yet again before the try handler completes
-then execution will B<restart> at the try handler which corresponds to the
-most recent C<JMPENV_JUMP()>.  Care should be taken to avoid infinite
-loops.
-
-Once the try handler[0] finishes, execution moves on to one of the try
-handlers that are run after the exception context is exited (i.e.
-handler[1]).  However, the difference between the two types of handlers
-is that exceptions raised in handlers run after exiting the exception
-context are no longer caught by the C<TRYBLOCK()>.  Of course, they may
-be caught at some outer exception trap set up for the purpose.  Therefore,
-C<JMPENV_JUMP()> at this point will not be trapped; it will jump to the
-previous C<TRYBLOCK()>.  This is useful for propagating exceptions to the
-top of the stack.
-
-WARNING: At the time of this writing, the C<CC.pm> compiler backend
-does not support exception traps that are configurable at runtime.  It
-only knows how to handle exceptions thrown with longjmp() (which is what
-the default exception mechanism in perl provides).  This will be corrected
-in a future release.
-
 =head2 Putting a C value on Perl stack
 
 A lot of opcodes (this is an elementary operation in the internal perl
index ac2ddfc..9b924bc 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -2015,7 +2015,7 @@ PP(pp_goto)
 
     if (top_env->je_prev) {
         restartop = retop;
-        JMPENV_JUMP(JMP_EXCEPTION);
+        JMPENV_JUMP(3);
     }
 
     RETURNOP(retop);
@@ -2110,7 +2110,7 @@ STATIC OP *
 docatch(OP *o)
 {
     dTHR;
-    int jmpstat;
+    int ret;
     OP *oldop = op;
     dJMPENV;
 
@@ -2119,14 +2119,14 @@ docatch(OP *o)
     assert(CATCH_GET == TRUE);
     DEBUG_l(deb("Setting up local jumplevel %p, was %p\n", &cur_env, top_env));
 #endif
-    JMPENV_PUSH(jmpstat);
-    switch (jmpstat) {
+    JMPENV_PUSH(ret);
+    switch (ret) {
     default:                           /* topmost level handles it */
        JMPENV_POP;
        op = oldop;
-       JMPENV_JUMP(jmpstat);
+       JMPENV_JUMP(ret);
        /* NOTREACHED */
-    case JMP_EXCEPTION:
+    case 3:
        if (!restartop) {
            PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
            break;
@@ -2134,7 +2134,7 @@ docatch(OP *o)
        op = restartop;
        restartop = 0;
        /* FALL THROUGH */
-    case JMP_NORMAL:
+    case 0:
         CALLRUNOPS();
        break;
     }
diff --git a/proto.h b/proto.h
index 4467dde..2356e68 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -205,7 +205,6 @@ VIRTUAL I32 ibcmp _((char* a, char* b, I32 len));
 VIRTUAL I32    ibcmp_locale _((char* a, char* b, I32 len));
 VIRTUAL I32    ingroup _((I32 testgid, I32 effective));
 VIRTUAL void   init_stacks _((ARGSproto));
-VIRTUAL void   install_tryblock_method _((tryblock_f fn));
 VIRTUAL U32    intro_my _((void));
 VIRTUAL char*  instr _((char* big, char* little));
 VIRTUAL bool   io_close _((IO* io));
diff --git a/scope.c b/scope.c
index c0924d8..5958aba 100644 (file)
--- a/scope.c
+++ b/scope.c
 #include "EXTERN.h"
 #include "perl.h"
 
-static void setjmp_tryblock _((CPERLarg_ TRYVTBL *vtbl, void *locals));
-    
-void
-install_tryblock_method(tryblock_f fn)
-{
-    if (fn)
-       tryblock_function = fn;
-    else
-       tryblock_function = setjmp_tryblock;
-}
-
 SV**
 stack_grow(SV **sp, SV **p, int n)
 {
@@ -917,69 +906,3 @@ cx_dump(PERL_CONTEXT *cx)
     }
 #endif /* DEBUGGING */
 }
-
-#include "XSUB.h"
-
-/* make 'static' once JMPENV_PUSH is no longer used (see scope.h) XXX */
-void
-setjmp_jump(CPERLarg)
-{
-    dTHR;
-    PerlProc_longjmp(((SETJMPENV*)top_env)->je_buf, 1);
-}
-
-static void
-setjmp_tryblock(CPERLarg_ TRYVTBL *vtbl, void *locals)
-{
-    dTHR;
-    int jmpstat;
-    SETJMPENV je;
-    JMPENV_INIT(je, setjmp_jump);
-    PerlProc_setjmp(je.je_buf, 1);
-    JMPENV_TRY(je);
-    jmpstat = JMPENV_STAT(je);
-    switch (jmpstat) {
-    case JMP_NORMAL:
-       assert(vtbl->try_normal[0]);
-       (*vtbl->try_normal[0])(PERL_OBJECT_THIS_ locals);
-       break;
-    case JMP_EXCEPTION:
-       if (vtbl->try_exception[0])
-           (*vtbl->try_exception[0])(PERL_OBJECT_THIS_ locals);
-       break;
-    case JMP_MYEXIT:
-       if (vtbl->try_myexit[0])
-           (*vtbl->try_myexit[0])(PERL_OBJECT_THIS_ locals);
-       break;
-    default:
-       if (jmpstat != JMP_ABNORMAL)
-           PerlIO_printf(PerlIO_stderr(),
-                         "JMPENV_JUMP(%d) is bogus\n", jmpstat);
-       if (vtbl->try_abnormal[0])
-           (*vtbl->try_abnormal[0])(PERL_OBJECT_THIS_ locals);
-       break;
-    }
-    JMPENV_POP_JE(je);
-    switch (JMPENV_STAT(je)) {
-    case JMP_NORMAL:
-       if (vtbl->try_normal[1])
-           (*vtbl->try_normal[1])(PERL_OBJECT_THIS_ locals);
-       break;
-    case JMP_EXCEPTION:
-       if (vtbl->try_exception[1])
-           (*vtbl->try_exception[1])(PERL_OBJECT_THIS_ locals);
-       break;
-    case JMP_MYEXIT:
-       if (vtbl->try_myexit[1])
-           (*vtbl->try_myexit[1])(PERL_OBJECT_THIS_ locals);
-       break;
-    default:
-       if (jmpstat != JMP_ABNORMAL)
-           PerlIO_printf(PerlIO_stderr(),
-                         "JMPENV_JUMP(%d) is bogus\n", jmpstat);
-       if (vtbl->try_abnormal[1])
-           (*vtbl->try_abnormal[1])(PERL_OBJECT_THIS_ locals);
-       break;
-    }
-}
-
diff --git a/scope.h b/scope.h
index 7170365..cc349f0 100644 (file)
--- a/scope.h
+++ b/scope.h
  * points to this initially, so top_env should always be non-null.
  *
  * Existence of a non-null top_env->je_prev implies it is valid to call
- * (*je_jump)() at that runlevel.  Always use the macros below!  They
- * manage most of the complexity for you.
+ * longjmp() at that runlevel (we make sure start_env.je_prev is always
+ * null to ensure this).
  *
  * je_mustcatch, when set at any runlevel to TRUE, means eval ops must
  * establish a local jmpenv to handle exception traps.  Care must be taken
  * to restore the previous value of je_mustcatch before exiting the
  * stack frame iff JMPENV_PUSH was not called in that stack frame.
- *
- * The support for C++ try/throw causes a small loss of flexibility.
- * No longer is it possible to place the body of exception-protected
- * code in the same C function as JMPENV_PUSH &etc.  Older code that
- * does this will continue to work with set/longjmp, but cannot use
- * C++ exceptions.
- *
- * GSAR  19970327
- * JPRIT 19980613 (C++ update)
+ * GSAR 97-03-27
  */
 
-#define JMP_NORMAL     0
-#define JMP_ABNORMAL   1       /* shouldn't happen */
-#define JMP_MYEXIT     2       /* exit */
-#define JMP_EXCEPTION  3       /* die */
-
-/* None of the JMPENV fields should be accessed directly.
-   Please use the macros below! */
 struct jmpenv {
     struct jmpenv *    je_prev;
-    int                        je_stat;        /* JMP_* reason for setjmp() */
-    bool               je_mustcatch;   /* will need a new TRYBLOCK? */
-    void               (*je_jump) _((CPERLproto));
-};
-typedef struct jmpenv JMPENV;
-
-struct tryvtbl {
-    /* [0] executed before JMPENV_POP
-       [1] executed after JMPENV_POP
-           (NULL pointers are OK) */
-    char *try_context;
-    void (*try_normal    [2]) _((CPERLproto_ void*));
-    void (*try_abnormal  [2]) _((CPERLproto_ void*));
-    void (*try_exception [2]) _((CPERLproto_ void*));
-    void (*try_myexit    [2]) _((CPERLproto_ void*));
+    Sigjmp_buf         je_buf;         
+    int                        je_ret;         /* return value of last setjmp() */
+    bool               je_mustcatch;   /* longjmp()s must be caught locally */
 };
-typedef struct tryvtbl TRYVTBL;
 
-typedef void (*tryblock_f) _((CPERLproto_ TRYVTBL *vtbl, void *locals));
-#define TRYBLOCK(mytry,vars) \
-       (*tryblock_function)(PERL_OBJECT_THIS_ &mytry, &vars)
+typedef struct jmpenv JMPENV;
 
 #ifdef OP_IN_REGISTER
 #define OP_REG_TO_MEM  opsave = op
@@ -157,83 +127,30 @@ typedef void (*tryblock_f) _((CPERLproto_ TRYVTBL *vtbl, void *locals));
 #define OP_MEM_TO_REG  NOOP
 #endif
 
-#define JMPENV_TOPINIT(top)                    \
-STMT_START {                                   \
-    top.je_prev = NULL;                                \
-    top.je_stat = JMP_ABNORMAL;                        \
-    top.je_mustcatch = TRUE;                   \
-    top_env = &top;                            \
-} STMT_END
-
-#define JMPENV_INIT(env, jmp)                  \
-STMT_START {                                   \
-    ((JMPENV*)&env)->je_prev = top_env;                \
-    ((JMPENV*)&env)->je_stat = JMP_NORMAL;     \
-    ((JMPENV*)&env)->je_jump = jmp;            \
-    OP_REG_TO_MEM;                             \
-} STMT_END
-
-#define JMPENV_TRY(env)                                \
-STMT_START {                                   \
-    OP_MEM_TO_REG;                             \
-    ((JMPENV*)&env)->je_mustcatch = FALSE;     \
-    top_env = (JMPENV*)&env;                   \
-} STMT_END
-
-#define JMPENV_POP_JE(env)                     \
-STMT_START {                                   \
-       assert(top_env == (JMPENV*)&env);       \
-       top_env = ((JMPENV*)&env)->je_prev;     \
-} STMT_END
-
-#define JMPENV_STAT(env) ((JMPENV*)&env)->je_stat
-
+#define dJMPENV                JMPENV cur_env
+#define JMPENV_PUSH(v) \
+    STMT_START {                                       \
+       cur_env.je_prev = top_env;                      \
+       OP_REG_TO_MEM;                                  \
+       cur_env.je_ret = PerlProc_setjmp(cur_env.je_buf, 1);    \
+       OP_MEM_TO_REG;                                  \
+       top_env = &cur_env;                             \
+       cur_env.je_mustcatch = FALSE;                   \
+       (v) = cur_env.je_ret;                           \
+    } STMT_END
+#define JMPENV_POP \
+    STMT_START { top_env = cur_env.je_prev; } STMT_END
 #define JMPENV_JUMP(v) \
     STMT_START {                                               \
-       assert((v) != JMP_NORMAL);                              \
        OP_REG_TO_MEM;                                          \
-       if (top_env->je_prev) {                                 \
-           top_env->je_stat = (v);                             \
-           (*top_env->je_jump)(PERL_OBJECT_THIS);              \
-       }                                                       \
-       if ((v) == JMP_MYEXIT)                                  \
-           PerlProc_exit(STATUS_NATIVE_EXPORT);                \
-       PerlIO_printf(PerlIO_stderr(), no_top_env);             \
-       PerlProc_exit(1);                                       \
+       if (top_env->je_prev)                                   \
+           PerlProc_longjmp(top_env->je_buf, (v));                     \
+       if ((v) == 2)                                           \
+           PerlProc_exit(STATUS_NATIVE_EXPORT);                                \
+       PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");     \
+       PerlProc_exit(1);                                               \
     } STMT_END
    
 #define CATCH_GET      (top_env->je_mustcatch)
 #define CATCH_SET(v)   (top_env->je_mustcatch = (v))
-
-
-
-/*******************************************************************
- * JMPENV_PUSH is the old depreciated API.  See perl.c for examples
- *  of the new API.
- */
-
-struct setjmpenv {
-    /* move to scope.c once JMPENV_PUSH is no longer needed XXX */
-    JMPENV             je0;
-    Sigjmp_buf         je_buf;         
-};
-typedef struct setjmpenv SETJMPENV;
-
-#define dJMPENV                SETJMPENV cur_env
-
-extern void setjmp_jump();
-
-#define JMPENV_PUSH(v) \
-    STMT_START {                                       \
-       JMPENV_INIT(cur_env, setjmp_jump);              \
-       PerlProc_setjmp(cur_env.je_buf, 1);             \
-       JMPENV_TRY(cur_env);                            \
-       (v) = JMPENV_STAT(cur_env);                     \
-    } STMT_END
-
-#define JMPENV_POP                             \
-STMT_START {                                   \
-       assert(top_env == (JMPENV*) &cur_env);  \
-       top_env = cur_env.je0.je_prev;          \
-} STMT_END
-
+   
diff --git a/util.c b/util.c
index f1cd3bc..2fa7740 100644 (file)
--- a/util.c
+++ b/util.c
@@ -1307,7 +1307,7 @@ die(const char* pat, ...)
          thr, restartop, was_in_eval, top_env));
 #endif /* USE_THREADS */
     if ((!restartop && was_in_eval) || top_env->je_prev)
-       JMPENV_JUMP(JMP_EXCEPTION);
+       JMPENV_JUMP(3);
     return restartop;
 }
 
@@ -1355,7 +1355,7 @@ croak(const char* pat, ...)
     }
     if (in_eval) {
        restartop = die_where(message);
-       JMPENV_JUMP(JMP_EXCEPTION);
+       JMPENV_JUMP(3);
     }
     PerlIO_puts(PerlIO_stderr(),message);
     (void)PerlIO_flush(PerlIO_stderr());
@@ -2759,7 +2759,10 @@ new_struct_thread(struct perl_thread *t)
        See comments in scope.h    
        Initialize top entry (as in perl.c for main thread)
      */
-    JMPENV_TOPINIT(start_env);
+    start_env.je_prev = NULL;
+    start_env.je_ret = -1;
+    start_env.je_mustcatch = TRUE;
+    top_env  = &start_env;
 
     in_eval = FALSE;
     restartop = 0;