scripts/dslookup.itk

   1 # vim: ft=tcl foldmethod=marker foldmarker=<<<,>>> ts=4 shiftwidth=4
   2
   3 class tlc::DSlookup {
   4         inherit tlc::Border tlc::Signalsource tlc::Textvariable tlc::Baselog
   5
   6         constructor {args} {}
   7
   8         public {
   9                 variable state                  "normal"
  10                 variable wrap                   0
  11                 variable ds                             {}
  12                 variable value                  ""      seekvalue
  13                 variable pagelength             5       rebindpage
  14                 variable zoom_memory    2000            ;# in ms
  15                 variable id_field               "id"
  16                 variable display_field  "name"
  17                 variable show_extra             {}
  18
  19                 method move {delta}
  20                 method moveto {sel_idx}
  21                 method next {{delta 1}}
  22                 method prev {{delta 1}}
  23                 method last {{offset 0}}
  24                 method first {{offset 0}}
  25                 method last_idx {}
  26                 method popdown {}
  27                 method set_choice {info_arr}
  28         }
  29
  30         protected {
  31                 variable idx                    0
  32
  33                 method update_view {}
  34                 method seekvalue {}
  35                 method rebindpage {}
  36                 method textvariable_changed {newvalue}
  37         }
  38
  39         private {
  40                 variable toggles
  41                 variable last_zoom_ms
  42                 variable zoom_spec              ""
  43                 variable popup_obj
  44                 variable old_ds
  45                 variable selected_info  {}
  46
  47                 method reset {}
  48                 method validate_input {newval}
  49                 method scrollwheel {delta}
  50                 method zoom {char}
  51                 method binding {args}
  52                 method popup {}
  53                 method toggle_popup {}
  54                 method statechanged {newstate}
  55         }
  56 }
  57
  58
  59 configbody tlc::DSlookup::state { #<<<1
  60         log debug "state: ($state)"
  61         [stategate_ref] configure -default [expr {$state == "normal"}]
  62 }
  63
  64
  65 configbody tlc::DSlookup::ds { #<<<1
  66         if {[info exists old_ds]} {
  67         }
  68
  69         reset
  70 }
  71
  72
  73 body tlc::DSlookup::constructor {args} { #<<<1
  74         array set toggles       {}
  75
  76         tlc::Signal #auto signals(valid) -name "$w valid"
  77
  78         # Border hacks <<<
  79         $itk_component(border) configure \
  80                         -highlightthickness 1 \
  81                         -takefocus 1 \
  82                         -highlightcolor black
  83         tlc::StateToggle #auto toggles(border) $itk_component(border) \
  84                         -takefocus {0 1}
  85         $toggles(border) attach_signal [stategate_ref]
  86         bind $itk_component(border).inner <FocusIn> \
  87                         [code focus $itk_component(border)]
  88         # Border hacks >>>
  89
  90         # Entry <<<
  91         itk_component add entry {
  92                 entry $w.entry -borderwidth 0 -highlightthickness 0 -state disabled \
  93                                 -validate all -validatecommand [code $this validate_input %P]
  94         } {
  95                 keep -width
  96                 rename -background -textbackground textBackground TextBackground
  97         }
  98         set enabled_fg          [$tlc::theme setting foreground]
  99         set enabled_bg          [$tlc::theme setting textbackground]
 100         set disabled_fg         [$tlc::theme setting disabledforeground]
 101         set disabled_bg         [$tlc::theme setting disabledbackground]
 102         tlc::StateToggle #auto toggles(entry) $itk_component(entry) \
 103                         -foreground [list $disabled_fg $enabled_fg] \
 104                         -background [list $disabled_bg $enabled_bg] \
 105                         -disabledforeground [list $disabled_fg $enabled_fg] \
 106                         -disabledbackground [list $disabled_bg $enabled_bg]
 107         $toggles(entry) attach_signal [stategate_ref]
 108         # Entry >>>
 109
 110         # Lookup button <<<
 111         option add *$wdb.Button.takeFocus                       0
 112         option add *$wdb.Button.borderWidth                     1
 113         option add *$wdb.Button.padX                            2
 114         option add *$wdb.Button.width                           10
 115         option add *$wdb.Button.padY                            0
 116         option add *$wdb.Button.highlightThickness      0
 117
 118         button $w.toggle_lookup -text "..." -command [code $this toggle_lookup]
 119         tlc::StateToggle #auto toggles(toggle_lookup) $w.toggle_lookup \
 120                         -state {disabled normal}
 121         $toggles(toggle_lookup) attach_input [stategate_ref]
 122         # Lookup button >>>
 123
 124         # Extra fields display <<<
 125         itk_component add extra {
 126                 label $w.extra
 127         }
 128         # Extra fields display >>>
 129
 130         # Popup <<<
 131         itk_component add popup {
 132                 tlc::DSpopup $w.#auto -parent $this
 133         } {
 134                 keep -ds
 135         }
 136         set popup_obj   $itk_component(popup)
 137         # Popup >>>
 138
 139         blt::table $w \
 140                         $w.entry                        1,1 -rspan 2 -fill both \
 141                         $w.toggle_lookup        1,2 -fill y \
 142                         $w.extra                        1,3 -anchor w
 143         blt::table configure $w c2 c3 -resize none
 144
 145         eval itk_initialize     $args
 146
 147         set listend             [expr {[llength $choices] - 1}]
 148         if {$listend < 0} {set listend 0}
 149
 150         bind $itk_component(entry) <Button-4> [code $this binding move -1]
 151         bind $itk_component(entry) <Button-5> [code $this binding move 1]
 152         bind $itk_component(entry) <MouseWheel> [code $this binding scrollwheel %D]
 153         #bind $itk_component(entry) <Button-1> [code focus $w]
 154         bind $itk_component(entry) <Button-1> [code $this toggle_popup]
 155         bind $itk_component(entry) <Button-3> [code $this toggle_popup]
 156         bind $itk_component(border) <Key-Up> [code $this binding move -1]
 157         bind $itk_component(border) <Key-Down> [code $this binding move 1]
 158         bind $itk_component(border) <Key-Home> [code $this binding moveto 0]
 159         bind $itk_component(border) <Key-End>  [code $this binding moveto $listend]
 160         bind $itk_component(border) <Key>  [code $this zoom %A]
 161
 162         [stategate_ref] attach_output [code $this statechanged]
 163 }
 164
 165
 166 body tlc::DSlookup::move {delta}        { #<<<1
 167         set sel_idx             [lsearch $choices [$w.entry get]]
 168
 169         set choices_len [llength $choices]
 170
 171         if {$sel_idx == -1} {
 172                 if {$delta < 0} {
 173                         set sel_idx             [expr {$choices_len + $delta}]
 174                         if {$sel_idx == [llength $choices]} {
 175                                 set sel_idx     [expr {$choices_len - 1}]
 176                         }
 177                 } else {
 178                         set sel_idx             [expr {$delta - 1}]
 179                         if {$sel_idx < 0} {
 180                                 set sel_idx             0
 181                         }
 182                 }
 183         } else {
 184                 set sel_idx             [expr {$sel_idx + $delta}]
 185         }
 186
 187         if {$wrap} {
 188                 if {$choices_len == 0} {
 189                         set sel_idx             0
 190                 } else {
 191                         set sel_idx     [expr {$sel_idx % $choices_len}]
 192                 }
 193         } else {
 194                 if {$sel_idx > [last_idx]} {
 195                         set sel_idx     [last_idx]
 196                 } elseif {$sel_idx < 0} {
 197                         set sel_idx     0
 198                 }
 199         }
 200
 201         moveto $sel_idx
 202 }
 203
 204
 205 body tlc::DSlookup::moveto {sel_idx} { #<<<1
 206         if {![[stategate_ref] state]} return
 207         if {$sel_idx < 0 || $sel_idx > [last_idx]} {
 208                 error "Choice out of bounds: $sel_idx (max is [last_idx])"
 209         } else {
 210                 set idx $sel_idx
 211         }
 212         update_view
 213 }
 214
 215
 216 body tlc::DSlookup::next {{delta 1}} { #<<<1
 217         move $delta
 218 }
 219
 220
 221 body tlc::DSlookup::prev {{delta 1}} { #<<<1
 222         move [expr {0 - $delta}]
 223 }
 224
 225
 226 body tlc::DSlookup::last {{offset 0}} { #<<<1
 227         moveto [expr {[last_idx] + $offset}]
 228 }
 229
 230
 231 body tlc::DSlookup::first {{offset 0}} { #<<<1
 232         moveto $offset
 233 }
 234
 235
 236 body tlc::DSlookup::last_idx {} { #<<<1
 237         return [expr {[llength $choices] - 1}]
 238 }
 239
 240
 241 body tlc::DSlookup::update_view {} { #<<<1
 242         set new         [lindex $choices $idx]
 243
 244         set hold        [$itk_component(entry) cget -state]
 245         $itk_component(entry) configure -state normal
 246         $itk_component(entry) delete 0 end
 247         $itk_component(entry) insert 0 $new
 248         $itk_component(entry) configure -state $hold
 249
 250         set_textvariable $new
 251 }
 252
 253
 254 body tlc::DSlookup::seekvalue {} { #<<<1
 255         set sel_idx     [lsearch $choices $value]
 256         if {$sel_idx != -1} {
 257                 moveto $sel_idx
 258         }
 259         set zoom_spec   ""
 260 }
 261
 262
 263 body tlc::DSlookup::rebindpage {} { #<<<1
 264         bind $itk_component(border) <Key-Prior> [code $this binding move -$pagelength]
 265         bind $itk_component(border) <Key-Next>  [code $this binding move $pagelength]
 266 }
 267
 268
 269 body tlc::DSlookup::reset {} { #<<<1
 270         set tidx                [lsearch $choices [$itk_component(entry) get]]
 271         if {$tidx == -1} {
 272                 $itk_component(entry) delete 0 end
 273         }
 274
 275         set listend             [expr {[llength $choices] - 1}]
 276         if {$listend < 0} {set listend 0}
 277
 278         bind $itk_component(entry) <Key-End> [code $this binding moveto $listend]
 279
 280         $popup_obj set_choices [lrange $choices 0 end]
 281
 282         set zoom_spec   ""
 283 }
 284
 285
 286 body tlc::DSlookup::validate_input {newval} { #<<<1
 287         set exists      [expr {[lsearch $choices $newval] != -1}]
 288         $signals(valid) set_state $exists
 289
 290         return [expr {$exists || $newval == ""}]
 291 }
 292
 293
 294 body tlc::DSlookup::textvariable_changed {newvalue} { #<<<1
 295         if {$newvalue == ""} {
 296                 set hold        [$itk_component(entry) cget -state]
 297                 $itk_component(entry) configure -state normal
 298                 $itk_component(entry) delete 0 end
 299                 $itk_component(entry) insert 0 ""
 300                 $itk_component(entry) configure -state $hold
 301         } else {
 302                 if {[lsearch $choices $newvalue] == -1} {
 303                         error "Invalid value" "" [list reject_change]
 304                 }
 305
 306                 configure -value $newvalue
 307         }
 308 }
 309
 310
 311 body tlc::DSlookup::scrollwheel {delta} { #<<<1
 312         if {$delta > 0} {
 313                 move -1
 314         } else {
 315                 move 1
 316         }
 317 }
 318
 319
 320 body tlc::DSlookup::zoom {char} { #<<<1
 321         set now         [clock clicks -milliseconds]
 322         if {![info exists last_zoom_ms] || $now - $last_zoom_ms > $zoom_memory} {
 323                 set zoom_spec           $char
 324         } else {
 325                 append zoom_spec        $char
 326         }
 327         set last_zoom_ms        $now
 328
 329         set zoom_spec   [string tolower $zoom_spec]
 330
 331         set zoom_last   [string length $zoom_spec]
 332         incr zoom_last  -1
 333
 334         set tidx                -1
 335         foreach choice $choices {
 336                 incr tidx
 337                 if {
 338                         [string tolower [string range $choice 0 $zoom_last]] == $zoom_spec
 339                 } {
 340                         moveto $tidx
 341                         return
 342                 }
 343         }
 344
 345         if {[string length $zoom_spec] > 1} {
 346                 # Try instead with this char only
 347                 set zoom_spec   ""
 348                 zoom $char
 349         }
 350 }
 351
 352
 353 body tlc::DSlookup::binding {args} { #<<<1
 354         log debug "Binding: $args"
 355         focus $w
 356         eval [code $this] $args
 357 }
 358
 359
 360 body tlc::DSlookup::popup {} { #<<<1
 361         if {![[stategate_ref] state]} return
 362         grab -global $w
 363         set topx                [winfo rootx $w.up]
 364         set topy                [winfo rooty $w.up]
 365
 366         set screenheight        [winfo screenheight $w]
 367         set screenwidth         [winfo screenwidth $w]
 368
 369         table arrange $w
 370         update idletasks
 371         foreach {id x y wd ht} [table extents $w c2] break
 372
 373         set botx                [expr $topx + $wd]
 374         set boty                [expr $topy + $ht]
 375
 376         #$popup_obj set_choices [$ds get_list {}]
 377
 378         set listwidth   [winfo reqwidth $popup_obj]
 379         set listheight  [winfo reqheight $popup_obj]
 380         wm overrideredirect $popup_obj 1
 381         wm positionfrom $popup_obj user
 382
 383         set planx       [expr {$botx - $listwidth}]
 384         set plany       [expr {$boty + 1}]
 385
 386         # Avoid going off the screen <<<
 387         if {$planx < 0} {set planx 0}
 388         if {$plany < 0} {set plany 0}
 389         if {$planx + $listwidth > $screenwidth} {
 390                 set planx       [expr {$screenwidth - $listwidth}]
 391         }
 392         if {$plany + $listheight > $screenheight} {
 393                 set plany       [expr {$screenheight - $listheight}]
 394         }
 395         # Avoid going off the screen >>>
 396
 397         $popup_obj moveto $planx $plany
 398         $popup_obj show
 399
 400         focus [$popup_obj component list]
 401
 402         bind $w <Button> [code $this popdown]
 403         bind $w <Key> [code $this popdown]
 404 }
 405
 406
 407 body tlc::DSlookup::popdown {} { #<<<1
 408         if {[winfo ismapped $popup_obj]} {
 409                 grab release $w
 410                 $popup_obj hide
 411
 412                 focus $itk_component(border)
 413         }
 414 }
 415
 416
 417 body tlc::DSlookup::toggle_popup {} { #<<<1
 418         if {[winfo ismapped $popup_obj]} {
 419                 popdown
 420         } else {
 421                 popup
 422         }
 423 }
 424
 425
 426 body tlc::DSlookup::set_choice {info_arr} { #<<<1
 427         set selected_info       $info_arr
 428         array set info  $info_arr
 429
 430         foreach reqf [list $id_field $display_field] {
 431                 if {![info exists info($reqf)]} {
 432                         error "Specified item does not contain the field ($reqf)" "" \
 433                                         [list missing_field $reqf]
 434                 }
 435         }
 436         set new         $info($display_field)
 437         set id          $info($id_field)
 438
 439         set hold        [$itk_component(entry) cget -state]
 440         $itk_component(entry) configure -state normal
 441         $itk_component(entry) delete 0 end
 442         $itk_component(entry) insert 0 $new
 443         $itk_component(entry) configure -state $hold
 444
 445         set extra
 446         foreach f $show_extra {
 447                 if {[info exists info($f)]} {
 448                         lappend extra   $info($f)
 449                 } else {
 450                         log warning "Requested additional field is not set: \"$f\""
 451                 }
 452         }
 453         $itk_component(extra) configure -text [join $extra ", "]
 454
 455         set_textvariable $id
 456
 457         popdown
 458 }
 459
 460
 461 body tlc::DSlookup::statechanged {newstate} { #<<<1
 462         if {$newstate} {
 463         } else {
 464                 popdown
 465         }
 466 }
 467
 468