/[emacs]/emacs/lisp/descr-text.el
ViewVC logotype

Diff of /emacs/lisp/descr-text.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.4 by walters, Sat Jun 8 22:43:33 2002 UTC revision 1.4.2.1 by miles, Fri Apr 4 06:20:01 2003 UTC
# Line 35  Line 35 
35        (delete-window)        (delete-window)
36      (bury-buffer)))      (bury-buffer)))
37    
38  (defvar describe-text-mode-map  (defvar describe-text-mode-map
39    (let ((map (make-sparse-keymap)))    (let ((map (make-sparse-keymap)))
40      (set-keymap-parent map widget-keymap)      (set-keymap-parent map widget-keymap)
41      map)      map)
42    "Keymap for `describe-text-mode'.")    "Keymap for `describe-text-mode'.")
43      
44  (defcustom describe-text-mode-hook nil  (defcustom describe-text-mode-hook nil
45    "List of hook functions ran by `describe-text-mode'."    "List of hook functions ran by `describe-text-mode'."
46    :type 'hook)    :type 'hook
47      :group 'facemenu)
48    
49  (defun describe-text-mode ()  (defun describe-text-mode ()
50    "Major mode for buffers created by `describe-text-at'.    "Major mode for buffers created by `describe-char'.
51    
52  \\{describe-text-mode-map}  \\{describe-text-mode-map}
53  Entry to this mode calls the value of `describe-text-mode-hook'  Entry to this mode calls the value of `describe-text-mode-hook'
# Line 56  if that value is non-nil." Line 57  if that value is non-nil."
57          mode-name "Describe-Text")          mode-name "Describe-Text")
58    (use-local-map describe-text-mode-map)    (use-local-map describe-text-mode-map)
59    (widget-setup)    (widget-setup)
60      (add-hook 'change-major-mode-hook 'font-lock-defontify nil t)
61    (run-hooks 'describe-text-mode-hook))    (run-hooks 'describe-text-mode-hook))
62    
63  ;;; Describe-Text Utilities.  ;;; Describe-Text Utilities.
# Line 65  if that value is non-nil." Line 67  if that value is non-nil."
67    (widget-create 'link    (widget-create 'link
68                   :notify `(lambda (&rest ignore)                   :notify `(lambda (&rest ignore)
69                              (widget-browse ',widget))                              (widget-browse ',widget))
70                   (format "%S" (if (symbolp widget)                   (format "%S" (if (symbolp widget)
71                                    widget                                    widget
72                                  (car widget))))                                  (car widget))))
73    (widget-insert " ")    (widget-insert " ")
# Line 92  if that value is non-nil." Line 94  if that value is non-nil."
94                                   (princ (widget-get widget :value))))                                   (princ (widget-get widget :value))))
95                       pp))))                       pp))))
96    
97  (defun describe-text-properties (properties)  (defun describe-property-list (properties)
98    "Insert a description of PROPERTIES in the current buffer.    "Insert a description of PROPERTIES in the current buffer.
99  PROPERTIES should be a list of overlay or text properties.  PROPERTIES should be a list of overlay or text properties.
100  The `category' property is made into a widget button that call  The `category' property is made into a widget button that call
101  `describe-text-category' when pushed."  `describe-text-category' when pushed."
102    ;; Sort the properties by the size of their value.    ;; Sort the properties by the size of their value.
103    (dolist (elt (sort (let ((ret nil)    (dolist (elt (sort (let ((ret nil)
# Line 117  The `category' property is made into a w Line 119  The `category' property is made into a w
119                            (nth 2 b)))))                            (nth 2 b)))))
120      (let ((key (nth 0 elt))      (let ((key (nth 0 elt))
121            (value (nth 1 elt)))            (value (nth 1 elt)))
122        (widget-insert (propertize (format "  %-20s" key)        (widget-insert (propertize (format "  %-20s " key)
123                                   'font-lock-face 'italic))                                   'font-lock-face 'italic))
124        (cond ((eq key 'category)        (cond ((eq key 'category)
125               (widget-create 'link               (widget-create 'link
126                              :notify `(lambda (&rest ignore)                              :notify `(lambda (&rest ignore)
127                                         (describe-text-category ',value))                                         (describe-text-category ',value))
128                              (format "%S" value)))                              (format "%S" value)))
# Line 135  The `category' property is made into a w Line 137  The `category' property is made into a w
137  (defun describe-text-category (category)  (defun describe-text-category (category)
138    "Describe a text property category."    "Describe a text property category."
139    (interactive "S")    (interactive "S")
   (when (get-buffer "*Text Category*")  
     (kill-buffer "*Text Category*"))  
140    (save-excursion    (save-excursion
141      (with-output-to-temp-buffer "*Text Category*"      (with-output-to-temp-buffer "*Help*"
142        (set-buffer "*Text Category*")        (set-buffer standard-output)
143        (widget-insert "Category " (format "%S" category) ":\n\n")        (widget-insert "Category " (format "%S" category) ":\n\n")
144        (describe-text-properties (symbol-plist category))        (describe-property-list (symbol-plist category))
145        (describe-text-mode)        (describe-text-mode)
146        (goto-char (point-min)))))        (goto-char (point-min)))))
147    
148  ;;;###autoload  ;;;###autoload
149  (defun describe-text-at (pos)  (defun describe-text-properties (pos &optional output-buffer)
150    "Describe widgets, buttons, overlays and text properties at POS."    "Describe widgets, buttons, overlays and text properties at POS.
151    Interactively, describe them for the character after point.
152    If optional second argument OUTPUT-BUFFER is non-nil,
153    insert the output into that buffer, and don't initialize or clear it
154    otherwise."
155    (interactive "d")    (interactive "d")
156    (when (eq (current-buffer) (get-buffer "*Text Description*"))    (if (>= pos (point-max))
157      (error "Can't do self inspection"))        (error "No character follows specified position"))
158      (if output-buffer
159          (describe-text-properties-1 pos output-buffer)
160        (if (not (or (text-properties-at pos) (overlays-at pos)))
161            (message "This is plain text.")
162          (let ((buffer (current-buffer)))
163            (when (eq buffer (get-buffer "*Help*"))
164              (error "Can't do self inspection"))
165            (save-excursion
166              (with-output-to-temp-buffer "*Help*"
167                (set-buffer standard-output)
168                (setq output-buffer (current-buffer))
169                (widget-insert "Text content at position " (format "%d" pos) ":\n\n")
170                (with-current-buffer buffer
171                  (describe-text-properties-1 pos output-buffer))
172                (describe-text-mode)
173                (goto-char (point-min))))))))
174    
175    (defun describe-text-properties-1 (pos output-buffer)
176    (let* ((properties (text-properties-at pos))    (let* ((properties (text-properties-at pos))
177           (overlays (overlays-at pos))           (overlays (overlays-at pos))
178           overlay           overlay
# Line 162  The `category' property is made into a w Line 184  The `category' property is made into a w
184           (button-type (and button (button-type button)))           (button-type (and button (button-type button)))
185           (button-label (and button (button-label button)))           (button-label (and button (button-label button)))
186           (widget (or wid-field wid-button wid-doc)))           (widget (or wid-field wid-button wid-doc)))
187      (if (not (or properties overlays))      (with-current-buffer output-buffer
188          (message "This is plain text.")        ;; Widgets
189        (when (get-buffer "*Text Description*")        (when (widgetp widget)
190          (kill-buffer "*Text Description*"))          (newline)
191        (save-excursion          (widget-insert (cond (wid-field "This is an editable text area")
192          (with-output-to-temp-buffer "*Text Description*"                               (wid-button "This is an active area")
193            (set-buffer "*Text Description*")                               (wid-doc "This is documentation text")))
194            (widget-insert "Text content at position " (format "%d" pos) ":\n\n")          (widget-insert " of a ")
195            ;; Widgets          (describe-text-widget widget)
196            (when (widgetp widget)          (widget-insert ".\n\n"))
197              (widget-insert (cond (wid-field "This is an editable text area")        ;; Buttons
198                                   (wid-button "This is an active area")        (when (and button (not (widgetp wid-button)))
199                                   (wid-doc "This is documentation text")))          (newline)
200              (widget-insert " of a ")          (widget-insert "Here is a " (format "%S" button-type)
201              (describe-text-widget widget)                         " button labeled `" button-label "'.\n\n"))
202              (widget-insert ".\n\n"))        ;; Overlays
203            ;; Buttons        (when overlays
204            (when (and button (not (widgetp wid-button)))          (newline)
205              (widget-insert "Here is a " (format "%S" button-type)          (if (eq (length overlays) 1)
206                             " button labeled `" button-label "'.\n\n"))              (widget-insert "There is an overlay here:\n")
207            ;; Overlays            (widget-insert "There are " (format "%d" (length overlays))
208            (when overlays                           " overlays here:\n"))
209              (if (eq (length overlays) 1)          (dolist (overlay overlays)
210                  (widget-insert "There is an overlay here:\n")            (widget-insert " From " (format "%d" (overlay-start overlay))
211                (widget-insert "There are " (format "%d" (length overlays))                           " to " (format "%d" (overlay-end overlay)) "\n")
212                               " overlays here:\n"))            (describe-property-list (overlay-properties overlay)))
213              (dolist (overlay overlays)          (widget-insert "\n"))
214                (widget-insert " From " (format "%d" (overlay-start overlay))        ;; Text properties
215                               " to " (format "%d" (overlay-end overlay)) "\n")        (when properties
216                (describe-text-properties (overlay-properties overlay)))          (newline)
217              (widget-insert "\n"))          (widget-insert "There are text properties here:\n")
218            ;; Text properties          (describe-property-list properties)))))
219            (when properties  
220              (widget-insert "There are text properties here:\n")  ;;;###autoload
221              (describe-text-properties properties))  (defun describe-char (pos)
222            (describe-text-mode)    "Describe the character after POS (interactively, the character after point).
223            (goto-char (point-min)))))))  The information includes character code, charset and code points in it,
224    syntax, category, how the character is encoded in a file,
225    character composition information (if relevant),
226    as well as widgets, buttons, overlays, and text properties."
227      (interactive "d")
228      (if (>= pos (point-max))
229          (error "No character follows specified position"))
230      (let* ((char (char-after pos))
231             (charset (char-charset char))
232             (buffer (current-buffer))
233             (composition (find-composition pos nil nil t))
234             (composed (if composition (buffer-substring (car composition)
235                                                         (nth 1 composition))))
236             (multibyte-p enable-multibyte-characters)
237             item-list max-width)
238        (if (eq charset 'unknown)
239            (setq item-list
240                  `(("character"
241                     ,(format "%s (0%o, %d, 0x%x) -- invalid character code"
242                              (if (< char 256)
243                                  (single-key-description char)
244                                (char-to-string char))
245                              char char char))))
246          (setq item-list
247                `(("character"
248                   ,(format "%s (0%o, %d, 0x%x)" (if (< char 256)
249                                                     (single-key-description char)
250                                                   (char-to-string char))
251                            char char char))
252                  ("charset"
253                   ,(symbol-name charset)
254                   ,(format "(%s)" (charset-description charset)))
255                  ("code point"
256                   ,(let ((split (split-char char)))
257                      (if (= (charset-dimension charset) 1)
258                          (format "%d" (nth 1 split))
259                        (format "%d %d" (nth 1 split) (nth 2 split)))))
260                  ("syntax"
261                   ,(let ((syntax (syntax-after pos)))
262                      (with-temp-buffer
263                        (internal-describe-syntax-value syntax)
264                        (buffer-string))))
265                  ("category"
266                   ,@(let ((category-set (char-category-set char)))
267                       (if (not category-set)
268                           '("-- none --")
269                         (mapcar #'(lambda (x) (format "%c:%s  "
270                                                       x (category-docstring x)))
271                                 (category-set-mnemonics category-set)))))
272                  ,@(let ((props (aref char-code-property-table char))
273                          ps)
274                      (when props
275                        (while props
276                          (push (format "%s:" (pop props)) ps)
277                          (push (format "%s;" (pop props)) ps))
278                        (list (cons "Properties" (nreverse ps)))))
279                  ("buffer code"
280                   ,(encoded-string-description
281                     (string-as-unibyte (char-to-string char)) nil))
282                  ("file code"
283                   ,@(let* ((coding buffer-file-coding-system)
284                            (encoded (encode-coding-char char coding)))
285                       (if encoded
286                           (list (encoded-string-description encoded coding)
287                                 (format "(encoded by coding system %S)" coding))
288                         (list "not encodable by coding system"
289                               (symbol-name coding)))))
290                  ,@(if (or (memq 'mule-utf-8
291                              (find-coding-systems-region pos (1+ pos)))
292                            (get-char-property pos 'untranslated-utf-8))
293                        (let ((uc (or (get-char-property pos 'untranslated-utf-8)
294                                      (encode-char char 'ucs))))
295                          (if uc
296                              (list (list "Unicode"
297                                          (format "%04X" uc))))))
298                  ,(if (display-graphic-p (selected-frame))
299                       (list "font" (or (internal-char-font pos)
300                                        "-- none --"))
301                     (list "terminal code"
302                           (let* ((coding (terminal-coding-system))
303                                  (encoded (encode-coding-char char coding)))
304                             (if encoded
305                                 (encoded-string-description encoded coding)
306                               "not encodable")))))))
307        (setq max-width (apply #'max (mapcar #'(lambda (x) (length (car x)))
308                                             item-list)))
309        (when (eq (current-buffer) (get-buffer "*Help*"))
310          (error "Can't do self inspection"))
311        (with-output-to-temp-buffer "*Help*"
312          (with-current-buffer standard-output
313            (set-buffer-multibyte multibyte-p)
314            (let ((formatter (format "%%%ds:" max-width)))
315              (dolist (elt item-list)
316                (insert (format formatter (car elt)))
317                (dolist (clm (cdr elt))
318                  (when (>= (+ (current-column)
319                               (or (string-match "\n" clm)
320                                   (string-width clm)) 1)
321                            (frame-width))
322                    (insert "\n")
323                    (indent-to (1+ max-width)))
324                  (insert " " clm))
325                (insert "\n")))
326            (when composition
327              (insert "\nComposed with the "
328                      (cond
329                       ((eq pos (car composition)) "following ")
330                       ((eq (1+ pos) (cadr composition)) "preceding ")
331                       (t ""))
332                      "character(s) `"
333                      (cond
334                       ((eq pos (car composition)) (substring composed 1))
335                       ((eq (1+ pos) (cadr composition)) (substring composed 0 -1))
336                       (t (concat (substring composed 0 (- pos (car composition)))
337                                  "' and `"
338                                  (substring composed (- (1+ pos) (car composition))))))
339    
340                      "' to form `" composed "'")
341              (if (nth 3 composition)
342                  (insert ".\n")
343                (insert "\nby the rule ("
344                        (mapconcat (lambda (x)
345                                     (format (if (consp x) "%S" "?%c") x))
346                                   (nth 2 composition)
347                                   " ")
348                        ").\n"
349                        "See the variable `reference-point-alist' for "
350                        "the meaning of the rule.\n")))
351    
352            (let ((output (current-buffer)))
353              (with-current-buffer buffer
354                (describe-text-properties pos output))
355              (describe-text-mode))))))
356    
357  (provide 'descr-text)  (provide 'descr-text)
358    

Legend:
Removed from v.1.4  
changed lines
  Added in v.1.4.2.1

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26