registrar as eTcl plugin

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 (but not change them). The script seems to have been originated on the early landscape-screen "clamshell" pocket PCs, so quite some changes in geometry were necessary.

WikiDbImage registrar.jpg

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 from horizontal to vertical and back, depending on what fits better for the small screen, by double-tapping on the sash.


 package require registry
 package require BWidget 1.3

 namespace eval regb {
    variable BaseKeys {
      HKEY_CLASSES_ROOT
      HKEY_LOCAL_MACHINE
      HKEY_CURRENT_USER
   }
   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 $f.pw -ori vert]
    bind $pw <Double-1> {toggle'ori %W}
    set tf [labelframe $pw.tf -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
    update
    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}

Note: even though this is only passively reading the registry, you can use it to change it as well. Just copy the text widget's contents into a buffer, put "registry set " in front, brace the name (because of the backslashes), remove the type (everything is an sz), and possibly quote the value. Eval and go...


MHo 2010-01-19: Just made a starpack of the above code because I quickly needed a browser to quickly inspect the registry while logged on as a normal user. Is there a way to avoid the invalid command name hexdump-message? I think this is a procedure available in your environment somewhere.


Category Windows