contrib/lisp/org-index.el

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