1#!/bin/sh
2# -*- tcl -*- \
3exec tclsh "$0" ${1+"$@"}
4
5
6package require Tcl 8.6
7package require Tk
8
9package require TclOO
10
11## --
12## Extend auto_path so package require will find the menubar package
13## in the tklib directory hierarchy.
14set selfdir  [file dirname [file normalize [info script]]]
15set modules [file join [file dirname [file dirname $selfdir]] modules]
16lappend auto_path [file join ${modules} menubar]
17
18package require menubar
19
20# uncomment the following line to enable the debugging menu
21# package require menubar::debug
22
23package provide AppMain 0.5
24
25# --
26#
27namespace eval Main {
28
29	variable wid
30	variable mbar
31	variable wid
32
33	proc main { } {
34		variable mbar
35		variable wid
36		set wid 0
37
38		wm withdraw .
39
40		##
41		## Create a menu bar definition
42		##
43
44		# create an instance of the menubar class
45		set mbar [menubar new \
46			-borderwidth 4 \
47			-relief groove  \
48			-foreground black \
49			-background tan \
50			-cursor dot \
51			-activebackground red \
52			-activeforeground white \
53			]
54
55		# define the menu tree for the instance
56		${mbar} define {
57			File M:file {
58			#   Label				 Type	Tag Name(s)
59			#   ----------------- 	 ----	---------
60				"New Window"	 	 C 		new
61				--					 S 							s0
62				"Show Macros Menu"	 C 		mshow
63				"Hide Macros Menu"   C 		mhide
64				"Toggle Paste State" C 		paste_state
65				--					 S 							s1
66				Close                C      close
67				--					 S 							s2
68				Exit			  	 C		exit
69			}
70			Edit M:items+ {
71			#   Label				Type	Tag Name(s)
72			#   ----------------- 	----	---------
73				"Cut"				C 		cut
74				"Copy"				C 		copy
75				"Paste"				C 		paste
76				"Scope (buttons)"		S 							s3
77				"Global" M:opts+ {
78					"CheckButtons"	S							s4
79						Apple		X 		apple+
80						Bread		X 		bread
81						Coffee		X 		coffee
82						Donut		X 		donut+
83					"RadioButtons"	S							s5
84						"Red"		R 		color
85						"Green"		R 		color+
86						"Blue"		R 		color
87						"~!@#%^&*()_+{}: <>?`-=;',./" R color
88				}
89				"Local" M:opts2 {
90					"Default" M:local1+ {
91						"CheckButtons"	S						s6
92							Square  	X@		square
93							Triangle	X@		triangle+
94							rectangle	X@		rectangle
95						"RadioButtons"	S						s7
96							"Magenta"	R@ 		ryb+
97							"Yellow"	R@ 		ryb
98							"Cyan"		R@ 		ryb
99					}
100					"Notebook Tab" M:local2+ {
101						"CheckButtons"	S						s8
102							Right  		X=		right
103							Left		X=		left+
104							Top			X=		top
105						"RadioButtons"	S						s9
106							"North"		R= 		compass+
107							"South"		R= 		compass
108							"East"		R= 		compass
109					}
110				}
111			}
112 			Macros M:macros+ {
113 			#	Label				Type	Tag Name(s)
114 			#	-----------------	----	---------
115				"Add Item" 			C		item_add
116				"Delete Item" 		C		item_delete
117				"Add MARK Item" 	C		mark_add
118				"Move MARK Up"  	C		mark_up
119				"Move MARK Down"	C		mark_down
120				"Delete MARK"		C		mark_del
121				"Macros"		  	C 		macro_entries
122				"Save Macros"  		C		serialize
123				"Restore Macros" 	C		deserialize
124				--COMMANDGROUP--	G		macro
125 			}
126			Debug M:debug {
127			#   Label				Type	Tag Name(s)
128			#   ----------------- 	----	---------
129				"Test tag.cget"		C 		testcget
130				"Debug Tree"		C 		debug_tree
131				"Debug Nodes"		C 		debug_nodes
132				"Debug Installs"	C 		debug_installs
133				"Debug notebook"	C 		debug_notebook
134				"ptree"				C 		ptree
135				"pnodes"			C 		pnodes
136				"pkeys"				C 		pkeys
137			}
138			Help M:help {
139			#   Label				Type	Tag Name(s)
140			#   ----------------- 	----	---------
141				About			  	C 		about
142				--					S						s10
143				Clear			  	C 		clear
144			}
145		}
146
147		NewWindow
148
149	}
150
151	proc NewWindow { args } {
152		variable mbar
153		variable wid
154
155		# create pathname for new toplevel window
156		set w ".top${wid}"
157		incr wid
158
159		Gui new ${wid} ${w} ${mbar}
160	}
161}
162
163# --
164#
165oo::class create Gui {
166
167	# ----------------------------------------
168	# Create a toplevel with a menu bar
169	constructor { wid w menubar } {
170		my variable mbar
171		my variable wtop
172		my variable nb
173		my variable tout
174		my variable tabvars
175
176		##
177		## Create toplevel window
178		##
179
180		set wtop ${w}
181		toplevel ${wtop}
182		wm withdraw ${wtop}
183
184		##
185		## Define the GUI
186		##
187
188		# -- note
189		# This demo doesn't use the notebook frames.
190		# A real application would include gui elements in the
191		# notebook frames.
192
193		set nb [ttk::notebook ${wtop}.nb]
194		set tout [text ${wtop}.t -height 12]
195		grid ${nb} -sticky news
196		grid ${tout} -sticky news
197		grid rowconfigure ${wtop} 1 -weight 1
198		grid rowconfigure ${wtop} 2 -weight 0
199
200		# add binding for notebook tabs
201		bind ${nb} "<<NotebookTabChanged>>" [list [self object] nbTabSelect ${wtop}]
202
203		##
204		## Install & Configure the menu bar
205		##
206
207		set mbar ${menubar}
208
209		${mbar} install ${wtop} {
210
211			# Create tags for this windows text widget. They will be
212			# used by the menubar callbacks to direct output to the
213			# text widget.
214			${mbar} tag.add tout ${tout}
215			${mbar} tag.add gui [self object]
216
217			${mbar} menu.configure -command {
218				# file menu
219				new				{::Main::NewWindow}
220				mshow			{my mShow}
221				mhide			{my mHide}
222				paste_state		{my TogglePasteState}
223				close			{my Close}
224				exit			{my Exit}
225				# Item menu
226				cut				{my Edit cut}
227				copy			{my Edit copy}
228				paste			{my Edit paste}
229				# boolean menu
230				apple	     	{my BoolToggle}
231				bread	     	{my BoolToggle}
232				coffee	     	{my BoolToggle}
233				donut	     	{my BoolToggle}
234				square	     	{my BoolToggle}
235				triangle     	{my BoolToggle}
236				rectangle     	{my BoolToggle}
237				left     		{my NotebookBoolToggle}
238				right     		{my NotebookBoolToggle}
239				top    			{my NotebookBoolToggle}
240				# radio menu
241				color	     	{my RadioToggle}
242				ryb		     	{my RadioToggle}
243				compass	     	{my NotebookRadioToggle}
244				# Help menu
245				about			{my About}
246				clear			{my Clear}
247			} -state {
248				mhide	    	disabled
249				paste	    	disabled
250			} -bind {
251				exit		{1 Cntl+Q  Control-Key-q}
252				cut			{2 Cntl+X  Control-Key-x}
253				copy		{0 Cntl+C  Control-Key-c}
254				paste		{0 Cntl+V  Control-Key-v}
255				apple		{0 Cntl+A  Control-Key-a}
256				bread		{0 Cntl+B  Control-Key-b}
257				about		0
258				clear		{0 {}	  Control-Key-d}
259			} -background {
260				exit red
261			} -foreground {
262				exit white
263			}
264
265
266			# change the namespace for commands associated the
267			# 'macros' commands and 'macro' command group
268			${mbar} menu.namespace macros ::Macros
269			${mbar} menu.namespace macro  ::Macros
270
271			# configure the macros menu
272			${mbar} menu.configure -command {
273				item_add		{NewItem}
274				item_delete		{DeleteItem}
275				mark_add		{Mark add}
276				mark_up			{Mark up}
277				mark_down		{Mark down}
278				mark_del		{Mark delete}
279				macro_entries	{Macros}
280				serialize		{Serialize}
281				deserialize		{Deserialize}
282			} -bind {
283				item_add	{0 Cntl+I  Control-Key-i}
284				mark_add	{0 Cntl+m  Control-Key-m}
285				mark_up		{0 Cntl+U  Control-Key-u}
286				mark_down	{0 Cntl+J  Control-Key-j}
287				mark_del	{0 Cntl+K  Control-Key-k}
288			}
289
290			# initally hide the macros menu
291			${mbar} menu.hide macros
292
293			# hide the debugging menu unless the package is loaded
294			if { [catch {package present menubar::debug}] } {
295				${mbar} menu.hide debug
296			} else {
297				${mbar} menu.configure -command {
298					testcget		{my TestCget}
299					debug_tree		{my Debug tree}
300					debug_nodes		{my Debug nodes}
301					debug_installs	{my Debug installs}
302					debug_notebook	{my Debug notebook}
303					ptree			{my print tree}
304					pnodes			{my print nodes}
305					pkeys			{my print keys}
306				}
307			}
308		}
309
310		# After the menubar is installed we add 3 tabs
311		# to its widget scope.
312		my nbNewTab "One"
313		my nbNewTab "Two"
314		my nbNewTab "Three"
315
316		wm minsize ${wtop} 300 300
317		wm geometry ${wtop} 300x300+[expr ${wid}*20]+[expr ${wid}*20]
318		wm protocol ${wtop} WM_DELETE_WINDOW [list [self object] closeWindow ${wtop}]
319		wm title ${wtop} "Menubar Demo"
320		wm focusmodel ${wtop} active
321		wm deiconify ${wtop}
322
323		return
324	}
325
326	method pout { txt } {
327		my variable wtop
328		my variable mbar
329		set tout [${mbar} tag.cget ${wtop} tout]
330		${tout} insert end "${txt}\n"
331	}
332
333	method nbNewTab { text } {
334		my variable mbar
335		my variable wtop
336		my variable nb
337		set tabid [${nb} index end]
338		incr tabid
339		set tabwin ${wtop}.tab${tabid}
340		${nb} add [frame ${tabwin}] -text ${text}
341		${mbar} notebook.addTabStore ${tabwin}
342	}
343
344	method nbTabSelect { wtop args } {
345		my variable mbar
346		my variable nb
347		my Clear
348		# restore tab values
349		set tabwin [${nb} select]
350		${mbar} notebook.restoreTabValues ${tabwin}
351		my pout "Tab Selected: ${tabwin}"
352	}
353
354	method mShow { args } {
355		my variable mbar
356		${mbar} menu.show macros
357		${mbar} menu.configure -state {
358			mshow		disabled
359			mhide		normal
360		}
361	}
362
363	method mHide { args } {
364		my variable mbar
365		${mbar} menu.hide macros
366		${mbar} menu.configure -state {
367			mshow		normal
368			mhide		disabled
369		}
370	}
371
372	method closeWindow { wtop } {
373		my variable mbar
374		destroy ${wtop}
375		# check to see if we closed the last window
376		if { [winfo children .] eq ""  } {
377			my Exit
378		}
379	}
380
381	method Close { args } {
382		my closeWindow {*}${args}
383	}
384
385	method Exit { args } {
386		puts "Goodbye"
387		exit
388	}
389
390	method Debug { args } {
391		my variable wtop
392		my variable mbar
393		lassign ${args} type
394		my Clear
395		foreach line [${mbar} debug ${type}] {
396			my pout ${line}
397		}
398	}
399	method Clear { args } {
400		my variable wtop
401		my variable mbar
402		set tout [${mbar} tag.cget ${wtop} tout]
403		${tout} delete 0.0 end
404	}
405
406	method TestCget { args } {
407		my variable wtop
408		my variable mbar
409		my Clear
410		my pout "user define tag: tout = [${mbar} tag.cget ${wtop} tout]"
411		my pout "Command tag: exit -background = [${mbar} tag.cget ${wtop} exit -background]"
412		my pout "Checkbutton tag: apple -state = [${mbar} tag.cget ${wtop} apple -state]"
413		my pout "Radiobutton tag: color -state = [${mbar} tag.cget ${wtop} color -state]"
414		my pout "Cascade tag: chx -background = [${mbar} tag.cget ${wtop} chx -background]"
415	}
416
417	method Edit { args } {
418		my pout "Edit: [join ${args} {, }]"
419	}
420
421	method TogglePasteState { args } {
422		my variable mbar
423		my pout "TogglePasteState: [join ${args} {, }]"
424		lassign ${args} wtop
425		set value [${mbar} tag.cget ${wtop} paste -state]
426		if { [${mbar} tag.cget ${wtop} paste -state] eq "normal" } {
427			${mbar} tag.configure ${wtop} paste -state "disabled" -background {}
428		} else {
429			${mbar} tag.configure ${wtop} paste -state "normal" -background green
430		}
431	}
432
433	method BoolToggle { args } {
434		my variable wtop
435		my variable mbar
436		my variable nb
437		my pout "BoolToggle: [join ${args} {, }]"
438	}
439
440	method RadioToggle { args } {
441		my variable wtop
442		my variable mbar
443		my variable nb
444		my pout "RadioToggle: [join ${args} {, }]"
445	}
446
447	method NotebookBoolToggle { args } {
448		my variable wtop
449		my variable mbar
450		my variable nb
451		my pout "NotebookBoolToggle: [join ${args} {, }]"
452		lassign ${args} wtop tag val
453		set tabwin [${nb} select]
454		${mbar} notebook.setTabValue ${tabwin} ${tag}
455	}
456
457	method NotebookRadioToggle { args } {
458		my variable wtop
459		my variable mbar
460		my variable nb
461		my pout "NotebookRadioToggle: [join ${args} {, }]"
462		lassign ${args} wtop tag val
463		set tabwin [${nb} select]
464		${mbar} notebook.setTabValue ${tabwin} ${tag}
465	}
466
467	method About { args } {
468		my pout "MenuBar Demo 0.5"
469	}
470
471	method print { args } {
472		my variable mbar
473		lassign ${args} type wtop
474		${mbar} print ${type}
475	}
476}
477
478# --
479#
480namespace eval Macros {
481
482	variable next 0
483	variable stream
484	variable stream_next
485
486	proc Mark { args } {
487		set mbar $::Main::mbar
488
489		lassign ${args} action wtop
490		set gui [${mbar} tag.cget ${wtop} gui]
491
492		set errno 0
493		switch -exact -- ${action} {
494		"add"	 {
495			set errno [${mbar} group.add macro MARK {Mout "MARK"} Cntl+0 Control-Key-0]
496 			if { ${errno} != 0 } {
497				${gui} pout "warning: MARK already exists"
498 			} else {
499 				${mbar} group.configure macro MARK \
500 					-background tan \
501					-foreground white
502 			}
503		}
504		"delete" {
505			set errno [${mbar} group.delete macro MARK]
506			if { ${errno} != 0 } {
507				${gui} pout  "warning: MARK not found"
508			}
509		}
510		"up"	 {
511			set errno [${mbar} group.move up macro MARK]
512 			if { ${errno} != 0 } {
513				${gui} pout "warning: MARK move up failed"
514 			}
515		}
516		"down"	 {
517			set errno [${mbar} group.move down macro MARK]
518 			if { ${errno} != 0 } {
519				${gui} pout "warning: MARK move down failed"
520 			}
521		}}
522	}
523
524	proc NewItem { args } {
525		variable next
526		if { ${next} == 9 } { return }
527		incr next
528		set mbar $::Main::mbar
529		set errno [${mbar} group.add macro Item${next} "Mout item${next}" Cntl+${next} Control-Key-${next}]
530 		if { ${errno} != 0 } {
531			lassign ${args} wtop
532			set gui [${mbar} tag.cget ${wtop} gui]
533			${gui} pout "warning: Item${next} already exists"
534 		}
535	}
536
537	proc DeleteItem { args } {
538		variable next
539		set mbar $::Main::mbar
540		set item "Item${next}"
541		${mbar} group.delete macro ${item}
542		if { ${next} > 0 } {
543			incr next -1
544		}
545	}
546
547	proc Macros { args } {
548		set mbar $::Main::mbar
549		puts "---"
550		puts [${mbar} group.entries macro]
551	}
552
553	proc Serialize { args } {
554		variable next
555		variable stream
556		variable stream_next
557		set mbar $::Main::mbar
558		set stream [${mbar} group.serialize macro]
559		set stream_next ${next}
560		puts "---"
561		puts ${stream}
562	}
563
564	proc Deserialize { args } {
565		variable next
566		variable stream
567		variable stream_next
568		set next ${stream_next}
569		set mbar $::Main::mbar
570		${mbar} group.deserialize macro ${stream}
571	}
572
573	proc Mout { args } {
574		set mbar $::Main::mbar
575		lassign ${args} action wtop
576		set gui [${mbar} tag.cget ${wtop} gui]
577		${gui} pout  "Mout: [join ${args} {, }]"
578	}
579}
580
581
582Main::main
583