Mercurial > hg > xemacs-beta
annotate lisp/wid-browse.el @ 5882:bbe4146603db
Reduce regexp usage, now CL-oriented non-regexp code available, core Lisp
lisp/ChangeLog addition:
2015-04-01 Aidan Kehoe <kehoea@parhasard.net>
When calling #'string-match with a REGEXP without regular
expression special characters, call #'search, #'mismatch, #'find,
etc. instead, making our code less likely to side-effect other
functions' match data and a little faster.
* apropos.el (apropos-command):
* apropos.el (apropos):
Call (position ?\n ...) rather than (string-match "\n" ...) here.
* buff-menu.el:
* buff-menu.el (buffers-menu-omit-invisible-buffers):
Don't fire up the regexp engine just to check if a string starts
with a space.
* buff-menu.el (select-buffers-tab-buffers-by-mode):
Don't fire up the regexp engine just to compare mode basenames.
* buff-menu.el (format-buffers-tab-line):
* buff-menu.el (build-buffers-tab-internal): Moved to being a
label within the following.
* buff-menu.el (buffers-tab-items): Use the label.
* bytecomp.el (byte-compile-log-1):
Don't fire up the regexp engine just to look for a newline.
* cus-edit.el (get):
Ditto.
* cus-edit.el (custom-variable-value-create):
Ditto, but for a colon.
* descr-text.el (describe-text-sexp):
Ditto.
* descr-text.el (describe-char-unicode-data):
Use #'split-string-by-char given that we're just looking for a
semicolon.
* descr-text.el (describe-char):
Don't fire up the regexp engine just to look for a newline.
* disass.el (disassemble-internal):
Ditto.
* files.el (file-name-sans-extension):
Implement this using #'position.
* files.el (file-name-extension):
Correct this function's docstring, implement it in terms of
#'position.
* files.el (insert-directory):
Don't fire up the regexp engine to split a string by space; don't
reverse the list of switches, this is actually a longstand bug as
far as I can see.
* gnuserv.el (gnuserv-process-filter):
Use #'position here, instead of consing inside #'split-string
needlessly.
* gtk-file-dialog.el (gtk-file-dialog-update-dropdown):
Use #'split-string-by-char here, don't fire up #'split-string for
directory-sep-char.
* gtk-font-menu.el (hack-font-truename):
Implement this more cheaply in terms of #'find,
#'split-string-by-char, #'equal, rather than #'string-match,
#'split-string, #'string-equal.
* hyper-apropos.el (hyper-apropos-grok-functions):
* hyper-apropos.el (hyper-apropos-grok-variables):
Look for a newline using #'position rather than #'string-match in
these functions.
* info.el (Info-insert-dir):
* info.el (Info-insert-file-contents):
* info.el (Info-follow-reference):
* info.el (Info-extract-menu-node-name):
* info.el (Info-menu):
Look for fixed strings using #'position or #'search as appropriate
in this file.
* ldap.el (ldap-decode-string):
* ldap.el (ldap-encode-string):
#'encode-coding-string, #'decode-coding-string are always
available, don't check if they're fboundp.
* ldap.el (ldap-decode-address):
* ldap.el (ldap-encode-address):
Use #'split-string-by-char in these functions.
* lisp-mnt.el (lm-creation-date):
* lisp-mnt.el (lm-last-modified-date):
Don't fire up the regexp engine just to look for spaces in this file.
* menubar-items.el (default-menubar):
Use (not (mismatch ...)) rather than #'string-match here, for
simple regexp.
Use (search "beta" ...) rather than (string-match "beta" ...)
* menubar-items.el (sort-buffers-menu-alphabetically):
* menubar-items.el (sort-buffers-menu-by-mode-then-alphabetically):
* menubar-items.el (group-buffers-menu-by-mode-then-alphabetically):
Don't fire up the regexp engine to check if a string starts with
a space or an asterisk.
Use the more fine-grained results of #'compare-strings; compare
case-insensitively for the buffer menu.
* menubar-items.el (list-all-buffers):
* menubar-items.el (tutorials-menu-filter):
Use #'equal rather than #'string-equal, which, in this context,
has the drawback of not having a bytecode, and no redeeming
features.
* minibuf.el:
* minibuf.el (un-substitute-in-file-name):
Use #'count, rather than counting the occurences of $ using the
regexp engine.
* minibuf.el (read-file-name-internal-1):
Don't fire up the regexp engine to search for ?=.
* mouse.el (mouse-eval-sexp):
Check for newline with #'find.
* msw-font-menu.el (mswindows-reset-device-font-menus):
Split a string by newline with #'split-string-by-char.
* mule/japanese.el:
* mule/japanese.el ("Japanese"):
Use #'search rather than #'string-match; canoncase before
comparing; fix a bug I had introduced where I had been making case
insensitive comparisons where the case mattered.
* mule/korea-util.el (default-korean-keyboard):
Look for ?3 using #'find, not #'string-march.
* mule/korea-util.el (quail-hangul-switch-hanja):
Search for a fixed string using #'search.
* mule/mule-cmds.el (set-locale-for-language-environment):
#'position, #'substitute rather than #'string-match,
#'replace-in-string.
* newcomment.el (comment-make-extra-lines):
Use #'search rather than #'string-match for a simple string.
* package-get.el (package-get-remote-filename):
Use #'position when looking for ?@
* process.el (setenv):
* process.el (read-envvar-name):
Use #'position when looking for ?=.
* replace.el (map-query-replace-regexp):
Use #'split-string-by-char instead of using an inline
implementation of it.
* select.el (select-convert-from-cf-text):
* select.el (select-convert-from-cf-unicodetext):
Use #'position rather than #'string-match in these functions.
* setup-paths.el (paths-emacs-data-root-p):
Use #'search when looking for simple string.
* sound.el (load-sound-file):
Use #'split-string-by-char rather than an inline reimplementation
of same.
* startup.el (splash-screen-window-body):
* startup.el (splash-screen-tty-body):
Search for simple strings using #'search.
* version.el (emacs-version):
Ditto.
* x-font-menu.el (hack-font-truename):
Implement this more cheaply in terms of #'find,
#'split-string-by-char, #'equal, rather than #'string-match,
#'split-string, #'string-equal.
* x-font-menu.el (x-reset-device-font-menus-core):
Use #'split-string-by-char here.
* x-init.el (x-initialize-keyboard):
Search for a simple string using #'search.
author | Aidan Kehoe <kehoea@parhasard.net> |
---|---|
date | Wed, 01 Apr 2015 14:28:20 +0100 |
parents | 308d34e9f07d |
children |
rev | line source |
---|---|
209 | 1 ;;; wid-browse.el --- Functions for browsing widgets. |
2 ;; | |
3 ;; Copyright (C) 1997 Free Software Foundation, Inc. | |
4 ;; | |
5 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk> | |
6 ;; Keywords: extensions | |
7 ;; Version: 1.9960 | |
8 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ | |
9 | |
613 | 10 ;; This file is part of XEmacs. |
209 | 11 |
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
613
diff
changeset
|
12 ;; XEmacs is free software: you can redistribute it and/or modify it |
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
613
diff
changeset
|
13 ;; under the terms of the GNU General Public License as published by the |
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
613
diff
changeset
|
14 ;; Free Software Foundation, either version 3 of the License, or (at your |
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
613
diff
changeset
|
15 ;; option) any later version. |
209 | 16 |
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
613
diff
changeset
|
17 ;; XEmacs is distributed in the hope that it will be useful, but WITHOUT |
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
613
diff
changeset
|
18 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or |
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
613
diff
changeset
|
19 ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License |
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
613
diff
changeset
|
20 ;; for more details. |
209 | 21 |
22 ;; You should have received a copy of the GNU General Public License | |
5402
308d34e9f07d
Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents:
613
diff
changeset
|
23 ;; along with XEmacs. If not, see <http://www.gnu.org/licenses/>. |
209 | 24 |
25 ;;; Commentary: | |
26 ;; | |
27 ;; Widget browser. See `widget.el'. | |
28 | |
29 ;;; Code: | |
30 | |
31 (require 'easymenu) | |
32 (require 'custom) | |
33 (require 'wid-edit) | |
34 (eval-when-compile (require 'cl)) | |
35 | |
36 (defgroup widget-browse nil | |
37 "Customization support for browsing widgets." | |
38 :group 'widgets) | |
39 | |
40 ;;; The Mode. | |
41 | |
42 (defvar widget-browse-mode-map nil | |
43 "Keymap for `widget-browse-mode'.") | |
44 | |
45 (unless widget-browse-mode-map | |
46 (setq widget-browse-mode-map (make-sparse-keymap)) | |
47 (set-keymap-parent widget-browse-mode-map widget-keymap) | |
48 (define-key widget-browse-mode-map "q" 'bury-buffer)) | |
49 | |
50 (easy-menu-define widget-browse-mode-customize-menu | |
51 widget-browse-mode-map | |
52 "Menu used in widget browser buffers." | |
53 (customize-menu-create 'widgets)) | |
54 | |
55 (easy-menu-define widget-browse-mode-menu | |
56 widget-browse-mode-map | |
57 "Menu used in widget browser buffers." | |
58 '("Widget" | |
59 ["Browse" widget-browse t] | |
60 ["Browse At" widget-browse-at t])) | |
61 | |
62 (defcustom widget-browse-mode-hook nil | |
63 "Hook called when entering widget-browse-mode." | |
64 :type 'hook | |
65 :group 'widget-browse) | |
66 | |
67 (defun widget-browse-mode () | |
68 "Major mode for widget browser buffers. | |
69 | |
70 The following commands are available: | |
71 | |
72 \\[widget-forward] Move to next button or editable field. | |
73 \\[widget-backward] Move to previous button or editable field. | |
74 \\[widget-button-click] Activate button under the mouse pointer. | |
75 \\[widget-button-press] Activate button under point. | |
76 | |
77 Entry to this mode calls the value of `widget-browse-mode-hook' | |
78 if that value is non-nil." | |
79 (kill-all-local-variables) | |
80 (setq major-mode 'widget-browse-mode | |
81 mode-name "Widget") | |
82 (use-local-map widget-browse-mode-map) | |
83 (easy-menu-add widget-browse-mode-customize-menu) | |
84 (easy-menu-add widget-browse-mode-menu) | |
85 (run-hooks 'widget-browse-mode-hook)) | |
86 | |
87 ;;; Commands. | |
88 | |
89 ;;;###autoload | |
90 (defun widget-browse-at (pos) | |
91 "Browse the widget under point." | |
92 (interactive "d") | |
93 (let* ((field (get-char-property pos 'field)) | |
94 (button (get-char-property pos 'button)) | |
95 (doc (get-char-property pos 'widget-doc)) | |
96 (text (cond (field "This is an editable text area.") | |
97 (button "This is an active area.") | |
98 (doc "This is documentation text.") | |
99 (t "This is unidentified text."))) | |
100 (widget (or field button doc))) | |
101 (when widget | |
102 (widget-browse widget)) | |
103 (message text))) | |
104 | |
105 (defvar widget-browse-history nil) | |
106 | |
107 ;;;###autoload | |
108 (defun widget-browse (widget) | |
109 "Create a widget browser for WIDGET." | |
110 (interactive (list (completing-read "Widget: " | |
111 obarray | |
112 (lambda (symbol) | |
113 (get symbol 'widget-type)) | |
114 t nil 'widget-browse-history))) | |
115 (if (stringp widget) | |
116 (setq widget (intern widget))) | |
117 (unless (if (symbolp widget) | |
118 (get widget 'widget-type) | |
119 (and (consp widget) | |
120 (get (widget-type widget) 'widget-type))) | |
121 (error "Not a widget.")) | |
122 ;; Create the buffer. | |
123 (if (symbolp widget) | |
124 (let ((buffer (format "*Browse %s Widget*" widget))) | |
125 (kill-buffer (get-buffer-create buffer)) | |
126 (switch-to-buffer (get-buffer-create buffer))) | |
127 (kill-buffer (get-buffer-create "*Browse Widget*")) | |
128 (switch-to-buffer (get-buffer-create "*Browse Widget*"))) | |
129 (widget-browse-mode) | |
130 | |
131 ;; Quick way to get out. | |
132 ;; (widget-create 'push-button | |
133 ;; :action (lambda (widget &optional event) | |
134 ;; (bury-buffer)) | |
135 ;; "Quit") | |
136 ;; (widget-insert "\n") | |
137 | |
138 ;; Top text indicating whether it is a class or object browser. | |
139 (if (listp widget) | |
140 (widget-insert "Widget object browser.\n\nClass: ") | |
141 (widget-insert "Widget class browser.\n\n") | |
142 (widget-create 'widget-browse | |
143 :format "%[%v%]\n%d" | |
144 :doc (get widget 'widget-documentation) | |
145 widget) | |
146 (unless (eq (preceding-char) ?\n) | |
147 (widget-insert "\n")) | |
148 (widget-insert "\nSuper: ") | |
149 (setq widget (get widget 'widget-type))) | |
150 | |
151 ;; Now show the attributes. | |
152 (let ((name (car widget)) | |
153 (items (cdr widget)) | |
154 key value printer) | |
155 (widget-create 'widget-browse | |
156 :format "%[%v%]" | |
157 name) | |
158 (widget-insert "\n") | |
159 (while items | |
160 (setq key (nth 0 items) | |
161 value (nth 1 items) | |
162 printer (or (get key 'widget-keyword-printer) | |
163 'widget-browse-sexp) | |
164 items (cdr (cdr items))) | |
165 (widget-insert "\n" (symbol-name key) "\n\t") | |
166 (funcall printer widget key value) | |
167 (widget-insert "\n"))) | |
168 (widget-setup) | |
169 (goto-char (point-min))) | |
170 | |
171 ;;;###autoload | |
172 (defun widget-browse-other-window (&optional widget) | |
173 "Show widget browser for WIDGET in other window." | |
174 (interactive) | |
175 (let ((window (selected-window))) | |
176 (switch-to-buffer-other-window "*Browse Widget*") | |
177 (if widget | |
178 (widget-browse widget) | |
179 (call-interactively 'widget-browse)) | |
180 (select-window window))) | |
181 | |
182 | |
183 ;;; The `widget-browse' Widget. | |
184 | |
185 (define-widget 'widget-browse 'push-button | |
186 "Button for creating a widget browser. | |
187 The :value of the widget shuld be the widget to be browsed." | |
188 :format "%[[%v]%]" | |
189 :value-create 'widget-browse-value-create | |
190 :action 'widget-browse-action) | |
191 | |
192 (defun widget-browse-action (widget &optional event) | |
193 ;; Create widget browser for WIDGET's :value. | |
194 (widget-browse (widget-get widget :value))) | |
195 | |
196 (defun widget-browse-value-create (widget) | |
197 ;; Insert type name. | |
198 (let ((value (widget-get widget :value))) | |
199 (cond ((symbolp value) | |
200 (insert (symbol-name value))) | |
201 ((consp value) | |
202 (insert (symbol-name (widget-type value)))) | |
203 (t | |
204 (insert "strange"))))) | |
205 | |
206 ;;; Keyword Printer Functions. | |
207 | |
208 (defun widget-browse-widget (widget key value) | |
209 "Insert description of WIDGET's KEY VALUE. | |
210 VALUE is assumed to be a widget." | |
211 (widget-create 'widget-browse value)) | |
212 | |
213 (defun widget-browse-widgets (widget key value) | |
214 "Insert description of WIDGET's KEY VALUE. | |
215 VALUE is assumed to be a list of widgets." | |
216 (while value | |
217 (widget-create 'widget-browse | |
218 (car value)) | |
219 (setq value (cdr value)) | |
220 (when value | |
221 (widget-insert " ")))) | |
222 | |
223 (defun widget-browse-sexp (widget key value) | |
224 "Insert description of WIDGET's KEY VALUE. | |
225 Nothing is assumed about value." | |
226 (let ((pp (condition-case signal | |
502 | 227 (declare-fboundp (pp-to-string value)) |
209 | 228 (error (prin1-to-string signal))))) |
229 (when (string-match "\n\\'" pp) | |
230 (setq pp (substring pp 0 (1- (length pp))))) | |
231 (if (cond ((string-match "\n" pp) | |
232 nil) | |
233 ((> (length pp) (- (window-width) (current-column))) | |
234 nil) | |
235 (t t)) | |
236 (widget-insert pp) | |
237 (widget-create 'push-button | |
238 :tag "show" | |
239 :action (lambda (widget &optional event) | |
240 (with-output-to-temp-buffer | |
241 "*Pp Eval Output*" | |
242 (princ (widget-get widget :value)))) | |
243 pp)))) | |
244 | |
245 (defun widget-browse-sexps (widget key value) | |
246 "Insert description of WIDGET's KEY VALUE. | |
247 VALUE is assumed to be a list of widgets." | |
248 (let ((target (current-column))) | |
249 (while value | |
250 (widget-browse-sexp widget key (car value)) | |
251 (setq value (cdr value)) | |
252 (when value | |
253 (widget-insert "\n" (make-string target ?\ )))))) | |
254 | |
255 ;;; Keyword Printers. | |
256 | |
257 (put :parent 'widget-keyword-printer 'widget-browse-widget) | |
258 (put :children 'widget-keyword-printer 'widget-browse-widgets) | |
259 (put :buttons 'widget-keyword-printer 'widget-browse-widgets) | |
260 (put :button 'widget-keyword-printer 'widget-browse-widget) | |
261 (put :args 'widget-keyword-printer 'widget-browse-sexps) | |
262 | |
263 ;;; Widget Minor Mode. | |
264 | |
265 (defvar widget-minor-mode nil | |
266 "I non-nil, we are in Widget Minor Mode.") | |
267 (make-variable-buffer-local 'widget-minor-mode) | |
268 | |
269 (defvar widget-minor-mode-map nil | |
270 "Keymap used in Widget Minor Mode.") | |
271 | |
272 (unless widget-minor-mode-map | |
273 (setq widget-minor-mode-map (make-sparse-keymap)) | |
274 (set-keymap-parent widget-minor-mode-map widget-keymap)) | |
275 | |
276 ;;;###autoload | |
277 (defun widget-minor-mode (&optional arg) | |
278 "Togle minor mode for traversing widgets. | |
279 With arg, turn widget mode on if and only if arg is positive." | |
280 (interactive "P") | |
281 (cond ((null arg) | |
282 (setq widget-minor-mode (not widget-minor-mode))) | |
283 ((<= arg 0) | |
284 (setq widget-minor-mode nil)) | |
285 (t | |
286 (setq widget-minor-mode t))) | |
287 (force-mode-line-update)) | |
288 | |
289 (add-to-list 'minor-mode-alist '(widget-minor-mode " Widget")) | |
290 | |
291 (add-to-list 'minor-mode-map-alist | |
292 (cons 'widget-minor-mode widget-minor-mode-map)) | |
293 | |
294 ;;; The End: | |
295 | |
296 (provide 'wid-browse) | |
297 | |
298 ;; wid-browse.el ends here |