/[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.10 by lektu, Tue Feb 4 11:09:25 2003 UTC revision 1.11 by fx, Wed May 21 22:00:01 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 217  otherwise." Line 219  otherwise."
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    (defcustom unicodedata-file nil
223      "Location of Unicode data file.
224    This is the UnicodeData.txt file from the Unicode consortium, used for
225    diagnostics.  If it is non-nil `describe-char-after' will print data
226    looked up from it.  This facility is mostly of use to people doing
227    multilingual development.
228    
229    This is a fairly large file, not typically present on GNU systems.  At
230    the time of writing it is at
231    <URL:ftp://www.unicode.org/Public/UNIDATA/UnicodeData.txt>."
232      :group 'mule
233      :version "21.5"
234      :type '(choice (const :tag "None" nil)
235                     file))
236    
237    ;; We could convert the unidata file into a Lispy form once-for-all
238    ;; and distribute it for loading on demand.  It might be made more
239    ;; space-efficient by splitting strings word-wise and replacing them
240    ;; with lists of symbols interned in a private obarray, e.g.
241    ;; "LATIN SMALL LETTER A" => '(LATIN SMALL LETTER A).
242    
243    ;; Fixme: Check whether this needs updating for Unicode 4.
244    (defun unicode-data (char)
245      "Return a list of Unicode data for unicode CHAR.
246    Each element is a list of a property description and the property value.
247    The list is null if CHAR isn't found in `unicodedata-file'."
248      (when unicodedata-file
249        (unless (file-exists-p unicodedata-file)
250          (error "`unicodedata-file' %s not found" unicodedata-file))
251        (save-excursion
252          ;; Find file in fundamental mode to avoid, e.g. flyspell turned
253          ;; on for .txt.  Don't use RAWFILE arg in case of DOS line endings.
254          (set-buffer (let ((auto-mode-alist))
255                        (find-file-noselect unicodedata-file)))
256          (goto-char (point-min))
257          (let ((hex (format "%04X" char))
258                found first last)
259            (if (re-search-forward (concat "^" hex) nil t)
260                (setq found t)
261              ;; It's not listed explicitly.  Look for ranges, e.g. CJK
262              ;; ideographs, and check whether it's in one of them.
263              (while (and (re-search-forward "^\\([^;]+\\);[^;]+First>;" nil t)
264                          (>= char (setq first
265                                         (string-to-number (match-string 1) 16)))
266                          (progn
267                            (forward-line 1)
268                            (looking-at "^\\([^;]+\\);[^;]+Last>;")
269                            (> char
270                               (setq last
271                                     (string-to-number (match-string 1) 16))))))
272              (if (and (>= char first)
273                       (<= char last))
274                  (setq found t)))
275            (if found
276                (let ((fields (mapcar (lambda (elt)
277                                        (if (> (length elt) 0)
278                                            elt))
279                                      (cdr (split-string
280                                            (buffer-substring
281                                             (line-beginning-position)
282                                             (line-end-position))
283                                            ";")))))
284                  ;; The length depends on whether the last field was empty.
285                  (unless (or (= 13 (length fields))
286                              (= 14 (length fields)))
287                    (error "Invalid contents in %s" unicodedata-file))
288                  ;; The field names and values lists are slightly
289                  ;; modified from Mule-UCS unidata.el.
290                  (list
291                   (list "Name" (let ((name (nth 0 fields)))
292                                  ;; Check for <..., First>, <..., Last>
293                                  (if (string-match "\\`\\(<[^,]+\\)," name)
294                                      (concat (match-string 1 name) ">")
295                                    name)))
296                   (list "Category"
297                         (cdr (assoc
298                               (nth 1 fields)
299                               '(("Lu" . "uppercase letter")
300                                 ("Ll" . "lowercase letter")
301                                 ("Lt" . "titlecase letter")
302                                 ("Mn" . "non-spacing mark")
303                                 ("Mc" . "spacing-combining mark")
304                                 ("Me" . "enclosing mark")
305                                 ("Nd" . "decimal digit")
306                                 ("Nl" . "letter number")
307                                 ("No" . "other number")
308                                 ("Zs" . "space separator")
309                                 ("Zl" . "line separator")
310                                 ("Zp" . "paragraph separator")
311                                 ("Cc" . "other control")
312                                 ("Cf" . "other format")
313                                 ("Cs" . "surrogate")
314                                 ("Co" . "private use")
315                                 ("Cn" . "not assigned")
316                                 ("Lm" . "modifier letter")
317                                 ("Lo" . "other letter")
318                                 ("Pc" . "connector punctuation")
319                                 ("Pd" . "dash punctuation")
320                                 ("Ps" . "open punctuation")
321                                 ("Pe" . "close punctuation")
322                                 ("Pi" . "initial-quotation punctuation")
323                                 ("Pf" . "final-quotation punctuation")
324                                 ("Po" . "other punctuation")
325                                 ("Sm" . "math symbol")
326                                 ("Sc" . "currency symbol")
327                                 ("Sk" . "modifier symbol")
328                                 ("So" . "other symbol")))))
329                   (list "Combining class"
330                         (cdr (assoc
331                               (string-to-number (nth 2 fields))
332                               '((0 . "Spacing")
333                                 (1 . "Overlays and interior")
334                                 (7 . "Nuktas")
335                                 (8 . "Hiragana/Katakana voicing marks")
336                                 (9 . "Viramas")
337                                 (10 . "Start of fixed position classes")
338                                 (199 . "End of fixed position classes")
339                                 (200 . "Below left attached")
340                                 (202 . "Below attached")
341                                 (204 . "Below right attached")
342                                 (208 . "Left attached (reordrant around \
343    single base character)")
344                                 (210 . "Right attached")
345                                 (212 . "Above left attached")
346                                 (214 . "Above attached")
347                                 (216 . "Above right attached")
348                                 (218 . "Below left")
349                                 (220 . "Below")
350                                 (222 . "Below right")
351                                 (224 . "Left (reordrant around single base \
352    character)")
353                                 (226 . "Right")
354                                 (228 . "Above left")
355                                 (230 . "Above")
356                                 (232 . "Above right")
357                                 (233 . "Double below")
358                                 (234 . "Double above")
359                                 (240 . "Below (iota subscript)")))))
360                   (list "Bidi category"
361                         (cdr (assoc
362                               (nth 3 fields)
363                               '(("L" . "Left-to-Right")
364                                 ("LRE" . "Left-to-Right Embedding")
365                                 ("LRO" . "Left-to-Right Override")
366                                 ("R" . "Right-to-Left")
367                                 ("AL" . "Right-to-Left Arabic")
368                                 ("RLE" . "Right-to-Left Embedding")
369                                 ("RLO" . "Right-to-Left Override")
370                                 ("PDF" . "Pop Directional Format")
371                                 ("EN" . "European Number")
372                                 ("ES" . "European Number Separator")
373                                 ("ET" . "European Number Terminator")
374                                 ("AN" . "Arabic Number")
375                                 ("CS" . "Common Number Separator")
376                                 ("NSM" . "Non-Spacing Mark")
377                                 ("BN" . "Boundary Neutral")
378                                 ("B" . "Paragraph Separator")
379                                 ("S" . "Segment Separator")
380                                 ("WS" . "Whitespace")
381                                 ("ON" . "Other Neutrals")))))
382                   (list
383                    "Decomposition"
384                    (if (nth 4 fields)
385                        (let* ((parts (split-string (nth 4 fields)))
386                               (info (car parts)))
387                          (if (string-match "\\`<\\(.+\\)>\\'" info)
388                              (setq info (match-string 1 info))
389                            (setq info nil))
390                          (if info (setq parts (cdr parts)))
391                          ;; Maybe printing ? for unrepresentable unicodes
392                          ;; here and below should be changed?
393                          (setq parts (mapconcat
394                                       (lambda (arg)
395                                         (string (or (decode-char
396                                                      'ucs
397                                                      (string-to-number arg 16))
398                                                     ??)))
399                                       parts " "))
400                          (concat info parts))))
401                   (list "Decimal digit value"
402                         (nth 5 fields))
403                   (list "Digit value"
404                         (nth 6 fields))
405                   (list "Numeric value"
406                         (nth 7 fields))
407                   (list "Mirrored"
408                         (if (equal "Y" (nth 8 fields))
409                             "yes"))
410                   (list "Old name" (nth 9 fields))
411                   (list "ISO 10646 comment" (nth 10 fields))
412                   (list "Uppercase" (and (nth 11 fields)
413                                          (string (or (decode-char
414                                                       'ucs
415                                                       (string-to-number
416                                                        (nth 11 fields) 16))
417                                                      ??))))
418                   (list "Lowercase" (and (nth 12 fields)
419                                          (string (or (decode-char
420                                                       'ucs
421                                                       (string-to-number
422                                                        (nth 12 fields) 16))
423                                                      ??))))
424                   (list "Titlecase" (and (nth 13 fields)
425                                          (string (or (decode-char
426                                                       'ucs
427                                                       (string-to-number
428                                                        (nth 13 fields) 16))
429                                                      ??)))))))))))
430    
431  ;;;###autoload  ;;;###autoload
432  (defun describe-char (pos)  (defun describe-char (pos)
433    "Describe the character after POS (interactively, the character after point).    "Describe the character after POS (interactively, the character after point).
# Line 234  as well as widgets, buttons, overlays, a Line 445  as well as widgets, buttons, overlays, a
445           (composed (if composition (buffer-substring (car composition)           (composed (if composition (buffer-substring (car composition)
446                                                       (nth 1 composition))))                                                       (nth 1 composition))))
447           (multibyte-p enable-multibyte-characters)           (multibyte-p enable-multibyte-characters)
448           item-list max-width)           item-list max-width unicode)
449      (if (eq charset 'unknown)      (if (eq charset 'unknown)
450          (setq item-list          (setq item-list
451                `(("character"                `(("character"
# Line 243  as well as widgets, buttons, overlays, a Line 454  as well as widgets, buttons, overlays, a
454                                (single-key-description char)                                (single-key-description char)
455                              (char-to-string char))                              (char-to-string char))
456                            char char char))))                            char char char))))
457    
458          (if (or (< (char-after) 256)
459                  (memq 'mule-utf-8 (find-coding-systems-region pos (1+ pos)))
460                  (get-char-property pos 'untranslated-utf-8))
461              (setq unicode (or (get-char-property pos 'untranslated-utf-8)
462                                (encode-char char 'ucs))))
463        (setq item-list        (setq item-list
464              `(("character"              `(("character"
465                 ,(format "%s (0%o, %d, 0x%x)" (if (< char 256)                 ,(format "%s (0%o, %d, 0x%x%s)" (if (< char 256)
466                                                   (single-key-description char)                                                   (single-key-description char)
467                                                 (char-to-string char))                                                 (char-to-string char))
468                          char char char))                          char char char
469                            (if unicode
470                                (format ", U+%04X" (encode-char char 'ucs))
471                              "")))
472                ("charset"                ("charset"
473                 ,(symbol-name charset)                 ,(symbol-name charset)
474                 ,(format "(%s)" (charset-description charset)))                 ,(format "(%s)" (charset-description charset)))
# Line 287  as well as widgets, buttons, overlays, a Line 507  as well as widgets, buttons, overlays, a
507                               (format "(encoded by coding system %S)" coding))                               (format "(encoded by coding system %S)" coding))
508                       (list "not encodable by coding system"                       (list "not encodable by coding system"
509                             (symbol-name coding)))))                             (symbol-name coding)))))
               ,@(if (or (memq 'mule-utf-8  
                           (find-coding-systems-region pos (1+ pos)))  
                         (get-char-property pos 'untranslated-utf-8))  
                     (let ((uc (or (get-char-property pos 'untranslated-utf-8)  
                                   (encode-char char 'ucs))))  
                       (if uc  
                           (list (list "Unicode"  
                                       (format "%04X" uc))))))  
510                ,(if (display-graphic-p (selected-frame))                ,(if (display-graphic-p (selected-frame))
511                     (list "font" (or (internal-char-font pos)                     (list "font" (or (internal-char-font pos)
512                                      "-- none --"))                                      "-- none --"))
# Line 303  as well as widgets, buttons, overlays, a Line 515  as well as widgets, buttons, overlays, a
515                                (encoded (encode-coding-char char coding)))                                (encoded (encode-coding-char char coding)))
516                           (if encoded                           (if encoded
517                               (encoded-string-description encoded coding)                               (encoded-string-description encoded coding)
518                             "not encodable")))))))                             "not encodable"))))
519                  ,@(let ((unicodedata (and unicode
520                                           (unicode-data unicode))))
521                      (if unicodedata
522                          (cons (list "Unicode data" " ") unicodedata))))))
523      (setq max-width (apply #'max (mapcar #'(lambda (x) (length (car x)))      (setq max-width (apply #'max (mapcar #'(lambda (x) (length (car x)))
524                                           item-list)))                                           item-list)))
525      (when (eq (current-buffer) (get-buffer "*Help*"))      (when (eq (current-buffer) (get-buffer "*Help*"))
526        (error "Can't do self inspection"))        (error "Can't describe char in Help buffer"))
527      (with-output-to-temp-buffer "*Help*"      (with-output-to-temp-buffer "*Help*"
528        (with-current-buffer standard-output        (with-current-buffer standard-output
529          (set-buffer-multibyte multibyte-p)          (set-buffer-multibyte multibyte-p)
530          (let ((formatter (format "%%%ds:" max-width)))          (let ((formatter (format "%%%ds:" max-width)))
531            (dolist (elt item-list)            (dolist (elt item-list)
532              (insert (format formatter (car elt)))              (when (cadr elt)
533              (dolist (clm (cdr elt))                (insert (format formatter (car elt)))
534                (when (>= (+ (current-column)                (dolist (clm (cdr elt))
535                             (or (string-match "\n" clm)                  (when (>= (+ (current-column)
536                                 (string-width clm)) 1)                               (or (string-match "\n" clm)
537                          (frame-width))                                   (string-width clm)) 1)
538                  (insert "\n")                            (frame-width))
539                  (indent-to (1+ max-width)))                    (insert "\n")
540                (insert " " clm))                    (indent-to (1+ max-width)))
541              (insert "\n")))                  (insert " " clm))
542                  (insert "\n"))))
543          (when composition          (when composition
544            (insert "\nComposed with the "            (insert "\nComposed with the "
545                    (cond                    (cond
# Line 354  as well as widgets, buttons, overlays, a Line 571  as well as widgets, buttons, overlays, a
571              (describe-text-properties pos output))              (describe-text-properties pos output))
572            (describe-text-mode))))))            (describe-text-mode))))))
573    
574    (defalias 'describe-char-after 'describe-char)
575    (make-obsolete 'describe-char-after 'describe-char "21.5")
576    
577  (provide 'descr-text)  (provide 'descr-text)
578    
579  ;;; descr-text.el ends here  ;;; descr-text.el ends here

Legend:
Removed from v.1.10  
changed lines
  Added in v.1.11

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