contrib/lisp/org-index.el

   1 ;;; org-index.el --- A personal adaptive index for org
   2
   3 ;; Copyright (C) 2011-2017 Free Software Foundation, Inc.
   4
   5 ;; Author: Marc Ihm <org-index@2484.de>
   6 ;; Version: 5.1.3
   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-26 Fr] Version 5.1.3
  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.3" "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.3 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 'short-help)
 584
 585         (org-index--display-short-help))
 586
 587
 588        ((eq command 'find-ref)
 589
 590         ;; Construct list of all org-buffers
 591         (let (org-buffers)
 592           (dolist (buff (buffer-list))
 593             (set-buffer buff)
 594             (if (string= major-mode "org-mode")
 595                 (setq org-buffers (cons buff org-buffers))))
 596
 597           ;; Do multi-occur
 598           (multi-occur org-buffers (org-index--make-guarded-search search-ref))
 599
 600           ;; Present results
 601           (if (get-buffer "*Occur*")
 602               (progn
 603                 (setq message-text (format "Found '%s'" search-ref))
 604                 (other-window 1)
 605                 (toggle-truncate-lines 1))
 606             (setq message-text (format "Did not find '%s'" search-ref)))))
 607
 608
 609        ((eq command 'add)
 610
 611         (let ((r (org-index--do-add-or-update (if (equal arg '(4)) t nil)
 612                                               (if (numberp arg) arg nil))))
 613           (setq message-text (car r))
 614           (setq kill-new-text (cdr r))))
 615
 616
 617        ((eq command 'kill)
 618         (setq message-text (org-index--do-kill)))
 619
 620
 621        ((eq command 'head)
 622
 623         (if (and org-index--within-index-node
 624                  (org-at-table-p))
 625             (setq search-id (org-index--get-or-set-field 'id)))
 626
 627         (if (and (not search-id) search-ref)
 628             (setq search-id (org-index--id-from-ref search-ref)))
 629
 630         (setq message-text
 631               (if search-id
 632                   (org-index--find-id search-id)
 633                 "Current line has no id")))
 634
 635
 636        ((eq command 'index)
 637
 638         (goto-char org-index--below-hline)
 639
 640         (setq message-text
 641
 642               (if search-ref
 643                   (if (org-index--go 'ref search-ref)
 644                       (progn
 645                         (org-index--update-current-line)
 646                         (org-table-goto-column (org-index--column-num 'ref))
 647                         (format "Found index line '%s'" search-ref))
 648                     (format "Did not find index line with reference '%s'" search-ref))
 649
 650                 (if search-id
 651                     (if (org-index--go 'id search-id)
 652                         (progn
 653                           (org-index--update-current-line)
 654                           (org-table-goto-column (org-index--column-num 'ref))
 655                           (format "Found index line '%s'" (org-index--get-or-set-field 'ref)))
 656                       (format "Did not find index line with id '%s'" search-id))
 657
 658                   (if search-fingerprint
 659                       (if (org-index--go 'fingerprint org-index--last-fingerprint)
 660                           (progn
 661                             (org-index--update-current-line)
 662                             (beginning-of-line)
 663                             (format "Found latest index line"))
 664                         (format "Did not find index line"))
 665
 666                     ;; simply go into table
 667                     "At index table"))))
 668
 669         (recenter))
 670
 671
 672        ((eq command 'ping)
 673
 674         (let ((moved-up 0) id info reached-top)
 675
 676           (unless (string= major-mode "org-mode") (error "No node at point"))
 677           ;; take id from current node or reference
 678           (setq id (if search-ref
 679                        (org-index--id-from-ref search-ref)
 680                      (org-id-get)))
 681
 682           ;; move up until we find a node in index
 683           (save-excursion
 684             (outline-back-to-heading)
 685             (while (not (or info
 686                             reached-top))
 687               (if id
 688                   (setq info (org-index--on 'id id
 689                                (mapcar (lambda (x) (org-index--get-or-set-field x))
 690                                        (list 'ref 'count 'created 'last-accessed 'category 'keywords 'ref)))))
 691
 692               (setq reached-top (= (org-outline-level) 1))
 693
 694               (unless (or info
 695                           reached-top)
 696                 (outline-up-heading 1 t)
 697                 (cl-incf moved-up))
 698
 699               (setq id (org-id-get))))
 700
 701           (if info
 702               (progn
 703                 (setq message-text
 704                       (apply 'format
 705                              (append (list "'%s'%shas been accessed %s times between %s and %s; category is '%s', keywords are '%s'"
 706                                            (pop info)
 707                                            (if (> moved-up 0) (format " (parent node, %d level up) " moved-up) " "))
 708                                      info)))
 709                 (setq kill-new-text (car (last info))))
 710             (setq message-text "Neither this node nor any of its parents is part of index"))))
 711
 712
 713        ((eq command 'occur)
 714
 715         (set-buffer org-index--buffer)
 716         (org-index--do-occur))
 717
 718
 719        ((eq command 'ref)
 720
 721         (let (args)
 722
 723           (setq args (org-index--collect-values-from-user org-index-edit-on-ref))
 724           (setq args (plist-put args 'category "yank"))
 725           (setq args (plist-put args 'ref org-index--nextref))
 726           (apply 'org-index--do-new-line args)
 727
 728           (setq kill-new-text org-index--nextref)
 729
 730           (setq message-text (format "Added new row with ref '%s'" org-index--nextref))))
 731
 732
 733        ((eq command 'yank)
 734
 735         (let (args)
 736
 737           (setq args (org-index--collect-values-from-user org-index-edit-on-yank))
 738           (if (plist-get args 'yank)
 739               (plist-put args 'yank (replace-regexp-in-string "|" "\\vert" (plist-get args 'yank) nil 'literal)))
 740           (setq args (plist-put args 'category "yank"))
 741           (apply 'org-index--do-new-line args)
 742
 743           (setq message-text "Added new row with text to yank")))
 744
 745
 746        ((eq command 'column)
 747
 748         (if (and org-index--within-index-node
 749                  (org-at-table-p))
 750             (let (char col num)
 751               (setq char (read-char "Please specify, which column to go to (r=ref, k=keywords, c=category, y=yank): "))
 752               (unless (memq char (list ?r ?k ?c ?y))
 753                 (error (format "Invalid char '%c', cannot goto this column" char)))
 754               (setq col (cdr (assoc char '((?r . ref) (?k . keywords) (?c . category) (?y . yank)))))
 755               (setq num (org-index--column-num col))
 756               (if num
 757                   (progn
 758                     (org-table-goto-column num)
 759                     (setq message-text (format "At column %s" (symbol-name col))))
 760
 761                 (error (format "Column '%s' is not present" col))))
 762           (error "Need to be in index table to go to a specific column")))
 763
 764
 765        ((eq command 'edit)
 766
 767         (setq message-text (org-index--do-edit)))
 768
 769
 770        ((eq command 'sort)
 771
 772         (let ((sorts (list "count" "last-accessed" "mixed" "id" "ref"))
 773               sort groups-and-counts)
 774
 775           (cond
 776            ((eq sort-what 'index)
 777             (setq sort
 778                   (intern
 779                    (completing-read
 780                     "Please choose column to sort index table: "
 781                     (cl-copy-list sorts)
 782                     nil t nil nil (symbol-name org-index-sort-by))))
 783
 784             (org-index--do-sort-index sort)
 785             (org-table-goto-column (org-index--column-num (if (eq sort 'mixed) 'last-access sort)))
 786             ;; When saving index, it should again be sorted correctly
 787             (with-current-buffer org-index--buffer
 788               (add-hook 'before-save-hook 'org-index--sort-silent t))
 789
 790             (setq message-text
 791                   (format
 792                    (concat "Your index has been sorted temporarily by %s and will be sorted again by %s after %d seconds of idle time"
 793                            (if groups-and-counts
 794                                "; %d groups with equal %s and a total of %d lines have been found"
 795                              ""))
 796                    (symbol-name sort)
 797                    org-index-sort-by
 798                    org-index--sort-idle-delay
 799                    (second groups-and-counts)
 800                    (symbol-name sort)
 801                    (third groups-and-counts))))
 802
 803            ((memq sort-what '(region buffer))
 804             (org-index--do-sort-lines sort-what)
 805             (setq message-text (format "Sorted %s by contained references" sort-what))))))
 806
 807
 808        ((eq command 'highlight)
 809
 810         (let ((where "buffer"))
 811           (save-excursion
 812             (save-restriction
 813               (when (and transient-mark-mode
 814                          mark-active)
 815                 (narrow-to-region (region-beginning) (region-end))
 816                 (setq where "region"))
 817
 818               (if arg
 819                   (progn
 820                     (unhighlight-regexp org-index--ref-regex)
 821                     (setq message-text (format "Removed highlights for references in %s" where)))
 822                 (highlight-regexp org-index--ref-regex 'isearch)
 823                 (setq message-text (format "Highlighted references in %s" where)))))))
 824
 825
 826        ((eq command 'maintain)
 827         (setq message-text (org-index--do-maintain)))
 828
 829
 830        ((eq command 'example)
 831
 832         (if (y-or-n-p "This assistant will help you to create a temporary index with detailed comments.\nDo you want to proceed ? ")
 833             (org-index--create-index t)))
 834
 835
 836        ((not command) (setq message-text "No command given"))
 837
 838
 839        (t (error "Unknown subcommand '%s'" command)))
 840
 841
 842       ;; tell, what we have done and what can be yanked
 843       (if kill-new-text (setq kill-new-text
 844                               (substring-no-properties kill-new-text)))
 845       (if (string= kill-new-text "") (setq kill-new-text nil))
 846       (let ((m (concat
 847                 message-text
 848                 (if (and message-text kill-new-text)
 849                     " and r"
 850                   (if kill-new-text "R" ""))
 851                 (if kill-new-text (format "eady to yank '%s'." kill-new-text) (if message-text "." "")))))
 852         (unless (string= m "")
 853           (message m)
 854           (setq org-index--message-text m)))
 855       (if kill-new-text (kill-new kill-new-text)))))
 856
 857
 858 (defun org-index-dispatch (&optional arg)
 859   "Read additional chars and call subcommands of `org-index'.
 860 Can be bound in global keyboard map as central entry point.
 861 Optional argument ARG is passed on."
 862   (interactive "P")
 863   (let (char command)
 864     (if (sit-for 1)
 865         (message "org-index (? for detailed prompt) -"))
 866     (setq char (key-description (read-key-sequence nil)))
 867     (if (string= char "C-g") (keyboard-quit))
 868     (if (string= char "SPC") (setq char "?"))
 869     (setq command (cdr (assoc char (org-index--get-shortcut-chars))))
 870     (unless command
 871       (message "No subcommand for '%s'; switching to detailed prompt" char)
 872       (sit-for 1)
 873       (setq command 'short-help))
 874     (org-index command nil arg)))
 875
 876
 877 (defun org-index-new-line (&rest keys-values)
 878   "Create a new line within the index table, returning its reference.
 879
 880 The function takes a varying number of argument pairs; each pair
 881 is a symbol for an existing column heading followed by its value.
 882 The return value is the new reference.
 883
 884 Example:
 885
 886   (message \"Created reference %s\"
 887            (org-index-new-line 'keywords \"foo bar\" 'category \"baz\"))
 888
 889 Optional argument KEYS-VALUES specifies content of new line."
 890
 891   (let ((ref (plist-get keys-values 'ref)))
 892     (org-index--verify-id)
 893     (org-index--parse-table)
 894     (if (not (memq ref  '(t nil)))
 895         (error "Column 'ref' accepts only 't' or 'nil'"))
 896     (when ref
 897       (setq ref org-index--nextref)
 898       (setq keys-values (plist-put keys-values 'ref ref)))
 899
 900     (apply 'org-index--do-new-line keys-values)
 901     ref))
 902
 903
 904 (defun org-index--read-command (&optional with-short-help)
 905   "Read subcommand for ‘org-index’ from minibuffer.
 906 Optional argument WITH-SHORT-HELP displays help screen upfront."
 907   (let (minibuffer-scroll-window
 908         minibuffer-setup-fun
 909         command)
 910     (setq org-index--short-help-displayed nil)
 911     (add-hook 'minibuffer-setup-hook 'org-index--minibuffer-setup-function)
 912     (add-hook 'minibuffer-exit-hook 'org-index--minibuffer-exit-function)
 913     (unwind-protect
 914         (setq command
 915               (intern
 916                (completing-read
 917                 (concat
 918                  "Please choose"
 919                  (if org-index--display-short-help "" " (? for short help)")
 920                  ": ")
 921                 (mapcar 'symbol-name org-index--commands) nil t)))
 922       (remove-hook 'minibuffer-setup-hook 'org-index--minibuffer-setup-function)
 923       (remove-hook 'minibuffer-exit-hook 'org-index--minibuffer-exit-function)
 924       (when org-index--short-help-displayed
 925         (quit-windows-on org-index--short-help-buffer-name)))
 926     command))
 927
 928
 929 (defun org-index--minibuffer-setup-function ()
 930   "Prepare minibuffer for `org-index--read-command'."
 931   (setq org-index--minibuffer-saved-key (local-key-binding (kbd "?")))
 932   (local-set-key (kbd "?") 'org-index--display-short-help)
 933   (if org-index--display-short-help (org-index--display-short-help)))
 934
 935
 936 (defun org-index--minibuffer-exit-function ()
 937   "Restore minibuffer after `org-index--read-command'."
 938   (local-set-key (kbd "?") org-index--minibuffer-saved-key)
 939   (setq org-index--minibuffer-saved-key nil))
 940
 941
 942 (defun org-index--display-short-help ()
 943   "Helper function to show help in minibuffer."
 944   (interactive)
 945
 946   (with-temp-buffer-window
 947    org-index--short-help-buffer-name nil nil
 948    (setq org-index--short-help-displayed t)
 949    (princ "Short help; all subcommands of `org-index', shortcuts in []\n")
 950    (princ (org-index--get-short-help-text)))
 951   (with-current-buffer org-index--short-help-buffer-name
 952     (let ((inhibit-read-only t)
 953           height-before height-after win)
 954       (setq win (get-buffer-window))
 955       (setq height-before (window-height win))
 956       (shrink-window-if-larger-than-buffer win)
 957       (setq height-after (window-height win))
 958       (goto-char (point-min))
 959       (end-of-line)
 960       (insert
 961        (if (> height-before height-after)
 962            "."
 963          (concat ", "
 964                  (substitute-command-keys "\\[scroll-other-window]")
 965                  " to scroll:")))
 966       (goto-char (point-min)))))
 967
 968
 969 (defun org-index--get-short-help-text ()
 970   "Extract text for short help message from long help."
 971   (or org-index--short-help-text
 972       (with-temp-buffer
 973         (insert (documentation 'org-index))
 974         (goto-char (point-min))
 975         (search-forward (concat "  " (symbol-name (first org-index--commands)) ": "))
 976         (forward-line 0)
 977         (kill-region (point-min) (point))
 978         (search-forward (concat "  " (symbol-name (car (last org-index--commands))) ": "))
 979         (forward-line 1)
 980         (kill-region (point) (point-max))
 981         (keep-lines "^  [-a-z]+:" (point-min) (point-max))
 982         (align-regexp (point-min) (point-max) "\\(\\s-*\\):")
 983         (goto-char (point-min))
 984         (while (re-search-forward "\\. *$" nil t)
 985           (replace-match "" nil nil))
 986         (goto-char (point-min))
 987         (re-search-forward "short-help")
 988         (end-of-line)
 989         (insert " (this text)")
 990         (goto-char (point-min))
 991         (unless (= (line-number-at-pos (point-max)) (1+ (length org-index--commands)))
 992           (error "Internal error, unable to properly extract one-line descriptions of subcommands"))
 993         (setq org-index--short-help-text (buffer-string)))))
 994
 995
 996 (defun org-index--get-shortcut-chars ()
 997   "Collect shortcut chars from short help message."
 998   (or org-index--shortcut-chars
 999       (with-temp-buffer
1000         (insert (org-index--get-short-help-text))
1001         (goto-char (point-min))
1002         (while (< (point) (point-max))
1003           (when (looking-at "^  \\([-a-z]+\\) +: +\\[\\([a-z?]\\)\\] ")
1004             (setq org-index--shortcut-chars
1005                   (cons (cons (match-string 2) (intern (match-string 1)))
1006                         org-index--shortcut-chars)))
1007           (forward-line 1))
1008         (unless (> (length org-index--shortcut-chars) 0)
1009           (error "Internal error, did not find shortcut chars"))
1010         org-index--shortcut-chars)))
1011
1012
1013 (defun org-index--do-edit ()
1014   "Perform command edit."
1015   (let ((maxlen 0) cols-vals buffer-keymap field-keymap keywords-pos val)
1016
1017     (setq org-index--context-node nil)
1018     (setq org-index--context-occur nil)
1019
1020     ;; change to index, if whithin occur
1021     (if org-index--within-occur
1022         (let ((pos (get-text-property (point) 'org-index-lbp)))
1023           (org-index--occur-test-stale pos)
1024           (setq org-index--context-occur (cons (point) (org-index--line-in-canonical-form)))
1025           (set-buffer org-index--buffer)
1026           (goto-char pos))
1027
1028       ;; change to index, if still not within
1029       (if (not org-index--within-index-node)
1030           (let ((id (org-id-get)))
1031             (setq org-index--context-node (cons (current-buffer) (point)))
1032             (set-buffer org-index--buffer)
1033             (unless (and id (org-index--go 'id id))
1034               (setq org-index--context-node nil)
1035               (error "This node is not in index")))))
1036
1037     ;; retrieve current content of index line
1038     (dolist (col (mapcar 'car (reverse org-index--columns)))
1039       (if (> (length (symbol-name col)) maxlen)
1040           (setq maxlen (length (symbol-name col))))
1041       (setq val (org-index--get-or-set-field col))
1042       (if (and val (eq col 'yank)) (setq val (replace-regexp-in-string (regexp-quote "\\vert") "|" val nil 'literal)))
1043       (setq cols-vals (cons (cons col val)
1044                             cols-vals)))
1045
1046     ;; we need two different keymaps
1047     (setq buffer-keymap (make-sparse-keymap))
1048     (set-keymap-parent buffer-keymap widget-keymap)
1049     (define-key buffer-keymap (kbd "C-c C-c") 'org-index--edit-c-c-c-c)
1050     (define-key buffer-keymap (kbd "C-c C-k") 'org-index--edit-c-c-c-k)
1051
1052     (setq field-keymap (make-sparse-keymap))
1053     (set-keymap-parent field-keymap widget-field-keymap)
1054     (define-key field-keymap (kbd "C-c C-c") 'org-index--edit-c-c-c-c)
1055     (define-key field-keymap (kbd "C-c C-k") 'org-index--edit-c-c-c-k)
1056
1057     ;; prepare buffer
1058     (setq org-index--context-index (cons (point) (org-index--line-in-canonical-form)))
1059     (if (get-buffer org-index--edit-buffer-name) (kill-buffer org-index--edit-buffer-name))
1060     (switch-to-buffer (get-buffer-create org-index--edit-buffer-name))
1061
1062     ;; create and fill widgets
1063     (setq org-index--edit-widgets nil)
1064     (widget-insert "Edit this line from index; type C-c C-c when done, C-c C-k to abort.\n\n")
1065     (dolist (col-val cols-vals)
1066       (if (eq (car col-val) 'keywords) (setq keywords-pos (point)))
1067       (setq org-index--edit-widgets (cons
1068                                      (cons (car col-val)
1069                                            (widget-create 'editable-field
1070                                                           :format (format  (format "%%%ds: %%%%v" maxlen) (symbol-name (car col-val)))
1071                                                           :keymap field-keymap
1072                                                           (or (cdr col-val) "")))
1073                                      org-index--edit-widgets)))
1074
1075     (widget-setup)
1076     (goto-char keywords-pos)
1077     (beginning-of-line)
1078     (forward-char (+  maxlen 2))
1079     (use-local-map buffer-keymap)
1080     "Editing a single line from index"))
1081
1082
1083 (defun org-index--edit-c-c-c-c ()
1084   "Function to  invoked on C-c C-c in Edit buffer."
1085   (interactive)
1086
1087   (let ((obuf (get-buffer org-index--occur-buffer-name))
1088         val line)
1089
1090     ;; Time might have passed
1091     (org-index--refresh-parse-table)
1092
1093     (with-current-buffer org-index--buffer
1094
1095       ;; check, if buffer has become stale
1096       (save-excursion
1097         (goto-char (car org-index--context-index))
1098         (unless (string= (cdr org-index--context-index)
1099                          (org-index--line-in-canonical-form))
1100           (switch-to-buffer org-index--edit-buffer-name)
1101           (error "Index table has changed: Cannot find line, that this buffer is editing")))
1102
1103       (pop-to-buffer-same-window org-index--buffer)
1104       (goto-char (car org-index--context-index))
1105
1106       ;; write back line to index
1107       (dolist (col-widget org-index--edit-widgets)
1108         (setq val (widget-value (cdr col-widget)))
1109         (if (eq (car col-widget) 'yank) (setq val (replace-regexp-in-string "|" (regexp-quote "\\vert") val)))
1110         (org-index--get-or-set-field (car col-widget) val))
1111
1112       (setq line (org-index--align-and-fontify-current-line))
1113       (beginning-of-line))
1114
1115     ;; write line to occur if appropriate
1116     (if org-index--context-occur
1117         (if obuf
1118             (if (string= (cdr org-index--context-index)
1119                          (cdr org-index--context-occur))
1120                 (progn
1121                   (pop-to-buffer-same-window obuf)
1122                   (goto-char (car org-index--context-occur))
1123                   (beginning-of-line)
1124                   (let ((inhibit-read-only t))
1125                     (delete-region (line-beginning-position) (line-end-position))
1126                     (insert line)
1127                     (put-text-property (line-beginning-position) (line-end-position)
1128                                        'org-index-lbp (cdr org-index--context-index))))
1129               (error "Occur buffer and index buffer do not match any longer"))
1130           (message "Occur buffer has gone, cannot switch back."))
1131       (setq org-index--context-occur nil))
1132
1133     ;; return to node, if invoked from there
1134     (when org-index--context-node
1135         (pop-to-buffer-same-window (car org-index--context-node))
1136         (goto-char (cdr org-index--context-node)))
1137
1138     ;; clean up
1139     (kill-buffer org-index--edit-buffer-name)
1140     (setq org-index--context-index nil)
1141     (setq org-index--edit-widgets nil)
1142     (beginning-of-line)
1143     (message "Index line has been edited.")))
1144
1145
1146 (defun org-index--edit-c-c-c-k ()
1147   "Function invoked on C-c C-k in Edit buffer."
1148   (interactive)
1149   (kill-buffer org-index--edit-buffer-name)
1150   (setq org-index--context-index nil)
1151   (setq org-index--edit-widgets nil)
1152   (beginning-of-line)
1153   (message "Edit aborted."))
1154
1155
1156 (defun org-index--do-new-line (&rest keys-values)
1157   "Do the work for `org-index-new-line'.
1158 Optional argument KEYS-VALUES specifies content of new line."
1159
1160   (org-index--retrieve-context)
1161   (with-current-buffer org-index--buffer
1162     (goto-char org-index--point)
1163
1164     ;; check arguments early; they might come from userland
1165     (let ((kvs keys-values)
1166           k v)
1167       (while kvs
1168         (setq k (car kvs))
1169         (setq v (cadr kvs))
1170         (if (or (not (symbolp k))
1171                 (and (symbolp v) (not (eq v t)) (not (eq v nil))))
1172             (error "Arguments must be alternation of key and value"))
1173         (unless (org-index--column-num k)
1174           (error "Unknown column or column not defined in table: '%s'" (symbol-name k)))
1175         (setq kvs (cddr kvs))))
1176
1177     (let (yank)
1178       ;; create new line
1179       (org-index--create-new-line)
1180
1181       ;; fill columns
1182       (let ((kvs keys-values)
1183             k v)
1184         (while kvs
1185           (setq k (car kvs))
1186           (setq v (cadr kvs))
1187           (org-table-goto-column (org-index--column-num k))
1188           (insert (org-trim (or v "")))
1189           (setq kvs (cddr kvs))))
1190
1191       ;; align and fontify line
1192       (org-index--promote-current-line)
1193       (org-index--align-and-fontify-current-line)
1194
1195       ;; remember fingerprint to be able to return
1196       (setq org-index--last-fingerprint (org-index--get-or-set-field 'fingerprint))
1197
1198       ;; get column to yank
1199       (setq yank (org-index--get-or-set-field org-index-yank-after-add))
1200
1201       yank)))
1202
1203
1204 (defun org-index-get-line (column value)
1205   "Retrieve an existing line within the index table by ref or id.
1206 Return its contents as a property list.
1207
1208 The function `plist-get' may be used to retrieve specific elements
1209 from the result.
1210
1211 Example:
1212
1213   (plist-get (org-index-get-line 'ref \"R12\") 'count)
1214
1215 retrieves the value of the count-column for reference number 12.
1216
1217 Argument COLUMN is a symbol, either ref or id,
1218 argument VALUE specifies the value to search for."
1219   ;; check arguments
1220   (unless (memq column '(ref id))
1221     (error "Argument column can only be 'ref' or 'id'"))
1222
1223   (unless value
1224     (error "Need a value to search for"))
1225
1226   (org-index--verify-id)
1227   (org-index--parse-table)
1228
1229   (org-index--get-line column value))
1230
1231
1232 (defun org-index--get-line (column value)
1233   "Find a line by ID, return its contents.
1234 Argument COLUMN and VALUE specify line to get."
1235   (let (content)
1236     (org-index--on
1237      column value
1238      (mapc (lambda (x)
1239              (if (and (numberp (cdr x))
1240                       (> (cdr x) 0))
1241                  (setq content (cons (car x) (cons (or (org-index--get-or-set-field (car x)) "") content)))))
1242            (reverse org-index--columns)))
1243     content))
1244
1245
1246 (defun org-index--ref-from-id (id)
1247   "Get reference from line ID."
1248   (org-index--on 'id id (org-index--get-or-set-field 'ref)))
1249
1250
1251 (defun org-index--id-from-ref (ref)
1252   "Get id from line REF."
1253   (org-index--on 'ref ref (org-index--get-or-set-field 'id)))
1254
1255
1256 (defun org-index--get-fingerprint ()
1257   "Get fingerprint of current line."
1258   (replace-regexp-in-string
1259    "\\s " ""
1260    (mapconcat (lambda (x) (org-index--get-or-set-field x)) '(id ref yank keywords created) "")))
1261
1262
1263 (defun org-index--read-search-for-index ()
1264     "Special input routine for command index."
1265
1266     ;; Accept single char commands or switch to reading a sequence of digits
1267     (let (char prompt search-ref search-id search-fingerprint)
1268
1269       ;; start with short prompt but give more help on next iteration
1270       (setq prompt "Please specify, where to go in index (0-9,.,space,backspace,return or ? for short help) - ")
1271
1272       ;; read one character
1273       (while (not (memq char (append (number-sequence ?0 ?9) (list ?\d ?\b ?\r ?\j ?\s ?.))))
1274         (setq char (read-char prompt))
1275         (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 - "))
1276
1277       (if (memq char (number-sequence ?0 ?9))
1278           ;; read rest of digits
1279           (setq search-ref (read-from-minibuffer "Search reference number: " (char-to-string char))))
1280       ;; decode single chars
1281       (if (memq char '(?\r ?\n ?.)) (setq search-id (org-id-get)))
1282       (if (memq char '(?\d ?\b)) (setq search-fingerprint org-index--last-fingerprint))
1283
1284       (list search-ref search-id search-fingerprint)))
1285
1286
1287 (defun org-index--verify-id ()
1288   "Check, that we have a valid id."
1289
1290   ;; Check id
1291   (unless org-index-id
1292     (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")))
1293       (if (string= answer "create-index")
1294           (org-index--create-missing-index "Variable org-index-id is not set, so probably no index table has been created yet.")
1295         (describe-function 'org-index)
1296         (throw 'new-index nil))))
1297
1298   ;; Find node
1299   (let (marker)
1300     (setq marker (org-id-find org-index-id 'marker))
1301     (unless marker (org-index--create-missing-index "Cannot find the node with id \"%s\" (as specified by variable org-index-id)." org-index-id))
1302     ; Try again with new node
1303     (setq marker (org-id-find org-index-id 'marker))
1304     (unless marker (error "Could not create node"))
1305     (setq org-index--buffer (marker-buffer marker)
1306           org-index--point (marker-position marker))
1307     (move-marker marker nil)))
1308
1309
1310 (defun org-index--retrieve-context ()
1311   "Collect context information before starting with command."
1312
1313   ;; Get the content of the active region or the word under cursor
1314   (setq org-index--active-region
1315         (if (and transient-mark-mode mark-active)
1316             (buffer-substring (region-beginning) (region-end))
1317           nil))
1318   (setq org-index--below-cursor (thing-at-point 'symbol))
1319
1320   ;; get category of current node
1321   (setq org-index--category-before
1322         (save-excursion ; workaround: org-get-category does not give category when at end of buffer
1323           (beginning-of-line)
1324           (org-get-category (point) t)))
1325
1326   ;; Find out, if we are within index table or occur buffer
1327   (setq org-index--within-index-node (string= (org-id-get) org-index-id))
1328   (setq org-index--within-occur (string= (buffer-name) org-index--occur-buffer-name)))
1329
1330
1331 (defun org-index--parse-table ()
1332   "Parse content of index table."
1333
1334   (let (ref-field
1335         id-field
1336         initial-point
1337         end-of-headings
1338         start-of-headings)
1339
1340     (with-current-buffer org-index--buffer
1341
1342       (setq org-index--maxrefnum 0)
1343       (setq initial-point (point))
1344
1345       (org-index--go-below-hline)
1346
1347       ;; align and fontify table once for this emacs session
1348       (unless org-index--aligned
1349         (org-table-align) ; needs to happen before fontification to be effective ?
1350         (let ((is-modified (buffer-modified-p))
1351               (below (point)))
1352           (while (org-at-table-p)
1353             (forward-line))
1354           (font-lock-fontify-region below (point))
1355           (org-index--go-below-hline)
1356           (setq org-index--aligned t)
1357           (set-buffer-modified-p is-modified)))
1358
1359       (org-index--go-below-hline)
1360       (beginning-of-line)
1361
1362       ;; get headings to display during occur
1363       (setq end-of-headings (point))
1364       (while (org-at-table-p) (forward-line -1))
1365       (forward-line)
1366       (setq start-of-headings (point))
1367       (setq org-index--headings-visible (substring-no-properties (org-index--copy-visible start-of-headings end-of-headings)))
1368       (setq org-index--headings (buffer-substring start-of-headings end-of-headings))
1369
1370       ;; count columns
1371       (org-table-goto-column 100)
1372       (setq org-index--numcols (- (org-table-current-column) 1))
1373
1374       ;; go to top of table
1375       (while (org-at-table-p)
1376         (forward-line -1))
1377       (forward-line)
1378
1379       ;; parse line of headings
1380       (org-index--parse-headings)
1381
1382       ;; parse list of flags
1383       (goto-char org-index--point)
1384
1385       ;; Retrieve any decorations around the number within the first nonempty ref-field
1386       (goto-char org-index--below-hline)
1387       (while (and (org-at-table-p)
1388                   (not (setq ref-field (org-index--get-or-set-field 'ref))))
1389         (forward-line))
1390
1391       ;; Some Checking
1392       (unless ref-field
1393         (org-index--report-index-error "Reference column is empty"))
1394
1395       (unless (string-match "^\\([^0-9]*\\)\\([0-9]+\\)\\([^0-9]*\\)$" ref-field)
1396         (org-index--report-index-error
1397          "First reference in index table ('%s') does not contain a number" ref-field))
1398
1399       ;; These are the decorations used within the first ref of index
1400       (setq org-index--head (match-string 1 ref-field))
1401       (setq org-index--tail (match-string 3 ref-field))
1402       (setq org-index--ref-regex (concat (regexp-quote org-index--head)
1403                                          "\\([0-9]+\\)"
1404                                          (regexp-quote org-index--tail)))
1405       (setq org-index--ref-format (concat org-index--head "%d" org-index--tail))
1406
1407       ;; check if the table still seems to be sorted mixed
1408       (goto-char org-index--below-hline)
1409       (when (eq org-index-sort-by 'mixed)
1410           (org-index--go-below-hline)
1411           (if (string< (org-index--get-or-set-field 'last-accessed)
1412                        (org-index--get-mixed-time))
1413               (org-index--do-sort-index org-index-sort-by)))
1414
1415       ;; Go through table to find maximum number and do some checking
1416       (let ((refnum 0))
1417
1418         (while (org-at-table-p)
1419
1420           (setq ref-field (org-index--get-or-set-field 'ref))
1421           (setq id-field (org-index--get-or-set-field 'id))
1422
1423           (if ref-field
1424               (if (string-match org-index--ref-regex ref-field)
1425                   ;; grab number
1426                   (setq refnum (string-to-number (match-string 1 ref-field)))
1427                 (kill-whole-line)
1428                 (message "Removing line from index-table whose ref does not contain a number")))
1429
1430           ;; check, if higher ref
1431           (if (> refnum org-index--maxrefnum) (setq org-index--maxrefnum refnum))
1432
1433           (forward-line 1)))
1434
1435       (setq org-index--nextref (format "%s%d%s" org-index--head (1+ org-index--maxrefnum) org-index--tail))
1436       ;; go back to initial position
1437       (goto-char initial-point))))
1438
1439
1440 (defun org-index--refresh-parse-table ()
1441   "Fast refresh of selected results of parsing index table."
1442
1443   (setq org-index--point (marker-position (org-id-find org-index-id 'marker)))
1444   (with-current-buffer org-index--buffer
1445     (save-excursion
1446       (org-index--go-below-hline))))
1447
1448
1449 (defun org-index--do-maintain ()
1450   "Choose among and perform some tasks to maintain index."
1451   (let ((check-what) (max-mini-window-height 1.0) message-text)
1452     (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")))
1453     (message nil)
1454
1455     (cond
1456      ((eq check-what 'check)
1457       (setq message-text (or (org-index--check-ids)
1458                              "No problems found")))
1459
1460      ((eq check-what 'statistics)
1461       (setq message-text (org-index--do-statistics)))
1462
1463      ((eq check-what 'duplicates)
1464       (setq message-text (org-index--find-duplicates)))
1465
1466      ((eq check-what 'clean)
1467       (let ((lines 0))
1468         (org-map-entries
1469          (lambda ()
1470            (when (org-entry-get (point) "org-index-ref")
1471              (cl-incf lines)
1472              (org-entry-delete (point) "org-index-ref")))
1473          nil 'agenda)
1474         (setq message-text (format "Removed property 'org-index-ref' from %d lines" lines))))
1475
1476      ((eq check-what 'update)
1477       (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 ? ")
1478           (setq message-text (org-index--update-all-lines))
1479         (setq message-text "Canceled."))))
1480     message-text))
1481
1482
1483 (defun org-index--get-mixed-time ()
1484   "Get timestamp for sorting order mixed."
1485   (format-time-string
1486    (org-time-stamp-format t t)
1487    (apply 'encode-time (append '(0 0 0) (nthcdr 3 (decode-time))))))
1488
1489
1490 (defun org-index--do-sort-index (sort)
1491   "Sort index table according to SORT."
1492
1493   (let ((is-modified (buffer-modified-p))
1494         top
1495         bottom
1496         mixed-time)
1497
1498     (unless buffer-read-only
1499
1500       (message "Sorting index table for %s..." (symbol-name sort))
1501       (undo-boundary)
1502
1503       (let ((message-log-max nil)) ; we have just issued a message, dont need those of sort-subr
1504
1505         ;; if needed for mixed sort
1506         (if (eq sort 'mixed)
1507             (setq mixed-time (org-index--get-mixed-time)))
1508
1509         ;; get boundaries of table
1510         (org-index--go-below-hline)
1511         (forward-line 0)
1512         (setq top (point))
1513         (while (org-at-table-p) (forward-line))
1514
1515         ;; kill all empty rows at bottom
1516         (while (progn
1517                  (forward-line -1)
1518                  (org-table-goto-column 1)
1519                  (and
1520                   (not (org-index--get-or-set-field 'ref))
1521                   (not (org-index--get-or-set-field 'id))
1522                   (not (org-index--get-or-set-field 'yank))))
1523           (org-table-kill-row))
1524         (forward-line 1)
1525         (setq bottom (point))
1526
1527         ;; sort lines
1528         (save-restriction
1529           (narrow-to-region top bottom)
1530           (goto-char top)
1531           (sort-subr t
1532                      'forward-line
1533                      'end-of-line
1534                      (lambda ()
1535                        (org-index--get-sort-key sort t mixed-time))
1536                      nil
1537                      'string<)
1538           (goto-char (point-min))
1539
1540           ;; restore modification state
1541           (set-buffer-modified-p is-modified)))
1542
1543         (setq org-index--last-sort sort))))
1544
1545
1546 (defun org-index--do-sort-lines (what)
1547   "Sort lines in WHAT according to contained reference."
1548   (save-restriction
1549     (cond
1550      ((eq what 'region)
1551       (if (region-active-p)
1552           (narrow-to-region (region-beginning) (region-end))
1553         (error "No active region, cannot sort")))
1554      ((eq what 'buffer)
1555       (unless (y-or-n-p "Sort whole current buffer ? ")
1556         (error "Canceled"))
1557       (narrow-to-region (point-min) (point-max))))
1558
1559     (goto-char (point-min))
1560     (sort-subr nil 'forward-line 'end-of-line
1561                (lambda ()
1562                  (if (looking-at (concat ".*"
1563                                          (org-index--make-guarded-search org-index--ref-regex 'dont-quote)))
1564                      (string-to-number (match-string 1))
1565                    0)))))
1566
1567
1568 (defun org-index--go-below-hline ()
1569   "Move below hline in index-table."
1570
1571   (let ((errstring (format "index table within node %s" org-index-id)))
1572
1573     (goto-char org-index--point)
1574
1575     ;; go to heading of node
1576     (while (not (org-at-heading-p)) (forward-line -1))
1577     (forward-line 1)
1578
1579     ;; go to first table, but make sure we do not get into another node
1580     (while (and (not (org-at-table-p))
1581                 (not (org-at-heading-p))
1582                 (not (eobp)))
1583       (forward-line))
1584
1585     ;; check, if there really is a table
1586     (unless (org-at-table-p)
1587       (org-index--create-missing-index "Cannot find %s." errstring))
1588
1589     ;; go just after hline
1590     (while (and (not (org-at-table-hline-p))
1591                 (org-at-table-p))
1592       (forward-line))
1593     (forward-line)
1594
1595     ;; and check
1596     (unless (org-at-table-p)
1597       (org-index--report-index-error "Cannot find a hline within %s" errstring))
1598
1599     (org-table-goto-column 1)
1600     (setq org-index--below-hline (point))))
1601
1602
1603 (defun org-index--parse-headings ()
1604   "Parse headings of index table."
1605
1606   (let (field         ;; field content
1607         field-symbol) ;; and as a symbol
1608
1609     (setq org-index--columns nil)
1610
1611     ;; For each column
1612     (dotimes (col org-index--numcols)
1613
1614       (setq field (substring-no-properties (downcase (org-trim (org-table-get-field (+ col 1))))))
1615
1616       (if (string= field "")
1617           (error "Heading of column cannot be empty"))
1618       (if (and (not (string= (substring field 0 1) "."))
1619                (not (member (intern field) org-index--valid-headings)))
1620           (error "Column name '%s' is not a valid heading (custom headings may start with a dot, e.g. '.foo')" field))
1621
1622       (setq field-symbol (intern field))
1623
1624       ;; check if heading has already appeared
1625       (if (assoc field-symbol org-index--columns)
1626           (org-index--report-index-error
1627            "'%s' appears two times as column heading" (downcase field))
1628         ;; add it to list at front, reverse later
1629         (setq org-index--columns (cons (cons field-symbol (+ col 1)) org-index--columns)))))
1630
1631   (setq org-index--columns (reverse org-index--columns))
1632
1633   ;; check if all necessary headings have appeared
1634   (mapc (lambda (head)
1635           (unless (cdr (assoc head org-index--columns))
1636             (org-index--report-index-error "No column has heading '%s'" head)))
1637         org-index--valid-headings))
1638
1639
1640 (defun org-index--create-missing-index (&rest reasons)
1641   "Create a new empty index table with detailed explanation.  Argument REASONS explains why."
1642
1643   (org-index--ask-before-create-index "Cannot find index table: "
1644                                       "new permanent" "."
1645                                       reasons)
1646   (org-index--create-index))
1647
1648
1649 (defun org-index--report-index-error (&rest reasons)
1650   "Report an error (explained by REASONS) with the existing index and offer to create a valid one to compare with."
1651
1652   (when org-index--buffer
1653     (pop-to-buffer-same-window org-index--buffer)
1654     (goto-char org-index--below-hline)
1655     (org-reveal t))
1656   (org-index--ask-before-create-index "The existing index contains this error: "
1657                                       "temporary" ", to compare with."
1658                                       reasons)
1659   (org-index--create-index t t))
1660
1661
1662 (defun org-index--ask-before-create-index (explanation type for-what reasons)
1663                                                   ; checkdoc-params: (explanation type for-what reasons)
1664   "Ask the user before creating an index or throw error.  Arguments specify bits of issued message."
1665   (let (reason prompt)
1666
1667     (setq reason (apply 'format reasons))
1668
1669     (setq prompt (concat explanation reason "\n"
1670                          "However, this assistant can help you to create a "
1671                          type " index with detailed comments" for-what "\n\n"
1672                          "Do you want to proceed ?"))
1673
1674     (unless (let ((max-mini-window-height 1.0))
1675               (y-or-n-p prompt))
1676       (error (concat explanation reason)))))
1677
1678
1679 (defun org-index--create-index (&optional temporary compare)
1680   "Create a new empty index table with detailed explanation.
1681 specify flag TEMPORARY for th new table temporary, maybe COMPARE it with existing index."
1682   (let (buffer
1683         title
1684         firstref
1685         id)
1686
1687     (if temporary
1688         (let ((file-name (concat temporary-file-directory "org-index--example-index.org"))
1689               (buffer-name "*org-index-example-index*"))
1690           (setq buffer (get-buffer-create buffer-name))
1691           (with-current-buffer buffer
1692             ;; but it needs a file for its index to be found
1693             (unless (string= (buffer-file-name) file-name)
1694               (set-visited-file-name file-name))
1695             (rename-buffer buffer-name) ; name is change by line above
1696
1697             (erase-buffer)
1698             (org-mode)))
1699
1700       (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))))))
1701
1702     (setq title (read-from-minibuffer "Please enter the title of the index node (leave empty for default 'index'): "))
1703     (if (string= title "") (setq title "index"))
1704
1705     (while (progn
1706              (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'): "))
1707              (if (string= firstref "") (setq firstref "R1"))
1708              (let (desc)
1709                (when (string-match "[[:blank:]]" firstref)
1710                  (setq desc "Contains whitespace"))
1711                (when (string-match "[[:cntrl:]]" firstref)
1712                  (setq desc "Contains control characters"))
1713                (unless (string-match "^[^0-9]+[0-9]+[^0-9]*$" firstref)
1714                  ;; firstref not okay, report details
1715                  (setq desc
1716                        (cond ((string= firstref "") "is empty")
1717                              ((not (string-match "^[^0-9]+" firstref)) "starts with a digit")
1718                              ((not (string-match "^[^0-9]+[0-9]+" firstref)) "does not contain a number")
1719                              ((not (string-match "^[^0-9]+[0-9]+[^0-9]*$" firstref)) "contains more than one sequence of digits")
1720
1721                              )))
1722                (if desc
1723                    (progn
1724                      (read-from-minibuffer (format "Your input '%s' does not meet the requirements because it %s.\nPlease hit RET and try again: " firstref desc))
1725                      t)
1726                  nil))))
1727
1728     (with-current-buffer buffer
1729       (goto-char (point-max))
1730       (insert (format "* %s %s\n" firstref title))
1731       (if temporary
1732           (insert "
1733   Below you find your temporary index table, which WILL NOT LAST LONGER
1734   THAN YOUR CURRENT EMACS SESSION; please use it only for evaluation.
1735 ")
1736         (insert "
1737   Below you find your initial index table, which will grow over time.
1738 "))
1739       (insert "  You may start using it by adding some lines. Just
1740   move to another heading within org, invoke `org-index' and
1741   choose the command 'add'.  After adding a few nodes, try the
1742   command 'occur' to search among them.
1743
1744   To gain further insight you may invoke the subcommand 'help', or
1745   (same content) read the help of `org-index'.
1746
1747   Within the index table below, the sequence of columns does not
1748   matter. You may reorder them in any way you like.  You may also
1749   add your own columns, which should start with a dot
1750   (e.g. '.my-column').
1751
1752   Invoke `org-customize' to tweak the behaviour of org-index
1753   (see the group org-index).
1754
1755   This node needs not be a top level node; its name is completely
1756   at your choice; it is found through its ID only.
1757 ")
1758       (unless temporary
1759         (insert "
1760   Remark: These lines of explanation can be removed at any time.
1761 "))
1762
1763       (setq id (org-id-get-create))
1764       (insert (format "
1765
1766   | ref | category | keywords | tags | count | level | last-accessed | created | id  | yank |
1767   |     |          |          |      |       |       |               |         | <4> | <4>  |
1768   |-----+----------+----------+------+-------+-------+---------------+---------+-----+------|
1769   | %s  |          | %s       |      |       |       |               | %s      | %s  |      |
1770
1771 "
1772                       firstref
1773                       title
1774                       (with-temp-buffer (org-insert-time-stamp nil nil t))
1775                       id))
1776
1777       ;; make sure, that node can be found
1778       (org-id-add-location id (buffer-file-name))
1779       (setq buffer-save-without-query t)
1780       (basic-save-buffer)
1781
1782       (while (not (org-at-table-p)) (forward-line -1))
1783       (unless buffer-read-only (org-table-align))
1784       (while (not (org-at-heading-p)) (forward-line -1))
1785
1786       ;; read back some info about new index
1787       (let ((org-index-id id))
1788         (org-index--verify-id))
1789
1790       ;; remember at least for this session
1791       (setq org-index-id id)
1792
1793       ;; present results to user
1794       (if temporary
1795           (progn
1796             ;; Present existing and temporary index together
1797             (when compare
1798               (pop-to-buffer-same-window org-index--buffer)
1799               (goto-char org-index--point)
1800               (org-index--unfold-buffer)
1801               (delete-other-windows)
1802               (select-window (split-window-vertically)))
1803             ;; show new index
1804             (pop-to-buffer-same-window buffer)
1805             (org-id-goto id)
1806             (org-index--unfold-buffer)
1807             (if compare
1808                 (progn
1809                   (message "Please compare your existing index (upper window) and a temporary new one (lower window) to fix your index")
1810                   (throw 'new-index nil))
1811               (message "This is your new temporary index, use command add to populate, occur to search.")))
1812         (progn
1813           ;; Only show the new index
1814           (pop-to-buffer-same-window buffer)
1815           (delete-other-windows)
1816           (org-id-goto id)
1817           (org-index--unfold-buffer)
1818           (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 ? ")
1819               (progn
1820                 (customize-save-variable 'org-index-id id)
1821                 (message "Saved org-index-id '%s' to %s." id (or custom-file
1822                                                                 user-init-file))
1823                 (throw 'new-index nil))
1824             (let (sq)
1825               (setq sq (format "(setq org-index-id \"%s\")" id))
1826               (kill-new sq)
1827               (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)
1828               (throw 'new-index nil))))))))
1829
1830
1831 (defun org-index--unfold-buffer ()
1832   "Helper function to unfold buffer."
1833   (org-show-context)
1834   (org-show-subtree)
1835   (recenter 1)
1836   (save-excursion
1837     (org-back-to-heading)
1838     (forward-line) ;; on property drawer
1839     (org-cycle)))
1840
1841
1842 (defun org-index--update-line (&optional ref-or-id-or-pos)
1843   "Update columns count and last-accessed in line REF-OR-ID-OR-POS."
1844
1845   (let (initial)
1846
1847     (with-current-buffer org-index--buffer
1848       (unless buffer-read-only
1849
1850         ;; search reference or id, if given (or assume, that we are already positioned right)
1851         (when ref-or-id-or-pos
1852           (setq initial (point))
1853           (goto-char org-index--below-hline)
1854           (while (and (org-at-table-p)
1855                       (not (if (integerp ref-or-id-or-pos)
1856                                (and (>= ref-or-id-or-pos (line-beginning-position))
1857                                     (< ref-or-id-or-pos (line-end-position)))
1858                              (or (string= ref-or-id-or-pos (org-index--get-or-set-field 'ref))
1859                                  (string= ref-or-id-or-pos (org-index--get-or-set-field 'id))))))
1860             (forward-line)))
1861
1862         (if (not (org-at-table-p))
1863             (error "Did not find reference or id '%s'" ref-or-id-or-pos)
1864           (org-index--update-current-line))
1865
1866         (if initial (goto-char initial))))))
1867
1868
1869 (defun org-index--update-current-line ()
1870   "Update current lines columns count and last-accessed."
1871   (let (newcount (count-field (org-index--get-or-set-field 'count)))
1872
1873     ;; update count field only if number or empty
1874     (when (or (not count-field)
1875               (string-match "^[0-9]+$" count-field))
1876       (setq newcount (+ 1 (string-to-number (or count-field "0"))))
1877       (org-index--get-or-set-field 'count
1878                             (number-to-string newcount)))
1879
1880     ;; update timestamp
1881     (org-table-goto-column (org-index--column-num 'last-accessed))
1882     (org-table-blank-field)
1883     (org-insert-time-stamp nil t t)
1884
1885     ;; move line according to new content
1886     (org-index--promote-current-line)
1887     (org-index--align-and-fontify-current-line)))
1888
1889
1890 (defun org-index--align-and-fontify-current-line (&optional num)
1891   "Make current line (or NUM lines) blend well among others."
1892   (let (lines)
1893     ;; get current content
1894     (unless num (setq num 1))
1895     (setq lines (delete-and-extract-region (line-beginning-position) (line-end-position num)))
1896     ;; create minimum table with fixed-width columns to align and fontify new line
1897     (insert (with-temp-buffer
1898               (org-set-font-lock-defaults)
1899               (insert org-index--headings-visible)
1900               ;; fill columns, so that aligning cannot shrink them
1901               (goto-char (point-min))
1902               (search-forward "|")
1903               (while (search-forward " " (line-end-position) t)
1904                 (replace-match "." nil t))
1905               (goto-char (point-min))
1906               (while (search-forward ".|." (line-end-position) t)
1907                 (replace-match " | " nil t))
1908               (goto-char (point-min))
1909               (while (search-forward "|." (line-end-position) t)
1910                 (replace-match "| " nil t))
1911               (goto-char (point-max))
1912               (insert lines)
1913               (forward-line 0)
1914               (let ((start (point)))
1915                 (while (re-search-forward "^\s +|-" nil t)
1916                   (replace-match "| -"))
1917                 (goto-char start))
1918               (org-mode)
1919               (org-table-align)
1920               (font-lock-fontify-region (point-min) (point-max))
1921               (goto-char (point-max))
1922               (if (eq -1 (skip-chars-backward "\n"))
1923                   (delete-char 1))
1924               (forward-line (- 1 num))
1925               (buffer-substring (line-beginning-position) (line-end-position num))))
1926     lines))
1927
1928
1929 (defun org-index--promote-current-line ()
1930   "Move current line up in table according to changed sort fields."
1931   (let (begin end key
1932         (to-skip 0))
1933
1934     (forward-line 0) ; stay at beginning of line
1935
1936     (setq key (org-index--get-sort-key))
1937     (setq begin (point))
1938     (setq end (line-beginning-position 2))
1939
1940     (forward-line -1)
1941     (while (and (org-at-table-p)
1942                 (not (org-at-table-hline-p))
1943                 (string< (org-index--get-sort-key) key))
1944
1945       (cl-incf to-skip)
1946       (forward-line -1))
1947     (forward-line 1)
1948
1949     ;; insert line at new position
1950     (when (> to-skip 0)
1951       (insert (delete-and-extract-region begin end))
1952       (forward-line -1))))
1953
1954
1955 (defun org-index--get-sort-key (&optional sort with-ref mixed-time)
1956   "Get value for sorting from column SORT, optional WITH-REF; if mixes use MIXED-TIME."
1957   (let (ref
1958         ref-field
1959         key)
1960
1961     (unless sort (setq sort org-index--last-sort)) ; use default value
1962
1963     (when (or with-ref
1964               (eq sort 'ref))
1965       ;; get reference with leading zeroes, so it can be
1966       ;; sorted as text
1967       (setq ref-field (org-index--get-or-set-field 'ref))
1968       (if ref-field
1969           (progn
1970             (string-match org-index--ref-regex ref-field)
1971             (setq ref (format
1972                        "%06d"
1973                        (string-to-number
1974                         (match-string 1 ref-field)))))
1975         (setq ref "000000")))
1976
1977     (setq key
1978           (cond
1979            ((eq sort 'count)
1980             (format "%08d" (string-to-number (or (org-index--get-or-set-field 'count) ""))))
1981            ((eq sort 'mixed)
1982             (let ((last-accessed (org-index--get-or-set-field 'last-accessed)))
1983               (unless mixed-time (setq mixed-time (org-index--get-mixed-time)))
1984               (concat
1985                (if (string< mixed-time last-accessed) last-accessed mixed-time)
1986                (format "%08d" (string-to-number (or (org-index--get-or-set-field 'count) ""))))))
1987            ((eq sort 'ref)
1988             ref)
1989            ((memq sort '(id last-accessed created))
1990             (org-index--get-or-set-field sort))
1991            (t (error "This is a bug: unmatched case '%s'" sort))))
1992
1993     (if with-ref (setq key (concat key ref)))
1994
1995     key))
1996
1997
1998 (defun org-index--get-or-set-field (key &optional value)
1999   "Retrieve field KEY from index table or set it to VALUE."
2000   (let (field)
2001     (save-excursion
2002       (if (eq key 'fingerprint)
2003           (progn
2004             (if value (error "Internal error, pseudo-column fingerprint cannot be set"))
2005             (setq field (org-index--get-fingerprint)))
2006         (setq field (org-trim (org-table-get-field (cdr (assoc key org-index--columns)) value))))
2007       (if (string= field "") (setq field nil))
2008
2009       (org-no-properties field))))
2010
2011
2012 (defun org-index--column-num (key)
2013   "Return number of column KEY."
2014   (if (numberp key)
2015       key
2016     (cdr (assoc key org-index--columns))))
2017
2018
2019 (defun org-index--make-guarded-search (ref &optional dont-quote)
2020   "Make robust search string from REF; DONT-QUOTE it, if requested."
2021   (concat "\\_<" (if dont-quote ref (regexp-quote ref)) "\\_>"))
2022
2023
2024 (defun org-index--find-duplicates ()
2025   "Find duplicate references or ids in index table."
2026   (let (ref-duplicates id-duplicates)
2027
2028     (setq ref-duplicates (org-index--find-duplicates-helper 'ref))
2029     (setq id-duplicates (org-index--find-duplicates-helper 'id))
2030     (goto-char org-index--below-hline)
2031     (if (or ref-duplicates id-duplicates)
2032         (progn
2033           ;; show results
2034           (pop-to-buffer-same-window
2035            (get-buffer-create "*org-index-duplicates*"))
2036           (when ref-duplicates
2037             (insert "These references appear more than once:\n")
2038             (mapc (lambda (x) (insert "  " x "\n")) ref-duplicates)
2039             (insert "\n\n"))
2040           (when id-duplicates
2041             (insert "These ids appear more than once:\n")
2042             (mapc (lambda (x) (insert "  " x "\n")) id-duplicates))
2043
2044           "Some references or ids are duplicates")
2045       "No duplicate references or ids found")))
2046
2047
2048 (defun org-index--find-duplicates-helper (column)
2049   "Helper for `org-index--find-duplicates': Go through table and count given COLUMN."
2050   (let (counts duplicates field found)
2051
2052     ;; go through table
2053     (goto-char org-index--below-hline)
2054     (while (org-at-table-p)
2055
2056       ;; get column
2057       (setq field (org-index--get-or-set-field column))
2058
2059       ;; and increment
2060       (setq found (assoc field counts))
2061       (if found
2062           (cl-incf (cdr found))
2063         (setq counts (cons (cons field 1) counts)))
2064
2065       (forward-line))
2066
2067     (mapc (lambda (x) (if (and (> (cdr x) 1)
2068                           (car x))
2069                      (setq duplicates (cons (car x) duplicates)))) counts)
2070
2071     duplicates))
2072
2073
2074 (defun org-index--do-statistics ()
2075   "Compute statistics about index table."
2076   (let ((total-lines 0) (total-refs 0)
2077         ref ref-field min max message)
2078
2079     ;; go through table
2080     (goto-char org-index--below-hline)
2081     (while (org-at-table-p)
2082
2083       ;; get ref
2084       (setq ref-field (org-index--get-or-set-field 'ref))
2085
2086       (when ref-field
2087         (string-match org-index--ref-regex ref-field)
2088         (setq ref (string-to-number (match-string 1 ref-field)))
2089
2090         ;; record min and max
2091         (if (or (not min) (< ref min)) (setq min ref))
2092         (if (or (not max) (> ref max)) (setq max ref))
2093
2094         (setq total-refs (1+ total-refs)))
2095
2096       ;; count
2097       (setq total-lines (1+ total-lines))
2098
2099       (forward-line))
2100
2101     (setq message (format "%d Lines in index table. First reference is %s, last %s; %d of them are used (%d percent)"
2102                           total-lines
2103                           (format org-index--ref-format min)
2104                           (format org-index--ref-format max)
2105                           total-refs
2106                           (truncate (* 100 (/ (float total-refs) (1+ (- max min)))))))
2107
2108     (goto-char org-index--below-hline)
2109     message))
2110
2111
2112 (defun org-index--do-add-or-update (&optional create-ref tag-with-ref)
2113   "For current node or current line in index, add or update in index table.
2114 CREATE-REF and TAG-WITH-REF if given."
2115
2116   (let* (id id-from-index ref args yank ret)
2117
2118     (org-index--save-positions)
2119     (unless (or org-index--within-index-node
2120                 org-index--within-occur)
2121       (org-back-to-heading))
2122
2123     ;; try to do the same things from within index and from outside
2124     (if org-index--within-index-node
2125
2126         (progn
2127           (unless (org-at-table-p)
2128             (error "Within index node but not on table"))
2129
2130           (setq id (org-index--get-or-set-field 'id))
2131           (setq ref (org-index--get-or-set-field 'ref))
2132           (setq args (org-index--collect-values-for-add-update-remote id))
2133           (org-index--write-fields args)
2134           (setq yank (org-index--get-or-set-field org-index-yank-after-add))
2135
2136           (setq ret
2137                 (if ref
2138                     (cons (format "Updated index line %s" ref) yank)
2139                   (cons "Updated index line" nil))))
2140
2141       (setq id (org-id-get-create))
2142       (org-index--refresh-parse-table)
2143       (setq id-from-index (org-index--on 'id id id))
2144       (setq ref (org-index--on 'id id (org-index--get-or-set-field 'ref)))
2145
2146       (if tag-with-ref
2147           (org-toggle-tag (format "%s%d%s" org-index--head tag-with-ref org-index--tail) 'on))
2148       (setq args (org-index--collect-values-for-add-update id))
2149
2150       (when (and create-ref
2151                  (not ref))
2152         (setq ref org-index--nextref)
2153         (setq args (plist-put args 'ref ref)))
2154
2155
2156       (if id-from-index
2157           ;; already have an id in index, find it and update fields
2158           (progn
2159
2160             (org-index--on
2161                 'id id
2162                 (org-index--write-fields args)
2163                 (setq yank (org-index--get-or-set-field org-index-yank-after-add)))
2164
2165             (setq ret
2166                   (if ref
2167                       (cons (format "Updated index line %s" ref) yank)
2168                     (cons "Updated index line" nil))))
2169
2170         ;; no id here, create new line in index
2171         (if ref (setq ref (plist-put args 'ref org-index--nextref)))
2172         (setq yank (apply 'org-index--do-new-line args))
2173
2174         (setq ret
2175               (if ref
2176                   (cons
2177                    (format "Added new index line %s" ref)
2178                    (concat yank " "))
2179                 (cons
2180                  "Added new index line"
2181                  nil)))))
2182
2183     (org-index--restore-positions)
2184
2185     ret))
2186
2187
2188 (defun org-index--check-ids ()
2189   "Check, that ids really point to a node."
2190
2191   (let ((lines 0)
2192         id ids marker)
2193
2194     (goto-char org-index--below-hline)
2195
2196     (catch 'problem
2197       (while (org-at-table-p)
2198
2199         (when (setq id (org-index--get-or-set-field 'id))
2200
2201           ;; check for double ids
2202           (when (member id ids)
2203             (org-table-goto-column (org-index--column-num 'id))
2204             (throw 'problem "This id appears twice in index; please use command 'maintain' to check for duplicate ids"))
2205           (cl-incf lines)
2206           (setq ids (cons id ids))
2207
2208           ;; check, if id is valid
2209           (setq marker (org-id-find id t))
2210           (unless marker
2211             (org-table-goto-column (org-index--column-num 'id))
2212             (throw 'problem "This id cannot be found")))
2213
2214         (forward-line))
2215
2216       (goto-char org-index--below-hline)
2217       nil)))
2218
2219
2220 (defun org-index--update-all-lines ()
2221   "Update all lines of index at once."
2222
2223   (let ((lines 0)
2224         id ref kvs)
2225
2226     ;; check for double ids
2227     (or
2228      (org-index--check-ids)
2229
2230      (progn
2231        (goto-char org-index--below-hline)
2232        (while (org-at-table-p)
2233
2234          ;; update single line
2235          (when (setq id (org-index--get-or-set-field 'id))
2236            (setq ref (org-index--get-or-set-field 'ref))
2237            (setq kvs (org-index--collect-values-for-add-update-remote id))
2238            (org-index--write-fields kvs)
2239            (cl-incf lines))
2240          (forward-line))
2241
2242        (goto-char org-index--below-hline)
2243        (org-table-align)
2244        (format "Updated %d lines" lines)))))
2245
2246
2247 (defun org-index--collect-values-for-add-update (id &optional silent category)
2248   "Collect values for adding or updating line specified by ID, do not ask if SILENT, use CATEGORY, if given."
2249
2250   (let ((args (list 'id id))
2251         content)
2252
2253     (dolist (col (mapcar 'car org-index--columns))
2254
2255       (setq content "")
2256
2257       (cond
2258        ((eq col 'keywords)
2259         (if org-index-copy-heading-to-keywords
2260             (setq content (nth 4 (org-heading-components))))
2261
2262         ;; Shift ref and timestamp ?
2263         (if org-index-strip-ref-and-date-from-heading
2264             (dotimes (i 2)
2265               (if (or (string-match (concat "^\\s-*" org-index--ref-regex) content)
2266                       (string-match (concat "^\\s-*" org-ts-regexp-both) content))
2267                   (setq content (substring content (match-end 0)))))))
2268
2269        ((eq col 'category)
2270         (setq content (or category org-index--category-before)))
2271
2272        ((eq col 'level)
2273         (setq content (number-to-string (org-outline-level))))
2274
2275        ((eq col 'tags)
2276         (setq content (org-get-tags-string))))
2277
2278       (unless (string= content "")
2279         (setq args (plist-put args col content))))
2280
2281     (if (not silent)
2282         (let ((args-edited (org-index--collect-values-from-user org-index-edit-on-add args)))
2283           (setq args (append args-edited args))))
2284
2285     args))
2286
2287
2288 (defun org-index--collect-values-for-add-update-remote (id)
2289   "Wrap `org-index--collect-values-for-add-update' by prior moving to remote node identified by ID."
2290
2291   (let (marker point args)
2292
2293     (setq marker (org-id-find id t))
2294     ;; enter buffer and collect information
2295     (with-current-buffer (marker-buffer marker)
2296       (setq point (point))
2297       (goto-char marker)
2298       (setq args (org-index--collect-values-for-add-update id t (org-get-category (point) t)))
2299       (goto-char point))
2300
2301     args))
2302
2303
2304 (defun org-index--collect-values-from-user (cols &optional defaults)
2305   "Collect values for adding a new yank-line.
2306 Argument COLS gives list of columns to edit.
2307 Optional argument DEFAULTS gives default values."
2308
2309   (let (content args)
2310
2311     (dolist (col cols)
2312
2313       (setq content "")
2314
2315       (setq content (read-from-minibuffer
2316                      (format "Enter text for column '%s': " (symbol-name col))
2317                      (plist-get col defaults)))
2318
2319       (unless (string= content "")
2320         (setq args (plist-put args col content))))
2321     args))
2322
2323
2324 (defun org-index--write-fields (kvs)
2325   "Update current line with values from KVS (keys-values)."
2326   (while kvs
2327     (org-index--get-or-set-field (car kvs) (org-trim (cadr kvs)))
2328     (setq kvs (cddr kvs))))
2329
2330
2331 (defun org-index--do-kill ()
2332   "Perform command kill from within occur, index or node."
2333
2334   (let (id ref chars-deleted-index text-deleted-from pos-in-index)
2335
2336     (org-index--save-positions)
2337     (unless (or org-index--within-index-node
2338                 org-index--within-occur)
2339       (org-back-to-heading))
2340
2341     ;; Collect information: What should be deleted ?
2342     (if (or org-index--within-occur
2343             org-index--within-index-node)
2344
2345         (progn
2346           (if org-index--within-index-node
2347               ;; In index
2348               (setq pos-in-index (point))
2349             ;; In occur
2350             (setq pos-in-index (get-text-property (point) 'org-index-lbp))
2351             (org-index--occur-test-stale pos-in-index)
2352             (set-buffer org-index--buffer)
2353             (goto-char pos-in-index))
2354           ;; In Index (maybe moved there)
2355           (setq id (org-index--get-or-set-field 'id))
2356           (setq ref (org-index--get-or-set-field 'ref)))
2357
2358       ;; At a headline
2359       (setq id (org-entry-get (point) "ID"))
2360       (setq ref (org-index--ref-from-id id))
2361       (setq pos-in-index (org-index--on 'id id (point)))
2362       (unless pos-in-index (error "This node is not in index")))
2363
2364     ;; Remark: Current buffer is not certain here, but we have all the information to delete
2365
2366     ;; Delete from node
2367     (when id
2368       (let ((m (org-id-find id 'marker)))
2369         (set-buffer (marker-buffer m))
2370         (goto-char m)
2371         (move-marker m nil)
2372         (unless (string= (org-id-get) id)
2373           (error "Could not find node with id %s" id)))
2374
2375       (org-index--delete-any-ref-from-tags)
2376       (if ref (org-index--delete-ref-from-heading ref))
2377       (setq text-deleted-from (cons "node" text-deleted-from)))
2378
2379     ;; Delete from index
2380     (set-buffer org-index--buffer)
2381     (unless pos-in-index "Internal error, pos-in-index should be defined here")
2382     (goto-char pos-in-index)
2383     (setq chars-deleted-index (length (delete-and-extract-region (line-beginning-position) (line-beginning-position 2))))
2384     (setq text-deleted-from (cons "index" text-deleted-from))
2385
2386     ;; Delete from occur only if we started there, accept that it will be stale otherwise
2387     (if org-index--within-occur
2388         (let ((inhibit-read-only t))
2389           (set-buffer org-index--occur-buffer-name)
2390           (delete-region (line-beginning-position) (line-beginning-position 2))
2391           ;; correct positions
2392           (while (org-at-table-p)
2393             (put-text-property (line-beginning-position) (line-end-position) 'org-index-lbp
2394                                (- (get-text-property (point) 'org-index-lbp) chars-deleted-index))
2395             (forward-line))
2396           (setq text-deleted-from (cons "occur" text-deleted-from))))
2397
2398     (org-index--restore-positions)
2399     (concat "Deleted from: " (mapconcat 'identity (sort text-deleted-from 'string<) ","))))
2400
2401
2402 (defun org-index--save-positions ()
2403   "Save current buffer and positions in index- and current buffer; not in occur-buffer."
2404
2405   (let (cur-buf cur-mrk idx-pnt idx-mrk)
2406     (setq cur-buf (current-buffer))
2407     (setq cur-mrk (point-marker))
2408     (set-buffer org-index--buffer)
2409     (if (string= (org-id-get) org-index-id)
2410         (setq idx-pnt (point))
2411       (setq idx-mrk (point-marker)))
2412     (set-buffer cur-buf)
2413     (setq org-index--saved-positions (list cur-buf cur-mrk idx-pnt idx-mrk))))
2414
2415
2416 (defun org-index--restore-positions ()
2417   "Restore positions as saved by `org-index--save-positions'."
2418
2419   (cl-multiple-value-bind
2420       (cur-buf cur-mrk idx-pnt idx-mrk buf)
2421       org-index--saved-positions
2422     (setq buf (current-buffer))
2423     (set-buffer cur-buf)
2424     (goto-char cur-mrk)
2425     (set-buffer org-index--buffer)
2426     (goto-char (or idx-pnt idx-mrk))
2427     (set-buffer buf))
2428   (setq org-index--saved-positions nil))
2429
2430
2431 (defun org-index--delete-ref-from-heading (ref)
2432   "Delete given REF from current heading."
2433   (save-excursion
2434     (end-of-line)
2435     (let ((end (point)))
2436       (beginning-of-line)
2437       (when (search-forward ref end t)
2438         (delete-char (- (length ref)))
2439         (just-one-space)))))
2440
2441
2442 (defun org-index--delete-any-ref-from-tags ()
2443   "Delete any reference from list of tags."
2444   (let (new-tags)
2445     (mapc (lambda (tag)
2446             (unless (string-match org-index--ref-regex tag)
2447               (setq new-tags (cons tag new-tags) )))
2448           (org-get-tags))
2449     (org-set-tags-to new-tags)))
2450
2451
2452 (defun org-index--go (&optional column value)
2453   "Position cursor on index line where COLUMN equals VALUE.
2454 Return t or nil, leave point on line or at top of table, needs to be in buffer initially."
2455   (let (found)
2456
2457     (unless (eq (current-buffer) org-index--buffer)
2458       (error "This is a bug: Not in index buffer"))
2459
2460     ;; loop over lines
2461     (goto-char org-index--below-hline)
2462     (if column
2463         (progn
2464           (forward-line -1)
2465           (while (and (not found)
2466                       (forward-line)
2467                       (org-at-table-p))
2468             (setq found (string= value (org-index--get-or-set-field column)))))
2469       (setq found t))
2470
2471     ;; return value
2472     (if found
2473         t
2474       (goto-char org-index--below-hline)
2475       nil)))
2476
2477
2478 (defun org-index--find-id (id &optional other)
2479   "Perform command head: Find node with REF or ID and present it.
2480 If OTHER in separate window."
2481
2482   (let (message marker)
2483
2484     (setq marker (org-id-find id t))
2485
2486     (if marker
2487         (progn
2488           (org-index--update-line id)
2489           (if other
2490               (progn
2491                 (pop-to-buffer (marker-buffer marker)))
2492             (pop-to-buffer-same-window (marker-buffer marker)))
2493
2494           (goto-char marker)
2495           (org-reveal t)
2496           (org-show-entry)
2497           (recenter)
2498           (unless (string= (org-id-get) id)
2499             (setq message (format "Could not go to node with id %s (narrowed ?)" id)))
2500           (setq message "Found headline"))
2501       (setq message (format "Did not find node with %s" id)))
2502     message))
2503
2504
2505 (defun org-index--do-occur ()
2506   "Perform command occur."
2507   (let ((word "") ; last word to search for growing and shrinking on keystrokes
2508         (prompt "Search for: ")
2509         (these-commands " NOTE: If you invoke the org-index subcommands edit or kill from within the occur buffer, the index is updated accordingly.")
2510         (lines-wanted (window-body-height))
2511         (lines-found 0)                      ; number of lines found
2512         words                                ; list words that should match
2513         occur-buffer
2514         begin ; position of first line
2515         narrow                         ; start of narrowed buffer
2516         help-text                      ; cons with help text short and long
2517         search-text                    ; description of text to search for
2518         done                           ; true, if loop is done
2519         in-c-backspace                 ; true, while processing C-backspace
2520         help-overlay                   ; Overlay with help text
2521         last-point                     ; Last position before end of search
2522         initial-frame                  ; Frame when starting occur
2523         key                            ; input from user in various forms
2524         key-sequence
2525         key-sequence-raw)
2526
2527
2528     ;; make and show buffer
2529     (if (get-buffer org-index--occur-buffer-name)
2530         (kill-buffer org-index--occur-buffer-name))
2531     (setq occur-buffer (make-indirect-buffer org-index--buffer org-index--occur-buffer-name))
2532     (pop-to-buffer-same-window occur-buffer)
2533     (setq initial-frame (selected-frame))
2534
2535     ;; avoid modifying direct buffer
2536     (setq buffer-read-only t)
2537     (toggle-truncate-lines 1)
2538     (setq font-lock-keywords-case-fold-search t)
2539     (setq case-fold-search t)
2540
2541     ;; reset stack and overlays
2542     (setq org-index--occur-stack nil)
2543     (setq org-index--occur-tail-overlay nil)
2544
2545     ;; narrow to table rows and one line before
2546     (goto-char org-index--below-hline)
2547     (forward-line 0)
2548     (setq begin (point))
2549     (forward-line -1)
2550     (setq narrow (point))
2551     (while (org-at-table-p)
2552       (forward-line))
2553     (narrow-to-region narrow (point))
2554     (goto-char (point-min))
2555     (forward-line)
2556
2557     ;; initialize help text
2558     (setq help-text (cons
2559                      (concat
2560                       (propertize "Incremental occur" 'face 'org-todo)
2561                       (propertize  "; ? toggles help and headlines.\n" 'face 'org-agenda-dimmed-todo-face))
2562                      (concat
2563                       (propertize
2564                        (org-index--wrap
2565                         (concat
2566                          "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"))
2567                        'face 'org-agenda-dimmed-todo-face)
2568                       org-index--headings)))
2569
2570     ;; insert overlays for help text and to cover unsearched lines
2571     (setq help-overlay (make-overlay (point-min) begin))
2572     (overlay-put help-overlay 'display (car help-text))
2573     (setq org-index--occur-tail-overlay (make-overlay (point-max) (point-max)))
2574     (overlay-put org-index--occur-tail-overlay 'invisible t)
2575
2576     (while (not done)
2577
2578       (if in-c-backspace
2579           (setq key "<backspace>")
2580         (setq search-text (mapconcat 'identity (reverse (cons word words)) ","))
2581                         (message "foo")
2582
2583         ;; read key, if selected frame has not changed
2584         (if (eq initial-frame (selected-frame))
2585             (progn
2586               (setq key-sequence
2587                     (let ((echo-keystrokes 0)
2588                           (full-prompt (format "%s%s%s"
2589                                                prompt
2590                                                search-text
2591                                                (if (string= search-text "") "" " "))))
2592                       (read-key-sequence full-prompt nil nil t t)))
2593               (setq key (key-description key-sequence))
2594               (setq key-sequence-raw (this-single-command-raw-keys)))
2595           (setq done t)
2596           (setq key-sequence nil)
2597           (setq key nil)
2598           (setq key-sequence-raw nil)))
2599
2600
2601       (cond
2602
2603
2604        ((string= key "<C-backspace>")
2605         (setq in-c-backspace t))
2606
2607
2608        ((member key (list "<backspace>" "DEL"))   ; erase last char
2609
2610         (if (= (length word) 0)
2611
2612             ;; nothing more to delete from current word; try next
2613             (progn
2614               (setq word (car words))
2615               (setq words (cdr words))
2616               (setq in-c-backspace nil))
2617
2618           ;; unhighlight longer match
2619           (unhighlight-regexp (regexp-quote word))
2620
2621           ;; some chars are left; shorten word
2622           (setq word (substring word 0 -1))
2623           (when (= (length word) 0) ; when nothing left, use next word from list
2624             (setq word (car words))
2625             (setq words (cdr words))
2626             (setq in-c-backspace nil))
2627
2628           ;; free top list of overlays and remove list
2629           (setq lines-found (or (org-index--unhide) lines-wanted))
2630           (move-overlay org-index--occur-tail-overlay
2631                         (if org-index--occur-stack (cdr (assq :end-of-visible (car org-index--occur-stack)))
2632                           (point-max))
2633                         (point-max))
2634
2635
2636           ;; highlight shorter word
2637           (unless (= (length word) 0)
2638             (highlight-regexp (regexp-quote word) 'isearch))
2639
2640           ;; make sure, point is still visible
2641           (goto-char begin)))
2642
2643
2644        ((member key (list "SPC" ",")) ; space or comma: enter an additional search word
2645
2646         ;; push current word and clear, no need to change display
2647         (unless (string= word "")
2648           (setq words (cons word words))
2649           (setq word "")))
2650
2651
2652        ((string= key "?") ; question mark: toggle display of headlines and help
2653         (setq help-text (cons (cdr help-text) (car help-text)))
2654         (overlay-put help-overlay 'display (car help-text)))
2655
2656        ((and (= (length key) 1)
2657              (aref printable-chars (elt key 0))) ; any printable char: add to current search word
2658
2659         ;; unhighlight short word
2660         (unless (= (length word) 0)
2661           (unhighlight-regexp (regexp-quote word)))
2662
2663         ;; add to word
2664         (setq word (concat word key))
2665
2666         ;; make overlays to hide lines, that do not match longer word any more
2667         (goto-char begin)
2668         (setq lines-found (org-index--hide-with-overlays (cons word words) lines-wanted))
2669         (move-overlay org-index--occur-tail-overlay
2670                       (if org-index--occur-stack (cdr (assq :end-of-visible (car org-index--occur-stack)))
2671                         (point-max))
2672                       (point-max))
2673
2674         (goto-char begin)
2675
2676         ;; highlight longer word
2677         (highlight-regexp (regexp-quote word) 'isearch)
2678
2679         ;; make sure, point is on a visible line
2680         (line-move -1 t)
2681         (line-move 1 t))
2682
2683        ;; anything else terminates loop
2684        (t (setq done t))))
2685
2686     ;; put back input event, that caused the loop to end
2687     (unless (string= key "C-g")
2688       (setq unread-command-events (listify-key-sequence key-sequence-raw))
2689       (message key))
2690
2691     ;; postprocessing
2692     (setq last-point (point))
2693
2694     ;; For performance reasons do not show matching lines for rest of table. So no code here.
2695
2696     ;; make permanent copy
2697     ;; copy visible lines
2698     (let ((lines-collected 0)
2699           keymap line all-lines all-lines-lbp header-lines lbp)
2700
2701       (setq cursor-type t)
2702       (goto-char begin)
2703
2704       ;; collect all visible lines
2705       (while (and (not (eobp))
2706                   (< lines-collected lines-wanted))
2707         ;; skip over invisible lines
2708         (while (and (invisible-p (point))
2709                     (not (eobp)))
2710           (goto-char (1+ (overlay-end (car (overlays-at (point)))))))
2711         (setq lbp (line-beginning-position))
2712         (setq line (buffer-substring-no-properties lbp (line-end-position)))
2713         (unless (string= line "")
2714           (cl-incf lines-collected)
2715           (setq all-lines (cons (concat line
2716                                         "\n")
2717                                 all-lines))
2718           (setq all-lines-lbp (cons lbp all-lines-lbp)))
2719         (forward-line 1))
2720
2721       (kill-buffer org-index--occur-buffer-name) ; cannot keep this buffer; might become stale soon
2722
2723       ;; create new buffer
2724       (setq occur-buffer (get-buffer-create org-index--occur-buffer-name))
2725       (pop-to-buffer-same-window occur-buffer)
2726       (insert org-index--headings)
2727       (setq header-lines (line-number-at-pos))
2728
2729       ;; insert into new buffer
2730       (save-excursion
2731         (apply 'insert (reverse all-lines))
2732         (if (= lines-collected lines-wanted)
2733             (insert "\n(more lines omitted)\n")))
2734       (setq org-index--occur-lines-collected lines-collected)
2735
2736       (org-mode)
2737       (setq truncate-lines t)
2738       (if all-lines (org-index--align-and-fontify-current-line (length all-lines)))
2739       (font-lock-ensure)
2740       (font-lock-flush)
2741       (when all-lines-lbp
2742           (while (not (org-at-table-p))
2743             (forward-line -1))
2744           (while all-lines-lbp
2745             (put-text-property (line-beginning-position) (line-end-position) 'org-index-lbp (car all-lines-lbp))
2746             (setq all-lines-lbp (cdr all-lines-lbp))
2747             (forward-line -1)))
2748
2749       ;; prepare help text
2750       (goto-char (point-min))
2751       (forward-line (1- header-lines))
2752       (setq org-index--occur-help-overlay (make-overlay (point-min) (point)))
2753       (setq org-index--occur-help-text
2754             (cons
2755              (org-index--wrap
2756               (propertize "Search is done;    ? toggles help and headlines.\n" 'face 'org-agenda-dimmed-todo-face))
2757              (concat
2758               (org-index--wrap
2759                (propertize
2760                 (format
2761                  (concat "Search is done."
2762                          (if (< lines-collected lines-wanted)
2763                              " Showing all %d matches for "
2764                            " Showing one window of matches for ")
2765                          "\"" search-text
2766                          "\". <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")
2767                  (length all-lines))
2768                 'face 'org-agenda-dimmed-todo-face))
2769               org-index--headings)))
2770
2771       (overlay-put org-index--occur-help-overlay 'display (car org-index--occur-help-text))
2772
2773       ;; highlight words
2774       (setq case-fold-search t)
2775       (setq font-lock-keywords-case-fold-search t)
2776       (mapc (lambda (w) (unless (or (not w) (string= w "")) (highlight-regexp (regexp-quote w) 'isearch)))
2777             (cons word words))
2778
2779       (setq buffer-read-only t)
2780
2781       ;; install keyboard-shortcuts
2782       (setq keymap (make-sparse-keymap))
2783       (set-keymap-parent keymap org-mode-map)
2784
2785       (mapc (lambda (x) (define-key keymap (kbd x)
2786                      (lambda () (interactive)
2787                        (message "%s" (org-index--occur-action)))))
2788             (list "<return>" "RET"))
2789
2790       (define-key keymap (kbd "<tab>")
2791         (lambda () (interactive)
2792           (message (org-index--occur-action t))))
2793
2794       (define-key keymap (kbd "SPC")
2795         (lambda () (interactive)
2796           (org-index--refresh-parse-table)
2797           ;; increment in index
2798           (let ((ref (org-index--get-or-set-field 'ref))
2799                 count)
2800             (org-index--on
2801                 'ref ref
2802                 (setq count (+ 1 (string-to-number (org-index--get-or-set-field 'count))))
2803                 (org-index--get-or-set-field 'count (number-to-string count))
2804                 (org-index--promote-current-line)
2805                 (org-index--align-and-fontify-current-line))
2806             ;; increment in this buffer
2807             (let ((inhibit-read-only t))
2808               (org-index--get-or-set-field 'count (number-to-string count)))
2809             (message "Incremented count to %d" count))))
2810
2811       (define-key keymap (kbd "<S-return>")
2812         (lambda () (interactive)
2813           (let ((pos (get-text-property (point) 'org-index-lbp)))
2814             (org-index--refresh-parse-table)
2815             (org-index--occur-test-stale pos)
2816             (pop-to-buffer org-index--buffer)
2817             (goto-char pos)
2818             (org-reveal t)
2819             (org-index--update-current-line)
2820             (beginning-of-line))))
2821
2822       (define-key keymap (kbd "?")
2823         (lambda () (interactive)
2824           (org-index--refresh-parse-table)
2825           (setq-local org-index--occur-help-text (cons (cdr org-index--occur-help-text) (car org-index--occur-help-text)))
2826           (overlay-put org-index--occur-help-overlay 'display (car org-index--occur-help-text))))
2827
2828       (use-local-map keymap))))
2829
2830
2831 (defun org-index--occur-test-stale (pos)
2832   "Test, if current line in occur buffer has become stale at POS."
2833   (let (here there)
2834     (org-index--refresh-parse-table)
2835     (setq here (org-index--line-in-canonical-form))
2836     (with-current-buffer org-index--buffer
2837       (goto-char pos)
2838       (setq there (org-index--line-in-canonical-form)))
2839     (unless (string= here there)
2840       (error "Occur buffer has become stale"))))
2841
2842
2843 (defun org-index--line-in-canonical-form ()
2844   "Return current line in its canonical form."
2845   (org-trim (substring-no-properties (replace-regexp-in-string "\s +" " " (buffer-substring (line-beginning-position) (line-beginning-position 2))))))
2846
2847
2848 (defun org-index--wrap (text)
2849   "Wrap TEXT at fill column."
2850   (with-temp-buffer
2851     (insert text)
2852     (fill-region (point-min) (point-max) nil t)
2853     (buffer-string)))
2854
2855
2856 (defun org-index--occur-action (&optional other)
2857   "Helper for `org-index--occur', find heading with ref or id; if OTHER, in other window; or copy yank column."
2858   (if (org-at-table-p)
2859       (let ((id (org-index--get-or-set-field 'id))
2860             (ref (org-index--get-or-set-field 'ref))
2861             (yank (org-index--get-or-set-field 'yank)))
2862         (if id
2863             (org-index--find-id id other)
2864           (if ref
2865               (progn
2866                 (org-mark-ring-goto)
2867                 (format "Found reference %s (no node is associated)" ref))
2868             (if yank
2869                 (progn
2870                   (org-index--update-line (get-text-property (point) 'org-index-lbp))
2871                   (setq yank (replace-regexp-in-string (regexp-quote "\\vert") "|" yank nil 'literal))
2872                   (kill-new yank)
2873                   (org-mark-ring-goto)
2874                   (format "Copied '%s' (no node is associated)" yank))
2875               (error "Internal error, this line contains neither id, nor reference, nor text to yank")))))
2876     (message "Not at table")))
2877
2878
2879 (defun org-index--hide-with-overlays (words lines-wanted)
2880   "Hide text that is currently visible and does not match WORDS by creating overlays; leave LINES-WANTED lines visible."
2881   (let ((lines-found 0)
2882         (end-of-visible (point))
2883         overlay overlays start matched)
2884
2885     ;; main loop
2886     (while (and (not (eobp))
2887                 (< lines-found lines-wanted))
2888
2889       ;; skip invisible lines
2890       (while (and (not (eobp))
2891                   (and
2892                    (invisible-p (point))
2893                    (< (point) (overlay-start org-index--occur-tail-overlay))))
2894         (goto-char (overlay-end (car (overlays-at (point))))))
2895
2896       ;; find stretch of lines, that are currently visible but should be invisible now
2897       (setq matched nil)
2898       (setq start (point))
2899       (while (and (not (eobp))
2900                   (not
2901                    (and
2902                     (invisible-p (point))
2903                     (< (point) (overlay-start org-index--occur-tail-overlay))))
2904                   (not (and (org-index--test-words words)
2905                             (setq matched t)))) ; for its side effect
2906         (forward-line 1))
2907
2908       ;; create overlay to hide this stretch
2909       (when (< start (point))           ; avoid creating an empty overlay
2910         (setq overlay (make-overlay start (point)))
2911         (overlay-put overlay 'invisible t)
2912         (setq overlays (cons overlay overlays)))
2913
2914       ;; skip and count line, that matched
2915       (when matched
2916         (forward-line 1)
2917         (setq end-of-visible (point))
2918         (cl-incf lines-found)))
2919
2920     ;; put new list on top of stack
2921     (setq org-index--occur-stack
2922           (cons (list (cons :overlays overlays)
2923                       (cons :end-of-visible end-of-visible)
2924                       (cons :lines lines-found))
2925                 org-index--occur-stack))
2926
2927     lines-found))
2928
2929
2930 (defun org-index--unhide ()
2931   "Unhide text that does has been hidden by `org-index--hide-with-overlays'."
2932   (when org-index--occur-stack
2933     ;; delete overlays and make visible again
2934     (mapc (lambda (y)
2935             (delete-overlay y))
2936           (cdr (assq :overlays (car org-index--occur-stack))))
2937           ;; remove from stack
2938     (setq org-index--occur-stack (cdr org-index--occur-stack))
2939     ;; return number of lines, that are now visible
2940     (if org-index--occur-stack (cdr (assq :lines (car org-index--occur-stack))))))
2941
2942
2943 (defun org-index--test-words (words)
2944   "Test current line for match against WORDS."
2945   (let (line)
2946     (setq line (downcase (buffer-substring (line-beginning-position) (line-beginning-position 2))))
2947     (catch 'not-found
2948       (dolist (w words)
2949         (or (cl-search w line)
2950             (throw 'not-found nil)))
2951       t)))
2952
2953
2954 (defun org-index--create-new-line ()
2955   "Do the common work for `org-index-new-line' and `org-index'."
2956
2957   ;; insert ref or id as last or first line, depending on sort-column
2958   (goto-char org-index--below-hline)
2959   (if (eq org-index-sort-by 'count)
2960       (progn
2961         (while (org-at-table-p)
2962           (forward-line))
2963         (forward-line -1)
2964         (org-table-insert-row t))
2965     (org-table-insert-row))
2966
2967   ;; insert some of the standard values
2968   (org-table-goto-column (org-index--column-num 'created))
2969   (org-insert-time-stamp nil nil t)
2970   (org-table-goto-column (org-index--column-num 'count))
2971   (insert "1"))
2972
2973
2974 (defun org-index--sort-silent ()
2975   "Sort index for default column to remove any effects of temporary sorting."
2976   (save-excursion
2977     (org-index--verify-id)
2978     (org-index--parse-table)
2979     (org-index--on nil nil
2980       (org-index--do-sort-index org-index-sort-by)
2981       (org-table-align)
2982       (remove-hook 'before-save-hook 'org-index--sort-silent))))
2983
2984
2985 (defun org-index--copy-visible (beg end)
2986   "Copy the visible parts of the region between BEG and END without adding it to `kill-ring'; copy of `org-copy-visible'."
2987   (let (snippets s)
2988     (save-excursion
2989       (save-restriction
2990         (narrow-to-region beg end)
2991         (setq s (goto-char (point-min)))
2992         (while (not (= (point) (point-max)))
2993           (goto-char (org-find-invisible))
2994           (push (buffer-substring s (point)) snippets)
2995           (setq s (goto-char (org-find-visible))))))
2996     (apply 'concat (nreverse snippets))))
2997
2998
2999 (provide 'org-index)
3000
3001 ;; Local Variables:
3002 ;; fill-column: 75
3003 ;; comment-column: 50
3004 ;; End:
3005
3006 ;;; org-index.el ends here