Commit 449c27f0 authored by Stefan Monnier's avatar Stefan Monnier
Browse files

Handle the [back] button properly (bug#4979).

* descr-text.el (describe-text-properties): Add a `buffer' argument.
Use help-setup-xref, help-buffer, and with-help-window.
(describe-char): Add `buffer' argument.
Pass proper command to help-setup-xref.  Don't meddle with
help-xref-stack-item directly.
(describe-text-category): Use with-help-window and help-buffer.
parent 32fe5377
2009-11-24 Stefan Monnier <monnier@iro.umontreal.ca> 2009-11-24 Stefan Monnier <monnier@iro.umontreal.ca>
Handle the [back] button properly (bug#4979).
* descr-text.el (describe-text-properties): Add a `buffer' argument.
Use help-setup-xref, help-buffer, and with-help-window.
(describe-char): Add `buffer' argument.
Pass proper command to help-setup-xref. Don't meddle with
help-xref-stack-item directly.
(describe-text-category): Use with-help-window and help-buffer.
* emacs-lisp/shadow.el (list-load-path-shadows): Setup a major mode * emacs-lisp/shadow.el (list-load-path-shadows): Setup a major mode
for the displayed buffer (bug#4887). for the displayed buffer (bug#4887).
......
...@@ -103,39 +103,41 @@ into help buttons that call `describe-text-category' or ...@@ -103,39 +103,41 @@ into help buttons that call `describe-text-category' or
(interactive "SCategory: ") (interactive "SCategory: ")
(help-setup-xref (list #'describe-text-category category) (help-setup-xref (list #'describe-text-category category)
(called-interactively-p 'interactive)) (called-interactively-p 'interactive))
(save-excursion (with-help-window (help-buffer)
(with-output-to-temp-buffer "*Help*" (with-current-buffer standard-output
(set-buffer standard-output)
(insert "Category " (format "%S" category) ":\n\n") (insert "Category " (format "%S" category) ":\n\n")
(describe-property-list (symbol-plist category)) (describe-property-list (symbol-plist category))
(goto-char (point-min))))) (goto-char (point-min)))))
;;;###autoload ;;;###autoload
(defun describe-text-properties (pos &optional output-buffer) (defun describe-text-properties (pos &optional output-buffer buffer)
"Describe widgets, buttons, overlays and text properties at POS. "Describe widgets, buttons, overlays, and text properties at POS.
POS is taken to be in BUFFER or in current buffer if nil.
Interactively, describe them for the character after point. Interactively, describe them for the character after point.
If optional second argument OUTPUT-BUFFER is non-nil, If optional second argument OUTPUT-BUFFER is non-nil,
insert the output into that buffer, and don't initialize or clear it insert the output into that buffer, and don't initialize or clear it
otherwise." otherwise."
(interactive "d") (interactive "d")
(let ((src-buf (current-buffer)))
(if buffer (set-buffer buffer) (setq buffer (current-buffer)))
(if (>= pos (point-max)) (if (>= pos (point-max))
(error "No character follows specified position")) (error "No character follows specified position"))
(if output-buffer (if output-buffer
(describe-text-properties-1 pos output-buffer) (describe-text-properties-1 pos output-buffer)
(if (not (or (text-properties-at pos) (overlays-at pos))) (if (not (or (text-properties-at pos) (overlays-at pos)))
(message "This is plain text.") (message "This is plain text.")
(let ((buffer (current-buffer)) (with-temp-buffer
(target-buffer "*Help*"))
(when (eq buffer (get-buffer target-buffer))
(setq target-buffer "*Help*<2>"))
(save-excursion
(with-output-to-temp-buffer target-buffer
(set-buffer standard-output)
(setq output-buffer (current-buffer)) (setq output-buffer (current-buffer))
(insert "Text content at position " (format "%d" pos) ":\n\n") (insert "Text content at position " (format "%d" pos) ":\n\n")
(with-current-buffer buffer (set-buffer buffer)
(describe-text-properties-1 pos output-buffer)) (describe-text-properties-1 pos output-buffer)
(goto-char (point-min)))))))) (set-buffer src-buf)
(help-setup-xref (list 'describe-text-properties pos nil buffer)
(called-interactively-p 'interactive))
(with-help-window (help-buffer)
(with-current-buffer standard-output
(buffer-swap-text output-buffer)
(goto-char (point-min)))))))))
(defun describe-text-properties-1 (pos output-buffer) (defun describe-text-properties-1 (pos output-buffer)
(let* ((properties (text-properties-at pos)) (let* ((properties (text-properties-at pos))
...@@ -373,19 +375,24 @@ This function is semi-obsolete. Use `get-char-code-property'." ...@@ -373,19 +375,24 @@ This function is semi-obsolete. Use `get-char-code-property'."
mnemonics ", "))))) mnemonics ", ")))))
;;;###autoload ;;;###autoload
(defun describe-char (pos) (defun describe-char (pos &optional buffer)
"Describe the character after POS (interactively, the character after point). "Describe the character after POS (interactively, the character after point).
Is POS is taken to be in buffer BUFFER or current buffer if nil.
The information includes character code, charset and code points in it, The information includes character code, charset and code points in it,
syntax, category, how the character is encoded in a file, syntax, category, how the character is encoded in a file,
character composition information (if relevant), character composition information (if relevant),
as well as widgets, buttons, overlays, and text properties." as well as widgets, buttons, overlays, and text properties."
(interactive "d") (interactive "d")
(unless (buffer-live-p buffer) (setq buffer (current-buffer)))
(let ((src-buf (current-buffer)))
(set-buffer buffer)
(if (>= pos (point-max)) (if (>= pos (point-max))
(error "No character follows specified position")) (error "No character follows specified position"))
(let* ((char (char-after pos)) (let* ((char (char-after pos))
(eight-bit-p (and (not enable-multibyte-characters) (>= char 128))) (eight-bit-p (and (not enable-multibyte-characters) (>= char 128)))
(charset (if eight-bit-p 'eight-bit (charset (if eight-bit-p 'eight-bit
(or (get-text-property pos 'charset) (char-charset char)))) (or (get-text-property pos 'charset)
(char-charset char))))
(composition (find-composition pos nil nil t)) (composition (find-composition pos nil nil t))
(component-chars nil) (component-chars nil)
(display-table (or (window-display-table) (display-table (or (window-display-table)
...@@ -424,7 +431,6 @@ as well as widgets, buttons, overlays, and text properties." ...@@ -424,7 +431,6 @@ as well as widgets, buttons, overlays, and text properties."
(or (catch 'tag (or (catch 'tag
(let ((from (car composition)) (let ((from (car composition))
(to (nth 1 composition)) (to (nth 1 composition))
(next (1+ pos))
(components (nth 2 composition)) (components (nth 2 composition))
ch) ch)
(if (and (vectorp components) (vectorp (aref components 0))) (if (and (vectorp components) (vectorp (aref components 0)))
...@@ -503,7 +509,8 @@ as well as widgets, buttons, overlays, and text properties." ...@@ -503,7 +509,8 @@ as well as widgets, buttons, overlays, and text properties."
,(format "(%s)" (charset-description charset))) ,(format "(%s)" (charset-description charset)))
("code point" ("code point"
,(let ((str (if (integerp code) ,(let ((str (if (integerp code)
(format (if (< code 256) "0x%02X" "0x%04X") code) (format (if (< code 256) "0x%02X" "0x%04X")
code)
(format "0x%04X%04X" (car code) (cdr code))))) (format "0x%04X%04X" (car code) (cdr code)))))
(if (<= (charset-dimension charset) 2) (if (<= (charset-dimension charset) 2)
`(insert-text-button `(insert-text-button
...@@ -515,8 +522,8 @@ as well as widgets, buttons, overlays, and text properties." ...@@ -515,8 +522,8 @@ as well as widgets, buttons, overlays, and text properties."
(goto-char (point-min)) (goto-char (point-min))
(forward-line 2) ;Skip the header. (forward-line 2) ;Skip the header.
(let ((case-fold-search nil)) (let ((case-fold-search nil))
(if (search-forward ,(char-to-string char) (if (search-forward
nil t) ,(char-to-string char) nil t)
(goto-char (match-beginning 0)))))) (goto-char (match-beginning 0))))))
'follow-link t 'follow-link t
'help-echo 'help-echo
...@@ -540,8 +547,10 @@ as well as widgets, buttons, overlays, and text properties." ...@@ -540,8 +547,10 @@ as well as widgets, buttons, overlays, and text properties."
(quail-find-key char)))) (quail-find-key char))))
(if (consp key-list) (if (consp key-list)
(list "type" (list "type"
(mapconcat #'(lambda (x) (concat "\"" x "\"")) (concat "\""
key-list " or ") (mapconcat 'identity
key-list "\" or \"")
"\"")
"with" "with"
`(insert-text-button `(insert-text-button
,current-input-method ,current-input-method
...@@ -558,7 +567,8 @@ as well as widgets, buttons, overlays, and text properties." ...@@ -558,7 +567,8 @@ as well as widgets, buttons, overlays, and text properties."
(encoded (encode-coding-char char coding charset))) (encoded (encode-coding-char char coding charset)))
(if encoded (if encoded
(list (encoded-string-description encoded coding) (list (encoded-string-description encoded coding)
(format "(encoded by coding system %S)" coding)) (format "(encoded by coding system %S)"
coding))
(list "not encodable by coding system" (list "not encodable by coding system"
(symbol-name coding)))) (symbol-name coding))))
(list (format "#x%02X" char)))) (list (format "#x%02X" char))))
...@@ -603,15 +613,18 @@ as well as widgets, buttons, overlays, and text properties." ...@@ -603,15 +613,18 @@ as well as widgets, buttons, overlays, and text properties."
(if face (list (list "hardcoded face" (if face (list (list "hardcoded face"
`(insert-text-button `(insert-text-button
,(symbol-name face) ,(symbol-name face)
'type 'help-face 'help-args '(,face)))))) 'type 'help-face
'help-args '(,face))))))
,@(if (not eight-bit-p) ,@(if (not eight-bit-p)
(let ((unicodedata (describe-char-unicode-data char))) (let ((unicodedata (describe-char-unicode-data char)))
(if unicodedata (if unicodedata
(cons (list "Unicode data" " ") unicodedata)))))) (cons (list "Unicode data" " ") unicodedata))))))
(setq max-width (apply #'max (mapcar #'(lambda (x) (setq max-width (apply 'max (mapcar (lambda (x)
(if (cadr x) (length (car x)) 0)) (if (cadr x) (length (car x)) 0))
item-list))) item-list)))
(help-setup-xref nil (called-interactively-p 'interactive)) (set-buffer src-buf)
(help-setup-xref (list 'describe-char pos buffer)
(called-interactively-p 'interactive))
(with-help-window (help-buffer) (with-help-window (help-buffer)
(with-current-buffer standard-output (with-current-buffer standard-output
(set-buffer-multibyte multibyte-p) (set-buffer-multibyte multibyte-p)
...@@ -715,7 +728,8 @@ as well as widgets, buttons, overlays, and text properties." ...@@ -715,7 +728,8 @@ as well as widgets, buttons, overlays, and text properties."
(insert "\n " (insert "\n "
(describe-char-padded-string (car elt)) (describe-char-padded-string (car elt))
?: ?:
(propertize " " 'display '(space :align-to 5)) (propertize " "
'display '(space :align-to 5))
(or (cdr elt) "-- no font --"))))) (or (cdr elt) "-- no font --")))))
(insert "these terminal codes:") (insert "these terminal codes:")
(dolist (elt component-chars) (dolist (elt component-chars)
...@@ -748,8 +762,7 @@ as well as widgets, buttons, overlays, and text properties." ...@@ -748,8 +762,7 @@ as well as widgets, buttons, overlays, and text properties."
(format " %s: %s\n" elt val))))))) (format " %s: %s\n" elt val)))))))
(if text-props-desc (insert text-props-desc)) (if text-props-desc (insert text-props-desc))
(setq help-xref-stack-item (list 'help-insert-string (buffer-string))) (toggle-read-only 1))))))
(toggle-read-only 1)))))
(define-obsolete-function-alias 'describe-char-after 'describe-char "22.1") (define-obsolete-function-alias 'describe-char-after 'describe-char "22.1")
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment