/[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.2.8 by miles, Tue May 11 02:28:44 2004 UTC revision 1.4.2.9 by miles, Tue Jul 6 09:14:17 2004 UTC
# Line 28  Line 28 
28    
29  ;;; Code:  ;;; Code:
30    
31  (eval-when-compile (require 'button))  (eval-when-compile (require 'button) (require 'quail))
32    
33  (defun describe-text-done ()  (defun describe-text-done ()
34    "Delete the current window or bury the current buffer."    "Delete the current window or bury the current buffer."
# Line 183  otherwise." Line 183  otherwise."
183  (defun describe-text-properties-1 (pos output-buffer)  (defun describe-text-properties-1 (pos output-buffer)
184    (let* ((properties (text-properties-at pos))    (let* ((properties (text-properties-at pos))
185           (overlays (overlays-at pos))           (overlays (overlays-at pos))
          overlay  
186           (wid-field (get-char-property pos 'field))           (wid-field (get-char-property pos 'field))
187           (wid-button (get-char-property pos 'button))           (wid-button (get-char-property pos 'button))
188           (wid-doc (get-char-property pos 'widget-doc))           (wid-doc (get-char-property pos 'widget-doc))
# Line 225  otherwise." Line 224  otherwise."
224          (widget-insert "There are text properties here:\n")          (widget-insert "There are text properties here:\n")
225          (describe-property-list properties)))))          (describe-property-list properties)))))
226    
227  ;;; We cannot use the UnicodeData.txt file as such; it is not free.  (defcustom describe-char-unicodedata-file nil
228  ;;; We can turn that info a different format and release the result    "Location of Unicode data file.
229  ;;; as free data.  When that is done, we could reinstate the code below.  This is the UnicodeData.txt file from the Unicode consortium, used for
230  ;;; For the mean time, here is a dummy placeholder.  diagnostics.  If it is non-nil `describe-char-after' will print data
231  ;;;  -- rms  looked up from it.  This facility is mostly of use to people doing
232  (defun describe-char-unicode-data (char) nil)  multilingual development.
233    
234  ;;; (defcustom describe-char-unicodedata-file nil  This is a fairly large file, not typically present on GNU systems.  At
235  ;;;   "Location of Unicode data file.  the time of writing it is at
236  ;;; This is the UnicodeData.txt file from the Unicode consortium, used for  <URL:http://www.unicode.org/Public/UNIDATA/UnicodeData.txt>."
237  ;;; diagnostics.  If it is non-nil `describe-char-after' will print data    :group 'mule
238  ;;; looked up from it.  This facility is mostly of use to people doing    :version "21.4"
239  ;;; multilingual development.    :type '(choice (const :tag "None" nil)
240                     file))
241  ;;; This is a fairly large file, not typically present on GNU systems.  At  
242  ;;; the time of writing it is at  ;; We could convert the unidata file into a Lispy form once-for-all
243  ;;; <URL:ftp://www.unicode.org/Public/UNIDATA/UnicodeData.txt>."  ;; and distribute it for loading on demand.  It might be made more
244  ;;;   :group 'mule  ;; space-efficient by splitting strings word-wise and replacing them
245  ;;;   :version "21.5"  ;; with lists of symbols interned in a private obarray, e.g.
246  ;;;   :type '(choice (const :tag "None" nil)  ;; "LATIN SMALL LETTER A" => '(LATIN SMALL LETTER A).
247  ;;;              file))  
248    ;; Fixme: Check whether this needs updating for Unicode 4.
249  ;;; ;; We could convert the unidata file into a Lispy form once-for-all  (defun describe-char-unicode-data (char)
250  ;;; ;; and distribute it for loading on demand.  It might be made more    "Return a list of Unicode data for unicode CHAR.
251  ;;; ;; space-efficient by splitting strings word-wise and replacing them  Each element is a list of a property description and the property value.
252  ;;; ;; with lists of symbols interned in a private obarray, e.g.  The list is null if CHAR isn't found in `describe-char-unicodedata-file'."
253  ;;; ;; "LATIN SMALL LETTER A" => '(LATIN SMALL LETTER A).    (when describe-char-unicodedata-file
254        (unless (file-exists-p describe-char-unicodedata-file)
255  ;;; ;; Fixme: Check whether this needs updating for Unicode 4.        (error "`unicodedata-file' %s not found" describe-char-unicodedata-file))
256  ;;; (defun describe-char-unicode-data (char)      (with-current-buffer
257  ;;;   "Return a list of Unicode data for unicode CHAR.          ;; Find file in fundamental mode to avoid, e.g. flyspell turned
258  ;;; Each element is a list of a property description and the property value.          ;; on for .txt.  Don't use RAWFILE arg in case of DOS line endings.
259  ;;; The list is null if CHAR isn't found in `describe-char-unicodedata-file'."          (let ((auto-mode-alist))
260  ;;;   (when describe-char-unicodedata-file            (find-file-noselect describe-char-unicodedata-file))
261  ;;;     (unless (file-exists-p describe-char-unicodedata-file)        (goto-char (point-min))
262  ;;;       (error "`unicodedata-file' %s not found" describe-char-unicodedata-file))        (let ((hex (format "%04X" char))
263  ;;;     (save-excursion              found first last)
264  ;;;       ;; Find file in fundamental mode to avoid, e.g. flyspell turned          (if (re-search-forward (concat "^" hex) nil t)
265  ;;;       ;; on for .txt.  Don't use RAWFILE arg in case of DOS line endings.              (setq found t)
266  ;;;       (set-buffer (let ((auto-mode-alist))            ;; It's not listed explicitly.  Look for ranges, e.g. CJK
267  ;;;                 (find-file-noselect describe-char-unicodedata-file)))            ;; ideographs, and check whether it's in one of them.
268  ;;;       (goto-char (point-min))            (while (and (re-search-forward "^\\([^;]+\\);[^;]+First>;" nil t)
269  ;;;       (let ((hex (format "%04X" char))                        (>= char (setq first
270  ;;;         found first last)                                       (string-to-number (match-string 1) 16)))
271  ;;;     (if (re-search-forward (concat "^" hex) nil t)                        (progn
272  ;;;         (setq found t)                          (forward-line 1)
273  ;;;       ;; It's not listed explicitly.  Look for ranges, e.g. CJK                          (looking-at "^\\([^;]+\\);[^;]+Last>;")
274  ;;;       ;; ideographs, and check whether it's in one of them.                          (> char
275  ;;;       (while (and (re-search-forward "^\\([^;]+\\);[^;]+First>;" nil t)                             (setq last
276  ;;;                   (>= char (setq first                                   (string-to-number (match-string 1) 16))))))
277  ;;;                                  (string-to-number (match-string 1) 16)))            (if (and (>= char first)
278  ;;;                   (progn                     (<= char last))
279  ;;;                     (forward-line 1)                (setq found t)))
280  ;;;                     (looking-at "^\\([^;]+\\);[^;]+Last>;")          (if found
281  ;;;                     (> char              (let ((fields (mapcar (lambda (elt)
282  ;;;                        (setq last                                      (if (> (length elt) 0)
283  ;;;                              (string-to-number (match-string 1) 16))))))                                          elt))
284  ;;;       (if (and (>= char first)                                    (cdr (split-string
285  ;;;                (<= char last))                                          (buffer-substring
286  ;;;           (setq found t)))                                           (line-beginning-position)
287  ;;;     (if found                                           (line-end-position))
288  ;;;         (let ((fields (mapcar (lambda (elt)                                          ";")))))
289  ;;;                                 (if (> (length elt) 0)                ;; The length depends on whether the last field was empty.
290  ;;;                                     elt))                (unless (or (= 13 (length fields))
291  ;;;                               (cdr (split-string                            (= 14 (length fields)))
292  ;;;                                     (buffer-substring                  (error "Invalid contents in %s" describe-char-unicodedata-file))
293  ;;;                                      (line-beginning-position)                ;; The field names and values lists are slightly
294  ;;;                                      (line-end-position))                ;; modified from Mule-UCS unidata.el.
295  ;;;                                     ";")))))                (list
296  ;;;           ;; The length depends on whether the last field was empty.                 (list "Name" (let ((name (nth 0 fields)))
297  ;;;           (unless (or (= 13 (length fields))                                ;; Check for <..., First>, <..., Last>
298  ;;;                       (= 14 (length fields)))                                (if (string-match "\\`\\(<[^,]+\\)," name)
299  ;;;             (error "Invalid contents in %s" describe-char-unicodedata-file))                                    (concat (match-string 1 name) ">")
300  ;;;           ;; The field names and values lists are slightly                                  name)))
301  ;;;           ;; modified from Mule-UCS unidata.el.                 (list "Category"
302  ;;;           (list                       (cdr (assoc
303  ;;;            (list "Name" (let ((name (nth 0 fields)))                             (nth 1 fields)
304  ;;;                           ;; Check for <..., First>, <..., Last>                             '(("Lu" . "uppercase letter")
305  ;;;                           (if (string-match "\\`\\(<[^,]+\\)," name)                               ("Ll" . "lowercase letter")
306  ;;;                               (concat (match-string 1 name) ">")                               ("Lt" . "titlecase letter")
307  ;;;                             name)))                               ("Mn" . "non-spacing mark")
308  ;;;            (list "Category"                               ("Mc" . "spacing-combining mark")
309  ;;;                  (cdr (assoc                               ("Me" . "enclosing mark")
310  ;;;                        (nth 1 fields)                               ("Nd" . "decimal digit")
311  ;;;                        '(("Lu" . "uppercase letter")                               ("Nl" . "letter number")
312  ;;;                          ("Ll" . "lowercase letter")                               ("No" . "other number")
313  ;;;                          ("Lt" . "titlecase letter")                               ("Zs" . "space separator")
314  ;;;                          ("Mn" . "non-spacing mark")                               ("Zl" . "line separator")
315  ;;;                          ("Mc" . "spacing-combining mark")                               ("Zp" . "paragraph separator")
316  ;;;                          ("Me" . "enclosing mark")                               ("Cc" . "other control")
317  ;;;                          ("Nd" . "decimal digit")                               ("Cf" . "other format")
318  ;;;                          ("Nl" . "letter number")                               ("Cs" . "surrogate")
319  ;;;                          ("No" . "other number")                               ("Co" . "private use")
320  ;;;                          ("Zs" . "space separator")                               ("Cn" . "not assigned")
321  ;;;                          ("Zl" . "line separator")                               ("Lm" . "modifier letter")
322  ;;;                          ("Zp" . "paragraph separator")                               ("Lo" . "other letter")
323  ;;;                          ("Cc" . "other control")                               ("Pc" . "connector punctuation")
324  ;;;                          ("Cf" . "other format")                               ("Pd" . "dash punctuation")
325  ;;;                          ("Cs" . "surrogate")                               ("Ps" . "open punctuation")
326  ;;;                          ("Co" . "private use")                               ("Pe" . "close punctuation")
327  ;;;                          ("Cn" . "not assigned")                               ("Pi" . "initial-quotation punctuation")
328  ;;;                          ("Lm" . "modifier letter")                               ("Pf" . "final-quotation punctuation")
329  ;;;                          ("Lo" . "other letter")                               ("Po" . "other punctuation")
330  ;;;                          ("Pc" . "connector punctuation")                               ("Sm" . "math symbol")
331  ;;;                          ("Pd" . "dash punctuation")                               ("Sc" . "currency symbol")
332  ;;;                          ("Ps" . "open punctuation")                               ("Sk" . "modifier symbol")
333  ;;;                          ("Pe" . "close punctuation")                               ("So" . "other symbol")))))
334  ;;;                          ("Pi" . "initial-quotation punctuation")                 (list "Combining class"
335  ;;;                          ("Pf" . "final-quotation punctuation")                       (cdr (assoc
336  ;;;                          ("Po" . "other punctuation")                             (string-to-number (nth 2 fields))
337  ;;;                          ("Sm" . "math symbol")                             '((0 . "Spacing")
338  ;;;                          ("Sc" . "currency symbol")                               (1 . "Overlays and interior")
339  ;;;                          ("Sk" . "modifier symbol")                               (7 . "Nuktas")
340  ;;;                          ("So" . "other symbol")))))                               (8 . "Hiragana/Katakana voicing marks")
341  ;;;            (list "Combining class"                               (9 . "Viramas")
342  ;;;                  (cdr (assoc                               (10 . "Start of fixed position classes")
343  ;;;                        (string-to-number (nth 2 fields))                               (199 . "End of fixed position classes")
344  ;;;                        '((0 . "Spacing")                               (200 . "Below left attached")
345  ;;;                          (1 . "Overlays and interior")                               (202 . "Below attached")
346  ;;;                          (7 . "Nuktas")                               (204 . "Below right attached")
347  ;;;                          (8 . "Hiragana/Katakana voicing marks")                               (208 . "Left attached (reordrant around \
348  ;;;                          (9 . "Viramas")  single base character)")
349  ;;;                          (10 . "Start of fixed position classes")                               (210 . "Right attached")
350  ;;;                          (199 . "End of fixed position classes")                               (212 . "Above left attached")
351  ;;;                          (200 . "Below left attached")                               (214 . "Above attached")
352  ;;;                          (202 . "Below attached")                               (216 . "Above right attached")
353  ;;;                          (204 . "Below right attached")                               (218 . "Below left")
354  ;;;                          (208 . "Left attached (reordrant around \                               (220 . "Below")
355  ;;; single base character)")                               (222 . "Below right")
356  ;;;                          (210 . "Right attached")                               (224 . "Left (reordrant around single base \
357  ;;;                          (212 . "Above left attached")  character)")
358  ;;;                          (214 . "Above attached")                               (226 . "Right")
359  ;;;                          (216 . "Above right attached")                               (228 . "Above left")
360  ;;;                          (218 . "Below left")                               (230 . "Above")
361  ;;;                          (220 . "Below")                               (232 . "Above right")
362  ;;;                          (222 . "Below right")                               (233 . "Double below")
363  ;;;                          (224 . "Left (reordrant around single base \                               (234 . "Double above")
364  ;;; character)")                               (240 . "Below (iota subscript)")))))
365  ;;;                          (226 . "Right")                 (list "Bidi category"
366  ;;;                          (228 . "Above left")                       (cdr (assoc
367  ;;;                          (230 . "Above")                             (nth 3 fields)
368  ;;;                          (232 . "Above right")                             '(("L" . "Left-to-Right")
369  ;;;                          (233 . "Double below")                               ("LRE" . "Left-to-Right Embedding")
370  ;;;                          (234 . "Double above")                               ("LRO" . "Left-to-Right Override")
371  ;;;                          (240 . "Below (iota subscript)")))))                               ("R" . "Right-to-Left")
372  ;;;            (list "Bidi category"                               ("AL" . "Right-to-Left Arabic")
373  ;;;                  (cdr (assoc                               ("RLE" . "Right-to-Left Embedding")
374  ;;;                        (nth 3 fields)                               ("RLO" . "Right-to-Left Override")
375  ;;;                        '(("L" . "Left-to-Right")                               ("PDF" . "Pop Directional Format")
376  ;;;                          ("LRE" . "Left-to-Right Embedding")                               ("EN" . "European Number")
377  ;;;                          ("LRO" . "Left-to-Right Override")                               ("ES" . "European Number Separator")
378  ;;;                          ("R" . "Right-to-Left")                               ("ET" . "European Number Terminator")
379  ;;;                          ("AL" . "Right-to-Left Arabic")                               ("AN" . "Arabic Number")
380  ;;;                          ("RLE" . "Right-to-Left Embedding")                               ("CS" . "Common Number Separator")
381  ;;;                          ("RLO" . "Right-to-Left Override")                               ("NSM" . "Non-Spacing Mark")
382  ;;;                          ("PDF" . "Pop Directional Format")                               ("BN" . "Boundary Neutral")
383  ;;;                          ("EN" . "European Number")                               ("B" . "Paragraph Separator")
384  ;;;                          ("ES" . "European Number Separator")                               ("S" . "Segment Separator")
385  ;;;                          ("ET" . "European Number Terminator")                               ("WS" . "Whitespace")
386  ;;;                          ("AN" . "Arabic Number")                               ("ON" . "Other Neutrals")))))
387  ;;;                          ("CS" . "Common Number Separator")                 (list
388  ;;;                          ("NSM" . "Non-Spacing Mark")                  "Decomposition"
389  ;;;                          ("BN" . "Boundary Neutral")                  (if (nth 4 fields)
390  ;;;                          ("B" . "Paragraph Separator")                      (let* ((parts (split-string (nth 4 fields)))
391  ;;;                          ("S" . "Segment Separator")                             (info (car parts)))
392  ;;;                          ("WS" . "Whitespace")                        (if (string-match "\\`<\\(.+\\)>\\'" info)
393  ;;;                          ("ON" . "Other Neutrals")))))                            (setq info (match-string 1 info))
394  ;;;            (list                          (setq info nil))
395  ;;;             "Decomposition"                        (if info (setq parts (cdr parts)))
396  ;;;             (if (nth 4 fields)                        ;; Maybe printing ? for unrepresentable unicodes
397  ;;;                 (let* ((parts (split-string (nth 4 fields)))                        ;; here and below should be changed?
398  ;;;                        (info (car parts)))                        (setq parts (mapconcat
399  ;;;                   (if (string-match "\\`<\\(.+\\)>\\'" info)                                     (lambda (arg)
400  ;;;                       (setq info (match-string 1 info))                                       (string (or (decode-char
401  ;;;                     (setq info nil))                                                    'ucs
402  ;;;                   (if info (setq parts (cdr parts)))                                                    (string-to-number arg 16))
403  ;;;                   ;; Maybe printing ? for unrepresentable unicodes                                                   ??)))
404  ;;;                   ;; here and below should be changed?                                     parts " "))
405  ;;;                   (setq parts (mapconcat                        (concat info parts))))
406  ;;;                                (lambda (arg)                 (list "Decimal digit value"
407  ;;;                                  (string (or (decode-char                       (nth 5 fields))
408  ;;;                                               'ucs                 (list "Digit value"
409  ;;;                                               (string-to-number arg 16))                       (nth 6 fields))
410  ;;;                                              ??)))                 (list "Numeric value"
411  ;;;                                parts " "))                       (nth 7 fields))
412  ;;;                   (concat info parts))))                 (list "Mirrored"
413  ;;;            (list "Decimal digit value"                       (if (equal "Y" (nth 8 fields))
414  ;;;                  (nth 5 fields))                           "yes"))
415  ;;;            (list "Digit value"                 (list "Old name" (nth 9 fields))
416  ;;;                  (nth 6 fields))                 (list "ISO 10646 comment" (nth 10 fields))
417  ;;;            (list "Numeric value"                 (list "Uppercase" (and (nth 11 fields)
418  ;;;                  (nth 7 fields))                                        (string (or (decode-char
419  ;;;            (list "Mirrored"                                                     'ucs
420  ;;;                  (if (equal "Y" (nth 8 fields))                                                     (string-to-number
421  ;;;                      "yes"))                                                      (nth 11 fields) 16))
422  ;;;            (list "Old name" (nth 9 fields))                                                    ??))))
423  ;;;            (list "ISO 10646 comment" (nth 10 fields))                 (list "Lowercase" (and (nth 12 fields)
424  ;;;            (list "Uppercase" (and (nth 11 fields)                                        (string (or (decode-char
425  ;;;                                   (string (or (decode-char                                                     'ucs
426  ;;;                                                'ucs                                                     (string-to-number
427  ;;;                                                (string-to-number                                                      (nth 12 fields) 16))
428  ;;;                                                 (nth 11 fields) 16))                                                    ??))))
429  ;;;                                               ??))))                 (list "Titlecase" (and (nth 13 fields)
430  ;;;            (list "Lowercase" (and (nth 12 fields)                                        (string (or (decode-char
431  ;;;                                   (string (or (decode-char                                                     'ucs
432  ;;;                                                'ucs                                                     (string-to-number
433  ;;;                                                (string-to-number                                                      (nth 13 fields) 16))
434  ;;;                                                 (nth 12 fields) 16))                                                    ??)))))))))))
 ;;;                                               ??))))  
 ;;;            (list "Titlecase" (and (nth 13 fields)  
 ;;;                                   (string (or (decode-char  
 ;;;                                                'ucs  
 ;;;                                                (string-to-number  
 ;;;                                                 (nth 13 fields) 16))  
 ;;;                                               ??)))))))))))  
435    
436  ;; Return information about how CHAR is displayed at the buffer  ;; Return information about how CHAR is displayed at the buffer
437  ;; position POS.  If the selected frame is on a graphic display,  ;; position POS.  If the selected frame is on a graphic display,
# Line 466  as well as widgets, buttons, overlays, a Line 458  as well as widgets, buttons, overlays, a
458        (error "No character follows specified position"))        (error "No character follows specified position"))
459    (let* ((char (char-after pos))    (let* ((char (char-after pos))
460           (charset (char-charset char))           (charset (char-charset char))
          (buffer (current-buffer))  
461           (composition (find-composition pos nil nil t))           (composition (find-composition pos nil nil t))
462           (component-chars nil)           (component-chars nil)
463           (display-table (or (window-display-table)           (display-table (or (window-display-table)
# Line 524  as well as widgets, buttons, overlays, a Line 515  as well as widgets, buttons, overlays, a
515                      (push (format "%s:" (pop props)) ps)                      (push (format "%s:" (pop props)) ps)
516                      (push (format "%s;" (pop props)) ps))                      (push (format "%s;" (pop props)) ps))
517                    (list (cons "Properties" (nreverse ps)))))                    (list (cons "Properties" (nreverse ps)))))
518                ("to input"
519                 ,@(let ((key-list (and current-input-method
520                                        (quail-find-key char))))
521                     (if (consp key-list)
522                         (list "type"
523                               (mapconcat #'(lambda (x) (concat "\"" x "\""))
524                                          key-list " or ")))))
525              ("buffer code"              ("buffer code"
526               ,(encoded-string-description               ,(encoded-string-description
527                 (string-as-unibyte (char-to-string char)) nil))                 (string-as-unibyte (char-to-string char)) nil))

Legend:
Removed from v.1.4.2.8  
changed lines
  Added in v.1.4.2.9

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