Mercurial > hg > xemacs-beta

comparison lisp/menubar-items.el @ 771:943eaba38521

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
[xemacs-hg @ 2002-03-13 08:51:24 by ben] The big ben-mule-21-5 check-in! Various files were added and deleted. See CHANGES-ben-mule. There are still some test suite failures. No crashes, though. Many of the failures have to do with problems in the test suite itself rather than in the actual code. I'll be addressing these in the next day or so -- none of the test suite failures are at all critical. Meanwhile I'll be trying to address the biggest issues -- i.e. build or run failures, which will almost certainly happen on various platforms. All comments should be sent to ben@xemacs.org -- use a Cc: if necessary when sending to mailing lists. There will be pre- and post- tags, something like pre-ben-mule-21-5-merge-in, and post-ben-mule-21-5-merge-in.
author ben
date Wed, 13 Mar 2002 08:54:06 +0000
parents b9b8621c2439
children 026c5bf9c134
comparison
equal deleted inserted replaced
770:336a418893b5 771:943eaba38521
1 ;;; menubar-items.el --- Menubar and popup-menu content for XEmacs. 1 ;;; menubar-items.el --- Menubar and popup-menu content for XEmacs.
2 2
3 ;; Copyright (C) 1991-1995, 1997-1998 Free Software Foundation, Inc. 3 ;; Copyright (C) 1991-1995, 1997-1998 Free Software Foundation, Inc.
4 ;; Copyright (C) 1995 Tinker Systems and INS Engineering Corp. 4 ;; Copyright (C) 1995 Tinker Systems and INS Engineering Corp.
5 ;; Copyright (C) 1995 Sun Microsystems. 5 ;; Copyright (C) 1995 Sun Microsystems.
6 ;; Copyright (C) 1995, 1996, 2000 Ben Wing. 6 ;; Copyright (C) 1995, 1996, 2000, 2001, 2002 Ben Wing.
7 ;; Copyright (C) 1997 MORIOKA Tomohiko. 7 ;; Copyright (C) 1997 MORIOKA Tomohiko.
8 8
9 ;; Maintainer: XEmacs Development Team 9 ;; Maintainer: XEmacs Development Team
10 ;; Keywords: frames, extensions, internal, dumped 10 ;; Keywords: frames, extensions, internal, dumped
11 11
126 (char-to-string (int-to-char (+ m (- (char-to-int ?a) 1)))) 126 (char-to-string (int-to-char (+ m (- (char-to-int ?a) 1))))
127 " ") 127 " ")
128 ""))) 128 "")))
129 (t ""))) 129 (t "")))
130 130
131 (defcustom menu-max-items 25
132 "*Maximum number of items in generated menus.
133 If number of entries in such a menu is larger than this value, split menu
134 into submenus of nearly equal length (see `menu-submenu-max-items'). If
135 nil, never split menu into submenus."
136 :group 'menu
137 :type '(choice (const :tag "no submenus" nil)
138 (integer)))
139
140 (defcustom menu-submenu-max-items 20
141 "*Maximum number of items in submenus when splitting menus.
142 We split large menus into submenus of this many items, and then balance
143 them out as much as possible (otherwise the last submenu may have very few
144 items)."
145 :group 'menu
146 :type 'integer)
147
148 (defcustom menu-submenu-name-format "%-12.12s ... %.12s"
149 "*Format specification of the submenu name when splitting menus.
150 Used by `menu-split-long-menu' if the number of entries in a menu is
151 larger than `menu-menu-max-items'.
152 This string should contain one %s for the name of the first entry and
153 one %s for the name of the last entry in the submenu.
154 If the value is a function, it should return the submenu name. The
155 function is be called with two arguments, the names of the first and
156 the last entry in the menu."
157 :group 'menu
158 :type '(choice (string :tag "Format string")
159 (function)))
160
161 (defun menu-split-long-menu (menu)
162 "Split MENU according to `menu-max-items' and add accelerator specs."
163 (let ((len (length menu)))
164 (if (or (null menu-max-items)
165 (<= len menu-max-items))
166 (submenu-generate-accelerator-spec menu)
167 (let* ((outer (/ (+ len (1- menu-submenu-max-items))
168 menu-submenu-max-items))
169 (inner (/ (+ len (1- outer)) outer))
170 (result nil))
171 (while menu
172 (let ((sub nil)
173 (from (car menu)))
174 (dotimes (foo (min inner len))
175 (setq sub (cons (car menu) sub)
176 menu (cdr menu)))
177 (setq len (- len inner))
178 (let ((to (car sub)))
179 (setq sub (nreverse sub))
180 (setq result
181 (cons (cons (if (stringp menu-submenu-name-format)
182 (format menu-submenu-name-format
183 (menu-item-strip-accelerator-spec
184 (aref from 0))
185 (menu-item-strip-accelerator-spec
186 (aref to 0)))
187 (funcall menu-submenu-name-format
188 (menu-item-strip-accelerator-spec
189 (aref from 0))
190 (menu-item-strip-accelerator-spec
191 (aref to 0))))
192 (submenu-generate-accelerator-spec sub))
193 result)))))
194 (submenu-generate-accelerator-spec (nreverse result))))))
195
196 (defun menu-sort-menu (menu)
197 "Sort MENU alphabetically."
198 (sort menu
199 #'(lambda (a b) (string-lessp (aref a 0) (aref b 0)))))
200
201 (defun coding-system-menu-filter (fun active &optional dots)
202 "Filter for menu entries with a submenu listing all coding systems.
203 This is for operations that take a coding system as an argument. FUN
204 should be a function of one argument, which will be a coding system symbol.
205 ACTIVE should be a function one argument (again, a coding system symbol),
206 indicating whether the entry is active. If DOTS is given, the menu entries
207 will have three dots appended.
208
209 Write your filter like this:
210
211 :filter
212 (lambda (menu)
213 (lambda (entry) ...)
214 (lambda (entry) ...))
215 "
216 (menu-split-long-menu
217 (menu-sort-menu
218 (mapcar
219 #'(lambda (_csmf_entry)
220 `[ ,(concat (coding-system-description _csmf_entry)
221 (if dots "..." ""))
222 (funcall ,fun ',_csmf_entry)
223 :active (funcall ,active ',_csmf_entry)
224 ])
225 (delete-if
226 #'(lambda (name)
227 (or (coding-system-alias-p name)
228 (not (eq name (coding-system-name
229 (coding-system-base name))))))
230 (coding-system-list))))))
231
131 (defconst default-menubar 232 (defconst default-menubar
132 ; (purecopy-menubar ;purespace is dead 233 ; (purecopy-menubar ;purespace is dead
133 ;; note backquote. 234 ;; note backquote.
134 `( 235 `(
135 ("%_File" 236 ("%_File"
136 ["%_Open..." find-file] 237 ["%_Open..." find-file]
137 ["Open in Other %_Window..." find-file-other-window] 238 ["Open in Other %_Window..." find-file-other-window]
138 ["Open in New %_Frame..." find-file-other-frame] 239 ["Open in New %_Frame..." find-file-other-frame]
240 ("Open with Specified %_Encoding"
241 :filter
242 (lambda (menu)
243 (coding-system-menu-filter
244 (lambda (entry)
245 (let ((coding-system-for-read entry))
246 (call-interactively 'find-file)))
247 (lambda (entry) t)
248 t))
249 )
139 ["%_Hex Edit File..." hexl-find-file 250 ["%_Hex Edit File..." hexl-find-file
140 :active (fboundp 'hexl-find-file)] 251 :active (fboundp 'hexl-find-file)]
141 ["%_Insert File..." insert-file] 252 ["%_Insert File..." insert-file]
142 ["%_View File..." view-file] 253 ["%_View File..." view-file]
143 "------" 254 "------"
162 :suffix (if put-buffer-names-in-file-menu (buffer-name) "")])) 273 :suffix (if put-buffer-names-in-file-menu (buffer-name) "")]))
163 "-----" 274 "-----"
164 ["%_Revert Buffer" revert-buffer 275 ["%_Revert Buffer" revert-buffer
165 :active (or buffer-file-name revert-buffer-function) 276 :active (or buffer-file-name revert-buffer-function)
166 :suffix (if put-buffer-names-in-file-menu (buffer-name) "")] 277 :suffix (if put-buffer-names-in-file-menu (buffer-name) "")]
278 ("Rever%_t Buffer with Specified Encoding"
279 :filter
280 (lambda (menu)
281 (coding-system-menu-filter
282 (lambda (entry)
283 (let ((coding-system-for-read entry))
284 (revert-buffer)))
285 (lambda (entry) (or buffer-file-name revert-buffer-function))
286 t))
287 )
167 ["Re%_cover File..." recover-file] 288 ["Re%_cover File..." recover-file]
168 ["Recover S%_ession..." recover-session] 289 ["Recover Sessio%_n..." recover-session]
169 "-----" 290 "-----"
170 ["E%_xit XEmacs" save-buffers-kill-emacs] 291 ["E%_xit XEmacs" save-buffers-kill-emacs]
171 ) 292 )
172 293
173 ("%_Edit" 294 ("%_Edit"
174 ["%_Undo" advertised-undo 295 ["%_Undo" undo
175 :active (and (not (eq buffer-undo-list t)) 296 :active (and (not (eq buffer-undo-list t))
176 (or buffer-undo-list pending-undo-list)) 297 (or buffer-undo-list pending-undo-list))
177 :suffix (if (or (eq last-command 'undo) 298 :suffix (if (eq last-command 'undo) "More" "")]
178 (eq last-command 'advertised-undo))
179 "More" "")]
180 ["%_Redo" redo 299 ["%_Redo" redo
181 :included (fboundp 'redo) 300 :included (fboundp 'redo)
182 :active (not (or (eq buffer-undo-list t) 301 :active (not (or (eq buffer-undo-list t)
183 (eq last-buffer-undo-list nil) 302 (eq last-buffer-undo-list nil)
184 (not (or (eq last-buffer-undo-list buffer-undo-list) 303 (not (or (eq last-buffer-undo-list buffer-undo-list)
204 ["Re%_select Region" activate-region :active (mark t)] 323 ["Re%_select Region" activate-region :active (mark t)]
205 "----" 324 "----"
206 ["%_Find..." make-search-dialog] 325 ["%_Find..." make-search-dialog]
207 ["R%_eplace..." query-replace] 326 ["R%_eplace..." query-replace]
208 ["Replace (Rege%_xp)..." query-replace-regexp] 327 ["Replace (Rege%_xp)..." query-replace-regexp]
209 ["%_List Matching Lines..." list-matching-lines] 328 ["List %_Matching Lines..." list-matching-lines]
210 ,@(when (featurep 'mule)
211 '("----"
212 ("%_Multilingual (\"Mule\")"
213 ("%_Describe Language Support")
214 ("%_Set Language Environment")
215 "--"
216 ["T%_oggle Input Method" toggle-input-method]
217 ["Select %_Input Method" set-input-method]
218 ["D%_escribe Input Method" describe-input-method]
219 "--"
220 ["Describe Current %_Coding Systems"
221 describe-current-coding-system]
222 ["Set Coding System of %_Buffer File..."
223 set-buffer-file-coding-system]
224 ;; not implemented yet
225 ["Set Coding System of %_Terminal..."
226 set-terminal-coding-system :active nil]
227 ;; not implemented yet
228 ["Set Coding System of %_Keyboard..."
229 set-keyboard-coding-system :active nil]
230 ["Set Coding System of %_Process..."
231 set-buffer-process-coding-system
232 :active (get-buffer-process (current-buffer))]
233 "--"
234 ["Show Cha%_racter Table" view-charset-by-menu]
235 ;; not implemented yet
236 ["Show Dia%_gnosis for MULE" mule-diag :active nil]
237 ["Show \"%_hello\" in Many Languages" view-hello-file]))
238 )
239 ) 329 )
240 330
241 ("%_View" 331 ("%_View"
242 ["%_New Frame" make-frame] 332 ["%_New Frame" make-frame]
243 ["Frame on Other Displa%_y..." make-frame-on-display 333 ["Frame on Other Displa%_y..." make-frame-on-display
467 (compilation-find-buffer) 557 (compilation-find-buffer)
468 (error nil)))) 558 (error nil))))
469 (and buffer (get-buffer-process buffer))))] 559 (and buffer (get-buffer-process buffer))))]
470 "---" 560 "---"
471 ["Grep %_All Files in Current Directory..." 561 ["Grep %_All Files in Current Directory..."
472 (progn 562 grep-all-files-in-current-directory
473 (require 'compile) 563 :active (fboundp 'grep-all-files-in-current-directory)]
474 (let ((grep-command 564 ["G%_rep All Files in Current Directory and Below..."
475 (cons (concat grep-command " *") 565 grep-all-files-in-current-directory-and-below
476 (length grep-command)))) 566 :active (fboundp 'grep-all-files-in-current-directory-and-below)]
477 (call-interactively 'grep))) 567 "---"
478 :active (fboundp 'grep)]
479 ["Grep %_C and C Header Files in Current Directory..." 568 ["Grep %_C and C Header Files in Current Directory..."
480 (progn 569 (progn
481 (require 'compile) 570 (require 'compile)
482 (let ((grep-command 571 (let ((grep-command
483 (cons (concat grep-command " *.[chCH]" 572 (cons (concat grep-command " *.[chCH]"
898 :style toggle 987 :style toggle
899 :selected (and (boundp 'smtpmail-debug-info) smtpmail-debug-info) 988 :selected (and (boundp 'smtpmail-debug-info) smtpmail-debug-info)
900 :active (and (boundp 'send-mail-function) 989 :active (and (boundp 'send-mail-function)
901 (eq send-mail-function 'smtpmail-send-it))]) 990 (eq send-mail-function 'smtpmail-send-it))])
902 ("%_Troubleshooting" 991 ("%_Troubleshooting"
903 ["%_Debug on Error" 992 ["%_Debug on Error [not saved]"
904 (customize-set-variable 'debug-on-error (not debug-on-error)) 993 (setq debug-on-error (not debug-on-error))
905 :style toggle :selected debug-on-error] 994 :style toggle :selected debug-on-error]
906 ["Debug on %_Quit" 995 ["Debug on %_Quit [not saved]"
907 (customize-set-variable 'debug-on-quit (not debug-on-quit)) 996 (setq debug-on-quit (not debug-on-quit))
908 :style toggle :selected debug-on-quit] 997 :style toggle :selected debug-on-quit]
909 ["Debug on S%_ignal" 998 ["Debug on S%_ignal [not saved]"
910 (customize-set-variable 'debug-on-signal (not debug-on-signal)) 999 (setq debug-on-signal (not debug-on-signal))
911 :style toggle :selected debug-on-signal] 1000 :style toggle :selected debug-on-signal]
912 ["%_Stack Trace on Error" 1001 ["%_Stack Trace on Error [not saved]"
913 (customize-set-variable 'stack-trace-on-error 1002 (setq stack-trace-on-error (not stack-trace-on-error))
914 (not stack-trace-on-error))
915 :style toggle :selected stack-trace-on-error] 1003 :style toggle :selected stack-trace-on-error]
916 ["Stack Trace on Si%_gnal" 1004 ["Stack Trace on Si%_gnal [not saved]"
917 (customize-set-variable 'stack-trace-on-signal 1005 (setq stack-trace-on-signal (not stack-trace-on-signal))
918 (not stack-trace-on-signal))
919 :style toggle :selected stack-trace-on-signal] 1006 :style toggle :selected stack-trace-on-signal]
920 ) 1007 )
1008 ("Encodin%_g"
1009 ["Automatic %_EOL Detection"
1010 (customize-set-variable 'eol-detection-enabled-p
1011 (not eol-detection-enabled-p))
1012 :style toggle
1013 :selected eol-detection-enabled-p
1014 :included (not (memq system-type '(windows-nt cygwin32)))]
1015 ("Set Coding System of %_Buffer File"
1016 :filter
1017 (lambda (menu)
1018 (coding-system-menu-filter
1019 (lambda (entry)
1020 (set-buffer-file-coding-system entry))
1021 (lambda (entry) t)
1022 ))
1023 )
1024 ;; not implemented yet
1025 ("Set Coding System of %_Terminal"
1026 :filter
1027 (lambda (menu)
1028 (coding-system-menu-filter
1029 (lambda (entry)
1030 (set-terminal-coding-system entry))
1031 (lambda (entry) nil)
1032 ))
1033 )
1034 ;; not implemented yet
1035 ("Set Coding System of %_Keyboard"
1036 :filter
1037 (lambda (menu)
1038 (coding-system-menu-filter
1039 (lambda (entry)
1040 (set-keyboard-coding-system entry))
1041 (lambda (entry) nil)
1042 ))
1043 )
1044 ("Set Coding System of %_Process"
1045 :filter
1046 (lambda (menu)
1047 (coding-system-menu-filter
1048 (lambda (entry)
1049 (set-buffer-process-coding-system entry))
1050 (lambda (entry) (get-buffer-process (current-buffer)))
1051 ))
1052 )
1053 )
1054 ,@(when (featurep 'mule)
1055 '(("Internationa%_l"
1056 ("Set %_Language Environment"
1057 :filter
1058 (lambda (menu)
1059 (menu-split-long-menu
1060 (menu-sort-menu
1061 (mapcar #'(lambda (entry)
1062 `[ ,(car entry)
1063 (set-language-environment ',(car entry))
1064 :style radio
1065 :selected
1066 ,(equal (car entry)
1067 current-language-environment)])
1068 language-info-alist)
1069 ))))
1070 ["%_Toggle Input Method" toggle-input-method]
1071 ["Select %_Input Method" set-input-method]
1072 )))
921 "-----" 1073 "-----"
922 ("%_Display" 1074 ("%_Display"
923 ,@(if (featurep 'scrollbar) 1075 ,@(if (featurep 'scrollbar)
924 '(["%_Scrollbars" 1076 '(["%_Scrollbars"
925 (customize-set-variable 'scrollbars-visible-p 1077 (customize-set-variable 'scrollbars-visible-p
1437 ["%_Recent Keys" view-lossage] 1589 ["%_Recent Keys" view-lossage]
1438 "-----" 1590 "-----"
1439 ["Describe %_Function..." describe-function] 1591 ["Describe %_Function..." describe-function]
1440 ["Describe %_Variable..." describe-variable] 1592 ["Describe %_Variable..." describe-variable]
1441 ["%_Locate Command in Keymap..." where-is]) 1593 ["%_Locate Command in Keymap..." where-is])
1594 ,@(when (featurep 'mule)
1595 '(("Internationa%_l"
1596 ("Describe %_Language Support"
1597 :filter
1598 (lambda (menu)
1599 (menu-split-long-menu
1600 (menu-sort-menu
1601 (mapcar #'(lambda (entry)
1602 `[ ,(car entry)
1603 (describe-language-environment
1604 ',(car entry))
1605 :style radio
1606 :selected
1607 ,(equal (car entry)
1608 current-language-environment)])
1609 language-info-alist)
1610 ))))
1611 ["Describe %_Input Method" describe-input-method]
1612 ["Describe Current %_Coding Systems"
1613 describe-current-coding-system]
1614 ["Show Character %_Table" view-charset-by-menu]
1615 ;; not implemented yet
1616 ["Show %_Diagnosis for MULE" mule-diag :active nil]
1617 ["Show \"%_hello\" in Many Languages" view-hello-file]
1618 )))
1442 ("%_Misc" 1619 ("%_Misc"
1443 ["%_Current Installation Info" describe-installation 1620 ["%_Current Installation Info" describe-installation
1444 :active (boundp 'Installation-string)] 1621 :active (boundp 'Installation-string)]
1445 ["%_No Warranty" describe-no-warranty] 1622 ["%_No Warranty" describe-no-warranty]
1446 ["XEmacs %_License" describe-copying] 1623 ["XEmacs %_License" describe-copying]
1451 ["%_Recent Messages" view-lossage] 1628 ["%_Recent Messages" view-lossage]
1452 ["Send %_Bug Report..." report-xemacs-bug 1629 ["Send %_Bug Report..." report-xemacs-bug
1453 :active (fboundp 'report-xemacs-bug)]))) 1630 :active (fboundp 'report-xemacs-bug)])))
1454 1631
1455 1632
1456 (defun maybe-add-init-button () 1633 (defun init-menubar-at-startup ()
1457 "Don't call this. 1634 "Don't call this.
1458 Adds `Load .emacs' button to menubar when starting up with -q." 1635 Adds `Load .emacs' button to menubar when starting up with -q."
1459 (when (and (not load-user-init-file-p) 1636 (when (and (not load-user-init-file-p)
1460 (file-exists-p (expand-file-name ".emacs" "~"))) 1637 (file-exists-p (expand-file-name ".emacs" "~")))
1461 (add-menu-button 1638 (add-menu-button
1467 (delete-menu-item '("Load .emacs")))) 1644 (delete-menu-item '("Load .emacs"))))
1468 (buffer-list)) 1645 (buffer-list))
1469 (load-user-init-file)) 1646 (load-user-init-file))
1470 ] 1647 ]
1471 "Help"))) 1648 "Help")))
1472
1473 (add-hook 'before-init-hook 'maybe-add-init-button)
1474 1649
1475 1650
1476 ;;; The File menu 1651 ;;; The File menu
1477 1652
1478 (defvar put-buffer-names-in-file-menu t) 1653 (defvar put-buffer-names-in-file-menu t)
1809 (setcdr lastcdr nil)))))) 1984 (setcdr lastcdr nil))))))
1810 (setq buffers (build-buffers-menu-internal buffers))) 1985 (setq buffers (build-buffers-menu-internal buffers)))
1811 (append menu buffers) 1986 (append menu buffers)
1812 )) 1987 ))
1813 1988
1814 (defun language-environment-menu-filter (menu)
1815 "This is the menu filter for the \"Language Environment\" submenu."
1816 (declare (special language-environment-list))
1817 (let ((n 0))
1818 (mapcar (lambda (env-sym)
1819 (setq n (1+ n))
1820 `[ ,(concat (menu-item-generate-accelerator-spec n)
1821 (capitalize (symbol-name env-sym)))
1822 (set-language-environment ',env-sym)])
1823 language-environment-list)))
1824
1825 1989
1826 ;;; The Options menu 1990 ;;; The Options menu
1827 1991
1828 ;; We'll keep those variables here for a while, in order to provide a 1992 ;; We'll keep those variables here for a while, in order to provide a
1829 ;; function for porting the old options file that a user may own to Custom. 1993 ;; function for porting the old options file that a user may own to Custom.
1875 ;; skip current language, since we already 2039 ;; skip current language, since we already
1876 ;; included it first 2040 ;; included it first
1877 (not (string= (car lang) 2041 (not (string= (car lang)
1878 current-language-environment)) 2042 current-language-environment))
1879 `([,(car lang) 2043 `([,(car lang)
1880 (help-with-tutorial nil ,(cdr tut))])))) 2044 (help-with-tutorial nil ,(car lang))]))))
1881 language-info-alist) 2045 language-info-alist)
1882 ;; Non mule tutorials. 2046 ;; Non mule tutorials.
1883 (mapcar #'(lambda (lang) 2047 (mapcar #'(lambda (lang)
1884 `[,(car lang) 2048 `[,(car lang)
1885 (help-with-tutorial ,(format "TUTORIAL.%s" 2049 (help-with-tutorial nil ,(car lang))])
1886 (cadr lang)))])
1887 tutorial-supported-languages))))) 2050 tutorial-supported-languages)))))
1888 2051
1889 (set-menubar default-menubar) 2052 (set-menubar default-menubar)
1890 2053
1891 2054