contrib/lisp/org-index.el

   1 ;;; org-index.el --- A personal adaptive index for org
   2
   3 ;; Copyright (C) 2011-2016 Free Software Foundation, Inc.
   4
   5 ;; Author: Marc Ihm <org-index@2484.de>
   6 ;; Version: 5.1.2
   7 ;; Keywords: outlines index
   8
   9 ;; This file is not part of GNU Emacs.
  10
  11 ;;; License:
  12
  13 ;; This program is free software; you can redistribute it and/or modify
  14 ;; it under the terms of the GNU General Public License as published by
  15 ;; the Free Software Foundation; either version 3, or (at your option)
  16 ;; any later version.
  17 ;;
  18 ;; This program is distributed in the hope that it will be useful,
  19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 ;; GNU General Public License for more details.
  22 ;;
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  25
  26 ;;; Commentary:
  27
  28 ;; Purpose:
  29 ;;
  30 ;;  Fast search for selected org nodes and things outside of org.
  31 ;;
  32 ;;  org-index creates and updates an index table with keywords; each line
  33 ;;  either points to a heading in org, references something outside or
  34 ;;  carries a snippet of text to yank.  When searching the index, the set
  35 ;;  of matching lines is updated with every keystroke; results are sorted
  36 ;;  by usage count and date, so that frequently used entries appear first
  37 ;;  in the list of results.
  38 ;;
  39 ;;  References are decorated numbers (e.g. 'R237' or '--455--'); they are
  40 ;;  well suited to be used outside of org, e.g. in folder names, ticket
  41 ;;  systems or on printed documents.
  42 ;;
  43 ;;  On first invocation org-index will assist you in creating the index
  44 ;;  table.
  45 ;;
  46 ;;  To start using your index, invoke subcommands 'add', 'ref' and 'yank'
  47 ;;  to create entries and 'occur' to find them.
  48 ;;
  49 ;;
  50 ;; Setup:
  51 ;;
  52 ;;  - Place this file in a directory from your load-path,
  53 ;;    e.g. org-mode/contrib/lisp.
  54 ;;
  55 ;;  - Add these lines to your .emacs:
  56 ;;
  57 ;;    (require 'org-index)
  58 ;;    (global-set-key (kbd "C-c i") 'org-index-dispatch) ; this is optional
  59 ;;
  60 ;;  - Restart your Emacs to make these lines effective.
  61 ;;
  62 ;;  - Invoke `org-index'; on first run it will assist in creating your
  63 ;;    index table.
  64 ;;
  65 ;;  - Optionally invoke `M-x org-customize' to tune some settings (choose
  66 ;;    group org-index).
  67 ;;
  68 ;;
  69 ;; Further information:
  70 ;;
  71 ;;  - Watch the screencast at http://2484.de/org-index.html.
  72 ;;
  73 ;;  - See the documentation of `org-index', which can also be read by
  74 ;;    invoking `org-index' and choosing the command help or '?'.
  75 ;;
  76 ;;
  77 ;; Updates:
  78 ;;
  79 ;;  The latest published version of this file can always be found at:
  80 ;;
  81 ;;    http://orgmode.org/w/?p=org-mode.git;a=blob_plain;f=contrib/lisp/org-index.el;hb=HEAD
  82 ;;
  83 ;;  Development version under:
  84 ;;
  85 ;;    https://github.com/marcIhm/org-index
  86
  87 ;;; Change Log:
  88
  89 ;;   [2016-08-05 Fr] Version 5.1.2
  90 ;;   - Offering help during query for subcommands
  91 ;;   - Removed org-index-default-keybindings
  92 ;;   - Renamed subcommand multi-occur to find-ref
  93 ;;   - Subcommands add and need no longer be invoked from heading
  94 ;;   - Many Bugfixes
  95 ;;
  96 ;;   [2015-12-29 Tu] Version 5.0.2
  97 ;;   - New commands yank, column and edit
  98 ;;   - New column tags
  99 ;;   - All columns are now required
 100 ;;   - References are now optional
 101 ;;   - Subcommand enter has been renamed to index
 102 ;;   - Subcommands kill and edit can be invoked from an occur buffer
 103 ;;   - Many Bugfixes
 104 ;;   - Added link to screencast
 105 ;;
 106 ;;   [2015-08-20 Th] Version 4.3.0
 107 ;;   - Configuration is done now via standard customize
 108 ;;   - New sorting strategy 'mixed'
 109 ;;   - Silenced some compiler warnings
 110 ;;
 111 ;;   [2015-03-18 We] Version 4.2.1
 112 ;;   - No garbage in kill-ring
 113 ;;   - No recentering after add
 114 ;;
 115 ;;   [2015-03-08 Su] Version 4.2.0
 116 ;;   - Reference numbers for subcommands can be passed as a prefix argument
 117 ;;   - New variable org-index-default-keybindings-list with a list of
 118 ;;     default keybindings for org-index-default-keybindings
 119 ;;   - Added new column level
 120 ;;   - removed flags get-category-on-add and get-heading-on-add
 121 ;;
 122 ;;   [2015-02-26 Th] to [2015-03-05 Th] Version 4.0.0 to 4.1.2
 123 ;;   - Removed command "leave"; rather go back with org-mark-ring-goto
 124 ;;   - Renamed column "link" to "id"
 125 ;;   - Added maintainance options to find duplicate rows, to check ids,
 126 ;;     update index or remove property org-index-ref from nodes
 127 ;;   - Shortened versin history
 128 ;;
 129 ;;   [2014-12-08 Mo] to [2015-01-31 Sa] Version 3.0.0 to 3.2.0:
 130 ;;   - Complete sorting of index only occurs in idle-timer
 131 ;;   - New command "maintain"  with some subcommands
 132 ;;   - Rewrote command "occur" with overlays in an indirect buffer
 133 ;;   - Command "add" updates index, if node is already present
 134 ;;   - New commands "add" and "delete" to easily add and remove
 135 ;;     the current node to or from your index.
 136 ;;   - New command "example" to create an example index.
 137 ;;   - Several new flags that are explained within index node.
 138 ;;   - Removed commands "reuse", "missing", "put", "goto",
 139 ;;     "update", "link", "fill", "unhighlight"
 140 ;;   - New function `org-index-default-keybindings'
 141 ;;
 142 ;;   [2012-12-07 Fr] to [2014-04-26 Sa] Version 2.0.0 to 2.4.3:
 143 ;;   - New functions org-index-new-line and org-index-get-line
 144 ;;     offer access to org-index from other lisp programs
 145 ;;   - Regression tests with ert
 146 ;;   - Renamed from "org-favtable" to "org-index"
 147 ;;   - Added an assistant to set up the index table
 148 ;;   - occur is now incremental, searching as you type
 149 ;;   - Integrated with org-mark-ring-goto
 150 ;;   - Added full support for ids
 151 ;;   - Renamed the package from "org-reftable" to "org-favtable"
 152 ;;   - Additional columns are required (e.g. "link"). Error messages will
 153 ;;     guide you
 154 ;;   - Ask user explicitly, which command to invoke
 155 ;;   - Renamed the package from "org-refer-by-number" to "org-reftable"
 156 ;;
 157 ;;   [2011-12-10 Sa] to [2012-09-22 Sa] Version Version 1.2.0 to 1.5.0:
 158 ;;    - New command "sort" to sort a buffer or region by reference number
 159 ;;    - New commands "highlight" and "unhighlight" to mark references
 160 ;;    - New command "head" to find a headline with a reference number
 161 ;;    - New commands occur and multi-occur
 162 ;;    - Started this Change Log
 163
 164 ;;; Code:
 165
 166 (require 'org-table)
 167 (require 'cl-lib)
 168 (require 'widget)
 169
 170 ;; Version of this package
 171 (defvar org-index-version "5.1.2" "Version of `org-index', format is major.minor.bugfix, where \"major\" are incompatible changes and \"minor\" are new features.")
 172
 173 ;; customizable options
 174 (defgroup org-index nil
 175   "Options concerning the optional index for org."
 176   :tag "Org Index"
 177   :group 'org)
 178
 179 (defcustom org-index-id nil
 180   "Id of the Org-mode node, which contains the index table."
 181   :group 'org-index)
 182
 183 (defcustom org-index-sort-by 'mixed
 184   "Strategy for sorting index table (and whence entries in occur).
 185 Valid values are:
 186
 187 last-access  Sort index by date and time of last access; show
 188              more recent entries first.
 189 count  Sort by usage count; more often used entries first.
 190 mixed  First, show all index entries, which have been
 191        used today; sort them by last access.  Then show
 192        older entries sorted by usage count."
 193   :group 'org-index
 194   :set (lambda (s v)
 195          (set-default s v)
 196          (if (and org-index-id
 197                   org-index--buffer
 198                   (functionp 'org-index--sort-silent))
 199              (org-index--sort-silent)))
 200   :initialize 'custom-initialize-default
 201   :type '(choice
 202           (const last-accessed)
 203           (const count)
 204           (const mixed)))
 205
 206 (defcustom org-index-yank-after-add 'ref
 207   "Specifies which column should be yanked after adding a new index row.
 208 Valid values are some columns of index table."
 209   :group 'org-index
 210   :type '(choice
 211           (const ref)
 212           (const category)
 213           (const keywords)))
 214
 215 (defcustom org-index-point-on-add 'keywords
 216   "Specifies in which column point will land when adding a new index row.
 217 Valid values are some columns of index table."
 218   :group 'org-index
 219   :type '(choice
 220           (const category)
 221           (const keywords)))
 222
 223 (defcustom org-index-copy-heading-to-keywords t
 224   "When adding a new node to index: Copy heading to keywords-column ?"
 225   :group 'org-index
 226   :type '(choice (const :tag "Yes" t)
 227                  (const :tag "No" nil)))
 228
 229 (defcustom org-index-strip-ref-and-date-from-heading t
 230   "When adding a node to index: strip leading ref or timestamps ?
 231
 232 This can be useful, if you have the habit of adding refs and
 233 dates to the start of your headings; then, if you change your
 234 heading and want to update your index, you do not need to remove
 235 those pieces."
 236   :group 'org-index
 237   :type '(choice (const :tag "Yes" t)
 238                  (const :tag "No" nil)))
 239
 240 (defcustom org-index-edit-on-add '(category keywords)
 241   "List of columns to edit when adding a new row."
 242   :group 'org-index
 243   :type '(repeat (choice
 244                   (const category)
 245                   (const keywords))))
 246
 247 (defcustom org-index-edit-on-yank '(yank keywords)
 248   "List of columns to edit when adding new text to yank."
 249   :group 'org-index
 250   :type '(repeat (choice
 251                   (const yank)
 252                   (const category)
 253                   (const keywords))))
 254
 255 (defcustom org-index-edit-on-ref '(category keywords)
 256   "List of columns to edit when adding new ref."
 257   :group 'org-index
 258   :type '(repeat (choice
 259                   (const category)
 260                   (const keywords))))
 261
 262 ;; Variables to hold the configuration of the index table
 263 (defvar org-index--maxrefnum nil "Maximum number from reference table, e.g. 153.")
 264 (defvar org-index--nextref nil "Next reference, that can be used, e.g. 'R154'.")
 265 (defvar org-index--head nil "Header before number (e.g. 'R').")
 266 (defvar org-index--tail nil "Tail after number (e.g. '}' or ')'.")
 267 (defvar org-index--numcols nil "Number of columns in index table.")
 268 (defvar org-index--ref-regex nil "Regular expression to match a reference.")
 269 (defvar org-index--ref-format nil "Format, that can print a reference.")
 270 (defvar org-index--columns nil "Columns of index-table.")
 271 (defvar org-index--buffer nil "Buffer of index table.")
 272 (defvar org-index--point nil "Position at start of headline of index table.")
 273 (defvar org-index--below-hline nil "Position of first cell in first line below hline.")
 274 (defvar org-index--saved-positions nil "Saved positions within current buffer and index buffer; filled by ‘org-index--save-positions’.")
 275 (defvar org-index--headings nil "Headlines of index-table as a string.")
 276 (defvar org-index--headings-visible nil "Visible part of headlines of index-table as a string.")
 277
 278 ;; Variables to hold context and state
 279 (defvar org-index--last-fingerprint nil "Fingerprint of last line created.")
 280 (defvar org-index--category-before nil "Category of node before.")
 281 (defvar org-index--active-region nil "Active region, initially.  I.e. what has been marked.")
 282 (defvar org-index--below-cursor nil "Word below cursor.")
 283 (defvar org-index--within-index-node nil "True, if we are within node of the index table.")
 284 (defvar org-index--within-occur nil "True, if we are within the occur-buffer.")
 285 (defvar org-index--message-text nil "Text that was issued as an explanation; helpful for regression tests.")
 286 (defvar org-index--occur-help-text nil "Text for help in occur buffer.")
 287 (defvar org-index--occur-help-overlay nil "Overlay for help in occur buffer.")
 288 (defvar org-index--occur-stack nil "Stack with overlays for hiding lines.")
 289 (defvar org-index--occur-tail-overlay nil "Overlay to cover invisible lines.")
 290 (defvar org-index--occur-lines-collected 0 "Number of lines collected in occur buffer; helpful for tests.")
 291 (defvar org-index--last-sort nil "Last column, the index has been sorted after.")
 292 (defvar org-index--sort-timer nil "Timer to sort index in correct order.")
 293 (defvar org-index--aligned nil "Remember for this Emacs session, if table has been aligned at least once.")
 294 (defvar org-index--edit-widgets nil "List of widgets used to edit.")
 295 (defvar org-index--context-index nil "Position and line used for index in edit buffer.")
 296 (defvar org-index--context-occur nil "Position and line used for occur in edit buffer.")
 297 (defvar org-index--context-node nil "Buffer and position for node in edit buffer.")
 298 (defvar org-index--short-help-buffer-name "*org-index commands*" "Name of buffer to display short help.")
 299 (defvar org-index--display-short-help nil "True, if short help should be displayed.")
 300 (defvar org-index--short-help-displayed nil "True, if short help message has been displayed.")
 301 (defvar org-index--minibuffer-saved-key nil "Temporarily save entry of minibuffer keymap.")
 302
 303 ;; static information for this program package
 304 (defconst org-index--commands '(occur add kill head ping index ref yank column edit help short-help example sort find-ref highlight maintain) "List of commands available.")
 305 (defconst org-index--valid-headings '(ref id created last-accessed count keywords category level yank tags) "All valid headings.")
 306 (defconst org-index--occur-buffer-name "*org-index-occur*" "Name of occur buffer.")
 307 (defconst org-index--edit-buffer-name "*org-index-edit*" "Name of edit buffer.")
 308 (defconst org-index--sort-idle-delay 300 "Delay in seconds after which buffer will sorted.")
 309 (defvar org-index--short-help-text nil "Cache for result of `org-index--get-short-help-text.")
 310 (defvar org-index--shortcut-chars nil "Cache for result of `org-index--get-shortcut-chars.")
 311
 312
 313 (defmacro org-index--on (column value &rest body)
 314   "Execute the forms in BODY with point on index line whose COLUMN is VALUE.
 315 The value returned is the value of the last form in BODY or nil,
 316 if VALUE cannot be found."
 317   (declare (indent 2) (debug t))
 318   (let ((pointvar (make-symbol "point")) ; avoid clash with same-named variables in body
 319         (foundvar (make-symbol "found"))
 320         (retvar (make-symbol "ret")))
 321     `(save-current-buffer
 322        (let ((,pointvar (point))
 323              ,foundvar
 324              ,retvar)
 325
 326          (set-buffer org-index--buffer)
 327
 328          (setq ,foundvar (org-index--go ,column ,value))
 329          (when ,foundvar
 330            (setq ,retvar (progn ,@body)))
 331
 332          (goto-char ,pointvar)
 333
 334          ,retvar))))
 335
 336
 337 (defun org-index (&optional command search-ref arg)
 338   "Fast search-index for selected org nodes and things outside of org.
 339
 340 org-index creates and updates an index table with keywords; each line
 341 either points to a heading in org, references something outside or
 342 carries a snippet of text to yank.  The index table is searched for
 343 keywords through an incremental occur; results are sorted by usage
 344 count and date, so that frequently used entries appear first among
 345 the results.
 346
 347 References are decorated numbers (e.g. 'R237' or '--455--'); they are
 348 well suited to be used outside of org, e.g. in folder names, ticket
 349 systems or on printed documents.
 350
 351 On first invocation org-index will help to create a dedicated node
 352 for its index table.
 353
 354 To start building up your index, use subcommands 'add', 'ref' and
 355 'yank' to create entries and use 'occur' to find them.
 356
 357 This is version 5.1.2 of org-index.el.
 358
 359
 360 The function `org-index' is the only interactive function of this
 361 package and its main entry point; it will present you with a list
 362 of subcommands to choose from:
 363
 364 \(Note the one-letter shortcuts, e.g. [o]; used like 'C-c i o'.)
 365
 366   occur: [o] Incrementally show matching lines from index.
 367     Result is updated after every keystroke.  You may enter a
 368     list of words seperated by space or comma (`,'), to select
 369     lines that contain all of the given words.
 370
 371   add: [a] Add the current node to index.
 372     So that (e.g.) it can be found through the subcommand
 373     'occur'. Update index, if node is already present.
 374
 375   kill: [k] Kill (delete) the current node from index.
 376     Can be invoked from index, from occur or from a headline.
 377
 378   head: [h] Search for heading, by ref or from index line.
 379     If invoked from within index table, go to associated
 380     node (if any), otherwise ask for ref to search.
 381
 382   index: [i] Enter index table and maybe go to a specific reference.
 383     Use `org-mark-ring-goto' (\\[org-mark-ring-goto]) to go back.
 384
 385   ping: [p] Echo line from index table for current node.
 386     If current node is not in index, than search among its
 387     parents.
 388
 389   ref: [r] Create a new index line with a reference.
 390     This line will not be associated with a node.
 391
 392   yank: [y] Store a new string, that can be yanked from occur.
 393     The index line will not be associated with a node.
 394
 395   column: [c] From within index table: read char and jump to column.
 396     Shortcut for column movement; stays within one index line.
 397
 398   edit: [e] Present current line in edit buffer.
 399     Can be invoked from index, from occur or from a headline.
 400
 401   help: Show complete help text of org-index.
 402
 403   short-help: [?] Show one-line description of each subcommand.
 404     I.e. show this list but only first sentence each.
 405
 406   example: Create an example index, that will not be saved.
 407     May serve as an example.
 408
 409   sort: Sort lines in index, in region or buffer.
 410     Region or buffer can be sorted by contained reference; Index
 411     by count, reference or last access.
 412
 413   find-ref: Search for given reference in all org-buffers.
 414     A wrapper to employ emacs standard `multi-occur' function;
 415     asks for reference.
 416
 417   highlight: Highlight or unhighlight all references.
 418      Operates on active region or whole buffer.  Call with prefix
 419      argument (`C-u') to remove highlights.
 420
 421   maintain: Index maintainance.
 422      Offers some choices to check, update or fix your index.
 423
 424 If you invoke `org-index' for the first time, an assistant will be
 425 invoked, that helps you to create your own index.
 426
 427 Invoke `org-customize' to tweak the behaviour of org-index.
 428
 429 Optionally bind `org-index-dispatch' to a key, e.g. 'C-c i' in
 430 the global keymap to invoke the most important subcommands with
 431 a single key.
 432
 433 A numeric prefix argument is used as a reference number for
 434 commands, that need one (e.g. 'head').
 435
 436 Use from elisp: Optional argument COMMAND is a symbol naming the
 437 command to execute. SEARCH-REF specifies a reference to search
 438 for, if needed. ARG allows passing in a prefix argument as in
 439 interactive calls."
 440
 441   (interactive "i\ni\nP")
 442
 443   (let (search-id             ; id to search for
 444         search-fingerprint    ; fingerprint to search for
 445         sort-what             ; sort what ?
 446         kill-new-text         ; text that will be appended to kill ring
 447         message-text)         ; text that will be issued as an explanation
 448
 449     (catch 'new-index
 450
 451       ;;
 452       ;; Initialize and parse
 453       ;;
 454
 455       ;; creates index table, if necessary
 456       (org-index--verify-id)
 457
 458       ;; Get configuration of index table
 459       (org-index--parse-table)
 460
 461       ;; store context information
 462       (org-index--retrieve-context)
 463
 464
 465       ;;
 466       ;; Arrange for proper sorting of index
 467       ;;
 468
 469       ;; lets assume, that it has been sorted this way (we try hard to make sure)
 470       (unless org-index--last-sort (setq org-index--last-sort org-index-sort-by))
 471       ;; rearrange for index beeing sorted into default sort order after 300 secs of idle time
 472       (unless org-index--sort-timer
 473         (setq org-index--sort-timer
 474               (run-with-idle-timer org-index--sort-idle-delay t 'org-index--sort-silent)))
 475
 476
 477       ;;
 478       ;; Find out, what we are supposed to do
 479       ;;
 480
 481       ;; Check or read command
 482       (if (and command (not (eq command 'short-help)))
 483           (unless (memq command org-index--commands)
 484             (error "Unknown command '%s' passed as argument, valid choices are any of these symbols: %s"
 485                    command (mapconcat 'symbol-name org-index--commands ",")))
 486
 487         ;; read command; if requested display help in read-loop
 488         (setq org-index--display-short-help (eq command 'short-help))
 489         (setq command (org-index--read-command))
 490         (setq org-index--display-short-help nil))
 491
 492       ;;
 493       ;; Get search string, if required; process possible sources one after
 494       ;; another (lisp argument, prefix argument, user input).
 495       ;;
 496
 497       ;; Try prefix, if no lisp argument given
 498       (if (and (not search-ref)
 499                (numberp arg))
 500           (setq search-ref (format "%s%d%s" org-index--head arg org-index--tail)))
 501
 502       ;; These actions really need a search string and may even prompt for it
 503       (when (memq command '(index head find-ref))
 504
 505         ;; search from surrounding text ?
 506         (unless search-ref
 507           (if org-index--within-index-node
 508
 509               (if (org-at-table-p)
 510                   (setq search-ref (org-index--get-or-set-field 'ref)))
 511
 512             (if (and org-index--below-cursor
 513                      (string-match (concat "\\(" org-index--ref-regex "\\)")
 514                                    org-index--below-cursor))
 515                 (setq search-ref (match-string 1 org-index--below-cursor)))))
 516
 517         ;; If we still do not have a search string, ask user explicitly
 518         (unless search-ref
 519           (if (eq command 'index)
 520               (let ((r (org-index--read-search-for-index)))
 521                 (setq search-ref (first r))
 522                 (setq search-id (second r))
 523                 (setq search-fingerprint (third r)))
 524             (unless (and (eq command 'head)
 525                          org-index--within-index-node
 526                          (org-at-table-p))
 527               (setq search-ref (read-from-minibuffer "Search reference number: ")))))
 528
 529         ;; Clean up search string
 530         (when search-ref
 531           (setq search-ref (org-trim search-ref))
 532           (if (string-match "^[0-9]+$" search-ref)
 533               (setq search-ref (concat org-index--head search-ref org-index--tail)))
 534           (if (string= search-ref "") (setq search-ref nil)))
 535
 536         (if (and (not search-ref)
 537                  (not (eq command 'index))
 538                  (not (and (eq command 'head)
 539                            org-index--within-index-node
 540                            (org-at-table-p))))
 541             (error "Command %s needs a reference number" command)))
 542
 543
 544       ;;
 545       ;; Command sort needs to know in advance, what to sort for
 546       ;;
 547
 548       (when (eq command 'sort)
 549         (setq sort-what (intern (org-completing-read "You may sort:\n  - index  : your index table by various columns\n  - region : the active region by contained reference\n  - buffer : the whole current buffer\nPlease choose what to sort: " (list "index" "region" "buffer") nil t))))
 550
 551
 552       ;;
 553       ;; Enter table
 554       ;;
 555
 556       ;; Arrange for beeing able to return
 557       (when (and (memq command '(occur head index example sort maintain))
 558                  (not (string= (buffer-name) org-index--occur-buffer-name)))
 559         (org-mark-ring-push))
 560
 561       ;; These commands will leave user in index table after they are finished
 562       (when (or (memq command '(index maintain))
 563                 (and (eq command 'sort)
 564                      (eq sort-what 'index)))
 565
 566         (pop-to-buffer-same-window org-index--buffer)
 567         (goto-char org-index--point)
 568         (org-index--unfold-buffer))
 569
 570
 571       ;;
 572       ;; Actually do, what is requested
 573       ;;
 574
 575       (cond
 576
 577        ((eq command 'help)
 578
 579         ;; bring up help-buffer for this function
 580         (describe-function 'org-index))
 581
 582
 583        ((eq command 'find-ref)
 584
 585         ;; Construct list of all org-buffers
 586         (let (org-buffers)
 587           (dolist (buff (buffer-list))
 588             (set-buffer buff)
 589             (if (string= major-mode "org-mode")
 590                 (setq org-buffers (cons buff org-buffers))))
 591
 592           ;; Do multi-occur
 593           (multi-occur org-buffers (org-index--make-guarded-search search-ref))
 594
 595           ;; Present results
 596           (if (get-buffer "*Occur*")
 597               (progn
 598                 (setq message-text (format "Found '%s'" search-ref))
 599                 (other-window 1)
 600                 (toggle-truncate-lines 1))
 601             (setq message-text (format "Did not find '%s'" search-ref)))))
 602
 603
 604        ((eq command 'add)
 605
 606         (let ((r (org-index--do-add-or-update (if (equal arg '(4)) t nil)
 607                                               (if (numberp arg) arg nil))))
 608           (setq message-text (car r))
 609           (setq kill-new-text (cdr r))))
 610
 611
 612        ((eq command 'kill)
 613         (setq message-text (org-index--do-kill)))
 614
 615
 616        ((eq command 'head)
 617
 618         (if (and org-index--within-index-node
 619                  (org-at-table-p))
 620             (setq search-id (org-index--get-or-set-field 'id)))
 621
 622         (if (and (not search-id) search-ref)
 623             (setq search-id (org-index--id-from-ref search-ref)))
 624
 625         (setq message-text
 626               (if search-id
 627                   (org-index--find-id search-id)
 628                 "Current line has no id")))
 629
 630
 631        ((eq command 'index)
 632
 633         (goto-char org-index--below-hline)
 634
 635         (setq message-text
 636
 637               (if search-ref
 638                   (if (org-index--go 'ref search-ref)
 639                       (progn
 640                         (org-index--update-current-line)
 641                         (org-table-goto-column (org-index--column-num 'ref))
 642                         (format "Found index line '%s'" search-ref))
 643                     (format "Did not find index line with reference '%s'" search-ref))
 644
 645                 (if search-id
 646                     (if (org-index--go 'id search-id)
 647                         (progn
 648                           (org-index--update-current-line)
 649                           (org-table-goto-column (org-index--column-num 'ref))
 650                           (format "Found index line '%s'" (org-index--get-or-set-field 'ref)))
 651                       (format "Did not find index line with id '%s'" search-id))
 652
 653                   (if search-fingerprint
 654                       (if (org-index--go 'fingerprint org-index--last-fingerprint)
 655                           (progn
 656                             (org-index--update-current-line)
 657                             (beginning-of-line)
 658                             (format "Found latest index line"))
 659                         (format "Did not find index line"))
 660
 661                     ;; simply go into table
 662                     "At index table"))))
 663
 664         (recenter))
 665
 666
 667        ((eq command 'ping)
 668
 669         (let ((moved-up 0) id info reached-top)
 670
 671           (unless (string= major-mode "org-mode") (error "No node at point"))
 672           ;; take id from current node or reference
 673           (setq id (if search-ref
 674                        (org-index--id-from-ref search-ref)
 675                      (org-id-get)))
 676
 677           ;; move up until we find a node in index
 678           (save-excursion
 679             (outline-back-to-heading)
 680             (while (not (or info
 681                             reached-top))
 682               (if id
 683                   (setq info (org-index--on 'id id
 684                                (mapcar (lambda (x) (org-index--get-or-set-field x))
 685                                        (list 'ref 'count 'created 'last-accessed 'category 'keywords 'ref)))))
 686
 687               (setq reached-top (= (org-outline-level) 1))
 688
 689               (unless (or info
 690                           reached-top)
 691                 (outline-up-heading 1 t)
 692                 (cl-incf moved-up))
 693
 694               (setq id (org-id-get))))
 695
 696           (if info
 697               (progn
 698                 (setq message-text
 699                       (apply 'format
 700                              (append (list "'%s'%shas been accessed %s times between %s and %s; category is '%s', keywords are '%s'"
 701                                            (pop info)
 702                                            (if (> moved-up 0) (format " (parent node, %d level up) " moved-up) " "))
 703                                      info)))
 704                 (setq kill-new-text (car (last info))))
 705             (setq message-text "Neither this node nor any of its parents is part of index"))))
 706
 707
 708        ((eq command 'occur)
 709
 710         (set-buffer org-index--buffer)
 711         (org-index--do-occur))
 712
 713
 714        ((eq command 'ref)
 715
 716         (let (args)
 717
 718           (setq args (org-index--collect-values-from-user org-index-edit-on-ref))
 719           (setq args (plist-put args 'category "yank"))
 720           (setq args (plist-put args 'ref org-index--nextref))
 721           (apply 'org-index--do-new-line args)
 722
 723           (setq kill-new-text org-index--nextref)
 724
 725           (setq message-text (format "Added new row with ref '%s'" org-index--nextref))))
 726
 727
 728        ((eq command 'yank)
 729
 730         (let (args)
 731
 732           (setq args (org-index--collect-values-from-user org-index-edit-on-yank))
 733           (if (plist-get args 'yank)
 734               (plist-put args 'yank (replace-regexp-in-string "|" (regexp-quote "\\vert") (plist-get args 'yank) nil 'literal)))
 735           (setq args (plist-put args 'category "yank"))
 736           (apply 'org-index--do-new-line args)
 737
 738           (setq message-text "Added new row with text to yank")))
 739
 740
 741        ((eq command 'column)
 742
 743         (if (and org-index--within-index-node
 744                  (org-at-table-p))
 745             (let (char col num)
 746               (setq char (read-char "Please specify, which column to go to (r=ref, k=keywords, c=category, y=yank): "))
 747               (unless (memq char (list ?r ?k ?c ?y))
 748                 (error (format "Invalid char '%c', cannot goto this column" char)))
 749               (setq col (cdr (assoc char '((?r . ref) (?k . keywords) (?c . category) (?y . yank)))))
 750               (setq num (org-index--column-num col))
 751               (if num
 752                   (progn
 753                     (org-table-goto-column num)
 754                     (setq message-text (format "At column %s" (symbol-name col))))
 755
 756                 (error (format "Column '%s' is not present" col))))
 757           (error "Need to be in index table to go to a specific column")))
 758
 759
 760        ((eq command 'edit)
 761
 762         (setq message-text (org-index--do-edit)))
 763
 764
 765        ((eq command 'sort)
 766
 767         (let ((sorts (list "count" "last-accessed" "mixed" "id" "ref"))
 768               sort groups-and-counts)
 769
 770           (cond
 771            ((eq sort-what 'index)
 772             (setq sort
 773                   (intern
 774                    (completing-read
 775                     "Please choose column to sort index table: "
 776                     (cl-copy-list sorts)
 777                     nil t nil nil (symbol-name org-index-sort-by))))
 778
 779             (org-index--do-sort-index sort)
 780             (org-table-goto-column (org-index--column-num (if (eq sort 'mixed) 'last-access sort)))
 781             ;; When saving index, it should again be sorted correctly
 782             (with-current-buffer org-index--buffer
 783               (add-hook 'before-save-hook 'org-index--sort-silent t))
 784
 785             (setq message-text
 786                   (format
 787                    (concat "Your index has been sorted temporarily by %s and will be sorted again by %s after %d seconds of idle time"
 788                            (if groups-and-counts
 789                                "; %d groups with equal %s and a total of %d lines have been found"
 790                              ""))
 791                    (symbol-name sort)
 792                    org-index-sort-by
 793                    org-index--sort-idle-delay
 794                    (second groups-and-counts)
 795                    (symbol-name sort)
 796                    (third groups-and-counts))))
 797
 798            ((memq sort-what '(region buffer))
 799             (org-index--do-sort-lines sort-what)
 800             (setq message-text (format "Sorted %s by contained references" sort-what))))))
 801
 802
 803        ((eq command 'highlight)
 804
 805         (let ((where "buffer"))
 806           (save-excursion
 807             (save-restriction
 808               (when (and transient-mark-mode
 809                          mark-active)
 810                 (narrow-to-region (region-beginning) (region-end))
 811                 (setq where "region"))
 812
 813               (if arg
 814                   (progn
 815                     (unhighlight-regexp org-index--ref-regex)
 816                     (setq message-text (format "Removed highlights for references in %s" where)))
 817                 (highlight-regexp org-index--ref-regex 'isearch)
 818                 (setq message-text (format "Highlighted references in %s" where)))))))
 819
 820
 821        ((eq command 'maintain)
 822         (setq message-text (org-index--do-maintain)))
 823
 824
 825        ((eq command 'example)
 826
 827         (if (y-or-n-p "This assistant will help you to create a temporary index with detailed comments.\nDo you want to proceed ? ")
 828             (org-index--create-index t)))
 829
 830
 831        ((not command) (setq message-text "No command given"))
 832
 833
 834        (t (error "Unknown subcommand '%s'" command)))
 835
 836
 837       ;; tell, what we have done and what can be yanked
 838       (if kill-new-text (setq kill-new-text
 839                               (substring-no-properties kill-new-text)))
 840       (if (string= kill-new-text "") (setq kill-new-text nil))
 841       (let ((m (concat
 842                 message-text
 843                 (if (and message-text kill-new-text)
 844                     " and r"
 845                   (if kill-new-text "R" ""))
 846                 (if kill-new-text (format "eady to yank '%s'." kill-new-text) (if message-text "." "")))))
 847         (unless (string= m "")
 848           (message m)
 849           (setq org-index--message-text m)))
 850       (if kill-new-text (kill-new kill-new-text)))))
 851
 852
 853 (defun org-index-dispatch (&optional arg)
 854   "Read additional chars and call subcommands of `org-index'.
 855 Can be bound in global keyboard map as central entry point.
 856 Optional argument ARG is passed on."
 857   (interactive "P")
 858   (let (char command)
 859     (if (sit-for 1)
 860         (message "org-index (? for detailed prompt) -"))
 861     (setq char (key-description (read-key-sequence nil)))
 862     (if (string= char "C-g") (keyboard-quit))
 863     (if (string= char "SPC") (setq char "?"))
 864     (setq command (cdr (assoc char (org-index--get-shortcut-chars))))
 865     (unless command
 866       (message "No subcommand for '%s'; switching to detailed prompt" char)
 867       (sit-for 1)
 868       (setq command 'short-help))
 869     (org-index command nil arg)))
 870
 871
 872 (defun org-index-new-line (&rest keys-values)
 873   "Create a new line within the index table, returning its reference.
 874
 875 The function takes a varying number of argument pairs; each pair
 876 is a symbol for an existing column heading followed by its value.
 877 The return value is the new reference.
 878
 879 Example:
 880
 881   (message \"Created reference %s\"
 882            (org-index-new-line 'keywords \"foo bar\" 'category \"baz\"))
 883
 884 Optional argument KEYS-VALUES specifies content of new line."
 885
 886   (let ((ref (plist-get keys-values 'ref)))
 887     (org-index--verify-id)
 888     (org-index--parse-table)
 889     (if (not (memq ref  '(t nil)))
 890         (error "Column 'ref' accepts only 't' or 'nil'"))
 891     (when ref
 892       (setq ref org-index--nextref)
 893       (setq keys-values (plist-put keys-values 'ref ref)))
 894
 895     (apply 'org-index--do-new-line keys-values)
 896     ref))
 897
 898
 899 (defun org-index--read-command (&optional with-short-help)
 900   "Read subcommand for ‘org-index’ from minibuffer.
 901 Optional argument WITH-SHORT-HELP displays help screen upfront."
 902   (let (minibuffer-scroll-window
 903         minibuffer-setup-fun
 904         command)
 905     (setq org-index--short-help-displayed nil)
 906     (add-hook 'minibuffer-setup-hook 'org-index--minibuffer-setup-function)
 907     (add-hook 'minibuffer-exit-hook 'org-index--minibuffer-exit-function)
 908     (unwind-protect
 909         (setq command
 910               (intern
 911                (completing-read
 912                 (concat
 913                  "Please choose"
 914                  (if org-index--display-short-help "" " (? for short help)")
 915                  ": ")
 916                 (mapcar 'symbol-name org-index--commands) nil t)))
 917       (remove-hook 'minibuffer-setup-hook 'org-index--minibuffer-setup-function)
 918       (remove-hook 'minibuffer-exit-hook 'org-index--minibuffer-exit-function)
 919       (when org-index--short-help-displayed
 920         (quit-windows-on org-index--short-help-buffer-name)))
 921     command))
 922
 923
 924 (defun org-index--minibuffer-setup-function ()
 925   "Prepare minibuffer for `org-index--read-command'."
 926   (setq org-index--minibuffer-saved-key (local-key-binding (kbd "?")))
 927   (local-set-key (kbd "?") 'org-index--minibuffer-short-help-helper)
 928   (if org-index--display-short-help (org-index--minibuffer-short-help-helper)))
 929
 930
 931 (defun org-index--minibuffer-exit-function ()
 932   "Restore minibuffer after `org-index--read-command'."
 933   (local-set-key (kbd "?") org-index--minibuffer-saved-key)
 934   (setq org-index--minibuffer-saved-key nil))
 935
 936
 937 (defun org-index--minibuffer-short-help-helper ()
 938   "Helper function to show help in minibuffer."
 939   (interactive)
 940   ;; take original help-text for org-index and extract one-line help for subcommands
 941   (with-temp-buffer-window
 942    org-index--short-help-buffer-name nil nil
 943    (setq org-index--short-help-displayed t)
 944    (princ (concat "Short help; all subcommands of `org-index', shortcuts in []; type "
 945                   (substitute-command-keys "\\[scroll-other-window]")
 946                   " to scroll:\n"))
 947    (princ (org-index--get-short-help-text))))
 948
 949
 950 (defun org-index--get-short-help-text ()
 951   "Extract text for short help message from long help."
 952   (or org-index--short-help-text
 953       (with-temp-buffer
 954         (insert (documentation 'org-index))
 955         (goto-char (point-min))
 956         (search-forward (concat "  " (symbol-name (first org-index--commands)) ": "))
 957         (forward-line 0)
 958         (kill-region (point-min) (point))
 959         (search-forward (concat "  " (symbol-name (car (last org-index--commands))) ": "))
 960         (forward-line 1)
 961         (kill-region (point) (point-max))
 962         (keep-lines "^  [-a-z]+:" (point-min) (point-max))
 963         (align-regexp (point-min) (point-max) "\\(\\s-*\\):")
 964         (goto-char (point-min))
 965         (while (re-search-forward "\\. *$" nil t)
 966           (replace-match "" nil nil))
 967         (goto-char (point-min))
 968         (re-search-forward "short-help")
 969         (end-of-line)
 970         (insert " (this text)")
 971         (goto-char (point-min))
 972         (unless (= (line-number-at-pos (point-max)) (1+ (length org-index--commands)))
 973           (error "Internal error, unable to properly extract one-line descriptions of subcommands"))
 974         (setq org-index--short-help-text (buffer-string)))))
 975
 976
 977 (defun org-index--get-shortcut-chars ()
 978   "Collect shortcut chars from short help message."
 979   (or org-index--shortcut-chars
 980       (with-temp-buffer
 981         (insert (org-index--get-short-help-text))
 982         (goto-char (point-min))
 983         (while (< (point) (point-max))
 984           (when (looking-at "^  \\([-a-z]+\\) +: +\\[\\([a-z?]\\)\\] ")
 985             (setq org-index--shortcut-chars
 986                   (cons (cons (match-string 2) (intern (match-string 1)))
 987                         org-index--shortcut-chars)))
 988           (forward-line 1))
 989         (unless (> (length org-index--shortcut-chars) 0)
 990           (error "Internal error, did not find shortcut chars"))
 991         org-index--shortcut-chars)))
 992
 993
 994 (defun org-index--do-edit ()
 995   "Perform command edit."
 996   (let ((maxlen 0) cols-vals buffer-keymap field-keymap keywords-pos val)
 997
 998     (setq org-index--context-node nil)
 999     (setq org-index--context-occur nil)
1000
1001     ;; change to index, if whithin occur
1002     (if org-index--within-occur
1003         (let ((pos (get-text-property (point) 'org-index-lbp)))
1004           (org-index--occur-test-stale pos)
1005           (setq org-index--context-occur (cons (point) (org-index--line-in-canonical-form)))
1006           (set-buffer org-index--buffer)
1007           (goto-char pos))
1008
1009       ;; change to index, if still not within
1010       (if (not org-index--within-index-node)
1011           (let ((id (org-id-get)))
1012             (setq org-index--context-node (cons (current-buffer) (point)))
1013             (set-buffer org-index--buffer)
1014             (unless (and id (org-index--go 'id id))
1015               (setq org-index--context-node nil)
1016               (error "This node is not in index")))))
1017
1018     ;; retrieve current content of index line
1019     (dolist (col (mapcar 'car (reverse org-index--columns)))
1020       (if (> (length (symbol-name col)) maxlen)
1021           (setq maxlen (length (symbol-name col))))
1022       (setq val (org-index--get-or-set-field col))
1023       (if (and val (eq col 'yank)) (setq val (replace-regexp-in-string (regexp-quote "\\vert") "|" val nil 'literal)))
1024       (setq cols-vals (cons (cons col val)
1025                             cols-vals)))
1026
1027     ;; we need two different keymaps
1028     (setq buffer-keymap (make-sparse-keymap))
1029     (set-keymap-parent buffer-keymap widget-keymap)
1030     (define-key buffer-keymap (kbd "C-c C-c") 'org-index--edit-c-c-c-c)
1031     (define-key buffer-keymap (kbd "C-c C-k") 'org-index--edit-c-c-c-k)
1032
1033     (setq field-keymap (make-sparse-keymap))
1034     (set-keymap-parent field-keymap widget-field-keymap)
1035     (define-key field-keymap (kbd "C-c C-c") 'org-index--edit-c-c-c-c)
1036     (define-key field-keymap (kbd "C-c C-k") 'org-index--edit-c-c-c-k)
1037
1038     ;; prepare buffer
1039     (setq org-index--context-index (cons (point) (org-index--line-in-canonical-form)))
1040     (if (get-buffer org-index--edit-buffer-name) (kill-buffer org-index--edit-buffer-name))
1041     (switch-to-buffer (get-buffer-create org-index--edit-buffer-name))
1042
1043     ;; create and fill widgets
1044     (setq org-index--edit-widgets nil)
1045     (widget-insert "Edit this line from index; type C-c C-c when done, C-c C-k to abort.\n\n")
1046     (dolist (col-val cols-vals)
1047       (if (eq (car col-val) 'keywords) (setq keywords-pos (point)))
1048       (setq org-index--edit-widgets (cons
1049                                      (cons (car col-val)
1050                                            (widget-create 'editable-field
1051                                                           :format (format  (format "%%%ds: %%%%v" maxlen) (symbol-name (car col-val)))
1052                                                           :keymap field-keymap
1053                                                           (or (cdr col-val) "")))
1054                                      org-index--edit-widgets)))
1055
1056     (widget-setup)
1057     (goto-char keywords-pos)
1058     (beginning-of-line)
1059     (forward-char (+  maxlen 2))
1060     (use-local-map buffer-keymap)
1061     "Editing a single line from index"))
1062
1063
1064 (defun org-index--edit-c-c-c-c ()
1065   "Function to  invoked on C-c C-c in Edit buffer."
1066   (interactive)
1067
1068   (let ((obuf (get-buffer org-index--occur-buffer-name))
1069         val line)
1070
1071     ;; Time might have passed
1072     (org-index--refresh-parse-table)
1073
1074     (with-current-buffer org-index--buffer
1075
1076       ;; check, if buffer has become stale
1077       (save-excursion
1078         (goto-char (car org-index--context-index))
1079         (unless (string= (cdr org-index--context-index)
1080                          (org-index--line-in-canonical-form))
1081           (switch-to-buffer org-index--edit-buffer-name)
1082           (error "Index table has changed: Cannot find line, that this buffer is editing")))
1083
1084       (pop-to-buffer-same-window org-index--buffer)
1085       (goto-char (car org-index--context-index))
1086
1087       ;; write back line to index
1088       (dolist (col-widget org-index--edit-widgets)
1089         (setq val (widget-value (cdr col-widget)))
1090         (if (eq (car col-widget) 'yank) (setq val (replace-regexp-in-string "|" (regexp-quote "\\vert") val)))
1091         (org-index--get-or-set-field (car col-widget) val))
1092
1093       (setq line (org-index--align-and-fontify-current-line))
1094       (beginning-of-line))
1095
1096     ;; write line to occur if appropriate
1097     (if org-index--context-occur
1098         (if obuf
1099             (if (string= (cdr org-index--context-index)
1100                          (cdr org-index--context-occur))
1101                 (progn
1102                   (pop-to-buffer-same-window obuf)
1103                   (goto-char (car org-index--context-occur))
1104                   (beginning-of-line)
1105                   (let ((inhibit-read-only t))
1106                     (delete-region (line-beginning-position) (line-end-position))
1107                     (insert line)
1108                     (put-text-property (line-beginning-position) (line-end-position)
1109                                        'org-index-lbp (cdr org-index--context-index))))
1110               (error "Occur buffer and index buffer do not match any longer"))
1111           (message "Occur buffer has gone, cannot switch back."))
1112       (setq org-index--context-occur nil))
1113
1114     ;; return to node, if invoked from there
1115     (when org-index--context-node
1116         (pop-to-buffer-same-window (car org-index--context-node))
1117         (goto-char (cdr org-index--context-node)))
1118
1119     ;; clean up
1120     (kill-buffer org-index--edit-buffer-name)
1121     (setq org-index--context-index nil)
1122     (setq org-index--edit-widgets nil)
1123     (beginning-of-line)
1124     (message "Index line has been edited.")))
1125
1126
1127 (defun org-index--edit-c-c-c-k ()
1128   "Function invoked on C-c C-k in Edit buffer."
1129   (interactive)
1130   (kill-buffer org-index--edit-buffer-name)
1131   (setq org-index--context-index nil)
1132   (setq org-index--edit-widgets nil)
1133   (beginning-of-line)
1134   (message "Edit aborted."))
1135
1136
1137 (defun org-index--do-new-line (&rest keys-values)
1138   "Do the work for `org-index-new-line'.
1139 Optional argument KEYS-VALUES specifies content of new line."
1140
1141   (org-index--retrieve-context)
1142   (with-current-buffer org-index--buffer
1143     (goto-char org-index--point)
1144
1145     ;; check arguments early; they might come from userland
1146     (let ((kvs keys-values)
1147           k v)
1148       (while kvs
1149         (setq k (car kvs))
1150         (setq v (cadr kvs))
1151         (if (or (not (symbolp k))
1152                 (and (symbolp v) (not (eq v t)) (not (eq v nil))))
1153             (error "Arguments must be alternation of key and value"))
1154         (unless (org-index--column-num k)
1155           (error "Unknown column or column not defined in table: '%s'" (symbol-name k)))
1156         (setq kvs (cddr kvs))))
1157
1158     (let (yank)
1159       ;; create new line
1160       (org-index--create-new-line)
1161
1162       ;; fill columns
1163       (let ((kvs keys-values)
1164             k v)
1165         (while kvs
1166           (setq k (car kvs))
1167           (setq v (cadr kvs))
1168           (org-table-goto-column (org-index--column-num k))
1169           (insert (org-trim (or v "")))
1170           (setq kvs (cddr kvs))))
1171
1172       ;; align and fontify line
1173       (org-index--promote-current-line)
1174       (org-index--align-and-fontify-current-line)
1175
1176       ;; remember fingerprint to be able to return
1177       (setq org-index--last-fingerprint (org-index--get-or-set-field 'fingerprint))
1178
1179       ;; get column to yank
1180       (setq yank (org-index--get-or-set-field org-index-yank-after-add))
1181
1182       yank)))
1183
1184
1185 (defun org-index-get-line (column value)
1186   "Retrieve an existing line within the index table by ref or id.
1187 Return its contents as a property list.
1188
1189 The function `plist-get' may be used to retrieve specific elements
1190 from the result.
1191
1192 Example:
1193
1194   (plist-get (org-index-get-line 'ref \"R12\") 'count)
1195
1196 retrieves the value of the count-column for reference number 12.
1197
1198 Argument COLUMN is a symbol, either ref or id,
1199 argument VALUE specifies the value to search for."
1200   ;; check arguments
1201   (unless (memq column '(ref id))
1202     (error "Argument column can only be 'ref' or 'id'"))
1203
1204   (unless value
1205     (error "Need a value to search for"))
1206
1207   (org-index--verify-id)
1208   (org-index--parse-table)
1209
1210   (org-index--get-line column value))
1211
1212
1213 (defun org-index--get-line (column value)
1214   "Find a line by ID, return its contents.
1215 Argument COLUMN and VALUE specify line to get."
1216   (let (content)
1217     (org-index--on
1218      column value
1219      (mapc (lambda (x)
1220              (if (and (numberp (cdr x))
1221                       (> (cdr x) 0))
1222                  (setq content (cons (car x) (cons (or (org-index--get-or-set-field (car x)) "") content)))))
1223            (reverse org-index--columns)))
1224     content))
1225
1226
1227 (defun org-index--ref-from-id (id)
1228   "Get reference from line ID."
1229   (org-index--on 'id id (org-index--get-or-set-field 'ref)))
1230
1231
1232 (defun org-index--id-from-ref (ref)
1233   "Get id from line REF."
1234   (org-index--on 'ref ref (org-index--get-or-set-field 'id)))
1235
1236
1237 (defun org-index--get-fingerprint ()
1238   "Get fingerprint of current line."
1239   (replace-regexp-in-string
1240    "\\s " ""
1241    (mapconcat (lambda (x) (org-index--get-or-set-field x)) '(id ref yank keywords created) "")))
1242
1243
1244 (defun org-index--read-search-for-index ()
1245     "Special input routine for command index."
1246
1247     ;; Accept single char commands or switch to reading a sequence of digits
1248     (let (char prompt search-ref search-id search-fingerprint)
1249
1250       ;; start with short prompt but give more help on next iteration
1251       (setq prompt "Please specify, where to go in index (0-9,.,space,backspace,return or ? for short help) - ")
1252
1253       ;; read one character
1254       (while (not (memq char (append (number-sequence ?0 ?9) (list ?\d ?\b ?\r ?\j ?\s ?.))))
1255         (setq char (read-char prompt))
1256         (setq prompt "Go to specific position in index table. Digits specify a reference number, <space> goes to top of index, <backspace> or <delete> to last line created and <return> or `.' to index line of current node. Please choose - "))
1257
1258       (if (memq char (number-sequence ?0 ?9))
1259           ;; read rest of digits
1260           (setq search-ref (read-from-minibuffer "Search reference number: " (char-to-string char))))
1261       ;; decode single chars
1262       (if (memq char '(?\r ?\n ?.)) (setq search-id (org-id-get)))
1263       (if (memq char '(?\d ?\b)) (setq search-fingerprint org-index--last-fingerprint))
1264
1265       (list search-ref search-id search-fingerprint)))
1266
1267
1268 (defun org-index--verify-id ()
1269   "Check, that we have a valid id."
1270
1271   ;; Check id
1272   (unless org-index-id
1273     (let ((answer (org-completing-read "Cannot find an index (org-index-id is not set). You may:\n  - read-help    : to learn more about org-index\n  - create-index : invoke an assistant to create an initial index\nPlease choose: " (list "read-help" "create-index") nil t nil nil "read-help")))
1274       (if (string= answer "create-index")
1275           (org-index--create-missing-index "Variable org-index-id is not set, so probably no index table has been created yet.")
1276         (describe-function 'org-index)
1277         (throw 'new-index nil))))
1278
1279   ;; Find node
1280   (let (marker)
1281     (setq marker (org-id-find org-index-id 'marker))
1282     (unless marker (org-index--create-missing-index "Cannot find the node with id \"%s\" (as specified by variable org-index-id)." org-index-id))
1283     ; Try again with new node
1284     (setq marker (org-id-find org-index-id 'marker))
1285     (unless marker (error "Could not create node"))
1286     (setq org-index--buffer (marker-buffer marker)
1287           org-index--point (marker-position marker))
1288     (move-marker marker nil)))
1289
1290
1291 (defun org-index--retrieve-context ()
1292   "Collect context information before starting with command."
1293
1294   ;; Get the content of the active region or the word under cursor
1295   (setq org-index--active-region
1296         (if (and transient-mark-mode mark-active)
1297             (buffer-substring (region-beginning) (region-end))
1298           nil))
1299   (setq org-index--below-cursor (thing-at-point 'symbol))
1300
1301   ;; get category of current node
1302   (setq org-index--category-before
1303         (save-excursion ; workaround: org-get-category does not give category when at end of buffer
1304           (beginning-of-line)
1305           (org-get-category (point) t)))
1306
1307   ;; Find out, if we are within index table or occur buffer
1308   (setq org-index--within-index-node (string= (org-id-get) org-index-id))
1309   (setq org-index--within-occur (string= (buffer-name) org-index--occur-buffer-name)))
1310
1311
1312 (defun org-index--parse-table ()
1313   "Parse content of index table."
1314
1315   (let (ref-field
1316         id-field
1317         initial-point
1318         end-of-headings
1319         start-of-headings)
1320
1321     (with-current-buffer org-index--buffer
1322
1323       (setq org-index--maxrefnum 0)
1324       (setq initial-point (point))
1325
1326       (org-index--go-below-hline)
1327
1328       ;; align and fontify table once for this emacs session
1329       (unless org-index--aligned
1330         (org-table-align) ; needs to happen before fontification to be effective ?
1331         (let ((is-modified (buffer-modified-p))
1332               (below (point)))
1333           (while (org-at-table-p)
1334             (forward-line))
1335           (font-lock-fontify-region below (point))
1336           (org-index--go-below-hline)
1337           (setq org-index--aligned t)
1338           (set-buffer-modified-p is-modified)))
1339
1340       (org-index--go-below-hline)
1341       (beginning-of-line)
1342
1343       ;; get headings to display during occur
1344       (setq end-of-headings (point))
1345       (while (org-at-table-p) (forward-line -1))
1346       (forward-line)
1347       (setq start-of-headings (point))
1348       (setq org-index--headings-visible (substring-no-properties (org-index--copy-visible start-of-headings end-of-headings)))
1349       (setq org-index--headings (buffer-substring start-of-headings end-of-headings))
1350
1351       ;; count columns
1352       (org-table-goto-column 100)
1353       (setq org-index--numcols (- (org-table-current-column) 1))
1354
1355       ;; go to top of table
1356       (while (org-at-table-p)
1357         (forward-line -1))
1358       (forward-line)
1359
1360       ;; parse line of headings
1361       (org-index--parse-headings)
1362
1363       ;; parse list of flags
1364       (goto-char org-index--point)
1365
1366       ;; Retrieve any decorations around the number within the first nonempty ref-field
1367       (goto-char org-index--below-hline)
1368       (while (and (org-at-table-p)
1369                   (not (setq ref-field (org-index--get-or-set-field 'ref))))
1370         (forward-line))
1371
1372       ;; Some Checking
1373       (unless ref-field
1374         (org-index--report-index-error "Reference column is empty"))
1375
1376       (unless (string-match "^\\([^0-9]*\\)\\([0-9]+\\)\\([^0-9]*\\)$" ref-field)
1377         (org-index--report-index-error
1378          "First reference in index table ('%s') does not contain a number" ref-field))
1379
1380       ;; These are the decorations used within the first ref of index
1381       (setq org-index--head (match-string 1 ref-field))
1382       (setq org-index--tail (match-string 3 ref-field))
1383       (setq org-index--ref-regex (concat (regexp-quote org-index--head)
1384                                          "\\([0-9]+\\)"
1385                                          (regexp-quote org-index--tail)))
1386       (setq org-index--ref-format (concat org-index--head "%d" org-index--tail))
1387
1388       ;; check if the table still seems to be sorted mixed
1389       (goto-char org-index--below-hline)
1390       (when (eq org-index-sort-by 'mixed)
1391           (org-index--go-below-hline)
1392           (if (string< (org-index--get-or-set-field 'last-accessed)
1393                        (org-index--get-mixed-time))
1394               (org-index--do-sort-index org-index-sort-by)))
1395
1396       ;; Go through table to find maximum number and do some checking
1397       (let ((refnum 0))
1398
1399         (while (org-at-table-p)
1400
1401           (setq ref-field (org-index--get-or-set-field 'ref))
1402           (setq id-field (org-index--get-or-set-field 'id))
1403
1404           (if ref-field
1405               (if (string-match org-index--ref-regex ref-field)
1406                   ;; grab number
1407                   (setq refnum (string-to-number (match-string 1 ref-field)))
1408                 (kill-whole-line)
1409                 (message "Removing line from index-table whose ref does not contain a number")))
1410
1411           ;; check, if higher ref
1412           (if (> refnum org-index--maxrefnum) (setq org-index--maxrefnum refnum))
1413
1414           (forward-line 1)))
1415
1416       (setq org-index--nextref (format "%s%d%s" org-index--head (1+ org-index--maxrefnum) org-index--tail))
1417       ;; go back to initial position
1418       (goto-char initial-point))))
1419
1420
1421 (defun org-index--refresh-parse-table ()
1422   "Fast refresh of selected results of parsing index table."
1423
1424   (setq org-index--point (marker-position (org-id-find org-index-id 'marker)))
1425   (with-current-buffer org-index--buffer
1426     (save-excursion
1427       (org-index--go-below-hline))))
1428
1429
1430 (defun org-index--do-maintain ()
1431   "Choose among and perform some tasks to maintain index."
1432   (let ((check-what) (max-mini-window-height 1.0) message-text)
1433     (setq check-what (intern (org-completing-read "These checks and fixes are available:\n  - statistics : compute statistics about index table\n  - check      : check ids by visiting their nodes\n  - duplicates : check index for duplicate rows (ref or id)\n  - clean      : remove obsolete property org-index-id\n  - update     : update content of index lines, with an id \nPlease choose: " (list "statistics" "check" "duplicates" "clean" "update") nil t nil nil "statistics")))
1434     (message nil)
1435
1436     (cond
1437      ((eq check-what 'check)
1438       (setq message-text (or (org-index--check-ids)
1439                              "No problems found")))
1440
1441      ((eq check-what 'statistics)
1442       (setq message-text (org-index--do-statistics)))
1443
1444      ((eq check-what 'duplicates)
1445       (setq message-text (org-index--find-duplicates)))
1446
1447      ((eq check-what 'clean)
1448       (let ((lines 0))
1449         (org-map-entries
1450          (lambda ()
1451            (when (org-entry-get (point) "org-index-ref")
1452              (cl-incf lines)
1453              (org-entry-delete (point) "org-index-ref")))
1454          nil 'agenda)
1455         (setq message-text (format "Removed property 'org-index-ref' from %d lines" lines))))
1456
1457      ((eq check-what 'update)
1458       (if (y-or-n-p "Updating your index will overwrite certain columns with content from the associated heading and category.  If unsure, you may try this for a single, already existing line of your index by invoking `add'.  Are you SURE to proceed for ALL INDEX LINES ? ")
1459           (setq message-text (org-index--update-all-lines))
1460         (setq message-text "Canceled."))))
1461     message-text))
1462
1463
1464 (defun org-index--get-mixed-time ()
1465   "Get timestamp for sorting order mixed."
1466   (format-time-string
1467    (org-time-stamp-format t t)
1468    (apply 'encode-time (append '(0 0 0) (nthcdr 3 (decode-time))))))
1469
1470
1471 (defun org-index--do-sort-index (sort)
1472   "Sort index table according to SORT."
1473
1474   (let ((is-modified (buffer-modified-p))
1475         top
1476         bottom
1477         mixed-time)
1478
1479     (unless buffer-read-only
1480
1481       (message "Sorting index table for %s..." (symbol-name sort))
1482       (undo-boundary)
1483
1484       (let ((message-log-max nil)) ; we have just issued a message, dont need those of sort-subr
1485
1486         ;; if needed for mixed sort
1487         (if (eq sort 'mixed)
1488             (setq mixed-time (org-index--get-mixed-time)))
1489
1490         ;; get boundaries of table
1491         (org-index--go-below-hline)
1492         (forward-line 0)
1493         (setq top (point))
1494         (while (org-at-table-p) (forward-line))
1495
1496         ;; kill all empty rows at bottom
1497         (while (progn
1498                  (forward-line -1)
1499                  (org-table-goto-column 1)
1500                  (and
1501                   (not (org-index--get-or-set-field 'ref))
1502                   (not (org-index--get-or-set-field 'id))
1503                   (not (org-index--get-or-set-field 'yank))))
1504           (org-table-kill-row))
1505         (forward-line 1)
1506         (setq bottom (point))
1507
1508         ;; sort lines
1509         (save-restriction
1510           (narrow-to-region top bottom)
1511           (goto-char top)
1512           (sort-subr t
1513                      'forward-line
1514                      'end-of-line
1515                      (lambda ()
1516                        (org-index--get-sort-key sort t mixed-time))
1517                      nil
1518                      'string<)
1519           (goto-char (point-min))
1520
1521           ;; restore modification state
1522           (set-buffer-modified-p is-modified)))
1523
1524         (setq org-index--last-sort sort))))
1525
1526
1527 (defun org-index--do-sort-lines (what)
1528   "Sort lines in WHAT according to contained reference."
1529   (save-restriction
1530     (cond
1531      ((eq what 'region)
1532       (if (region-active-p)
1533           (narrow-to-region (region-beginning) (region-end))
1534         (error "No active region, cannot sort")))
1535      ((eq what 'buffer)
1536       (unless (y-or-n-p "Sort whole current buffer ? ")
1537         (error "Canceled"))
1538       (narrow-to-region (point-min) (point-max))))
1539
1540     (goto-char (point-min))
1541     (sort-subr nil 'forward-line 'end-of-line
1542                (lambda ()
1543                  (if (looking-at (concat ".*"
1544                                          (org-index--make-guarded-search org-index--ref-regex 'dont-quote)))
1545                      (string-to-number (match-string 1))
1546                    0)))))
1547
1548
1549 (defun org-index--go-below-hline ()
1550   "Move below hline in index-table."
1551
1552   (let ((errstring (format "index table within node %s" org-index-id)))
1553
1554     (goto-char org-index--point)
1555
1556     ;; go to heading of node
1557     (while (not (org-at-heading-p)) (forward-line -1))
1558     (forward-line 1)
1559
1560     ;; go to first table, but make sure we do not get into another node
1561     (while (and (not (org-at-table-p))
1562                 (not (org-at-heading-p))
1563                 (not (eobp)))
1564       (forward-line))
1565
1566     ;; check, if there really is a table
1567     (unless (org-at-table-p)
1568       (org-index--create-missing-index "Cannot find %s." errstring))
1569
1570     ;; go just after hline
1571     (while (and (not (org-at-table-hline-p))
1572                 (org-at-table-p))
1573       (forward-line))
1574     (forward-line)
1575
1576     ;; and check
1577     (unless (org-at-table-p)
1578       (org-index--report-index-error "Cannot find a hline within %s" errstring))
1579
1580     (org-table-goto-column 1)
1581     (setq org-index--below-hline (point))))
1582
1583
1584 (defun org-index--parse-headings ()
1585   "Parse headings of index table."
1586
1587   (let (field         ;; field content
1588         field-symbol) ;; and as a symbol
1589
1590     (setq org-index--columns nil)
1591
1592     ;; For each column
1593     (dotimes (col org-index--numcols)
1594
1595       (setq field (substring-no-properties (downcase (org-trim (org-table-get-field (+ col 1))))))
1596
1597       (if (string= field "")
1598           (error "Heading of column cannot be empty"))
1599       (if (and (not (string= (substring field 0 1) "."))
1600                (not (member (intern field) org-index--valid-headings)))
1601           (error "Column name '%s' is not a valid heading (custom headings may start with a dot, e.g. '.foo')" field))
1602
1603       (setq field-symbol (intern field))
1604
1605       ;; check if heading has already appeared
1606       (if (assoc field-symbol org-index--columns)
1607           (org-index--report-index-error
1608            "'%s' appears two times as column heading" (downcase field))
1609         ;; add it to list at front, reverse later
1610         (setq org-index--columns (cons (cons field-symbol (+ col 1)) org-index--columns)))))
1611
1612   (setq org-index--columns (reverse org-index--columns))
1613
1614   ;; check if all necessary headings have appeared
1615   (mapc (lambda (head)
1616           (unless (cdr (assoc head org-index--columns))
1617             (org-index--report-index-error "No column has heading '%s'" head)))
1618         org-index--valid-headings))
1619
1620
1621 (defun org-index--create-missing-index (&rest reasons)
1622   "Create a new empty index table with detailed explanation.  Argument REASONS explains why."
1623
1624   (org-index--ask-before-create-index "Cannot find index table: "
1625                                       "new permanent" "."
1626                                       reasons)
1627   (org-index--create-index))
1628
1629
1630 (defun org-index--report-index-error (&rest reasons)
1631   "Report an error (explained by REASONS) with the existing index and offer to create a valid one to compare with."
1632
1633   (when org-index--buffer
1634     (pop-to-buffer-same-window org-index--buffer)
1635     (goto-char org-index--below-hline)
1636     (org-reveal t))
1637   (org-index--ask-before-create-index "The existing index contains this error: "
1638                                       "temporary" ", to compare with."
1639                                       reasons)
1640   (org-index--create-index t t))
1641
1642
1643 (defun org-index--ask-before-create-index (explanation type for-what reasons)
1644                                                   ; checkdoc-params: (explanation type for-what reasons)
1645   "Ask the user before creating an index or throw error.  Arguments specify bits of issued message."
1646   (let (reason prompt)
1647
1648     (setq reason (apply 'format reasons))
1649
1650     (setq prompt (concat explanation reason "\n"
1651                          "However, this assistant can help you to create a "
1652                          type " index with detailed comments" for-what "\n\n"
1653                          "Do you want to proceed ?"))
1654
1655     (unless (let ((max-mini-window-height 1.0))
1656               (y-or-n-p prompt))
1657       (error (concat explanation reason)))))
1658
1659
1660 (defun org-index--create-index (&optional temporary compare)
1661   "Create a new empty index table with detailed explanation.
1662 specify flag TEMPORARY for th new table temporary, maybe COMPARE it with existing index."
1663   (let (buffer
1664         title
1665         firstref
1666         id)
1667
1668     (if temporary
1669         (let ((file-name (concat temporary-file-directory "org-index--example-index.org"))
1670               (buffer-name "*org-index-example-index*"))
1671           (setq buffer (get-buffer-create buffer-name))
1672           (with-current-buffer buffer
1673             ;; but it needs a file for its index to be found
1674             (unless (string= (buffer-file-name) file-name)
1675               (set-visited-file-name file-name))
1676             (rename-buffer buffer-name) ; name is change by line above
1677
1678             (erase-buffer)
1679             (org-mode)))
1680
1681       (setq buffer (get-buffer (org-completing-read "Please choose the buffer, where the new node for the index table should be created; the new node will be inserted at its end.\n\nBuffer: " (mapcar 'buffer-name (org-buffer-list))))))
1682
1683     (setq title (read-from-minibuffer "Please enter the title of the index node (leave empty for default 'index'): "))
1684     (if (string= title "") (setq title "index"))
1685
1686     (while (progn
1687              (setq firstref (read-from-minibuffer "Please enter your first reference-number. This is an integer number preceeded by some and optionally followed by some non-numeric chars; e.g. 'R1', '-1-' or '#1#' (and your initial number does not need to be '1'). The format of your reference-numbers only needs to make sense for yourself, so that you can spot it easily in your texts or write it on a piece of paper; it should however not already appear frequently within your existing notes, to avoid too many false hits when searching.\n\nPlease choose (leave empty for default 'R1'): "))
1688              (if (string= firstref "") (setq firstref "R1"))
1689              (let (desc)
1690                (when (string-match "[[:blank:]]" firstref)
1691                  (setq desc "Contains whitespace"))
1692                (when (string-match "[[:cntrl:]]" firstref)
1693                  (setq desc "Contains control characters"))
1694                (unless (string-match "^[^0-9]+[0-9]+[^0-9]*$" firstref)
1695                  ;; firstref not okay, report details
1696                  (setq desc
1697                        (cond ((string= firstref "") "is empty")
1698                              ((not (string-match "^[^0-9]+" firstref)) "starts with a digit")
1699                              ((not (string-match "^[^0-9]+[0-9]+" firstref)) "does not contain a number")
1700                              ((not (string-match "^[^0-9]+[0-9]+[^0-9]*$" firstref)) "contains more than one sequence of digits")
1701
1702                              )))
1703                (if desc
1704                    (progn
1705                      (read-from-minibuffer (format "Your input '%s' does not meet the requirements because it %s.\nPlease hit RET and try again: " firstref desc))
1706                      t)
1707                  nil))))
1708
1709     (with-current-buffer buffer
1710       (goto-char (point-max))
1711       (insert (format "* %s %s\n" firstref title))
1712       (if temporary
1713           (insert "
1714   Below you find your temporary index table, which WILL NOT LAST LONGER
1715   THAN YOUR CURRENT EMACS SESSION; please use it only for evaluation.
1716 ")
1717         (insert "
1718   Below you find your initial index table, which will grow over time.
1719 "))
1720       (insert "  You may start using it by adding some lines. Just
1721   move to another heading within org, invoke `org-index' and
1722   choose the command 'add'.  After adding a few nodes, try the
1723   command 'occur' to search among them.
1724
1725   To gain further insight you may invoke the subcommand 'help', or
1726   (same content) read the help of `org-index'.
1727
1728   Within the index table below, the sequence of columns does not
1729   matter. You may reorder them in any way you like.  You may also
1730   add your own columns, which should start with a dot
1731   (e.g. '.my-column').
1732
1733   Invoke `org-customize' to tweak the behaviour of org-index
1734   (see the group org-index).
1735
1736   This node needs not be a top level node; its name is completely
1737   at your choice; it is found through its ID only.
1738 ")
1739       (unless temporary
1740         (insert "
1741   Remark: These lines of explanation can be removed at any time.
1742 "))
1743
1744       (setq id (org-id-get-create))
1745       (insert (format "
1746
1747   | ref | category | keywords | tags | count | level | last-accessed | created | id  | yank |
1748   |     |          |          |      |       |       |               |         | <4> | <4>  |
1749   |-----+----------+----------+------+-------+-------+---------------+---------+-----+------|
1750   | %s  |          | %s       |      |       |       |               | %s      | %s  |      |
1751
1752 "
1753                       firstref
1754                       title
1755                       (with-temp-buffer (org-insert-time-stamp nil nil t))
1756                       id))
1757
1758       ;; make sure, that node can be found
1759       (org-id-add-location id (buffer-file-name))
1760       (setq buffer-save-without-query t)
1761       (basic-save-buffer)
1762
1763       (while (not (org-at-table-p)) (forward-line -1))
1764       (unless buffer-read-only (org-table-align))
1765       (while (not (org-at-heading-p)) (forward-line -1))
1766
1767       ;; read back some info about new index
1768       (let ((org-index-id id))
1769         (org-index--verify-id))
1770
1771       ;; remember at least for this session
1772       (setq org-index-id id)
1773
1774       ;; present results to user
1775       (if temporary
1776           (progn
1777             ;; Present existing and temporary index together
1778             (when compare
1779               (pop-to-buffer-same-window org-index--buffer)
1780               (goto-char org-index--point)
1781               (org-index--unfold-buffer)
1782               (delete-other-windows)
1783               (select-window (split-window-vertically)))
1784             ;; show new index
1785             (pop-to-buffer-same-window buffer)
1786             (org-id-goto id)
1787             (org-index--unfold-buffer)
1788             (if compare
1789                 (progn
1790                   (message "Please compare your existing index (upper window) and a temporary new one (lower window) to fix your index")
1791                   (throw 'new-index nil))
1792               (message "This is your new temporary index, use command add to populate, occur to search.")))
1793         (progn
1794           ;; Only show the new index
1795           (pop-to-buffer-same-window buffer)
1796           (delete-other-windows)
1797           (org-id-goto id)
1798           (org-index--unfold-buffer)
1799           (if (y-or-n-p "This is your new index table.  It is already set for this Emacs session, so you may try it out.  Do you want to save its id to make it available for future Emacs sessions too ? ")
1800               (progn
1801                 (customize-save-variable 'org-index-id id)
1802                 (message "Saved org-index-id '%s' to %s." id (or custom-file
1803                                                                 user-init-file))
1804                 (throw 'new-index nil))
1805             (let (sq)
1806               (setq sq (format "(setq org-index-id \"%s\")" id))
1807               (kill-new sq)
1808               (message "Did not make the id of this new index permanent; you may want to put\n\n   %s\n\ninto your own initialization; it is copied already, just yank it." sq)
1809               (throw 'new-index nil))))))))
1810
1811
1812 (defun org-index--unfold-buffer ()
1813   "Helper function to unfold buffer."
1814   (org-show-context)
1815   (org-show-subtree)
1816   (recenter 1)
1817   (save-excursion
1818     (org-back-to-heading)
1819     (forward-line) ;; on property drawer
1820     (org-cycle)))
1821
1822
1823 (defun org-index--update-line (&optional ref-or-id-or-pos)
1824   "Update columns count and last-accessed in line REF-OR-ID-OR-POS."
1825
1826   (let (initial)
1827
1828     (with-current-buffer org-index--buffer
1829       (unless buffer-read-only
1830
1831         ;; search reference or id, if given (or assume, that we are already positioned right)
1832         (when ref-or-id-or-pos
1833           (setq initial (point))
1834           (goto-char org-index--below-hline)
1835           (while (and (org-at-table-p)
1836                       (not (if (integerp ref-or-id-or-pos)
1837                                (and (>= ref-or-id-or-pos (line-beginning-position))
1838                                     (< ref-or-id-or-pos (line-end-position)))
1839                              (or (string= ref-or-id-or-pos (org-index--get-or-set-field 'ref))
1840                                  (string= ref-or-id-or-pos (org-index--get-or-set-field 'id))))))
1841             (forward-line)))
1842
1843         (if (not (org-at-table-p))
1844             (error "Did not find reference or id '%s'" ref-or-id-or-pos)
1845           (org-index--update-current-line))
1846
1847         (if initial (goto-char initial))))))
1848
1849
1850 (defun org-index--update-current-line ()
1851   "Update current lines columns count and last-accessed."
1852   (let (newcount (count-field (org-index--get-or-set-field 'count)))
1853
1854     ;; update count field only if number or empty
1855     (when (or (not count-field)
1856               (string-match "^[0-9]+$" count-field))
1857       (setq newcount (+ 1 (string-to-number (or count-field "0"))))
1858       (org-index--get-or-set-field 'count
1859                             (number-to-string newcount)))
1860
1861     ;; update timestamp
1862     (org-table-goto-column (org-index--column-num 'last-accessed))
1863     (org-table-blank-field)
1864     (org-insert-time-stamp nil t t)
1865
1866     ;; move line according to new content
1867     (org-index--promote-current-line)
1868     (org-index--align-and-fontify-current-line)))
1869
1870
1871 (defun org-index--align-and-fontify-current-line (&optional num)
1872   "Make current line (or NUM lines) blend well among others."
1873   (let (lines)
1874     ;; get current content
1875     (unless num (setq num 1))
1876     (setq lines (delete-and-extract-region (line-beginning-position) (line-end-position num)))
1877     ;; create minimum table with fixed-width columns to align and fontify new line
1878     (insert (with-temp-buffer
1879               (org-set-font-lock-defaults)
1880               (insert org-index--headings-visible)
1881               ;; fill columns, so that aligning cannot shrink them
1882               (goto-char (point-min))
1883               (search-forward "|")
1884               (while (search-forward " " (line-end-position) t)
1885                 (replace-match "." nil t))
1886               (goto-char (point-min))
1887               (while (search-forward ".|." (line-end-position) t)
1888                 (replace-match " | " nil t))
1889               (goto-char (point-min))
1890               (while (search-forward "|." (line-end-position) t)
1891                 (replace-match "| " nil t))
1892               (goto-char (point-max))
1893               (insert lines)
1894               (forward-line 0)
1895               (let ((start (point)))
1896                 (while (re-search-forward "^\s +|-" nil t)
1897                   (replace-match "| -"))
1898                 (goto-char start))
1899               (org-mode)
1900               (org-table-align)
1901               (font-lock-fontify-region (point-min) (point-max))
1902               (goto-char (point-max))
1903               (if (eq -1 (skip-chars-backward "\n"))
1904                   (delete-char 1))
1905               (forward-line (- 1 num))
1906               (buffer-substring (line-beginning-position) (line-end-position num))))
1907     lines))
1908
1909
1910 (defun org-index--promote-current-line ()
1911   "Move current line up in table according to changed sort fields."
1912   (let (begin end key
1913         (to-skip 0))
1914
1915     (forward-line 0) ; stay at beginning of line
1916
1917     (setq key (org-index--get-sort-key))
1918     (setq begin (point))
1919     (setq end (line-beginning-position 2))
1920
1921     (forward-line -1)
1922     (while (and (org-at-table-p)
1923                 (not (org-at-table-hline-p))
1924                 (string< (org-index--get-sort-key) key))
1925
1926       (cl-incf to-skip)
1927       (forward-line -1))
1928     (forward-line 1)
1929
1930     ;; insert line at new position
1931     (when (> to-skip 0)
1932       (insert (delete-and-extract-region begin end))
1933       (forward-line -1))))
1934
1935
1936 (defun org-index--get-sort-key (&optional sort with-ref mixed-time)
1937   "Get value for sorting from column SORT, optional WITH-REF; if mixes use MIXED-TIME."
1938   (let (ref
1939         ref-field
1940         key)
1941
1942     (unless sort (setq sort org-index--last-sort)) ; use default value
1943
1944     (when (or with-ref
1945               (eq sort 'ref))
1946       ;; get reference with leading zeroes, so it can be
1947       ;; sorted as text
1948       (setq ref-field (org-index--get-or-set-field 'ref))
1949       (if ref-field
1950           (progn
1951             (string-match org-index--ref-regex ref-field)
1952             (setq ref (format
1953                        "%06d"
1954                        (string-to-number
1955                         (match-string 1 ref-field)))))
1956         (setq ref "000000")))
1957
1958     (setq key
1959           (cond
1960            ((eq sort 'count)
1961             (format "%08d" (string-to-number (or (org-index--get-or-set-field 'count) ""))))
1962            ((eq sort 'mixed)
1963             (let ((last-accessed (org-index--get-or-set-field 'last-accessed)))
1964               (unless mixed-time (setq mixed-time (org-index--get-mixed-time)))
1965               (concat
1966                (if (string< mixed-time last-accessed) last-accessed mixed-time)
1967                (format "%08d" (string-to-number (or (org-index--get-or-set-field 'count) ""))))))
1968            ((eq sort 'ref)
1969             ref)
1970            ((memq sort '(id last-accessed created))
1971             (org-index--get-or-set-field sort))
1972            (t (error "This is a bug: unmatched case '%s'" sort))))
1973
1974     (if with-ref (setq key (concat key ref)))
1975
1976     key))
1977
1978
1979 (defun org-index--get-or-set-field (key &optional value)
1980   "Retrieve field KEY from index table or set it to VALUE."
1981   (let (field)
1982     (save-excursion
1983       (if (eq key 'fingerprint)
1984           (progn
1985             (if value (error "Internal error, pseudo-column fingerprint cannot be set"))
1986             (setq field (org-index--get-fingerprint)))
1987         (setq field (org-trim (org-table-get-field (cdr (assoc key org-index--columns)) value))))
1988       (if (string= field "") (setq field nil))
1989
1990       (org-no-properties field))))
1991
1992
1993 (defun org-index--column-num (key)
1994   "Return number of column KEY."
1995   (if (numberp key)
1996       key
1997     (cdr (assoc key org-index--columns))))
1998
1999
2000 (defun org-index--make-guarded-search (ref &optional dont-quote)
2001   "Make robust search string from REF; DONT-QUOTE it, if requested."
2002   (concat "\\_<" (if dont-quote ref (regexp-quote ref)) "\\_>"))
2003
2004
2005 (defun org-index--find-duplicates ()
2006   "Find duplicate references or ids in index table."
2007   (let (ref-duplicates id-duplicates)
2008
2009     (setq ref-duplicates (org-index--find-duplicates-helper 'ref))
2010     (setq id-duplicates (org-index--find-duplicates-helper 'id))
2011     (goto-char org-index--below-hline)
2012     (if (or ref-duplicates id-duplicates)
2013         (progn
2014           ;; show results
2015           (pop-to-buffer-same-window
2016            (get-buffer-create "*org-index-duplicates*"))
2017           (when ref-duplicates
2018             (insert "These references appear more than once:\n")
2019             (mapc (lambda (x) (insert "  " x "\n")) ref-duplicates)
2020             (insert "\n\n"))
2021           (when id-duplicates
2022             (insert "These ids appear more than once:\n")
2023             (mapc (lambda (x) (insert "  " x "\n")) id-duplicates))
2024
2025           "Some references or ids are duplicates")
2026       "No duplicate references or ids found")))
2027
2028
2029 (defun org-index--find-duplicates-helper (column)
2030   "Helper for `org-index--find-duplicates': Go through table and count given COLUMN."
2031   (let (counts duplicates field found)
2032
2033     ;; go through table
2034     (goto-char org-index--below-hline)
2035     (while (org-at-table-p)
2036
2037       ;; get column
2038       (setq field (org-index--get-or-set-field column))
2039
2040       ;; and increment
2041       (setq found (assoc field counts))
2042       (if found
2043           (cl-incf (cdr found))
2044         (setq counts (cons (cons field 1) counts)))
2045
2046       (forward-line))
2047
2048     (mapc (lambda (x) (if (and (> (cdr x) 1)
2049                           (car x))
2050                      (setq duplicates (cons (car x) duplicates)))) counts)
2051
2052     duplicates))
2053
2054
2055 (defun org-index--do-statistics ()
2056   "Compute statistics about index table."
2057   (let ((total-lines 0) (total-refs 0)
2058         ref ref-field min max message)
2059
2060     ;; go through table
2061     (goto-char org-index--below-hline)
2062     (while (org-at-table-p)
2063
2064       ;; get ref
2065       (setq ref-field (org-index--get-or-set-field 'ref))
2066
2067       (when ref-field
2068         (string-match org-index--ref-regex ref-field)
2069         (setq ref (string-to-number (match-string 1 ref-field)))
2070
2071         ;; record min and max
2072         (if (or (not min) (< ref min)) (setq min ref))
2073         (if (or (not max) (> ref max)) (setq max ref))
2074
2075         (setq total-refs (1+ total-refs)))
2076
2077       ;; count
2078       (setq total-lines (1+ total-lines))
2079
2080       (forward-line))
2081
2082     (setq message (format "%d Lines in index table. First reference is %s, last %s; %d of them are used (%d percent)"
2083                           total-lines
2084                           (format org-index--ref-format min)
2085                           (format org-index--ref-format max)
2086                           total-refs
2087                           (truncate (* 100 (/ (float total-refs) (1+ (- max min)))))))
2088
2089     (goto-char org-index--below-hline)
2090     message))
2091
2092
2093 (defun org-index--do-add-or-update (&optional create-ref tag-with-ref)
2094   "For current node or current line in index, add or update in index table.
2095 CREATE-REF and TAG-WITH-REF if given."
2096
2097   (let* (id id-from-index ref args yank ret)
2098
2099     (org-index--save-positions)
2100     (unless (or org-index--within-index-node
2101                 org-index--within-occur)
2102       (org-back-to-heading))
2103
2104     ;; try to do the same things from within index and from outside
2105     (if org-index--within-index-node
2106
2107         (progn
2108           (unless (org-at-table-p)
2109             (error "Within index node but not on table"))
2110
2111           (setq id (org-index--get-or-set-field 'id))
2112           (setq ref (org-index--get-or-set-field 'ref))
2113           (setq args (org-index--collect-values-for-add-update-remote id))
2114           (org-index--write-fields args)
2115           (setq yank (org-index--get-or-set-field org-index-yank-after-add))
2116
2117           (setq ret
2118                 (if ref
2119                     (cons (format "Updated index line %s" ref) yank)
2120                   (cons "Updated index line" nil))))
2121
2122       (setq id (org-id-get-create))
2123       (org-index--refresh-parse-table)
2124       (setq id-from-index (org-index--on 'id id id))
2125       (setq ref (org-index--on 'id id (org-index--get-or-set-field 'ref)))
2126
2127       (if tag-with-ref
2128           (org-toggle-tag (format "%s%d%s" org-index--head tag-with-ref org-index--tail) 'on))
2129       (setq args (org-index--collect-values-for-add-update id))
2130
2131       (when (and create-ref
2132                  (not ref))
2133         (setq ref org-index--nextref)
2134         (setq args (plist-put args 'ref ref)))
2135
2136
2137       (if id-from-index
2138           ;; already have an id in index, find it and update fields
2139           (progn
2140
2141             (org-index--on
2142                 'id id
2143                 (org-index--write-fields args)
2144                 (setq yank (org-index--get-or-set-field org-index-yank-after-add)))
2145
2146             (setq ret
2147                   (if ref
2148                       (cons (format "Updated index line %s" ref) yank)
2149                     (cons "Updated index line" nil))))
2150
2151         ;; no id here, create new line in index
2152         (if ref (setq ref (plist-put args 'ref org-index--nextref)))
2153         (setq yank (apply 'org-index--do-new-line args))
2154
2155         (setq ret
2156               (if ref
2157                   (cons
2158                    (format "Added new index line %s" ref)
2159                    (concat yank " "))
2160                 (cons
2161                  "Added new index line"
2162                  nil)))))
2163
2164     (org-index--restore-positions)
2165
2166     ret))
2167
2168
2169 (defun org-index--check-ids ()
2170   "Check, that ids really point to a node."
2171
2172   (let ((lines 0)
2173         id ids marker)
2174
2175     (goto-char org-index--below-hline)
2176
2177     (catch 'problem
2178       (while (org-at-table-p)
2179
2180         (when (setq id (org-index--get-or-set-field 'id))
2181
2182           ;; check for double ids
2183           (when (member id ids)
2184             (org-table-goto-column (org-index--column-num 'id))
2185             (throw 'problem "This id appears twice in index; please use command 'maintain' to check for duplicate ids"))
2186           (cl-incf lines)
2187           (setq ids (cons id ids))
2188
2189           ;; check, if id is valid
2190           (setq marker (org-id-find id t))
2191           (unless marker
2192             (org-table-goto-column (org-index--column-num 'id))
2193             (throw 'problem "This id cannot be found")))
2194
2195         (forward-line))
2196
2197       (goto-char org-index--below-hline)
2198       nil)))
2199
2200
2201 (defun org-index--update-all-lines ()
2202   "Update all lines of index at once."
2203
2204   (let ((lines 0)
2205         id ref kvs)
2206
2207     ;; check for double ids
2208     (or
2209      (org-index--check-ids)
2210
2211      (progn
2212        (goto-char org-index--below-hline)
2213        (while (org-at-table-p)
2214
2215          ;; update single line
2216          (when (setq id (org-index--get-or-set-field 'id))
2217            (setq ref (org-index--get-or-set-field 'ref))
2218            (setq kvs (org-index--collect-values-for-add-update-remote id))
2219            (org-index--write-fields kvs)
2220            (cl-incf lines))
2221          (forward-line))
2222
2223        (goto-char org-index--below-hline)
2224        (org-table-align)
2225        (format "Updated %d lines" lines)))))
2226
2227
2228 (defun org-index--collect-values-for-add-update (id &optional silent category)
2229   "Collect values for adding or updating line specified by ID, do not ask if SILENT, use CATEGORY, if given."
2230
2231   (let ((args (list 'id id))
2232         content)
2233
2234     (dolist (col (mapcar 'car org-index--columns))
2235
2236       (setq content "")
2237
2238       (cond
2239        ((eq col 'keywords)
2240         (if org-index-copy-heading-to-keywords
2241             (setq content (nth 4 (org-heading-components))))
2242
2243         ;; Shift ref and timestamp ?
2244         (if org-index-strip-ref-and-date-from-heading
2245             (dotimes (i 2)
2246               (if (or (string-match (concat "^\\s-*" org-index--ref-regex) content)
2247                       (string-match (concat "^\\s-*" org-ts-regexp-both) content))
2248                   (setq content (substring content (match-end 0)))))))
2249
2250        ((eq col 'category)
2251         (setq content (or category org-index--category-before)))
2252
2253        ((eq col 'level)
2254         (setq content (number-to-string (org-outline-level))))
2255
2256        ((eq col 'tags)
2257         (setq content (org-get-tags-string))))
2258
2259       (unless (string= content "")
2260         (setq args (plist-put args col content))))
2261
2262     (if (not silent)
2263         (let ((args-edited (org-index--collect-values-from-user org-index-edit-on-add args)))
2264           (setq args (append args-edited args))))
2265
2266     args))
2267
2268
2269 (defun org-index--collect-values-for-add-update-remote (id)
2270   "Wrap `org-index--collect-values-for-add-update' by prior moving to remote node identified by ID."
2271
2272   (let (marker point args)
2273
2274     (setq marker (org-id-find id t))
2275     ;; enter buffer and collect information
2276     (with-current-buffer (marker-buffer marker)
2277       (setq point (point))
2278       (goto-char marker)
2279       (setq args (org-index--collect-values-for-add-update id t (org-get-category (point) t)))
2280       (goto-char point))
2281
2282     args))
2283
2284
2285 (defun org-index--collect-values-from-user (cols &optional defaults)
2286   "Collect values for adding a new yank-line.
2287 Argument COLS gives list of columns to edit.
2288 Optional argument DEFAULTS gives default values."
2289
2290   (let (content args)
2291
2292     (dolist (col cols)
2293
2294       (setq content "")
2295
2296       (setq content (read-from-minibuffer
2297                      (format "Enter text for column '%s': " (symbol-name col))
2298                      (plist-get col defaults)))
2299
2300       (unless (string= content "")
2301         (setq args (plist-put args col content))))
2302     args))
2303
2304
2305 (defun org-index--write-fields (kvs)
2306   "Update current line with values from KVS (keys-values)."
2307   (while kvs
2308     (org-index--get-or-set-field (car kvs) (org-trim (cadr kvs)))
2309     (setq kvs (cddr kvs))))
2310
2311
2312 (defun org-index--do-kill ()
2313   "Perform command kill from within occur, index or node."
2314
2315   (let (id ref chars-deleted-index text-deleted-from pos-in-index)
2316
2317     (org-index--save-positions)
2318     (unless (or org-index--within-index-node
2319                 org-index--within-occur)
2320       (org-back-to-heading))
2321
2322     ;; Collect information: What should be deleted ?
2323     (if (or org-index--within-occur
2324             org-index--within-index-node)
2325
2326         (progn
2327           (if org-index--within-index-node
2328               ;; In index
2329               (setq pos-in-index (point))
2330             ;; In occur
2331             (setq pos-in-index (get-text-property (point) 'org-index-lbp))
2332             (org-index--occur-test-stale pos-in-index)
2333             (set-buffer org-index--buffer)
2334             (goto-char pos-in-index))
2335           ;; In Index (maybe moved there)
2336           (setq id (org-index--get-or-set-field 'id))
2337           (setq ref (org-index--get-or-set-field 'ref)))
2338
2339       ;; At a headline
2340       (setq id (org-entry-get (point) "ID"))
2341       (setq ref (org-index--ref-from-id id))
2342       (setq pos-in-index (org-index--on 'id id (point)))
2343       (unless pos-in-index (error "This node is not in index")))
2344
2345     ;; Remark: Current buffer is not certain here, but we have all the information to delete
2346
2347     ;; Delete from node
2348     (when id
2349       (let ((m (org-id-find id 'marker)))
2350         (set-buffer (marker-buffer m))
2351         (goto-char m)
2352         (move-marker m nil)
2353         (unless (string= (org-id-get) id)
2354           (error "Could not find node with id %s" id)))
2355
2356       (org-index--delete-any-ref-from-tags)
2357       (if ref (org-index--delete-ref-from-heading ref))
2358       (setq text-deleted-from (cons "node" text-deleted-from)))
2359
2360     ;; Delete from index
2361     (set-buffer org-index--buffer)
2362     (unless pos-in-index "Internal error, pos-in-index should be defined here")
2363     (goto-char pos-in-index)
2364     (setq chars-deleted-index (length (delete-and-extract-region (line-beginning-position) (line-beginning-position 2))))
2365     (setq text-deleted-from (cons "index" text-deleted-from))
2366
2367     ;; Delete from occur only if we started there, accept that it will be stale otherwise
2368     (if org-index--within-occur
2369         (let ((inhibit-read-only t))
2370           (set-buffer org-index--occur-buffer-name)
2371           (delete-region (line-beginning-position) (line-beginning-position 2))
2372           ;; correct positions
2373           (while (org-at-table-p)
2374             (put-text-property (line-beginning-position) (line-end-position) 'org-index-lbp
2375                                (- (get-text-property (point) 'org-index-lbp) chars-deleted-index))
2376             (forward-line))
2377           (setq text-deleted-from (cons "occur" text-deleted-from))))
2378
2379     (org-index--restore-positions)
2380     (concat "Deleted from: " (mapconcat 'identity (sort text-deleted-from 'string<) ","))))
2381
2382
2383 (defun org-index--save-positions ()
2384   "Save current buffer and positions in index- and current buffer; not in occur-buffer."
2385
2386   (let (cur-buf cur-mrk idx-pnt idx-mrk)
2387     (setq cur-buf (current-buffer))
2388     (setq cur-mrk (point-marker))
2389     (set-buffer org-index--buffer)
2390     (if (string= (org-id-get) org-index-id)
2391         (setq idx-pnt (point))
2392       (setq idx-mrk (point-marker)))
2393     (set-buffer cur-buf)
2394     (setq org-index--saved-positions (list cur-buf cur-mrk idx-pnt idx-mrk))))
2395
2396
2397 (defun org-index--restore-positions ()
2398   "Restore positions as saved by `org-index--save-positions'."
2399
2400   (cl-multiple-value-bind
2401       (cur-buf cur-mrk idx-pnt idx-mrk buf)
2402       org-index--saved-positions
2403     (setq buf (current-buffer))
2404     (set-buffer cur-buf)
2405     (goto-char cur-mrk)
2406     (set-buffer org-index--buffer)
2407     (goto-char (or idx-pnt idx-mrk))
2408     (set-buffer buf))
2409   (setq org-index--saved-positions nil))
2410
2411
2412 (defun org-index--delete-ref-from-heading (ref)
2413   "Delete given REF from current heading."
2414   (save-excursion
2415     (end-of-line)
2416     (let ((end (point)))
2417       (beginning-of-line)
2418       (when (search-forward ref end t)
2419         (delete-char (- (length ref)))
2420         (just-one-space)))))
2421
2422
2423 (defun org-index--delete-any-ref-from-tags ()
2424   "Delete any reference from list of tags."
2425   (let (new-tags)
2426     (mapc (lambda (tag)
2427             (unless (string-match org-index--ref-regex tag)
2428               (setq new-tags (cons tag new-tags) )))
2429           (org-get-tags))
2430     (org-set-tags-to new-tags)))
2431
2432
2433 (defun org-index--go (&optional column value)
2434   "Position cursor on index line where COLUMN equals VALUE.
2435 Return t or nil, leave point on line or at top of table, needs to be in buffer initially."
2436   (let (found)
2437
2438     (unless (eq (current-buffer) org-index--buffer)
2439       (error "This is a bug: Not in index buffer"))
2440
2441     ;; loop over lines
2442     (goto-char org-index--below-hline)
2443     (if column
2444         (progn
2445           (forward-line -1)
2446           (while (and (not found)
2447                       (forward-line)
2448                       (org-at-table-p))
2449             (setq found (string= value (org-index--get-or-set-field column)))))
2450       (setq found t))
2451
2452     ;; return value
2453     (if found
2454         t
2455       (goto-char org-index--below-hline)
2456       nil)))
2457
2458
2459 (defun org-index--find-id (id &optional other)
2460   "Perform command head: Find node with REF or ID and present it.
2461 If OTHER in separate window."
2462
2463   (let (message marker)
2464
2465     (setq marker (org-id-find id t))
2466
2467     (if marker
2468         (progn
2469           (org-index--update-line id)
2470           (if other
2471               (progn
2472                 (pop-to-buffer (marker-buffer marker)))
2473             (pop-to-buffer-same-window (marker-buffer marker)))
2474
2475           (goto-char marker)
2476           (org-reveal t)
2477           (org-show-entry)
2478           (recenter)
2479           (unless (string= (org-id-get) id)
2480             (setq message (format "Could not go to node with id %s (narrowed ?)" id)))
2481           (setq message "Found headline"))
2482       (setq message (format "Did not find node with %s" id)))
2483     message))
2484
2485
2486 (defun org-index--do-occur ()
2487   "Perform command occur."
2488   (let ((word "") ; last word to search for growing and shrinking on keystrokes
2489         (prompt "Search for: ")
2490         (these-commands " NOTE: If you invoke the org-index subcommands edit or kill from within the occur buffer, the index is updated accordingly.")
2491         (lines-wanted (window-body-height))
2492         (lines-found 0)                      ; number of lines found
2493         words                                ; list words that should match
2494         occur-buffer
2495         begin ; position of first line
2496         narrow                         ; start of narrowed buffer
2497         help-text                      ; cons with help text short and long
2498         search-text                    ; description of text to search for
2499         done                           ; true, if loop is done
2500         in-c-backspace                 ; true, while processing C-backspace
2501         help-overlay                   ; Overlay with help text
2502         last-point                     ; Last position before end of search
2503         initial-frame                  ; Frame when starting occur
2504         key                            ; input from user in various forms
2505         key-sequence
2506         key-sequence-raw)
2507
2508
2509     ;; make and show buffer
2510     (if (get-buffer org-index--occur-buffer-name)
2511         (kill-buffer org-index--occur-buffer-name))
2512     (setq occur-buffer (make-indirect-buffer org-index--buffer org-index--occur-buffer-name))
2513     (pop-to-buffer-same-window occur-buffer)
2514     (setq initial-frame (selected-frame))
2515
2516     ;; avoid modifying direct buffer
2517     (setq buffer-read-only t)
2518     (toggle-truncate-lines 1)
2519     (setq font-lock-keywords-case-fold-search t)
2520     (setq case-fold-search t)
2521
2522     ;; reset stack and overlays
2523     (setq org-index--occur-stack nil)
2524     (setq org-index--occur-tail-overlay nil)
2525
2526     ;; narrow to table rows and one line before
2527     (goto-char org-index--below-hline)
2528     (forward-line 0)
2529     (setq begin (point))
2530     (forward-line -1)
2531     (setq narrow (point))
2532     (while (org-at-table-p)
2533       (forward-line))
2534     (narrow-to-region narrow (point))
2535     (goto-char (point-min))
2536     (forward-line)
2537
2538     ;; initialize help text
2539     (setq help-text (cons
2540                      (concat
2541                       (propertize "Incremental occur" 'face 'org-todo)
2542                       (propertize  "; ? toggles help and headlines.\n" 'face 'org-agenda-dimmed-todo-face))
2543                      (concat
2544                       (propertize
2545                        (org-index--wrap
2546                         (concat
2547                          "Normal keys add to search word; <space> or <comma> start additional word; <backspace> erases last char, <C-backspace> last word; <return> jumps to heading, <tab> jumps to heading in other window, <S-return> jumps to matching line in index; all other keys end search." these-commands "\n"))
2548                        'face 'org-agenda-dimmed-todo-face)
2549                       org-index--headings)))
2550
2551     ;; insert overlays for help text and to cover unsearched lines
2552     (setq help-overlay (make-overlay (point-min) begin))
2553     (overlay-put help-overlay 'display (car help-text))
2554     (setq org-index--occur-tail-overlay (make-overlay (point-max) (point-max)))
2555     (overlay-put org-index--occur-tail-overlay 'invisible t)
2556
2557     (while (not done)
2558
2559       (if in-c-backspace
2560           (setq key "<backspace>")
2561         (setq search-text (mapconcat 'identity (reverse (cons word words)) ","))
2562                         (message "foo")
2563
2564         ;; read key, if selected frame has not changed
2565         (if (eq initial-frame (selected-frame))
2566             (progn
2567               (setq key-sequence
2568                     (let ((echo-keystrokes 0)
2569                           (full-prompt (format "%s%s%s"
2570                                                prompt
2571                                                search-text
2572                                                (if (string= search-text "") "" " "))))
2573                       (read-key-sequence full-prompt nil nil t t)))
2574               (setq key (key-description key-sequence))
2575               (setq key-sequence-raw (this-single-command-raw-keys)))
2576           (setq done t)
2577           (setq key-sequence nil)
2578           (setq key nil)
2579           (setq key-sequence-raw nil)))
2580
2581
2582       (cond
2583
2584
2585        ((string= key "<C-backspace>")
2586         (setq in-c-backspace t))
2587
2588
2589        ((member key (list "<backspace>" "DEL"))   ; erase last char
2590
2591         (if (= (length word) 0)
2592
2593             ;; nothing more to delete from current word; try next
2594             (progn
2595               (setq word (car words))
2596               (setq words (cdr words))
2597               (setq in-c-backspace nil))
2598
2599           ;; unhighlight longer match
2600           (unhighlight-regexp (regexp-quote word))
2601
2602           ;; some chars are left; shorten word
2603           (setq word (substring word 0 -1))
2604           (when (= (length word) 0) ; when nothing left, use next word from list
2605             (setq word (car words))
2606             (setq words (cdr words))
2607             (setq in-c-backspace nil))
2608
2609           ;; free top list of overlays and remove list
2610           (setq lines-found (or (org-index--unhide) lines-wanted))
2611           (move-overlay org-index--occur-tail-overlay
2612                         (if org-index--occur-stack (cdr (assoc :end-of-visible (car org-index--occur-stack)))
2613                           (point-max))
2614                         (point-max))
2615
2616
2617           ;; highlight shorter word
2618           (unless (= (length word) 0)
2619             (highlight-regexp (regexp-quote word) 'isearch))
2620
2621           ;; make sure, point is still visible
2622           (goto-char begin)))
2623
2624
2625        ((member key (list "SPC" ",")) ; space or comma: enter an additional search word
2626
2627         ;; push current word and clear, no need to change display
2628         (unless (string= word "")
2629           (setq words (cons word words))
2630           (setq word "")))
2631
2632
2633        ((string= key "?") ; question mark: toggle display of headlines and help
2634         (setq help-text (cons (cdr help-text) (car help-text)))
2635         (overlay-put help-overlay 'display (car help-text)))
2636
2637        ((and (= (length key) 1)
2638              (aref printable-chars (elt key 0))) ; any printable char: add to current search word
2639
2640         ;; unhighlight short word
2641         (unless (= (length word) 0)
2642           (unhighlight-regexp (regexp-quote word)))
2643
2644         ;; add to word
2645         (setq word (concat word key))
2646
2647         ;; make overlays to hide lines, that do not match longer word any more
2648         (goto-char begin)
2649         (setq lines-found (org-index--hide-with-overlays (cons word words) lines-wanted))
2650         (move-overlay org-index--occur-tail-overlay
2651                       (if org-index--occur-stack (cdr (assoc :end-of-visible (car org-index--occur-stack)))
2652                         (point-max))
2653                       (point-max))
2654
2655         (goto-char begin)
2656
2657         ;; highlight longer word
2658         (highlight-regexp (regexp-quote word) 'isearch)
2659
2660         ;; make sure, point is on a visible line
2661         (line-move -1 t)
2662         (line-move 1 t))
2663
2664        ;; anything else terminates loop
2665        (t (setq done t))))
2666
2667     ;; put back input event, that caused the loop to end
2668     (unless (string= key "C-g")
2669       (setq unread-command-events (listify-key-sequence key-sequence-raw))
2670       (message key))
2671
2672     ;; postprocessing
2673     (setq last-point (point))
2674
2675     ;; For performance reasons do not show matching lines for rest of table. So no code here.
2676
2677     ;; make permanent copy
2678     ;; copy visible lines
2679     (let ((lines-collected 0)
2680           keymap line all-lines all-lines-lbp header-lines lbp)
2681
2682       (setq cursor-type t)
2683       (goto-char begin)
2684
2685       ;; collect all visible lines
2686       (while (and (not (eobp))
2687                   (< lines-collected lines-wanted))
2688         ;; skip over invisible lines
2689         (while (and (invisible-p (point))
2690                     (not (eobp)))
2691           (goto-char (1+ (overlay-end (car (overlays-at (point)))))))
2692         (setq lbp (line-beginning-position))
2693         (setq line (buffer-substring-no-properties lbp (line-end-position)))
2694         (unless (string= line "")
2695           (cl-incf lines-collected)
2696           (setq all-lines (cons (concat line
2697                                         "\n")
2698                                 all-lines))
2699           (setq all-lines-lbp (cons lbp all-lines-lbp)))
2700         (forward-line 1))
2701
2702       (kill-buffer org-index--occur-buffer-name) ; cannot keep this buffer; might become stale soon
2703
2704       ;; create new buffer
2705       (setq occur-buffer (get-buffer-create org-index--occur-buffer-name))
2706       (pop-to-buffer-same-window occur-buffer)
2707       (insert org-index--headings)
2708       (setq header-lines (line-number-at-pos))
2709
2710       ;; insert into new buffer
2711       (save-excursion
2712         (apply 'insert (reverse all-lines))
2713         (if (= lines-collected lines-wanted)
2714             (insert "\n(more lines omitted)\n")))
2715       (setq org-index--occur-lines-collected lines-collected)
2716
2717       (org-mode)
2718       (setq truncate-lines t)
2719       (if all-lines (org-index--align-and-fontify-current-line (length all-lines)))
2720       (font-lock-ensure)
2721       (font-lock-flush)
2722       (when all-lines-lbp
2723           (while (not (org-at-table-p))
2724             (forward-line -1))
2725           (while all-lines-lbp
2726             (put-text-property (line-beginning-position) (line-end-position) 'org-index-lbp (car all-lines-lbp))
2727             (setq all-lines-lbp (cdr all-lines-lbp))
2728             (forward-line -1)))
2729
2730       ;; prepare help text
2731       (goto-char (point-min))
2732       (forward-line (1- header-lines))
2733       (setq org-index--occur-help-overlay (make-overlay (point-min) (point)))
2734       (setq org-index--occur-help-text
2735             (cons
2736              (org-index--wrap
2737               (propertize "Search is done;    ? toggles help and headlines.\n" 'face 'org-agenda-dimmed-todo-face))
2738              (concat
2739               (org-index--wrap
2740                (propertize
2741                 (format
2742                  (concat "Search is done."
2743                          (if (< lines-collected lines-wanted)
2744                              " Showing all %d matches for "
2745                            " Showing one window of matches for ")
2746                          "\"" search-text
2747                          "\". <return> jumps to heading, <tab> jumps to heading in other window, <S-return> jumps to matching line in index, <space> increments count.\n" these-commands "\n")
2748                  (length all-lines))
2749                 'face 'org-agenda-dimmed-todo-face))
2750               org-index--headings)))
2751
2752       (overlay-put org-index--occur-help-overlay 'display (car org-index--occur-help-text))
2753
2754       ;; highlight words
2755       (setq case-fold-search t)
2756       (setq font-lock-keywords-case-fold-search t)
2757       (mapc (lambda (w) (unless (or (not w) (string= w "")) (highlight-regexp (regexp-quote w) 'isearch)))
2758             (cons word words))
2759
2760       (setq buffer-read-only t)
2761
2762       ;; install keyboard-shortcuts
2763       (setq keymap (make-sparse-keymap))
2764       (set-keymap-parent keymap org-mode-map)
2765
2766       (mapc (lambda (x) (define-key keymap (kbd x)
2767                      (lambda () (interactive)
2768                        (message "%s" (org-index--occur-action)))))
2769             (list "<return>" "RET"))
2770
2771       (define-key keymap (kbd "<tab>")
2772         (lambda () (interactive)
2773           (message (org-index--occur-action t))))
2774
2775       (define-key keymap (kbd "SPC")
2776         (lambda () (interactive)
2777           (org-index--refresh-parse-table)
2778           ;; increment in index
2779           (let ((ref (org-index--get-or-set-field 'ref))
2780                 count)
2781             (org-index--on
2782                 'ref ref
2783                 (setq count (+ 1 (string-to-number (org-index--get-or-set-field 'count))))
2784                 (org-index--get-or-set-field 'count (number-to-string count))
2785                 (org-index--promote-current-line)
2786                 (org-index--align-and-fontify-current-line))
2787             ;; increment in this buffer
2788             (let ((inhibit-read-only t))
2789               (org-index--get-or-set-field 'count (number-to-string count)))
2790             (message "Incremented count to %d" count))))
2791
2792       (define-key keymap (kbd "<S-return>")
2793         (lambda () (interactive)
2794           (let ((pos (get-text-property (point) 'org-index-lbp)))
2795             (org-index--refresh-parse-table)
2796             (org-index--occur-test-stale pos)
2797             (pop-to-buffer org-index--buffer)
2798             (goto-char pos)
2799             (org-reveal t)
2800             (org-index--update-current-line)
2801             (beginning-of-line))))
2802
2803       (define-key keymap (kbd "?")
2804         (lambda () (interactive)
2805           (org-index--refresh-parse-table)
2806           (setq-local org-index--occur-help-text (cons (cdr org-index--occur-help-text) (car org-index--occur-help-text)))
2807           (overlay-put org-index--occur-help-overlay 'display (car org-index--occur-help-text))))
2808
2809       (use-local-map keymap))))
2810
2811
2812 (defun org-index--occur-test-stale (pos)
2813   "Test, if current line in occur buffer has become stale at POS."
2814   (let (here there)
2815     (org-index--refresh-parse-table)
2816     (setq here (org-index--line-in-canonical-form))
2817     (with-current-buffer org-index--buffer
2818       (goto-char pos)
2819       (setq there (org-index--line-in-canonical-form)))
2820     (unless (string= here there)
2821       (error "Occur buffer has become stale"))))
2822
2823
2824 (defun org-index--line-in-canonical-form ()
2825   "Return current line in its canonical form."
2826   (org-trim (substring-no-properties (replace-regexp-in-string "\s +" " " (buffer-substring (line-beginning-position) (line-beginning-position 2))))))
2827
2828
2829 (defun org-index--wrap (text)
2830   "Wrap TEXT at fill column."
2831   (with-temp-buffer
2832     (insert text)
2833     (fill-region (point-min) (point-max) nil t)
2834     (buffer-string)))
2835
2836
2837 (defun org-index--occur-action (&optional other)
2838   "Helper for `org-index--occur', find heading with ref or id; if OTHER, in other window; or copy yank column."
2839   (if (org-at-table-p)
2840       (let ((id (org-index--get-or-set-field 'id))
2841             (ref (org-index--get-or-set-field 'ref))
2842             (yank (org-index--get-or-set-field 'yank)))
2843         (if id
2844             (org-index--find-id id other)
2845           (if ref
2846               (progn
2847                 (org-mark-ring-goto)
2848                 (format "Found reference %s (no node is associated)" ref))
2849             (if yank
2850                 (progn
2851                   (org-index--update-line (get-text-property (point) 'org-index-lbp))
2852                   (setq yank (replace-regexp-in-string (regexp-quote "\\vert") "|" yank nil 'literal))
2853                   (kill-new yank)
2854                   (org-mark-ring-goto)
2855                   (format "Copied '%s' (no node is associated)" yank))
2856               (error "Internal error, this line contains neither id, nor reference, nor text to yank")))))
2857     (message "Not at table")))
2858
2859
2860 (defun org-index--hide-with-overlays (words lines-wanted)
2861   "Hide text that is currently visible and does not match WORDS by creating overlays; leave LINES-WANTED lines visible."
2862   (let ((lines-found 0)
2863         (end-of-visible (point))
2864         overlay overlays start matched)
2865
2866     ;; main loop
2867     (while (and (not (eobp))
2868                 (< lines-found lines-wanted))
2869
2870       ;; skip invisible lines
2871       (while (and (not (eobp))
2872                   (and
2873                    (invisible-p (point))
2874                    (< (point) (overlay-start org-index--occur-tail-overlay))))
2875         (goto-char (overlay-end (car (overlays-at (point))))))
2876
2877       ;; find stretch of lines, that are currently visible but should be invisible now
2878       (setq matched nil)
2879       (setq start (point))
2880       (while (and (not (eobp))
2881                   (not
2882                    (and
2883                     (invisible-p (point))
2884                     (< (point) (overlay-start org-index--occur-tail-overlay))))
2885                   (not (and (org-index--test-words words)
2886                             (setq matched t)))) ; for its side effect
2887         (forward-line 1))
2888
2889       ;; create overlay to hide this stretch
2890       (when (< start (point))           ; avoid creating an empty overlay
2891         (setq overlay (make-overlay start (point)))
2892         (overlay-put overlay 'invisible t)
2893         (setq overlays (cons overlay overlays)))
2894
2895       ;; skip and count line, that matched
2896       (when matched
2897         (forward-line 1)
2898         (setq end-of-visible (point))
2899         (cl-incf lines-found)))
2900
2901     ;; put new list on top of stack
2902     (setq org-index--occur-stack
2903           (cons (list (cons :overlays overlays)
2904                       (cons :end-of-visible end-of-visible)
2905                       (cons :lines lines-found))
2906                 org-index--occur-stack))
2907
2908     lines-found))
2909
2910
2911 (defun org-index--unhide ()
2912   "Unhide text that does has been hidden by `org-index--hide-with-overlays'."
2913   (when org-index--occur-stack
2914     ;; delete overlays and make visible again
2915     (mapc (lambda (y)
2916             (delete-overlay y))
2917           (cdr (assoc :overlays (car org-index--occur-stack))))
2918           ;; remove from stack
2919     (setq org-index--occur-stack (cdr org-index--occur-stack))
2920     ;; return number of lines, that are now visible
2921     (if org-index--occur-stack (cdr (assoc :lines (car org-index--occur-stack))))))
2922
2923
2924 (defun org-index--test-words (words)
2925   "Test current line for match against WORDS."
2926   (let (line)
2927     (setq line (downcase (buffer-substring (line-beginning-position) (line-beginning-position 2))))
2928     (catch 'not-found
2929       (dolist (w words)
2930         (or (cl-search w line)
2931             (throw 'not-found nil)))
2932       t)))
2933
2934
2935 (defun org-index--create-new-line ()
2936   "Do the common work for `org-index-new-line' and `org-index'."
2937
2938   ;; insert ref or id as last or first line, depending on sort-column
2939   (goto-char org-index--below-hline)
2940   (if (eq org-index-sort-by 'count)
2941       (progn
2942         (while (org-at-table-p)
2943           (forward-line))
2944         (forward-line -1)
2945         (org-table-insert-row t))
2946     (org-table-insert-row))
2947
2948   ;; insert some of the standard values
2949   (org-table-goto-column (org-index--column-num 'created))
2950   (org-insert-time-stamp nil nil t)
2951   (org-table-goto-column (org-index--column-num 'count))
2952   (insert "1"))
2953
2954
2955 (defun org-index--sort-silent ()
2956   "Sort index for default column to remove any effects of temporary sorting."
2957   (save-excursion
2958     (org-index--verify-id)
2959     (org-index--parse-table)
2960     (org-index--on nil nil
2961       (org-index--do-sort-index org-index-sort-by)
2962       (org-table-align)
2963       (remove-hook 'before-save-hook 'org-index--sort-silent))))
2964
2965
2966 (defun org-index--copy-visible (beg end)
2967   "Copy the visible parts of the region between BEG and END without adding it to `kill-ring'; copy of `org-copy-visible'."
2968   (let (snippets s)
2969     (save-excursion
2970       (save-restriction
2971         (narrow-to-region beg end)
2972         (setq s (goto-char (point-min)))
2973         (while (not (= (point) (point-max)))
2974           (goto-char (org-find-invisible))
2975           (push (buffer-substring s (point)) snippets)
2976           (setq s (goto-char (org-find-visible))))))
2977     (apply 'concat (nreverse snippets))))
2978
2979
2980 (provide 'org-index)
2981
2982 ;; Local Variables:
2983 ;; fill-column: 75
2984 ;; comment-column: 50
2985 ;; End:
2986
2987 ;;; org-index.el ends here