| 1 | /* run.c |
| 2 | * |
| 3 | * Copyright (c) 1991-2001, Larry Wall |
| 4 | * |
| 5 | * You may distribute under the terms of either the GNU General Public |
| 6 | * License or the Artistic License, as specified in the README file. |
| 7 | * |
| 8 | */ |
| 9 | |
| 10 | #include "EXTERN.h" |
| 11 | #define PERL_IN_RUN_C |
| 12 | #include "perl.h" |
| 13 | |
| 14 | /* |
| 15 | * "Away now, Shadowfax! Run, greatheart, run as you have never run before! |
| 16 | * Now we are come to the lands where you were foaled, and every stone you |
| 17 | * know. Run now! Hope is in speed!" --Gandalf |
| 18 | */ |
| 19 | |
| 20 | int |
| 21 | Perl_runops_standard(pTHX) |
| 22 | { |
| 23 | while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX))) { |
| 24 | PERL_ASYNC_CHECK(); |
| 25 | } |
| 26 | |
| 27 | TAINT_NOT; |
| 28 | return 0; |
| 29 | } |
| 30 | |
| 31 | int |
| 32 | Perl_runops_debug(pTHX) |
| 33 | { |
| 34 | #ifdef DEBUGGING |
| 35 | if (!PL_op) { |
| 36 | if (ckWARN_d(WARN_DEBUGGING)) |
| 37 | Perl_warner(aTHX_ WARN_DEBUGGING, "NULL OP IN RUN"); |
| 38 | return 0; |
| 39 | } |
| 40 | |
| 41 | do { |
| 42 | PERL_ASYNC_CHECK(); |
| 43 | if (PL_debug) { |
| 44 | if (PL_watchaddr != 0 && *PL_watchaddr != PL_watchok) |
| 45 | PerlIO_printf(Perl_debug_log, |
| 46 | "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n", |
| 47 | PTR2UV(PL_watchaddr), PTR2UV(PL_watchok), |
| 48 | PTR2UV(*PL_watchaddr)); |
| 49 | DEBUG_s(debstack()); |
| 50 | DEBUG_t(debop(PL_op)); |
| 51 | DEBUG_P(debprof(PL_op)); |
| 52 | } |
| 53 | } while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX))); |
| 54 | |
| 55 | TAINT_NOT; |
| 56 | return 0; |
| 57 | #else |
| 58 | return runops_standard(); |
| 59 | #endif /* DEBUGGING */ |
| 60 | } |
| 61 | |
| 62 | I32 |
| 63 | Perl_debop(pTHX_ OP *o) |
| 64 | { |
| 65 | #ifdef DEBUGGING |
| 66 | AV *padlist, *comppad; |
| 67 | CV *cv; |
| 68 | SV *sv; |
| 69 | STRLEN n_a; |
| 70 | Perl_deb(aTHX_ "%s", PL_op_name[o->op_type]); |
| 71 | switch (o->op_type) { |
| 72 | case OP_CONST: |
| 73 | PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo_sv)); |
| 74 | break; |
| 75 | case OP_GVSV: |
| 76 | case OP_GV: |
| 77 | if (cGVOPo_gv) { |
| 78 | sv = NEWSV(0,0); |
| 79 | gv_fullname3(sv, cGVOPo_gv, Nullch); |
| 80 | PerlIO_printf(Perl_debug_log, "(%s)", SvPV(sv, n_a)); |
| 81 | SvREFCNT_dec(sv); |
| 82 | } |
| 83 | else |
| 84 | PerlIO_printf(Perl_debug_log, "(NULL)"); |
| 85 | break; |
| 86 | case OP_PADSV: |
| 87 | case OP_PADAV: |
| 88 | case OP_PADHV: |
| 89 | /* print the lexical's name */ |
| 90 | cv = deb_curcv(cxstack_ix); |
| 91 | if (cv) { |
| 92 | padlist = CvPADLIST(cv); |
| 93 | comppad = (AV*)(*av_fetch(padlist, 0, FALSE)); |
| 94 | sv = *av_fetch(comppad, o->op_targ, FALSE); |
| 95 | } else |
| 96 | sv = Nullsv; |
| 97 | if (sv) |
| 98 | PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen(sv)); |
| 99 | else |
| 100 | PerlIO_printf(Perl_debug_log, "[%"UVuf"]", (UV)o->op_targ); |
| 101 | break; |
| 102 | default: |
| 103 | break; |
| 104 | } |
| 105 | PerlIO_printf(Perl_debug_log, "\n"); |
| 106 | #endif /* DEBUGGING */ |
| 107 | return 0; |
| 108 | } |
| 109 | |
| 110 | #ifdef DEBUGGING |
| 111 | |
| 112 | STATIC CV* |
| 113 | S_deb_curcv(pTHX_ I32 ix) |
| 114 | { |
| 115 | PERL_CONTEXT *cx = &cxstack[ix]; |
| 116 | if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) |
| 117 | return cx->blk_sub.cv; |
| 118 | else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx)) |
| 119 | return PL_compcv; |
| 120 | else if (ix == 0 && PL_curstackinfo->si_type == PERLSI_MAIN) |
| 121 | return PL_main_cv; |
| 122 | else if (ix <= 0) |
| 123 | return Nullcv; |
| 124 | else |
| 125 | return deb_curcv(ix - 1); |
| 126 | } |
| 127 | |
| 128 | #endif /* DEBUGGING */ |
| 129 | |
| 130 | void |
| 131 | Perl_watch(pTHX_ char **addr) |
| 132 | { |
| 133 | #ifdef DEBUGGING |
| 134 | PL_watchaddr = addr; |
| 135 | PL_watchok = *addr; |
| 136 | PerlIO_printf(Perl_debug_log, "WATCHING, %"UVxf" is currently %"UVxf"\n", |
| 137 | PTR2UV(PL_watchaddr), PTR2UV(PL_watchok)); |
| 138 | #endif /* DEBUGGING */ |
| 139 | } |
| 140 | |
| 141 | #ifdef DEBUGGING |
| 142 | |
| 143 | STATIC void |
| 144 | S_debprof(pTHX_ OP *o) |
| 145 | { |
| 146 | if (!PL_profiledata) |
| 147 | Newz(000, PL_profiledata, MAXO, U32); |
| 148 | ++PL_profiledata[o->op_type]; |
| 149 | } |
| 150 | |
| 151 | #endif /* DEBUGGING */ |
| 152 | |
| 153 | void |
| 154 | Perl_debprofdump(pTHX) |
| 155 | { |
| 156 | #ifdef DEBUGGING |
| 157 | unsigned i; |
| 158 | if (!PL_profiledata) |
| 159 | return; |
| 160 | for (i = 0; i < MAXO; i++) { |
| 161 | if (PL_profiledata[i]) |
| 162 | PerlIO_printf(Perl_debug_log, |
| 163 | "%5lu %s\n", (unsigned long)PL_profiledata[i], |
| 164 | PL_op_name[i]); |
| 165 | } |
| 166 | #endif /* DEBUGGING */ |
| 167 | } |