git.rot13.org Git - webpac/blob - openisis/tcl/lib/mlcm.gui.tcl

   1
   2 package provide mlcm::gui 0.1
   3
   4 namespace eval mlcm::gui {
   5
   6         variable _gid 0
   7
   8         proc _newwindow {} {
   9                 variable _gid
  10                 return ".top[incr _gid]"
  11         }
  12
  13         proc _activate btn {
  14                 set bg1 [$btn cget -background]
  15                 set bg2 [$btn cget -activebackground]
  16                 if ![string equal $bg1 $bg2] {
  17                         $btn configure -background $bg2
  18                         after 200 $btn configure -background $bg1
  19                         $btn invoke
  20                 }
  21         }
  22
  23         proc _button args {
  24                 set res [eval button $args]
  25                 if [catch {
  26                         set under [$res cget -underline]
  27                         set key [$res cget -text]
  28                         if {0 <= $under} {
  29                                 set key [string index $key $under]
  30                                 bind . <Alt-KeyPress-$key> "mlcm::gui::_activate $res"
  31                                 puts "bound $key to $res"
  32                         }
  33                 }] {
  34                         global errorInfo
  35                         puts $errorInfo
  36                 }
  37                 return $res
  38         }
  39
  40         proc _header {that frm db} {
  41                 set maxrow [$db get maxrow]
  42                 set scrw $frm.dbhead
  43                 tixScrolledWindow $scrw
  44                 pack $scrw -side left -expand yes -fill both
  45                 set panel [$scrw subwidget window]
  46                 set lbl [label $panel.maxrow -text "[mlcm::lang::msg maxrow]: $maxrow"]
  47                 set bf [_button $panel.first -command "mlcm::gui::_dbfirst $db" \
  48                         -text [mlcm::lang::msg first] -underline 0]
  49                 set bp [_button $panel.prev -command "mlcm::gui::_dbprev $db" \
  50                         -text [mlcm::lang::msg prev] -underline 0]
  51                 set bn [_button $panel.next -command "mlcm::gui::_dbnext $db" \
  52                         -text [mlcm::lang::msg next] -underline 0]
  53                 set bl [_button $panel.last -command "mlcm::gui::_dblast $db" \
  54                         -text [mlcm::lang::msg last] -underline 0]
  55                 pack $panel.maxrow $panel.first $panel.prev $panel.next \
  56                         $panel.last -side left
  57         }
  58
  59         proc _dbfirst {db} {
  60                 puts "first [$db name]"
  61         }
  62
  63         proc _dbprev {db} {
  64                 puts "prev [$db name]"
  65         }
  66
  67         proc _dbnext {db} {
  68                 puts "next [$db name]"
  69         }
  70
  71         proc _dblast {db} {
  72                 puts "last [$db name]"
  73         }
  74
  75         proc _workarea {that frm db} {
  76                 set pnw $frm.pnw
  77                 tixPanedWindow $pnw -orientation horizontal
  78                 pack $pnw -side top -expand yes -fill both
  79                 $pnw add pane1 -size 444
  80                 $pnw add pane2
  81
  82                 #       left area: result set list
  83                 set htmlw $pnw.pane1.text
  84                 set scb $pnw.pane1.scby
  85                 html $htmlw
  86                 scrollbar $scb -command "$htmlw yview"
  87                 $htmlw configure -yscrollcommand "$scb set"
  88                 pack $scb -side right -expand no -fill y
  89                 pack $htmlw -side right -expand yes -fill both
  90
  91                 $that add html $htmlw
  92
  93                 #       right area: TBD
  94                 label $pnw.pane2.lbl -text "edit me"
  95                 pack $pnw.pane2.lbl -side left -expand yes -fill both
  96         }
  97
  98 #       create new gui hierarchy for db
  99 #       @param parent parent window where to put the gui into
 100 #               if empty, a new toplevel window is created
 101 #       @param profile actual profile to use
 102 #       @param db actual database to use
 103 #       @return gui record
 104         proc new {parent profile db} {
 105                 set that [openIsisRec -fdt $mlcm::meta::fdtGui]
 106                 set top 0
 107                 set path $parent
 108                 if ![string length $parent] {
 109                         set parent [_newwindow]
 110                         toplevel $parent
 111                         set path $parent.
 112                 } elseif [string equal . $parent] {
 113                         set top 1
 114                 } {
 115                         set path $parent.
 116                         set top 2
 117                 }
 118
 119                 $that add top $parent db $db stub [$db stub]
 120
 121                 set main ${path}main
 122                 if $top {
 123                         destroy $main
 124                 }
 125                 frame $main
 126                 pack $main -side top -fill both -expand yes
 127
 128                 set actmenu [$profile menu]
 129                 set mbar [frame $main.menubar -bd 5]
 130                 pack $mbar -side top -fill x
 131                 mlcm::menu::showmenu $actmenu $mbar
 132
 133                 set fhead [frame $main.frhead]
 134                 pack $fhead -side top -expand no -fill x
 135                 _header $that $fhead $db
 136
 137                 set fwork [frame $main.workarea]
 138                 pack $fwork -side top -expand yes -fill both
 139                 _workarea $that $fwork $db
 140
 141                 if $top {
 142                         wm title $parent "MLCM - [$db name]"
 143                         if {2 == $top} {
 144                                 wm geom $parent 500x400+80+80
 145                         }
 146                 }
 147                 return $that
 148         }
 149
 150 #       setup global/openIsis variables for active window
 151         proc activate that {
 152                 set stb [$that get stub]
 153                 set openIsis::srv $stb
 154                 set htmlw [$that get html]
 155                 proc ::openIsis::puts msg "
 156                         $htmlw parse \$msg
 157                 "
 158         }
 159
 160 #       show all db entries
 161         proc all that {
 162                 set db [$that get db]
 163                 set htmlw [$that get html]
 164                 $htmlw clear
 165                 catch {
 166                         set tsp [tsp list $db]
 167                         set dbn [$db name]
 168                         for {$db all} {[$db hasNext]} {} {
 169                                 set mfn [$db next]
 170                                 if ![openIsis::isis read -rowid $mfn -db $dbn] {
 171                                         puts "no record for mfn $mfn"
 172                                         continue
 173                                 }
 174                                 if [catch {openIsis::Tspr $tsp}] {
 175                                         global errorInfo
 176                                         puts "error in $tsp:\n$errorInfo"
 177                                         break
 178                                 }
 179                         }
 180                 }
 181         }
 182
 183         proc _chktsp {name dbn path res} {
 184                 upvar $res ret
 185                 set ret "$path/$dbn.$name"
 186                 if [file readable $ret] {
 187                         return 1
 188                 }
 189                 set ret "$path/$name"
 190                 file readable $ret
 191         }
 192
 193 #       find tsp file
 194 #       first, look for <path_of_db>/<name_of_db>.<tsp>.tsp
 195 #       second, look for <path_of_db>/<tsp>.tsp
 196 #       third, scan $::auto_path for <name_of_db>.<tsp>.tsp
 197 #       fourth, scan $::auto_path for <tsp>.tsp
 198 #       fifth, raise an error
 199 #       @param tsp name of tsp file without extension
 200 #       @param db actual databse object
 201 #       @return path to tsp file
 202         proc tsp {tsp db} {
 203                 global auto_path
 204                 set tsp "$tsp.tsp"
 205                 set dbn [$db name]
 206                 set path "$auto_path"
 207                 catch {
 208                         set cfg [$db get 4002]
 209                         set dbp [$cfg get {803 {}}]
 210                         if [string length $dbp] {
 211                                 set path "$dbp $auto_path"
 212                         }
 213                 }
 214                 set res ""
 215                 foreach p "$path" {
 216                         if [_chktsp $tsp $dbn $p res] {
 217                                 return $res
 218                         }
 219                 }
 220                 error "cannot find $tsp in $path"
 221         }
 222 }
 223