;;;;
;;;; 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))))))