home *** CD-ROM | disk | FTP | other *** search
/ ARM Club 3 / TheARMClub_PDCD3.iso / hensa / programming / tcl / tcl_1 / !Peek_Peek < prev    next >
Encoding:
Text File  |  1996-03-21  |  3.4 KB  |  161 lines
  1. # Peek
  2.  
  3. source {<tcl$Dir>.!Choices}
  4.  
  5. w_init Peek
  6.  
  7. source {<tcl$Dir>.library.debug}
  8.  
  9. w_box progInfo create "About this program"\
  10.  { vlist {info Name Peek}
  11.          {info Purpose "Examine a Tcl/w program"}
  12.          {info Author C.T.Stretch}
  13.          {info Version 0.00}
  14.  }
  15.  
  16. w_box openbox create "Open a task"\
  17.  { vlist {write task task}
  18.          {hlist {action Cancel} {default " Open" {startup $task}}}
  19.  }
  20.  
  21. w_box commandbox create Peek\
  22.  { vlist {display Task: tasks}
  23.         { hlist
  24.           {action Variables {getvars %d;return show}}
  25.           {action Arrays {getarrays %d;return show}}
  26.         }
  27.         { hlist
  28.           {action Trace {settrace %d $command(%d);return show}}
  29.           {action TraceProc {traceproc %d $command(%d);return show}}
  30.         }
  31.         { write " Command" command}
  32.         { hlist
  33.           {action Close}
  34.           {default Execute {send %d $command(%d);return show}}
  35.         }
  36.  } -tag
  37.  
  38. set tasklist [w_info wimptasks]
  39. set menudata Tasks
  40. foreach t $tasklist\
  41.  { lappend menudata [list $t -click [list startup $t]]
  42.  }
  43. set menudata [list $menudata]
  44.  
  45. set menudata [list Peek {Info -dbox progInfo}\
  46.                          "Tasks -sub $menudata"\
  47.                         {Open -dbox openbox}\
  48.                         {Quit -click exit}\
  49.              ]
  50.  
  51. w_bar -menu $menudata
  52.  
  53. proc traceproc {t v}\
  54.  { if {[catch {w_send $t "info args $v"} pargs]}\
  55.    { w_error "send to $t failed1"
  56.      return
  57.    }
  58.    if {[catch {w_send $t "info body $v"} pbody]}\
  59.    { w_error "send to $t failed2"
  60.      return
  61.    }
  62.    set p "proc $v \{$pargs\} \{"
  63.    set dargs ""
  64.    foreach a $pargs\
  65.    { set dargs "$dargs \$$a"
  66.    }
  67.    set q "catch \{w_send Peek \"w_text $t write traceproc $v $dargs\" \}"
  68.    if {[catch {w_send $t $p\n$q\n$pbody\}} res]}\
  69.    { w_error "send to $t failed3"
  70.      w_text $t write $res
  71.      return
  72.    }
  73.  }
  74.  
  75. proc settrace {t v}\
  76.  { set p\
  77.    { proc peek_trace {name element op}\
  78.      { if {$element !=""}\
  79.        { set name ${name}($element)
  80.        }
  81.        upvar $name x
  82.        catch\
  83.        { w_send Peek\
  84.          " w_text xxxxx write \" trace: $name ($op) $x\" " 
  85.        }
  86.      }
  87.    }
  88.    regsub xxxxx $p $t p
  89.    set s "trace variable $v wu peek_trace"
  90.    if {[catch {w_send $t $p\n$s} vars]}\
  91.    { w_error "send to $t failed"
  92.      return
  93.    }
  94.  }
  95.  
  96. proc getvars {t}\
  97.  { if {[catch {w_send $t {info globals}} vars]}\
  98.    { w_error "send to $t failed"
  99.      return
  100.    }
  101.    foreach v $vars\
  102.    { set k [catch {w_send $t "set $v"} res]
  103.      if {$k==1}\
  104.      { w_error "send to $t failed"
  105.        return
  106.      }
  107.      if {$k==0}\
  108.      { w_text $t write $v=$res}
  109.    }
  110.    return
  111.  }
  112.  
  113. proc getarrays {t}\
  114.  { if {[catch {w_send $t {info globals}} vars]}\
  115.    { w_error "send to $t failed"
  116.      return
  117.    }
  118.    foreach v $vars\
  119.    { set k [catch {w_send $t "array names $v"} res]
  120.      if {$k==1}\
  121.      { w_error "send to $t failed"
  122.        return
  123.      }
  124.      if {$k!=0} continue
  125.      if {$res==""} continue
  126.      w_text $t write $v:$res
  127.      foreach n $res\
  128.      { set k [catch {w_send $t "set $v\($n)"} val]
  129.        if {$k==1}\
  130.        { w_error "send to $t failed"
  131.          return
  132.        }
  133.        w_text $t write "$v\($n)=$val"
  134.      }
  135.    }
  136.  }
  137.  
  138. proc startup {t}\
  139.  { global tasks
  140.    if {[catch {w_text $t create -title "Peek at $t"}]}\
  141.    { w_error "$t already open"
  142.      return 0
  143.    }
  144.    set tasks($t) $t
  145.    w_text $t open
  146.    w_box commandbox open $t
  147.    list 0
  148.  }
  149.  
  150. proc send {t c}\
  151.  { set k [catch {w_send $t $c} result]
  152.    if {$k==1}\
  153.    { w_error "send to $t failed"
  154.      return
  155.    }
  156.    w_text $t write $result
  157.  }
  158.  
  159.  
  160.  
  161.