--- /dev/null
+
+package provide mlcm::gui 0.1
+
+namespace eval mlcm::gui {
+
+ variable _gid 0
+
+ proc _newwindow {} {
+ variable _gid
+ return ".top[incr _gid]"
+ }
+
+ proc _activate btn {
+ set bg1 [$btn cget -background]
+ set bg2 [$btn cget -activebackground]
+ if ![string equal $bg1 $bg2] {
+ $btn configure -background $bg2
+ after 200 $btn configure -background $bg1
+ $btn invoke
+ }
+ }
+
+ proc _button args {
+ set res [eval button $args]
+ if [catch {
+ set under [$res cget -underline]
+ set key [$res cget -text]
+ if {0 <= $under} {
+ set key [string index $key $under]
+ bind . <Alt-KeyPress-$key> "mlcm::gui::_activate $res"
+ puts "bound $key to $res"
+ }
+ }] {
+ global errorInfo
+ puts $errorInfo
+ }
+ return $res
+ }
+
+ proc _header {that frm db} {
+ set maxrow [$db get maxrow]
+ set scrw $frm.dbhead
+ tixScrolledWindow $scrw
+ pack $scrw -side left -expand yes -fill both
+ set panel [$scrw subwidget window]
+ set lbl [label $panel.maxrow -text "[mlcm::lang::msg maxrow]: $maxrow"]
+ set bf [_button $panel.first -command "mlcm::gui::_dbfirst $db" \
+ -text [mlcm::lang::msg first] -underline 0]
+ set bp [_button $panel.prev -command "mlcm::gui::_dbprev $db" \
+ -text [mlcm::lang::msg prev] -underline 0]
+ set bn [_button $panel.next -command "mlcm::gui::_dbnext $db" \
+ -text [mlcm::lang::msg next] -underline 0]
+ set bl [_button $panel.last -command "mlcm::gui::_dblast $db" \
+ -text [mlcm::lang::msg last] -underline 0]
+ pack $panel.maxrow $panel.first $panel.prev $panel.next \
+ $panel.last -side left
+ }
+
+ proc _dbfirst {db} {
+ puts "first [$db name]"
+ }
+
+ proc _dbprev {db} {
+ puts "prev [$db name]"
+ }
+
+ proc _dbnext {db} {
+ puts "next [$db name]"
+ }
+
+ proc _dblast {db} {
+ puts "last [$db name]"
+ }
+
+ proc _workarea {that frm db} {
+ set pnw $frm.pnw
+ tixPanedWindow $pnw -orientation horizontal
+ pack $pnw -side top -expand yes -fill both
+ $pnw add pane1 -size 444
+ $pnw add pane2
+
+ # left area: result set list
+ set htmlw $pnw.pane1.text
+ set scb $pnw.pane1.scby
+ html $htmlw
+ scrollbar $scb -command "$htmlw yview"
+ $htmlw configure -yscrollcommand "$scb set"
+ pack $scb -side right -expand no -fill y
+ pack $htmlw -side right -expand yes -fill both
+
+ $that add html $htmlw
+
+ # right area: TBD
+ label $pnw.pane2.lbl -text "edit me"
+ pack $pnw.pane2.lbl -side left -expand yes -fill both
+ }
+
+# create new gui hierarchy for db
+# @param parent parent window where to put the gui into
+# if empty, a new toplevel window is created
+# @param profile actual profile to use
+# @param db actual database to use
+# @return gui record
+ proc new {parent profile db} {
+ set that [openIsisRec -fdt $mlcm::meta::fdtGui]
+ set top 0
+ set path $parent
+ if ![string length $parent] {
+ set parent [_newwindow]
+ toplevel $parent
+ set path $parent.
+ } elseif [string equal . $parent] {
+ set top 1
+ } {
+ set path $parent.
+ set top 2
+ }
+
+ $that add top $parent db $db stub [$db stub]
+
+ set main ${path}main
+ if $top {
+ destroy $main
+ }
+ frame $main
+ pack $main -side top -fill both -expand yes
+
+ set actmenu [$profile menu]
+ set mbar [frame $main.menubar -bd 5]
+ pack $mbar -side top -fill x
+ mlcm::menu::showmenu $actmenu $mbar
+
+ set fhead [frame $main.frhead]
+ pack $fhead -side top -expand no -fill x
+ _header $that $fhead $db
+
+ set fwork [frame $main.workarea]
+ pack $fwork -side top -expand yes -fill both
+ _workarea $that $fwork $db
+
+ if $top {
+ wm title $parent "MLCM - [$db name]"
+ if {2 == $top} {
+ wm geom $parent 500x400+80+80
+ }
+ }
+ return $that
+ }
+
+# setup global/openIsis variables for active window
+ proc activate that {
+ set stb [$that get stub]
+ set openIsis::srv $stb
+ set htmlw [$that get html]
+ proc ::openIsis::puts msg "
+ $htmlw parse \$msg
+ "
+ }
+
+# show all db entries
+ proc all that {
+ set db [$that get db]
+ set htmlw [$that get html]
+ $htmlw clear
+ catch {
+ set tsp [tsp list $db]
+ set dbn [$db name]
+ for {$db all} {[$db hasNext]} {} {
+ set mfn [$db next]
+ if ![openIsis::isis read -rowid $mfn -db $dbn] {
+ puts "no record for mfn $mfn"
+ continue
+ }
+ if [catch {openIsis::Tspr $tsp}] {
+ global errorInfo
+ puts "error in $tsp:\n$errorInfo"
+ break
+ }
+ }
+ }
+ }
+
+ proc _chktsp {name dbn path res} {
+ upvar $res ret
+ set ret "$path/$dbn.$name"
+ if [file readable $ret] {
+ return 1
+ }
+ set ret "$path/$name"
+ file readable $ret
+ }
+
+# find tsp file
+# first, look for <path_of_db>/<name_of_db>.<tsp>.tsp
+# second, look for <path_of_db>/<tsp>.tsp
+# third, scan $::auto_path for <name_of_db>.<tsp>.tsp
+# fourth, scan $::auto_path for <tsp>.tsp
+# fifth, raise an error
+# @param tsp name of tsp file without extension
+# @param db actual databse object
+# @return path to tsp file
+ proc tsp {tsp db} {
+ global auto_path
+ set tsp "$tsp.tsp"
+ set dbn [$db name]
+ set path "$auto_path"
+ catch {
+ set cfg [$db get 4002]
+ set dbp [$cfg get {803 {}}]
+ if [string length $dbp] {
+ set path "$dbp $auto_path"
+ }
+ }
+ set res ""
+ foreach p "$path" {
+ if [_chktsp $tsp $dbn $p res] {
+ return $res
+ }
+ }
+ error "cannot find $tsp in $path"
+ }
+}
+
projects / webpac / blobdiff