scripts/stackdump.tcl

   1 # vim: ft=tcl foldmethod=marker foldmarker=<<<,>>> ts=4 shiftwidth=4
   2
   3 proc tlc::stackdump {} { #<<<
   4         return "Disfunctional at the moment"
   5         set build               ""
   6         set stackframes [tlc::build_stackdump 2]
   7
   8         foreach frameinfo $stackframes {
   9                 if {[dict get $frameinfo type] eq "precompiled"} {
  10                         append build    "compiled - no info" \n
  11                         continue
  12                 }
  13
  14                 if {[dict get $frameinfo type] eq "eval"} {
  15                         continue
  16                 }
  17
  18                 set line        {}
  19
  20                 if {[dict exists $frameinfo file]} {
  21                         lappend line    "([dict get $frameinfo file]:[dict get $frameinfo line])"
  22                 } elseif {[dict exists $frameinfo proc]} {
  23                         lappend line    "(proc [dict get $frameinfo proc]:[dict get $frameinfo line])"
  24                 }
  25
  26                 if {[dict exists $frameinfo desc]} {
  27                         lappend line    [dict get $frameinfo desc]
  28                 } else {
  29                         # TODO: defend against very long values of cmd
  30                         lappend line    [dict get $frameinfo cmd]
  31                 }
  32
  33                 append build    [join $line " "] "\n"
  34         }
  35
  36         return $build
  37 }
  38
  39 #>>>
  40 proc tlc::build_stackdump {{trim 2}} { #<<<
  41         set stackframes {}
  42
  43         set thislevel   [expr {[info frame] - $trim}]
  44         for {set i $thislevel} {$i > 0} {incr i -1} {
  45                 set frameinfo   [info frame $i]
  46                 if {[dict exists $frameinfo level]} {
  47                         set level       [dict get $frameinfo level]
  48                         if {![catch {
  49                                 dict set frameinfo levelinf [info level [expr {0 - $level}]]
  50                         }]} {
  51                                 set stackname   [lindex [dict get $frameinfo levelinf] 0]
  52                                 set passed_args [lrange [dict get $frameinfo levelinf] 1 end]
  53
  54                                 if {$stackname ne "" && $stackname ne "namespace"} {
  55                                         if {[catch {
  56                                                 set fqname \
  57                                                                 [uplevel $level [list namespace origin $stackname]]
  58                                         } errmsg]} {
  59                                                 set fqname "??$stackname"
  60                                         }
  61                                         if {[catch {
  62                                                 set caller_args_def \
  63                                                                 [uplevel $level [list info args $stackname]]
  64                                         } errmsg]} {
  65                                                 set caller_args_def     "Bad uplevel depth: ($level)"
  66                                         }
  67                                 } else {
  68                                         set fqname      "<unknown>"
  69                                         set caller_args_def     {}
  70                                         for {set j      1} {$j < [llength $passed_args]} {incr j} {
  71                                                 lappend caller_args_def "<unknown$j>"
  72                                         }
  73                                 }
  74                                 set idx         -1
  75                                 set substmap    [list "\n" "\\n" "\t" "\\t"]
  76                                 set argdesc     {}
  77                                 foreach arg $caller_args_def {
  78                                         incr idx
  79                                         if {$arg eq "args"} {
  80                                                 set this_passed_arg     [lrange $passed_args $idx end]
  81                                         } else {
  82                                                 set this_passed_arg     [lindex $passed_args $idx]
  83                                         }
  84
  85                                         set alen        [string length $this_passed_arg]
  86
  87                                         if {$this_passed_arg eq ""} {
  88                                                 set this_passed_arg "{}"
  89                                         } elseif {![string is print $this_passed_arg]} {
  90                                                 set this_passed_arg     "#<nonprint($alen)>"
  91                                         } elseif {$alen > 23} {
  92                                                 set this_passed_arg     [string range $this_passed_arg 0 21]
  93                                                 set this_passed_arg     [string map $substmap $this_passed_arg]
  94                                                 set this_passed_arg     "$this_passed_arg/$alen"
  95                                         } else {
  96                                                 set this_passed_arg     [string map $substmap $this_passed_arg]
  97                                         }
  98
  99                                         lappend argdesc "$arg<$this_passed_arg>"
 100                                 }
 101                                 set desc        "${fqname}([join $argdesc])"
 102                                 dict set frameinfo desc $desc
 103                         }
 104
 105                         lappend stackframes     $frameinfo
 106                 }
 107         }
 108
 109         return $stackframes
 110 }
 111
 112 #>>>