/[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.1 by miles, Fri Apr 4 06:20:01 2003 UTC revision 1.4.2.2 by miles, Tue Oct 14 23:50:54 2003 UTC
# Line 1  Line 1 
1  ;;; descr-text.el --- describe text mode  ;;; descr-text.el --- describe text mode
2    
3  ;; Copyright (c) 1994, 1995, 1996, 2001, 2002 Free Software Foundation, Inc.  ;; Copyright (c) 1994, 1995, 1996, 2001, 02, 03 Free Software Foundation, Inc.
4    
5  ;; Author: Boris Goldowsky <boris@gnu.org>  ;; Author: Boris Goldowsky <boris@gnu.org>
6  ;; Keywords: faces  ;; Keywords: faces
# Line 28  Line 28 
28    
29  ;;; Code:  ;;; Code:
30    
31    (eval-when-compile (require 'button))
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."
35    (interactive)    (interactive)
# Line 216  otherwise." Line 218  otherwise."
218          (newline)          (newline)
219          (widget-insert "There are text properties here:\n")          (widget-insert "There are text properties here:\n")
220          (describe-property-list properties)))))          (describe-property-list properties)))))
221    
222    ;;; We cannot use the UnicodeData.txt file as such; it is not free.
223    ;;; We can turn that info a different format and release the result
224    ;;; as free data.  When that is done, we could reinstate the code below.
225    ;;; For the mean time, here is a dummy placeholder.
226    ;;;  -- rms
227    (defun describe-char-unicode-data (char) nil)
228    
229    ;;; (defcustom describe-char-unicodedata-file nil
230    ;;;   "Location of Unicode data file.
231    ;;; This is the UnicodeData.txt file from the Unicode consortium, used for
232    ;;; diagnostics.  If it is non-nil `describe-char-after' will print data
233    ;;; looked up from it.  This facility is mostly of use to people doing
234    ;;; multilingual development.
235    
236    ;;; This is a fairly large file, not typically present on GNU systems.  At
237    ;;; the time of writing it is at
238    ;;; <URL:ftp://www.unicode.org/Public/UNIDATA/UnicodeData.txt>."
239    ;;;   :group 'mule
240    ;;;   :version "21.5"
241    ;;;   :type '(choice (const :tag "None" nil)
242    ;;;              file))
243    
244    ;;; ;; We could convert the unidata file into a Lispy form once-for-all
245    ;;; ;; and distribute it for loading on demand.  It might be made more
246    ;;; ;; space-efficient by splitting strings word-wise and replacing them
247    ;;; ;; with lists of symbols interned in a private obarray, e.g.
248    ;;; ;; "LATIN SMALL LETTER A" => '(LATIN SMALL LETTER A).
249    
250    ;;; ;; Fixme: Check whether this needs updating for Unicode 4.
251    ;;; (defun describe-char-unicode-data (char)
252    ;;;   "Return a list of Unicode data for unicode CHAR.
253    ;;; Each element is a list of a property description and the property value.
254    ;;; The list is null if CHAR isn't found in `describe-char-unicodedata-file'."
255    ;;;   (when describe-char-unicodedata-file
256    ;;;     (unless (file-exists-p describe-char-unicodedata-file)
257    ;;;       (error "`unicodedata-file' %s not found" describe-char-unicodedata-file))
258    ;;;     (save-excursion
259    ;;;       ;; Find file in fundamental mode to avoid, e.g. flyspell turned
260    ;;;       ;; on for .txt.  Don't use RAWFILE arg in case of DOS line endings.
261    ;;;       (set-buffer (let ((auto-mode-alist))
262    ;;;                 (find-file-noselect describe-char-unicodedata-file)))
263    ;;;       (goto-char (point-min))
264    ;;;       (let ((hex (format "%04X" char))
265    ;;;         found first last)
266    ;;;     (if (re-search-forward (concat "^" hex) nil t)
267    ;;;         (setq found t)
268    ;;;       ;; It's not listed explicitly.  Look for ranges, e.g. CJK
269    ;;;       ;; ideographs, and check whether it's in one of them.
270    ;;;       (while (and (re-search-forward "^\\([^;]+\\);[^;]+First>;" nil t)
271    ;;;                   (>= char (setq first
272    ;;;                                  (string-to-number (match-string 1) 16)))
273    ;;;                   (progn
274    ;;;                     (forward-line 1)
275    ;;;                     (looking-at "^\\([^;]+\\);[^;]+Last>;")
276    ;;;                     (> char
277    ;;;                        (setq last
278    ;;;                              (string-to-number (match-string 1) 16))))))
279    ;;;       (if (and (>= char first)
280    ;;;                (<= char last))
281    ;;;           (setq found t)))
282    ;;;     (if found
283    ;;;         (let ((fields (mapcar (lambda (elt)
284    ;;;                                 (if (> (length elt) 0)
285    ;;;                                     elt))
286    ;;;                               (cdr (split-string
287    ;;;                                     (buffer-substring
288    ;;;                                      (line-beginning-position)
289    ;;;                                      (line-end-position))
290    ;;;                                     ";")))))
291    ;;;           ;; The length depends on whether the last field was empty.
292    ;;;           (unless (or (= 13 (length fields))
293    ;;;                       (= 14 (length fields)))
294    ;;;             (error "Invalid contents in %s" describe-char-unicodedata-file))
295    ;;;           ;; The field names and values lists are slightly
296    ;;;           ;; modified from Mule-UCS unidata.el.
297    ;;;           (list
298    ;;;            (list "Name" (let ((name (nth 0 fields)))
299    ;;;                           ;; Check for <..., First>, <..., Last>
300    ;;;                           (if (string-match "\\`\\(<[^,]+\\)," name)
301    ;;;                               (concat (match-string 1 name) ">")
302    ;;;                             name)))
303    ;;;            (list "Category"
304    ;;;                  (cdr (assoc
305    ;;;                        (nth 1 fields)
306    ;;;                        '(("Lu" . "uppercase letter")
307    ;;;                          ("Ll" . "lowercase letter")
308    ;;;                          ("Lt" . "titlecase letter")
309    ;;;                          ("Mn" . "non-spacing mark")
310    ;;;                          ("Mc" . "spacing-combining mark")
311    ;;;                          ("Me" . "enclosing mark")
312    ;;;                          ("Nd" . "decimal digit")
313    ;;;                          ("Nl" . "letter number")
314    ;;;                          ("No" . "other number")
315    ;;;                          ("Zs" . "space separator")
316    ;;;                          ("Zl" . "line separator")
317    ;;;                          ("Zp" . "paragraph separator")
318    ;;;                          ("Cc" . "other control")
319    ;;;                          ("Cf" . "other format")
320    ;;;                          ("Cs" . "surrogate")
321    ;;;                          ("Co" . "private use")
322    ;;;                          ("Cn" . "not assigned")
323    ;;;                          ("Lm" . "modifier letter")
324    ;;;                          ("Lo" . "other letter")
325    ;;;                          ("Pc" . "connector punctuation")
326    ;;;                          ("Pd" . "dash punctuation")
327    ;;;                          ("Ps" . "open punctuation")
328    ;;;                          ("Pe" . "close punctuation")
329    ;;;                          ("Pi" . "initial-quotation punctuation")
330    ;;;                          ("Pf" . "final-quotation punctuation")
331    ;;;                          ("Po" . "other punctuation")
332    ;;;                          ("Sm" . "math symbol")
333    ;;;                          ("Sc" . "currency symbol")
334    ;;;                          ("Sk" . "modifier symbol")
335    ;;;                          ("So" . "other symbol")))))
336    ;;;            (list "Combining class"
337    ;;;                  (cdr (assoc
338    ;;;                        (string-to-number (nth 2 fields))
339    ;;;                        '((0 . "Spacing")
340    ;;;                          (1 . "Overlays and interior")
341    ;;;                          (7 . "Nuktas")
342    ;;;                          (8 . "Hiragana/Katakana voicing marks")
343    ;;;                          (9 . "Viramas")
344    ;;;                          (10 . "Start of fixed position classes")
345    ;;;                          (199 . "End of fixed position classes")
346    ;;;                          (200 . "Below left attached")
347    ;;;                          (202 . "Below attached")
348    ;;;                          (204 . "Below right attached")
349    ;;;                          (208 . "Left attached (reordrant around \
350    ;;; single base character)")
351    ;;;                          (210 . "Right attached")
352    ;;;                          (212 . "Above left attached")
353    ;;;                          (214 . "Above attached")
354    ;;;                          (216 . "Above right attached")
355    ;;;                          (218 . "Below left")
356    ;;;                          (220 . "Below")
357    ;;;                          (222 . "Below right")
358    ;;;                          (224 . "Left (reordrant around single base \
359    ;;; character)")
360    ;;;                          (226 . "Right")
361    ;;;                          (228 . "Above left")
362    ;;;                          (230 . "Above")
363    ;;;                          (232 . "Above right")
364    ;;;                          (233 . "Double below")
365    ;;;                          (234 . "Double above")
366    ;;;                          (240 . "Below (iota subscript)")))))
367    ;;;            (list "Bidi category"
368    ;;;                  (cdr (assoc
369    ;;;                        (nth 3 fields)
370    ;;;                        '(("L" . "Left-to-Right")
371    ;;;                          ("LRE" . "Left-to-Right Embedding")
372    ;;;                          ("LRO" . "Left-to-Right Override")
373    ;;;                          ("R" . "Right-to-Left")
374    ;;;                          ("AL" . "Right-to-Left Arabic")
375    ;;;                          ("RLE" . "Right-to-Left Embedding")
376    ;;;                          ("RLO" . "Right-to-Left Override")
377    ;;;                          ("PDF" . "Pop Directional Format")
378    ;;;                          ("EN" . "European Number")
379    ;;;                          ("ES" . "European Number Separator")
380    ;;;                          ("ET" . "European Number Terminator")
381    ;;;                          ("AN" . "Arabic Number")
382    ;;;                          ("CS" . "Common Number Separator")
383    ;;;                          ("NSM" . "Non-Spacing Mark")
384    ;;;                          ("BN" . "Boundary Neutral")
385    ;;;                          ("B" . "Paragraph Separator")
386    ;;;                          ("S" . "Segment Separator")
387    ;;;                          ("WS" . "Whitespace")
388    ;;;                          ("ON" . "Other Neutrals")))))
389    ;;;            (list
390    ;;;             "Decomposition"
391    ;;;             (if (nth 4 fields)
392    ;;;                 (let* ((parts (split-string (nth 4 fields)))
393    ;;;                        (info (car parts)))
394    ;;;                   (if (string-match "\\`<\\(.+\\)>\\'" info)
395    ;;;                       (setq info (match-string 1 info))
396    ;;;                     (setq info nil))
397    ;;;                   (if info (setq parts (cdr parts)))
398    ;;;                   ;; Maybe printing ? for unrepresentable unicodes
399    ;;;                   ;; here and below should be changed?
400    ;;;                   (setq parts (mapconcat
401    ;;;                                (lambda (arg)
402    ;;;                                  (string (or (decode-char
403    ;;;                                               'ucs
404    ;;;                                               (string-to-number arg 16))
405    ;;;                                              ??)))
406    ;;;                                parts " "))
407    ;;;                   (concat info parts))))
408    ;;;            (list "Decimal digit value"
409    ;;;                  (nth 5 fields))
410    ;;;            (list "Digit value"
411    ;;;                  (nth 6 fields))
412    ;;;            (list "Numeric value"
413    ;;;                  (nth 7 fields))
414    ;;;            (list "Mirrored"
415    ;;;                  (if (equal "Y" (nth 8 fields))
416    ;;;                      "yes"))
417    ;;;            (list "Old name" (nth 9 fields))
418    ;;;            (list "ISO 10646 comment" (nth 10 fields))
419    ;;;            (list "Uppercase" (and (nth 11 fields)
420    ;;;                                   (string (or (decode-char
421    ;;;                                                'ucs
422    ;;;                                                (string-to-number
423    ;;;                                                 (nth 11 fields) 16))
424    ;;;                                               ??))))
425    ;;;            (list "Lowercase" (and (nth 12 fields)
426    ;;;                                   (string (or (decode-char
427    ;;;                                                'ucs
428    ;;;                                                (string-to-number
429    ;;;                                                 (nth 12 fields) 16))
430    ;;;                                               ??))))
431    ;;;            (list "Titlecase" (and (nth 13 fields)
432    ;;;                                   (string (or (decode-char
433    ;;;                                                'ucs
434    ;;;                                                (string-to-number
435    ;;;                                                 (nth 13 fields) 16))
436    ;;;                                               ??)))))))))))
437    
438    ;; Return information about how CHAR is displayed at the buffer
439    ;; position POS.  If the selected frame is on a graphic display,
440    ;; return a cons (FONTNAME . GLYPH-CODE).  Otherwise, return a string
441    ;; describing the terminal codes for the character.
442    (defun describe-char-display (pos char)
443      (if (display-graphic-p (selected-frame))
444          (internal-char-font pos char)
445        (let* ((coding (terminal-coding-system))
446               (encoded (encode-coding-char char coding)))
447          (if encoded
448              (encoded-string-description encoded coding)))))
449    
450    
451  ;;;###autoload  ;;;###autoload
452  (defun describe-char (pos)  (defun describe-char (pos)
453    "Describe the character after POS (interactively, the character after point).    "Describe the character after POS (interactively, the character after point).
# Line 231  as well as widgets, buttons, overlays, a Line 462  as well as widgets, buttons, overlays, a
462           (charset (char-charset char))           (charset (char-charset char))
463           (buffer (current-buffer))           (buffer (current-buffer))
464           (composition (find-composition pos nil nil t))           (composition (find-composition pos nil nil t))
465           (composed (if composition (buffer-substring (car composition)           (component-chars nil)
466                                                       (nth 1 composition))))           (display-table (or (window-display-table)
467                                buffer-display-table
468                                standard-display-table))
469             (disp-vector (and display-table (aref display-table char)))
470           (multibyte-p enable-multibyte-characters)           (multibyte-p enable-multibyte-characters)
471           item-list max-width)           item-list max-width unicode)
472      (if (eq charset 'unknown)      (if (eq charset 'unknown)
473          (setq item-list          (setq item-list
474                `(("character"                `(("character"
# Line 243  as well as widgets, buttons, overlays, a Line 477  as well as widgets, buttons, overlays, a
477                                (single-key-description char)                                (single-key-description char)
478                              (char-to-string char))                              (char-to-string char))
479                            char char char))))                            char char char))))
480    
481          (if (or (< char 256)
482                  (memq 'mule-utf-8 (find-coding-systems-region pos (1+ pos)))
483                  (get-char-property pos 'untranslated-utf-8))
484              (setq unicode (or (get-char-property pos 'untranslated-utf-8)
485                                (encode-char char 'ucs))))
486        (setq item-list        (setq item-list
487              `(("character"              `(("character"
488                 ,(format "%s (0%o, %d, 0x%x)" (if (< char 256)                 ,(format "%s (0%o, %d, 0x%x%s)" (if (< char 256)
489                                                   (single-key-description char)                                                   (single-key-description char)
490                                                 (char-to-string char))                                                 (char-to-string char))
491                          char char char))                          char char char
492                            (if unicode
493                                (format ", U+%04X" unicode)
494                              "")))
495                ("charset"                ("charset"
496                 ,(symbol-name charset)                 ,(symbol-name charset)
497                 ,(format "(%s)" (charset-description charset)))                 ,(format "(%s)" (charset-description charset)))
# Line 287  as well as widgets, buttons, overlays, a Line 530  as well as widgets, buttons, overlays, a
530                               (format "(encoded by coding system %S)" coding))                               (format "(encoded by coding system %S)" coding))
531                       (list "not encodable by coding system"                       (list "not encodable by coding system"
532                             (symbol-name coding)))))                             (symbol-name coding)))))
533                ,@(if (or (memq 'mule-utf-8                ("display"
534                            (find-coding-systems-region pos (1+ pos)))                 ,(cond
535                          (get-char-property pos 'untranslated-utf-8))                   (disp-vector
536                      (let ((uc (or (get-char-property pos 'untranslated-utf-8)                    (setq disp-vector (copy-sequence disp-vector))
537                                    (encode-char char 'ucs))))                    (dotimes (i (length disp-vector))
538                        (if uc                      (setq char (aref disp-vector i))
539                            (list (list "Unicode"                      (aset disp-vector i
540                                        (format "%04X" uc))))))                            (cons char (describe-char-display pos char))))
541                ,(if (display-graphic-p (selected-frame))                    (format "by display table entry [%s] (see below)"
542                     (list "font" (or (internal-char-font pos)                            (mapconcat #'(lambda (x) (format "?%c" (car x)))
543                                      "-- none --"))                                       disp-vector " ")))
544                   (list "terminal code"                   (composition
545                         (let* ((coding (terminal-coding-system))                    (let ((from (car composition))
546                                (encoded (encode-coding-char char coding)))                          (to (nth 1 composition))
547                           (if encoded                          (next (1+ pos))
548                               (encoded-string-description encoded coding)                          (components (nth 2 composition))
549                             "not encodable")))))))                          ch)
550                        (setcar composition
551                                (and (< from pos) (buffer-substring from pos)))
552                        (setcar (cdr composition)
553                                (and (< next to) (buffer-substring next to)))
554                        (dotimes (i (length components))
555                          (if (integerp (setq ch (aref components i)))
556                              (push (cons ch (describe-char-display pos ch))
557                                    component-chars)))
558                        (setq component-chars (nreverse component-chars))
559                        (format "composed to form \"%s\" (see below)"
560                                (buffer-substring from to))))
561                     (t
562                      (let ((display (describe-char-display pos char)))
563                        (if (display-graphic-p (selected-frame))
564                            (if display
565                                (concat
566                                 "by this font (glyph code)\n"
567                                 (format "     %s (0x%02X)"
568                                         (car display) (cdr display)))
569                              "no font avairable")
570                          (if display
571                              (format "terminal code %s" display)
572                            "not encodable for terminal"))))))
573                  ,@(let ((unicodedata (and unicode
574                                            (describe-char-unicode-data unicode))))
575                      (if unicodedata
576                          (cons (list "Unicode data" " ") unicodedata))))))
577      (setq max-width (apply #'max (mapcar #'(lambda (x) (length (car x)))      (setq max-width (apply #'max (mapcar #'(lambda (x) (length (car x)))
578                                           item-list)))                                           item-list)))
579      (when (eq (current-buffer) (get-buffer "*Help*"))      (when (eq (current-buffer) (get-buffer "*Help*"))
580        (error "Can't do self inspection"))        (error "Can't describe char in Help buffer"))
581      (with-output-to-temp-buffer "*Help*"      (with-output-to-temp-buffer "*Help*"
582        (with-current-buffer standard-output        (with-current-buffer standard-output
583          (set-buffer-multibyte multibyte-p)          (set-buffer-multibyte multibyte-p)
584          (let ((formatter (format "%%%ds:" max-width)))          (let ((formatter (format "%%%ds:" max-width)))
585            (dolist (elt item-list)            (dolist (elt item-list)
586              (insert (format formatter (car elt)))              (when (cadr elt)
587              (dolist (clm (cdr elt))                (insert (format formatter (car elt)))
588                (when (>= (+ (current-column)                (dolist (clm (cdr elt))
589                             (or (string-match "\n" clm)                  (when (>= (+ (current-column)
590                                 (string-width clm)) 1)                               (or (string-match "\n" clm)
591                          (frame-width))                                   (string-width clm)) 1)
592                  (insert "\n")                            (frame-width))
593                  (indent-to (1+ max-width)))                    (insert "\n")
594                (insert " " clm))                    (indent-to (1+ max-width)))
595              (insert "\n")))                  (insert " " clm))
596                  (insert "\n"))))
597    
598            (when disp-vector
599              (insert
600               "\nThe display table entry is displayed by ")
601              (if (display-graphic-p (selected-frame))
602                  (progn
603                    (insert "these fonts (glyph codes):\n")
604                    (dotimes (i (length disp-vector))
605                      (insert (car (aref disp-vector i)) ?:
606                              (propertize " " 'display '(space :align-to 5))
607                              (if (cdr (aref disp-vector i))
608                                  (format "%s (0x%02X)" (cadr (aref disp-vector i))
609                                          (cddr (aref disp-vector i)))
610                                "-- no font --")
611                              "\n ")))
612                (insert "these terminal codes:\n")
613                (dotimes (i (length disp-vector))
614                  (insert (car (aref disp-vector i))
615                          (propertize " " 'display '(space :align-to 5))
616                          (or (cdr (aref disp-vector i)) "-- not encodable --")
617                          "\n"))))
618    
619          (when composition          (when composition
620            (insert "\nComposed with the "            (insert "\nComposed")
621                    (cond            (if (car composition)
622                     ((eq pos (car composition)) "following ")                (if (cadr composition)
623                     ((eq (1+ pos) (cadr composition)) "preceding ")                    (insert " with the surrounding characters \""
624                     (t ""))                            (car composition) "\" and \""
625                    "character(s) `"                            (cadr composition) "\"")
626                    (cond                  (insert " with the preceding character(s) \""
627                     ((eq pos (car composition)) (substring composed 1))                          (car composition) "\""))
628                     ((eq (1+ pos) (cadr composition)) (substring composed 0 -1))              (if (cadr composition)
629                     (t (concat (substring composed 0 (- pos (car composition)))                  (insert " with the following character(s) \""
630                                "' and `"                          (cadr composition) "\"")))
631                                (substring composed (- (1+ pos) (car composition))))))            (insert " by the rule:\n\t("
632                      (mapconcat (lambda (x)
633                    "' to form `" composed "'")                                 (format (if (consp x) "%S" "?%c") x))
634            (if (nth 3 composition)                               (nth 2 composition)
635                (insert ".\n")                               " ")
636              (insert "\nby the rule ("                    ")")
637                      (mapconcat (lambda (x)            (insert  "\nThe component character(s) are displayed by ")
638                                   (format (if (consp x) "%S" "?%c") x))            (if (display-graphic-p (selected-frame))
639                                 (nth 2 composition)                (progn
640                                 " ")                  (insert "these fonts (glyph codes):")
641                      ").\n"                  (dolist (elt component-chars)
642                      "See the variable `reference-point-alist' for "                    (insert "\n " (car elt) ?:
643                      "the meaning of the rule.\n")))                            (propertize " " 'display '(space :align-to 5))
644                              (if (cdr elt)
645                                  (format "%s (0x%02X)" (cadr elt) (cddr elt))
646                                "-- no font --"))))
647                (insert "these terminal codes:")
648                (dolist (elt component-chars)
649                  (insert "\n  " (car elt) ":"
650                          (propertize " " 'display '(space :align-to 5))
651                          (or (cdr elt) "-- not encodable --"))))
652              (insert "\nSee the variable `reference-point-alist' for "
653                      "the meaning of the rule.\n"))
654    
655          (let ((output (current-buffer)))          (let ((output (current-buffer)))
656            (with-current-buffer buffer            (with-current-buffer buffer
657              (describe-text-properties pos output))              (describe-text-properties pos output))
658            (describe-text-mode))))))            (describe-text-mode))))))
659    
660    (defalias 'describe-char-after 'describe-char)
661    (make-obsolete 'describe-char-after 'describe-char "21.5")
662    
663  (provide 'descr-text)  (provide 'descr-text)
664    
665    ;;; arch-tag: fc55a498-f3e9-4312-b5bd-98cc02480af1
666  ;;; descr-text.el ends here  ;;; descr-text.el ends here

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

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