stk/Lib/menu.stk

;;;;
;;;; Copyright <20> 1993-1999 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;; 
;;;; Permission to use, copy, modify, distribute,and license this
;;;; software and its documentation for any purpose is hereby granted,
;;;; provided that existing copyright notices are retained in all
;;;; copies and that this notice is included verbatim in any
;;;; distributions.  No written agreement, license, or royalty fee is
;;;; required for any of the authorized uses.
;;;; 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:  3-Sep-1999 19:53 (eg)
;;;;

(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 #f))

(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 #t))

(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 :global w))))))


;; 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).
;; motion - 		If false then originated from an <Enter>

(define (Tk:menu-motion menu x y state motion)
  (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
  (when (and motion
	     (not (= (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 :global tk::posted-mb)
      (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 :global menu)))))

;; 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))
     ((and tk::menubar (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)))
  ;; This is a last minute addition before 4.0 It doesn't seem to hurt.
  (grab 'release w))


;; 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:menu-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))
	     (i       (do ((i 0 (+ i 1))) 
			  ((eq? tk::posted-mb (list-ref buttons i)) i)
			'nothing)))
	(let loop ((i   (modulo (+ i count) len))
		   (cnt 0))
	  (let ((mb (list-ref buttons i)))
	    (if (or (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")))
		    (eq? mb tk::posted-mb))
		;; found a menu to post
		(begin
		  (Tk:menu-button-post mb)
		  (Tk:menu-first-entry (tk-get mb :menu)))
		;; no menu, search another one, if possible
		(if (< cnt len)
		    (loop (modulo (+ i count) len)   (+ cnt 1))))))))))

;; 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)))
    (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 :underline))
				      (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 (equal? w "")
	    (if (string=? (winfo 'class w) "Menu")
		(begin
		  (Tk:menu-set-focus w)
		  (set! tk::window w)
		  (Tk:save-grab-info w)
		  (grab :global w)
		  (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 (equal? w "")
      (if (string=? (winfo 'class w) "Menu")
	  (begin
	    (Tk:menu-set-focus w)
	    (set! tk::window w)
	    (Tk:save-grab-info w)
	    (grab :global w)
	    (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 :global menu)
    (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"
				  :direction "flush"))
	 (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