From: tromey@cns.caltech.edu (Tom Tromey)
Newsgroups: comp.lang.tcl
Subject: Dynamically reconfigurable cascade menus
Date: 12 Dec 92 11:31:22
Organization: California Institute of Technology
NNTP-Posting-Host: kant.cns.caltech.edu

Enclosed is a patch to Tk2.3 that implements dynamically
reconfigurable cascade menus.

This patch does two things:

* Usurps the -command option for cascade menu entries.  The command is
now run from ActivateMenuEnty just before the submenu is popped up.
The command can reconfigure the submenu (within limits; see below)
before it is popped up.  The canonical example is a menu which is
dynamically reconfigured to show the elements of a directory, even if
the contents of the directory change.  Note that the -command option
is no longer available if the cascade menu item itself is activated;
now nothing happens in that case.

* Extends the "$menu delete" command (where $menu is a menu of
course).  Now the usage is "$menu delete first ?last?".  This eases
reconfiguration of submenus somewhat.

I wanted the code to work so that my -command entry for a cascade item
could delete the submenu and re-create it from scratch, but my first
stab didn't work, and I only have one machine here to work on -- which
makes debugging menu code difficult to impossible.  There are only so
many printfs I can add without going crazy (sometimes I think: if gdb
used Tcl as its scripting language, then I could do things like this
by setting a lot of breakpoints which would automatically print local
variables and continue -- in effect adding printfs without actually
adding them -- but alas, the gdb people aren't quite enlightened
enough, or don't have the time, or whatever).

So as it stands, you can delete all the elements of the cascade
submenu, but you can't change the submenu itself (from inside the
-command callback).

Here is some sample code to show how dynamic menus work:


#!/home/isis/tromey/tk2.3/wish -f
# Test of dynamic cascade menus

proc RC menu {
  # catch in case the menu is intially empty
  catch {$menu delete 0 last}
  foreach file [glob -nocomplain *] {
    $menu add command -label $file -command "puts stderr $file"
  }
  .mb.menu entryconfigure 0 -menu $menu
}

menubutton .mb -text Blah -menu .mb.menu
menu .mb.menu
.mb.menu add cascade -label directory -command "RC .mb.menu.menu" \
  -menu .mb.menu.menu
menu .mb.menu.menu

pack append . .mb left


Tom

*** tkMenu.c.~1~	Sat Dec  5 14:09:20 1992
--- tkMenu.c	Mon Dec  7 16:00:01 1992
***************
*** 601,633 ****
  	    result = ConfigureMenu(interp, menuPtr, argc-2, argv+2,
  		    TK_CONFIG_ARGV_ONLY);
  	}
      } else if ((c == 'd') && (strncmp(argv[1], "delete", length) == 0)
  	    && (length >= 2)) {
! 	int index, i;
  
! 	if (argc != 3) {
  	    Tcl_AppendResult(interp, "wrong # args: should be \"",
! 		    argv[0], " delete index\"", (char *) NULL);
  	    goto error;
  	}
! 	if (GetMenuIndex(interp, menuPtr, argv[2], &index) != TCL_OK) {
  	    goto error;
  	}
! 	if (index < 0) {
  	    goto done;
  	}
! 	Tk_EventuallyFree((ClientData) menuPtr->entries[index],
! 		DestroyMenuEntry);
! 	for (i = index; i < menuPtr->numEntries-1; i++) {
! 	    menuPtr->entries[i] = menuPtr->entries[i+1];
  	}
! 	menuPtr->numEntries -= 1;
! 	if (menuPtr->active == index) {
  	    menuPtr->active = -1;
! 	} else if (menuPtr->active > index) {
! 	    menuPtr->active -= 1;
  	}
  	if (!(menuPtr->flags & RESIZE_PENDING)) {
  	    menuPtr->flags |= RESIZE_PENDING;
  	    Tk_DoWhenIdle(ComputeMenuGeometry, (ClientData) menuPtr);
  	}
--- 601,642 ----
  	    result = ConfigureMenu(interp, menuPtr, argc-2, argv+2,
  		    TK_CONFIG_ARGV_ONLY);
  	}
      } else if ((c == 'd') && (strncmp(argv[1], "delete", length) == 0)
  	    && (length >= 2)) {
! 	int first, last, i;
  
! 	if (argc != 3 && argc != 4) {
  	    Tcl_AppendResult(interp, "wrong # args: should be \"",
! 		    argv[0], " delete first ?last?\"", (char *) NULL);
  	    goto error;
  	}
! 	if (GetMenuIndex(interp, menuPtr, argv[2], &first) != TCL_OK) {
  	    goto error;
  	}
! 	if (argc == 3) {
! 	    last = first;
! 	} else {
! 	    if (GetMenuIndex(interp, menuPtr, argv[3], &last) != TCL_OK) {
! 	        goto error;
! 	    }
! 	}
! 	if ((first < 0) || (last < 0) || (last < first)) {
  	    goto done;
  	}
! 	for (i = first; i <= last; ++i) {
! 	    Tk_EventuallyFree((ClientData) menuPtr->entries[i],
! 			      DestroyMenuEntry);
! 	    if (i < menuPtr->numEntries-(last-first+1)) {
! 	        menuPtr->entries[i] = menuPtr->entries[i+(last-first+1)];
! 	    }
  	}
! 	menuPtr->numEntries -= (last-first+1);
! 	if ((menuPtr->active >= first) && (menuPtr->active <= last)) {
  	    menuPtr->active = -1;
! 	} else if (menuPtr->active > last) {
! 	    menuPtr->active -= (last-first+1);
  	}
  	if (!(menuPtr->flags & RESIZE_PENDING)) {
  	    menuPtr->flags |= RESIZE_PENDING;
  	    Tk_DoWhenIdle(ComputeMenuGeometry, (ClientData) menuPtr);
  	}
***************
*** 2045,2055 ****
  	mePtr = menuPtr->entries[index];
  	mePtr->state = tkActiveUid;
  	EventuallyRedrawMenu(menuPtr, index);
  	Tk_Preserve((ClientData) mePtr);
  	if (mePtr->type == CASCADE_ENTRY) {
! 	    result = Tcl_GlobalEval(menuPtr->interp, mePtr->command);
  	    if (result == TCL_OK) {
  	        result = PostSubmenu(menuPtr->interp, menuPtr, mePtr);
  	    }
  	} else {
  	    result = PostSubmenu(menuPtr->interp, menuPtr, (MenuEntry *) NULL);
--- 2054,2068 ----
  	mePtr = menuPtr->entries[index];
  	mePtr->state = tkActiveUid;
  	EventuallyRedrawMenu(menuPtr, index);
  	Tk_Preserve((ClientData) mePtr);
  	if (mePtr->type == CASCADE_ENTRY) {
! 	    if (mePtr->command != NULL) {
! 	        result = Tcl_GlobalEval(menuPtr->interp, mePtr->command);
! 	    } else {
! 	        result = TCL_OK;
! 	    }
  	    if (result == TCL_OK) {
  	        result = PostSubmenu(menuPtr->interp, menuPtr, mePtr);
  	    }
  	} else {
  	    result = PostSubmenu(menuPtr->interp, menuPtr, (MenuEntry *) NULL);

--
tromey@cns.caltech.edu
"In a riddle whose answer is chess, what is the only prohibited word?"
I thought a moment and replied, "The word chess".
	-- Jorge Luis Borges
Newsgroups: comp.lang.tcl