contrib/lisp/org-index.el

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