137 lines
4.7 KiB
Plaintext
137 lines
4.7 KiB
Plaintext
;;;;
|
|
;;;; Copyright © 1993-1996 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: 8-Sep-1995 11:37
|
|
;;;; Last file update: 22-Feb-1996 11:19
|
|
;;;;
|
|
|
|
;; 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)
|
|
|
|
(define (Tk:menu-dup src dst) ;; duplicate src menu into dst
|
|
(let ((args '()))
|
|
(for-each (lambda (option)
|
|
(unless (= (length option) 2)
|
|
(set! args `(,(car option) ,(list-ref option 4) ,@args))))
|
|
(src 'configure))
|
|
|
|
(set! dst (apply Tk:menu dst 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)
|
|
|
|
(if (equal? type "cascade")
|
|
(let* ((name (format #f "~A.m~A" (widget-name dst) i))
|
|
(m2 (src 'entrycget i :menu)))
|
|
(if m2
|
|
(begin
|
|
(Tk:menu-dup m2 name)
|
|
(dst 'entryconfigure i :menu name))
|
|
(dst 'entryconfigure i :menu ""))))
|
|
|
|
(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))
|
|
|
|
|
|
;;******** Start of Tk:tear-off-menu
|
|
|
|
;; 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 ((parent [winfo 'parent w]))
|
|
(while (or (not (equal? parent [winfo 'toplevel parent]))
|
|
(equal? (winfo 'class parent) "Menu"))
|
|
(set! parent [winfo 'parent parent]))
|
|
|
|
(let ((menu (Tk:menu-dup w (format #f "~A.~A"
|
|
(if (equal? parent *root*)
|
|
""
|
|
(widget-name parent))
|
|
(gensym "tear__off")))))
|
|
(tk-set! menu :transient #f)
|
|
|
|
;; 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
|
|
((string=? [winfo 'class parent] "Menubutton")
|
|
(tk-get parent :text))
|
|
((string=? [winfo 'class parent] "Menu")
|
|
(parent 'entrycget "active" :label))
|
|
(ELSE "Menu")))
|
|
|
|
(tk-set! menu :tearoff #f)
|
|
(menu 'post [winfo 'x w] [winfo 'y w])
|
|
|
|
;; 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))))))
|
|
|
|
|