#!/usr/bin/env wish
#!/usr//bin/wish
package require Tk
# frames
# +---+
# | A |
# +---+
# | B |
# +---+
set A [ttk::frame ._top]
set B [ttk::frame ._tail]
set PAD [::ttk::notebook $B.pad -width 720 -height 640]
pack $A -fill x
pack $B $PAD -expand yes -fill both
bind . <Escape> { destroy [$PAD select] }
bind $PAD <2> { destroy [lindex [$PAD tabs] [$PAD index @%x,%y]]}
#############################################################################
#############################################################################
#############################################################################
proc man_tag { w {regex {[\w\d:\-\.]+\s*\([1-9]\w*\)}} } {
# we need to do tags individually as they
# as they need a binding and are likely different,
# unlike a general search
set A [$w.txt search -regex -count B -all $regex 1.0 end]
if { $A eq "" } return
foreach a $A b $B {
set name [$w.txt get $a "$a +${b}c" ]
$w.txt tag add $name $a "$a +${b}c"
$w.txt tag configure $name -foreground blue
$w.txt tag bind $name <1> "execute fossil help $name"
}
}
# do a grep on a text widget and get all indices
proc search { w } {
global PAD
set B {}
set L {}
set tagname $w.tag
$w.txt tag remove $tagname 1.0 end
# B == the string lengths
set A [$w.txt search -regex -count B -all [$w.grep get] 1.0 end]
if { $B eq {} } return
foreach a $A b $B {
lappend L $a "$a + $b chars"
}
$w.txt tag configure $tagname -foreground black -background yellow
eval $w.txt tag add $tagname $L
focus [$PAD select].txt
$w.txt see [lindex $A 0]
}
proc scroller {name} {
set frame $name
frame $frame
ttk::scrollbar ${frame}.s -command " $frame.txt yview "
text $frame.txt -yscrollcommand "${frame}.s set"
$frame.txt configure -font {Courier 10} -wrap none -relief groove
$frame.txt configure -foreground black -background ivory
pack $frame.s -side left -fill y
pack $frame.txt -expand yes -fill both
set g [entry $frame.grep -width 30]
pack [label $frame.name -anchor w -text grep] -side left
pack $g -fill x
bind $g <Key-Return> "search $frame"
return $frame
}
# if the system call runs but fails, the close will fail
proc slurp_inner { args } {
set args [eval concat $args]
set fp [open "|$args 2>@1"]
set R [read $fp]
catch {close $fp}
return $R
}
# catch the sytem call itself
proc slurp { args } {
catch {slurp_inner $args} a b
return $a
}
proc name_trim { args } {
return [regsub -all {\W} $args _ ]
}
proc execute { args } {
global PAD keywords
set args [eval concat $args]
set name .[name_trim $args]
if { ! [winfo exists $name] } {
scroller $name
$PAD add $name -text $args
$name.txt insert end "$args\n"
$name.txt insert end [eval slurp $args]
man_tag $name $keywords
}
$PAD select $name
}
##################### Jetzt geht's los! #######################
# use 'fossil help -a' to automagically grab
# the available commands and join a huge regex
# like:
# "this|that|or|the|other"
set cmds [ slurp fossil help -a ]
set keywords [ join $cmds {\M|\m}]
puts $keywords
execute fossil help -a