compound_container.tcl

来自「一个跨平台的TCL/TK可视开发环境类似VC. TCL/TK是一个跨平台的脚本」· TCL 代码 · 共 1,392 行 · 第 1/4 页

        } else {
            ::vTcl::compounds::${spc}::procsCmd
            ::vTcl::compounds::${spc}::bindtagsCmd
        }
        ::vTcl::compounds::${spc}::compoundCmd ${target}.cmpd
        ::vTcl::compounds::${spc}::infoCmd ${target}.cmpd
        pack $target.cmpd -fill both -expand 1

        ## register some info about ourself
        namespace eval ::$target "set compoundType $type; set compoundClass $compoundName"

        ## change the widget procedure
        rename ::$target ::_$target
        proc ::$target {command args}  "eval ::vTcl::widgets::core::compoundcontainer::widgetProc $target \$command \$args"
    }
}
#############################################################################
## Library Procedure:  vTcl::widgets::core::compoundcontainer::widgetProc

namespace eval vTcl::widgets::core::compoundcontainer {
proc widgetProc {w args} {
        ## This procedure may be used free of restrictions.
        ##    Exception added by Christian Gavin on 08/08/02.
        ## Other packages and widget toolkits have different licensing requirements.
        ##    Please read their license agreements for details.

        if {[llength $args] == 0} {
            ## If no arguments, returns the path the alias points to
            return $w
        }

        set command [lindex $args 0]
        set args [lrange $args 1 end]
        switch $command {
            configure {
                return [eval configureProc $w $args]
            }
            cget {
                return [eval cgetProc $w $args]
            }
            widget {
                ## call megawidget widgetProc
                return [eval $w.cmpd widget $args]
            }
            innerClass {
                return [winfo class $w.cmpd]
            }
            default {
                ## we have renamed the default widgetProc _<widgetpath>
                uplevel _$w $command $args
            }
        }
    }
}
#############################################################################
## Library Procedure:  vTcl:DefineAlias

proc ::vTcl:DefineAlias {target alias widgetProc top_or_alias cmdalias} {
    ## This procedure may be used free of restrictions.
    ##    Exception added by Christian Gavin on 08/08/02.
    ## Other packages and widget toolkits have different licensing requirements.
    ##    Please read their license agreements for details.

    global widget
    set widget($alias) $target
    set widget(rev,$target) $alias
    if {$cmdalias} {
        interp alias {} $alias {} $widgetProc $target
    }
    if {$top_or_alias != ""} {
        set widget($top_or_alias,$alias) $target
        if {$cmdalias} {
            interp alias {} $top_or_alias.$alias {} $widgetProc $target
        }
    }
}
#############################################################################
## Library Procedure:  vTcl:DoCmdOption

proc ::vTcl:DoCmdOption {target cmd} {
    ## This procedure may be used free of restrictions.
    ##    Exception added by Christian Gavin on 08/08/02.
    ## Other packages and widget toolkits have different licensing requirements.
    ##    Please read their license agreements for details.

    ## menus are considered toplevel windows
    set parent $target
    while {[winfo class $parent] == "Menu"} {
        set parent [winfo parent $parent]
    }

    regsub -all {\%widget} $cmd $target cmd
    regsub -all {\%top} $cmd [winfo toplevel $parent] cmd

    uplevel #0 [list eval $cmd]
}
#############################################################################
## Library Procedure:  vTcl:FireEvent

proc ::vTcl:FireEvent {target event {params {}}} {
    ## This procedure may be used free of restrictions.
    ##    Exception added by Christian Gavin on 08/08/02.
    ## Other packages and widget toolkits have different licensing requirements.
    ##    Please read their license agreements for details.

    ## The window may have disappeared
    if {![winfo exists $target]} return
    ## Process each binding tag, looking for the event
    foreach bindtag [bindtags $target] {
        set tag_events [bind $bindtag]
        set stop_processing 0
        foreach tag_event $tag_events {
            if {$tag_event == $event} {
                set bind_code [bind $bindtag $tag_event]
                foreach rep "\{%W $target\} $params" {
                    regsub -all [lindex $rep 0] $bind_code [lindex $rep 1] bind_code
                }
                set result [catch {uplevel #0 $bind_code} errortext]
                if {$result == 3} {
                    ## break exception, stop processing
                    set stop_processing 1
                } elseif {$result != 0} {
                    bgerror $errortext
                }
                break
            }
        }
        if {$stop_processing} {break}
    }
}
#############################################################################
## Library Procedure:  vTcl:Toplevel:WidgetProc

proc ::vTcl:Toplevel:WidgetProc {w args} {
    ## This procedure may be used free of restrictions.
    ##    Exception added by Christian Gavin on 08/08/02.
    ## Other packages and widget toolkits have different licensing requirements.
    ##    Please read their license agreements for details.

    if {[llength $args] == 0} {
        ## If no arguments, returns the path the alias points to
        return $w
    }
    set command [lindex $args 0]
    set args [lrange $args 1 end]
    switch -- $command {
        "setvar" {
            set varname [lindex $args 0]
            set value [lindex $args 1]
            if {$value == ""} {
                return [set ::${w}::${varname}]
            } else {
                return [set ::${w}::${varname} $value]
            }
        }
        "hide" - "Hide" - "show" - "Show" {
            Window [string tolower $command] $w
        }
        "ShowModal" {
            Window show $w
            raise $w
            grab $w
            tkwait window $w
            grab release $w
        }
        default {
            uplevel $w $command $args
        }
    }
}
#############################################################################
## Library Procedure:  vTcl:WidgetProc

proc ::vTcl:WidgetProc {w args} {
    ## This procedure may be used free of restrictions.
    ##    Exception added by Christian Gavin on 08/08/02.
    ## Other packages and widget toolkits have different licensing requirements.
    ##    Please read their license agreements for details.

    if {[llength $args] == 0} {
        ## If no arguments, returns the path the alias points to
        return $w
    }
    ## The first argument is a switch, they must be doing a configure.
    if {[string index $args 0] == "-"} {
        set command configure
        ## There's only one argument, must be a cget.
        if {[llength $args] == 1} {
            set command cget
        }
    } else {
        set command [lindex $args 0]
        set args [lrange $args 1 end]
    }
    uplevel $w $command $args
}
#############################################################################
## Library Procedure:  vTcl:toplevel

proc ::vTcl:toplevel {args} {
    ## This procedure may be used free of restrictions.
    ##    Exception added by Christian Gavin on 08/08/02.
    ## Other packages and widget toolkits have different licensing requirements.
    ##    Please read their license agreements for details.

    uplevel #0 eval toplevel $args
    set target [lindex $args 0]
    namespace eval ::$target {}
}
}


if {[info exists vTcl(sourcing)]} {

proc vTcl:project:info {} {
    set base .top72
    namespace eval ::widgets::$base {
        set set,origin 1
        set set,size 0
        set runvisible 1
    }
    namespace eval ::widgets::$base.lab73 {
        array set save {-anchor 1 -justify 1 -text 1}
    }
    namespace eval ::widgets::$base.lab75 {
        array set save {-anchor 1 -background 1 -justify 1 -text 1}
    }
    namespace eval ::widgets::$base.cpd74 {
        array set save {-borderwidth 1 -height 1 -relief 1 -takefocus 1}
    }
    set site_3_0 $base.cpd74
    namespace eval ::widgets::$site_3_0.upframe {
        array set save {-borderwidth 1 -height 1}
    }
    namespace eval ::widgets::$site_3_0.centerframe {
        array set save {-borderwidth 1}
    }
    set site_4_0 $site_3_0.centerframe
    namespace eval ::widgets::$site_4_0.leftframe {
        array set save {-borderwidth 1 -width 1}
    }
    namespace eval ::widgets::$site_4_0.rightframe {
        array set save {-borderwidth 1 -width 1}
    }
    namespace eval ::widgets::$site_4_0.05 {
        array set save {-borderwidth 1}
    }
    set site_5_0 $site_4_0.05
    namespace eval ::widgets::$site_5_0.06 {
        array set save {-borderwidth 1 -image 1 -text 1}
    }
    namespace eval ::widgets::$site_5_0.07 {
        array set save {-borderwidth 1 -text 1}
    }
    namespace eval ::widgets::$site_3_0.downframe {
        array set save {-borderwidth 1 -height 1 -relief 1}
    }
    namespace eval ::widgets::$base.lab77 {
        array set save {-anchor 1 -background 1 -justify 1 -text 1}
    }
    namespace eval ::widgets::$base.com78 {
        array set save {-class 1 -compoundClass 1}
    }
    namespace eval ::widgets::$base.lab79 {
        array set save {-anchor 1 -background 1 -justify 1 -text 1}
    }
    namespace eval ::widgets_bindings {
        set tagslist {_TopLevel BitmapButtonSub1 BitmapButtonSub2 BitmapButtonSub3 BitmapButtonTop}
    }
    namespace eval ::vTcl::modules::main {
        set procs {
            ::bitmapbutton::get_parent
            ::bitmapbutton::init
            ::bitmapbutton::mouse_down
            ::bitmapbutton::mouse_inside
            ::bitmapbutton::mouse_up
            ::bitmapbutton::set_command
            ::bitmapbutton::show_state
            init
            main
        }
        set compounds {
            {user {bitmap button}}
        }
    }
}
}

#################################
# USER DEFINED PROCEDURES
#
#############################################################################
## Procedure:  ::bitmapbutton::get_parent

namespace eval ::bitmapbutton {
proc get_parent {W {level 1}} {
global widget

set items [split $W .]
set last [expr [llength $items] - 1]

set parent_items [lrange $items 0 [expr $last - $level] ]
return [join $parent_items .]
}
}
#############################################################################
## Procedure:  ::bitmapbutton::init

namespace eval ::bitmapbutton {
proc init {W} {
global widget

set N [vTcl:rename $W]
namespace eval ::${N} {
    variable command
    set command ""}
}
}
#############################################################################
## Procedure:  ::bitmapbutton::mouse_down

namespace eval ::bitmapbutton {
proc mouse_down {W X Y} {
global widget

::bitmapbutton::show_state $W sunken

set N [vTcl:rename $W]
namespace eval ::$N {variable state}

set ::${N}::state "mouse_down"
}
}
#############################################################################
## Procedure:  ::bitmapbutton::mouse_inside

namespace eval ::bitmapbutton {
proc mouse_inside {W X Y} {
global widget

set button_X [winfo rootx $W]
set button_Y [winfo rooty $W]
set button_width [winfo width $W]
set button_height [winfo height $W]

set N [vTcl:rename $W]
set S "mouse_up"