/[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.5 by rms, Mon Jun 17 16:12:47 2002 UTC
# Line 46  Line 46 
46    :type 'hook)    :type 'hook)
47    
48  (defun describe-text-mode ()  (defun describe-text-mode ()
49    "Major mode for buffers created by `describe-text-at'.    "Major mode for buffers created by `describe-char'.
50    
51  \\{describe-text-mode-map}  \\{describe-text-mode-map}
52  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 92  if that value is non-nil." Line 92  if that value is non-nil."
92                                   (princ (widget-get widget :value))))                                   (princ (widget-get widget :value))))
93                       pp))))                       pp))))
94    
95  (defun describe-text-properties (properties)  (defun describe-property-list (properties)
96    "Insert a description of PROPERTIES in the current buffer.    "Insert a description of PROPERTIES in the current buffer.
97  PROPERTIES should be a list of overlay or text properties.  PROPERTIES should be a list of overlay or text properties.
98  The `category' property is made into a widget button that call  The `category' property is made into a widget button that call
# Line 141  The `category' property is made into a w Line 141  The `category' property is made into a w
141      (with-output-to-temp-buffer "*Text Category*"      (with-output-to-temp-buffer "*Text Category*"
142        (set-buffer "*Text Category*")        (set-buffer "*Text Category*")
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*"))    (when (eq (current-buffer) (get-buffer "*Text Description*"))
157      (error "Can't do self inspection"))      (error "Can't do self inspection"))
158      (if (>= pos (point-max))
159          (error "No character follows specified position"))
160      (if output-buffer
161          (describe-text-properties-1 pos output-buffer)
162        (if (not (or (text-properties-at pos) (overlays-at pos)))
163            (message "This is plain text.")
164          (when (get-buffer "*Text Description*")
165            (kill-buffer "*Text Description*"))
166          (let ((buffer (current-buffer)))
167            (save-excursion
168              (with-output-to-temp-buffer "*Text Description*"
169                (set-buffer "*Text Description*")
170                (setq output-buffer (current-buffer))
171                (widget-insert "Text content at position " (format "%d" pos) ":\n\n")
172                (with-current-buffer buffer
173                  (describe-text-properties-1 pos output-buffer))
174                (describe-text-mode)
175                (goto-char (point-min))))))))
176    
177    (defun describe-text-properties-1 (pos output-buffer)
178    (let* ((properties (text-properties-at pos))    (let* ((properties (text-properties-at pos))
179           (overlays (overlays-at pos))           (overlays (overlays-at pos))
180           overlay           overlay
# Line 162  The `category' property is made into a w Line 186  The `category' property is made into a w
186           (button-type (and button (button-type button)))           (button-type (and button (button-type button)))
187           (button-label (and button (button-label button)))           (button-label (and button (button-label button)))
188           (widget (or wid-field wid-button wid-doc)))           (widget (or wid-field wid-button wid-doc)))
189      (if (not (or properties overlays))      (with-current-buffer output-buffer
190          (message "This is plain text.")        ;; Widgets
191        (when (get-buffer "*Text Description*")        (when (widgetp widget)
192          (kill-buffer "*Text Description*"))          (newline)
193            (widget-insert (cond (wid-field "This is an editable text area")
194                                 (wid-button "This is an active area")
195                                 (wid-doc "This is documentation text")))
196            (widget-insert " of a ")
197            (describe-text-widget widget)
198            (widget-insert ".\n\n"))
199          ;; Buttons
200          (when (and button (not (widgetp wid-button)))
201            (newline)
202            (widget-insert "Here is a " (format "%S" button-type)
203                           " button labeled `" button-label "'.\n\n"))
204          ;; Overlays
205          (when overlays
206            (newline)
207            (if (eq (length overlays) 1)
208                (widget-insert "There is an overlay here:\n")
209              (widget-insert "There are " (format "%d" (length overlays))
210                             " overlays here:\n"))
211            (dolist (overlay overlays)
212              (widget-insert " From " (format "%d" (overlay-start overlay))
213                             " to " (format "%d" (overlay-end overlay)) "\n")
214              (describe-property-list (overlay-properties overlay)))
215            (widget-insert "\n"))
216          ;; Text properties
217          (when properties
218            (newline)
219            (widget-insert "There are text properties here:\n")
220            (describe-property-list properties)))))
221    
222    ;;;###autoload
223    (defun describe-char (pos)
224      "Describe the character after POS (interactively, the character after point).
225    The information includes character code, charset and code points in it,
226    syntax, category, how the character is encoded in a file,
227    character composition information (if relevant),
228    as well as widgets, buttons, overlays, and text properties."
229      (interactive "d")
230      (when (eq (current-buffer) (get-buffer "*Text Description*"))
231        (error "Can't do self inspection"))
232      (if (>= pos (point-max))
233          (error "No character follows specified position"))
234      (let* ((char (char-after pos))
235             (charset (char-charset char))
236             (buffer (current-buffer))
237             (composition (find-composition (point) nil nil t))
238             (composed (if composition (buffer-substring (car composition)
239                                                         (nth 1 composition))))
240             (multibyte-p enable-multibyte-characters)
241             item-list max-width)
242        (if (eq charset 'unknown)
243            (setq item-list
244                  `(("character"
245                     ,(format "%s (0%o, %d, 0x%x) -- invalid character code"
246                              (if (< char 256)
247                                  (single-key-description char)
248                                (char-to-string char))
249                              char char char))))
250          (setq item-list
251                `(("character"
252                   ,(format "%s (0%o, %d, 0x%x)" (if (< char 256)
253                                                     (single-key-description char)
254                                                   (char-to-string char))
255                            char char char))
256                  ("charset"
257                   ,(symbol-name charset)
258                   ,(format "(%s)" (charset-description charset)))
259                  ("code point"
260                   ,(let ((split (split-char char)))
261                      (if (= (charset-dimension charset) 1)
262                          (format "%d" (nth 1 split))
263                        (format "%d %d" (nth 1 split) (nth 2 split)))))
264                  ("syntax"
265                   ,(let ((syntax (get-char-property (point) 'syntax-table)))
266                      (with-temp-buffer
267                        (internal-describe-syntax-value
268                         (if (consp syntax) syntax
269                           (aref (or syntax (syntax-table)) char)))
270                        (buffer-string))))
271                  ("category"
272                   ,@(let ((category-set (char-category-set char)))
273                       (if (not category-set)
274                           '("-- none --")
275                         (mapcar #'(lambda (x) (format "%c:%s  "
276                                                       x (category-docstring x)))
277                                 (category-set-mnemonics category-set)))))
278                  ,@(let ((props (aref char-code-property-table char))
279                          ps)
280                      (when props
281                        (while props
282                          (push (format "%s:" (pop props)) ps)
283                          (push (format "%s;" (pop props)) ps))
284                        (list (cons "Properties" (nreverse ps)))))
285                  ("buffer code"
286                   ,(encoded-string-description
287                     (string-as-unibyte (char-to-string char)) nil))
288                  ("file code"
289                   ,@(let* ((coding buffer-file-coding-system)
290                            (encoded (encode-coding-char char coding)))
291                       (if encoded
292                           (list (encoded-string-description encoded coding)
293                                 (format "(encoded by coding system %S)" coding))
294                         (list "not encodable by coding system"
295                               (symbol-name coding)))))
296                  ,@(if (or (memq 'mule-utf-8
297                              (find-coding-systems-region (point) (1+ (point))))
298                            (get-char-property (point) 'untranslated-utf-8))
299                        (let ((uc (or (get-char-property (point)
300                                                         'untranslated-utf-8)
301                                      (encode-char (char-after) 'ucs))))
302                          (if uc
303                              (list (list "Unicode"
304                                          (format "%04X" uc))))))
305                  ,(if (display-graphic-p (selected-frame))
306                       (list "font" (or (internal-char-font (point))
307                                        "-- none --"))
308                     (list "terminal code"
309                           (let* ((coding (terminal-coding-system))
310                                  (encoded (encode-coding-char char coding)))
311                             (if encoded
312                                 (encoded-string-description encoded coding)
313                               "not encodable")))))))
314        (setq max-width (apply #'max (mapcar #'(lambda (x) (length (car x)))
315                                             item-list)))
316        (when (get-buffer "*Help*")
317          (kill-buffer "*Help*"))
318        (with-output-to-temp-buffer "*Help*"
319        (save-excursion        (save-excursion
320          (with-output-to-temp-buffer "*Text Description*"          (set-buffer standard-output)
321            (set-buffer "*Text Description*")          (set-buffer-multibyte multibyte-p)
322            (widget-insert "Text content at position " (format "%d" pos) ":\n\n")          (let ((formatter (format "%%%ds:" max-width)))
323            ;; Widgets            (dolist (elt item-list)
324            (when (widgetp widget)              (insert (format formatter (car elt)))
325              (widget-insert (cond (wid-field "This is an editable text area")              (dolist (clm (cdr elt))
326                                   (wid-button "This is an active area")                (when (>= (+ (current-column)
327                                   (wid-doc "This is documentation text")))                             (or (string-match "\n" clm)
328              (widget-insert " of a ")                                 (string-width clm)) 1)
329              (describe-text-widget widget)                          (frame-width))
330              (widget-insert ".\n\n"))                  (insert "\n")
331            ;; Buttons                  (indent-to (1+ max-width)))
332            (when (and button (not (widgetp wid-button)))                (insert " " clm))
333              (widget-insert "Here is a " (format "%S" button-type)              (insert "\n")))
334                             " button labeled `" button-label "'.\n\n"))          (when composition
335            ;; Overlays            (insert "\nComposed with the following character(s) "
336            (when overlays                    (mapconcat (lambda (x) (format "`%c'" x))
337              (if (eq (length overlays) 1)                               (substring composed 1)
338                  (widget-insert "There is an overlay here:\n")                               ", ")
339                (widget-insert "There are " (format "%d" (length overlays))                    " to form `" composed "'")
340                               " overlays here:\n"))            (if (nth 3 composition)
341              (dolist (overlay overlays)                (insert ".\n")
342                (widget-insert " From " (format "%d" (overlay-start overlay))              (insert "\nby the rule ("
343                               " to " (format "%d" (overlay-end overlay)) "\n")                      (mapconcat (lambda (x)
344                (describe-text-properties (overlay-properties overlay)))                                   (format (if (consp x) "%S" "?%c") x))
345              (widget-insert "\n"))                                 (nth 2 composition)
346            ;; Text properties                                 " ")
347            (when properties                      ").\n"
348              (widget-insert "There are text properties here:\n")                      "See the variable `reference-point-alist' for "
349              (describe-text-properties properties))                      "the meaning of the rule.\n")))
350            (describe-text-mode)  
351            (goto-char (point-min)))))))          (let ((output (current-buffer)))
352              (with-current-buffer buffer
353                (describe-text-properties pos output))
354              (describe-text-mode))))))
355    
356  (provide 'descr-text)  (provide 'descr-text)
357    

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

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