1147 lines
39 KiB
Plaintext
1147 lines
39 KiB
Plaintext
;;;;
|
|
;;;; Copyright © 1993-1998 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
|
|
;;;;
|
|
;;;; Permission to use, copy, and/or distribute this software and its
|
|
;;;; documentation for any purpose and without fee is hereby granted, provided
|
|
;;;; that both the above copyright notice and this permission notice appear in
|
|
;;;; all copies and derived works. Fees for distribution or use of this
|
|
;;;; software or derived works may only be charged with express written
|
|
;;;; permission of the copyright holder.
|
|
;;;; This software is provided ``as is'' without express or implied warranty.
|
|
;;;;
|
|
;;;; This software is a derivative work of other copyrighted softwares; the
|
|
;;;; copyright notices of these softwares are placed in the file COPYRIGHTS
|
|
;;;;
|
|
;;;;
|
|
;;;; Author: Erick Gallesio [eg@unice.fr]
|
|
;;;; Creation date: 17-May-1993 12:35
|
|
;;;; Last file update: 27-Apr-1998 12:34
|
|
;;;;
|
|
|
|
(select-module Tk)
|
|
|
|
;;
|
|
;; This file is loaded for the first menu or menu-button.
|
|
;; Avoid to load it twice
|
|
;;
|
|
(unless (or (tk-command? Tk:menu) (tk-command? Tk:menubutton))
|
|
(define tk::in-menu-button #f)
|
|
(define tk::posted-mb #f)
|
|
(define tk::popup #f)
|
|
(define tk::grab-status #f)
|
|
(define tk::old-grab #f)
|
|
(define tk::menubar #f)
|
|
(define tk::tearoff #f)
|
|
|
|
;;-------------------------------------------------------------------------
|
|
;; Globals that are used in this file:
|
|
;;
|
|
;; cursor - Saves the -cursor option for the posted menubutton.
|
|
;; focus - Saves the focus during a menu selection operation.
|
|
;; Focus gets restored here when the menu is unposted.
|
|
;; grab-status - Used in conjunction with Tk::old-grab: if Tk:old-grab
|
|
;; is not false, then Tk:grab-global contains either an
|
|
;; empty string or "-global" to indicate whether the old
|
|
;; grab was a local one or a global one.
|
|
;; in-menu-button - The name of the menubutton widget containing
|
|
;; the mouse, or an empty string if the mouse is
|
|
;; not over any menubutton.
|
|
;; menuBar - The name of the menubar that is the root
|
|
;; of the cascade hierarchy which is currently
|
|
;; posted. This is null when there is no menu currently
|
|
;; being pulled down from a menu bar.
|
|
;; old-grab - Window that had the grab before a menu was posted.
|
|
;; Used to restore the grab state after the menu
|
|
;; is unposted. Empty string means there was no
|
|
;; grab previously set.
|
|
;; popup - If a menu has been popped up via tk_popup, this
|
|
;; gives the name of the menu. Otherwise this
|
|
;; value is empty.
|
|
;; posted-mb - Name of the menubutton whose menu is currently
|
|
;; posted, or an empty string if nothing is posted
|
|
;; A grab is set on this widget.
|
|
;; relief - Used to save the original relief of the current
|
|
;; menubutton.
|
|
;; window - When the mouse is over a menu, this holds the
|
|
;; name of the menu; it's cleared when the mouse
|
|
;; leaves the menu.
|
|
;; tearoff - Whether the last menu posted was a tearoff or not.
|
|
;; This is true always for unix, for tearoffs for Mac
|
|
;; and Windows.
|
|
|
|
;;-------------------------------------------------------------------------
|
|
|
|
;;-------------------------------------------------------------------------
|
|
;; Overall note:
|
|
;; This file is tricky because there are four different ways that menus
|
|
;; can be used:
|
|
;;
|
|
;; 1. As a pulldown from a menubutton. This is the most common usage.
|
|
;; In this style, the variable tk::posted-mb identifies the posted
|
|
;; menubutton.
|
|
;; 2. As a torn-off menu copied from some other menu. In this style
|
|
;; tk::posted-Mb is empty, and the top-level menu is no
|
|
;; override-redirect.
|
|
;; 3. As an option menu, triggered from an option menubutton. In thi
|
|
;; style tk::posted-Mb identifies the posted menubutton.
|
|
;; 4. As a popup menu. In this style tk::posted-mb is empty and
|
|
;; the top-level menu is override-redirect.
|
|
;;
|
|
;; The various binding procedures use the state described above to
|
|
;; distinguish the various cases and take different actions in each
|
|
;; case.
|
|
;;-------------------------------------------------------------------------
|
|
|
|
;;-------------------------------------------------------------------------
|
|
;; The code below creates the default class bindings for menus
|
|
;; and menubuttons.
|
|
;;-------------------------------------------------------------------------
|
|
|
|
|
|
(define-binding "Menubutton" "<FocusIn>" ()
|
|
'())
|
|
|
|
(define-binding "Menubutton" "<Enter>" (|W|)
|
|
(Tk:menu-button-enter |W|))
|
|
|
|
(define-binding "Menubutton" "<Leave>" (|W|)
|
|
(Tk:menu-button-leave |W|))
|
|
|
|
(define-binding "Menubutton" "<1>" (|W| |X| |Y|)
|
|
(when tk::in-menu-button
|
|
(Tk:menu-button-post tk::in-menu-button |X| |Y|)))
|
|
|
|
(define-binding "Menubutton" "<Motion>" (|W| |X| |Y|)
|
|
(Tk:menu-button-motion |W| 'up |X| |Y|))
|
|
|
|
(define-binding "Menubutton" "<B1-Motion>" (|W| |X| |Y|)
|
|
(Tk:menu-button-motion |W| 'down |X| |Y|))
|
|
|
|
(define-binding "Menubutton" "<ButtonRelease-1>" (|W|)
|
|
(Tk:menu-button-button-up |W|))
|
|
|
|
(define-binding "Menubutton" "<space>" (|W|)
|
|
(Tk:menu-button-post |W|)
|
|
(Tk:menu-first-entry (tk-get |W| :menu)))
|
|
|
|
;; Must set focus when mouse enters a menu, in order to allow
|
|
;; mixed-mode processing using both the mouse and the keyboard.
|
|
;; Don't set the focus if the event comes from a grab release,
|
|
;; though: such an event can happen after as part of unposting
|
|
;; a cascaded chain of menus, after the focus has already been
|
|
;; restored to wherever it was before menu selection started.
|
|
|
|
(define-binding "Menu" "<FocusIn>" ()
|
|
'())
|
|
|
|
(define-binding "Menu" "<Enter>" (|W| m x y s)
|
|
(set! tk::window |W|)
|
|
(when (string=? (tk-get |W| :type) "tearoff")
|
|
(unless (string=? m "NotifyUngrab")
|
|
(when (eqv? (os-kind) 'Unix)
|
|
(Tk:menu-set-focus |W|))))
|
|
(Tk:menu-motion |W| x y s))
|
|
|
|
(define-binding "Menu" "<Leave>" (|W| |X| |Y|)
|
|
(Tk:menu-leave |W| |X| |Y|))
|
|
|
|
(define-binding "Menu" "<Motion>" (|W| x y s)
|
|
(Tk:menu-motion |W| x y s))
|
|
|
|
(define-binding "Menu" "<ButtonPress>" (|W|)
|
|
(Tk:menu-button-down |W|))
|
|
|
|
(define-binding "Menu" "<ButtonRelease>" (|W|)
|
|
(Tk:menu-invoke |W| #t))
|
|
|
|
(define-binding "Menu" "<space>" (|W|)
|
|
(Tk:menu-invoke |W| #f))
|
|
|
|
(define-binding "Menu" "<Return>" (|W|)
|
|
(Tk:menu-invoke |W| #f))
|
|
|
|
(define-binding "Menu" "<Escape>" (|W|)
|
|
(Tk:menu-escape |W|))
|
|
|
|
(define-binding "Menu" "<Left>" (|W|)
|
|
(Tk:menu-left-arrow |W|))
|
|
|
|
(define-binding "Menu" "<Right>" (|W|)
|
|
(Tk:menu-right-arrow |W|))
|
|
|
|
(define-binding "Menu" "<Up>" (|W|)
|
|
(Tk:menu-up-arrow |W|))
|
|
|
|
(define-binding "Menu" "<Down>" (|W|)
|
|
(Tk:menu-down-arrow |W|))
|
|
|
|
(define-binding "Menu" "<KeyPress>" (|W| |A|)
|
|
(Tk:traverse-within-menu |W| |A|))
|
|
|
|
|
|
;; The following bindings apply to all windows, and are used to
|
|
;; implement keyboard menu traversal.
|
|
(if (eqv? (os-kind) 'Unix)
|
|
(begin
|
|
(define-binding "all" "<Alt-KeyPress>" (|W| |A|)
|
|
(Tk:traverse-to-menu |W| |A|))
|
|
|
|
(define-binding "all" "<F10>" (|W|)
|
|
(Tk:first-menu |W|)))
|
|
(begin
|
|
(define-binding "Menubutton" "<Alt-KeyPress>" (|W| |A|)
|
|
(Tk:traverse-to-menu |W| |A|))
|
|
|
|
(define-binding "Menubutton" "<F10>" (|W|)
|
|
(Tk:first-menu |W|))))
|
|
|
|
;; Tk:menu-button-enter --
|
|
;; This procedure is invoked when the mouse enters a menubutton
|
|
;; widget. It activates the widget unless it is disabled. Note:
|
|
;; this procedure is only invoked when mouse button 1 is *not* down.
|
|
;; The procedure Tk:menu-button-B1-enter is invoked if the button is down.
|
|
;;
|
|
|
|
(define (Tk:menu-button-enter w)
|
|
(when tk::in-menu-button
|
|
(Tk:menu-button-leave tk::in-menu-button))
|
|
|
|
(set! tk::in-menu-button w)
|
|
|
|
(unless (equal? (tk-get w :state) "disabled")
|
|
(tk-set! w :state "active")))
|
|
|
|
;; Tk:menu-button-leave --
|
|
;; This procedure is invoked when the mouse leaves a menubutton widget.
|
|
;; It de-activates the widget, if the widget still exists.
|
|
;;
|
|
|
|
(define (Tk:menu-button-leave w)
|
|
(set! tk::in-menu-button #f)
|
|
(when (and (winfo 'exists w) (equal? (tk-get w :state) "active"))
|
|
(tk-set! w :state "normal")))
|
|
|
|
;; Tk:menu-button-Post --
|
|
;; Given a menubutton, this procedure does all the work of posting
|
|
;; its associated menu and unposting any other menu that is currently
|
|
;; posted.
|
|
;;
|
|
;; w - The name of the menubutton widget whose menu
|
|
;; is to be posted.
|
|
;; x, y - Root coordinates of cursor, used for positioning
|
|
;; option menus. If not specified, then the center
|
|
;; of the menubutton is used for an option menu.
|
|
|
|
(define (Tk:menu-button-post w . coords)
|
|
(unless (or (string=? (tk-get w :state) "disabled") (equal? w tk::posted-mb))
|
|
(let ((menu (tk-get w :menu))
|
|
(tearoff #f))
|
|
(when menu
|
|
(set! tearoff (or (eqv? (os-kind) 'Unix)
|
|
(string=? (tk-get menu :type) "tearoff")))
|
|
|
|
(unless (string-find? (string-append (widget->string w) ".")
|
|
(widget->string menu))
|
|
;; This is weak, but should be sufficient
|
|
(error "can't post ~S: it isn't a descendant of ~S" menu w))
|
|
|
|
(let ((cur tk::posted-mb))
|
|
(when tk::posted-mb (Tk:menu-unpost #f))
|
|
(set! tk::cursor (tk-get w :cursor))
|
|
(set! tk::relief (tk-get w :relief))
|
|
(tk-set! w :cursor "arrow")
|
|
(tk-set! w :relief "raised")
|
|
|
|
(set! tk::posted-mb w)
|
|
(set! tk::focus (focus))
|
|
(menu 'activate 'none)
|
|
(event 'generate menu "<<MenuSelect>>")
|
|
|
|
;; If this looks like an option menubutton then post the menu so
|
|
;; that the current entry is on top of the mouse. Otherwise post
|
|
;; the menu just below the menubutton, as for a pull-down.
|
|
(update 'idletasks)
|
|
(when (catch
|
|
(case (string->symbol (tk-get w :direction))
|
|
((above)
|
|
(menu 'post
|
|
(winfo 'rootx w)
|
|
(- (winfo 'rooty w) (winfo 'reqheight menu))))
|
|
((below)
|
|
(menu 'post
|
|
(winfo 'rootx w)
|
|
(+ (winfo 'rooty w) (winfo 'height w))))
|
|
((left)
|
|
(let ((x (- (winfo 'rootx w) (winfo 'reqwidth menu)))
|
|
(y (/ (+ (* 2 (winfo 'rooty w))
|
|
(winfo 'height w)) 2))
|
|
(entry (Tk:menu-find-name menu (tk-get w :text))))
|
|
(when (tk-get w :indicatoron)
|
|
(set y (- y (/ (if (= entry (menu 'index 'last))
|
|
(+ (menu 'yposition entry)
|
|
(winfo 'reqheight menu))
|
|
(+ (menu 'yposition entry)
|
|
(menu 'yposition (+ entry 1))))
|
|
2))))
|
|
(menu 'post x y)
|
|
(when (and entry
|
|
(not (string=? (menu 'entrycget entry :state)
|
|
"disabled")))
|
|
(menu 'activate entry)
|
|
(event 'generate menu "<<MenuSelect>>"))))
|
|
((right)
|
|
(let ((x (+ (winfo 'rootx w) (winfo 'reqwidth menu)))
|
|
(y (/ (+ (* 2 (winfo 'rooty w))
|
|
(winfo 'height w)) 2))
|
|
(entry (Tk:menu-find-name menu (tk-get w :text))))
|
|
(when (tk-get w :indicatoron)
|
|
(set y (- y (/ (if (= entry (menu 'index 'last))
|
|
(+ (menu 'yposition entry)
|
|
(winfo 'reqheight menu))
|
|
(+ (menu 'yposition entry)
|
|
(menu 'yposition (+ entry 1))))
|
|
2))))
|
|
(menu 'post x y)
|
|
(when (and entry
|
|
(not (string=? (menu 'entrycget entry :state)
|
|
"disabled")))
|
|
(menu 'activate entry)
|
|
(event 'generate menu "<<MenuSelect>>"))))
|
|
(else (if (tk-get w :indicatoron)
|
|
(let ((x (if (null? coords)
|
|
(+ (winfo 'rootx w)
|
|
(/ (winfo 'width w) 2))
|
|
(car coords)))
|
|
(y (if (null? coords)
|
|
(+ (winfo 'rooty w)
|
|
(/ (winfo 'height w) 2))
|
|
(cadr coords))))
|
|
(Tk:post-over-point
|
|
menu
|
|
x
|
|
y
|
|
(Tk:menu-find-name menu (tk-get w :text))))
|
|
(menu 'post
|
|
(winfo 'rootx w)
|
|
(+ (winfo 'rooty w) (winfo 'height w)))))))
|
|
;; Error posting menu (e.g. bogus -postcommand). Unpost it and
|
|
;; reflect the error.
|
|
(let ((msg (list *last-error-message* *last-error-arg*)))
|
|
(Tk:menu-unpost #f)
|
|
(apply error "~A: ~S" msg))))
|
|
|
|
(set! tk::tearoff tearoff)
|
|
(when tearoff
|
|
(focus menu)
|
|
(Tk:save-grab-info w)
|
|
(grab w)))))) ;; Tcl/Tk grab is :global here.
|
|
|
|
|
|
;; Tk:menu-unpost --
|
|
;; This procedure unposts a given menu, plus all of its ancestors up
|
|
;; to (and including) a menubutton, if any. It also restores various
|
|
;; values to what they were before the menu was posted, and releases
|
|
;; a grab if there's a menubutton involved. Special notes:
|
|
;; 1. It's important to unpost all menus before releasing the grab, so
|
|
;; that any Enter-Leave events (e.g. from menu back to main
|
|
;; application) have mode NotifyGrab.
|
|
;; 2. Be sure to enclose various groups of commands in "catch" so that
|
|
;; the procedure will complete even if the menubutton or the menu
|
|
;; or the grab window has been deleted.
|
|
;;
|
|
;; menu - Name of a menu to unpost. Ignored if there
|
|
;; is a posted menubutton.
|
|
|
|
(define (Tk:menu-unpost menu)
|
|
(let ((mb tk::posted-mb))
|
|
;; Restore focus right away (otherwise X will take focus away when
|
|
;; the menu is unmapped and under some window managers (e.g. olvwm)
|
|
;; we'll lose the focus completely).
|
|
|
|
(catch (focus tk::focus))
|
|
(set! tk::focus #f)
|
|
|
|
;; Unpost menu(s) and restore some stuff that's dependent on
|
|
;; what was posted.
|
|
(catch
|
|
(if mb
|
|
(begin
|
|
(set! menu (tk-get mb :menu))
|
|
(menu 'unpost)
|
|
(set! tk::posted-mb #f)
|
|
(tk-set! mb :cursor tk::cursor :relief tk::relief))
|
|
(if tk::popup
|
|
(begin
|
|
(tk::popup 'unpost)
|
|
(set! tk::popup #f))
|
|
(let ((type (tk-get menu :type)))
|
|
(when (or (and (not (string=? type "menubar"))
|
|
(not (string=? type "tearoff")))
|
|
(wm 'overrideredirect menu))
|
|
;; We're in a cascaded sub-menu from a torn-off menu or popup.
|
|
;; Unpost all the menus up to the toplevel one (but not
|
|
;; including the top-level torn-off one) and deactivate the
|
|
;; top-level torn off menu if there is one.
|
|
(let loop ((parent (winfo 'parent menu)))
|
|
(when (and (equal? (winfo 'class parent) "Menu")
|
|
(winfo 'ismapped parent))
|
|
(parent 'activate 'none)
|
|
(parent 'postcascade 'none)
|
|
(event 'generate parent "<<MenuSelect>>")
|
|
|
|
(unless (or (string=? (tk-get parent :type) "menubar")
|
|
(not (wm 'overrideredirect parent)))
|
|
(loop (winfo 'parent parent)))))
|
|
|
|
(unless (string? (tk-get menu :type) "menubar")
|
|
(menu 'unpost)))))))
|
|
|
|
(when (or tk::tearoff tk::menubar)
|
|
;; Release grab, if any, and restore the previous grab, if there was one.
|
|
(when menu
|
|
(let ((g (grab 'current menu)))
|
|
(and g (grab 'release g))))
|
|
|
|
(Tk:restore-old-grab)
|
|
|
|
(when tk::menubar
|
|
(tk-set! tk::menubar :cursor tk::cursor)
|
|
(set! tk::menubar #f))
|
|
|
|
(unless (equal? (os-kind) 'Unix)
|
|
(set! tk::tearoff #f)))))
|
|
|
|
;; Tk:menu-button-motion --
|
|
;; This procedure handles mouse motion events inside menubuttons, and
|
|
;; also outside menubuttons when a menubutton has a grab (e.g. when a
|
|
;; menu selection operation is in progress).
|
|
;;
|
|
;; w - The name of the menubutton widget.
|
|
;; upDown - "down" means button 1 is pressed, "up" means
|
|
;; it isn't.
|
|
;; rootx, rooty - Coordinates of mouse, in (virtual?) root window.
|
|
(define (Tk:menu-button-motion w upDown rootx rooty)
|
|
(unless (equal? tk::in-menu-button w)
|
|
(let ((new (winfo 'containing rootx rooty)))
|
|
(when (and (not (equal? new tk::in-menu-button))
|
|
(or (not new)
|
|
(equal? (winfo 'toplevel new) (winfo 'toplevel w))))
|
|
(if tk::in-menu-button
|
|
(Tk:menu-button-leave tk::in-menu-button))
|
|
(when (and new
|
|
(string=? (winfo 'class new) "Menubutton")
|
|
(not (tk-get new :indicatoron))
|
|
(not (tk-get w :indicatoron)))
|
|
(if (eq? updown 'down)
|
|
(Tk:menu-button-post new rootx rooty)
|
|
(Tk:menu-button-enter new)))))))
|
|
|
|
|
|
;; Tk:menu-button-button-up --
|
|
;; This procedure is invoked to handle button 1 releases for menubuttons.
|
|
;; If the release happens inside the menubutton then leave its menu
|
|
;; posted with element 0 activated. Otherwise, unpost the menu.
|
|
;;
|
|
(define (Tk:menu-button-button-up w)
|
|
(let ((tearoff (or (eqv? (os-kind) 'Unix)
|
|
(string=? (tk-get (tk-get w menu) :type) "tearoff"))))
|
|
|
|
(if (and tearoff (equal? tk::posted-mb w) (equal? tk::in-menu-button w))
|
|
(Tk:menu-first-entry (tk-get tk::posted-mb :menu))
|
|
(Tk:menu-unpost #f))))
|
|
|
|
|
|
;; Tk:menu-motion --
|
|
;; This procedure is called to handle mouse motion events for menus.
|
|
;; It does two things. First, it resets the active element in the
|
|
;; menu, if the mouse is over the menu. Second, if a mouse button
|
|
;; is down, it posts and unposts cascade entries to match the mouse
|
|
;; position.
|
|
;;
|
|
;; Arguments:
|
|
;; menu - The menu window.
|
|
;; x - The x position of the mouse.
|
|
;; y - The y position of the mouse.
|
|
;; state - Modifier state (tells whether buttons are down).
|
|
|
|
(define (Tk:menu-motion menu x y state)
|
|
(if (equal? menu tk::window)
|
|
(if (string=? (tk-get menu :type) "menubar")
|
|
(unless (equal? tk::focus menu)
|
|
(menu 'activate (format #f "@~A,~A" x y))
|
|
(event 'generate menu "<<MenuSelect>>"))
|
|
(begin
|
|
(menu 'activate (format #f "@~A,~A" x y))
|
|
(event 'generate menu "<<MenuSelect>>"))))
|
|
|
|
;; We want to test if state & 0x1f00
|
|
(unless (= (modulo (quotient state #x100) #x100) 0)
|
|
(menu 'postcascade 'active)))
|
|
|
|
;; Tk:menu-button-down --
|
|
;; Handles button presses in menus. There are a couple of tricky things
|
|
;; here:
|
|
;; 1. Change the posted cascade entry (if any) to match the mouse position.
|
|
;; 2. If there is a posted menubutton, must grab to the menubutton; this
|
|
;; overrrides the implicit grab on button press, so that the menu
|
|
;; button can track mouse motions over other menubuttons and change
|
|
;; the posted menu.
|
|
;; 3. If there's no posted menubutton (e.g. because we're a torn-off menu
|
|
;; or one of its descendants) must grab to the top-level menu so that
|
|
;; we can track mouse motions across the entire menu hierarchy.
|
|
;;
|
|
|
|
(define (Tk:menu-button-down menu)
|
|
(menu 'postcascade 'active)
|
|
(if tk::posted-mb
|
|
(grab tk::posted-mb) ;; Tcl/Tk use :global here
|
|
(begin
|
|
(while (and (not (string=? (tk-get menu :type) "menubar"))
|
|
(wm 'overrideredirect menu)
|
|
(string=? (winfo 'class (winfo 'parent menu)) "Menu")
|
|
(winfo 'ismapped (winfo 'parent menu)))
|
|
(set! menu (winfo 'parent menu)))
|
|
|
|
(unless tk::menubar
|
|
(set! tk::menubar menu)
|
|
(set! tk::cursor (tk-get menu :cursor))
|
|
(tk-set! menu :cursor "arrow"))
|
|
|
|
; Don't update grab information if the grab window isn't changing.
|
|
; Otherwise, we'll get an error when we unpost the menus and
|
|
; restore the grab, since the old grab window will not be viewable
|
|
; anymore.
|
|
(unless (equal? menu (grab 'current menu))
|
|
(Tk:save-grab-info menu))
|
|
|
|
; Must re-grab even if the grab window hasn't changed, in order
|
|
; to release the implicit grab from the button press.
|
|
(when (equal? (os-kind) 'Unix)
|
|
(grab menu))))) ;; Tcl/Tk use a :global here
|
|
|
|
;; Tk:menu-leave --
|
|
;; This procedure is invoked to handle Leave events for a menu. It
|
|
;; deactivates everything unless the active element is a cascade element
|
|
;; and the mouse is now over the submenu.
|
|
;;
|
|
;; menu - The menu window.
|
|
;; rootx, rooty - Root coordinates of mouse.
|
|
;; state - Modifier state.
|
|
|
|
(define (Tk:menu-leave menu rootx rooty)
|
|
(set! tk::window #f)
|
|
(unless (equal? (menu 'index 'active) "none")
|
|
(unless (and (equal? (menu 'type "active") "cascade")
|
|
(equal? (winfo 'containing rootx rooty)
|
|
(menu 'entrycget 'active :menu)))
|
|
(menu 'activate 'none)
|
|
(event 'generate menu "<<MenuSelect>>"))))
|
|
|
|
|
|
;; Tk:menu-invoke --
|
|
;; This procedure is invoked when button 1 is released over a menu.
|
|
;; It invokes the appropriate menu action and unposts the menu if
|
|
;; it came from a menubutton.
|
|
;;
|
|
;; w - menu widget.
|
|
;; button-release - #t means this procedure is called because of
|
|
;; a button release; #f means because of keystroke.
|
|
;;
|
|
(define (Tk:menu-invoke w button-release)
|
|
(cond
|
|
((and button-release (not tk::window))
|
|
;; Mouse was pressed over a menu without a menu button,
|
|
;; then dragged off the menu (possibly with a cascade
|
|
;; posted) and released. Unpost everything
|
|
(w 'postcascade 'none)
|
|
(w 'activate 'none)
|
|
(event 'generate w "<<MenuSelect>>")
|
|
(Tk:menu-unpost w))
|
|
((equal? (w 'type 'active) "cascade")
|
|
(w 'postcascade 'active)
|
|
(Tk:menu-first-entry (w 'entrycget 'active :menu)))
|
|
((equal? (w 'type 'active) "tearoff")
|
|
(Tk:menu-unpost w)
|
|
(Tk:tear-off-menu w))
|
|
((equal? (w 'type 'active) "menubar")
|
|
(w 'postcascade 'none)
|
|
(w 'activate 'none)
|
|
(event 'generate w "<<MenuSelect>>")
|
|
(Tk:menu-unpost w))
|
|
(else (Tk:menu-unpost w)
|
|
(w 'invoke 'active))))
|
|
|
|
|
|
;; Tk:menu-escape --
|
|
;; This procedure is invoked for the Cancel (or Escape) key. It unposts
|
|
;; the given menu and, if it is the top-level menu for a menu button,
|
|
;; unposts the menu button as well.
|
|
;;
|
|
(define (Tk:menu-escape menu)
|
|
(let ((parent (winfo 'parent menu)))
|
|
(if (not (string=? (winfo 'class parent) "Menu"))
|
|
(Tk:menu-unpost menu)
|
|
(if (string=? (tk-get parent :type) "menubar")
|
|
(begin
|
|
(Tk:menu-unpost menu)
|
|
(Tk:restore-old-grab))
|
|
(Tk:next-menu menu 'left)))))
|
|
|
|
;; The following routines handle arrow keys. Arrow keys behave
|
|
;; differently depending on whether the menu is a menu bar or not.
|
|
|
|
(define (Tk:menu-up-arrow menu)
|
|
(if (string=? (tk-get menu :type) "menubar")
|
|
(Tk:menu-next-menu menu 'left)
|
|
(Tk:menu-next-entry menu -1)))
|
|
|
|
(define (Tk:menu-down-arrow menu)
|
|
(if (string=? (tk-get menu :type) "menubar")
|
|
(Tk:menu-next-menu menu 'right)
|
|
(Tk:menu-next-entry menu +1)))
|
|
|
|
(define (Tk:menu-left-arrow menu)
|
|
(if (string=? (tk-get menu :type) "menubar")
|
|
(Tk:menu-next-entry menu -1)
|
|
(Tk:menu-next-menu menu 'left)))
|
|
|
|
(define (Tk:menu-right-arrow menu)
|
|
(if (string=? (tk-get menu :type) "menubar")
|
|
(Tk:menu-next-entry menu +1)
|
|
(Tk:menu-next-menu menu 'right)))
|
|
|
|
;; Tk:menu-next-menu --
|
|
;; This procedure is invoked to handle "left" and "right" traversal
|
|
;; motions in menus. It traverses to the next menu in a menu bar,
|
|
;; or into or out of a cascaded menu.
|
|
;;
|
|
;; menu - The menu that received the keyboard
|
|
;; event.
|
|
;; direction - Direction in which to move: "left" or "right"
|
|
|
|
(define (Tk:menu-next-menu menu direction)
|
|
(let ((count +1)
|
|
(continue #t))
|
|
;; First handle traversals into and out of cascaded menus.
|
|
(if (eq? direction 'right)
|
|
;; Direction is 'right
|
|
(if (equal? (menu 'type 'active) "cascade")
|
|
(begin
|
|
(menu 'postcascade 'active)
|
|
(let ((m2 (menu 'entrycget 'active :menu)))
|
|
(and m2 (Tk:menu-first-entry m2))
|
|
(set! continue #f)))
|
|
(let loop ((parent (winfo 'parent menu)))
|
|
(unless (equal? parent *root*)
|
|
(if (and (string=? (winfo 'class parent) "Menu")
|
|
(string=? (tk-get parent :type) "menubar"))
|
|
(begin
|
|
(Tk:menu-set-focus parent)
|
|
(Tk:menu-next-entry parent 1)
|
|
(set! continue #f))
|
|
(loop (winfo 'parent parent))))))
|
|
;; Direction is 'left
|
|
(let ((m2 (winfo 'parent menu)))
|
|
(set! count -1)
|
|
|
|
(when (string=? (winfo 'class m2) "Menu")
|
|
(menu 'activate 'none)
|
|
(event 'generate menu "<<MenuSelect>>")
|
|
(Tk:menu-set-focus m2)
|
|
|
|
;; This code unposts any posted submenu in the parent.
|
|
(let ((tmp (m2 'index 'active)))
|
|
(m2 'activate 'none)
|
|
(m2 'activate tmp)
|
|
(set! continue #f)))))
|
|
|
|
(when (and continue tk::posted-mb)
|
|
;; Can't traverse into or out of a cascaded menu. Go to the next
|
|
;; or previous menubutton, if that makes sense.
|
|
(let* ((buttons (winfo 'children [winfo 'parent tk::posted-mb]))
|
|
(len (length buttons)))
|
|
(let loop ((i (- count (length (member tk::posted-mb buttons)))))
|
|
(while (< i 0) (set! i (+ i len)))
|
|
|
|
(while (>= i len) (set! i (- i len)))
|
|
|
|
(let ((mb (list-ref buttons i)))
|
|
(unless (and (string=? [winfo 'class mb] "Menubutton")
|
|
(not (string=? [tk-get mb :state] "disabled"))
|
|
(tk-get mb :menu)
|
|
(not (equal? ((tk-get mb :menu) 'index 'last) "none")))
|
|
(when (eq? mb tk::posted-mb)
|
|
(set! continue #f))))
|
|
(loop (+ i count))))
|
|
(when continue
|
|
(Tk:menu-button-post mb)
|
|
(Tk:menu-first-entry (tk-get mb :menu))))))
|
|
|
|
;; Tk:menu-next-entry --
|
|
;; Activate the next higher or lower entry in the posted menu,
|
|
;; wrapping around at the ends. Disabled entries are skipped.
|
|
;;
|
|
;; Arguments:
|
|
;; menu - Menu window that received the keystroke.
|
|
;; count - 1 means go to the next lower entry,
|
|
;; -1 means go to the next higher entry.
|
|
|
|
(define (Tk:menu-next-entry menu count)
|
|
(unless (equal? (menu 'index 'last) "none")
|
|
(let* ((length (+ (menu 'index 'last) 1))
|
|
(quit-after length)
|
|
(active (menu 'index 'active))
|
|
(i 0)
|
|
(state #f)
|
|
(break #f))
|
|
|
|
(unless (equal? active "none")
|
|
(set! i (+ active count)))
|
|
|
|
(let loop ((i i) (quit-after quit-after))
|
|
(when (> quit-after 0)
|
|
;; We've not already tried every entry in the menu
|
|
(while (< i 0) (set! i (+ i length)))
|
|
(while (>= i length) (set! i (- i length)))
|
|
|
|
(unless (catch (set! state (menu 'entrycget i :state)))
|
|
(unless (string=? state "disabled")
|
|
(set! break #t)))
|
|
|
|
(if break
|
|
(begin
|
|
(menu 'activate i)
|
|
(event 'generate menu "<<MenuSelect>>")
|
|
(menu 'postcascade i))
|
|
(unless (= i active)
|
|
(loop (+ i count) (- quit-after 1)))))))))
|
|
|
|
;; Tk:menu-find --
|
|
;; This procedure searches the entire window hierarchy under w for
|
|
;; a menubutton that isn't disabled and whose underlined character
|
|
;; is "char" or an entry in a menubar that isn't disabled and whose
|
|
;; underlined character is "char".
|
|
;; It returns the name of that window, if found, or #f
|
|
;; if no matching window was found. If "char" is an
|
|
;; empty string then the procedure returns the name of the first
|
|
;; menubutton found that isn't disabled.
|
|
;;
|
|
;; w - Name of window where key was typed.
|
|
;; char - Underlined character to search for;
|
|
;; may be either upper or lower case, and
|
|
;; will match either upper or lower case.
|
|
|
|
(define (Tk:menu-find w char)
|
|
(let ((char (string-lower char))
|
|
(window-list (winfo 'child w)))
|
|
; FIXME: (DEBUG " Tk:menu-find (à debugger) ~S ~S" w char)
|
|
(call/cc
|
|
(lambda (exit)
|
|
(for-each (lambda (child)
|
|
(when (string=? (winfo 'class child) "Menu")
|
|
(when (string=? (tk-get child :type) "menubar")
|
|
(if (equal? char "")
|
|
(exit child)
|
|
(let ((last (child 'index 'last)))
|
|
(dotimes (i (+ last 1))
|
|
(let* ((index (child 'entrycget i :under))
|
|
(txt (child 'entrycget i :label))
|
|
(char2 (if (= index -1)
|
|
""
|
|
(string (string-ref txt index)))))
|
|
(if (member char (list "" (string-lower char2)))
|
|
(unless (string=? (child 'entrycget i :state)
|
|
"disabled")
|
|
(exit child))))))))))
|
|
window-list)
|
|
|
|
(for-each (lambda (child)
|
|
(cond
|
|
((string=? (winfo 'class child) "Menubutton")
|
|
(let* ((index (tk-get child :underline))
|
|
(txt (tk-get child :text))
|
|
(char2 (if (= index -1)
|
|
""
|
|
(string (string-ref txt index)))))
|
|
(if (member char (list "" (string-lower char2)))
|
|
(unless (string=? (tk-get child :state)
|
|
"disabled")
|
|
(exit child)))))
|
|
(else (let ((match (Tk:menu-find child char)))
|
|
(unless (equal? match "")
|
|
(exit match))))))
|
|
window-list)
|
|
(exit "")))))
|
|
|
|
;; Tk:traverse-to-menu --
|
|
;; This procedure implements keyboard traversal of menus. Given an
|
|
;; ASCII character "char", it looks for a menubutton with that character
|
|
;; underlined. If one is found, it posts the menubutton's menu
|
|
;;
|
|
;; Arguments:
|
|
;; w - Window in which the key was typed (selects
|
|
;; a toplevel window).
|
|
;; char - Character that selects a menu. The case
|
|
;; is ignored. If an empty string, nothing
|
|
;; happens.
|
|
|
|
(define (Tk:traverse-to-menu w char)
|
|
(unless (string=? char "")
|
|
(let ((continue #t))
|
|
(let Loop ((w w))
|
|
(when (string=? (winfo 'class w) "Menu")
|
|
(if (not (or (string=? (tk-get w :type) "menubar") tk::posted-mb))
|
|
(set! continue #f)
|
|
(if (string=? (tk-get w :type) "menubar")
|
|
'break
|
|
(loop (winfo 'parent w))))))
|
|
|
|
(when continue
|
|
(let ((w (Tk:menu-find (winfo 'toplevel w) char)))
|
|
(unless (string=? w "")
|
|
(if (string=? (winfo 'class w) "Menu")
|
|
(begin
|
|
(Tk-menu-set-focus w)
|
|
(set! tk::window w)
|
|
(Tk:save-grab-info w)
|
|
(grab w) ;; in Tcl/Tk grab was :global
|
|
(Tk:traverse-within-menu w char))
|
|
(begin
|
|
(Tk:menu-button-post w)
|
|
(Tk:menu-first-entry (tk-get w :menu))))))))))
|
|
|
|
;; Tk:first-menu --
|
|
;; This procedure traverses to the first menubutton in the toplevel
|
|
;; for a given window, and posts that menubutton's menu.
|
|
;;
|
|
;; w - Name of a window. Selects which toplevel
|
|
;; to search for menubuttons.
|
|
|
|
(define (Tk:first-menu w)
|
|
(let ((w (Tk:menu-find (winfo 'toplevel w) "")))
|
|
(unless (string=? w "")
|
|
(if (string=? (winfo 'class w) "Menu")
|
|
(begin
|
|
(Tk:menu-set-focus w)
|
|
(set! tk::window w)
|
|
(Tk:save-grab-info w)
|
|
(grab w) ;; in Tcl/Tk grab was :global
|
|
(Tk:menu-first-entry w))
|
|
(begin
|
|
(Tk:menu-button-post w)
|
|
(Tk:menu-first-entry (tk-get w :menu)))))))
|
|
|
|
;; Tk:traverse-within-menu
|
|
;; This procedure implements keyboard traversal within a menu. It
|
|
;; searches for an entry in the menu that has "char" underlined. If
|
|
;; such an entry is found, it is invoked and the menu is unposted.
|
|
;;
|
|
;; Arguments:
|
|
;; w - The name of the menu widget.
|
|
;; char - The character to look for; case is
|
|
;; ignored. If the string is empty then
|
|
;; nothing happens.
|
|
|
|
(define (Tk:traverse-within-menu w char)
|
|
(unless (equal? char "")
|
|
(let* ((char (string-lower char))
|
|
(last (w 'index 'last)))
|
|
(unless (equal? last "none")
|
|
(let loop ((i 0))
|
|
(when (<= i last)
|
|
(let ((index -1) (label "") (char2 #f))
|
|
(unless (catch (set! index (w 'entrycget i :underline))
|
|
(set! label (w 'entrycget i :label))
|
|
(set! char2 (string (string-ref label index))))
|
|
(if (string=? char (string-lower char2))
|
|
; found
|
|
(if (equal? (w 'type i) "cascade")
|
|
(begin
|
|
(w 'activate i)
|
|
(w 'postcascade i)
|
|
(event 'generate w "<<MenuSelect>>")
|
|
(let ((m2 (w 'entrycget i :menu)))
|
|
(and m2 (Tk:menu-first-entry m2))))
|
|
(begin
|
|
(Tk:menu-unpost w)
|
|
(w 'invoke i)))
|
|
; not found => continue
|
|
(loop (+ i 1)))))))))))
|
|
|
|
;; Tk:menu-first-entry --
|
|
;; Given a menu, this procedure finds the first entry that isn't
|
|
;; disabled or a tear-off or separator, and activates that entry.
|
|
;; However, if there is already an active entry in the menu (e.g.,
|
|
;; because of a previous call to tkPostOverPoint) then the active
|
|
;; entry isn't changed. This procedure also sets the input focus
|
|
;; to the menu.
|
|
;;
|
|
(define (Tk:menu-first-entry menu)
|
|
(when menu
|
|
(Tk:menu-set-focus menu)
|
|
(when (equal? (menu 'index 'active) "none")
|
|
(let ((last (menu 'index 'last)))
|
|
(unless (equal? last "none")
|
|
|
|
(let loop ((i 0))
|
|
(when (<= i last)
|
|
(let ((state #f))
|
|
(if (or (catch (set! state (menu 'entrycget i :state)))
|
|
(string=? state "disabled")
|
|
(equal? (menu 'type i) "tearoff"))
|
|
(loop (+ i 1))
|
|
(begin
|
|
(menu 'activate i)
|
|
(event 'generate menu "<<MenuSelect>>")))))))))))
|
|
|
|
;; Tk:menu-find-name --
|
|
;; Given a menu and a text string, return the index of the menu entry
|
|
;; that displays the string as its label. If there is no such entry,
|
|
;; return an empty string. This procedure is tricky because some names
|
|
;; like "active" have a special meaning in menu commands, so we can't
|
|
;; always use the "index" widget command.
|
|
;;
|
|
;; menu - Name of the menu widget.
|
|
;; s - String to look for.
|
|
|
|
(define (Tk:menu-find-name menu s)
|
|
; FIXME: Tk:menu-find-name manque des test pour les chaines speciales
|
|
(let ((last (menu 'index 'last))
|
|
(label #f))
|
|
(if (equal? last "none")
|
|
(let loop ((i 0))
|
|
(if (<= i last)
|
|
(if (and (not (catch (set! label (menu 'entrycget i :label))))
|
|
(equal? label s))
|
|
i
|
|
(loop ( + i 1)))
|
|
#f))
|
|
#f)))
|
|
|
|
;; Tk:post-over-point --
|
|
;; This procedure posts a given menu such that a given entry in the
|
|
;; menu is centered over a given point in the root window. It also
|
|
;; activates the given entry.
|
|
;;
|
|
;; menu - Menu to post.
|
|
;; x, y - Root coordinates of point.
|
|
;; entry - Index of entry within menu to center over (x,y).
|
|
;; If omitted or specified as {}, then the menu's
|
|
;; upper-left corner goes at (x,y).
|
|
|
|
(define (Tk:post-over-point menu x y entry)
|
|
(when entry
|
|
(set! x (- x (/ (winfo 'reqwidth menu) 2)))
|
|
(set! y (- y (/ (if (= entry (menu 'index 'last))
|
|
(+ (menu 'yposition entry) (winfo 'reqheight menu))
|
|
(+ (menu 'yposition entry) (menu 'yposition (+ entry 1))))
|
|
2))))
|
|
|
|
(menu 'post (inexact->exact x) (inexact->exact y))
|
|
(when (and entry (not (string=? (menu 'entrycget entry :state) "disabled")))
|
|
(menu 'activate entry)
|
|
(event 'generate menu "<<MenuSelect>>")))
|
|
|
|
;; Tk:save-grab-info
|
|
;; Sets the variables tk::old-grab and tk::grab-status to record
|
|
;; the state of any existing grab on the w's display.
|
|
;;
|
|
;; w - Name of a window; used to select the display
|
|
;; whose grab information is to be recorded.
|
|
|
|
(define (Tk:save-grab-info w)
|
|
(set! tk::old-grab (grab 'current w))
|
|
(when tk::old-grab
|
|
(set! tk::grab-status [grab 'status tk::old-grab])))
|
|
|
|
;; Tk:restore-old-grab --
|
|
;; Restores the grab to what it was before TkSaveGrabInfo was called.
|
|
|
|
(define (Tk:restore-old-grab)
|
|
(when tk::old-grab
|
|
;; Be careful restoring the old grab, since it's window may not
|
|
;; be visible anymore.
|
|
(catch (if (string=? tk::grab-status "global")
|
|
(grab 'set :global tk::old-grab)
|
|
(grab 'set tk::old-grab)))
|
|
(set! tk::old-grab #f)))
|
|
|
|
;;
|
|
;; Tk:menu-set-focus
|
|
;;
|
|
(define (Tk:menu-set-focus menu)
|
|
(unless tk::focus (set! tk::focus [focus]))
|
|
(focus menu))
|
|
|
|
|
|
;; Tk:popup --
|
|
;; This procedure pops up a menu and sets things up for traversing
|
|
;; the menu and its submenus.
|
|
;;
|
|
;; menu - Name of the menu to be popped up.
|
|
;; x, y - Root coordinates at which to pop up the
|
|
;; menu.
|
|
;; entry - Index of a menu entry to center over (x,y).
|
|
;; If omitted or specified as {}, then menu's
|
|
;; upper-left corner goes at (x,y).
|
|
|
|
(define (Tk:popup menu x y entry)
|
|
(when (or tk::popup tk::posted-mb)
|
|
(Tk:menu-unpost #f))
|
|
|
|
(Tk:post-over-point menu x y entry)
|
|
|
|
(when (equal? (os-kind) 'Unix)
|
|
(Tk:save-grab-info menu)
|
|
(grab menu) ;; In Tcl/Tk, grab was :global
|
|
(set! tk::popup menu)
|
|
(Tk:menu-set-focus menu)))
|
|
|
|
|
|
;; Tk:tear-off-menu --
|
|
;; Given the name of a menu, this procedure creates a torn-off menu
|
|
;; that is identical to the given menu (including nested submenus).
|
|
;; The new torn-off menu exists as a toplevel window managed by the
|
|
;; window manager. The return value is the name of the new menu.
|
|
;;
|
|
;; Arguments:
|
|
;; w - The menu to be torn-off (duplicated).
|
|
|
|
(define (Tk:tear-off-menu w . args)
|
|
;; Find a unique name to use for the torn-off menu. Find the first
|
|
;; ancestor of w that is a toplevel but not a menu, and use this as
|
|
;; the parent of the new menu. This guarantees that the torn off
|
|
;; menu will be on the same screen as the original menu. By making
|
|
;; it a child of the ancestor, rather than a child of the menu, it
|
|
;; can continue to live even if the menu is deleted; it will go
|
|
;; away when the toplevel goes away.
|
|
(let ((x (if (null? args) (winfo 'rootx w) (car args)))
|
|
(y (if (null? args) (winfo 'rooty w) (cadr args)))
|
|
(parent [winfo 'parent w]))
|
|
|
|
(while (or (not (equal? parent [winfo 'toplevel parent]))
|
|
(string=? (winfo 'class parent) "Menu"))
|
|
(set! parent [winfo 'parent parent]))
|
|
|
|
(let* ((name (format #f "~A.~A"
|
|
(if (equal? parent *root*) "" (widget-name parent))
|
|
(gensym "tear__off")))
|
|
(menu (w 'clone name 'tearoff)))
|
|
|
|
;; FIXME: Virer cette horreur d'eval
|
|
(set! menu (eval (string->symbol name)
|
|
(module-environment (find-module 'Tk))))
|
|
|
|
;; Pick a title for the new menu by looking at the parent of the
|
|
;; original: if the parent is a menu, then use the text of the active
|
|
;; entry. If it's a menubutton then use its text.
|
|
|
|
(set! parent [winfo 'parent w])
|
|
(wm 'title menu (cond
|
|
((not (string=? (tk-get menu :title) ""))
|
|
(tk-get menu :title))
|
|
((string=? [winfo 'class parent] "Menubutton")
|
|
(tk-get parent :text))
|
|
((string=? [winfo 'class parent] "Menu")
|
|
(parent 'entrycget "active" :label))
|
|
(ELSE "Menu")))
|
|
|
|
(menu 'post x y)
|
|
|
|
(if (winfo 'exists menu)
|
|
(begin
|
|
;; Set tk::focus on entry: otherwise the focus will get lost
|
|
;; after keyboard invocation of a sub-menu (it will stay on the
|
|
;; submenu).
|
|
|
|
(bind menu "<Enter>" (lambda (|W|)
|
|
(set! tk::focus |W|)))
|
|
|
|
;; If there is a :tearoffcommand option for the menu, invoke it
|
|
;; now.
|
|
(let ((cmd (tk-get w :tearoffcommand)))
|
|
(unless (equal? cmd "")
|
|
(cmd w menu)))
|
|
;; return menu
|
|
menu)
|
|
;; return #f
|
|
#f))))
|
|
|
|
(define (Tk:menu-dup src dst type) ;; duplicate src menu into dst
|
|
(let ((args '()))
|
|
(for-each (lambda (option)
|
|
(unless (or (= (length option) 2) (equal? (car option) :type))
|
|
(set! args `(,(car option) ,(list-ref option 4) ,@args))))
|
|
(src 'configure))
|
|
|
|
(set! dst (apply menu dst :type type args))
|
|
|
|
(let ((last (src 'index "last")))
|
|
(unless (equal? last "none")
|
|
(let loop ((i (if (tk-get src :tearoff) 1 0)))
|
|
(when (<= i last)
|
|
(let ((args '())
|
|
(type (src 'type i)))
|
|
(for-each (lambda (option)
|
|
(set! args
|
|
`(,(car option) ,(list-ref option 4) ,@args)))
|
|
(src 'entryconfigure i))
|
|
(apply dst 'add type args)
|
|
(loop (+ i 1)))))))
|
|
|
|
;; Duplicate the binding tags and bindings from the source menu.
|
|
;
|
|
; regsub -all . $src {\\&} quotedSrc
|
|
; regsub -all . $dst {\\&} quotedDst
|
|
; regsub -all $quotedSrc [bindtags $src] $dst x
|
|
; bindtags $dst $x
|
|
; foreach event [bind $src] {
|
|
; regsub -all $quotedSrc [bind $src $event] $dst x
|
|
; bind $dst $event $x
|
|
; }
|
|
;
|
|
; Is it really useful? Should we duplicate bindings on the copy?
|
|
; Furthermore, most of the time this code should do nothing (even if
|
|
; necessary for completude).
|
|
; Eventually translate this Tcl code in STk but don't use regexp
|
|
; since they could not be compiled for STk
|
|
|
|
;; Return dst as result
|
|
dst))
|
|
|
|
;; Tk:option-menu --
|
|
;; This procedure creates an option button named and an associated
|
|
;; menu. Together they provide the functionality of Motif option menus:
|
|
;; they can be used to select one of many values, and the current value
|
|
;; appears in the global variable var-name, as well as in the text of
|
|
;; the option menubutton. The menu is returned as the
|
|
;; procedure's result, so that the caller can use it to change configuration
|
|
;; options on the menu or otherwise manipulate it.
|
|
;;
|
|
;; w - The name to use for the menubutton.
|
|
;; var-name - Global variable to hold the currently selected value.
|
|
;; first - first (mandatory) legal value for option
|
|
;; l legal values for option
|
|
|
|
(define (Tk:option-menu w var-name env first . l)
|
|
;; define var-name before (if necessary) otherwise :textvar will define it to ""
|
|
(unless (symbol-bound? var-name env)
|
|
(eval `(define ,var-name ',first) env))
|
|
|
|
(let* ((menu-name (format #f "~A.~A" (if (equal? w *root*) "" w)
|
|
(gensym "menu")))
|
|
(mb (menubutton w :textvariable var-name
|
|
:indicatoron #t
|
|
:menu menu-name
|
|
:relief "raised"
|
|
:borderwidth 2
|
|
:highlightthickness 2
|
|
:anchor "c"))
|
|
(m (menu menu-name :tearoff #f)))
|
|
(for-each (lambda (x)
|
|
(m 'add 'radiobutton :label x :variable var-name :environment env))
|
|
(cons first l))
|
|
mb))
|
|
|
|
) ;; closes the unless
|