notebook.tcl

是TCL的另外一个编译（解释）器

# ------------------------------------------------------------------------------
proc NoteBook::raise { path {page ""} } {
    variable $path
    upvar 0  $path data

    if { $page != "" } {
        _test_page $path $page
        _select $path $page
    }
    return $data(select)
}


# ------------------------------------------------------------------------------
#  Command NoteBook::see
# ------------------------------------------------------------------------------
proc NoteBook::see { path page } {
    variable $path
    upvar 0  $path data

    set pos [_test_page $path $page]
    if { $pos < $data(base) } {
        set data(base) $pos
        _redraw $path
    } else {
        set w     [expr {[winfo width $path]-1}]
        set fpage [expr {[_get_x_page $path $pos] + $data($page,width) + 6}]
        set idx   $data(base)
        while { $idx < $pos && $fpage > $w } {
            set fpage [expr {$fpage - $data([lindex $data(pages) $idx],width)}]
            incr idx
        }
        if { $idx != $data(base) } {
            set data(base) $idx
            _redraw $path
        }
    }
}


# ------------------------------------------------------------------------------
#  Command NoteBook::page
# ------------------------------------------------------------------------------
proc NoteBook::page { path first {last ""} } {
    variable $path
    upvar 0  $path data

    if { $last == "" } {
        return [lindex $data(pages) $first]
    } else {
        return [lrange $data(pages) $first $last]
    }
}


# ------------------------------------------------------------------------------
#  Command NoteBook::pages
# ------------------------------------------------------------------------------
proc NoteBook::pages { path {first ""} {last ""}} {
    variable $path
    upvar 0  $path data

    if { ![string length $first] } {
	return $data(pages)
    }

    if { ![string length $last] } {
        return [lindex $data(pages) $first]
    } else {
        return [lrange $data(pages) $first $last]
    }
}


# ------------------------------------------------------------------------------
#  Command NoteBook::index
# ------------------------------------------------------------------------------
proc NoteBook::index { path page } {
    variable $path
    upvar 0  $path data

    return [lsearch $data(pages) $page]
}


# ------------------------------------------------------------------------------
#  Command NoteBook::_destroy
# ------------------------------------------------------------------------------
proc NoteBook::_destroy { path } {
    variable $path
    upvar 0  $path data

    foreach page $data(pages) {
        Widget::destroy $path.f$page
    }
    Widget::destroy $path
    unset data
    rename $path {}
}


# ------------------------------------------------------------------------------
#  Command NoteBook::getframe
# ------------------------------------------------------------------------------
proc NoteBook::getframe { path page } {
    return $path.f$page
}


# ------------------------------------------------------------------------------
#  Command NoteBook::_test_page
# ------------------------------------------------------------------------------
proc NoteBook::_test_page { path page } {
    variable $path
    upvar 0  $path data

    if { [set pos [lsearch $data(pages) $page]] == -1 } {
        return -code error "page \"$page\" does not exists"
    }
    return $pos
}

proc NoteBook::_getoption { path page option } {
    set value [Widget::cget $path.f$page $option]
    if {![string length $value]} {
        set value [Widget::cget $path $option]
    }
    return $value
}

# ------------------------------------------------------------------------------
#  Command NoteBook::_itemconfigure
# ------------------------------------------------------------------------------
proc NoteBook::_itemconfigure { path page lres } {
    variable $path
    upvar 0  $path data

    set res [Widget::configure $path.f$page $lres]
    if { [Widget::hasChanged $path.f$page -text foo] } {
        _compute_width $path
    } elseif  { [Widget::hasChanged $path.f$page -image foo] } {
        set data(hpage) [expr {[font metrics [Widget::cget $path -font] -linespace] + 6}]
        _compute_width $path
    }
    if { [Widget::hasChanged $path.f$page -state state] &&
         $state == "disabled" && $data(select) == $page } {
        set data(select) ""
    }
    return $res
}


# ------------------------------------------------------------------------------
#  Command NoteBook::_compute_width
# ------------------------------------------------------------------------------
proc NoteBook::_compute_width { path } {
    variable $path
    upvar 0  $path data

    set font [Widget::cget $path -font]
    set wmax 0
    set hmax $data(hpage)
    set wtot 0
    if { ![info exists data(textid)] } {
        set data(textid) [$path.c create text 0 -100 -font $font -anchor nw]
    }
    set id $data(textid)
    $path.c itemconfigure $id -font $font
    foreach page $data(pages) {
        $path.c itemconfigure $id -text [Widget::cget $path.f$page -text]
	# Get the bbox for this text to determine its width, then substract
	# 6 from the width to account for canvas bbox oddness w.r.t. widths of
	# simple text.
	foreach {x1 y1 x2 y2} [$path.c bbox $id] break
	set x2 [expr {$x2 - 6}]
        set  wtext [expr {$x2 - $x1 + 20}]
        if { [set img [Widget::cget $path.f$page -image]] != "" } {
            set wtext [expr {$wtext+[image width $img]+4}]
            set himg  [expr {[image height $img]+6}]
            if { $himg > $hmax } {
                set hmax $himg
            }
        }
        set  wmax  [expr {$wtext>$wmax ? $wtext : $wmax}]
        incr wtot  $wtext
        set  data($page,width) $wtext
    }
    if { [Widget::cget $path -homogeneous] } {
        foreach page $data(pages) {
            set data($page,width) $wmax
        }
        set wtot [expr {$wmax * [llength $data(pages)]}]
    }
    set data(hpage) $hmax
    set data(wpage) $wtot
}


# ------------------------------------------------------------------------------
#  Command NoteBook::_get_x_page
# ------------------------------------------------------------------------------
proc NoteBook::_get_x_page { path pos } {
    variable _warrow
    variable $path
    upvar 0  $path data

    set base $data(base)
    # notebook tabs start flush with the left side of the notebook
    set x 0
    if { $pos < $base } {
        foreach page [lrange $data(pages) $pos [expr {$base-1}]] {
            incr x [expr {-$data($page,width)}]
        }
    } elseif { $pos > $base } {
        foreach page [lrange $data(pages) $base [expr {$pos-1}]] {
            incr x $data($page,width)
        }
    }
    return $x
}


# ------------------------------------------------------------------------------
#  Command NoteBook::_xview
# ------------------------------------------------------------------------------
proc NoteBook::_xview { path inc } {
    variable $path
    upvar 0  $path data

    if { $inc == -1 } {
        set base [expr {$data(base)-1}]
        set dx $data([lindex $data(pages) $base],width)
    } else {
        set dx [expr {-$data([lindex $data(pages) $data(base)],width)}]
        set base [expr {$data(base)+1}]
    }

    if { $base >= 0 && $base < [llength $data(pages)] } {
        set data(base) $base
        $path.c move page $dx 0
        _draw_area   $path
        _draw_arrows $path
    }
}


# ------------------------------------------------------------------------------
#  Command NoteBook::_highlight
# ------------------------------------------------------------------------------
proc NoteBook::_highlight { type path page } {
    variable $path
    upvar 0  $path data

    if { ![string compare [Widget::cget $path.f$page -state] "disabled"] } {
        return
    }

    switch -- $type {
        on {
            $path.c itemconfigure "$page:poly" \
		    -fill [_getoption $path $page -activebackground]
            $path.c itemconfigure "$page:text" \
		    -fill [_getoption $path $page -activeforeground]
        }
        off {
            $path.c itemconfigure "$page:poly" \
		    -fill [_getoption $path $page -background]
            $path.c itemconfigure "$page:text" \
		    -fill [_getoption $path $page -foreground]
        }
    }
}


# ------------------------------------------------------------------------------
#  Command NoteBook::_select
# ------------------------------------------------------------------------------
proc NoteBook::_select { path page } {
    variable $path
    upvar 0  $path data

    if { ![string compare [Widget::cget $path.f$page -state] "normal"] } {
        set oldsel $data(select)
        if { [string compare $page $oldsel] } {
            if { ![string equal $oldsel ""] } {
		set cmd [Widget::cget $path.f$oldsel -leavecmd]
                if { ![string equal $cmd ""] } {
		    set code [catch {uplevel \#0 $cmd} res]
                    if { $code == 1 || $res == 0 } {
                        return -code $code $res
                    }
                }
                set data(select) ""
                _draw_page $path $oldsel 0
            }
            set data(select) $page
            if { ![string equal $page ""] } {
                if { !$data($page,realized) } {
                    set data($page,realized) 1
		    set cmd [Widget::cget $path.f$page -createcmd]
                    if { ![string equal $cmd ""] } {
                        uplevel \#0 $cmd
                    }
                }
		set cmd [Widget::cget $path.f$page -raisecmd]
                if { ![string equal $cmd ""] } {
                    uplevel \#0 $cmd
                }
                _draw_page $path $page 0
            }
            _draw_area $path
        }
    }
}


# -----------------------------------------------------------------------------
#  Command NoteBook::_redraw
# -----------------------------------------------------------------------------
proc NoteBook::_redraw { path } {
    variable $path
    upvar 0  $path data

    if { !$data(realized) } {
        return
    }

    foreach page $data(pages) {
        _draw_page $path $page 0
    }
    _draw_area   $path
    _draw_arrows $path
}


# ----------------------------------------------------------------------------
#  Command NoteBook::_draw_page
# ----------------------------------------------------------------------------
proc NoteBook::_draw_page { path page create } {
    variable $path
    upvar 0  $path data

    # --- calcul des coordonnees et des couleurs de l'onglet ------------------
    set pos [lsearch $data(pages) $page]
    set bg  [_getoption $path $page -background]

    # lookup the tab colors
    set fgt   $data(lbg)
    set fgb   $data(dbg)

    set h   $data(hpage)
    set xd  [_get_x_page $path $pos]
    set xf  [expr {$xd + $data($page,width)}]

    # Set the initial text offsets -- a few pixels down, centered left-to-right
    set textOffsetY 3
    set textOffsetX 9

    # Coordinates of the tab corners are:
    #     c3        c4
    #
    # c2                c5