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.
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.