scripts/module.itk

   1 # vim: ft=tcl foldmethod=marker foldmarker=<<<,>>> ts=4 shiftwidth=4
   2
   3 #option add *Module*Menu*font   $::tlc::config(normalfont)      widgetDefault
   4 #option add *Module*Menu*activeBackground       "#0a246a"               widgetDefault
   5 #option add *Module*Menu*tearOff                                0                               widgetDefault
   6
   7 proc tlc::module {pathName args} {
   8         uplevel tlc::Module $pathName $args
   9 }
  10
  11
  12 class tlc::Module {
  13         inherit ::tlc::Mytoplevel
  14
  15         constructor {args} {}
  16
  17         itk_option define -visible visible Visible 0 {visibility}
  18         itk_option define -onclose onclose Command ""
  19         itk_option define -onshow onshow Command ""
  20         itk_option define -onhide onhide Command ""
  21         itk_option define -geometry geometry Geometry ""
  22         itk_option define -minsize      minsize Geometry ""
  23         itk_option define -hideonsubmit hideOnSubmit Bool 1
  24         itk_option define -savepos savePos Command ""
  25         itk_option define -menubar menuBar MenuBar {}
  26
  27         public {
  28                 method show {args}
  29                 method hide {args}
  30                 method toggle {args}
  31                 method raisewin {}
  32                 method closewin {}
  33                 method center_on_screen {}
  34                 method moveto {x y {snaprange 0}}
  35                 method moveto_topright {}
  36         }
  37
  38         protected {
  39                 variable w
  40                 variable wdb
  41
  42                 # Placeholder methods.  Designed to be overloaded by descendant classes
  43                 # included here to be able to do the binding at this level
  44                 variable submit
  45                 variable cansubmit      0
  46
  47                 method _submit {}
  48                 method submit {}
  49         }
  50
  51         private {
  52                 variable configure_lock 0
  53                 variable bx     0
  54                 variable by 0
  55
  56                 method visibility {args}
  57                 method goto {rx ry st}
  58                 method savepos {}
  59                 method construct_menu {parent def {depth 3}}
  60                 method themechanged {}
  61         }
  62 }
  63
  64
  65 configbody tlc::Module::menubar { #<<<1
  66         if {$itk_option(-menubar) == {}} {
  67                 set m   ""
  68         } else {
  69                 # Double buffer the change to minimize window flicker
  70                 if {![winfo exists $w.menubar_a]} {
  71                         set wn  $w.menubar_a
  72                 } else {
  73                         set wn  $w.menubar_b
  74                 }
  75                 if {[winfo exists $wn]} {
  76                         destroy $wn
  77                 }
  78                 if {$::tcl_platform(platform) == "windows"} {
  79                         menu $wn -tearoff 0 \
  80                                         -font $::tlc::config(normalfont) \
  81                                         -activebackground "#0a246a"
  82                 } else {
  83                         menu $wn -tearoff 0 \
  84                                         -font $::tlc::config(normalfont)
  85                 }
  86                 set m   $wn
  87
  88                 construct_menu $m $itk_option(-menubar)
  89         }
  90
  91         configure -menu $m
  92         set menubar     $m
  93 }
  94
  95
  96 configbody tlc::Module::geometry { #<<<1
  97         if {$itk_option(-geometry) != ""} {
  98                 wm geometry [component hull] $itk_option(-geometry)
  99         }
 100 }
 101
 102 configbody tlc::Module::minsize { #<<<1
 103         if {$itk_option(-minsize) != ""} {
 104                 set minlist [split $itk_option(-minsize) "x"]
 105                 wm minsize $itk_component(hull) [lindex $minlist 0] [lindex $minlist 1]
 106         }
 107 }
 108
 109
 110 body tlc::Module::constructor {args} { #<<<1
 111         set w   $itk_interior
 112         set wdb [string trimleft $w .]
 113
 114         wm protocol [component hull] WM_DELETE_WINDOW [code $this closewin]
 115         bind $itk_component(hull) <Key-Escape> [code $this closewin]
 116         bind $itk_component(hull) <Control-space> [code $this _submit]
 117
 118         bind $itk_component(hull) <Alt-Button-1> [list apply {
 119                 {bx by x y} {
 120                         set $bx $x
 121                         set $by $y
 122                 }
 123         } [scope bx] [scope by] %x %y]
 124         bind $itk_component(hull) <Control-Button-1> [list apply {
 125                 {bx by x y} {
 126                         set $bx $x
 127                         set $by $y
 128                 }
 129         } [scope bx] [scope by] %x %y]
 130         bind $itk_component(hull) <Alt-Motion> [code $this goto %X %Y %s]
 131         bind $itk_component(hull) <Alt-Motion><ButtonRelease-1> [code $this savepos]
 132         bind $itk_component(hull) <<ThemeChanged>> [code $this themechanged]
 133
 134         itk_initialize
 135         configure \
 136                         -background [ttk::style lookup $::ttk::currentTheme -background ] \
 137                         {*}$args
 138
 139         hide
 140 }
 141
 142
 143 body tlc::Module::visibility {args} { #<<<1
 144         if {$itk_option(-visible)} {
 145                 set cmd $itk_option(-onshow)
 146                 if {$cmd != ""} {
 147                         eval $cmd
 148                 }
 149                 update idletasks
 150                 wm deiconify [component hull]
 151         } else {
 152                 set cmd $itk_option(-onhide)
 153                 if {$cmd != ""} {
 154                         eval $cmd
 155                 }
 156                 wm withdraw [component hull]
 157         }
 158 }
 159
 160
 161 body tlc::Module::show {args} { #<<<1
 162         configure -visible      1
 163 }
 164
 165
 166 body tlc::Module::hide {args} { #<<<1
 167         configure -visible      0
 168 }
 169
 170
 171 body tlc::Module::toggle {args} { #<<<1
 172         configure -visible      [expr ($itk_option(-visible) + 1) % 2]
 173 }
 174
 175
 176 body tlc::Module::raisewin {} { #<<<1
 177         raise [component hull]
 178 }
 179
 180
 181 body tlc::Module::closewin {} { #<<<1
 182         if {$itk_option(-onclose) == ""} {
 183                 delete object $this
 184         } else {
 185                 eval $itk_option(-onclose)
 186         }
 187 }
 188
 189
 190 body tlc::Module::goto {rx ry st} { #<<<1
 191         set state       [expr ($st & 0x700) >> 8]
 192         if {$state != 1} return
 193         set nx  [expr $rx - $bx]
 194         set ny  [expr $ry - $by]
 195         moveto $nx $ny 5
 196 }
 197
 198
 199 body tlc::Module::moveto {x y {snaprange 0}} { #<<<1
 200         set sw          [winfo screenwidth [component hull]]
 201         set sh          [winfo screenheight [component hull]]
 202         set width       [winfo reqwidth [component hull]]
 203         set height      [winfo reqheight [component hull]]
 204         set x2          [expr $x + $width]
 205         set y2          [expr $y + $height]
 206         set dx1         [expr $x - 0]
 207         set dy1         [expr $y - 0]
 208         set dx2         [expr $sw - $x2]
 209         set dy2         [expr $sh - $y2]
 210
 211         if {abs($dx1) < $snaprange} {
 212                 set x   0
 213         } elseif {abs($dx2) < $snaprange} {
 214                 set x   [expr $sw - $width]
 215         }
 216
 217         if {abs($dy1) < $snaprange} {
 218                 set y   0
 219         } elseif {abs($dy2) < $snaprange} {
 220                 set y   [expr $sh - $height]
 221         }
 222
 223         set x   [expr {int($x)}]
 224         set y   [expr {int($y)}]
 225
 226         if {$::tcl_platform(platform) == "unix" && [winfo ismapped $itk_component(hull)] && [info commands "::blt::winop"] == "::blt::winop"} {
 227                 ::blt::winop move $itk_component(hull) $x $y
 228         } else {
 229                 wm geometry $itk_component(hull) +$x+$y
 230         }
 231 }
 232
 233
 234 body tlc::Module::savepos {} { #<<<1
 235         if {$itk_option(-savepos) != ""} {
 236                 set geom        [wm geometry $itk_component(hull)]
 237                 regexp {\+([0-9]+)\+([0-9]+)} $geom foo x y
 238                 uplevel #0 $itk_option(-savepos) $x $y
 239         }
 240 }
 241
 242
 243 body tlc::Module::center_on_screen {} { #<<<1
 244         update idletasks
 245
 246         set wd [winfo reqwidth $itk_component(hull)]
 247         set ht [winfo reqheight $itk_component(hull)]
 248         set x [expr ([winfo screenwidth $itk_component(hull)]-$wd)/2]
 249         set y [expr ([winfo screenheight $itk_component(hull)]-$ht)/2]
 250         wm minsize $itk_component(hull) $wd $ht
 251         moveto $x $y
 252 }
 253
 254
 255 body tlc::Module::moveto_topright {} { #<<<1
 256         if {$configure_lock} return
 257         set configure_lock      1
 258
 259         update idletasks
 260
 261         set bbox        [grid bbox $itk_component(hull)]
 262         set wd          [expr [lindex $bbox 2] - [lindex $bbox 0] + 1]
 263         set wd          [winfo reqwidth $itk_component(hull)]
 264         set x [expr [winfo screenwidth $itk_component(hull)] - $wd]
 265         set y 0
 266         moveto $x $y
 267
 268         set configure_lock 0
 269 }
 270
 271
 272 body tlc::Module::_submit {} { #<<<1
 273         if {!$cansubmit} return
 274         if {[winfo exists $submit]} {
 275                 setstate [set cansubmit 0] $submit
 276                 update idletasks
 277         }
 278 #       $submit invoke
 279         submit
 280
 281         if {$itk_option(-hideonsubmit)} {
 282                 hide
 283         }
 284 }
 285
 286
 287 body tlc::Module::submit {} { #<<<1
 288         puts "Called tlc::Module's submit method"
 289 }
 290
 291
 292 body tlc::Module::construct_menu {parent def {depth 3}} { #<<<1
 293         set seq         0
 294         foreach {label opts} $def {
 295                 set type        [lindex $opts 0]
 296                 set detail      [lindex $opts 1]
 297                 set args        [lrange $opts 2 end]
 298
 299                 switch -- $type {
 300                         "cascade" {
 301                                 if {$::tcl_platform(platform) == "windows"} {
 302                                         set m   [menu $parent.$seq -tearoff 0 -font $::tlc::config(normalfont) -activebackground "#0a246a"]
 303                                 } else {
 304                                         set m   [menu $parent.$seq -tearoff 0 -font $::tlc::config(normalfont)]
 305                                 }
 306                                 incr seq
 307                                 construct_menu $m $detail [expr {$depth + 1}]
 308                                 set fixed       [list -label $label -menu $m]
 309                                 eval [list $parent] add cascade $fixed $args
 310                         }
 311
 312                         "command" {
 313                                 set fixed       [list -label $label -command [uplevel $depth code $this $detail]]
 314                                 eval [list $parent] add command $fixed $args
 315                         }
 316
 317                         "separator" {
 318                                 eval [list $parent] add separator $args
 319                         }
 320
 321                         default {
 322                                 error "Unknown menu type: ($type)"
 323                         }
 324                 }
 325         }
 326 }
 327
 328
 329 body tlc::Module::themechanged {} { #<<<1
 330         set newchrome   [ttk::style lookup $::ttk::currentTheme -background]
 331         $itk_component(hull) configure -background $newchrome
 332 }
 333
 334