BUGFIXING/org-log.el

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