org-log.el 12 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349
  1. (defun org-agenda-switch-to (&optional delete-other-windows)
  2. "Go to the Org-mode file which contains the item at point."
  3. (interactive)
  4. (let ((cb (current-buffer))
  5. (line (org-current-line))
  6. (col (current-column))
  7. (buf (current-buffer))
  8. (pos (point)))
  9. (with-current-buffer (get-buffer-create "OrgAgendaGotoLog")
  10. (goto-char (point-max))
  11. (insert "--------------------------------------------------------\n")
  12. (insert (format "This command: %s\n" this-command))
  13. (insert (format "Last command: %s\n" last-command))
  14. (insert (format "Line/Column/Point: %d/%d/%d\n" line col pos))))
  15. (orglog-describe-char (point))
  16. (let* ((marker (or (get-text-property (point) 'org-marker)
  17. (org-agenda-error)))
  18. (buffer (marker-buffer marker))
  19. (pos (marker-position marker)))
  20. (switch-to-buffer buffer)
  21. (and delete-other-windows (delete-other-windows))
  22. (widen)
  23. (goto-char pos)
  24. (when (eq major-mode 'org-mode)
  25. (org-show-context 'agenda)
  26. (save-excursion
  27. (and (outline-next-heading)
  28. (org-flag-heading nil))))
  29. (let ((cb (current-buffer))
  30. (pos (point)))
  31. (with-current-buffer (get-buffer-create "OrgAgendaGotoLog")
  32. (goto-char (point-max))
  33. (insert (format "Arrived: %s %d\n" cb pos))))))
  34. (defun org-agenda-goto (&optional highlight)
  35. "Go to the Org-mode file which contains the item at point."
  36. (interactive)
  37. (let ((cb (current-buffer))
  38. (line (org-current-line))
  39. (col (current-column))
  40. (buf (current-buffer))
  41. (pos (point)))
  42. (with-current-buffer (get-buffer-create "OrgAgendaGotoLog")
  43. (goto-char (point-max))
  44. (insert "--------------------------------------------------------\n")
  45. (insert (format "This command: %s\n" this-command))
  46. (insert (format "Last command: %s\n" last-command))
  47. (insert (format "Line/Column/Point: %d/%d/%d\n" line col pos))))
  48. (orglog-describe-char (point))
  49. (let* ((marker (or (get-text-property (point) 'org-marker)
  50. (org-agenda-error)))
  51. (buffer (marker-buffer marker))
  52. (pos (marker-position marker)))
  53. (switch-to-buffer-other-window buffer)
  54. (widen)
  55. (goto-char pos)
  56. (when (eq major-mode 'org-mode)
  57. (org-show-context 'agenda)
  58. (save-excursion
  59. (and (outline-next-heading)
  60. (org-flag-heading nil)))) ; show the next heading
  61. (run-hooks 'org-agenda-after-show-hook)
  62. (and highlight (org-highlight (point-at-bol) (point-at-eol)))
  63. (let ((cb (current-buffer))
  64. (pos (point)))
  65. (with-current-buffer (get-buffer-create "OrgAgendaGotoLog")
  66. (goto-char (point-max))
  67. (insert (format "Arrived: %s %d\n" cb pos))))))
  68. (defun orglog-describe-char (pos)
  69. "Describe the character after POS (interactively, the character after point).
  70. The information includes character code, charset and code points in it,
  71. syntax, category, how the character is encoded in a file,
  72. character composition information (if relevant),
  73. as well as widgets, buttons, overlays, and text properties."
  74. (interactive "d")
  75. (if (>= pos (point-max))
  76. (error "No character follows specified position"))
  77. (let* ((char (char-after pos))
  78. (charset (char-charset char))
  79. (composition (find-composition pos nil nil t))
  80. (component-chars nil)
  81. (display-table (or (window-display-table)
  82. buffer-display-table
  83. standard-display-table))
  84. (disp-vector (and display-table (aref display-table char)))
  85. (multibyte-p enable-multibyte-characters)
  86. (overlays (mapcar #'(lambda (o) (overlay-properties o))
  87. (overlays-at pos)))
  88. (char-description (if (not multibyte-p)
  89. (single-key-description char)
  90. (if (< char 128)
  91. (single-key-description char)
  92. (string-to-multibyte
  93. (char-to-string char)))))
  94. (text-props-desc
  95. (let ((tmp-buf (generate-new-buffer " *text-props*")))
  96. (unwind-protect
  97. (progn
  98. (describe-text-properties pos tmp-buf)
  99. (with-current-buffer tmp-buf (buffer-string)))
  100. (kill-buffer tmp-buf))))
  101. item-list max-width unicode)
  102. (if (or (< char 256)
  103. (memq 'mule-utf-8 (find-coding-systems-region pos (1+ pos)))
  104. (get-char-property pos 'untranslated-utf-8))
  105. (setq unicode (or (get-char-property pos 'untranslated-utf-8)
  106. (encode-char char 'ucs))))
  107. (setq item-list
  108. `(("character"
  109. ,(format "%s (%d, #o%o, #x%x%s)"
  110. (apply 'propertize char-description
  111. (text-properties-at pos))
  112. char char char
  113. (if unicode
  114. (format ", U+%04X" unicode)
  115. "")))
  116. ("charset"
  117. ,`(insert-text-button
  118. ,(symbol-name charset)
  119. 'type 'help-character-set 'help-args '(,charset))
  120. ,(format "(%s)" (charset-description charset)))
  121. ("code point"
  122. ,(let ((split (split-char char)))
  123. `(insert-text-button
  124. ,(if (= (charset-dimension charset) 1)
  125. (format "#x%02X" (nth 1 split))
  126. (format "#x%02X #x%02X" (nth 1 split)
  127. (nth 2 split)))
  128. 'action (lambda (&rest ignore)
  129. (list-charset-chars ',charset)
  130. (with-selected-window
  131. (get-buffer-window "*Character List*" 0)
  132. (goto-char (point-min))
  133. (forward-line 2) ;Skip the header.
  134. (let ((case-fold-search nil))
  135. (search-forward ,(char-to-string char)
  136. nil t))))
  137. 'help-echo
  138. "mouse-2, RET: show this character in its character set")))
  139. ("syntax"
  140. ,(let ((syntax (syntax-after pos)))
  141. (with-temp-buffer
  142. (internal-describe-syntax-value syntax)
  143. (buffer-string))))
  144. ("category"
  145. ,@(let ((category-set (char-category-set char)))
  146. (if (not category-set)
  147. '("-- none --")
  148. (mapcar #'(lambda (x) (format "%c:%s"
  149. x (category-docstring x)))
  150. (category-set-mnemonics category-set)))))
  151. ,@(let ((props (aref char-code-property-table char))
  152. ps)
  153. (when props
  154. (while props
  155. (push (format "%s:" (pop props)) ps)
  156. (push (format "%s;" (pop props)) ps))
  157. (list (cons "Properties" (nreverse ps)))))
  158. ("to input"
  159. ,@(let ((key-list (and (eq input-method-function
  160. 'quail-input-method)
  161. (quail-find-key char))))
  162. (if (consp key-list)
  163. (list "type"
  164. (mapconcat #'(lambda (x) (concat "\"" x "\""))
  165. key-list " or ")
  166. "with"
  167. `(insert-text-button
  168. ,current-input-method
  169. 'type 'help-input-method
  170. 'help-args '(,current-input-method))))))
  171. ("buffer code"
  172. ,(encoded-string-description
  173. (string-as-unibyte (char-to-string char)) nil))
  174. ("file code"
  175. ,@(let* ((coding buffer-file-coding-system)
  176. (encoded (encode-coding-char char coding)))
  177. (if encoded
  178. (list (encoded-string-description encoded coding)
  179. (format "(encoded by coding system %S)" coding))
  180. (list "not encodable by coding system"
  181. (symbol-name coding)))))
  182. ("display"
  183. ,(cond
  184. (disp-vector
  185. (setq disp-vector (copy-sequence disp-vector))
  186. (dotimes (i (length disp-vector))
  187. (setq char (aref disp-vector i))
  188. (aset disp-vector i
  189. (cons char (describe-char-display
  190. pos (glyph-char char)))))
  191. (format "by display table entry [%s] (see below)"
  192. (mapconcat
  193. #'(lambda (x)
  194. (format "?%c" (glyph-char (car x))))
  195. disp-vector " ")))
  196. (composition
  197. (let ((from (car composition))
  198. (to (nth 1 composition))
  199. (next (1+ pos))
  200. (components (nth 2 composition))
  201. ch)
  202. (setcar composition
  203. (and (< from pos) (buffer-substring from pos)))
  204. (setcar (cdr composition)
  205. (and (< next to) (buffer-substring next to)))
  206. (dotimes (i (length components))
  207. (if (integerp (setq ch (aref components i)))
  208. (push (cons ch (describe-char-display pos ch))
  209. component-chars)))
  210. (setq component-chars (nreverse component-chars))
  211. (format "composed to form \"%s\" (see below)"
  212. (buffer-substring from to))))
  213. (t
  214. (let ((display (describe-char-display pos char)))
  215. (if (display-graphic-p (selected-frame))
  216. (if display
  217. (concat
  218. "by this font (glyph code)\n"
  219. (format " %s (#x%02X)"
  220. (car display) (cdr display)))
  221. "no font available")
  222. (if display
  223. (format "terminal code %s" display)
  224. "not encodable for terminal"))))))
  225. ,@(let ((face
  226. (if (not (or disp-vector composition))
  227. (cond
  228. ((and show-trailing-whitespace
  229. (save-excursion (goto-char pos)
  230. (looking-at "[ \t]+$")))
  231. 'trailing-whitespace)
  232. ((and nobreak-char-display unicode (eq unicode '#xa0))
  233. 'nobreak-space)
  234. ((and nobreak-char-display unicode (eq unicode '#xad))
  235. 'escape-glyph)
  236. ((and (< char 32) (not (memq char '(9 10))))
  237. 'escape-glyph)))))
  238. (if face (list (list "hardcoded face"
  239. `(insert-text-button
  240. ,(symbol-name face)
  241. 'type 'help-face 'help-args '(,face))))))
  242. ,@(let ((unicodedata (and unicode
  243. (describe-char-unicode-data unicode))))
  244. (if unicodedata
  245. (cons (list "Unicode data" " ") unicodedata)))))
  246. (setq max-width (apply #'max (mapcar #'(lambda (x)
  247. (if (cadr x) (length (car x)) 0))
  248. item-list)))
  249. (with-current-buffer (get-buffer-create "OrgAgendaGotoLog")
  250. (goto-char (point-max))
  251. (set-buffer-multibyte multibyte-p)
  252. (let ((formatter (format "%%%ds:" max-width)))
  253. (dolist (elt item-list)
  254. (when (cadr elt)
  255. (insert (format formatter (car elt)))
  256. (dolist (clm (cdr elt))
  257. (if (eq (car-safe clm) 'insert-text-button)
  258. (progn (insert " ") (eval clm))
  259. (when (>= (+ (current-column)
  260. (or (string-match "\n" clm)
  261. (string-width clm))
  262. 1)
  263. (window-width))
  264. (insert "\n")
  265. (indent-to (1+ max-width)))
  266. (insert " " clm)))
  267. (insert "\n"))))
  268. (when overlays
  269. (save-excursion
  270. (goto-char (point-min))
  271. (re-search-forward "character:[ \t\n]+")
  272. (let* ((end (+ (point) (length char-description))))
  273. (mapc #'(lambda (props)
  274. (let ((o (make-overlay (point) end)))
  275. (while props
  276. (overlay-put o (car props) (nth 1 props))
  277. (setq props (cddr props)))))
  278. overlays))))
  279. (when disp-vector
  280. (insert
  281. "\nThe display table entry is displayed by ")
  282. (if (display-graphic-p (selected-frame))
  283. (progn
  284. (insert "these fonts (glyph codes):\n")
  285. (dotimes (i (length disp-vector))
  286. (insert (glyph-char (car (aref disp-vector i))) ?:
  287. (propertize " " 'display '(space :align-to 5))
  288. (if (cdr (aref disp-vector i))
  289. (format "%s (#x%02X)" (cadr (aref disp-vector i))
  290. (cddr (aref disp-vector i)))
  291. "-- no font --")
  292. "\n")
  293. (let ((face (glyph-face (car (aref disp-vector i)))))
  294. (when face
  295. (insert (propertize " " 'display '(space :align-to 5))
  296. "face: ")
  297. (insert (concat "`" (symbol-name face) "'"))
  298. (insert "\n")))))
  299. (insert "these terminal codes:\n")
  300. (dotimes (i (length disp-vector))
  301. (insert (car (aref disp-vector i))
  302. (propertize " " 'display '(space :align-to 5))
  303. (or (cdr (aref disp-vector i)) "-- not encodable --")
  304. "\n"))))
  305. (when composition
  306. (insert "\nComposed")
  307. (if (car composition)
  308. (if (cadr composition)
  309. (insert " with the surrounding characters \""
  310. (car composition) "\" and \""
  311. (cadr composition) "\"")
  312. (insert " with the preceding character(s) \""
  313. (car composition) "\""))
  314. (if (cadr composition)
  315. (insert " with the following character(s) \""
  316. (cadr composition) "\"")))
  317. (insert " by the rule:\n\t("
  318. (mapconcat (lambda (x)
  319. (format (if (consp x) "%S" "?%c") x))
  320. (nth 2 composition)
  321. " ")
  322. ")")
  323. (insert "\nThe component character(s) are displayed by ")
  324. (if (display-graphic-p (selected-frame))
  325. (progn
  326. (insert "these fonts (glyph codes):")
  327. (dolist (elt component-chars)
  328. (insert "\n " (car elt) ?:
  329. (propertize " " 'display '(space :align-to 5))
  330. (if (cdr elt)
  331. (format "%s (#x%02X)" (cadr elt) (cddr elt))
  332. "-- no font --"))))
  333. (insert "these terminal codes:")
  334. (dolist (elt component-chars)
  335. (insert "\n " (car elt) ":"
  336. (propertize " " 'display '(space :align-to 5))
  337. (or (cdr elt) "-- not encodable --"))))
  338. (insert "\nSee the variable `reference-point-alist' for "
  339. "the meaning of the rule.\n"))
  340. (if text-props-desc (insert text-props-desc)))))