This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
added patch, fixed typo, reworked documentation
authorJoshua Pritikin <joshua.pritikin@db.com>
Sun, 14 Jun 1998 14:03:15 +0000 (10:03 -0400)
committerGurusamy Sarathy <gsar@cpan.org>
Mon, 15 Jun 1998 05:32:01 +0000 (05:32 +0000)
Message-Id: <H00000e500071aa3@MHS>
Subject: [PATCH 5.004_66] JMPENV!

p4raw-id: //depot/perl@1135

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 605ef1c..5bdac21 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 fe830c0..7d28ff5 100644 (file)
 /* Anyone using eval "" deserves this mess */
 #define PP_EVAL(ppaddr, nxt) do {              \
        dJMPENV;                                \
-       int ret;                                \
+       int jmpstat;                            \
        PUTBACK;                                \
-       JMPENV_PUSH(ret);                       \
-       switch (ret) {                          \
-       case 0:                                 \
+       JMPENV_PUSH(jmpstat);                   \
+       switch (jmpstat) {                      \
+       case JMP_NORMAL:                        \
            op = ppaddr(ARGS);                  \
            retstack[retstack_ix - 1] = Nullop; \
            if (op != nxt) runops();            \
            JMPENV_POP;                         \
            break;                              \
-       case 1: JMPENV_POP; JMPENV_JUMP(1);     \
-       case 2: JMPENV_POP; JMPENV_JUMP(2);     \
-       case 3:                                 \
+       case JMP_ABNORMAL: JMPENV_POP; JMPENV_JUMP(JMP_ABNORMAL);       \
+       case JMP_MYEXIT: JMPENV_POP; JMPENV_JUMP(JMP_MYEXIT);   \
+       case JMP_EXCEPTION:                                     \
            JMPENV_POP;                         \
            if (restartop != nxt)               \
-               JMPENV_JUMP(3);                 \
+               JMPENV_JUMP(JMP_EXCEPTION);                     \
        }                                       \
        op = nxt;                               \
        SPAGAIN;                                \
@@ -64,8 +64,8 @@
        int ret;                                \
        JMPENV_PUSH(ret);                       \
        switch (ret) {                          \
-       case 1: JMPENV_POP; JMPENV_JUMP(1);     \
-       case 2: JMPENV_POP; JMPENV_JUMP(2);     \
-       case 3: JMPENV_POP; SPAGAIN; goto label;\
+       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;\
        }                                       \
     } while (0)
diff --git a/embed.h b/embed.h
index c5b537e..bca4108 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 2e64829..2441767 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 9b3308f..a455804 100644 (file)
@@ -367,6 +367,7 @@ ibcmp
 ibcmp_locale
 ingroup
 init_stacks
+install_tryblock_method
 instr
 intro_my
 intuit_more
index 7bbb11e..344af2c 100644 (file)
@@ -186,5 +186,6 @@ tmps_max
 tmps_stack
 top_env
 toptarget
+tryblock_function
 unsafe
 warnhook
index 74c914b..9f5f41b 100644 (file)
@@ -152,6 +152,8 @@ 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 757a65b..ba192d2 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 7b76edf..a119a45 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -214,10 +214,8 @@ perl_construct(register PerlInterpreter *sv_interp)
     init_ids();
     lex_state = LEX_NOTPARSING;
 
-    start_env.je_prev = NULL;
-    start_env.je_ret = -1;
-    start_env.je_mustcatch = TRUE;
-    top_env     = &start_env;
+    install_tryblock_method(0);     /* default to set/longjmp style tryblock */
+    JMPENV_TOPINIT(start_env);
     STATUS_ALL_SUCCESS;
 
     SET_NUMERIC_STANDARD();
@@ -610,6 +608,17 @@ 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)
@@ -618,16 +627,11 @@ perl_parse(PerlInterpreter *sv_interp, void (*xsinit) (void), int argc, char **a
 #endif
 {
     dTHR;
-    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;
+    TRY_PARSE_LOCALS locals;
+    locals.xsinit = xsinit;
+    locals.argc = argc;
+    locals.argv = argv;
+    locals.env = env;
 
 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
 #ifdef IAMSUID
@@ -675,451 +679,68 @@ setuid perl scripts securely.\n");
     main_cv = Nullcv;
 
     time(&basetime);
-    oldscope = scopestack_ix;
+    locals.oldscope = scopestack_ix;
 
-    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;
-    }
+    TRYBLOCK(PerlParseVtbl, locals);
+    return locals.ret;
+}
 
-    sv_setpvn(linestr,"",0);
-    sv = newSVpv("",0);                /* first used for -I flags */
-    SAVEFREESV(sv);
-    init_main_stash();
+struct try_run_locals {
+    I32 oldscope;
+    int ret;
+};
+typedef struct try_run_locals TRY_RUN_LOCALS;
+static TRYVTBL PerlRunVtbl;
 
-    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];
+int
+#ifdef PERL_OBJECT
+CPerlObj::perl_run(void)
+#else
+perl_run(PerlInterpreter *sv_interp)
 #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;
+{
+    dTHR;
+    TRY_RUN_LOCALS locals;
 
-       case 'T':
-           tainting = TRUE;
-           s++;
-           goto reswitch;
+#ifndef PERL_OBJECT
+    if (!(curinterp = sv_interp))
+       return 255;
+#endif
 
-       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;
+    locals.oldscope = scopestack_ix;
+    TRYBLOCK(PerlRunVtbl, locals);
+    return locals.ret;
+}
 
-       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);
+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);
        }
     }
-  switch_end:
+#endif /* USE_THREADS */
+    gv = gv_fetchpv(name, create, SVt_PV);
+    if (gv)
+       return GvSV(gv);
+    return Nullsv;
+}
 
-    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;
-    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;
-}
+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)
@@ -1205,7 +826,7 @@ perl_call_sv(SV *sv, I32 flags)
     I32 oldscope;
     bool oldcatch = CATCH_GET;
     dJMPENV;
-    int ret;
+    int jmpstat;
     OP* oldop = op;
 
     if (flags & G_DISCARD) {
@@ -1261,14 +882,14 @@ perl_call_sv(SV *sv, I32 flags)
        }
        markstack_ptr++;
 
-       JMPENV_PUSH(ret);
-       switch (ret) {
-       case 0:
+       JMPENV_PUSH(jmpstat);
+       switch (jmpstat) {
+       case JMP_NORMAL:
            break;
-       case 1:
+       case JMP_ABNORMAL:
            STATUS_ALL_FAILURE;
            /* FALL THROUGH */
-       case 2:
+       case JMP_MYEXIT:
            /* my_exit() was called */
            curstash = defstash;
            FREETMPS;
@@ -1277,7 +898,7 @@ perl_call_sv(SV *sv, I32 flags)
                croak("Callback called exit");
            my_exit_jump();
            /* NOTREACHED */
-       case 3:
+       case JMP_EXCEPTION:
            if (restartop) {
                op = restartop;
                restartop = 0;
@@ -1347,7 +968,7 @@ perl_eval_sv(SV *sv, I32 flags)
     I32 retval;
     I32 oldscope;
     dJMPENV;
-    int ret;
+    int jmpstat;
     OP* oldop = op;
 
     if (flags & G_DISCARD) {
@@ -1372,14 +993,14 @@ perl_eval_sv(SV *sv, I32 flags)
     if (flags & G_KEEPERR)
        myop.op_flags |= OPf_SPECIAL;
 
-    JMPENV_PUSH(ret);
-    switch (ret) {
-    case 0:
+    JMPENV_PUSH(jmpstat);
+    switch (jmpstat) {
+    case JMP_NORMAL:
        break;
-    case 1:
+    case JMP_ABNORMAL:
        STATUS_ALL_FAILURE;
        /* FALL THROUGH */
-    case 2:
+    case JMP_MYEXIT:
        /* my_exit() was called */
        curstash = defstash;
        FREETMPS;
@@ -1388,7 +1009,7 @@ perl_eval_sv(SV *sv, I32 flags)
            croak("Callback called exit");
        my_exit_jump();
        /* NOTREACHED */
-    case 3:
+    case JMP_EXCEPTION:
        if (restartop) {
            op = restartop;
            restartop = 0;
@@ -2729,16 +2350,16 @@ call_list(I32 oldscope, AV *paramList)
     line_t oldline = curcop->cop_line;
     STRLEN len;
     dJMPENV;
-    int ret;
+    int jmpstat;
 
     while (AvFILL(paramList) >= 0) {
        CV *cv = (CV*)av_shift(paramList);
 
        SAVEFREESV(cv);
 
-       JMPENV_PUSH(ret);
-       switch (ret) {
-       case 0: {
+       JMPENV_PUSH(jmpstat);
+       switch (jmpstat) {
+       case JMP_NORMAL: {
                SV* atsv = ERRSV;
                PUSHMARK(stack_sp);
                perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
@@ -2757,10 +2378,10 @@ call_list(I32 oldscope, AV *paramList)
                }
            }
            break;
-       case 1:
+       case JMP_ABNORMAL:
            STATUS_ALL_FAILURE;
            /* FALL THROUGH */
-       case 2:
+       case JMP_MYEXIT:
            /* my_exit() was called */
            while (scopestack_ix > oldscope)
                LEAVE;
@@ -2779,7 +2400,7 @@ call_list(I32 oldscope, AV *paramList)
            }
            my_exit_jump();
            /* NOTREACHED */
-       case 3:
+       case JMP_EXCEPTION:
            if (!restartop) {
                PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
                FREETMPS;
@@ -2788,7 +2409,7 @@ call_list(I32 oldscope, AV *paramList)
            JMPENV_POP;
            curcop = &compiling;
            curcop->cop_line = oldline;
-           JMPENV_JUMP(3);
+           JMPENV_JUMP(JMP_EXCEPTION);
        }
        JMPENV_POP;
     }
@@ -2867,18 +2488,14 @@ my_exit_jump(void)
        LEAVE;
     }
 
-    JMPENV_JUMP(2);
+    JMPENV_JUMP(JMP_MYEXIT);
 }
 
 
 #include "XSUB.h"
 
 static I32
-#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
+read_e_script(CPERLarg_ int idx, SV *buf_sv, int maxlen)
 {
     char *p, *nl;
     p  = SvPVX(e_script);
@@ -2891,4 +2508,461 @@ read_e_script(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 60f7dd5..b8a5cb7 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -104,6 +104,7 @@ 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,
@@ -118,6 +119,7 @@ class CPerlObj;
 #define STATIC static
 #define CPERLscope(x) x
 #define CPERLproto
+#define CPERLproto_
 #define _CPERLproto
 #define CPERLarg void
 #define CPERLarg_
@@ -1638,6 +1640,10 @@ 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 8dd2f82..e35ad46 100644 (file)
@@ -1380,6 +1380,11 @@ 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.
@@ -1915,7 +1920,9 @@ was string.
 
 =item panic: top_env
 
-(P) The compiler attempted to do a goto, or something weird like that.
+(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>.
 
 =item panic: yylex
 
index fb52ecf..dce6ca5 100644 (file)
@@ -1252,6 +1252,79 @@ 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 9b924bc..ac2ddfc 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(3);
+        JMPENV_JUMP(JMP_EXCEPTION);
     }
 
     RETURNOP(retop);
@@ -2110,7 +2110,7 @@ STATIC OP *
 docatch(OP *o)
 {
     dTHR;
-    int ret;
+    int jmpstat;
     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(ret);
-    switch (ret) {
+    JMPENV_PUSH(jmpstat);
+    switch (jmpstat) {
     default:                           /* topmost level handles it */
        JMPENV_POP;
        op = oldop;
-       JMPENV_JUMP(ret);
+       JMPENV_JUMP(jmpstat);
        /* NOTREACHED */
-    case 3:
+    case JMP_EXCEPTION:
        if (!restartop) {
            PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
            break;
@@ -2134,7 +2134,7 @@ docatch(OP *o)
        op = restartop;
        restartop = 0;
        /* FALL THROUGH */
-    case 0:
+    case JMP_NORMAL:
         CALLRUNOPS();
        break;
     }
diff --git a/proto.h b/proto.h
index 2356e68..4467dde 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -205,6 +205,7 @@ 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 5958aba..c0924d8 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)
 {
@@ -906,3 +917,69 @@ 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 cc349f0..7170365 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
- * longjmp() at that runlevel (we make sure start_env.je_prev is always
- * null to ensure this).
+ * (*je_jump)() at that runlevel.  Always use the macros below!  They
+ * manage most of the complexity for you.
  *
  * 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.
- * GSAR 97-03-27
+ *
+ * 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)
  */
 
+#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;
-    Sigjmp_buf         je_buf;         
-    int                        je_ret;         /* return value of last setjmp() */
-    bool               je_mustcatch;   /* longjmp()s must be caught locally */
+    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*));
+};
+typedef struct tryvtbl TRYVTBL;
+
+typedef void (*tryblock_f) _((CPERLproto_ TRYVTBL *vtbl, void *locals));
+#define TRYBLOCK(mytry,vars) \
+       (*tryblock_function)(PERL_OBJECT_THIS_ &mytry, &vars)
+
 #ifdef OP_IN_REGISTER
 #define OP_REG_TO_MEM  opsave = op
 #define OP_MEM_TO_REG  op = opsave
@@ -127,30 +157,83 @@ typedef struct jmpenv JMPENV;
 #define OP_MEM_TO_REG  NOOP
 #endif
 
-#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_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 JMPENV_JUMP(v) \
     STMT_START {                                               \
+       assert((v) != JMP_NORMAL);                              \
        OP_REG_TO_MEM;                                          \
-       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);                                               \
+       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);                                       \
     } 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 2fa7740..f1cd3bc 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(3);
+       JMPENV_JUMP(JMP_EXCEPTION);
     return restartop;
 }
 
@@ -1355,7 +1355,7 @@ croak(const char* pat, ...)
     }
     if (in_eval) {
        restartop = die_where(message);
-       JMPENV_JUMP(3);
+       JMPENV_JUMP(JMP_EXCEPTION);
     }
     PerlIO_puts(PerlIO_stderr(),message);
     (void)PerlIO_flush(PerlIO_stderr());
@@ -2759,10 +2759,7 @@ new_struct_thread(struct perl_thread *t)
        See comments in scope.h    
        Initialize top entry (as in perl.c for main thread)
      */
-    start_env.je_prev = NULL;
-    start_env.je_ret = -1;
-    start_env.je_mustcatch = TRUE;
-    top_env  = &start_env;
+    JMPENV_TOPINIT(start_env);
 
     in_eval = FALSE;
     restartop = 0;