run.c

   1 /*    run.c
   2  *
   3  *    Copyright (c) 1991-1997, 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 #include "perl.h"
  12
  13 /*
  14  * "Away now, Shadowfax!  Run, greatheart, run as you have never run before!
  15  * Now we are come to the lands where you were foaled, and every stone you
  16  * know.  Run now!  Hope is in speed!"  --Gandalf
  17  */
  18
  19 #ifdef PERL_OBJECT
  20 #define CALLOP this->*op
  21 #else
  22 #define CALLOP *op
  23 #endif
  24
  25 int
  26 runops_standard(void) {
  27     dTHR;
  28
  29     while ( op = (CALLOP->op_ppaddr)(ARGS) ) ;
  30
  31     TAINT_NOT;
  32     return 0;
  33 }
  34
  35 dEXT char **watchaddr = 0;
  36 dEXT char *watchok;
  37
  38 #ifndef PERL_OBJECT
  39 static void debprof _((OP*o));
  40 #endif
  41
  42 int
  43 runops_debug(void)
  44 {
  45 #ifdef DEBUGGING
  46     dTHR;
  47     if (!op) {
  48         warn("NULL OP IN RUN");
  49         return 0;
  50     }
  51
  52     do {
  53         if (debug) {
  54             if (watchaddr != 0 && *watchaddr != watchok)
  55                 PerlIO_printf(Perl_debug_log, "WARNING: %lx changed from %lx to %lx\n",
  56                     (long)watchaddr, (long)watchok, (long)*watchaddr);
  57             DEBUG_s(debstack());
  58             DEBUG_t(debop(op));
  59             DEBUG_P(debprof(op));
  60         }
  61     } while ( op = (CALLOP->op_ppaddr)(ARGS) );
  62
  63     TAINT_NOT;
  64     return 0;
  65 #else
  66     return runops_standard();
  67 #endif /* DEBUGGING */
  68 }
  69
  70 I32
  71 debop(OP *o)
  72 {
  73 #ifdef DEBUGGING
  74     SV *sv;
  75     deb("%s", op_name[o->op_type]);
  76     switch (o->op_type) {
  77     case OP_CONST:
  78         PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOPo->op_sv));
  79         break;
  80     case OP_GVSV:
  81     case OP_GV:
  82         if (cGVOPo->op_gv) {
  83             sv = NEWSV(0,0);
  84             gv_fullname3(sv, cGVOPo->op_gv, Nullch);
  85             PerlIO_printf(Perl_debug_log, "(%s)", SvPV(sv, na));
  86             SvREFCNT_dec(sv);
  87         }
  88         else
  89             PerlIO_printf(Perl_debug_log, "(NULL)");
  90         break;
  91     default:
  92         break;
  93     }
  94     PerlIO_printf(Perl_debug_log, "\n");
  95 #endif /* DEBUGGING */
  96     return 0;
  97 }
  98
  99 void
 100 watch(char **addr)
 101 {
 102 #ifdef DEBUGGING
 103     watchaddr = addr;
 104     watchok = *addr;
 105     PerlIO_printf(Perl_debug_log, "WATCHING, %lx is currently %lx\n",
 106         (long)watchaddr, (long)watchok);
 107 #endif /* DEBUGGING */
 108 }
 109
 110 STATIC void
 111 debprof(OP *o)
 112 {
 113 #ifdef DEBUGGING
 114     if (!profiledata)
 115         New(000, profiledata, MAXO, U32);
 116     ++profiledata[o->op_type];
 117 #endif /* DEBUGGING */
 118 }
 119
 120 void
 121 debprofdump(void)
 122 {
 123 #ifdef DEBUGGING
 124     unsigned i;
 125     if (!profiledata)
 126         return;
 127     for (i = 0; i < MAXO; i++) {
 128         if (profiledata[i])
 129             PerlIO_printf(Perl_debug_log,
 130                           "%u\t%lu\n", i, (unsigned long)profiledata[i]);
 131     }
 132 #endif /* DEBUGGING */
 133 }