aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--lisp/ChangeLog8
-rw-r--r--lisp/descr-text.el785
2 files changed, 407 insertions, 386 deletions
diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index b0cc109162b..f44529c9bc0 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,5 +1,13 @@
12009-11-24 Stefan Monnier <monnier@iro.umontreal.ca> 12009-11-24 Stefan Monnier <monnier@iro.umontreal.ca>
2 2
3 Handle the [back] button properly (bug#4979).
4 * descr-text.el (describe-text-properties): Add a `buffer' argument.
5 Use help-setup-xref, help-buffer, and with-help-window.
6 (describe-char): Add `buffer' argument.
7 Pass proper command to help-setup-xref. Don't meddle with
8 help-xref-stack-item directly.
9 (describe-text-category): Use with-help-window and help-buffer.
10
3 * emacs-lisp/shadow.el (list-load-path-shadows): Setup a major mode 11 * emacs-lisp/shadow.el (list-load-path-shadows): Setup a major mode
4 for the displayed buffer (bug#4887). 12 for the displayed buffer (bug#4887).
5 13
diff --git a/lisp/descr-text.el b/lisp/descr-text.el
index c952ef1d796..d289f7d6d47 100644
--- a/lisp/descr-text.el
+++ b/lisp/descr-text.el
@@ -103,39 +103,41 @@ into help buttons that call `describe-text-category' or
103 (interactive "SCategory: ") 103 (interactive "SCategory: ")
104 (help-setup-xref (list #'describe-text-category category) 104 (help-setup-xref (list #'describe-text-category category)
105 (called-interactively-p 'interactive)) 105 (called-interactively-p 'interactive))
106 (save-excursion 106 (with-help-window (help-buffer)
107 (with-output-to-temp-buffer "*Help*" 107 (with-current-buffer standard-output
108 (set-buffer standard-output)
109 (insert "Category " (format "%S" category) ":\n\n") 108 (insert "Category " (format "%S" category) ":\n\n")
110 (describe-property-list (symbol-plist category)) 109 (describe-property-list (symbol-plist category))
111 (goto-char (point-min))))) 110 (goto-char (point-min)))))
112 111
113;;;###autoload 112;;;###autoload
114(defun describe-text-properties (pos &optional output-buffer) 113(defun describe-text-properties (pos &optional output-buffer buffer)
115 "Describe widgets, buttons, overlays and text properties at POS. 114 "Describe widgets, buttons, overlays, and text properties at POS.
115POS is taken to be in BUFFER or in current buffer if nil.
116Interactively, describe them for the character after point. 116Interactively, describe them for the character after point.
117If optional second argument OUTPUT-BUFFER is non-nil, 117If optional second argument OUTPUT-BUFFER is non-nil,
118insert the output into that buffer, and don't initialize or clear it 118insert the output into that buffer, and don't initialize or clear it
119otherwise." 119otherwise."
120 (interactive "d") 120 (interactive "d")
121 (let ((src-buf (current-buffer)))
122 (if buffer (set-buffer buffer) (setq buffer (current-buffer)))
121 (if (>= pos (point-max)) 123 (if (>= pos (point-max))
122 (error "No character follows specified position")) 124 (error "No character follows specified position"))
123 (if output-buffer 125 (if output-buffer
124 (describe-text-properties-1 pos output-buffer) 126 (describe-text-properties-1 pos output-buffer)
125 (if (not (or (text-properties-at pos) (overlays-at pos))) 127 (if (not (or (text-properties-at pos) (overlays-at pos)))
126 (message "This is plain text.") 128 (message "This is plain text.")
127 (let ((buffer (current-buffer)) 129 (with-temp-buffer
128 (target-buffer "*Help*"))
129 (when (eq buffer (get-buffer target-buffer))
130 (setq target-buffer "*Help*<2>"))
131 (save-excursion
132 (with-output-to-temp-buffer target-buffer
133 (set-buffer standard-output)
134 (setq output-buffer (current-buffer)) 130 (setq output-buffer (current-buffer))
135 (insert "Text content at position " (format "%d" pos) ":\n\n") 131 (insert "Text content at position " (format "%d" pos) ":\n\n")
136 (with-current-buffer buffer 132 (set-buffer buffer)
137 (describe-text-properties-1 pos output-buffer)) 133 (describe-text-properties-1 pos output-buffer)
138 (goto-char (point-min)))))))) 134 (set-buffer src-buf)
135 (help-setup-xref (list 'describe-text-properties pos nil buffer)
136 (called-interactively-p 'interactive))
137 (with-help-window (help-buffer)
138 (with-current-buffer standard-output
139 (buffer-swap-text output-buffer)
140 (goto-char (point-min)))))))))
139 141
140(defun describe-text-properties-1 (pos output-buffer) 142(defun describe-text-properties-1 (pos output-buffer)
141 (let* ((properties (text-properties-at pos)) 143 (let* ((properties (text-properties-at pos))
@@ -373,383 +375,394 @@ This function is semi-obsolete. Use `get-char-code-property'."
373 mnemonics ", "))))) 375 mnemonics ", ")))))
374 376
375;;;###autoload 377;;;###autoload
376(defun describe-char (pos) 378(defun describe-char (pos &optional buffer)
377 "Describe the character after POS (interactively, the character after point). 379 "Describe the character after POS (interactively, the character after point).
380Is POS is taken to be in buffer BUFFER or current buffer if nil.
378The information includes character code, charset and code points in it, 381The information includes character code, charset and code points in it,
379syntax, category, how the character is encoded in a file, 382syntax, category, how the character is encoded in a file,
380character composition information (if relevant), 383character composition information (if relevant),
381as well as widgets, buttons, overlays, and text properties." 384as well as widgets, buttons, overlays, and text properties."
382 (interactive "d") 385 (interactive "d")
383 (if (>= pos (point-max)) 386 (unless (buffer-live-p buffer) (setq buffer (current-buffer)))
384 (error "No character follows specified position")) 387 (let ((src-buf (current-buffer)))
385 (let* ((char (char-after pos)) 388 (set-buffer buffer)
386 (eight-bit-p (and (not enable-multibyte-characters) (>= char 128))) 389 (if (>= pos (point-max))
387 (charset (if eight-bit-p 'eight-bit 390 (error "No character follows specified position"))
388 (or (get-text-property pos 'charset) (char-charset char)))) 391 (let* ((char (char-after pos))
389 (composition (find-composition pos nil nil t)) 392 (eight-bit-p (and (not enable-multibyte-characters) (>= char 128)))
390 (component-chars nil) 393 (charset (if eight-bit-p 'eight-bit
391 (display-table (or (window-display-table) 394 (or (get-text-property pos 'charset)
392 buffer-display-table 395 (char-charset char))))
393 standard-display-table)) 396 (composition (find-composition pos nil nil t))
394 (disp-vector (and display-table (aref display-table char))) 397 (component-chars nil)
395 (multibyte-p enable-multibyte-characters) 398 (display-table (or (window-display-table)
396 (overlays (mapcar #'(lambda (o) (overlay-properties o)) 399 buffer-display-table
397 (overlays-at pos))) 400 standard-display-table))
398 (char-description (if (not multibyte-p) 401 (disp-vector (and display-table (aref display-table char)))
399 (single-key-description char) 402 (multibyte-p enable-multibyte-characters)
400 (if (< char 128) 403 (overlays (mapcar #'(lambda (o) (overlay-properties o))
401 (single-key-description char) 404 (overlays-at pos)))
402 (string-to-multibyte 405 (char-description (if (not multibyte-p)
403 (char-to-string char))))) 406 (single-key-description char)
404 (text-props-desc 407 (if (< char 128)
405 (let ((tmp-buf (generate-new-buffer " *text-props*"))) 408 (single-key-description char)
406 (unwind-protect 409 (string-to-multibyte
407 (progn 410 (char-to-string char)))))
408 (describe-text-properties pos tmp-buf) 411 (text-props-desc
409 (with-current-buffer tmp-buf (buffer-string))) 412 (let ((tmp-buf (generate-new-buffer " *text-props*")))
410 (kill-buffer tmp-buf)))) 413 (unwind-protect
411 item-list max-width code) 414 (progn
412 415 (describe-text-properties pos tmp-buf)
413 (if multibyte-p 416 (with-current-buffer tmp-buf (buffer-string)))
414 (or (setq code (encode-char char charset)) 417 (kill-buffer tmp-buf))))
415 (setq charset (char-charset char) 418 item-list max-width code)
416 code (encode-char char charset))) 419
417 (setq code char)) 420 (if multibyte-p
418 (when composition 421 (or (setq code (encode-char char charset))
419 ;; When the composition is trivial (i.e. composed only with the 422 (setq charset (char-charset char)
420 ;; current character itself without any alternate characters), 423 code (encode-char char charset)))
421 ;; we don't show the composition information. Otherwise, store 424 (setq code char))
422 ;; two descriptive strings in the first two elments of 425 (when composition
423 ;; COMPOSITION. 426 ;; When the composition is trivial (i.e. composed only with the
424 (or (catch 'tag 427 ;; current character itself without any alternate characters),
425 (let ((from (car composition)) 428 ;; we don't show the composition information. Otherwise, store
426 (to (nth 1 composition)) 429 ;; two descriptive strings in the first two elments of
427 (next (1+ pos)) 430 ;; COMPOSITION.
428 (components (nth 2 composition)) 431 (or (catch 'tag
429 ch) 432 (let ((from (car composition))
430 (if (and (vectorp components) (vectorp (aref components 0))) 433 (to (nth 1 composition))
431 (let ((idx (- pos from)) 434 (components (nth 2 composition))
432 (nglyphs (lgstring-glyph-len components)) 435 ch)
433 (i 0) j glyph glyph-from) 436 (if (and (vectorp components) (vectorp (aref components 0)))
434 ;; COMPONENTS is a gstring. Find a grapheme 437 (let ((idx (- pos from))
435 ;; cluster containing the current character. 438 (nglyphs (lgstring-glyph-len components))
436 (while (and (< i nglyphs) 439 (i 0) j glyph glyph-from)
437 (setq glyph (lgstring-glyph components i)) 440 ;; COMPONENTS is a gstring. Find a grapheme
438 (< (lglyph-to glyph) idx)) 441 ;; cluster containing the current character.
439 (setq i (1+ i))) 442 (while (and (< i nglyphs)
440 (if (or (not glyph) (= i nglyphs)) 443 (setq glyph (lgstring-glyph components i))
441 ;; The composition is broken. 444 (< (lglyph-to glyph) idx))
442 (throw 'tag nil)) 445 (setq i (1+ i)))
443 (setq glyph-from (lglyph-from glyph) 446 (if (or (not glyph) (= i nglyphs))
444 to (+ from (lglyph-to glyph) 1) 447 ;; The composition is broken.
445 from (+ from glyph-from) 448 (throw 'tag nil))
446 j i) 449 (setq glyph-from (lglyph-from glyph)
447 (while (and (< j nglyphs) 450 to (+ from (lglyph-to glyph) 1)
448 (setq glyph (lgstring-glyph components j)) 451 from (+ from glyph-from)
449 (= (lglyph-from glyph) glyph-from)) 452 j i)
450 (setq j (1+ j))) 453 (while (and (< j nglyphs)
451 (if (and (= to (1+ from)) 454 (setq glyph (lgstring-glyph components j))
452 (= i (1- j)) 455 (= (lglyph-from glyph) glyph-from))
453 (setq glyph (lgstring-glyph components i)) 456 (setq j (1+ j)))
454 (= char (lglyph-char glyph))) 457 (if (and (= to (1+ from))
455 ;; The composition is trivial. 458 (= i (1- j))
456 (throw 'tag nil)) 459 (setq glyph (lgstring-glyph components i))
457 (nconc composition (list i (1- j)))) 460 (= char (lglyph-char glyph)))
458 (dotimes (i (length components)) 461 ;; The composition is trivial.
459 (if (integerp (setq ch (aref components i))) 462 (throw 'tag nil))
460 (push (cons ch (describe-char-display pos ch)) 463 (nconc composition (list i (1- j))))
461 component-chars))) 464 (dotimes (i (length components))
462 (setq component-chars (nreverse component-chars))) 465 (if (integerp (setq ch (aref components i)))
463 (if (< from pos) 466 (push (cons ch (describe-char-display pos ch))
464 (if (< (1+ pos) to) 467 component-chars)))
465 (setcar composition 468 (setq component-chars (nreverse component-chars)))
466 (concat 469 (if (< from pos)
467 " with the surrounding characters \"" 470 (if (< (1+ pos) to)
468 (mapconcat 'describe-char-padded-string 471 (setcar composition
469 (buffer-substring from pos) "") 472 (concat
470 "\" and \"" 473 " with the surrounding characters \""
471 (mapconcat 'describe-char-padded-string 474 (mapconcat 'describe-char-padded-string
472 (buffer-substring (1+ pos) to) "") 475 (buffer-substring from pos) "")
473 "\"")) 476 "\" and \""
474 (setcar composition 477 (mapconcat 'describe-char-padded-string
475 (concat 478 (buffer-substring (1+ pos) to) "")
476 " with the preceding character(s) \"" 479 "\""))
477 (mapconcat 'describe-char-padded-string 480 (setcar composition
478 (buffer-substring from pos) "") 481 (concat
479 "\""))) 482 " with the preceding character(s) \""
480 (if (< (1+ pos) to) 483 (mapconcat 'describe-char-padded-string
481 (setcar composition 484 (buffer-substring from pos) "")
482 (concat 485 "\"")))
483 " with the following character(s) \"" 486 (if (< (1+ pos) to)
484 (mapconcat 'describe-char-padded-string 487 (setcar composition
485 (buffer-substring (1+ pos) to) "") 488 (concat
486 "\"")) 489 " with the following character(s) \""
487 (setcar composition nil))) 490 (mapconcat 'describe-char-padded-string
488 (setcar (cdr composition) 491 (buffer-substring (1+ pos) to) "")
489 (format "composed to form \"%s\" (see below)" 492 "\""))
490 (buffer-substring from to))))) 493 (setcar composition nil)))
491 (setq composition nil))) 494 (setcar (cdr composition)
492 495 (format "composed to form \"%s\" (see below)"
493 (setq item-list 496 (buffer-substring from to)))))
494 `(("character" 497 (setq composition nil)))
495 ,(format "%s (%d, #o%o, #x%x)" 498
496 (apply 'propertize char-description 499 (setq item-list
497 (text-properties-at pos)) 500 `(("character"
498 char char char)) 501 ,(format "%s (%d, #o%o, #x%x)"
499 ("preferred charset" 502 (apply 'propertize char-description
500 ,`(insert-text-button 503 (text-properties-at pos))
501 ,(symbol-name charset) 504 char char char))
502 'type 'help-character-set 'help-args '(,charset)) 505 ("preferred charset"
503 ,(format "(%s)" (charset-description charset))) 506 ,`(insert-text-button
504 ("code point" 507 ,(symbol-name charset)
505 ,(let ((str (if (integerp code) 508 'type 'help-character-set 'help-args '(,charset))
506 (format (if (< code 256) "0x%02X" "0x%04X") code) 509 ,(format "(%s)" (charset-description charset)))
507 (format "0x%04X%04X" (car code) (cdr code))))) 510 ("code point"
508 (if (<= (charset-dimension charset) 2) 511 ,(let ((str (if (integerp code)
509 `(insert-text-button 512 (format (if (< code 256) "0x%02X" "0x%04X")
510 ,str 513 code)
511 'action (lambda (&rest ignore) 514 (format "0x%04X%04X" (car code) (cdr code)))))
512 (list-charset-chars ',charset) 515 (if (<= (charset-dimension charset) 2)
513 (with-selected-window 516 `(insert-text-button
514 (get-buffer-window "*Character List*" 0) 517 ,str
515 (goto-char (point-min)) 518 'action (lambda (&rest ignore)
516 (forward-line 2) ;Skip the header. 519 (list-charset-chars ',charset)
517 (let ((case-fold-search nil)) 520 (with-selected-window
518 (if (search-forward ,(char-to-string char) 521 (get-buffer-window "*Character List*" 0)
519 nil t) 522 (goto-char (point-min))
520 (goto-char (match-beginning 0)))))) 523 (forward-line 2) ;Skip the header.
521 'follow-link t 524 (let ((case-fold-search nil))
522 'help-echo 525 (if (search-forward
523 "mouse-2, RET: show this character in its character set") 526 ,(char-to-string char) nil t)
524 str))) 527 (goto-char (match-beginning 0))))))
525 ("syntax" 528 'follow-link t
526 ,(let ((syntax (syntax-after pos))) 529 'help-echo
527 (with-temp-buffer 530 "mouse-2, RET: show this character in its character set")
528 (internal-describe-syntax-value syntax) 531 str)))
529 (buffer-string)))) 532 ("syntax"
530 ("category" 533 ,(let ((syntax (syntax-after pos)))
531 ,@(if (not eight-bit-p) 534 (with-temp-buffer
532 (let ((category-set (char-category-set char))) 535 (internal-describe-syntax-value syntax)
533 (if category-set 536 (buffer-string))))
534 (describe-char-categories category-set) 537 ("category"
535 '("-- none --"))))) 538 ,@(if (not eight-bit-p)
536 ("to input" 539 (let ((category-set (char-category-set char)))
537 ,@(if (not eight-bit-p) 540 (if category-set
538 (let ((key-list (and (eq input-method-function 541 (describe-char-categories category-set)
539 'quail-input-method) 542 '("-- none --")))))
540 (quail-find-key char)))) 543 ("to input"
541 (if (consp key-list) 544 ,@(if (not eight-bit-p)
542 (list "type" 545 (let ((key-list (and (eq input-method-function
543 (mapconcat #'(lambda (x) (concat "\"" x "\"")) 546 'quail-input-method)
544 key-list " or ") 547 (quail-find-key char))))
545 "with" 548 (if (consp key-list)
546 `(insert-text-button 549 (list "type"
547 ,current-input-method 550 (concat "\""
548 'type 'help-input-method 551 (mapconcat 'identity
549 'help-args '(,current-input-method))))))) 552 key-list "\" or \"")
550 ("buffer code" 553 "\"")
551 ,(if multibyte-p 554 "with"
552 (encoded-string-description 555 `(insert-text-button
553 (string-as-unibyte (char-to-string char)) nil) 556 ,current-input-method
554 (format "#x%02X" char))) 557 'type 'help-input-method
555 ("file code" 558 'help-args '(,current-input-method)))))))
556 ,@(if multibyte-p 559 ("buffer code"
557 (let* ((coding buffer-file-coding-system) 560 ,(if multibyte-p
558 (encoded (encode-coding-char char coding charset))) 561 (encoded-string-description
559 (if encoded 562 (string-as-unibyte (char-to-string char)) nil)
560 (list (encoded-string-description encoded coding) 563 (format "#x%02X" char)))
561 (format "(encoded by coding system %S)" coding)) 564 ("file code"
562 (list "not encodable by coding system" 565 ,@(if multibyte-p
563 (symbol-name coding)))) 566 (let* ((coding buffer-file-coding-system)
564 (list (format "#x%02X" char)))) 567 (encoded (encode-coding-char char coding charset)))
565 ("display" 568 (if encoded
566 ,(cond 569 (list (encoded-string-description encoded coding)
567 (disp-vector 570 (format "(encoded by coding system %S)"
568 (setq disp-vector (copy-sequence disp-vector)) 571 coding))
569 (dotimes (i (length disp-vector)) 572 (list "not encodable by coding system"
570 (aset disp-vector i 573 (symbol-name coding))))
571 (cons (aref disp-vector i) 574 (list (format "#x%02X" char))))
572 (describe-char-display 575 ("display"
573 pos (glyph-char (aref disp-vector i)))))) 576 ,(cond
574 (format "by display table entry [%s] (see below)" 577 (disp-vector
575 (mapconcat 578 (setq disp-vector (copy-sequence disp-vector))
576 #'(lambda (x) 579 (dotimes (i (length disp-vector))
577 (format "?%c" (glyph-char (car x)))) 580 (aset disp-vector i
578 disp-vector " "))) 581 (cons (aref disp-vector i)
579 (composition 582 (describe-char-display
580 (cadr composition)) 583 pos (glyph-char (aref disp-vector i))))))
581 (t 584 (format "by display table entry [%s] (see below)"
582 (let ((display (describe-char-display pos char))) 585 (mapconcat
583 (if (display-graphic-p (selected-frame)) 586 #'(lambda (x)
584 (if display 587 (format "?%c" (glyph-char (car x))))
585 (concat "by this font (glyph code)\n " display) 588 disp-vector " ")))
586 "no font available") 589 (composition
587 (if display 590 (cadr composition))
588 (format "terminal code %s" display) 591 (t
589 "not encodable for terminal")))))) 592 (let ((display (describe-char-display pos char)))
590 ,@(let ((face 593 (if (display-graphic-p (selected-frame))
591 (if (not (or disp-vector composition)) 594 (if display
592 (cond 595 (concat "by this font (glyph code)\n " display)
593 ((and show-trailing-whitespace 596 "no font available")
594 (save-excursion (goto-char pos) 597 (if display
595 (looking-at-p "[ \t]+$"))) 598 (format "terminal code %s" display)
596 'trailing-whitespace) 599 "not encodable for terminal"))))))
597 ((and nobreak-char-display char (eq char '#xa0)) 600 ,@(let ((face
598 'nobreak-space) 601 (if (not (or disp-vector composition))
599 ((and nobreak-char-display char (eq char '#xad)) 602 (cond
600 'escape-glyph) 603 ((and show-trailing-whitespace
601 ((and (< char 32) (not (memq char '(9 10)))) 604 (save-excursion (goto-char pos)
602 'escape-glyph))))) 605 (looking-at-p "[ \t]+$")))
603 (if face (list (list "hardcoded face" 606 'trailing-whitespace)
604 `(insert-text-button 607 ((and nobreak-char-display char (eq char '#xa0))
605 ,(symbol-name face) 608 'nobreak-space)
606 'type 'help-face 'help-args '(,face)))))) 609 ((and nobreak-char-display char (eq char '#xad))
607 ,@(if (not eight-bit-p) 610 'escape-glyph)
608 (let ((unicodedata (describe-char-unicode-data char))) 611 ((and (< char 32) (not (memq char '(9 10))))
609 (if unicodedata 612 'escape-glyph)))))
610 (cons (list "Unicode data" " ") unicodedata)))))) 613 (if face (list (list "hardcoded face"
611 (setq max-width (apply #'max (mapcar #'(lambda (x) 614 `(insert-text-button
612 (if (cadr x) (length (car x)) 0)) 615 ,(symbol-name face)
613 item-list))) 616 'type 'help-face
614 (help-setup-xref nil (called-interactively-p 'interactive)) 617 'help-args '(,face))))))
615 (with-help-window (help-buffer) 618 ,@(if (not eight-bit-p)
616 (with-current-buffer standard-output 619 (let ((unicodedata (describe-char-unicode-data char)))
617 (set-buffer-multibyte multibyte-p) 620 (if unicodedata
618 (let ((formatter (format "%%%ds:" max-width))) 621 (cons (list "Unicode data" " ") unicodedata))))))
619 (dolist (elt item-list) 622 (setq max-width (apply 'max (mapcar (lambda (x)
620 (when (cadr elt) 623 (if (cadr x) (length (car x)) 0))
621 (insert (format formatter (car elt))) 624 item-list)))
622 (dolist (clm (cdr elt)) 625 (set-buffer src-buf)
623 (if (eq (car-safe clm) 'insert-text-button) 626 (help-setup-xref (list 'describe-char pos buffer)
624 (progn (insert " ") (eval clm)) 627 (called-interactively-p 'interactive))
625 (when (>= (+ (current-column) 628 (with-help-window (help-buffer)
626 (or (string-match-p "\n" clm) 629 (with-current-buffer standard-output
627 (string-width clm)) 630 (set-buffer-multibyte multibyte-p)
628 1) 631 (let ((formatter (format "%%%ds:" max-width)))
629 (window-width)) 632 (dolist (elt item-list)
630 (insert "\n") 633 (when (cadr elt)
631 (indent-to (1+ max-width))) 634 (insert (format formatter (car elt)))
632 (insert " " clm))) 635 (dolist (clm (cdr elt))
633 (insert "\n")))) 636 (if (eq (car-safe clm) 'insert-text-button)
634 637 (progn (insert " ") (eval clm))
635 (when overlays 638 (when (>= (+ (current-column)
636 (save-excursion 639 (or (string-match-p "\n" clm)
637 (goto-char (point-min)) 640 (string-width clm))
638 (re-search-forward "character:[ \t\n]+") 641 1)
639 (let ((end (+ (point) (length char-description)))) 642 (window-width))
640 (mapc #'(lambda (props) 643 (insert "\n")
641 (let ((o (make-overlay (point) end))) 644 (indent-to (1+ max-width)))
642 (while props 645 (insert " " clm)))
643 (overlay-put o (car props) (nth 1 props)) 646 (insert "\n"))))
644 (setq props (cddr props))))) 647
645 overlays)))) 648 (when overlays
646 649 (save-excursion
647 (when disp-vector 650 (goto-char (point-min))
648 (insert 651 (re-search-forward "character:[ \t\n]+")
649 "\nThe display table entry is displayed by ") 652 (let ((end (+ (point) (length char-description))))
650 (if (display-graphic-p (selected-frame)) 653 (mapc #'(lambda (props)
651 (progn 654 (let ((o (make-overlay (point) end)))
652 (insert "these fonts (glyph codes):\n") 655 (while props
653 (dotimes (i (length disp-vector)) 656 (overlay-put o (car props) (nth 1 props))
654 (insert (glyph-char (car (aref disp-vector i))) ?: 657 (setq props (cddr props)))))
655 (propertize " " 'display '(space :align-to 5)) 658 overlays))))
656 (or (cdr (aref disp-vector i)) "-- no font --") 659
657 "\n") 660 (when disp-vector
658 (let ((face (glyph-face (car (aref disp-vector i))))) 661 (insert
659 (when face 662 "\nThe display table entry is displayed by ")
660 (insert (propertize " " 'display '(space :align-to 5)) 663 (if (display-graphic-p (selected-frame))
661 "face: ") 664 (progn
662 (insert (concat "`" (symbol-name face) "'")) 665 (insert "these fonts (glyph codes):\n")
663 (insert "\n"))))) 666 (dotimes (i (length disp-vector))
664 (insert "these terminal codes:\n") 667 (insert (glyph-char (car (aref disp-vector i))) ?:
665 (dotimes (i (length disp-vector)) 668 (propertize " " 'display '(space :align-to 5))
666 (insert (car (aref disp-vector i)) 669 (or (cdr (aref disp-vector i)) "-- no font --")
667 (propertize " " 'display '(space :align-to 5)) 670 "\n")
668 (or (cdr (aref disp-vector i)) "-- not encodable --") 671 (let ((face (glyph-face (car (aref disp-vector i)))))
669 "\n")))) 672 (when face
670 673 (insert (propertize " " 'display '(space :align-to 5))
671 (when composition 674 "face: ")
672 (insert "\nComposed") 675 (insert (concat "`" (symbol-name face) "'"))
673 (if (car composition) 676 (insert "\n")))))
674 (insert (car composition))) 677 (insert "these terminal codes:\n")
675 (if (and (vectorp (nth 2 composition)) 678 (dotimes (i (length disp-vector))
676 (vectorp (aref (nth 2 composition) 0))) 679 (insert (car (aref disp-vector i))
677 (let* ((gstring (nth 2 composition)) 680 (propertize " " 'display '(space :align-to 5))
678 (font (lgstring-font gstring)) 681 (or (cdr (aref disp-vector i)) "-- not encodable --")
679 (from (nth 3 composition)) 682 "\n"))))
680 (to (nth 4 composition)) 683
681 glyph) 684 (when composition
682 (if (fontp font) 685 (insert "\nComposed")
683 (progn 686 (if (car composition)
684 (insert " using this font:\n " 687 (insert (car composition)))
685 (symbol-name (font-get font :type)) 688 (if (and (vectorp (nth 2 composition))
686 ?: 689 (vectorp (aref (nth 2 composition) 0)))
687 (aref (query-font font) 0) 690 (let* ((gstring (nth 2 composition))
688 "\nby these glyphs:\n") 691 (font (lgstring-font gstring))
689 (while (and (<= from to) 692 (from (nth 3 composition))
690 (setq glyph (lgstring-glyph gstring from))) 693 (to (nth 4 composition))
691 (insert (format " %S\n" glyph)) 694 glyph)
692 (setq from (1+ from)))) 695 (if (fontp font)
693 (insert " by these characters:\n") 696 (progn
694 (while (and (<= from to) 697 (insert " using this font:\n "
695 (setq glyph (lgstring-glyph gstring from))) 698 (symbol-name (font-get font :type))
696 (insert (format " %c (#x%d)\n" 699 ?:
697 (lglyph-char glyph) (lglyph-char glyph))) 700 (aref (query-font font) 0)
698 (setq from (1+ from))))) 701 "\nby these glyphs:\n")
699 (insert " by the rule:\n\t(") 702 (while (and (<= from to)
700 (let ((first t)) 703 (setq glyph (lgstring-glyph gstring from)))
701 (mapc (lambda (x) 704 (insert (format " %S\n" glyph))
702 (if first (setq first nil) 705 (setq from (1+ from))))
703 (insert " ")) 706 (insert " by these characters:\n")
704 (if (consp x) (insert (format "%S" x)) 707 (while (and (<= from to)
705 (if (= x ?\t) (insert (single-key-description x)) 708 (setq glyph (lgstring-glyph gstring from)))
706 (insert ??) 709 (insert (format " %c (#x%d)\n"
707 (insert (describe-char-padded-string x))))) 710 (lglyph-char glyph) (lglyph-char glyph)))
708 (nth 2 composition))) 711 (setq from (1+ from)))))
709 (insert ")\nThe component character(s) are displayed by ") 712 (insert " by the rule:\n\t(")
710 (if (display-graphic-p (selected-frame)) 713 (let ((first t))
711 (progn 714 (mapc (lambda (x)
712 (insert "these fonts (glyph codes):") 715 (if first (setq first nil)
713 (dolist (elt component-chars) 716 (insert " "))
714 (if (/= (car elt) ?\t) 717 (if (consp x) (insert (format "%S" x))
715 (insert "\n " 718 (if (= x ?\t) (insert (single-key-description x))
716 (describe-char-padded-string (car elt)) 719 (insert ??)
717 ?: 720 (insert (describe-char-padded-string x)))))
718 (propertize " " 'display '(space :align-to 5)) 721 (nth 2 composition)))
719 (or (cdr elt) "-- no font --"))))) 722 (insert ")\nThe component character(s) are displayed by ")
720 (insert "these terminal codes:") 723 (if (display-graphic-p (selected-frame))
721 (dolist (elt component-chars) 724 (progn
722 (insert "\n " (car elt) ":" 725 (insert "these fonts (glyph codes):")
723 (propertize " " 'display '(space :align-to 4)) 726 (dolist (elt component-chars)
724 (or (cdr elt) "-- not encodable --")))) 727 (if (/= (car elt) ?\t)
725 (insert "\nSee the variable `reference-point-alist' for " 728 (insert "\n "
726 "the meaning of the rule.\n"))) 729 (describe-char-padded-string (car elt))
727 730 ?:
728 (unless eight-bit-p 731 (propertize " "
729 (insert (if (not describe-char-unidata-list) 732 'display '(space :align-to 5))
730 "\nCharacter code properties are not shown: " 733 (or (cdr elt) "-- no font --")))))
731 "\nCharacter code properties: ")) 734 (insert "these terminal codes:")
732 (insert-text-button 735 (dolist (elt component-chars)
733 "customize what to show" 736 (insert "\n " (car elt) ":"
734 'action (lambda (&rest ignore) 737 (propertize " " 'display '(space :align-to 4))
735 (customize-variable 738 (or (cdr elt) "-- not encodable --"))))
736 'describe-char-unidata-list)) 739 (insert "\nSee the variable `reference-point-alist' for "
737 'follow-link t) 740 "the meaning of the rule.\n")))
738 (insert "\n") 741
739 (dolist (elt (if (eq describe-char-unidata-list t) 742 (unless eight-bit-p
740 (nreverse (mapcar 'car char-code-property-alist)) 743 (insert (if (not describe-char-unidata-list)
741 describe-char-unidata-list)) 744 "\nCharacter code properties are not shown: "
742 (let ((val (get-char-code-property char elt)) 745 "\nCharacter code properties: "))
743 description) 746 (insert-text-button
744 (when val 747 "customize what to show"
745 (setq description (char-code-property-description elt val)) 748 'action (lambda (&rest ignore)
746 (insert (if description 749 (customize-variable
747 (format " %s: %s (%s)\n" elt val description) 750 'describe-char-unidata-list))
748 (format " %s: %s\n" elt val))))))) 751 'follow-link t)
749 752 (insert "\n")
750 (if text-props-desc (insert text-props-desc)) 753 (dolist (elt (if (eq describe-char-unidata-list t)
751 (setq help-xref-stack-item (list 'help-insert-string (buffer-string))) 754 (nreverse (mapcar 'car char-code-property-alist))
752 (toggle-read-only 1))))) 755 describe-char-unidata-list))
756 (let ((val (get-char-code-property char elt))
757 description)
758 (when val
759 (setq description (char-code-property-description elt val))
760 (insert (if description
761 (format " %s: %s (%s)\n" elt val description)
762 (format " %s: %s\n" elt val)))))))
763
764 (if text-props-desc (insert text-props-desc))
765 (toggle-read-only 1))))))
753 766
754(define-obsolete-function-alias 'describe-char-after 'describe-char "22.1") 767(define-obsolete-function-alias 'describe-char-after 'describe-char "22.1")
755 768
generated by cgit v1.2.1 (git 2.18.0) at 2026-02-04 13:46:53 +0000