Version 0 of registrar as eTcl plugin

Updated 2006-01-30 09:24:27 by suchenwi

Richard Suchenwirth 2006-01-30 - The following script is a radical rewrite for use with Sepp and eTcl, of regbrowser.tcl (author unknown), that comes with the Keuchel distribution of Tcl 8.4a2 on PocketPC. It allows to wander through the tree of registry keys, and list the items there. The script seems to have been originated on the early landscape-screen "clamshell" pocket PCs. I also used Tk's panedwindow and labelframe instead of the BWidget equivalents. One nice feature is that one can toggle the orientation of the panedwindow form horizontal to vertical and back, depending what fits better for the small screen.

 package require registry
 package require BWidget 1.3

 namespace eval regb {
    variable BaseKeys {
   variable PROGINC -1
   variable PROGTXT ""
 proc regb::build_screen {w} {
    variable BaseKeys
    if {$w ne ""} {toplevel $w}
    NoteBook $w.nb -internalborderwidth 0
    foreach k $BaseKeys {
         build_tree_tab $w.nb $k
    build_info_tab $w.nb
    $w.nb compute_size
    pack $w.nb -fill both -expand yes
    $w.nb raise [$w.nb pages end]
    if {$w eq ""} {set w .; wm deic $w}
    wm title $w Registrar
    wm geometry $w 240x268
    catch {wce siphide}
 proc regb::build_info_tab {nb} {
    set f [$nb insert end help -text ?]
    text $f.t 
    $f.t tag config HEAD -font {Tahoma 9 bold}
    pack $f.t
    $f.t insert end "\nSimple Registry Browser" HEAD
    $f.t insert end "\n
 Each Tab is a separate HKEY section of Registry
 Selecting a key on the left side shows all values under that key\n\n"
    $f.t insert end "Mouse Actions:\n" HEAD
    $f.t insert end "Click : Selects that key
 Click: (on Cross) Opens/closes folder\n\n"
    $f.t insert end "Arrow Key Actions:\n" HEAD
    $f.t insert end "Up : Moves selection to previous key
 Down : Moves selection to next key
 Right : Opens key folder (subkeys)
 Left : Closes key folder (subkeys)"
 proc regb::make_readable key {
    set str {}
    foreach word [lrange [split $key _] 1 end] {
       regexp {(.)(.*)} $word -> l rest
       lappend str "$l[string tolower $rest]"
    join $str
 proc regb::build_tree_tab {nb key} {
   set font {Tahoma 8}
    set f [$nb insert end $key -text [make_readable $key]]
    set pw [panedwindow $ -ori vert]
    bind $pw <Double-1> {toggle'ori %W}
    set tf [labelframe $ -text $key -font $font]
    $pw add $tf
    set sw [ScrolledWindow $tf.sw -relief sunken -borderwidth 0]
    set tree [Tree $sw.tree -deltax 8 \
                  -opencmd "regb::change_node 1 $sw.tree" \
                  -closecmd "regb::change_node 0 $sw.tree"]
    $sw setwidget $tree
    pack $sw  -fill both -expand yes
    set sw [ScrolledWindow $pw.sw -borderwidth 0]
    $pw add $sw
    set txt [text $sw.txt -font $font]
    $txt tag config MAINKEY -font "$font bold"
    $sw setwidget $txt
    pack $pw -fill both -expand yes
    after idle "$pw sash place 0 0 140"
    $tree configure -selectcommand "regb::update_contents $txt"
    $nb itemconfigure $key \
        -createcmd "regb::init_tree $tree $key" \
        -raisecmd "focus $tree"
    return $tree
 proc toggle'ori w {
    $w config -ori [expr {[$w cget -ori] eq "horizontal"? "vertical" : "horizontal"}]
 proc regb::init_tree {tw key} {
    variable PROGTXT "Creating Tree for \n $key"
    variable PROGINC -1
    ProgressDlg .prg -textvariable ::regb::PROGTXT -variable ::regb::PROGINC \
        -type infinite -maximum 50000
    $tw configure -redraw 0
    add_nodes $tw root $key 0
    $tw configure -redraw 1
    destroy .prg
 proc max args {
    if {[llength $args] == 1} {
       set args [lindex $args 0]
    lindex [lsort -dict -dec $args] 0
 set regb::NODECOUNT 0
 proc regb::add_nodes {tw node key {cfg 1}} {
    variable PROGINC
    if [catch {registry keys $key} keys] {
       tk_messageBox -icon error -title "Registry Lookup Failed" -message \
           "Unable to get keys from registry.\nKey: $key\nError: $keys"
    } else {
       set cursor [$tw cget -cursor]
       $tw configure -cursor watch
       foreach k $keys {
          $tw insert end $node nd:[incr ::regb::NODECOUNT] \
              -text $k \
              -data "$key\\$k" \
              -drawcross allways \
              -image [Bitmap::get folder]
          incr PROGINC
       $tw configure -cursor $cursor
    set data "$key\n\n"
    if [catch {registry values $key} vals] {
       tk_messageBox -icon error -title "Registry Lookup Failed" -message \
           "Unable to get values from registry.\nKey: $key\nError: $vals"
       append data "ERROR: Cannot Get Values"
    } else {
       set items {}
       foreach n $vals {
         set t [registry type $key $n]
         set v [registry get $key $n]
         if {$t eq "binary"} {set v [hexdump $v]}
         lappend items [format "%s (%s) %s" $n $t $v ]
       if {[llength $items]} {
          append data [join $items "\n"]
       } else {append data "(no values)"}
    if { $cfg } {
       $tw itemconfigure $node -drawcross auto -data $data
    incr PROGINC
 proc regb::update_contents {txt tw node} {
    $txt config -state normal
    $txt delete 1.0 end
    set dat [$tw itemcget $node -data]
    if {[$tw itemcget $node -drawcross] eq "allways"} {
       add_nodes $tw $node $dat
       set dat [$tw itemcget $node -data]
    $txt insert end $dat
    $txt tag add MAINKEY 1.0 2.0 
    $txt config -state disabled

 proc regb::change_node {open tw node} {
    if {$open} {
       if {[$tw itemcget $node -drawcross] eq "allways"} {
          add_nodes $tw $node [$tw itemcget $node -data]
          if {[llength [$tw nodes $node]]} {
             $tw itemconfigure $node -image [Bitmap::get openfold]
          } else {
             $tw itemconfigure $node -image [Bitmap::get folder]
       } else {
          $tw itemconfigure $node -image [Bitmap::get openfold]
    } else {
       $tw itemconfigure $node -image [Bitmap::get folder]

#-- toplevel entry function

 proc registrar {{w ""}} {regb::build_screen  $w}