141 |
# $flags2's flags should match at least one of the flags in $flags1: |
# $flags2's flags should match at least one of the flags in $flags1: |
142 |
proc ::tcldrop::CheckFlags {flags1 flags2} { |
proc ::tcldrop::CheckFlags {flags1 flags2} { |
143 |
switch -- $flags1 { |
switch -- $flags1 { |
144 |
{-} - {*} - {+} - {} { return 1 } |
{+} - {*} - {} { return 1 } |
145 |
{default} { |
{default} { |
146 |
# FixMe: This is really simple right now, it needs fixing to allow &'s though. |
# FixMe: This is really simple right now, it needs fixing to allow &'s though. |
147 |
# I think it'll require a foreach [split $flags1 {}] { } |
# I think it'll require a foreach [split $flags1 {}] { } |
185 |
proc ::tcldrop::bind {type flags mask proc {priority {50}}} { |
proc ::tcldrop::bind {type flags mask proc {priority {50}}} { |
186 |
# FixMe: This should check a list of registered bind types before accepting the bind. |
# FixMe: This should check a list of registered bind types before accepting the bind. |
187 |
variable Binds |
variable Binds |
188 |
|
# Note: + or * means "anybody". And - means "nobody". |
189 |
|
switch -- $flags { |
190 |
|
{-} - {+} - {*} - {-|-} - {*|*} { set flags {+|+} } |
191 |
|
{default} { if {![string match {*|*} $flags]} { set flags "$flags|-" } } |
192 |
|
} |
193 |
set Binds($type,$priority,$proc,$mask) [list type $type flags $flags mask $mask proc $proc] |
set Binds($type,$priority,$proc,$mask) [list type $type flags $flags mask $mask proc $proc] |
194 |
set mask |
set mask |
195 |
} |
} |