listbox.tcl

一个用TCL/TK写的用于verilog的集成编辑环境.

            set y0    [expr {$dy/2}]
            set bbox  [eval $path:cmd bbox $drawn]
            set drawn {}
            set x0    [expr {[lindex $bbox 2]+$dx}]
            set x1    [expr {$x0+$padx}]
            set nitem 0
            lappend data(xlist) [lindex $bbox 2]
        }
    }
    if { $nitem && $nitem < $nrows } {
        set bbox  [eval $path:cmd bbox $drawn]
        lappend data(xlist) [lindex $bbox 2]
    }
    set data(upd,delete) {}
    $path:cmd configure -cursor [Widget::getoption $path -cursor]
}


# ------------------------------------------------------------------------------
#  Command ListBox::_redraw_selection
# ------------------------------------------------------------------------------
proc ListBox::_redraw_selection { path } {
    variable $path
    upvar 0  $path data

    set selbg [Widget::getoption $path -selectbackground]
    set selfg [Widget::getoption $path -selectforeground]
    foreach id [$path:cmd find withtag sel] {
        set item [string range [lindex [$path:cmd gettags $id] 1] 2 end]
        $path:cmd itemconfigure "n:$item" -fill [Widget::getoption $path.$item -fill]
    }
    $path:cmd delete sel
    foreach item $data(selitems) {
        set bbox [$path:cmd bbox "n:$item"]
        if { [llength $bbox] } {
            set id [eval $path:cmd create rectangle $bbox -fill $selbg -outline $selbg -tags [list "sel s:$item"]]
            $path:cmd itemconfigure "n:$item" -fill $selfg
            $path:cmd lower $id
        }
    }
}


# ------------------------------------------------------------------------------
#  Command ListBox::_redraw_listbox
# ------------------------------------------------------------------------------
proc ListBox::_redraw_listbox { path } {
    variable $path
    upvar 0  $path data

    if { [Widget::getoption $path -redraw] } {
        if { $data(upd,level) == 2 } {
            _redraw_items $path
        }
        _redraw_selection $path
        _update_scrollregion $path
        set data(upd,level)   0
        set data(upd,afterid) ""
    }
}


# ------------------------------------------------------------------------------
#  Command ListBox::_redraw_idle
# ------------------------------------------------------------------------------
proc ListBox::_redraw_idle { path level } {
    variable $path
    upvar 0  $path data

    if { $data(nrows) != -1 } {
        # widget is realized
        if { [Widget::getoption $path -redraw] && $data(upd,afterid) == "" } {
            set data(upd,afterid) [after idle ListBox::_redraw_listbox $path]
        }
    }
    if { $level > $data(upd,level) } {
        set data(upd,level) $level
    }
    return ""
}


# ------------------------------------------------------------------------------
#  Command ListBox::_resize
# ------------------------------------------------------------------------------
proc ListBox::_resize { path } {
    variable $path
    upvar 0  $path data

    if { [Widget::getoption $path -multicolumn] } {
        set bd    [expr {[$path:cmd cget -borderwidth]+[$path:cmd cget -highlightthickness]}]
        set h     [expr {[winfo height $path] - 2*$bd}]
        set nrows [expr {$h/[$path:cmd cget -yscrollincrement]}]
        if { $nrows == 0 } {
            set nrows 1
        }
        if { $nrows != $data(nrows) } {
            set data(nrows) $nrows
            _redraw_idle $path 2
        } else {
            _update_scrollregion $path
        }
    } elseif { $data(nrows) == -1 } {
        # first Configure event
        set data(nrows) 0
        ListBox::_redraw_listbox $path
    } else {
        _update_scrollregion $path
    }
}


# ------------------------------------------------------------------------------
#  Command ListBox::_init_drag_cmd
# ------------------------------------------------------------------------------
proc ListBox::_init_drag_cmd { path X Y top } {
    set ltags [$path:cmd gettags current]
    set item  [lindex $ltags 0]
    if { ![string compare $item "item"] ||
         ![string compare $item "img"]  ||
         ![string compare $item "win"] } {
        set item [string range [lindex $ltags 1] 2 end]
        if { [set cmd [Widget::getoption $path -draginitcmd]] != "" } {
            return [uplevel \#0 $cmd [list $path $item $top]]
        }
        if { [set type [Widget::getoption $path -dragtype]] == "" } {
            set type "LISTBOX_ITEM"
        }
        if { [set img [Widget::getoption $path.$item -image]] != "" } {
            pack [label $top.l -image $img -padx 0 -pady 0]
        }
        return [list $type {copy move link} $item]
    }
    return {}
}


# ------------------------------------------------------------------------------
#  Command ListBox::_drop_cmd
# ------------------------------------------------------------------------------
proc ListBox::_drop_cmd { path source X Y op type dnddata } {
    variable $path
    upvar 0  $path data

    if { [string length $data(dnd,afterid)] } {
        after cancel $data(dnd,afterid)
        set data(dnd,afterid) ""
    }
    $path:cmd delete drop
    set data(dnd,scroll) ""
    if { [llength $data(dnd,item)] } {
        if { [set cmd [Widget::getoption $path -dropcmd]] != "" } {
            return [uplevel \#0 $cmd [list $path $source $data(dnd,item) $op $type $dnddata]]
        }
    }
    return 0
}


# ------------------------------------------------------------------------------
#  Command ListBox::_over_cmd
# ------------------------------------------------------------------------------
proc ListBox::_over_cmd { path source event X Y op type dnddata } {
    variable $path
    upvar 0  $path data

    if { ![string compare $event "leave"] } {
        # we leave the window listbox
        $path:cmd delete drop
        if { [string length $data(dnd,afterid)] } {
            after cancel $data(dnd,afterid)
            set data(dnd,afterid) ""
        }
        set data(dnd,scroll) ""
        return 0
    }

    if { ![string compare $event "enter"] } {
        # we enter the window listbox - dnd data initialization
        set mode [Widget::getoption $path -dropovermode]
        set data(dnd,mode) 0
        foreach c {w p i} {
            set data(dnd,mode) [expr {($data(dnd,mode) << 1) | ([string first $c $mode] != -1)}]
        }
    }

    set x [expr {$X-[winfo rootx $path]}]
    set y [expr {$Y-[winfo rooty $path]}]
    $path:cmd delete drop
    set data(dnd,item) ""

    # test for auto-scroll unless mode is widget only
    if { $data(dnd,mode) != 4 && [_auto_scroll $path $x $y] != "" } {
        return 2
    }

    if { $data(dnd,mode) & 4 } {
        # dropovermode includes widget
        set target [list widget]
        set vmode  4
    } else {
        set target [list ""]
        set vmode  0
    }

    if { $data(dnd,mode) & 3 } {
        # dropovermode includes item or position
        # we extract the box (xi,yi,xs,ys) where we can find item around x,y
        set len  [llength $data(items)]
        set xc   [$path:cmd canvasx $x]
        set yc   [$path:cmd canvasy $y]
        set dy   [$path:cmd cget -yscrollincrement]
        set line [expr {int($yc/$dy)}]
        set yi   [expr {$line*$dy}]
        set ys   [expr {$yi+$dy}]
        set xi   0
        set pos  $line
        if { [Widget::getoption $path -multicolumn] } {
            set nrows $data(nrows)
        } else {
            set nrows $len
        }
        if { $line < $nrows } {
            foreach xs $data(xlist) {
                if { $xc <= $xs } {
                    break
                }
                set  xi  $xs
                incr pos $nrows
            }
            if { $pos < $len } {
                set item [lindex $data(items) $pos]
                if { $data(dnd,mode) & 1 } {
                    # dropovermode includes item
                    lappend target $item
                    set vmode [expr {$vmode | 1}]
                } else {
                    lappend target ""
                }

                if { $data(dnd,mode) & 2 } {
                    # dropovermode includes position
                    if { $yc >= $yi+$dy/2 } {
                        # position is after $item
                        incr pos
                        set yl $ys
                    } else {
                        # position is before $item
                        set yl $yi
                    }
                    lappend target $pos
                    set vmode [expr {$vmode | 2}]
                } else {
                    lappend target ""
                }
            } else {
                lappend target "" ""
            }
        } else {
            lappend target "" ""
        }

        if { ($vmode & 3) == 3 } {
            # result have both item and position
            # we compute what is the preferred method
            if { $yc-$yi <= 3 || $ys-$yc <= 3 } {
                lappend target "position"
            } else {
                lappend target "item"
            }
        }
    }

    if { $vmode && [set cmd [Widget::getoption $path -dropovercmd]] != "" } {
        # user-defined dropover command
        set res   [uplevel \#0 $cmd [list $source $target $op $type $dnddata]]
        set code  [lindex $res 0]
        set vmode 0
        if { $code & 1 } {
            # update vmode
            set mode [lindex $res 1]
            if { ![string compare $mode "item"] } {
                set vmode 1
            } elseif { ![string compare $mode "position"] } {
                set vmode 2
            } elseif { ![string compare $mode "widget"] } {
                set vmode 4
            }
        }
    } else {
        if { ($vmode & 3) == 3 } {
            # result have both item and position
            # we choose the preferred method
            if { ![string compare [lindex $target 3] "position"] } {
                set vmode [expr {$vmode & ~1}]
            } else {
                set vmode [expr {$vmode & ~2}]
            }
        }

        if { $data(dnd,mode) == 4 || $data(dnd,mode) == 0 } {
            # dropovermode is widget or empty - recall is not necessary
            set code 1
        } else {
            set code 3
        }
    }

    # draw dnd visual following vmode
    if { $vmode & 1 } {
        set data(dnd,item) [list "item" [lindex $target 1]]
        $path:cmd create rectangle $xi $yi $xs $ys -tags drop
    } elseif { $vmode & 2 } {
        set data(dnd,item) [concat "position" [lindex $target 2]]
        $path:cmd create line $xi $yl $xs $yl -tags drop
    } elseif { $vmode & 4 } {
        set data(dnd,item) [list "widget"]
    } else {
        set code [expr {$code & 2}]
    }

    if { $code & 1 } {
        DropSite::setcursor based_arrow_down
    } else {
        DropSite::setcursor dot
    }
    return $code
}


# ------------------------------------------------------------------------------
#  Command ListBox::_auto_scroll
# ------------------------------------------------------------------------------
proc ListBox::_auto_scroll { path x y } {
    variable $path
    upvar 0  $path data

    set xmax   [winfo width  $path]
    set ymax   [winfo height $path]
    set scroll {}
    if { $y <= 6 } {
        if { [lindex [$path:cmd yview] 0] > 0 } {
            set scroll [list yview -1]
            DropSite::setcursor sb_up_arrow
        }
    } elseif { $y >= $ymax-6 } {
        if { [lindex [$path:cmd yview] 1] < 1 } {
            set scroll [list yview 1]
            DropSite::setcursor sb_down_arrow
        }
    } elseif { $x <= 6 } {
        if { [lindex [$path:cmd xview] 0] > 0 } {
            set scroll [list xview -1]
            DropSite::setcursor sb_left_arrow
        }
    } elseif { $x >= $xmax-6 } {
        if { [lindex [$path:cmd xview] 1] < 1 } {
            set scroll [list xview 1]
            DropSite::setcursor sb_right_arrow
        }
    }

    if { [string length $data(dnd,afterid)] && [string compare $data(dnd,scroll) $scroll] } {
        after cancel $data(dnd,afterid)
        set data(dnd,afterid) ""
    }

    set data(dnd,scroll) $scroll
    if { [llength $scroll] && ![string length $data(dnd,afterid)] } {
        set data(dnd,afterid) [after 200 ListBox::_scroll $path $scroll]
    }
    return $data(dnd,afterid)
}


# ------------------------------------------------------------------------------
#  Command ListBox::_scroll
# ------------------------------------------------------------------------------
proc ListBox::_scroll { path cmd dir } {
    variable $path
    upvar 0  $path data

    if { ($dir == -1 && [lindex [$path:cmd $cmd] 0] > 0) ||
         ($dir == 1  && [lindex [$path:cmd $cmd] 1] < 1) } {
        $path $cmd scroll $dir units
        set data(dnd,afterid) [after 100 ListBox::_scroll $path $cmd $dir]
    } else {
        set data(dnd,afterid) ""
        DropSite::setcursor dot
    }
}