diff options
Diffstat (limited to 'lisp/textmodes')
| -rw-r--r-- | lisp/textmodes/org.el | 15101 |
1 files changed, 8733 insertions, 6368 deletions
diff --git a/lisp/textmodes/org.el b/lisp/textmodes/org.el index a55bcdd7e25..313748e8e43 100644 --- a/lisp/textmodes/org.el +++ b/lisp/textmodes/org.el | |||
| @@ -1,11 +1,11 @@ | |||
| 1 | ;;; org.el --- Outline-based notes management and organize | 1 | ;;;; org.el --- Outline-based notes management and organize |
| 2 | ;; Carstens outline-mode for keeping track of everything. | 2 | ;; Carstens outline-mode for keeping track of everything. |
| 3 | ;; Copyright (C) 2004, 2005, 2006, 2007 Free Software Foundation, Inc. | 3 | ;; Copyright (C) 2004, 2005, 2006, 2007 Free Software Foundation, Inc. |
| 4 | ;; | 4 | ;; |
| 5 | ;; Author: Carsten Dominik <dominik at science dot uva dot nl> | 5 | ;; Author: Carsten Dominik <dominik at science dot uva dot nl> |
| 6 | ;; Keywords: outlines, hypermedia, calendar, wp | 6 | ;; Keywords: outlines, hypermedia, calendar, wp |
| 7 | ;; Homepage: http://www.astro.uva.nl/~dominik/Tools/org/ | 7 | ;; Homepage: http://www.astro.uva.nl/~dominik/Tools/org/ |
| 8 | ;; Version: 4.56f | 8 | ;; Version: 4.67 |
| 9 | ;; | 9 | ;; |
| 10 | ;; This file is part of GNU Emacs. | 10 | ;; This file is part of GNU Emacs. |
| 11 | ;; | 11 | ;; |
| @@ -59,46 +59,13 @@ | |||
| 59 | ;; excellent reference card made by Philip Rooke. This card can be found | 59 | ;; excellent reference card made by Philip Rooke. This card can be found |
| 60 | ;; in the etc/ directory of Emacs 22. | 60 | ;; in the etc/ directory of Emacs 22. |
| 61 | ;; | 61 | ;; |
| 62 | ;; Recent changes | 62 | ;; A list of recent changes can be found at |
| 63 | ;; -------------- | 63 | ;; http://www.astro.uva.nl/~dominik/Tools/org/Changes |
| 64 | ;; Version 4.56 | ||
| 65 | ;; - `C-k' in agenda kills current line and corresponding subtree in file. | ||
| 66 | ;; - XEmacs compatibility issues fixed, in particular tag alignment. | ||
| 67 | ;; - M-left/right now in/outdents plain list items, no Shift needed. | ||
| 68 | ;; - Bug fixes. | ||
| 69 | ;; | ||
| 70 | ;; Version 4.55 | ||
| 71 | ;; - Bug fixes. | ||
| 72 | ;; | ||
| 73 | ;; Version 4.54 | ||
| 74 | ;; - Improvements to fast tag selection | ||
| 75 | ;; + show status also in target line. | ||
| 76 | ;; + option to auto-exit after first change to tags list (see manual). | ||
| 77 | ;; - Tags sparse trees now also respect the settings in | ||
| 78 | ;; `org-show-hierarchy-above' and `org-show-following-heading'. | ||
| 79 | ;; - Bug fixes. | ||
| 80 | ;; | ||
| 81 | ;; Version 4.53 | ||
| 82 | ;; - Custom time formats can be overlayed over time stamps. | ||
| 83 | ;; - New option `org-agenda-todo-ignore-deadlines'. | ||
| 84 | ;; - Work-around for flyspell bug (CVS Emacs has this fixed in flyspell.el). | ||
| 85 | ;; - Work-around for session.el problem with circular data structures. | ||
| 86 | ;; - Bug fixes. | ||
| 87 | ;; | ||
| 88 | ;; Version 4.52 | ||
| 89 | ;; - TAG matches can also specify conditions on TODO keywords. | ||
| 90 | ;; - The fast tag interface allows setting tags that are not in the | ||
| 91 | ;; predefined list. | ||
| 92 | ;; - Bug fixes. | ||
| 93 | ;; | ||
| 94 | ;; Version 4.51 | ||
| 95 | ;; - Link abbreviations (manual section 4.5). | ||
| 96 | ;; - More control over how agenda is displayed. See the new variables | ||
| 97 | ;; `org-agenda-window-setup', `org-agenda-restore-windows-after-quit'. | ||
| 98 | ;; - Bug fixes. | ||
| 99 | ;; | 64 | ;; |
| 100 | ;;; Code: | 65 | ;;; Code: |
| 101 | 66 | ||
| 67 | ;;;; Require other packages | ||
| 68 | |||
| 102 | (eval-when-compile | 69 | (eval-when-compile |
| 103 | (require 'cl) | 70 | (require 'cl) |
| 104 | (require 'gnus-sum) | 71 | (require 'gnus-sum) |
| @@ -112,15 +79,17 @@ | |||
| 112 | (require 'time-date) | 79 | (require 'time-date) |
| 113 | (require 'easymenu) | 80 | (require 'easymenu) |
| 114 | 81 | ||
| 115 | ;;; Customization variables | 82 | ;;;; Customization variables |
| 116 | 83 | ||
| 117 | (defvar org-version "4.56f" | 84 | ;;; Version |
| 85 | |||
| 86 | (defvar org-version "4.67" | ||
| 118 | "The version number of the file org.el.") | 87 | "The version number of the file org.el.") |
| 119 | (defun org-version () | 88 | (defun org-version () |
| 120 | (interactive) | 89 | (interactive) |
| 121 | (message "Org-mode version %s" org-version)) | 90 | (message "Org-mode version %s" org-version)) |
| 122 | 91 | ||
| 123 | ;; Compatibility constants | 92 | ;;; Compatibility constants |
| 124 | (defconst org-xemacs-p (featurep 'xemacs)) ; not used by org.el itself | 93 | (defconst org-xemacs-p (featurep 'xemacs)) ; not used by org.el itself |
| 125 | (defconst org-format-transports-properties-p | 94 | (defconst org-format-transports-properties-p |
| 126 | (let ((x "a")) | 95 | (let ((x "a")) |
| @@ -128,6 +97,8 @@ | |||
| 128 | (get-text-property 0 'test (format "%s" x))) | 97 | (get-text-property 0 'test (format "%s" x))) |
| 129 | "Does format transport text properties?") | 98 | "Does format transport text properties?") |
| 130 | 99 | ||
| 100 | ;;; The custom variables | ||
| 101 | |||
| 131 | (defgroup org nil | 102 | (defgroup org nil |
| 132 | "Outline-based notes management and organizer." | 103 | "Outline-based notes management and organizer." |
| 133 | :tag "Org" | 104 | :tag "Org" |
| @@ -172,17 +143,6 @@ the following lines anywhere in the buffer: | |||
| 172 | :group 'org-startup | 143 | :group 'org-startup |
| 173 | :type 'boolean) | 144 | :type 'boolean) |
| 174 | 145 | ||
| 175 | (defcustom org-startup-with-deadline-check nil | ||
| 176 | "Non-nil means, entering Org-mode will run the deadline check. | ||
| 177 | This means, if you start editing an org file, you will get an | ||
| 178 | immediate reminder of any due deadlines. | ||
| 179 | This can also be configured on a per-file basis by adding one of | ||
| 180 | the following lines anywhere in the buffer: | ||
| 181 | #+STARTUP: dlcheck | ||
| 182 | #+STARTUP: nodlcheck" | ||
| 183 | :group 'org-startup | ||
| 184 | :type 'boolean) | ||
| 185 | |||
| 186 | (defcustom org-insert-mode-line-in-empty-file nil | 146 | (defcustom org-insert-mode-line-in-empty-file nil |
| 187 | "Non-nil means insert the first line setting Org-mode in empty files. | 147 | "Non-nil means insert the first line setting Org-mode in empty files. |
| 188 | When the function `org-mode' is called interactively in an empty file, this | 148 | When the function `org-mode' is called interactively in an empty file, this |
| @@ -210,8 +170,9 @@ S-right -> M-+ | |||
| 210 | If you do not like the alternative keys, take a look at the variable | 170 | If you do not like the alternative keys, take a look at the variable |
| 211 | `org-disputed-keys'. | 171 | `org-disputed-keys'. |
| 212 | 172 | ||
| 213 | This option is only relevant at load-time of Org-mode. Changing it requires | 173 | This option is only relevant at load-time of Org-mode, and must be set |
| 214 | a restart of Emacs to become effective." | 174 | *before* org.el is loaded. Changing it requires a restart of Emacs to |
| 175 | become effective." | ||
| 215 | :group 'org-startup | 176 | :group 'org-startup |
| 216 | :type 'boolean) | 177 | :type 'boolean) |
| 217 | 178 | ||
| @@ -294,11 +255,114 @@ An entry can be toggled between QUOTE and normal with | |||
| 294 | :group 'org-keywords | 255 | :group 'org-keywords |
| 295 | :type 'string) | 256 | :type 'string) |
| 296 | 257 | ||
| 258 | (defvar org-repeat-re "\\<REPEAT(\\([-+ 0-9dwmy]+\\))" | ||
| 259 | "Regular expression for specifying repeated events. | ||
| 260 | After a match, group 1 contains the repeat expression.") | ||
| 261 | |||
| 297 | (defgroup org-structure nil | 262 | (defgroup org-structure nil |
| 298 | "Options concerning the general structure of Org-mode files." | 263 | "Options concerning the general structure of Org-mode files." |
| 299 | :tag "Org Structure" | 264 | :tag "Org Structure" |
| 300 | :group 'org) | 265 | :group 'org) |
| 301 | 266 | ||
| 267 | (defgroup org-reveal-location nil | ||
| 268 | "Options about how to make context of a location visible." | ||
| 269 | :tag "Org Reveal Location" | ||
| 270 | :group 'org-structure) | ||
| 271 | |||
| 272 | (defcustom org-show-hierarchy-above '((default . t)) | ||
| 273 | "Non-nil means, show full hierarchy when revealing a location. | ||
| 274 | Org-mode often shows locations in an org-mode file which might have | ||
| 275 | been invisible before. When this is set, the hierarchy of headings | ||
| 276 | above the exposed location is shown. | ||
| 277 | Turning this off for example for sparse trees makes them very compact. | ||
| 278 | Instead of t, this can also be an alist specifying this option for different | ||
| 279 | contexts. Valid contexts are | ||
| 280 | agenda when exposing an entry from the agenda | ||
| 281 | org-goto when using the command `org-goto' on key C-c C-j | ||
| 282 | occur-tree when using the command `org-occur' on key C-c / | ||
| 283 | tags-tree when constructing a sparse tree based on tags matches | ||
| 284 | link-search when exposing search matches associated with a link | ||
| 285 | mark-goto when exposing the jump goal of a mark | ||
| 286 | bookmark-jump when exposing a bookmark location | ||
| 287 | isearch when exiting from an incremental search | ||
| 288 | default default for all contexts not set explicitly" | ||
| 289 | :group 'org-reveal-location | ||
| 290 | :type '(choice | ||
| 291 | (const :tag "Always" t) | ||
| 292 | (const :tag "Never" nil) | ||
| 293 | (repeat :greedy t :tag "Individual contexts" | ||
| 294 | (cons | ||
| 295 | (choice :tag "Context" | ||
| 296 | (const agenda) | ||
| 297 | (const org-goto) | ||
| 298 | (const occur-tree) | ||
| 299 | (const tags-tree) | ||
| 300 | (const link-search) | ||
| 301 | (const mark-goto) | ||
| 302 | (const bookmark-jump) | ||
| 303 | (const isearch) | ||
| 304 | (const default)) | ||
| 305 | (boolean))))) | ||
| 306 | |||
| 307 | (defcustom org-show-following-heading '((default . t)) | ||
| 308 | "Non-nil means, show following heading when revealing a location. | ||
| 309 | Org-mode often shows locations in an org-mode file which might have | ||
| 310 | been invisible before. When this is set, the heading following the | ||
| 311 | match is shown. | ||
| 312 | Turning this off for example for sparse trees makes them very compact, | ||
| 313 | but makes it harder to edit the location of the match. In such a case, | ||
| 314 | use the command \\[org-reveal] to show more context. | ||
| 315 | Instead of t, this can also be an alist specifying this option for different | ||
| 316 | contexts. See `org-show-hierarchy-above' for valid contexts." | ||
| 317 | :group 'org-reveal-location | ||
| 318 | :type '(choice | ||
| 319 | (const :tag "Always" t) | ||
| 320 | (const :tag "Never" nil) | ||
| 321 | (repeat :greedy t :tag "Individual contexts" | ||
| 322 | (cons | ||
| 323 | (choice :tag "Context" | ||
| 324 | (const agenda) | ||
| 325 | (const org-goto) | ||
| 326 | (const occur-tree) | ||
| 327 | (const tags-tree) | ||
| 328 | (const link-search) | ||
| 329 | (const mark-goto) | ||
| 330 | (const bookmark-jump) | ||
| 331 | (const isearch) | ||
| 332 | (const default)) | ||
| 333 | (boolean))))) | ||
| 334 | |||
| 335 | (defcustom org-show-siblings '((default . nil) (isearch t)) | ||
| 336 | "Non-nil means, show all sibling heading when revealing a location. | ||
| 337 | Org-mode often shows locations in an org-mode file which might have | ||
| 338 | been invisible before. When this is set, the sibling of the current entry | ||
| 339 | heading are all made visible. If `org-show-hierarchy-above' is t, | ||
| 340 | the same happens on each level of the hierarchy above the current entry. | ||
| 341 | |||
| 342 | By default this is on for the isearch context, off for all other contexts. | ||
| 343 | Turning this off for example for sparse trees makes them very compact, | ||
| 344 | but makes it harder to edit the location of the match. In such a case, | ||
| 345 | use the command \\[org-reveal] to show more context. | ||
| 346 | Instead of t, this can also be an alist specifying this option for different | ||
| 347 | contexts. See `org-show-hierarchy-above' for valid contexts." | ||
| 348 | :group 'org-reveal-location | ||
| 349 | :type '(choice | ||
| 350 | (const :tag "Always" t) | ||
| 351 | (const :tag "Never" nil) | ||
| 352 | (repeat :greedy t :tag "Individual contexts" | ||
| 353 | (cons | ||
| 354 | (choice :tag "Context" | ||
| 355 | (const agenda) | ||
| 356 | (const org-goto) | ||
| 357 | (const occur-tree) | ||
| 358 | (const tags-tree) | ||
| 359 | (const link-search) | ||
| 360 | (const mark-goto) | ||
| 361 | (const bookmark-jump) | ||
| 362 | (const isearch) | ||
| 363 | (const default)) | ||
| 364 | (boolean))))) | ||
| 365 | |||
| 302 | (defgroup org-cycle nil | 366 | (defgroup org-cycle nil |
| 303 | "Options concerning visibility cycling in Org-mode." | 367 | "Options concerning visibility cycling in Org-mode." |
| 304 | :tag "Org Cycle" | 368 | :tag "Org Cycle" |
| @@ -342,6 +406,7 @@ the values `folded', `children', or `subtree'." | |||
| 342 | :group 'org-cycle | 406 | :group 'org-cycle |
| 343 | :type 'hook) | 407 | :type 'hook) |
| 344 | 408 | ||
| 409 | |||
| 345 | (defgroup org-edit-structure nil | 410 | (defgroup org-edit-structure nil |
| 346 | "Options concerning structure editing in Org-mode." | 411 | "Options concerning structure editing in Org-mode." |
| 347 | :tag "Org Edit Structure" | 412 | :tag "Org Edit Structure" |
| @@ -417,61 +482,6 @@ The highlights created by `org-preview-latex-fragment' always need | |||
| 417 | :group 'org-time | 482 | :group 'org-time |
| 418 | :type 'boolean) | 483 | :type 'boolean) |
| 419 | 484 | ||
| 420 | (defcustom org-show-hierarchy-above '((default . t)) | ||
| 421 | "Non-nil means, show full hierarchy when showing a spot in the tree. | ||
| 422 | Turning this off makes sparse trees more compact, but also less clear. | ||
| 423 | Instead of t, this can also be an alist specifying this option for different | ||
| 424 | contexts. Valid contexts are | ||
| 425 | agenda when exposing an entry from the agenda | ||
| 426 | org-goto when using the command `org-goto' on key C-c C-j | ||
| 427 | occur-tree when using the command `org-occur' on key C-c / | ||
| 428 | tags-tree when constructing a sparse tree based on tags matches | ||
| 429 | link-search when exposing search matches associated with a link | ||
| 430 | mark-goto when exposing the jump goal of a mark | ||
| 431 | bookmark-jump when exposing a bookmark location | ||
| 432 | default default for all contexts not set explicitly" | ||
| 433 | :group 'org-sparse-trees | ||
| 434 | :type '(choice | ||
| 435 | (const :tag "Always" t) | ||
| 436 | (const :tag "Never" nil) | ||
| 437 | (repeat :greedy t :tag "Individual contexts" | ||
| 438 | (cons | ||
| 439 | (choice :tag "Context" | ||
| 440 | (const agenda) | ||
| 441 | (const org-goto) | ||
| 442 | (const occur-tree) | ||
| 443 | (const tags-tree) | ||
| 444 | (const link-search) | ||
| 445 | (const mark-goto) | ||
| 446 | (const bookmark-jump) | ||
| 447 | (const default)) | ||
| 448 | (boolean))))) | ||
| 449 | |||
| 450 | (defcustom org-show-following-heading '((default . t)) | ||
| 451 | "Non-nil means, show heading following match in `org-occur'. | ||
| 452 | When doing an `org-occur' it is useful to show the headline which | ||
| 453 | follows the match, even if they do not match the regexp. This makes it | ||
| 454 | easier to edit directly inside the sparse tree. However, if you use | ||
| 455 | `org-occur' mainly as an overview, the following headlines are | ||
| 456 | unnecessary clutter. | ||
| 457 | Instead of t, this can also be an alist specifying this option for different | ||
| 458 | contexts. See `org-show-hierarchy-above' for valid contexts." | ||
| 459 | :group 'org-sparse-trees | ||
| 460 | :type '(choice | ||
| 461 | (const :tag "Always" t) | ||
| 462 | (const :tag "Never" nil) | ||
| 463 | (repeat :greedy t :tag "Individual contexts" | ||
| 464 | (cons | ||
| 465 | (choice :tag "Context" | ||
| 466 | (const agenda) | ||
| 467 | (const org-goto) | ||
| 468 | (const occur-tree) | ||
| 469 | (const tags-tree) | ||
| 470 | (const link-search) | ||
| 471 | (const mark-goto) | ||
| 472 | (const bookmark-jump) | ||
| 473 | (const default)) | ||
| 474 | (boolean))))) | ||
| 475 | 485 | ||
| 476 | (defcustom org-occur-hook '(org-first-headline-recenter) | 486 | (defcustom org-occur-hook '(org-first-headline-recenter) |
| 477 | "Hook that is run after `org-occur' has constructed a sparse tree. | 487 | "Hook that is run after `org-occur' has constructed a sparse tree. |
| @@ -519,7 +529,7 @@ use \\[org-ctrl-c-ctrl-c] to trigger renumbering." | |||
| 519 | When this is set, checkbox statistics is updated each time you either insert | 529 | When this is set, checkbox statistics is updated each time you either insert |
| 520 | a new checkbox with \\[org-insert-todo-heading] or toggle a checkbox | 530 | a new checkbox with \\[org-insert-todo-heading] or toggle a checkbox |
| 521 | with \\[org-ctrl-c-ctrl-c\\]." | 531 | with \\[org-ctrl-c-ctrl-c\\]." |
| 522 | :group 'org | 532 | :group 'org-plain-lists |
| 523 | :type 'boolean) | 533 | :type 'boolean) |
| 524 | 534 | ||
| 525 | (defgroup org-archive nil | 535 | (defgroup org-archive nil |
| @@ -539,7 +549,7 @@ not contribute to the agenda listings." | |||
| 539 | "Non-nil means, the agenda will skip any items located in archived trees. | 549 | "Non-nil means, the agenda will skip any items located in archived trees. |
| 540 | An archived tree is a tree marked with the tag ARCHIVE." | 550 | An archived tree is a tree marked with the tag ARCHIVE." |
| 541 | :group 'org-archive | 551 | :group 'org-archive |
| 542 | :group 'org-agenda-display | 552 | :group 'org-agenda-skip |
| 543 | :type 'boolean) | 553 | :type 'boolean) |
| 544 | 554 | ||
| 545 | (defcustom org-cycle-open-archived-trees nil | 555 | (defcustom org-cycle-open-archived-trees nil |
| @@ -658,6 +668,33 @@ this variable requires a restart of Emacs to become effective." | |||
| 658 | :group 'org-table | 668 | :group 'org-table |
| 659 | :type 'boolean) | 669 | :type 'boolean) |
| 660 | 670 | ||
| 671 | (defcustom orgtbl-radio-table-templates | ||
| 672 | '((latex-mode "% BEGIN RECEIVE ORGTBL %n | ||
| 673 | % END RECEIVE ORGTBL %n | ||
| 674 | \\begin{comment} | ||
| 675 | #+ORGTBL: SEND %n orgtbl-to-latex :splice nil :skip 0 | ||
| 676 | | | | | ||
| 677 | \\end{comment}\n") | ||
| 678 | (texinfo-mode "@c BEGIN RECEIVE ORGTBL %n | ||
| 679 | @c END RECEIVE ORGTBL %n | ||
| 680 | @ignore | ||
| 681 | #+ORGTBL: SEND %n orgtbl-to-html :splice nil :skip 0 | ||
| 682 | | | | | ||
| 683 | @end ignore\n") | ||
| 684 | (html-mode "<!-- BEGIN RECEIVE ORGTBL %n --> | ||
| 685 | <!-- END RECEIVE ORGTBL %n --> | ||
| 686 | <!-- | ||
| 687 | #+ORGTBL: SEND %n orgtbl-to-html :splice nil :skip 0 | ||
| 688 | | | | | ||
| 689 | -->\n")) | ||
| 690 | "Templates for radio tables in different major modes. | ||
| 691 | All occurrences of %n in a template will be replaced with the name of the | ||
| 692 | table, obtained by prompting the user." | ||
| 693 | :group 'org-table | ||
| 694 | :type '(repeat | ||
| 695 | (list (symbol :tag "Major mode") | ||
| 696 | (string :tag "Format")))) | ||
| 697 | |||
| 661 | (defgroup org-table-settings nil | 698 | (defgroup org-table-settings nil |
| 662 | "Settings for tables in Org-mode." | 699 | "Settings for tables in Org-mode." |
| 663 | :tag "Org Table Settings" | 700 | :tag "Org Table Settings" |
| @@ -669,7 +706,7 @@ this variable requires a restart of Emacs to become effective." | |||
| 669 | :type 'string) | 706 | :type 'string) |
| 670 | 707 | ||
| 671 | (defcustom org-table-number-regexp | 708 | (defcustom org-table-number-regexp |
| 672 | "^\\([<>]?[-+^.0-9]*[0-9][-+^.0-9eEdDx()%]*\\|\\(0[xX]\\)?[0-9a-fA-F]+\\)$" | 709 | "^\\([<>]?[-+^.0-9]*[0-9][-+^.0-9eEdDx()%:]*\\|\\(0[xX]\\)[0-9a-fA-F]+\\)$" |
| 673 | "Regular expression for recognizing numbers in table columns. | 710 | "Regular expression for recognizing numbers in table columns. |
| 674 | If a table column contains mostly numbers, it will be aligned to the | 711 | If a table column contains mostly numbers, it will be aligned to the |
| 675 | right. If not, it will be aligned to the left. | 712 | right. If not, it will be aligned to the left. |
| @@ -694,7 +731,7 @@ Other options offered by the customize interface are more restrictive." | |||
| 694 | (const :tag "Exponential, Floating point, Integer" | 731 | (const :tag "Exponential, Floating point, Integer" |
| 695 | "^[-+]?[0-9.]+\\([eEdD][-+0-9]+\\)?$") | 732 | "^[-+]?[0-9.]+\\([eEdD][-+0-9]+\\)?$") |
| 696 | (const :tag "Very General Number-Like, including hex" | 733 | (const :tag "Very General Number-Like, including hex" |
| 697 | "^\\([<>]?[-+^.0-9]*[0-9][-+^.0-9eEdDx()%]*\\|\\(0[xX]\\)?[0-9a-fA-F]+\\)$") | 734 | "^\\([<>]?[-+^.0-9]*[0-9][-+^.0-9eEdDx()%]*\\|\\(0[xX]\\)[0-9a-fA-F]+\\)$") |
| 698 | (string :tag "Regexp:"))) | 735 | (string :tag "Regexp:"))) |
| 699 | 736 | ||
| 700 | (defcustom org-table-number-fraction 0.5 | 737 | (defcustom org-table-number-fraction 0.5 |
| @@ -717,11 +754,6 @@ removal/insertion." | |||
| 717 | :group 'org-table-editing | 754 | :group 'org-table-editing |
| 718 | :type 'boolean) | 755 | :type 'boolean) |
| 719 | 756 | ||
| 720 | (defcustom org-table-limit-column-width t ;kw | ||
| 721 | "Non-nil means, allow to limit the width of table columns with <N> fields." | ||
| 722 | :group 'org-table-editing | ||
| 723 | :type 'boolean) | ||
| 724 | |||
| 725 | (defcustom org-table-auto-blank-field t | 757 | (defcustom org-table-auto-blank-field t |
| 726 | "Non-nil means, automatically blank table field when starting to type into it. | 758 | "Non-nil means, automatically blank table field when starting to type into it. |
| 727 | This only happens when typing immediately after a field motion | 759 | This only happens when typing immediately after a field motion |
| @@ -783,7 +815,9 @@ the command \\[org-table-eval-formula]." | |||
| 783 | :group 'org-table-calculation | 815 | :group 'org-table-calculation |
| 784 | :type 'boolean) | 816 | :type 'boolean) |
| 785 | 817 | ||
| 786 | 818 | ;; FIXME this is also a variable that makes Org-mode files non-portable | |
| 819 | ;; Maybe I should have a #+ options for constants? | ||
| 820 | ;; How about the SI/cgs issue? | ||
| 787 | (defcustom org-table-formula-use-constants t | 821 | (defcustom org-table-formula-use-constants t |
| 788 | "Non-nil means, interpret constants in formulas in tables. | 822 | "Non-nil means, interpret constants in formulas in tables. |
| 789 | A constant looks like `$c' or `$Grav' and will be replaced before evaluation | 823 | A constant looks like `$c' or `$Grav' and will be replaced before evaluation |
| @@ -806,14 +840,6 @@ and then use it in an equation like `$1*$c'." | |||
| 806 | (cons (string :tag "name") | 840 | (cons (string :tag "name") |
| 807 | (string :tag "value")))) | 841 | (string :tag "value")))) |
| 808 | 842 | ||
| 809 | (defcustom org-table-formula-numbers-only nil | ||
| 810 | "Non-nil means, calculate only with numbers in table formulas. | ||
| 811 | Then all input fields will be converted to a number, and the result | ||
| 812 | must also be a number. When nil, calc's full potential is available | ||
| 813 | in table calculations, including symbolics etc." | ||
| 814 | :group 'org-table-calculation | ||
| 815 | :type 'boolean) | ||
| 816 | |||
| 817 | (defcustom org-table-allow-automatic-line-recalculation t | 843 | (defcustom org-table-allow-automatic-line-recalculation t |
| 818 | "Non-nil means, lines marked with |#| or |*| will be recomputed automatically. | 844 | "Non-nil means, lines marked with |#| or |*| will be recomputed automatically. |
| 819 | Automatically means, when TAB or RET or C-c C-c are pressed in the line." | 845 | Automatically means, when TAB or RET or C-c C-c are pressed in the line." |
| @@ -836,7 +862,7 @@ The car of each element is a string, to be replaced at the start of a link. | |||
| 836 | The cdrs are replacement values, like (\"linkkey\" . REPLACE). Abbreviated | 862 | The cdrs are replacement values, like (\"linkkey\" . REPLACE). Abbreviated |
| 837 | links in Org-mode buffers can have an optional tag after a double colon, e.g. | 863 | links in Org-mode buffers can have an optional tag after a double colon, e.g. |
| 838 | 864 | ||
| 839 | [[linkkey::tag][description]] | 865 | [[linkkey:tag][description]] |
| 840 | 866 | ||
| 841 | If REPLACE is a string, the tag will simply be appended to create the link. | 867 | If REPLACE is a string, the tag will simply be appended to create the link. |
| 842 | If the string contains \"%s\", the tag will be inserted there. REPLACE may | 868 | If the string contains \"%s\", the tag will be inserted there. REPLACE may |
| @@ -853,30 +879,6 @@ per-buffer basis from the Org->Hyperlinks menu." | |||
| 853 | :group 'org-link | 879 | :group 'org-link |
| 854 | :type 'boolean) | 880 | :type 'boolean) |
| 855 | 881 | ||
| 856 | (defcustom org-link-style 'bracket | ||
| 857 | "The style of links to be inserted with \\[org-insert-link]. | ||
| 858 | Possible values are: | ||
| 859 | bracket [[link][description]]. This is recommended | ||
| 860 | plain Description \\n link. The old way, no longer recommended." | ||
| 861 | :group 'org-link | ||
| 862 | :type '(choice | ||
| 863 | (const :tag "Bracket (recommended)" bracket) | ||
| 864 | (const :tag "Plain (no longer recommended)" plain))) | ||
| 865 | |||
| 866 | (defcustom org-link-format "%s" | ||
| 867 | "Default format for external, URL-like linkes in the buffer. | ||
| 868 | This is a format string for printf, %s will be replaced by the link text. | ||
| 869 | The recommended value is just \"%s\", since links will be protected by | ||
| 870 | enclosing them in double brackets. If you prefer plain links (see variable | ||
| 871 | `org-link-style'), \"<%s>\" is useful. Some people also recommend an | ||
| 872 | additional URL: prefix, so the format would be \"<URL:%s>\"." | ||
| 873 | :group 'org-link | ||
| 874 | :type '(choice | ||
| 875 | (const :tag "\"%s\" (e.g. http://www.there.com)" "%s") | ||
| 876 | (const :tag "\"<%s>\" (e.g. <http://www.there.com>)" "<%s>") | ||
| 877 | (const :tag "\"<URL:%s>\" (e.g. <URL:http://www.there.com>)" "<URL:%s>") | ||
| 878 | (string :tag "Other" :value "<%s>"))) | ||
| 879 | |||
| 880 | (defcustom org-link-file-path-type 'adaptive | 882 | (defcustom org-link-file-path-type 'adaptive |
| 881 | "How the path name in file links should be stored. | 883 | "How the path name in file links should be stored. |
| 882 | Valid values are: | 884 | Valid values are: |
| @@ -907,7 +909,6 @@ plain Plain links in normal text, no whitespace, like http://google.com. | |||
| 907 | radio Text that is matched by a radio target, see manual for details. | 909 | radio Text that is matched by a radio target, see manual for details. |
| 908 | tag Tag settings in a headline (link to tag search). | 910 | tag Tag settings in a headline (link to tag search). |
| 909 | date Time stamps (link to calendar). | 911 | date Time stamps (link to calendar). |
| 910 | camel CamelCase words defining text searches. | ||
| 911 | 912 | ||
| 912 | Changing this variable requires a restart of Emacs to become effective." | 913 | Changing this variable requires a restart of Emacs to become effective." |
| 913 | :group 'org-link | 914 | :group 'org-link |
| @@ -916,14 +917,45 @@ Changing this variable requires a restart of Emacs to become effective." | |||
| 916 | (const :tag "plain text links" plain) | 917 | (const :tag "plain text links" plain) |
| 917 | (const :tag "Radio target matches" radio) | 918 | (const :tag "Radio target matches" radio) |
| 918 | (const :tag "Tags" tag) | 919 | (const :tag "Tags" tag) |
| 919 | (const :tag "Timestamps" date) | 920 | (const :tag "Timestamps" date))) |
| 920 | (const :tag "CamelCase words" camel))) | ||
| 921 | 921 | ||
| 922 | (defgroup org-link-store nil | 922 | (defgroup org-link-store nil |
| 923 | "Options concerning storing links in Org-mode" | 923 | "Options concerning storing links in Org-mode" |
| 924 | :tag "Org Store Link" | 924 | :tag "Org Store Link" |
| 925 | :group 'org-link) | 925 | :group 'org-link) |
| 926 | 926 | ||
| 927 | (defcustom org-email-link-description-format "Email %c: %.30s" | ||
| 928 | "Format of the description part of a link to an email or usenet message. | ||
| 929 | The following %-excapes will be replaced by corresponding information: | ||
| 930 | |||
| 931 | %F full \"From\" field | ||
| 932 | %f name, taken from \"From\" field, address if no name | ||
| 933 | %T full \"To\" field | ||
| 934 | %t first name in \"To\" field, address if no name | ||
| 935 | %c correspondent. Unually \"from NAME\", but if you sent it yourself, it | ||
| 936 | will be \"to NAME\". See also the variable `org-from-is-user-regexp'. | ||
| 937 | %s subject | ||
| 938 | %m message-id. | ||
| 939 | |||
| 940 | You may use normal field width specification between the % and the letter. | ||
| 941 | This is for example useful to limit the length of the subject. | ||
| 942 | |||
| 943 | Examples: \"%f on: %.30s\", \"Email from %f\", \"Email %c\"" | ||
| 944 | :group 'org-link-store | ||
| 945 | :type 'string) | ||
| 946 | |||
| 947 | (defcustom org-from-is-user-regexp | ||
| 948 | (let (r1 r2) | ||
| 949 | (when (and user-mail-address (not (string= user-mail-address ""))) | ||
| 950 | (setq r1 (concat "\\<" (regexp-quote user-mail-address) "\\>"))) | ||
| 951 | (when (and user-full-name (not (string= user-full-name ""))) | ||
| 952 | (setq r2 (concat "\\<" (regexp-quote user-full-name) "\\>"))) | ||
| 953 | (if (and r1 r2) (concat r1 "\\|" r2) (or r1 r2))) | ||
| 954 | "Regexp mached against the \"From:\" header of an email or usenet message. | ||
| 955 | It should match if the message is from the user him/herself." | ||
| 956 | :group 'org-link-store | ||
| 957 | :type 'regexp) | ||
| 958 | |||
| 927 | (defcustom org-context-in-file-links t | 959 | (defcustom org-context-in-file-links t |
| 928 | "Non-nil means, file links from `org-store-link' contain context. | 960 | "Non-nil means, file links from `org-store-link' contain context. |
| 929 | A search string will be added to the file name with :: as separator and | 961 | A search string will be added to the file name with :: as separator and |
| @@ -934,13 +966,6 @@ negates this setting for the duration of the command." | |||
| 934 | :group 'org-link-store | 966 | :group 'org-link-store |
| 935 | :type 'boolean) | 967 | :type 'boolean) |
| 936 | 968 | ||
| 937 | (defcustom org-file-link-context-use-camel-case nil | ||
| 938 | "Non-nil means, use CamelCase to store a search context in a file link. | ||
| 939 | When nil, the search string simply consists of the words of the string. | ||
| 940 | CamelCase is deprecated, and support for it may be dropped in the future." | ||
| 941 | :group 'org-link-store | ||
| 942 | :type 'boolean) | ||
| 943 | |||
| 944 | (defcustom org-keep-stored-link-after-insertion nil | 969 | (defcustom org-keep-stored-link-after-insertion nil |
| 945 | "Non-nil means, keep link in list for entire session. | 970 | "Non-nil means, keep link in list for entire session. |
| 946 | 971 | ||
| @@ -1041,9 +1066,8 @@ changes to the current buffer." | |||
| 1041 | :group 'org-link-follow | 1066 | :group 'org-link-follow |
| 1042 | :type 'boolean) | 1067 | :type 'boolean) |
| 1043 | 1068 | ||
| 1044 | |||
| 1045 | (defcustom org-open-non-existing-files nil | 1069 | (defcustom org-open-non-existing-files nil |
| 1046 | "Non-nil means, `org-open-file' will open non-existing file. | 1070 | "Non-nil means, `org-open-file' will open non-existing files. |
| 1047 | When nil, an error will be generated." | 1071 | When nil, an error will be generated." |
| 1048 | :group 'org-link-follow | 1072 | :group 'org-link-follow |
| 1049 | :type 'boolean) | 1073 | :type 'boolean) |
| @@ -1176,7 +1200,7 @@ For more examples, see the system specific constants | |||
| 1176 | (defcustom org-mhe-search-all-folders nil | 1200 | (defcustom org-mhe-search-all-folders nil |
| 1177 | "Non-nil means, that the search for the mh-message will be extended to | 1201 | "Non-nil means, that the search for the mh-message will be extended to |
| 1178 | all folders if the message cannot be found in the folder given in the link. | 1202 | all folders if the message cannot be found in the folder given in the link. |
| 1179 | Searching all folders is very effective with one of the search engines | 1203 | Searching all folders is very efficient with one of the search engines |
| 1180 | supported by MH-E, but will be slow with pick." | 1204 | supported by MH-E, but will be slow with pick." |
| 1181 | :group 'org-link-follow | 1205 | :group 'org-link-follow |
| 1182 | :type 'boolean) | 1206 | :type 'boolean) |
| @@ -1196,39 +1220,83 @@ Used by the hooks for remember.el." | |||
| 1196 | (defcustom org-default-notes-file "~/.notes" | 1220 | (defcustom org-default-notes-file "~/.notes" |
| 1197 | "Default target for storing notes. | 1221 | "Default target for storing notes. |
| 1198 | Used by the hooks for remember.el. This can be a string, or nil to mean | 1222 | Used by the hooks for remember.el. This can be a string, or nil to mean |
| 1199 | the value of `remember-data-file'." | 1223 | the value of `remember-data-file'. |
| 1224 | You can set this on a per-template basis with the variable | ||
| 1225 | `org-remember-templates'." | ||
| 1200 | :group 'org-remember | 1226 | :group 'org-remember |
| 1201 | :type '(choice | 1227 | :type '(choice |
| 1202 | (const :tag "Default from remember-data-file" nil) | 1228 | (const :tag "Default from remember-data-file" nil) |
| 1203 | file)) | 1229 | file)) |
| 1204 | 1230 | ||
| 1231 | (defcustom org-remember-default-headline "" | ||
| 1232 | "The headline that should be the default location in the notes file. | ||
| 1233 | When filing remember notes, the cursor will start at that position. | ||
| 1234 | You can set this on a per-template basis with the variable | ||
| 1235 | `org-remember-templates'." | ||
| 1236 | :group 'org-remember | ||
| 1237 | :type 'string) | ||
| 1238 | |||
| 1205 | (defcustom org-remember-templates nil | 1239 | (defcustom org-remember-templates nil |
| 1206 | "Templates for the creation of remember buffers. | 1240 | "Templates for the creation of remember buffers. |
| 1207 | When nil, just let remember make the buffer. | 1241 | When nil, just let remember make the buffer. |
| 1208 | When not nil, this is a list of 3-element lists. In each entry, the first | 1242 | When not nil, this is a list of 4-element lists. In each entry, the first |
| 1209 | element is a character, a unique key to select this template. | 1243 | element is a character, a unique key to select this template. |
| 1210 | The second element is the template. The third element is optional and can | 1244 | The second element is the template. The third element is optional and can |
| 1211 | specify a destination file for remember items created with this template. | 1245 | specify a destination file for remember items created with this template. |
| 1212 | The default file is given by `org-default-notes-file'. | 1246 | The default file is given by `org-default-notes-file'. An optional third |
| 1247 | element can specify the headline in that file that should be offered | ||
| 1248 | first when the user is asked to file the entry. The default headline is | ||
| 1249 | given in the variable `org-remember-default-headline'. | ||
| 1213 | 1250 | ||
| 1214 | The template specifies the structure of the remember buffer. It should have | 1251 | The template specifies the structure of the remember buffer. It should have |
| 1215 | a first line starting with a star, to act as the org-mode headline. | 1252 | a first line starting with a star, to act as the org-mode headline. |
| 1216 | Furthermore, the following %-escapes will be replaced with content: | 1253 | Furthermore, the following %-escapes will be replaced with content: |
| 1217 | %t time stamp, date only | 1254 | |
| 1218 | %T time stamp with date and time | 1255 | %^{prompt} prompt the user for a string and replace this sequence with it. |
| 1219 | %u inactive time stamp, date only | 1256 | %t time stamp, date only |
| 1220 | %U inactive time stamp with date and time | 1257 | %T time stamp with date and time |
| 1221 | %n user name | 1258 | %u, %U like the above, but inactive time stamps |
| 1222 | %a annotation, normally the link created with org-store-link | 1259 | %^t like %t, but prompt for date. Similarly %^T, %^u, %^U |
| 1223 | %i initial content, the region when remember is called with C-u. | 1260 | You may define a prompt like %^{Please specify birthday}t |
| 1224 | If %i is indented, the entire inserted text will be indented as well. | 1261 | %n user name (taken from `user-full-name') |
| 1225 | %? This will be removed, and the cursor placed at this position." | 1262 | %a annotation, normally the link created with org-store-link |
| 1263 | %i initial content, the region when remember is called with C-u. | ||
| 1264 | If %i is indented, the entire inserted text will be indented | ||
| 1265 | as well. | ||
| 1266 | |||
| 1267 | %? After completing the template, position cursor here. | ||
| 1268 | |||
| 1269 | Apart from these general escapes, you can access information specific to the | ||
| 1270 | link type that is created. For example, calling `remember' in emails or gnus | ||
| 1271 | will record the author and the subject of the message, which you can access | ||
| 1272 | with %:author and %:subject, respectively. Here is a complete list of what | ||
| 1273 | is recorded for each link type. | ||
| 1274 | |||
| 1275 | Link type | Available information | ||
| 1276 | -------------------+------------------------------------------------------ | ||
| 1277 | bbdb | %:type %:name %:company | ||
| 1278 | vm, wl, mh, rmail | %:type %:subject %:message-id | ||
| 1279 | | %:from %:fromname %:fromaddress | ||
| 1280 | | %:to %:toname %:toaddress | ||
| 1281 | | %:fromto (either \"to NAME\" or \"from NAME\") | ||
| 1282 | gnus | %:group, for messages also all email fields | ||
| 1283 | w3, w3m | %:type %:url | ||
| 1284 | info | %:type %:file %:node | ||
| 1285 | calendar | %:type %:date" | ||
| 1226 | :group 'org-remember | 1286 | :group 'org-remember |
| 1227 | :type '(repeat :tag "enabled" | 1287 | :get (lambda (var) ; Make sure all entries have 4 elements |
| 1228 | (list :value (?a "\n" nil) | 1288 | (mapcar (lambda (x) |
| 1229 | (character :tag "Selection Key") | 1289 | (cond ((= (length x) 3) (append x '(""))) |
| 1230 | (string :tag "Template") | 1290 | ((= (length x) 2) (append x '("" ""))) |
| 1231 | (file :tag "Destination file (optional)")))) | 1291 | (t x))) |
| 1292 | (default-value var))) | ||
| 1293 | :type '(repeat | ||
| 1294 | :tag "enabled" | ||
| 1295 | (list :value (?a "\n" nil nil) | ||
| 1296 | (character :tag "Selection Key") | ||
| 1297 | (string :tag "Template") | ||
| 1298 | (file :tag "Destination file (optional)") | ||
| 1299 | (string :tag "Destination headline (optional)")))) | ||
| 1232 | 1300 | ||
| 1233 | (defcustom org-reverse-note-order nil | 1301 | (defcustom org-reverse-note-order nil |
| 1234 | "Non-nil means, store new notes at the beginning of a file or entry. | 1302 | "Non-nil means, store new notes at the beginning of a file or entry. |
| @@ -1245,6 +1313,11 @@ When nil, new notes will be filed to the end of a file or entry." | |||
| 1245 | :tag "Org TODO" | 1313 | :tag "Org TODO" |
| 1246 | :group 'org) | 1314 | :group 'org) |
| 1247 | 1315 | ||
| 1316 | (defgroup org-progress nil | ||
| 1317 | "Options concerning Progress logging in Org-mode." | ||
| 1318 | :tag "Org Progress" | ||
| 1319 | :group 'org-time) | ||
| 1320 | |||
| 1248 | (defcustom org-todo-keywords '("TODO" "DONE") | 1321 | (defcustom org-todo-keywords '("TODO" "DONE") |
| 1249 | "List of TODO entry keywords. | 1322 | "List of TODO entry keywords. |
| 1250 | \\<org-mode-map>By default, this is '(\"TODO\" \"DONE\"). The last entry in the list is | 1323 | \\<org-mode-map>By default, this is '(\"TODO\" \"DONE\"). The last entry in the list is |
| @@ -1291,6 +1364,10 @@ the time stamp recording the action should be annotated with a short note. | |||
| 1291 | Valid members of this list are | 1364 | Valid members of this list are |
| 1292 | 1365 | ||
| 1293 | done Offer to record a note when marking entries done | 1366 | done Offer to record a note when marking entries done |
| 1367 | state Offer to record a note whenever changing the TODO state | ||
| 1368 | of an item. This is only relevant if TODO keywords are | ||
| 1369 | interpreted as sequence, see variable `org-todo-interpretation'. | ||
| 1370 | When `state' is set, this includes tracking `done'. | ||
| 1294 | clock-out Offer to record a note when clocking out of an item. | 1371 | clock-out Offer to record a note when clocking out of an item. |
| 1295 | 1372 | ||
| 1296 | A separate window will then pop up and allow you to type a note. | 1373 | A separate window will then pop up and allow you to type a note. |
| @@ -1301,26 +1378,51 @@ timestamp, as a plain list item. See also the variable | |||
| 1301 | Logging can also be configured on a per-file basis by adding one of | 1378 | Logging can also be configured on a per-file basis by adding one of |
| 1302 | the following lines anywhere in the buffer: | 1379 | the following lines anywhere in the buffer: |
| 1303 | 1380 | ||
| 1304 | #+STARTUP: logging | 1381 | #+STARTUP: logdone |
| 1305 | #+STARTUP: nologging" | 1382 | #+STARTUP: nologging |
| 1306 | ;; FIXME: in-buffer words for notes??????? | 1383 | #+STARTUP: lognotedone |
| 1384 | #+STARTUP: lognotestate | ||
| 1385 | #+STARTUP: lognoteclock-out" | ||
| 1307 | :group 'org-todo | 1386 | :group 'org-todo |
| 1387 | :group 'org-progress | ||
| 1308 | :type '(choice | 1388 | :type '(choice |
| 1309 | (const :tag "off" nil) | 1389 | (const :tag "off" nil) |
| 1310 | (const :tag "on" t) | 1390 | (const :tag "on" t) |
| 1311 | (set :tag "on, with notes" :greedy t :value (done) | 1391 | (set :tag "on, with notes, detailed control" :greedy t :value (done) |
| 1312 | (const done) (const clock-out)))) | 1392 | (const :tag "when item is marked DONE" done) |
| 1313 | 1393 | (const :tag "when TODO state changes" state) | |
| 1314 | (defcustom org-log-note-headings '((done . "CLOSING NOTE") (clock-out . "")) | 1394 | (const :tag "when clocking out" clock-out)))) |
| 1395 | |||
| 1396 | (defcustom org-log-note-headings | ||
| 1397 | '((done . "CLOSING NOTE %t") | ||
| 1398 | (state . "State %-12s %t") | ||
| 1399 | (clock-out . "")) | ||
| 1315 | "Headings for notes added when clocking out or closing TODO items. | 1400 | "Headings for notes added when clocking out or closing TODO items. |
| 1316 | The value is an alist, with the car being a sympol indicating the note | 1401 | The value is an alist, with the car being a sympol indicating the note |
| 1317 | context, and the cdr is the heading to be used. The heading may also be the | 1402 | context, and the cdr is the heading to be used. The heading may also be the |
| 1318 | empty string." | 1403 | empty string. |
| 1404 | %t in the heading will be replaced by a time stamp. | ||
| 1405 | %s will be replaced by the new TODO state, in double quotes. | ||
| 1406 | %u will be replaced by the user name. | ||
| 1407 | %U will be replaced by the full user name." | ||
| 1319 | :group 'org-todo | 1408 | :group 'org-todo |
| 1409 | :group 'org-progress | ||
| 1320 | :type '(list :greedy t | 1410 | :type '(list :greedy t |
| 1321 | (cons (const :tag "Heading when closing an item" done) string) | 1411 | (cons (const :tag "Heading when closing an item" done) string) |
| 1412 | (cons (const :tag | ||
| 1413 | "Heading when changing todo state (todo sequence only)" | ||
| 1414 | state) string) | ||
| 1322 | (cons (const :tag "Heading when clocking out" clock-out) string))) | 1415 | (cons (const :tag "Heading when clocking out" clock-out) string))) |
| 1323 | 1416 | ||
| 1417 | (defcustom org-allow-auto-repeat t | ||
| 1418 | "Non-nil means, find REPEAT cookies in entries and apply them. | ||
| 1419 | A repeat cookie looks like REPEAT(+1m) and causes deadlines and schedules | ||
| 1420 | to repeat themselves shifted by a certain amount of time, each time an | ||
| 1421 | entry is marked DONE." | ||
| 1422 | :group 'org-todo | ||
| 1423 | :group 'org-progress | ||
| 1424 | :type 'boolean) | ||
| 1425 | |||
| 1324 | (defgroup org-priorities nil | 1426 | (defgroup org-priorities nil |
| 1325 | "Priorities in Org-mode." | 1427 | "Priorities in Org-mode." |
| 1326 | :tag "Org Priorities" | 1428 | :tag "Org Priorities" |
| @@ -1381,6 +1483,14 @@ These are overlayed over the default ISO format if the variable | |||
| 1381 | :group 'org-time | 1483 | :group 'org-time |
| 1382 | :type 'sexp) | 1484 | :type 'sexp) |
| 1383 | 1485 | ||
| 1486 | (defun org-time-stamp-format (&optional long inactive) | ||
| 1487 | "Get the right format for a time string." | ||
| 1488 | (let ((f (if long (cdr org-time-stamp-formats) | ||
| 1489 | (car org-time-stamp-formats)))) | ||
| 1490 | (if inactive | ||
| 1491 | (concat "[" (substring f 1 -1) "]") | ||
| 1492 | f))) | ||
| 1493 | |||
| 1384 | (defcustom org-deadline-warning-days 30 | 1494 | (defcustom org-deadline-warning-days 30 |
| 1385 | "No. of days before expiration during which a deadline becomes active. | 1495 | "No. of days before expiration during which a deadline becomes active. |
| 1386 | This variable governs the display in sparse trees and in the agenda." | 1496 | This variable governs the display in sparse trees and in the agenda." |
| @@ -1440,9 +1550,14 @@ automatically if necessary." | |||
| 1440 | (defcustom org-fast-tag-selection-single-key nil | 1550 | (defcustom org-fast-tag-selection-single-key nil |
| 1441 | "Non-nil means, fast tag selection exits after first change. | 1551 | "Non-nil means, fast tag selection exits after first change. |
| 1442 | When nil, you have to press RET to exit it. | 1552 | When nil, you have to press RET to exit it. |
| 1443 | During fast tag selection, you can toggle this flag with `C-c'." | 1553 | During fast tag selection, you can toggle this flag with `C-c'. |
| 1554 | This variable can also have the value `expert'. In this case, the window | ||
| 1555 | displaying the tags menu is not even shown, until you press C-c again." | ||
| 1444 | :group 'org-tags | 1556 | :group 'org-tags |
| 1445 | :type 'boolean) | 1557 | :type '(choice |
| 1558 | (const :tag "No" nil) | ||
| 1559 | (const :tag "Yes" t) | ||
| 1560 | (const :tag "Expert" expert))) | ||
| 1446 | 1561 | ||
| 1447 | (defcustom org-tags-column 48 | 1562 | (defcustom org-tags-column 48 |
| 1448 | "The column to which tags should be indented in a headline. | 1563 | "The column to which tags should be indented in a headline. |
| @@ -1489,7 +1604,7 @@ make sure all corresponding TODO items find their way into the list." | |||
| 1489 | "The last used completion table for tags.") | 1604 | "The last used completion table for tags.") |
| 1490 | 1605 | ||
| 1491 | (defgroup org-agenda nil | 1606 | (defgroup org-agenda nil |
| 1492 | "Options concerning agenda display Org-mode." | 1607 | "Options concerning agenda views in Org-mode." |
| 1493 | :tag "Org Agenda" | 1608 | :tag "Org Agenda" |
| 1494 | :group 'org) | 1609 | :group 'org) |
| 1495 | 1610 | ||
| @@ -1520,8 +1635,31 @@ agenda file per line." | |||
| 1520 | (repeat :tag "List of files" file) | 1635 | (repeat :tag "List of files" file) |
| 1521 | (file :tag "Store list in a file\n" :value "~/.agenda_files"))) | 1636 | (file :tag "Store list in a file\n" :value "~/.agenda_files"))) |
| 1522 | 1637 | ||
| 1523 | (defcustom org-agenda-custom-commands ;'(("w" todo "WAITING")) | 1638 | |
| 1524 | '(("w" todo "WAITING" ((aaa 1) (bbb 2)))) | 1639 | (defcustom org-agenda-confirm-kill 1 |
| 1640 | "When set, remote killing from the agenda buffer needs confirmation. | ||
| 1641 | When t, a confirmation is always needed. When a number N, confirmation is | ||
| 1642 | only needed when the text to be killed contains more than N non-white lines." | ||
| 1643 | :group 'org-agenda | ||
| 1644 | :type '(choice | ||
| 1645 | (const :tag "Never" nil) | ||
| 1646 | (const :tag "Always" t) | ||
| 1647 | (number :tag "When more than N lines"))) | ||
| 1648 | |||
| 1649 | (defcustom org-calendar-to-agenda-key [?c] | ||
| 1650 | "The key to be installed in `calendar-mode-map' for switching to the agenda. | ||
| 1651 | The command `org-calendar-goto-agenda' will be bound to this key. The | ||
| 1652 | default is the character `c' because then `c' can be used to switch back and | ||
| 1653 | forth between agenda and calendar." | ||
| 1654 | :group 'org-agenda | ||
| 1655 | :type 'sexp) | ||
| 1656 | |||
| 1657 | (defgroup org-agenda-custom-commands nil | ||
| 1658 | "Options concerning agenda views in Org-mode." | ||
| 1659 | :tag "Org Agenda Custom Commands" | ||
| 1660 | :group 'org-agenda) | ||
| 1661 | |||
| 1662 | (defcustom org-agenda-custom-commands '(("w" todo "WAITING")) | ||
| 1525 | "Custom commands for the agenda. | 1663 | "Custom commands for the agenda. |
| 1526 | These commands will be offered on the splash screen displayed by the | 1664 | These commands will be offered on the splash screen displayed by the |
| 1527 | agenda dispatcher \\[org-agenda]. Each entry is a list like this: | 1665 | agenda dispatcher \\[org-agenda]. Each entry is a list like this: |
| @@ -1556,6 +1694,7 @@ cmd An agenda command, similar to the above. However, tree commands | |||
| 1556 | So valid commands for a set are: | 1694 | So valid commands for a set are: |
| 1557 | (agenda) | 1695 | (agenda) |
| 1558 | (alltodo) | 1696 | (alltodo) |
| 1697 | (stuck) | ||
| 1559 | (todo \"match\" options) | 1698 | (todo \"match\" options) |
| 1560 | (tags \"match\" options ) | 1699 | (tags \"match\" options ) |
| 1561 | (tags-todo \"match\" options) | 1700 | (tags-todo \"match\" options) |
| @@ -1563,7 +1702,7 @@ cmd An agenda command, similar to the above. However, tree commands | |||
| 1563 | Each command can carry a list of options, and another set of options can be | 1702 | Each command can carry a list of options, and another set of options can be |
| 1564 | given for the whole set of commands. Individual command options take | 1703 | given for the whole set of commands. Individual command options take |
| 1565 | precedence over the general options." | 1704 | precedence over the general options." |
| 1566 | :group 'org-agenda | 1705 | :group 'org-agenda-custom-commands |
| 1567 | :type '(repeat | 1706 | :type '(repeat |
| 1568 | (choice | 1707 | (choice |
| 1569 | (list :tag "Single command" | 1708 | (list :tag "Single command" |
| @@ -1574,7 +1713,8 @@ precedence over the general options." | |||
| 1574 | (const :tag "TODO keyword search (all agenda files)" todo) | 1713 | (const :tag "TODO keyword search (all agenda files)" todo) |
| 1575 | (const :tag "Tags sparse tree (current buffer)" tags-tree) | 1714 | (const :tag "Tags sparse tree (current buffer)" tags-tree) |
| 1576 | (const :tag "TODO keyword tree (current buffer)" todo-tree) | 1715 | (const :tag "TODO keyword tree (current buffer)" todo-tree) |
| 1577 | (const :tag "Occur tree (current buffer)" occur-tree)) | 1716 | (const :tag "Occur tree (current buffer)" occur-tree) |
| 1717 | (symbol :tag "Other, user-defined function")) | ||
| 1578 | (string :tag "Match") | 1718 | (string :tag "Match") |
| 1579 | (repeat :tag "Local options" | 1719 | (repeat :tag "Local options" |
| 1580 | (list (variable :tag "Option") (sexp :tag "Value")))) | 1720 | (list (variable :tag "Option") (sexp :tag "Value")))) |
| @@ -1585,6 +1725,7 @@ precedence over the general options." | |||
| 1585 | (choice | 1725 | (choice |
| 1586 | (const :tag "Agenda" (agenda)) | 1726 | (const :tag "Agenda" (agenda)) |
| 1587 | (const :tag "TODO list" (alltodo)) | 1727 | (const :tag "TODO list" (alltodo)) |
| 1728 | (const :tag "Stuck projects" (stuck)) | ||
| 1588 | (list :tag "Tags search" | 1729 | (list :tag "Tags search" |
| 1589 | (const :format "" tags) | 1730 | (const :format "" tags) |
| 1590 | (string :tag "Match") | 1731 | (string :tag "Match") |
| @@ -1604,16 +1745,51 @@ precedence over the general options." | |||
| 1604 | (string :tag "Match") | 1745 | (string :tag "Match") |
| 1605 | (repeat :tag "Local options" | 1746 | (repeat :tag "Local options" |
| 1606 | (list (variable :tag "Option") | 1747 | (list (variable :tag "Option") |
| 1748 | (sexp :tag "Value")))) | ||
| 1749 | |||
| 1750 | (list :tag "Other, user-defined function" | ||
| 1751 | (symbol :tag "function") | ||
| 1752 | (string :tag "Match") | ||
| 1753 | (repeat :tag "Local options" | ||
| 1754 | (list (variable :tag "Option") | ||
| 1607 | (sexp :tag "Value")))))) | 1755 | (sexp :tag "Value")))))) |
| 1756 | |||
| 1608 | (repeat :tag "General options" | 1757 | (repeat :tag "General options" |
| 1609 | (list (variable :tag "Option") | 1758 | (list (variable :tag "Option") |
| 1610 | (sexp :tag "Value"))))))) | 1759 | (sexp :tag "Value"))))))) |
| 1611 | 1760 | ||
| 1761 | (defcustom org-stuck-projects | ||
| 1762 | '("+LEVEL=2/-DONE" ("TODO" "NEXT" "NEXTACTION") nil) | ||
| 1763 | "How to identify stuck projects. | ||
| 1764 | This is a list of three items: | ||
| 1765 | 1. A tags/todo matcher string that is used to identify a project. | ||
| 1766 | The entire tree below a headline matched by this is considered a project. | ||
| 1767 | 2. A list of TODO keywords itentifying non-stuck projects. | ||
| 1768 | If the project subtree contains any headline with one of these todo | ||
| 1769 | keywords, the project is consitered to be not stuck. | ||
| 1770 | 3. A list of tags identifying non-stuck projects. | ||
| 1771 | If the project subtree contains any headline with one of these tags, | ||
| 1772 | the project is consitered to be not stuck. | ||
| 1773 | |||
| 1774 | After defining this variable, you may use \\[org-agenda-list-stuck-projects] | ||
| 1775 | or `C-c a #' to produce the list." | ||
| 1776 | :group 'org-agenda-custom-commands | ||
| 1777 | :type '(list | ||
| 1778 | (string :tag "Tags/TODO match to identify a project") | ||
| 1779 | (repeat :tag "Projects are *not* stuck if they have an entry with TODO keyword any of" (string)) | ||
| 1780 | (repeat :tag "Projects are *not* stuck if they have an entry with TAG being any of" (string)))) | ||
| 1781 | |||
| 1782 | |||
| 1783 | (defgroup org-agenda-skip nil | ||
| 1784 | "Options concerning skipping parts of agenda files." | ||
| 1785 | :tag "Org Agenda Skip" | ||
| 1786 | :group 'org-agenda) | ||
| 1787 | |||
| 1612 | (defcustom org-agenda-todo-list-sublevels t | 1788 | (defcustom org-agenda-todo-list-sublevels t |
| 1613 | "Non-nil means, check also the sublevels of a TODO entry for TODO entries. | 1789 | "Non-nil means, check also the sublevels of a TODO entry for TODO entries. |
| 1614 | When nil, the sublevels of a TODO entry are not checked, resulting in | 1790 | When nil, the sublevels of a TODO entry are not checked, resulting in |
| 1615 | potentially much shorter TODO lists." | 1791 | potentially much shorter TODO lists." |
| 1616 | :group 'org-agenda | 1792 | :group 'org-agenda-skip |
| 1617 | :group 'org-todo | 1793 | :group 'org-todo |
| 1618 | :type 'boolean) | 1794 | :type 'boolean) |
| 1619 | 1795 | ||
| @@ -1621,7 +1797,7 @@ potentially much shorter TODO lists." | |||
| 1621 | "Non-nil means, don't show scheduled entries in the global todo list. | 1797 | "Non-nil means, don't show scheduled entries in the global todo list. |
| 1622 | The idea behind this is that by scheduling it, you have already taken care | 1798 | The idea behind this is that by scheduling it, you have already taken care |
| 1623 | of this item." | 1799 | of this item." |
| 1624 | :group 'org-agenda | 1800 | :group 'org-agenda-skip |
| 1625 | :group 'org-todo | 1801 | :group 'org-todo |
| 1626 | :type 'boolean) | 1802 | :type 'boolean) |
| 1627 | 1803 | ||
| @@ -1629,10 +1805,15 @@ of this item." | |||
| 1629 | "Non-nil means, don't show near deadline entries in the global todo list. | 1805 | "Non-nil means, don't show near deadline entries in the global todo list. |
| 1630 | Near means closer than `org-deadline-warning-days' days. | 1806 | Near means closer than `org-deadline-warning-days' days. |
| 1631 | The idea behind this is that such items will appear in the agenda anyway." | 1807 | The idea behind this is that such items will appear in the agenda anyway." |
| 1632 | :group 'org-agenda | 1808 | :group 'org-agenda-skip |
| 1633 | :group 'org-todo | 1809 | :group 'org-todo |
| 1634 | :type 'boolean) | 1810 | :type 'boolean) |
| 1635 | 1811 | ||
| 1812 | (defcustom org-agenda-skip-scheduled-if-done nil | ||
| 1813 | "Non-nil means don't show scheduled items in agenda when they are done. | ||
| 1814 | This is relevant for the daily/weekly agenda, not for the TODO list." | ||
| 1815 | :group 'org-agenda-skip | ||
| 1816 | :type 'boolean) | ||
| 1636 | 1817 | ||
| 1637 | (defcustom org-timeline-show-empty-dates 3 | 1818 | (defcustom org-timeline-show-empty-dates 3 |
| 1638 | "Non-nil means, `org-timeline' also shows dates without an entry. | 1819 | "Non-nil means, `org-timeline' also shows dates without an entry. |
| @@ -1640,46 +1821,38 @@ When nil, only the days which actually have entries are shown. | |||
| 1640 | When t, all days between the first and the last date are shown. | 1821 | When t, all days between the first and the last date are shown. |
| 1641 | When an integer, show also empty dates, but if there is a gap of more than | 1822 | When an integer, show also empty dates, but if there is a gap of more than |
| 1642 | N days, just insert a special line indicating the size of the gap." | 1823 | N days, just insert a special line indicating the size of the gap." |
| 1643 | :group 'org-agenda | 1824 | :group 'org-agenda-skip |
| 1644 | :type '(choice | 1825 | :type '(choice |
| 1645 | (const :tag "None" nil) | 1826 | (const :tag "None" nil) |
| 1646 | (const :tag "All" t) | 1827 | (const :tag "All" t) |
| 1647 | (number :tag "at most"))) | 1828 | (number :tag "at most"))) |
| 1648 | 1829 | ||
| 1649 | (defcustom org-agenda-confirm-kill 1 | ||
| 1650 | "When set, remote killing from the agenda buffer needs confirmation. | ||
| 1651 | When t, a confirmation is always needed. When a number N, confirmation is | ||
| 1652 | only needed when the text to be killed contains more than N non-white lines." | ||
| 1653 | :group 'org-agenda ;; FIXME | ||
| 1654 | :type '(choice | ||
| 1655 | (const :tag "Never" nil) | ||
| 1656 | (const :tag "Always" t) | ||
| 1657 | (number :tag "When more than N lines"))) | ||
| 1658 | 1830 | ||
| 1659 | ;; FIXME: This variable could be removed | 1831 | (defgroup org-agenda-startup nil |
| 1660 | (defcustom org-agenda-include-all-todo nil | 1832 | "Options concerning initial settings in the Agenda in Org Mode." |
| 1661 | "Set means weekly/daily agenda will always contain all TODO entries. | 1833 | :tag "Org Agenda Startup" |
| 1662 | The TODO entries will be listed at the top of the agenda, before | 1834 | :group 'org-agenda) |
| 1663 | the entries for specific days." | ||
| 1664 | :group 'org-agenda | ||
| 1665 | :type 'boolean) | ||
| 1666 | 1835 | ||
| 1667 | (defcustom org-agenda-include-diary nil | 1836 | (defcustom org-finalize-agenda-hook nil |
| 1668 | "If non-nil, include in the agenda entries from the Emacs Calendar's diary." | 1837 | "Hook run just before displaying an agenda buffer." |
| 1669 | :group 'org-agenda | 1838 | :group 'org-agenda-startup |
| 1839 | :type 'hook) | ||
| 1840 | |||
| 1841 | (defcustom org-agenda-mouse-1-follows-link nil | ||
| 1842 | "Non-nil means, mouse-1 on a link will follow the link in the agenda. | ||
| 1843 | A longer mouse click will still set point. Does not wortk on XEmacs. | ||
| 1844 | Needs to be set before org.el is loaded." | ||
| 1845 | :group 'org-agenda-startup | ||
| 1670 | :type 'boolean) | 1846 | :type 'boolean) |
| 1671 | 1847 | ||
| 1672 | (defcustom org-calendar-to-agenda-key [?c] | 1848 | (defcustom org-agenda-start-with-follow-mode nil |
| 1673 | "The key to be installed in `calendar-mode-map' for switching to the agenda. | 1849 | "The initial value of follwo-mode in a newly created agenda window." |
| 1674 | The command `org-calendar-goto-agenda' will be bound to this key. The | 1850 | :group 'org-agenda-startup |
| 1675 | default is the character `c' because then `c' can be used to switch back and | 1851 | :type 'boolean) |
| 1676 | forth between agenda and calendar." | ||
| 1677 | :group 'org-agenda | ||
| 1678 | :type 'sexp) | ||
| 1679 | 1852 | ||
| 1680 | (defgroup org-agenda-setup nil | 1853 | (defgroup org-agenda-windows nil |
| 1681 | "Options concerning setting up the Agenda window in Org Mode." | 1854 | "Options concerning the windows used by the Agenda in Org Mode." |
| 1682 | :tag "Org Agenda Window Setup" | 1855 | :tag "Org Agenda Windows" |
| 1683 | :group 'org-agenda) | 1856 | :group 'org-agenda) |
| 1684 | 1857 | ||
| 1685 | (defcustom org-agenda-window-setup 'reorganize-frame | 1858 | (defcustom org-agenda-window-setup 'reorganize-frame |
| @@ -1690,11 +1863,9 @@ current-window Show agenda in the current window, keeping all other windows. | |||
| 1690 | other-frame Use `switch-to-buffer-other-frame' to display agenda. | 1863 | other-frame Use `switch-to-buffer-other-frame' to display agenda. |
| 1691 | other-window Use `switch-to-buffer-other-window' to display agenda. | 1864 | other-window Use `switch-to-buffer-other-window' to display agenda. |
| 1692 | reorganize-frame Show only two windows on the current frame, the current | 1865 | reorganize-frame Show only two windows on the current frame, the current |
| 1693 | window and the agenda. Also, if the option | 1866 | window and the agenda. |
| 1694 | `org-fit-agenda-window' is set, resize the agenda window to | ||
| 1695 | try to show as much as possible of the buffer content. | ||
| 1696 | See also the variable `org-agenda-restore-windows-after-quit'." | 1867 | See also the variable `org-agenda-restore-windows-after-quit'." |
| 1697 | :group 'org-agenda-setup | 1868 | :group 'org-agenda-windows |
| 1698 | :type '(choice | 1869 | :type '(choice |
| 1699 | (const current-window) | 1870 | (const current-window) |
| 1700 | (const other-frame) | 1871 | (const other-frame) |
| @@ -1708,64 +1879,75 @@ the current status is recorded. When the agenda is exited with | |||
| 1708 | `q' or `x' and this option is set, the old state is restored. If | 1879 | `q' or `x' and this option is set, the old state is restored. If |
| 1709 | `org-agenda-window-setup' is `other-frame', the value of this | 1880 | `org-agenda-window-setup' is `other-frame', the value of this |
| 1710 | option will be ignored.." | 1881 | option will be ignored.." |
| 1711 | :group 'org-agenda-setup | 1882 | :group 'org-agenda-windows |
| 1712 | :type 'boolean) | ||
| 1713 | |||
| 1714 | ;; FIXME: I think this variable could be removed. | ||
| 1715 | (defcustom org-select-agenda-window t | ||
| 1716 | "Non-nil means, after creating an agenda, move cursor into Agenda window. | ||
| 1717 | When nil, cursor will remain in the current window." | ||
| 1718 | :group 'org-agenda-setup | ||
| 1719 | :type 'boolean) | 1883 | :type 'boolean) |
| 1720 | 1884 | ||
| 1721 | ;; FIXME: I think this variable could be removed. | 1885 | (defcustom org-indirect-buffer-display 'other-window |
| 1722 | (defcustom org-fit-agenda-window t | 1886 | "How should indirect tree buffers be displayed? |
| 1723 | "Non-nil means, change window size of agenda to fit content. | 1887 | This applies to indirect buffers created with the commands |
| 1724 | This is only effective if `org-agenda-window-setup' is `reorganize-frame'." | 1888 | \\[org-tree-to-indirect-buffer] and \\[org-agenda-tree-to-indirect-buffer]. |
| 1725 | :group 'org-agenda-setup | 1889 | Valid values are: |
| 1726 | :type 'boolean) | 1890 | current-window Display in the current window |
| 1727 | 1891 | other-window Just display in another window. | |
| 1728 | (defcustom org-finalize-agenda-hook nil | 1892 | dedicated-frame Create one new frame, and re-use it each time. |
| 1729 | "Hook run just before displaying an agenda buffer." | 1893 | new-frame Make a new frame each time." |
| 1730 | :group 'org-agenda-setup | 1894 | :group 'org-structure |
| 1731 | :type 'hook) | 1895 | :group 'org-agenda-windows |
| 1732 | 1896 | :type '(choice | |
| 1733 | (defcustom org-agenda-mouse-1-follows-link nil | 1897 | (const :tag "In current window" current-window) |
| 1734 | "Non-nil means, mouse-1 on a link will follow the link in the agenda. | 1898 | (const :tag "In current frame, other window" other-window) |
| 1735 | A longer mouse click will still set point. Does not wortk on XEmacs. | 1899 | (const :tag "Each time a new frame" new-frame) |
| 1736 | Needs to be set before org.el is loaded." | 1900 | (const :tag "One dedicated frame" dedicated-frame))) |
| 1737 | :group 'org-agenda-setup | 1901 | |
| 1738 | :type 'boolean) | 1902 | (defgroup org-agenda-daily/weekly nil |
| 1739 | 1903 | "Options concerning the daily/weekly agenda." | |
| 1740 | (defcustom org-agenda-start-with-follow-mode nil | 1904 | :tag "Org Agenda Daily/Weekly" |
| 1741 | "The initial value of follwo-mode in a newly created agenda window." | ||
| 1742 | :group 'org-agenda-setup | ||
| 1743 | :type 'boolean) | ||
| 1744 | |||
| 1745 | (defgroup org-agenda-display nil | ||
| 1746 | "Options concerning what to display initially in Agenda." | ||
| 1747 | :tag "Org Agenda Display" | ||
| 1748 | :group 'org-agenda) | 1905 | :group 'org-agenda) |
| 1749 | 1906 | ||
| 1750 | (defcustom org-agenda-show-all-dates t | 1907 | (defcustom org-agenda-ndays 7 |
| 1751 | "Non-nil means, `org-agenda' shows every day in the selected range. | 1908 | "Number of days to include in overview display. |
| 1752 | When nil, only the days which actually have entries are shown." | 1909 | Should be 1 or 7." |
| 1753 | :group 'org-agenda-display | 1910 | :group 'org-agenda-daily/weekly |
| 1754 | :type 'boolean) | 1911 | :type 'number) |
| 1755 | 1912 | ||
| 1756 | (defcustom org-agenda-start-on-weekday 1 | 1913 | (defcustom org-agenda-start-on-weekday 1 |
| 1757 | "Non-nil means, start the overview always on the specified weekday. | 1914 | "Non-nil means, start the overview always on the specified weekday. |
| 1758 | 0 denotes Sunday, 1 denotes Monday etc. | 1915 | 0 denotes Sunday, 1 denotes Monday etc. |
| 1759 | When nil, always start on the current day." | 1916 | When nil, always start on the current day." |
| 1760 | :group 'org-agenda-display | 1917 | :group 'org-agenda-daily/weekly |
| 1761 | :type '(choice (const :tag "Today" nil) | 1918 | :type '(choice (const :tag "Today" nil) |
| 1762 | (number :tag "Weekday No."))) | 1919 | (number :tag "Weekday No."))) |
| 1763 | 1920 | ||
| 1764 | (defcustom org-agenda-ndays 7 | 1921 | (defcustom org-agenda-show-all-dates t |
| 1765 | "Number of days to include in overview display. | 1922 | "Non-nil means, `org-agenda' shows every day in the selected range. |
| 1766 | Should be 1 or 7." | 1923 | When nil, only the days which actually have entries are shown." |
| 1767 | :group 'org-agenda-display | 1924 | :group 'org-agenda-daily/weekly |
| 1768 | :type 'number) | 1925 | :type 'boolean) |
| 1926 | |||
| 1927 | (defcustom org-agenda-date-format "%A %d %B %Y" | ||
| 1928 | "Format string for displaying dates in the agenda. | ||
| 1929 | Used by the daily/weekly agenda and by the timeline. This should be | ||
| 1930 | a format string understood by `format-time-string'. | ||
| 1931 | FIXME: Not used currently, because of timezone problem." | ||
| 1932 | :group 'org-agenda-daily/weekly | ||
| 1933 | :type 'string) | ||
| 1934 | |||
| 1935 | (defcustom org-agenda-include-diary nil | ||
| 1936 | "If non-nil, include in the agenda entries from the Emacs Calendar's diary." | ||
| 1937 | :group 'org-agenda-daily/weekly | ||
| 1938 | :type 'boolean) | ||
| 1939 | |||
| 1940 | (defcustom org-agenda-include-all-todo nil | ||
| 1941 | "Set means weekly/daily agenda will always contain all TODO entries. | ||
| 1942 | The TODO entries will be listed at the top of the agenda, before | ||
| 1943 | the entries for specific days." | ||
| 1944 | :group 'org-agenda-daily/weekly | ||
| 1945 | :type 'boolean) | ||
| 1946 | |||
| 1947 | (defgroup org-agenda-time-grid nil | ||
| 1948 | "Options concerning the time grid in the Org-mode Agenda." | ||
| 1949 | :tag "Org Agenda Time Grid" | ||
| 1950 | :group 'org-agenda) | ||
| 1769 | 1951 | ||
| 1770 | (defcustom org-agenda-use-time-grid t | 1952 | (defcustom org-agenda-use-time-grid t |
| 1771 | "Non-nil means, show a time grid in the agenda schedule. | 1953 | "Non-nil means, show a time grid in the agenda schedule. |
| @@ -1774,7 +1956,7 @@ A time grid is a set of lines for specific times (like every two hours between | |||
| 1774 | sorted in between these lines. | 1956 | sorted in between these lines. |
| 1775 | For details about when the grid will be shown, and what it will look like, see | 1957 | For details about when the grid will be shown, and what it will look like, see |
| 1776 | the variable `org-agenda-time-grid'." | 1958 | the variable `org-agenda-time-grid'." |
| 1777 | :group 'org-agenda-display | 1959 | :group 'org-agenda-time-grid |
| 1778 | :type 'boolean) | 1960 | :type 'boolean) |
| 1779 | 1961 | ||
| 1780 | (defcustom org-agenda-time-grid | 1962 | (defcustom org-agenda-time-grid |
| @@ -1795,7 +1977,7 @@ The second item is a string which will be places behing the grid time. | |||
| 1795 | 1977 | ||
| 1796 | The third item is a list of integers, indicating the times that should have | 1978 | The third item is a list of integers, indicating the times that should have |
| 1797 | a grid line." | 1979 | a grid line." |
| 1798 | :group 'org-agenda-display | 1980 | :group 'org-agenda-time-grid |
| 1799 | :type | 1981 | :type |
| 1800 | '(list | 1982 | '(list |
| 1801 | (set :greedy t :tag "Grid Display Options" | 1983 | (set :greedy t :tag "Grid Display Options" |
| @@ -1809,6 +1991,11 @@ a grid line." | |||
| 1809 | (string :tag "Grid String") | 1991 | (string :tag "Grid String") |
| 1810 | (repeat :tag "Grid Times" (integer :tag "Time")))) | 1992 | (repeat :tag "Grid Times" (integer :tag "Time")))) |
| 1811 | 1993 | ||
| 1994 | (defgroup org-agenda-sorting nil | ||
| 1995 | "Options concerning sorting in the Org-mode Agenda." | ||
| 1996 | :tag "Org Agenda Sorting" | ||
| 1997 | :group 'org-agenda) | ||
| 1998 | |||
| 1812 | (let ((sorting-choice | 1999 | (let ((sorting-choice |
| 1813 | '(choice | 2000 | '(choice |
| 1814 | (const time-up) (const time-down) | 2001 | (const time-up) (const time-down) |
| @@ -1848,7 +2035,7 @@ priority. | |||
| 1848 | 2035 | ||
| 1849 | Leaving out `category-keep' would mean that items will be sorted across | 2036 | Leaving out `category-keep' would mean that items will be sorted across |
| 1850 | categories by priority." | 2037 | categories by priority." |
| 1851 | :group 'org-agenda-display | 2038 | :group 'org-agenda-sorting |
| 1852 | :type `(choice | 2039 | :type `(choice |
| 1853 | (repeat :tag "General" ,sorting-choice) | 2040 | (repeat :tag "General" ,sorting-choice) |
| 1854 | (list :tag "Individually" | 2041 | (list :tag "Individually" |
| @@ -1866,7 +2053,7 @@ time like 15:30 will be considered as 99:01, i.e. later than any items which | |||
| 1866 | do have a time. When nil, the default time is before 0:00. You can use this | 2053 | do have a time. When nil, the default time is before 0:00. You can use this |
| 1867 | option to decide if the schedule for today should come before or after timeless | 2054 | option to decide if the schedule for today should come before or after timeless |
| 1868 | agenda entries." | 2055 | agenda entries." |
| 1869 | :group 'org-agenda-display | 2056 | :group 'org-agenda-sorting |
| 1870 | :type 'boolean) | 2057 | :type 'boolean) |
| 1871 | 2058 | ||
| 1872 | (defgroup org-agenda-prefix nil | 2059 | (defgroup org-agenda-prefix nil |
| @@ -2070,15 +2257,24 @@ This option can also be set with the +OPTIONS line, e.g. \"num:t\"." | |||
| 2070 | (defcustom org-export-with-toc t | 2257 | (defcustom org-export-with-toc t |
| 2071 | "Non-nil means, create a table of contents in exported files. | 2258 | "Non-nil means, create a table of contents in exported files. |
| 2072 | The TOC contains headlines with levels up to`org-export-headline-levels'. | 2259 | The TOC contains headlines with levels up to`org-export-headline-levels'. |
| 2260 | When an integer, include levels up to N in the toc, this may then be | ||
| 2261 | different from `org-export-headline-levels', but it will not be allowed | ||
| 2262 | to be larger than the number of headline levels. | ||
| 2263 | When nil, no table of contents is made. | ||
| 2073 | 2264 | ||
| 2074 | Headlines which contain any TODO items will be marked with \"(*)\" in | 2265 | Headlines which contain any TODO items will be marked with \"(*)\" in |
| 2075 | ASCII export, and with red color in HTML output. | 2266 | ASCII export, and with red color in HTML output, if the option |
| 2267 | `org-export-mark-todo-in-toc' is set. | ||
| 2076 | 2268 | ||
| 2077 | In HTML output, the TOC will be clickable. | 2269 | In HTML output, the TOC will be clickable. |
| 2078 | 2270 | ||
| 2079 | This option can also be set with the +OPTIONS line, e.g. \"toc:nil\"." | 2271 | This option can also be set with the +OPTIONS line, e.g. \"toc:nil\" |
| 2272 | or \"toc:3\"." | ||
| 2080 | :group 'org-export-general | 2273 | :group 'org-export-general |
| 2081 | :type 'boolean) | 2274 | :type '(choice |
| 2275 | (const :tag "No Table of Contents" nil) | ||
| 2276 | (const :tag "Full Table of Contents" t) | ||
| 2277 | (integer :tag "TOC to level"))) | ||
| 2082 | 2278 | ||
| 2083 | (defcustom org-export-mark-todo-in-toc nil | 2279 | (defcustom org-export-mark-todo-in-toc nil |
| 2084 | "Non-nil means, mark TOC lines that contain any open TODO items." | 2280 | "Non-nil means, mark TOC lines that contain any open TODO items." |
| @@ -2279,12 +2475,6 @@ Org-mode file." | |||
| 2279 | :group 'org-export-ascii | 2475 | :group 'org-export-ascii |
| 2280 | :type '(repeat character)) | 2476 | :type '(repeat character)) |
| 2281 | 2477 | ||
| 2282 | (defcustom org-export-ascii-show-new-buffer t | ||
| 2283 | "Non-nil means, popup buffer containing the exported ASCII text. | ||
| 2284 | Otherwise the buffer will just be saved to a file and stay hidden." | ||
| 2285 | :group 'org-export-ascii | ||
| 2286 | :type 'boolean) | ||
| 2287 | |||
| 2288 | (defgroup org-export-xml nil | 2478 | (defgroup org-export-xml nil |
| 2289 | "Options specific for XML export of Org-mode files." | 2479 | "Options specific for XML export of Org-mode files." |
| 2290 | :tag "Org Export XML" | 2480 | :tag "Org Export XML" |
| @@ -2317,7 +2507,7 @@ Otherwise the buffer will just be saved to a file and stay hidden." | |||
| 2317 | table { border-collapse: collapse; } | 2507 | table { border-collapse: collapse; } |
| 2318 | td, th { | 2508 | td, th { |
| 2319 | vertical-align: top; | 2509 | vertical-align: top; |
| 2320 | border: 1pt solid #ADB9CC; | 2510 | <!--border: 1pt solid #ADB9CC;--> |
| 2321 | } | 2511 | } |
| 2322 | </style>" | 2512 | </style>" |
| 2323 | "The default style specification for exported HTML files. | 2513 | "The default style specification for exported HTML files. |
| @@ -2377,6 +2567,7 @@ be linked only." | |||
| 2377 | (const :tag "Always" t) | 2567 | (const :tag "Always" t) |
| 2378 | (const :tag "When there is no description" maybe))) | 2568 | (const :tag "When there is no description" maybe))) |
| 2379 | 2569 | ||
| 2570 | ;; FIXME: rename | ||
| 2380 | (defcustom org-export-html-expand t | 2571 | (defcustom org-export-html-expand t |
| 2381 | "Non-nil means, for HTML export, treat @<...> as HTML tag. | 2572 | "Non-nil means, for HTML export, treat @<...> as HTML tag. |
| 2382 | When nil, these tags will be exported as plain text and therefore | 2573 | When nil, these tags will be exported as plain text and therefore |
| @@ -2387,7 +2578,7 @@ This option can also be set with the +OPTIONS line, e.g. \"@:nil\"." | |||
| 2387 | :type 'boolean) | 2578 | :type 'boolean) |
| 2388 | 2579 | ||
| 2389 | (defcustom org-export-html-table-tag | 2580 | (defcustom org-export-html-table-tag |
| 2390 | "<table border=\"1\" cellspacing=\"0\" cellpadding=\"6\">" | 2581 | "<table border=\"2\" cellspacing=\"0\" cellpadding=\"6\" rules=\"groups\" frame=\"hsides\">" |
| 2391 | "The HTML tag used to start a table. | 2582 | "The HTML tag used to start a table. |
| 2392 | This must be a <table> tag, but you may change the options like | 2583 | This must be a <table> tag, but you may change the options like |
| 2393 | borders and spacing." | 2584 | borders and spacing." |
| @@ -2407,12 +2598,6 @@ to a file." | |||
| 2407 | :group 'org-export-html | 2598 | :group 'org-export-html |
| 2408 | :type 'string) | 2599 | :type 'string) |
| 2409 | 2600 | ||
| 2410 | (defcustom org-export-html-show-new-buffer nil | ||
| 2411 | "Non-nil means, popup buffer containing the exported html text. | ||
| 2412 | Otherwise, the buffer will just be saved to a file and stay hidden." | ||
| 2413 | :group 'org-export-html | ||
| 2414 | :type 'boolean) | ||
| 2415 | |||
| 2416 | (defgroup org-export-icalendar nil | 2601 | (defgroup org-export-icalendar nil |
| 2417 | "Options specific for iCalendar export of Org-mode files." | 2602 | "Options specific for iCalendar export of Org-mode files." |
| 2418 | :tag "Org Export iCalendar" | 2603 | :tag "Org Export iCalendar" |
| @@ -2428,7 +2613,10 @@ The file name should be absolute." | |||
| 2428 | (defcustom org-icalendar-include-todo nil | 2613 | (defcustom org-icalendar-include-todo nil |
| 2429 | "Non-nil means, export to iCalendar files should also cover TODO items." | 2614 | "Non-nil means, export to iCalendar files should also cover TODO items." |
| 2430 | :group 'org-export-icalendar | 2615 | :group 'org-export-icalendar |
| 2431 | :type 'boolean) | 2616 | :type '(choice |
| 2617 | (const :tag "None" nil) | ||
| 2618 | (const :tag "Unfinished" t) | ||
| 2619 | (const :tag "All" all))) | ||
| 2432 | 2620 | ||
| 2433 | (defcustom org-icalendar-combined-name "OrgMode" | 2621 | (defcustom org-icalendar-combined-name "OrgMode" |
| 2434 | "Calendar name for the combined iCalendar representing all agenda files." | 2622 | "Calendar name for the combined iCalendar representing all agenda files." |
| @@ -2521,7 +2709,7 @@ Changing this variable requires a restart of Emacs to take effect." | |||
| 2521 | "\\([" post (if stacked markers) "]\\|$\\)"))))) | 2709 | "\\([" post (if stacked markers) "]\\|$\\)"))))) |
| 2522 | 2710 | ||
| 2523 | (defcustom org-emphasis-regexp-components | 2711 | (defcustom org-emphasis-regexp-components |
| 2524 | '(" \t(" " \t.,?;'\")" " \t\r\n," "." 1 nil) | 2712 | '(" \t('\"" " \t.,?;'\")" " \t\r\n," "." 1 nil) |
| 2525 | "Components used to build the reqular expression for emphasis. | 2713 | "Components used to build the reqular expression for emphasis. |
| 2526 | This is a list with 6 entries. Terminology: In an emphasis string | 2714 | This is a list with 6 entries. Terminology: In an emphasis string |
| 2527 | like \" *strong word* \", we call the initial space PREMATCH, the final | 2715 | like \" *strong word* \", we call the initial space PREMATCH, the final |
| @@ -2575,6 +2763,8 @@ Use customize to modify this, or restart Emacs after changing it." | |||
| 2575 | (string :tag "HTML start tag") | 2763 | (string :tag "HTML start tag") |
| 2576 | (string :tag "HTML end tag")))) | 2764 | (string :tag "HTML end tag")))) |
| 2577 | 2765 | ||
| 2766 | ;;; The faces | ||
| 2767 | |||
| 2578 | (defgroup org-faces nil | 2768 | (defgroup org-faces nil |
| 2579 | "Faces in Org-mode." | 2769 | "Faces in Org-mode." |
| 2580 | :tag "Org Faces" | 2770 | :tag "Org Faces" |
| @@ -2829,7 +3019,8 @@ This face is only used if `org-fontify-done-headline' is set." | |||
| 2829 | (defconst org-n-levels (length org-level-faces)) | 3019 | (defconst org-n-levels (length org-level-faces)) |
| 2830 | 3020 | ||
| 2831 | 3021 | ||
| 2832 | ;; Variables for pre-computed regular expressions, all buffer local | 3022 | ;;; Variables for pre-computed regular expressions, all buffer local |
| 3023 | |||
| 2833 | (defvar org-done-string nil | 3024 | (defvar org-done-string nil |
| 2834 | "The last string in `org-todo-keywords', indicating an item is DONE.") | 3025 | "The last string in `org-todo-keywords', indicating an item is DONE.") |
| 2835 | (make-variable-buffer-local 'org-done-string) | 3026 | (make-variable-buffer-local 'org-done-string) |
| @@ -2881,14 +3072,17 @@ Also put tags into group 4 if tags are present.") | |||
| 2881 | (make-variable-buffer-local 'org-closed-time-regexp) | 3072 | (make-variable-buffer-local 'org-closed-time-regexp) |
| 2882 | 3073 | ||
| 2883 | (defvar org-keyword-time-regexp nil | 3074 | (defvar org-keyword-time-regexp nil |
| 2884 | "Matches any of the 3 keywords, together with the time stamp.") | 3075 | "Matches any of the 4 keywords, together with the time stamp.") |
| 2885 | (make-variable-buffer-local 'org-keyword-time-regexp) | 3076 | (make-variable-buffer-local 'org-keyword-time-regexp) |
| 3077 | (defvar org-keyword-time-not-clock-regexp nil | ||
| 3078 | "Matches any of the 3 keywords, together with the time stamp.") | ||
| 3079 | (make-variable-buffer-local 'org-keyword-time-not-clock-regexp) | ||
| 2886 | (defvar org-maybe-keyword-time-regexp nil | 3080 | (defvar org-maybe-keyword-time-regexp nil |
| 2887 | "Matches a timestamp, possibly preceeded by a keyword.") | 3081 | "Matches a timestamp, possibly preceeded by a keyword.") |
| 2888 | (make-variable-buffer-local 'org-keyword-time-regexp) | 3082 | (make-variable-buffer-local 'org-maybe-keyword-time-regexp) |
| 2889 | 3083 | ||
| 2890 | (defconst org-rm-props '(invisible t face t keymap t intangible t mouse-face t | 3084 | (defconst org-rm-props '(invisible t face t keymap t intangible t mouse-face t |
| 2891 | rear-nonsticky t mouse-map t) | 3085 | rear-nonsticky t mouse-map t fontified t) |
| 2892 | "Properties to remove when a string without properties is wanted.") | 3086 | "Properties to remove when a string without properties is wanted.") |
| 2893 | 3087 | ||
| 2894 | (defsubst org-match-string-no-properties (num &optional string) | 3088 | (defsubst org-match-string-no-properties (num &optional string) |
| @@ -2927,7 +3121,6 @@ Also put tags into group 4 if tags are present.") | |||
| 2927 | (defun org-let2 (list1 list2 &rest body) | 3121 | (defun org-let2 (list1 list2 &rest body) |
| 2928 | (eval (cons 'let (cons list1 (list (cons 'let (cons list2 body))))))) | 3122 | (eval (cons 'let (cons list1 (list (cons 'let (cons list2 body))))))) |
| 2929 | (put 'org-let2 'lisp-indent-function 2) | 3123 | (put 'org-let2 'lisp-indent-function 2) |
| 2930 | |||
| 2931 | (defconst org-startup-options | 3124 | (defconst org-startup-options |
| 2932 | '(("fold" org-startup-folded t) | 3125 | '(("fold" org-startup-folded t) |
| 2933 | ("overview" org-startup-folded t) | 3126 | ("overview" org-startup-folded t) |
| @@ -2942,9 +3135,16 @@ Also put tags into group 4 if tags are present.") | |||
| 2942 | ("noalign" org-startup-align-all-tables nil) | 3135 | ("noalign" org-startup-align-all-tables nil) |
| 2943 | ("customtime" org-display-custom-times t) | 3136 | ("customtime" org-display-custom-times t) |
| 2944 | ("logging" org-log-done t) | 3137 | ("logging" org-log-done t) |
| 3138 | ("logdone" org-log-done t) | ||
| 2945 | ("nologging" org-log-done nil) | 3139 | ("nologging" org-log-done nil) |
| 2946 | ("dlcheck" org-startup-with-deadline-check t) | 3140 | ("lognotedone" org-log-done done push) |
| 2947 | ("nodlcheck" org-startup-with-deadline-check nil))) | 3141 | ("lognotestate" org-log-done state push) |
| 3142 | ("lognoteclock-out" org-log-done clock-out push)) | ||
| 3143 | "Variable associated with STARTUP options for org-mode. | ||
| 3144 | Each element is a list of three items: The startup options as written | ||
| 3145 | in the #+STARTUP line, the corresponding variable, and the value to | ||
| 3146 | set this variable to if the option is found. An optional forth element PUSH | ||
| 3147 | means to push this value onto the list in the variable.") | ||
| 2948 | 3148 | ||
| 2949 | (defun org-set-regexps-and-options () | 3149 | (defun org-set-regexps-and-options () |
| 2950 | "Precompute regular expressions for current buffer." | 3150 | "Precompute regular expressions for current buffer." |
| @@ -2986,7 +3186,12 @@ Also put tags into group 4 if tags are present.") | |||
| 2986 | l var val) | 3186 | l var val) |
| 2987 | (while (setq l (assoc (pop opts) org-startup-options)) | 3187 | (while (setq l (assoc (pop opts) org-startup-options)) |
| 2988 | (setq var (nth 1 l) val (nth 2 l)) | 3188 | (setq var (nth 1 l) val (nth 2 l)) |
| 2989 | (set (make-local-variable var) val)))) | 3189 | (if (not (nth 3 l)) |
| 3190 | (set (make-local-variable var) val) | ||
| 3191 | (if (not (listp (symbol-value var))) | ||
| 3192 | (set (make-local-variable var) nil)) | ||
| 3193 | (set (make-local-variable var) (symbol-value var)) | ||
| 3194 | (add-to-list var val))))) | ||
| 2990 | ((equal key "ARCHIVE") | 3195 | ((equal key "ARCHIVE") |
| 2991 | (string-match " *$" value) | 3196 | (string-match " *$" value) |
| 2992 | (setq arch (replace-match "" t t value)) | 3197 | (setq arch (replace-match "" t t value)) |
| @@ -3059,6 +3264,11 @@ Also put tags into group 4 if tags are present.") | |||
| 3059 | "\\|" org-closed-string | 3264 | "\\|" org-closed-string |
| 3060 | "\\|" org-clock-string "\\)" | 3265 | "\\|" org-clock-string "\\)" |
| 3061 | " *[[<]\\([^]>]+\\)[]>]") | 3266 | " *[[<]\\([^]>]+\\)[]>]") |
| 3267 | org-keyword-time-not-clock-regexp | ||
| 3268 | (concat "\\<\\(" org-scheduled-string | ||
| 3269 | "\\|" org-deadline-string | ||
| 3270 | "\\|" org-closed-string "\\)" | ||
| 3271 | " *[[<]\\([^]>]+\\)[]>]") | ||
| 3062 | org-maybe-keyword-time-regexp | 3272 | org-maybe-keyword-time-regexp |
| 3063 | (concat "\\(\\<\\(" org-scheduled-string | 3273 | (concat "\\(\\<\\(" org-scheduled-string |
| 3064 | "\\|" org-deadline-string | 3274 | "\\|" org-deadline-string |
| @@ -3068,70 +3278,194 @@ Also put tags into group 4 if tags are present.") | |||
| 3068 | 3278 | ||
| 3069 | (org-set-font-lock-defaults))) | 3279 | (org-set-font-lock-defaults))) |
| 3070 | 3280 | ||
| 3071 | ;; Tell the compiler about dynamically scoped variables, | 3281 | |
| 3072 | ;; and variables from other packages | 3282 | ;;; Some variables ujsed in various places |
| 3073 | (defvar calc-embedded-close-formula) ; defined by the calc package | 3283 | |
| 3074 | (defvar calc-embedded-open-formula) ; defined by the calc package | 3284 | (defvar org-window-configuration nil |
| 3075 | (defvar font-lock-unfontify-region-function) ; defined by font-lock.el | 3285 | "Used in various places to store a window configuration.") |
| 3286 | (defvar org-finish-function nil | ||
| 3287 | "Function to be called when `C-c C-c' is used. | ||
| 3288 | This is for getting out of special buffers like remember.") | ||
| 3289 | |||
| 3290 | ;;; Foreign variables, to inform the compiler | ||
| 3291 | |||
| 3292 | ;; XEmacs only | ||
| 3293 | (defvar outline-mode-menu-heading) | ||
| 3294 | (defvar outline-mode-menu-show) | ||
| 3295 | (defvar outline-mode-menu-hide) | ||
| 3076 | (defvar zmacs-regions) ; XEmacs regions | 3296 | (defvar zmacs-regions) ; XEmacs regions |
| 3077 | (defvar original-date) ; dynamically scoped in calendar | 3297 | ;; Emacs only |
| 3078 | (defvar org-old-auto-fill-inhibit-regexp) ; local variable used by `orgtbl-mode' | 3298 | (defvar mark-active) |
| 3079 | (defvar orgtbl-mode-menu) ; defined when orgtbl mode get initialized | 3299 | |
| 3080 | (defvar org-html-entities) ; defined later in this file | 3300 | ;; Packages that org-mode interacts with |
| 3081 | (defvar org-goto-start-pos) ; dynamically scoped parameter | 3301 | (defvar calc-embedded-close-formula) |
| 3082 | (defvar org-time-was-given) ; dynamically scoped parameter | 3302 | (defvar calc-embedded-open-formula) |
| 3083 | (defvar org-ts-what) ; dynamically scoped parameter | 3303 | (defvar font-lock-unfontify-region-function) |
| 3084 | (defvar org-current-export-file) ; dynamically scoped parameter | 3304 | (defvar org-goto-start-pos) |
| 3085 | (defvar org-current-export-dir) ; dynamically scoped parameter | 3305 | (defvar vm-message-pointer) |
| 3086 | (defvar mark-active) ; Emacs only, not available in XEmacs. | 3306 | (defvar vm-folder-directory) |
| 3087 | (defvar timecnt) ; dynamically scoped parameter | 3307 | (defvar wl-summary-buffer-elmo-folder) |
| 3088 | (defvar levels-open) ; dynamically scoped parameter | 3308 | (defvar wl-summary-buffer-folder-name) |
| 3089 | (defvar entry) ; dynamically scoped parameter | 3309 | (defvar gnus-other-frame-object) |
| 3090 | (defvar state) ; dynamically scoped into `org-after-todo-state-change-hook' | 3310 | (defvar gnus-group-name) |
| 3091 | (defvar date) ; dynamically scoped parameter | 3311 | (defvar gnus-article-current) |
| 3092 | (defvar description) ; dynamically scoped parameter | 3312 | (defvar w3m-current-url) |
| 3093 | (defvar ans1) ; dynamically scoped parameter | 3313 | (defvar w3m-current-title) |
| 3094 | (defvar ans2) ; dynamically scoped parameter | 3314 | (defvar mh-progs) |
| 3095 | (defvar starting-day) ; local variable | 3315 | (defvar mh-current-folder) |
| 3096 | (defvar include-all-loc) ; local variable | 3316 | (defvar mh-show-folder-buffer) |
| 3097 | (defvar vm-message-pointer) ; from vm | 3317 | (defvar mh-index-folder) |
| 3098 | (defvar vm-folder-directory) ; from vm | 3318 | (defvar mh-searcher) |
| 3099 | (defvar gnus-other-frame-object) ; from gnus | 3319 | (defvar calendar-mode-map) |
| 3100 | (defvar wl-summary-buffer-elmo-folder) ; from wanderlust | 3320 | (defvar Info-current-file) |
| 3101 | (defvar wl-summary-buffer-folder-name) ; from wanderlust | 3321 | (defvar Info-current-node) |
| 3102 | (defvar gnus-group-name) ; from gnus | 3322 | (defvar texmathp-why) |
| 3103 | (defvar gnus-article-current) ; from gnus | 3323 | (defvar remember-save-after-remembering) |
| 3104 | (defvar w3m-current-url) ; from w3m | 3324 | (defvar remember-data-file) |
| 3105 | (defvar w3m-current-title) ; from w3m | ||
| 3106 | (defvar mh-progs) ; from MH-E | ||
| 3107 | (defvar mh-current-folder) ; from MH-E | ||
| 3108 | (defvar mh-show-folder-buffer) ; from MH-E | ||
| 3109 | (defvar mh-index-folder) ; from MH-E | ||
| 3110 | (defvar mh-searcher) ; from MH-E | ||
| 3111 | (defvar org-selected-point) ; dynamically scoped parameter | ||
| 3112 | (defvar calendar-mode-map) ; from calendar.el | ||
| 3113 | (defvar last-arg) ; local variable | ||
| 3114 | (defvar remember-save-after-remembering) ; from remember.el | ||
| 3115 | (defvar remember-data-file) ; from remember.el | ||
| 3116 | (defvar annotation) ; from remember.el, dynamically scoped in `remember-mode' | 3325 | (defvar annotation) ; from remember.el, dynamically scoped in `remember-mode' |
| 3117 | (defvar initial) ; from remember.el, dynamically scoped in `remember-mode' | 3326 | (defvar initial) ; from remember.el, dynamically scoped in `remember-mode' |
| 3118 | (defvar orgtbl-mode) ; defined later in this file | ||
| 3119 | (defvar Info-current-file) ; from info.el | ||
| 3120 | (defvar Info-current-node) ; from info.el | ||
| 3121 | (defvar texmathp-why) ; from texmathp.el | ||
| 3122 | (defvar org-latex-regexps) | 3327 | (defvar org-latex-regexps) |
| 3123 | (defvar outline-mode-menu-heading) | ||
| 3124 | (defvar outline-mode-menu-show) | ||
| 3125 | (defvar outline-mode-menu-hide) | ||
| 3126 | 3328 | ||
| 3127 | ;;; Define the mode | 3329 | (defvar original-date) ; dynamically scoped in calendar.el does scope this |
| 3330 | |||
| 3331 | ;; FIXME: Occasionally check by commenting these, to make sure | ||
| 3332 | ;; no other functions uses these, forgetting to let-bind them. | ||
| 3333 | (defvar entry) | ||
| 3334 | (defvar state) | ||
| 3335 | (defvar last-state) | ||
| 3336 | (defvar date) | ||
| 3337 | (defvar description) | ||
| 3338 | |||
| 3339 | |||
| 3340 | ;; Defined somewhere in this file, but used before definition. | ||
| 3341 | (defvar orgtbl-mode-menu) ; defined when orgtbl mode get initialized | ||
| 3342 | (defvar org-agenda-undo-list) | ||
| 3343 | (defvar org-agenda-pending-undo-list) | ||
| 3344 | (defvar org-agenda-overriding-header) | ||
| 3345 | (defvar orgtbl-mode) | ||
| 3346 | (defvar org-html-entities) | ||
| 3347 | (defvar org-struct-menu) | ||
| 3348 | (defvar org-org-menu) | ||
| 3349 | (defvar org-tbl-menu) | ||
| 3350 | (defvar org-agenda-keymap) | ||
| 3351 | (defvar org-category-table) | ||
| 3352 | |||
| 3353 | ;;;; Emacs/XEmacs compatibility | ||
| 3354 | |||
| 3355 | ;; Overlay compatibility functions | ||
| 3356 | (defun org-make-overlay (beg end &optional buffer) | ||
| 3357 | (if (featurep 'xemacs) | ||
| 3358 | (make-extent beg end buffer) | ||
| 3359 | (make-overlay beg end buffer))) | ||
| 3360 | (defun org-delete-overlay (ovl) | ||
| 3361 | (if (featurep 'xemacs) (delete-extent ovl) (delete-overlay ovl))) | ||
| 3362 | (defun org-detach-overlay (ovl) | ||
| 3363 | (if (featurep 'xemacs) (detach-extent ovl) (delete-overlay ovl))) | ||
| 3364 | (defun org-move-overlay (ovl beg end &optional buffer) | ||
| 3365 | (if (featurep 'xemacs) | ||
| 3366 | (set-extent-endpoints ovl beg end (or buffer (current-buffer))) | ||
| 3367 | (move-overlay ovl beg end buffer))) | ||
| 3368 | (defun org-overlay-put (ovl prop value) | ||
| 3369 | (if (featurep 'xemacs) | ||
| 3370 | (set-extent-property ovl prop value) | ||
| 3371 | (overlay-put ovl prop value))) | ||
| 3372 | (defun org-overlay-display (ovl text &optional face evap) | ||
| 3373 | "Make overlay OVL display TEXT with face FACE." | ||
| 3374 | (if (featurep 'xemacs) | ||
| 3375 | (let ((gl (make-glyph text))) | ||
| 3376 | (and face (set-glyph-face gl face)) | ||
| 3377 | (set-extent-property ovl 'invisible t) | ||
| 3378 | (set-extent-property ovl 'end-glyph gl)) | ||
| 3379 | (overlay-put ovl 'display text) | ||
| 3380 | (if face (overlay-put ovl 'face face)) | ||
| 3381 | (if evap (overlay-put ovl 'evaporate t)))) | ||
| 3382 | (defun org-overlay-before-string (ovl text &optional face evap) | ||
| 3383 | "Make overlay OVL display TEXT with face FACE." | ||
| 3384 | (if (featurep 'xemacs) | ||
| 3385 | (let ((gl (make-glyph text))) | ||
| 3386 | (and face (set-glyph-face gl face)) | ||
| 3387 | (set-extent-property ovl 'begin-glyph gl)) | ||
| 3388 | (if face (org-add-props text nil 'face face)) | ||
| 3389 | (overlay-put ovl 'before-string text) | ||
| 3390 | (if evap (overlay-put ovl 'evaporate t)))) | ||
| 3391 | (defun org-overlay-get (ovl prop) | ||
| 3392 | (if (featurep 'xemacs) | ||
| 3393 | (extent-property ovl prop) | ||
| 3394 | (overlay-get ovl prop))) | ||
| 3395 | (defun org-overlays-at (pos) | ||
| 3396 | (if (featurep 'xemacs) (extents-at pos) (overlays-at pos))) | ||
| 3397 | (defun org-overlays-in (&optional start end) | ||
| 3398 | (if (featurep 'xemacs) | ||
| 3399 | (extent-list nil start end) | ||
| 3400 | (overlays-in start end))) | ||
| 3401 | (defun org-overlay-start (o) | ||
| 3402 | (if (featurep 'xemacs) (extent-start-position o) (overlay-start o))) | ||
| 3403 | (defun org-overlay-end (o) | ||
| 3404 | (if (featurep 'xemacs) (extent-end-position o) (overlay-end o))) | ||
| 3405 | (defun org-find-overlays (prop &optional pos delete) | ||
| 3406 | "Find all overlays specifying PROP at POS or point. | ||
| 3407 | If DELETE is non-nil, delete all those overlays." | ||
| 3408 | (let ((overlays (org-overlays-at (or pos (point)))) | ||
| 3409 | ov found) | ||
| 3410 | (while (setq ov (pop overlays)) | ||
| 3411 | (if (org-overlay-get ov prop) | ||
| 3412 | (if delete (org-delete-overlay ov) (push ov found)))) | ||
| 3413 | found)) | ||
| 3414 | |||
| 3415 | ;; Region compatibility | ||
| 3416 | |||
| 3417 | (defun org-add-hook (hook function &optional append local) | ||
| 3418 | "Add-hook, compatible with both Emacsen." | ||
| 3419 | (if (and local (featurep 'xemacs)) | ||
| 3420 | (add-local-hook hook function append) | ||
| 3421 | (add-hook hook function append local))) | ||
| 3422 | |||
| 3423 | (defvar org-ignore-region nil | ||
| 3424 | "To temporarily disable the active region.") | ||
| 3425 | |||
| 3426 | (defun org-region-active-p () | ||
| 3427 | "Is `transient-mark-mode' on and the region active? | ||
| 3428 | Works on both Emacs and XEmacs." | ||
| 3429 | (if org-ignore-region | ||
| 3430 | nil | ||
| 3431 | (if (featurep 'xemacs) | ||
| 3432 | (and zmacs-regions (region-active-p)) | ||
| 3433 | (and transient-mark-mode mark-active)))) | ||
| 3434 | |||
| 3435 | ;; Invisibility compatibility | ||
| 3436 | |||
| 3437 | (defun org-add-to-invisibility-spec (arg) | ||
| 3438 | "Add elements to `buffer-invisibility-spec'. | ||
| 3439 | See documentation for `buffer-invisibility-spec' for the kind of elements | ||
| 3440 | that can be added." | ||
| 3441 | (cond | ||
| 3442 | ((fboundp 'add-to-invisibility-spec) | ||
| 3443 | (add-to-invisibility-spec arg)) | ||
| 3444 | ((or (null buffer-invisibility-spec) (eq buffer-invisibility-spec t)) | ||
| 3445 | (setq buffer-invisibility-spec (list arg))) | ||
| 3446 | (t | ||
| 3447 | (setq buffer-invisibility-spec | ||
| 3448 | (cons arg buffer-invisibility-spec))))) | ||
| 3449 | |||
| 3450 | (defun org-remove-from-invisibility-spec (arg) | ||
| 3451 | "Remove elements from `buffer-invisibility-spec'." | ||
| 3452 | (if (fboundp 'remove-from-invisibility-spec) | ||
| 3453 | (remove-from-invisibility-spec arg) | ||
| 3454 | (if (consp buffer-invisibility-spec) | ||
| 3455 | (setq buffer-invisibility-spec | ||
| 3456 | (delete arg buffer-invisibility-spec))))) | ||
| 3457 | |||
| 3458 | (defun org-in-invisibility-spec-p (arg) | ||
| 3459 | "Is ARG a member of `buffer-invisibility-spec'?" | ||
| 3460 | (if (consp buffer-invisibility-spec) | ||
| 3461 | (member arg buffer-invisibility-spec) | ||
| 3462 | nil)) | ||
| 3463 | |||
| 3464 | ;;;; Define the Org-mode | ||
| 3128 | 3465 | ||
| 3129 | (if (and (not (keymapp outline-mode-map)) (featurep 'allout)) | 3466 | (if (and (not (keymapp outline-mode-map)) (featurep 'allout)) |
| 3130 | (error "Conflict with outdated version of allout.el. Load org.el before allout.el, or ugrade to newer allout, for example by switching to Emacs 22.")) | 3467 | (error "Conflict with outdated version of allout.el. Load org.el before allout.el, or ugrade to newer allout, for example by switching to Emacs 22.")) |
| 3131 | 3468 | ||
| 3132 | (defvar org-struct-menu) ; defined later in this file | ||
| 3133 | (defvar org-org-menu) ; defined later in this file | ||
| 3134 | (defvar org-tbl-menu) ; defined later in this file | ||
| 3135 | 3469 | ||
| 3136 | ;; We use a before-change function to check if a table might need | 3470 | ;; We use a before-change function to check if a table might need |
| 3137 | ;; an update. | 3471 | ;; an update. |
| @@ -3189,7 +3523,8 @@ The following commands are available: | |||
| 3189 | (setq outline-regexp "\\*+") | 3523 | (setq outline-regexp "\\*+") |
| 3190 | ;;(setq outline-regexp "\\(?:\\*+\\|[ \t]*\\(?:[-+*]\\|[0-9]+[.)]\\) \\)") | 3524 | ;;(setq outline-regexp "\\(?:\\*+\\|[ \t]*\\(?:[-+*]\\|[0-9]+[.)]\\) \\)") |
| 3191 | (setq outline-level 'org-outline-level) | 3525 | (setq outline-level 'org-outline-level) |
| 3192 | (when (and org-ellipsis (stringp org-ellipsis)) | 3526 | (when (and org-ellipsis (stringp org-ellipsis) |
| 3527 | (fboundp 'set-display-table-slot) (boundp 'buffer-display-table)) | ||
| 3193 | (unless org-display-table | 3528 | (unless org-display-table |
| 3194 | (setq org-display-table (make-display-table))) | 3529 | (setq org-display-table (make-display-table))) |
| 3195 | (set-display-table-slot org-display-table | 3530 | (set-display-table-slot org-display-table |
| @@ -3211,10 +3546,21 @@ The following commands are available: | |||
| 3211 | ;; Paragraphs and auto-filling | 3546 | ;; Paragraphs and auto-filling |
| 3212 | (org-set-autofill-regexps) | 3547 | (org-set-autofill-regexps) |
| 3213 | (org-update-radio-target-regexp) | 3548 | (org-update-radio-target-regexp) |
| 3214 | ;; Make isearch reveal context after success | ||
| 3215 | (org-set-local 'outline-isearch-open-invisible-function | ||
| 3216 | (lambda (&rest ignore) (org-show-context nil t))) | ||
| 3217 | 3549 | ||
| 3550 | ;; Comment characters | ||
| 3551 | ; (org-set-local 'comment-start "#") ;; FIXME: this breaks wrapping | ||
| 3552 | (org-set-local 'comment-padding " ") | ||
| 3553 | |||
| 3554 | ;; Make isearch reveal context | ||
| 3555 | (if (or (featurep 'xemacs) | ||
| 3556 | (not (boundp 'outline-isearch-open-invisible-function))) | ||
| 3557 | ;; Emacs 21 and XEmacs make use of the hook | ||
| 3558 | (org-add-hook 'isearch-mode-end-hook 'org-isearch-end 'append 'local) | ||
| 3559 | ;; Emacs 22 deals with this through a special variable | ||
| 3560 | (org-set-local 'outline-isearch-open-invisible-function | ||
| 3561 | (lambda (&rest ignore) (org-show-context 'isearch)))) | ||
| 3562 | |||
| 3563 | ;; If empty file that did not turn on org-mode automatically, make it to. | ||
| 3218 | (if (and org-insert-mode-line-in-empty-file | 3564 | (if (and org-insert-mode-line-in-empty-file |
| 3219 | (interactive-p) | 3565 | (interactive-p) |
| 3220 | (= (point-min) (point-max))) | 3566 | (= (point-min) (point-max))) |
| @@ -3225,14 +3571,12 @@ The following commands are available: | |||
| 3225 | (let ((bmp (buffer-modified-p))) | 3571 | (let ((bmp (buffer-modified-p))) |
| 3226 | (org-table-map-tables 'org-table-align) | 3572 | (org-table-map-tables 'org-table-align) |
| 3227 | (set-buffer-modified-p bmp))) | 3573 | (set-buffer-modified-p bmp))) |
| 3228 | (if org-startup-with-deadline-check | 3574 | (cond |
| 3229 | (call-interactively 'org-check-deadlines) | 3575 | ((eq org-startup-folded t) |
| 3230 | (cond | 3576 | (org-cycle '(4))) |
| 3231 | ((eq org-startup-folded t) | 3577 | ((eq org-startup-folded 'content) |
| 3232 | (org-cycle '(4))) | 3578 | (let ((this-command 'org-cycle) (last-command 'org-cycle)) |
| 3233 | ((eq org-startup-folded 'content) | 3579 | (org-cycle '(4)) (org-cycle '(4))))))) |
| 3234 | (let ((this-command 'org-cycle) (last-command 'org-cycle)) | ||
| 3235 | (org-cycle '(4)) (org-cycle '(4)))))))) | ||
| 3236 | 3580 | ||
| 3237 | (defsubst org-call-with-arg (command arg) | 3581 | (defsubst org-call-with-arg (command arg) |
| 3238 | "Call COMMAND interactively, but pretend prefix are was ARG." | 3582 | "Call COMMAND interactively, but pretend prefix are was ARG." |
| @@ -3263,7 +3607,7 @@ that will be added to PLIST. Returns the string that was modified." | |||
| 3263 | (put 'org-add-props 'lisp-indent-function 2) | 3607 | (put 'org-add-props 'lisp-indent-function 2) |
| 3264 | 3608 | ||
| 3265 | 3609 | ||
| 3266 | ;;; Font-Lock stuff | 3610 | ;;;; Font-Lock stuff, including the activators |
| 3267 | 3611 | ||
| 3268 | (defvar org-mouse-map (make-sparse-keymap)) | 3612 | (defvar org-mouse-map (make-sparse-keymap)) |
| 3269 | (define-key org-mouse-map | 3613 | (define-key org-mouse-map |
| @@ -3331,6 +3675,12 @@ that will be added to PLIST. Returns the string that was modified." | |||
| 3331 | ; 4: [desc] | 3675 | ; 4: [desc] |
| 3332 | ; 5: desc | 3676 | ; 5: desc |
| 3333 | 3677 | ||
| 3678 | (defconst org-any-link-re | ||
| 3679 | (concat "\\(" org-bracket-link-regexp "\\)\\|\\(" | ||
| 3680 | org-angle-link-re "\\)\\|\\(" | ||
| 3681 | org-plain-link-re "\\)") | ||
| 3682 | "Regular expression matching any link.") | ||
| 3683 | |||
| 3334 | (defconst org-ts-lengths | 3684 | (defconst org-ts-lengths |
| 3335 | (cons (length (format-time-string (car org-time-stamp-formats))) | 3685 | (cons (length (format-time-string (car org-time-stamp-formats))) |
| 3336 | (length (format-time-string (cdr org-time-stamp-formats)))) | 3686 | (length (format-time-string (cdr org-time-stamp-formats)))) |
| @@ -3438,10 +3788,6 @@ We use a macro so that the test can happen at compilation time." | |||
| 3438 | 3788 | ||
| 3439 | (defun org-activate-dates (limit) | 3789 | (defun org-activate-dates (limit) |
| 3440 | "Run through the buffer and add overlays to dates." | 3790 | "Run through the buffer and add overlays to dates." |
| 3441 | ; (if (re-search-forward org-tsr-regexp limit t) | ||
| 3442 | ; (if (re-search-forward | ||
| 3443 | ; (if org-display-custom-times org-ts-regexp-both org-tsr-regexp-both) | ||
| 3444 | ; limit t) | ||
| 3445 | (if (re-search-forward org-tsr-regexp-both limit t) | 3791 | (if (re-search-forward org-tsr-regexp-both limit t) |
| 3446 | (progn | 3792 | (progn |
| 3447 | (add-text-properties (match-beginning 0) (match-end 0) | 3793 | (add-text-properties (match-beginning 0) (match-end 0) |
| @@ -3526,19 +3872,6 @@ between words." | |||
| 3526 | "\\|") | 3872 | "\\|") |
| 3527 | "\\)\\>"))) | 3873 | "\\)\\>"))) |
| 3528 | 3874 | ||
| 3529 | (defvar org-camel-regexp "\\*?\\<[A-Z]+[a-z]+[A-Z][a-zA-Z]*\\>" | ||
| 3530 | "Matches CamelCase words, possibly with a star before it.") | ||
| 3531 | |||
| 3532 | (defun org-activate-camels (limit) | ||
| 3533 | "Run through the buffer and add overlays to dates." | ||
| 3534 | (if (re-search-forward org-camel-regexp limit t) | ||
| 3535 | (progn | ||
| 3536 | (add-text-properties (match-beginning 0) (match-end 0) | ||
| 3537 | (list 'mouse-face 'highlight | ||
| 3538 | 'rear-nonsticky t | ||
| 3539 | 'keymap org-mouse-map)) | ||
| 3540 | t))) | ||
| 3541 | |||
| 3542 | (defun org-activate-tags (limit) | 3875 | (defun org-activate-tags (limit) |
| 3543 | (if (re-search-forward "[ \t]\\(:[A-Za-z_@0-9:]+:\\)[ \r\n]" limit t) | 3876 | (if (re-search-forward "[ \t]\\(:[A-Za-z_@0-9:]+:\\)[ \r\n]" limit t) |
| 3544 | (progn | 3877 | (progn |
| @@ -3578,16 +3911,14 @@ between words." | |||
| 3578 | (if (memq 'bracket lk) '(org-activate-bracket-links (0 'org-link t))) | 3911 | (if (memq 'bracket lk) '(org-activate-bracket-links (0 'org-link t))) |
| 3579 | (if (memq 'radio lk) '(org-activate-target-links (0 'org-link t))) | 3912 | (if (memq 'radio lk) '(org-activate-target-links (0 'org-link t))) |
| 3580 | (if (memq 'date lk) '(org-activate-dates (0 'org-date t))) | 3913 | (if (memq 'date lk) '(org-activate-dates (0 'org-date t))) |
| 3581 | (if (memq 'camel lk) '(org-activate-camels (0 'org-link t))) | ||
| 3582 | (if (memq 'tag lk) '(org-activate-tags (1 'org-tag prepend))) | 3914 | (if (memq 'tag lk) '(org-activate-tags (1 'org-tag prepend))) |
| 3583 | (if org-table-limit-column-width | ||
| 3584 | '(org-hide-wide-columns (0 nil append))) | ||
| 3585 | ;; TODO lines | 3915 | ;; TODO lines |
| 3586 | (list (concat "^\\*+[ \t]*" org-not-done-regexp) | 3916 | (list (concat "^\\*+[ \t]*" org-not-done-regexp) |
| 3587 | '(1 'org-todo t)) | 3917 | '(1 'org-todo t)) |
| 3588 | ;; Priorities | 3918 | ;; Priorities |
| 3589 | (list (concat "\\[#[A-Z]\\]") '(0 'org-special-keyword t)) | 3919 | (list (concat "\\[#[A-Z]\\]") '(0 'org-special-keyword t)) |
| 3590 | ;; Special keywords | 3920 | ;; Special keywords |
| 3921 | (list org-repeat-re '(0 'org-special-keyword t)) | ||
| 3591 | (list (concat "\\<" org-deadline-string) '(0 'org-special-keyword t)) | 3922 | (list (concat "\\<" org-deadline-string) '(0 'org-special-keyword t)) |
| 3592 | (list (concat "\\<" org-scheduled-string) '(0 'org-special-keyword t)) | 3923 | (list (concat "\\<" org-scheduled-string) '(0 'org-special-keyword t)) |
| 3593 | (list (concat "\\<" org-closed-string) '(0 'org-special-keyword t)) | 3924 | (list (concat "\\<" org-closed-string) '(0 'org-special-keyword t)) |
| @@ -3655,7 +3986,9 @@ between words." | |||
| 3655 | rear-nonsticky t | 3986 | rear-nonsticky t |
| 3656 | invisible t intangible t)))) | 3987 | invisible t intangible t)))) |
| 3657 | 3988 | ||
| 3658 | ;;; Visibility cycling | 3989 | ;;;; Visibility cycling, including org-goto and indirect buffer |
| 3990 | |||
| 3991 | ;;; Cycling | ||
| 3659 | 3992 | ||
| 3660 | (defvar org-cycle-global-status nil) | 3993 | (defvar org-cycle-global-status nil) |
| 3661 | (make-variable-buffer-local 'org-cycle-global-status) | 3994 | (make-variable-buffer-local 'org-cycle-global-status) |
| @@ -3767,14 +4100,16 @@ between words." | |||
| 3767 | (get-char-property (1- (point)) 'invisible)) | 4100 | (get-char-property (1- (point)) 'invisible)) |
| 3768 | (beginning-of-line 2)) (setq eol (point))) | 4101 | (beginning-of-line 2)) (setq eol (point))) |
| 3769 | (outline-end-of-heading) (setq eoh (point)) | 4102 | (outline-end-of-heading) (setq eoh (point)) |
| 3770 | (org-end-of-subtree t) (setq eos (point)) | 4103 | (org-end-of-subtree t) |
| 3771 | (outline-next-heading)) | 4104 | (skip-chars-forward " \t\n") |
| 4105 | (beginning-of-line 1) ; in case this is an item | ||
| 4106 | (setq eos (1- (point)))) | ||
| 3772 | ;; Find out what to do next and set `this-command' | 4107 | ;; Find out what to do next and set `this-command' |
| 3773 | (cond | 4108 | (cond |
| 3774 | ((and (= eos eoh) | 4109 | ((= eos eoh) |
| 3775 | ;; Nothing is hidden behind this heading | 4110 | ;; Nothing is hidden behind this heading |
| 3776 | (message "EMPTY ENTRY") | 4111 | (message "EMPTY ENTRY") |
| 3777 | (setq org-cycle-subtree-status nil))) | 4112 | (setq org-cycle-subtree-status nil)) |
| 3778 | ((>= eol eos) | 4113 | ((>= eol eos) |
| 3779 | ;; Entire subtree is hidden in one line: open it | 4114 | ;; Entire subtree is hidden in one line: open it |
| 3780 | (org-show-entry) | 4115 | (org-show-entry) |
| @@ -3849,12 +4184,13 @@ results." | |||
| 3849 | (funcall outline-level)) | 4184 | (funcall outline-level)) |
| 3850 | 1)))) | 4185 | 1)))) |
| 3851 | 4186 | ||
| 3852 | ;; FIXME: allow an argument to give a limiting level for this. | 4187 | (defun org-content (&optional arg) |
| 3853 | (defun org-content () | 4188 | "Show all headlines in the buffer, like a table of contents. |
| 3854 | "Show all headlines in the buffer, like a table of contents" | 4189 | With numerical argument N, show content up to level N." |
| 3855 | (interactive) | 4190 | (interactive "P") |
| 3856 | (save-excursion | 4191 | (save-excursion |
| 3857 | ;; Visit all headings and show their offspring | 4192 | ;; Visit all headings and show their offspring |
| 4193 | (and (integerp arg) (org-overview)) | ||
| 3858 | (goto-char (point-max)) | 4194 | (goto-char (point-max)) |
| 3859 | (catch 'exit | 4195 | (catch 'exit |
| 3860 | (while (and (progn (condition-case nil | 4196 | (while (and (progn (condition-case nil |
| @@ -3862,7 +4198,9 @@ results." | |||
| 3862 | (error (goto-char (point-min)))) | 4198 | (error (goto-char (point-min)))) |
| 3863 | t) | 4199 | t) |
| 3864 | (looking-at outline-regexp)) | 4200 | (looking-at outline-regexp)) |
| 3865 | (show-branches) | 4201 | (if (integerp arg) |
| 4202 | (show-children (1- arg)) | ||
| 4203 | (show-branches)) | ||
| 3866 | (if (bobp) (throw 'exit nil)))))) | 4204 | (if (bobp) (throw 'exit nil)))))) |
| 3867 | 4205 | ||
| 3868 | 4206 | ||
| @@ -3891,6 +4229,8 @@ Optional argument N means, put the headline into the Nth line of the window." | |||
| 3891 | (beginning-of-line) | 4229 | (beginning-of-line) |
| 3892 | (recenter (prefix-numeric-value N)))) | 4230 | (recenter (prefix-numeric-value N)))) |
| 3893 | 4231 | ||
| 4232 | ;;; Org-goto | ||
| 4233 | |||
| 3894 | (defvar org-goto-window-configuration nil) | 4234 | (defvar org-goto-window-configuration nil) |
| 3895 | (defvar org-goto-marker nil) | 4235 | (defvar org-goto-marker nil) |
| 3896 | (defvar org-goto-map (make-sparse-keymap)) | 4236 | (defvar org-goto-map (make-sparse-keymap)) |
| @@ -3948,6 +4288,8 @@ to the new location, making it and the headline hierarchy above it visible." | |||
| 3948 | (org-show-context 'org-goto))) | 4288 | (org-show-context 'org-goto))) |
| 3949 | (error "Quit")))) | 4289 | (error "Quit")))) |
| 3950 | 4290 | ||
| 4291 | (defvar org-selected-point nil) ; dynamically scoped parameter | ||
| 4292 | |||
| 3951 | (defun org-get-location (buf help) | 4293 | (defun org-get-location (buf help) |
| 3952 | "Let the user select a location in the Org-mode buffer BUF. | 4294 | "Let the user select a location in the Org-mode buffer BUF. |
| 3953 | This function uses a recursive edit. It returns the selected position | 4295 | This function uses a recursive edit. It returns the selected position |
| @@ -3965,12 +4307,16 @@ or nil." | |||
| 3965 | (insert-buffer-substring buf) | 4307 | (insert-buffer-substring buf) |
| 3966 | (let ((org-startup-truncated t) | 4308 | (let ((org-startup-truncated t) |
| 3967 | (org-startup-folded t) | 4309 | (org-startup-folded t) |
| 3968 | (org-startup-align-all-tables nil) | 4310 | (org-startup-align-all-tables nil)) |
| 3969 | (org-startup-with-deadline-check nil)) | ||
| 3970 | (org-mode)) | 4311 | (org-mode)) |
| 3971 | (setq buffer-read-only t) | 4312 | (setq buffer-read-only t) |
| 3972 | (if (boundp 'org-goto-start-pos) | 4313 | (if (and (boundp 'org-goto-start-pos) |
| 3973 | (goto-char org-goto-start-pos) | 4314 | (integer-or-marker-p org-goto-start-pos)) |
| 4315 | (let ((org-show-hierarchy-above t) | ||
| 4316 | (org-show-siblings t) | ||
| 4317 | (org-show-following-heading t)) | ||
| 4318 | (goto-char org-goto-start-pos) | ||
| 4319 | (and (org-invisible-p) (org-show-context))) | ||
| 3974 | (goto-char (point-min))) | 4320 | (goto-char (point-min))) |
| 3975 | (org-beginning-of-line) | 4321 | (org-beginning-of-line) |
| 3976 | (message "Select location and press RET") | 4322 | (message "Select location and press RET") |
| @@ -4022,10 +4368,89 @@ or nil." | |||
| 4022 | (setq org-selected-point nil) | 4368 | (setq org-selected-point nil) |
| 4023 | (throw 'exit nil)) | 4369 | (throw 'exit nil)) |
| 4024 | 4370 | ||
| 4025 | ;;; Promotion, Demotion, Inserting new headlines | 4371 | ;;; Indirect buffer display of subtrees |
| 4372 | |||
| 4373 | (defvar org-indirect-dedicated-frame nil | ||
| 4374 | "This is the frame being used for indirect tree display.") | ||
| 4375 | (defvar org-last-indirect-buffer nil) | ||
| 4376 | |||
| 4377 | (defun org-tree-to-indirect-buffer (&optional arg) | ||
| 4378 | "Create indirect buffer and narrow it to current subtree. | ||
| 4379 | With numerical prefix ARG, go up to this level and then take that tree. | ||
| 4380 | If ARG is negative, go up that many levels. | ||
| 4381 | Normally this command removes the indirect buffer previously made | ||
| 4382 | with this command. However, when called with a C-u prefix, the last buffer | ||
| 4383 | is kept so that you can work with several indirect buffers at the same time. | ||
| 4384 | If `org-indirect-buffer-display' is `dedicated-frame', the C-u prefix also | ||
| 4385 | requests that a new frame be made for the new buffer, so that the dedicated | ||
| 4386 | frame is not changed." | ||
| 4387 | (interactive "P") | ||
| 4388 | (let ((cbuf (current-buffer)) | ||
| 4389 | (cwin (selected-window)) | ||
| 4390 | (pos (point)) | ||
| 4391 | beg end level heading ibuf) | ||
| 4392 | (save-excursion | ||
| 4393 | (org-back-to-heading t) | ||
| 4394 | (when (numberp arg) | ||
| 4395 | (setq level (org-outline-level)) | ||
| 4396 | (if (< arg 0) (setq arg (+ level arg))) | ||
| 4397 | (while (> (setq level (org-outline-level)) arg) | ||
| 4398 | (outline-up-heading 1 t))) | ||
| 4399 | (setq beg (point) | ||
| 4400 | heading (org-get-heading)) | ||
| 4401 | (org-end-of-subtree t) (setq end (point))) | ||
| 4402 | (if (and (not arg) | ||
| 4403 | (buffer-live-p org-last-indirect-buffer)) | ||
| 4404 | (kill-buffer org-last-indirect-buffer)) | ||
| 4405 | (setq ibuf (org-get-indirect-buffer cbuf) | ||
| 4406 | org-last-indirect-buffer ibuf) | ||
| 4407 | (cond | ||
| 4408 | ((or (eq org-indirect-buffer-display 'new-frame) | ||
| 4409 | (and arg (eq org-indirect-buffer-display 'dedicated-frame))) | ||
| 4410 | (select-frame (make-frame)) | ||
| 4411 | (delete-other-windows) | ||
| 4412 | (switch-to-buffer ibuf) | ||
| 4413 | (org-set-frame-title heading)) | ||
| 4414 | ((eq org-indirect-buffer-display 'dedicated-frame) | ||
| 4415 | (raise-frame | ||
| 4416 | (select-frame (or (and org-indirect-dedicated-frame | ||
| 4417 | (frame-live-p org-indirect-dedicated-frame) | ||
| 4418 | org-indirect-dedicated-frame) | ||
| 4419 | (setq org-indirect-dedicated-frame (make-frame))))) | ||
| 4420 | (delete-other-windows) | ||
| 4421 | (switch-to-buffer ibuf) | ||
| 4422 | (org-set-frame-title (concat "Indirect: " heading))) | ||
| 4423 | ((eq org-indirect-buffer-display 'current-window) | ||
| 4424 | (switch-to-buffer ibuf)) | ||
| 4425 | ((eq org-indirect-buffer-display 'other-window) | ||
| 4426 | (pop-to-buffer ibuf)) | ||
| 4427 | (t (error "Invalid value."))) | ||
| 4428 | (if (featurep 'xemacs) | ||
| 4429 | (save-excursion (org-mode) (turn-on-font-lock))) | ||
| 4430 | (narrow-to-region beg end) | ||
| 4431 | (show-all) | ||
| 4432 | (goto-char pos) | ||
| 4433 | (and (window-live-p cwin) (select-window cwin)))) | ||
| 4434 | |||
| 4435 | (defun org-get-indirect-buffer (&optional buffer) | ||
| 4436 | (setq buffer (or buffer (current-buffer))) | ||
| 4437 | (let ((n 1) (base (buffer-name buffer)) bname) | ||
| 4438 | (while (buffer-live-p | ||
| 4439 | (get-buffer (setq bname (concat base "-" (number-to-string n))))) | ||
| 4440 | (setq n (1+ n))) | ||
| 4441 | (condition-case nil | ||
| 4442 | (make-indirect-buffer buffer bname 'clone) | ||
| 4443 | (error (make-indirect-buffer buffer bname))))) | ||
| 4026 | 4444 | ||
| 4027 | (defvar org-ignore-region nil | 4445 | (defun org-set-frame-title (title) |
| 4028 | "To temporarily disable the active region.") | 4446 | "Set the title of the current frame to the string TITLE." |
| 4447 | ;; FIXME: how to name a single frame in XEmacs??? | ||
| 4448 | (unless (featurep 'xemacs) | ||
| 4449 | (modify-frame-parameters (selected-frame) (list (cons 'name title))))) | ||
| 4450 | |||
| 4451 | ;;;; Structure editing | ||
| 4452 | |||
| 4453 | ;;; Inserting headlines | ||
| 4029 | 4454 | ||
| 4030 | (defun org-insert-heading (&optional force-heading) | 4455 | (defun org-insert-heading (&optional force-heading) |
| 4031 | "Insert a new heading or item with same depth at point. | 4456 | "Insert a new heading or item with same depth at point. |
| @@ -4060,49 +4485,6 @@ the current headline." | |||
| 4060 | (unless (= (point) pos) (just-one-space) (backward-delete-char 1)) | 4485 | (unless (= (point) pos) (just-one-space) (backward-delete-char 1)) |
| 4061 | (run-hooks 'org-insert-heading-hook))))) | 4486 | (run-hooks 'org-insert-heading-hook))))) |
| 4062 | 4487 | ||
| 4063 | (defun org-in-item-p () | ||
| 4064 | "It the cursor inside a plain list item. | ||
| 4065 | Does not have to be the first line." | ||
| 4066 | (save-excursion | ||
| 4067 | (condition-case nil | ||
| 4068 | (progn | ||
| 4069 | (org-beginning-of-item) | ||
| 4070 | (org-at-item-p) | ||
| 4071 | t) | ||
| 4072 | (error nil)))) | ||
| 4073 | |||
| 4074 | (defun org-insert-item (&optional checkbox) | ||
| 4075 | "Insert a new item at the current level. | ||
| 4076 | Return t when things worked, nil when we are not in an item." | ||
| 4077 | (when (save-excursion | ||
| 4078 | (condition-case nil | ||
| 4079 | (progn | ||
| 4080 | (org-beginning-of-item) | ||
| 4081 | (org-at-item-p) | ||
| 4082 | (if (org-invisible-p) (error "Invisible item")) | ||
| 4083 | t) | ||
| 4084 | (error nil))) | ||
| 4085 | (let* ((bul (match-string 0)) | ||
| 4086 | (eow (save-excursion (beginning-of-line 1) (looking-at "[ \t]*") | ||
| 4087 | (match-end 0))) | ||
| 4088 | (blank (cdr (assq 'plain-list-item org-blank-before-new-entry))) | ||
| 4089 | pos) | ||
| 4090 | (cond | ||
| 4091 | ((and (org-at-item-p) (<= (point) eow)) | ||
| 4092 | ;; before the bullet | ||
| 4093 | (beginning-of-line 1) | ||
| 4094 | (open-line (if blank 2 1))) | ||
| 4095 | ((<= (point) eow) | ||
| 4096 | (beginning-of-line 1)) | ||
| 4097 | (t (newline (if blank 2 1)))) | ||
| 4098 | (insert bul (if checkbox "[ ]" "")) | ||
| 4099 | (just-one-space) | ||
| 4100 | (setq pos (point)) | ||
| 4101 | (end-of-line 1) | ||
| 4102 | (unless (= (point) pos) (just-one-space) (backward-delete-char 1))) | ||
| 4103 | (org-maybe-renumber-ordered-list) | ||
| 4104 | (and checkbox (org-update-checkbox-count-maybe)) | ||
| 4105 | t)) | ||
| 4106 | 4488 | ||
| 4107 | (defun org-insert-todo-heading (arg) | 4489 | (defun org-insert-todo-heading (arg) |
| 4108 | "Insert a new heading with the same level and TODO state as current heading. | 4490 | "Insert a new heading with the same level and TODO state as current heading. |
| @@ -4121,6 +4503,8 @@ state (TODO by default). Also with prefix arg, force first state." | |||
| 4121 | (insert (car org-todo-keywords) " ") | 4503 | (insert (car org-todo-keywords) " ") |
| 4122 | (insert (match-string 2) " ")))) | 4504 | (insert (match-string 2) " ")))) |
| 4123 | 4505 | ||
| 4506 | ;;; Promotion and Demotion | ||
| 4507 | |||
| 4124 | (defun org-promote-subtree () | 4508 | (defun org-promote-subtree () |
| 4125 | "Promote the entire subtree. | 4509 | "Promote the entire subtree. |
| 4126 | See also `org-promote'." | 4510 | See also `org-promote'." |
| @@ -4162,14 +4546,14 @@ in the region." | |||
| 4162 | 4546 | ||
| 4163 | (defun org-fix-position-after-promote () | 4547 | (defun org-fix-position-after-promote () |
| 4164 | "Make sure that after pro/demotion cursor position is right." | 4548 | "Make sure that after pro/demotion cursor position is right." |
| 4165 | (if (and (equal (char-after) ?\n) | 4549 | (let ((pos (point))) |
| 4166 | (save-excursion | 4550 | (when (save-excursion |
| 4167 | (skip-chars-backward "a-zA-Z0-9_@") | 4551 | (beginning-of-line 1) |
| 4168 | (looking-at org-todo-regexp))) | 4552 | (looking-at org-todo-line-regexp) |
| 4169 | (insert " ")) | 4553 | (or (equal pos (match-end 1)) (equal pos (match-end 2)))) |
| 4170 | (and (equal (char-after) ?\ ) | 4554 | (cond ((eobp) (insert " ")) |
| 4171 | (equal (char-before) ?*) | 4555 | ((eolp) (insert " ")) |
| 4172 | (forward-char 1))) | 4556 | ((equal (char-after) ?\ ) (forward-char 1)))))) |
| 4173 | 4557 | ||
| 4174 | (defun org-get-legal-level (level &optional change) | 4558 | (defun org-get-legal-level (level &optional change) |
| 4175 | "Rectify a level change under the influence of `org-odd-levels-only' | 4559 | "Rectify a level change under the influence of `org-odd-levels-only' |
| @@ -4255,6 +4639,47 @@ would end up with no indentation after the change, nothing at all is done." | |||
| 4255 | (indent-to (+ diff col)))) | 4639 | (indent-to (+ diff col)))) |
| 4256 | (move-marker end nil)))) | 4640 | (move-marker end nil)))) |
| 4257 | 4641 | ||
| 4642 | (defun org-convert-to-odd-levels () | ||
| 4643 | "Convert an org-mode file with all levels allowed to one with odd levels. | ||
| 4644 | This will leave level 1 alone, convert level 2 to level 3, level 3 to | ||
| 4645 | level 5 etc." | ||
| 4646 | (interactive) | ||
| 4647 | (when (yes-or-no-p "Are you sure you want to globally change levels to odd? ") | ||
| 4648 | (let ((org-odd-levels-only nil) n) | ||
| 4649 | (save-excursion | ||
| 4650 | (goto-char (point-min)) | ||
| 4651 | (while (re-search-forward "^\\*\\*+" nil t) | ||
| 4652 | (setq n (1- (length (match-string 0)))) | ||
| 4653 | (while (>= (setq n (1- n)) 0) | ||
| 4654 | (org-demote)) | ||
| 4655 | (end-of-line 1)))))) | ||
| 4656 | |||
| 4657 | |||
| 4658 | (defun org-convert-to-oddeven-levels () | ||
| 4659 | "Convert an org-mode file with only odd levels to one with odd and even levels. | ||
| 4660 | This promotes level 3 to level 2, level 5 to level 3 etc. If the file contains a | ||
| 4661 | section with an even level, conversion would destroy the structure of the file. An error | ||
| 4662 | is signaled in this case." | ||
| 4663 | (interactive) | ||
| 4664 | (goto-char (point-min)) | ||
| 4665 | ;; First check if there are no even levels | ||
| 4666 | (when (re-search-forward "^\\(\\*\\*\\)+[^*]" nil t) | ||
| 4667 | (org-show-context t) | ||
| 4668 | (error "Not all levels are odd in this file. Conversion not possible.")) | ||
| 4669 | (when (yes-or-no-p "Are you sure you want to globally change levels to odd-even? ") | ||
| 4670 | (let ((org-odd-levels-only nil) n) | ||
| 4671 | (save-excursion | ||
| 4672 | (goto-char (point-min)) | ||
| 4673 | (while (re-search-forward "^\\*\\*+" nil t) | ||
| 4674 | (setq n (/ (length (match-string 0)) 2)) | ||
| 4675 | (while (>= (setq n (1- n)) 0) | ||
| 4676 | (org-promote)) | ||
| 4677 | (end-of-line 1)))))) | ||
| 4678 | |||
| 4679 | (defun org-tr-level (n) | ||
| 4680 | "Make N odd if required." | ||
| 4681 | (if org-odd-levels-only (1+ (/ n 2)) n)) | ||
| 4682 | |||
| 4258 | ;;; Vertical tree motion, cutting and pasting of subtrees | 4683 | ;;; Vertical tree motion, cutting and pasting of subtrees |
| 4259 | 4684 | ||
| 4260 | (defun org-move-subtree-up (&optional arg) | 4685 | (defun org-move-subtree-up (&optional arg) |
| @@ -4464,6 +4889,138 @@ If optional TXT is given, check this string instead of the current kill." | |||
| 4464 | (progn (org-back-to-heading) (point)) | 4889 | (progn (org-back-to-heading) (point)) |
| 4465 | (progn (org-end-of-subtree t) (point))))) | 4890 | (progn (org-end-of-subtree t) (point))))) |
| 4466 | 4891 | ||
| 4892 | |||
| 4893 | ;;; Outline Sorting | ||
| 4894 | |||
| 4895 | (defun org-sort (with-case) | ||
| 4896 | "Call `org-sort-entries' or `org-table-sort-lines', depending on context." | ||
| 4897 | (interactive "P") | ||
| 4898 | (if (org-at-table-p) | ||
| 4899 | (org-call-with-arg 'org-table-sort-lines with-case) | ||
| 4900 | (org-call-with-arg 'org-sort-entries with-case))) | ||
| 4901 | |||
| 4902 | (defun org-sort-entries (&optional with-case sorting-type) | ||
| 4903 | "Sort entries on a certain level of an outline tree. | ||
| 4904 | If there is an active region, the entries in the region are sorted. | ||
| 4905 | Else, if the cursor is before the first entry, sort the top-level items. | ||
| 4906 | Else, the children of the entry at point are sorted. | ||
| 4907 | |||
| 4908 | Sorting can be alphabetically, numerically, and by date/time as given by | ||
| 4909 | the first time stamp in the entry. The command prompts for the sorting | ||
| 4910 | type unless it has been given to the function through the SORTING-TYPE | ||
| 4911 | argument, which needs to a character, any of (?n ?N ?a ?A ?t ?T). | ||
| 4912 | |||
| 4913 | Comparing entries ignores case by default. However, with an optional argument | ||
| 4914 | WITH-CASE, the sorting considers case as well. With two prefix arguments | ||
| 4915 | `C-u C-u', sorting is case-sensitive and duplicate entries will be removed." | ||
| 4916 | (interactive "P") | ||
| 4917 | (let ((unique (equal with-case '(16))) | ||
| 4918 | start beg end entries stars re re2 p nentries (nremoved 0) | ||
| 4919 | last txt what) | ||
| 4920 | ;; Find beginning and end of region to sort | ||
| 4921 | (cond | ||
| 4922 | ((org-region-active-p) | ||
| 4923 | ;; we will sort the region | ||
| 4924 | (setq end (region-end) | ||
| 4925 | what "region") | ||
| 4926 | (goto-char (region-beginning)) | ||
| 4927 | (if (not (org-on-heading-p)) (outline-next-heading)) | ||
| 4928 | (setq start (point))) | ||
| 4929 | ((or (org-on-heading-p) | ||
| 4930 | (condition-case nil (progn (org-back-to-heading) t) (error nil))) | ||
| 4931 | ;; we will sort the children of the current headline | ||
| 4932 | (org-back-to-heading) | ||
| 4933 | (setq start (point) end (org-end-of-subtree) what "children") | ||
| 4934 | (goto-char start) | ||
| 4935 | (show-subtree) | ||
| 4936 | (outline-next-heading)) | ||
| 4937 | (t | ||
| 4938 | ;; we will sort the top-level entries in this file | ||
| 4939 | (goto-char (point-min)) | ||
| 4940 | (or (org-on-heading-p) (outline-next-heading)) | ||
| 4941 | (setq start (point) end (point-max) what "top-level") | ||
| 4942 | (goto-char start) | ||
| 4943 | (show-all))) | ||
| 4944 | (setq beg (point)) | ||
| 4945 | (if (>= (point) end) (error "Nothing to sort")) | ||
| 4946 | (looking-at "\\(\\*+\\)") | ||
| 4947 | (setq stars (match-string 1) | ||
| 4948 | re (concat "^" (regexp-quote stars) " +") | ||
| 4949 | re2 (concat "^" (regexp-quote (substring stars 0 -1)) "[^*]") | ||
| 4950 | txt (buffer-substring beg end)) | ||
| 4951 | (if (not (equal (substring txt -1) "\n")) (setq txt (concat txt "\n"))) | ||
| 4952 | (if (and (not (equal stars "*")) (string-match re2 txt)) | ||
| 4953 | (error "Region to sort contains a level above the first entry")) | ||
| 4954 | ;; Make a list that can be sorted. | ||
| 4955 | ;; The car is the string for comparison, the cdr is the subtree | ||
| 4956 | (message "Sorting entries...") | ||
| 4957 | (setq entries | ||
| 4958 | (mapcar | ||
| 4959 | (lambda (x) | ||
| 4960 | (string-match "^.*\\(\n.*\\)?" x) ; take two lines | ||
| 4961 | (cons (match-string 0 x) x)) | ||
| 4962 | (org-split-string txt re))) | ||
| 4963 | |||
| 4964 | ;; Sort the list | ||
| 4965 | (save-excursion | ||
| 4966 | (goto-char start) | ||
| 4967 | (setq entries (org-do-sort entries what with-case sorting-type))) | ||
| 4968 | |||
| 4969 | ;; Delete the old stuff | ||
| 4970 | (goto-char beg) | ||
| 4971 | (kill-region beg end) | ||
| 4972 | (setq nentries (length entries)) | ||
| 4973 | ;; Insert the sorted entries, and remove duplicates if this is required | ||
| 4974 | (while (setq p (pop entries)) | ||
| 4975 | (if (and unique (equal last (setq last (org-trim (cdr p))))) | ||
| 4976 | (setq nremoved (1+ nremoved)) ; same entry as before, skip it | ||
| 4977 | (insert stars " " (cdr p)))) | ||
| 4978 | (goto-char start) | ||
| 4979 | (message "Sorting entries...done (%d entries%s)" | ||
| 4980 | nentries | ||
| 4981 | (if unique (format ", %d duplicates removed" nremoved) "")))) | ||
| 4982 | |||
| 4983 | (defun org-do-sort (table what &optional with-case sorting-type) | ||
| 4984 | "Sort TABLE of WHAT according to SORTING-TYPE. | ||
| 4985 | The user will be prompted for the SORTING-TYPE if the call to this | ||
| 4986 | function does not specify it. WHAT is only for the prompt, to indicate | ||
| 4987 | what is being sorted. The sorting key will be extracted from | ||
| 4988 | the car of the elements of the table. | ||
| 4989 | If WITH-CASE is non-nil, the sorting will be case-sensitive." | ||
| 4990 | (unless sorting-type | ||
| 4991 | (message | ||
| 4992 | "Sort %s: [a]lphabetically [n]umerically [t]ime. A/N/T means reversed:" | ||
| 4993 | what) | ||
| 4994 | (setq sorting-type (read-char-exclusive))) | ||
| 4995 | (let ((dcst (downcase sorting-type)) | ||
| 4996 | extractfun comparefun) | ||
| 4997 | ;; Define the appropriate functions | ||
| 4998 | (cond | ||
| 4999 | ((= dcst ?n) | ||
| 5000 | (setq extractfun 'string-to-number | ||
| 5001 | comparefun (if (= dcst sorting-type) '< '>))) | ||
| 5002 | ((= dcst ?a) | ||
| 5003 | (setq extractfun (if with-case 'identity 'downcase) | ||
| 5004 | comparefun (if (= dcst sorting-type) | ||
| 5005 | 'string< | ||
| 5006 | (lambda (a b) (and (not (string< a b)) | ||
| 5007 | (not (string= a b))))))) | ||
| 5008 | ((= dcst ?t) | ||
| 5009 | (setq extractfun | ||
| 5010 | (lambda (x) | ||
| 5011 | (if (string-match org-ts-regexp x) | ||
| 5012 | (time-to-seconds | ||
| 5013 | (org-time-string-to-time (match-string 0 x))) | ||
| 5014 | 0)) | ||
| 5015 | comparefun (if (= dcst sorting-type) '< '>))) | ||
| 5016 | (t (error "Invalid sorting type `%c'" sorting-type))) | ||
| 5017 | |||
| 5018 | (sort (mapcar (lambda (x) (cons (funcall extractfun (car x)) (cdr x))) | ||
| 5019 | table) | ||
| 5020 | (lambda (a b) (funcall comparefun (car a) (car b)))))) | ||
| 5021 | |||
| 5022 | ;;;; Plain list items, including checkboxes | ||
| 5023 | |||
| 4467 | ;;; Plain list items | 5024 | ;;; Plain list items |
| 4468 | 5025 | ||
| 4469 | (defun org-at-item-p () | 5026 | (defun org-at-item-p () |
| @@ -4478,6 +5035,53 @@ If optional TXT is given, check this string instead of the current kill." | |||
| 4478 | ((= llt ?\)) "\\([ \t]*\\([-+]\\|\\([0-9]+)\\)\\)\\|[ \t]+\\*\\)\\( \\|$\\)") | 5035 | ((= llt ?\)) "\\([ \t]*\\([-+]\\|\\([0-9]+)\\)\\)\\|[ \t]+\\*\\)\\( \\|$\\)") |
| 4479 | (t (error "Invalid value of `org-plain-list-ordered-item-terminator'"))))))) | 5036 | (t (error "Invalid value of `org-plain-list-ordered-item-terminator'"))))))) |
| 4480 | 5037 | ||
| 5038 | |||
| 5039 | (defun org-in-item-p () | ||
| 5040 | "It the cursor inside a plain list item. | ||
| 5041 | Does not have to be the first line." | ||
| 5042 | (save-excursion | ||
| 5043 | (condition-case nil | ||
| 5044 | (progn | ||
| 5045 | (org-beginning-of-item) | ||
| 5046 | (org-at-item-p) | ||
| 5047 | t) | ||
| 5048 | (error nil)))) | ||
| 5049 | |||
| 5050 | (defun org-insert-item (&optional checkbox) | ||
| 5051 | "Insert a new item at the current level. | ||
| 5052 | Return t when things worked, nil when we are not in an item." | ||
| 5053 | (when (save-excursion | ||
| 5054 | (condition-case nil | ||
| 5055 | (progn | ||
| 5056 | (org-beginning-of-item) | ||
| 5057 | (org-at-item-p) | ||
| 5058 | (if (org-invisible-p) (error "Invisible item")) | ||
| 5059 | t) | ||
| 5060 | (error nil))) | ||
| 5061 | (let* ((bul (match-string 0)) | ||
| 5062 | (eow (save-excursion (beginning-of-line 1) (looking-at "[ \t]*") | ||
| 5063 | (match-end 0))) | ||
| 5064 | (blank (cdr (assq 'plain-list-item org-blank-before-new-entry))) | ||
| 5065 | pos) | ||
| 5066 | (cond | ||
| 5067 | ((and (org-at-item-p) (<= (point) eow)) | ||
| 5068 | ;; before the bullet | ||
| 5069 | (beginning-of-line 1) | ||
| 5070 | (open-line (if blank 2 1))) | ||
| 5071 | ((<= (point) eow) | ||
| 5072 | (beginning-of-line 1)) | ||
| 5073 | (t (newline (if blank 2 1)))) | ||
| 5074 | (insert bul (if checkbox "[ ]" "")) | ||
| 5075 | (just-one-space) | ||
| 5076 | (setq pos (point)) | ||
| 5077 | (end-of-line 1) | ||
| 5078 | (unless (= (point) pos) (just-one-space) (backward-delete-char 1))) | ||
| 5079 | (org-maybe-renumber-ordered-list) | ||
| 5080 | (and checkbox (org-update-checkbox-count-maybe)) | ||
| 5081 | t)) | ||
| 5082 | |||
| 5083 | ;;; Checkboxes | ||
| 5084 | |||
| 4481 | (defun org-at-item-checkbox-p () | 5085 | (defun org-at-item-checkbox-p () |
| 4482 | "Is point at a line starting a plain-list item with a checklet?" | 5086 | "Is point at a line starting a plain-list item with a checklet?" |
| 4483 | (and (org-at-item-p) | 5087 | (and (org-at-item-p) |
| @@ -4596,10 +5200,11 @@ Assumes that s is a single line, starting in column 0." | |||
| 4596 | t t s))) | 5200 | t t s))) |
| 4597 | s) | 5201 | s) |
| 4598 | 5202 | ||
| 4599 | ;; FIXME: document properly. | ||
| 4600 | (defun org-fix-indentation (line ind) | 5203 | (defun org-fix-indentation (line ind) |
| 4601 | "If the current indenation is smaller than ind1, leave it alone. | 5204 | "Fix indentation in LINE. |
| 4602 | If it is larger than ind, reduce it by ind." | 5205 | IND is a cons cell with target and minimum indentation. |
| 5206 | If the current indenation in LINE is smaller than the minimum, | ||
| 5207 | leave it alone. If it is larger than ind, set it to the target." | ||
| 4603 | (let* ((l (org-remove-tabs line)) | 5208 | (let* ((l (org-remove-tabs line)) |
| 4604 | (i (org-get-indentation l)) | 5209 | (i (org-get-indentation l)) |
| 4605 | (i1 (car ind)) (i2 (cdr ind))) | 5210 | (i1 (car ind)) (i2 (cdr ind))) |
| @@ -4848,7 +5453,9 @@ with something like \"1.\" or \"2)\"." | |||
| 4848 | (indent-to-column (+ ind1 arg)) | 5453 | (indent-to-column (+ ind1 arg)) |
| 4849 | (beginning-of-line 2))))) | 5454 | (beginning-of-line 2))))) |
| 4850 | 5455 | ||
| 4851 | ;;; Archiving | 5456 | ;;;; Archiving |
| 5457 | |||
| 5458 | (defalias 'org-advertized-archive-subtree 'org-archive-subtree) | ||
| 4852 | 5459 | ||
| 4853 | (defun org-archive-subtree (&optional find-done) | 5460 | (defun org-archive-subtree (&optional find-done) |
| 4854 | "Move the current subtree to the archive. | 5461 | "Move the current subtree to the archive. |
| @@ -4872,8 +5479,17 @@ this heading. " | |||
| 4872 | (tr-org-done-string org-done-string) | 5479 | (tr-org-done-string org-done-string) |
| 4873 | (tr-org-todo-regexp org-todo-regexp) | 5480 | (tr-org-todo-regexp org-todo-regexp) |
| 4874 | (tr-org-todo-line-regexp org-todo-line-regexp) | 5481 | (tr-org-todo-line-regexp org-todo-line-regexp) |
| 5482 | (tr-org-odd-levels-only org-odd-levels-only) | ||
| 4875 | (this-buffer (current-buffer)) | 5483 | (this-buffer (current-buffer)) |
| 5484 | (org-archive-location org-archive-location) | ||
| 5485 | (re "^#\\+ARCHIVE:[ \t]+\\(\\S-.*\\S-\\)[ \t]*$") | ||
| 4876 | file heading buffer level newfile-p) | 5486 | file heading buffer level newfile-p) |
| 5487 | |||
| 5488 | ;; Try to find a local archive location | ||
| 5489 | (save-excursion | ||
| 5490 | (if (or (re-search-backward re nil t) (re-search-forward re nil t)) | ||
| 5491 | (setq org-archive-location (match-string 1)))) | ||
| 5492 | |||
| 4877 | (if (string-match "\\(.*\\)::\\(.*\\)" org-archive-location) | 5493 | (if (string-match "\\(.*\\)::\\(.*\\)" org-archive-location) |
| 4878 | (progn | 5494 | (progn |
| 4879 | (setq file (format (match-string 1 org-archive-location) | 5495 | (setq file (format (match-string 1 org-archive-location) |
| @@ -4911,13 +5527,16 @@ this heading. " | |||
| 4911 | (org-todo-interpretation tr-org-todo-interpretation) | 5527 | (org-todo-interpretation tr-org-todo-interpretation) |
| 4912 | (org-done-string tr-org-done-string) | 5528 | (org-done-string tr-org-done-string) |
| 4913 | (org-todo-regexp tr-org-todo-regexp) | 5529 | (org-todo-regexp tr-org-todo-regexp) |
| 4914 | (org-todo-line-regexp tr-org-todo-line-regexp)) | 5530 | (org-todo-line-regexp tr-org-todo-line-regexp) |
| 5531 | (org-odd-levels-only (if (local-variable-p org-odd-levels-only) | ||
| 5532 | org-odd-levels-only | ||
| 5533 | tr-org-odd-levels-only))) | ||
| 4915 | (goto-char (point-min)) | 5534 | (goto-char (point-min)) |
| 4916 | (if heading | 5535 | (if heading |
| 4917 | (progn | 5536 | (progn |
| 4918 | (if (re-search-forward | 5537 | (if (re-search-forward |
| 4919 | (concat "\\(^\\|\r\\)" | 5538 | (concat "\\(^\\|\r\\)" |
| 4920 | (regexp-quote heading) "[ \t]*\\($\\|\r\\)") | 5539 | (regexp-quote heading) "[ \t]*\\(:[a-zA-Z0-9_@:]+:\\)?[ \t]*\\($\\|\r\\)") |
| 4921 | nil t) | 5540 | nil t) |
| 4922 | (goto-char (match-end 0)) | 5541 | (goto-char (match-end 0)) |
| 4923 | ;; Heading not found, just insert it at the end | 5542 | ;; Heading not found, just insert it at the end |
| @@ -4934,10 +5553,11 @@ this heading. " | |||
| 4934 | ;; No specific heading, just go to end of file. | 5553 | ;; No specific heading, just go to end of file. |
| 4935 | (goto-char (point-max)) (insert "\n")) | 5554 | (goto-char (point-max)) (insert "\n")) |
| 4936 | ;; Paste | 5555 | ;; Paste |
| 4937 | (org-paste-subtree (1+ level)) | 5556 | (org-paste-subtree (org-get-legal-level level 1)) |
| 4938 | ;; Mark the entry as done, i.e. set to last work in org-todo-keywords | 5557 | ;; Mark the entry as done, i.e. set to last work in org-todo-keywords |
| 4939 | (if org-archive-mark-done | 5558 | (if org-archive-mark-done |
| 4940 | (org-todo (length org-todo-keywords))) | 5559 | (let (org-log-done) |
| 5560 | (org-todo (length org-todo-keywords)))) | ||
| 4941 | ;; Move cursor to right after the TODO keyword | 5561 | ;; Move cursor to right after the TODO keyword |
| 4942 | (when org-archive-stamp-time | 5562 | (when org-archive-stamp-time |
| 4943 | (beginning-of-line 1) | 5563 | (beginning-of-line 1) |
| @@ -5073,116 +5693,4985 @@ the children that do not contain any open TODO items." | |||
| 5073 | (and set (beginning-of-line 1)) | 5693 | (and set (beginning-of-line 1)) |
| 5074 | (message "Subtree %s" (if set "archived" "unarchived"))))) | 5694 | (message "Subtree %s" (if set "archived" "unarchived"))))) |
| 5075 | 5695 | ||
| 5076 | (defvar org-agenda-multi nil) ; dynammically scoped | 5696 | |
| 5077 | (defvar org-agenda-buffer-name "*Org Agenda*") | 5697 | ;;;; Tables |
| 5078 | (defvar org-pre-agenda-window-conf nil) | 5698 | |
| 5079 | (defun org-prepare-agenda () | 5699 | ;;; The table editor |
| 5080 | (if org-agenda-multi | 5700 | |
| 5081 | (progn | 5701 | ;; Watch out: Here we are talking about two different kind of tables. |
| 5082 | (setq buffer-read-only nil) | 5702 | ;; Most of the code is for the tables created with the Org-mode table editor. |
| 5703 | ;; Sometimes, we talk about tables created and edited with the table.el | ||
| 5704 | ;; Emacs package. We call the former org-type tables, and the latter | ||
| 5705 | ;; table.el-type tables. | ||
| 5706 | |||
| 5707 | (defun org-before-change-function (beg end) | ||
| 5708 | "Every change indicates that a table might need an update." | ||
| 5709 | (setq org-table-may-need-update t)) | ||
| 5710 | |||
| 5711 | (defconst org-table-line-regexp "^[ \t]*|" | ||
| 5712 | "Detects an org-type table line.") | ||
| 5713 | (defconst org-table-dataline-regexp "^[ \t]*|[^-]" | ||
| 5714 | "Detects an org-type table line.") | ||
| 5715 | (defconst org-table-auto-recalculate-regexp "^[ \t]*| *# *\\(|\\|$\\)" | ||
| 5716 | "Detects a table line marked for automatic recalculation.") | ||
| 5717 | (defconst org-table-recalculate-regexp "^[ \t]*| *[#*] *\\(|\\|$\\)" | ||
| 5718 | "Detects a table line marked for automatic recalculation.") | ||
| 5719 | (defconst org-table-calculate-mark-regexp "^[ \t]*| *[!$^_#*] *\\(|\\|$\\)" | ||
| 5720 | "Detects a table line marked for automatic recalculation.") | ||
| 5721 | (defconst org-table-hline-regexp "^[ \t]*|-" | ||
| 5722 | "Detects an org-type table hline.") | ||
| 5723 | (defconst org-table1-hline-regexp "^[ \t]*\\+-[-+]" | ||
| 5724 | "Detects a table-type table hline.") | ||
| 5725 | (defconst org-table-any-line-regexp "^[ \t]*\\(|\\|\\+-[-+]\\)" | ||
| 5726 | "Detects an org-type or table-type table.") | ||
| 5727 | (defconst org-table-border-regexp "^[ \t]*[^| \t]" | ||
| 5728 | "Searching from within a table (any type) this finds the first line | ||
| 5729 | outside the table.") | ||
| 5730 | (defconst org-table-any-border-regexp "^[ \t]*[^|+ \t]" | ||
| 5731 | "Searching from within a table (any type) this finds the first line | ||
| 5732 | outside the table.") | ||
| 5733 | |||
| 5734 | (defvar org-table-last-highlighted-reference nil) | ||
| 5735 | (defvar org-table-formula-history nil) | ||
| 5736 | |||
| 5737 | (defvar org-table-column-names nil | ||
| 5738 | "Alist with column names, derived from the `!' line.") | ||
| 5739 | (defvar org-table-column-name-regexp nil | ||
| 5740 | "Regular expression matching the current column names.") | ||
| 5741 | (defvar org-table-local-parameters nil | ||
| 5742 | "Alist with parameter names, derived from the `$' line.") | ||
| 5743 | (defvar org-table-named-field-locations nil | ||
| 5744 | "Alist with locations of named fields.") | ||
| 5745 | |||
| 5746 | (defvar org-table-current-line-types nil | ||
| 5747 | "Table row types, non-nil only for the duration of a comand.") | ||
| 5748 | (defvar org-table-current-begin-line nil | ||
| 5749 | "Table begin line, non-nil only for the duration of a comand.") | ||
| 5750 | (defvar org-table-dlines nil | ||
| 5751 | "Vector of data line line numbers in the current table.") | ||
| 5752 | (defvar org-table-hlines nil | ||
| 5753 | "Vector of hline line numbers in the current table.") | ||
| 5754 | |||
| 5755 | (defconst org-table-range-regexp | ||
| 5756 | "@\\([-+]?I*[-+]?[0-9]*\\)?\\(\\$[-+]?[0-9]+\\)?\\(\\.\\.@?\\([-+]?I*[-+]?[0-9]*\\)?\\(\\$[-+]?[0-9]+\\)?\\)?" | ||
| 5757 | ;; 1 2 3 4 5 | ||
| 5758 | "Regular expression for matching ranges in formulas.") | ||
| 5759 | |||
| 5760 | (defconst org-table-range-regexp2 | ||
| 5761 | "@\\([-+]?I*[-+]?[0-9]*\\)?\\(\\$[-+]?[a-zA-Z0-9]+\\)?\\(\\.\\.@?\\([-+]?I*[-+]?[0-9]*\\)?\\(\\$[-+]?[a-zA-Z0-9]+\\)?\\)?\\|\\$[a-zA-Z0-9]+\\.\\.\\$[a-zA-Z0-9]+" | ||
| 5762 | "Regular expression to recognize ranges in formulas for highlighting.") | ||
| 5763 | |||
| 5764 | (defvar org-inhibit-highlight-removal nil) | ||
| 5765 | |||
| 5766 | |||
| 5767 | (defun org-table-create-with-table.el () | ||
| 5768 | "Use the table.el package to insert a new table. | ||
| 5769 | If there is already a table at point, convert between Org-mode tables | ||
| 5770 | and table.el tables." | ||
| 5771 | (interactive) | ||
| 5772 | (require 'table) | ||
| 5773 | (cond | ||
| 5774 | ((org-at-table.el-p) | ||
| 5775 | (if (y-or-n-p "Convert table to Org-mode table? ") | ||
| 5776 | (org-table-convert))) | ||
| 5777 | ((org-at-table-p) | ||
| 5778 | (if (y-or-n-p "Convert table to table.el table? ") | ||
| 5779 | (org-table-convert))) | ||
| 5780 | (t (call-interactively 'table-insert)))) | ||
| 5781 | |||
| 5782 | (defun org-table-create-or-convert-from-region (arg) | ||
| 5783 | "Convert region to table, or create an empty table. | ||
| 5784 | If there is an active region, convert it to a table. If there is no such | ||
| 5785 | region, create an empty table." | ||
| 5786 | (interactive "P") | ||
| 5787 | (if (org-region-active-p) | ||
| 5788 | (org-table-convert-region (region-beginning) (region-end) arg) | ||
| 5789 | (org-table-create arg))) | ||
| 5790 | |||
| 5791 | (defun org-table-create (&optional size) | ||
| 5792 | "Query for a size and insert a table skeleton. | ||
| 5793 | SIZE is a string Columns x Rows like for example \"3x2\"." | ||
| 5794 | (interactive "P") | ||
| 5795 | (unless size | ||
| 5796 | (setq size (read-string | ||
| 5797 | (concat "Table size Columns x Rows [e.g. " | ||
| 5798 | org-table-default-size "]: ") | ||
| 5799 | "" nil org-table-default-size))) | ||
| 5800 | |||
| 5801 | (let* ((pos (point)) | ||
| 5802 | (indent (make-string (current-column) ?\ )) | ||
| 5803 | (split (org-split-string size " *x *")) | ||
| 5804 | (rows (string-to-number (nth 1 split))) | ||
| 5805 | (columns (string-to-number (car split))) | ||
| 5806 | (line (concat (apply 'concat indent "|" (make-list columns " |")) | ||
| 5807 | "\n"))) | ||
| 5808 | (if (string-match "^[ \t]*$" (buffer-substring-no-properties | ||
| 5809 | (point-at-bol) (point))) | ||
| 5810 | (beginning-of-line 1) | ||
| 5811 | (newline)) | ||
| 5812 | ;; (mapcar (lambda (x) (insert line)) (make-list rows t)) | ||
| 5813 | (dotimes (i rows) (insert line)) | ||
| 5814 | (goto-char pos) | ||
| 5815 | (if (> rows 1) | ||
| 5816 | ;; Insert a hline after the first row. | ||
| 5817 | (progn | ||
| 5818 | (end-of-line 1) | ||
| 5819 | (insert "\n|-") | ||
| 5820 | (goto-char pos))) | ||
| 5821 | (org-table-align))) | ||
| 5822 | |||
| 5823 | (defun org-table-convert-region (beg0 end0 &optional nspace) | ||
| 5824 | "Convert region to a table. | ||
| 5825 | The region goes from BEG0 to END0, but these borders will be moved | ||
| 5826 | slightly, to make sure a beginning of line in the first line is included. | ||
| 5827 | When NSPACE is non-nil, it indicates the minimum number of spaces that | ||
| 5828 | separate columns (default: just one space)." | ||
| 5829 | (interactive "rP") | ||
| 5830 | (let* ((beg (min beg0 end0)) | ||
| 5831 | (end (max beg0 end0)) | ||
| 5832 | (tabsep t) | ||
| 5833 | re) | ||
| 5834 | (goto-char beg) | ||
| 5835 | (beginning-of-line 1) | ||
| 5836 | (setq beg (move-marker (make-marker) (point))) | ||
| 5837 | (goto-char end) | ||
| 5838 | (if (bolp) (backward-char 1) (end-of-line 1)) | ||
| 5839 | (setq end (move-marker (make-marker) (point))) | ||
| 5840 | ;; Lets see if this is tab-separated material. If every nonempty line | ||
| 5841 | ;; contains a tab, we will assume that it is tab-separated material | ||
| 5842 | (if nspace | ||
| 5843 | (setq tabsep nil) | ||
| 5844 | (goto-char beg) | ||
| 5845 | (and (re-search-forward "^[^\n\t]+$" end t) (setq tabsep nil))) | ||
| 5846 | (if nspace (setq tabsep nil)) | ||
| 5847 | (if tabsep | ||
| 5848 | (setq re "^\\|\t") | ||
| 5849 | (setq re (format "^ *\\| *\t *\\| \\{%d,\\}" | ||
| 5850 | (max 1 (prefix-numeric-value nspace))))) | ||
| 5851 | (goto-char beg) | ||
| 5852 | (while (re-search-forward re end t) | ||
| 5853 | (replace-match "| " t t)) | ||
| 5854 | (goto-char beg) | ||
| 5855 | (insert " ") | ||
| 5856 | (org-table-align))) | ||
| 5857 | |||
| 5858 | (defun org-table-import (file arg) | ||
| 5859 | "Import FILE as a table. | ||
| 5860 | The file is assumed to be tab-separated. Such files can be produced by most | ||
| 5861 | spreadsheet and database applications. If no tabs (at least one per line) | ||
| 5862 | are found, lines will be split on whitespace into fields." | ||
| 5863 | (interactive "f\nP") | ||
| 5864 | (or (bolp) (newline)) | ||
| 5865 | (let ((beg (point)) | ||
| 5866 | (pm (point-max))) | ||
| 5867 | (insert-file-contents file) | ||
| 5868 | (org-table-convert-region beg (+ (point) (- (point-max) pm)) arg))) | ||
| 5869 | |||
| 5870 | (defun org-table-export () | ||
| 5871 | "Export table as a tab-separated file. | ||
| 5872 | Such a file can be imported into a spreadsheet program like Excel." | ||
| 5873 | (interactive) | ||
| 5874 | (let* ((beg (org-table-begin)) | ||
| 5875 | (end (org-table-end)) | ||
| 5876 | (table (buffer-substring beg end)) | ||
| 5877 | (file (read-file-name "Export table to: ")) | ||
| 5878 | buf) | ||
| 5879 | (unless (or (not (file-exists-p file)) | ||
| 5880 | (y-or-n-p (format "Overwrite file %s? " file))) | ||
| 5881 | (error "Abort")) | ||
| 5882 | (with-current-buffer (find-file-noselect file) | ||
| 5883 | (setq buf (current-buffer)) | ||
| 5884 | (erase-buffer) | ||
| 5885 | (fundamental-mode) | ||
| 5886 | (insert table) | ||
| 5887 | (goto-char (point-min)) | ||
| 5888 | (while (re-search-forward "^[ \t]*|[ \t]*" nil t) | ||
| 5889 | (replace-match "" t t) | ||
| 5890 | (end-of-line 1)) | ||
| 5891 | (goto-char (point-min)) | ||
| 5892 | (while (re-search-forward "[ \t]*|[ \t]*$" nil t) | ||
| 5893 | (replace-match "" t t) | ||
| 5894 | (goto-char (min (1+ (point)) (point-max)))) | ||
| 5895 | (goto-char (point-min)) | ||
| 5896 | (while (re-search-forward "^-[-+]*$" nil t) | ||
| 5897 | (replace-match "") | ||
| 5898 | (if (looking-at "\n") | ||
| 5899 | (delete-char 1))) | ||
| 5900 | (goto-char (point-min)) | ||
| 5901 | (while (re-search-forward "[ \t]*|[ \t]*" nil t) | ||
| 5902 | (replace-match "\t" t t)) | ||
| 5903 | (save-buffer)) | ||
| 5904 | (kill-buffer buf))) | ||
| 5905 | |||
| 5906 | (defvar org-table-aligned-begin-marker (make-marker) | ||
| 5907 | "Marker at the beginning of the table last aligned. | ||
| 5908 | Used to check if cursor still is in that table, to minimize realignment.") | ||
| 5909 | (defvar org-table-aligned-end-marker (make-marker) | ||
| 5910 | "Marker at the end of the table last aligned. | ||
| 5911 | Used to check if cursor still is in that table, to minimize realignment.") | ||
| 5912 | (defvar org-table-last-alignment nil | ||
| 5913 | "List of flags for flushright alignment, from the last re-alignment. | ||
| 5914 | This is being used to correctly align a single field after TAB or RET.") | ||
| 5915 | (defvar org-table-last-column-widths nil | ||
| 5916 | "List of max width of fields in each column. | ||
| 5917 | This is being used to correctly align a single field after TAB or RET.") | ||
| 5918 | (defvar org-table-overlay-coordinates nil | ||
| 5919 | "Overlay coordinates after each align of a table.") | ||
| 5920 | (make-variable-buffer-local 'org-table-overlay-coordinates) | ||
| 5921 | |||
| 5922 | (defvar org-last-recalc-line nil) | ||
| 5923 | (defconst org-narrow-column-arrow "=>" | ||
| 5924 | "Used as display property in narrowed table columns.") | ||
| 5925 | |||
| 5926 | (defun org-table-align () | ||
| 5927 | "Align the table at point by aligning all vertical bars." | ||
| 5928 | (interactive) | ||
| 5929 | (let* ( | ||
| 5930 | ;; Limits of table | ||
| 5931 | (beg (org-table-begin)) | ||
| 5932 | (end (org-table-end)) | ||
| 5933 | ;; Current cursor position | ||
| 5934 | (linepos (org-current-line)) | ||
| 5935 | (colpos (org-table-current-column)) | ||
| 5936 | (winstart (window-start)) | ||
| 5937 | (winstartline (org-current-line (min winstart (1- (point-max))))) | ||
| 5938 | lines (new "") lengths l typenums ty fields maxfields i | ||
| 5939 | column | ||
| 5940 | (indent "") cnt frac | ||
| 5941 | rfmt hfmt | ||
| 5942 | (spaces '(1 . 1)) | ||
| 5943 | (sp1 (car spaces)) | ||
| 5944 | (sp2 (cdr spaces)) | ||
| 5945 | (rfmt1 (concat | ||
| 5946 | (make-string sp2 ?\ ) "%%%s%ds" (make-string sp1 ?\ ) "|")) | ||
| 5947 | (hfmt1 (concat | ||
| 5948 | (make-string sp2 ?-) "%s" (make-string sp1 ?-) "+")) | ||
| 5949 | emptystrings links dates narrow fmax f1 len c e) | ||
| 5950 | (untabify beg end) | ||
| 5951 | (remove-text-properties beg end '(org-cwidth t org-dwidth t display t)) | ||
| 5952 | ;; Check if we have links or dates | ||
| 5953 | (goto-char beg) | ||
| 5954 | (setq links (re-search-forward org-bracket-link-regexp end t)) | ||
| 5955 | (goto-char beg) | ||
| 5956 | (setq dates (and org-display-custom-times | ||
| 5957 | (re-search-forward org-ts-regexp-both end t))) | ||
| 5958 | ;; Make sure the link properties are right | ||
| 5959 | (when links (goto-char beg) (while (org-activate-bracket-links end))) | ||
| 5960 | ;; Make sure the date properties are right | ||
| 5961 | (when dates (goto-char beg) (while (org-activate-dates end))) | ||
| 5962 | |||
| 5963 | ;; Check if we are narrowing any columns | ||
| 5964 | (goto-char beg) | ||
| 5965 | (setq narrow (and org-format-transports-properties-p | ||
| 5966 | (re-search-forward "<[0-9]+>" end t))) | ||
| 5967 | ;; Get the rows | ||
| 5968 | (setq lines (org-split-string | ||
| 5969 | (buffer-substring beg end) "\n")) | ||
| 5970 | ;; Store the indentation of the first line | ||
| 5971 | (if (string-match "^ *" (car lines)) | ||
| 5972 | (setq indent (make-string (- (match-end 0) (match-beginning 0)) ?\ ))) | ||
| 5973 | ;; Mark the hlines by setting the corresponding element to nil | ||
| 5974 | ;; At the same time, we remove trailing space. | ||
| 5975 | (setq lines (mapcar (lambda (l) | ||
| 5976 | (if (string-match "^ *|-" l) | ||
| 5977 | nil | ||
| 5978 | (if (string-match "[ \t]+$" l) | ||
| 5979 | (substring l 0 (match-beginning 0)) | ||
| 5980 | l))) | ||
| 5981 | lines)) | ||
| 5982 | ;; Get the data fields by splitting the lines. | ||
| 5983 | (setq fields (mapcar | ||
| 5984 | (lambda (l) | ||
| 5985 | (org-split-string l " *| *")) | ||
| 5986 | (delq nil (copy-sequence lines)))) | ||
| 5987 | ;; How many fields in the longest line? | ||
| 5988 | (condition-case nil | ||
| 5989 | (setq maxfields (apply 'max (mapcar 'length fields))) | ||
| 5990 | (error | ||
| 5991 | (kill-region beg end) | ||
| 5992 | (org-table-create org-table-default-size) | ||
| 5993 | (error "Empty table - created default table"))) | ||
| 5994 | ;; A list of empty strings to fill any short rows on output | ||
| 5995 | (setq emptystrings (make-list maxfields "")) | ||
| 5996 | ;; Check for special formatting. | ||
| 5997 | (setq i -1) | ||
| 5998 | (while (< (setq i (1+ i)) maxfields) ;; Loop over all columns | ||
| 5999 | (setq column (mapcar (lambda (x) (or (nth i x) "")) fields)) | ||
| 6000 | ;; Check if there is an explicit width specified | ||
| 6001 | (when narrow | ||
| 6002 | (setq c column fmax nil) | ||
| 6003 | (while c | ||
| 6004 | (setq e (pop c)) | ||
| 6005 | (if (and (stringp e) (string-match "^<\\([0-9]+\\)>$" e)) | ||
| 6006 | (setq fmax (string-to-number (match-string 1 e)) c nil))) | ||
| 6007 | ;; Find fields that are wider than fmax, and shorten them | ||
| 6008 | (when fmax | ||
| 6009 | (loop for xx in column do | ||
| 6010 | (when (and (stringp xx) | ||
| 6011 | (> (org-string-width xx) fmax)) | ||
| 6012 | (org-add-props xx nil | ||
| 6013 | 'help-echo | ||
| 6014 | (concat "Clipped table field, use C-c ` to edit. Full value is:\n" (org-no-properties (copy-sequence xx)))) | ||
| 6015 | (setq f1 (min fmax (or (string-match org-bracket-link-regexp xx) fmax))) | ||
| 6016 | (unless (> f1 1) | ||
| 6017 | (error "Cannot narrow field starting with wide link \"%s\"" | ||
| 6018 | (match-string 0 xx))) | ||
| 6019 | (add-text-properties f1 (length xx) (list 'org-cwidth t) xx) | ||
| 6020 | (add-text-properties (- f1 2) f1 | ||
| 6021 | (list 'display org-narrow-column-arrow) | ||
| 6022 | xx))))) | ||
| 6023 | ;; Get the maximum width for each column | ||
| 6024 | (push (apply 'max 1 (mapcar 'org-string-width column)) lengths) | ||
| 6025 | ;; Get the fraction of numbers, to decide about alignment of the column | ||
| 6026 | (setq cnt 0 frac 0.0) | ||
| 6027 | (loop for x in column do | ||
| 6028 | (if (equal x "") | ||
| 6029 | nil | ||
| 6030 | (setq frac ( / (+ (* frac cnt) | ||
| 6031 | (if (string-match org-table-number-regexp x) 1 0)) | ||
| 6032 | (setq cnt (1+ cnt)))))) | ||
| 6033 | (push (>= frac org-table-number-fraction) typenums)) | ||
| 6034 | (setq lengths (nreverse lengths) typenums (nreverse typenums)) | ||
| 6035 | |||
| 6036 | ;; Store the alignment of this table, for later editing of single fields | ||
| 6037 | (setq org-table-last-alignment typenums | ||
| 6038 | org-table-last-column-widths lengths) | ||
| 6039 | |||
| 6040 | ;; With invisible characters, `format' does not get the field width right | ||
| 6041 | ;; So we need to make these fields wide by hand. | ||
| 6042 | (when links | ||
| 6043 | (loop for i from 0 upto (1- maxfields) do | ||
| 6044 | (setq len (nth i lengths)) | ||
| 6045 | (loop for j from 0 upto (1- (length fields)) do | ||
| 6046 | (setq c (nthcdr i (car (nthcdr j fields)))) | ||
| 6047 | (if (and (stringp (car c)) | ||
| 6048 | (string-match org-bracket-link-regexp (car c)) | ||
| 6049 | (< (org-string-width (car c)) len)) | ||
| 6050 | (setcar c (concat (car c) (make-string (- len (org-string-width (car c))) ?\ ))))))) | ||
| 6051 | |||
| 6052 | ;; Compute the formats needed for output of the table | ||
| 6053 | (setq rfmt (concat indent "|") hfmt (concat indent "|")) | ||
| 6054 | (while (setq l (pop lengths)) | ||
| 6055 | (setq ty (if (pop typenums) "" "-")) ; number types flushright | ||
| 6056 | (setq rfmt (concat rfmt (format rfmt1 ty l)) | ||
| 6057 | hfmt (concat hfmt (format hfmt1 (make-string l ?-))))) | ||
| 6058 | (setq rfmt (concat rfmt "\n") | ||
| 6059 | hfmt (concat (substring hfmt 0 -1) "|\n")) | ||
| 6060 | |||
| 6061 | (setq new (mapconcat | ||
| 6062 | (lambda (l) | ||
| 6063 | (if l (apply 'format rfmt | ||
| 6064 | (append (pop fields) emptystrings)) | ||
| 6065 | hfmt)) | ||
| 6066 | lines "")) | ||
| 6067 | ;; Replace the old one | ||
| 6068 | (delete-region beg end) | ||
| 6069 | (move-marker end nil) | ||
| 6070 | (move-marker org-table-aligned-begin-marker (point)) | ||
| 6071 | (insert new) | ||
| 6072 | (move-marker org-table-aligned-end-marker (point)) | ||
| 6073 | (when (and orgtbl-mode (not (org-mode-p))) | ||
| 6074 | (goto-char org-table-aligned-begin-marker) | ||
| 6075 | (while (org-hide-wide-columns org-table-aligned-end-marker))) | ||
| 6076 | ;; Try to move to the old location | ||
| 6077 | (goto-line winstartline) | ||
| 6078 | (setq winstart (point-at-bol)) | ||
| 6079 | (goto-line linepos) | ||
| 6080 | (set-window-start (selected-window) winstart 'noforce) | ||
| 6081 | (org-table-goto-column colpos) | ||
| 6082 | (and org-table-overlay-coordinates (org-table-overlay-coordinates)) | ||
| 6083 | (setq org-table-may-need-update nil) | ||
| 6084 | )) | ||
| 6085 | |||
| 6086 | (defun org-string-width (s) | ||
| 6087 | "Compute width of string, ignoring invisible characters. | ||
| 6088 | This ignores character with invisibility property `org-link', and also | ||
| 6089 | characters with property `org-cwidth', because these will become invisible | ||
| 6090 | upon the next fontification round." | ||
| 6091 | (let (b l) | ||
| 6092 | (when (or (eq t buffer-invisibility-spec) | ||
| 6093 | (assq 'org-link buffer-invisibility-spec)) | ||
| 6094 | (while (setq b (text-property-any 0 (length s) | ||
| 6095 | 'invisible 'org-link s)) | ||
| 6096 | (setq s (concat (substring s 0 b) | ||
| 6097 | (substring s (or (next-single-property-change | ||
| 6098 | b 'invisible s) (length s))))))) | ||
| 6099 | (while (setq b (text-property-any 0 (length s) 'org-cwidth t s)) | ||
| 6100 | (setq s (concat (substring s 0 b) | ||
| 6101 | (substring s (or (next-single-property-change | ||
| 6102 | b 'org-cwidth s) (length s)))))) | ||
| 6103 | (setq l (string-width s) b -1) | ||
| 6104 | (while (setq b (text-property-any (1+ b) (length s) 'org-dwidth t s)) | ||
| 6105 | (setq l (- l (get-text-property b 'org-dwidth-n s)))) | ||
| 6106 | l)) | ||
| 6107 | |||
| 6108 | (defun org-table-begin (&optional table-type) | ||
| 6109 | "Find the beginning of the table and return its position. | ||
| 6110 | With argument TABLE-TYPE, go to the beginning of a table.el-type table." | ||
| 6111 | (save-excursion | ||
| 6112 | (if (not (re-search-backward | ||
| 6113 | (if table-type org-table-any-border-regexp | ||
| 6114 | org-table-border-regexp) | ||
| 6115 | nil t)) | ||
| 6116 | (progn (goto-char (point-min)) (point)) | ||
| 6117 | (goto-char (match-beginning 0)) | ||
| 6118 | (beginning-of-line 2) | ||
| 6119 | (point)))) | ||
| 6120 | |||
| 6121 | (defun org-table-end (&optional table-type) | ||
| 6122 | "Find the end of the table and return its position. | ||
| 6123 | With argument TABLE-TYPE, go to the end of a table.el-type table." | ||
| 6124 | (save-excursion | ||
| 6125 | (if (not (re-search-forward | ||
| 6126 | (if table-type org-table-any-border-regexp | ||
| 6127 | org-table-border-regexp) | ||
| 6128 | nil t)) | ||
| 5083 | (goto-char (point-max)) | 6129 | (goto-char (point-max)) |
| 5084 | (unless (= (point) 1) | 6130 | (goto-char (match-beginning 0))) |
| 5085 | (insert "\n" (make-string (window-width) ?=) "\n")) | 6131 | (point-marker))) |
| 5086 | (narrow-to-region (point) (point-max))) | 6132 | |
| 5087 | (org-agenda-maybe-reset-markers 'force) | 6133 | (defun org-table-justify-field-maybe (&optional new) |
| 5088 | (org-prepare-agenda-buffers (org-agenda-files)) | 6134 | "Justify the current field, text to left, number to right. |
| 5089 | (let* ((abuf (get-buffer-create org-agenda-buffer-name)) | 6135 | Optional argument NEW may specify text to replace the current field content." |
| 5090 | (awin (get-buffer-window abuf))) | 6136 | (cond |
| 6137 | ((and (not new) org-table-may-need-update)) ; Realignment will happen anyway | ||
| 6138 | ((org-at-table-hline-p)) | ||
| 6139 | ((and (not new) | ||
| 6140 | (or (not (equal (marker-buffer org-table-aligned-begin-marker) | ||
| 6141 | (current-buffer))) | ||
| 6142 | (< (point) org-table-aligned-begin-marker) | ||
| 6143 | (>= (point) org-table-aligned-end-marker))) | ||
| 6144 | ;; This is not the same table, force a full re-align | ||
| 6145 | (setq org-table-may-need-update t)) | ||
| 6146 | (t ;; realign the current field, based on previous full realign | ||
| 6147 | (let* ((pos (point)) s | ||
| 6148 | (col (org-table-current-column)) | ||
| 6149 | (num (if (> col 0) (nth (1- col) org-table-last-alignment))) | ||
| 6150 | l f n o e) | ||
| 6151 | (when (> col 0) | ||
| 6152 | (skip-chars-backward "^|\n") | ||
| 6153 | (if (looking-at " *\\([^|\n]*?\\) *\\(|\\|$\\)") | ||
| 6154 | (progn | ||
| 6155 | (setq s (match-string 1) | ||
| 6156 | o (match-string 0) | ||
| 6157 | l (max 1 (- (match-end 0) (match-beginning 0) 3)) | ||
| 6158 | e (not (= (match-beginning 2) (match-end 2)))) | ||
| 6159 | (setq f (format (if num " %%%ds %s" " %%-%ds %s") | ||
| 6160 | l (if e "|" (setq org-table-may-need-update t) "")) | ||
| 6161 | n (format f s)) | ||
| 6162 | (if new | ||
| 6163 | (if (<= (length new) l) ;; FIXME: length -> str-width? | ||
| 6164 | (setq n (format f new)) | ||
| 6165 | (setq n (concat new "|") org-table-may-need-update t))) | ||
| 6166 | (or (equal n o) | ||
| 6167 | (let (org-table-may-need-update) | ||
| 6168 | (replace-match n)))) | ||
| 6169 | (setq org-table-may-need-update t)) | ||
| 6170 | (goto-char pos)))))) | ||
| 6171 | |||
| 6172 | (defun org-table-next-field () | ||
| 6173 | "Go to the next field in the current table, creating new lines as needed. | ||
| 6174 | Before doing so, re-align the table if necessary." | ||
| 6175 | (interactive) | ||
| 6176 | (org-table-maybe-eval-formula) | ||
| 6177 | (org-table-maybe-recalculate-line) | ||
| 6178 | (if (and org-table-automatic-realign | ||
| 6179 | org-table-may-need-update) | ||
| 6180 | (org-table-align)) | ||
| 6181 | (let ((end (org-table-end))) | ||
| 6182 | (if (org-at-table-hline-p) | ||
| 6183 | (end-of-line 1)) | ||
| 6184 | (condition-case nil | ||
| 6185 | (progn | ||
| 6186 | (re-search-forward "|" end) | ||
| 6187 | (if (looking-at "[ \t]*$") | ||
| 6188 | (re-search-forward "|" end)) | ||
| 6189 | (if (and (looking-at "-") | ||
| 6190 | org-table-tab-jumps-over-hlines | ||
| 6191 | (re-search-forward "^[ \t]*|\\([^-]\\)" end t)) | ||
| 6192 | (goto-char (match-beginning 1))) | ||
| 6193 | (if (looking-at "-") | ||
| 6194 | (progn | ||
| 6195 | (beginning-of-line 0) | ||
| 6196 | (org-table-insert-row 'below)) | ||
| 6197 | (if (looking-at " ") (forward-char 1)))) | ||
| 6198 | (error | ||
| 6199 | (org-table-insert-row 'below))))) | ||
| 6200 | |||
| 6201 | (defun org-table-previous-field () | ||
| 6202 | "Go to the previous field in the table. | ||
| 6203 | Before doing so, re-align the table if necessary." | ||
| 6204 | (interactive) | ||
| 6205 | (org-table-justify-field-maybe) | ||
| 6206 | (org-table-maybe-recalculate-line) | ||
| 6207 | (if (and org-table-automatic-realign | ||
| 6208 | org-table-may-need-update) | ||
| 6209 | (org-table-align)) | ||
| 6210 | (if (org-at-table-hline-p) | ||
| 6211 | (end-of-line 1)) | ||
| 6212 | (re-search-backward "|" (org-table-begin)) | ||
| 6213 | (re-search-backward "|" (org-table-begin)) | ||
| 6214 | (while (looking-at "|\\(-\\|[ \t]*$\\)") | ||
| 6215 | (re-search-backward "|" (org-table-begin))) | ||
| 6216 | (if (looking-at "| ?") | ||
| 6217 | (goto-char (match-end 0)))) | ||
| 6218 | |||
| 6219 | (defun org-table-next-row () | ||
| 6220 | "Go to the next row (same column) in the current table. | ||
| 6221 | Before doing so, re-align the table if necessary." | ||
| 6222 | (interactive) | ||
| 6223 | (org-table-maybe-eval-formula) | ||
| 6224 | (org-table-maybe-recalculate-line) | ||
| 6225 | (if (or (looking-at "[ \t]*$") | ||
| 6226 | (save-excursion (skip-chars-backward " \t") (bolp))) | ||
| 6227 | (newline) | ||
| 6228 | (if (and org-table-automatic-realign | ||
| 6229 | org-table-may-need-update) | ||
| 6230 | (org-table-align)) | ||
| 6231 | (let ((col (org-table-current-column))) | ||
| 6232 | (beginning-of-line 2) | ||
| 6233 | (if (or (not (org-at-table-p)) | ||
| 6234 | (org-at-table-hline-p)) | ||
| 6235 | (progn | ||
| 6236 | (beginning-of-line 0) | ||
| 6237 | (org-table-insert-row 'below))) | ||
| 6238 | (org-table-goto-column col) | ||
| 6239 | (skip-chars-backward "^|\n\r") | ||
| 6240 | (if (looking-at " ") (forward-char 1))))) | ||
| 6241 | |||
| 6242 | (defun org-table-copy-down (n) | ||
| 6243 | "Copy a field down in the current column. | ||
| 6244 | If the field at the cursor is empty, copy into it the content of the nearest | ||
| 6245 | non-empty field above. With argument N, use the Nth non-empty field. | ||
| 6246 | If the current field is not empty, it is copied down to the next row, and | ||
| 6247 | the cursor is moved with it. Therefore, repeating this command causes the | ||
| 6248 | column to be filled row-by-row. | ||
| 6249 | If the variable `org-table-copy-increment' is non-nil and the field is an | ||
| 6250 | integer, it will be incremented while copying." | ||
| 6251 | (interactive "p") | ||
| 6252 | (let* ((colpos (org-table-current-column)) | ||
| 6253 | (field (org-table-get-field)) | ||
| 6254 | (non-empty (string-match "[^ \t]" field)) | ||
| 6255 | (beg (org-table-begin)) | ||
| 6256 | txt) | ||
| 6257 | (org-table-check-inside-data-field) | ||
| 6258 | (if non-empty | ||
| 6259 | (progn | ||
| 6260 | (setq txt (org-trim field)) | ||
| 6261 | (org-table-next-row) | ||
| 6262 | (org-table-blank-field)) | ||
| 6263 | (save-excursion | ||
| 6264 | (setq txt | ||
| 6265 | (catch 'exit | ||
| 6266 | (while (progn (beginning-of-line 1) | ||
| 6267 | (re-search-backward org-table-dataline-regexp | ||
| 6268 | beg t)) | ||
| 6269 | (org-table-goto-column colpos t) | ||
| 6270 | (if (and (looking-at | ||
| 6271 | "|[ \t]*\\([^| \t][^|]*?\\)[ \t]*|") | ||
| 6272 | (= (setq n (1- n)) 0)) | ||
| 6273 | (throw 'exit (match-string 1)))))))) | ||
| 6274 | (if txt | ||
| 6275 | (progn | ||
| 6276 | (if (and org-table-copy-increment | ||
| 6277 | (string-match "^[0-9]+$" txt)) | ||
| 6278 | (setq txt (format "%d" (+ (string-to-number txt) 1)))) | ||
| 6279 | (insert txt) | ||
| 6280 | (org-table-maybe-recalculate-line) | ||
| 6281 | (org-table-align)) | ||
| 6282 | (error "No non-empty field found")))) | ||
| 6283 | |||
| 6284 | (defun org-table-check-inside-data-field () | ||
| 6285 | "Is point inside a table data field? | ||
| 6286 | I.e. not on a hline or before the first or after the last column? | ||
| 6287 | This actually throws an error, so it aborts the current command." | ||
| 6288 | (if (or (not (org-at-table-p)) | ||
| 6289 | (= (org-table-current-column) 0) | ||
| 6290 | (org-at-table-hline-p) | ||
| 6291 | (looking-at "[ \t]*$")) | ||
| 6292 | (error "Not in table data field"))) | ||
| 6293 | |||
| 6294 | (defvar org-table-clip nil | ||
| 6295 | "Clipboard for table regions.") | ||
| 6296 | |||
| 6297 | (defun org-table-blank-field () | ||
| 6298 | "Blank the current table field or active region." | ||
| 6299 | (interactive) | ||
| 6300 | (org-table-check-inside-data-field) | ||
| 6301 | (if (and (interactive-p) (org-region-active-p)) | ||
| 6302 | (let (org-table-clip) | ||
| 6303 | (org-table-cut-region (region-beginning) (region-end))) | ||
| 6304 | (skip-chars-backward "^|") | ||
| 6305 | (backward-char 1) | ||
| 6306 | (if (looking-at "|[^|\n]+") | ||
| 6307 | (let* ((pos (match-beginning 0)) | ||
| 6308 | (match (match-string 0)) | ||
| 6309 | (len (org-string-width match))) | ||
| 6310 | (replace-match (concat "|" (make-string (1- len) ?\ ))) | ||
| 6311 | (goto-char (+ 2 pos)) | ||
| 6312 | (substring match 1))))) | ||
| 6313 | |||
| 6314 | (defun org-table-get-field (&optional n replace) | ||
| 6315 | "Return the value of the field in column N of current row. | ||
| 6316 | N defaults to current field. | ||
| 6317 | If REPLACE is a string, replace field with this value. The return value | ||
| 6318 | is always the old value." | ||
| 6319 | (and n (org-table-goto-column n)) | ||
| 6320 | (skip-chars-backward "^|\n") | ||
| 6321 | (backward-char 1) | ||
| 6322 | (if (looking-at "|[^|\r\n]*") | ||
| 6323 | (let* ((pos (match-beginning 0)) | ||
| 6324 | (val (buffer-substring (1+ pos) (match-end 0)))) | ||
| 6325 | (if replace | ||
| 6326 | (replace-match (concat "|" replace))) | ||
| 6327 | (goto-char (min (point-at-eol) (+ 2 pos))) | ||
| 6328 | val) | ||
| 6329 | (forward-char 1) "")) | ||
| 6330 | |||
| 6331 | |||
| 6332 | (defun org-table-field-info (arg) | ||
| 6333 | "Show info about the current field, and highlight any reference at point." | ||
| 6334 | (interactive "P") | ||
| 6335 | (org-table-get-specials) | ||
| 6336 | (save-excursion | ||
| 6337 | (let* ((pos (point)) | ||
| 6338 | (col (org-table-current-column)) | ||
| 6339 | (cname (car (rassoc (int-to-string col) org-table-column-names))) | ||
| 6340 | (name (car (rassoc (list (org-current-line) col) | ||
| 6341 | org-table-named-field-locations))) | ||
| 6342 | (eql (org-table-get-stored-formulas)) | ||
| 6343 | (dline (org-table-current-dline)) | ||
| 6344 | (ref (format "@%d$%d" dline col)) | ||
| 6345 | (fequation (or (assoc name eql) (assoc ref eql))) | ||
| 6346 | (cequation (assoc (int-to-string col) eql))) | ||
| 6347 | (goto-char pos) | ||
| 6348 | (condition-case nil | ||
| 6349 | (org-show-reference 'local) | ||
| 6350 | (error nil)) | ||
| 6351 | (message "line @%d, col $%s%s, ref @%d$%d%s%s" | ||
| 6352 | dline col | ||
| 6353 | (if cname (concat " or $" cname) "") | ||
| 6354 | dline col | ||
| 6355 | (if name (concat " or $" name) "") | ||
| 6356 | ;; FIXME: formula info not correct if special table line | ||
| 6357 | (if (or fequation cequation) | ||
| 6358 | (concat ", " (if fequation "field" "column") | ||
| 6359 | " formula applies" "") | ||
| 6360 | ""))))) | ||
| 6361 | |||
| 6362 | (defun org-table-current-column () | ||
| 6363 | "Find out which column we are in. | ||
| 6364 | When called interactively, column is also displayed in echo area." | ||
| 6365 | (interactive) | ||
| 6366 | (if (interactive-p) (org-table-check-inside-data-field)) | ||
| 6367 | (save-excursion | ||
| 6368 | (let ((cnt 0) (pos (point))) | ||
| 6369 | (beginning-of-line 1) | ||
| 6370 | (while (search-forward "|" pos t) | ||
| 6371 | (setq cnt (1+ cnt))) | ||
| 6372 | (if (interactive-p) (message "This is table column %d" cnt)) | ||
| 6373 | cnt))) | ||
| 6374 | |||
| 6375 | (defun org-table-current-dline () | ||
| 6376 | "Find out what table data line we are in. | ||
| 6377 | Only datalins count for this." | ||
| 6378 | (interactive) | ||
| 6379 | (if (interactive-p) (org-table-check-inside-data-field)) | ||
| 6380 | (save-excursion | ||
| 6381 | (let ((cnt 0) (pos (point))) | ||
| 6382 | (goto-char (org-table-begin)) | ||
| 6383 | (while (<= (point) pos) | ||
| 6384 | (if (looking-at org-table-dataline-regexp) (setq cnt (1+ cnt))) | ||
| 6385 | (beginning-of-line 2)) | ||
| 6386 | (if (interactive-p) (message "This is table line %d" cnt)) | ||
| 6387 | cnt))) | ||
| 6388 | |||
| 6389 | (defun org-table-goto-column (n &optional on-delim force) | ||
| 6390 | "Move the cursor to the Nth column in the current table line. | ||
| 6391 | With optional argument ON-DELIM, stop with point before the left delimiter | ||
| 6392 | of the field. | ||
| 6393 | If there are less than N fields, just go to after the last delimiter. | ||
| 6394 | However, when FORCE is non-nil, create new columns if necessary." | ||
| 6395 | (interactive "p") | ||
| 6396 | (let ((pos (point-at-eol))) | ||
| 6397 | (beginning-of-line 1) | ||
| 6398 | (when (> n 0) | ||
| 6399 | (while (and (> (setq n (1- n)) -1) | ||
| 6400 | (or (search-forward "|" pos t) | ||
| 6401 | (and force | ||
| 6402 | (progn (end-of-line 1) | ||
| 6403 | (skip-chars-backward "^|") | ||
| 6404 | (insert " | ")))))) | ||
| 6405 | ; (backward-char 2) t))))) | ||
| 6406 | (when (and force (not (looking-at ".*|"))) | ||
| 6407 | (save-excursion (end-of-line 1) (insert " | "))) | ||
| 6408 | (if on-delim | ||
| 6409 | (backward-char 1) | ||
| 6410 | (if (looking-at " ") (forward-char 1)))))) | ||
| 6411 | |||
| 6412 | (defun org-at-table-p (&optional table-type) | ||
| 6413 | "Return t if the cursor is inside an org-type table. | ||
| 6414 | If TABLE-TYPE is non-nil, also check for table.el-type tables." | ||
| 6415 | (if org-enable-table-editor | ||
| 6416 | (save-excursion | ||
| 6417 | (beginning-of-line 1) | ||
| 6418 | (looking-at (if table-type org-table-any-line-regexp | ||
| 6419 | org-table-line-regexp))) | ||
| 6420 | nil)) | ||
| 6421 | |||
| 6422 | (defun org-at-table.el-p () | ||
| 6423 | "Return t if and only if we are at a table.el table." | ||
| 6424 | (and (org-at-table-p 'any) | ||
| 6425 | (save-excursion | ||
| 6426 | (goto-char (org-table-begin 'any)) | ||
| 6427 | (looking-at org-table1-hline-regexp)))) | ||
| 6428 | |||
| 6429 | (defun org-table-recognize-table.el () | ||
| 6430 | "If there is a table.el table nearby, recognize it and move into it." | ||
| 6431 | (if org-table-tab-recognizes-table.el | ||
| 6432 | (if (org-at-table.el-p) | ||
| 6433 | (progn | ||
| 6434 | (beginning-of-line 1) | ||
| 6435 | (if (looking-at org-table-dataline-regexp) | ||
| 6436 | nil | ||
| 6437 | (if (looking-at org-table1-hline-regexp) | ||
| 6438 | (progn | ||
| 6439 | (beginning-of-line 2) | ||
| 6440 | (if (looking-at org-table-any-border-regexp) | ||
| 6441 | (beginning-of-line -1))))) | ||
| 6442 | (if (re-search-forward "|" (org-table-end t) t) | ||
| 6443 | (progn | ||
| 6444 | (require 'table) | ||
| 6445 | (if (table--at-cell-p (point)) | ||
| 6446 | t | ||
| 6447 | (message "recognizing table.el table...") | ||
| 6448 | (table-recognize-table) | ||
| 6449 | (message "recognizing table.el table...done"))) | ||
| 6450 | (error "This should not happen...")) | ||
| 6451 | t) | ||
| 6452 | nil) | ||
| 6453 | nil)) | ||
| 6454 | |||
| 6455 | (defun org-at-table-hline-p () | ||
| 6456 | "Return t if the cursor is inside a hline in a table." | ||
| 6457 | (if org-enable-table-editor | ||
| 6458 | (save-excursion | ||
| 6459 | (beginning-of-line 1) | ||
| 6460 | (looking-at org-table-hline-regexp)) | ||
| 6461 | nil)) | ||
| 6462 | |||
| 6463 | (defun org-table-insert-column () | ||
| 6464 | "Insert a new column into the table." | ||
| 6465 | (interactive) | ||
| 6466 | (if (not (org-at-table-p)) | ||
| 6467 | (error "Not at a table")) | ||
| 6468 | (org-table-find-dataline) | ||
| 6469 | (let* ((col (max 1 (org-table-current-column))) | ||
| 6470 | (beg (org-table-begin)) | ||
| 6471 | (end (org-table-end)) | ||
| 6472 | ;; Current cursor position | ||
| 6473 | (linepos (org-current-line)) | ||
| 6474 | (colpos col)) | ||
| 6475 | (goto-char beg) | ||
| 6476 | (while (< (point) end) | ||
| 6477 | (if (org-at-table-hline-p) | ||
| 6478 | nil | ||
| 6479 | (org-table-goto-column col t) | ||
| 6480 | (insert "| ")) | ||
| 6481 | (beginning-of-line 2)) | ||
| 6482 | (move-marker end nil) | ||
| 6483 | (goto-line linepos) | ||
| 6484 | (org-table-goto-column colpos) | ||
| 6485 | (org-table-align) | ||
| 6486 | (org-table-fix-formulas "$" nil (1- col) 1))) | ||
| 6487 | |||
| 6488 | (defun org-table-find-dataline () | ||
| 6489 | "Find a dataline in the current table, which is needed for column commands." | ||
| 6490 | (if (and (org-at-table-p) | ||
| 6491 | (not (org-at-table-hline-p))) | ||
| 6492 | t | ||
| 6493 | (let ((col (current-column)) | ||
| 6494 | (end (org-table-end))) | ||
| 6495 | (move-to-column col) | ||
| 6496 | (while (and (< (point) end) | ||
| 6497 | (or (not (= (current-column) col)) | ||
| 6498 | (org-at-table-hline-p))) | ||
| 6499 | (beginning-of-line 2) | ||
| 6500 | (move-to-column col)) | ||
| 6501 | (if (and (org-at-table-p) | ||
| 6502 | (not (org-at-table-hline-p))) | ||
| 6503 | t | ||
| 6504 | (error | ||
| 6505 | "Please position cursor in a data line for column operations"))))) | ||
| 6506 | |||
| 6507 | (defun org-table-delete-column () | ||
| 6508 | "Delete a column from the table." | ||
| 6509 | (interactive) | ||
| 6510 | (if (not (org-at-table-p)) | ||
| 6511 | (error "Not at a table")) | ||
| 6512 | (org-table-find-dataline) | ||
| 6513 | (org-table-check-inside-data-field) | ||
| 6514 | (let* ((col (org-table-current-column)) | ||
| 6515 | (beg (org-table-begin)) | ||
| 6516 | (end (org-table-end)) | ||
| 6517 | ;; Current cursor position | ||
| 6518 | (linepos (org-current-line)) | ||
| 6519 | (colpos col)) | ||
| 6520 | (goto-char beg) | ||
| 6521 | (while (< (point) end) | ||
| 6522 | (if (org-at-table-hline-p) | ||
| 6523 | nil | ||
| 6524 | (org-table-goto-column col t) | ||
| 6525 | (and (looking-at "|[^|\n]+|") | ||
| 6526 | (replace-match "|"))) | ||
| 6527 | (beginning-of-line 2)) | ||
| 6528 | (move-marker end nil) | ||
| 6529 | (goto-line linepos) | ||
| 6530 | (org-table-goto-column colpos) | ||
| 6531 | (org-table-align) | ||
| 6532 | (org-table-fix-formulas "$" (list (cons (number-to-string col) "INVALID")) | ||
| 6533 | col -1 col))) | ||
| 6534 | |||
| 6535 | (defun org-table-move-column-right () | ||
| 6536 | "Move column to the right." | ||
| 6537 | (interactive) | ||
| 6538 | (org-table-move-column nil)) | ||
| 6539 | (defun org-table-move-column-left () | ||
| 6540 | "Move column to the left." | ||
| 6541 | (interactive) | ||
| 6542 | (org-table-move-column 'left)) | ||
| 6543 | |||
| 6544 | (defun org-table-move-column (&optional left) | ||
| 6545 | "Move the current column to the right. With arg LEFT, move to the left." | ||
| 6546 | (interactive "P") | ||
| 6547 | (if (not (org-at-table-p)) | ||
| 6548 | (error "Not at a table")) | ||
| 6549 | (org-table-find-dataline) | ||
| 6550 | (org-table-check-inside-data-field) | ||
| 6551 | (let* ((col (org-table-current-column)) | ||
| 6552 | (col1 (if left (1- col) col)) | ||
| 6553 | (beg (org-table-begin)) | ||
| 6554 | (end (org-table-end)) | ||
| 6555 | ;; Current cursor position | ||
| 6556 | (linepos (org-current-line)) | ||
| 6557 | (colpos (if left (1- col) (1+ col)))) | ||
| 6558 | (if (and left (= col 1)) | ||
| 6559 | (error "Cannot move column further left")) | ||
| 6560 | (if (and (not left) (looking-at "[^|\n]*|[^|\n]*$")) | ||
| 6561 | (error "Cannot move column further right")) | ||
| 6562 | (goto-char beg) | ||
| 6563 | (while (< (point) end) | ||
| 6564 | (if (org-at-table-hline-p) | ||
| 6565 | nil | ||
| 6566 | (org-table-goto-column col1 t) | ||
| 6567 | (and (looking-at "|\\([^|\n]+\\)|\\([^|\n]+\\)|") | ||
| 6568 | (replace-match "|\\2|\\1|"))) | ||
| 6569 | (beginning-of-line 2)) | ||
| 6570 | (move-marker end nil) | ||
| 6571 | (goto-line linepos) | ||
| 6572 | (org-table-goto-column colpos) | ||
| 6573 | (org-table-align) | ||
| 6574 | (org-table-fix-formulas | ||
| 6575 | "$" (list (cons (number-to-string col) (number-to-string colpos)) | ||
| 6576 | (cons (number-to-string colpos) (number-to-string col)))))) | ||
| 6577 | |||
| 6578 | (defun org-table-move-row-down () | ||
| 6579 | "Move table row down." | ||
| 6580 | (interactive) | ||
| 6581 | (org-table-move-row nil)) | ||
| 6582 | (defun org-table-move-row-up () | ||
| 6583 | "Move table row up." | ||
| 6584 | (interactive) | ||
| 6585 | (org-table-move-row 'up)) | ||
| 6586 | |||
| 6587 | (defun org-table-move-row (&optional up) | ||
| 6588 | "Move the current table line down. With arg UP, move it up." | ||
| 6589 | (interactive "P") | ||
| 6590 | (let* ((col (current-column)) | ||
| 6591 | (pos (point)) | ||
| 6592 | (hline1p (save-excursion (beginning-of-line 1) | ||
| 6593 | (looking-at org-table-hline-regexp))) | ||
| 6594 | (dline1 (org-table-current-dline)) | ||
| 6595 | (dline2 (+ dline1 (if up -1 1))) | ||
| 6596 | (tonew (if up 0 2)) | ||
| 6597 | txt hline2p) | ||
| 6598 | (beginning-of-line tonew) | ||
| 6599 | (unless (org-at-table-p) | ||
| 6600 | (goto-char pos) | ||
| 6601 | (error "Cannot move row further")) | ||
| 6602 | (setq hline2p (looking-at org-table-hline-regexp)) | ||
| 6603 | (goto-char pos) | ||
| 6604 | (beginning-of-line 1) | ||
| 6605 | (setq pos (point)) | ||
| 6606 | (setq txt (buffer-substring (point) (1+ (point-at-eol)))) | ||
| 6607 | (delete-region (point) (1+ (point-at-eol))) | ||
| 6608 | (beginning-of-line tonew) | ||
| 6609 | (insert txt) | ||
| 6610 | (beginning-of-line 0) | ||
| 6611 | (move-to-column col) | ||
| 6612 | (unless (or hline1p hline2p) | ||
| 6613 | (org-table-fix-formulas | ||
| 6614 | "@" (list (cons (number-to-string dline1) (number-to-string dline2)) | ||
| 6615 | (cons (number-to-string dline2) (number-to-string dline1))))))) | ||
| 6616 | |||
| 6617 | (defun org-table-insert-row (&optional arg) | ||
| 6618 | "Insert a new row above the current line into the table. | ||
| 6619 | With prefix ARG, insert below the current line." | ||
| 6620 | (interactive "P") | ||
| 6621 | (if (not (org-at-table-p)) | ||
| 6622 | (error "Not at a table")) | ||
| 6623 | (let* ((line (buffer-substring (point-at-bol) (point-at-eol))) | ||
| 6624 | (new (org-table-clean-line line))) | ||
| 6625 | ;; Fix the first field if necessary | ||
| 6626 | (if (string-match "^[ \t]*| *[#$] *|" line) | ||
| 6627 | (setq new (replace-match (match-string 0 line) t t new))) | ||
| 6628 | (beginning-of-line (if arg 2 1)) | ||
| 6629 | (let (org-table-may-need-update) (insert-before-markers new "\n")) | ||
| 6630 | (beginning-of-line 0) | ||
| 6631 | (re-search-forward "| ?" (point-at-eol) t) | ||
| 6632 | (and (or org-table-may-need-update org-table-overlay-coordinates) | ||
| 6633 | (org-table-align)) | ||
| 6634 | (org-table-fix-formulas "@" nil (1- (org-table-current-dline)) 1))) | ||
| 6635 | |||
| 6636 | (defun org-table-insert-hline (&optional arg) | ||
| 6637 | "Insert a horizontal-line below the current line into the table. | ||
| 6638 | With prefix ARG, insert above the current line." | ||
| 6639 | (interactive "P") | ||
| 6640 | (if (not (org-at-table-p)) | ||
| 6641 | (error "Not at a table")) | ||
| 6642 | (let ((line (org-table-clean-line | ||
| 6643 | (buffer-substring (point-at-bol) (point-at-eol)))) | ||
| 6644 | (col (current-column))) | ||
| 6645 | (while (string-match "|\\( +\\)|" line) | ||
| 6646 | (setq line (replace-match | ||
| 6647 | (concat "+" (make-string (- (match-end 1) (match-beginning 1)) | ||
| 6648 | ?-) "|") t t line))) | ||
| 6649 | (and (string-match "\\+" line) (setq line (replace-match "|" t t line))) | ||
| 6650 | (beginning-of-line (if arg 1 2)) | ||
| 6651 | (insert line "\n") | ||
| 6652 | (beginning-of-line (if arg 1 -1)) | ||
| 6653 | (move-to-column col) | ||
| 6654 | (and org-table-overlay-coordinates (org-table-align)))) | ||
| 6655 | |||
| 6656 | (defun org-table-clean-line (s) | ||
| 6657 | "Convert a table line S into a string with only \"|\" and space. | ||
| 6658 | In particular, this does handle wide and invisible characters." | ||
| 6659 | (if (string-match "^[ \t]*|-" s) | ||
| 6660 | ;; It's a hline, just map the characters | ||
| 6661 | (setq s (mapconcat (lambda (x) (if (member x '(?| ?+)) "|" " ")) s "")) | ||
| 6662 | (while (string-match "|\\([ \t]*?[^ \t\r\n|][^\r\n|]*\\)|" s) | ||
| 6663 | (setq s (replace-match | ||
| 6664 | (concat "|" (make-string (org-string-width (match-string 1 s)) | ||
| 6665 | ?\ ) "|") | ||
| 6666 | t t s))) | ||
| 6667 | s)) | ||
| 6668 | |||
| 6669 | (defun org-table-kill-row () | ||
| 6670 | "Delete the current row or horizontal line from the table." | ||
| 6671 | (interactive) | ||
| 6672 | (if (not (org-at-table-p)) | ||
| 6673 | (error "Not at a table")) | ||
| 6674 | (let ((col (current-column)) | ||
| 6675 | (dline (org-table-current-dline))) | ||
| 6676 | (kill-region (point-at-bol) (min (1+ (point-at-eol)) (point-max))) | ||
| 6677 | (if (not (org-at-table-p)) (beginning-of-line 0)) | ||
| 6678 | (move-to-column col) | ||
| 6679 | (org-table-fix-formulas "@" (list (cons (number-to-string dline) "INVALID")) | ||
| 6680 | dline -1 dline))) | ||
| 6681 | |||
| 6682 | |||
| 6683 | (defun org-table-sort-lines (with-case &optional sorting-type) | ||
| 6684 | "Sort table lines according to the column at point. | ||
| 6685 | |||
| 6686 | The position of point indicates the column to be used for | ||
| 6687 | sorting, and the range of lines is the range between the nearest | ||
| 6688 | horizontal separator lines, or the entire table of no such lines | ||
| 6689 | exist. If point is before the first column, you will be prompted | ||
| 6690 | for the sorting column. If there is an active region, the mark | ||
| 6691 | specifies the first line and the sorting column, while point | ||
| 6692 | should be in the last line to be included into the sorting. | ||
| 6693 | |||
| 6694 | The command then prompts for the sorting type which can be | ||
| 6695 | alphabetically, numerically, or by time (as given in a time stamp | ||
| 6696 | in the field). Sorting in reverse order is also possible. | ||
| 6697 | |||
| 6698 | With prefix argument WITH-CASE, alphabetic sorting will be case-sensitive. | ||
| 6699 | |||
| 6700 | If SORTING-TYPE is specified when this function is called from a Lisp | ||
| 6701 | program, no prompting will take place. SORTING-TYPE must be a character, | ||
| 6702 | any of (?a ?A ?n ?N ?t ?T) where the capital letter indicate that sorting | ||
| 6703 | should be done in reverse order." | ||
| 6704 | (interactive "P") | ||
| 6705 | (let* ((thisline (org-current-line)) | ||
| 6706 | (thiscol (org-table-current-column)) | ||
| 6707 | beg end bcol ecol tend tbeg column lns pos) | ||
| 6708 | (when (equal thiscol 0) | ||
| 6709 | (if (interactive-p) | ||
| 6710 | (setq thiscol | ||
| 6711 | (string-to-number | ||
| 6712 | (read-string "Use column N for sorting: "))) | ||
| 6713 | (setq thiscol 1)) | ||
| 6714 | (org-table-goto-column thiscol)) | ||
| 6715 | (org-table-check-inside-data-field) | ||
| 6716 | (if (org-region-active-p) | ||
| 6717 | (progn | ||
| 6718 | (setq beg (region-beginning) end (region-end)) | ||
| 6719 | (goto-char beg) | ||
| 6720 | (setq column (org-table-current-column) | ||
| 6721 | beg (point-at-bol)) | ||
| 6722 | (goto-char end) | ||
| 6723 | (setq end (point-at-bol 2))) | ||
| 6724 | (setq column (org-table-current-column) | ||
| 6725 | pos (point) | ||
| 6726 | tbeg (org-table-begin) | ||
| 6727 | tend (org-table-end)) | ||
| 6728 | (if (re-search-backward org-table-hline-regexp tbeg t) | ||
| 6729 | (setq beg (point-at-bol 2)) | ||
| 6730 | (goto-char tbeg) | ||
| 6731 | (setq beg (point-at-bol 1))) | ||
| 6732 | (goto-char pos) | ||
| 6733 | (if (re-search-forward org-table-hline-regexp tend t) | ||
| 6734 | (setq beg (point-at-bol 0)) | ||
| 6735 | (goto-char tend) | ||
| 6736 | (setq end (point-at-bol)))) | ||
| 6737 | (setq beg (move-marker (make-marker) beg) | ||
| 6738 | end (move-marker (make-marker) end)) | ||
| 6739 | (untabify beg end) | ||
| 6740 | (goto-char beg) | ||
| 6741 | (org-table-goto-column column) | ||
| 6742 | (skip-chars-backward "^|") | ||
| 6743 | (setq bcol (current-column)) | ||
| 6744 | (org-table-goto-column (1+ column)) | ||
| 6745 | (skip-chars-backward "^|") | ||
| 6746 | (setq ecol (1- (current-column))) | ||
| 6747 | (org-table-goto-column column) | ||
| 6748 | (setq lns (mapcar (lambda(x) (cons (org-trim (substring x bcol ecol)) x)) | ||
| 6749 | (org-split-string (buffer-substring beg end) "\n"))) | ||
| 6750 | (setq lns (org-do-sort lns "Table" with-case sorting-type)) | ||
| 6751 | (delete-region beg end) | ||
| 6752 | (move-marker beg nil) | ||
| 6753 | (move-marker end nil) | ||
| 6754 | (insert (mapconcat 'cdr lns "\n") "\n") | ||
| 6755 | (goto-line thisline) | ||
| 6756 | (org-table-goto-column thiscol) | ||
| 6757 | (message "%d lines sorted, based on column %d" (length lns) column))) | ||
| 6758 | |||
| 6759 | (defun org-table-cut-region (beg end) | ||
| 6760 | "Copy region in table to the clipboard and blank all relevant fields." | ||
| 6761 | (interactive "r") | ||
| 6762 | (org-table-copy-region beg end 'cut)) | ||
| 6763 | |||
| 6764 | (defun org-table-copy-region (beg end &optional cut) | ||
| 6765 | "Copy rectangular region in table to clipboard. | ||
| 6766 | A special clipboard is used which can only be accessed | ||
| 6767 | with `org-table-paste-rectangle'." | ||
| 6768 | (interactive "rP") | ||
| 6769 | (let* (l01 c01 l02 c02 l1 c1 l2 c2 ic1 ic2 | ||
| 6770 | region cols | ||
| 6771 | (rpl (if cut " " nil))) | ||
| 6772 | (goto-char beg) | ||
| 6773 | (org-table-check-inside-data-field) | ||
| 6774 | (setq l01 (org-current-line) | ||
| 6775 | c01 (org-table-current-column)) | ||
| 6776 | (goto-char end) | ||
| 6777 | (org-table-check-inside-data-field) | ||
| 6778 | (setq l02 (org-current-line) | ||
| 6779 | c02 (org-table-current-column)) | ||
| 6780 | (setq l1 (min l01 l02) l2 (max l01 l02) | ||
| 6781 | c1 (min c01 c02) c2 (max c01 c02)) | ||
| 6782 | (catch 'exit | ||
| 6783 | (while t | ||
| 6784 | (catch 'nextline | ||
| 6785 | (if (> l1 l2) (throw 'exit t)) | ||
| 6786 | (goto-line l1) | ||
| 6787 | (if (org-at-table-hline-p) (throw 'nextline (setq l1 (1+ l1)))) | ||
| 6788 | (setq cols nil ic1 c1 ic2 c2) | ||
| 6789 | (while (< ic1 (1+ ic2)) | ||
| 6790 | (push (org-table-get-field ic1 rpl) cols) | ||
| 6791 | (setq ic1 (1+ ic1))) | ||
| 6792 | (push (nreverse cols) region) | ||
| 6793 | (setq l1 (1+ l1))))) | ||
| 6794 | (setq org-table-clip (nreverse region)) | ||
| 6795 | (if cut (org-table-align)) | ||
| 6796 | org-table-clip)) | ||
| 6797 | |||
| 6798 | (defun org-table-paste-rectangle () | ||
| 6799 | "Paste a rectangular region into a table. | ||
| 6800 | The upper right corner ends up in the current field. All involved fields | ||
| 6801 | will be overwritten. If the rectangle does not fit into the present table, | ||
| 6802 | the table is enlarged as needed. The process ignores horizontal separator | ||
| 6803 | lines." | ||
| 6804 | (interactive) | ||
| 6805 | (unless (and org-table-clip (listp org-table-clip)) | ||
| 6806 | (error "First cut/copy a region to paste!")) | ||
| 6807 | (org-table-check-inside-data-field) | ||
| 6808 | (let* ((clip org-table-clip) | ||
| 6809 | (line (org-current-line)) | ||
| 6810 | (col (org-table-current-column)) | ||
| 6811 | (org-enable-table-editor t) | ||
| 6812 | (org-table-automatic-realign nil) | ||
| 6813 | c cols field) | ||
| 6814 | (while (setq cols (pop clip)) | ||
| 6815 | (while (org-at-table-hline-p) (beginning-of-line 2)) | ||
| 6816 | (if (not (org-at-table-p)) | ||
| 6817 | (progn (end-of-line 0) (org-table-next-field))) | ||
| 6818 | (setq c col) | ||
| 6819 | (while (setq field (pop cols)) | ||
| 6820 | (org-table-goto-column c nil 'force) | ||
| 6821 | (org-table-get-field nil field) | ||
| 6822 | (setq c (1+ c))) | ||
| 6823 | (beginning-of-line 2)) | ||
| 6824 | (goto-line line) | ||
| 6825 | (org-table-goto-column col) | ||
| 6826 | (org-table-align))) | ||
| 6827 | |||
| 6828 | (defun org-table-convert () | ||
| 6829 | "Convert from `org-mode' table to table.el and back. | ||
| 6830 | Obviously, this only works within limits. When an Org-mode table is | ||
| 6831 | converted to table.el, all horizontal separator lines get lost, because | ||
| 6832 | table.el uses these as cell boundaries and has no notion of horizontal lines. | ||
| 6833 | A table.el table can be converted to an Org-mode table only if it does not | ||
| 6834 | do row or column spanning. Multiline cells will become multiple cells. | ||
| 6835 | Beware, Org-mode does not test if the table can be successfully converted - it | ||
| 6836 | blindly applies a recipe that works for simple tables." | ||
| 6837 | (interactive) | ||
| 6838 | (require 'table) | ||
| 6839 | (if (org-at-table.el-p) | ||
| 6840 | ;; convert to Org-mode table | ||
| 6841 | (let ((beg (move-marker (make-marker) (org-table-begin t))) | ||
| 6842 | (end (move-marker (make-marker) (org-table-end t)))) | ||
| 6843 | (table-unrecognize-region beg end) | ||
| 6844 | (goto-char beg) | ||
| 6845 | (while (re-search-forward "^\\([ \t]*\\)\\+-.*\n" end t) | ||
| 6846 | (replace-match "")) | ||
| 6847 | (goto-char beg)) | ||
| 6848 | (if (org-at-table-p) | ||
| 6849 | ;; convert to table.el table | ||
| 6850 | (let ((beg (move-marker (make-marker) (org-table-begin))) | ||
| 6851 | (end (move-marker (make-marker) (org-table-end)))) | ||
| 6852 | ;; first, get rid of all horizontal lines | ||
| 6853 | (goto-char beg) | ||
| 6854 | (while (re-search-forward "^\\([ \t]*\\)|-.*\n" end t) | ||
| 6855 | (replace-match "")) | ||
| 6856 | ;; insert a hline before first | ||
| 6857 | (goto-char beg) | ||
| 6858 | (org-table-insert-hline 'above) | ||
| 6859 | (beginning-of-line -1) | ||
| 6860 | ;; insert a hline after each line | ||
| 6861 | (while (progn (beginning-of-line 3) (< (point) end)) | ||
| 6862 | (org-table-insert-hline)) | ||
| 6863 | (goto-char beg) | ||
| 6864 | (setq end (move-marker end (org-table-end))) | ||
| 6865 | ;; replace "+" at beginning and ending of hlines | ||
| 6866 | (while (re-search-forward "^\\([ \t]*\\)|-" end t) | ||
| 6867 | (replace-match "\\1+-")) | ||
| 6868 | (goto-char beg) | ||
| 6869 | (while (re-search-forward "-|[ \t]*$" end t) | ||
| 6870 | (replace-match "-+")) | ||
| 6871 | (goto-char beg))))) | ||
| 6872 | |||
| 6873 | (defun org-table-wrap-region (arg) | ||
| 6874 | "Wrap several fields in a column like a paragraph. | ||
| 6875 | This is useful if you'd like to spread the contents of a field over several | ||
| 6876 | lines, in order to keep the table compact. | ||
| 6877 | |||
| 6878 | If there is an active region, and both point and mark are in the same column, | ||
| 6879 | the text in the column is wrapped to minimum width for the given number of | ||
| 6880 | lines. Generally, this makes the table more compact. A prefix ARG may be | ||
| 6881 | used to change the number of desired lines. For example, `C-2 \\[org-table-wrap]' | ||
| 6882 | formats the selected text to two lines. If the region was longer than two | ||
| 6883 | lines, the remaining lines remain empty. A negative prefix argument reduces | ||
| 6884 | the current number of lines by that amount. The wrapped text is pasted back | ||
| 6885 | into the table. If you formatted it to more lines than it was before, fields | ||
| 6886 | further down in the table get overwritten - so you might need to make space in | ||
| 6887 | the table first. | ||
| 6888 | |||
| 6889 | If there is no region, the current field is split at the cursor position and | ||
| 6890 | the text fragment to the right of the cursor is prepended to the field one | ||
| 6891 | line down. | ||
| 6892 | |||
| 6893 | If there is no region, but you specify a prefix ARG, the current field gets | ||
| 6894 | blank, and the content is appended to the field above." | ||
| 6895 | (interactive "P") | ||
| 6896 | (org-table-check-inside-data-field) | ||
| 6897 | (if (org-region-active-p) | ||
| 6898 | ;; There is a region: fill as a paragraph | ||
| 6899 | (let* ((beg (region-beginning)) | ||
| 6900 | (cline (save-excursion (goto-char beg) (org-current-line))) | ||
| 6901 | (ccol (save-excursion (goto-char beg) (org-table-current-column))) | ||
| 6902 | nlines) | ||
| 6903 | (org-table-cut-region (region-beginning) (region-end)) | ||
| 6904 | (if (> (length (car org-table-clip)) 1) | ||
| 6905 | (error "Region must be limited to single column")) | ||
| 6906 | (setq nlines (if arg | ||
| 6907 | (if (< arg 1) | ||
| 6908 | (+ (length org-table-clip) arg) | ||
| 6909 | arg) | ||
| 6910 | (length org-table-clip))) | ||
| 6911 | (setq org-table-clip | ||
| 6912 | (mapcar 'list (org-wrap (mapconcat 'car org-table-clip " ") | ||
| 6913 | nil nlines))) | ||
| 6914 | (goto-line cline) | ||
| 6915 | (org-table-goto-column ccol) | ||
| 6916 | (org-table-paste-rectangle)) | ||
| 6917 | ;; No region, split the current field at point | ||
| 6918 | (if arg | ||
| 6919 | ;; combine with field above | ||
| 6920 | (let ((s (org-table-blank-field)) | ||
| 6921 | (col (org-table-current-column))) | ||
| 6922 | (beginning-of-line 0) | ||
| 6923 | (while (org-at-table-hline-p) (beginning-of-line 0)) | ||
| 6924 | (org-table-goto-column col) | ||
| 6925 | (skip-chars-forward "^|") | ||
| 6926 | (skip-chars-backward " ") | ||
| 6927 | (insert " " (org-trim s)) | ||
| 6928 | (org-table-align)) | ||
| 6929 | ;; split field | ||
| 6930 | (when (looking-at "\\([^|]+\\)+|") | ||
| 6931 | (let ((s (match-string 1))) | ||
| 6932 | (replace-match " |") | ||
| 6933 | (goto-char (match-beginning 0)) | ||
| 6934 | (org-table-next-row) | ||
| 6935 | (insert (org-trim s) " ") | ||
| 6936 | (org-table-align)))))) | ||
| 6937 | |||
| 6938 | (defvar org-field-marker nil) | ||
| 6939 | |||
| 6940 | (defun org-table-edit-field (arg) | ||
| 6941 | "Edit table field in a different window. | ||
| 6942 | This is mainly useful for fields that contain hidden parts. | ||
| 6943 | When called with a \\[universal-argument] prefix, just make the full field visible so that | ||
| 6944 | it can be edited in place." | ||
| 6945 | (interactive "P") | ||
| 6946 | (if arg | ||
| 6947 | (let ((b (save-excursion (skip-chars-backward "^|") (point))) | ||
| 6948 | (e (save-excursion (skip-chars-forward "^|\r\n") (point)))) | ||
| 6949 | (remove-text-properties b e '(org-cwidth t invisible t | ||
| 6950 | display t intangible t)) | ||
| 6951 | (if (and (boundp 'font-lock-mode) font-lock-mode) | ||
| 6952 | (font-lock-fontify-block))) | ||
| 6953 | (let ((pos (move-marker (make-marker) (point))) | ||
| 6954 | (field (org-table-get-field)) | ||
| 6955 | (cw (current-window-configuration)) | ||
| 6956 | p) | ||
| 6957 | (switch-to-buffer-other-window "*Org tmp*") | ||
| 6958 | (erase-buffer) | ||
| 6959 | (insert "#\n# Edit field and finish with C-c C-c\n#\n") | ||
| 6960 | (org-mode) | ||
| 6961 | (goto-char (setq p (point-max))) | ||
| 6962 | (insert (org-trim field)) | ||
| 6963 | (remove-text-properties p (point-max) | ||
| 6964 | '(invisible t org-cwidth t display t | ||
| 6965 | intangible t)) | ||
| 6966 | (goto-char p) | ||
| 6967 | (org-set-local 'org-finish-function | ||
| 6968 | 'org-table-finish-edit-field) | ||
| 6969 | (org-set-local 'org-window-configuration cw) | ||
| 6970 | (org-set-local 'org-field-marker pos) | ||
| 6971 | (message "Edit and finish with C-c C-c")))) | ||
| 6972 | |||
| 6973 | (defun org-table-finish-edit-field () | ||
| 6974 | "Finish editing a table data field. | ||
| 6975 | Remove all newline characters, insert the result into the table, realign | ||
| 6976 | the table and kill the editing buffer." | ||
| 6977 | (let ((pos org-field-marker) | ||
| 6978 | (cw org-window-configuration) | ||
| 6979 | (cb (current-buffer)) | ||
| 6980 | text) | ||
| 6981 | (goto-char (point-min)) | ||
| 6982 | (while (re-search-forward "^#.*\n?" nil t) (replace-match "")) | ||
| 6983 | (while (re-search-forward "\\([ \t]*\n[ \t]*\\)+" nil t) | ||
| 6984 | (replace-match " ")) | ||
| 6985 | (setq text (org-trim (buffer-string))) | ||
| 6986 | (set-window-configuration cw) | ||
| 6987 | (kill-buffer cb) | ||
| 6988 | (select-window (get-buffer-window (marker-buffer pos))) | ||
| 6989 | (goto-char pos) | ||
| 6990 | (move-marker pos nil) | ||
| 6991 | (org-table-check-inside-data-field) | ||
| 6992 | (org-table-get-field nil text) | ||
| 6993 | (org-table-align) | ||
| 6994 | (message "New field value inserted"))) | ||
| 6995 | |||
| 6996 | (defun org-trim (s) | ||
| 6997 | "Remove whitespace at beginning and end of string." | ||
| 6998 | (if (string-match "^[ \t]+" s) (setq s (replace-match "" t t s))) | ||
| 6999 | (if (string-match "[ \t]+$" s) (setq s (replace-match "" t t s))) | ||
| 7000 | s) | ||
| 7001 | |||
| 7002 | (defun org-wrap (string &optional width lines) | ||
| 7003 | "Wrap string to either a number of lines, or a width in characters. | ||
| 7004 | If WIDTH is non-nil, the string is wrapped to that width, however many lines | ||
| 7005 | that costs. If there is a word longer than WIDTH, the text is actually | ||
| 7006 | wrapped to the length of that word. | ||
| 7007 | IF WIDTH is nil and LINES is non-nil, the string is forced into at most that | ||
| 7008 | many lines, whatever width that takes. | ||
| 7009 | The return value is a list of lines, without newlines at the end." | ||
| 7010 | (let* ((words (org-split-string string "[ \t\n]+")) | ||
| 7011 | (maxword (apply 'max (mapcar 'org-string-width words))) | ||
| 7012 | w ll) | ||
| 7013 | (cond (width | ||
| 7014 | (org-do-wrap words (max maxword width))) | ||
| 7015 | (lines | ||
| 7016 | (setq w maxword) | ||
| 7017 | (setq ll (org-do-wrap words maxword)) | ||
| 7018 | (if (<= (length ll) lines) | ||
| 7019 | ll | ||
| 7020 | (setq ll words) | ||
| 7021 | (while (> (length ll) lines) | ||
| 7022 | (setq w (1+ w)) | ||
| 7023 | (setq ll (org-do-wrap words w))) | ||
| 7024 | ll)) | ||
| 7025 | (t (error "Cannot wrap this"))))) | ||
| 7026 | |||
| 7027 | |||
| 7028 | (defun org-do-wrap (words width) | ||
| 7029 | "Create lines of maximum width WIDTH (in characters) from word list WORDS." | ||
| 7030 | (let (lines line) | ||
| 7031 | (while words | ||
| 7032 | (setq line (pop words)) | ||
| 7033 | (while (and words (< (+ (length line) (length (car words))) width)) | ||
| 7034 | (setq line (concat line " " (pop words)))) | ||
| 7035 | (setq lines (push line lines))) | ||
| 7036 | (nreverse lines))) | ||
| 7037 | |||
| 7038 | (defun org-split-string (string &optional separators) | ||
| 7039 | "Splits STRING into substrings at SEPARATORS. | ||
| 7040 | No empty strings are returned if there are matches at the beginning | ||
| 7041 | and end of string." | ||
| 7042 | (let ((rexp (or separators "[ \f\t\n\r\v]+")) | ||
| 7043 | (start 0) | ||
| 7044 | notfirst | ||
| 7045 | (list nil)) | ||
| 7046 | (while (and (string-match rexp string | ||
| 7047 | (if (and notfirst | ||
| 7048 | (= start (match-beginning 0)) | ||
| 7049 | (< start (length string))) | ||
| 7050 | (1+ start) start)) | ||
| 7051 | (< (match-beginning 0) (length string))) | ||
| 7052 | (setq notfirst t) | ||
| 7053 | (or (eq (match-beginning 0) 0) | ||
| 7054 | (and (eq (match-beginning 0) (match-end 0)) | ||
| 7055 | (eq (match-beginning 0) start)) | ||
| 7056 | (setq list | ||
| 7057 | (cons (substring string start (match-beginning 0)) | ||
| 7058 | list))) | ||
| 7059 | (setq start (match-end 0))) | ||
| 7060 | (or (eq start (length string)) | ||
| 7061 | (setq list | ||
| 7062 | (cons (substring string start) | ||
| 7063 | list))) | ||
| 7064 | (nreverse list))) | ||
| 7065 | |||
| 7066 | (defun org-table-map-tables (function) | ||
| 7067 | "Apply FUNCTION to the start of all tables in the buffer." | ||
| 7068 | (save-excursion | ||
| 7069 | (save-restriction | ||
| 7070 | (widen) | ||
| 7071 | (goto-char (point-min)) | ||
| 7072 | (while (re-search-forward org-table-any-line-regexp nil t) | ||
| 7073 | (message "Mapping tables: %d%%" (/ (* 100.0 (point)) (buffer-size))) | ||
| 7074 | (beginning-of-line 1) | ||
| 7075 | (if (looking-at org-table-line-regexp) | ||
| 7076 | (save-excursion (funcall function))) | ||
| 7077 | (re-search-forward org-table-any-border-regexp nil 1)))) | ||
| 7078 | (message "Mapping tables: done")) | ||
| 7079 | |||
| 7080 | (defvar org-timecnt) ; dynamically scoped parameter | ||
| 7081 | |||
| 7082 | (defun org-table-sum (&optional beg end nlast) | ||
| 7083 | "Sum numbers in region of current table column. | ||
| 7084 | The result will be displayed in the echo area, and will be available | ||
| 7085 | as kill to be inserted with \\[yank]. | ||
| 7086 | |||
| 7087 | If there is an active region, it is interpreted as a rectangle and all | ||
| 7088 | numbers in that rectangle will be summed. If there is no active | ||
| 7089 | region and point is located in a table column, sum all numbers in that | ||
| 7090 | column. | ||
| 7091 | |||
| 7092 | If at least one number looks like a time HH:MM or HH:MM:SS, all other | ||
| 7093 | numbers are assumed to be times as well (in decimal hours) and the | ||
| 7094 | numbers are added as such. | ||
| 7095 | |||
| 7096 | If NLAST is a number, only the NLAST fields will actually be summed." | ||
| 7097 | (interactive) | ||
| 7098 | (save-excursion | ||
| 7099 | (let (col (org-timecnt 0) diff h m s org-table-clip) | ||
| 5091 | (cond | 7100 | (cond |
| 5092 | ((equal (current-buffer) abuf) nil) | 7101 | ((and beg end)) ; beg and end given explicitly |
| 5093 | (awin (select-window awin)) | 7102 | ((org-region-active-p) |
| 5094 | ((not (setq org-pre-agenda-window-conf (current-window-configuration)))) | 7103 | (setq beg (region-beginning) end (region-end))) |
| 5095 | ((equal org-agenda-window-setup 'current-window) | 7104 | (t |
| 5096 | (switch-to-buffer abuf)) | 7105 | (setq col (org-table-current-column)) |
| 5097 | ((equal org-agenda-window-setup 'other-window) | 7106 | (goto-char (org-table-begin)) |
| 5098 | (switch-to-buffer-other-window abuf)) | 7107 | (unless (re-search-forward "^[ \t]*|[^-]" nil t) |
| 5099 | ((equal org-agenda-window-setup 'other-frame) | 7108 | (error "No table data")) |
| 5100 | (switch-to-buffer-other-frame abuf)) | 7109 | (org-table-goto-column col) |
| 5101 | ((equal org-agenda-window-setup 'reorganize-frame) | 7110 | (setq beg (point)) |
| 5102 | (delete-other-windows) | 7111 | (goto-char (org-table-end)) |
| 5103 | (switch-to-buffer-other-window abuf)))) | 7112 | (unless (re-search-backward "^[ \t]*|[^-]" nil t) |
| 5104 | (setq buffer-read-only nil) | 7113 | (error "No table data")) |
| 7114 | (org-table-goto-column col) | ||
| 7115 | (setq end (point)))) | ||
| 7116 | (let* ((items (apply 'append (org-table-copy-region beg end))) | ||
| 7117 | (items1 (cond ((not nlast) items) | ||
| 7118 | ((>= nlast (length items)) items) | ||
| 7119 | (t (setq items (reverse items)) | ||
| 7120 | (setcdr (nthcdr (1- nlast) items) nil) | ||
| 7121 | (nreverse items)))) | ||
| 7122 | (numbers (delq nil (mapcar 'org-table-get-number-for-summing | ||
| 7123 | items1))) | ||
| 7124 | (res (apply '+ numbers)) | ||
| 7125 | (sres (if (= org-timecnt 0) | ||
| 7126 | (format "%g" res) | ||
| 7127 | (setq diff (* 3600 res) | ||
| 7128 | h (floor (/ diff 3600)) diff (mod diff 3600) | ||
| 7129 | m (floor (/ diff 60)) diff (mod diff 60) | ||
| 7130 | s diff) | ||
| 7131 | (format "%d:%02d:%02d" h m s)))) | ||
| 7132 | (kill-new sres) | ||
| 7133 | (if (interactive-p) | ||
| 7134 | (message "%s" | ||
| 7135 | (substitute-command-keys | ||
| 7136 | (format "Sum of %d items: %-20s (\\[yank] will insert result into buffer)" | ||
| 7137 | (length numbers) sres)))) | ||
| 7138 | sres)))) | ||
| 7139 | |||
| 7140 | (defun org-table-get-number-for-summing (s) | ||
| 7141 | (let (n) | ||
| 7142 | (if (string-match "^ *|? *" s) | ||
| 7143 | (setq s (replace-match "" nil nil s))) | ||
| 7144 | (if (string-match " *|? *$" s) | ||
| 7145 | (setq s (replace-match "" nil nil s))) | ||
| 7146 | (setq n (string-to-number s)) | ||
| 7147 | (cond | ||
| 7148 | ((and (string-match "0" s) | ||
| 7149 | (string-match "\\`[-+ \t0.edED]+\\'" s)) 0) | ||
| 7150 | ((string-match "\\`[ \t]+\\'" s) nil) | ||
| 7151 | ((string-match "\\`\\([0-9]+\\):\\([0-9]+\\)\\(:\\([0-9]+\\)\\)?\\'" s) | ||
| 7152 | (let ((h (string-to-number (or (match-string 1 s) "0"))) | ||
| 7153 | (m (string-to-number (or (match-string 2 s) "0"))) | ||
| 7154 | (s (string-to-number (or (match-string 4 s) "0")))) | ||
| 7155 | (if (boundp 'org-timecnt) (setq org-timecnt (1+ org-timecnt))) | ||
| 7156 | (* 1.0 (+ h (/ m 60.0) (/ s 3600.0))))) | ||
| 7157 | ((equal n 0) nil) | ||
| 7158 | (t n)))) | ||
| 7159 | |||
| 7160 | (defun org-table-current-field-formula () | ||
| 7161 | "Return the formula active for the current field. | ||
| 7162 | Assumes that specials are in place." | ||
| 7163 | (let* ((name (car (rassoc (list (org-current-line) | ||
| 7164 | (org-table-current-column)) | ||
| 7165 | org-table-named-field-locations))) | ||
| 7166 | (col (org-table-current-column)) | ||
| 7167 | (scol (int-to-string col)) | ||
| 7168 | (ref (format "@%d$%d" (org-table-current-dline) col)) | ||
| 7169 | (stored-list (org-table-get-stored-formulas)) | ||
| 7170 | (ass (or (assoc name stored-list) | ||
| 7171 | (assoc ref stored-list) | ||
| 7172 | (assoc scol stored-list)))) | ||
| 7173 | (if ass (concat (if (string-match "^[0-9]+$" (car ass)) "=" ":=") | ||
| 7174 | (cdr ass))))) | ||
| 7175 | |||
| 7176 | (defun org-table-get-formula (&optional equation named) | ||
| 7177 | "Read a formula from the minibuffer, offer stored formula as default. | ||
| 7178 | When NAMED is non-nil, look for a named equation." | ||
| 7179 | (let* ((stored-list (org-table-get-stored-formulas)) | ||
| 7180 | (name (car (rassoc (list (org-current-line) | ||
| 7181 | (org-table-current-column)) | ||
| 7182 | org-table-named-field-locations))) | ||
| 7183 | (ref (format "@%d$%d" (org-table-current-dline) | ||
| 7184 | (org-table-current-column))) | ||
| 7185 | (refass (assoc ref stored-list)) | ||
| 7186 | (scol (if named | ||
| 7187 | (if name name ref) | ||
| 7188 | (int-to-string (org-table-current-column)))) | ||
| 7189 | (dummy (and (or name refass) (not named) | ||
| 7190 | (not (y-or-n-p "Replace field formula with column formula? " )) | ||
| 7191 | (error "Abort"))) | ||
| 7192 | (name (or name ref)) | ||
| 7193 | (org-table-may-need-update nil) | ||
| 7194 | (stored (cdr (assoc scol stored-list))) | ||
| 7195 | (eq (cond | ||
| 7196 | ((and stored equation (string-match "^ *=? *$" equation)) | ||
| 7197 | stored) | ||
| 7198 | ((stringp equation) | ||
| 7199 | equation) | ||
| 7200 | (t (read-string | ||
| 7201 | (format "%s formula $%s=" (if named "Field" "Column") scol) | ||
| 7202 | (or stored "") 'org-table-formula-history | ||
| 7203 | ;stored | ||
| 7204 | )))) | ||
| 7205 | mustsave) | ||
| 7206 | (when (not (string-match "\\S-" eq)) | ||
| 7207 | ;; remove formula | ||
| 7208 | (setq stored-list (delq (assoc scol stored-list) stored-list)) | ||
| 7209 | (org-table-store-formulas stored-list) | ||
| 7210 | (error "Formula removed")) | ||
| 7211 | (if (string-match "^ *=?" eq) (setq eq (replace-match "" t t eq))) | ||
| 7212 | (if (string-match " *$" eq) (setq eq (replace-match "" t t eq))) | ||
| 7213 | (if (and name (not named)) | ||
| 7214 | ;; We set the column equation, delete the named one. | ||
| 7215 | (setq stored-list (delq (assoc name stored-list) stored-list) | ||
| 7216 | mustsave t)) | ||
| 7217 | (if stored | ||
| 7218 | (setcdr (assoc scol stored-list) eq) | ||
| 7219 | (setq stored-list (cons (cons scol eq) stored-list))) | ||
| 7220 | (if (or mustsave (not (equal stored eq))) | ||
| 7221 | (org-table-store-formulas stored-list)) | ||
| 7222 | eq)) | ||
| 7223 | |||
| 7224 | (defun org-table-store-formulas (alist) | ||
| 7225 | "Store the list of formulas below the current table." | ||
| 7226 | (setq alist (sort alist (lambda (a b) (string< (car a) (car b))))) | ||
| 7227 | (save-excursion | ||
| 7228 | (goto-char (org-table-end)) | ||
| 7229 | (if (looking-at "\\([ \t]*\n\\)*#\\+TBLFM:\\(.*\n?\\)") | ||
| 7230 | (progn | ||
| 7231 | ;; don't overwrite TBLFM, we might use text properties to store stuff | ||
| 7232 | (goto-char (match-beginning 2)) | ||
| 7233 | (delete-region (match-beginning 2) (match-end 0))) | ||
| 7234 | (insert "#+TBLFM:")) | ||
| 7235 | (insert " " | ||
| 7236 | (mapconcat (lambda (x) | ||
| 7237 | (concat | ||
| 7238 | (if (equal (string-to-char (car x)) ?@) "" "$") | ||
| 7239 | (car x) "=" (cdr x))) | ||
| 7240 | alist "::") | ||
| 7241 | "\n"))) | ||
| 7242 | |||
| 7243 | (defun org-table-get-stored-formulas () | ||
| 7244 | "Return an alist with the stored formulas directly after current table." | ||
| 7245 | (interactive) | ||
| 7246 | (let (scol eq eq-alist strings string seen) | ||
| 7247 | (save-excursion | ||
| 7248 | (goto-char (org-table-end)) | ||
| 7249 | (when (looking-at "\\([ \t]*\n\\)*#\\+TBLFM: *\\(.*\\)") | ||
| 7250 | (setq strings (org-split-string (match-string 2) " *:: *")) | ||
| 7251 | (while (setq string (pop strings)) | ||
| 7252 | (when (string-match "\\(@[0-9]+\\$[0-9]+\\|\\$\\([a-zA-Z0-9]+\\)\\) *= *\\(.*[^ \t]\\)" string) | ||
| 7253 | (setq scol (if (match-end 2) | ||
| 7254 | (match-string 2 string) | ||
| 7255 | (match-string 1 string)) | ||
| 7256 | eq (match-string 3 string) | ||
| 7257 | eq-alist (cons (cons scol eq) eq-alist)) | ||
| 7258 | (if (member scol seen) | ||
| 7259 | (error "Double definition `$%s=' in TBLFM line, please fix by hand" scol) | ||
| 7260 | (push scol seen)))))) | ||
| 7261 | (nreverse eq-alist))) | ||
| 7262 | |||
| 7263 | (defun org-table-fix-formulas (key replace &optional limit delta remove) | ||
| 7264 | "Modify the equations after the table structure has been edited. | ||
| 7265 | KEY is \"@\" or \"$\". REPLACE is an alist of numbers to replace. | ||
| 7266 | For all numbers larger than LIMIT, shift them by DELTA." | ||
| 7267 | (save-excursion | ||
| 7268 | (goto-char (org-table-end)) | ||
| 7269 | (when (looking-at "#\\+TBLFM:") | ||
| 7270 | (let ((re (concat key "\\([0-9]+\\)")) | ||
| 7271 | (re2 | ||
| 7272 | (when remove | ||
| 7273 | (if (equal key "$") | ||
| 7274 | (format "\\(@[0-9]+\\)?\\$%d=.*?\\(::\\|$\\)" remove) | ||
| 7275 | (format "@%d\\$[0-9]+=.*?\\(::\\|$\\)" remove)))) | ||
| 7276 | s n a) | ||
| 7277 | (when remove | ||
| 7278 | (while (re-search-forward re2 (point-at-eol) t) | ||
| 7279 | (replace-match ""))) | ||
| 7280 | (while (re-search-forward re (point-at-eol) t) | ||
| 7281 | (setq s (match-string 1) n (string-to-number s)) | ||
| 7282 | (cond | ||
| 7283 | ((setq a (assoc s replace)) | ||
| 7284 | (replace-match (concat key (cdr a)) t t)) | ||
| 7285 | ((and limit (> n limit)) | ||
| 7286 | (replace-match (concat key (int-to-string (+ n delta))) t t)))))))) | ||
| 7287 | |||
| 7288 | (defun org-table-get-specials () | ||
| 7289 | "Get the column names and local parameters for this table." | ||
| 7290 | (save-excursion | ||
| 7291 | (let ((beg (org-table-begin)) (end (org-table-end)) | ||
| 7292 | names name fields fields1 field cnt | ||
| 7293 | c v l line col types dlines hlines) | ||
| 7294 | (setq org-table-column-names nil | ||
| 7295 | org-table-local-parameters nil | ||
| 7296 | org-table-named-field-locations nil | ||
| 7297 | org-table-current-begin-line nil | ||
| 7298 | org-table-current-line-types nil) | ||
| 7299 | (goto-char beg) | ||
| 7300 | (when (re-search-forward "^[ \t]*| *! *\\(|.*\\)" end t) | ||
| 7301 | (setq names (org-split-string (match-string 1) " *| *") | ||
| 7302 | cnt 1) | ||
| 7303 | (while (setq name (pop names)) | ||
| 7304 | (setq cnt (1+ cnt)) | ||
| 7305 | (if (string-match "^[a-zA-Z][a-zA-Z0-9]*$" name) | ||
| 7306 | (push (cons name (int-to-string cnt)) org-table-column-names)))) | ||
| 7307 | (setq org-table-column-names (nreverse org-table-column-names)) | ||
| 7308 | (setq org-table-column-name-regexp | ||
| 7309 | (concat "\\$\\(" (mapconcat 'car org-table-column-names "\\|") "\\)\\>")) | ||
| 7310 | (goto-char beg) | ||
| 7311 | (while (re-search-forward "^[ \t]*| *\\$ *\\(|.*\\)" end t) | ||
| 7312 | (setq fields (org-split-string (match-string 1) " *| *")) | ||
| 7313 | (while (setq field (pop fields)) | ||
| 7314 | (if (string-match "^\\([a-zA-Z][a-zA-Z0-9]*\\|%\\) *= *\\(.*\\)" field) | ||
| 7315 | (push (cons (match-string 1 field) (match-string 2 field)) | ||
| 7316 | org-table-local-parameters)))) | ||
| 7317 | (goto-char beg) | ||
| 7318 | (while (re-search-forward "^[ \t]*| *\\([_^]\\) *\\(|.*\\)" end t) | ||
| 7319 | (setq c (match-string 1) | ||
| 7320 | fields (org-split-string (match-string 2) " *| *")) | ||
| 7321 | (save-excursion | ||
| 7322 | (beginning-of-line (if (equal c "_") 2 0)) | ||
| 7323 | (setq line (org-current-line) col 1) | ||
| 7324 | (and (looking-at "^[ \t]*|[^|]*\\(|.*\\)") | ||
| 7325 | (setq fields1 (org-split-string (match-string 1) " *| *")))) | ||
| 7326 | (while (and fields1 (setq field (pop fields))) | ||
| 7327 | (setq v (pop fields1) col (1+ col)) | ||
| 7328 | (when (and (stringp field) (stringp v) | ||
| 7329 | (string-match "^[a-zA-Z][a-zA-Z0-9]*$" field)) | ||
| 7330 | (push (cons field v) org-table-local-parameters) | ||
| 7331 | (push (list field line col) org-table-named-field-locations)))) | ||
| 7332 | ;; Analyse the line types | ||
| 7333 | (goto-char beg) | ||
| 7334 | (setq org-table-current-begin-line (org-current-line) | ||
| 7335 | l org-table-current-begin-line) | ||
| 7336 | (while (looking-at "[ \t]*|\\(-\\)?") | ||
| 7337 | (push (if (match-end 1) 'hline 'dline) types) | ||
| 7338 | (if (match-end 1) (push l hlines) (push l dlines)) | ||
| 7339 | (beginning-of-line 2) | ||
| 7340 | (setq l (1+ l))) | ||
| 7341 | (setq org-table-current-line-types (apply 'vector (nreverse types)) | ||
| 7342 | org-table-dlines (apply 'vector (cons nil (nreverse dlines))) | ||
| 7343 | org-table-hlines (apply 'vector (cons nil (nreverse hlines))))))) | ||
| 7344 | |||
| 7345 | (defun org-this-word () | ||
| 7346 | ;; Get the current word | ||
| 7347 | (save-excursion | ||
| 7348 | (let ((beg (progn (skip-chars-backward "^ \t\n") (point))) | ||
| 7349 | (end (progn (skip-chars-forward "^ \t\n") (point)))) | ||
| 7350 | (buffer-substring-no-properties beg end)))) | ||
| 7351 | |||
| 7352 | (defun org-table-maybe-eval-formula () | ||
| 7353 | "Check if the current field starts with \"=\" or \":=\". | ||
| 7354 | If yes, store the formula and apply it." | ||
| 7355 | ;; We already know we are in a table. Get field will only return a formula | ||
| 7356 | ;; when appropriate. It might return a separator line, but no problem. | ||
| 7357 | (when org-table-formula-evaluate-inline | ||
| 7358 | (let* ((field (org-trim (or (org-table-get-field) ""))) | ||
| 7359 | named eq) | ||
| 7360 | (when (string-match "^:?=\\(.*\\)" field) | ||
| 7361 | (setq named (equal (string-to-char field) ?:) | ||
| 7362 | eq (match-string 1 field)) | ||
| 7363 | (if (or (fboundp 'calc-eval) | ||
| 7364 | (equal (substring eq 0 (min 2 (length eq))) "'(")) | ||
| 7365 | (org-table-eval-formula (if named '(4) nil) eq) | ||
| 7366 | (error "Calc does not seem to be installed, and is needed to evaluate the formula")))))) | ||
| 7367 | |||
| 7368 | (defvar org-recalc-commands nil | ||
| 7369 | "List of commands triggering the recalculation of a line. | ||
| 7370 | Will be filled automatically during use.") | ||
| 7371 | |||
| 7372 | (defvar org-recalc-marks | ||
| 7373 | '((" " . "Unmarked: no special line, no automatic recalculation") | ||
| 7374 | ("#" . "Automatically recalculate this line upon TAB, RET, and C-c C-c in the line") | ||
| 7375 | ("*" . "Recalculate only when entire table is recalculated with `C-u C-c *'") | ||
| 7376 | ("!" . "Column name definition line. Reference in formula as $name.") | ||
| 7377 | ("$" . "Parameter definition line name=value. Reference in formula as $name.") | ||
| 7378 | ("_" . "Names for values in row below this one.") | ||
| 7379 | ("^" . "Names for values in row above this one."))) | ||
| 7380 | |||
| 7381 | (defun org-table-rotate-recalc-marks (&optional newchar) | ||
| 7382 | "Rotate the recalculation mark in the first column. | ||
| 7383 | If in any row, the first field is not consistent with a mark, | ||
| 7384 | insert a new column for the markers. | ||
| 7385 | When there is an active region, change all the lines in the region, | ||
| 7386 | after prompting for the marking character. | ||
| 7387 | After each change, a message will be displayed indicating the meaning | ||
| 7388 | of the new mark." | ||
| 7389 | (interactive) | ||
| 7390 | (unless (org-at-table-p) (error "Not at a table")) | ||
| 7391 | (let* ((marks (append (mapcar 'car org-recalc-marks) '(" "))) | ||
| 7392 | (beg (org-table-begin)) | ||
| 7393 | (end (org-table-end)) | ||
| 7394 | (l (org-current-line)) | ||
| 7395 | (l1 (if (org-region-active-p) (org-current-line (region-beginning)))) | ||
| 7396 | (l2 (if (org-region-active-p) (org-current-line (region-end)))) | ||
| 7397 | (have-col | ||
| 7398 | (save-excursion | ||
| 7399 | (goto-char beg) | ||
| 7400 | (not (re-search-forward "^[ \t]*|[^-|][^|]*[^#!$*_^| \t][^|]*|" end t)))) | ||
| 7401 | (col (org-table-current-column)) | ||
| 7402 | (forcenew (car (assoc newchar org-recalc-marks))) | ||
| 7403 | epos new) | ||
| 7404 | (when l1 | ||
| 7405 | (message "Change region to what mark? Type # * ! $ or SPC: ") | ||
| 7406 | (setq newchar (char-to-string (read-char-exclusive)) | ||
| 7407 | forcenew (car (assoc newchar org-recalc-marks)))) | ||
| 7408 | (if (and newchar (not forcenew)) | ||
| 7409 | (error "Invalid NEWCHAR `%s' in `org-table-rotate-recalc-marks'" | ||
| 7410 | newchar)) | ||
| 7411 | (if l1 (goto-line l1)) | ||
| 7412 | (save-excursion | ||
| 7413 | (beginning-of-line 1) | ||
| 7414 | (unless (looking-at org-table-dataline-regexp) | ||
| 7415 | (error "Not at a table data line"))) | ||
| 7416 | (unless have-col | ||
| 7417 | (org-table-goto-column 1) | ||
| 7418 | (org-table-insert-column) | ||
| 7419 | (org-table-goto-column (1+ col))) | ||
| 7420 | (setq epos (point-at-eol)) | ||
| 7421 | (save-excursion | ||
| 7422 | (beginning-of-line 1) | ||
| 7423 | (org-table-get-field | ||
| 7424 | 1 (if (looking-at "^[ \t]*| *\\([#!$*^_ ]\\) *|") | ||
| 7425 | (concat " " | ||
| 7426 | (setq new (or forcenew | ||
| 7427 | (cadr (member (match-string 1) marks)))) | ||
| 7428 | " ") | ||
| 7429 | " # "))) | ||
| 7430 | (if (and l1 l2) | ||
| 7431 | (progn | ||
| 7432 | (goto-line l1) | ||
| 7433 | (while (progn (beginning-of-line 2) (not (= (org-current-line) l2))) | ||
| 7434 | (and (looking-at org-table-dataline-regexp) | ||
| 7435 | (org-table-get-field 1 (concat " " new " ")))) | ||
| 7436 | (goto-line l1))) | ||
| 7437 | (if (not (= epos (point-at-eol))) (org-table-align)) | ||
| 7438 | (goto-line l) | ||
| 7439 | (and (interactive-p) (message (cdr (assoc new org-recalc-marks)))))) | ||
| 7440 | |||
| 7441 | (defun org-table-maybe-recalculate-line () | ||
| 7442 | "Recompute the current line if marked for it, and if we haven't just done it." | ||
| 7443 | (interactive) | ||
| 7444 | (and org-table-allow-automatic-line-recalculation | ||
| 7445 | (not (and (memq last-command org-recalc-commands) | ||
| 7446 | (equal org-last-recalc-line (org-current-line)))) | ||
| 7447 | (save-excursion (beginning-of-line 1) | ||
| 7448 | (looking-at org-table-auto-recalculate-regexp)) | ||
| 7449 | (org-table-recalculate) t)) | ||
| 7450 | |||
| 7451 | (defvar org-table-formula-debug nil | ||
| 7452 | "Non-nil means, debug table formulas. | ||
| 7453 | When nil, simply write \"#ERROR\" in corrupted fields.") | ||
| 7454 | (make-variable-buffer-local 'org-table-formula-debug) | ||
| 7455 | |||
| 7456 | (defvar modes) | ||
| 7457 | (defsubst org-set-calc-mode (var &optional value) | ||
| 7458 | (if (stringp var) | ||
| 7459 | (setq var (assoc var '(("D" calc-angle-mode deg) | ||
| 7460 | ("R" calc-angle-mode rad) | ||
| 7461 | ("F" calc-prefer-frac t) | ||
| 7462 | ("S" calc-symbolic-mode t))) | ||
| 7463 | value (nth 2 var) var (nth 1 var))) | ||
| 7464 | (if (memq var modes) | ||
| 7465 | (setcar (cdr (memq var modes)) value) | ||
| 7466 | (cons var (cons value modes))) | ||
| 7467 | modes) | ||
| 7468 | |||
| 7469 | (defun org-table-eval-formula (&optional arg equation | ||
| 7470 | suppress-align suppress-const | ||
| 7471 | suppress-store suppress-analysis) | ||
| 7472 | "Replace the table field value at the cursor by the result of a calculation. | ||
| 7473 | |||
| 7474 | This function makes use of Dave Gillespie's Calc package, in my view the | ||
| 7475 | most exciting program ever written for GNU Emacs. So you need to have Calc | ||
| 7476 | installed in order to use this function. | ||
| 7477 | |||
| 7478 | In a table, this command replaces the value in the current field with the | ||
| 7479 | result of a formula. It also installs the formula as the \"current\" column | ||
| 7480 | formula, by storing it in a special line below the table. When called | ||
| 7481 | with a `C-u' prefix, the current field must ba a named field, and the | ||
| 7482 | formula is installed as valid in only this specific field. | ||
| 7483 | |||
| 7484 | When called with two `C-u' prefixes, insert the active equation | ||
| 7485 | for the field back into the current field, so that it can be | ||
| 7486 | edited there. This is useful in order to use \\[org-show-reference] | ||
| 7487 | to check the referenced fields. | ||
| 7488 | |||
| 7489 | When called, the command first prompts for a formula, which is read in | ||
| 7490 | the minibuffer. Previously entered formulas are available through the | ||
| 7491 | history list, and the last used formula is offered as a default. | ||
| 7492 | These stored formulas are adapted correctly when moving, inserting, or | ||
| 7493 | deleting columns with the corresponding commands. | ||
| 7494 | |||
| 7495 | The formula can be any algebraic expression understood by the Calc package. | ||
| 7496 | For details, see the Org-mode manual. | ||
| 7497 | |||
| 7498 | This function can also be called from Lisp programs and offers | ||
| 7499 | additional arguments: EQUATION can be the formula to apply. If this | ||
| 7500 | argument is given, the user will not be prompted. SUPPRESS-ALIGN is | ||
| 7501 | used to speed-up recursive calls by by-passing unnecessary aligns. | ||
| 7502 | SUPPRESS-CONST suppresses the interpretation of constants in the | ||
| 7503 | formula, assuming that this has been done already outside the function. | ||
| 7504 | SUPPRESS-STORE means the formula should not be stored, either because | ||
| 7505 | it is already stored, or because it is a modified equation that should | ||
| 7506 | not overwrite the stored one." | ||
| 7507 | (interactive "P") | ||
| 7508 | (org-table-check-inside-data-field) | ||
| 7509 | (or suppress-analysis (org-table-get-specials)) | ||
| 7510 | (if (equal arg '(16)) | ||
| 7511 | (let ((eq (org-table-current-field-formula))) | ||
| 7512 | (or eq (error "No equation active for current field")) | ||
| 7513 | (org-table-get-field nil eq) | ||
| 7514 | (org-table-align) | ||
| 7515 | (setq org-table-may-need-update t)) | ||
| 7516 | (let* (fields | ||
| 7517 | (ndown (if (integerp arg) arg 1)) | ||
| 7518 | (org-table-automatic-realign nil) | ||
| 7519 | (case-fold-search nil) | ||
| 7520 | (down (> ndown 1)) | ||
| 7521 | (formula (if (and equation suppress-store) | ||
| 7522 | equation | ||
| 7523 | (org-table-get-formula equation (equal arg '(4))))) | ||
| 7524 | (n0 (org-table-current-column)) | ||
| 7525 | (modes (copy-sequence org-calc-default-modes)) | ||
| 7526 | (numbers nil) ; was a variable, now fixed default | ||
| 7527 | (keep-empty nil) | ||
| 7528 | n form form0 bw fmt x ev orig c lispp) | ||
| 7529 | ;; Parse the format string. Since we have a lot of modes, this is | ||
| 7530 | ;; a lot of work. However, I think calc still uses most of the time. | ||
| 7531 | (if (string-match ";" formula) | ||
| 7532 | (let ((tmp (org-split-string formula ";"))) | ||
| 7533 | (setq formula (car tmp) | ||
| 7534 | fmt (concat (cdr (assoc "%" org-table-local-parameters)) | ||
| 7535 | (nth 1 tmp))) | ||
| 7536 | (while (string-match "\\([pnfse]\\)\\(-?[0-9]+\\)" fmt) | ||
| 7537 | (setq c (string-to-char (match-string 1 fmt)) | ||
| 7538 | n (string-to-number (match-string 2 fmt))) | ||
| 7539 | (if (= c ?p) | ||
| 7540 | (setq modes (org-set-calc-mode 'calc-internal-prec n)) | ||
| 7541 | (setq modes (org-set-calc-mode | ||
| 7542 | 'calc-float-format | ||
| 7543 | (list (cdr (assoc c '((?n . float) (?f . fix) | ||
| 7544 | (?s . sci) (?e . eng)))) | ||
| 7545 | n)))) | ||
| 7546 | (setq fmt (replace-match "" t t fmt))) | ||
| 7547 | (if (string-match "[NT]" fmt) | ||
| 7548 | (setq numbers (equal (match-string 0 fmt) "N") | ||
| 7549 | fmt (replace-match "" t t fmt))) | ||
| 7550 | (if (string-match "E" fmt) | ||
| 7551 | (setq keep-empty t | ||
| 7552 | fmt (replace-match "" t t fmt))) | ||
| 7553 | (while (string-match "[DRFS]" fmt) | ||
| 7554 | (setq modes (org-set-calc-mode (match-string 0 fmt))) | ||
| 7555 | (setq fmt (replace-match "" t t fmt))) | ||
| 7556 | (unless (string-match "\\S-" fmt) | ||
| 7557 | (setq fmt nil)))) | ||
| 7558 | (if (and (not suppress-const) org-table-formula-use-constants) | ||
| 7559 | (setq formula (org-table-formula-substitute-names formula))) | ||
| 7560 | (setq orig (or (get-text-property 1 :orig-formula formula) "?")) | ||
| 7561 | (while (> ndown 0) | ||
| 7562 | (setq fields (org-split-string | ||
| 7563 | (org-no-properties | ||
| 7564 | (buffer-substring (point-at-bol) (point-at-eol))) | ||
| 7565 | " *| *")) | ||
| 7566 | (if numbers | ||
| 7567 | (setq fields (mapcar | ||
| 7568 | (lambda (x) (number-to-string (string-to-number x))) | ||
| 7569 | fields))) | ||
| 7570 | (setq ndown (1- ndown)) | ||
| 7571 | (setq form (copy-sequence formula) | ||
| 7572 | lispp (and (> (length form) 2)(equal (substring form 0 2) "'("))) | ||
| 7573 | ;; Check for old vertical references | ||
| 7574 | (setq form (org-rewrite-old-row-references form)) | ||
| 7575 | ;; Insert complex ranges | ||
| 7576 | (while (string-match org-table-range-regexp form) | ||
| 7577 | (setq form | ||
| 7578 | (replace-match | ||
| 7579 | (save-match-data | ||
| 7580 | (org-table-make-reference | ||
| 7581 | (org-table-get-range (match-string 0 form) nil n0) | ||
| 7582 | keep-empty numbers lispp)) | ||
| 7583 | t t form))) | ||
| 7584 | ;; Insert simple ranges | ||
| 7585 | (while (string-match "\\$\\([0-9]+\\)\\.\\.\\$\\([0-9]+\\)" form) | ||
| 7586 | (setq form | ||
| 7587 | (replace-match | ||
| 7588 | (save-match-data | ||
| 7589 | (org-table-make-reference | ||
| 7590 | (org-sublist | ||
| 7591 | fields (string-to-number (match-string 1 form)) | ||
| 7592 | (string-to-number (match-string 2 form))) | ||
| 7593 | keep-empty numbers lispp)) | ||
| 7594 | t t form))) | ||
| 7595 | (setq form0 form) | ||
| 7596 | ;; Insert the references to fields in same row | ||
| 7597 | (while (string-match "\\$\\([0-9]+\\)?" form) | ||
| 7598 | (setq n (if (match-beginning 1) | ||
| 7599 | (string-to-number (match-string 1 form)) | ||
| 7600 | n0) | ||
| 7601 | x (nth (1- n) fields)) | ||
| 7602 | (unless x (error "Invalid field specifier \"%s\"" | ||
| 7603 | (match-string 0 form))) | ||
| 7604 | (setq form (replace-match | ||
| 7605 | (save-match-data | ||
| 7606 | (org-table-make-reference x nil numbers lispp)) | ||
| 7607 | t t form))) | ||
| 7608 | (if lispp | ||
| 7609 | (setq ev (condition-case nil | ||
| 7610 | (eval (eval (read form))) | ||
| 7611 | (error "#ERROR")) | ||
| 7612 | ev (if (numberp ev) (number-to-string ev) ev)) | ||
| 7613 | (or (fboundp 'calc-eval) | ||
| 7614 | (error "Calc does not seem to be installed, and is needed to evaluate the formula")) | ||
| 7615 | (setq ev (calc-eval (cons form modes) | ||
| 7616 | (if numbers 'num)))) | ||
| 7617 | |||
| 7618 | (when org-table-formula-debug | ||
| 7619 | (with-output-to-temp-buffer "*Substitution History*" | ||
| 7620 | (princ (format "Substitution history of formula | ||
| 7621 | Orig: %s | ||
| 7622 | $xyz-> %s | ||
| 7623 | @r$c-> %s | ||
| 7624 | $1-> %s\n" orig formula form0 form)) | ||
| 7625 | (if (listp ev) | ||
| 7626 | (princ (format " %s^\nError: %s" | ||
| 7627 | (make-string (car ev) ?\-) (nth 1 ev))) | ||
| 7628 | (princ (format "Result: %s\nFormat: %s\nFinal: %s" | ||
| 7629 | ev (or fmt "NONE") | ||
| 7630 | (if fmt (format fmt (string-to-number ev)) ev))))) | ||
| 7631 | (setq bw (get-buffer-window "*Substitution History*")) | ||
| 7632 | (shrink-window-if-larger-than-buffer bw) | ||
| 7633 | (unless (and (interactive-p) (not ndown)) | ||
| 7634 | (unless (let (inhibit-redisplay) | ||
| 7635 | (y-or-n-p "Debugging Formula. Continue to next? ")) | ||
| 7636 | (org-table-align) | ||
| 7637 | (error "Abort")) | ||
| 7638 | (delete-window bw) | ||
| 7639 | (message ""))) | ||
| 7640 | (if (listp ev) (setq fmt nil ev "#ERROR")) | ||
| 7641 | (org-table-justify-field-maybe | ||
| 7642 | (if fmt (format fmt (string-to-number ev)) ev)) | ||
| 7643 | (if (and down (> ndown 0) (looking-at ".*\n[ \t]*|[^-]")) | ||
| 7644 | (call-interactively 'org-return) | ||
| 7645 | (setq ndown 0))) | ||
| 7646 | (and down (org-table-maybe-recalculate-line)) | ||
| 7647 | (or suppress-align (and org-table-may-need-update | ||
| 7648 | (org-table-align)))))) | ||
| 7649 | |||
| 7650 | (defun org-table-get-range (desc &optional tbeg col highlight) | ||
| 7651 | "Get a calc vector from a column, accorting to descriptor DESC. | ||
| 7652 | Optional arguments TBEG and COL can give the beginning of the table and | ||
| 7653 | the current column, to avoid unnecessary parsing. | ||
| 7654 | HIGHLIGHT means, just highlight the range." | ||
| 7655 | (if (not (equal (string-to-char desc) ?@)) | ||
| 7656 | (setq desc (concat "@" desc))) | ||
| 7657 | (save-excursion | ||
| 7658 | (or tbeg (setq tbeg (org-table-begin))) | ||
| 7659 | (or col (setq col (org-table-current-column))) | ||
| 7660 | (let ((thisline (org-current-line)) | ||
| 7661 | beg end c1 c2 r1 r2 rangep tmp) | ||
| 7662 | (unless (string-match org-table-range-regexp desc) | ||
| 7663 | (error "Invalid table range specifier `%s'" desc)) | ||
| 7664 | (setq rangep (match-end 3) | ||
| 7665 | r1 (and (match-end 1) (match-string 1 desc)) | ||
| 7666 | r2 (and (match-end 4) (match-string 4 desc)) | ||
| 7667 | c1 (and (match-end 2) (substring (match-string 2 desc) 1)) | ||
| 7668 | c2 (and (match-end 5) (substring (match-string 5 desc) 1))) | ||
| 7669 | |||
| 7670 | (and c1 (setq c1 (+ (string-to-number c1) | ||
| 7671 | (if (memq (string-to-char c1) '(?- ?+)) col 0)))) | ||
| 7672 | (and c2 (setq c2 (+ (string-to-number c2) | ||
| 7673 | (if (memq (string-to-char c2) '(?- ?+)) col 0)))) | ||
| 7674 | (if (equal r1 "") (setq r1 nil)) | ||
| 7675 | (if (equal r2 "") (setq r2 nil)) | ||
| 7676 | (if r1 (setq r1 (org-table-get-descriptor-line r1))) | ||
| 7677 | (if r2 (setq r2 (org-table-get-descriptor-line r2))) | ||
| 7678 | ; (setq r2 (or r2 r1) c2 (or c2 c1)) | ||
| 7679 | (if (not r1) (setq r1 thisline)) | ||
| 7680 | (if (not r2) (setq r2 thisline)) | ||
| 7681 | (if (not c1) (setq c1 col)) | ||
| 7682 | (if (not c2) (setq c2 col)) | ||
| 7683 | (if (or (not rangep) (and (= r1 r2) (= c1 c2))) | ||
| 7684 | ;; just one field | ||
| 7685 | (progn | ||
| 7686 | (goto-line r1) | ||
| 7687 | (while (not (looking-at org-table-dataline-regexp)) | ||
| 7688 | (beginning-of-line 2)) | ||
| 7689 | (prog1 (org-table-get-field c1) | ||
| 7690 | (if highlight (org-table-highlight-rectangle (point) (point))))) | ||
| 7691 | ;; A range, return a vector | ||
| 7692 | ;; First sort the numbers to get a regular ractangle | ||
| 7693 | (if (< r2 r1) (setq tmp r1 r1 r2 r2 tmp)) | ||
| 7694 | (if (< c2 c1) (setq tmp c1 c1 c2 c2 tmp)) | ||
| 7695 | (goto-line r1) | ||
| 7696 | (while (not (looking-at org-table-dataline-regexp)) | ||
| 7697 | (beginning-of-line 2)) | ||
| 7698 | (org-table-goto-column c1) | ||
| 7699 | (setq beg (point)) | ||
| 7700 | (goto-line r2) | ||
| 7701 | (while (not (looking-at org-table-dataline-regexp)) | ||
| 7702 | (beginning-of-line 0)) | ||
| 7703 | (org-table-goto-column c2) | ||
| 7704 | (setq end (point)) | ||
| 7705 | (if highlight | ||
| 7706 | (org-table-highlight-rectangle | ||
| 7707 | beg (progn (skip-chars-forward "^|\n") (point)))) | ||
| 7708 | ;; return string representation of calc vector | ||
| 7709 | (apply 'append (org-table-copy-region beg end)))))) | ||
| 7710 | |||
| 7711 | (defun org-table-get-descriptor-line (desc &optional cline bline table) | ||
| 7712 | "Analyze descriptor DESC and retrieve the corresponding line number. | ||
| 7713 | The cursor is currently in line CLINE, the table begins in line BLINE, | ||
| 7714 | and TABLE is a vector with line types." | ||
| 7715 | (if (string-match "^[0-9]+$" desc) | ||
| 7716 | (aref org-table-dlines (string-to-number desc)) | ||
| 7717 | (setq cline (or cline (org-current-line)) | ||
| 7718 | bline (or bline org-table-current-begin-line) | ||
| 7719 | table (or table org-table-current-line-types)) | ||
| 7720 | (if (or | ||
| 7721 | (not (string-match "^\\(\\([-+]\\)?\\(I+\\)\\)?\\(\\([-+]\\)?\\([0-9]+\\)\\)?" desc)) | ||
| 7722 | ;; 1 2 3 4 5 6 | ||
| 7723 | (and (not (match-end 3)) (not (match-end 6))) | ||
| 7724 | (and (match-end 3) (match-end 6) (not (match-end 5)))) | ||
| 7725 | (error "invalid row descriptor `%s'" desc)) | ||
| 7726 | (let* ((hdir (and (match-end 2) (match-string 2 desc))) | ||
| 7727 | (hn (if (match-end 3) (- (match-end 3) (match-beginning 3)) nil)) | ||
| 7728 | (odir (and (match-end 5) (match-string 5 desc))) | ||
| 7729 | (on (if (match-end 6) (string-to-number (match-string 6 desc)))) | ||
| 7730 | (i (- cline bline)) | ||
| 7731 | (rel (and (match-end 6) | ||
| 7732 | (or (and (match-end 1) (not (match-end 3))) | ||
| 7733 | (match-end 5))))) | ||
| 7734 | (if (and hn (not hdir)) | ||
| 7735 | (progn | ||
| 7736 | (setq i 0 hdir "+") | ||
| 7737 | (if (eq (aref table 0) 'hline) (setq hn (1- hn))))) | ||
| 7738 | (if (and (not hn) on (not odir)) | ||
| 7739 | (error "should never happen");;(aref org-table-dlines on) FIXME | ||
| 7740 | (if (and hn (> hn 0)) | ||
| 7741 | (setq i (org-find-row-type table i 'hline (equal hdir "-") nil hn))) | ||
| 7742 | (if on | ||
| 7743 | (setq i (org-find-row-type table i 'dline (equal odir "-") rel on))) | ||
| 7744 | (+ bline i))))) | ||
| 7745 | |||
| 7746 | (defun org-find-row-type (table i type backwards relative n) | ||
| 7747 | (let ((l (length table))) | ||
| 7748 | (while (> n 0) | ||
| 7749 | (while (and (setq i (+ i (if backwards -1 1))) | ||
| 7750 | (>= i 0) (< i l) | ||
| 7751 | (not (eq (aref table i) type)) | ||
| 7752 | (if (and relative (eq (aref table i) 'hline)) | ||
| 7753 | (progn (setq i (- i (if backwards -1 1)) n 1) nil) | ||
| 7754 | t))) | ||
| 7755 | (setq n (1- n))) | ||
| 7756 | (if (or (< i 0) (>= i l)) | ||
| 7757 | (error "Row descriptior leads outside table") | ||
| 7758 | i))) | ||
| 7759 | |||
| 7760 | (defun org-rewrite-old-row-references (s) | ||
| 7761 | (if (string-match "&[-+0-9I]" s) | ||
| 7762 | (error "Formula contains old &row reference, please rewrite using @-syntax") | ||
| 7763 | s)) | ||
| 7764 | |||
| 7765 | (defun org-table-make-reference (elements keep-empty numbers lispp) | ||
| 7766 | "Convert list ELEMENTS to something appropriate to insert into formula. | ||
| 7767 | KEEP-EMPTY indicated to keep empty fields, default is to skip them. | ||
| 7768 | NUMBERS indicates that everything should be converted to numbers. | ||
| 7769 | LISPP means to return something appropriate for a Lisp list." | ||
| 7770 | (if (stringp elements) ; just a single val | ||
| 7771 | (if lispp | ||
| 7772 | (prin1-to-string (if numbers (string-to-number elements) elements)) | ||
| 7773 | (if (equal elements "") (setq elements "0")) | ||
| 7774 | (if numbers (number-to-string (string-to-number elements)) elements)) | ||
| 7775 | (unless keep-empty | ||
| 7776 | (setq elements | ||
| 7777 | (delq nil | ||
| 7778 | (mapcar (lambda (x) (if (string-match "\\S-" x) x nil)) | ||
| 7779 | elements)))) | ||
| 7780 | (setq elements (or elements '("0"))) | ||
| 7781 | (if lispp | ||
| 7782 | (mapconcat 'prin1-to-string | ||
| 7783 | (if numbers (mapcar 'string-to-number elements) elements) | ||
| 7784 | " ") | ||
| 7785 | (concat "[" (mapconcat | ||
| 7786 | (lambda (x) | ||
| 7787 | (if numbers (number-to-string (string-to-number x)) x)) | ||
| 7788 | elements | ||
| 7789 | ",") "]")))) | ||
| 7790 | |||
| 7791 | (defun org-table-recalculate (&optional all noalign) | ||
| 7792 | "Recalculate the current table line by applying all stored formulas. | ||
| 7793 | With prefix arg ALL, do this for all lines in the table." | ||
| 7794 | (interactive "P") | ||
| 7795 | (or (memq this-command org-recalc-commands) | ||
| 7796 | (setq org-recalc-commands (cons this-command org-recalc-commands))) | ||
| 7797 | (unless (org-at-table-p) (error "Not at a table")) | ||
| 7798 | (if (equal all '(16)) | ||
| 7799 | (org-table-iterate) | ||
| 7800 | (org-table-get-specials) | ||
| 7801 | (let* ((eqlist (sort (org-table-get-stored-formulas) | ||
| 7802 | (lambda (a b) (string< (car a) (car b))))) | ||
| 7803 | (inhibit-redisplay (not debug-on-error)) | ||
| 7804 | (line-re org-table-dataline-regexp) | ||
| 7805 | (thisline (org-current-line)) | ||
| 7806 | (thiscol (org-table-current-column)) | ||
| 7807 | beg end entry eqlnum eqlname eql (cnt 0) eq a name) | ||
| 7808 | ;; Insert constants in all formulas | ||
| 7809 | (setq eqlist | ||
| 7810 | (mapcar (lambda (x) | ||
| 7811 | (setcdr x (org-table-formula-substitute-names (cdr x))) | ||
| 7812 | x) | ||
| 7813 | eqlist)) | ||
| 7814 | ;; Split the equation list | ||
| 7815 | (while (setq eq (pop eqlist)) | ||
| 7816 | (if (<= (string-to-char (car eq)) ?9) | ||
| 7817 | (push eq eqlnum) | ||
| 7818 | (push eq eqlname))) | ||
| 7819 | (setq eqlnum (nreverse eqlnum) eqlname (nreverse eqlname)) | ||
| 7820 | (if all | ||
| 7821 | (progn | ||
| 7822 | (setq end (move-marker (make-marker) (1+ (org-table-end)))) | ||
| 7823 | (goto-char (setq beg (org-table-begin))) | ||
| 7824 | (if (re-search-forward org-table-calculate-mark-regexp end t) | ||
| 7825 | ;; This is a table with marked lines, compute selected lines | ||
| 7826 | (setq line-re org-table-recalculate-regexp) | ||
| 7827 | ;; Move forward to the first non-header line | ||
| 7828 | (if (and (re-search-forward org-table-dataline-regexp end t) | ||
| 7829 | (re-search-forward org-table-hline-regexp end t) | ||
| 7830 | (re-search-forward org-table-dataline-regexp end t)) | ||
| 7831 | (setq beg (match-beginning 0)) | ||
| 7832 | nil))) ;; just leave beg where it is | ||
| 7833 | (setq beg (point-at-bol) | ||
| 7834 | end (move-marker (make-marker) (1+ (point-at-eol))))) | ||
| 7835 | (goto-char beg) | ||
| 7836 | (and all (message "Re-applying formulas to full table...")) | ||
| 7837 | (while (re-search-forward line-re end t) | ||
| 7838 | (unless (string-match "^ *[_^!$] *$" (org-table-get-field 1)) | ||
| 7839 | ;; Unprotected line, recalculate | ||
| 7840 | (and all (message "Re-applying formulas to full table...(line %d)" | ||
| 7841 | (setq cnt (1+ cnt)))) | ||
| 7842 | (setq org-last-recalc-line (org-current-line)) | ||
| 7843 | (setq eql eqlnum) | ||
| 7844 | (while (setq entry (pop eql)) | ||
| 7845 | (goto-line org-last-recalc-line) | ||
| 7846 | (org-table-goto-column (string-to-number (car entry)) nil 'force) | ||
| 7847 | (org-table-eval-formula nil (cdr entry) | ||
| 7848 | 'noalign 'nocst 'nostore 'noanalysis)))) | ||
| 7849 | (goto-line thisline) | ||
| 7850 | (org-table-goto-column thiscol) | ||
| 7851 | (or noalign (and org-table-may-need-update (org-table-align)) | ||
| 7852 | (and all (message "Re-applying formulas to %d lines...done" cnt))) | ||
| 7853 | ;; Now do the named fields | ||
| 7854 | (while (setq eq (pop eqlname)) | ||
| 7855 | (setq name (car eq) | ||
| 7856 | a (assoc name org-table-named-field-locations)) | ||
| 7857 | (and (not a) | ||
| 7858 | (string-match "@\\([0-9]+\\)\\$\\([0-9]+\\)" name) | ||
| 7859 | (setq a | ||
| 7860 | (list | ||
| 7861 | name | ||
| 7862 | (aref org-table-dlines | ||
| 7863 | (string-to-number (match-string 1 name))) | ||
| 7864 | (string-to-number (match-string 2 name))))) | ||
| 7865 | (when (and a (or all (equal (nth 1 a) thisline))) | ||
| 7866 | (message "Re-applying formula to field: %s" name) | ||
| 7867 | (goto-line (nth 1 a)) | ||
| 7868 | (org-table-goto-column (nth 2 a)) | ||
| 7869 | (org-table-eval-formula nil (cdr eq) 'noalign 'nocst | ||
| 7870 | 'nostore 'noanalysis))) | ||
| 7871 | ;; back to initial position | ||
| 7872 | (message "Re-applying formulas...done") | ||
| 7873 | (goto-line thisline) | ||
| 7874 | (org-table-goto-column thiscol) | ||
| 7875 | (or noalign (and org-table-may-need-update (org-table-align)) | ||
| 7876 | (and all (message "Re-applying formulas...done")))))) | ||
| 7877 | |||
| 7878 | (defun org-table-iterate (&optional arg) | ||
| 7879 | "Recalculate the table until it does not change anymore." | ||
| 7880 | (interactive "P") | ||
| 7881 | (let ((imax (if arg (prefix-numeric-value arg) 10)) | ||
| 7882 | (i 0) | ||
| 7883 | (lasttbl (buffer-substring (org-table-begin) (org-table-end))) | ||
| 7884 | thistbl) | ||
| 7885 | (catch 'exit | ||
| 7886 | (while (< i imax) | ||
| 7887 | (setq i (1+ i)) | ||
| 7888 | (org-table-recalculate 'all) | ||
| 7889 | (setq thistbl (buffer-substring (org-table-begin) (org-table-end))) | ||
| 7890 | (if (not (string= lasttbl thistbl)) | ||
| 7891 | (setq lasttbl thistbl) | ||
| 7892 | (if (> i 1) | ||
| 7893 | (message "Convergence after %d iterations" i) | ||
| 7894 | (message "Table was already stable")) | ||
| 7895 | (throw 'exit t))) | ||
| 7896 | (error "No convergence after %d iterations" i)))) | ||
| 7897 | |||
| 7898 | (defun org-table-formula-substitute-names (f) | ||
| 7899 | "Replace $const with values in string F." | ||
| 7900 | (let ((start 0) a (f1 f)) | ||
| 7901 | ;; First, check for column names | ||
| 7902 | (while (setq start (string-match org-table-column-name-regexp f start)) | ||
| 7903 | (setq start (1+ start)) | ||
| 7904 | (setq a (assoc (match-string 1 f) org-table-column-names)) | ||
| 7905 | (setq f (replace-match (concat "$" (cdr a)) t t f))) | ||
| 7906 | ;; Parameters and constants | ||
| 7907 | (setq start 0) | ||
| 7908 | (while (setq start (string-match "\\$\\([a-zA-Z][a-zA-Z0-9]*\\)" f start)) | ||
| 7909 | (setq start (1+ start)) | ||
| 7910 | (if (setq a (save-match-data | ||
| 7911 | (org-table-get-constant (match-string 1 f)))) | ||
| 7912 | (setq f (replace-match (concat "(" a ")") t t f)))) | ||
| 7913 | (if org-table-formula-debug | ||
| 7914 | (put-text-property 0 (length f) :orig-formula f1 f)) | ||
| 7915 | f)) | ||
| 7916 | |||
| 7917 | (defun org-table-get-constant (const) | ||
| 7918 | "Find the value for a parameter or constant in a formula. | ||
| 7919 | Parameters get priority." | ||
| 7920 | (or (cdr (assoc const org-table-local-parameters)) | ||
| 7921 | (cdr (assoc const org-table-formula-constants)) | ||
| 7922 | (and (fboundp 'constants-get) (constants-get const)) | ||
| 7923 | "#UNDEFINED_NAME")) | ||
| 7924 | |||
| 7925 | (defvar org-edit-formulas-map (make-sparse-keymap)) | ||
| 7926 | (define-key org-edit-formulas-map "\C-c\C-c" 'org-finish-edit-formulas) | ||
| 7927 | (define-key org-edit-formulas-map "\C-c\C-q" 'org-abort-edit-formulas) | ||
| 7928 | (define-key org-edit-formulas-map "\C-c?" 'org-show-reference) | ||
| 7929 | (define-key org-edit-formulas-map [(shift up)] 'org-table-edit-line-up) | ||
| 7930 | (define-key org-edit-formulas-map [(shift down)] 'org-table-edit-line-down) | ||
| 7931 | (define-key org-edit-formulas-map [(shift left)] 'org-table-edit-backward-field) | ||
| 7932 | (define-key org-edit-formulas-map [(shift right)] 'org-table-edit-next-field) | ||
| 7933 | (define-key org-edit-formulas-map [(meta up)] 'org-table-edit-scroll-down) | ||
| 7934 | (define-key org-edit-formulas-map [(meta down)] 'org-table-edit-scroll) | ||
| 7935 | (define-key org-edit-formulas-map [(meta tab)] 'lisp-complete-symbol) | ||
| 7936 | (define-key org-edit-formulas-map "\M-\C-i" 'lisp-complete-symbol) | ||
| 7937 | (define-key org-edit-formulas-map [(tab)] 'org-edit-formula-lisp-indent) | ||
| 7938 | (define-key org-edit-formulas-map "\C-i" 'org-edit-formula-lisp-indent) | ||
| 7939 | |||
| 7940 | (defvar org-pos) | ||
| 7941 | |||
| 7942 | (defun org-table-edit-formulas () | ||
| 7943 | "Edit the formulas of the current table in a separate buffer." | ||
| 7944 | (interactive) | ||
| 7945 | (unless (org-at-table-p) (error "Not at a table")) | ||
| 7946 | (org-table-get-specials) | ||
| 7947 | (let ((eql (org-table-get-stored-formulas)) | ||
| 7948 | (pos (move-marker (make-marker) (point))) | ||
| 7949 | (wc (current-window-configuration)) | ||
| 7950 | entry s) | ||
| 7951 | (switch-to-buffer-other-window "*Edit Formulas*") | ||
| 5105 | (erase-buffer) | 7952 | (erase-buffer) |
| 5106 | (org-agenda-mode)) | 7953 | (fundamental-mode) |
| 5107 | (setq buffer-read-only nil)) | 7954 | (org-set-local 'org-pos pos) |
| 7955 | (org-set-local 'org-window-configuration wc) | ||
| 7956 | (use-local-map org-edit-formulas-map) | ||
| 7957 | (org-add-hook 'post-command-hook 'org-table-edit-formulas-post-command t t) | ||
| 7958 | (setq s "# `C-c C-c' to finish, `C-u C-c C-c' to also apply, `C-c C-q' to abort. | ||
| 7959 | # `TAB' to pretty-print Lisp expressions, `M-TAB' to complete List symbols | ||
| 7960 | # `M-up/down' to scroll table, `S-up/down' to change line for column formulas\n\n") | ||
| 5108 | 7961 | ||
| 5109 | (defun org-finalize-agenda () | 7962 | (put-text-property 0 (length s) 'face 'font-lock-comment-face s) |
| 5110 | "Finishing touch for the agenda buffer, called just before displaying it." | 7963 | (insert s) |
| 5111 | (unless org-agenda-multi | 7964 | (while (setq entry (pop eql)) |
| 5112 | (org-agenda-align-tags) | 7965 | (setq s (concat (if (equal (string-to-char (car entry)) ?@) "" "$") |
| 7966 | (car entry) " = " (cdr entry) "\n")) | ||
| 7967 | (remove-text-properties 0 (length s) '(face nil) s) | ||
| 7968 | (insert s)) | ||
| 7969 | (goto-char (point-min)) | ||
| 7970 | (message "Edit formulas and finish with `C-c C-c'."))) | ||
| 7971 | |||
| 7972 | (defun org-table-edit-formulas-post-command () | ||
| 7973 | (when (not (memq this-command '(lisp-complete-symbol))) | ||
| 7974 | (let ((win (selected-window))) | ||
| 7975 | (save-excursion | ||
| 7976 | (condition-case nil | ||
| 7977 | (org-show-reference) | ||
| 7978 | (error nil)) | ||
| 7979 | (select-window win))))) | ||
| 7980 | |||
| 7981 | (defun org-finish-edit-formulas (&optional arg) | ||
| 7982 | "Parse the buffer for formula definitions and install them. | ||
| 7983 | With prefix ARG, apply the new formulas to the table." | ||
| 7984 | (interactive "P") | ||
| 7985 | (org-table-remove-rectangle-highlight) | ||
| 7986 | (let ((pos org-pos) eql var form) | ||
| 7987 | (setq org-pos nil) | ||
| 7988 | (goto-char (point-min)) | ||
| 7989 | (while (re-search-forward | ||
| 7990 | "^\\(@[0-9]+\\$[0-9]+\\|\\$\\([a-zA-Z0-9]+\\)\\) *= *\\(.*\\(\n[ \t]+.*$\\)*\\)" | ||
| 7991 | nil t) | ||
| 7992 | (setq var (if (match-end 2) (match-string 2) (match-string 1)) | ||
| 7993 | form (match-string 3)) | ||
| 7994 | (setq form (org-trim form)) | ||
| 7995 | (while (string-match "[ \t]*\n[ \t]*" form) | ||
| 7996 | (setq form (replace-match " " t t form))) | ||
| 7997 | (push (cons var form) eql)) | ||
| 7998 | (set-window-configuration org-window-configuration) | ||
| 7999 | (select-window (get-buffer-window (marker-buffer pos))) | ||
| 8000 | (goto-char pos) | ||
| 8001 | (unless (org-at-table-p) | ||
| 8002 | (error "Lost table position - cannot install formulae")) | ||
| 8003 | (org-table-store-formulas eql) | ||
| 8004 | (move-marker pos nil) | ||
| 8005 | (kill-buffer "*Edit Formulas*") | ||
| 8006 | (if arg | ||
| 8007 | (org-table-recalculate 'all) | ||
| 8008 | (message "New formulas installed - press C-u C-c C-c to apply.")))) | ||
| 8009 | |||
| 8010 | (defun org-abort-edit-formulas () | ||
| 8011 | "Abort editing formulas, without installing the changes." | ||
| 8012 | (interactive) | ||
| 8013 | (org-table-remove-rectangle-highlight) | ||
| 8014 | (let ((pos org-pos)) | ||
| 8015 | (set-window-configuration org-window-configuration) | ||
| 8016 | (select-window (get-buffer-window (marker-buffer pos))) | ||
| 8017 | (goto-char pos) | ||
| 8018 | (move-marker pos nil) | ||
| 8019 | (message "Formula editing aborted without installing changes"))) | ||
| 8020 | |||
| 8021 | (defun org-edit-formula-lisp-indent () | ||
| 8022 | "Pretty-print and re-indent Lisp expressions in the Formula Editor." | ||
| 8023 | (interactive) | ||
| 8024 | (let ((pos (point)) beg end ind) | ||
| 8025 | (beginning-of-line 1) | ||
| 8026 | (cond | ||
| 8027 | ((looking-at "[ \t]") | ||
| 8028 | (goto-char pos) | ||
| 8029 | (call-interactively 'lisp-indent-line)) | ||
| 8030 | ((looking-at "[$@0-9a-zA-Z]+ *= *[^ \t\n']") (goto-char pos)) | ||
| 8031 | ((not (fboundp 'pp-buffer)) | ||
| 8032 | (error "Cannot pretty-print. Command `pp-buffer' is not available.")) | ||
| 8033 | ((looking-at "[$@0-9a-zA-Z]+ *= *'(") | ||
| 8034 | (goto-char (- (match-end 0) 2)) | ||
| 8035 | (setq beg (point)) | ||
| 8036 | (setq ind (make-string (current-column) ?\ )) | ||
| 8037 | (condition-case nil (forward-sexp 1) | ||
| 8038 | (error | ||
| 8039 | (error "Cannot pretty-print Lisp expression: Unbalanced parenthesis"))) | ||
| 8040 | (setq end (point)) | ||
| 8041 | (save-restriction | ||
| 8042 | (narrow-to-region beg end) | ||
| 8043 | (if (eq last-command this-command) | ||
| 8044 | (progn | ||
| 8045 | (goto-char (point-min)) | ||
| 8046 | (setq this-command nil) | ||
| 8047 | (while (re-search-forward "[ \t]*\n[ \t]*" nil t) | ||
| 8048 | (replace-match " "))) | ||
| 8049 | (pp-buffer) | ||
| 8050 | (untabify (point-min) (point-max)) | ||
| 8051 | (goto-char (1+ (point-min))) | ||
| 8052 | (while (re-search-forward "^." nil t) | ||
| 8053 | (beginning-of-line 1) | ||
| 8054 | (insert ind)) | ||
| 8055 | (goto-char (point-max)) | ||
| 8056 | (backward-delete-char 1))) | ||
| 8057 | (goto-char beg)) | ||
| 8058 | (t nil)))) | ||
| 8059 | |||
| 8060 | (defvar org-show-positions nil) | ||
| 8061 | |||
| 8062 | (defun org-show-reference (&optional local) | ||
| 8063 | "Show the location/value of the $ expression at point." | ||
| 8064 | (interactive) | ||
| 8065 | (org-table-remove-rectangle-highlight) | ||
| 8066 | (catch 'exit | ||
| 8067 | (let ((pos (if local (point) org-pos)) | ||
| 8068 | (face2 'highlight) | ||
| 8069 | (org-inhibit-highlight-removal t) | ||
| 8070 | (win (selected-window)) | ||
| 8071 | (org-show-positions nil) | ||
| 8072 | var name e what match dest) | ||
| 8073 | (if local (org-table-get-specials)) | ||
| 8074 | (setq what (cond | ||
| 8075 | ((org-at-regexp-p org-table-range-regexp2) 'range) | ||
| 8076 | ((org-at-regexp-p "\\$[a-zA-Z][a-zA-Z0-9]*") 'name) | ||
| 8077 | ((org-at-regexp-p "\\$[0-9]+") 'column) | ||
| 8078 | ((not local) nil) | ||
| 8079 | (t (error "No reference at point"))) | ||
| 8080 | match (and what (match-string 0))) | ||
| 8081 | (when (and match (not (equal (match-beginning 0) (point-at-bol)))) | ||
| 8082 | (org-table-add-rectangle-overlay (match-beginning 0) (match-end 0) | ||
| 8083 | 'secondary-selection)) | ||
| 8084 | (org-add-hook 'before-change-functions | ||
| 8085 | 'org-table-remove-rectangle-highlight) | ||
| 8086 | (if (eq what 'name) (setq var (substring match 1))) | ||
| 8087 | (when (eq what 'range) | ||
| 8088 | (or (equal (string-to-char match) ?@) (setq match (concat "@" match))) | ||
| 8089 | (setq match (org-table-formula-substitute-names match))) | ||
| 8090 | (unless local | ||
| 8091 | (save-excursion | ||
| 8092 | (beginning-of-line 1) | ||
| 8093 | (when (looking-at "\\(\\$[0-9a-zA-Z]+\\|@[0-9]+\\$[0-9]+\\)=") | ||
| 8094 | (setq dest (match-string 1)) | ||
| 8095 | (org-table-add-rectangle-overlay | ||
| 8096 | (match-beginning 1) (match-end 1) face2)))) | ||
| 8097 | (if (and (markerp pos) (marker-buffer pos)) | ||
| 8098 | (if (get-buffer-window (marker-buffer pos)) | ||
| 8099 | (select-window (get-buffer-window (marker-buffer pos))) | ||
| 8100 | (switch-to-buffer-other-window (get-buffer-window | ||
| 8101 | (marker-buffer pos))))) | ||
| 8102 | (goto-char pos) | ||
| 8103 | (org-table-force-dataline) | ||
| 8104 | (when dest | ||
| 8105 | (setq name (substring dest 1)) | ||
| 8106 | (cond | ||
| 8107 | ((string-match "^\\$[a-zA-Z][a-zA-Z0-9]*" dest) | ||
| 8108 | (setq e (assoc name org-table-named-field-locations)) | ||
| 8109 | (goto-line (nth 1 e)) | ||
| 8110 | (org-table-goto-column (nth 2 e))) | ||
| 8111 | ((string-match "^@\\([0-9]+\\)\\$\\([0-9]+\\)" dest) | ||
| 8112 | (let ((l (string-to-number (match-string 1 dest))) | ||
| 8113 | (c (string-to-number (match-string 2 dest)))) | ||
| 8114 | (goto-line (aref org-table-dlines l)) | ||
| 8115 | (org-table-goto-column c))) | ||
| 8116 | (t (org-table-goto-column (string-to-number name)))) | ||
| 8117 | (move-marker pos (point)) | ||
| 8118 | (org-table-highlight-rectangle nil nil face2)) | ||
| 8119 | (cond | ||
| 8120 | ((equal dest match)) | ||
| 8121 | ((not match)) | ||
| 8122 | ((eq what 'range) | ||
| 8123 | (condition-case nil | ||
| 8124 | (save-excursion | ||
| 8125 | (org-table-get-range match nil nil 'highlight)) | ||
| 8126 | (error nil))) | ||
| 8127 | ((setq e (assoc var org-table-named-field-locations)) | ||
| 8128 | (goto-line (nth 1 e)) | ||
| 8129 | (org-table-goto-column (nth 2 e)) | ||
| 8130 | (org-table-highlight-rectangle (point) (point)) | ||
| 8131 | (message "Named field, column %d of line %d" (nth 2 e) (nth 1 e))) | ||
| 8132 | ((setq e (assoc var org-table-column-names)) | ||
| 8133 | (org-table-goto-column (string-to-number (cdr e))) | ||
| 8134 | (org-table-highlight-rectangle (point) (point)) | ||
| 8135 | (goto-char (org-table-begin)) | ||
| 8136 | (if (re-search-forward (concat "^[ \t]*| *! *.*?| *\\(" var "\\) *|") | ||
| 8137 | (org-table-end) t) | ||
| 8138 | (progn | ||
| 8139 | (goto-char (match-beginning 1)) | ||
| 8140 | (org-table-highlight-rectangle) | ||
| 8141 | (message "Named column (column %s)" (cdr e))) | ||
| 8142 | (error "Column name not found"))) | ||
| 8143 | ((eq what 'column) | ||
| 8144 | ;; column number | ||
| 8145 | (org-table-goto-column (string-to-number (substring match 1))) | ||
| 8146 | (org-table-highlight-rectangle (point) (point)) | ||
| 8147 | (message "Column %s" (substring match 1))) | ||
| 8148 | ((setq e (assoc var org-table-local-parameters)) | ||
| 8149 | (goto-char (org-table-begin)) | ||
| 8150 | (if (re-search-forward (concat "^[ \t]*| *\\$ *.*?| *\\(" var "=\\)") nil t) | ||
| 8151 | (progn | ||
| 8152 | (goto-char (match-beginning 1)) | ||
| 8153 | (org-table-highlight-rectangle) | ||
| 8154 | (message "Local parameter.")) | ||
| 8155 | (error "Parameter not found"))) | ||
| 8156 | (t | ||
| 8157 | (cond | ||
| 8158 | ((not var) (error "No reference at point")) | ||
| 8159 | ((setq e (assoc var org-table-formula-constants)) | ||
| 8160 | (message "Constant: $%s=%s in `org-table-formula-constants'." | ||
| 8161 | var (cdr e))) | ||
| 8162 | ((setq e (and (fboundp 'constants-get) (constants-get var))) | ||
| 8163 | (message "Constant: $%s=%s, retrieved from `constants.el'." var e)) | ||
| 8164 | (t (error "Undefined name $%s" var))))) | ||
| 8165 | (goto-char pos) | ||
| 8166 | (when org-show-positions | ||
| 8167 | (push pos org-show-positions) | ||
| 8168 | (let ((min (apply 'min org-show-positions)) | ||
| 8169 | (max (apply 'max org-show-positions))) | ||
| 8170 | (when (or (not (pos-visible-in-window-p min)) | ||
| 8171 | (not (pos-visible-in-window-p max))) | ||
| 8172 | (goto-char min) | ||
| 8173 | (set-window-start (selected-window) (point-at-bol)) | ||
| 8174 | (goto-char pos)))) | ||
| 8175 | (select-window win)))) | ||
| 8176 | |||
| 8177 | (defun org-table-force-dataline () | ||
| 8178 | "Make sure the cursor is in a dataline in a table." | ||
| 8179 | (unless (save-excursion | ||
| 8180 | (beginning-of-line 1) | ||
| 8181 | (looking-at org-table-dataline-regexp)) | ||
| 8182 | (let* ((re org-table-dataline-regexp) | ||
| 8183 | (p1 (save-excursion (re-search-forward re nil 'move))) | ||
| 8184 | (p2 (save-excursion (re-search-backward re nil 'move)))) | ||
| 8185 | (cond ((and p1 p2) | ||
| 8186 | (goto-char (if (< (abs (- p1 (point))) (abs (- p2 (point)))) | ||
| 8187 | p1 p2))) | ||
| 8188 | ((or p1 p2) (goto-char (or p1 p2))) | ||
| 8189 | (t (error "No table dataline around here")))))) | ||
| 8190 | |||
| 8191 | (defun org-table-edit-line-up () | ||
| 8192 | "Move cursor one line up in the window showing the table." | ||
| 8193 | (interactive) | ||
| 8194 | (org-table-edit-move 'previous-line)) | ||
| 8195 | |||
| 8196 | (defun org-table-edit-line-down () | ||
| 8197 | "Move cursor one line down in the window showing the table." | ||
| 8198 | (interactive) | ||
| 8199 | (org-table-edit-move 'next-line)) | ||
| 8200 | |||
| 8201 | (defun org-table-edit-backward-field () | ||
| 8202 | "Move cursor one field backward in the window showing the table." | ||
| 8203 | (interactive) | ||
| 8204 | (org-table-edit-move 'org-table-previous-field)) | ||
| 8205 | |||
| 8206 | (defun org-table-edit-next-field () | ||
| 8207 | "Move cursor one field forward in the window showing the table." | ||
| 8208 | (interactive) | ||
| 8209 | (org-table-edit-move 'org-table-next-field)) | ||
| 8210 | |||
| 8211 | (defun org-table-edit-move (command) | ||
| 8212 | "Move the cursor in the window shoinw the table. | ||
| 8213 | Use COMMAND to do the motion, repeat if necessary to end up in a data line." | ||
| 8214 | (let ((org-table-allow-automatic-line-recalculation nil) | ||
| 8215 | (pos org-pos) (win (selected-window)) p) | ||
| 8216 | (select-window (get-buffer-window (marker-buffer org-pos))) | ||
| 8217 | (setq p (point)) | ||
| 8218 | (call-interactively command) | ||
| 8219 | (while (and (org-at-table-p) | ||
| 8220 | (org-at-table-hline-p)) | ||
| 8221 | (call-interactively command)) | ||
| 8222 | (or (org-at-table-p) (goto-char p)) | ||
| 8223 | (move-marker pos (point)) | ||
| 8224 | (select-window win))) | ||
| 8225 | |||
| 8226 | (defun org-table-edit-scroll (N) | ||
| 8227 | (interactive "p") | ||
| 8228 | (let ((other-window-scroll-buffer (marker-buffer org-pos))) | ||
| 8229 | (scroll-other-window N))) | ||
| 8230 | |||
| 8231 | (defun org-table-edit-scroll-down (N) | ||
| 8232 | (interactive "p") | ||
| 8233 | (org-table-edit-scroll (- N))) | ||
| 8234 | |||
| 8235 | (defvar org-table-rectangle-overlays nil) | ||
| 8236 | |||
| 8237 | (defun org-table-add-rectangle-overlay (beg end &optional face) | ||
| 8238 | "Add a new overlay." | ||
| 8239 | (let ((ov (org-make-overlay beg end))) | ||
| 8240 | (org-overlay-put ov 'face (or face 'secondary-selection)) | ||
| 8241 | (push ov org-table-rectangle-overlays))) | ||
| 8242 | |||
| 8243 | (defun org-table-highlight-rectangle (&optional beg end face) | ||
| 8244 | "Highlight rectangular region in a table." | ||
| 8245 | (setq beg (or beg (point)) end (or end (point))) | ||
| 8246 | (let ((b (min beg end)) | ||
| 8247 | (e (max beg end)) | ||
| 8248 | l1 c1 l2 c2 tmp) | ||
| 8249 | (and (boundp 'org-show-positions) | ||
| 8250 | (setq org-show-positions (cons b (cons e org-show-positions)))) | ||
| 8251 | (goto-char (min beg end)) | ||
| 8252 | (setq l1 (org-current-line) | ||
| 8253 | c1 (org-table-current-column)) | ||
| 8254 | (goto-char (max beg end)) | ||
| 8255 | (setq l2 (org-current-line) | ||
| 8256 | c2 (org-table-current-column)) | ||
| 8257 | (if (> c1 c2) (setq tmp c1 c1 c2 c2 tmp)) | ||
| 8258 | (goto-line l1) | ||
| 8259 | (beginning-of-line 1) | ||
| 8260 | (loop for line from l1 to l2 do | ||
| 8261 | (when (looking-at org-table-dataline-regexp) | ||
| 8262 | (org-table-goto-column c1) | ||
| 8263 | (skip-chars-backward "^|\n") (setq beg (point)) | ||
| 8264 | (org-table-goto-column c2) | ||
| 8265 | (skip-chars-forward "^|\n") (setq end (point)) | ||
| 8266 | (org-table-add-rectangle-overlay beg end face)) | ||
| 8267 | (beginning-of-line 2)) | ||
| 8268 | (goto-char b)) | ||
| 8269 | (add-hook 'before-change-functions 'org-table-remove-rectangle-highlight)) | ||
| 8270 | |||
| 8271 | (defun org-table-remove-rectangle-highlight (&rest ignore) | ||
| 8272 | "Remove the rectangle overlays." | ||
| 8273 | (unless org-inhibit-highlight-removal | ||
| 8274 | (remove-hook 'before-change-functions 'org-table-remove-rectangle-highlight) | ||
| 8275 | (mapc 'org-delete-overlay org-table-rectangle-overlays) | ||
| 8276 | (setq org-table-rectangle-overlays nil))) | ||
| 8277 | |||
| 8278 | (defvar org-table-coordinate-overlays nil | ||
| 8279 | "Collects the cooordinate grid overlays, so that they can be removed.") | ||
| 8280 | (make-variable-buffer-local 'org-table-coordinate-overlays) | ||
| 8281 | |||
| 8282 | (defun org-table-overlay-coordinates () | ||
| 8283 | "Add overlays to the table at point, to show row/column coordinates." | ||
| 8284 | (interactive) | ||
| 8285 | (mapc 'org-delete-overlay org-table-coordinate-overlays) | ||
| 8286 | (setq org-table-coordinate-overlays nil) | ||
| 8287 | (save-excursion | ||
| 8288 | (let ((id 0) (ih 0) hline eol str ic ov beg) | ||
| 8289 | (goto-char (org-table-begin)) | ||
| 8290 | (while (org-at-table-p) | ||
| 8291 | (setq eol (point-at-eol)) | ||
| 8292 | (setq ov (org-make-overlay (point-at-bol) (1+ (point-at-bol)))) | ||
| 8293 | (push ov org-table-coordinate-overlays) | ||
| 8294 | (setq hline (looking-at org-table-hline-regexp)) | ||
| 8295 | (setq str (if hline (format "I*%-2d" (setq ih (1+ ih))) | ||
| 8296 | (format "%4d" (setq id (1+ id))))) | ||
| 8297 | (org-overlay-before-string ov str 'org-formula 'evaporate) | ||
| 8298 | (when hline | ||
| 8299 | (setq ic 0) | ||
| 8300 | (while (re-search-forward "[+|]-+" eol t) | ||
| 8301 | (setq beg (1+ (match-beginning 0)) | ||
| 8302 | str (concat "$" (int-to-string (setq ic (1+ ic))))) | ||
| 8303 | (setq ov (org-make-overlay beg (+ beg (length str)))) | ||
| 8304 | (push ov org-table-coordinate-overlays) | ||
| 8305 | (org-overlay-display ov str 'org-formula 'evaporate))) | ||
| 8306 | (beginning-of-line 2))))) | ||
| 8307 | |||
| 8308 | (defun org-table-toggle-coordinate-overlays () | ||
| 8309 | "Toggle the display of Row/Column numbers in tables." | ||
| 8310 | (interactive) | ||
| 8311 | (setq org-table-overlay-coordinates (not org-table-overlay-coordinates)) | ||
| 8312 | (message "Row/Column number display turned %s" | ||
| 8313 | (if org-table-overlay-coordinates "on" "off")) | ||
| 8314 | (if (and (org-at-table-p) org-table-overlay-coordinates) | ||
| 8315 | (org-table-align)) | ||
| 8316 | (unless org-table-overlay-coordinates | ||
| 8317 | (mapc 'org-delete-overlay org-table-coordinate-overlays) | ||
| 8318 | (setq org-table-coordinate-overlays nil))) | ||
| 8319 | |||
| 8320 | (defun org-table-toggle-formula-debugger () | ||
| 8321 | "Toggle the formula debugger in tables." | ||
| 8322 | (interactive) | ||
| 8323 | (setq org-table-formula-debug (not org-table-formula-debug)) | ||
| 8324 | (message "Formula debugging has been turned %s" | ||
| 8325 | (if org-table-formula-debug "on" "off"))) | ||
| 8326 | |||
| 8327 | ;;; The orgtbl minor mode | ||
| 8328 | |||
| 8329 | ;; Define a minor mode which can be used in other modes in order to | ||
| 8330 | ;; integrate the org-mode table editor. | ||
| 8331 | |||
| 8332 | ;; This is really a hack, because the org-mode table editor uses several | ||
| 8333 | ;; keys which normally belong to the major mode, for example the TAB and | ||
| 8334 | ;; RET keys. Here is how it works: The minor mode defines all the keys | ||
| 8335 | ;; necessary to operate the table editor, but wraps the commands into a | ||
| 8336 | ;; function which tests if the cursor is currently inside a table. If that | ||
| 8337 | ;; is the case, the table editor command is executed. However, when any of | ||
| 8338 | ;; those keys is used outside a table, the function uses `key-binding' to | ||
| 8339 | ;; look up if the key has an associated command in another currently active | ||
| 8340 | ;; keymap (minor modes, major mode, global), and executes that command. | ||
| 8341 | ;; There might be problems if any of the keys used by the table editor is | ||
| 8342 | ;; otherwise used as a prefix key. | ||
| 8343 | |||
| 8344 | ;; Another challenge is that the key binding for TAB can be tab or \C-i, | ||
| 8345 | ;; likewise the binding for RET can be return or \C-m. Orgtbl-mode | ||
| 8346 | ;; addresses this by checking explicitly for both bindings. | ||
| 8347 | |||
| 8348 | ;; The optimized version (see variable `orgtbl-optimized') takes over | ||
| 8349 | ;; all keys which are bound to `self-insert-command' in the *global map*. | ||
| 8350 | ;; Some modes bind other commands to simple characters, for example | ||
| 8351 | ;; AUCTeX binds the double quote to `Tex-insert-quote'. With orgtbl-mode | ||
| 8352 | ;; active, this binding is ignored inside tables and replaced with a | ||
| 8353 | ;; modified self-insert. | ||
| 8354 | |||
| 8355 | (defvar orgtbl-mode nil | ||
| 8356 | "Variable controlling `orgtbl-mode', a minor mode enabling the `org-mode' | ||
| 8357 | table editor in arbitrary modes.") | ||
| 8358 | (make-variable-buffer-local 'orgtbl-mode) | ||
| 8359 | |||
| 8360 | (defvar orgtbl-mode-map (make-keymap) | ||
| 8361 | "Keymap for `orgtbl-mode'.") | ||
| 8362 | |||
| 8363 | ;;;###autoload | ||
| 8364 | (defun turn-on-orgtbl () | ||
| 8365 | "Unconditionally turn on `orgtbl-mode'." | ||
| 8366 | (orgtbl-mode 1)) | ||
| 8367 | |||
| 8368 | (defvar org-old-auto-fill-inhibit-regexp nil | ||
| 8369 | "Local variable used by `orgtbl-mode'") | ||
| 8370 | |||
| 8371 | (defconst orgtbl-line-start-regexp "[ \t]*\\(|\\|#\\+\\(TBLFM\\|ORGTBL\\):\\)" | ||
| 8372 | "Matches a line belonging to an orgtbl.") | ||
| 8373 | |||
| 8374 | (defconst orgtbl-extra-font-lock-keywords | ||
| 8375 | (list (list (concat "^" orgtbl-line-start-regexp ".*") | ||
| 8376 | 0 (quote 'org-table) 'prepend)) | ||
| 8377 | "Extra font-lock-keywords to be added when orgtbl-mode is active.") | ||
| 8378 | |||
| 8379 | ;;;###autoload | ||
| 8380 | (defun orgtbl-mode (&optional arg) | ||
| 8381 | "The `org-mode' table editor as a minor mode for use in other modes." | ||
| 8382 | (interactive) | ||
| 8383 | (if (org-mode-p) | ||
| 8384 | ;; Exit without error, in case some hook functions calls this | ||
| 8385 | ;; by accident in org-mode. | ||
| 8386 | (message "Orgtbl-mode is not useful in org-mode, command ignored") | ||
| 8387 | (setq orgtbl-mode | ||
| 8388 | (if arg (> (prefix-numeric-value arg) 0) (not orgtbl-mode))) | ||
| 8389 | (if orgtbl-mode | ||
| 8390 | (progn | ||
| 8391 | (and (orgtbl-setup) (defun orgtbl-setup () nil)) | ||
| 8392 | ;; Make sure we are first in minor-mode-map-alist | ||
| 8393 | (let ((c (assq 'orgtbl-mode minor-mode-map-alist))) | ||
| 8394 | (and c (setq minor-mode-map-alist | ||
| 8395 | (cons c (delq c minor-mode-map-alist))))) | ||
| 8396 | (org-set-local (quote org-table-may-need-update) t) | ||
| 8397 | (org-add-hook 'before-change-functions 'org-before-change-function | ||
| 8398 | nil 'local) | ||
| 8399 | (org-set-local 'org-old-auto-fill-inhibit-regexp | ||
| 8400 | auto-fill-inhibit-regexp) | ||
| 8401 | (org-set-local 'auto-fill-inhibit-regexp | ||
| 8402 | (if auto-fill-inhibit-regexp | ||
| 8403 | (concat orgtbl-line-start-regexp "\\|" | ||
| 8404 | auto-fill-inhibit-regexp) | ||
| 8405 | orgtbl-line-start-regexp)) | ||
| 8406 | (org-add-to-invisibility-spec '(org-cwidth)) | ||
| 8407 | (when (fboundp 'font-lock-add-keywords) | ||
| 8408 | (font-lock-add-keywords nil orgtbl-extra-font-lock-keywords) | ||
| 8409 | (org-restart-font-lock)) | ||
| 8410 | (easy-menu-add orgtbl-mode-menu) | ||
| 8411 | (run-hooks 'orgtbl-mode-hook)) | ||
| 8412 | (setq auto-fill-inhibit-regexp org-old-auto-fill-inhibit-regexp) | ||
| 8413 | (org-cleanup-narrow-column-properties) | ||
| 8414 | (org-remove-from-invisibility-spec '(org-cwidth)) | ||
| 8415 | (remove-hook 'before-change-functions 'org-before-change-function t) | ||
| 8416 | (when (fboundp 'font-lock-remove-keywords) | ||
| 8417 | (font-lock-remove-keywords nil orgtbl-extra-font-lock-keywords) | ||
| 8418 | (org-restart-font-lock)) | ||
| 8419 | (easy-menu-remove orgtbl-mode-menu) | ||
| 8420 | (force-mode-line-update 'all)))) | ||
| 8421 | |||
| 8422 | (defun org-cleanup-narrow-column-properties () | ||
| 8423 | "Remove all properties related to narrow-column invisibility." | ||
| 8424 | (let ((s 1)) | ||
| 8425 | (while (setq s (text-property-any s (point-max) | ||
| 8426 | 'display org-narrow-column-arrow)) | ||
| 8427 | (remove-text-properties s (1+ s) '(display t))) | ||
| 8428 | (setq s 1) | ||
| 8429 | (while (setq s (text-property-any s (point-max) 'org-cwidth 1)) | ||
| 8430 | (remove-text-properties s (1+ s) '(org-cwidth t))) | ||
| 8431 | (setq s 1) | ||
| 8432 | (while (setq s (text-property-any s (point-max) 'invisible 'org-cwidth)) | ||
| 8433 | (remove-text-properties s (1+ s) '(invisible t))))) | ||
| 8434 | |||
| 8435 | ;; Install it as a minor mode. | ||
| 8436 | (put 'orgtbl-mode :included t) | ||
| 8437 | (put 'orgtbl-mode :menu-tag "Org Table Mode") | ||
| 8438 | (add-minor-mode 'orgtbl-mode " OrgTbl" orgtbl-mode-map) | ||
| 8439 | |||
| 8440 | (defun orgtbl-make-binding (fun n &rest keys) | ||
| 8441 | "Create a function for binding in the table minor mode. | ||
| 8442 | FUN is the command to call inside a table. N is used to create a unique | ||
| 8443 | command name. KEYS are keys that should be checked in for a command | ||
| 8444 | to execute outside of tables." | ||
| 8445 | (eval | ||
| 8446 | (list 'defun | ||
| 8447 | (intern (concat "orgtbl-hijacker-command-" (int-to-string n))) | ||
| 8448 | '(arg) | ||
| 8449 | (concat "In tables, run `" (symbol-name fun) "'.\n" | ||
| 8450 | "Outside of tables, run the binding of `" | ||
| 8451 | (mapconcat (lambda (x) (format "%s" x)) keys "' or `") | ||
| 8452 | "'.") | ||
| 8453 | '(interactive "p") | ||
| 8454 | (list 'if | ||
| 8455 | '(org-at-table-p) | ||
| 8456 | (list 'call-interactively (list 'quote fun)) | ||
| 8457 | (list 'let '(orgtbl-mode) | ||
| 8458 | (list 'call-interactively | ||
| 8459 | (append '(or) | ||
| 8460 | (mapcar (lambda (k) | ||
| 8461 | (list 'key-binding k)) | ||
| 8462 | keys) | ||
| 8463 | '('orgtbl-error)))))))) | ||
| 8464 | |||
| 8465 | (defun orgtbl-error () | ||
| 8466 | "Error when there is no default binding for a table key." | ||
| 8467 | (interactive) | ||
| 8468 | (error "This key is has no function outside tables")) | ||
| 8469 | |||
| 8470 | (defun orgtbl-setup () | ||
| 8471 | "Setup orgtbl keymaps." | ||
| 8472 | (let ((nfunc 0) | ||
| 8473 | (bindings | ||
| 8474 | (list | ||
| 8475 | '([(meta shift left)] org-table-delete-column) | ||
| 8476 | '([(meta left)] org-table-move-column-left) | ||
| 8477 | '([(meta right)] org-table-move-column-right) | ||
| 8478 | '([(meta shift right)] org-table-insert-column) | ||
| 8479 | '([(meta shift up)] org-table-kill-row) | ||
| 8480 | '([(meta shift down)] org-table-insert-row) | ||
| 8481 | '([(meta up)] org-table-move-row-up) | ||
| 8482 | '([(meta down)] org-table-move-row-down) | ||
| 8483 | '("\C-c\C-w" org-table-cut-region) | ||
| 8484 | '("\C-c\M-w" org-table-copy-region) | ||
| 8485 | '("\C-c\C-y" org-table-paste-rectangle) | ||
| 8486 | '("\C-c-" org-table-insert-hline) | ||
| 8487 | '("\C-c}" org-table-toggle-coordinate-overlays) | ||
| 8488 | '("\C-c{" org-table-toggle-formula-debugger) | ||
| 8489 | '("\C-m" org-table-next-row) | ||
| 8490 | (list (org-key 'S-return) 'org-table-copy-down) | ||
| 8491 | '("\C-c\C-q" org-table-wrap-region) | ||
| 8492 | '("\C-c?" org-table-field-info) | ||
| 8493 | '("\C-c " org-table-blank-field) | ||
| 8494 | '("\C-c+" org-table-sum) | ||
| 8495 | '("\C-c=" org-table-eval-formula) | ||
| 8496 | '("\C-c'" org-table-edit-formulas) | ||
| 8497 | '("\C-c`" org-table-edit-field) | ||
| 8498 | '("\C-c*" org-table-recalculate) | ||
| 8499 | '("\C-c|" org-table-create-or-convert-from-region) | ||
| 8500 | '("\C-c^" org-table-sort-lines) | ||
| 8501 | '([(control ?#)] org-table-rotate-recalc-marks))) | ||
| 8502 | elt key fun cmd) | ||
| 8503 | (while (setq elt (pop bindings)) | ||
| 8504 | (setq nfunc (1+ nfunc)) | ||
| 8505 | (setq key (car elt) | ||
| 8506 | fun (nth 1 elt) | ||
| 8507 | cmd (orgtbl-make-binding fun nfunc key)) | ||
| 8508 | (define-key orgtbl-mode-map key cmd)) | ||
| 8509 | |||
| 8510 | ;; Special treatment needed for TAB and RET | ||
| 8511 | (define-key orgtbl-mode-map [(return)] | ||
| 8512 | (orgtbl-make-binding 'orgtbl-ret 100 [(return)] "\C-m")) | ||
| 8513 | (define-key orgtbl-mode-map "\C-m" | ||
| 8514 | (orgtbl-make-binding 'orgtbl-ret 101 "\C-m" [(return)])) | ||
| 8515 | |||
| 8516 | (define-key orgtbl-mode-map [(tab)] | ||
| 8517 | (orgtbl-make-binding 'orgtbl-tab 102 [(tab)] "\C-i")) | ||
| 8518 | (define-key orgtbl-mode-map "\C-i" | ||
| 8519 | (orgtbl-make-binding 'orgtbl-tab 103 "\C-i" [(tab)])) | ||
| 8520 | |||
| 8521 | (define-key orgtbl-mode-map [(shift tab)] | ||
| 8522 | (orgtbl-make-binding 'org-table-previous-field 104 | ||
| 8523 | [(shift tab)] [(tab)] "\C-i")) | ||
| 8524 | |||
| 8525 | (define-key orgtbl-mode-map "\M-\C-m" | ||
| 8526 | (orgtbl-make-binding 'org-table-wrap-region 105 | ||
| 8527 | "\M-\C-m" [(meta return)])) | ||
| 8528 | (define-key orgtbl-mode-map [(meta return)] | ||
| 8529 | (orgtbl-make-binding 'org-table-wrap-region 106 | ||
| 8530 | [(meta return)] "\M-\C-m")) | ||
| 8531 | |||
| 8532 | (define-key orgtbl-mode-map "\C-c\C-c" 'orgtbl-ctrl-c-ctrl-c) | ||
| 8533 | (when orgtbl-optimized | ||
| 8534 | ;; If the user wants maximum table support, we need to hijack | ||
| 8535 | ;; some standard editing functions | ||
| 8536 | (org-remap orgtbl-mode-map | ||
| 8537 | 'self-insert-command 'orgtbl-self-insert-command | ||
| 8538 | 'delete-char 'org-delete-char | ||
| 8539 | 'delete-backward-char 'org-delete-backward-char) | ||
| 8540 | (define-key orgtbl-mode-map "|" 'org-force-self-insert)) | ||
| 8541 | (easy-menu-define orgtbl-mode-menu orgtbl-mode-map "OrgTbl menu" | ||
| 8542 | '("OrgTbl" | ||
| 8543 | ["Align" org-ctrl-c-ctrl-c :active (org-at-table-p) :keys "C-c C-c"] | ||
| 8544 | ["Next Field" org-cycle :active (org-at-table-p) :keys "TAB"] | ||
| 8545 | ["Previous Field" org-shifttab :active (org-at-table-p) :keys "S-TAB"] | ||
| 8546 | ["Next Row" org-return :active (org-at-table-p) :keys "RET"] | ||
| 8547 | "--" | ||
| 8548 | ["Blank Field" org-table-blank-field :active (org-at-table-p) :keys "C-c SPC"] | ||
| 8549 | ["Edit Field" org-table-edit-field :active (org-at-table-p) :keys "C-c ` "] | ||
| 8550 | ["Copy Field from Above" | ||
| 8551 | org-table-copy-down :active (org-at-table-p) :keys "S-RET"] | ||
| 8552 | "--" | ||
| 8553 | ("Column" | ||
| 8554 | ["Move Column Left" org-metaleft :active (org-at-table-p) :keys "M-<left>"] | ||
| 8555 | ["Move Column Right" org-metaright :active (org-at-table-p) :keys "M-<right>"] | ||
| 8556 | ["Delete Column" org-shiftmetaleft :active (org-at-table-p) :keys "M-S-<left>"] | ||
| 8557 | ["Insert Column" org-shiftmetaright :active (org-at-table-p) :keys "M-S-<right>"]) | ||
| 8558 | ("Row" | ||
| 8559 | ["Move Row Up" org-metaup :active (org-at-table-p) :keys "M-<up>"] | ||
| 8560 | ["Move Row Down" org-metadown :active (org-at-table-p) :keys "M-<down>"] | ||
| 8561 | ["Delete Row" org-shiftmetaup :active (org-at-table-p) :keys "M-S-<up>"] | ||
| 8562 | ["Insert Row" org-shiftmetadown :active (org-at-table-p) :keys "M-S-<down>"] | ||
| 8563 | ["Sort lines in region" org-table-sort-lines (org-at-table-p) :keys "C-c ^"] | ||
| 8564 | "--" | ||
| 8565 | ["Insert Hline" org-table-insert-hline :active (org-at-table-p) :keys "C-c -"]) | ||
| 8566 | ("Rectangle" | ||
| 8567 | ["Copy Rectangle" org-copy-special :active (org-at-table-p)] | ||
| 8568 | ["Cut Rectangle" org-cut-special :active (org-at-table-p)] | ||
| 8569 | ["Paste Rectangle" org-paste-special :active (org-at-table-p)] | ||
| 8570 | ["Fill Rectangle" org-table-wrap-region :active (org-at-table-p)]) | ||
| 8571 | "--" | ||
| 8572 | ("Radio tables" | ||
| 8573 | ["Insert table template" orgtbl-insert-radio-table | ||
| 8574 | (assq major-mode orgtbl-radio-table-templates)] | ||
| 8575 | ["Comment/uncomment table" orgtbl-toggle-comment t]) | ||
| 8576 | "--" | ||
| 8577 | ["Set Column Formula" org-table-eval-formula :active (org-at-table-p) :keys "C-c ="] | ||
| 8578 | ["Set Field Formula" (org-table-eval-formula '(4)) :active (org-at-table-p) :keys "C-u C-c ="] | ||
| 8579 | ["Edit Formulas" org-table-edit-formulas :active (org-at-table-p) :keys "C-c '"] | ||
| 8580 | ["Recalculate line" org-table-recalculate :active (org-at-table-p) :keys "C-c *"] | ||
| 8581 | ["Recalculate all" (org-table-recalculate '(4)) :active (org-at-table-p) :keys "C-u C-c *"] | ||
| 8582 | ["Iterate all" (org-table-recalculate '(16)) :active (org-at-table-p) :keys "C-u C-u C-c *"] | ||
| 8583 | ["Toggle Recalculate Mark" org-table-rotate-recalc-marks :active (org-at-table-p) :keys "C-c #"] | ||
| 8584 | ["Sum Column/Rectangle" org-table-sum | ||
| 8585 | :active (or (org-at-table-p) (org-region-active-p)) :keys "C-c +"] | ||
| 8586 | ["Which Column?" org-table-current-column :active (org-at-table-p) :keys "C-c ?"] | ||
| 8587 | ["Debug Formulas" | ||
| 8588 | org-table-toggle-formula-debugger :active (org-at-table-p) | ||
| 8589 | :keys "C-c {" | ||
| 8590 | :style toggle :selected org-table-formula-debug] | ||
| 8591 | ["Show Col/Row Numbers" | ||
| 8592 | org-table-toggle-coordinate-overlays :active (org-at-table-p) | ||
| 8593 | :keys "C-c }" | ||
| 8594 | :style toggle :selected org-table-overlay-coordinates] | ||
| 8595 | )) | ||
| 8596 | t)) | ||
| 8597 | |||
| 8598 | (defun orgtbl-ctrl-c-ctrl-c (arg) | ||
| 8599 | "If the cursor is inside a table, realign the table. | ||
| 8600 | It it is a table to be sent away to a receiver, do it. | ||
| 8601 | With prefix arg, also recompute table." | ||
| 8602 | (interactive "P") | ||
| 8603 | (let ((pos (point)) action) | ||
| 5113 | (save-excursion | 8604 | (save-excursion |
| 5114 | (let ((buffer-read-only)) | 8605 | (beginning-of-line 1) |
| 8606 | (setq action (cond ((looking-at "#\\+ORGTBL:.*\n[ \t]*|") (match-end 0)) | ||
| 8607 | ((looking-at "[ \t]*|") pos) | ||
| 8608 | ((looking-at "#\\+TBLFM:") 'recalc)))) | ||
| 8609 | (cond | ||
| 8610 | ((integerp action) | ||
| 8611 | (goto-char action) | ||
| 8612 | (org-table-maybe-eval-formula) | ||
| 8613 | (if arg | ||
| 8614 | (call-interactively 'org-table-recalculate) | ||
| 8615 | (org-table-maybe-recalculate-line)) | ||
| 8616 | (call-interactively 'org-table-align) | ||
| 8617 | (orgtbl-send-table 'maybe)) | ||
| 8618 | ((eq action 'recalc) | ||
| 8619 | (save-excursion | ||
| 8620 | (beginning-of-line 1) | ||
| 8621 | (skip-chars-backward " \r\n\t") | ||
| 8622 | (if (org-at-table-p) | ||
| 8623 | (org-call-with-arg 'org-table-recalculate t)))) | ||
| 8624 | (t (let (orgtbl-mode) | ||
| 8625 | (call-interactively (key-binding "\C-c\C-c"))))))) | ||
| 8626 | |||
| 8627 | (defun orgtbl-tab (arg) | ||
| 8628 | "Justification and field motion for `orgtbl-mode'." | ||
| 8629 | (interactive "P") | ||
| 8630 | (if arg (org-table-edit-field t) | ||
| 8631 | (org-table-justify-field-maybe) | ||
| 8632 | (org-table-next-field))) | ||
| 8633 | |||
| 8634 | (defun orgtbl-ret () | ||
| 8635 | "Justification and field motion for `orgtbl-mode'." | ||
| 8636 | (interactive) | ||
| 8637 | (org-table-justify-field-maybe) | ||
| 8638 | (org-table-next-row)) | ||
| 8639 | |||
| 8640 | (defun orgtbl-self-insert-command (N) | ||
| 8641 | "Like `self-insert-command', use overwrite-mode for whitespace in tables. | ||
| 8642 | If the cursor is in a table looking at whitespace, the whitespace is | ||
| 8643 | overwritten, and the table is not marked as requiring realignment." | ||
| 8644 | (interactive "p") | ||
| 8645 | (if (and (org-at-table-p) | ||
| 8646 | (or | ||
| 8647 | (and org-table-auto-blank-field | ||
| 8648 | (member last-command | ||
| 8649 | '(orgtbl-hijacker-command-100 | ||
| 8650 | orgtbl-hijacker-command-101 | ||
| 8651 | orgtbl-hijacker-command-102 | ||
| 8652 | orgtbl-hijacker-command-103 | ||
| 8653 | orgtbl-hijacker-command-104 | ||
| 8654 | orgtbl-hijacker-command-105)) | ||
| 8655 | (org-table-blank-field)) | ||
| 8656 | t) | ||
| 8657 | (eq N 1) | ||
| 8658 | (looking-at "[^|\n]* +|")) | ||
| 8659 | (let (org-table-may-need-update) | ||
| 8660 | (goto-char (1- (match-end 0))) | ||
| 8661 | (delete-backward-char 1) | ||
| 8662 | (goto-char (match-beginning 0)) | ||
| 8663 | (self-insert-command N)) | ||
| 8664 | (setq org-table-may-need-update t) | ||
| 8665 | (let (orgtbl-mode) | ||
| 8666 | (call-interactively (key-binding (vector last-input-event)))))) | ||
| 8667 | |||
| 8668 | (defun org-force-self-insert (N) | ||
| 8669 | "Needed to enforce self-insert under remapping." | ||
| 8670 | (interactive "p") | ||
| 8671 | (self-insert-command N)) | ||
| 8672 | |||
| 8673 | (defvar orgtbl-exp-regexp "^\\([-+]?[0-9][0-9.]*\\)[eE]\\([-+]?[0-9]+\\)$" | ||
| 8674 | "Regula expression matching exponentials as produced by calc.") | ||
| 8675 | |||
| 8676 | (defvar org-table-clean-did-remove-column-1 nil) | ||
| 8677 | |||
| 8678 | (defun orgtbl-send-table (&optional maybe) | ||
| 8679 | "Send a tranformed version of this table to the receiver position. | ||
| 8680 | With argument MAYBE, fail quietly if no transformation is defined for | ||
| 8681 | this table." | ||
| 8682 | (interactive) | ||
| 8683 | (catch 'exit | ||
| 8684 | (unless (org-at-table-p) (error "Not at a table")) | ||
| 8685 | ;; when non-interactive, we assume align has just happened. | ||
| 8686 | (when (interactive-p) (org-table-align)) | ||
| 8687 | (save-excursion | ||
| 8688 | (goto-char (org-table-begin)) | ||
| 8689 | (beginning-of-line 0) | ||
| 8690 | (unless (looking-at "#\\+ORGTBL: *SEND +\\([a-zA-Z0-9_]+\\) +\\([^ \t\r\n]+\\)\\( +.*\\)?") | ||
| 8691 | (if maybe | ||
| 8692 | (throw 'exit nil) | ||
| 8693 | (error "Don't know how to transform this table.")))) | ||
| 8694 | (let* ((name (match-string 1)) | ||
| 8695 | beg | ||
| 8696 | (transform (intern (match-string 2))) | ||
| 8697 | (params (if (match-end 3) (read (concat "(" (match-string 3) ")")))) | ||
| 8698 | (skip (plist-get params :skip)) | ||
| 8699 | (skipcols (plist-get params :skipcols)) | ||
| 8700 | (txt (buffer-substring-no-properties | ||
| 8701 | (org-table-begin) (org-table-end))) | ||
| 8702 | (lines (nthcdr (or skip 0) (org-split-string txt "[ \t]*\n[ \t]*"))) | ||
| 8703 | (lines (org-table-clean-before-export lines)) | ||
| 8704 | (i0 (if org-table-clean-did-remove-column-1 2 1)) | ||
| 8705 | (table (mapcar | ||
| 8706 | (lambda (x) | ||
| 8707 | (if (string-match org-table-hline-regexp x) | ||
| 8708 | 'hline | ||
| 8709 | (org-remove-by-index | ||
| 8710 | (org-split-string (org-trim x) "\\s-*|\\s-*") | ||
| 8711 | skipcols i0))) | ||
| 8712 | lines)) | ||
| 8713 | (fun (if (= i0 2) 'cdr 'identity)) | ||
| 8714 | (org-table-last-alignment | ||
| 8715 | (org-remove-by-index (funcall fun org-table-last-alignment) | ||
| 8716 | skipcols i0)) | ||
| 8717 | (org-table-last-column-widths | ||
| 8718 | (org-remove-by-index (funcall fun org-table-last-column-widths) | ||
| 8719 | skipcols i0))) | ||
| 8720 | |||
| 8721 | (unless (fboundp transform) | ||
| 8722 | (error "No such transformation function %s" transform)) | ||
| 8723 | (setq txt (funcall transform table params)) | ||
| 8724 | ;; Find the insertion place | ||
| 8725 | (save-excursion | ||
| 5115 | (goto-char (point-min)) | 8726 | (goto-char (point-min)) |
| 5116 | (while (org-activate-bracket-links (point-max)) | 8727 | (unless (re-search-forward |
| 5117 | (add-text-properties (match-beginning 0) (match-end 0) | 8728 | (concat "BEGIN RECEIVE ORGTBL +" name "\\([ \t]\\|$\\)") nil t) |
| 5118 | '(face org-link)))) | 8729 | (error "Don't know where to insert translated table")) |
| 5119 | (run-hooks 'org-finalize-agenda-hook)))) | 8730 | (goto-char (match-beginning 0)) |
| 8731 | (beginning-of-line 2) | ||
| 8732 | (setq beg (point)) | ||
| 8733 | (unless (re-search-forward (concat "END RECEIVE ORGTBL +" name) nil t) | ||
| 8734 | (error "Cannot find end of insertion region")) | ||
| 8735 | (beginning-of-line 1) | ||
| 8736 | (delete-region beg (point)) | ||
| 8737 | (goto-char beg) | ||
| 8738 | (insert txt "\n")) | ||
| 8739 | (message "Table converted and installed at receiver location")))) | ||
| 5120 | 8740 | ||
| 5121 | (defun org-prepare-agenda-buffers (files) | 8741 | (defun org-remove-by-index (list indices &optional i0) |
| 5122 | "Create buffers for all agenda files, protect archived trees and comments." | 8742 | "Remove the elements in LIST with indices in INDICES. |
| 8743 | First element has index 0, or I0 if given." | ||
| 8744 | (if (not indices) | ||
| 8745 | list | ||
| 8746 | (if (integerp indices) (setq indices (list indices))) | ||
| 8747 | (setq i0 (1- (or i0 0))) | ||
| 8748 | (delq :rm (mapcar (lambda (x) | ||
| 8749 | (setq i0 (1+ i0)) | ||
| 8750 | (if (memq i0 indices) :rm x)) | ||
| 8751 | list)))) | ||
| 8752 | |||
| 8753 | (defun orgtbl-toggle-comment () | ||
| 8754 | "Comment or uncomment the orgtbl at point." | ||
| 5123 | (interactive) | 8755 | (interactive) |
| 5124 | (let ((pa '(:org-archived t)) | 8756 | (let* ((re1 (concat "^" (regexp-quote comment-start) orgtbl-line-start-regexp)) |
| 5125 | (pc '(:org-comment t)) | 8757 | (re2 (concat "^" orgtbl-line-start-regexp)) |
| 5126 | (pall '(:org-archived t :org-comment t)) | 8758 | (commented (save-excursion (beginning-of-line 1) |
| 5127 | (rea (concat ":" org-archive-tag ":")) | 8759 | (cond ((looking-at re1) t) |
| 5128 | bmp file re) | 8760 | ((looking-at re2) nil) |
| 8761 | (t (error "Not at an org table"))))) | ||
| 8762 | (re (if commented re1 re2)) | ||
| 8763 | beg end) | ||
| 5129 | (save-excursion | 8764 | (save-excursion |
| 5130 | (while (setq file (pop files)) | 8765 | (beginning-of-line 1) |
| 5131 | (org-check-agenda-file file) | 8766 | (while (looking-at re) (beginning-of-line 0)) |
| 5132 | (set-buffer (org-get-agenda-file-buffer file)) | 8767 | (beginning-of-line 2) |
| 5133 | (widen) | 8768 | (setq beg (point)) |
| 5134 | (setq bmp (buffer-modified-p)) | 8769 | (while (looking-at re) (beginning-of-line 2)) |
| 8770 | (setq end (point))) | ||
| 8771 | (comment-region beg end (if commented '(4) nil)))) | ||
| 8772 | |||
| 8773 | (defun orgtbl-insert-radio-table () | ||
| 8774 | "Insert a radio table template appropriate for this major mode." | ||
| 8775 | (interactive) | ||
| 8776 | (let* ((e (assq major-mode orgtbl-radio-table-templates)) | ||
| 8777 | (txt (nth 1 e)) | ||
| 8778 | name pos) | ||
| 8779 | (unless e (error "No radio table setup defined for %s" major-mode)) | ||
| 8780 | (setq name (read-string "Table name: ")) | ||
| 8781 | (while (string-match "%n" txt) | ||
| 8782 | (setq txt (replace-match name t t txt))) | ||
| 8783 | (or (bolp) (insert "\n")) | ||
| 8784 | (setq pos (point)) | ||
| 8785 | (insert txt) | ||
| 8786 | (goto-char pos))) | ||
| 8787 | |||
| 8788 | (defun org-get-param (params header i sym &optional hsym) | ||
| 8789 | "Get parameter value for symbol SYM. | ||
| 8790 | If this is a header line, actually get the value for the symbol with an | ||
| 8791 | additional \"h\" inserted after the colon. | ||
| 8792 | If the value is a protperty list, get the element for the current column. | ||
| 8793 | Assumes variables VAL, PARAMS, HEAD and I to be scoped into the function." | ||
| 8794 | (let ((val (plist-get params sym))) | ||
| 8795 | (and hsym header (setq val (or (plist-get params hsym) val))) | ||
| 8796 | (if (consp val) (plist-get val i) val))) | ||
| 8797 | |||
| 8798 | (defun orgtbl-to-generic (table params) | ||
| 8799 | "Convert the orgtbl-mode TABLE to some other format. | ||
| 8800 | This generic routine can be used for many standard cases. | ||
| 8801 | TABLE is a list, each entry either the symbol `hline' for a horizontal | ||
| 8802 | separator line, or a list of fields for that line. | ||
| 8803 | PARAMS is a property list of parameters that can influence the conversion. | ||
| 8804 | For the generic converter, some parameters are obligatory: You need to | ||
| 8805 | specify either :lfmt, or all of (:lstart :lend :sep). If you do not use | ||
| 8806 | :splice, you must have :tstart and :tend. | ||
| 8807 | |||
| 8808 | Valid parameters are | ||
| 8809 | |||
| 8810 | :tstart String to start the table. Ignored when :splice is t. | ||
| 8811 | :tend String to end the table. Ignored when :splice is t. | ||
| 8812 | |||
| 8813 | :splice When set to t, return only table body lines, don't wrap | ||
| 8814 | them into :tstart and :tend. Default is nil. | ||
| 8815 | |||
| 8816 | :hline String to be inserted on horizontal separation lines. | ||
| 8817 | May be nil to ignore hlines. | ||
| 8818 | |||
| 8819 | :lstart String to start a new table line. | ||
| 8820 | :lend String to end a table line | ||
| 8821 | :sep Separator between two fields | ||
| 8822 | :lfmt Format for entire line, with enough %s to capture all fields. | ||
| 8823 | If this is present, :lstart, :lend, and :sep are ignored. | ||
| 8824 | :fmt A format to be used to wrap the field, should contain | ||
| 8825 | %s for the original field value. For example, to wrap | ||
| 8826 | everything in dollars, you could use :fmt \"$%s$\". | ||
| 8827 | This may also be a property list with column numbers and | ||
| 8828 | formats. for example :fmt (2 \"$%s$\" 4 \"%s%%\") | ||
| 8829 | |||
| 8830 | :hlstart :hlend :hlsep :hlfmt :hfmt | ||
| 8831 | Same as above, specific for the header lines in the table. | ||
| 8832 | All lines before the first hline are treated as header. | ||
| 8833 | If any of these is not present, the data line value is used. | ||
| 8834 | |||
| 8835 | :efmt Use this format to print numbers with exponentials. | ||
| 8836 | The format should have %s twice for inserting mantissa | ||
| 8837 | and exponent, for example \"%s\\\\times10^{%s}\". This | ||
| 8838 | may also be a property list with column numbers and | ||
| 8839 | formats. :fmt will still be applied after :efmt. | ||
| 8840 | |||
| 8841 | In addition to this, the parameters :skip and :skipcols are always handled | ||
| 8842 | directly by `orgtbl-send-table'. See manual." | ||
| 8843 | (interactive) | ||
| 8844 | (let* ((p params) | ||
| 8845 | (splicep (plist-get p :splice)) | ||
| 8846 | (hline (plist-get p :hline)) | ||
| 8847 | rtn line i fm efm lfmt h) | ||
| 8848 | |||
| 8849 | ;; Do we have a header? | ||
| 8850 | (if (and (not splicep) (listp (car table)) (memq 'hline table)) | ||
| 8851 | (setq h t)) | ||
| 8852 | |||
| 8853 | ;; Put header | ||
| 8854 | (unless splicep | ||
| 8855 | (push (or (plist-get p :tstart) "ERROR: no :tstart") rtn)) | ||
| 8856 | |||
| 8857 | ;; Now loop over all lines | ||
| 8858 | (while (setq line (pop table)) | ||
| 8859 | (if (eq line 'hline) | ||
| 8860 | ;; A horizontal separator line | ||
| 8861 | (progn (if hline (push hline rtn)) | ||
| 8862 | (setq h nil)) ; no longer in header | ||
| 8863 | ;; A normal line. Convert the fields, push line onto the result list | ||
| 8864 | (setq i 0) | ||
| 8865 | (setq line | ||
| 8866 | (mapcar | ||
| 8867 | (lambda (f) | ||
| 8868 | (setq i (1+ i) | ||
| 8869 | fm (org-get-param p h i :fmt :hfmt) | ||
| 8870 | efm (org-get-param p h i :efmt)) | ||
| 8871 | (if (and efm (string-match orgtbl-exp-regexp f)) | ||
| 8872 | (setq f (format | ||
| 8873 | efm (match-string 1 f) (match-string 2 f)))) | ||
| 8874 | (if fm (setq f (format fm f))) | ||
| 8875 | f) | ||
| 8876 | line)) | ||
| 8877 | (if (setq lfmt (org-get-param p h i :lfmt :hlfmt)) | ||
| 8878 | (push (apply 'format lfmt line) rtn) | ||
| 8879 | (push (concat | ||
| 8880 | (org-get-param p h i :lstart :hlstart) | ||
| 8881 | (mapconcat 'identity line (org-get-param p h i :sep :hsep)) | ||
| 8882 | (org-get-param p h i :lend :hlend)) | ||
| 8883 | rtn)))) | ||
| 8884 | |||
| 8885 | (unless splicep | ||
| 8886 | (push (or (plist-get p :tend) "ERROR: no :tend") rtn)) | ||
| 8887 | |||
| 8888 | (mapconcat 'identity (nreverse rtn) "\n"))) | ||
| 8889 | |||
| 8890 | (defun orgtbl-to-latex (table params) | ||
| 8891 | "Convert the orgtbl-mode TABLE to LaTeX. | ||
| 8892 | TABLE is a list, each entry either the symbol `hline' for a horizontal | ||
| 8893 | separator line, or a list of fields for that line. | ||
| 8894 | PARAMS is a property list of parameters that can influence the conversion. | ||
| 8895 | Supports all parameters from `orgtbl-to-generic'. Most important for | ||
| 8896 | LaTeX are: | ||
| 8897 | |||
| 8898 | :splice When set to t, return only table body lines, don't wrap | ||
| 8899 | them into a tabular environment. Default is nil. | ||
| 8900 | |||
| 8901 | :fmt A format to be used to wrap the field, should contain %s for the | ||
| 8902 | original field value. For example, to wrap everything in dollars, | ||
| 8903 | use :fmt \"$%s$\". This may also be a property list with column | ||
| 8904 | numbers and formats. for example :fmt (2 \"$%s$\" 4 \"%s%%\") | ||
| 8905 | |||
| 8906 | :efmt Format for transforming numbers with exponentials. The format | ||
| 8907 | should have %s twice for inserting mantissa and exponent, for | ||
| 8908 | example \"%s\\\\times10^{%s}\". LaTeX default is \"%s\\\\,(%s)\". | ||
| 8909 | This may also be a property list with column numbers and formats. | ||
| 8910 | |||
| 8911 | The general parameters :skip and :skipcols have already been applied when | ||
| 8912 | this function is called." | ||
| 8913 | (let* ((alignment (mapconcat (lambda (x) (if x "r" "l")) | ||
| 8914 | org-table-last-alignment "")) | ||
| 8915 | (params2 | ||
| 8916 | (list | ||
| 8917 | :tstart (concat "\\begin{tabular}{" alignment "}") | ||
| 8918 | :tend "\\end{tabular}" | ||
| 8919 | :lstart "" :lend " \\\\" :sep " & " | ||
| 8920 | :efmt "%s\\,(%s)" :hline "\\hline"))) | ||
| 8921 | (orgtbl-to-generic table (org-combine-plists params2 params)))) | ||
| 8922 | |||
| 8923 | (defun orgtbl-to-html (table params) | ||
| 8924 | "Convert the orgtbl-mode TABLE to LaTeX. | ||
| 8925 | TABLE is a list, each entry either the symbol `hline' for a horizontal | ||
| 8926 | separator line, or a list of fields for that line. | ||
| 8927 | PARAMS is a property list of parameters that can influence the conversion. | ||
| 8928 | Currently this function recognizes the following parameters: | ||
| 8929 | |||
| 8930 | :splice When set to t, return only table body lines, don't wrap | ||
| 8931 | them into a <table> environment. Default is nil. | ||
| 8932 | |||
| 8933 | The general parameters :skip and :skipcols have already been applied when | ||
| 8934 | this function is called. The function does *not* use `orgtbl-to-generic', | ||
| 8935 | so you cannot specify parameters for it." | ||
| 8936 | (let* ((splicep (plist-get params :splice)) | ||
| 8937 | html) | ||
| 8938 | ;; Just call the formatter we already have | ||
| 8939 | ;; We need to make text lines for it, so put the fields back together. | ||
| 8940 | (setq html (org-format-org-table-html | ||
| 8941 | (mapcar | ||
| 8942 | (lambda (x) | ||
| 8943 | (if (eq x 'hline) | ||
| 8944 | "|----+----|" | ||
| 8945 | (concat "| " (mapconcat 'identity x " | ") " |"))) | ||
| 8946 | table) | ||
| 8947 | splicep)) | ||
| 8948 | (if (string-match "\n+\\'" html) | ||
| 8949 | (setq html (replace-match "" t t html))) | ||
| 8950 | html)) | ||
| 8951 | |||
| 8952 | (defun orgtbl-to-texinfo (table params) | ||
| 8953 | "Convert the orgtbl-mode TABLE to TeXInfo. | ||
| 8954 | TABLE is a list, each entry either the symbol `hline' for a horizontal | ||
| 8955 | separator line, or a list of fields for that line. | ||
| 8956 | PARAMS is a property list of parameters that can influence the conversion. | ||
| 8957 | Supports all parameters from `orgtbl-to-generic'. Most important for | ||
| 8958 | TeXInfo are: | ||
| 8959 | |||
| 8960 | :splice nil/t When set to t, return only table body lines, don't wrap | ||
| 8961 | them into a multitable environment. Default is nil. | ||
| 8962 | |||
| 8963 | :fmt fmt A format to be used to wrap the field, should contain | ||
| 8964 | %s for the original field value. For example, to wrap | ||
| 8965 | everything in @kbd{}, you could use :fmt \"@kbd{%s}\". | ||
| 8966 | This may also be a property list with column numbers and | ||
| 8967 | formats. for example :fmt (2 \"@kbd{%s}\" 4 \"@code{%s}\"). | ||
| 8968 | |||
| 8969 | :cf \"f1 f2..\" The column fractions for the table. Bye default these | ||
| 8970 | are computed automatically from the width of the columns | ||
| 8971 | under org-mode. | ||
| 8972 | |||
| 8973 | The general parameters :skip and :skipcols have already been applied when | ||
| 8974 | this function is called." | ||
| 8975 | (let* ((total (float (apply '+ org-table-last-column-widths))) | ||
| 8976 | (colfrac (or (plist-get params :cf) | ||
| 8977 | (mapconcat | ||
| 8978 | (lambda (x) (format "%.3f" (/ (float x) total))) | ||
| 8979 | org-table-last-column-widths " "))) | ||
| 8980 | (params2 | ||
| 8981 | (list | ||
| 8982 | :tstart (concat "@multitable @columnfractions " colfrac) | ||
| 8983 | :tend "@end multitable" | ||
| 8984 | :lstart "@item " :lend "" :sep " @tab " | ||
| 8985 | :hlstart "@headitem "))) | ||
| 8986 | (orgtbl-to-generic table (org-combine-plists params2 params)))) | ||
| 8987 | |||
| 8988 | ;;;; Link Stuff | ||
| 8989 | |||
| 8990 | ;;; Link abbreviations | ||
| 8991 | |||
| 8992 | (defun org-link-expand-abbrev (link) | ||
| 8993 | "Apply replacements as defined in `org-link-abbrev-alist." | ||
| 8994 | (if (string-match "^\\([a-zA-Z]+\\)\\(::?\\(.*\\)\\)?$" link) | ||
| 8995 | (let* ((key (match-string 1 link)) | ||
| 8996 | (as (or (assoc key org-link-abbrev-alist-local) | ||
| 8997 | (assoc key org-link-abbrev-alist))) | ||
| 8998 | (tag (and (match-end 2) (match-string 3 link))) | ||
| 8999 | rpl) | ||
| 9000 | (if (not as) | ||
| 9001 | link | ||
| 9002 | (setq rpl (cdr as)) | ||
| 9003 | (cond | ||
| 9004 | ((symbolp rpl) (funcall rpl tag)) | ||
| 9005 | ((string-match "%s" rpl) (replace-match (or tag "") t t rpl)) | ||
| 9006 | (t (concat rpl tag))))) | ||
| 9007 | link)) | ||
| 9008 | |||
| 9009 | ;;; Storing and inserting links | ||
| 9010 | |||
| 9011 | (defvar org-insert-link-history nil | ||
| 9012 | "Minibuffer history for links inserted with `org-insert-link'.") | ||
| 9013 | |||
| 9014 | (defvar org-stored-links nil | ||
| 9015 | "Contains the links stored with `org-store-link'.") | ||
| 9016 | |||
| 9017 | (defvar org-store-link-plist nil | ||
| 9018 | "Plist with info about the most recently link created with `org-store-link'.") | ||
| 9019 | |||
| 9020 | ;;;###autoload | ||
| 9021 | (defun org-store-link (arg) | ||
| 9022 | "\\<org-mode-map>Store an org-link to the current location. | ||
| 9023 | This link can later be inserted into an org-buffer with | ||
| 9024 | \\[org-insert-link]. | ||
| 9025 | For some link types, a prefix arg is interpreted: | ||
| 9026 | For links to usenet articles, arg negates `org-usenet-links-prefer-google'. | ||
| 9027 | For file links, arg negates `org-context-in-file-links'." | ||
| 9028 | (interactive "P") | ||
| 9029 | (setq org-store-link-plist nil) ; reset | ||
| 9030 | (let (link cpltxt desc description search txt) | ||
| 9031 | (cond | ||
| 9032 | |||
| 9033 | ((eq major-mode 'bbdb-mode) | ||
| 9034 | (let ((name (bbdb-record-name (bbdb-current-record))) | ||
| 9035 | (company (bbdb-record-company (bbdb-current-record)))) | ||
| 9036 | (setq cpltxt (concat "bbdb:" (or name company)) | ||
| 9037 | link (org-make-link cpltxt)) | ||
| 9038 | (org-store-link-props :type "bbdb" :name name :company company))) | ||
| 9039 | |||
| 9040 | ((eq major-mode 'Info-mode) | ||
| 9041 | (setq link (org-make-link "info:" | ||
| 9042 | (file-name-nondirectory Info-current-file) | ||
| 9043 | ":" Info-current-node)) | ||
| 9044 | (setq cpltxt (concat (file-name-nondirectory Info-current-file) | ||
| 9045 | ":" Info-current-node)) | ||
| 9046 | (org-store-link-props :type "info" :file Info-current-file | ||
| 9047 | :node Info-current-node)) | ||
| 9048 | |||
| 9049 | ((eq major-mode 'calendar-mode) | ||
| 9050 | (let ((cd (calendar-cursor-to-date))) | ||
| 9051 | (setq link | ||
| 9052 | (format-time-string | ||
| 9053 | (car org-time-stamp-formats) | ||
| 9054 | (apply 'encode-time | ||
| 9055 | (list 0 0 0 (nth 1 cd) (nth 0 cd) (nth 2 cd) | ||
| 9056 | nil nil nil)))) | ||
| 9057 | (org-store-link-props :type "calendar" :date cd))) | ||
| 9058 | |||
| 9059 | ((or (eq major-mode 'vm-summary-mode) | ||
| 9060 | (eq major-mode 'vm-presentation-mode)) | ||
| 9061 | (and (eq major-mode 'vm-presentation-mode) (vm-summarize)) | ||
| 9062 | (vm-follow-summary-cursor) | ||
| 9063 | (save-excursion | ||
| 9064 | (vm-select-folder-buffer) | ||
| 9065 | (let* ((message (car vm-message-pointer)) | ||
| 9066 | (folder buffer-file-name) | ||
| 9067 | (subject (vm-su-subject message)) | ||
| 9068 | (to (vm-get-header-contents message "To")) | ||
| 9069 | (from (vm-get-header-contents message "From")) | ||
| 9070 | (message-id (vm-su-message-id message))) | ||
| 9071 | (org-store-link-props :type "vm" :from from :to to :subject subject | ||
| 9072 | :message-id message-id) | ||
| 9073 | (setq message-id (org-remove-angle-brackets message-id)) | ||
| 9074 | (setq folder (abbreviate-file-name folder)) | ||
| 9075 | (if (string-match (concat "^" (regexp-quote vm-folder-directory)) | ||
| 9076 | folder) | ||
| 9077 | (setq folder (replace-match "" t t folder))) | ||
| 9078 | (setq cpltxt (org-email-link-description)) | ||
| 9079 | (setq link (org-make-link "vm:" folder "#" message-id))))) | ||
| 9080 | |||
| 9081 | ((eq major-mode 'wl-summary-mode) | ||
| 9082 | (let* ((msgnum (wl-summary-message-number)) | ||
| 9083 | (message-id (elmo-message-field wl-summary-buffer-elmo-folder | ||
| 9084 | msgnum 'message-id)) | ||
| 9085 | (wl-message-entity | ||
| 9086 | (if (fboundp 'elmo-message-entity) | ||
| 9087 | (elmo-message-entity | ||
| 9088 | wl-summary-buffer-elmo-folder msgnum) | ||
| 9089 | (elmo-msgdb-overview-get-entity | ||
| 9090 | msgnum (wl-summary-buffer-msgdb)))) | ||
| 9091 | (from (wl-summary-line-from)) | ||
| 9092 | (to (car (elmo-message-entity-field wl-message-entity 'to))) | ||
| 9093 | (subject (let (wl-thr-indent-string wl-parent-message-entity) | ||
| 9094 | (wl-summary-line-subject)))) | ||
| 9095 | (org-store-link-props :type "wl" :from from :to to | ||
| 9096 | :subject subject :message-id message-id) | ||
| 9097 | (setq message-id (org-remove-angle-brackets message-id)) | ||
| 9098 | (setq cpltxt (org-email-link-description)) | ||
| 9099 | (setq link (org-make-link "wl:" wl-summary-buffer-folder-name | ||
| 9100 | "#" message-id)))) | ||
| 9101 | |||
| 9102 | ((or (equal major-mode 'mh-folder-mode) | ||
| 9103 | (equal major-mode 'mh-show-mode)) | ||
| 9104 | (let ((from (org-mhe-get-header "From:")) | ||
| 9105 | (to (org-mhe-get-header "To:")) | ||
| 9106 | (message-id (org-mhe-get-header "Message-Id:")) | ||
| 9107 | (subject (org-mhe-get-header "Subject:"))) | ||
| 9108 | (org-store-link-props :type "mh" :from from :to to | ||
| 9109 | :subject subject :message-id message-id) | ||
| 9110 | (setq cpltxt (org-email-link-description)) | ||
| 9111 | (setq link (org-make-link "mhe:" (org-mhe-get-message-real-folder) "#" | ||
| 9112 | (org-remove-angle-brackets message-id))))) | ||
| 9113 | |||
| 9114 | ((eq major-mode 'rmail-mode) | ||
| 9115 | (save-excursion | ||
| 9116 | (save-restriction | ||
| 9117 | (rmail-narrow-to-non-pruned-header) | ||
| 9118 | (let ((folder buffer-file-name) | ||
| 9119 | (message-id (mail-fetch-field "message-id")) | ||
| 9120 | (from (mail-fetch-field "from")) | ||
| 9121 | (to (mail-fetch-field "to")) | ||
| 9122 | (subject (mail-fetch-field "subject"))) | ||
| 9123 | (org-store-link-props | ||
| 9124 | :type "rmail" :from from :to to | ||
| 9125 | :subject subject :message-id message-id) | ||
| 9126 | (setq message-id (org-remove-angle-brackets message-id)) | ||
| 9127 | (setq cpltxt (org-email-link-description)) | ||
| 9128 | (setq link (org-make-link "rmail:" folder "#" message-id)))))) | ||
| 9129 | |||
| 9130 | ((eq major-mode 'gnus-group-mode) | ||
| 9131 | (let ((group (cond ((fboundp 'gnus-group-group-name) ; depending on Gnus | ||
| 9132 | (gnus-group-group-name)) ; version | ||
| 9133 | ((fboundp 'gnus-group-name) | ||
| 9134 | (gnus-group-name)) | ||
| 9135 | (t "???")))) | ||
| 9136 | (unless group (error "Not on a group")) | ||
| 9137 | (org-store-link-props :type "gnus" :group group) | ||
| 9138 | (setq cpltxt (concat | ||
| 9139 | (if (org-xor arg org-usenet-links-prefer-google) | ||
| 9140 | "http://groups.google.com/groups?group=" | ||
| 9141 | "gnus:") | ||
| 9142 | group) | ||
| 9143 | link (org-make-link cpltxt)))) | ||
| 9144 | |||
| 9145 | ((memq major-mode '(gnus-summary-mode gnus-article-mode)) | ||
| 9146 | (and (eq major-mode 'gnus-article-mode) (gnus-article-show-summary)) | ||
| 9147 | (let* ((group gnus-newsgroup-name) | ||
| 9148 | (article (gnus-summary-article-number)) | ||
| 9149 | (header (gnus-summary-article-header article)) | ||
| 9150 | (from (mail-header-from header)) | ||
| 9151 | (message-id (mail-header-id header)) | ||
| 9152 | (date (mail-header-date header)) | ||
| 9153 | (subject (gnus-summary-subject-string))) | ||
| 9154 | (org-store-link-props :type "gnus" :from from :subject subject | ||
| 9155 | :message-id message-id :group group) | ||
| 9156 | (setq cpltxt (org-email-link-description)) | ||
| 9157 | (if (org-xor arg org-usenet-links-prefer-google) | ||
| 9158 | (setq link | ||
| 9159 | (concat | ||
| 9160 | cpltxt "\n " | ||
| 9161 | (format "http://groups.google.com/groups?as_umsgid=%s" | ||
| 9162 | (org-fixup-message-id-for-http message-id)))) | ||
| 9163 | (setq link (org-make-link "gnus:" group | ||
| 9164 | "#" (number-to-string article)))))) | ||
| 9165 | |||
| 9166 | ((eq major-mode 'w3-mode) | ||
| 9167 | (setq cpltxt (url-view-url t) | ||
| 9168 | link (org-make-link cpltxt)) | ||
| 9169 | (org-store-link-props :type "w3" :url (url-view-url t))) | ||
| 9170 | |||
| 9171 | ((eq major-mode 'w3m-mode) | ||
| 9172 | (setq cpltxt (or w3m-current-title w3m-current-url) | ||
| 9173 | link (org-make-link w3m-current-url)) | ||
| 9174 | (org-store-link-props :type "w3m" :url (url-view-url t))) | ||
| 9175 | |||
| 9176 | ((setq search (run-hook-with-args-until-success | ||
| 9177 | 'org-create-file-search-functions)) | ||
| 9178 | (setq link (concat "file:" (abbreviate-file-name buffer-file-name) | ||
| 9179 | "::" search)) | ||
| 9180 | (setq cpltxt (or description link))) | ||
| 9181 | |||
| 9182 | ((eq major-mode 'image-mode) | ||
| 9183 | (setq cpltxt (concat "file:" | ||
| 9184 | (abbreviate-file-name buffer-file-name)) | ||
| 9185 | link (org-make-link cpltxt)) | ||
| 9186 | (org-store-link-props :type "image" :file buffer-file-name)) | ||
| 9187 | |||
| 9188 | ((eq major-mode 'dired-mode) | ||
| 9189 | ;; link to the file in the current line | ||
| 9190 | (setq cpltxt (concat "file:" | ||
| 9191 | (abbreviate-file-name | ||
| 9192 | (expand-file-name | ||
| 9193 | (dired-get-filename nil t)))) | ||
| 9194 | link (org-make-link cpltxt))) | ||
| 9195 | |||
| 9196 | ((and buffer-file-name (org-mode-p)) | ||
| 9197 | ;; Just link to current headline | ||
| 9198 | (setq cpltxt (concat "file:" | ||
| 9199 | (abbreviate-file-name buffer-file-name))) | ||
| 9200 | ;; Add a context search string | ||
| 9201 | (when (org-xor org-context-in-file-links arg) | ||
| 9202 | ;; Check if we are on a target | ||
| 9203 | (if (org-in-regexp "<<\\(.*?\\)>>") | ||
| 9204 | (setq cpltxt (concat cpltxt "::" (match-string 1))) | ||
| 9205 | (setq txt (cond | ||
| 9206 | ((org-on-heading-p) nil) | ||
| 9207 | ((org-region-active-p) | ||
| 9208 | (buffer-substring (region-beginning) (region-end))) | ||
| 9209 | (t (buffer-substring (point-at-bol) (point-at-eol))))) | ||
| 9210 | (when (or (null txt) (string-match "\\S-" txt)) | ||
| 9211 | (setq cpltxt | ||
| 9212 | (concat cpltxt "::" (org-make-org-heading-search-string txt)) | ||
| 9213 | desc "NONE")))) | ||
| 9214 | (if (string-match "::\\'" cpltxt) | ||
| 9215 | (setq cpltxt (substring cpltxt 0 -2))) | ||
| 9216 | (setq link (org-make-link cpltxt))) | ||
| 9217 | |||
| 9218 | (buffer-file-name | ||
| 9219 | ;; Just link to this file here. | ||
| 9220 | (setq cpltxt (concat "file:" | ||
| 9221 | (abbreviate-file-name buffer-file-name))) | ||
| 9222 | ;; Add a context string | ||
| 9223 | (when (org-xor org-context-in-file-links arg) | ||
| 9224 | (setq txt (if (org-region-active-p) | ||
| 9225 | (buffer-substring (region-beginning) (region-end)) | ||
| 9226 | (buffer-substring (point-at-bol) (point-at-eol)))) | ||
| 9227 | ;; Only use search option if there is some text. | ||
| 9228 | (when (string-match "\\S-" txt) | ||
| 9229 | (setq cpltxt | ||
| 9230 | (concat cpltxt "::" (org-make-org-heading-search-string txt)) | ||
| 9231 | desc "NONE"))) | ||
| 9232 | (setq link (org-make-link cpltxt))) | ||
| 9233 | |||
| 9234 | ((interactive-p) | ||
| 9235 | (error "Cannot link to a buffer which is not visiting a file")) | ||
| 9236 | |||
| 9237 | (t (setq link nil))) | ||
| 9238 | |||
| 9239 | (if (consp link) (setq cpltxt (car link) link (cdr link))) | ||
| 9240 | (setq link (or link cpltxt) | ||
| 9241 | desc (or desc cpltxt)) | ||
| 9242 | (if (equal desc "NONE") (setq desc nil)) | ||
| 9243 | |||
| 9244 | (if (and (interactive-p) link) | ||
| 9245 | (progn | ||
| 9246 | (setq org-stored-links | ||
| 9247 | (cons (list cpltxt link desc) org-stored-links)) | ||
| 9248 | (message "Stored: %s" (or cpltxt link))) | ||
| 9249 | (org-make-link-string link desc)))) | ||
| 9250 | |||
| 9251 | (defun org-store-link-props (&rest plist) | ||
| 9252 | "Store link properties, extract names and addresses." | ||
| 9253 | (let (x adr) | ||
| 9254 | (when (setq x (plist-get plist :from)) | ||
| 9255 | (setq adr (mail-extract-address-components x)) | ||
| 9256 | (plist-put plist :fromname (car adr)) | ||
| 9257 | (plist-put plist :fromaddress (nth 1 adr))) | ||
| 9258 | (when (setq x (plist-get plist :to)) | ||
| 9259 | (setq adr (mail-extract-address-components x)) | ||
| 9260 | (plist-put plist :toname (car adr)) | ||
| 9261 | (plist-put plist :toaddress (nth 1 adr)))) | ||
| 9262 | (let ((from (plist-get plist :from)) | ||
| 9263 | (to (plist-get plist :to))) | ||
| 9264 | (when (and from to org-from-is-user-regexp) | ||
| 9265 | (plist-put plist :fromto | ||
| 9266 | (if (string-match org-from-is-user-regexp from) | ||
| 9267 | (concat "to %t") | ||
| 9268 | (concat "from %f"))))) | ||
| 9269 | (setq org-store-link-plist plist)) | ||
| 9270 | |||
| 9271 | (defun org-email-link-description (&optional fmt) | ||
| 9272 | "Return the description part of an email link. | ||
| 9273 | This takes information from `org-store-link-plist' and formats it | ||
| 9274 | according to FMT (default from `org-email-link-description-format')." | ||
| 9275 | (setq fmt (or fmt org-email-link-description-format)) | ||
| 9276 | (let* ((p org-store-link-plist) | ||
| 9277 | (to (plist-get p :toaddress)) | ||
| 9278 | (from (plist-get p :fromaddress)) | ||
| 9279 | (table | ||
| 9280 | (list | ||
| 9281 | (cons "%c" (plist-get p :fromto)) | ||
| 9282 | (cons "%F" (plist-get p :from)) | ||
| 9283 | (cons "%f" (or (plist-get p :fromname) (plist-get p :fromaddress) "?")) | ||
| 9284 | (cons "%T" (plist-get p :to)) | ||
| 9285 | (cons "%t" (or (plist-get p :toname) (plist-get p :toaddress) "?")) | ||
| 9286 | (cons "%s" (plist-get p :subject)) | ||
| 9287 | (cons "%m" (plist-get p :message-id))))) | ||
| 9288 | (when (string-match "%c" fmt) | ||
| 9289 | ;; Check if the user wrote this message | ||
| 9290 | (if (and org-from-is-user-regexp from to | ||
| 9291 | (save-match-data (string-match org-from-is-user-regexp from))) | ||
| 9292 | (setq fmt (replace-match "to %t" t t fmt)) | ||
| 9293 | (setq fmt (replace-match "from %f" t t fmt)))) | ||
| 9294 | (org-replace-escapes fmt table))) | ||
| 9295 | |||
| 9296 | (defun org-make-org-heading-search-string (&optional string heading) | ||
| 9297 | "Make search string for STRING or current headline." | ||
| 9298 | (interactive) | ||
| 9299 | (let ((s (or string (org-get-heading)))) | ||
| 9300 | (unless (and string (not heading)) | ||
| 9301 | ;; We are using a headline, clean up garbage in there. | ||
| 9302 | (if (string-match org-todo-regexp s) | ||
| 9303 | (setq s (replace-match "" t t s))) | ||
| 9304 | (if (string-match ":[a-zA-Z_@0-9:]+:[ \t]*$" s) | ||
| 9305 | (setq s (replace-match "" t t s))) | ||
| 9306 | (setq s (org-trim s)) | ||
| 9307 | (if (string-match (concat "^\\(" org-quote-string "\\|" | ||
| 9308 | org-comment-string "\\)") s) | ||
| 9309 | (setq s (replace-match "" t t s))) | ||
| 9310 | (while (string-match org-ts-regexp s) | ||
| 9311 | (setq s (replace-match "" t t s)))) | ||
| 9312 | (while (string-match "[^a-zA-Z_0-9 \t]+" s) | ||
| 9313 | (setq s (replace-match " " t t s))) | ||
| 9314 | (or string (setq s (concat "*" s))) ; Add * for headlines | ||
| 9315 | (mapconcat 'identity (org-split-string s "[ \t]+") " "))) | ||
| 9316 | |||
| 9317 | (defun org-make-link (&rest strings) | ||
| 9318 | "Concatenate STRINGS, format resulting string with `org-link-format'." | ||
| 9319 | (apply 'concat strings)) | ||
| 9320 | |||
| 9321 | (defun org-make-link-string (link &optional description) | ||
| 9322 | "Make a link with brackets, consisting of LINK and DESCRIPTION." | ||
| 9323 | (when (stringp description) | ||
| 9324 | ;; Remove brackets from the description, they are fatal. | ||
| 9325 | (while (string-match "\\[\\|\\]" description) | ||
| 9326 | (setq description (replace-match "" t t description)))) | ||
| 9327 | (when (equal (org-link-escape link) description) | ||
| 9328 | ;; No description needed, it is identical | ||
| 9329 | (setq description nil)) | ||
| 9330 | (when (and (not description) | ||
| 9331 | (not (equal link (org-link-escape link)))) | ||
| 9332 | (setq description link)) | ||
| 9333 | (concat "[[" (org-link-escape link) "]" | ||
| 9334 | (if description (concat "[" description "]") "") | ||
| 9335 | "]")) | ||
| 9336 | |||
| 9337 | (defconst org-link-escape-chars '(("[" . "%5B") ("]" . "%5D") (" " . "%20")) | ||
| 9338 | "Association list of escapes for some characters problematic in links.") | ||
| 9339 | |||
| 9340 | (defun org-link-escape (text) | ||
| 9341 | "Escape charaters in TEXT that are problematic for links." | ||
| 9342 | (when text | ||
| 9343 | (let ((re (mapconcat (lambda (x) (regexp-quote (car x))) | ||
| 9344 | org-link-escape-chars "\\|"))) | ||
| 9345 | (while (string-match re text) | ||
| 9346 | (setq text | ||
| 9347 | (replace-match | ||
| 9348 | (cdr (assoc (match-string 0 text) org-link-escape-chars)) | ||
| 9349 | t t text))) | ||
| 9350 | text))) | ||
| 9351 | |||
| 9352 | (defun org-link-unescape (text) | ||
| 9353 | "Reverse the action of `org-link-escape'." | ||
| 9354 | (when text | ||
| 9355 | (let ((re (mapconcat (lambda (x) (regexp-quote (cdr x))) | ||
| 9356 | org-link-escape-chars "\\|"))) | ||
| 9357 | (while (string-match re text) | ||
| 9358 | (setq text | ||
| 9359 | (replace-match | ||
| 9360 | (car (rassoc (match-string 0 text) org-link-escape-chars)) | ||
| 9361 | t t text))) | ||
| 9362 | text))) | ||
| 9363 | |||
| 9364 | (defun org-xor (a b) | ||
| 9365 | "Exclusive or." | ||
| 9366 | (if a (not b) b)) | ||
| 9367 | |||
| 9368 | (defun org-get-header (header) | ||
| 9369 | "Find a header field in the current buffer." | ||
| 9370 | (save-excursion | ||
| 9371 | (goto-char (point-min)) | ||
| 9372 | (let ((case-fold-search t) s) | ||
| 9373 | (cond | ||
| 9374 | ((eq header 'from) | ||
| 9375 | (if (re-search-forward "^From:\\s-+\\(.*\\)" nil t) | ||
| 9376 | (setq s (match-string 1))) | ||
| 9377 | (while (string-match "\"" s) | ||
| 9378 | (setq s (replace-match "" t t s))) | ||
| 9379 | (if (string-match "[<(].*" s) | ||
| 9380 | (setq s (replace-match "" t t s)))) | ||
| 9381 | ((eq header 'message-id) | ||
| 9382 | (if (re-search-forward "^message-id:\\s-+\\(.*\\)" nil t) | ||
| 9383 | (setq s (match-string 1)))) | ||
| 9384 | ((eq header 'subject) | ||
| 9385 | (if (re-search-forward "^subject:\\s-+\\(.*\\)" nil t) | ||
| 9386 | (setq s (match-string 1))))) | ||
| 9387 | (if (string-match "\\`[ \t\]+" s) (setq s (replace-match "" t t s))) | ||
| 9388 | (if (string-match "[ \t\]+\\'" s) (setq s (replace-match "" t t s))) | ||
| 9389 | s))) | ||
| 9390 | |||
| 9391 | |||
| 9392 | (defun org-fixup-message-id-for-http (s) | ||
| 9393 | "Replace special characters in a message id, so it can be used in an http query." | ||
| 9394 | (while (string-match "<" s) | ||
| 9395 | (setq s (replace-match "%3C" t t s))) | ||
| 9396 | (while (string-match ">" s) | ||
| 9397 | (setq s (replace-match "%3E" t t s))) | ||
| 9398 | (while (string-match "@" s) | ||
| 9399 | (setq s (replace-match "%40" t t s))) | ||
| 9400 | s) | ||
| 9401 | |||
| 9402 | (defun org-insert-link (&optional complete-file) | ||
| 9403 | "Insert a link. At the prompt, enter the link. | ||
| 9404 | |||
| 9405 | Completion can be used to select a link previously stored with | ||
| 9406 | `org-store-link'. When the empty string is entered (i.e. if you just | ||
| 9407 | press RET at the prompt), the link defaults to the most recently | ||
| 9408 | stored link. As SPC triggers completion in the minibuffer, you need to | ||
| 9409 | use M-SPC or C-q SPC to force the insertion of a space character. | ||
| 9410 | |||
| 9411 | You will also be prompted for a description, and if one is given, it will | ||
| 9412 | be displayed in the buffer instead of the link. | ||
| 9413 | |||
| 9414 | If there is already a link at point, this command will allow you to edit link | ||
| 9415 | and description parts. | ||
| 9416 | |||
| 9417 | With a \\[universal-argument] prefix, prompts for a file to link to. The file name can be | ||
| 9418 | selected using completion. The path to the file will be relative to | ||
| 9419 | the current directory if the file is in the current directory or a | ||
| 9420 | subdirectory. Otherwise, the link will be the absolute path as | ||
| 9421 | completed in the minibuffer (i.e. normally ~/path/to/file). | ||
| 9422 | |||
| 9423 | With two \\[universal-argument] prefixes, enforce an absolute path even if the file | ||
| 9424 | is in the current directory or below. | ||
| 9425 | With three \\[universal-argument] prefixes, negate the meaning of | ||
| 9426 | `org-keep-stored-link-after-insertion'." | ||
| 9427 | (interactive "P") | ||
| 9428 | (let ((region (if (org-region-active-p) | ||
| 9429 | (prog1 (buffer-substring (region-beginning) (region-end)) | ||
| 9430 | (delete-region (region-beginning) (region-end))))) | ||
| 9431 | tmphist ; byte-compile incorrectly complains about this | ||
| 9432 | link desc entry remove file) | ||
| 9433 | (cond | ||
| 9434 | ((org-in-regexp org-bracket-link-regexp 1) | ||
| 9435 | ;; We do have a link at point, and we are going to edit it. | ||
| 9436 | (setq remove (list (match-beginning 0) (match-end 0))) | ||
| 9437 | (setq desc (if (match-end 3) (org-match-string-no-properties 3))) | ||
| 9438 | (setq link (read-string "Link: " | ||
| 9439 | (org-link-unescape | ||
| 9440 | (org-match-string-no-properties 1))))) | ||
| 9441 | ((or (org-in-regexp org-angle-link-re) | ||
| 9442 | (org-in-regexp org-plain-link-re)) | ||
| 9443 | ;; Convert to bracket link | ||
| 9444 | (setq remove (list (match-beginning 0) (match-end 0)) | ||
| 9445 | link (read-string "Link: " | ||
| 9446 | (org-remove-angle-brackets (match-string 0))))) | ||
| 9447 | ((equal complete-file '(4)) | ||
| 9448 | ;; Completing read for file names. | ||
| 9449 | (setq file (read-file-name "File: ")) | ||
| 9450 | (let ((pwd (file-name-as-directory (expand-file-name "."))) | ||
| 9451 | (pwd1 (file-name-as-directory (abbreviate-file-name | ||
| 9452 | (expand-file-name "."))))) | ||
| 9453 | (cond | ||
| 9454 | ((equal complete-file '(16)) | ||
| 9455 | (setq link (org-make-link | ||
| 9456 | "file:" | ||
| 9457 | (abbreviate-file-name (expand-file-name file))))) | ||
| 9458 | ((string-match (concat "^" (regexp-quote pwd1) "\\(.+\\)") file) | ||
| 9459 | (setq link (org-make-link "file:" (match-string 1 file)))) | ||
| 9460 | ((string-match (concat "^" (regexp-quote pwd) "\\(.+\\)") | ||
| 9461 | (expand-file-name file)) | ||
| 9462 | (setq link (org-make-link | ||
| 9463 | "file:" (match-string 1 (expand-file-name file))))) | ||
| 9464 | (t (setq link (org-make-link "file:" file)))))) | ||
| 9465 | (t | ||
| 9466 | ;; Read link, with completion for stored links. | ||
| 9467 | ;; Fake a link history | ||
| 9468 | (setq tmphist (append (mapcar 'car org-stored-links) | ||
| 9469 | org-insert-link-history)) | ||
| 9470 | (setq link (org-completing-read | ||
| 9471 | "Link: " org-stored-links nil nil nil | ||
| 9472 | 'tmphist | ||
| 9473 | (or (car (car org-stored-links))))) | ||
| 9474 | (setq entry (assoc link org-stored-links)) | ||
| 9475 | (or entry (push link org-insert-link-history)) | ||
| 9476 | (if (funcall (if (equal complete-file '(64)) 'not 'identity) | ||
| 9477 | (not org-keep-stored-link-after-insertion)) | ||
| 9478 | (setq org-stored-links (delq (assoc link org-stored-links) | ||
| 9479 | org-stored-links))) | ||
| 9480 | (setq link (if entry (nth 1 entry) link) | ||
| 9481 | desc (or region desc (nth 2 entry))))) | ||
| 9482 | |||
| 9483 | (if (string-match org-plain-link-re link) | ||
| 9484 | ;; URL-like link, normalize the use of angular brackets. | ||
| 9485 | (setq link (org-make-link (org-remove-angle-brackets link)))) | ||
| 9486 | |||
| 9487 | ;; Check if we are linking to the current file with a search option | ||
| 9488 | ;; If yes, simplify the link by using only the search option. | ||
| 9489 | (when (and buffer-file-name | ||
| 9490 | (string-match "\\<file:\\(.+?\\)::\\([^>]+\\)" link)) | ||
| 9491 | (let* ((path (match-string 1 link)) | ||
| 9492 | (case-fold-search nil) | ||
| 9493 | (search (match-string 2 link))) | ||
| 9494 | (save-match-data | ||
| 9495 | (if (equal (file-truename buffer-file-name) (file-truename path)) | ||
| 9496 | ;; We are linking to this same file, with a search option | ||
| 9497 | (setq link search))))) | ||
| 9498 | |||
| 9499 | ;; Check if we can/should use a relative path. If yes, simplify the link | ||
| 9500 | (when (string-match "\\<file:\\(.*\\)" link) | ||
| 9501 | (let* ((path (match-string 1 link)) | ||
| 9502 | (case-fold-search nil)) | ||
| 9503 | (cond | ||
| 9504 | ((eq org-link-file-path-type 'absolute) | ||
| 9505 | (setq path (abbreviate-file-name (expand-file-name path)))) | ||
| 9506 | ((eq org-link-file-path-type 'noabbrev) | ||
| 9507 | (setq path (expand-file-name path))) | ||
| 9508 | ((eq org-link-file-path-type 'relative) | ||
| 9509 | (setq path (file-relative-name path))) | ||
| 9510 | (t | ||
| 9511 | (save-match-data | ||
| 9512 | (if (string-match (concat "^" (regexp-quote | ||
| 9513 | (file-name-as-directory | ||
| 9514 | (expand-file-name ".")))) | ||
| 9515 | (expand-file-name path)) | ||
| 9516 | ;; We are linking a file with relative path name. | ||
| 9517 | (setq path (substring (expand-file-name path) | ||
| 9518 | (match-end 0))))))) | ||
| 9519 | (setq link (concat "file:" path)))) | ||
| 9520 | |||
| 9521 | (setq desc (read-string "Description: " desc)) | ||
| 9522 | (unless (string-match "\\S-" desc) (setq desc nil)) | ||
| 9523 | (if remove (apply 'delete-region remove)) | ||
| 9524 | (insert (org-make-link-string link desc)))) | ||
| 9525 | |||
| 9526 | (defun org-completing-read (&rest args) | ||
| 9527 | (let ((minibuffer-local-completion-map | ||
| 9528 | (copy-keymap minibuffer-local-completion-map))) | ||
| 9529 | (define-key minibuffer-local-completion-map " " 'self-insert-command) | ||
| 9530 | (apply 'completing-read args))) | ||
| 9531 | |||
| 9532 | ;;; Opening/following a link | ||
| 9533 | (defvar org-link-search-failed nil) | ||
| 9534 | |||
| 9535 | (defun org-next-link () | ||
| 9536 | "Move forward to the next link. | ||
| 9537 | If the link is in hidden text, expose it." | ||
| 9538 | (interactive) | ||
| 9539 | (when (and org-link-search-failed (eq this-command last-command)) | ||
| 9540 | (goto-char (point-min)) | ||
| 9541 | (message "Link search wrapped back to beginning of buffer")) | ||
| 9542 | (setq org-link-search-failed nil) | ||
| 9543 | (let* ((pos (point)) | ||
| 9544 | (ct (org-context)) | ||
| 9545 | (a (assoc :link ct))) | ||
| 9546 | (if a (goto-char (nth 2 a))) | ||
| 9547 | (if (re-search-forward org-any-link-re nil t) | ||
| 9548 | (progn | ||
| 9549 | (goto-char (match-beginning 0)) | ||
| 9550 | (if (org-invisible-p) (org-show-context))) | ||
| 9551 | (goto-char pos) | ||
| 9552 | (setq org-link-search-failed t) | ||
| 9553 | (error "No further link found")))) | ||
| 9554 | |||
| 9555 | (defun org-previous-link () | ||
| 9556 | "Move backward to the previous link. | ||
| 9557 | If the link is in hidden text, expose it." | ||
| 9558 | (interactive) | ||
| 9559 | (when (and org-link-search-failed (eq this-command last-command)) | ||
| 9560 | (goto-char (point-max)) | ||
| 9561 | (message "Link search wrapped back to end of buffer")) | ||
| 9562 | (setq org-link-search-failed nil) | ||
| 9563 | (let* ((pos (point)) | ||
| 9564 | (ct (org-context)) | ||
| 9565 | (a (assoc :link ct))) | ||
| 9566 | (if a (goto-char (nth 1 a))) | ||
| 9567 | (if (re-search-backward org-any-link-re nil t) | ||
| 9568 | (progn | ||
| 9569 | (goto-char (match-beginning 0)) | ||
| 9570 | (if (org-invisible-p) (org-show-context))) | ||
| 9571 | (goto-char pos) | ||
| 9572 | (setq org-link-search-failed t) | ||
| 9573 | (error "No further link found")))) | ||
| 9574 | |||
| 9575 | (defun org-find-file-at-mouse (ev) | ||
| 9576 | "Open file link or URL at mouse." | ||
| 9577 | (interactive "e") | ||
| 9578 | (mouse-set-point ev) | ||
| 9579 | (org-open-at-point 'in-emacs)) | ||
| 9580 | |||
| 9581 | (defun org-open-at-mouse (ev) | ||
| 9582 | "Open file link or URL at mouse." | ||
| 9583 | (interactive "e") | ||
| 9584 | (mouse-set-point ev) | ||
| 9585 | (org-open-at-point)) | ||
| 9586 | |||
| 9587 | (defvar org-window-config-before-follow-link nil | ||
| 9588 | "The window configuration before following a link. | ||
| 9589 | This is saved in case the need arises to restore it.") | ||
| 9590 | |||
| 9591 | (defvar org-open-link-marker (make-marker) | ||
| 9592 | "Marker pointing to the location where `org-open-at-point; was called.") | ||
| 9593 | |||
| 9594 | (defun org-open-at-point (&optional in-emacs) | ||
| 9595 | "Open link at or after point. | ||
| 9596 | If there is no link at point, this function will search forward up to | ||
| 9597 | the end of the current subtree. | ||
| 9598 | Normally, files will be opened by an appropriate application. If the | ||
| 9599 | optional argument IN-EMACS is non-nil, Emacs will visit the file." | ||
| 9600 | (interactive "P") | ||
| 9601 | (move-marker org-open-link-marker (point)) | ||
| 9602 | (setq org-window-config-before-follow-link (current-window-configuration)) | ||
| 9603 | (org-remove-occur-highlights nil nil t) | ||
| 9604 | (if (org-at-timestamp-p t) | ||
| 9605 | (org-follow-timestamp-link) | ||
| 9606 | (let (type path link line search (pos (point))) | ||
| 9607 | (catch 'match | ||
| 5135 | (save-excursion | 9608 | (save-excursion |
| 5136 | (remove-text-properties (point-min) (point-max) pall) | 9609 | (skip-chars-forward "^]\n\r") |
| 5137 | (when org-agenda-skip-archived-trees | 9610 | (when (org-in-regexp org-bracket-link-regexp) |
| 5138 | (goto-char (point-min)) | 9611 | (setq link (org-link-unescape (org-match-string-no-properties 1))) |
| 5139 | (while (re-search-forward rea nil t) | 9612 | (while (string-match " *\n *" link) |
| 5140 | (if (org-on-heading-p) | 9613 | (setq link (replace-match " " t t link))) |
| 5141 | (add-text-properties (point-at-bol) (org-end-of-subtree t) pa)))) | 9614 | (setq link (org-link-expand-abbrev link)) |
| 5142 | (goto-char (point-min)) | 9615 | (if (string-match org-link-re-with-space2 link) |
| 5143 | (setq re (concat "^\\*+ +" org-comment-string "\\>")) | 9616 | (setq type (match-string 1 link) path (match-string 2 link)) |
| 5144 | (while (re-search-forward re nil t) | 9617 | (setq type "thisfile" path link)) |
| 5145 | (add-text-properties | 9618 | (throw 'match t))) |
| 5146 | (match-beginning 0) (org-end-of-subtree t) pc))) | ||
| 5147 | (set-buffer-modified-p bmp))))) | ||
| 5148 | 9619 | ||
| 5149 | (defun org-agenda-skip () | 9620 | (when (get-text-property (point) 'org-linked-text) |
| 5150 | "Throw to `:skip' in places that should be skipped." | 9621 | (setq type "thisfile" |
| 5151 | (let ((p (point-at-bol))) | 9622 | pos (if (get-text-property (1+ (point)) 'org-linked-text) |
| 5152 | (and org-agenda-skip-archived-trees | 9623 | (1+ (point)) (point)) |
| 5153 | (get-text-property p :org-archived) | 9624 | path (buffer-substring |
| 5154 | (org-end-of-subtree t) | 9625 | (previous-single-property-change pos 'org-linked-text) |
| 5155 | (throw :skip t)) | 9626 | (next-single-property-change pos 'org-linked-text))) |
| 5156 | (and (get-text-property p :org-comment) | 9627 | (throw 'match t)) |
| 5157 | (org-end-of-subtree t) | ||
| 5158 | (throw :skip t)) | ||
| 5159 | (if (equal (char-after p) ?#) (throw :skip t)))) | ||
| 5160 | 9628 | ||
| 5161 | (defun org-agenda-toggle-archive-tag () | 9629 | (save-excursion |
| 5162 | "Toggle the archive tag for the current entry." | 9630 | (when (or (org-in-regexp org-angle-link-re) |
| 9631 | (org-in-regexp org-plain-link-re)) | ||
| 9632 | (setq type (match-string 1) path (match-string 2)) | ||
| 9633 | (throw 'match t))) | ||
| 9634 | (save-excursion | ||
| 9635 | (when (org-in-regexp "\\(:[A-Za-z_@0-9:]+\\):[ \t\r\n]") | ||
| 9636 | (setq type "tags" | ||
| 9637 | path (match-string 1)) | ||
| 9638 | (while (string-match ":" path) | ||
| 9639 | (setq path (replace-match "+" t t path))) | ||
| 9640 | (throw 'match t)))) | ||
| 9641 | (unless path | ||
| 9642 | (error "No link found")) | ||
| 9643 | ;; Remove any trailing spaces in path | ||
| 9644 | (if (string-match " +\\'" path) | ||
| 9645 | (setq path (replace-match "" t t path))) | ||
| 9646 | |||
| 9647 | (cond | ||
| 9648 | |||
| 9649 | ((equal type "mailto") | ||
| 9650 | (let ((cmd (car org-link-mailto-program)) | ||
| 9651 | (args (cdr org-link-mailto-program)) args1 | ||
| 9652 | (address path) (subject "") a) | ||
| 9653 | (if (string-match "\\(.*\\)::\\(.*\\)" path) | ||
| 9654 | (setq address (match-string 1 path) | ||
| 9655 | subject (org-link-escape (match-string 2 path)))) | ||
| 9656 | (while args | ||
| 9657 | (cond | ||
| 9658 | ((not (stringp (car args))) (push (pop args) args1)) | ||
| 9659 | (t (setq a (pop args)) | ||
| 9660 | (if (string-match "%a" a) | ||
| 9661 | (setq a (replace-match address t t a))) | ||
| 9662 | (if (string-match "%s" a) | ||
| 9663 | (setq a (replace-match subject t t a))) | ||
| 9664 | (push a args1)))) | ||
| 9665 | (apply cmd (nreverse args1)))) | ||
| 9666 | |||
| 9667 | ((member type '("http" "https" "ftp" "news")) | ||
| 9668 | (browse-url (concat type ":" path))) | ||
| 9669 | |||
| 9670 | ((string= type "tags") | ||
| 9671 | (org-tags-view in-emacs path)) | ||
| 9672 | ((string= type "thisfile") | ||
| 9673 | (if in-emacs | ||
| 9674 | (switch-to-buffer-other-window | ||
| 9675 | (org-get-buffer-for-internal-link (current-buffer))) | ||
| 9676 | (org-mark-ring-push)) | ||
| 9677 | (org-link-search | ||
| 9678 | path | ||
| 9679 | (cond ((equal in-emacs '(4)) 'occur) | ||
| 9680 | ((equal in-emacs '(16)) 'org-occur) | ||
| 9681 | (t nil)) | ||
| 9682 | pos)) | ||
| 9683 | |||
| 9684 | ((string= type "file") | ||
| 9685 | (if (string-match "::\\([0-9]+\\)\\'" path) | ||
| 9686 | (setq line (string-to-number (match-string 1 path)) | ||
| 9687 | path (substring path 0 (match-beginning 0))) | ||
| 9688 | (if (string-match "::\\(.+\\)\\'" path) | ||
| 9689 | (setq search (match-string 1 path) | ||
| 9690 | path (substring path 0 (match-beginning 0))))) | ||
| 9691 | (org-open-file path in-emacs line search)) | ||
| 9692 | |||
| 9693 | ((string= type "news") | ||
| 9694 | (org-follow-gnus-link path)) | ||
| 9695 | |||
| 9696 | ((string= type "bbdb") | ||
| 9697 | (org-follow-bbdb-link path)) | ||
| 9698 | |||
| 9699 | ((string= type "info") | ||
| 9700 | (org-follow-info-link path)) | ||
| 9701 | |||
| 9702 | ((string= type "gnus") | ||
| 9703 | (let (group article) | ||
| 9704 | (if (not (string-match "\\`\\([^#]+\\)\\(#\\(.*\\)\\)?" path)) | ||
| 9705 | (error "Error in Gnus link")) | ||
| 9706 | (setq group (match-string 1 path) | ||
| 9707 | article (match-string 3 path)) | ||
| 9708 | (org-follow-gnus-link group article))) | ||
| 9709 | |||
| 9710 | ((string= type "vm") | ||
| 9711 | (let (folder article) | ||
| 9712 | (if (not (string-match "\\`\\([^#]+\\)\\(#\\(.*\\)\\)?" path)) | ||
| 9713 | (error "Error in VM link")) | ||
| 9714 | (setq folder (match-string 1 path) | ||
| 9715 | article (match-string 3 path)) | ||
| 9716 | ;; in-emacs is the prefix arg, will be interpreted as read-only | ||
| 9717 | (org-follow-vm-link folder article in-emacs))) | ||
| 9718 | |||
| 9719 | ((string= type "wl") | ||
| 9720 | (let (folder article) | ||
| 9721 | (if (not (string-match "\\`\\([^#]+\\)\\(#\\(.*\\)\\)?" path)) | ||
| 9722 | (error "Error in Wanderlust link")) | ||
| 9723 | (setq folder (match-string 1 path) | ||
| 9724 | article (match-string 3 path)) | ||
| 9725 | (org-follow-wl-link folder article))) | ||
| 9726 | |||
| 9727 | ((string= type "mhe") | ||
| 9728 | (let (folder article) | ||
| 9729 | (if (not (string-match "\\`\\([^#]+\\)\\(#\\(.*\\)\\)?" path)) | ||
| 9730 | (error "Error in MHE link")) | ||
| 9731 | (setq folder (match-string 1 path) | ||
| 9732 | article (match-string 3 path)) | ||
| 9733 | (org-follow-mhe-link folder article))) | ||
| 9734 | |||
| 9735 | ((string= type "rmail") | ||
| 9736 | (let (folder article) | ||
| 9737 | (if (not (string-match "\\`\\([^#]+\\)\\(#\\(.*\\)\\)?" path)) | ||
| 9738 | (error "Error in RMAIL link")) | ||
| 9739 | (setq folder (match-string 1 path) | ||
| 9740 | article (match-string 3 path)) | ||
| 9741 | (org-follow-rmail-link folder article))) | ||
| 9742 | |||
| 9743 | ((string= type "shell") | ||
| 9744 | (let ((cmd path)) | ||
| 9745 | ;; FIXME: the following is only for backward compatibility | ||
| 9746 | (while (string-match "@{" cmd) (setq cmd (replace-match "<" t t cmd))) | ||
| 9747 | (while (string-match "@}" cmd) (setq cmd (replace-match ">" t t cmd))) | ||
| 9748 | (if (or (not org-confirm-shell-link-function) | ||
| 9749 | (funcall org-confirm-shell-link-function | ||
| 9750 | (format "Execute \"%s\" in shell? " | ||
| 9751 | (org-add-props cmd nil | ||
| 9752 | 'face 'org-warning)))) | ||
| 9753 | (progn | ||
| 9754 | (message "Executing %s" cmd) | ||
| 9755 | (shell-command cmd)) | ||
| 9756 | (error "Abort")))) | ||
| 9757 | |||
| 9758 | ((string= type "elisp") | ||
| 9759 | (let ((cmd path)) | ||
| 9760 | (if (or (not org-confirm-elisp-link-function) | ||
| 9761 | (funcall org-confirm-elisp-link-function | ||
| 9762 | (format "Execute \"%s\" as elisp? " | ||
| 9763 | (org-add-props cmd nil | ||
| 9764 | 'face 'org-warning)))) | ||
| 9765 | (message "%s => %s" cmd (eval (read cmd))) | ||
| 9766 | (error "Abort")))) | ||
| 9767 | |||
| 9768 | (t | ||
| 9769 | (browse-url-at-point))))) | ||
| 9770 | (move-marker org-open-link-marker nil)) | ||
| 9771 | |||
| 9772 | |||
| 9773 | ;;; File search | ||
| 9774 | |||
| 9775 | (defvar org-create-file-search-functions nil | ||
| 9776 | "List of functions to construct the right search string for a file link. | ||
| 9777 | These functions are called in turn with point at the location to | ||
| 9778 | which the link should point. | ||
| 9779 | |||
| 9780 | A function in the hook should first test if it would like to | ||
| 9781 | handle this file type, for example by checking the major-mode or | ||
| 9782 | the file extension. If it decides not to handle this file, it | ||
| 9783 | should just return nil to give other functions a chance. If it | ||
| 9784 | does handle the file, it must return the search string to be used | ||
| 9785 | when following the link. The search string will be part of the | ||
| 9786 | file link, given after a double colon, and `org-open-at-point' | ||
| 9787 | will automatically search for it. If special measures must be | ||
| 9788 | taken to make the search successful, another function should be | ||
| 9789 | added to the companion hook `org-execute-file-search-functions', | ||
| 9790 | which see. | ||
| 9791 | |||
| 9792 | A function in this hook may also use `setq' to set the variable | ||
| 9793 | `description' to provide a suggestion for the descriptive text to | ||
| 9794 | be used for this link when it gets inserted into an Org-mode | ||
| 9795 | buffer with \\[org-insert-link].") | ||
| 9796 | |||
| 9797 | (defvar org-execute-file-search-functions nil | ||
| 9798 | "List of functions to execute a file search triggered by a link. | ||
| 9799 | |||
| 9800 | Functions added to this hook must accept a single argument, the | ||
| 9801 | search string that was part of the file link, the part after the | ||
| 9802 | double colon. The function must first check if it would like to | ||
| 9803 | handle this search, for example by checking the major-mode or the | ||
| 9804 | file extension. If it decides not to handle this search, it | ||
| 9805 | should just return nil to give other functions a chance. If it | ||
| 9806 | does handle the search, it must return a non-nil value to keep | ||
| 9807 | other functions from trying. | ||
| 9808 | |||
| 9809 | Each function can access the current prefix argument through the | ||
| 9810 | variable `current-prefix-argument'. Note that a single prefix is | ||
| 9811 | used to force opening a link in Emacs, so it may be good to only | ||
| 9812 | use a numeric or double prefix to guide the search function. | ||
| 9813 | |||
| 9814 | In case this is needed, a function in this hook can also restore | ||
| 9815 | the window configuration before `org-open-at-point' was called using: | ||
| 9816 | |||
| 9817 | (set-window-configuration org-window-config-before-follow-link)") | ||
| 9818 | |||
| 9819 | (defun org-link-search (s &optional type avoid-pos) | ||
| 9820 | "Search for a link search option. | ||
| 9821 | If S is surrounded by forward slashes, it is interpreted as a | ||
| 9822 | regular expression. In org-mode files, this will create an `org-occur' | ||
| 9823 | sparse tree. In ordinary files, `occur' will be used to list matches. | ||
| 9824 | If the current buffer is in `dired-mode', grep will be used to search | ||
| 9825 | in all files. If AVOID-POS is given, ignore matches near that position." | ||
| 9826 | (let ((case-fold-search t) | ||
| 9827 | (s0 (mapconcat 'identity (org-split-string s "[ \t\r\n]+") " ")) | ||
| 9828 | (pos (point)) | ||
| 9829 | (pre "") (post "") | ||
| 9830 | words re0 re1 re2 re3 re4 re5 re2a reall) | ||
| 9831 | (cond | ||
| 9832 | ;; First check if there are any special | ||
| 9833 | ((run-hook-with-args-until-success 'org-execute-file-search-functions s)) | ||
| 9834 | ;; Now try the builtin stuff | ||
| 9835 | ((save-excursion | ||
| 9836 | (goto-char (point-min)) | ||
| 9837 | (and | ||
| 9838 | (re-search-forward | ||
| 9839 | (concat "<<" (regexp-quote s0) ">>") nil t) | ||
| 9840 | (setq pos (match-beginning 0)))) | ||
| 9841 | ;; There is an exact target for this | ||
| 9842 | (goto-char pos)) | ||
| 9843 | ((string-match "^/\\(.*\\)/$" s) | ||
| 9844 | ;; A regular expression | ||
| 9845 | (cond | ||
| 9846 | ((org-mode-p) | ||
| 9847 | (org-occur (match-string 1 s))) | ||
| 9848 | ;;((eq major-mode 'dired-mode) | ||
| 9849 | ;; (grep (concat "grep -n -e '" (match-string 1 s) "' *"))) | ||
| 9850 | (t (org-do-occur (match-string 1 s))))) | ||
| 9851 | (t | ||
| 9852 | ;; A normal search string | ||
| 9853 | (when (equal (string-to-char s) ?*) | ||
| 9854 | ;; Anchor on headlines, post may include tags. | ||
| 9855 | (setq pre "^\\*+[ \t]*\\(?:\\sw+\\)?[ \t]*" | ||
| 9856 | post "[ \t]*\\(?:[ \t]+:[a-zA-Z_@0-9:+]:[ \t]*\\)?$" | ||
| 9857 | s (substring s 1))) | ||
| 9858 | (remove-text-properties | ||
| 9859 | 0 (length s) | ||
| 9860 | '(face nil mouse-face nil keymap nil fontified nil) s) | ||
| 9861 | ;; Make a series of regular expressions to find a match | ||
| 9862 | (setq words (org-split-string s "[ \n\r\t]+") | ||
| 9863 | re0 (concat "\\(<<" (regexp-quote s0) ">>\\)") | ||
| 9864 | re2 (concat "[ \t\r\n]\\(" (mapconcat 'downcase words "[ \t]+") "\\)[ \t\r\n]") | ||
| 9865 | re2a (concat "[ \t\r\n]\\(" (mapconcat 'downcase words "[ \t\r\n]+") "\\)[ \t\r\n]") | ||
| 9866 | re4 (concat "[^a-zA-Z_]\\(" (mapconcat 'downcase words "[^a-zA-Z_\r\n]+") "\\)[^a-zA-Z_]") | ||
| 9867 | re1 (concat pre re2 post) | ||
| 9868 | re3 (concat pre re4 post) | ||
| 9869 | re5 (concat pre ".*" re4) | ||
| 9870 | re2 (concat pre re2) | ||
| 9871 | re2a (concat pre re2a) | ||
| 9872 | re4 (concat pre re4) | ||
| 9873 | reall (concat "\\(" re0 "\\)\\|\\(" re1 "\\)\\|\\(" re2 | ||
| 9874 | "\\)\\|\\(" re3 "\\)\\|\\(" re4 "\\)\\|\\(" | ||
| 9875 | re5 "\\)" | ||
| 9876 | )) | ||
| 9877 | (cond | ||
| 9878 | ((eq type 'org-occur) (org-occur reall)) | ||
| 9879 | ((eq type 'occur) (org-do-occur (downcase reall) 'cleanup)) | ||
| 9880 | (t (goto-char (point-min)) | ||
| 9881 | (if (or (org-search-not-self 1 re0 nil t) | ||
| 9882 | (org-search-not-self 1 re1 nil t) | ||
| 9883 | (org-search-not-self 1 re2 nil t) | ||
| 9884 | (org-search-not-self 1 re2a nil t) | ||
| 9885 | (org-search-not-self 1 re3 nil t) | ||
| 9886 | (org-search-not-self 1 re4 nil t) | ||
| 9887 | (org-search-not-self 1 re5 nil t) | ||
| 9888 | ) | ||
| 9889 | (goto-char (match-beginning 1)) | ||
| 9890 | (goto-char pos) | ||
| 9891 | (error "No match"))))) | ||
| 9892 | (t | ||
| 9893 | ;; Normal string-search | ||
| 9894 | (goto-char (point-min)) | ||
| 9895 | (if (search-forward s nil t) | ||
| 9896 | (goto-char (match-beginning 0)) | ||
| 9897 | (error "No match")))) | ||
| 9898 | (and (org-mode-p) (org-show-context 'link-search)))) | ||
| 9899 | |||
| 9900 | (defun org-search-not-self (group &rest args) | ||
| 9901 | "Execute `re-search-forward', but only accept matches that do not | ||
| 9902 | enclose the position of `org-open-link-marker'." | ||
| 9903 | (let ((m org-open-link-marker)) | ||
| 9904 | (catch 'exit | ||
| 9905 | (while (apply 're-search-forward args) | ||
| 9906 | (goto-char (match-end group)) | ||
| 9907 | (if (and (or (not (eq (marker-buffer m) (current-buffer))) | ||
| 9908 | (> (match-beginning 0) (marker-position m)) | ||
| 9909 | (< (match-end 0) (marker-position m))) | ||
| 9910 | (save-match-data | ||
| 9911 | (or (not (org-in-regexp org-bracket-link-analytic-regexp 1)) | ||
| 9912 | (not (match-end 4)) ; no description | ||
| 9913 | (and (<= (match-beginning 4) (point)) | ||
| 9914 | (>= (match-end 4) (point)))))) | ||
| 9915 | (throw 'exit (point))))))) | ||
| 9916 | |||
| 9917 | (defun org-get-buffer-for-internal-link (buffer) | ||
| 9918 | "Return a buffer to be used for displaying the link target of internal links." | ||
| 9919 | (cond | ||
| 9920 | ((not org-display-internal-link-with-indirect-buffer) | ||
| 9921 | buffer) | ||
| 9922 | ((string-match "(Clone)$" (buffer-name buffer)) | ||
| 9923 | (message "Buffer is already a clone, not making another one") | ||
| 9924 | ;; we also do not modify visibility in this case | ||
| 9925 | buffer) | ||
| 9926 | (t ; make a new indirect buffer for displaying the link | ||
| 9927 | (let* ((bn (buffer-name buffer)) | ||
| 9928 | (ibn (concat bn "(Clone)")) | ||
| 9929 | (ib (or (get-buffer ibn) (make-indirect-buffer buffer ibn 'clone)))) | ||
| 9930 | (with-current-buffer ib (org-overview)) | ||
| 9931 | ib)))) | ||
| 9932 | |||
| 9933 | (defun org-do-occur (regexp &optional cleanup) | ||
| 9934 | "Call the Emacs command `occur'. | ||
| 9935 | If CLEANUP is non-nil, remove the printout of the regular expression | ||
| 9936 | in the *Occur* buffer. This is useful if the regex is long and not useful | ||
| 9937 | to read." | ||
| 9938 | (occur regexp) | ||
| 9939 | (when cleanup | ||
| 9940 | (let ((cwin (selected-window)) win beg end) | ||
| 9941 | (when (setq win (get-buffer-window "*Occur*")) | ||
| 9942 | (select-window win)) | ||
| 9943 | (goto-char (point-min)) | ||
| 9944 | (when (re-search-forward "match[a-z]+" nil t) | ||
| 9945 | (setq beg (match-end 0)) | ||
| 9946 | (if (re-search-forward "^[ \t]*[0-9]+" nil t) | ||
| 9947 | (setq end (1- (match-beginning 0))))) | ||
| 9948 | (and beg end (let ((buffer-read-only)) (delete-region beg end))) | ||
| 9949 | (goto-char (point-min)) | ||
| 9950 | (select-window cwin)))) | ||
| 9951 | |||
| 9952 | ;;; The mark ring for links jumps | ||
| 9953 | |||
| 9954 | (defvar org-mark-ring nil | ||
| 9955 | "Mark ring for positions before jumps in Org-mode.") | ||
| 9956 | (defvar org-mark-ring-last-goto nil | ||
| 9957 | "Last position in the mark ring used to go back.") | ||
| 9958 | ;; Fill and close the ring | ||
| 9959 | (setq org-mark-ring nil org-mark-ring-last-goto nil) ;; in case file is reloaded | ||
| 9960 | (loop for i from 1 to org-mark-ring-length do | ||
| 9961 | (push (make-marker) org-mark-ring)) | ||
| 9962 | (setcdr (nthcdr (1- org-mark-ring-length) org-mark-ring) | ||
| 9963 | org-mark-ring) | ||
| 9964 | |||
| 9965 | (defun org-mark-ring-push (&optional pos buffer) | ||
| 9966 | "Put the current position or POS into the mark ring and rotate it." | ||
| 5163 | (interactive) | 9967 | (interactive) |
| 5164 | (org-agenda-check-no-diary) | 9968 | (setq pos (or pos (point))) |
| 5165 | (org-agenda-show) ;;; FIXME This is a stupid hack and should not be needed | 9969 | (setq org-mark-ring (nthcdr (1- org-mark-ring-length) org-mark-ring)) |
| 5166 | (let* ((hdmarker (or (get-text-property (point) 'org-hd-marker) | 9970 | (move-marker (car org-mark-ring) |
| 5167 | (org-agenda-error))) | 9971 | (or pos (point)) |
| 5168 | (buffer (marker-buffer hdmarker)) | 9972 | (or buffer (current-buffer))) |
| 5169 | (pos (marker-position hdmarker)) | 9973 | (message |
| 5170 | (buffer-read-only nil) | 9974 | (substitute-command-keys |
| 5171 | newhead) | 9975 | "Position saved to mark ring, go back with \\[org-mark-ring-goto]."))) |
| 5172 | (with-current-buffer buffer | 9976 | |
| 9977 | (defun org-mark-ring-goto (&optional n) | ||
| 9978 | "Jump to the previous position in the mark ring. | ||
| 9979 | With prefix arg N, jump back that many stored positions. When | ||
| 9980 | called several times in succession, walk through the entire ring. | ||
| 9981 | Org-mode commands jumping to a different position in the current file, | ||
| 9982 | or to another Org-mode file, automatically push the old position | ||
| 9983 | onto the ring." | ||
| 9984 | (interactive "p") | ||
| 9985 | (let (p m) | ||
| 9986 | (if (eq last-command this-command) | ||
| 9987 | (setq p (nthcdr n (or org-mark-ring-last-goto org-mark-ring))) | ||
| 9988 | (setq p org-mark-ring)) | ||
| 9989 | (setq org-mark-ring-last-goto p) | ||
| 9990 | (setq m (car p)) | ||
| 9991 | (switch-to-buffer (marker-buffer m)) | ||
| 9992 | (goto-char m) | ||
| 9993 | (if (or (org-invisible-p) (org-invisible-p2)) (org-show-context 'mark-goto)))) | ||
| 9994 | |||
| 9995 | (defun org-remove-angle-brackets (s) | ||
| 9996 | (if (equal (substring s 0 1) "<") (setq s (substring s 1))) | ||
| 9997 | (if (equal (substring s -1) ">") (setq s (substring s 0 -1))) | ||
| 9998 | s) | ||
| 9999 | (defun org-add-angle-brackets (s) | ||
| 10000 | (if (equal (substring s 0 1) "<") nil (setq s (concat "<" s))) | ||
| 10001 | (if (equal (substring s -1) ">") nil (setq s (concat s ">"))) | ||
| 10002 | s) | ||
| 10003 | |||
| 10004 | ;;; Following specific links | ||
| 10005 | |||
| 10006 | (defun org-follow-timestamp-link () | ||
| 10007 | (cond | ||
| 10008 | ((org-at-date-range-p t) | ||
| 10009 | (let ((org-agenda-start-on-weekday) | ||
| 10010 | (t1 (match-string 1)) | ||
| 10011 | (t2 (match-string 2))) | ||
| 10012 | (setq t1 (time-to-days (org-time-string-to-time t1)) | ||
| 10013 | t2 (time-to-days (org-time-string-to-time t2))) | ||
| 10014 | (org-agenda-list nil t1 (1+ (- t2 t1))))) | ||
| 10015 | ((org-at-timestamp-p t) | ||
| 10016 | (org-agenda-list nil (time-to-days (org-time-string-to-time | ||
| 10017 | (substring (match-string 1) 0 10))) | ||
| 10018 | 1)) | ||
| 10019 | (t (error "This should not happen")))) | ||
| 10020 | |||
| 10021 | |||
| 10022 | (defun org-follow-bbdb-link (name) | ||
| 10023 | "Follow a BBDB link to NAME." | ||
| 10024 | (require 'bbdb) | ||
| 10025 | (let ((inhibit-redisplay (not debug-on-error)) | ||
| 10026 | (bbdb-electric-p nil)) | ||
| 10027 | (catch 'exit | ||
| 10028 | ;; Exact match on name | ||
| 10029 | (bbdb-name (concat "\\`" name "\\'") nil) | ||
| 10030 | (if (< 0 (buffer-size (get-buffer "*BBDB*"))) (throw 'exit nil)) | ||
| 10031 | ;; Exact match on name | ||
| 10032 | (bbdb-company (concat "\\`" name "\\'") nil) | ||
| 10033 | (if (< 0 (buffer-size (get-buffer "*BBDB*"))) (throw 'exit nil)) | ||
| 10034 | ;; Partial match on name | ||
| 10035 | (bbdb-name name nil) | ||
| 10036 | (if (< 0 (buffer-size (get-buffer "*BBDB*"))) (throw 'exit nil)) | ||
| 10037 | ;; Partial match on company | ||
| 10038 | (bbdb-company name nil) | ||
| 10039 | (if (< 0 (buffer-size (get-buffer "*BBDB*"))) (throw 'exit nil)) | ||
| 10040 | ;; General match including network address and notes | ||
| 10041 | (bbdb name nil) | ||
| 10042 | (when (= 0 (buffer-size (get-buffer "*BBDB*"))) | ||
| 10043 | (delete-window (get-buffer-window "*BBDB*")) | ||
| 10044 | (error "No matching BBDB record"))))) | ||
| 10045 | |||
| 10046 | (defun org-follow-info-link (name) | ||
| 10047 | "Follow an info file & node link to NAME." | ||
| 10048 | (if (or (string-match "\\(.*\\)::?\\(.*\\)" name) | ||
| 10049 | (string-match "\\(.*\\)" name)) | ||
| 10050 | (progn | ||
| 10051 | (require 'info) | ||
| 10052 | (if (match-string 2 name) ; If there isn't a node, choose "Top" | ||
| 10053 | (Info-find-node (match-string 1 name) (match-string 2 name)) | ||
| 10054 | (Info-find-node (match-string 1 name) "Top"))) | ||
| 10055 | (message (concat "Could not open: " name)))) | ||
| 10056 | |||
| 10057 | (defun org-follow-gnus-link (&optional group article) | ||
| 10058 | "Follow a Gnus link to GROUP and ARTICLE." | ||
| 10059 | (require 'gnus) | ||
| 10060 | (funcall (cdr (assq 'gnus org-link-frame-setup))) | ||
| 10061 | (if gnus-other-frame-object (select-frame gnus-other-frame-object)) | ||
| 10062 | (cond ((and group article) | ||
| 10063 | (gnus-group-read-group 0 nil group) | ||
| 10064 | (gnus-summary-goto-article (string-to-number article) nil t)) | ||
| 10065 | (group (gnus-group-jump-to-group group)))) | ||
| 10066 | |||
| 10067 | (defun org-follow-vm-link (&optional folder article readonly) | ||
| 10068 | "Follow a VM link to FOLDER and ARTICLE." | ||
| 10069 | (require 'vm) | ||
| 10070 | (setq article (org-add-angle-brackets article)) | ||
| 10071 | (if (string-match "^//\\([a-zA-Z]+@\\)?\\([^:]+\\):\\(.*\\)" folder) | ||
| 10072 | ;; ange-ftp or efs or tramp access | ||
| 10073 | (let ((user (or (match-string 1 folder) (user-login-name))) | ||
| 10074 | (host (match-string 2 folder)) | ||
| 10075 | (file (match-string 3 folder))) | ||
| 10076 | (cond | ||
| 10077 | ((featurep 'tramp) | ||
| 10078 | ;; use tramp to access the file | ||
| 10079 | (if (featurep 'xemacs) | ||
| 10080 | (setq folder (format "[%s@%s]%s" user host file)) | ||
| 10081 | (setq folder (format "/%s@%s:%s" user host file)))) | ||
| 10082 | (t | ||
| 10083 | ;; use ange-ftp or efs | ||
| 10084 | (require (if (featurep 'xemacs) 'efs 'ange-ftp)) | ||
| 10085 | (setq folder (format "/%s@%s:%s" user host file)))))) | ||
| 10086 | (when folder | ||
| 10087 | (funcall (cdr (assq 'vm org-link-frame-setup)) folder readonly) | ||
| 10088 | (sit-for 0.1) | ||
| 10089 | (when article | ||
| 10090 | (vm-select-folder-buffer) | ||
| 5173 | (widen) | 10091 | (widen) |
| 5174 | (goto-char pos) | 10092 | (let ((case-fold-search t)) |
| 5175 | (org-show-context 'agenda) | 10093 | (goto-char (point-min)) |
| 5176 | (save-excursion | 10094 | (if (not (re-search-forward |
| 5177 | (and (outline-next-heading) | 10095 | (concat "^" "message-id: *" (regexp-quote article)))) |
| 5178 | (org-flag-heading nil))) ; show the next heading | 10096 | (error "Could not find the specified message in this folder")) |
| 5179 | (call-interactively 'org-toggle-archive-tag) | 10097 | (vm-isearch-update) |
| 5180 | (end-of-line 1) | 10098 | (vm-isearch-narrow) |
| 5181 | (setq newhead (org-get-heading))) | 10099 | (vm-beginning-of-message) |
| 5182 | (org-agenda-change-all-lines newhead hdmarker) | 10100 | (vm-summarize))))) |
| 5183 | (beginning-of-line 1))) | ||
| 5184 | 10101 | ||
| 5185 | ;;; Dynamic blocks | 10102 | (defun org-follow-wl-link (folder article) |
| 10103 | "Follow a Wanderlust link to FOLDER and ARTICLE." | ||
| 10104 | (if (and (string= folder "%") | ||
| 10105 | article | ||
| 10106 | (string-match "^\\([^#]+\\)\\(#\\(.*\\)\\)?" article)) | ||
| 10107 | ;; XXX: imap-uw supports folders starting with '#' such as "#mh/inbox". | ||
| 10108 | ;; Thus, we recompose folder and article ids. | ||
| 10109 | (setq folder (format "%s#%s" folder (match-string 1 article)) | ||
| 10110 | article (match-string 3 article))) | ||
| 10111 | (if (not (elmo-folder-exists-p (wl-folder-get-elmo-folder folder))) | ||
| 10112 | (error "No such folder: %s" folder)) | ||
| 10113 | (wl-summary-goto-folder-subr folder 'no-sync t nil t nil nil) | ||
| 10114 | (and article | ||
| 10115 | (wl-summary-jump-to-msg-by-message-id (org-add-angle-brackets article)) | ||
| 10116 | (wl-summary-redisplay))) | ||
| 10117 | |||
| 10118 | (defun org-follow-rmail-link (folder article) | ||
| 10119 | "Follow an RMAIL link to FOLDER and ARTICLE." | ||
| 10120 | (setq article (org-add-angle-brackets article)) | ||
| 10121 | (let (message-number) | ||
| 10122 | (save-excursion | ||
| 10123 | (save-window-excursion | ||
| 10124 | (rmail (if (string= folder "RMAIL") rmail-file-name folder)) | ||
| 10125 | (setq message-number | ||
| 10126 | (save-restriction | ||
| 10127 | (widen) | ||
| 10128 | (goto-char (point-max)) | ||
| 10129 | (if (re-search-backward | ||
| 10130 | (concat "^Message-ID:\\s-+" (regexp-quote | ||
| 10131 | (or article ""))) | ||
| 10132 | nil t) | ||
| 10133 | (rmail-what-message)))))) | ||
| 10134 | (if message-number | ||
| 10135 | (progn | ||
| 10136 | (rmail (if (string= folder "RMAIL") rmail-file-name folder)) | ||
| 10137 | (rmail-show-message message-number) | ||
| 10138 | message-number) | ||
| 10139 | (error "Message not found")))) | ||
| 10140 | |||
| 10141 | ;;; mh-e integration based on planner-mode | ||
| 10142 | (defun org-mhe-get-message-real-folder () | ||
| 10143 | "Return the name of the current message real folder, so if you use | ||
| 10144 | sequences, it will now work." | ||
| 10145 | (save-excursion | ||
| 10146 | (let* ((folder | ||
| 10147 | (if (equal major-mode 'mh-folder-mode) | ||
| 10148 | mh-current-folder | ||
| 10149 | ;; Refer to the show buffer | ||
| 10150 | mh-show-folder-buffer)) | ||
| 10151 | (end-index | ||
| 10152 | (if (boundp 'mh-index-folder) | ||
| 10153 | (min (length mh-index-folder) (length folder)))) | ||
| 10154 | ) | ||
| 10155 | ;; a simple test on mh-index-data does not work, because | ||
| 10156 | ;; mh-index-data is always nil in a show buffer. | ||
| 10157 | (if (and (boundp 'mh-index-folder) | ||
| 10158 | (string= mh-index-folder (substring folder 0 end-index))) | ||
| 10159 | (if (equal major-mode 'mh-show-mode) | ||
| 10160 | (save-window-excursion | ||
| 10161 | (when (buffer-live-p (get-buffer folder)) | ||
| 10162 | (progn | ||
| 10163 | (pop-to-buffer folder) | ||
| 10164 | (org-mhe-get-message-folder-from-index) | ||
| 10165 | ) | ||
| 10166 | )) | ||
| 10167 | (org-mhe-get-message-folder-from-index) | ||
| 10168 | ) | ||
| 10169 | folder | ||
| 10170 | ) | ||
| 10171 | ))) | ||
| 10172 | |||
| 10173 | (defun org-mhe-get-message-folder-from-index () | ||
| 10174 | "Returns the name of the message folder in a index folder buffer." | ||
| 10175 | (save-excursion | ||
| 10176 | (mh-index-previous-folder) | ||
| 10177 | (re-search-forward "^\\(+.*\\)$" nil t) | ||
| 10178 | (message (match-string 1)))) | ||
| 10179 | |||
| 10180 | (defun org-mhe-get-message-folder () | ||
| 10181 | "Return the name of the current message folder. Be careful if you | ||
| 10182 | use sequences." | ||
| 10183 | (save-excursion | ||
| 10184 | (if (equal major-mode 'mh-folder-mode) | ||
| 10185 | mh-current-folder | ||
| 10186 | ;; Refer to the show buffer | ||
| 10187 | mh-show-folder-buffer))) | ||
| 10188 | |||
| 10189 | (defun org-mhe-get-message-num () | ||
| 10190 | "Return the number of the current message. Be careful if you | ||
| 10191 | use sequences." | ||
| 10192 | (save-excursion | ||
| 10193 | (if (equal major-mode 'mh-folder-mode) | ||
| 10194 | (mh-get-msg-num nil) | ||
| 10195 | ;; Refer to the show buffer | ||
| 10196 | (mh-show-buffer-message-number)))) | ||
| 10197 | |||
| 10198 | (defun org-mhe-get-header (header) | ||
| 10199 | "Return a header of the message in folder mode. This will create a | ||
| 10200 | show buffer for the corresponding message. If you have a more clever | ||
| 10201 | idea..." | ||
| 10202 | (let* ((folder (org-mhe-get-message-folder)) | ||
| 10203 | (num (org-mhe-get-message-num)) | ||
| 10204 | (buffer (get-buffer-create (concat "show-" folder))) | ||
| 10205 | (header-field)) | ||
| 10206 | (with-current-buffer buffer | ||
| 10207 | (mh-display-msg num folder) | ||
| 10208 | (if (equal major-mode 'mh-folder-mode) | ||
| 10209 | (mh-header-display) | ||
| 10210 | (mh-show-header-display)) | ||
| 10211 | (set-buffer buffer) | ||
| 10212 | (setq header-field (mh-get-header-field header)) | ||
| 10213 | (if (equal major-mode 'mh-folder-mode) | ||
| 10214 | (mh-show) | ||
| 10215 | (mh-show-show)) | ||
| 10216 | header-field))) | ||
| 10217 | |||
| 10218 | (defun org-follow-mhe-link (folder article) | ||
| 10219 | "Follow an MHE link to FOLDER and ARTICLE. | ||
| 10220 | If ARTICLE is nil FOLDER is shown. If the configuration variable | ||
| 10221 | `org-mhe-search-all-folders' is t and `mh-searcher' is pick, | ||
| 10222 | ARTICLE is searched in all folders. Indexed searches (swish++, | ||
| 10223 | namazu, and others supported by MH-E) will always search in all | ||
| 10224 | folders." | ||
| 10225 | (require 'mh-e) | ||
| 10226 | (require 'mh-search) | ||
| 10227 | (require 'mh-utils) | ||
| 10228 | (mh-find-path) | ||
| 10229 | (if (not article) | ||
| 10230 | (mh-visit-folder (mh-normalize-folder-name folder)) | ||
| 10231 | (setq article (org-add-angle-brackets article)) | ||
| 10232 | (mh-search-choose) | ||
| 10233 | (if (equal mh-searcher 'pick) | ||
| 10234 | (progn | ||
| 10235 | (mh-search folder (list "--message-id" article)) | ||
| 10236 | (when (and org-mhe-search-all-folders | ||
| 10237 | (not (org-mhe-get-message-real-folder))) | ||
| 10238 | (kill-this-buffer) | ||
| 10239 | (mh-search "+" (list "--message-id" article)))) | ||
| 10240 | (mh-search "+" article)) | ||
| 10241 | (if (org-mhe-get-message-real-folder) | ||
| 10242 | (mh-show-msg 1) | ||
| 10243 | (kill-this-buffer) | ||
| 10244 | (error "Message not found")))) | ||
| 10245 | |||
| 10246 | ;;; BibTeX links | ||
| 10247 | |||
| 10248 | ;; Use the custom search meachnism to construct and use search strings for | ||
| 10249 | ;; file links to BibTeX database entries. | ||
| 10250 | |||
| 10251 | (defun org-create-file-search-in-bibtex () | ||
| 10252 | "Create the search string and description for a BibTeX database entry." | ||
| 10253 | (when (eq major-mode 'bibtex-mode) | ||
| 10254 | ;; yes, we want to construct this search string. | ||
| 10255 | ;; Make a good description for this entry, using names, year and the title | ||
| 10256 | ;; Put it into the `description' variable which is dynamically scoped. | ||
| 10257 | (let ((bibtex-autokey-names 1) | ||
| 10258 | (bibtex-autokey-names-stretch 1) | ||
| 10259 | (bibtex-autokey-name-case-convert-function 'identity) | ||
| 10260 | (bibtex-autokey-name-separator " & ") | ||
| 10261 | (bibtex-autokey-additional-names " et al.") | ||
| 10262 | (bibtex-autokey-year-length 4) | ||
| 10263 | (bibtex-autokey-name-year-separator " ") | ||
| 10264 | (bibtex-autokey-titlewords 3) | ||
| 10265 | (bibtex-autokey-titleword-separator " ") | ||
| 10266 | (bibtex-autokey-titleword-case-convert-function 'identity) | ||
| 10267 | (bibtex-autokey-titleword-length 'infty) | ||
| 10268 | (bibtex-autokey-year-title-separator ": ")) | ||
| 10269 | (setq description (bibtex-generate-autokey))) | ||
| 10270 | ;; Now parse the entry, get the key and return it. | ||
| 10271 | (save-excursion | ||
| 10272 | (bibtex-beginning-of-entry) | ||
| 10273 | (cdr (assoc "=key=" (bibtex-parse-entry)))))) | ||
| 10274 | |||
| 10275 | (defun org-execute-file-search-in-bibtex (s) | ||
| 10276 | "Find the link search string S as a key for a database entry." | ||
| 10277 | (when (eq major-mode 'bibtex-mode) | ||
| 10278 | ;; Yes, we want to do the search in this file. | ||
| 10279 | ;; We construct a regexp that searches for "@entrytype{" followed by the key | ||
| 10280 | (goto-char (point-min)) | ||
| 10281 | (and (re-search-forward (concat "@[a-zA-Z]+[ \t\n]*{[ \t\n]*" | ||
| 10282 | (regexp-quote s) "[ \t\n]*,") nil t) | ||
| 10283 | (goto-char (match-beginning 0))) | ||
| 10284 | (if (and (match-beginning 0) (equal current-prefix-arg '(16))) | ||
| 10285 | ;; Use double prefix to indicate that any web link should be browsed | ||
| 10286 | (let ((b (current-buffer)) (p (point))) | ||
| 10287 | ;; Restore the window configuration because we just use the web link | ||
| 10288 | (set-window-configuration org-window-config-before-follow-link) | ||
| 10289 | (save-excursion (set-buffer b) (goto-char p) | ||
| 10290 | (bibtex-url))) | ||
| 10291 | (recenter 0)) ; Move entry start to beginning of window | ||
| 10292 | ;; return t to indicate that the search is done. | ||
| 10293 | t)) | ||
| 10294 | |||
| 10295 | ;; Finally add the functions to the right hooks. | ||
| 10296 | (add-hook 'org-create-file-search-functions 'org-create-file-search-in-bibtex) | ||
| 10297 | (add-hook 'org-execute-file-search-functions 'org-execute-file-search-in-bibtex) | ||
| 10298 | |||
| 10299 | ;; end of Bibtex link setup | ||
| 10300 | |||
| 10301 | ;;; Following file links | ||
| 10302 | |||
| 10303 | (defun org-open-file (path &optional in-emacs line search) | ||
| 10304 | "Open the file at PATH. | ||
| 10305 | First, this expands any special file name abbreviations. Then the | ||
| 10306 | configuration variable `org-file-apps' is checked if it contains an | ||
| 10307 | entry for this file type, and if yes, the corresponding command is launched. | ||
| 10308 | If no application is found, Emacs simply visits the file. | ||
| 10309 | With optional argument IN-EMACS, Emacs will visit the file. | ||
| 10310 | Optional LINE specifies a line to go to, optional SEARCH a string to | ||
| 10311 | search for. If LINE or SEARCH is given, the file will always be | ||
| 10312 | opened in Emacs. | ||
| 10313 | If the file does not exist, an error is thrown." | ||
| 10314 | (setq in-emacs (or in-emacs line search)) | ||
| 10315 | (let* ((file (if (equal path "") | ||
| 10316 | buffer-file-name | ||
| 10317 | (substitute-in-file-name (expand-file-name path)))) | ||
| 10318 | (apps (append org-file-apps (org-default-apps))) | ||
| 10319 | (remp (and (assq 'remote apps) (org-file-remote-p file))) | ||
| 10320 | (dirp (if remp nil (file-directory-p file))) | ||
| 10321 | (dfile (downcase file)) | ||
| 10322 | (old-buffer (current-buffer)) | ||
| 10323 | (old-pos (point)) | ||
| 10324 | (old-mode major-mode) | ||
| 10325 | ext cmd) | ||
| 10326 | (if (string-match "^.*\\.\\([a-zA-Z0-9]+\\.gz\\)$" dfile) | ||
| 10327 | (setq ext (match-string 1 dfile)) | ||
| 10328 | (if (string-match "^.*\\.\\([a-zA-Z0-9]+\\)$" dfile) | ||
| 10329 | (setq ext (match-string 1 dfile)))) | ||
| 10330 | (if in-emacs | ||
| 10331 | (setq cmd 'emacs) | ||
| 10332 | (setq cmd (or (and remp (cdr (assoc 'remote apps))) | ||
| 10333 | (and dirp (cdr (assoc 'directory apps))) | ||
| 10334 | (cdr (assoc ext apps)) | ||
| 10335 | (cdr (assoc t apps))))) | ||
| 10336 | (when (eq cmd 'mailcap) | ||
| 10337 | (require 'mailcap) | ||
| 10338 | (mailcap-parse-mailcaps) | ||
| 10339 | (let* ((mime-type (mailcap-extension-to-mime (or ext ""))) | ||
| 10340 | (command (mailcap-mime-info mime-type))) | ||
| 10341 | (if (stringp command) | ||
| 10342 | (setq cmd command) | ||
| 10343 | (setq cmd 'emacs)))) | ||
| 10344 | (if (and (not (eq cmd 'emacs)) ; Emacs has not problems with non-ex files | ||
| 10345 | (not (file-exists-p file)) | ||
| 10346 | (not org-open-non-existing-files)) | ||
| 10347 | (error "No such file: %s" file)) | ||
| 10348 | (cond | ||
| 10349 | ((and (stringp cmd) (not (string-match "^\\s-*$" cmd))) | ||
| 10350 | ;; Remove quotes around the file name - we'll use shell-quote-argument. | ||
| 10351 | (if (string-match "['\"]%s['\"]" cmd) | ||
| 10352 | (setq cmd (replace-match "%s" t t cmd))) | ||
| 10353 | (setq cmd (format cmd (shell-quote-argument file))) | ||
| 10354 | (save-window-excursion | ||
| 10355 | (shell-command (concat cmd " &")))) | ||
| 10356 | ((or (stringp cmd) | ||
| 10357 | (eq cmd 'emacs)) | ||
| 10358 | (funcall (cdr (assq 'file org-link-frame-setup)) file) | ||
| 10359 | (if line (goto-line line) | ||
| 10360 | (if search (org-link-search search)))) | ||
| 10361 | ((consp cmd) | ||
| 10362 | (eval cmd)) | ||
| 10363 | (t (funcall (cdr (assq 'file org-link-frame-setup)) file))) | ||
| 10364 | (and (org-mode-p) (eq old-mode 'org-mode) | ||
| 10365 | (or (not (equal old-buffer (current-buffer))) | ||
| 10366 | (not (equal old-pos (point)))) | ||
| 10367 | (org-mark-ring-push old-pos old-buffer)))) | ||
| 10368 | |||
| 10369 | (defun org-default-apps () | ||
| 10370 | "Return the default applications for this operating system." | ||
| 10371 | (cond | ||
| 10372 | ((eq system-type 'darwin) | ||
| 10373 | org-file-apps-defaults-macosx) | ||
| 10374 | ((eq system-type 'windows-nt) | ||
| 10375 | org-file-apps-defaults-windowsnt) | ||
| 10376 | (t org-file-apps-defaults-gnu))) | ||
| 10377 | |||
| 10378 | (defun org-expand-file-name (path) | ||
| 10379 | "Replace special path abbreviations and expand the file name." | ||
| 10380 | (expand-file-name path)) | ||
| 10381 | |||
| 10382 | (defvar ange-ftp-name-format) ; to silence the XEmacs compiler. | ||
| 10383 | (defun org-file-remote-p (file) | ||
| 10384 | "Test whether FILE specifies a location on a remote system. | ||
| 10385 | Return non-nil if the location is indeed remote. | ||
| 10386 | |||
| 10387 | For example, the filename \"/user@host:/foo\" specifies a location | ||
| 10388 | on the system \"/user@host:\"." | ||
| 10389 | (cond ((fboundp 'file-remote-p) | ||
| 10390 | (file-remote-p file)) | ||
| 10391 | ((fboundp 'tramp-handle-file-remote-p) | ||
| 10392 | (tramp-handle-file-remote-p file)) | ||
| 10393 | ((and (boundp 'ange-ftp-name-format) | ||
| 10394 | (string-match (car ange-ftp-name-format) file)) | ||
| 10395 | t) | ||
| 10396 | (t nil))) | ||
| 10397 | |||
| 10398 | |||
| 10399 | ;;;; Hooks for remember.el | ||
| 10400 | |||
| 10401 | ;;;###autoload | ||
| 10402 | (defun org-remember-annotation () | ||
| 10403 | "Return a link to the current location as an annotation for remember.el. | ||
| 10404 | If you are using Org-mode files as target for data storage with | ||
| 10405 | remember.el, then the annotations should include a link compatible with the | ||
| 10406 | conventions in Org-mode. This function returns such a link." | ||
| 10407 | (org-store-link nil)) | ||
| 10408 | |||
| 10409 | (defconst org-remember-help | ||
| 10410 | "Select a destination location for the note. | ||
| 10411 | UP/DOWN=headline TAB=cycle visibility [Q]uit RET/<left>/<right>=Store | ||
| 10412 | RET at beg-of-buf -> Append to file as level 2 headline | ||
| 10413 | RET on headline -> Store as sublevel entry to current headline | ||
| 10414 | <left>/<right> -> before/after current headline, same headings level") | ||
| 10415 | |||
| 10416 | ;;;###autoload | ||
| 10417 | (defun org-remember-apply-template (&optional use-char skip-interactive) | ||
| 10418 | "Initialize *remember* buffer with template, invoke `org-mode'. | ||
| 10419 | This function should be placed into `remember-mode-hook' and in fact requires | ||
| 10420 | to be run from that hook to fucntion properly." | ||
| 10421 | (if org-remember-templates | ||
| 10422 | |||
| 10423 | (let* ((char (or use-char | ||
| 10424 | (if (= (length org-remember-templates) 1) | ||
| 10425 | (caar org-remember-templates) | ||
| 10426 | (message "Select template: %s" | ||
| 10427 | (mapconcat | ||
| 10428 | (lambda (x) (char-to-string (car x))) | ||
| 10429 | org-remember-templates " ")) | ||
| 10430 | (read-char-exclusive)))) | ||
| 10431 | (entry (cdr (assoc char org-remember-templates))) | ||
| 10432 | (tpl (car entry)) | ||
| 10433 | (plist-p (if org-store-link-plist t nil)) | ||
| 10434 | (file (if (and (nth 1 entry) (stringp (nth 1 entry)) | ||
| 10435 | (string-match "\\S-" (nth 1 entry))) | ||
| 10436 | (nth 1 entry) | ||
| 10437 | org-default-notes-file)) | ||
| 10438 | (headline (nth 2 entry)) | ||
| 10439 | (v-t (format-time-string (car org-time-stamp-formats) (org-current-time))) | ||
| 10440 | (v-T (format-time-string (cdr org-time-stamp-formats) (org-current-time))) | ||
| 10441 | (v-u (concat "[" (substring v-t 1 -1) "]")) | ||
| 10442 | (v-U (concat "[" (substring v-T 1 -1) "]")) | ||
| 10443 | (v-i initial) ; defined in `remember-mode' | ||
| 10444 | (v-a (if (equal annotation "[[]]") "" annotation)) ; likewise | ||
| 10445 | (v-n user-full-name) | ||
| 10446 | (org-startup-folded nil) | ||
| 10447 | org-time-was-given x prompt char time) | ||
| 10448 | (setq org-store-link-plist | ||
| 10449 | (append (list :annotation v-a :initial v-i))) | ||
| 10450 | (unless tpl (setq tpl "") (message "No template") (ding)) | ||
| 10451 | (erase-buffer) | ||
| 10452 | (insert (substitute-command-keys | ||
| 10453 | (format | ||
| 10454 | "## `C-c C-c' to file interactively, `C-u C-c C-c' to file directly. | ||
| 10455 | ## Target file \"%s\", headline \"%s\" | ||
| 10456 | ## To switch templates, use `\\[org-remember]'.\n\n" | ||
| 10457 | (abbreviate-file-name (or file org-default-notes-file)) | ||
| 10458 | (or headline "")))) | ||
| 10459 | (insert tpl) (goto-char (point-min)) | ||
| 10460 | ;; Simple %-escapes | ||
| 10461 | (while (re-search-forward "%\\([tTuUai]\\)" nil t) | ||
| 10462 | (when (and initial (equal (match-string 0) "%i")) | ||
| 10463 | (save-match-data | ||
| 10464 | (let* ((lead (buffer-substring | ||
| 10465 | (point-at-bol) (match-beginning 0)))) | ||
| 10466 | (setq v-i (mapconcat 'identity | ||
| 10467 | (org-split-string initial "\n") | ||
| 10468 | (concat "\n" lead)))))) | ||
| 10469 | (replace-match | ||
| 10470 | (or (eval (intern (concat "v-" (match-string 1)))) "") | ||
| 10471 | t t)) | ||
| 10472 | ;; From the property list | ||
| 10473 | (when plist-p | ||
| 10474 | (goto-char (point-min)) | ||
| 10475 | (while (re-search-forward "%\\(:[-a-zA-Z]+\\)" nil t) | ||
| 10476 | (and (setq x (plist-get org-store-link-plist | ||
| 10477 | (intern (match-string 1)))) | ||
| 10478 | (replace-match x t t)))) | ||
| 10479 | ;; Turn on org-mode in the remember buffer, set local variables | ||
| 10480 | (org-mode) | ||
| 10481 | (org-set-local 'org-finish-function 'remember-buffer) | ||
| 10482 | (if (and file (string-match "\\S-" file) (not (file-directory-p file))) | ||
| 10483 | (org-set-local 'org-default-notes-file file)) | ||
| 10484 | (if (and headline (stringp headline) (string-match "\\S-" headline)) | ||
| 10485 | (org-set-local 'org-remember-default-headline headline)) | ||
| 10486 | ;; Interactive template entries | ||
| 10487 | (goto-char (point-min)) | ||
| 10488 | (while (re-search-forward "%^\\({\\([^}]*\\)}\\)?\\([uUtT]\\)?" nil t) | ||
| 10489 | (setq char (if (match-end 3) (match-string 3)) | ||
| 10490 | prompt (if (match-end 2) (match-string 2))) | ||
| 10491 | (goto-char (match-beginning 0)) | ||
| 10492 | (replace-match "") | ||
| 10493 | (if char | ||
| 10494 | (progn | ||
| 10495 | (setq org-time-was-given (equal (upcase char) char)) | ||
| 10496 | (setq time (org-read-date (equal (upcase char) "U") t nil | ||
| 10497 | prompt)) | ||
| 10498 | (org-insert-time-stamp time org-time-was-given | ||
| 10499 | (member char '("u" "U")))) | ||
| 10500 | (insert (read-string | ||
| 10501 | (if prompt (concat prompt ": ") "Enter string"))))) | ||
| 10502 | (goto-char (point-min)) | ||
| 10503 | (if (re-search-forward "%\\?" nil t) | ||
| 10504 | (replace-match "") | ||
| 10505 | (and (re-search-forward "^[^#\n]" nil t) (backward-char 1)))) | ||
| 10506 | (org-mode) | ||
| 10507 | (org-set-local 'org-finish-function 'remember-buffer))) | ||
| 10508 | |||
| 10509 | ;;;###autoload | ||
| 10510 | (defun org-remember () | ||
| 10511 | "Call `remember'. If this is already a remember buffer, re-apply template. | ||
| 10512 | If there is an active region, make sure remember uses it as initial content | ||
| 10513 | of the remember buffer." | ||
| 10514 | (interactive) | ||
| 10515 | (if (eq org-finish-function 'remember-buffer) | ||
| 10516 | (progn | ||
| 10517 | (when (< (length org-remember-templates) 2) | ||
| 10518 | (error "No other template available")) | ||
| 10519 | (erase-buffer) | ||
| 10520 | (let ((annotation (plist-get org-store-link-plist :annotation)) | ||
| 10521 | (initial (plist-get org-store-link-plist :initial))) | ||
| 10522 | (org-remember-apply-template)) | ||
| 10523 | (message "Press C-c C-c to remember data")) | ||
| 10524 | (if (org-region-active-p) | ||
| 10525 | (remember (buffer-substring (point) (mark))) | ||
| 10526 | (call-interactively 'remember)))) | ||
| 10527 | |||
| 10528 | ;;;###autoload | ||
| 10529 | (defun org-remember-handler () | ||
| 10530 | "Store stuff from remember.el into an org file. | ||
| 10531 | First prompts for an org file. If the user just presses return, the value | ||
| 10532 | of `org-default-notes-file' is used. | ||
| 10533 | Then the command offers the headings tree of the selected file in order to | ||
| 10534 | file the text at a specific location. | ||
| 10535 | You can either immediately press RET to get the note appended to the | ||
| 10536 | file, or you can use vertical cursor motion and visibility cycling (TAB) to | ||
| 10537 | find a better place. Then press RET or <left> or <right> in insert the note. | ||
| 10538 | |||
| 10539 | Key Cursor position Note gets inserted | ||
| 10540 | ----------------------------------------------------------------------------- | ||
| 10541 | RET buffer-start as level 2 heading at end of file | ||
| 10542 | RET on headline as sublevel of the heading at cursor | ||
| 10543 | RET no heading at cursor position, level taken from context. | ||
| 10544 | Or use prefix arg to specify level manually. | ||
| 10545 | <left> on headline as same level, before current heading | ||
| 10546 | <right> on headline as same level, after current heading | ||
| 10547 | |||
| 10548 | So the fastest way to store the note is to press RET RET to append it to | ||
| 10549 | the default file. This way your current train of thought is not | ||
| 10550 | interrupted, in accordance with the principles of remember.el. But with | ||
| 10551 | little extra effort, you can push it directly to the correct location. | ||
| 10552 | |||
| 10553 | Before being stored away, the function ensures that the text has a | ||
| 10554 | headline, i.e. a first line that starts with a \"*\". If not, a headline | ||
| 10555 | is constructed from the current date and some additional data. | ||
| 10556 | |||
| 10557 | If the variable `org-adapt-indentation' is non-nil, the entire text is | ||
| 10558 | also indented so that it starts in the same column as the headline | ||
| 10559 | \(i.e. after the stars). | ||
| 10560 | |||
| 10561 | See also the variable `org-reverse-note-order'." | ||
| 10562 | (goto-char (point-min)) | ||
| 10563 | (while (looking-at "^[ \t]*\n\\|^##.*\n") | ||
| 10564 | (replace-match "")) | ||
| 10565 | (catch 'quit | ||
| 10566 | (let* ((txt (buffer-substring (point-min) (point-max))) | ||
| 10567 | (fastp current-prefix-arg) | ||
| 10568 | (file (if fastp org-default-notes-file (org-get-org-file))) | ||
| 10569 | (heading org-remember-default-headline) | ||
| 10570 | (visiting (org-find-base-buffer-visiting file)) | ||
| 10571 | (org-startup-folded nil) | ||
| 10572 | (org-startup-align-all-tables nil) | ||
| 10573 | (org-goto-start-pos 1) | ||
| 10574 | spos level indent reversed) | ||
| 10575 | ;; Modify text so that it becomes a nice subtree which can be inserted | ||
| 10576 | ;; into an org tree. | ||
| 10577 | (let* ((lines (split-string txt "\n")) | ||
| 10578 | first) | ||
| 10579 | (setq first (car lines) lines (cdr lines)) | ||
| 10580 | (if (string-match "^\\*+" first) | ||
| 10581 | ;; Is already a headline | ||
| 10582 | (setq indent nil) | ||
| 10583 | ;; We need to add a headline: Use time and first buffer line | ||
| 10584 | (setq lines (cons first lines) | ||
| 10585 | first (concat "* " (current-time-string) | ||
| 10586 | " (" (remember-buffer-desc) ")") | ||
| 10587 | indent " ")) | ||
| 10588 | (if (and org-adapt-indentation indent) | ||
| 10589 | (setq lines (mapcar (lambda (x) (concat indent x)) lines))) | ||
| 10590 | (setq txt (concat first "\n" | ||
| 10591 | (mapconcat 'identity lines "\n")))) | ||
| 10592 | ;; Find the file | ||
| 10593 | (if (not visiting) (find-file-noselect file)) | ||
| 10594 | (with-current-buffer (or visiting (get-file-buffer file)) | ||
| 10595 | (save-excursion (and (goto-char (point-min)) | ||
| 10596 | (not (re-search-forward "^\\* " nil t)) | ||
| 10597 | (insert "\n* Notes\n"))) | ||
| 10598 | (setq reversed (org-notes-order-reversed-p)) | ||
| 10599 | (save-excursion | ||
| 10600 | (save-restriction | ||
| 10601 | (widen) | ||
| 10602 | |||
| 10603 | ;; Find the default location | ||
| 10604 | (when (and heading (stringp heading) (string-match "\\S-" heading)) | ||
| 10605 | (goto-char (point-min)) | ||
| 10606 | (if (re-search-forward | ||
| 10607 | (concat "^\\*+[ \t]+" (regexp-quote heading) | ||
| 10608 | "\\([ \t]+:[@a-zA-Z0-9_:]*\\)?[ \t]*$") | ||
| 10609 | nil t) | ||
| 10610 | (setq org-goto-start-pos (match-beginning 0)))) | ||
| 10611 | |||
| 10612 | ;; Ask the User for a location | ||
| 10613 | (setq spos (if fastp | ||
| 10614 | org-goto-start-pos | ||
| 10615 | (org-get-location (current-buffer) org-remember-help))) | ||
| 10616 | (if (not spos) (throw 'quit nil)) ; return nil to show we did | ||
| 10617 | ; not handle this note | ||
| 10618 | (goto-char spos) | ||
| 10619 | (cond ((and (bobp) (not reversed)) | ||
| 10620 | ;; Put it at the end, one level below level 1 | ||
| 10621 | (save-restriction | ||
| 10622 | (widen) | ||
| 10623 | (goto-char (point-max)) | ||
| 10624 | (if (not (bolp)) (newline)) | ||
| 10625 | (org-paste-subtree (org-get-legal-level 1 1) txt))) | ||
| 10626 | ((and (bobp) reversed) | ||
| 10627 | ;; Put it at the start, as level 1 | ||
| 10628 | (save-restriction | ||
| 10629 | (widen) | ||
| 10630 | (goto-char (point-min)) | ||
| 10631 | (re-search-forward "^\\*" nil t) | ||
| 10632 | (beginning-of-line 1) | ||
| 10633 | (org-paste-subtree 1 txt))) | ||
| 10634 | ((and (org-on-heading-p nil) (not current-prefix-arg)) | ||
| 10635 | ;; Put it below this entry, at the beg/end of the subtree | ||
| 10636 | (org-back-to-heading t) | ||
| 10637 | (setq level (funcall outline-level)) | ||
| 10638 | (if reversed | ||
| 10639 | (outline-end-of-heading) | ||
| 10640 | (org-end-of-subtree t)) | ||
| 10641 | (if (not (bolp)) (newline)) | ||
| 10642 | (beginning-of-line 1) | ||
| 10643 | (org-paste-subtree (org-get-legal-level level 1) txt)) | ||
| 10644 | (t | ||
| 10645 | ;; Put it right there, with automatic level determined by | ||
| 10646 | ;; org-paste-subtree or from prefix arg | ||
| 10647 | (org-paste-subtree current-prefix-arg txt))) | ||
| 10648 | (when remember-save-after-remembering | ||
| 10649 | (save-buffer) | ||
| 10650 | (if (not visiting) (kill-buffer (current-buffer))))))))) | ||
| 10651 | t) ;; return t to indicate that we took care of this note. | ||
| 10652 | |||
| 10653 | (defun org-get-org-file () | ||
| 10654 | "Read a filename, with default directory `org-directory'." | ||
| 10655 | (let ((default (or org-default-notes-file remember-data-file))) | ||
| 10656 | (read-file-name (format "File name [%s]: " default) | ||
| 10657 | (file-name-as-directory org-directory) | ||
| 10658 | default))) | ||
| 10659 | |||
| 10660 | (defun org-notes-order-reversed-p () | ||
| 10661 | "Check if the current file should receive notes in reversed order." | ||
| 10662 | (cond | ||
| 10663 | ((not org-reverse-note-order) nil) | ||
| 10664 | ((eq t org-reverse-note-order) t) | ||
| 10665 | ((not (listp org-reverse-note-order)) nil) | ||
| 10666 | (t (catch 'exit | ||
| 10667 | (let ((all org-reverse-note-order) | ||
| 10668 | entry) | ||
| 10669 | (while (setq entry (pop all)) | ||
| 10670 | (if (string-match (car entry) buffer-file-name) | ||
| 10671 | (throw 'exit (cdr entry)))) | ||
| 10672 | nil))))) | ||
| 10673 | |||
| 10674 | ;;;; Dynamic blocks | ||
| 5186 | 10675 | ||
| 5187 | (defun org-find-dblock (name) | 10676 | (defun org-find-dblock (name) |
| 5188 | "Find the first dynamic block with name NAME in the buffer. | 10677 | "Find the first dynamic block with name NAME in the buffer. |
| @@ -5292,7 +10781,7 @@ This function can be used in a hook." | |||
| 5292 | (org-map-dblocks 'org-update-dblock))) | 10781 | (org-map-dblocks 'org-update-dblock))) |
| 5293 | 10782 | ||
| 5294 | 10783 | ||
| 5295 | ;;; Completion | 10784 | ;;;; Completion |
| 5296 | 10785 | ||
| 5297 | (defun org-complete (&optional arg) | 10786 | (defun org-complete (&optional arg) |
| 5298 | "Perform completion on word at point. | 10787 | "Perform completion on word at point. |
| @@ -5314,7 +10803,7 @@ At all other locations, this simply calls `ispell-complete-word'." | |||
| 5314 | (skip-chars-backward "a-zA-Z0-9_:$") | 10803 | (skip-chars-backward "a-zA-Z0-9_:$") |
| 5315 | (point))) | 10804 | (point))) |
| 5316 | (confirm (lambda (x) (stringp (car x)))) | 10805 | (confirm (lambda (x) (stringp (car x)))) |
| 5317 | (camel (equal (char-before beg) ?*)) | 10806 | (searchhead (equal (char-before beg) ?*)) |
| 5318 | (tag (equal (char-before beg1) ?:)) | 10807 | (tag (equal (char-before beg1) ?:)) |
| 5319 | (texp (equal (char-before beg) ?\\)) | 10808 | (texp (equal (char-before beg) ?\\)) |
| 5320 | (link (equal (char-before beg) ?\[)) | 10809 | (link (equal (char-before beg) ?\[)) |
| @@ -5345,16 +10834,14 @@ At all other locations, this simply calls `ispell-complete-word'." | |||
| 5345 | (buffer-substring (point-at-bol) beg)) | 10834 | (buffer-substring (point-at-bol) beg)) |
| 5346 | (setq type :todo) | 10835 | (setq type :todo) |
| 5347 | (mapcar 'list org-todo-keywords)) | 10836 | (mapcar 'list org-todo-keywords)) |
| 5348 | (camel | 10837 | (searchhead |
| 5349 | (setq type :camel) | 10838 | (setq type :searchhead) |
| 5350 | (save-excursion | 10839 | (save-excursion |
| 5351 | (goto-char (point-min)) | 10840 | (goto-char (point-min)) |
| 5352 | (while (re-search-forward org-todo-line-regexp nil t) | 10841 | (while (re-search-forward org-todo-line-regexp nil t) |
| 5353 | (push (list | 10842 | (push (list |
| 5354 | (if org-file-link-context-use-camel-case | 10843 | (org-make-org-heading-search-string |
| 5355 | (org-make-org-heading-camel (match-string 3) t) | 10844 | (match-string 3) t)) |
| 5356 | (org-make-org-heading-search-string | ||
| 5357 | (match-string 3) t))) | ||
| 5358 | tbl))) | 10845 | tbl))) |
| 5359 | tbl) | 10846 | tbl) |
| 5360 | (tag (setq type :tag beg beg1) | 10847 | (tag (setq type :tag beg beg1) |
| @@ -5365,7 +10852,8 @@ At all other locations, this simply calls `ispell-complete-word'." | |||
| 5365 | (cond ((eq completion t) | 10852 | (cond ((eq completion t) |
| 5366 | (if (equal type :opt) | 10853 | (if (equal type :opt) |
| 5367 | (insert (substring (cdr (assoc (upcase pattern) table)) | 10854 | (insert (substring (cdr (assoc (upcase pattern) table)) |
| 5368 | (length pattern))))) | 10855 | (length pattern))) |
| 10856 | (if (equal type :tag) (insert ":")))) | ||
| 5369 | ((null completion) | 10857 | ((null completion) |
| 5370 | (message "Can't find completion for \"%s\"" pattern) | 10858 | (message "Can't find completion for \"%s\"" pattern) |
| 5371 | (ding)) | 10859 | (ding)) |
| @@ -5393,7 +10881,7 @@ At all other locations, this simply calls `ispell-complete-word'." | |||
| 5393 | (error (display-completion-list list))))) | 10881 | (error (display-completion-list list))))) |
| 5394 | (message "Making completion list...%s" "done")))))) | 10882 | (message "Making completion list...%s" "done")))))) |
| 5395 | 10883 | ||
| 5396 | ;;; Comments, TODO and DEADLINE | 10884 | ;;;; TODO, DEADLINE, Comments |
| 5397 | 10885 | ||
| 5398 | (defun org-toggle-comment () | 10886 | (defun org-toggle-comment () |
| 5399 | "Change the COMMENT state of an entry." | 10887 | "Change the COMMENT state of an entry." |
| @@ -5426,8 +10914,15 @@ So for this example: when the item starts with TODO, it is changed to DONE. | |||
| 5426 | When it starts with DONE, the DONE is removed. And when neither TODO nor | 10914 | When it starts with DONE, the DONE is removed. And when neither TODO nor |
| 5427 | DONE are present, add TODO at the beginning of the heading. | 10915 | DONE are present, add TODO at the beginning of the heading. |
| 5428 | 10916 | ||
| 5429 | With prefix arg, use completion to determine the new state. With numeric | 10917 | With C-u prefix arg, use completion to determine the new state. |
| 5430 | prefix arg, switch to that state." | 10918 | With numeric prefix arg, switch to that state. |
| 10919 | |||
| 10920 | For calling through lisp, arg is also interpreted in the following way: | ||
| 10921 | 'none -> empty state | ||
| 10922 | \"\"(empty string) -> switch to empty state | ||
| 10923 | 'done -> switch to DONE | ||
| 10924 | \"WAITING\" -> switch to the specified keyword, but only if it | ||
| 10925 | really is a member of `org-todo-keywords'." | ||
| 5431 | (interactive "P") | 10926 | (interactive "P") |
| 5432 | (save-excursion | 10927 | (save-excursion |
| 5433 | (org-back-to-heading) | 10928 | (org-back-to-heading) |
| @@ -5435,6 +10930,7 @@ prefix arg, switch to that state." | |||
| 5435 | (or (looking-at (concat " +" org-todo-regexp " *")) | 10930 | (or (looking-at (concat " +" org-todo-regexp " *")) |
| 5436 | (looking-at " *")) | 10931 | (looking-at " *")) |
| 5437 | (let* ((this (match-string 1)) | 10932 | (let* ((this (match-string 1)) |
| 10933 | (last-state (or this "")) | ||
| 5438 | (completion-ignore-case t) | 10934 | (completion-ignore-case t) |
| 5439 | (member (member this org-todo-keywords)) | 10935 | (member (member this org-todo-keywords)) |
| 5440 | (tail (cdr member)) | 10936 | (tail (cdr member)) |
| @@ -5457,8 +10953,13 @@ prefix arg, switch to that state." | |||
| 5457 | org-done-string))) | 10953 | org-done-string))) |
| 5458 | (arg | 10954 | (arg |
| 5459 | ;; user requests a specific state | 10955 | ;; user requests a specific state |
| 5460 | (nth (1- (prefix-numeric-value arg)) | 10956 | (cond |
| 5461 | org-todo-keywords)) | 10957 | ((equal arg "") nil) |
| 10958 | ((eq arg 'none) nil) | ||
| 10959 | ((eq arg 'done) (org-last org-todo-keywords)) | ||
| 10960 | ((car (member arg org-todo-keywords))) | ||
| 10961 | ((nth (1- (prefix-numeric-value arg)) | ||
| 10962 | org-todo-keywords)))) | ||
| 5462 | ((null member) (car org-todo-keywords)) | 10963 | ((null member) (car org-todo-keywords)) |
| 5463 | ((null tail) nil) ;; -> first entry | 10964 | ((null tail) nil) ;; -> first entry |
| 5464 | ((eq org-todo-interpretation 'sequence) | 10965 | ((eq org-todo-interpretation 'sequence) |
| @@ -5468,18 +10969,30 @@ prefix arg, switch to that state." | |||
| 5468 | (car tail) | 10969 | (car tail) |
| 5469 | (if (> (length tail) 0) org-done-string nil))) | 10970 | (if (> (length tail) 0) org-done-string nil))) |
| 5470 | (t nil))) | 10971 | (t nil))) |
| 5471 | (next (if state (concat " " state " ") " "))) | 10972 | (next (if state (concat " " state " ") " ")) |
| 10973 | dostates) | ||
| 5472 | (replace-match next t t) | 10974 | (replace-match next t t) |
| 5473 | (setq org-last-todo-state-is-todo | 10975 | (setq org-last-todo-state-is-todo |
| 5474 | (not (equal state org-done-string))) | 10976 | (not (equal state org-done-string))) |
| 5475 | (when org-log-done | 10977 | (when org-log-done |
| 5476 | (if (equal state org-done-string) | 10978 | (setq dostates (and (eq org-todo-interpretation 'sequence) |
| 5477 | (org-add-planning-info 'closed (org-current-time) 'scheduled) | 10979 | (listp org-log-done) (memq 'state org-log-done))) |
| 5478 | (if (not this) | 10980 | (cond |
| 5479 | (org-add-planning-info nil nil 'closed)))) | 10981 | ((and state (not this)) |
| 10982 | (org-add-planning-info nil nil 'closed) | ||
| 10983 | (and dostates (org-add-log-maybe 'state state 'findpos))) | ||
| 10984 | ((and state dostates) | ||
| 10985 | (org-add-log-maybe 'state state 'findpos)) | ||
| 10986 | ((equal state org-done-string) | ||
| 10987 | ;; Planning info calls the note-setting command. | ||
| 10988 | (org-add-planning-info 'closed (org-current-time) | ||
| 10989 | (if (org-get-repeat) nil 'scheduled)) | ||
| 10990 | (org-add-log-maybe 'done state 'findpos)))) | ||
| 5480 | ;; Fixup tag positioning | 10991 | ;; Fixup tag positioning |
| 5481 | (and org-auto-align-tags (org-set-tags nil t)) | 10992 | (and org-auto-align-tags (org-set-tags nil t)) |
| 5482 | (run-hooks 'org-after-todo-state-change-hook))) | 10993 | (run-hooks 'org-after-todo-state-change-hook) |
| 10994 | (and (equal state org-done-string) (org-auto-repeat-maybe)) | ||
| 10995 | )) | ||
| 5483 | ;; Fixup cursor location if close to the keyword | 10996 | ;; Fixup cursor location if close to the keyword |
| 5484 | (if (and (outline-on-heading-p) | 10997 | (if (and (outline-on-heading-p) |
| 5485 | (not (bolp)) | 10998 | (not (bolp)) |
| @@ -5490,6 +11003,54 @@ prefix arg, switch to that state." | |||
| 5490 | (goto-char (or (match-end 2) (match-end 1))) | 11003 | (goto-char (or (match-end 2) (match-end 1))) |
| 5491 | (just-one-space)))) | 11004 | (just-one-space)))) |
| 5492 | 11005 | ||
| 11006 | (defun org-get-repeat () | ||
| 11007 | "Return the REPEAT statement of this entry." | ||
| 11008 | (save-match-data | ||
| 11009 | (save-excursion | ||
| 11010 | (org-back-to-heading t) | ||
| 11011 | (if (re-search-forward | ||
| 11012 | org-repeat-re (save-excursion (outline-next-heading) (point)) t) | ||
| 11013 | (match-string 1))))) | ||
| 11014 | |||
| 11015 | (defvar org-last-changed-timestamp) | ||
| 11016 | (defvar org-log-post-message) | ||
| 11017 | (defun org-auto-repeat-maybe () | ||
| 11018 | "Check if the current headline contains a REPEAT key. | ||
| 11019 | If yes, set TODO state back to what it was and change any SCHEDULED | ||
| 11020 | or DEADLINE times the new date. | ||
| 11021 | This function should be run in the `org-after-todo-state-change-hook'." | ||
| 11022 | ;; last-state is dynamically scoped into this function | ||
| 11023 | (let ((repeat (org-get-repeat)) | ||
| 11024 | (whata '(("d" . day) ("m" . month) ("y" . year))) | ||
| 11025 | (msg "Entry repeats: ") | ||
| 11026 | (org-log-done) | ||
| 11027 | re type n what start) | ||
| 11028 | (when repeat | ||
| 11029 | (org-todo (if (eq 'org-todo-interpretation 'type) | ||
| 11030 | last-state | ||
| 11031 | (car org-todo-keywords))) | ||
| 11032 | (unless (memq 'org-add-log-note (default-value 'post-command-hook)) | ||
| 11033 | ;; Make sure a note is taken | ||
| 11034 | (let ((org-log-done '(done))) | ||
| 11035 | (org-add-log-maybe 'done org-done-string 'findpos))) | ||
| 11036 | (org-back-to-heading t) | ||
| 11037 | (org-add-planning-info nil nil 'closed) | ||
| 11038 | (setq re (concat "\\(" org-scheduled-time-regexp "\\)\\|\\(" | ||
| 11039 | org-deadline-time-regexp "\\)")) | ||
| 11040 | (while (re-search-forward | ||
| 11041 | re (save-excursion (outline-next-heading) (point)) t) | ||
| 11042 | (setq type (if (match-end 1) org-scheduled-string org-deadline-string) | ||
| 11043 | start 0) | ||
| 11044 | (while (string-match "\\([-+]?[0-9]+\\)\\([dwmy]\\)" repeat start) | ||
| 11045 | (setq start (match-end 0) | ||
| 11046 | n (string-to-number (match-string 1 repeat)) | ||
| 11047 | what (match-string 2 repeat)) | ||
| 11048 | (if (equal what "w") (setq n (* n 7) what "d")) | ||
| 11049 | (org-timestamp-change n (cdr (assoc what whata)))) | ||
| 11050 | (setq msg (concat msg type org-last-changed-timestamp " "))) | ||
| 11051 | (setq org-log-post-message msg) | ||
| 11052 | (message msg)))) | ||
| 11053 | |||
| 5493 | (defun org-show-todo-tree (arg) | 11054 | (defun org-show-todo-tree (arg) |
| 5494 | "Make a compact tree which shows all headlines marked with TODO. | 11055 | "Make a compact tree which shows all headlines marked with TODO. |
| 5495 | The tree will show the lines where the regexp matches, and all higher | 11056 | The tree will show the lines where the regexp matches, and all higher |
| @@ -5530,85 +11091,103 @@ If non is given, the user is prompted for a date. | |||
| 5530 | REMOVE indicates what kind of entries to remove. An old WHAT entry will also | 11091 | REMOVE indicates what kind of entries to remove. An old WHAT entry will also |
| 5531 | be removed." | 11092 | be removed." |
| 5532 | (interactive) | 11093 | (interactive) |
| 5533 | (when what (setq time (or time (org-read-date nil 'to-time)))) | 11094 | (let (org-time-was-given) |
| 5534 | (when (and org-insert-labeled-timestamps-at-point | 11095 | (when what (setq time (or time (org-read-date nil 'to-time)))) |
| 5535 | (member what '(scheduled deadline))) | 11096 | (when (and org-insert-labeled-timestamps-at-point |
| 5536 | (insert | 11097 | (member what '(scheduled deadline))) |
| 5537 | (if (eq what 'scheduled) org-scheduled-string org-deadline-string) " ") | 11098 | (insert |
| 5538 | (org-insert-time-stamp time) | 11099 | (if (eq what 'scheduled) org-scheduled-string org-deadline-string) " ") |
| 5539 | (setq what nil)) | 11100 | (org-insert-time-stamp time org-time-was-given) |
| 5540 | (save-excursion | 11101 | (setq what nil)) |
| 5541 | (save-restriction | 11102 | (save-excursion |
| 5542 | (let (col list elt ts buffer-invisibility-spec) | 11103 | (save-restriction |
| 5543 | (org-back-to-heading t) | 11104 | (let (col list elt ts buffer-invisibility-spec) |
| 5544 | (looking-at (concat outline-regexp "\\( *\\)[^\r\n]*")) | 11105 | (org-back-to-heading t) |
| 5545 | (goto-char (match-end 1)) | 11106 | (looking-at (concat outline-regexp "\\( *\\)[^\r\n]*")) |
| 5546 | (setq col (current-column)) | 11107 | (goto-char (match-end 1)) |
| 5547 | (goto-char (1+ (match-end 0))) | 11108 | (setq col (current-column)) |
| 5548 | (if (and (not (looking-at outline-regexp)) | 11109 | (goto-char (1+ (match-end 0))) |
| 5549 | (looking-at (concat "[^\r\n]*?" org-keyword-time-regexp | 11110 | (if (and (not (looking-at outline-regexp)) |
| 5550 | "[^\r\n]*")) | 11111 | (looking-at (concat "[^\r\n]*?" org-keyword-time-regexp |
| 5551 | (not (equal (match-string 1) org-clock-string))) | 11112 | "[^\r\n]*")) |
| 5552 | (narrow-to-region (match-beginning 0) (match-end 0)) | 11113 | (not (equal (match-string 1) org-clock-string))) |
| 5553 | (insert "\n") | 11114 | (narrow-to-region (match-beginning 0) (match-end 0)) |
| 5554 | (backward-char 1) | 11115 | (insert "\n") |
| 5555 | (narrow-to-region (point) (point)) | 11116 | (backward-char 1) |
| 5556 | (indent-to-column col)) | 11117 | (narrow-to-region (point) (point)) |
| 5557 | ;; Check if we have to remove something. | 11118 | (indent-to-column col)) |
| 5558 | (setq list (cons what remove)) | 11119 | ;; Check if we have to remove something. |
| 5559 | (while list | 11120 | (setq list (cons what remove)) |
| 5560 | (setq elt (pop list)) | 11121 | (while list |
| 11122 | (setq elt (pop list)) | ||
| 11123 | (goto-char (point-min)) | ||
| 11124 | (when (or (and (eq elt 'scheduled) | ||
| 11125 | (re-search-forward org-scheduled-time-regexp nil t)) | ||
| 11126 | (and (eq elt 'deadline) | ||
| 11127 | (re-search-forward org-deadline-time-regexp nil t)) | ||
| 11128 | (and (eq elt 'closed) | ||
| 11129 | (re-search-forward org-closed-time-regexp nil t))) | ||
| 11130 | (replace-match "") | ||
| 11131 | (if (looking-at "--+<[^>]+>") (replace-match "")) | ||
| 11132 | (if (looking-at " +") (replace-match "")))) | ||
| 11133 | (goto-char (point-max)) | ||
| 11134 | (when what | ||
| 11135 | (insert | ||
| 11136 | (if (not (equal (char-before) ?\ )) " " "") | ||
| 11137 | (cond ((eq what 'scheduled) org-scheduled-string) | ||
| 11138 | ((eq what 'deadline) org-deadline-string) | ||
| 11139 | ((eq what 'closed) org-closed-string)) | ||
| 11140 | " ") | ||
| 11141 | (org-insert-time-stamp time | ||
| 11142 | (or org-time-was-given (eq what 'closed)) | ||
| 11143 | (eq what 'closed)) | ||
| 11144 | (end-of-line 1)) | ||
| 5561 | (goto-char (point-min)) | 11145 | (goto-char (point-min)) |
| 5562 | (when (or (and (eq elt 'scheduled) | 11146 | (widen) |
| 5563 | (re-search-forward org-scheduled-time-regexp nil t)) | 11147 | (if (looking-at "[ \t]+\r?\n") |
| 5564 | (and (eq elt 'deadline) | 11148 | (replace-match "")) |
| 5565 | (re-search-forward org-deadline-time-regexp nil t)) | 11149 | ts))))) |
| 5566 | (and (eq elt 'closed) | ||
| 5567 | (re-search-forward org-closed-time-regexp nil t))) | ||
| 5568 | (replace-match "") | ||
| 5569 | (if (looking-at " +") (replace-match "")))) | ||
| 5570 | (goto-char (point-max)) | ||
| 5571 | (when what | ||
| 5572 | (insert | ||
| 5573 | (if (not (equal (char-before) ?\ )) " " "") | ||
| 5574 | (cond ((eq what 'scheduled) org-scheduled-string) | ||
| 5575 | ((eq what 'deadline) org-deadline-string) | ||
| 5576 | ((eq what 'closed) org-closed-string)) | ||
| 5577 | " ") | ||
| 5578 | (org-insert-time-stamp time nil (eq what 'closed)) | ||
| 5579 | (end-of-line 1) | ||
| 5580 | (org-add-log-maybe 'done)) | ||
| 5581 | (goto-char (point-min)) | ||
| 5582 | (widen) | ||
| 5583 | (if (looking-at "[ \t]+\r?\n") | ||
| 5584 | (replace-match "")) | ||
| 5585 | ts)))) | ||
| 5586 | 11150 | ||
| 5587 | (defvar org-log-note-marker (make-marker)) | 11151 | (defvar org-log-note-marker (make-marker)) |
| 5588 | (defvar org-log-note-purpose nil) | 11152 | (defvar org-log-note-purpose nil) |
| 11153 | (defvar org-log-note-state nil) | ||
| 5589 | (defvar org-log-note-window-configuration nil) | 11154 | (defvar org-log-note-window-configuration nil) |
| 11155 | (defvar org-log-note-return-to (make-marker)) | ||
| 11156 | (defvar org-log-post-message nil | ||
| 11157 | "Message to be displayed after a log note has been stored. | ||
| 11158 | The auto-repeater uses this.") | ||
| 5590 | 11159 | ||
| 5591 | (defun org-add-log-maybe (&optional purpose) | 11160 | (defun org-add-log-maybe (&optional purpose state findpos) |
| 5592 | (when (and (listp org-log-done) | 11161 | (save-excursion |
| 5593 | (memq purpose org-log-done)) | 11162 | (when (and (listp org-log-done) |
| 5594 | (move-marker org-log-note-marker (point)) | 11163 | (memq purpose org-log-done)) |
| 5595 | (setq org-log-note-purpose purpose) | 11164 | (when findpos |
| 5596 | (add-hook 'post-command-hook 'org-add-log-note 'append))) | 11165 | (org-back-to-heading t) |
| 11166 | (looking-at (concat outline-regexp "\\( *\\)[^\r\n]*" | ||
| 11167 | "\\(\n[^\r\n]*?" org-keyword-time-not-clock-regexp | ||
| 11168 | "[^\r\n]*\\)?")) | ||
| 11169 | (goto-char (match-end 0))) | ||
| 11170 | (move-marker org-log-note-marker (point)) | ||
| 11171 | (setq org-log-note-purpose purpose) | ||
| 11172 | (setq org-log-note-state state) | ||
| 11173 | (add-hook 'post-command-hook 'org-add-log-note 'append)))) | ||
| 5597 | 11174 | ||
| 5598 | (defun org-add-log-note (&optional purpose) | 11175 | (defun org-add-log-note (&optional purpose) |
| 5599 | "Pop up a window for taking a note, and add this note later at point." | 11176 | "Pop up a window for taking a note, and add this note later at point." |
| 5600 | (remove-hook 'post-command-hook 'org-add-log-note) | 11177 | (remove-hook 'post-command-hook 'org-add-log-note) |
| 5601 | (setq org-log-note-window-configuration (current-window-configuration)) | 11178 | (setq org-log-note-window-configuration (current-window-configuration)) |
| 5602 | (delete-other-windows) | 11179 | (delete-other-windows) |
| 11180 | (move-marker org-log-note-return-to (point)) | ||
| 5603 | (switch-to-buffer (marker-buffer org-log-note-marker)) | 11181 | (switch-to-buffer (marker-buffer org-log-note-marker)) |
| 5604 | (goto-char org-log-note-marker) | 11182 | (goto-char org-log-note-marker) |
| 5605 | (switch-to-buffer-other-window "*Org Note*") | 11183 | (switch-to-buffer-other-window "*Org Note*") |
| 5606 | (erase-buffer) | 11184 | (erase-buffer) |
| 5607 | (org-mode) | 11185 | (let ((org-inhibit-startup t)) (org-mode)) |
| 5608 | (insert (format "# Insert note for %s, finish with C-c C-c.\n\n" | 11186 | (insert (format "# Insert note for %s, finish with C-c C-c.\n\n" |
| 5609 | (cond | 11187 | (cond |
| 5610 | ((eq org-log-note-purpose 'clock-out) "stopped clock") | 11188 | ((eq org-log-note-purpose 'clock-out) "stopped clock") |
| 5611 | ((eq org-log-note-purpose 'done) "closed todo item") | 11189 | ((eq org-log-note-purpose 'done) "closed todo item") |
| 11190 | ((eq org-log-note-purpose 'state) "state change") | ||
| 5612 | (t (error "This should not happen"))))) | 11191 | (t (error "This should not happen"))))) |
| 5613 | (org-set-local 'org-finish-function 'org-store-log-note)) | 11192 | (org-set-local 'org-finish-function 'org-store-log-note)) |
| 5614 | 11193 | ||
| @@ -5618,24 +11197,41 @@ be removed." | |||
| 5618 | (note (cdr (assq org-log-note-purpose org-log-note-headings))) | 11197 | (note (cdr (assq org-log-note-purpose org-log-note-headings))) |
| 5619 | lines ind) | 11198 | lines ind) |
| 5620 | (kill-buffer (current-buffer)) | 11199 | (kill-buffer (current-buffer)) |
| 5621 | (if (string-match "^#.*\n[ \t\\n]*" txt) | 11200 | (if (string-match "^#.*\n[ \t\n]*" txt) |
| 5622 | (setq txt (replace-match "" t t txt))) | 11201 | (setq txt (replace-match "" t t txt))) |
| 5623 | (when (string-match "\\S-" txt) | 11202 | (if (string-match "\\s-+\\'" txt) |
| 5624 | (if (string-match "\\s-+\\'" txt) | 11203 | (setq txt (replace-match "" t t txt))) |
| 5625 | (setq txt (replace-match "" t t txt))) | 11204 | (setq lines (org-split-string txt "\n")) |
| 5626 | (setq lines (org-split-string txt "\n")) | 11205 | (when (and note (string-match "\\S-" note)) |
| 5627 | (and note (string-match "\\S-" note) (push note lines)) | 11206 | (setq note |
| 11207 | (org-replace-escapes | ||
| 11208 | note | ||
| 11209 | (list (cons "%u" (user-login-name)) | ||
| 11210 | (cons "%U" user-full-name) | ||
| 11211 | (cons "%t" (format-time-string | ||
| 11212 | (org-time-stamp-format 'long 'inactive) | ||
| 11213 | (current-time))) | ||
| 11214 | (cons "%s" (if org-log-note-state | ||
| 11215 | (concat "\"" org-log-note-state "\"") | ||
| 11216 | ""))))) | ||
| 11217 | (if lines (setq note (concat note " \\\\"))) | ||
| 11218 | (push note lines)) | ||
| 11219 | (save-excursion | ||
| 11220 | (set-buffer (marker-buffer org-log-note-marker)) | ||
| 5628 | (save-excursion | 11221 | (save-excursion |
| 5629 | (set-buffer (marker-buffer org-log-note-marker)) | 11222 | (goto-char org-log-note-marker) |
| 5630 | (save-excursion | 11223 | (move-marker org-log-note-marker nil) |
| 5631 | (goto-char org-log-note-marker) | 11224 | (end-of-line 1) |
| 5632 | (if (not (bolp)) (newline)) | 11225 | (if (not (bolp)) (insert "\n")) (indent-relative nil) |
| 5633 | (indent-relative t) | 11226 | (setq ind (concat (buffer-substring (point-at-bol) (point)) " ")) |
| 5634 | (setq ind (concat (buffer-substring (point-at-bol) (point)) " ")) | 11227 | (insert " - " (pop lines)) |
| 5635 | (insert " - " (pop lines)) | 11228 | (while lines |
| 5636 | (while lines | 11229 | (insert "\n" ind (pop lines)))))) |
| 5637 | (insert "\n" ind (pop lines)))))) | 11230 | (set-window-configuration org-log-note-window-configuration) |
| 5638 | (set-window-configuration org-log-note-window-configuration))) | 11231 | (with-current-buffer (marker-buffer org-log-note-return-to) |
| 11232 | (goto-char org-log-note-return-to)) | ||
| 11233 | (move-marker org-log-note-return-to nil) | ||
| 11234 | (and org-log-post-message (message org-log-post-message))) | ||
| 5639 | 11235 | ||
| 5640 | (defvar org-occur-highlights nil) | 11236 | (defvar org-occur-highlights nil) |
| 5641 | (make-variable-buffer-local 'org-occur-highlights) | 11237 | (make-variable-buffer-local 'org-occur-highlights) |
| @@ -5675,14 +11271,15 @@ that the match should indeed be shown." | |||
| 5675 | (message "%d match(es) for regexp %s" cnt regexp)) | 11271 | (message "%d match(es) for regexp %s" cnt regexp)) |
| 5676 | cnt)) | 11272 | cnt)) |
| 5677 | 11273 | ||
| 5678 | (defun org-show-context (&optional key siblings) | 11274 | (defun org-show-context (&optional key) |
| 5679 | "Make sure point and context and visible. | 11275 | "Make sure point and context and visible. |
| 5680 | How much context is shown depends upon the variables | 11276 | How much context is shown depends upon the variables |
| 5681 | `org-show-hierarchy-above' and `org-show-following-heading'. | 11277 | `org-show-hierarchy-above', `org-show-following-heading'. and |
| 5682 | When SIBLINGS is non-nil, show all siblings on each hierarchy level." | 11278 | `org-show-siblings'." |
| 5683 | (let ((heading-p (org-on-heading-p t)) | 11279 | (let ((heading-p (org-on-heading-p t)) |
| 5684 | (hierarchy-p (org-get-alist-option org-show-hierarchy-above key)) | 11280 | (hierarchy-p (org-get-alist-option org-show-hierarchy-above key)) |
| 5685 | (following-p (org-get-alist-option org-show-following-heading key))) | 11281 | (following-p (org-get-alist-option org-show-following-heading key)) |
| 11282 | (siblings-p (org-get-alist-option org-show-siblings key))) | ||
| 5686 | (catch 'exit | 11283 | (catch 'exit |
| 5687 | ;; Show heading or entry text | 11284 | ;; Show heading or entry text |
| 5688 | (if heading-p | 11285 | (if heading-p |
| @@ -5694,7 +11291,7 @@ When SIBLINGS is non-nil, show all siblings on each hierarchy level." | |||
| 5694 | (save-excursion | 11291 | (save-excursion |
| 5695 | (and (if heading-p (org-goto-sibling) (outline-next-heading)) | 11292 | (and (if heading-p (org-goto-sibling) (outline-next-heading)) |
| 5696 | (org-flag-heading nil)))) | 11293 | (org-flag-heading nil)))) |
| 5697 | (when siblings (org-show-siblings)) | 11294 | (when siblings-p (org-show-siblings)) |
| 5698 | (when hierarchy-p | 11295 | (when hierarchy-p |
| 5699 | ;; show all higher headings, possibly with siblings | 11296 | ;; show all higher headings, possibly with siblings |
| 5700 | (save-excursion | 11297 | (save-excursion |
| @@ -5703,15 +11300,7 @@ When SIBLINGS is non-nil, show all siblings on each hierarchy level." | |||
| 5703 | (error nil)) | 11300 | (error nil)) |
| 5704 | (not (bobp))) | 11301 | (not (bobp))) |
| 5705 | (org-flag-heading nil) | 11302 | (org-flag-heading nil) |
| 5706 | (when siblings (org-show-siblings)))))))) | 11303 | (when siblings-p (org-show-siblings)))))))) |
| 5707 | |||
| 5708 | (defun org-show-siblings () | ||
| 5709 | "Show all siblings of the current headline." | ||
| 5710 | (save-excursion | ||
| 5711 | (while (org-goto-sibling) (org-flag-heading nil))) | ||
| 5712 | (save-excursion | ||
| 5713 | (while (org-goto-sibling 'previous) | ||
| 5714 | (org-flag-heading nil)))) | ||
| 5715 | 11304 | ||
| 5716 | (defun org-reveal (&optional siblings) | 11305 | (defun org-reveal (&optional siblings) |
| 5717 | "Show current entry, hierarchy above it, and the following headline. | 11306 | "Show current entry, hierarchy above it, and the following headline. |
| @@ -5720,53 +11309,13 @@ exposed with `org-show-hierarchy-above' or `org-show-following-heading' | |||
| 5720 | not t for the search context. | 11309 | not t for the search context. |
| 5721 | 11310 | ||
| 5722 | With optional argument SIBLINGS, on each level of the hierarchy all | 11311 | With optional argument SIBLINGS, on each level of the hierarchy all |
| 5723 | siblings are shown. This repairs the tree structure so what it would | 11312 | siblings are shown. This repairs the tree structure to what it would |
| 5724 | look like when opend with successive calls to `org-cycle'." | 11313 | look like when opened with hierarchical calls to `org-cycle'." |
| 5725 | (interactive "P") | 11314 | (interactive "P") |
| 5726 | (let ((org-show-hierarchy-above t) | 11315 | (let ((org-show-hierarchy-above t) |
| 5727 | (org-show-following-heading t)) | 11316 | (org-show-following-heading t) |
| 5728 | (org-show-context nil siblings))) | 11317 | (org-show-siblings (if siblings t org-show-siblings))) |
| 5729 | 11318 | (org-show-context nil))) | |
| 5730 | ;; Overlay compatibility functions | ||
| 5731 | (defun org-make-overlay (beg end &optional buffer) | ||
| 5732 | (if (featurep 'xemacs) | ||
| 5733 | (make-extent beg end buffer) | ||
| 5734 | (make-overlay beg end buffer))) | ||
| 5735 | (defun org-delete-overlay (ovl) | ||
| 5736 | (if (featurep 'xemacs) (delete-extent ovl) (delete-overlay ovl))) | ||
| 5737 | (defun org-detach-overlay (ovl) | ||
| 5738 | (if (featurep 'xemacs) (detach-extent ovl) (delete-overlay ovl))) | ||
| 5739 | (defun org-move-overlay (ovl beg end &optional buffer) | ||
| 5740 | (if (featurep 'xemacs) | ||
| 5741 | (set-extent-endpoints ovl beg end (or buffer (current-buffer))) | ||
| 5742 | (move-overlay ovl beg end buffer))) | ||
| 5743 | (defun org-overlay-put (ovl prop value) | ||
| 5744 | (if (featurep 'xemacs) | ||
| 5745 | (set-extent-property ovl prop value) | ||
| 5746 | (overlay-put ovl prop value))) | ||
| 5747 | (defun org-overlay-display (ovl text &optional face) | ||
| 5748 | "Make overlay OVL display TEXT with face FACE." | ||
| 5749 | (if (featurep 'xemacs) | ||
| 5750 | (let ((gl (make-glyph text))) | ||
| 5751 | (and face (set-glyph-face gl face)) | ||
| 5752 | (set-extent-property ovl 'invisible t) | ||
| 5753 | (set-extent-property ovl 'end-glyph gl)) | ||
| 5754 | (overlay-put ovl 'display text) | ||
| 5755 | (if face (overlay-put ovl 'face face)))) | ||
| 5756 | (defun org-overlay-get (ovl prop) | ||
| 5757 | (if (featurep 'xemacs) | ||
| 5758 | (extent-property ovl prop) | ||
| 5759 | (overlay-get ovl prop))) | ||
| 5760 | (defun org-overlays-at (pos) | ||
| 5761 | (if (featurep 'xemacs) (extents-at pos) (overlays-at pos))) | ||
| 5762 | (defun org-overlays-in (&optional start end) | ||
| 5763 | (if (featurep 'xemacs) | ||
| 5764 | (extent-list nil start end) | ||
| 5765 | (overlays-in start end))) | ||
| 5766 | (defun org-overlay-start (o) | ||
| 5767 | (if (featurep 'xemacs) (extent-start-position o) (overlay-start o))) | ||
| 5768 | (defun org-overlay-end (o) | ||
| 5769 | (if (featurep 'xemacs) (extent-end-position o) (overlay-end o))) | ||
| 5770 | 11319 | ||
| 5771 | (defun org-highlight-new-match (beg end) | 11320 | (defun org-highlight-new-match (beg end) |
| 5772 | "Highlight from BEG to END and mark the highlight is an occur headline." | 11321 | "Highlight from BEG to END and mark the highlight is an occur headline." |
| @@ -5774,7 +11323,6 @@ look like when opend with successive calls to `org-cycle'." | |||
| 5774 | (org-overlay-put ov 'face 'secondary-selection) | 11323 | (org-overlay-put ov 'face 'secondary-selection) |
| 5775 | (push ov org-occur-highlights))) | 11324 | (push ov org-occur-highlights))) |
| 5776 | 11325 | ||
| 5777 | (defvar org-inhibit-highlight-removal nil) | ||
| 5778 | (defun org-remove-occur-highlights (&optional beg end noremove) | 11326 | (defun org-remove-occur-highlights (&optional beg end noremove) |
| 5779 | "Remove the occur highlights from the buffer. | 11327 | "Remove the occur highlights from the buffer. |
| 5780 | BEG and END are ignored. If NOREMOVE is nil, remove this function | 11328 | BEG and END are ignored. If NOREMOVE is nil, remove this function |
| @@ -5787,7 +11335,7 @@ from the `before-change-functions' in the current buffer." | |||
| 5787 | (remove-hook 'before-change-functions | 11335 | (remove-hook 'before-change-functions |
| 5788 | 'org-remove-occur-highlights 'local)))) | 11336 | 'org-remove-occur-highlights 'local)))) |
| 5789 | 11337 | ||
| 5790 | ;;; Priorities | 11338 | ;;;; Priorities |
| 5791 | 11339 | ||
| 5792 | (defvar org-priority-regexp ".*?\\(\\[#\\([A-Z]\\)\\] ?\\)" | 11340 | (defvar org-priority-regexp ".*?\\(\\[#\\([A-Z]\\)\\] ?\\)" |
| 5793 | "Regular expression matching the priority indicator.") | 11341 | "Regular expression matching the priority indicator.") |
| @@ -5857,9 +11405,504 @@ ACTION can be set, up, or down." | |||
| 5857 | (* 1000 (- org-lowest-priority | 11405 | (* 1000 (- org-lowest-priority |
| 5858 | (string-to-char (match-string 2 s))))))) | 11406 | (string-to-char (match-string 2 s))))))) |
| 5859 | 11407 | ||
| 5860 | ;;; Timestamps | 11408 | ;;;; Tags |
| 11409 | |||
| 11410 | (defun org-scan-tags (action matcher &optional todo-only) | ||
| 11411 | "Scan headline tags with inheritance and produce output ACTION. | ||
| 11412 | ACTION can be `sparse-tree' or `agenda'. MATCHER is a Lisp form to be | ||
| 11413 | evaluated, testing if a given set of tags qualifies a headline for | ||
| 11414 | inclusion. When TODO-ONLY is non-nil, only lines with a TODO keyword | ||
| 11415 | are included in the output." | ||
| 11416 | (let* ((re (concat "[\n\r]" outline-regexp " *\\(\\<\\(" | ||
| 11417 | (mapconcat 'regexp-quote | ||
| 11418 | (nreverse (cdr (reverse org-todo-keywords))) | ||
| 11419 | "\\|") | ||
| 11420 | "\\>\\)\\)? *\\(.*?\\)\\(:[A-Za-z_@0-9:]+:\\)?[ \t]*$")) | ||
| 11421 | (props (list 'face nil | ||
| 11422 | 'done-face 'org-done | ||
| 11423 | 'undone-face nil | ||
| 11424 | 'mouse-face 'highlight | ||
| 11425 | 'org-not-done-regexp org-not-done-regexp | ||
| 11426 | 'keymap org-agenda-keymap | ||
| 11427 | 'help-echo | ||
| 11428 | (format "mouse-2 or RET jump to org file %s" | ||
| 11429 | (abbreviate-file-name buffer-file-name)))) | ||
| 11430 | (case-fold-search nil) | ||
| 11431 | lspos | ||
| 11432 | tags tags-list tags-alist (llast 0) rtn level category i txt | ||
| 11433 | todo marker entry) | ||
| 11434 | (save-excursion | ||
| 11435 | (goto-char (point-min)) | ||
| 11436 | (when (eq action 'sparse-tree) (org-overview)) | ||
| 11437 | (while (re-search-forward re nil t) | ||
| 11438 | (catch :skip | ||
| 11439 | (setq todo (if (match-end 1) (match-string 2)) | ||
| 11440 | tags (if (match-end 4) (match-string 4))) | ||
| 11441 | (goto-char (setq lspos (1+ (match-beginning 0)))) | ||
| 11442 | (setq level (funcall outline-level) | ||
| 11443 | category (org-get-category)) | ||
| 11444 | (setq i llast llast level) | ||
| 11445 | ;; remove tag lists from same and sublevels | ||
| 11446 | (while (>= i level) | ||
| 11447 | (when (setq entry (assoc i tags-alist)) | ||
| 11448 | (setq tags-alist (delete entry tags-alist))) | ||
| 11449 | (setq i (1- i))) | ||
| 11450 | ;; add the nex tags | ||
| 11451 | (when tags | ||
| 11452 | (setq tags (mapcar 'downcase (org-split-string tags ":")) | ||
| 11453 | tags-alist | ||
| 11454 | (cons (cons level tags) tags-alist))) | ||
| 11455 | ;; compile tags for current headline | ||
| 11456 | (setq tags-list | ||
| 11457 | (if org-use-tag-inheritance | ||
| 11458 | (apply 'append (mapcar 'cdr tags-alist)) | ||
| 11459 | tags)) | ||
| 11460 | (when (and (or (not todo-only) todo) | ||
| 11461 | (eval matcher) | ||
| 11462 | (or (not org-agenda-skip-archived-trees) | ||
| 11463 | (not (member org-archive-tag tags-list)))) | ||
| 11464 | (and (eq action 'agenda) (org-agenda-skip)) | ||
| 11465 | ;; list this headline | ||
| 11466 | (if (eq action 'sparse-tree) | ||
| 11467 | (progn | ||
| 11468 | (org-show-context 'tags-tree)) | ||
| 11469 | (setq txt (org-format-agenda-item | ||
| 11470 | "" | ||
| 11471 | (concat | ||
| 11472 | (if org-tags-match-list-sublevels | ||
| 11473 | (make-string (1- level) ?.) "") | ||
| 11474 | (org-get-heading)) | ||
| 11475 | category tags-list)) | ||
| 11476 | (goto-char lspos) | ||
| 11477 | (setq marker (org-agenda-new-marker)) | ||
| 11478 | (org-add-props txt props | ||
| 11479 | 'org-marker marker 'org-hd-marker marker 'org-category category) | ||
| 11480 | (push txt rtn)) | ||
| 11481 | ;; if we are to skip sublevels, jump to end of subtree | ||
| 11482 | (or org-tags-match-list-sublevels (org-end-of-subtree t)))))) | ||
| 11483 | (when (and (eq action 'sparse-tree) | ||
| 11484 | (not org-sparse-tree-open-archived-trees)) | ||
| 11485 | (org-hide-archived-subtrees (point-min) (point-max))) | ||
| 11486 | (nreverse rtn))) | ||
| 11487 | |||
| 11488 | (defvar todo-only) ;; dynamically scoped | ||
| 11489 | |||
| 11490 | (defun org-tags-sparse-tree (&optional todo-only match) | ||
| 11491 | "Create a sparse tree according to tags string MATCH. | ||
| 11492 | MATCH can contain positive and negative selection of tags, like | ||
| 11493 | \"+WORK+URGENT-WITHBOSS\". | ||
| 11494 | If optional argument TODO_ONLY is non-nil, only select lines that are | ||
| 11495 | also TODO lines." | ||
| 11496 | (interactive "P") | ||
| 11497 | (org-scan-tags 'sparse-tree (cdr (org-make-tags-matcher match)) todo-only)) | ||
| 11498 | |||
| 11499 | (defun org-make-tags-matcher (match) | ||
| 11500 | "Create the TAGS//TODO matcher form for the selection string MATCH." | ||
| 11501 | ;; todo-only is scoped dynamically into this function, and the function | ||
| 11502 | ;; may change it it the matcher asksk for it. | ||
| 11503 | (unless match | ||
| 11504 | ;; Get a new match request, with completion | ||
| 11505 | (setq org-last-tags-completion-table | ||
| 11506 | (or org-tag-alist | ||
| 11507 | org-last-tags-completion-table)) | ||
| 11508 | (setq match (completing-read | ||
| 11509 | "Match: " 'org-tags-completion-function nil nil nil | ||
| 11510 | 'org-tags-history))) | ||
| 11511 | |||
| 11512 | ;; Parse the string and create a lisp form | ||
| 11513 | (let ((match0 match) | ||
| 11514 | (re "^&?\\([-+:]\\)?\\({[^}]+}\\|LEVEL=\\([0-9]+\\)\\|[A-Za-z_@0-9]+\\)") | ||
| 11515 | minus tag mm | ||
| 11516 | tagsmatch todomatch tagsmatcher todomatcher kwd matcher | ||
| 11517 | orterms term orlist re-p level-p) | ||
| 11518 | (if (string-match "/+" match) | ||
| 11519 | ;; match contains also a todo-matching request | ||
| 11520 | (progn | ||
| 11521 | (setq tagsmatch (substring match 0 (match-beginning 0)) | ||
| 11522 | todomatch (substring match (match-end 0))) | ||
| 11523 | (if (string-match "^!" todomatch) | ||
| 11524 | (setq todo-only t todomatch (substring todomatch 1))) | ||
| 11525 | (if (string-match "^\\s-*$" todomatch) | ||
| 11526 | (setq todomatch nil))) | ||
| 11527 | ;; only matching tags | ||
| 11528 | (setq tagsmatch match todomatch nil)) | ||
| 11529 | |||
| 11530 | ;; Make the tags matcher | ||
| 11531 | (if (or (not tagsmatch) (not (string-match "\\S-" tagsmatch))) | ||
| 11532 | (setq tagsmatcher t) | ||
| 11533 | (setq orterms (org-split-string tagsmatch "|") orlist nil) | ||
| 11534 | (while (setq term (pop orterms)) | ||
| 11535 | (while (and (equal (substring term -1) "\\") orterms) | ||
| 11536 | (setq term (concat term "|" (pop orterms)))) ; repair bad split | ||
| 11537 | (while (string-match re term) | ||
| 11538 | (setq minus (and (match-end 1) | ||
| 11539 | (equal (match-string 1 term) "-")) | ||
| 11540 | tag (match-string 2 term) | ||
| 11541 | re-p (equal (string-to-char tag) ?{) | ||
| 11542 | level-p (match-end 3) | ||
| 11543 | mm (cond | ||
| 11544 | (re-p `(org-match-any-p ,(substring tag 1 -1) tags-list)) | ||
| 11545 | (level-p `(= level ,(string-to-number | ||
| 11546 | (match-string 3 term)))) | ||
| 11547 | (t `(member ,(downcase tag) tags-list))) | ||
| 11548 | mm (if minus (list 'not mm) mm) | ||
| 11549 | term (substring term (match-end 0))) | ||
| 11550 | (push mm tagsmatcher)) | ||
| 11551 | (push (if (> (length tagsmatcher) 1) | ||
| 11552 | (cons 'and tagsmatcher) | ||
| 11553 | (car tagsmatcher)) | ||
| 11554 | orlist) | ||
| 11555 | (setq tagsmatcher nil)) | ||
| 11556 | (setq tagsmatcher (if (> (length orlist) 1) (cons 'or orlist) (car orlist)))) | ||
| 11557 | |||
| 11558 | ;; Make the todo matcher | ||
| 11559 | (if (or (not todomatch) (not (string-match "\\S-" todomatch))) | ||
| 11560 | (setq todomatcher t) | ||
| 11561 | (setq orterms (org-split-string todomatch "|") orlist nil) | ||
| 11562 | (while (setq term (pop orterms)) | ||
| 11563 | (while (string-match re term) | ||
| 11564 | (setq minus (and (match-end 1) | ||
| 11565 | (equal (match-string 1 term) "-")) | ||
| 11566 | kwd (match-string 2 term) | ||
| 11567 | re-p (equal (string-to-char kwd) ?{) | ||
| 11568 | term (substring term (match-end 0)) | ||
| 11569 | mm (if re-p | ||
| 11570 | `(string-match ,(substring kwd 1 -1) todo) | ||
| 11571 | (list 'equal 'todo kwd)) | ||
| 11572 | mm (if minus (list 'not mm) mm)) | ||
| 11573 | (push mm todomatcher)) | ||
| 11574 | (push (if (> (length todomatcher) 1) | ||
| 11575 | (cons 'and todomatcher) | ||
| 11576 | (car todomatcher)) | ||
| 11577 | orlist) | ||
| 11578 | (setq todomatcher nil)) | ||
| 11579 | (setq todomatcher (if (> (length orlist) 1) | ||
| 11580 | (cons 'or orlist) (car orlist)))) | ||
| 11581 | |||
| 11582 | ;; Return the string and lisp forms of the matcher | ||
| 11583 | (setq matcher (if todomatcher | ||
| 11584 | (list 'and tagsmatcher todomatcher) | ||
| 11585 | tagsmatcher)) | ||
| 11586 | (cons match0 matcher))) | ||
| 11587 | |||
| 11588 | (defun org-match-any-p (re list) | ||
| 11589 | "Does re match any element of list?" | ||
| 11590 | (setq list (mapcar (lambda (x) (string-match re x)) list)) | ||
| 11591 | (delq nil list)) | ||
| 11592 | |||
| 11593 | (defvar org-add-colon-after-tag-completion nil) ;; dynamically skoped param | ||
| 11594 | (defvar org-tags-overlay (org-make-overlay 1 1)) | ||
| 11595 | (org-detach-overlay org-tags-overlay) | ||
| 11596 | |||
| 11597 | (defun org-set-tags (&optional arg just-align) | ||
| 11598 | "Set the tags for the current headline. | ||
| 11599 | With prefix ARG, realign all tags in headings in the current buffer." | ||
| 11600 | (interactive "P") | ||
| 11601 | (let* ((re (concat "^" outline-regexp)) | ||
| 11602 | (current (org-get-tags)) | ||
| 11603 | table current-tags inherited-tags ; computed below when needed | ||
| 11604 | tags p0 c0 c1 rpl) | ||
| 11605 | (if arg | ||
| 11606 | (save-excursion | ||
| 11607 | (goto-char (point-min)) | ||
| 11608 | (let (buffer-invisibility-spec) ; Emacs 21 compatibility | ||
| 11609 | (while (re-search-forward re nil t) | ||
| 11610 | (org-set-tags nil t) | ||
| 11611 | (end-of-line 1))) | ||
| 11612 | (message "All tags realigned to column %d" org-tags-column)) | ||
| 11613 | (if just-align | ||
| 11614 | (setq tags current) | ||
| 11615 | ;; Get a new set of tags from the user | ||
| 11616 | (setq table (or org-tag-alist (org-get-buffer-tags)) | ||
| 11617 | org-last-tags-completion-table table | ||
| 11618 | current-tags (org-split-string current ":") | ||
| 11619 | inherited-tags (nreverse | ||
| 11620 | (nthcdr (length current-tags) | ||
| 11621 | (nreverse (org-get-tags-at)))) | ||
| 11622 | tags | ||
| 11623 | (if (or (eq t org-use-fast-tag-selection) | ||
| 11624 | (and org-use-fast-tag-selection | ||
| 11625 | (delq nil (mapcar 'cdr table)))) | ||
| 11626 | (org-fast-tag-selection current-tags inherited-tags table) | ||
| 11627 | (let ((org-add-colon-after-tag-completion t)) | ||
| 11628 | (org-trim | ||
| 11629 | (completing-read "Tags: " 'org-tags-completion-function | ||
| 11630 | nil nil current 'org-tags-history))))) | ||
| 11631 | (while (string-match "[-+&]+" tags) | ||
| 11632 | ;; No boolean logic, just a list | ||
| 11633 | (setq tags (replace-match ":" t t tags)))) | ||
| 11634 | (if (string-match "\\`[\t ]*\\'" tags) | ||
| 11635 | (setq tags "") | ||
| 11636 | (unless (string-match ":$" tags) (setq tags (concat tags ":"))) | ||
| 11637 | (unless (string-match "^:" tags) (setq tags (concat ":" tags)))) | ||
| 11638 | |||
| 11639 | ;; Insert new tags at the correct column | ||
| 11640 | (beginning-of-line 1) | ||
| 11641 | (if (re-search-forward | ||
| 11642 | (concat "\\([ \t]*" (regexp-quote current) "\\)[ \t]*$") | ||
| 11643 | (point-at-eol) t) | ||
| 11644 | (progn | ||
| 11645 | (if (equal tags "") | ||
| 11646 | (setq rpl "") | ||
| 11647 | (goto-char (match-beginning 0)) | ||
| 11648 | (setq c0 (current-column) p0 (point) | ||
| 11649 | c1 (max (1+ c0) (if (> org-tags-column 0) | ||
| 11650 | org-tags-column | ||
| 11651 | (- (- org-tags-column) (length tags)))) | ||
| 11652 | rpl (concat (make-string (max 0 (- c1 c0)) ?\ ) tags))) | ||
| 11653 | (replace-match rpl) | ||
| 11654 | (and (not (featurep 'xemacs)) c0 (tabify p0 (point))) | ||
| 11655 | tags) | ||
| 11656 | (error "Tags alignment failed"))))) | ||
| 11657 | |||
| 11658 | (defun org-tags-completion-function (string predicate &optional flag) | ||
| 11659 | (let (s1 s2 rtn (ctable org-last-tags-completion-table) | ||
| 11660 | (confirm (lambda (x) (stringp (car x))))) | ||
| 11661 | (if (string-match "^\\(.*[-+:&|]\\)\\([^-+:&|]*\\)$" string) | ||
| 11662 | (setq s1 (match-string 1 string) | ||
| 11663 | s2 (match-string 2 string)) | ||
| 11664 | (setq s1 "" s2 string)) | ||
| 11665 | (cond | ||
| 11666 | ((eq flag nil) | ||
| 11667 | ;; try completion | ||
| 11668 | (setq rtn (try-completion s2 ctable confirm)) | ||
| 11669 | (if (stringp rtn) | ||
| 11670 | (concat s1 s2 (substring rtn (length s2)) | ||
| 11671 | (if (and org-add-colon-after-tag-completion | ||
| 11672 | (assoc rtn ctable)) | ||
| 11673 | ":" ""))) | ||
| 11674 | ) | ||
| 11675 | ((eq flag t) | ||
| 11676 | ;; all-completions | ||
| 11677 | (all-completions s2 ctable confirm) | ||
| 11678 | ) | ||
| 11679 | ((eq flag 'lambda) | ||
| 11680 | ;; exact match? | ||
| 11681 | (assoc s2 ctable))) | ||
| 11682 | )) | ||
| 11683 | |||
| 11684 | (defun org-fast-tag-insert (kwd tags face &optional end) | ||
| 11685 | "Insert KDW, and the TAGS, the latter with face FACE. Also inser END." | ||
| 11686 | (insert (format "%-12s" (concat kwd ":")) | ||
| 11687 | (org-add-props (mapconcat 'identity tags " ") nil 'face face) | ||
| 11688 | (or end ""))) | ||
| 11689 | |||
| 11690 | (defun org-fast-tag-show-exit (flag) | ||
| 11691 | (save-excursion | ||
| 11692 | (goto-line 3) | ||
| 11693 | (if (re-search-forward "[ \t]+Next change exits" (point-at-eol) t) | ||
| 11694 | (replace-match "")) | ||
| 11695 | (when flag | ||
| 11696 | (end-of-line 1) | ||
| 11697 | (move-to-column (- (window-width) 19) t) | ||
| 11698 | (insert (org-add-props " Next change exits" nil 'face 'org-warning))))) | ||
| 11699 | |||
| 11700 | (defun org-set-current-tags-overlay (current prefix) | ||
| 11701 | (let ((s (concat ":" (mapconcat 'identity current ":") ":"))) | ||
| 11702 | (if (featurep 'xemacs) | ||
| 11703 | (org-overlay-display org-tags-overlay (concat prefix s) | ||
| 11704 | 'secondary-selection) | ||
| 11705 | (put-text-property 0 (length s) 'face '(secondary-selection org-tag) s) | ||
| 11706 | (org-overlay-display org-tags-overlay (concat prefix s))))) | ||
| 11707 | |||
| 11708 | (defun org-fast-tag-selection (current inherited table) | ||
| 11709 | "Fast tag selection with single keys. | ||
| 11710 | CURRENT is the current list of tags in the headline, INHERITED is the | ||
| 11711 | list of inherited tags, and TABLE is an alist of tags and corresponding keys, | ||
| 11712 | possibly with grouping information. | ||
| 11713 | If the keys are nil, a-z are automatically assigned. | ||
| 11714 | Returns the new tags string, or nil to not change the current settings." | ||
| 11715 | (let* ((maxlen (apply 'max (mapcar | ||
| 11716 | (lambda (x) | ||
| 11717 | (if (stringp (car x)) (string-width (car x)) 0)) | ||
| 11718 | table))) | ||
| 11719 | (buf (current-buffer)) | ||
| 11720 | (expert (eq org-fast-tag-selection-single-key 'expert)) | ||
| 11721 | (buffer-tags nil) | ||
| 11722 | (fwidth (+ maxlen 3 1 3)) | ||
| 11723 | (ncol (/ (- (window-width) 4) fwidth)) | ||
| 11724 | (i-face 'org-done) | ||
| 11725 | (c-face 'org-tag) | ||
| 11726 | tg cnt e c char c1 c2 ntable tbl rtn | ||
| 11727 | ov-start ov-end ov-prefix | ||
| 11728 | (exit-after-next org-fast-tag-selection-single-key) | ||
| 11729 | groups ingroup) | ||
| 11730 | (save-excursion | ||
| 11731 | (beginning-of-line 1) | ||
| 11732 | (if (looking-at ".*[ \t]\\(:[A-Za-z_@0-9:]+:\\)[ \t]*\\(\r\\|$\\)") | ||
| 11733 | (setq ov-start (match-beginning 1) | ||
| 11734 | ov-end (match-end 1) | ||
| 11735 | ov-prefix "") | ||
| 11736 | (setq ov-start (1- (point-at-eol)) | ||
| 11737 | ov-end (1+ ov-start)) | ||
| 11738 | (skip-chars-forward "^\n\r") | ||
| 11739 | (setq ov-prefix | ||
| 11740 | (concat | ||
| 11741 | (buffer-substring (1- (point)) (point)) | ||
| 11742 | (if (> (current-column) org-tags-column) | ||
| 11743 | " " | ||
| 11744 | (make-string (- org-tags-column (current-column)) ?\ )))))) | ||
| 11745 | (org-move-overlay org-tags-overlay ov-start ov-end) | ||
| 11746 | (save-window-excursion | ||
| 11747 | (if expert | ||
| 11748 | (set-buffer (get-buffer-create " *Org tags*")) | ||
| 11749 | (delete-other-windows) | ||
| 11750 | (split-window-vertically) | ||
| 11751 | (switch-to-buffer-other-window (get-buffer-create " *Org tags*"))) | ||
| 11752 | (erase-buffer) | ||
| 11753 | (org-fast-tag-insert "Inherited" inherited i-face "\n") | ||
| 11754 | (org-fast-tag-insert "Current" current c-face "\n\n") | ||
| 11755 | (org-fast-tag-show-exit exit-after-next) | ||
| 11756 | (org-set-current-tags-overlay current ov-prefix) | ||
| 11757 | (setq tbl table char ?a cnt 0) | ||
| 11758 | (while (setq e (pop tbl)) | ||
| 11759 | (cond | ||
| 11760 | ((equal e '(:startgroup)) | ||
| 11761 | (push '() groups) (setq ingroup t) | ||
| 11762 | (when (not (= cnt 0)) | ||
| 11763 | (setq cnt 0) | ||
| 11764 | (insert "\n")) | ||
| 11765 | (insert "{ ")) | ||
| 11766 | ((equal e '(:endgroup)) | ||
| 11767 | (setq ingroup nil cnt 0) | ||
| 11768 | (insert "}\n")) | ||
| 11769 | (t | ||
| 11770 | (setq tg (car e) c2 nil) | ||
| 11771 | (if (cdr e) | ||
| 11772 | (setq c (cdr e)) | ||
| 11773 | ;; automatically assign a character. | ||
| 11774 | (setq c1 (string-to-char | ||
| 11775 | (downcase (substring | ||
| 11776 | tg (if (= (string-to-char tg) ?@) 1 0))))) | ||
| 11777 | (if (or (rassoc c1 ntable) (rassoc c1 table)) | ||
| 11778 | (while (or (rassoc char ntable) (rassoc char table)) | ||
| 11779 | (setq char (1+ char))) | ||
| 11780 | (setq c2 c1)) | ||
| 11781 | (setq c (or c2 char))) | ||
| 11782 | (if ingroup (push tg (car groups))) | ||
| 11783 | (setq tg (org-add-props tg nil 'face | ||
| 11784 | (cond | ||
| 11785 | ((member tg current) c-face) | ||
| 11786 | ((member tg inherited) i-face) | ||
| 11787 | (t nil)))) | ||
| 11788 | (if (and (= cnt 0) (not ingroup)) (insert " ")) | ||
| 11789 | (insert "[" c "] " tg (make-string | ||
| 11790 | (- fwidth 4 (length tg)) ?\ )) | ||
| 11791 | (push (cons tg c) ntable) | ||
| 11792 | (when (= (setq cnt (1+ cnt)) ncol) | ||
| 11793 | (insert "\n") | ||
| 11794 | (if ingroup (insert " ")) | ||
| 11795 | (setq cnt 0))))) | ||
| 11796 | (setq ntable (nreverse ntable)) | ||
| 11797 | (insert "\n") | ||
| 11798 | (goto-char (point-min)) | ||
| 11799 | (if (and (not expert) (fboundp 'fit-window-to-buffer)) | ||
| 11800 | (fit-window-to-buffer)) | ||
| 11801 | (setq rtn | ||
| 11802 | (catch 'exit | ||
| 11803 | (while t | ||
| 11804 | (message "[a-z..]:Toggle [SPC]:clear [RET]:accept [TAB]:free%s%s" | ||
| 11805 | (if groups " [!] no groups" " [!]groups") | ||
| 11806 | (if expert " [C-c]:window" (if exit-after-next " [C-c]:single" " [C-c]:multi"))) | ||
| 11807 | (setq c (let ((inhibit-quit t)) (read-char-exclusive))) | ||
| 11808 | (cond | ||
| 11809 | ((= c ?\r) (throw 'exit t)) | ||
| 11810 | ((= c ?!) | ||
| 11811 | (setq groups (not groups)) | ||
| 11812 | (goto-char (point-min)) | ||
| 11813 | (while (re-search-forward "[{}]" nil t) (replace-match " "))) | ||
| 11814 | ((= c ?\C-c) | ||
| 11815 | (if (not expert) | ||
| 11816 | (org-fast-tag-show-exit | ||
| 11817 | (setq exit-after-next (not exit-after-next))) | ||
| 11818 | (setq expert nil) | ||
| 11819 | (delete-other-windows) | ||
| 11820 | (split-window-vertically) | ||
| 11821 | (switch-to-buffer-other-window " *Org tags*") | ||
| 11822 | (and (fboundp 'fit-window-to-buffer) | ||
| 11823 | (fit-window-to-buffer)))) | ||
| 11824 | ((or (= c ?\C-g) | ||
| 11825 | (and (= c ?q) (not (rassoc c ntable)))) | ||
| 11826 | (org-detach-overlay org-tags-overlay) | ||
| 11827 | (setq quit-flag t)) | ||
| 11828 | ((= c ?\ ) | ||
| 11829 | (setq current nil) | ||
| 11830 | (if exit-after-next (setq exit-after-next 'now))) | ||
| 11831 | ((= c ?\t) | ||
| 11832 | (condition-case nil | ||
| 11833 | (setq tg (completing-read | ||
| 11834 | "Tag: " | ||
| 11835 | (or buffer-tags | ||
| 11836 | (with-current-buffer buf | ||
| 11837 | (org-get-buffer-tags))))) | ||
| 11838 | (quit (setq tg ""))) | ||
| 11839 | (when (string-match "\\S-" tg) | ||
| 11840 | (add-to-list 'buffer-tags (list tg)) | ||
| 11841 | (if (member tg current) | ||
| 11842 | (setq current (delete tg current)) | ||
| 11843 | (push tg current))) | ||
| 11844 | (if exit-after-next (setq exit-after-next 'now))) | ||
| 11845 | ((setq e (rassoc c ntable) tg (car e)) | ||
| 11846 | (if (member tg current) | ||
| 11847 | (setq current (delete tg current)) | ||
| 11848 | (loop for g in groups do | ||
| 11849 | (if (member tg g) | ||
| 11850 | (mapcar (lambda (x) | ||
| 11851 | (setq current (delete x current))) | ||
| 11852 | g))) | ||
| 11853 | (push tg current)) | ||
| 11854 | (if exit-after-next (setq exit-after-next 'now)))) | ||
| 11855 | |||
| 11856 | ;; Create a sorted list | ||
| 11857 | (setq current | ||
| 11858 | (sort current | ||
| 11859 | (lambda (a b) | ||
| 11860 | (assoc b (cdr (memq (assoc a ntable) ntable)))))) | ||
| 11861 | (if (eq exit-after-next 'now) (throw 'exit t)) | ||
| 11862 | (goto-char (point-min)) | ||
| 11863 | (beginning-of-line 2) | ||
| 11864 | (delete-region (point) (point-at-eol)) | ||
| 11865 | (org-fast-tag-insert "Current" current c-face) | ||
| 11866 | (org-set-current-tags-overlay current ov-prefix) | ||
| 11867 | (while (re-search-forward "\\[.\\] \\([a-zA-Z0-9_@]+\\)" nil t) | ||
| 11868 | (setq tg (match-string 1)) | ||
| 11869 | (add-text-properties (match-beginning 1) (match-end 1) | ||
| 11870 | (list 'face | ||
| 11871 | (cond | ||
| 11872 | ((member tg current) c-face) | ||
| 11873 | ((member tg inherited) i-face) | ||
| 11874 | (t nil))))) | ||
| 11875 | (goto-char (point-min))))) | ||
| 11876 | (org-detach-overlay org-tags-overlay) | ||
| 11877 | (if rtn | ||
| 11878 | (mapconcat 'identity current ":") | ||
| 11879 | nil)))) | ||
| 11880 | |||
| 11881 | (defun org-get-tags () | ||
| 11882 | "Get the TAGS string in the current headline." | ||
| 11883 | (unless (org-on-heading-p t) | ||
| 11884 | (error "Not on a heading")) | ||
| 11885 | (save-excursion | ||
| 11886 | (beginning-of-line 1) | ||
| 11887 | (if (looking-at ".*[ \t]\\(:[A-Za-z_@0-9:]+:\\)[ \t]*\\(\r\\|$\\)") | ||
| 11888 | (org-match-string-no-properties 1) | ||
| 11889 | ""))) | ||
| 11890 | |||
| 11891 | (defun org-get-buffer-tags () | ||
| 11892 | "Get a table of all tags used in the buffer, for completion." | ||
| 11893 | (let (tags) | ||
| 11894 | (save-excursion | ||
| 11895 | (goto-char (point-min)) | ||
| 11896 | (while (re-search-forward "[ \t]:\\([A-Za-z_@0-9:]+\\):[ \t\r\n]" nil t) | ||
| 11897 | (mapc (lambda (x) (add-to-list 'tags x)) | ||
| 11898 | (org-split-string (org-match-string-no-properties 1) ":")))) | ||
| 11899 | (mapcar 'list tags))) | ||
| 11900 | |||
| 11901 | ;;;; Timestamps | ||
| 5861 | 11902 | ||
| 5862 | (defvar org-last-changed-timestamp nil) | 11903 | (defvar org-last-changed-timestamp nil) |
| 11904 | (defvar org-time-was-given) ; dynamically scoped parameter | ||
| 11905 | (defvar org-ts-what) ; dynamically scoped parameter | ||
| 5863 | 11906 | ||
| 5864 | (defun org-time-stamp (arg) | 11907 | (defun org-time-stamp (arg) |
| 5865 | "Prompt for a date/time and insert a time stamp. | 11908 | "Prompt for a date/time and insert a time stamp. |
| @@ -5908,7 +11951,10 @@ So these are more for recording a certain time/date." | |||
| 5908 | (org-overlay-put org-date-ovl 'face 'org-warning) | 11951 | (org-overlay-put org-date-ovl 'face 'org-warning) |
| 5909 | (org-detach-overlay org-date-ovl) | 11952 | (org-detach-overlay org-date-ovl) |
| 5910 | 11953 | ||
| 5911 | (defun org-read-date (&optional with-time to-time from-string) | 11954 | (defvar org-ans1) ; dynamically scoped parameter |
| 11955 | (defvar org-ans2) ; dynamically scoped parameter | ||
| 11956 | |||
| 11957 | (defun org-read-date (&optional with-time to-time from-string prompt) | ||
| 5912 | "Read a date and make things smooth for the user. | 11958 | "Read a date and make things smooth for the user. |
| 5913 | The prompt will suggest to enter an ISO date, but you can also enter anything | 11959 | The prompt will suggest to enter an ISO date, but you can also enter anything |
| 5914 | which will at least partially be understood by `parse-time-string'. | 11960 | which will at least partially be understood by `parse-time-string'. |
| @@ -5921,6 +11967,7 @@ hour and minute. For example, | |||
| 5921 | 22 sept 0:34 --> currentyear-09-22 0:34 | 11967 | 22 sept 0:34 --> currentyear-09-22 0:34 |
| 5922 | 12 --> currentyear-currentmonth-12 | 11968 | 12 --> currentyear-currentmonth-12 |
| 5923 | Fri --> nearest Friday (today or later) | 11969 | Fri --> nearest Friday (today or later) |
| 11970 | +4 --> four days from today (only if +N is the only thing given) | ||
| 5924 | etc. | 11971 | etc. |
| 5925 | The function understands only English month and weekday abbreviations, | 11972 | The function understands only English month and weekday abbreviations, |
| 5926 | but this can be configured with the variables `parse-time-months' and | 11973 | but this can be configured with the variables `parse-time-months' and |
| @@ -5960,8 +12007,9 @@ used to insert the time stamp into the buffer to include the time." | |||
| 5960 | (view-calendar-holidays-initially nil) | 12007 | (view-calendar-holidays-initially nil) |
| 5961 | (timestr (format-time-string | 12008 | (timestr (format-time-string |
| 5962 | (if with-time "%Y-%m-%d %H:%M" "%Y-%m-%d") default-time)) | 12009 | (if with-time "%Y-%m-%d %H:%M" "%Y-%m-%d") default-time)) |
| 5963 | (prompt (format "YYYY-MM-DD [%s]: " timestr)) | 12010 | (prompt (concat (if prompt (concat prompt " ") "") |
| 5964 | ans ans1 ans2 | 12011 | (format "YYYY-MM-DD [%s]: " timestr))) |
| 12012 | ans (org-ans0 "") org-ans1 org-ans2 (deltadays 0) | ||
| 5965 | second minute hour day month year tl wday wday1) | 12013 | second minute hour day month year tl wday wday1) |
| 5966 | 12014 | ||
| 5967 | (cond | 12015 | (cond |
| @@ -6009,14 +12057,20 @@ used to insert the time stamp into the buffer to include the time." | |||
| 6009 | (unwind-protect | 12057 | (unwind-protect |
| 6010 | (progn | 12058 | (progn |
| 6011 | (use-local-map map) | 12059 | (use-local-map map) |
| 6012 | (setq ans (read-string prompt "" nil nil)) | 12060 | (setq org-ans0 (read-string prompt "" nil nil)) |
| 6013 | (if (not (string-match "\\S-" ans)) (setq ans nil)) | 12061 | ; (if (not (string-match "\\S-" org-ans0)) (setq org-ans0 nil)) |
| 6014 | (setq ans (or ans1 ans ans2))) | 12062 | ;; org-ans0: from prompt |
| 12063 | ;; org-ans1: from mouse click | ||
| 12064 | ;; org-ans2: from calendar motion | ||
| 12065 | (setq ans (concat org-ans0 " " (or org-ans1 org-ans2)))) | ||
| 6015 | (use-local-map old-map)))))) | 12066 | (use-local-map old-map)))))) |
| 6016 | (t ; Naked prompt only | 12067 | (t ; Naked prompt only |
| 6017 | (setq ans (read-string prompt "" nil timestr)))) | 12068 | (setq ans (read-string prompt "" nil timestr)))) |
| 6018 | (org-detach-overlay org-date-ovl) | 12069 | (org-detach-overlay org-date-ovl) |
| 6019 | 12070 | ||
| 12071 | (if (string-match "^[ \t]*[-+][0-9]+[ \t]*$" org-ans0) | ||
| 12072 | (setq deltadays (string-to-number ans) ans "")) | ||
| 12073 | |||
| 6020 | (if (string-match | 12074 | (if (string-match |
| 6021 | "^ *\\(\\([0-9]+\\)-\\)?\\([0-1]?[0-9]\\)-\\([0-3]?[0-9]\\)\\([^-0-9]\\|$\\)" ans) | 12075 | "^ *\\(\\([0-9]+\\)-\\)?\\([0-1]?[0-9]\\)-\\([0-3]?[0-9]\\)\\([^-0-9]\\|$\\)" ans) |
| 6022 | (progn | 12076 | (progn |
| @@ -6036,6 +12090,7 @@ used to insert the time stamp into the buffer to include the time." | |||
| 6036 | minute (or (nth 1 tl) (string-to-number (format-time-string "%M" ct))) | 12090 | minute (or (nth 1 tl) (string-to-number (format-time-string "%M" ct))) |
| 6037 | second (or (nth 0 tl) 0) | 12091 | second (or (nth 0 tl) 0) |
| 6038 | wday (nth 6 tl)) | 12092 | wday (nth 6 tl)) |
| 12093 | (setq day (+ day deltadays)) | ||
| 6039 | (when (and wday (not (nth 3 tl))) | 12094 | (when (and wday (not (nth 3 tl))) |
| 6040 | ;; Weekday was given, but no day, so pick that day in the week | 12095 | ;; Weekday was given, but no day, so pick that day in the week |
| 6041 | ;; on or after the derived date. | 12096 | ;; on or after the derived date. |
| @@ -6054,14 +12109,14 @@ used to insert the time stamp into the buffer to include the time." | |||
| 6054 | 12109 | ||
| 6055 | (defun org-eval-in-calendar (form) | 12110 | (defun org-eval-in-calendar (form) |
| 6056 | "Eval FORM in the calendar window and return to current window. | 12111 | "Eval FORM in the calendar window and return to current window. |
| 6057 | Also, store the cursor date in variable ans2." | 12112 | Also, store the cursor date in variable org-ans2." |
| 6058 | (let ((sw (selected-window))) | 12113 | (let ((sw (selected-window))) |
| 6059 | (select-window (get-buffer-window "*Calendar*")) | 12114 | (select-window (get-buffer-window "*Calendar*")) |
| 6060 | (eval form) | 12115 | (eval form) |
| 6061 | (when (calendar-cursor-to-date) | 12116 | (when (calendar-cursor-to-date) |
| 6062 | (let* ((date (calendar-cursor-to-date)) | 12117 | (let* ((date (calendar-cursor-to-date)) |
| 6063 | (time (encode-time 0 0 0 (nth 1 date) (nth 0 date) (nth 2 date)))) | 12118 | (time (encode-time 0 0 0 (nth 1 date) (nth 0 date) (nth 2 date)))) |
| 6064 | (setq ans2 (format-time-string "%Y-%m-%d" time)))) | 12119 | (setq org-ans2 (format-time-string "%Y-%m-%d" time)))) |
| 6065 | (org-move-overlay org-date-ovl (1- (point)) (1+ (point)) (current-buffer)) | 12120 | (org-move-overlay org-date-ovl (1- (point)) (1+ (point)) (current-buffer)) |
| 6066 | (select-window sw))) | 12121 | (select-window sw))) |
| 6067 | 12122 | ||
| @@ -6072,7 +12127,7 @@ This is used by `org-read-date' in a temporary keymap for the calendar buffer." | |||
| 6072 | (when (calendar-cursor-to-date) | 12127 | (when (calendar-cursor-to-date) |
| 6073 | (let* ((date (calendar-cursor-to-date)) | 12128 | (let* ((date (calendar-cursor-to-date)) |
| 6074 | (time (encode-time 0 0 0 (nth 1 date) (nth 0 date) (nth 2 date)))) | 12129 | (time (encode-time 0 0 0 (nth 1 date) (nth 0 date) (nth 2 date)))) |
| 6075 | (setq ans1 (format-time-string "%Y-%m-%d" time))) | 12130 | (setq org-ans1 (format-time-string "%Y-%m-%d" time))) |
| 6076 | (if (active-minibuffer-window) (exit-minibuffer)))) | 12131 | (if (active-minibuffer-window) (exit-minibuffer)))) |
| 6077 | 12132 | ||
| 6078 | (defun org-insert-time-stamp (time &optional with-hm inactive pre post) | 12133 | (defun org-insert-time-stamp (time &optional with-hm inactive pre post) |
| @@ -6118,10 +12173,8 @@ The command returns the inserted time stamp." | |||
| 6118 | (org-parse-time-string (buffer-substring beg end) t))) | 12173 | (org-parse-time-string (buffer-substring beg end) t))) |
| 6119 | (w1 (- end beg)) | 12174 | (w1 (- end beg)) |
| 6120 | (with-hm (and (nth 1 t1) (nth 2 t1))) | 12175 | (with-hm (and (nth 1 t1) (nth 2 t1))) |
| 6121 | (inactive (= (char-before (1- beg)) ?\[)) | ||
| 6122 | (tf (funcall (if with-hm 'cdr 'car) org-time-stamp-custom-formats)) | 12176 | (tf (funcall (if with-hm 'cdr 'car) org-time-stamp-custom-formats)) |
| 6123 | (time (org-fix-decoded-time t1)) | 12177 | (time (org-fix-decoded-time t1)) |
| 6124 | (time (mapcar (lambda (x) (or x 0)) t1)) | ||
| 6125 | (str (org-add-props | 12178 | (str (org-add-props |
| 6126 | (format-time-string | 12179 | (format-time-string |
| 6127 | (substring tf 1 -1) (apply 'encode-time time)) | 12180 | (substring tf 1 -1) (apply 'encode-time time)) |
| @@ -6136,6 +12189,33 @@ The command returns the inserted time stamp." | |||
| 6136 | (put-text-property beg end 'end-glyph (make-glyph str))) | 12189 | (put-text-property beg end 'end-glyph (make-glyph str))) |
| 6137 | (put-text-property beg end 'display str)))) | 12190 | (put-text-property beg end 'display str)))) |
| 6138 | 12191 | ||
| 12192 | (defun org-translate-time (string) | ||
| 12193 | "Translate all timestamps in STRING to custom format. | ||
| 12194 | But do this only if the variable `org-display-custom-times' is set." | ||
| 12195 | (when org-display-custom-times | ||
| 12196 | (save-match-data | ||
| 12197 | (let* ((start 0) | ||
| 12198 | (re org-ts-regexp-both) | ||
| 12199 | t1 with-hm inactive tf time str beg end) | ||
| 12200 | (while (setq start (string-match re string start)) | ||
| 12201 | (setq beg (match-beginning 0) | ||
| 12202 | end (match-end 0) | ||
| 12203 | t1 (save-match-data | ||
| 12204 | (org-parse-time-string (substring string beg end) t)) | ||
| 12205 | with-hm (and (nth 1 t1) (nth 2 t1)) | ||
| 12206 | inactive (equal (substring string beg (1+ beg)) "[") | ||
| 12207 | tf (funcall (if with-hm 'cdr 'car) | ||
| 12208 | org-time-stamp-custom-formats) | ||
| 12209 | time (org-fix-decoded-time t1) | ||
| 12210 | str (format-time-string | ||
| 12211 | (concat | ||
| 12212 | (if inactive "[" "<") (substring tf 1 -1) | ||
| 12213 | (if inactive "]" ">")) | ||
| 12214 | (apply 'encode-time time)) | ||
| 12215 | string (replace-match str t t string) | ||
| 12216 | start (+ start (length str))))))) | ||
| 12217 | string) | ||
| 12218 | |||
| 6139 | (defun org-fix-decoded-time (time) | 12219 | (defun org-fix-decoded-time (time) |
| 6140 | "Set 0 instead of nil for the first 6 elements of time. | 12220 | "Set 0 instead of nil for the first 6 elements of time. |
| 6141 | Don't touch the rest." | 12221 | Don't touch the rest." |
| @@ -6161,7 +12241,7 @@ This is used by `org-read-date' in a temporary keymap for the calendar buffer." | |||
| 6161 | (when (calendar-cursor-to-date) | 12241 | (when (calendar-cursor-to-date) |
| 6162 | (let* ((date (calendar-cursor-to-date)) | 12242 | (let* ((date (calendar-cursor-to-date)) |
| 6163 | (time (encode-time 0 0 0 (nth 1 date) (nth 0 date) (nth 2 date)))) | 12243 | (time (encode-time 0 0 0 (nth 1 date) (nth 0 date) (nth 2 date)))) |
| 6164 | (setq ans1 (format-time-string "%Y-%m-%d" time))) | 12244 | (setq org-ans1 (format-time-string "%Y-%m-%d" time))) |
| 6165 | (if (active-minibuffer-window) (exit-minibuffer)))) | 12245 | (if (active-minibuffer-window) (exit-minibuffer)))) |
| 6166 | 12246 | ||
| 6167 | (defun org-check-deadlines (ndays) | 12247 | (defun org-check-deadlines (ndays) |
| @@ -6451,14 +12531,16 @@ If necessary, clock-out of the currently active clock." | |||
| 6451 | (save-excursion | 12531 | (save-excursion |
| 6452 | (org-back-to-heading t) | 12532 | (org-back-to-heading t) |
| 6453 | (beginning-of-line 2) | 12533 | (beginning-of-line 2) |
| 6454 | (if (and (looking-at (concat "[ \t]*" org-keyword-time-regexp)) | 12534 | (when (and (looking-at (concat "[ \t]*" org-keyword-time-regexp)) |
| 6455 | (not (equal (match-string 1) org-clock-string))) | 12535 | (not (equal (match-string 1) org-clock-string))) |
| 6456 | (beginning-of-line 1)) | 12536 | ;; First line hast scheduling info, move one further |
| 12537 | (beginning-of-line 2) | ||
| 12538 | (or (bolp) (newline))) | ||
| 6457 | (insert "\n") (backward-char 1) | 12539 | (insert "\n") (backward-char 1) |
| 6458 | (indent-relative) | 12540 | (indent-relative) |
| 6459 | (insert org-clock-string " ") | 12541 | (insert org-clock-string " ") |
| 6460 | (setq ts (org-insert-time-stamp (current-time) 'with-hm 'inactive)) | 12542 | (setq ts (org-insert-time-stamp (current-time) 'with-hm 'inactive)) |
| 6461 | (move-marker org-clock-marker (point)) | 12543 | (move-marker org-clock-marker (point) (buffer-base-buffer)) |
| 6462 | (message "Clock started at %s" ts)))) | 12544 | (message "Clock started at %s" ts)))) |
| 6463 | 12545 | ||
| 6464 | (defun org-clock-out (&optional fail-quietly) | 12546 | (defun org-clock-out (&optional fail-quietly) |
| @@ -6752,7 +12834,6 @@ the returned times will be formatted strings." | |||
| 6752 | (apply 'encode-time (org-parse-time-string te))))) | 12834 | (apply 'encode-time (org-parse-time-string te))))) |
| 6753 | (move-marker ins (point)) | 12835 | (move-marker ins (point)) |
| 6754 | (setq ipos (point)) | 12836 | (setq ipos (point)) |
| 6755 | ;; FIXME: does not yet use org-insert-time-stamp | ||
| 6756 | (insert-before-markers "Clock summary at [" | 12837 | (insert-before-markers "Clock summary at [" |
| 6757 | (substring | 12838 | (substring |
| 6758 | (format-time-string (cdr org-time-stamp-formats)) | 12839 | (format-time-string (cdr org-time-stamp-formats)) |
| @@ -6796,6 +12877,7 @@ the returned times will be formatted strings." | |||
| 6796 | (skip-chars-forward "^|") | 12877 | (skip-chars-forward "^|") |
| 6797 | (org-table-align))) | 12878 | (org-table-align))) |
| 6798 | 12879 | ||
| 12880 | ;; FIXME: I don't think anybody uses this, ask David | ||
| 6799 | (defun org-collect-clock-time-entries () | 12881 | (defun org-collect-clock-time-entries () |
| 6800 | "Return an internal list with clocking information. | 12882 | "Return an internal list with clocking information. |
| 6801 | This list has one entry for each CLOCK interval. | 12883 | This list has one entry for each CLOCK interval. |
| @@ -6834,9 +12916,9 @@ FIXME: describe the elements." | |||
| 6834 | (goto-char cont))) | 12916 | (goto-char cont))) |
| 6835 | (nreverse rtn))) | 12917 | (nreverse rtn))) |
| 6836 | 12918 | ||
| 6837 | ;;; Agenda, and Diary Integration | 12919 | ;;;; Agenda, and Diary Integration |
| 6838 | 12920 | ||
| 6839 | ;;; Define the mode | 12921 | ;;; Define the Org-agenda-mode |
| 6840 | 12922 | ||
| 6841 | (defvar org-agenda-mode-map (make-sparse-keymap) | 12923 | (defvar org-agenda-mode-map (make-sparse-keymap) |
| 6842 | "Keymap for `org-agenda-mode'.") | 12924 | "Keymap for `org-agenda-mode'.") |
| @@ -6857,6 +12939,8 @@ The following commands are available: | |||
| 6857 | \\{org-agenda-mode-map}" | 12939 | \\{org-agenda-mode-map}" |
| 6858 | (interactive) | 12940 | (interactive) |
| 6859 | (kill-all-local-variables) | 12941 | (kill-all-local-variables) |
| 12942 | (setq org-agenda-undo-list nil | ||
| 12943 | org-agenda-pending-undo-list nil) | ||
| 6860 | (setq major-mode 'org-agenda-mode) | 12944 | (setq major-mode 'org-agenda-mode) |
| 6861 | (setq mode-name "Org-Agenda") | 12945 | (setq mode-name "Org-Agenda") |
| 6862 | (use-local-map org-agenda-mode-map) | 12946 | (use-local-map org-agenda-mode-map) |
| @@ -6864,6 +12948,12 @@ The following commands are available: | |||
| 6864 | (if org-startup-truncated (setq truncate-lines t)) | 12948 | (if org-startup-truncated (setq truncate-lines t)) |
| 6865 | (org-add-hook 'post-command-hook 'org-agenda-post-command-hook nil 'local) | 12949 | (org-add-hook 'post-command-hook 'org-agenda-post-command-hook nil 'local) |
| 6866 | (org-add-hook 'pre-command-hook 'org-unhighlight nil 'local) | 12950 | (org-add-hook 'pre-command-hook 'org-unhighlight nil 'local) |
| 12951 | ;; Make sure properties are removed when copying text | ||
| 12952 | (when (boundp 'buffer-substring-filters) | ||
| 12953 | (org-set-local 'buffer-substring-filters | ||
| 12954 | (cons (lambda (x) | ||
| 12955 | (set-text-properties 0 (length x) nil x) x) | ||
| 12956 | buffer-substring-filters))) | ||
| 6867 | (unless org-agenda-keep-modes | 12957 | (unless org-agenda-keep-modes |
| 6868 | (setq org-agenda-follow-mode org-agenda-start-with-follow-mode | 12958 | (setq org-agenda-follow-mode org-agenda-start-with-follow-mode |
| 6869 | org-agenda-show-log nil)) | 12959 | org-agenda-show-log nil)) |
| @@ -6884,12 +12974,19 @@ The following commands are available: | |||
| 6884 | (if (fboundp 'run-mode-hooks) 'run-mode-hooks 'run-hooks) | 12974 | (if (fboundp 'run-mode-hooks) 'run-mode-hooks 'run-hooks) |
| 6885 | (list 'org-agenda-mode-hook))) | 12975 | (list 'org-agenda-mode-hook))) |
| 6886 | 12976 | ||
| 12977 | (substitute-key-definition 'undo 'org-agenda-undo | ||
| 12978 | org-agenda-mode-map global-map) | ||
| 6887 | (define-key org-agenda-mode-map "\C-i" 'org-agenda-goto) | 12979 | (define-key org-agenda-mode-map "\C-i" 'org-agenda-goto) |
| 6888 | (define-key org-agenda-mode-map [(tab)] 'org-agenda-goto) | 12980 | (define-key org-agenda-mode-map [(tab)] 'org-agenda-goto) |
| 6889 | (define-key org-agenda-mode-map "\C-m" 'org-agenda-switch-to) | 12981 | (define-key org-agenda-mode-map "\C-m" 'org-agenda-switch-to) |
| 6890 | (define-key org-agenda-mode-map "\C-k" 'org-agenda-kill) | 12982 | (define-key org-agenda-mode-map "\C-k" 'org-agenda-kill) |
| 12983 | (define-key org-agenda-mode-map "\C-c$" 'org-agenda-archive) | ||
| 12984 | (define-key org-agenda-mode-map "$" 'org-agenda-archive) | ||
| 12985 | (define-key org-agenda-mode-map "\C-c\C-o" 'org-agenda-open-link) | ||
| 6891 | (define-key org-agenda-mode-map " " 'org-agenda-show) | 12986 | (define-key org-agenda-mode-map " " 'org-agenda-show) |
| 6892 | (define-key org-agenda-mode-map "\C-c\C-t" 'org-agenda-todo) | 12987 | (define-key org-agenda-mode-map "\C-c\C-t" 'org-agenda-todo) |
| 12988 | (define-key org-agenda-mode-map "\C-c\C-xb" 'org-agenda-tree-to-indirect-buffer) | ||
| 12989 | (define-key org-agenda-mode-map "b" 'org-agenda-tree-to-indirect-buffer) | ||
| 6893 | (define-key org-agenda-mode-map "o" 'delete-other-windows) | 12990 | (define-key org-agenda-mode-map "o" 'delete-other-windows) |
| 6894 | (define-key org-agenda-mode-map "L" 'org-agenda-recenter) | 12991 | (define-key org-agenda-mode-map "L" 'org-agenda-recenter) |
| 6895 | (define-key org-agenda-mode-map "t" 'org-agenda-todo) | 12992 | (define-key org-agenda-mode-map "t" 'org-agenda-todo) |
| @@ -6939,8 +13036,8 @@ The following commands are available: | |||
| 6939 | (define-key org-agenda-mode-map "H" 'org-agenda-holidays) | 13036 | (define-key org-agenda-mode-map "H" 'org-agenda-holidays) |
| 6940 | (define-key org-agenda-mode-map "+" 'org-agenda-priority-up) | 13037 | (define-key org-agenda-mode-map "+" 'org-agenda-priority-up) |
| 6941 | (define-key org-agenda-mode-map "I" 'org-agenda-clock-in) | 13038 | (define-key org-agenda-mode-map "I" 'org-agenda-clock-in) |
| 6942 | (define-key org-agenda-mode-map "O" 'org-clock-out) | 13039 | (define-key org-agenda-mode-map "O" 'org-agenda-clock-out) |
| 6943 | (define-key org-agenda-mode-map "X" 'org-clock-cancel) | 13040 | (define-key org-agenda-mode-map "X" 'org-agenda-clock-cancel) |
| 6944 | (define-key org-agenda-mode-map "-" 'org-agenda-priority-down) | 13041 | (define-key org-agenda-mode-map "-" 'org-agenda-priority-down) |
| 6945 | (define-key org-agenda-mode-map (org-key 'S-up) 'org-agenda-priority-up) | 13042 | (define-key org-agenda-mode-map (org-key 'S-up) 'org-agenda-priority-up) |
| 6946 | (define-key org-agenda-mode-map (org-key 'S-down) 'org-agenda-priority-down) | 13043 | (define-key org-agenda-mode-map (org-key 'S-down) 'org-agenda-priority-down) |
| @@ -6967,57 +13064,145 @@ The following commands are available: | |||
| 6967 | ["Go To (this window)" org-agenda-switch-to t] | 13064 | ["Go To (this window)" org-agenda-switch-to t] |
| 6968 | ["Follow Mode" org-agenda-follow-mode | 13065 | ["Follow Mode" org-agenda-follow-mode |
| 6969 | :style toggle :selected org-agenda-follow-mode :active t] | 13066 | :style toggle :selected org-agenda-follow-mode :active t] |
| 13067 | ["Tree to indirect frame" org-agenda-tree-to-indirect-buffer t] | ||
| 6970 | "--" | 13068 | "--" |
| 6971 | ["Cycle TODO" org-agenda-todo t] | 13069 | ["Cycle TODO" org-agenda-todo t] |
| 13070 | ["Archive subtree" org-agenda-archive t] | ||
| 13071 | ["Delete subtree" org-agenda-kill t] | ||
| 13072 | "--" | ||
| 13073 | ["Goto Today" org-agenda-goto-today (org-agenda-check-type nil 'agenda 'timeline)] | ||
| 13074 | ["Next Dates" org-agenda-later (org-agenda-check-type nil 'agenda)] | ||
| 13075 | ["Previous Dates" org-agenda-earlier (org-agenda-check-type nil 'agenda)] | ||
| 13076 | "--" | ||
| 6972 | ("Tags" | 13077 | ("Tags" |
| 6973 | ["Show all Tags" org-agenda-show-tags t] | 13078 | ["Show all Tags" org-agenda-show-tags t] |
| 6974 | ["Set Tags" org-agenda-set-tags t]) | 13079 | ["Set Tags" org-agenda-set-tags t]) |
| 6975 | ("Schedule" | 13080 | ("Date/Schedule" |
| 6976 | ["Schedule" org-agenda-schedule t] | 13081 | ["Schedule" org-agenda-schedule t] |
| 6977 | ["Set Deadline" org-agenda-deadline t] | 13082 | ["Set Deadline" org-agenda-deadline t] |
| 6978 | "--" | 13083 | "--" |
| 6979 | ["Reschedule +1 day" org-agenda-date-later (org-agenda-check-type nil 'agenda 'timeline)] | 13084 | ["Change date +1 day" org-agenda-date-later (org-agenda-check-type nil 'agenda 'timeline)] |
| 6980 | ["Reschedule -1 day" org-agenda-date-earlier (org-agenda-check-type nil 'agenda 'timeline)] | 13085 | ["Change date -1 day" org-agenda-date-earlier (org-agenda-check-type nil 'agenda 'timeline)] |
| 6981 | ["Reschedule to ..." org-agenda-date-prompt (org-agenda-check-type nil 'agenda 'timeline)]) | 13086 | ["Change date to ..." org-agenda-date-prompt (org-agenda-check-type nil 'agenda 'timeline)]) |
| 6982 | ("Priority" | 13087 | ("Priority" |
| 6983 | ["Set Priority" org-agenda-priority t] | 13088 | ["Set Priority" org-agenda-priority t] |
| 6984 | ["Increase Priority" org-agenda-priority-up t] | 13089 | ["Increase Priority" org-agenda-priority-up t] |
| 6985 | ["Decrease Priority" org-agenda-priority-down t] | 13090 | ["Decrease Priority" org-agenda-priority-down t] |
| 6986 | ["Show Priority" org-agenda-show-priority t]) | 13091 | ["Show Priority" org-agenda-show-priority t]) |
| 6987 | "--" | 13092 | ("Calendar/Diary" |
| 6988 | ;; ["New agenda command" org-agenda t] | 13093 | ["New Diary Entry" org-agenda-diary-entry (org-agenda-check-type nil 'agenda 'timeline)] |
| 6989 | ["Rebuild buffer" org-agenda-redo t] | ||
| 6990 | ["Save all Org-mode Buffers" org-save-all-org-buffers t] | ||
| 6991 | "--" | ||
| 6992 | ["Goto Today" org-agenda-goto-today (org-agenda-check-type nil 'agenda 'timeline)] | ||
| 6993 | ["Next Dates" org-agenda-later (org-agenda-check-type nil 'agenda)] | ||
| 6994 | ["Previous Dates" org-agenda-earlier (org-agenda-check-type nil 'agenda)] | ||
| 6995 | "--" | ||
| 6996 | ["Day View" org-agenda-day-view :active (org-agenda-check-type nil 'agenda) | ||
| 6997 | :style radio :selected (equal org-agenda-ndays 1)] | ||
| 6998 | ["Week View" org-agenda-week-view :active (org-agenda-check-type nil 'agenda) | ||
| 6999 | :style radio :selected (equal org-agenda-ndays 7)] | ||
| 7000 | "--" | ||
| 7001 | ["Show Logbook entries" org-agenda-log-mode | ||
| 7002 | :style toggle :selected org-agenda-show-log :active (org-agenda-check-type nil 'agenda 'timeline)] | ||
| 7003 | ["Include Diary" org-agenda-toggle-diary | ||
| 7004 | :style toggle :selected org-agenda-include-diary :active (org-agenda-check-type nil 'agenda)] | ||
| 7005 | ["Use Time Grid" org-agenda-toggle-time-grid | ||
| 7006 | :style toggle :selected org-agenda-use-time-grid :active (org-agenda-check-type nil 'agenda)] | ||
| 7007 | "--" | ||
| 7008 | ["New Diary Entry" org-agenda-diary-entry (org-agenda-check-type nil 'agenda 'timeline)] | ||
| 7009 | ("Calendar Commands" | ||
| 7010 | ["Goto Calendar" org-agenda-goto-calendar (org-agenda-check-type nil 'agenda 'timeline)] | 13094 | ["Goto Calendar" org-agenda-goto-calendar (org-agenda-check-type nil 'agenda 'timeline)] |
| 7011 | ["Phases of the Moon" org-agenda-phases-of-moon (org-agenda-check-type nil 'agenda 'timeline)] | 13095 | ["Phases of the Moon" org-agenda-phases-of-moon (org-agenda-check-type nil 'agenda 'timeline)] |
| 7012 | ["Sunrise/Sunset" org-agenda-sunrise-sunset (org-agenda-check-type nil 'agenda 'timeline)] | 13096 | ["Sunrise/Sunset" org-agenda-sunrise-sunset (org-agenda-check-type nil 'agenda 'timeline)] |
| 7013 | ["Holidays" org-agenda-holidays (org-agenda-check-type nil 'agenda 'timeline)] | 13097 | ["Holidays" org-agenda-holidays (org-agenda-check-type nil 'agenda 'timeline)] |
| 7014 | ["Convert" org-agenda-convert-date (org-agenda-check-type nil 'agenda 'timeline)]) | 13098 | ["Convert" org-agenda-convert-date (org-agenda-check-type nil 'agenda 'timeline)] |
| 7015 | ["Create iCalendar file" org-export-icalendar-combine-agenda-files t] | 13099 | "--" |
| 13100 | ["Create iCalendar file" org-export-icalendar-combine-agenda-files t]) | ||
| 13101 | "--" | ||
| 13102 | ("View" | ||
| 13103 | ["Day View" org-agenda-day-view :active (org-agenda-check-type nil 'agenda) | ||
| 13104 | :style radio :selected (equal org-agenda-ndays 1)] | ||
| 13105 | ["Week View" org-agenda-week-view :active (org-agenda-check-type nil 'agenda) | ||
| 13106 | :style radio :selected (equal org-agenda-ndays 7)] | ||
| 13107 | "--" | ||
| 13108 | ["Show Logbook entries" org-agenda-log-mode | ||
| 13109 | :style toggle :selected org-agenda-show-log :active (org-agenda-check-type nil 'agenda 'timeline)] | ||
| 13110 | ["Include Diary" org-agenda-toggle-diary | ||
| 13111 | :style toggle :selected org-agenda-include-diary :active (org-agenda-check-type nil 'agenda)] | ||
| 13112 | ["Use Time Grid" org-agenda-toggle-time-grid | ||
| 13113 | :style toggle :selected org-agenda-use-time-grid :active (org-agenda-check-type nil 'agenda)]) | ||
| 13114 | ["Rebuild buffer" org-agenda-redo t] | ||
| 13115 | ["Save all Org-mode Buffers" org-save-all-org-buffers t] | ||
| 13116 | "--" | ||
| 13117 | ["Undo Remote Editing" org-agenda-undo org-agenda-undo-list] | ||
| 7016 | "--" | 13118 | "--" |
| 7017 | ["Quit" org-agenda-quit t] | 13119 | ["Quit" org-agenda-quit t] |
| 7018 | ["Exit and Release Buffers" org-agenda-exit t] | 13120 | ["Exit and Release Buffers" org-agenda-exit t] |
| 7019 | )) | 13121 | )) |
| 7020 | 13122 | ||
| 13123 | ;;; Agenda undo | ||
| 13124 | |||
| 13125 | (defvar org-agenda-allow-remote-undo t | ||
| 13126 | "Non-nil means, allow remote undo from the agenda buffer.") | ||
| 13127 | (defvar org-agenda-undo-list nil | ||
| 13128 | "List of undoable operations in the agenda since last refresh.") | ||
| 13129 | (defvar org-agenda-undo-has-started-in nil | ||
| 13130 | "Buffers that have already seen `undo-start' in the current undo sequence.") | ||
| 13131 | (defvar org-agenda-pending-undo-list nil | ||
| 13132 | "In a series of undo commands, this is the list of remaning undo items.") | ||
| 13133 | |||
| 13134 | (defmacro org-if-unprotected (&rest body) | ||
| 13135 | "Execute BODY if ther is no `org-protected' text property at point." | ||
| 13136 | (declare (debug t)) | ||
| 13137 | `(unless (get-text-property (point) 'org-protected) | ||
| 13138 | ,@body)) | ||
| 13139 | |||
| 13140 | (defmacro org-with-remote-undo (_buffer &rest _body) | ||
| 13141 | "Execute BODY while recording undo information in two buffers." | ||
| 13142 | (declare (indent 1) (debug t)) | ||
| 13143 | `(let ((_cline (org-current-line)) | ||
| 13144 | (_cmd this-command) | ||
| 13145 | (_buf1 (current-buffer)) | ||
| 13146 | (_buf2 ,_buffer) | ||
| 13147 | (_undo1 buffer-undo-list) | ||
| 13148 | (_undo2 (with-current-buffer ,_buffer buffer-undo-list)) | ||
| 13149 | _c1 _c2) | ||
| 13150 | ,@_body | ||
| 13151 | (when org-agenda-allow-remote-undo | ||
| 13152 | (setq _c1 (org-verify-change-for-undo | ||
| 13153 | _undo1 (with-current-buffer _buf1 buffer-undo-list)) | ||
| 13154 | _c2 (org-verify-change-for-undo | ||
| 13155 | _undo2 (with-current-buffer _buf2 buffer-undo-list))) | ||
| 13156 | (when (or _c1 _c2) | ||
| 13157 | ;; make sure there are undo boundaries | ||
| 13158 | (and _c1 (with-current-buffer _buf1 (undo-boundary))) | ||
| 13159 | (and _c2 (with-current-buffer _buf2 (undo-boundary))) | ||
| 13160 | ;; remember which buffer to undo | ||
| 13161 | (push (list _cmd _cline _buf1 _c1 _buf2 _c2) | ||
| 13162 | org-agenda-undo-list))))) | ||
| 13163 | |||
| 13164 | (defun org-agenda-undo () | ||
| 13165 | "Undo a remote editing step in the agenda. | ||
| 13166 | This undoes changes both in the agenda buffer and in the remote buffer | ||
| 13167 | that have been changed along." | ||
| 13168 | (interactive) | ||
| 13169 | (or org-agenda-allow-remote-undo | ||
| 13170 | (error "Check the variable `org-agenda-allow-remote-undo' to activate remote undo.")) | ||
| 13171 | (if (not (eq this-command last-command)) | ||
| 13172 | (setq org-agenda-undo-has-started-in nil | ||
| 13173 | org-agenda-pending-undo-list org-agenda-undo-list)) | ||
| 13174 | (if (not org-agenda-pending-undo-list) | ||
| 13175 | (error "No further undo information")) | ||
| 13176 | (let* ((entry (pop org-agenda-pending-undo-list)) | ||
| 13177 | buf line cmd rembuf) | ||
| 13178 | (setq cmd (pop entry) line (pop entry)) | ||
| 13179 | (setq rembuf (nth 2 entry)) | ||
| 13180 | (org-with-remote-undo rembuf | ||
| 13181 | (while (bufferp (setq buf (pop entry))) | ||
| 13182 | (if (pop entry) | ||
| 13183 | (with-current-buffer buf | ||
| 13184 | (let ((last-undo-buffer buf) | ||
| 13185 | buffer-read-only) | ||
| 13186 | (unless (memq buf org-agenda-undo-has-started-in) | ||
| 13187 | (push buf org-agenda-undo-has-started-in) | ||
| 13188 | (make-local-variable 'pending-undo-list) | ||
| 13189 | (undo-start)) | ||
| 13190 | (while (and pending-undo-list | ||
| 13191 | (listp pending-undo-list) | ||
| 13192 | (not (car pending-undo-list))) | ||
| 13193 | (pop pending-undo-list)) | ||
| 13194 | (undo-more 1)))))) | ||
| 13195 | (goto-line line) | ||
| 13196 | (message "`%s' undone (buffer %s)" cmd (buffer-name rembuf)))) | ||
| 13197 | |||
| 13198 | (defun org-verify-change-for-undo (l1 l2) | ||
| 13199 | "Verify that a real change occurred between the undo lists L1 and L2." | ||
| 13200 | (while (and l1 (listp l1) (null (car l1))) (pop l1)) | ||
| 13201 | (while (and l2 (listp l2) (null (car l2))) (pop l2)) | ||
| 13202 | (not (eq l1 l2))) | ||
| 13203 | |||
| 13204 | ;;; Agenda dispatch | ||
| 13205 | |||
| 7021 | (defvar org-agenda-restrict nil) | 13206 | (defvar org-agenda-restrict nil) |
| 7022 | (defvar org-agenda-restrict-begin (make-marker)) | 13207 | (defvar org-agenda-restrict-begin (make-marker)) |
| 7023 | (defvar org-agenda-restrict-end (make-marker)) | 13208 | (defvar org-agenda-restrict-end (make-marker)) |
| @@ -7063,32 +13248,42 @@ next use of \\[org-agenda]) restricted to the current file." | |||
| 7063 | (delete-other-windows) | 13248 | (delete-other-windows) |
| 7064 | (switch-to-buffer-other-window " *Agenda Commands*") | 13249 | (switch-to-buffer-other-window " *Agenda Commands*") |
| 7065 | (erase-buffer) | 13250 | (erase-buffer) |
| 7066 | (insert | 13251 | (insert (eval-when-compile |
| 7067 | "Press key for an agenda command: | 13252 | (let ((header |
| 7068 | -------------------------------- | 13253 | "Press key for an agenda command: |
| 13254 | -------------------------------- C Configure custom agenda commands | ||
| 7069 | a Agenda for current week or day | 13255 | a Agenda for current week or day |
| 7070 | t List of all TODO entries T Entries with special TODO kwd | 13256 | t List of all TODO entries T Entries with special TODO kwd |
| 7071 | m Match a TAGS query M Like m, but only TODO entries | 13257 | m Match a TAGS query M Like m, but only TODO entries |
| 7072 | L Timeline for current buffer C Configure custom agenda commands") | 13258 | L Timeline for current buffer # List stuck projects (!=configure) |
| 13259 | ") | ||
| 13260 | (start 0)) | ||
| 13261 | (while (string-match "\\(^\\| \\|(\\)\\(\\S-\\)\\( \\|=\\)" header start) | ||
| 13262 | (setq start (match-end 0)) | ||
| 13263 | (add-text-properties (match-beginning 2) (match-end 2) | ||
| 13264 | '(face bold) header)) | ||
| 13265 | header))) | ||
| 7073 | (while (setq entry (pop custom)) | 13266 | (while (setq entry (pop custom)) |
| 7074 | (setq key (car entry) type (nth 1 entry) match (nth 2 entry)) | 13267 | (setq key (car entry) type (nth 1 entry) match (nth 2 entry)) |
| 7075 | (insert (format "\n%-4s%-14s: %s" | 13268 | (insert (format "\n%-4s%-14s: %s" |
| 7076 | key | 13269 | (org-add-props (copy-sequence key) |
| 13270 | '(face bold)) | ||
| 7077 | (cond | 13271 | (cond |
| 7078 | ((stringp type) type) | 13272 | ((stringp type) type) |
| 7079 | ((eq type 'tags) "Tags query") | ||
| 7080 | ((eq type 'todo) "TODO keyword") | 13273 | ((eq type 'todo) "TODO keyword") |
| 13274 | ((eq type 'tags) "Tags query") | ||
| 13275 | ((eq type 'tags-todo) "Tags (TODO)") | ||
| 7081 | ((eq type 'tags-tree) "Tags tree") | 13276 | ((eq type 'tags-tree) "Tags tree") |
| 7082 | ((eq type 'todo-tree) "TODO kwd tree") | 13277 | ((eq type 'todo-tree) "TODO kwd tree") |
| 7083 | ((eq type 'occur-tree) "Occur tree") | 13278 | ((eq type 'occur-tree) "Occur tree") |
| 13279 | ((functionp type) (symbol-name type)) | ||
| 7084 | (t "???")) | 13280 | (t "???")) |
| 7085 | (if (stringp match) | 13281 | (if (stringp match) |
| 7086 | (org-add-props match nil 'face 'org-warning) | 13282 | (org-add-props match nil 'face 'org-warning) |
| 7087 | (format "set of %d commands" (+ -2 (length entry))))))) | 13283 | (format "set of %d commands" (length match)))))) |
| 7088 | (if restrict-ok | 13284 | (if restrict-ok |
| 7089 | (insert "\n" | 13285 | (insert "\n" |
| 7090 | (org-add-props "1 Restrict call to current buffer 0 Restrict call to region or subtree" nil 'face 'org-table))) | 13286 | (org-add-props "1 Restrict call to current buffer 0 Restrict call to region or subtree" nil 'face 'org-table))) |
| 7091 | |||
| 7092 | (goto-char (point-min)) | 13287 | (goto-char (point-min)) |
| 7093 | (if (fboundp 'fit-window-to-buffer) (fit-window-to-buffer)) | 13288 | (if (fboundp 'fit-window-to-buffer) (fit-window-to-buffer)) |
| 7094 | (message "Press key for agenda command%s" | 13289 | (message "Press key for agenda command%s" |
| @@ -7123,16 +13318,6 @@ L Timeline for current buffer C Configure custom agenda commands") | |||
| 7123 | (require 'calendar) ; FIXME: can we avoid this for some commands? | 13318 | (require 'calendar) ; FIXME: can we avoid this for some commands? |
| 7124 | ;; For example the todo list should not need it (but does...) | 13319 | ;; For example the todo list should not need it (but does...) |
| 7125 | (cond | 13320 | (cond |
| 7126 | ((equal c ?C) (customize-variable 'org-agenda-custom-commands)) | ||
| 7127 | ((equal c ?a) (call-interactively 'org-agenda-list)) | ||
| 7128 | ((equal c ?t) (call-interactively 'org-todo-list)) | ||
| 7129 | ((equal c ?T) (org-call-with-arg 'org-todo-list (or arg '(4)))) | ||
| 7130 | ((equal c ?m) (call-interactively 'org-tags-view)) | ||
| 7131 | ((equal c ?M) (org-call-with-arg 'org-tags-view (or arg '(4)))) | ||
| 7132 | ((equal c ?L) | ||
| 7133 | (unless restrict-ok | ||
| 7134 | (error "This is not an Org-mode file")) | ||
| 7135 | (org-call-with-arg 'org-timeline arg)) | ||
| 7136 | ((setq entry (assoc (char-to-string c) org-agenda-custom-commands)) | 13321 | ((setq entry (assoc (char-to-string c) org-agenda-custom-commands)) |
| 7137 | (if (symbolp (nth 1 entry)) | 13322 | (if (symbolp (nth 1 entry)) |
| 7138 | (progn | 13323 | (progn |
| @@ -7156,16 +13341,28 @@ L Timeline for current buffer C Configure custom agenda commands") | |||
| 7156 | ((eq type 'occur-tree) | 13341 | ((eq type 'occur-tree) |
| 7157 | (org-check-for-org-mode) | 13342 | (org-check-for-org-mode) |
| 7158 | (org-let lprops '(org-occur match))) | 13343 | (org-let lprops '(org-occur match))) |
| 13344 | ((fboundp type) | ||
| 13345 | (org-let lprops '(funcall type match))) | ||
| 7159 | (t (error "Invalid custom agenda command type %s" type)))) | 13346 | (t (error "Invalid custom agenda command type %s" type)))) |
| 7160 | (org-run-agenda-series (cddr entry)))) | 13347 | (org-run-agenda-series (cddr entry)))) |
| 13348 | ((equal c ?C) (customize-variable 'org-agenda-custom-commands)) | ||
| 13349 | ((equal c ?a) (call-interactively 'org-agenda-list)) | ||
| 13350 | ((equal c ?t) (call-interactively 'org-todo-list)) | ||
| 13351 | ((equal c ?T) (org-call-with-arg 'org-todo-list (or arg '(4)))) | ||
| 13352 | ((equal c ?m) (call-interactively 'org-tags-view)) | ||
| 13353 | ((equal c ?M) (org-call-with-arg 'org-tags-view (or arg '(4)))) | ||
| 13354 | ((equal c ?L) | ||
| 13355 | (unless restrict-ok | ||
| 13356 | (error "This is not an Org-mode file")) | ||
| 13357 | (org-call-with-arg 'org-timeline arg)) | ||
| 13358 | ((equal c ?#) (call-interactively 'org-agenda-list-stuck-projects)) | ||
| 13359 | ((equal c ?!) (customize-variable 'org-stuck-projects)) | ||
| 7161 | (t (error "Invalid key")))))) | 13360 | (t (error "Invalid key")))))) |
| 7162 | 13361 | ||
| 7163 | ;; FIXME: what is the meaning of WINDOW????? | 13362 | (defun org-run-agenda-series (series) |
| 7164 | (defun org-run-agenda-series (series &optional window) | ||
| 7165 | (org-prepare-agenda) | 13363 | (org-prepare-agenda) |
| 7166 | (let* ((org-agenda-multi t) | 13364 | (let* ((org-agenda-multi t) |
| 7167 | (redo (list 'org-run-agenda-series (list 'quote series))) | 13365 | (redo (list 'org-run-agenda-series (list 'quote series))) |
| 7168 | (org-select-agenda-window t) | ||
| 7169 | (cmds (car series)) | 13366 | (cmds (car series)) |
| 7170 | (gprops (nth 1 series)) | 13367 | (gprops (nth 1 series)) |
| 7171 | match ;; The byte compiler incorrectly complains about this. Keep it! | 13368 | match ;; The byte compiler incorrectly complains about this. Keep it! |
| @@ -7177,6 +13374,8 @@ L Timeline for current buffer C Configure custom agenda commands") | |||
| 7177 | (call-interactively 'org-agenda-list)) | 13374 | (call-interactively 'org-agenda-list)) |
| 7178 | ((eq type 'alltodo) | 13375 | ((eq type 'alltodo) |
| 7179 | (call-interactively 'org-todo-list)) | 13376 | (call-interactively 'org-todo-list)) |
| 13377 | ((eq type 'stuck) | ||
| 13378 | (call-interactively 'org-agenda-list-stuck-projects)) | ||
| 7180 | ((eq type 'tags) | 13379 | ((eq type 'tags) |
| 7181 | (org-let2 gprops lprops | 13380 | (org-let2 gprops lprops |
| 7182 | '(org-tags-view current-prefix-arg match))) | 13381 | '(org-tags-view current-prefix-arg match))) |
| @@ -7186,6 +13385,9 @@ L Timeline for current buffer C Configure custom agenda commands") | |||
| 7186 | ((eq type 'todo) | 13385 | ((eq type 'todo) |
| 7187 | (org-let2 gprops lprops | 13386 | (org-let2 gprops lprops |
| 7188 | '(org-todo-list match))) | 13387 | '(org-todo-list match))) |
| 13388 | ((fboundp type) | ||
| 13389 | (org-let2 gprops lprops | ||
| 13390 | '(funcall type match))) | ||
| 7189 | (t (error "Invalid type in command series")))) | 13391 | (t (error "Invalid type in command series")))) |
| 7190 | (widen) | 13392 | (widen) |
| 7191 | (setq org-agenda-redo-command redo) | 13393 | (setq org-agenda-redo-command redo) |
| @@ -7218,12 +13420,13 @@ before running the agenda command." | |||
| 7218 | 13420 | ||
| 7219 | (defun org-fit-agenda-window () | 13421 | (defun org-fit-agenda-window () |
| 7220 | "Fit the window to the buffer size." | 13422 | "Fit the window to the buffer size." |
| 7221 | (and org-fit-agenda-window | 13423 | (and (memq org-agenda-window-setup '(reorganize-frame)) |
| 7222 | (memq org-agenda-window-setup '(reorganize-frame)) | ||
| 7223 | (fboundp 'fit-window-to-buffer) | 13424 | (fboundp 'fit-window-to-buffer) |
| 7224 | (fit-window-to-buffer nil (/ (* (frame-height) 3) 4) | 13425 | (fit-window-to-buffer nil (/ (* (frame-height) 3) 4) |
| 7225 | (/ (frame-height) 2)))) | 13426 | (/ (frame-height) 2)))) |
| 7226 | 13427 | ||
| 13428 | ;;; Agenda file list | ||
| 13429 | |||
| 7227 | (defun org-agenda-files (&optional unrestricted) | 13430 | (defun org-agenda-files (&optional unrestricted) |
| 7228 | "Get the list of agenda files. | 13431 | "Get the list of agenda files. |
| 7229 | Optional UNRESTRICTED means return the full list even if a restriction | 13432 | Optional UNRESTRICTED means return the full list even if a restriction |
| @@ -7234,8 +13437,6 @@ is currently in place." | |||
| 7234 | ((listp org-agenda-files) org-agenda-files) | 13437 | ((listp org-agenda-files) org-agenda-files) |
| 7235 | (t (error "Invalid value of `org-agenda-files'")))) | 13438 | (t (error "Invalid value of `org-agenda-files'")))) |
| 7236 | 13439 | ||
| 7237 | (defvar org-window-configuration) | ||
| 7238 | |||
| 7239 | (defun org-edit-agenda-file-list () | 13440 | (defun org-edit-agenda-file-list () |
| 7240 | "Edit the list of agenda files. | 13441 | "Edit the list of agenda files. |
| 7241 | Depending on setup, this either uses customize to edit the variable | 13442 | Depending on setup, this either uses customize to edit the variable |
| @@ -7277,6 +13478,197 @@ the buffer and restores the previous window configuration." | |||
| 7277 | (insert-file-contents org-agenda-files) | 13478 | (insert-file-contents org-agenda-files) |
| 7278 | (org-split-string (buffer-string) "[ \t\r\n]*?[\r\n][ \t\r\n]*")))) | 13479 | (org-split-string (buffer-string) "[ \t\r\n]*?[\r\n][ \t\r\n]*")))) |
| 7279 | 13480 | ||
| 13481 | |||
| 13482 | ;;;###autoload | ||
| 13483 | (defun org-cycle-agenda-files () | ||
| 13484 | "Cycle through the files in `org-agenda-files'. | ||
| 13485 | If the current buffer visits an agenda file, find the next one in the list. | ||
| 13486 | If the current buffer does not, find the first agenda file." | ||
| 13487 | (interactive) | ||
| 13488 | (let* ((fs (org-agenda-files t)) | ||
| 13489 | (files (append fs (list (car fs)))) | ||
| 13490 | (tcf (if buffer-file-name (file-truename buffer-file-name))) | ||
| 13491 | file) | ||
| 13492 | (unless files (error "No agenda files")) | ||
| 13493 | (catch 'exit | ||
| 13494 | (while (setq file (pop files)) | ||
| 13495 | (if (equal (file-truename file) tcf) | ||
| 13496 | (when (car files) | ||
| 13497 | (find-file (car files)) | ||
| 13498 | (throw 'exit t)))) | ||
| 13499 | (find-file (car fs))) | ||
| 13500 | (if (buffer-base-buffer) (switch-to-buffer (buffer-base-buffer))))) | ||
| 13501 | |||
| 13502 | (defun org-agenda-file-to-end () | ||
| 13503 | "Move/add the current file to the end of the agenda file list. | ||
| 13504 | If the file is not present in the list, it is appended to the list. If it is | ||
| 13505 | present, it is moved there." | ||
| 13506 | (interactive) | ||
| 13507 | (org-agenda-file-to-front 'to-end)) | ||
| 13508 | |||
| 13509 | (defun org-agenda-file-to-front (&optional to-end) | ||
| 13510 | "Move/add the current file to the top of the agenda file list. | ||
| 13511 | If the file is not present in the list, it is added to the front. If it is | ||
| 13512 | present, it is moved there. With optional argument TO-END, add/move to the | ||
| 13513 | end of the list." | ||
| 13514 | (interactive "P") | ||
| 13515 | (let ((file-alist (mapcar (lambda (x) | ||
| 13516 | (cons (file-truename x) x)) | ||
| 13517 | (org-agenda-files t))) | ||
| 13518 | (ctf (file-truename buffer-file-name)) | ||
| 13519 | x had) | ||
| 13520 | (setq x (assoc ctf file-alist) had x) | ||
| 13521 | |||
| 13522 | (if (not x) (setq x (cons ctf (abbreviate-file-name buffer-file-name)))) | ||
| 13523 | (if to-end | ||
| 13524 | (setq file-alist (append (delq x file-alist) (list x))) | ||
| 13525 | (setq file-alist (cons x (delq x file-alist)))) | ||
| 13526 | (org-store-new-agenda-file-list (mapcar 'cdr file-alist)) | ||
| 13527 | (org-install-agenda-files-menu) | ||
| 13528 | (message "File %s to %s of agenda file list" | ||
| 13529 | (if had "moved" "added") (if to-end "end" "front")))) | ||
| 13530 | |||
| 13531 | (defun org-remove-file (&optional file) | ||
| 13532 | "Remove current file from the list of files in variable `org-agenda-files'. | ||
| 13533 | These are the files which are being checked for agenda entries. | ||
| 13534 | Optional argument FILE means, use this file instead of the current." | ||
| 13535 | (interactive) | ||
| 13536 | (let* ((file (or file buffer-file-name)) | ||
| 13537 | (true-file (file-truename file)) | ||
| 13538 | (afile (abbreviate-file-name file)) | ||
| 13539 | (files (delq nil (mapcar | ||
| 13540 | (lambda (x) | ||
| 13541 | (if (equal true-file | ||
| 13542 | (file-truename x)) | ||
| 13543 | nil x)) | ||
| 13544 | (org-agenda-files t))))) | ||
| 13545 | (if (not (= (length files) (length (org-agenda-files t)))) | ||
| 13546 | (progn | ||
| 13547 | (org-store-new-agenda-file-list files) | ||
| 13548 | (org-install-agenda-files-menu) | ||
| 13549 | (message "Removed file: %s" afile)) | ||
| 13550 | (message "File was not in list: %s" afile)))) | ||
| 13551 | |||
| 13552 | (defun org-file-menu-entry (file) | ||
| 13553 | (vector file (list 'find-file file) t)) | ||
| 13554 | |||
| 13555 | (defun org-check-agenda-file (file) | ||
| 13556 | "Make sure FILE exists. If not, ask user what to do." | ||
| 13557 | (when (not (file-exists-p file)) | ||
| 13558 | (message "non-existent file %s. [R]emove from list or [A]bort?" | ||
| 13559 | (abbreviate-file-name file)) | ||
| 13560 | (let ((r (downcase (read-char-exclusive)))) | ||
| 13561 | (cond | ||
| 13562 | ((equal r ?r) | ||
| 13563 | (org-remove-file file) | ||
| 13564 | (throw 'nextfile t)) | ||
| 13565 | (t (error "Abort")))))) | ||
| 13566 | |||
| 13567 | ;;; Agenda prepare and finalize | ||
| 13568 | |||
| 13569 | (defvar org-agenda-multi nil) ; dynammically scoped | ||
| 13570 | (defvar org-agenda-buffer-name "*Org Agenda*") | ||
| 13571 | (defvar org-pre-agenda-window-conf nil) | ||
| 13572 | (defun org-prepare-agenda () | ||
| 13573 | (if org-agenda-multi | ||
| 13574 | (progn | ||
| 13575 | (setq buffer-read-only nil) | ||
| 13576 | (goto-char (point-max)) | ||
| 13577 | (unless (= (point) 1) | ||
| 13578 | (insert "\n" (make-string (window-width) ?=) "\n")) | ||
| 13579 | (narrow-to-region (point) (point-max))) | ||
| 13580 | (org-agenda-maybe-reset-markers 'force) | ||
| 13581 | (org-prepare-agenda-buffers (org-agenda-files)) | ||
| 13582 | (let* ((abuf (get-buffer-create org-agenda-buffer-name)) | ||
| 13583 | (awin (get-buffer-window abuf))) | ||
| 13584 | (cond | ||
| 13585 | ((equal (current-buffer) abuf) nil) | ||
| 13586 | (awin (select-window awin)) | ||
| 13587 | ((not (setq org-pre-agenda-window-conf (current-window-configuration)))) | ||
| 13588 | ((equal org-agenda-window-setup 'current-window) | ||
| 13589 | (switch-to-buffer abuf)) | ||
| 13590 | ((equal org-agenda-window-setup 'other-window) | ||
| 13591 | (switch-to-buffer-other-window abuf)) | ||
| 13592 | ((equal org-agenda-window-setup 'other-frame) | ||
| 13593 | (switch-to-buffer-other-frame abuf)) | ||
| 13594 | ((equal org-agenda-window-setup 'reorganize-frame) | ||
| 13595 | (delete-other-windows) | ||
| 13596 | (switch-to-buffer-other-window abuf)))) | ||
| 13597 | (setq buffer-read-only nil) | ||
| 13598 | (erase-buffer) | ||
| 13599 | (org-agenda-mode)) | ||
| 13600 | (setq buffer-read-only nil)) | ||
| 13601 | |||
| 13602 | (defun org-finalize-agenda () | ||
| 13603 | "Finishing touch for the agenda buffer, called just before displaying it." | ||
| 13604 | (unless org-agenda-multi | ||
| 13605 | (org-agenda-align-tags) | ||
| 13606 | (save-excursion | ||
| 13607 | (let ((buffer-read-only)) | ||
| 13608 | (goto-char (point-min)) | ||
| 13609 | (while (org-activate-bracket-links (point-max)) | ||
| 13610 | (add-text-properties (match-beginning 0) (match-end 0) | ||
| 13611 | '(face org-link)))) | ||
| 13612 | (run-hooks 'org-finalize-agenda-hook)))) | ||
| 13613 | |||
| 13614 | (defun org-prepare-agenda-buffers (files) | ||
| 13615 | "Create buffers for all agenda files, protect archived trees and comments." | ||
| 13616 | (interactive) | ||
| 13617 | (let ((pa '(:org-archived t)) | ||
| 13618 | (pc '(:org-comment t)) | ||
| 13619 | (pall '(:org-archived t :org-comment t)) | ||
| 13620 | (rea (concat ":" org-archive-tag ":")) | ||
| 13621 | bmp file re) | ||
| 13622 | (save-excursion | ||
| 13623 | (save-restriction | ||
| 13624 | (while (setq file (pop files)) | ||
| 13625 | (org-check-agenda-file file) | ||
| 13626 | (set-buffer (org-get-agenda-file-buffer file)) | ||
| 13627 | (widen) | ||
| 13628 | (setq bmp (buffer-modified-p)) | ||
| 13629 | (save-excursion | ||
| 13630 | (remove-text-properties (point-min) (point-max) pall) | ||
| 13631 | (when org-agenda-skip-archived-trees | ||
| 13632 | (goto-char (point-min)) | ||
| 13633 | (while (re-search-forward rea nil t) | ||
| 13634 | (if (org-on-heading-p) | ||
| 13635 | (add-text-properties (point-at-bol) (org-end-of-subtree t) pa)))) | ||
| 13636 | (goto-char (point-min)) | ||
| 13637 | (setq re (concat "^\\*+ +" org-comment-string "\\>")) | ||
| 13638 | (while (re-search-forward re nil t) | ||
| 13639 | (add-text-properties | ||
| 13640 | (match-beginning 0) (org-end-of-subtree t) pc))) | ||
| 13641 | (set-buffer-modified-p bmp)))))) | ||
| 13642 | |||
| 13643 | (defvar org-agenda-skip-function nil | ||
| 13644 | "Function to be called at each match during agenda construction. | ||
| 13645 | If this function return nil, the current match should not be skipped. | ||
| 13646 | Otherwise, the function must return a position from where the search | ||
| 13647 | should be continued. | ||
| 13648 | Never set this variable using `setq' or so, because then it will apply | ||
| 13649 | to all future agenda commands. Instead, bind it with `let' to scope | ||
| 13650 | it dynamically into the agenda-constructing command.") | ||
| 13651 | |||
| 13652 | (defun org-agenda-skip () | ||
| 13653 | "Throw to `:skip' in places that should be skipped. | ||
| 13654 | Also moves point to the end of the skipped region, so that search can | ||
| 13655 | continue from there." | ||
| 13656 | (let ((p (point-at-bol)) to) | ||
| 13657 | (and org-agenda-skip-archived-trees | ||
| 13658 | (get-text-property p :org-archived) | ||
| 13659 | (org-end-of-subtree t) | ||
| 13660 | (throw :skip t)) | ||
| 13661 | (and (get-text-property p :org-comment) | ||
| 13662 | (org-end-of-subtree t) | ||
| 13663 | (throw :skip t)) | ||
| 13664 | (if (equal (char-after p) ?#) (throw :skip t)) | ||
| 13665 | (when (and (functionp org-agenda-skip-function) | ||
| 13666 | (setq to (save-excursion | ||
| 13667 | (save-match-data | ||
| 13668 | (funcall org-agenda-skip-function))))) | ||
| 13669 | (goto-char to) | ||
| 13670 | (throw :skip t)))) | ||
| 13671 | |||
| 7280 | (defvar org-agenda-markers nil | 13672 | (defvar org-agenda-markers nil |
| 7281 | "List of all currently active markers created by `org-agenda'.") | 13673 | "List of all currently active markers created by `org-agenda'.") |
| 7282 | (defvar org-agenda-last-marker-time (time-to-seconds (current-time)) | 13674 | (defvar org-agenda-last-marker-time (time-to-seconds (current-time)) |
| @@ -7306,9 +13698,9 @@ no longer in use." | |||
| 7306 | (defun org-get-agenda-file-buffer (file) | 13698 | (defun org-get-agenda-file-buffer (file) |
| 7307 | "Get a buffer visiting FILE. If the buffer needs to be created, add | 13699 | "Get a buffer visiting FILE. If the buffer needs to be created, add |
| 7308 | it to the list of buffers which might be released later." | 13700 | it to the list of buffers which might be released later." |
| 7309 | (let ((buf (find-buffer-visiting file))) | 13701 | (let ((buf (org-find-base-buffer-visiting file))) |
| 7310 | (if buf | 13702 | (if buf |
| 7311 | buf ; just return it | 13703 | buf ; just return it |
| 7312 | ;; Make a new buffer and remember it | 13704 | ;; Make a new buffer and remember it |
| 7313 | (setq buf (find-file-noselect file)) | 13705 | (setq buf (find-file-noselect file)) |
| 7314 | (if buf (push buf org-agenda-new-buffers)) | 13706 | (if buf (push buf org-agenda-new-buffers)) |
| @@ -7327,6 +13719,36 @@ When a buffer is unmodified, it is just killed. When modified, it is saved | |||
| 7327 | (with-current-buffer buf (save-buffer))) | 13719 | (with-current-buffer buf (save-buffer))) |
| 7328 | (kill-buffer buf)))) | 13720 | (kill-buffer buf)))) |
| 7329 | 13721 | ||
| 13722 | (defvar org-category-table nil) | ||
| 13723 | (defun org-get-category-table () | ||
| 13724 | "Get the table of categories and positions in current buffer." | ||
| 13725 | (let (tbl) | ||
| 13726 | (save-excursion | ||
| 13727 | (goto-char (point-min)) | ||
| 13728 | (while (re-search-forward "\\(^\\|\r\\)#\\+CATEGORY:[ \t]*\\(.*\\)" nil t) | ||
| 13729 | (push (cons (point) (org-trim (match-string 2))) tbl))) | ||
| 13730 | tbl)) | ||
| 13731 | |||
| 13732 | (defun org-get-category (&optional pos) | ||
| 13733 | "Get the category applying to position POS." | ||
| 13734 | (if (not org-category-table) | ||
| 13735 | (cond | ||
| 13736 | ((null org-category) | ||
| 13737 | (setq org-category | ||
| 13738 | (if buffer-file-name | ||
| 13739 | (file-name-sans-extension | ||
| 13740 | (file-name-nondirectory buffer-file-name)) | ||
| 13741 | "???"))) | ||
| 13742 | ((symbolp org-category) (symbol-name org-category)) | ||
| 13743 | (t org-category)) | ||
| 13744 | (let ((tbl org-category-table) | ||
| 13745 | (pos (or pos (point)))) | ||
| 13746 | (while (and tbl (> (caar tbl) pos)) | ||
| 13747 | (pop tbl)) | ||
| 13748 | (or (cdar tbl) (cdr (nth (1- (length org-category-table)) | ||
| 13749 | org-category-table)))))) | ||
| 13750 | ;;; Agenda timeline | ||
| 13751 | |||
| 7330 | (defun org-timeline (&optional include-all) | 13752 | (defun org-timeline (&optional include-all) |
| 7331 | "Show a time-sorted view of the entries in the current org file. | 13753 | "Show a time-sorted view of the entries in the current org file. |
| 7332 | Only entries with a time stamp of today or later will be listed. With | 13754 | Only entries with a time stamp of today or later will be listed. With |
| @@ -7343,8 +13765,6 @@ dates." | |||
| 7343 | (doclosed org-agenda-show-log) | 13765 | (doclosed org-agenda-show-log) |
| 7344 | (entry buffer-file-name) | 13766 | (entry buffer-file-name) |
| 7345 | (date (calendar-current-date)) | 13767 | (date (calendar-current-date)) |
| 7346 | (win (selected-window)) | ||
| 7347 | (pos1 (point)) | ||
| 7348 | (beg (if (org-region-active-p) (region-beginning) (point-min))) | 13768 | (beg (if (org-region-active-p) (region-beginning) (point-min))) |
| 7349 | (end (if (org-region-active-p) (region-end) (point-max))) | 13769 | (end (if (org-region-active-p) (region-end) (point-max))) |
| 7350 | (day-numbers (org-get-all-dates beg end 'no-ranges | 13770 | (day-numbers (org-get-all-dates beg end 'no-ranges |
| @@ -7391,8 +13811,12 @@ dates." | |||
| 7391 | (number-to-string (extract-calendar-day date)) " " | 13811 | (number-to-string (extract-calendar-day date)) " " |
| 7392 | (calendar-month-name (extract-calendar-month date)) " " | 13812 | (calendar-month-name (extract-calendar-month date)) " " |
| 7393 | (number-to-string (extract-calendar-year date)) "\n") | 13813 | (number-to-string (extract-calendar-year date)) "\n") |
| 7394 | (put-text-property s (1- (point)) 'face | 13814 | ; FIXME: this gives a timezone problem |
| 7395 | 'org-level-3) | 13815 | ; (insert (format-time-string org-agenda-date-format |
| 13816 | ; (calendar-time-from-absolute d 0)) | ||
| 13817 | ; "\n") | ||
| 13818 | (put-text-property s (1- (point)) 'face 'org-level-3) | ||
| 13819 | (put-text-property s (1- (point)) 'org-date-line t) | ||
| 7396 | (if (equal d today) | 13820 | (if (equal d today) |
| 7397 | (put-text-property s (1- (point)) 'org-today t)) | 13821 | (put-text-property s (1- (point)) 'org-today t)) |
| 7398 | (and rtn (insert (org-finalize-agenda-entries rtn) "\n")) | 13822 | (and rtn (insert (org-finalize-agenda-entries rtn) "\n")) |
| @@ -7402,14 +13826,56 @@ dates." | |||
| 7402 | (point-min))) | 13826 | (point-min))) |
| 7403 | (add-text-properties (point-min) (point-max) '(org-agenda-type timeline)) | 13827 | (add-text-properties (point-min) (point-max) '(org-agenda-type timeline)) |
| 7404 | (org-finalize-agenda) | 13828 | (org-finalize-agenda) |
| 7405 | (setq buffer-read-only t) | 13829 | (setq buffer-read-only t))) |
| 7406 | (when (not org-select-agenda-window) | 13830 | |
| 7407 | (select-window win) | 13831 | (defun org-get-all-dates (beg end &optional no-ranges force-today inactive empty) |
| 7408 | (goto-char pos1)))) | 13832 | "Return a list of all relevant day numbers from BEG to END buffer positions. |
| 13833 | If NO-RANGES is non-nil, include only the start and end dates of a range, | ||
| 13834 | not every single day in the range. If FORCE-TODAY is non-nil, make | ||
| 13835 | sure that TODAY is included in the list. If INACTIVE is non-nil, also | ||
| 13836 | inactive time stamps (those in square brackets) are included. | ||
| 13837 | When EMPTY is non-nil, also include days without any entries." | ||
| 13838 | (let ((re (if inactive org-ts-regexp-both org-ts-regexp)) | ||
| 13839 | dates dates1 date day day1 day2 ts1 ts2) | ||
| 13840 | (if force-today | ||
| 13841 | (setq dates (list (time-to-days (current-time))))) | ||
| 13842 | (save-excursion | ||
| 13843 | (goto-char beg) | ||
| 13844 | (while (re-search-forward re end t) | ||
| 13845 | (setq day (time-to-days (org-time-string-to-time | ||
| 13846 | (substring (match-string 1) 0 10)))) | ||
| 13847 | (or (memq day dates) (push day dates))) | ||
| 13848 | (unless no-ranges | ||
| 13849 | (goto-char beg) | ||
| 13850 | (while (re-search-forward org-tr-regexp end t) | ||
| 13851 | (setq ts1 (substring (match-string 1) 0 10) | ||
| 13852 | ts2 (substring (match-string 2) 0 10) | ||
| 13853 | day1 (time-to-days (org-time-string-to-time ts1)) | ||
| 13854 | day2 (time-to-days (org-time-string-to-time ts2))) | ||
| 13855 | (while (< (setq day1 (1+ day1)) day2) | ||
| 13856 | (or (memq day1 dates) (push day1 dates))))) | ||
| 13857 | (setq dates (sort dates '<)) | ||
| 13858 | (when empty | ||
| 13859 | (while (setq day (pop dates)) | ||
| 13860 | (setq day2 (car dates)) | ||
| 13861 | (push day dates1) | ||
| 13862 | (when (and day2 empty) | ||
| 13863 | (if (or (eq empty t) | ||
| 13864 | (and (numberp empty) (<= (- day2 day) empty))) | ||
| 13865 | (while (< (setq day (1+ day)) day2) | ||
| 13866 | (push (list day) dates1)) | ||
| 13867 | (push (cons :omitted (- day2 day)) dates1)))) | ||
| 13868 | (setq dates (nreverse dates1))) | ||
| 13869 | dates))) | ||
| 13870 | |||
| 13871 | ;;; Agenda Daily/Weekly | ||
| 7409 | 13872 | ||
| 7410 | (defvar org-agenda-overriding-arguments nil) ; dynamically scoped parameter | 13873 | (defvar org-agenda-overriding-arguments nil) ; dynamically scoped parameter |
| 7411 | (defvar org-agenda-last-arguments nil | 13874 | (defvar org-agenda-last-arguments nil |
| 7412 | "The arguments of the previous call to org-agenda") | 13875 | "The arguments of the previous call to org-agenda") |
| 13876 | (defvar org-starting-day nil) ; local variable in the agenda buffer | ||
| 13877 | (defvar org-include-all-loc nil) ; local variable | ||
| 13878 | |||
| 7413 | 13879 | ||
| 7414 | ;;;###autoload | 13880 | ;;;###autoload |
| 7415 | (defun org-agenda-list (&optional include-all start-day ndays) | 13881 | (defun org-agenda-list (&optional include-all start-day ndays) |
| @@ -7439,7 +13905,6 @@ NDAYS defaults to `org-agenda-ndays'." | |||
| 7439 | nil org-agenda-start-on-weekday)) | 13905 | nil org-agenda-start-on-weekday)) |
| 7440 | (thefiles (org-agenda-files)) | 13906 | (thefiles (org-agenda-files)) |
| 7441 | (files thefiles) | 13907 | (files thefiles) |
| 7442 | (win (selected-window)) | ||
| 7443 | (today (time-to-days (current-time))) | 13908 | (today (time-to-days (current-time))) |
| 7444 | (sd (or start-day today)) | 13909 | (sd (or start-day today)) |
| 7445 | (start (if (or (null org-agenda-start-on-weekday) | 13910 | (start (if (or (null org-agenda-start-on-weekday) |
| @@ -7451,7 +13916,7 @@ NDAYS defaults to `org-agenda-ndays'." | |||
| 7451 | (d (- nt n1))) | 13916 | (d (- nt n1))) |
| 7452 | (- sd (+ (if (< d 0) 7 0) d))))) | 13917 | (- sd (+ (if (< d 0) 7 0) d))))) |
| 7453 | (day-numbers (list start)) | 13918 | (day-numbers (list start)) |
| 7454 | (inhibit-redisplay t) | 13919 | (inhibit-redisplay (not debug-on-error)) |
| 7455 | s e rtn rtnall file date d start-pos end-pos todayp nd) | 13920 | s e rtn rtnall file date d start-pos end-pos todayp nd) |
| 7456 | (setq org-agenda-redo-command | 13921 | (setq org-agenda-redo-command |
| 7457 | (list 'org-agenda-list (list 'quote include-all) start-day ndays)) | 13922 | (list 'org-agenda-list (list 'quote include-all) start-day ndays)) |
| @@ -7463,8 +13928,8 @@ NDAYS defaults to `org-agenda-ndays'." | |||
| 7463 | (setq ndays (1- ndays))) | 13928 | (setq ndays (1- ndays))) |
| 7464 | (setq day-numbers (nreverse day-numbers)) | 13929 | (setq day-numbers (nreverse day-numbers)) |
| 7465 | (org-prepare-agenda) | 13930 | (org-prepare-agenda) |
| 7466 | (org-set-local 'starting-day (car day-numbers)) | 13931 | (org-set-local 'org-starting-day (car day-numbers)) |
| 7467 | (org-set-local 'include-all-loc include-all) | 13932 | (org-set-local 'org-include-all-loc include-all) |
| 7468 | (when (and (or include-all org-agenda-include-all-todo) | 13933 | (when (and (or include-all org-agenda-include-all-todo) |
| 7469 | (member today day-numbers)) | 13934 | (member today day-numbers)) |
| 7470 | (setq files thefiles | 13935 | (setq files thefiles |
| @@ -7517,10 +13982,12 @@ NDAYS defaults to `org-agenda-ndays'." | |||
| 7517 | (extract-calendar-day date) | 13982 | (extract-calendar-day date) |
| 7518 | (calendar-month-name (extract-calendar-month date)) | 13983 | (calendar-month-name (extract-calendar-month date)) |
| 7519 | (extract-calendar-year date))) | 13984 | (extract-calendar-year date))) |
| 7520 | (put-text-property s (1- (point)) 'face | 13985 | ; FIXME: this gives a timezone problem |
| 7521 | 'org-level-3) | 13986 | ; (insert (format-time-string org-agenda-date-format |
| 13987 | ; (calendar-time-from-absolute d 0)) "\n") | ||
| 13988 | (put-text-property s (1- (point)) 'face 'org-level-3) | ||
| 13989 | (put-text-property s (1- (point)) 'org-date-line t) | ||
| 7522 | (if todayp (put-text-property s (1- (point)) 'org-today t)) | 13990 | (if todayp (put-text-property s (1- (point)) 'org-today t)) |
| 7523 | |||
| 7524 | (if rtnall (insert | 13991 | (if rtnall (insert |
| 7525 | (org-finalize-agenda-entries | 13992 | (org-finalize-agenda-entries |
| 7526 | (org-agenda-add-time-grid-maybe | 13993 | (org-agenda-add-time-grid-maybe |
| @@ -7541,10 +14008,12 @@ NDAYS defaults to `org-agenda-ndays'." | |||
| 7541 | (add-text-properties (point-min) (point-max) '(org-agenda-type agenda)) | 14008 | (add-text-properties (point-min) (point-max) '(org-agenda-type agenda)) |
| 7542 | (org-finalize-agenda) | 14009 | (org-finalize-agenda) |
| 7543 | (setq buffer-read-only t) | 14010 | (setq buffer-read-only t) |
| 7544 | (if (not org-select-agenda-window) (select-window win)) | ||
| 7545 | (message ""))) | 14011 | (message ""))) |
| 7546 | 14012 | ||
| 14013 | ;;; Agenda TODO list | ||
| 14014 | |||
| 7547 | (defvar org-select-this-todo-keyword nil) | 14015 | (defvar org-select-this-todo-keyword nil) |
| 14016 | (defvar org-last-arg nil) | ||
| 7548 | 14017 | ||
| 7549 | ;;;###autoload | 14018 | ;;;###autoload |
| 7550 | (defun org-todo-list (arg) | 14019 | (defun org-todo-list (arg) |
| @@ -7559,7 +14028,6 @@ for a keyword. A numeric prefix directly selects the Nth keyword in | |||
| 7559 | (org-set-sorting-strategy 'todo) | 14028 | (org-set-sorting-strategy 'todo) |
| 7560 | (let* ((today (time-to-days (current-time))) | 14029 | (let* ((today (time-to-days (current-time))) |
| 7561 | (date (calendar-gregorian-from-absolute today)) | 14030 | (date (calendar-gregorian-from-absolute today)) |
| 7562 | (win (selected-window)) | ||
| 7563 | (kwds org-todo-keywords) | 14031 | (kwds org-todo-keywords) |
| 7564 | (completion-ignore-case t) | 14032 | (completion-ignore-case t) |
| 7565 | (org-select-this-todo-keyword | 14033 | (org-select-this-todo-keyword |
| @@ -7573,10 +14041,10 @@ for a keyword. A numeric prefix directly selects the Nth keyword in | |||
| 7573 | nil t))) | 14041 | nil t))) |
| 7574 | (and (equal 0 arg) (setq org-select-this-todo-keyword nil)) | 14042 | (and (equal 0 arg) (setq org-select-this-todo-keyword nil)) |
| 7575 | (org-prepare-agenda) | 14043 | (org-prepare-agenda) |
| 7576 | (org-set-local 'last-arg arg) | 14044 | (org-set-local 'org-last-arg arg) |
| 7577 | (org-set-local 'org-todo-keywords kwds) | 14045 | (org-set-local 'org-todo-keywords kwds) |
| 7578 | (setq org-agenda-redo-command | 14046 | (setq org-agenda-redo-command |
| 7579 | '(org-todo-list (or current-prefix-arg last-arg))) | 14047 | '(org-todo-list (or current-prefix-arg org-last-arg))) |
| 7580 | (setq files (org-agenda-files) | 14048 | (setq files (org-agenda-files) |
| 7581 | rtnall nil) | 14049 | rtnall nil) |
| 7582 | (while (setq file (pop files)) | 14050 | (while (setq file (pop files)) |
| @@ -7584,262 +14052,154 @@ for a keyword. A numeric prefix directly selects the Nth keyword in | |||
| 7584 | (org-check-agenda-file file) | 14052 | (org-check-agenda-file file) |
| 7585 | (setq rtn (org-agenda-get-day-entries file date :todo)) | 14053 | (setq rtn (org-agenda-get-day-entries file date :todo)) |
| 7586 | (setq rtnall (append rtnall rtn)))) | 14054 | (setq rtnall (append rtnall rtn)))) |
| 7587 | (insert "Global list of TODO items of type: ") | 14055 | (if org-agenda-overriding-header |
| 7588 | (add-text-properties (point-min) (1- (point)) | 14056 | (insert (org-add-props (copy-sequence org-agenda-overriding-header) |
| 7589 | (list 'face 'org-level-3)) | 14057 | nil 'face 'org-level-3) "\n") |
| 7590 | (setq pos (point)) | 14058 | (insert "Global list of TODO items of type: ") |
| 7591 | (insert (or org-select-this-todo-keyword "ALL") "\n") | 14059 | (add-text-properties (point-min) (1- (point)) |
| 7592 | (add-text-properties pos (1- (point)) (list 'face 'org-warning)) | 14060 | (list 'face 'org-level-3)) |
| 7593 | (setq pos (point)) | 14061 | (setq pos (point)) |
| 7594 | (unless org-agenda-multi | 14062 | (insert (or org-select-this-todo-keyword "ALL") "\n") |
| 7595 | (insert | 14063 | (add-text-properties pos (1- (point)) (list 'face 'org-warning)) |
| 7596 | "Available with `N r': (0)ALL " | 14064 | (setq pos (point)) |
| 7597 | (let ((n 0)) | 14065 | (unless org-agenda-multi |
| 7598 | (mapconcat (lambda (x) | 14066 | (insert |
| 7599 | (format "(%d)%s" (setq n (1+ n)) x)) | 14067 | "Available with `N r': (0)ALL " |
| 7600 | org-todo-keywords " ")) | 14068 | (let ((n 0)) |
| 7601 | "\n")) | 14069 | (mapconcat (lambda (x) |
| 7602 | (add-text-properties pos (1- (point)) (list 'face 'org-level-3)) | 14070 | (format "(%d)%s" (setq n (1+ n)) x)) |
| 14071 | org-todo-keywords " ")) | ||
| 14072 | "\n")) | ||
| 14073 | (add-text-properties pos (1- (point)) (list 'face 'org-level-3))) | ||
| 7603 | (when rtnall | 14074 | (when rtnall |
| 7604 | (insert (org-finalize-agenda-entries rtnall) "\n")) | 14075 | (insert (org-finalize-agenda-entries rtnall) "\n")) |
| 7605 | (goto-char (point-min)) | 14076 | (goto-char (point-min)) |
| 7606 | (org-fit-agenda-window) | 14077 | (org-fit-agenda-window) |
| 7607 | (add-text-properties (point-min) (point-max) '(org-agenda-type todo)) | 14078 | (add-text-properties (point-min) (point-max) '(org-agenda-type todo)) |
| 7608 | (org-finalize-agenda) | 14079 | (org-finalize-agenda) |
| 7609 | (setq buffer-read-only t) | 14080 | (setq buffer-read-only t))) |
| 7610 | (if (not org-select-agenda-window) (select-window win)))) | ||
| 7611 | |||
| 7612 | (defun org-check-agenda-file (file) | ||
| 7613 | "Make sure FILE exists. If not, ask user what to do." | ||
| 7614 | (when (not (file-exists-p file)) | ||
| 7615 | (message "non-existent file %s. [R]emove from list or [A]bort?" | ||
| 7616 | (abbreviate-file-name file)) | ||
| 7617 | (let ((r (downcase (read-char-exclusive)))) | ||
| 7618 | (cond | ||
| 7619 | ((equal r ?r) | ||
| 7620 | (org-remove-file file) | ||
| 7621 | (throw 'nextfile t)) | ||
| 7622 | (t (error "Abort")))))) | ||
| 7623 | |||
| 7624 | (defun org-agenda-check-type (error &rest types) | ||
| 7625 | "Check if agenda buffer is of allowed type. | ||
| 7626 | If ERROR is non-nil, throw an error, otherwise just return nil." | ||
| 7627 | (if (memq org-agenda-type types) | ||
| 7628 | t | ||
| 7629 | (if error | ||
| 7630 | (error "Not allowed in %s-type agenda buffers" org-agenda-type) | ||
| 7631 | nil))) | ||
| 7632 | 14081 | ||
| 7633 | (defun org-agenda-quit () | 14082 | ;;; Agenda tags match |
| 7634 | "Exit agenda by removing the window or the buffer." | ||
| 7635 | (interactive) | ||
| 7636 | (let ((buf (current-buffer))) | ||
| 7637 | (if (not (one-window-p)) (delete-window)) | ||
| 7638 | (kill-buffer buf) | ||
| 7639 | (org-agenda-maybe-reset-markers 'force)) | ||
| 7640 | ;; Maybe restore the pre-agenda window configuration. | ||
| 7641 | (and org-agenda-restore-windows-after-quit | ||
| 7642 | (not (eq org-agenda-window-setup 'other-frame)) | ||
| 7643 | org-pre-agenda-window-conf | ||
| 7644 | (set-window-configuration org-pre-agenda-window-conf))) | ||
| 7645 | |||
| 7646 | (defun org-agenda-exit () | ||
| 7647 | "Exit agenda by removing the window or the buffer. | ||
| 7648 | Also kill all Org-mode buffers which have been loaded by `org-agenda'. | ||
| 7649 | Org-mode buffers visited directly by the user will not be touched." | ||
| 7650 | (interactive) | ||
| 7651 | (org-release-buffers org-agenda-new-buffers) | ||
| 7652 | (setq org-agenda-new-buffers nil) | ||
| 7653 | (org-agenda-quit)) | ||
| 7654 | |||
| 7655 | (defun org-save-all-org-buffers () | ||
| 7656 | "Save all Org-mode buffers without user confirmation." | ||
| 7657 | (interactive) | ||
| 7658 | (message "Saving all Org-mode buffers...") | ||
| 7659 | (save-some-buffers t 'org-mode-p) | ||
| 7660 | (message "Saving all Org-mode buffers... done")) | ||
| 7661 | |||
| 7662 | (defun org-agenda-redo () | ||
| 7663 | "Rebuild Agenda. | ||
| 7664 | When this is the global TODO list, a prefix argument will be interpreted." | ||
| 7665 | (interactive) | ||
| 7666 | (let* ((org-agenda-keep-modes t) | ||
| 7667 | (line (org-current-line)) | ||
| 7668 | (window-line (- line (org-current-line (window-start))))) | ||
| 7669 | (message "Rebuilding agenda buffer...") | ||
| 7670 | (eval org-agenda-redo-command) | ||
| 7671 | (message "Rebuilding agenda buffer...done") | ||
| 7672 | (goto-line line) | ||
| 7673 | (recenter window-line))) | ||
| 7674 | |||
| 7675 | (defun org-agenda-goto-today () | ||
| 7676 | "Go to today." | ||
| 7677 | (interactive) | ||
| 7678 | (org-agenda-check-type t 'timeline 'agenda) | ||
| 7679 | (let ((tdpos (text-property-any (point-min) (point-max) 'org-today t))) | ||
| 7680 | (cond | ||
| 7681 | (tdpos (goto-char tdpos)) | ||
| 7682 | ((eq org-agenda-type 'agenda) | ||
| 7683 | (let ((org-agenda-overriding-arguments org-agenda-last-arguments)) | ||
| 7684 | (setf (nth 1 org-agenda-overriding-arguments) nil) | ||
| 7685 | (org-agenda-redo) | ||
| 7686 | (org-agenda-find-today-or-agenda))) | ||
| 7687 | (t (error "Cannot find today"))))) | ||
| 7688 | |||
| 7689 | (defun org-agenda-find-today-or-agenda () | ||
| 7690 | (goto-char | ||
| 7691 | (or (text-property-any (point-min) (point-max) 'org-today t) | ||
| 7692 | (text-property-any (point-min) (point-max) 'org-agenda-type 'agenda) | ||
| 7693 | (point-min)))) | ||
| 7694 | |||
| 7695 | (defun org-agenda-later (arg) | ||
| 7696 | "Go forward in time by `org-agenda-ndays' days. | ||
| 7697 | With prefix ARG, go forward that many times `org-agenda-ndays'." | ||
| 7698 | (interactive "p") | ||
| 7699 | (org-agenda-check-type t 'agenda) | ||
| 7700 | (let ((org-agenda-overriding-arguments | ||
| 7701 | (list (car org-agenda-last-arguments) | ||
| 7702 | (+ starting-day (* arg org-agenda-ndays)) | ||
| 7703 | nil t))) | ||
| 7704 | (org-agenda-redo) | ||
| 7705 | (org-agenda-find-today-or-agenda))) | ||
| 7706 | |||
| 7707 | (defun org-agenda-earlier (arg) | ||
| 7708 | "Go back in time by `org-agenda-ndays' days. | ||
| 7709 | With prefix ARG, go back that many times `org-agenda-ndays'." | ||
| 7710 | (interactive "p") | ||
| 7711 | (org-agenda-check-type t 'agenda) | ||
| 7712 | (let ((org-agenda-overriding-arguments | ||
| 7713 | (list (car org-agenda-last-arguments) | ||
| 7714 | (- starting-day (* arg org-agenda-ndays)) | ||
| 7715 | nil t))) | ||
| 7716 | (org-agenda-redo) | ||
| 7717 | (org-agenda-find-today-or-agenda))) | ||
| 7718 | |||
| 7719 | (defun org-agenda-week-view () | ||
| 7720 | "Switch to weekly view for agenda." | ||
| 7721 | (interactive) | ||
| 7722 | (org-agenda-check-type t 'agenda) | ||
| 7723 | (if (= org-agenda-ndays 7) | ||
| 7724 | (error "This is already the week view")) | ||
| 7725 | (setq org-agenda-ndays 7) | ||
| 7726 | (let ((org-agenda-overriding-arguments | ||
| 7727 | (list (car org-agenda-last-arguments) | ||
| 7728 | (or (get-text-property (point) 'day) | ||
| 7729 | starting-day) | ||
| 7730 | nil t))) | ||
| 7731 | (org-agenda-redo) | ||
| 7732 | (org-agenda-find-today-or-agenda)) | ||
| 7733 | (org-agenda-set-mode-name) | ||
| 7734 | (message "Switched to week view")) | ||
| 7735 | |||
| 7736 | (defun org-agenda-day-view () | ||
| 7737 | "Switch to daily view for agenda." | ||
| 7738 | (interactive) | ||
| 7739 | (org-agenda-check-type t 'agenda) | ||
| 7740 | (if (= org-agenda-ndays 1) | ||
| 7741 | (error "This is already the day view")) | ||
| 7742 | (setq org-agenda-ndays 1) | ||
| 7743 | (let ((org-agenda-overriding-arguments | ||
| 7744 | (list (car org-agenda-last-arguments) | ||
| 7745 | (or (get-text-property (point) 'day) | ||
| 7746 | starting-day) | ||
| 7747 | nil t))) | ||
| 7748 | (org-agenda-redo) | ||
| 7749 | (org-agenda-find-today-or-agenda)) | ||
| 7750 | (org-agenda-set-mode-name) | ||
| 7751 | (message "Switched to day view")) | ||
| 7752 | |||
| 7753 | (defun org-agenda-next-date-line (&optional arg) | ||
| 7754 | "Jump to the next line indicating a date in agenda buffer." | ||
| 7755 | (interactive "p") | ||
| 7756 | (org-agenda-check-type t 'agenda 'timeline) | ||
| 7757 | (beginning-of-line 1) | ||
| 7758 | (if (looking-at "^\\S-") (forward-char 1)) | ||
| 7759 | (if (not (re-search-forward "^\\S-" nil t arg)) | ||
| 7760 | (progn | ||
| 7761 | (backward-char 1) | ||
| 7762 | (error "No next date after this line in this buffer"))) | ||
| 7763 | (goto-char (match-beginning 0))) | ||
| 7764 | |||
| 7765 | (defun org-agenda-previous-date-line (&optional arg) | ||
| 7766 | "Jump to the previous line indicating a date in agenda buffer." | ||
| 7767 | (interactive "p") | ||
| 7768 | (org-agenda-check-type t 'agenda 'timeline) | ||
| 7769 | (beginning-of-line 1) | ||
| 7770 | (if (not (re-search-backward "^\\S-" nil t arg)) | ||
| 7771 | (error "No previous date before this line in this buffer"))) | ||
| 7772 | |||
| 7773 | ;; Initialize the highlight | ||
| 7774 | (defvar org-hl (org-make-overlay 1 1)) | ||
| 7775 | (org-overlay-put org-hl 'face 'highlight) | ||
| 7776 | |||
| 7777 | (defun org-highlight (begin end &optional buffer) | ||
| 7778 | "Highlight a region with overlay." | ||
| 7779 | (funcall (if (featurep 'xemacs) 'set-extent-endpoints 'move-overlay) | ||
| 7780 | org-hl begin end (or buffer (current-buffer)))) | ||
| 7781 | |||
| 7782 | (defun org-unhighlight () | ||
| 7783 | "Detach overlay INDEX." | ||
| 7784 | (funcall (if (featurep 'xemacs) 'detach-extent 'delete-overlay) org-hl)) | ||
| 7785 | 14083 | ||
| 14084 | ;;;###autoload | ||
| 14085 | (defun org-tags-view (&optional todo-only match) | ||
| 14086 | "Show all headlines for all `org-agenda-files' matching a TAGS criterion. | ||
| 14087 | The prefix arg TODO-ONLY limits the search to TODO entries." | ||
| 14088 | (interactive "P") | ||
| 14089 | (org-compile-prefix-format 'tags) | ||
| 14090 | (org-set-sorting-strategy 'tags) | ||
| 14091 | (let* ((org-tags-match-list-sublevels | ||
| 14092 | (if todo-only t org-tags-match-list-sublevels)) | ||
| 14093 | (completion-ignore-case t) | ||
| 14094 | rtn rtnall files file pos matcher | ||
| 14095 | buffer) | ||
| 14096 | (setq matcher (org-make-tags-matcher match) | ||
| 14097 | match (car matcher) matcher (cdr matcher)) | ||
| 14098 | (org-prepare-agenda) | ||
| 14099 | (setq org-agenda-redo-command | ||
| 14100 | (list 'org-tags-view (list 'quote todo-only) | ||
| 14101 | (list 'if 'current-prefix-arg nil match))) | ||
| 14102 | (setq files (org-agenda-files) | ||
| 14103 | rtnall nil) | ||
| 14104 | (while (setq file (pop files)) | ||
| 14105 | (catch 'nextfile | ||
| 14106 | (org-check-agenda-file file) | ||
| 14107 | (setq buffer (if (file-exists-p file) | ||
| 14108 | (org-get-agenda-file-buffer file) | ||
| 14109 | (error "No such file %s" file))) | ||
| 14110 | (if (not buffer) | ||
| 14111 | ;; If file does not exist, merror message to agenda | ||
| 14112 | (setq rtn (list | ||
| 14113 | (format "ORG-AGENDA-ERROR: No such org-file %s" file)) | ||
| 14114 | rtnall (append rtnall rtn)) | ||
| 14115 | (with-current-buffer buffer | ||
| 14116 | (unless (org-mode-p) | ||
| 14117 | (error "Agenda file %s is not in `org-mode'" file)) | ||
| 14118 | (setq org-category-table (org-get-category-table)) | ||
| 14119 | (save-excursion | ||
| 14120 | (save-restriction | ||
| 14121 | (if org-agenda-restrict | ||
| 14122 | (narrow-to-region org-agenda-restrict-begin | ||
| 14123 | org-agenda-restrict-end) | ||
| 14124 | (widen)) | ||
| 14125 | (setq rtn (org-scan-tags 'agenda matcher todo-only)) | ||
| 14126 | (setq rtnall (append rtnall rtn)))))))) | ||
| 14127 | (if org-agenda-overriding-header | ||
| 14128 | (insert (org-add-props (copy-sequence org-agenda-overriding-header) | ||
| 14129 | nil 'face 'org-level-3) "\n") | ||
| 14130 | (insert "Headlines with TAGS match: ") | ||
| 14131 | (add-text-properties (point-min) (1- (point)) | ||
| 14132 | (list 'face 'org-level-3)) | ||
| 14133 | (setq pos (point)) | ||
| 14134 | (insert match "\n") | ||
| 14135 | (add-text-properties pos (1- (point)) (list 'face 'org-warning)) | ||
| 14136 | (setq pos (point)) | ||
| 14137 | (unless org-agenda-multi | ||
| 14138 | (insert "Press `C-u r' to search again with new search string\n")) | ||
| 14139 | (add-text-properties pos (1- (point)) (list 'face 'org-level-3))) | ||
| 14140 | (when rtnall | ||
| 14141 | (insert (org-finalize-agenda-entries rtnall) "\n")) | ||
| 14142 | (goto-char (point-min)) | ||
| 14143 | (org-fit-agenda-window) | ||
| 14144 | (add-text-properties (point-min) (point-max) '(org-agenda-type tags)) | ||
| 14145 | (org-finalize-agenda) | ||
| 14146 | (setq buffer-read-only t))) | ||
| 7786 | 14147 | ||
| 7787 | (defun org-agenda-follow-mode () | 14148 | ;;; Agenda Finding stuck projects |
| 7788 | "Toggle follow mode in an agenda buffer." | ||
| 7789 | (interactive) | ||
| 7790 | (setq org-agenda-follow-mode (not org-agenda-follow-mode)) | ||
| 7791 | (org-agenda-set-mode-name) | ||
| 7792 | (message "Follow mode is %s" | ||
| 7793 | (if org-agenda-follow-mode "on" "off"))) | ||
| 7794 | 14149 | ||
| 7795 | (defun org-agenda-log-mode () | 14150 | (defvar org-agenda-skip-regexp nil |
| 7796 | "Toggle log mode in an agenda buffer." | 14151 | "Regular expression used in skipping subtrees for the agenda. |
| 7797 | (interactive) | 14152 | This is basically a temporary global variable that can be set and then |
| 7798 | (org-agenda-check-type t 'agenda 'timeline) | 14153 | used by user-defined selections using `org-agenda-skip-function'.") |
| 7799 | (setq org-agenda-show-log (not org-agenda-show-log)) | ||
| 7800 | (org-agenda-set-mode-name) | ||
| 7801 | (org-agenda-redo) | ||
| 7802 | (message "Log mode is %s" | ||
| 7803 | (if org-agenda-show-log "on" "off"))) | ||
| 7804 | 14154 | ||
| 7805 | (defun org-agenda-toggle-diary () | 14155 | (defvar org-agenda-overriding-header nil |
| 7806 | "Toggle diary inclusion in an agenda buffer." | 14156 | "When this is set during todo and tags searches, will replace header.") |
| 7807 | (interactive) | ||
| 7808 | (org-agenda-check-type t 'agenda) | ||
| 7809 | (setq org-agenda-include-diary (not org-agenda-include-diary)) | ||
| 7810 | (org-agenda-redo) | ||
| 7811 | (org-agenda-set-mode-name) | ||
| 7812 | (message "Diary inclusion turned %s" | ||
| 7813 | (if org-agenda-include-diary "on" "off"))) | ||
| 7814 | 14157 | ||
| 7815 | (defun org-agenda-toggle-time-grid () | 14158 | (defun org-agenda-skip-subtree-when-regexp-matches () |
| 7816 | "Toggle time grid in an agenda buffer." | 14159 | "Checks if the current subtree contains match for `org-agenda-skip-regexp'. |
| 14160 | If yes, it returns the end position of this tree, causing agenda commands | ||
| 14161 | to skip this subtree. This is a function that can be put into | ||
| 14162 | `org-agenda-skip-function' for the duration of a command." | ||
| 14163 | (save-match-data | ||
| 14164 | (let ((end (save-excursion (org-end-of-subtree t))) | ||
| 14165 | skip) | ||
| 14166 | (save-excursion | ||
| 14167 | (setq skip (re-search-forward org-agenda-skip-regexp end t))) | ||
| 14168 | (and skip end)))) | ||
| 14169 | |||
| 14170 | (defun org-agenda-list-stuck-projects (&rest ignore) | ||
| 14171 | "Create agenda view for projects that are stuck. | ||
| 14172 | Stuck projects are project that have no next actions. For the definitions | ||
| 14173 | of what a project is and how to check if it stuck, customize the variable | ||
| 14174 | `org-stuck-projects'. | ||
| 14175 | MATCH is being ignored." | ||
| 7817 | (interactive) | 14176 | (interactive) |
| 7818 | (org-agenda-check-type t 'agenda) | 14177 | (let* ((org-agenda-skip-function 'org-agenda-skip-subtree-when-regexp-matches) |
| 7819 | (setq org-agenda-use-time-grid (not org-agenda-use-time-grid)) | 14178 | (org-agenda-overriding-header "List of stuck projects: ") |
| 7820 | (org-agenda-redo) | 14179 | (matcher (nth 0 org-stuck-projects)) |
| 7821 | (org-agenda-set-mode-name) | 14180 | (todo (nth 1 org-stuck-projects)) |
| 7822 | (message "Time-grid turned %s" | 14181 | (tags (nth 2 org-stuck-projects)) |
| 7823 | (if org-agenda-use-time-grid "on" "off"))) | 14182 | (todo-re (concat "^\\*+[ \t]+\\(" |
| 7824 | 14183 | (mapconcat 'identity todo "\\|") | |
| 7825 | (defun org-agenda-set-mode-name () | 14184 | "\\)\\>")) |
| 7826 | "Set the mode name to indicate all the small mode settings." | 14185 | (tags-re (concat "^\\*+.*:\\(" |
| 7827 | (setq mode-name | 14186 | (mapconcat 'identity tags "\\|") |
| 7828 | (concat "Org-Agenda" | 14187 | "\\):[a-zA-Z0-9_@:]*[ \t]*$"))) |
| 7829 | (if (equal org-agenda-ndays 1) " Day" "") | 14188 | |
| 7830 | (if (equal org-agenda-ndays 7) " Week" "") | 14189 | (setq org-agenda-skip-regexp |
| 7831 | (if org-agenda-follow-mode " Follow" "") | 14190 | (cond |
| 7832 | (if org-agenda-include-diary " Diary" "") | 14191 | ((and todo tags) |
| 7833 | (if org-agenda-use-time-grid " Grid" "") | 14192 | (concat todo-re "\\|" tags-re)) |
| 7834 | (if org-agenda-show-log " Log" ""))) | 14193 | (todo todo-re) |
| 7835 | (force-mode-line-update)) | 14194 | (tags tags-re) |
| 7836 | 14195 | (t (error "No information how to identify unstuck projects")))) | |
| 7837 | (defun org-agenda-post-command-hook () | 14196 | (org-tags-view nil matcher) |
| 7838 | (and (eolp) (not (bolp)) (backward-char 1)) | 14197 | (with-current-buffer org-agenda-buffer-name |
| 7839 | (setq org-agenda-type (get-text-property (point) 'org-agenda-type)) | 14198 | (setq org-agenda-redo-command |
| 7840 | (if (and org-agenda-follow-mode | 14199 | '(org-agenda-list-stuck-projects |
| 7841 | (get-text-property (point) 'org-marker)) | 14200 | (or current-prefix-arg org-last-arg)))))) |
| 7842 | (org-agenda-show))) | 14201 | |
| 14202 | ;;; Diary integration | ||
| 7843 | 14203 | ||
| 7844 | (defvar org-disable-agenda-to-diary nil) ;Dynamically-scoped param. | 14204 | (defvar org-disable-agenda-to-diary nil) ;Dynamically-scoped param. |
| 7845 | 14205 | ||
| @@ -7936,118 +14296,6 @@ Needed to avoid empty dates which mess up holiday display." | |||
| 7936 | (add-to-diary-list original-date "Org-mode dummy" "" nil))))) | 14296 | (add-to-diary-list original-date "Org-mode dummy" "" nil))))) |
| 7937 | 14297 | ||
| 7938 | ;;;###autoload | 14298 | ;;;###autoload |
| 7939 | (defun org-cycle-agenda-files () | ||
| 7940 | "Cycle through the files in `org-agenda-files'. | ||
| 7941 | If the current buffer visits an agenda file, find the next one in the list. | ||
| 7942 | If the current buffer does not, find the first agenda file." | ||
| 7943 | (interactive) | ||
| 7944 | (let* ((fs (org-agenda-files t)) | ||
| 7945 | (files (append fs (list (car fs)))) | ||
| 7946 | (tcf (if buffer-file-name (file-truename buffer-file-name))) | ||
| 7947 | file) | ||
| 7948 | (unless files (error "No agenda files")) | ||
| 7949 | (catch 'exit | ||
| 7950 | (while (setq file (pop files)) | ||
| 7951 | (if (equal (file-truename file) tcf) | ||
| 7952 | (when (car files) | ||
| 7953 | (find-file (car files)) | ||
| 7954 | (throw 'exit t)))) | ||
| 7955 | (find-file (car fs))))) | ||
| 7956 | |||
| 7957 | (defun org-agenda-file-to-end () | ||
| 7958 | "Move/add the current file to the end of the agenda file list. | ||
| 7959 | If the file is not present in the list, it is appended to the list. If it is | ||
| 7960 | present, it is moved there." | ||
| 7961 | (interactive) | ||
| 7962 | (org-agenda-file-to-front 'to-end)) | ||
| 7963 | |||
| 7964 | (defun org-agenda-file-to-front (&optional to-end) | ||
| 7965 | "Move/add the current file to the top of the agenda file list. | ||
| 7966 | If the file is not present in the list, it is added to the front. If it is | ||
| 7967 | present, it is moved there. With optional argument TO-END, add/move to the | ||
| 7968 | end of the list." | ||
| 7969 | (interactive "P") | ||
| 7970 | (let ((file-alist (mapcar (lambda (x) | ||
| 7971 | (cons (file-truename x) x)) | ||
| 7972 | (org-agenda-files t))) | ||
| 7973 | (ctf (file-truename buffer-file-name)) | ||
| 7974 | x had) | ||
| 7975 | (setq x (assoc ctf file-alist) had x) | ||
| 7976 | |||
| 7977 | (if (not x) (setq x (cons ctf (abbreviate-file-name buffer-file-name)))) | ||
| 7978 | (if to-end | ||
| 7979 | (setq file-alist (append (delq x file-alist) (list x))) | ||
| 7980 | (setq file-alist (cons x (delq x file-alist)))) | ||
| 7981 | (org-store-new-agenda-file-list (mapcar 'cdr file-alist)) | ||
| 7982 | (org-install-agenda-files-menu) | ||
| 7983 | (message "File %s to %s of agenda file list" | ||
| 7984 | (if had "moved" "added") (if to-end "end" "front")))) | ||
| 7985 | |||
| 7986 | (defun org-remove-file (&optional file) | ||
| 7987 | "Remove current file from the list of files in variable `org-agenda-files'. | ||
| 7988 | These are the files which are being checked for agenda entries. | ||
| 7989 | Optional argument FILE means, use this file instead of the current." | ||
| 7990 | (interactive) | ||
| 7991 | (let* ((file (or file buffer-file-name)) | ||
| 7992 | (true-file (file-truename file)) | ||
| 7993 | (afile (abbreviate-file-name file)) | ||
| 7994 | (files (delq nil (mapcar | ||
| 7995 | (lambda (x) | ||
| 7996 | (if (equal true-file | ||
| 7997 | (file-truename x)) | ||
| 7998 | nil x)) | ||
| 7999 | (org-agenda-files t))))) | ||
| 8000 | (if (not (= (length files) (length (org-agenda-files t)))) | ||
| 8001 | (progn | ||
| 8002 | (org-store-new-agenda-file-list files) | ||
| 8003 | (org-install-agenda-files-menu) | ||
| 8004 | (message "Removed file: %s" afile)) | ||
| 8005 | (message "File was not in list: %s" afile)))) | ||
| 8006 | |||
| 8007 | (defun org-file-menu-entry (file) | ||
| 8008 | (vector file (list 'find-file file) t)) | ||
| 8009 | |||
| 8010 | (defun org-get-all-dates (beg end &optional no-ranges force-today inactive empty) | ||
| 8011 | "Return a list of all relevant day numbers from BEG to END buffer positions. | ||
| 8012 | If NO-RANGES is non-nil, include only the start and end dates of a range, | ||
| 8013 | not every single day in the range. If FORCE-TODAY is non-nil, make | ||
| 8014 | sure that TODAY is included in the list. If INACTIVE is non-nil, also | ||
| 8015 | inactive time stamps (those in square brackets) are included. | ||
| 8016 | When EMPTY is non-nil, also include days without any entries." | ||
| 8017 | (let ((re (if inactive org-ts-regexp-both org-ts-regexp)) | ||
| 8018 | dates dates1 date day day1 day2 ts1 ts2) | ||
| 8019 | (if force-today | ||
| 8020 | (setq dates (list (time-to-days (current-time))))) | ||
| 8021 | (save-excursion | ||
| 8022 | (goto-char beg) | ||
| 8023 | (while (re-search-forward re end t) | ||
| 8024 | (setq day (time-to-days (org-time-string-to-time | ||
| 8025 | (substring (match-string 1) 0 10)))) | ||
| 8026 | (or (memq day dates) (push day dates))) | ||
| 8027 | (unless no-ranges | ||
| 8028 | (goto-char beg) | ||
| 8029 | (while (re-search-forward org-tr-regexp end t) | ||
| 8030 | (setq ts1 (substring (match-string 1) 0 10) | ||
| 8031 | ts2 (substring (match-string 2) 0 10) | ||
| 8032 | day1 (time-to-days (org-time-string-to-time ts1)) | ||
| 8033 | day2 (time-to-days (org-time-string-to-time ts2))) | ||
| 8034 | (while (< (setq day1 (1+ day1)) day2) | ||
| 8035 | (or (memq day1 dates) (push day1 dates))))) | ||
| 8036 | (setq dates (sort dates '<)) | ||
| 8037 | (when empty | ||
| 8038 | (while (setq day (pop dates)) | ||
| 8039 | (setq day2 (car dates)) | ||
| 8040 | (push day dates1) | ||
| 8041 | (when (and day2 empty) | ||
| 8042 | (if (or (eq empty t) | ||
| 8043 | (and (numberp empty) (<= (- day2 day) empty))) | ||
| 8044 | (while (< (setq day (1+ day)) day2) | ||
| 8045 | (push (list day) dates1)) | ||
| 8046 | (push (cons :omitted (- day2 day)) dates1)))) | ||
| 8047 | (setq dates (nreverse dates1))) | ||
| 8048 | dates))) | ||
| 8049 | |||
| 8050 | ;;;###autoload | ||
| 8051 | (defun org-diary (&rest args) | 14299 | (defun org-diary (&rest args) |
| 8052 | "Return diary information from org-files. | 14300 | "Return diary information from org-files. |
| 8053 | This function can be used in a \"sexp\" diary entry in the Emacs calendar. | 14301 | This function can be used in a \"sexp\" diary entry in the Emacs calendar. |
| @@ -8107,33 +14355,8 @@ function from a program - use `org-agenda-get-day-entries' instead." | |||
| 8107 | (setq results (append results rtn))) | 14355 | (setq results (append results rtn))) |
| 8108 | (if results | 14356 | (if results |
| 8109 | (concat (org-finalize-agenda-entries results) "\n")))) | 14357 | (concat (org-finalize-agenda-entries results) "\n")))) |
| 8110 | (defvar org-category-table nil) | 14358 | |
| 8111 | (defun org-get-category-table () | 14359 | ;;; Agenda entry finders |
| 8112 | "Get the table of categories and positions in current buffer." | ||
| 8113 | (let (tbl) | ||
| 8114 | (save-excursion | ||
| 8115 | (goto-char (point-min)) | ||
| 8116 | (while (re-search-forward "\\(^\\|\r\\)#\\+CATEGORY:[ \t]*\\(.*\\)" nil t) | ||
| 8117 | (push (cons (point) (org-trim (match-string 2))) tbl))) | ||
| 8118 | tbl)) | ||
| 8119 | (defun org-get-category (&optional pos) | ||
| 8120 | "Get the category applying to position POS." | ||
| 8121 | (if (not org-category-table) | ||
| 8122 | (cond | ||
| 8123 | ((null org-category) | ||
| 8124 | (setq org-category | ||
| 8125 | (if buffer-file-name | ||
| 8126 | (file-name-sans-extension | ||
| 8127 | (file-name-nondirectory buffer-file-name)) | ||
| 8128 | "???"))) | ||
| 8129 | ((symbolp org-category) (symbol-name org-category)) | ||
| 8130 | (t org-category)) | ||
| 8131 | (let ((tbl org-category-table) | ||
| 8132 | (pos (or pos (point)))) | ||
| 8133 | (while (and tbl (> (caar tbl) pos)) | ||
| 8134 | (pop tbl)) | ||
| 8135 | (or (cdar tbl) (cdr (nth (1- (length org-category-table)) | ||
| 8136 | org-category-table)))))) | ||
| 8137 | 14360 | ||
| 8138 | (defun org-agenda-get-day-entries (file date &rest args) | 14361 | (defun org-agenda-get-day-entries (file date &rest args) |
| 8139 | "Does the work for `org-diary' and `org-agenda'. | 14362 | "Does the work for `org-diary' and `org-agenda'. |
| @@ -8142,8 +14365,7 @@ the one returned by `calendar-current-date'. ARGS are symbols indicating | |||
| 8142 | which kind of entries should be extracted. For details about these, see | 14365 | which kind of entries should be extracted. For details about these, see |
| 8143 | the documentation of `org-diary'." | 14366 | the documentation of `org-diary'." |
| 8144 | (setq args (or args '(:deadline :scheduled :timestamp))) | 14367 | (setq args (or args '(:deadline :scheduled :timestamp))) |
| 8145 | (let* ((org-startup-with-deadline-check nil) | 14368 | (let* ((org-startup-folded nil) |
| 8146 | (org-startup-folded nil) | ||
| 8147 | (org-startup-align-all-tables nil) | 14369 | (org-startup-align-all-tables nil) |
| 8148 | (buffer (if (file-exists-p file) | 14370 | (buffer (if (file-exists-p file) |
| 8149 | (org-get-agenda-file-buffer file) | 14371 | (org-get-agenda-file-buffer file) |
| @@ -8227,23 +14449,20 @@ the documentation of `org-diary'." | |||
| 8227 | "\\)\\>") | 14449 | "\\)\\>") |
| 8228 | org-not-done-regexp) | 14450 | org-not-done-regexp) |
| 8229 | "[^\n\r]*\\)")) | 14451 | "[^\n\r]*\\)")) |
| 8230 | (deadline-re (concat ".*\\(\n[^*].*\\)?" org-deadline-time-regexp)) | ||
| 8231 | (sched-re (concat ".*\\(\n[^*].*\\)?" org-scheduled-time-regexp)) | ||
| 8232 | ; FIXME why was this wrong? (sched-re (concat ".*\n?.*?" org-scheduled-time-regexp)) | ||
| 8233 | marker priority category tags | 14452 | marker priority category tags |
| 8234 | ee txt) | 14453 | ee txt beg end) |
| 8235 | (goto-char (point-min)) | 14454 | (goto-char (point-min)) |
| 8236 | (while (re-search-forward regexp nil t) | 14455 | (while (re-search-forward regexp nil t) |
| 8237 | (catch :skip | 14456 | (catch :skip |
| 8238 | (save-match-data | 14457 | (save-match-data |
| 8239 | (beginning-of-line) | 14458 | (beginning-of-line) |
| 8240 | (when (or (and org-agenda-todo-ignore-scheduled | 14459 | (setq beg (point) end (progn (outline-next-heading) (point))) |
| 8241 | (looking-at sched-re)) | 14460 | (when (or (and org-agenda-todo-ignore-scheduled (goto-char beg) |
| 8242 | (and org-agenda-todo-ignore-deadlines | 14461 | (re-search-forward org-scheduled-time-regexp end t)) |
| 8243 | (looking-at deadline-re) | 14462 | (and org-agenda-todo-ignore-deadlines (goto-char beg) |
| 8244 | (org-deadline-close (match-string 2)))) | 14463 | (re-search-forward org-deadline-time-regexp end t) |
| 8245 | 14464 | (org-deadline-close (match-string 1)))) | |
| 8246 | ;; FIXME: the following test also happens below, but we need it here | 14465 | (goto-char beg) |
| 8247 | (or org-agenda-todo-list-sublevels (org-end-of-subtree 'invisible)) | 14466 | (or org-agenda-todo-list-sublevels (org-end-of-subtree 'invisible)) |
| 8248 | (throw :skip nil))) | 14467 | (throw :skip nil))) |
| 8249 | (org-agenda-skip) | 14468 | (org-agenda-skip) |
| @@ -8304,6 +14523,9 @@ the documentation of `org-diary'." | |||
| 8304 | deadlinep (string-match org-deadline-regexp tmp) | 14523 | deadlinep (string-match org-deadline-regexp tmp) |
| 8305 | scheduledp (string-match org-scheduled-regexp tmp) | 14524 | scheduledp (string-match org-scheduled-regexp tmp) |
| 8306 | donep (org-entry-is-done-p)) | 14525 | donep (org-entry-is-done-p)) |
| 14526 | (and org-agenda-skip-scheduled-if-done | ||
| 14527 | scheduledp donep | ||
| 14528 | (throw :skip t)) | ||
| 8307 | (if (string-match ">" timestr) | 14529 | (if (string-match ">" timestr) |
| 8308 | ;; substring should only run to end of time stamp | 14530 | ;; substring should only run to end of time stamp |
| 8309 | (setq timestr (substring timestr 0 (match-end 0)))) | 14531 | (setq timestr (substring timestr 0 (match-end 0)))) |
| @@ -8545,6 +14767,9 @@ the documentation of `org-diary'." | |||
| 8545 | ;; Sort the entries by expiration date. | 14767 | ;; Sort the entries by expiration date. |
| 8546 | (nreverse ee))) | 14768 | (nreverse ee))) |
| 8547 | 14769 | ||
| 14770 | ;;; Agenda presentation and sorting | ||
| 14771 | |||
| 14772 | ;; FIXME: should I allow spaces around the dash? | ||
| 8548 | (defconst org-plain-time-of-day-regexp | 14773 | (defconst org-plain-time-of-day-regexp |
| 8549 | (concat | 14774 | (concat |
| 8550 | "\\(\\<[012]?[0-9]" | 14775 | "\\(\\<[012]?[0-9]" |
| @@ -8603,7 +14828,7 @@ only the correctly processes TXT should be returned - this is used by | |||
| 8603 | (file-name-nondirectory buffer-file-name)) | 14828 | (file-name-nondirectory buffer-file-name)) |
| 8604 | ""))) | 14829 | ""))) |
| 8605 | (tag (if tags (nth (1- (length tags)) tags) "")) | 14830 | (tag (if tags (nth (1- (length tags)) tags) "")) |
| 8606 | time ;; needed for the eval of the prefix format | 14831 | time ; time and tag are needed for the eval of the prefix format |
| 8607 | (ts (if dotime (concat (if (stringp dotime) dotime "") txt))) | 14832 | (ts (if dotime (concat (if (stringp dotime) dotime "") txt))) |
| 8608 | (time-of-day (and dotime (org-get-time-of-day ts))) | 14833 | (time-of-day (and dotime (org-get-time-of-day ts))) |
| 8609 | stamp plain s0 s1 s2 rtn) | 14834 | stamp plain s0 s1 s2 rtn) |
| @@ -8827,6 +15052,7 @@ HH:MM." | |||
| 8827 | (defun org-entries-lessp (a b) | 15052 | (defun org-entries-lessp (a b) |
| 8828 | "Predicate for sorting agenda entries." | 15053 | "Predicate for sorting agenda entries." |
| 8829 | ;; The following variables will be used when the form is evaluated. | 15054 | ;; The following variables will be used when the form is evaluated. |
| 15055 | ;; So even though the compiler complains, keep them. | ||
| 8830 | (let* ((time-up (org-cmp-time a b)) | 15056 | (let* ((time-up (org-cmp-time a b)) |
| 8831 | (time-down (if time-up (- time-up) nil)) | 15057 | (time-down (if time-up (- time-up) nil)) |
| 8832 | (priority-up (org-cmp-priority a b)) | 15058 | (priority-up (org-cmp-priority a b)) |
| @@ -8840,6 +15066,238 @@ HH:MM." | |||
| 8840 | (eval (cons 'or org-agenda-sorting-strategy-selected)) | 15066 | (eval (cons 'or org-agenda-sorting-strategy-selected)) |
| 8841 | '((-1 . t) (1 . nil) (nil . nil)))))) | 15067 | '((-1 . t) (1 . nil) (nil . nil)))))) |
| 8842 | 15068 | ||
| 15069 | ;;; Agenda commands | ||
| 15070 | |||
| 15071 | (defun org-agenda-check-type (error &rest types) | ||
| 15072 | "Check if agenda buffer is of allowed type. | ||
| 15073 | If ERROR is non-nil, throw an error, otherwise just return nil." | ||
| 15074 | (if (memq org-agenda-type types) | ||
| 15075 | t | ||
| 15076 | (if error | ||
| 15077 | (error "Not allowed in %s-type agenda buffers" org-agenda-type) | ||
| 15078 | nil))) | ||
| 15079 | |||
| 15080 | (defun org-agenda-quit () | ||
| 15081 | "Exit agenda by removing the window or the buffer." | ||
| 15082 | (interactive) | ||
| 15083 | (let ((buf (current-buffer))) | ||
| 15084 | (if (not (one-window-p)) (delete-window)) | ||
| 15085 | (kill-buffer buf) | ||
| 15086 | (org-agenda-maybe-reset-markers 'force)) | ||
| 15087 | ;; Maybe restore the pre-agenda window configuration. | ||
| 15088 | (and org-agenda-restore-windows-after-quit | ||
| 15089 | (not (eq org-agenda-window-setup 'other-frame)) | ||
| 15090 | org-pre-agenda-window-conf | ||
| 15091 | (set-window-configuration org-pre-agenda-window-conf))) | ||
| 15092 | |||
| 15093 | (defun org-agenda-exit () | ||
| 15094 | "Exit agenda by removing the window or the buffer. | ||
| 15095 | Also kill all Org-mode buffers which have been loaded by `org-agenda'. | ||
| 15096 | Org-mode buffers visited directly by the user will not be touched." | ||
| 15097 | (interactive) | ||
| 15098 | (org-release-buffers org-agenda-new-buffers) | ||
| 15099 | (setq org-agenda-new-buffers nil) | ||
| 15100 | (org-agenda-quit)) | ||
| 15101 | |||
| 15102 | (defun org-save-all-org-buffers () | ||
| 15103 | "Save all Org-mode buffers without user confirmation." | ||
| 15104 | (interactive) | ||
| 15105 | (message "Saving all Org-mode buffers...") | ||
| 15106 | (save-some-buffers t 'org-mode-p) | ||
| 15107 | (message "Saving all Org-mode buffers... done")) | ||
| 15108 | |||
| 15109 | (defun org-agenda-redo () | ||
| 15110 | "Rebuild Agenda. | ||
| 15111 | When this is the global TODO list, a prefix argument will be interpreted." | ||
| 15112 | (interactive) | ||
| 15113 | (let* ((org-agenda-keep-modes t) | ||
| 15114 | (line (org-current-line)) | ||
| 15115 | (window-line (- line (org-current-line (window-start))))) | ||
| 15116 | (message "Rebuilding agenda buffer...") | ||
| 15117 | (eval org-agenda-redo-command) | ||
| 15118 | (setq org-agenda-undo-list nil | ||
| 15119 | org-agenda-pending-undo-list nil) | ||
| 15120 | (message "Rebuilding agenda buffer...done") | ||
| 15121 | (goto-line line) | ||
| 15122 | (recenter window-line))) | ||
| 15123 | |||
| 15124 | (defun org-agenda-goto-today () | ||
| 15125 | "Go to today." | ||
| 15126 | (interactive) | ||
| 15127 | (org-agenda-check-type t 'timeline 'agenda) | ||
| 15128 | (let ((tdpos (text-property-any (point-min) (point-max) 'org-today t))) | ||
| 15129 | (cond | ||
| 15130 | (tdpos (goto-char tdpos)) | ||
| 15131 | ((eq org-agenda-type 'agenda) | ||
| 15132 | (let ((org-agenda-overriding-arguments org-agenda-last-arguments)) | ||
| 15133 | (setf (nth 1 org-agenda-overriding-arguments) nil) | ||
| 15134 | (org-agenda-redo) | ||
| 15135 | (org-agenda-find-today-or-agenda))) | ||
| 15136 | (t (error "Cannot find today"))))) | ||
| 15137 | |||
| 15138 | (defun org-agenda-find-today-or-agenda () | ||
| 15139 | (goto-char | ||
| 15140 | (or (text-property-any (point-min) (point-max) 'org-today t) | ||
| 15141 | (text-property-any (point-min) (point-max) 'org-agenda-type 'agenda) | ||
| 15142 | (point-min)))) | ||
| 15143 | |||
| 15144 | (defun org-agenda-later (arg) | ||
| 15145 | "Go forward in time by `org-agenda-ndays' days. | ||
| 15146 | With prefix ARG, go forward that many times `org-agenda-ndays'." | ||
| 15147 | (interactive "p") | ||
| 15148 | (org-agenda-check-type t 'agenda) | ||
| 15149 | (let ((org-agenda-overriding-arguments | ||
| 15150 | (list (car org-agenda-last-arguments) | ||
| 15151 | (+ org-starting-day (* arg org-agenda-ndays)) | ||
| 15152 | nil t))) | ||
| 15153 | (org-agenda-redo) | ||
| 15154 | (org-agenda-find-today-or-agenda))) | ||
| 15155 | |||
| 15156 | (defun org-agenda-earlier (arg) | ||
| 15157 | "Go back in time by `org-agenda-ndays' days. | ||
| 15158 | With prefix ARG, go back that many times `org-agenda-ndays'." | ||
| 15159 | (interactive "p") | ||
| 15160 | (org-agenda-check-type t 'agenda) | ||
| 15161 | (let ((org-agenda-overriding-arguments | ||
| 15162 | (list (car org-agenda-last-arguments) | ||
| 15163 | (- org-starting-day (* arg org-agenda-ndays)) | ||
| 15164 | nil t))) | ||
| 15165 | (org-agenda-redo) | ||
| 15166 | (org-agenda-find-today-or-agenda))) | ||
| 15167 | |||
| 15168 | (defun org-agenda-week-view () | ||
| 15169 | "Switch to weekly view for agenda." | ||
| 15170 | (interactive) | ||
| 15171 | (org-agenda-check-type t 'agenda) | ||
| 15172 | (if (= org-agenda-ndays 7) | ||
| 15173 | (error "This is already the week view")) | ||
| 15174 | (setq org-agenda-ndays 7) | ||
| 15175 | (let ((org-agenda-overriding-arguments | ||
| 15176 | (list (car org-agenda-last-arguments) | ||
| 15177 | (or (get-text-property (point) 'day) | ||
| 15178 | org-starting-day) | ||
| 15179 | nil t))) | ||
| 15180 | (org-agenda-redo) | ||
| 15181 | (org-agenda-find-today-or-agenda)) | ||
| 15182 | (org-agenda-set-mode-name) | ||
| 15183 | (message "Switched to week view")) | ||
| 15184 | |||
| 15185 | (defun org-agenda-day-view () | ||
| 15186 | "Switch to daily view for agenda." | ||
| 15187 | (interactive) | ||
| 15188 | (org-agenda-check-type t 'agenda) | ||
| 15189 | (if (= org-agenda-ndays 1) | ||
| 15190 | (error "This is already the day view")) | ||
| 15191 | (setq org-agenda-ndays 1) | ||
| 15192 | (let ((org-agenda-overriding-arguments | ||
| 15193 | (list (car org-agenda-last-arguments) | ||
| 15194 | (or (get-text-property (point) 'day) | ||
| 15195 | org-starting-day) | ||
| 15196 | nil t))) | ||
| 15197 | (org-agenda-redo) | ||
| 15198 | (org-agenda-find-today-or-agenda)) | ||
| 15199 | (org-agenda-set-mode-name) | ||
| 15200 | (message "Switched to day view")) | ||
| 15201 | |||
| 15202 | ;; FIXME: this no longer works if user make date format that starts with a blank | ||
| 15203 | (defun org-agenda-next-date-line (&optional arg) | ||
| 15204 | "Jump to the next line indicating a date in agenda buffer." | ||
| 15205 | (interactive "p") | ||
| 15206 | (org-agenda-check-type t 'agenda 'timeline) | ||
| 15207 | (beginning-of-line 1) | ||
| 15208 | (if (looking-at "^\\S-") (forward-char 1)) | ||
| 15209 | (if (not (re-search-forward "^\\S-" nil t arg)) | ||
| 15210 | (progn | ||
| 15211 | (backward-char 1) | ||
| 15212 | (error "No next date after this line in this buffer"))) | ||
| 15213 | (goto-char (match-beginning 0))) | ||
| 15214 | |||
| 15215 | (defun org-agenda-previous-date-line (&optional arg) | ||
| 15216 | "Jump to the previous line indicating a date in agenda buffer." | ||
| 15217 | (interactive "p") | ||
| 15218 | (org-agenda-check-type t 'agenda 'timeline) | ||
| 15219 | (beginning-of-line 1) | ||
| 15220 | (if (not (re-search-backward "^\\S-" nil t arg)) | ||
| 15221 | (error "No previous date before this line in this buffer"))) | ||
| 15222 | |||
| 15223 | ;; Initialize the highlight | ||
| 15224 | (defvar org-hl (org-make-overlay 1 1)) | ||
| 15225 | (org-overlay-put org-hl 'face 'highlight) | ||
| 15226 | |||
| 15227 | (defun org-highlight (begin end &optional buffer) | ||
| 15228 | "Highlight a region with overlay." | ||
| 15229 | (funcall (if (featurep 'xemacs) 'set-extent-endpoints 'move-overlay) | ||
| 15230 | org-hl begin end (or buffer (current-buffer)))) | ||
| 15231 | |||
| 15232 | (defun org-unhighlight () | ||
| 15233 | "Detach overlay INDEX." | ||
| 15234 | (funcall (if (featurep 'xemacs) 'detach-extent 'delete-overlay) org-hl)) | ||
| 15235 | |||
| 15236 | (defun org-highlight-until-next-command (beg end &optional buffer) | ||
| 15237 | (org-highlight beg end buffer) | ||
| 15238 | (add-hook 'pre-command-hook 'org-unhighlight-once)) | ||
| 15239 | |||
| 15240 | (defun org-unhighlight-once () | ||
| 15241 | (remove-hook 'pre-command-hook 'org-unhighlight-once) | ||
| 15242 | (org-unhighlight)) | ||
| 15243 | |||
| 15244 | (defun org-agenda-follow-mode () | ||
| 15245 | "Toggle follow mode in an agenda buffer." | ||
| 15246 | (interactive) | ||
| 15247 | (setq org-agenda-follow-mode (not org-agenda-follow-mode)) | ||
| 15248 | (org-agenda-set-mode-name) | ||
| 15249 | (message "Follow mode is %s" | ||
| 15250 | (if org-agenda-follow-mode "on" "off"))) | ||
| 15251 | |||
| 15252 | (defun org-agenda-log-mode () | ||
| 15253 | "Toggle log mode in an agenda buffer." | ||
| 15254 | (interactive) | ||
| 15255 | (org-agenda-check-type t 'agenda 'timeline) | ||
| 15256 | (setq org-agenda-show-log (not org-agenda-show-log)) | ||
| 15257 | (org-agenda-set-mode-name) | ||
| 15258 | (org-agenda-redo) | ||
| 15259 | (message "Log mode is %s" | ||
| 15260 | (if org-agenda-show-log "on" "off"))) | ||
| 15261 | |||
| 15262 | (defun org-agenda-toggle-diary () | ||
| 15263 | "Toggle diary inclusion in an agenda buffer." | ||
| 15264 | (interactive) | ||
| 15265 | (org-agenda-check-type t 'agenda) | ||
| 15266 | (setq org-agenda-include-diary (not org-agenda-include-diary)) | ||
| 15267 | (org-agenda-redo) | ||
| 15268 | (org-agenda-set-mode-name) | ||
| 15269 | (message "Diary inclusion turned %s" | ||
| 15270 | (if org-agenda-include-diary "on" "off"))) | ||
| 15271 | |||
| 15272 | (defun org-agenda-toggle-time-grid () | ||
| 15273 | "Toggle time grid in an agenda buffer." | ||
| 15274 | (interactive) | ||
| 15275 | (org-agenda-check-type t 'agenda) | ||
| 15276 | (setq org-agenda-use-time-grid (not org-agenda-use-time-grid)) | ||
| 15277 | (org-agenda-redo) | ||
| 15278 | (org-agenda-set-mode-name) | ||
| 15279 | (message "Time-grid turned %s" | ||
| 15280 | (if org-agenda-use-time-grid "on" "off"))) | ||
| 15281 | |||
| 15282 | (defun org-agenda-set-mode-name () | ||
| 15283 | "Set the mode name to indicate all the small mode settings." | ||
| 15284 | (setq mode-name | ||
| 15285 | (concat "Org-Agenda" | ||
| 15286 | (if (equal org-agenda-ndays 1) " Day" "") | ||
| 15287 | (if (equal org-agenda-ndays 7) " Week" "") | ||
| 15288 | (if org-agenda-follow-mode " Follow" "") | ||
| 15289 | (if org-agenda-include-diary " Diary" "") | ||
| 15290 | (if org-agenda-use-time-grid " Grid" "") | ||
| 15291 | (if org-agenda-show-log " Log" ""))) | ||
| 15292 | (force-mode-line-update)) | ||
| 15293 | |||
| 15294 | (defun org-agenda-post-command-hook () | ||
| 15295 | (and (eolp) (not (bolp)) (backward-char 1)) | ||
| 15296 | (setq org-agenda-type (get-text-property (point) 'org-agenda-type)) | ||
| 15297 | (if (and org-agenda-follow-mode | ||
| 15298 | (get-text-property (point) 'org-marker)) | ||
| 15299 | (org-agenda-show))) | ||
| 15300 | |||
| 8843 | (defun org-agenda-show-priority () | 15301 | (defun org-agenda-show-priority () |
| 8844 | "Show the priority of the current item. | 15302 | "Show the priority of the current item. |
| 8845 | This priority is composed of the main priority given with the [#A] cookies, | 15303 | This priority is composed of the main priority given with the [#A] cookies, |
| @@ -8877,36 +15335,88 @@ and by additional input from the age of a schedules or deadline entry." | |||
| 8877 | (defun org-agenda-kill () | 15335 | (defun org-agenda-kill () |
| 8878 | "Kill the entry or subtree belonging to the current agenda entry." | 15336 | "Kill the entry or subtree belonging to the current agenda entry." |
| 8879 | (interactive) | 15337 | (interactive) |
| 15338 | (or (eq major-mode 'org-agenda-mode) (error "Not in agenda")) | ||
| 8880 | (let* ((marker (or (get-text-property (point) 'org-marker) | 15339 | (let* ((marker (or (get-text-property (point) 'org-marker) |
| 8881 | (org-agenda-error))) | 15340 | (org-agenda-error))) |
| 8882 | (hdmarker (get-text-property (point) 'org-hd-marker)) | ||
| 8883 | (buffer (marker-buffer marker)) | 15341 | (buffer (marker-buffer marker)) |
| 8884 | (pos (marker-position marker)) | 15342 | (pos (marker-position marker)) |
| 8885 | dbeg dend txt n conf) | 15343 | dbeg dend (n 0) conf) |
| 8886 | (with-current-buffer buffer | 15344 | (org-with-remote-undo buffer |
| 8887 | (save-excursion | 15345 | (with-current-buffer buffer |
| 8888 | (goto-char pos) | 15346 | (save-excursion |
| 15347 | (goto-char pos) | ||
| 15348 | (if (org-mode-p) | ||
| 15349 | (setq dbeg (progn (org-back-to-heading t) (point)) | ||
| 15350 | dend (org-end-of-subtree t)) | ||
| 15351 | (setq dbeg (point-at-bol) | ||
| 15352 | dend (min (point-max) (1+ (point-at-eol))))) | ||
| 15353 | (goto-char dbeg) | ||
| 15354 | (while (re-search-forward "^[ \t]*\\S-" dend t) (setq n (1+ n))))) | ||
| 15355 | (setq conf (or (eq t org-agenda-confirm-kill) | ||
| 15356 | (and (numberp org-agenda-confirm-kill) | ||
| 15357 | (> n org-agenda-confirm-kill)))) | ||
| 15358 | (and conf | ||
| 15359 | (not (y-or-n-p | ||
| 15360 | (format "Delete entry with %d lines in buffer \"%s\"? " | ||
| 15361 | n (buffer-name buffer)))) | ||
| 15362 | (error "Abort")) | ||
| 15363 | (org-remove-subtree-entries-from-agenda buffer dbeg dend) | ||
| 15364 | (with-current-buffer buffer (delete-region dbeg dend)) | ||
| 15365 | (message "Agenda item and source killed")))) | ||
| 15366 | |||
| 15367 | (defun org-agenda-archive () | ||
| 15368 | "Kill the entry or subtree belonging to the current agenda entry." | ||
| 15369 | (interactive) | ||
| 15370 | (or (eq major-mode 'org-agenda-mode) (error "Not in agenda")) | ||
| 15371 | (let* ((marker (or (get-text-property (point) 'org-marker) | ||
| 15372 | (org-agenda-error))) | ||
| 15373 | (buffer (marker-buffer marker)) | ||
| 15374 | (pos (marker-position marker))) | ||
| 15375 | (org-with-remote-undo buffer | ||
| 15376 | (with-current-buffer buffer | ||
| 8889 | (if (org-mode-p) | 15377 | (if (org-mode-p) |
| 8890 | (setq dbeg (progn (org-back-to-heading t) (point)) | 15378 | (save-excursion |
| 8891 | dend (org-end-of-subtree t)) | 15379 | (goto-char pos) |
| 8892 | (setq dbeg (point-at-bol) | 15380 | (org-remove-subtree-entries-from-agenda) |
| 8893 | dend (min (point-max) (1+ (point-at-eol))))) | 15381 | (org-back-to-heading t) |
| 8894 | (setq txt (buffer-substring dbeg dend)))) | 15382 | (org-archive-subtree)) |
| 8895 | (while (string-match "^[ \t]*\n" txt) (setq txt (replace-match "" t t txt))) | 15383 | (error "Archiving works only in Org-mode files")))))) |
| 8896 | (setq n (length (split-string txt "\n")) | 15384 | |
| 8897 | conf (or (eq t org-agenda-confirm-kill) | 15385 | (defun org-remove-subtree-entries-from-agenda (&optional buf beg end) |
| 8898 | (and (numberp org-agenda-confirm-kill) | 15386 | "Remove all lines in the agenda that correspond to a given subtree. |
| 8899 | (> n org-agenda-confirm-kill)))) | 15387 | The subtree is the one in buffer BUF, starting at BEG and ending at END. |
| 8900 | (and conf | 15388 | If this information is not given, the function uses the tree at point." |
| 8901 | (not (y-or-n-p | 15389 | (let ((buf (or buf (current-buffer))) m p) |
| 8902 | (format "Delete entry with %d lines in buffer \"%s\"? " | 15390 | (save-excursion |
| 8903 | n (buffer-name buffer)))) | 15391 | (unless (and beg end) |
| 8904 | (error "Abort")) | 15392 | (org-back-to-heading t) |
| 8905 | ;; FIXME: if we kill an entire subtree, should we not find all | 15393 | (setq beg (point)) |
| 8906 | ;; lines coming from the subtree? | 15394 | (org-end-of-subtree t) |
| 8907 | (save-excursion (org-agenda-change-all-lines "" hdmarker)) | 15395 | (setq end (point))) |
| 8908 | (with-current-buffer buffer (delete-region dbeg dend)) | 15396 | (set-buffer (get-buffer org-agenda-buffer-name)) |
| 8909 | (message "Agenda item and source killed"))) | 15397 | (save-excursion |
| 15398 | (goto-char (point-max)) | ||
| 15399 | (beginning-of-line 1) | ||
| 15400 | (while (not (bobp)) | ||
| 15401 | (when (and (setq m (get-text-property (point) 'org-marker)) | ||
| 15402 | (equal buf (marker-buffer m)) | ||
| 15403 | (setq p (marker-position m)) | ||
| 15404 | (>= p beg) | ||
| 15405 | (<= p end)) | ||
| 15406 | (let (buffer-read-only) | ||
| 15407 | (delete-region (point-at-bol) (1+ (point-at-eol))))) | ||
| 15408 | (beginning-of-line 0)))))) | ||
| 15409 | |||
| 15410 | (defun org-agenda-open-link () | ||
| 15411 | "Follow the link in the current line, if any." | ||
| 15412 | (interactive) | ||
| 15413 | (let ((eol (point-at-eol))) | ||
| 15414 | (save-excursion | ||
| 15415 | (if (or (re-search-forward org-bracket-link-regexp eol t) | ||
| 15416 | (re-search-forward org-angle-link-re eol t) | ||
| 15417 | (re-search-forward org-plain-link-re eol t)) | ||
| 15418 | (call-interactively 'org-open-at-point) | ||
| 15419 | (error "No link in current line"))))) | ||
| 8910 | 15420 | ||
| 8911 | (defun org-agenda-switch-to (&optional delete-other-windows) | 15421 | (defun org-agenda-switch-to (&optional delete-other-windows) |
| 8912 | "Go to the Org-mode file which contains the item at point." | 15422 | "Go to the Org-mode file which contains the item at point." |
| @@ -8960,6 +15470,24 @@ and by additional input from the age of a schedules or deadline entry." | |||
| 8960 | (defun org-agenda-error () | 15470 | (defun org-agenda-error () |
| 8961 | (error "Command not allowed in this line")) | 15471 | (error "Command not allowed in this line")) |
| 8962 | 15472 | ||
| 15473 | (defun org-agenda-tree-to-indirect-buffer () | ||
| 15474 | "Show the subtree corresponding to the current entry in an indirect buffer. | ||
| 15475 | This calls the command `org-tree-to-indirect-buffer' from the original | ||
| 15476 | Org-mode buffer. | ||
| 15477 | With numerical prefix arg ARG, go up to this level and then take that tree. | ||
| 15478 | With a C-u prefix, make a separate frame for this tree (i.e. don't use the | ||
| 15479 | dedicated frame)." | ||
| 15480 | (interactive) | ||
| 15481 | (org-agenda-check-no-diary) | ||
| 15482 | (let* ((marker (or (get-text-property (point) 'org-marker) | ||
| 15483 | (org-agenda-error))) | ||
| 15484 | (buffer (marker-buffer marker)) | ||
| 15485 | (pos (marker-position marker))) | ||
| 15486 | (with-current-buffer buffer | ||
| 15487 | (save-excursion | ||
| 15488 | (goto-char pos) | ||
| 15489 | (call-interactively 'org-tree-to-indirect-buffer))))) | ||
| 15490 | |||
| 8963 | (defvar org-last-heading-marker (make-marker) | 15491 | (defvar org-last-heading-marker (make-marker) |
| 8964 | "Marker pointing to the headline that last changed its TODO state | 15492 | "Marker pointing to the headline that last changed its TODO state |
| 8965 | by a remote command from the agenda.") | 15493 | by a remote command from the agenda.") |
| @@ -8978,23 +15506,24 @@ the same tree node, and the headline of the tree node in the Org-mode file." | |||
| 8978 | (hdmarker (get-text-property (point) 'org-hd-marker)) | 15506 | (hdmarker (get-text-property (point) 'org-hd-marker)) |
| 8979 | (buffer-read-only nil) | 15507 | (buffer-read-only nil) |
| 8980 | newhead) | 15508 | newhead) |
| 8981 | (with-current-buffer buffer | 15509 | (org-with-remote-undo buffer |
| 8982 | (widen) | 15510 | (with-current-buffer buffer |
| 8983 | (goto-char pos) | 15511 | (widen) |
| 8984 | (org-show-context 'agenda) | 15512 | (goto-char pos) |
| 8985 | (save-excursion | 15513 | (org-show-context 'agenda) |
| 8986 | (and (outline-next-heading) | 15514 | (save-excursion |
| 8987 | (org-flag-heading nil))) ; show the next heading | 15515 | (and (outline-next-heading) |
| 8988 | (org-todo arg) | 15516 | (org-flag-heading nil))) ; show the next heading |
| 8989 | (and (bolp) (forward-char 1)) | 15517 | (org-todo arg) |
| 8990 | (setq newhead (org-get-heading)) | 15518 | (and (bolp) (forward-char 1)) |
| 15519 | (setq newhead (org-get-heading)) | ||
| 15520 | (save-excursion | ||
| 15521 | (org-back-to-heading) | ||
| 15522 | (move-marker org-last-heading-marker (point)))) | ||
| 15523 | (beginning-of-line 1) | ||
| 8991 | (save-excursion | 15524 | (save-excursion |
| 8992 | (org-back-to-heading) | 15525 | (org-agenda-change-all-lines newhead hdmarker 'fixface)) |
| 8993 | (move-marker org-last-heading-marker (point)))) | 15526 | (move-to-column col)))) |
| 8994 | (beginning-of-line 1) | ||
| 8995 | (save-excursion | ||
| 8996 | (org-agenda-change-all-lines newhead hdmarker 'fixface)) | ||
| 8997 | (move-to-column col))) | ||
| 8998 | 15527 | ||
| 8999 | (defun org-agenda-change-all-lines (newhead hdmarker &optional fixface) | 15528 | (defun org-agenda-change-all-lines (newhead hdmarker &optional fixface) |
| 9000 | "Change all lines in the agenda buffer which match HDMARKER. | 15529 | "Change all lines in the agenda buffer which match HDMARKER. |
| @@ -9041,6 +15570,8 @@ the new TODO state." | |||
| 9041 | (beginning-of-line 0))) | 15570 | (beginning-of-line 0))) |
| 9042 | (org-finalize-agenda))) | 15571 | (org-finalize-agenda))) |
| 9043 | 15572 | ||
| 15573 | ;; FIXME: allow negative value for org-agenda-align-tags-to-column | ||
| 15574 | ;; See the code in set-tags for the way to do this. | ||
| 9044 | (defun org-agenda-align-tags (&optional line) | 15575 | (defun org-agenda-align-tags (&optional line) |
| 9045 | "Align all tags in agenda items to `org-agenda-align-tags-to-column'." | 15576 | "Align all tags in agenda items to `org-agenda-align-tags-to-column'." |
| 9046 | (let ((buffer-read-only)) | 15577 | (let ((buffer-read-only)) |
| @@ -9078,18 +15609,19 @@ the same tree node, and the headline of the tree node in the Org-mode file." | |||
| 9078 | (hdmarker (get-text-property (point) 'org-hd-marker)) | 15609 | (hdmarker (get-text-property (point) 'org-hd-marker)) |
| 9079 | (buffer-read-only nil) | 15610 | (buffer-read-only nil) |
| 9080 | newhead) | 15611 | newhead) |
| 9081 | (with-current-buffer buffer | 15612 | (org-with-remote-undo buffer |
| 9082 | (widen) | 15613 | (with-current-buffer buffer |
| 9083 | (goto-char pos) | 15614 | (widen) |
| 9084 | (org-show-context 'agenda) | 15615 | (goto-char pos) |
| 9085 | (save-excursion | 15616 | (org-show-context 'agenda) |
| 9086 | (and (outline-next-heading) | 15617 | (save-excursion |
| 9087 | (org-flag-heading nil))) ; show the next heading | 15618 | (and (outline-next-heading) |
| 9088 | (funcall 'org-priority force-direction) | 15619 | (org-flag-heading nil))) ; show the next heading |
| 9089 | (end-of-line 1) | 15620 | (funcall 'org-priority force-direction) |
| 9090 | (setq newhead (org-get-heading))) | 15621 | (end-of-line 1) |
| 9091 | (org-agenda-change-all-lines newhead hdmarker) | 15622 | (setq newhead (org-get-heading))) |
| 9092 | (beginning-of-line 1))) | 15623 | (org-agenda-change-all-lines newhead hdmarker) |
| 15624 | (beginning-of-line 1)))) | ||
| 9093 | 15625 | ||
| 9094 | (defun org-get-tags-at (&optional pos) | 15626 | (defun org-get-tags-at (&optional pos) |
| 9095 | "Get a list of all headline tags applicable at POS. | 15627 | "Get a list of all headline tags applicable at POS. |
| @@ -9099,20 +15631,22 @@ the tags of the current headline come last." | |||
| 9099 | (interactive) | 15631 | (interactive) |
| 9100 | (let (tags) | 15632 | (let (tags) |
| 9101 | (save-excursion | 15633 | (save-excursion |
| 9102 | (goto-char (or pos (point))) | 15634 | (save-restriction |
| 9103 | (save-match-data | 15635 | (widen) |
| 9104 | (org-back-to-heading t) | 15636 | (goto-char (or pos (point))) |
| 9105 | (condition-case nil | 15637 | (save-match-data |
| 9106 | (while t | 15638 | (org-back-to-heading t) |
| 9107 | (if (looking-at "[^\r\n]+?:\\([a-zA-Z_@0-9:]+\\):[ \t]*\\([\n\r]\\|\\'\\)") | 15639 | (condition-case nil |
| 9108 | (setq tags (append (org-split-string | 15640 | (while t |
| 9109 | (org-match-string-no-properties 1) ":") | 15641 | (if (looking-at "[^\r\n]+?:\\([a-zA-Z_@0-9:]+\\):[ \t]*\\([\n\r]\\|\\'\\)") |
| 9110 | tags))) | 15642 | (setq tags (append (org-split-string |
| 15643 | (org-match-string-no-properties 1) ":") | ||
| 15644 | tags))) | ||
| 9111 | (or org-use-tag-inheritance (error "")) | 15645 | (or org-use-tag-inheritance (error "")) |
| 9112 | (org-up-heading-all 1)) | 15646 | (org-up-heading-all 1)) |
| 9113 | (error nil)))) | 15647 | (error nil)))) |
| 9114 | tags)) | 15648 | tags))) |
| 9115 | 15649 | ||
| 9116 | ;; FIXME: should fix the tags property of the agenda line. | 15650 | ;; FIXME: should fix the tags property of the agenda line. |
| 9117 | (defun org-agenda-set-tags () | 15651 | (defun org-agenda-set-tags () |
| 9118 | "Set tags for the current headline." | 15652 | "Set tags for the current headline." |
| @@ -9125,18 +15659,44 @@ the tags of the current headline come last." | |||
| 9125 | (pos (marker-position hdmarker)) | 15659 | (pos (marker-position hdmarker)) |
| 9126 | (buffer-read-only nil) | 15660 | (buffer-read-only nil) |
| 9127 | newhead) | 15661 | newhead) |
| 9128 | (with-current-buffer buffer | 15662 | (org-with-remote-undo buffer |
| 9129 | (widen) | 15663 | (with-current-buffer buffer |
| 9130 | (goto-char pos) | 15664 | (widen) |
| 9131 | (org-show-context 'agenda) | 15665 | (goto-char pos) |
| 9132 | (save-excursion | 15666 | (org-show-context 'agenda) |
| 9133 | (and (outline-next-heading) | 15667 | (save-excursion |
| 9134 | (org-flag-heading nil))) ; show the next heading | 15668 | (and (outline-next-heading) |
| 9135 | (call-interactively 'org-set-tags) | 15669 | (org-flag-heading nil))) ; show the next heading |
| 9136 | (end-of-line 1) | 15670 | (call-interactively 'org-set-tags) |
| 9137 | (setq newhead (org-get-heading))) | 15671 | (end-of-line 1) |
| 9138 | (org-agenda-change-all-lines newhead hdmarker) | 15672 | (setq newhead (org-get-heading))) |
| 9139 | (beginning-of-line 1))) | 15673 | (org-agenda-change-all-lines newhead hdmarker) |
| 15674 | (beginning-of-line 1)))) | ||
| 15675 | |||
| 15676 | (defun org-agenda-toggle-archive-tag () | ||
| 15677 | "Toggle the archive tag for the current entry." | ||
| 15678 | (interactive) | ||
| 15679 | (org-agenda-check-no-diary) | ||
| 15680 | (org-agenda-show) ;;; FIXME This is a stupid hack and should not be needed | ||
| 15681 | (let* ((hdmarker (or (get-text-property (point) 'org-hd-marker) | ||
| 15682 | (org-agenda-error))) | ||
| 15683 | (buffer (marker-buffer hdmarker)) | ||
| 15684 | (pos (marker-position hdmarker)) | ||
| 15685 | (buffer-read-only nil) | ||
| 15686 | newhead) | ||
| 15687 | (org-with-remote-undo buffer | ||
| 15688 | (with-current-buffer buffer | ||
| 15689 | (widen) | ||
| 15690 | (goto-char pos) | ||
| 15691 | (org-show-context 'agenda) | ||
| 15692 | (save-excursion | ||
| 15693 | (and (outline-next-heading) | ||
| 15694 | (org-flag-heading nil))) ; show the next heading | ||
| 15695 | (call-interactively 'org-toggle-archive-tag) | ||
| 15696 | (end-of-line 1) | ||
| 15697 | (setq newhead (org-get-heading))) | ||
| 15698 | (org-agenda-change-all-lines newhead hdmarker) | ||
| 15699 | (beginning-of-line 1)))) | ||
| 9140 | 15700 | ||
| 9141 | (defun org-agenda-date-later (arg &optional what) | 15701 | (defun org-agenda-date-later (arg &optional what) |
| 9142 | "Change the date of this item to one day later." | 15702 | "Change the date of this item to one day later." |
| @@ -9147,19 +15707,46 @@ the tags of the current headline come last." | |||
| 9147 | (org-agenda-error))) | 15707 | (org-agenda-error))) |
| 9148 | (buffer (marker-buffer marker)) | 15708 | (buffer (marker-buffer marker)) |
| 9149 | (pos (marker-position marker))) | 15709 | (pos (marker-position marker))) |
| 9150 | (with-current-buffer buffer | 15710 | (org-with-remote-undo buffer |
| 9151 | (widen) | 15711 | (with-current-buffer buffer |
| 9152 | (goto-char pos) | 15712 | (widen) |
| 9153 | (if (not (org-at-timestamp-p)) | 15713 | (goto-char pos) |
| 9154 | (error "Cannot find time stamp")) | 15714 | (if (not (org-at-timestamp-p)) |
| 9155 | (org-timestamp-change arg (or what 'day)) | 15715 | (error "Cannot find time stamp")) |
| 9156 | (message "Time stamp changed to %s" org-last-changed-timestamp)))) | 15716 | (org-timestamp-change arg (or what 'day))) |
| 15717 | (org-agenda-show-new-time marker org-last-changed-timestamp)) | ||
| 15718 | (message "Time stamp changed to %s" org-last-changed-timestamp))) | ||
| 9157 | 15719 | ||
| 9158 | (defun org-agenda-date-earlier (arg &optional what) | 15720 | (defun org-agenda-date-earlier (arg &optional what) |
| 9159 | "Change the date of this item to one day earlier." | 15721 | "Change the date of this item to one day earlier." |
| 9160 | (interactive "p") | 15722 | (interactive "p") |
| 9161 | (org-agenda-date-later (- arg) what)) | 15723 | (org-agenda-date-later (- arg) what)) |
| 9162 | 15724 | ||
| 15725 | (defun org-agenda-show-new-time (marker stamp) | ||
| 15726 | "Show new date stamp via text properties." | ||
| 15727 | ;; We use text properties to make this undoable | ||
| 15728 | (let ((buffer-read-only nil)) | ||
| 15729 | (setq stamp (concat " => " stamp)) | ||
| 15730 | (save-excursion | ||
| 15731 | (goto-char (point-max)) | ||
| 15732 | (while (not (bobp)) | ||
| 15733 | (when (equal marker (get-text-property (point) 'org-marker)) | ||
| 15734 | (move-to-column (- (window-width) (length stamp)) t) | ||
| 15735 | (if (featurep 'xemacs) | ||
| 15736 | ;; Use `duplicable' property to trigger undo recording | ||
| 15737 | (let ((ex (make-extent nil nil)) | ||
| 15738 | (gl (make-glyph stamp))) | ||
| 15739 | (set-glyph-face gl 'secondary-selection) | ||
| 15740 | (set-extent-properties | ||
| 15741 | ex (list 'invisible t 'end-glyph gl 'duplicable t)) | ||
| 15742 | (insert-extent ex (1- (point)) (point-at-eol))) | ||
| 15743 | (add-text-properties | ||
| 15744 | (1- (point)) (point-at-eol) | ||
| 15745 | (list 'display (org-add-props stamp nil | ||
| 15746 | 'face 'secondary-selection)))) | ||
| 15747 | (beginning-of-line 1)) | ||
| 15748 | (beginning-of-line 0))))) | ||
| 15749 | |||
| 9163 | (defun org-agenda-date-prompt (arg) | 15750 | (defun org-agenda-date-prompt (arg) |
| 9164 | "Change the date of this item. Date is prompted for, with default today. | 15751 | "Change the date of this item. Date is prompted for, with default today. |
| 9165 | The prefix ARG is passed to the `org-time-stamp' command and can therefore | 15752 | The prefix ARG is passed to the `org-time-stamp' command and can therefore |
| @@ -9171,13 +15758,14 @@ be used to request time specification in the time stamp." | |||
| 9171 | (org-agenda-error))) | 15758 | (org-agenda-error))) |
| 9172 | (buffer (marker-buffer marker)) | 15759 | (buffer (marker-buffer marker)) |
| 9173 | (pos (marker-position marker))) | 15760 | (pos (marker-position marker))) |
| 9174 | (with-current-buffer buffer | 15761 | (org-with-remote-undo buffer |
| 9175 | (widen) | 15762 | (with-current-buffer buffer |
| 9176 | (goto-char pos) | 15763 | (widen) |
| 9177 | (if (not (org-at-timestamp-p)) | 15764 | (goto-char pos) |
| 9178 | (error "Cannot find time stamp")) | 15765 | (if (not (org-at-timestamp-p)) |
| 9179 | (org-time-stamp arg) | 15766 | (error "Cannot find time stamp")) |
| 9180 | (message "Time stamp changed to %s" org-last-changed-timestamp)))) | 15767 | (org-time-stamp arg) |
| 15768 | (message "Time stamp changed to %s" org-last-changed-timestamp))))) | ||
| 9181 | 15769 | ||
| 9182 | (defun org-agenda-schedule (arg) | 15770 | (defun org-agenda-schedule (arg) |
| 9183 | "Schedule the item at point." | 15771 | "Schedule the item at point." |
| @@ -9190,11 +15778,12 @@ be used to request time specification in the time stamp." | |||
| 9190 | (pos (marker-position marker)) | 15778 | (pos (marker-position marker)) |
| 9191 | (org-insert-labeled-timestamps-at-point nil) | 15779 | (org-insert-labeled-timestamps-at-point nil) |
| 9192 | ts) | 15780 | ts) |
| 9193 | (with-current-buffer buffer | 15781 | (org-with-remote-undo buffer |
| 9194 | (widen) | 15782 | (with-current-buffer buffer |
| 9195 | (goto-char pos) | 15783 | (widen) |
| 9196 | (setq ts (org-schedule)) | 15784 | (goto-char pos) |
| 9197 | (message "Item scheduled for %s" ts)))) | 15785 | (setq ts (org-schedule)) |
| 15786 | (message "Item scheduled for %s" ts))))) | ||
| 9198 | 15787 | ||
| 9199 | (defun org-agenda-deadline (arg) | 15788 | (defun org-agenda-deadline (arg) |
| 9200 | "Schedule the item at point." | 15789 | "Schedule the item at point." |
| @@ -9207,20 +15796,18 @@ be used to request time specification in the time stamp." | |||
| 9207 | (pos (marker-position marker)) | 15796 | (pos (marker-position marker)) |
| 9208 | (org-insert-labeled-timestamps-at-point nil) | 15797 | (org-insert-labeled-timestamps-at-point nil) |
| 9209 | ts) | 15798 | ts) |
| 9210 | (with-current-buffer buffer | 15799 | (org-with-remote-undo buffer |
| 9211 | (widen) | 15800 | (with-current-buffer buffer |
| 9212 | (goto-char pos) | 15801 | (widen) |
| 9213 | (setq ts (org-deadline)) | 15802 | (goto-char pos) |
| 9214 | (message "Deadline for this item set to %s" ts)))) | 15803 | (setq ts (org-deadline)) |
| 15804 | (message "Deadline for this item set to %s" ts))))) | ||
| 9215 | 15805 | ||
| 9216 | (defun org-get-heading () | 15806 | (defun org-get-heading () |
| 9217 | "Return the heading of the current entry, without the stars." | 15807 | "Return the heading of the current entry, without the stars." |
| 9218 | (save-excursion | 15808 | (save-excursion |
| 9219 | (and (memq (char-before) '(?\n ?\r)) (skip-chars-forward "^\n\r")) | 15809 | (org-back-to-heading t) |
| 9220 | (if (and (re-search-backward "[\r\n]\\*" nil t) | 15810 | (if (looking-at "\\*+[ \t]+\\([^\r\n]*\\)") (match-string 1) ""))) |
| 9221 | (looking-at "[\r\n]\\*+[ \t]+\\([^\r\n]*\\)")) | ||
| 9222 | (match-string 1) | ||
| 9223 | ""))) | ||
| 9224 | 15811 | ||
| 9225 | (defun org-agenda-clock-in (&optional arg) | 15812 | (defun org-agenda-clock-in (&optional arg) |
| 9226 | "Start the clock on the currently selected item." | 15813 | "Start the clock on the currently selected item." |
| @@ -9229,10 +15816,27 @@ be used to request time specification in the time stamp." | |||
| 9229 | (let* ((marker (or (get-text-property (point) 'org-marker) | 15816 | (let* ((marker (or (get-text-property (point) 'org-marker) |
| 9230 | (org-agenda-error))) | 15817 | (org-agenda-error))) |
| 9231 | (pos (marker-position marker))) | 15818 | (pos (marker-position marker))) |
| 9232 | (with-current-buffer (marker-buffer marker) | 15819 | (org-with-remote-undo (marker-buffer marker) |
| 9233 | (widen) | 15820 | (with-current-buffer (marker-buffer marker) |
| 9234 | (goto-char pos) | 15821 | (widen) |
| 9235 | (org-clock-in)))) | 15822 | (goto-char pos) |
| 15823 | (org-clock-in))))) | ||
| 15824 | |||
| 15825 | (defun org-agenda-clock-out (&optional arg) | ||
| 15826 | "Stop the currently running clock." | ||
| 15827 | (interactive "P") | ||
| 15828 | (unless (marker-buffer org-clock-marker) | ||
| 15829 | (error "No running clock")) | ||
| 15830 | (org-with-remote-undo (marker-buffer org-clock-marker) | ||
| 15831 | (org-clock-out))) | ||
| 15832 | |||
| 15833 | (defun org-agenda-clock-cancel (&optional arg) | ||
| 15834 | "Cancel the currently running clock." | ||
| 15835 | (interactive "P") | ||
| 15836 | (unless (marker-buffer org-clock-marker) | ||
| 15837 | (error "No running clock")) | ||
| 15838 | (org-with-remote-undo (marker-buffer org-clock-marker) | ||
| 15839 | (org-clock-cancel))) | ||
| 9236 | 15840 | ||
| 9237 | (defun org-agenda-diary-entry () | 15841 | (defun org-agenda-diary-entry () |
| 9238 | "Make a diary entry, like the `i' command from the calendar. | 15842 | "Make a diary entry, like the `i' command from the calendar. |
| @@ -9252,6 +15856,7 @@ All the standard commands work: block, weekly etc." | |||
| 9252 | (?b . insert-block-diary-entry) | 15856 | (?b . insert-block-diary-entry) |
| 9253 | (?c . insert-cyclic-diary-entry))))) | 15857 | (?c . insert-cyclic-diary-entry))))) |
| 9254 | (oldf (symbol-function 'calendar-cursor-to-date)) | 15858 | (oldf (symbol-function 'calendar-cursor-to-date)) |
| 15859 | ; (buf (get-file-buffer (substitute-in-file-name diary-file))) | ||
| 9255 | (point (point)) | 15860 | (point (point)) |
| 9256 | (mark (or (mark t) (point)))) | 15861 | (mark (or (mark t) (point)))) |
| 9257 | (unless cmd | 15862 | (unless cmd |
| @@ -9272,7 +15877,7 @@ All the standard commands work: block, weekly etc." | |||
| 9272 | (lambda (&optional error) | 15877 | (lambda (&optional error) |
| 9273 | (calendar-gregorian-from-absolute | 15878 | (calendar-gregorian-from-absolute |
| 9274 | (get-text-property point 'day)))) | 15879 | (get-text-property point 'day)))) |
| 9275 | (call-interactively cmd)) | 15880 | (call-interactively cmd)) |
| 9276 | (fset 'calendar-cursor-to-date oldf))))) | 15881 | (fset 'calendar-cursor-to-date oldf))))) |
| 9277 | 15882 | ||
| 9278 | 15883 | ||
| @@ -9287,6 +15892,7 @@ the cursor position." | |||
| 9287 | (point (point)) | 15892 | (point (point)) |
| 9288 | (date (calendar-gregorian-from-absolute | 15893 | (date (calendar-gregorian-from-absolute |
| 9289 | (get-text-property point 'day))) | 15894 | (get-text-property point 'day))) |
| 15895 | ;; the following 3 vars are needed in the calendar | ||
| 9290 | (displayed-day (extract-calendar-day date)) | 15896 | (displayed-day (extract-calendar-day date)) |
| 9291 | (displayed-month (extract-calendar-month date)) | 15897 | (displayed-month (extract-calendar-month date)) |
| 9292 | (displayed-year (extract-calendar-year date))) | 15898 | (displayed-year (extract-calendar-year date))) |
| @@ -9370,4420 +15976,299 @@ This is a command that has to be installed in `calendar-mode-map'." | |||
| 9370 | (if (fboundp 'fit-window-to-buffer) | 15976 | (if (fboundp 'fit-window-to-buffer) |
| 9371 | (fit-window-to-buffer (get-buffer-window "*Dates*"))))) | 15977 | (fit-window-to-buffer (get-buffer-window "*Dates*"))))) |
| 9372 | 15978 | ||
| 9373 | ;;; Tags | ||
| 9374 | |||
| 9375 | (defun org-scan-tags (action matcher &optional todo-only) | ||
| 9376 | "Scan headline tags with inheritance and produce output ACTION. | ||
| 9377 | ACTION can be `sparse-tree' or `agenda'. MATCHER is a Lisp form to be | ||
| 9378 | evaluated, testing if a given set of tags qualifies a headline for | ||
| 9379 | inclusion. When TODO-ONLY is non-nil, only lines with a TODO keyword | ||
| 9380 | are included in the output." | ||
| 9381 | (let* ((re (concat "[\n\r]" outline-regexp " *\\(\\<\\(" | ||
| 9382 | (mapconcat 'regexp-quote | ||
| 9383 | (nreverse (cdr (reverse org-todo-keywords))) | ||
| 9384 | "\\|") | ||
| 9385 | "\\>\\)\\)? *\\(.*?\\)\\(:[A-Za-z_@0-9:]+:\\)?[ \t]*$")) | ||
| 9386 | (props (list 'face nil | ||
| 9387 | 'done-face 'org-done | ||
| 9388 | 'undone-face nil | ||
| 9389 | 'mouse-face 'highlight | ||
| 9390 | 'org-not-done-regexp org-not-done-regexp | ||
| 9391 | 'keymap org-agenda-keymap | ||
| 9392 | 'help-echo | ||
| 9393 | (format "mouse-2 or RET jump to org file %s" | ||
| 9394 | (abbreviate-file-name buffer-file-name)))) | ||
| 9395 | (case-fold-search nil) | ||
| 9396 | lspos | ||
| 9397 | tags tags-list tags-alist (llast 0) rtn level category i txt | ||
| 9398 | todo marker) | ||
| 9399 | (save-excursion | ||
| 9400 | (goto-char (point-min)) | ||
| 9401 | (when (eq action 'sparse-tree) (org-overview)) | ||
| 9402 | (while (re-search-forward re nil t) | ||
| 9403 | (catch :skip | ||
| 9404 | (and (eq action 'agenda) (org-agenda-skip)) | ||
| 9405 | (setq todo (if (match-end 1) (match-string 2)) | ||
| 9406 | tags (if (match-end 4) (match-string 4))) | ||
| 9407 | (goto-char (setq lspos (1+ (match-beginning 0)))) | ||
| 9408 | (setq level (funcall outline-level) | ||
| 9409 | category (org-get-category)) | ||
| 9410 | (setq i llast llast level) | ||
| 9411 | ;; remove tag lists from same and sublevels | ||
| 9412 | (while (>= i level) | ||
| 9413 | (when (setq entry (assoc i tags-alist)) | ||
| 9414 | (setq tags-alist (delete entry tags-alist))) | ||
| 9415 | (setq i (1- i))) | ||
| 9416 | ;; add the nex tags | ||
| 9417 | (when tags | ||
| 9418 | (setq tags (mapcar 'downcase (org-split-string tags ":")) | ||
| 9419 | tags-alist | ||
| 9420 | (cons (cons level tags) tags-alist))) | ||
| 9421 | ;; compile tags for current headline | ||
| 9422 | (setq tags-list | ||
| 9423 | (if org-use-tag-inheritance | ||
| 9424 | (apply 'append (mapcar 'cdr tags-alist)) | ||
| 9425 | tags)) | ||
| 9426 | (when (and (or (not todo-only) todo) | ||
| 9427 | (eval matcher) | ||
| 9428 | (or (not org-agenda-skip-archived-trees) | ||
| 9429 | (not (member org-archive-tag tags-list)))) | ||
| 9430 | ;; list this headline | ||
| 9431 | (if (eq action 'sparse-tree) | ||
| 9432 | (progn | ||
| 9433 | (org-show-context 'tags-tree)) | ||
| 9434 | (setq txt (org-format-agenda-item | ||
| 9435 | "" | ||
| 9436 | (concat | ||
| 9437 | (if org-tags-match-list-sublevels | ||
| 9438 | (make-string (1- level) ?.) "") | ||
| 9439 | (org-get-heading)) | ||
| 9440 | category tags-list)) | ||
| 9441 | (goto-char lspos) | ||
| 9442 | (setq marker (org-agenda-new-marker)) | ||
| 9443 | (org-add-props txt props | ||
| 9444 | 'org-marker marker 'org-hd-marker marker 'org-category category) | ||
| 9445 | (push txt rtn)) | ||
| 9446 | ;; if we are to skip sublevels, jump to end of subtree | ||
| 9447 | (or org-tags-match-list-sublevels (org-end-of-subtree t)))))) | ||
| 9448 | (when (and (eq action 'sparse-tree) | ||
| 9449 | (not org-sparse-tree-open-archived-trees)) | ||
| 9450 | (org-hide-archived-subtrees (point-min) (point-max))) | ||
| 9451 | (nreverse rtn))) | ||
| 9452 | |||
| 9453 | (defun org-tags-sparse-tree (&optional arg match) | ||
| 9454 | "Create a sparse tree according to tags string MATCH. | ||
| 9455 | MATCH can contain positive and negative selection of tags, like | ||
| 9456 | \"+WORK+URGENT-WITHBOSS\"." | ||
| 9457 | (interactive "P") | ||
| 9458 | (org-scan-tags 'sparse-tree (cdr (org-make-tags-matcher match)))) | ||
| 9459 | |||
| 9460 | (defun org-make-tags-matcher (match) | ||
| 9461 | "Create the TAGS//TODO matcher form for the selection string MATCH." | ||
| 9462 | (unless match | ||
| 9463 | ;; Get a new match request, with completion | ||
| 9464 | (setq org-last-tags-completion-table | ||
| 9465 | (or org-tag-alist | ||
| 9466 | org-last-tags-completion-table)) | ||
| 9467 | (setq match (completing-read | ||
| 9468 | "Match: " 'org-tags-completion-function nil nil nil | ||
| 9469 | 'org-tags-history))) ; FIXME: SHould we have a separate history for this? | ||
| 9470 | |||
| 9471 | ;; Parse the string and create a lisp form | ||
| 9472 | (let ((match0 match) minus tag mm | ||
| 9473 | tagsmatch todomatch tagsmatcher todomatcher kwd matcher | ||
| 9474 | orterms term orlist) | ||
| 9475 | (if (string-match "/+" match) | ||
| 9476 | ;; match contains also a todo-matching request | ||
| 9477 | (setq tagsmatch (substring match 0 (match-beginning 0)) | ||
| 9478 | todomatch (substring match (match-end 0))) | ||
| 9479 | ;; only matching tags | ||
| 9480 | (setq tagsmatch match todomatch nil)) | ||
| 9481 | |||
| 9482 | ;; Make the tags matcher | ||
| 9483 | (if (or (not tagsmatch) (not (string-match "\\S-" tagsmatch))) | ||
| 9484 | (setq tagsmatcher t) | ||
| 9485 | (setq orterms (org-split-string tagsmatch "|") orlist nil) | ||
| 9486 | (while (setq term (pop orterms)) | ||
| 9487 | (while (string-match "^&?\\([-+:]\\)?\\([A-Za-z_@0-9]+\\)" term) | ||
| 9488 | (setq minus (and (match-end 1) | ||
| 9489 | (equal (match-string 1 term) "-")) | ||
| 9490 | tag (match-string 2 term) | ||
| 9491 | term (substring term (match-end 0)) | ||
| 9492 | mm (list 'member (downcase tag) 'tags-list) | ||
| 9493 | mm (if minus (list 'not mm) mm)) | ||
| 9494 | (push mm tagsmatcher)) | ||
| 9495 | (push (if (> (length tagsmatcher) 1) | ||
| 9496 | (cons 'and tagsmatcher) | ||
| 9497 | (car tagsmatcher)) | ||
| 9498 | orlist) | ||
| 9499 | (setq tagsmatcher nil)) | ||
| 9500 | (setq tagsmatcher (if (> (length orlist) 1) (cons 'or orlist) (car orlist)))) | ||
| 9501 | |||
| 9502 | ;; Make the todo matcher ;; FIXME: reduce syntax richness? | ||
| 9503 | (if (or (not todomatch) (not (string-match "\\S-" todomatch))) | ||
| 9504 | (setq todomatcher t) | ||
| 9505 | (setq orterms (org-split-string todomatch "|") orlist nil) | ||
| 9506 | (while (setq term (pop orterms)) | ||
| 9507 | (while (string-match "^&?\\([-+:]\\)?\\([A-Za-z_@0-9]+\\)" term) | ||
| 9508 | (setq minus (and (match-end 1) | ||
| 9509 | (equal (match-string 1 term) "-")) | ||
| 9510 | kwd (match-string 2 term) | ||
| 9511 | term (substring term (match-end 0)) | ||
| 9512 | mm (list 'equal 'todo kwd) | ||
| 9513 | mm (if minus (list 'not mm) mm)) | ||
| 9514 | (push mm todomatcher)) | ||
| 9515 | (push (if (> (length todomatcher) 1) | ||
| 9516 | (cons 'and todomatcher) | ||
| 9517 | (car todomatcher)) | ||
| 9518 | orlist) | ||
| 9519 | (setq todomatcher nil)) | ||
| 9520 | (setq todomatcher (if (> (length orlist) 1) | ||
| 9521 | (cons 'or orlist) (car orlist)))) | ||
| 9522 | |||
| 9523 | ;; Return the string and lisp forms of the matcher | ||
| 9524 | (setq matcher (if todomatcher | ||
| 9525 | (list 'and tagsmatcher todomatcher) | ||
| 9526 | tagsmatcher)) | ||
| 9527 | (cons match0 matcher))) | ||
| 9528 | |||
| 9529 | ;;;###autoload | ||
| 9530 | (defun org-tags-view (&optional todo-only match) | ||
| 9531 | "Show all headlines for all `org-agenda-files' matching a TAGS criterion. | ||
| 9532 | The prefix arg TODO-ONLY limits the search to TODO entries." | ||
| 9533 | (interactive "P") | ||
| 9534 | (org-compile-prefix-format 'tags) | ||
| 9535 | (org-set-sorting-strategy 'tags) | ||
| 9536 | (let* ((org-tags-match-list-sublevels | ||
| 9537 | (if todo-only t org-tags-match-list-sublevels)) | ||
| 9538 | (win (selected-window)) | ||
| 9539 | (completion-ignore-case t) | ||
| 9540 | rtn rtnall files file pos matcher | ||
| 9541 | buffer) | ||
| 9542 | (setq matcher (org-make-tags-matcher match) | ||
| 9543 | match (car matcher) matcher (cdr matcher)) | ||
| 9544 | (org-prepare-agenda) | ||
| 9545 | (setq org-agenda-redo-command | ||
| 9546 | (list 'org-tags-view (list 'quote todo-only) | ||
| 9547 | (list 'if 'current-prefix-arg nil match))) | ||
| 9548 | (setq files (org-agenda-files) | ||
| 9549 | rtnall nil) | ||
| 9550 | (while (setq file (pop files)) | ||
| 9551 | (catch 'nextfile | ||
| 9552 | (org-check-agenda-file file) | ||
| 9553 | (setq buffer (if (file-exists-p file) | ||
| 9554 | (org-get-agenda-file-buffer file) | ||
| 9555 | (error "No such file %s" file))) | ||
| 9556 | (if (not buffer) | ||
| 9557 | ;; If file does not exist, merror message to agenda | ||
| 9558 | (setq rtn (list | ||
| 9559 | (format "ORG-AGENDA-ERROR: No such org-file %s" file)) | ||
| 9560 | rtnall (append rtnall rtn)) | ||
| 9561 | (with-current-buffer buffer | ||
| 9562 | (unless (org-mode-p) | ||
| 9563 | (error "Agenda file %s is not in `org-mode'" file)) | ||
| 9564 | (setq org-category-table (org-get-category-table)) | ||
| 9565 | (save-excursion | ||
| 9566 | (save-restriction | ||
| 9567 | (if org-agenda-restrict | ||
| 9568 | (narrow-to-region org-agenda-restrict-begin | ||
| 9569 | org-agenda-restrict-end) | ||
| 9570 | (widen)) | ||
| 9571 | (setq rtn (org-scan-tags 'agenda matcher todo-only)) | ||
| 9572 | (setq rtnall (append rtnall rtn)))))))) | ||
| 9573 | (insert "Headlines with TAGS match: ") | ||
| 9574 | (add-text-properties (point-min) (1- (point)) | ||
| 9575 | (list 'face 'org-level-3)) | ||
| 9576 | (setq pos (point)) | ||
| 9577 | (insert match "\n") | ||
| 9578 | (add-text-properties pos (1- (point)) (list 'face 'org-warning)) | ||
| 9579 | (setq pos (point)) | ||
| 9580 | (unless org-agenda-multi | ||
| 9581 | (insert "Press `C-u r' to search again with new search string\n")) | ||
| 9582 | (add-text-properties pos (1- (point)) (list 'face 'org-level-3)) | ||
| 9583 | (when rtnall | ||
| 9584 | (insert (org-finalize-agenda-entries rtnall) "\n")) | ||
| 9585 | (goto-char (point-min)) | ||
| 9586 | (org-fit-agenda-window) | ||
| 9587 | (add-text-properties (point-min) (point-max) '(org-agenda-type tags)) | ||
| 9588 | (org-finalize-agenda) | ||
| 9589 | (setq buffer-read-only t) | ||
| 9590 | (if (not org-select-agenda-window) (select-window win)))) | ||
| 9591 | |||
| 9592 | (defvar org-add-colon-after-tag-completion nil) ;; dynamically skoped param | ||
| 9593 | (defvar org-tags-overlay (org-make-overlay 1 1)) | ||
| 9594 | (org-detach-overlay org-tags-overlay) | ||
| 9595 | |||
| 9596 | (defun org-set-tags (&optional arg just-align) | ||
| 9597 | "Set the tags for the current headline. | ||
| 9598 | With prefix ARG, realign all tags in headings in the current buffer." | ||
| 9599 | (interactive "P") | ||
| 9600 | (let* ((re (concat "^" outline-regexp)) | ||
| 9601 | (current (org-get-tags)) | ||
| 9602 | table current-tags inherited-tags ; computed below when needed | ||
| 9603 | tags p0 c0 c1 rpl) | ||
| 9604 | (if arg | ||
| 9605 | (save-excursion | ||
| 9606 | (goto-char (point-min)) | ||
| 9607 | (let (buffer-invisibility-spec) ; Emacs 21 compatibility | ||
| 9608 | (while (re-search-forward re nil t) | ||
| 9609 | (org-set-tags nil t) | ||
| 9610 | (end-of-line 1))) | ||
| 9611 | (message "All tags realigned to column %d" org-tags-column)) | ||
| 9612 | (if just-align | ||
| 9613 | (setq tags current) | ||
| 9614 | ;; Get a new set of tags from the user | ||
| 9615 | (setq table (or org-tag-alist (org-get-buffer-tags)) | ||
| 9616 | org-last-tags-completion-table table | ||
| 9617 | current-tags (org-split-string current ":") | ||
| 9618 | inherited-tags (nreverse | ||
| 9619 | (nthcdr (length current-tags) | ||
| 9620 | (nreverse (org-get-tags-at)))) | ||
| 9621 | tags | ||
| 9622 | (if (or (eq t org-use-fast-tag-selection) | ||
| 9623 | (and org-use-fast-tag-selection | ||
| 9624 | (delq nil (mapcar 'cdr table)))) | ||
| 9625 | (org-fast-tag-selection current-tags inherited-tags table) | ||
| 9626 | (let ((org-add-colon-after-tag-completion t)) | ||
| 9627 | (org-trim | ||
| 9628 | (completing-read "Tags: " 'org-tags-completion-function | ||
| 9629 | nil nil current 'org-tags-history))))) | ||
| 9630 | (while (string-match "[-+&]+" tags) | ||
| 9631 | ;; No boolean logic, just a list | ||
| 9632 | (setq tags (replace-match ":" t t tags)))) | ||
| 9633 | (if (string-match "\\`[\t ]*\\'" tags) | ||
| 9634 | (setq tags "") | ||
| 9635 | (unless (string-match ":$" tags) (setq tags (concat tags ":"))) | ||
| 9636 | (unless (string-match "^:" tags) (setq tags (concat ":" tags)))) | ||
| 9637 | |||
| 9638 | ;; Insert new tags at the correct column | ||
| 9639 | (beginning-of-line 1) | ||
| 9640 | (if (re-search-forward | ||
| 9641 | (concat "\\([ \t]*" (regexp-quote current) "\\)[ \t]*$") | ||
| 9642 | (point-at-eol) t) | ||
| 9643 | (progn | ||
| 9644 | (if (equal tags "") | ||
| 9645 | (setq rpl "") | ||
| 9646 | (goto-char (match-beginning 0)) | ||
| 9647 | (setq c0 (current-column) p0 (point) | ||
| 9648 | c1 (max (1+ c0) (if (> org-tags-column 0) | ||
| 9649 | org-tags-column | ||
| 9650 | (- (- org-tags-column) (length tags)))) | ||
| 9651 | rpl (concat (make-string (max 0 (- c1 c0)) ?\ ) tags))) | ||
| 9652 | (replace-match rpl) | ||
| 9653 | (and (not (featurep 'xemacs)) c0 (tabify p0 (point))) | ||
| 9654 | tags) | ||
| 9655 | (error "Tags alignment failed"))))) | ||
| 9656 | 15979 | ||
| 9657 | (defun org-tags-completion-function (string predicate &optional flag) | 15980 | ;;;; Embedded LaTeX |
| 9658 | (let (s1 s2 rtn (ctable org-last-tags-completion-table) | ||
| 9659 | (confirm (lambda (x) (stringp (car x))))) | ||
| 9660 | (if (string-match "^\\(.*[-+:&|]\\)\\([^-+:&|]*\\)$" string) | ||
| 9661 | (setq s1 (match-string 1 string) | ||
| 9662 | s2 (match-string 2 string)) | ||
| 9663 | (setq s1 "" s2 string)) | ||
| 9664 | (cond | ||
| 9665 | ((eq flag nil) | ||
| 9666 | ;; try completion | ||
| 9667 | (setq rtn (try-completion s2 ctable confirm)) | ||
| 9668 | (if (stringp rtn) | ||
| 9669 | (concat s1 s2 (substring rtn (length s2)) | ||
| 9670 | (if (and org-add-colon-after-tag-completion | ||
| 9671 | (assoc rtn ctable)) | ||
| 9672 | ":" ""))) | ||
| 9673 | ) | ||
| 9674 | ((eq flag t) | ||
| 9675 | ;; all-completions | ||
| 9676 | (all-completions s2 ctable confirm) | ||
| 9677 | ) | ||
| 9678 | ((eq flag 'lambda) | ||
| 9679 | ;; exact match? | ||
| 9680 | (assoc s2 ctable))) | ||
| 9681 | )) | ||
| 9682 | 15981 | ||
| 9683 | (defun org-fast-tag-insert (kwd tags face &optional end) | 15982 | (defvar org-cdlatex-mode-map (make-sparse-keymap) |
| 9684 | "Insert KDW, and the TAGS, the latter with face FACE. Also inser END." | 15983 | "Keymap for the minor `org-cdlatex-mode'.") |
| 9685 | (insert (format "%-12s" (concat kwd ":")) | ||
| 9686 | (org-add-props (mapconcat 'identity tags " ") nil 'face face) | ||
| 9687 | (or end ""))) | ||
| 9688 | 15984 | ||
| 9689 | (defun org-fast-tag-show-exit (flag) | 15985 | (define-key org-cdlatex-mode-map "_" 'org-cdlatex-underscore-caret) |
| 9690 | (save-excursion | 15986 | (define-key org-cdlatex-mode-map "^" 'org-cdlatex-underscore-caret) |
| 9691 | (goto-line 3) | 15987 | (define-key org-cdlatex-mode-map "`" 'cdlatex-math-symbol) |
| 9692 | (if (re-search-forward "[ \t]+Next change exits" (point-at-eol) t) | 15988 | (define-key org-cdlatex-mode-map "'" 'org-cdlatex-math-modify) |
| 9693 | (replace-match "")) | 15989 | (define-key org-cdlatex-mode-map "\C-c{" 'cdlatex-environment) |
| 9694 | (when flag | ||
| 9695 | (end-of-line 1) | ||
| 9696 | (move-to-column (- (window-width) 19) t) | ||
| 9697 | (insert (org-add-props " Next change exits" nil 'face 'org-warning))))) | ||
| 9698 | 15990 | ||
| 9699 | (defun org-set-current-tags-overlay (current prefix) | 15991 | (defvar org-cdlatex-texmathp-advice-is-done nil |
| 9700 | (let ((s (concat ":" (mapconcat 'identity current ":") ":"))) | 15992 | "Flag remembering if we have applied the advice to texmathp already.") |
| 9701 | (if (featurep 'xemacs) | ||
| 9702 | (org-overlay-display org-tags-overlay (concat prefix s) | ||
| 9703 | 'secondary-selection) | ||
| 9704 | (put-text-property 0 (length s) 'face '(secondary-selection org-tag) s) | ||
| 9705 | (org-overlay-display org-tags-overlay (concat prefix s))))) | ||
| 9706 | 15993 | ||
| 9707 | (defun org-fast-tag-selection (current inherited table) | 15994 | (define-minor-mode org-cdlatex-mode |
| 9708 | "Fast tag selection with single keys. | 15995 | "Toggle the minor `org-cdlatex-mode'. |
| 9709 | CURRENT is the current list of tags in the headline, INHERITED is the | 15996 | This mode supports entering LaTeX environment and math in LaTeX fragments |
| 9710 | list of inherited tags, and TABLE is an alist of tags and corresponding keys, | 15997 | in Org-mode. |
| 9711 | possibly with grouping information. | 15998 | \\{org-cdlatex-mode-map}" |
| 9712 | If the keys are nil, a-z are automatically assigned. | 15999 | nil " OCDL" nil |
| 9713 | Returns the new tags string, or nil to not change the current settings." | 16000 | (when org-cdlatex-mode (require 'cdlatex)) |
| 9714 | (let* ((maxlen (apply 'max (mapcar | 16001 | (unless org-cdlatex-texmathp-advice-is-done |
| 9715 | (lambda (x) | 16002 | (setq org-cdlatex-texmathp-advice-is-done t) |
| 9716 | (if (stringp (car x)) (string-width (car x)) 0)) | 16003 | (defadvice texmathp (around org-math-always-on activate) |
| 9717 | table))) | 16004 | "Always return t in org-mode buffers. |
| 9718 | (buf (current-buffer)) | 16005 | This is because we want to insert math symbols without dollars even outside |
| 9719 | (buffer-tags nil) | 16006 | the LaTeX math segments. If Orgmode thinks that point is actually inside |
| 9720 | (fwidth (+ maxlen 3 1 3)) | 16007 | en embedded LaTeX fragement, let texmathp do its job. |
| 9721 | (ncol (/ (- (window-width) 4) fwidth)) | 16008 | \\[org-cdlatex-mode-map]" |
| 9722 | (i-face 'org-done) | 16009 | (interactive) |
| 9723 | (c-face 'org-tag) | 16010 | (let (p) |
| 9724 | tg cnt e c char c1 c2 ntable tbl rtn | ||
| 9725 | ov-start ov-end ov-prefix | ||
| 9726 | (exit-after-next org-fast-tag-selection-single-key) | ||
| 9727 | groups ingroup) | ||
| 9728 | (save-excursion | ||
| 9729 | (beginning-of-line 1) | ||
| 9730 | (if (looking-at ".*[ \t]\\(:[A-Za-z_@0-9:]+:\\)[ \t]*\\(\r\\|$\\)") | ||
| 9731 | (setq ov-start (match-beginning 1) | ||
| 9732 | ov-end (match-end 1) | ||
| 9733 | ov-prefix "") | ||
| 9734 | (setq ov-start (1- (point-at-eol)) | ||
| 9735 | ov-end (1+ ov-start)) | ||
| 9736 | (skip-chars-forward "^\n\r") | ||
| 9737 | (setq ov-prefix | ||
| 9738 | (concat | ||
| 9739 | (buffer-substring (1- (point)) (point)) | ||
| 9740 | (if (> (current-column) org-tags-column) | ||
| 9741 | " " | ||
| 9742 | (make-string (- org-tags-column (current-column)) ?\ )))))) | ||
| 9743 | (org-move-overlay org-tags-overlay ov-start ov-end) | ||
| 9744 | (save-window-excursion | ||
| 9745 | ;; FIXME: would it be better to keep the other windows? | ||
| 9746 | (delete-other-windows) | ||
| 9747 | (split-window-vertically) | ||
| 9748 | (switch-to-buffer-other-window (get-buffer-create " *Org tags*")) | ||
| 9749 | (erase-buffer) | ||
| 9750 | (org-fast-tag-insert "Inherited" inherited i-face "\n") | ||
| 9751 | (org-fast-tag-insert "Current" current c-face "\n\n") | ||
| 9752 | (org-fast-tag-show-exit exit-after-next) | ||
| 9753 | (org-set-current-tags-overlay current ov-prefix) | ||
| 9754 | (setq tbl table char ?a cnt 0) | ||
| 9755 | (while (setq e (pop tbl)) | ||
| 9756 | (cond | 16011 | (cond |
| 9757 | ((equal e '(:startgroup)) | 16012 | ((not (org-mode-p)) ad-do-it) |
| 9758 | (push '() groups) (setq ingroup t) | 16013 | ((eq this-command 'cdlatex-math-symbol) |
| 9759 | (when (not (= cnt 0)) | 16014 | (setq ad-return-value t |
| 9760 | (setq cnt 0) | 16015 | texmathp-why '("cdlatex-math-symbol in org-mode" . 0))) |
| 9761 | (insert "\n")) | ||
| 9762 | (insert "{ ")) | ||
| 9763 | ((equal e '(:endgroup)) | ||
| 9764 | (setq ingroup nil cnt 0) | ||
| 9765 | (insert "}\n")) | ||
| 9766 | (t | 16016 | (t |
| 9767 | (setq tg (car e) c2 nil) | 16017 | (let ((p (org-inside-LaTeX-fragment-p))) |
| 9768 | (if (cdr e) | 16018 | (if (and p (member (car p) (plist-get org-format-latex-options :matchers))) |
| 9769 | (setq c (cdr e)) | 16019 | (setq ad-return-value t |
| 9770 | ;; automatically assign a character. | 16020 | texmathp-why '("Org-mode embedded math" . 0)) |
| 9771 | (setq c1 (string-to-char | 16021 | (if p ad-do-it))))))))) |
| 9772 | (downcase (substring | ||
| 9773 | tg (if (= (string-to-char tg) ?@) 1 0))))) | ||
| 9774 | (if (or (rassoc c1 ntable) (rassoc c1 table)) | ||
| 9775 | (while (or (rassoc char ntable) (rassoc char table)) | ||
| 9776 | (setq char (1+ char))) | ||
| 9777 | (setq c2 c1)) | ||
| 9778 | (setq c (or c2 char))) | ||
| 9779 | (if ingroup (push tg (car groups))) | ||
| 9780 | (setq tg (org-add-props tg nil 'face | ||
| 9781 | (cond | ||
| 9782 | ((member tg current) c-face) | ||
| 9783 | ((member tg inherited) i-face) | ||
| 9784 | (t nil)))) | ||
| 9785 | (if (and (= cnt 0) (not ingroup)) (insert " ")) | ||
| 9786 | (insert "[" c "] " tg (make-string | ||
| 9787 | (- fwidth 4 (length tg)) ?\ )) | ||
| 9788 | (push (cons tg c) ntable) | ||
| 9789 | (when (= (setq cnt (1+ cnt)) ncol) | ||
| 9790 | (insert "\n") | ||
| 9791 | (if ingroup (insert " ")) | ||
| 9792 | (setq cnt 0))))) | ||
| 9793 | (setq ntable (nreverse ntable)) | ||
| 9794 | (insert "\n") | ||
| 9795 | (goto-char (point-min)) | ||
| 9796 | (if (fboundp 'fit-window-to-buffer) (fit-window-to-buffer)) | ||
| 9797 | (setq rtn | ||
| 9798 | (catch 'exit | ||
| 9799 | (while t | ||
| 9800 | (message "[a-z..]:Toggle [SPC]:clear [RET]:accept [TAB]:free [C-c]: multi%s" | ||
| 9801 | (if groups " [!] no groups" "")) | ||
| 9802 | (setq c (let ((inhibit-quit t)) (read-char-exclusive))) | ||
| 9803 | (cond | ||
| 9804 | ((= c ?\r) (throw 'exit t)) | ||
| 9805 | ((= c ?!) | ||
| 9806 | (setq groups nil) | ||
| 9807 | (goto-char (point-min)) | ||
| 9808 | (while (re-search-forward "[{}]" nil t) (replace-match " "))) | ||
| 9809 | ((= c ?\C-c) | ||
| 9810 | (org-fast-tag-show-exit | ||
| 9811 | (setq exit-after-next (not exit-after-next)))) | ||
| 9812 | ((or (= c ?\C-g) | ||
| 9813 | (and (= c ?q) (not (rassoc c ntable)))) | ||
| 9814 | (org-detach-overlay org-tags-overlay) | ||
| 9815 | (setq quit-flag t)) | ||
| 9816 | ((= c ?\ ) | ||
| 9817 | (setq current nil) | ||
| 9818 | (if exit-after-next (setq exit-after-next 'now))) | ||
| 9819 | ((= c ?\t) | ||
| 9820 | (condition-case nil | ||
| 9821 | (setq tg (completing-read | ||
| 9822 | "Tag: " | ||
| 9823 | (or buffer-tags | ||
| 9824 | (with-current-buffer buf | ||
| 9825 | (org-get-buffer-tags))))) | ||
| 9826 | (quit (setq tg ""))) | ||
| 9827 | (when (string-match "\\S-" tg) | ||
| 9828 | (add-to-list 'buffer-tags (list tg)) | ||
| 9829 | (if (member tg current) | ||
| 9830 | (setq current (delete tg current)) | ||
| 9831 | (push tg current))) | ||
| 9832 | (if exit-after-next (setq exit-after-next 'now))) | ||
| 9833 | ((setq e (rassoc c ntable) tg (car e)) | ||
| 9834 | (if (member tg current) | ||
| 9835 | (setq current (delete tg current)) | ||
| 9836 | (loop for g in groups do | ||
| 9837 | (if (member tg g) | ||
| 9838 | (mapcar (lambda (x) | ||
| 9839 | (setq current (delete x current))) | ||
| 9840 | g))) | ||
| 9841 | (push tg current)) | ||
| 9842 | (if exit-after-next (setq exit-after-next 'now)))) | ||
| 9843 | |||
| 9844 | ;; Create a sorted list | ||
| 9845 | (setq current | ||
| 9846 | (sort current | ||
| 9847 | (lambda (a b) | ||
| 9848 | (assoc b (cdr (memq (assoc a ntable) ntable)))))) | ||
| 9849 | (if (eq exit-after-next 'now) (throw 'exit t)) | ||
| 9850 | (goto-char (point-min)) | ||
| 9851 | (beginning-of-line 2) | ||
| 9852 | (delete-region (point) (point-at-eol)) | ||
| 9853 | (org-fast-tag-insert "Current" current c-face) | ||
| 9854 | (org-set-current-tags-overlay current ov-prefix) | ||
| 9855 | (while (re-search-forward "\\[.\\] \\([a-zA-Z0-9_@]+\\)" nil t) | ||
| 9856 | (setq tg (match-string 1)) | ||
| 9857 | (add-text-properties (match-beginning 1) (match-end 1) | ||
| 9858 | (list 'face | ||
| 9859 | (cond | ||
| 9860 | ((member tg current) c-face) | ||
| 9861 | ((member tg inherited) i-face) | ||
| 9862 | (t nil))))) | ||
| 9863 | (goto-char (point-min))))) | ||
| 9864 | (org-detach-overlay org-tags-overlay) | ||
| 9865 | (if rtn | ||
| 9866 | (mapconcat 'identity current ":") | ||
| 9867 | nil)))) | ||
| 9868 | |||
| 9869 | (defun org-get-tags () | ||
| 9870 | "Get the TAGS string in the current headline." | ||
| 9871 | (unless (org-on-heading-p t) | ||
| 9872 | (error "Not on a heading")) | ||
| 9873 | (save-excursion | ||
| 9874 | (beginning-of-line 1) | ||
| 9875 | (if (looking-at ".*[ \t]\\(:[A-Za-z_@0-9:]+:\\)[ \t]*\\(\r\\|$\\)") | ||
| 9876 | (org-match-string-no-properties 1) | ||
| 9877 | ""))) | ||
| 9878 | |||
| 9879 | (defun org-get-buffer-tags () | ||
| 9880 | "Get a table of all tags used in the buffer, for completion." | ||
| 9881 | (let (tags) | ||
| 9882 | (save-excursion | ||
| 9883 | (goto-char (point-min)) | ||
| 9884 | (while (re-search-forward "[ \t]:\\([A-Za-z_@0-9:]+\\):[ \t\r\n]" nil t) | ||
| 9885 | (mapc (lambda (x) (add-to-list 'tags x)) | ||
| 9886 | (org-split-string (org-match-string-no-properties 1) ":")))) | ||
| 9887 | (mapcar 'list tags))) | ||
| 9888 | |||
| 9889 | ;;; Link Stuff | ||
| 9890 | |||
| 9891 | (defvar org-create-file-search-functions nil | ||
| 9892 | "List of functions to construct the right search string for a file link. | ||
| 9893 | These functions are called in turn with point at the location to | ||
| 9894 | which the link should point. | ||
| 9895 | |||
| 9896 | A function in the hook should first test if it would like to | ||
| 9897 | handle this file type, for example by checking the major-mode or | ||
| 9898 | the file extension. If it decides not to handle this file, it | ||
| 9899 | should just return nil to give other functions a chance. If it | ||
| 9900 | does handle the file, it must return the search string to be used | ||
| 9901 | when following the link. The search string will be part of the | ||
| 9902 | file link, given after a double colon, and `org-open-at-point' | ||
| 9903 | will automatically search for it. If special measures must be | ||
| 9904 | taken to make the search successful, another function should be | ||
| 9905 | added to the companion hook `org-execute-file-search-functions', | ||
| 9906 | which see. | ||
| 9907 | |||
| 9908 | A function in this hook may also use `setq' to set the variable | ||
| 9909 | `description' to provide a suggestion for the descriptive text to | ||
| 9910 | be used for this link when it gets inserted into an Org-mode | ||
| 9911 | buffer with \\[org-insert-link].") | ||
| 9912 | |||
| 9913 | (defvar org-execute-file-search-functions nil | ||
| 9914 | "List of functions to execute a file search triggered by a link. | ||
| 9915 | |||
| 9916 | Functions added to this hook must accept a single argument, the | ||
| 9917 | search string that was part of the file link, the part after the | ||
| 9918 | double colon. The function must first check if it would like to | ||
| 9919 | handle this search, for example by checking the major-mode or the | ||
| 9920 | file extension. If it decides not to handle this search, it | ||
| 9921 | should just return nil to give other functions a chance. If it | ||
| 9922 | does handle the search, it must return a non-nil value to keep | ||
| 9923 | other functions from trying. | ||
| 9924 | |||
| 9925 | Each function can access the current prefix argument through the | ||
| 9926 | variable `current-prefix-argument'. Note that a single prefix is | ||
| 9927 | used to force opening a link in Emacs, so it may be good to only | ||
| 9928 | use a numeric or double prefix to guide the search function. | ||
| 9929 | |||
| 9930 | In case this is needed, a function in this hook can also restore | ||
| 9931 | the window configuration before `org-open-at-point' was called using: | ||
| 9932 | |||
| 9933 | (set-window-configuration org-window-config-before-follow-link)") | ||
| 9934 | |||
| 9935 | (defun org-find-file-at-mouse (ev) | ||
| 9936 | "Open file link or URL at mouse." | ||
| 9937 | (interactive "e") | ||
| 9938 | (mouse-set-point ev) | ||
| 9939 | (org-open-at-point 'in-emacs)) | ||
| 9940 | |||
| 9941 | (defun org-open-at-mouse (ev) | ||
| 9942 | "Open file link or URL at mouse." | ||
| 9943 | (interactive "e") | ||
| 9944 | (mouse-set-point ev) | ||
| 9945 | (org-open-at-point)) | ||
| 9946 | |||
| 9947 | (defvar org-window-config-before-follow-link nil | ||
| 9948 | "The window configuration before following a link. | ||
| 9949 | This is saved in case the need arises to restore it.") | ||
| 9950 | |||
| 9951 | ;; FIXME: IN-EMACS is used for many purposes, maybe rename this argument??? | ||
| 9952 | (defun org-open-at-point (&optional in-emacs) | ||
| 9953 | "Open link at or after point. | ||
| 9954 | If there is no link at point, this function will search forward up to | ||
| 9955 | the end of the current subtree. | ||
| 9956 | Normally, files will be opened by an appropriate application. If the | ||
| 9957 | optional argument IN-EMACS is non-nil, Emacs will visit the file." | ||
| 9958 | (interactive "P") | ||
| 9959 | (setq org-window-config-before-follow-link (current-window-configuration)) | ||
| 9960 | (org-remove-occur-highlights nil nil t) | ||
| 9961 | (if (org-at-timestamp-p t) | ||
| 9962 | (org-follow-timestamp-link) | ||
| 9963 | (let (type path link line search (pos (point))) | ||
| 9964 | (catch 'match | ||
| 9965 | (save-excursion | ||
| 9966 | (skip-chars-forward "^]\n\r") | ||
| 9967 | (when (and (re-search-backward "\\[\\[" nil t) | ||
| 9968 | (looking-at org-bracket-link-regexp) | ||
| 9969 | (<= (match-beginning 0) pos) | ||
| 9970 | (>= (match-end 0) pos)) | ||
| 9971 | (setq link (org-link-unescape (org-match-string-no-properties 1))) | ||
| 9972 | (while (string-match " *\n *" link) | ||
| 9973 | (setq link (replace-match " " t t link))) | ||
| 9974 | (setq link (org-link-expand-abbrev link)) | ||
| 9975 | (if (string-match org-link-re-with-space2 link) | ||
| 9976 | (setq type (match-string 1 link) | ||
| 9977 | path (match-string 2 link)) | ||
| 9978 | (setq type "thisfile" | ||
| 9979 | path link)) | ||
| 9980 | (throw 'match t))) | ||
| 9981 | |||
| 9982 | (when (get-text-property (point) 'org-linked-text) | ||
| 9983 | (setq type "thisfile" | ||
| 9984 | pos (if (get-text-property (1+ (point)) 'org-linked-text) | ||
| 9985 | (1+ (point)) (point)) | ||
| 9986 | path (buffer-substring | ||
| 9987 | (previous-single-property-change pos 'org-linked-text) | ||
| 9988 | (next-single-property-change pos 'org-linked-text))) | ||
| 9989 | (throw 'match t)) | ||
| 9990 | |||
| 9991 | (save-excursion | ||
| 9992 | (skip-chars-backward (concat "^[]" org-non-link-chars " ")) | ||
| 9993 | (if (equal (char-before) ?<) (backward-char 1)) | ||
| 9994 | (when (or (looking-at org-angle-link-re) | ||
| 9995 | (looking-at org-plain-link-re) | ||
| 9996 | (and (or (re-search-forward org-angle-link-re (point-at-eol) t) | ||
| 9997 | (re-search-forward org-plain-link-re (point-at-eol) t)) | ||
| 9998 | (<= (match-beginning 0) pos) | ||
| 9999 | (>= (match-end 0) pos))) | ||
| 10000 | (setq type (match-string 1) | ||
| 10001 | path (match-string 2)) | ||
| 10002 | (throw 'match t))) | ||
| 10003 | (save-excursion | ||
| 10004 | (skip-chars-backward "^ \t\n\r") | ||
| 10005 | (when (looking-at "\\(:[A-Za-z_@0-9:]+\\):[ \t\r\n]") | ||
| 10006 | (setq type "tags" | ||
| 10007 | path (match-string 1)) | ||
| 10008 | (while (string-match ":" path) | ||
| 10009 | (setq path (replace-match "+" t t path))) | ||
| 10010 | (throw 'match t))) | ||
| 10011 | (save-excursion | ||
| 10012 | (skip-chars-backward "a-zA-Z_") | ||
| 10013 | (when (and (memq 'camel org-activate-links) | ||
| 10014 | (looking-at org-camel-regexp)) | ||
| 10015 | (setq type "camel" path (match-string 0)) | ||
| 10016 | (if (equal (char-before) ?*) | ||
| 10017 | (setq path (concat "*" path)))) | ||
| 10018 | (throw 'match t))) | ||
| 10019 | (unless path | ||
| 10020 | (error "No link found")) | ||
| 10021 | ;; Remove any trailing spaces in path | ||
| 10022 | (if (string-match " +\\'" path) | ||
| 10023 | (setq path (replace-match "" t t path))) | ||
| 10024 | |||
| 10025 | (cond | ||
| 10026 | |||
| 10027 | ((equal type "mailto") | ||
| 10028 | (let ((cmd (car org-link-mailto-program)) | ||
| 10029 | (args (cdr org-link-mailto-program)) args1 | ||
| 10030 | (address path) (subject "") a) | ||
| 10031 | (if (string-match "\\(.*\\)::\\(.*\\)" path) | ||
| 10032 | (setq address (match-string 1 path) | ||
| 10033 | subject (org-link-escape (match-string 2 path)))) | ||
| 10034 | (while args | ||
| 10035 | (cond | ||
| 10036 | ((not (stringp (car args))) (push (pop args) args1)) | ||
| 10037 | (t (setq a (pop args)) | ||
| 10038 | (if (string-match "%a" a) | ||
| 10039 | (setq a (replace-match address t t a))) | ||
| 10040 | (if (string-match "%s" a) | ||
| 10041 | (setq a (replace-match subject t t a))) | ||
| 10042 | (push a args1)))) | ||
| 10043 | (apply cmd (nreverse args1)))) | ||
| 10044 | |||
| 10045 | ((member type '("http" "https" "ftp" "news")) | ||
| 10046 | (browse-url (concat type ":" path))) | ||
| 10047 | |||
| 10048 | ((string= type "tags") | ||
| 10049 | (org-tags-view in-emacs path)) | ||
| 10050 | ((or (string= type "camel") | ||
| 10051 | (string= type "thisfile")) | ||
| 10052 | (if in-emacs | ||
| 10053 | (switch-to-buffer-other-window | ||
| 10054 | (org-get-buffer-for-internal-link (current-buffer))) | ||
| 10055 | (org-mark-ring-push)) | ||
| 10056 | (org-link-search | ||
| 10057 | path | ||
| 10058 | (cond ((equal in-emacs '(4)) 'occur) | ||
| 10059 | ((equal in-emacs '(16)) 'org-occur) | ||
| 10060 | (t nil)))) | ||
| 10061 | |||
| 10062 | ((string= type "file") | ||
| 10063 | (if (string-match "::\\([0-9]+\\)\\'" path) | ||
| 10064 | (setq line (string-to-number (match-string 1 path)) | ||
| 10065 | path (substring path 0 (match-beginning 0))) | ||
| 10066 | (if (string-match "::\\(.+\\)\\'" path) | ||
| 10067 | (setq search (match-string 1 path) | ||
| 10068 | path (substring path 0 (match-beginning 0))))) | ||
| 10069 | (org-open-file path in-emacs line search)) | ||
| 10070 | |||
| 10071 | ((string= type "news") | ||
| 10072 | (org-follow-gnus-link path)) | ||
| 10073 | |||
| 10074 | ((string= type "bbdb") | ||
| 10075 | (org-follow-bbdb-link path)) | ||
| 10076 | |||
| 10077 | ((string= type "info") | ||
| 10078 | (org-follow-info-link path)) | ||
| 10079 | |||
| 10080 | ((string= type "gnus") | ||
| 10081 | (let (group article) | ||
| 10082 | (if (not (string-match "\\`\\([^#]+\\)\\(#\\(.*\\)\\)?" path)) | ||
| 10083 | (error "Error in Gnus link")) | ||
| 10084 | (setq group (match-string 1 path) | ||
| 10085 | article (match-string 3 path)) | ||
| 10086 | (org-follow-gnus-link group article))) | ||
| 10087 | |||
| 10088 | ((string= type "vm") | ||
| 10089 | (let (folder article) | ||
| 10090 | (if (not (string-match "\\`\\([^#]+\\)\\(#\\(.*\\)\\)?" path)) | ||
| 10091 | (error "Error in VM link")) | ||
| 10092 | (setq folder (match-string 1 path) | ||
| 10093 | article (match-string 3 path)) | ||
| 10094 | ;; in-emacs is the prefix arg, will be interpreted as read-only | ||
| 10095 | (org-follow-vm-link folder article in-emacs))) | ||
| 10096 | |||
| 10097 | ((string= type "wl") | ||
| 10098 | (let (folder article) | ||
| 10099 | (if (not (string-match "\\`\\([^#]+\\)\\(#\\(.*\\)\\)?" path)) | ||
| 10100 | (error "Error in Wanderlust link")) | ||
| 10101 | (setq folder (match-string 1 path) | ||
| 10102 | article (match-string 3 path)) | ||
| 10103 | (org-follow-wl-link folder article))) | ||
| 10104 | |||
| 10105 | ((string= type "mhe") | ||
| 10106 | (let (folder article) | ||
| 10107 | (if (not (string-match "\\`\\([^#]+\\)\\(#\\(.*\\)\\)?" path)) | ||
| 10108 | (error "Error in MHE link")) | ||
| 10109 | (setq folder (match-string 1 path) | ||
| 10110 | article (match-string 3 path)) | ||
| 10111 | (org-follow-mhe-link folder article))) | ||
| 10112 | |||
| 10113 | ((string= type "rmail") | ||
| 10114 | (let (folder article) | ||
| 10115 | (if (not (string-match "\\`\\([^#]+\\)\\(#\\(.*\\)\\)?" path)) | ||
| 10116 | (error "Error in RMAIL link")) | ||
| 10117 | (setq folder (match-string 1 path) | ||
| 10118 | article (match-string 3 path)) | ||
| 10119 | (org-follow-rmail-link folder article))) | ||
| 10120 | |||
| 10121 | ((string= type "shell") | ||
| 10122 | (let ((cmd path)) | ||
| 10123 | (while (string-match "@{" cmd) ; FIXME: not needed for [[]] links | ||
| 10124 | (setq cmd (replace-match "<" t t cmd))) | ||
| 10125 | (while (string-match "@}" cmd) ; FIXME: not needed for [[]] links | ||
| 10126 | (setq cmd (replace-match ">" t t cmd))) | ||
| 10127 | (if (or (not org-confirm-shell-link-function) | ||
| 10128 | (funcall org-confirm-shell-link-function | ||
| 10129 | (format "Execute \"%s\" in shell? " | ||
| 10130 | (org-add-props cmd nil | ||
| 10131 | 'face 'org-warning)))) | ||
| 10132 | (progn | ||
| 10133 | (message "Executing %s" cmd) | ||
| 10134 | (shell-command cmd)) | ||
| 10135 | (error "Abort")))) | ||
| 10136 | |||
| 10137 | ((string= type "elisp") | ||
| 10138 | (let ((cmd path)) | ||
| 10139 | (if (or (not org-confirm-elisp-link-function) | ||
| 10140 | (funcall org-confirm-elisp-link-function | ||
| 10141 | (format "Execute \"%s\" as elisp? " | ||
| 10142 | (org-add-props cmd nil | ||
| 10143 | 'face 'org-warning)))) | ||
| 10144 | (message "%s => %s" cmd (eval (read cmd))) | ||
| 10145 | (error "Abort")))) | ||
| 10146 | |||
| 10147 | (t | ||
| 10148 | (browse-url-at-point)))))) | ||
| 10149 | 16022 | ||
| 10150 | (defun org-link-expand-abbrev (link) | 16023 | (defun turn-on-org-cdlatex () |
| 10151 | "Apply replacements as defined in `org-link-abbrev-alist." | 16024 | "Unconditionally turn on `org-cdlatex-mode'." |
| 10152 | (if (string-match "^\\([a-zA-Z]+\\)\\(::\\(.*\\)\\)?$" link) | 16025 | (org-cdlatex-mode 1)) |
| 10153 | (let* ((key (match-string 1 link)) | ||
| 10154 | (as (or (assoc key org-link-abbrev-alist-local) | ||
| 10155 | (assoc key org-link-abbrev-alist))) | ||
| 10156 | (tag (and (match-end 2) (match-string 3 link))) | ||
| 10157 | rpl) | ||
| 10158 | (if (not as) | ||
| 10159 | link | ||
| 10160 | (setq rpl (cdr as)) | ||
| 10161 | (cond | ||
| 10162 | ((symbolp rpl) (funcall rpl tag)) | ||
| 10163 | ((string-match "%s" rpl) (replace-match (or tag "") t t rpl)) | ||
| 10164 | (t (concat rpl tag))))) | ||
| 10165 | link)) | ||
| 10166 | 16026 | ||
| 10167 | (defun org-link-search (s &optional type) | 16027 | (defun org-inside-LaTeX-fragment-p () |
| 10168 | "Search for a link search option. | 16028 | "Test if point is inside a LaTeX fragment. |
| 10169 | When S is a CamelCaseWord, search for a target, or for a sentence containing | 16029 | I.e. after a \\begin, \\(, \\[, $, or $$, without the corresponding closing |
| 10170 | the words. If S is surrounded by forward slashes, it is interpreted as a | 16030 | sequence appearing also before point. |
| 10171 | regular expression. In org-mode files, this will create an `org-occur' | 16031 | Even though the matchers for math are configurable, this function assumes |
| 10172 | sparse tree. In ordinary files, `occur' will be used to list matches. | 16032 | that \\begin, \\(, \\[, and $$ are always used. Only the single dollar |
| 10173 | If the current buffer is in `dired-mode', grep will be used to search | 16033 | delimiters are skipped when they have been removed by customization. |
| 10174 | in all files." | 16034 | The return value is nil, or a cons cell with the delimiter and |
| 10175 | (let ((case-fold-search t) | 16035 | and the position of this delimiter. |
| 10176 | (s0 (mapconcat 'identity (org-split-string s "[ \t\r\n]+") " ")) | ||
| 10177 | (pos (point)) | ||
| 10178 | (pre "") (post "") | ||
| 10179 | words re0 re1 re2 re3 re4 re5 re2a reall camel) | ||
| 10180 | (cond | ||
| 10181 | ;; First check if there are any special | ||
| 10182 | ((run-hook-with-args-until-success 'org-execute-file-search-functions s)) | ||
| 10183 | ;; Now try the builtin stuff | ||
| 10184 | ((save-excursion | ||
| 10185 | (goto-char (point-min)) | ||
| 10186 | (and | ||
| 10187 | (re-search-forward | ||
| 10188 | (concat "<<" (regexp-quote s0) ">>") nil t) | ||
| 10189 | (setq pos (match-beginning 0)))) | ||
| 10190 | ;; There is an exact target for this | ||
| 10191 | (goto-char pos)) | ||
| 10192 | ((string-match "^/\\(.*\\)/$" s) | ||
| 10193 | ;; A regular expression | ||
| 10194 | (cond | ||
| 10195 | ((org-mode-p) | ||
| 10196 | (org-occur (match-string 1 s))) | ||
| 10197 | ;;((eq major-mode 'dired-mode) | ||
| 10198 | ;; (grep (concat "grep -n -e '" (match-string 1 s) "' *"))) | ||
| 10199 | (t (org-do-occur (match-string 1 s))))) | ||
| 10200 | ((or (setq camel (string-match (concat "^" org-camel-regexp "$") s)) | ||
| 10201 | t) | ||
| 10202 | ;; A camel or a normal search string | ||
| 10203 | (when (equal (string-to-char s) ?*) | ||
| 10204 | ;; Anchor on headlines, post may include tags. | ||
| 10205 | (setq pre "^\\*+[ \t]*\\(?:\\sw+\\)?[ \t]*" | ||
| 10206 | post "[ \t]*\\(?:[ \t]+:[a-zA-Z_@0-9:+]:[ \t]*\\)?$" | ||
| 10207 | s (substring s 1))) | ||
| 10208 | (remove-text-properties | ||
| 10209 | 0 (length s) | ||
| 10210 | '(face nil mouse-face nil keymap nil fontified nil) s) | ||
| 10211 | ;; Make a series of regular expressions to find a match | ||
| 10212 | (setq words | ||
| 10213 | (if camel | ||
| 10214 | (org-camel-to-words s) | ||
| 10215 | (org-split-string s "[ \n\r\t]+")) | ||
| 10216 | re0 (concat "\\(<<" (regexp-quote s0) ">>\\)") | ||
| 10217 | re2 (concat "[ \t\r\n]\\(" (mapconcat 'downcase words "[ \t]+") "\\)[ \t\r\n]") | ||
| 10218 | re2a (concat "[ \t\r\n]\\(" (mapconcat 'downcase words "[ \t\r\n]+") "\\)[ \t\r\n]") | ||
| 10219 | re4 (concat "[^a-zA-Z_]\\(" (mapconcat 'downcase words "[^a-zA-Z_\r\n]+") "\\)[^a-zA-Z_]") | ||
| 10220 | re1 (concat pre re2 post) | ||
| 10221 | re3 (concat pre re4 post) | ||
| 10222 | re5 (concat pre ".*" re4) | ||
| 10223 | re2 (concat pre re2) | ||
| 10224 | re2a (concat pre re2a) | ||
| 10225 | re4 (concat pre re4) | ||
| 10226 | reall (concat "\\(" re0 "\\)\\|\\(" re1 "\\)\\|\\(" re2 | ||
| 10227 | "\\)\\|\\(" re3 "\\)\\|\\(" re4 "\\)\\|\\(" | ||
| 10228 | re5 "\\)" | ||
| 10229 | )) | ||
| 10230 | (cond | ||
| 10231 | ((eq type 'org-occur) (org-occur reall)) | ||
| 10232 | ((eq type 'occur) (org-do-occur (downcase reall) 'cleanup)) | ||
| 10233 | (t (goto-char (point-min)) | ||
| 10234 | (if (or (org-search-not-link re0 nil t) | ||
| 10235 | (org-search-not-link re1 nil t) | ||
| 10236 | (org-search-not-link re2 nil t) | ||
| 10237 | (org-search-not-link re2a nil t) | ||
| 10238 | (org-search-not-link re3 nil t) | ||
| 10239 | (org-search-not-link re4 nil t) | ||
| 10240 | (org-search-not-link re5 nil t) | ||
| 10241 | ) | ||
| 10242 | (goto-char (match-beginning 1)) | ||
| 10243 | (goto-char pos) | ||
| 10244 | (error "No match"))))) | ||
| 10245 | (t | ||
| 10246 | ;; Normal string-search | ||
| 10247 | (goto-char (point-min)) | ||
| 10248 | (if (search-forward s nil t) | ||
| 10249 | (goto-char (match-beginning 0)) | ||
| 10250 | (error "No match")))) | ||
| 10251 | (and (org-mode-p) (org-show-context 'link-search)))) | ||
| 10252 | 16036 | ||
| 10253 | (defun org-search-not-link (&rest args) | 16037 | This function does a reasonably good job, but can locally be fooled by |
| 10254 | "Execute `re-search-forward', but only accept matches that are not a link." | 16038 | for example currency specifications. For example it will assume being in |
| 16039 | inline math after \"$22.34\". The LaTeX fragment formatter will only format | ||
| 16040 | fragments that are properly closed, but during editing, we have to live | ||
| 16041 | with the uncertainty caused by missing closing delimiters. This function | ||
| 16042 | looks only before point, not after." | ||
| 10255 | (catch 'exit | 16043 | (catch 'exit |
| 10256 | (let (p1) | 16044 | (let ((pos (point)) |
| 10257 | (while (apply 're-search-forward args) | 16045 | (dodollar (member "$" (plist-get org-format-latex-options :matchers))) |
| 10258 | (setq p1 (point)) | 16046 | (lim (progn |
| 10259 | (if (not (save-match-data | 16047 | (re-search-backward (concat "^\\(" paragraph-start "\\)") nil t) |
| 10260 | (and (re-search-backward "\\[\\[" nil t) | 16048 | (point))) |
| 10261 | (looking-at org-bracket-link-regexp) | 16049 | dd-on str (start 0) m re) |
| 10262 | (<= (match-beginning 0) p1) | 16050 | (goto-char pos) |
| 10263 | (>= (match-end 0) p1)))) | 16051 | (when dodollar |
| 10264 | (progn (goto-char (match-end 0)) | 16052 | (setq str (concat (buffer-substring lim (point)) "\000 X$.") |
| 10265 | (throw 'exit (point))) | 16053 | re (nth 1 (assoc "$" org-latex-regexps))) |
| 10266 | (goto-char (match-end 0))))))) | 16054 | (while (string-match re str start) |
| 10267 | 16055 | (cond | |
| 10268 | (defun org-get-buffer-for-internal-link (buffer) | 16056 | ((= (match-end 0) (length str)) |
| 10269 | "Return a buffer to be used for displaying the link target of internal links." | 16057 | (throw 'exit (cons "$" (+ lim (match-beginning 0))))) |
| 10270 | (cond | 16058 | ((= (match-end 0) (- (length str) 5)) |
| 10271 | ((not org-display-internal-link-with-indirect-buffer) | 16059 | (throw 'exit nil)) |
| 10272 | buffer) | 16060 | (t (setq start (match-end 0)))))) |
| 10273 | ((string-match "(Clone)$" (buffer-name buffer)) | 16061 | (when (setq m (re-search-backward "\\(\\\\begin{[^}]*}\\|\\\\(\\|\\\\\\[\\)\\|\\(\\\\end{[^}]*}\\|\\\\)\\|\\\\\\]\\)\\|\\(\\$\\$\\)" lim t)) |
| 10274 | (message "Buffer is already a clone, not making another one") | 16062 | (goto-char pos) |
| 10275 | ;; we also do not modify visibility in this case | 16063 | (and (match-beginning 1) (throw 'exit (cons (match-string 1) m))) |
| 10276 | buffer) | 16064 | (and (match-beginning 2) (throw 'exit nil)) |
| 10277 | (t ; make a new indirect buffer for displaying the link | 16065 | ;; count $$ |
| 10278 | (let* ((bn (buffer-name buffer)) | 16066 | (while (re-search-backward "\\$\\$" lim t) |
| 10279 | (ibn (concat bn "(Clone)")) | 16067 | (setq dd-on (not dd-on))) |
| 10280 | (ib (or (get-buffer ibn) (make-indirect-buffer buffer ibn 'clone)))) | 16068 | (goto-char pos) |
| 10281 | (with-current-buffer ib (org-overview)) | 16069 | (if dd-on (cons "$$" m)))))) |
| 10282 | ib)))) | ||
| 10283 | |||
| 10284 | (defun org-do-occur (regexp &optional cleanup) | ||
| 10285 | "Call the Emacs command `occur'. | ||
| 10286 | If CLEANUP is non-nil, remove the printout of the regular expression | ||
| 10287 | in the *Occur* buffer. This is useful if the regex is long and not useful | ||
| 10288 | to read." | ||
| 10289 | (occur regexp) | ||
| 10290 | (when cleanup | ||
| 10291 | (let ((cwin (selected-window)) win beg end) | ||
| 10292 | (when (setq win (get-buffer-window "*Occur*")) | ||
| 10293 | (select-window win)) | ||
| 10294 | (goto-char (point-min)) | ||
| 10295 | (when (re-search-forward "match[a-z]+" nil t) | ||
| 10296 | (setq beg (match-end 0)) | ||
| 10297 | (if (re-search-forward "^[ \t]*[0-9]+" nil t) | ||
| 10298 | (setq end (1- (match-beginning 0))))) | ||
| 10299 | (and beg end (let ((buffer-read-only)) (delete-region beg end))) | ||
| 10300 | (goto-char (point-min)) | ||
| 10301 | (select-window cwin)))) | ||
| 10302 | |||
| 10303 | (defvar org-mark-ring nil | ||
| 10304 | "Mark ring for positions before jumps in Org-mode.") | ||
| 10305 | (defvar org-mark-ring-last-goto nil | ||
| 10306 | "Last position in the mark ring used to go back.") | ||
| 10307 | ;; Fill and close the ring | ||
| 10308 | (setq org-mark-ring nil org-mark-ring-last-goto nil) ;; in case file is reloaded | ||
| 10309 | (loop for i from 1 to org-mark-ring-length do | ||
| 10310 | (push (make-marker) org-mark-ring)) | ||
| 10311 | (setcdr (nthcdr (1- org-mark-ring-length) org-mark-ring) | ||
| 10312 | org-mark-ring) | ||
| 10313 | |||
| 10314 | (defun org-mark-ring-push (&optional pos buffer) | ||
| 10315 | "Put the current position or POS into the mark ring and rotate it." | ||
| 10316 | (interactive) | ||
| 10317 | (setq pos (or pos (point))) | ||
| 10318 | (setq org-mark-ring (nthcdr (1- org-mark-ring-length) org-mark-ring)) | ||
| 10319 | (move-marker (car org-mark-ring) | ||
| 10320 | (or pos (point)) | ||
| 10321 | (or buffer (current-buffer))) | ||
| 10322 | (message | ||
| 10323 | (substitute-command-keys | ||
| 10324 | "Position saved to mark ring, go back with \\[org-mark-ring-goto]."))) | ||
| 10325 | |||
| 10326 | (defun org-mark-ring-goto (&optional n) | ||
| 10327 | "Jump to the previous position in the mark ring. | ||
| 10328 | With prefix arg N, jump back that many stored positions. When | ||
| 10329 | called several times in succession, walk through the entire ring. | ||
| 10330 | Org-mode commands jumping to a different position in the current file, | ||
| 10331 | or to another Org-mode file, automatically push the old position | ||
| 10332 | onto the ring." | ||
| 10333 | (interactive "p") | ||
| 10334 | (let (p m) | ||
| 10335 | (if (eq last-command this-command) | ||
| 10336 | (setq p (nthcdr n (or org-mark-ring-last-goto org-mark-ring))) | ||
| 10337 | (setq p org-mark-ring)) | ||
| 10338 | (setq org-mark-ring-last-goto p) | ||
| 10339 | (setq m (car p)) | ||
| 10340 | (switch-to-buffer (marker-buffer m)) | ||
| 10341 | (goto-char m) | ||
| 10342 | (if (or (org-invisible-p) (org-invisible-p2)) (org-show-context 'mark-goto)))) | ||
| 10343 | |||
| 10344 | (defun org-camel-to-words (s) | ||
| 10345 | "Split \"CamelCaseWords\" to (\"Camel\" \"Case\" \"Words\")." | ||
| 10346 | (let ((case-fold-search nil) | ||
| 10347 | words) | ||
| 10348 | (while (string-match "[a-z][A-Z]" s) | ||
| 10349 | (push (substring s 0 (1+ (match-beginning 0))) words) | ||
| 10350 | (setq s (substring s (1+ (match-beginning 0))))) | ||
| 10351 | (nreverse (cons s words)))) | ||
| 10352 | |||
| 10353 | (defun org-remove-angle-brackets (s) | ||
| 10354 | (if (equal (substring s 0 1) "<") (setq s (substring s 1))) | ||
| 10355 | (if (equal (substring s -1) ">") (setq s (substring s 0 -1))) | ||
| 10356 | s) | ||
| 10357 | (defun org-add-angle-brackets (s) | ||
| 10358 | (if (equal (substring s 0 1) "<") nil (setq s (concat "<" s))) | ||
| 10359 | (if (equal (substring s -1) ">") nil (setq s (concat s ">"))) | ||
| 10360 | s) | ||
| 10361 | |||
| 10362 | (defun org-follow-timestamp-link () | ||
| 10363 | (cond | ||
| 10364 | ((org-at-date-range-p t) | ||
| 10365 | (let ((org-agenda-start-on-weekday) | ||
| 10366 | (t1 (match-string 1)) | ||
| 10367 | (t2 (match-string 2))) | ||
| 10368 | (setq t1 (time-to-days (org-time-string-to-time t1)) | ||
| 10369 | t2 (time-to-days (org-time-string-to-time t2))) | ||
| 10370 | (org-agenda-list nil t1 (1+ (- t2 t1))))) | ||
| 10371 | ((org-at-timestamp-p t) | ||
| 10372 | (org-agenda-list nil (time-to-days (org-time-string-to-time | ||
| 10373 | (substring (match-string 1) 0 10))) | ||
| 10374 | 1)) | ||
| 10375 | (t (error "This should not happen")))) | ||
| 10376 | |||
| 10377 | |||
| 10378 | (defun org-follow-bbdb-link (name) | ||
| 10379 | "Follow a BBDB link to NAME." | ||
| 10380 | (require 'bbdb) | ||
| 10381 | (let ((inhibit-redisplay t) | ||
| 10382 | (bbdb-electric-p nil)) | ||
| 10383 | (catch 'exit | ||
| 10384 | ;; Exact match on name | ||
| 10385 | (bbdb-name (concat "\\`" name "\\'") nil) | ||
| 10386 | (if (< 0 (buffer-size (get-buffer "*BBDB*"))) (throw 'exit nil)) | ||
| 10387 | ;; Exact match on name | ||
| 10388 | (bbdb-company (concat "\\`" name "\\'") nil) | ||
| 10389 | (if (< 0 (buffer-size (get-buffer "*BBDB*"))) (throw 'exit nil)) | ||
| 10390 | ;; Partial match on name | ||
| 10391 | (bbdb-name name nil) | ||
| 10392 | (if (< 0 (buffer-size (get-buffer "*BBDB*"))) (throw 'exit nil)) | ||
| 10393 | ;; Partial match on company | ||
| 10394 | (bbdb-company name nil) | ||
| 10395 | (if (< 0 (buffer-size (get-buffer "*BBDB*"))) (throw 'exit nil)) | ||
| 10396 | ;; General match including network address and notes | ||
| 10397 | (bbdb name nil) | ||
| 10398 | (when (= 0 (buffer-size (get-buffer "*BBDB*"))) | ||
| 10399 | (delete-window (get-buffer-window "*BBDB*")) | ||
| 10400 | (error "No matching BBDB record"))))) | ||
| 10401 | |||
| 10402 | |||
| 10403 | (defun org-follow-info-link (name) | ||
| 10404 | "Follow an info file & node link to NAME." | ||
| 10405 | (if (or (string-match "\\(.*\\)::?\\(.*\\)" name) | ||
| 10406 | (string-match "\\(.*\\)" name)) | ||
| 10407 | (progn | ||
| 10408 | (require 'info) | ||
| 10409 | (if (match-string 2 name) ; If there isn't a node, choose "Top" | ||
| 10410 | (Info-find-node (match-string 1 name) (match-string 2 name)) | ||
| 10411 | (Info-find-node (match-string 1 name) "Top"))) | ||
| 10412 | (message (concat "Could not open: " name)))) | ||
| 10413 | |||
| 10414 | (defun org-follow-gnus-link (&optional group article) | ||
| 10415 | "Follow a Gnus link to GROUP and ARTICLE." | ||
| 10416 | (require 'gnus) | ||
| 10417 | (funcall (cdr (assq 'gnus org-link-frame-setup))) | ||
| 10418 | (if gnus-other-frame-object (select-frame gnus-other-frame-object)) | ||
| 10419 | (if group (gnus-fetch-group group)) | ||
| 10420 | (if article | ||
| 10421 | (or (gnus-summary-goto-article article nil 'force) | ||
| 10422 | (if (fboundp 'gnus-summary-insert-cached-articles) | ||
| 10423 | (progn | ||
| 10424 | (gnus-summary-insert-cached-articles) | ||
| 10425 | (gnus-summary-goto-article article nil 'force)) | ||
| 10426 | (message "Message could not be found."))))) | ||
| 10427 | |||
| 10428 | (defun org-follow-vm-link (&optional folder article readonly) | ||
| 10429 | "Follow a VM link to FOLDER and ARTICLE." | ||
| 10430 | (require 'vm) | ||
| 10431 | (setq article (org-add-angle-brackets article)) | ||
| 10432 | (if (string-match "^//\\([a-zA-Z]+@\\)?\\([^:]+\\):\\(.*\\)" folder) | ||
| 10433 | ;; ange-ftp or efs or tramp access | ||
| 10434 | (let ((user (or (match-string 1 folder) (user-login-name))) | ||
| 10435 | (host (match-string 2 folder)) | ||
| 10436 | (file (match-string 3 folder))) | ||
| 10437 | (cond | ||
| 10438 | ((featurep 'tramp) | ||
| 10439 | ;; use tramp to access the file | ||
| 10440 | (if (featurep 'xemacs) | ||
| 10441 | (setq folder (format "[%s@%s]%s" user host file)) | ||
| 10442 | (setq folder (format "/%s@%s:%s" user host file)))) | ||
| 10443 | (t | ||
| 10444 | ;; use ange-ftp or efs | ||
| 10445 | (require (if (featurep 'xemacs) 'efs 'ange-ftp)) | ||
| 10446 | (setq folder (format "/%s@%s:%s" user host file)))))) | ||
| 10447 | (when folder | ||
| 10448 | (funcall (cdr (assq 'vm org-link-frame-setup)) folder readonly) | ||
| 10449 | (sit-for 0.1) | ||
| 10450 | (when article | ||
| 10451 | (vm-select-folder-buffer) | ||
| 10452 | (widen) | ||
| 10453 | (let ((case-fold-search t)) | ||
| 10454 | (goto-char (point-min)) | ||
| 10455 | (if (not (re-search-forward | ||
| 10456 | (concat "^" "message-id: *" (regexp-quote article)))) | ||
| 10457 | (error "Could not find the specified message in this folder")) | ||
| 10458 | (vm-isearch-update) | ||
| 10459 | (vm-isearch-narrow) | ||
| 10460 | (vm-beginning-of-message) | ||
| 10461 | (vm-summarize))))) | ||
| 10462 | |||
| 10463 | (defun org-follow-wl-link (folder article) | ||
| 10464 | "Follow a Wanderlust link to FOLDER and ARTICLE." | ||
| 10465 | (setq article (org-add-angle-brackets article)) | ||
| 10466 | (wl-summary-goto-folder-subr folder 'no-sync t nil t) | ||
| 10467 | (if article (wl-summary-jump-to-msg-by-message-id article ">")) | ||
| 10468 | (wl-summary-redisplay)) | ||
| 10469 | |||
| 10470 | (defun org-follow-rmail-link (folder article) | ||
| 10471 | "Follow an RMAIL link to FOLDER and ARTICLE." | ||
| 10472 | (setq article (org-add-angle-brackets article)) | ||
| 10473 | (let (message-number) | ||
| 10474 | (save-excursion | ||
| 10475 | (save-window-excursion | ||
| 10476 | (rmail (if (string= folder "RMAIL") rmail-file-name folder)) | ||
| 10477 | (setq message-number | ||
| 10478 | (save-restriction | ||
| 10479 | (widen) | ||
| 10480 | (goto-char (point-max)) | ||
| 10481 | (if (re-search-backward | ||
| 10482 | (concat "^Message-ID:\\s-+" (regexp-quote | ||
| 10483 | (or article ""))) | ||
| 10484 | nil t) | ||
| 10485 | (rmail-what-message)))))) | ||
| 10486 | (if message-number | ||
| 10487 | (progn | ||
| 10488 | (rmail (if (string= folder "RMAIL") rmail-file-name folder)) | ||
| 10489 | (rmail-show-message message-number) | ||
| 10490 | message-number) | ||
| 10491 | (error "Message not found")))) | ||
| 10492 | |||
| 10493 | ;; mh-e integration based on planner-mode | ||
| 10494 | (defun org-mhe-get-message-real-folder () | ||
| 10495 | "Return the name of the current message real folder, so if you use | ||
| 10496 | sequences, it will now work." | ||
| 10497 | (save-excursion | ||
| 10498 | (let* ((folder | ||
| 10499 | (if (equal major-mode 'mh-folder-mode) | ||
| 10500 | mh-current-folder | ||
| 10501 | ;; Refer to the show buffer | ||
| 10502 | mh-show-folder-buffer)) | ||
| 10503 | (end-index | ||
| 10504 | (if (boundp 'mh-index-folder) | ||
| 10505 | (min (length mh-index-folder) (length folder)))) | ||
| 10506 | ) | ||
| 10507 | ;; a simple test on mh-index-data does not work, because | ||
| 10508 | ;; mh-index-data is always nil in a show buffer. | ||
| 10509 | (if (and (boundp 'mh-index-folder) | ||
| 10510 | (string= mh-index-folder (substring folder 0 end-index))) | ||
| 10511 | (if (equal major-mode 'mh-show-mode) | ||
| 10512 | (save-window-excursion | ||
| 10513 | (when (buffer-live-p (get-buffer folder)) | ||
| 10514 | (progn | ||
| 10515 | (pop-to-buffer folder) | ||
| 10516 | (org-mhe-get-message-folder-from-index) | ||
| 10517 | ) | ||
| 10518 | )) | ||
| 10519 | (org-mhe-get-message-folder-from-index) | ||
| 10520 | ) | ||
| 10521 | folder | ||
| 10522 | ) | ||
| 10523 | ))) | ||
| 10524 | |||
| 10525 | (defun org-mhe-get-message-folder-from-index () | ||
| 10526 | "Returns the name of the message folder in a index folder buffer." | ||
| 10527 | (save-excursion | ||
| 10528 | (mh-index-previous-folder) | ||
| 10529 | (re-search-forward "^\\(+.*\\)$" nil t) | ||
| 10530 | (message (match-string 1)))) | ||
| 10531 | |||
| 10532 | (defun org-mhe-get-message-folder () | ||
| 10533 | "Return the name of the current message folder. Be careful if you | ||
| 10534 | use sequences." | ||
| 10535 | (save-excursion | ||
| 10536 | (if (equal major-mode 'mh-folder-mode) | ||
| 10537 | mh-current-folder | ||
| 10538 | ;; Refer to the show buffer | ||
| 10539 | mh-show-folder-buffer))) | ||
| 10540 | |||
| 10541 | (defun org-mhe-get-message-num () | ||
| 10542 | "Return the number of the current message. Be careful if you | ||
| 10543 | use sequences." | ||
| 10544 | (save-excursion | ||
| 10545 | (if (equal major-mode 'mh-folder-mode) | ||
| 10546 | (mh-get-msg-num nil) | ||
| 10547 | ;; Refer to the show buffer | ||
| 10548 | (mh-show-buffer-message-number)))) | ||
| 10549 | |||
| 10550 | (defun org-mhe-get-header (header) | ||
| 10551 | "Return a header of the message in folder mode. This will create a | ||
| 10552 | show buffer for the corresponding message. If you have a more clever | ||
| 10553 | idea..." | ||
| 10554 | (let* ((folder (org-mhe-get-message-folder)) | ||
| 10555 | (num (org-mhe-get-message-num)) | ||
| 10556 | (buffer (get-buffer-create (concat "show-" folder))) | ||
| 10557 | (header-field)) | ||
| 10558 | (with-current-buffer buffer | ||
| 10559 | (mh-display-msg num folder) | ||
| 10560 | (if (equal major-mode 'mh-folder-mode) | ||
| 10561 | (mh-header-display) | ||
| 10562 | (mh-show-header-display)) | ||
| 10563 | (set-buffer buffer) | ||
| 10564 | (setq header-field (mh-get-header-field header)) | ||
| 10565 | (if (equal major-mode 'mh-folder-mode) | ||
| 10566 | (mh-show) | ||
| 10567 | (mh-show-show)) | ||
| 10568 | header-field))) | ||
| 10569 | |||
| 10570 | (defun org-follow-mhe-link (folder article) | ||
| 10571 | "Follow an MHE link to FOLDER and ARTICLE. | ||
| 10572 | If ARTICLE is nil FOLDER is shown. If the configuration variable | ||
| 10573 | `org-mhe-search-all-folders' is t and `mh-searcher' is pick, | ||
| 10574 | ARTICLE is searched in all folders. Indexed searches (swish++, | ||
| 10575 | namazu, and others supported by MH-E) will always search in all | ||
| 10576 | folders." | ||
| 10577 | (require 'mh-e) | ||
| 10578 | (require 'mh-search) | ||
| 10579 | (require 'mh-utils) | ||
| 10580 | (mh-find-path) | ||
| 10581 | (if (not article) | ||
| 10582 | (mh-visit-folder (mh-normalize-folder-name folder)) | ||
| 10583 | (setq article (org-add-angle-brackets article)) | ||
| 10584 | (mh-search-choose) | ||
| 10585 | (if (equal mh-searcher 'pick) | ||
| 10586 | (progn | ||
| 10587 | (mh-search folder (list "--message-id" article)) | ||
| 10588 | (when (and org-mhe-search-all-folders | ||
| 10589 | (not (org-mhe-get-message-real-folder))) | ||
| 10590 | (kill-this-buffer) | ||
| 10591 | (mh-search "+" (list "--message-id" article)))) | ||
| 10592 | (mh-search "+" article)) | ||
| 10593 | (if (org-mhe-get-message-real-folder) | ||
| 10594 | (mh-show-msg 1) | ||
| 10595 | (kill-this-buffer) | ||
| 10596 | (error "Message not found")))) | ||
| 10597 | |||
| 10598 | ;; BibTeX links | ||
| 10599 | |||
| 10600 | ;; Use the custom search meachnism to construct and use search strings for | ||
| 10601 | ;; file links to BibTeX database entries. | ||
| 10602 | |||
| 10603 | (defun org-create-file-search-in-bibtex () | ||
| 10604 | "Create the search string and description for a BibTeX database entry." | ||
| 10605 | (when (eq major-mode 'bibtex-mode) | ||
| 10606 | ;; yes, we want to construct this search string. | ||
| 10607 | ;; Make a good description for this entry, using names, year and the title | ||
| 10608 | ;; Put it into the `description' variable which is dynamically scoped. | ||
| 10609 | (let ((bibtex-autokey-names 1) | ||
| 10610 | (bibtex-autokey-names-stretch 1) | ||
| 10611 | (bibtex-autokey-name-case-convert-function 'identity) | ||
| 10612 | (bibtex-autokey-name-separator " & ") | ||
| 10613 | (bibtex-autokey-additional-names " et al.") | ||
| 10614 | (bibtex-autokey-year-length 4) | ||
| 10615 | (bibtex-autokey-name-year-separator " ") | ||
| 10616 | (bibtex-autokey-titlewords 3) | ||
| 10617 | (bibtex-autokey-titleword-separator " ") | ||
| 10618 | (bibtex-autokey-titleword-case-convert-function 'identity) | ||
| 10619 | (bibtex-autokey-titleword-length 'infty) | ||
| 10620 | (bibtex-autokey-year-title-separator ": ")) | ||
| 10621 | (setq description (bibtex-generate-autokey))) | ||
| 10622 | ;; Now parse the entry, get the key and return it. | ||
| 10623 | (save-excursion | ||
| 10624 | (bibtex-beginning-of-entry) | ||
| 10625 | (cdr (assoc "=key=" (bibtex-parse-entry)))))) | ||
| 10626 | |||
| 10627 | (defun org-execute-file-search-in-bibtex (s) | ||
| 10628 | "Find the link search string S as a key for a database entry." | ||
| 10629 | (when (eq major-mode 'bibtex-mode) | ||
| 10630 | ;; Yes, we want to do the search in this file. | ||
| 10631 | ;; We construct a regexp that searches for "@entrytype{" followed by the key | ||
| 10632 | (goto-char (point-min)) | ||
| 10633 | (and (re-search-forward (concat "@[a-zA-Z]+[ \t\n]*{[ \t\n]*" | ||
| 10634 | (regexp-quote s) "[ \t\n]*,") nil t) | ||
| 10635 | (goto-char (match-beginning 0))) | ||
| 10636 | (if (and (match-beginning 0) (equal current-prefix-arg '(16))) | ||
| 10637 | ;; Use double prefix to indicate that any web link should be browsed | ||
| 10638 | (let ((b (current-buffer)) (p (point))) | ||
| 10639 | ;; Restore the window configuration because we just use the web link | ||
| 10640 | (set-window-configuration org-window-config-before-follow-link) | ||
| 10641 | (save-excursion (set-buffer b) (goto-char p) | ||
| 10642 | (bibtex-url))) | ||
| 10643 | (recenter 0)) ; Move entry start to beginning of window | ||
| 10644 | ;; return t to indicate that the search is done. | ||
| 10645 | t)) | ||
| 10646 | |||
| 10647 | ;; Finally add the functions to the right hooks. | ||
| 10648 | (add-hook 'org-create-file-search-functions 'org-create-file-search-in-bibtex) | ||
| 10649 | (add-hook 'org-execute-file-search-functions 'org-execute-file-search-in-bibtex) | ||
| 10650 | |||
| 10651 | ;; end of Bibtex link setup | ||
| 10652 | |||
| 10653 | (defun org-upgrade-old-links (&optional query-description) | ||
| 10654 | "Transfer old <...> style links to new [[...]] style links. | ||
| 10655 | With arg query-description, ask at each match for a description text to use | ||
| 10656 | for this link." | ||
| 10657 | (interactive (list (y-or-n-p "Would you like to be queried for a description at each link?"))) | ||
| 10658 | (save-excursion | ||
| 10659 | (goto-char (point-min)) | ||
| 10660 | (let ((re (concat "\\([^[]\\)<\\(" | ||
| 10661 | "\\(" (mapconcat 'identity org-link-types "\\|") | ||
| 10662 | "\\):" | ||
| 10663 | "[^" org-non-link-chars "]+\\)>")) | ||
| 10664 | l1 l2 (cnt 0)) | ||
| 10665 | (while (re-search-forward re nil t) | ||
| 10666 | (setq cnt (1+ cnt) | ||
| 10667 | l1 (org-match-string-no-properties 2) | ||
| 10668 | l2 (save-match-data (org-link-escape l1))) | ||
| 10669 | (when query-description (setq l1 (read-string "Desc: " l1))) | ||
| 10670 | (if (equal l1 l2) | ||
| 10671 | (replace-match (concat (match-string 1) "[[" l1 "]]") t t) | ||
| 10672 | (replace-match (concat (match-string 1) "[[" l2 "][" l1 "]]") t t))) | ||
| 10673 | (message "%d matches have beed treated" cnt)))) | ||
| 10674 | |||
| 10675 | (defun org-open-file (path &optional in-emacs line search) | ||
| 10676 | "Open the file at PATH. | ||
| 10677 | First, this expands any special file name abbreviations. Then the | ||
| 10678 | configuration variable `org-file-apps' is checked if it contains an | ||
| 10679 | entry for this file type, and if yes, the corresponding command is launched. | ||
| 10680 | If no application is found, Emacs simply visits the file. | ||
| 10681 | With optional argument IN-EMACS, Emacs will visit the file. | ||
| 10682 | Optional LINE specifies a line to go to, optional SEARCH a string to | ||
| 10683 | search for. If LINE or SEARCH is given, the file will always be | ||
| 10684 | opened in Emacs. | ||
| 10685 | If the file does not exist, an error is thrown." | ||
| 10686 | (setq in-emacs (or in-emacs line search)) | ||
| 10687 | (let* ((file (if (equal path "") | ||
| 10688 | buffer-file-name | ||
| 10689 | (substitute-in-file-name (expand-file-name path)))) | ||
| 10690 | (apps (append org-file-apps (org-default-apps))) | ||
| 10691 | (remp (and (assq 'remote apps) (org-file-remote-p file))) | ||
| 10692 | (dirp (if remp nil (file-directory-p file))) | ||
| 10693 | (dfile (downcase file)) | ||
| 10694 | (old-buffer (current-buffer)) | ||
| 10695 | (old-pos (point)) | ||
| 10696 | (old-mode major-mode) | ||
| 10697 | ext cmd) | ||
| 10698 | (if (string-match "^.*\\.\\([a-zA-Z0-9]+\\.gz\\)$" dfile) | ||
| 10699 | (setq ext (match-string 1 dfile)) | ||
| 10700 | (if (string-match "^.*\\.\\([a-zA-Z0-9]+\\)$" dfile) | ||
| 10701 | (setq ext (match-string 1 dfile)))) | ||
| 10702 | (if in-emacs | ||
| 10703 | (setq cmd 'emacs) | ||
| 10704 | (setq cmd (or (and remp (cdr (assoc 'remote apps))) | ||
| 10705 | (and dirp (cdr (assoc 'directory apps))) | ||
| 10706 | (cdr (assoc ext apps)) | ||
| 10707 | (cdr (assoc t apps))))) | ||
| 10708 | (when (eq cmd 'mailcap) | ||
| 10709 | (require 'mailcap) | ||
| 10710 | (mailcap-parse-mailcaps) | ||
| 10711 | (let* ((mime-type (mailcap-extension-to-mime (or ext ""))) | ||
| 10712 | (command (mailcap-mime-info mime-type))) | ||
| 10713 | (if (stringp command) | ||
| 10714 | (setq cmd command) | ||
| 10715 | (setq cmd 'emacs)))) | ||
| 10716 | (if (and (not (eq cmd 'emacs)) ; Emacs has not problems with non-ex files | ||
| 10717 | (not (file-exists-p file)) | ||
| 10718 | (not org-open-non-existing-files)) | ||
| 10719 | (error "No such file: %s" file)) | ||
| 10720 | (cond | ||
| 10721 | ((and (stringp cmd) (not (string-match "^\\s-*$" cmd))) | ||
| 10722 | ;; Remove quotes around the file name - we'll use shell-quote-argument. | ||
| 10723 | (if (string-match "['\"]%s['\"]" cmd) | ||
| 10724 | (setq cmd (replace-match "%s" t t cmd))) | ||
| 10725 | (setq cmd (format cmd (shell-quote-argument file))) | ||
| 10726 | (save-window-excursion | ||
| 10727 | (shell-command (concat cmd " &")))) | ||
| 10728 | ((or (stringp cmd) | ||
| 10729 | (eq cmd 'emacs)) | ||
| 10730 | ; (unless (equal (file-truename file) (file-truename (or buffer-file-name ""))) | ||
| 10731 | ; (funcall (cdr (assq 'file org-link-frame-setup)) file)) | ||
| 10732 | (funcall (cdr (assq 'file org-link-frame-setup)) file) | ||
| 10733 | (if line (goto-line line) | ||
| 10734 | (if search (org-link-search search)))) | ||
| 10735 | ((consp cmd) | ||
| 10736 | (eval cmd)) | ||
| 10737 | (t (funcall (cdr (assq 'file org-link-frame-setup)) file))) | ||
| 10738 | (and (org-mode-p) (eq old-mode 'org-mode) | ||
| 10739 | (or (not (equal old-buffer (current-buffer))) | ||
| 10740 | (not (equal old-pos (point)))) | ||
| 10741 | (org-mark-ring-push old-pos old-buffer)))) | ||
| 10742 | |||
| 10743 | (defun org-default-apps () | ||
| 10744 | "Return the default applications for this operating system." | ||
| 10745 | (cond | ||
| 10746 | ((eq system-type 'darwin) | ||
| 10747 | org-file-apps-defaults-macosx) | ||
| 10748 | ((eq system-type 'windows-nt) | ||
| 10749 | org-file-apps-defaults-windowsnt) | ||
| 10750 | (t org-file-apps-defaults-gnu))) | ||
| 10751 | |||
| 10752 | (defun org-expand-file-name (path) | ||
| 10753 | "Replace special path abbreviations and expand the file name." | ||
| 10754 | (expand-file-name path)) | ||
| 10755 | |||
| 10756 | (defvar ange-ftp-name-format) ; to silence the XEmacs compiler. | ||
| 10757 | (defun org-file-remote-p (file) | ||
| 10758 | "Test whether FILE specifies a location on a remote system. | ||
| 10759 | Return non-nil if the location is indeed remote. | ||
| 10760 | |||
| 10761 | For example, the filename \"/user@host:/foo\" specifies a location | ||
| 10762 | on the system \"/user@host:\"." | ||
| 10763 | (cond ((fboundp 'file-remote-p) | ||
| 10764 | (file-remote-p file)) | ||
| 10765 | ((fboundp 'tramp-handle-file-remote-p) | ||
| 10766 | (tramp-handle-file-remote-p file)) | ||
| 10767 | ((and (boundp 'ange-ftp-name-format) | ||
| 10768 | (string-match (car ange-ftp-name-format) file)) | ||
| 10769 | t) | ||
| 10770 | (t nil))) | ||
| 10771 | |||
| 10772 | (defvar org-insert-link-history nil | ||
| 10773 | "Minibuffer history for links inserted with `org-insert-link'.") | ||
| 10774 | |||
| 10775 | (defvar org-stored-links nil | ||
| 10776 | "Contains the links stored with `org-store-link'.") | ||
| 10777 | |||
| 10778 | ;;;###autoload | ||
| 10779 | (defun org-store-link (arg) | ||
| 10780 | "\\<org-mode-map>Store an org-link to the current location. | ||
| 10781 | This link can later be inserted into an org-buffer with | ||
| 10782 | \\[org-insert-link]. | ||
| 10783 | For some link types, a prefix arg is interpreted: | ||
| 10784 | For links to usenet articles, arg negates `org-usenet-links-prefer-google'. | ||
| 10785 | For file links, arg negates `org-context-in-file-links'." | ||
| 10786 | (interactive "P") | ||
| 10787 | (let (link cpltxt desc description search txt (pos (point))) | ||
| 10788 | (cond | ||
| 10789 | |||
| 10790 | ((eq major-mode 'bbdb-mode) | ||
| 10791 | (setq cpltxt (concat | ||
| 10792 | "bbdb:" | ||
| 10793 | (or (bbdb-record-name (bbdb-current-record)) | ||
| 10794 | (bbdb-record-company (bbdb-current-record)))) | ||
| 10795 | link (org-make-link cpltxt))) | ||
| 10796 | |||
| 10797 | ((eq major-mode 'Info-mode) | ||
| 10798 | (setq link (org-make-link "info:" | ||
| 10799 | (file-name-nondirectory Info-current-file) | ||
| 10800 | ":" Info-current-node)) | ||
| 10801 | (setq cpltxt (concat (file-name-nondirectory Info-current-file) | ||
| 10802 | ":" Info-current-node))) | ||
| 10803 | |||
| 10804 | ((eq major-mode 'calendar-mode) | ||
| 10805 | (let ((cd (calendar-cursor-to-date))) | ||
| 10806 | (setq link | ||
| 10807 | (format-time-string | ||
| 10808 | (car org-time-stamp-formats) | ||
| 10809 | (apply 'encode-time | ||
| 10810 | (list 0 0 0 (nth 1 cd) (nth 0 cd) (nth 2 cd) | ||
| 10811 | nil nil nil)))))) | ||
| 10812 | |||
| 10813 | ((or (eq major-mode 'vm-summary-mode) | ||
| 10814 | (eq major-mode 'vm-presentation-mode)) | ||
| 10815 | (and (eq major-mode 'vm-presentation-mode) (vm-summarize)) | ||
| 10816 | (vm-follow-summary-cursor) | ||
| 10817 | (save-excursion | ||
| 10818 | (vm-select-folder-buffer) | ||
| 10819 | (let* ((message (car vm-message-pointer)) | ||
| 10820 | (folder buffer-file-name) | ||
| 10821 | (subject (vm-su-subject message)) | ||
| 10822 | (author (vm-su-full-name message)) | ||
| 10823 | (message-id (vm-su-message-id message))) | ||
| 10824 | (setq message-id (org-remove-angle-brackets message-id)) | ||
| 10825 | (setq folder (abbreviate-file-name folder)) | ||
| 10826 | (if (string-match (concat "^" (regexp-quote vm-folder-directory)) | ||
| 10827 | folder) | ||
| 10828 | (setq folder (replace-match "" t t folder))) | ||
| 10829 | (setq cpltxt (concat author " on: " subject)) | ||
| 10830 | (setq link (org-make-link "vm:" folder "#" message-id))))) | ||
| 10831 | |||
| 10832 | ((eq major-mode 'wl-summary-mode) | ||
| 10833 | (let* ((msgnum (wl-summary-message-number)) | ||
| 10834 | (message-id (elmo-message-field wl-summary-buffer-elmo-folder | ||
| 10835 | msgnum 'message-id)) | ||
| 10836 | (wl-message-entity (elmo-msgdb-overview-get-entity | ||
| 10837 | msgnum (wl-summary-buffer-msgdb))) | ||
| 10838 | (author (wl-summary-line-from)) ; FIXME: correct? | ||
| 10839 | (subject "???")) ; FIXME: | ||
| 10840 | (setq message-id (org-remove-angle-brackets message-id)) | ||
| 10841 | (setq cpltxt (concat author " on: " subject)) | ||
| 10842 | (setq link (org-make-link "wl:" wl-summary-buffer-folder-name | ||
| 10843 | "#" message-id)))) | ||
| 10844 | |||
| 10845 | ((or (equal major-mode 'mh-folder-mode) | ||
| 10846 | (equal major-mode 'mh-show-mode)) | ||
| 10847 | (let ((from-header (org-mhe-get-header "From:")) | ||
| 10848 | (to-header (org-mhe-get-header "To:")) | ||
| 10849 | (subject (org-mhe-get-header "Subject:"))) | ||
| 10850 | (setq cpltxt (concat from-header " on: " subject)) | ||
| 10851 | (setq link (org-make-link "mhe:" (org-mhe-get-message-real-folder) "#" | ||
| 10852 | (org-remove-angle-brackets | ||
| 10853 | (org-mhe-get-header "Message-Id:")))))) | ||
| 10854 | |||
| 10855 | ((eq major-mode 'rmail-mode) | ||
| 10856 | (save-excursion | ||
| 10857 | (save-restriction | ||
| 10858 | (rmail-narrow-to-non-pruned-header) | ||
| 10859 | (let ((folder buffer-file-name) | ||
| 10860 | (message-id (mail-fetch-field "message-id")) | ||
| 10861 | (author (mail-fetch-field "from")) | ||
| 10862 | (subject (mail-fetch-field "subject"))) | ||
| 10863 | (setq message-id (org-remove-angle-brackets message-id)) | ||
| 10864 | (setq cpltxt (concat author " on: " subject)) | ||
| 10865 | (setq link (org-make-link "rmail:" folder "#" message-id)))))) | ||
| 10866 | |||
| 10867 | ((eq major-mode 'gnus-group-mode) | ||
| 10868 | (let ((group (cond ((fboundp 'gnus-group-group-name) ; depending on Gnus | ||
| 10869 | (gnus-group-group-name)) ; version | ||
| 10870 | ((fboundp 'gnus-group-name) | ||
| 10871 | (gnus-group-name)) | ||
| 10872 | (t "???")))) | ||
| 10873 | (setq cpltxt (concat | ||
| 10874 | (if (org-xor arg org-usenet-links-prefer-google) | ||
| 10875 | "http://groups.google.com/groups?group=" | ||
| 10876 | "gnus:") | ||
| 10877 | group) | ||
| 10878 | link (org-make-link cpltxt)))) | ||
| 10879 | |||
| 10880 | ((memq major-mode '(gnus-summary-mode gnus-article-mode)) | ||
| 10881 | (require 'gnus-sum) | ||
| 10882 | (and (eq major-mode 'gnus-article-mode) (gnus-article-show-summary)) | ||
| 10883 | (gnus-summary-beginning-of-article) | ||
| 10884 | (let* ((group (car gnus-article-current)) | ||
| 10885 | (article (cdr gnus-article-current)) | ||
| 10886 | (header (gnus-summary-article-header article)) | ||
| 10887 | (author (mail-header-from header)) | ||
| 10888 | (message-id (mail-header-id header)) | ||
| 10889 | (date (mail-header-date header)) | ||
| 10890 | (subject (gnus-summary-subject-string))) | ||
| 10891 | (setq cpltxt (concat author " on: " subject)) | ||
| 10892 | (if (org-xor arg org-usenet-links-prefer-google) | ||
| 10893 | (setq link | ||
| 10894 | (concat | ||
| 10895 | cpltxt "\n " | ||
| 10896 | (format "http://groups.google.com/groups?as_umsgid=%s" | ||
| 10897 | (org-fixup-message-id-for-http message-id)))) | ||
| 10898 | (setq link (org-make-link "gnus:" group | ||
| 10899 | "#" (number-to-string article)))))) | ||
| 10900 | |||
| 10901 | ((eq major-mode 'w3-mode) | ||
| 10902 | (setq cpltxt (url-view-url t) | ||
| 10903 | link (org-make-link cpltxt))) | ||
| 10904 | ((eq major-mode 'w3m-mode) | ||
| 10905 | (setq cpltxt (or w3m-current-title w3m-current-url) | ||
| 10906 | link (org-make-link w3m-current-url))) | ||
| 10907 | |||
| 10908 | ((setq search (run-hook-with-args-until-success | ||
| 10909 | 'org-create-file-search-functions)) | ||
| 10910 | (setq link (concat "file:" (abbreviate-file-name buffer-file-name) | ||
| 10911 | "::" search)) | ||
| 10912 | (setq cpltxt (or description link))) | ||
| 10913 | |||
| 10914 | ((eq major-mode 'image-mode) | ||
| 10915 | (setq cpltxt (concat "file:" | ||
| 10916 | (abbreviate-file-name buffer-file-name)) | ||
| 10917 | link (org-make-link cpltxt))) | ||
| 10918 | |||
| 10919 | ((eq major-mode 'dired-mode) | ||
| 10920 | ;; link to the file in the current line | ||
| 10921 | (setq cpltxt (concat "file:" | ||
| 10922 | (abbreviate-file-name | ||
| 10923 | (expand-file-name | ||
| 10924 | (dired-get-filename nil t)))) | ||
| 10925 | link (org-make-link cpltxt))) | ||
| 10926 | |||
| 10927 | ((and buffer-file-name (org-mode-p)) | ||
| 10928 | ;; Just link to current headline | ||
| 10929 | (setq cpltxt (concat "file:" | ||
| 10930 | (abbreviate-file-name buffer-file-name))) | ||
| 10931 | ;; Add a context search string | ||
| 10932 | (when (org-xor org-context-in-file-links arg) | ||
| 10933 | ;; Check if we are on a target | ||
| 10934 | (if (save-excursion | ||
| 10935 | (skip-chars-forward "^>\n\r") | ||
| 10936 | (and (re-search-backward "<<" nil t) | ||
| 10937 | (looking-at "<<\\(.*?\\)>>") | ||
| 10938 | (<= (match-beginning 0) pos) | ||
| 10939 | (>= (match-end 0) pos))) | ||
| 10940 | (setq cpltxt (concat cpltxt "::" (match-string 1))) | ||
| 10941 | (setq txt (cond | ||
| 10942 | ((org-on-heading-p) nil) | ||
| 10943 | ((org-region-active-p) | ||
| 10944 | (buffer-substring (region-beginning) (region-end))) | ||
| 10945 | (t (buffer-substring (point-at-bol) (point-at-eol))))) | ||
| 10946 | (when (or (null txt) (string-match "\\S-" txt)) | ||
| 10947 | (setq cpltxt | ||
| 10948 | (concat cpltxt "::" | ||
| 10949 | (if org-file-link-context-use-camel-case | ||
| 10950 | (org-make-org-heading-camel txt) | ||
| 10951 | (org-make-org-heading-search-string txt))) | ||
| 10952 | desc "NONE")))) | ||
| 10953 | (if (string-match "::\\'" cpltxt) | ||
| 10954 | (setq cpltxt (substring cpltxt 0 -2))) | ||
| 10955 | (setq link (org-make-link cpltxt))) | ||
| 10956 | |||
| 10957 | (buffer-file-name | ||
| 10958 | ;; Just link to this file here. | ||
| 10959 | (setq cpltxt (concat "file:" | ||
| 10960 | (abbreviate-file-name buffer-file-name))) | ||
| 10961 | ;; Add a context string | ||
| 10962 | (when (org-xor org-context-in-file-links arg) | ||
| 10963 | (setq txt (if (org-region-active-p) | ||
| 10964 | (buffer-substring (region-beginning) (region-end)) | ||
| 10965 | (buffer-substring (point-at-bol) (point-at-eol)))) | ||
| 10966 | ;; Only use search option if there is some text. | ||
| 10967 | (when (string-match "\\S-" txt) | ||
| 10968 | (setq cpltxt | ||
| 10969 | (concat cpltxt "::" | ||
| 10970 | (if org-file-link-context-use-camel-case | ||
| 10971 | (org-make-org-heading-camel txt) | ||
| 10972 | (org-make-org-heading-search-string txt))) | ||
| 10973 | desc "NONE"))) | ||
| 10974 | (setq link (org-make-link cpltxt))) | ||
| 10975 | |||
| 10976 | ((interactive-p) | ||
| 10977 | (error "Cannot link to a buffer which is not visiting a file")) | ||
| 10978 | |||
| 10979 | (t (setq link nil))) | ||
| 10980 | |||
| 10981 | (if (consp link) (setq cpltxt (car link) link (cdr link))) | ||
| 10982 | (setq link (or link cpltxt) | ||
| 10983 | desc (or desc cpltxt)) | ||
| 10984 | (if (equal desc "NONE") (setq desc nil)) | ||
| 10985 | |||
| 10986 | (if (and (interactive-p) link) | ||
| 10987 | (progn | ||
| 10988 | (setq org-stored-links | ||
| 10989 | (cons (list cpltxt link desc) org-stored-links)) | ||
| 10990 | (message "Stored: %s" (or cpltxt link))) | ||
| 10991 | (org-make-link-string link desc)))) | ||
| 10992 | |||
| 10993 | (defun org-make-org-heading-search-string (&optional string heading) | ||
| 10994 | "Make search string for STRING or current headline." | ||
| 10995 | (interactive) | ||
| 10996 | (let ((s (or string (org-get-heading)))) | ||
| 10997 | (unless (and string (not heading)) | ||
| 10998 | ;; We are using a headline, clean up garbage in there. | ||
| 10999 | (if (string-match org-todo-regexp s) | ||
| 11000 | (setq s (replace-match "" t t s))) | ||
| 11001 | (if (string-match ":[a-zA-Z_@0-9:]+:[ \t]*$" s) | ||
| 11002 | (setq s (replace-match "" t t s))) | ||
| 11003 | (setq s (org-trim s)) | ||
| 11004 | (if (string-match (concat "^\\(" org-quote-string "\\|" | ||
| 11005 | org-comment-string "\\)") s) | ||
| 11006 | (setq s (replace-match "" t t s))) | ||
| 11007 | (while (string-match org-ts-regexp s) | ||
| 11008 | (setq s (replace-match "" t t s)))) | ||
| 11009 | (while (string-match "[^a-zA-Z_0-9 \t]+" s) | ||
| 11010 | (setq s (replace-match " " t t s))) | ||
| 11011 | (or string (setq s (concat "*" s))) ; Add * for headlines | ||
| 11012 | (mapconcat 'identity (org-split-string s "[ \t]+") " "))) | ||
| 11013 | |||
| 11014 | (defun org-make-org-heading-camel (&optional string heading) | ||
| 11015 | "Make a CamelCase string for STRING or the current headline." | ||
| 11016 | (interactive) | ||
| 11017 | (let ((s (or string (org-get-heading)))) | ||
| 11018 | (unless (and string (not heading)) | ||
| 11019 | ;; We are using a headline, clean up garbage in there. | ||
| 11020 | (if (string-match org-todo-regexp s) | ||
| 11021 | (setq s (replace-match "" t t s))) | ||
| 11022 | (if (string-match ":[a-zA-Z_@0-9:]+:[ \t]*$" s) | ||
| 11023 | (setq s (replace-match "" t t s))) | ||
| 11024 | (setq s (org-trim s)) | ||
| 11025 | (if (string-match (concat "^\\(" org-quote-string "\\|" | ||
| 11026 | org-comment-string "\\)") s) | ||
| 11027 | (setq s (replace-match "" t t s))) | ||
| 11028 | (while (string-match org-ts-regexp s) | ||
| 11029 | (setq s (replace-match "" t t s)))) | ||
| 11030 | (while (string-match "[^a-zA-Z_ \t]+" s) | ||
| 11031 | (setq s (replace-match " " t t s))) | ||
| 11032 | (or string (setq s (concat "*" s))) ; Add * for headlines | ||
| 11033 | (mapconcat 'capitalize (org-split-string s "[ \t]+") ""))) | ||
| 11034 | |||
| 11035 | (defun org-make-link (&rest strings) | ||
| 11036 | "Concatenate STRINGS, format resulting string with `org-link-format'." | ||
| 11037 | (format org-link-format (apply 'concat strings))) | ||
| 11038 | |||
| 11039 | (defun org-make-link-string (link &optional description) | ||
| 11040 | "Make a link with brackets, consisting of LINK and DESCRIPTION." | ||
| 11041 | (if (eq org-link-style 'plain) | ||
| 11042 | (if (equal description link) | ||
| 11043 | link | ||
| 11044 | (concat description "\n" link)) | ||
| 11045 | (when (stringp description) | ||
| 11046 | ;; Remove brackets from the description, they are fatal. | ||
| 11047 | (while (string-match "\\[\\|\\]" description) | ||
| 11048 | (setq description (replace-match "" t t description)))) | ||
| 11049 | (when (equal (org-link-escape link) description) | ||
| 11050 | ;; No description needed, it is identical | ||
| 11051 | (setq description nil)) | ||
| 11052 | (when (and (not description) | ||
| 11053 | (not (equal link (org-link-escape link)))) | ||
| 11054 | (setq description link)) | ||
| 11055 | (concat "[[" (org-link-escape link) "]" | ||
| 11056 | (if description (concat "[" description "]") "") | ||
| 11057 | "]"))) | ||
| 11058 | |||
| 11059 | (defconst org-link-escape-chars '(("[" . "%5B") ("]" . "%5D") (" " . "%20")) | ||
| 11060 | "Association list of escapes for some characters problematic in links.") | ||
| 11061 | |||
| 11062 | (defun org-link-escape (text) | ||
| 11063 | "Escape charaters in TEXT that are problematic for links." | ||
| 11064 | (when text | ||
| 11065 | (let ((re (mapconcat (lambda (x) (regexp-quote (car x))) | ||
| 11066 | org-link-escape-chars "\\|"))) | ||
| 11067 | (while (string-match re text) | ||
| 11068 | (setq text | ||
| 11069 | (replace-match | ||
| 11070 | (cdr (assoc (match-string 0 text) org-link-escape-chars)) | ||
| 11071 | t t text))) | ||
| 11072 | text))) | ||
| 11073 | |||
| 11074 | (defun org-link-unescape (text) | ||
| 11075 | "Reverse the action of `org-link-escape'." | ||
| 11076 | (when text | ||
| 11077 | (let ((re (mapconcat (lambda (x) (regexp-quote (cdr x))) | ||
| 11078 | org-link-escape-chars "\\|"))) | ||
| 11079 | (while (string-match re text) | ||
| 11080 | (setq text | ||
| 11081 | (replace-match | ||
| 11082 | (car (rassoc (match-string 0 text) org-link-escape-chars)) | ||
| 11083 | t t text))) | ||
| 11084 | text))) | ||
| 11085 | |||
| 11086 | (defun org-xor (a b) | ||
| 11087 | "Exclusive or." | ||
| 11088 | (if a (not b) b)) | ||
| 11089 | |||
| 11090 | (defun org-get-header (header) | ||
| 11091 | "Find a header field in the current buffer." | ||
| 11092 | (save-excursion | ||
| 11093 | (goto-char (point-min)) | ||
| 11094 | (let ((case-fold-search t) s) | ||
| 11095 | (cond | ||
| 11096 | ((eq header 'from) | ||
| 11097 | (if (re-search-forward "^From:\\s-+\\(.*\\)" nil t) | ||
| 11098 | (setq s (match-string 1))) | ||
| 11099 | (while (string-match "\"" s) | ||
| 11100 | (setq s (replace-match "" t t s))) | ||
| 11101 | (if (string-match "[<(].*" s) | ||
| 11102 | (setq s (replace-match "" t t s)))) | ||
| 11103 | ((eq header 'message-id) | ||
| 11104 | (if (re-search-forward "^message-id:\\s-+\\(.*\\)" nil t) | ||
| 11105 | (setq s (match-string 1)))) | ||
| 11106 | ((eq header 'subject) | ||
| 11107 | (if (re-search-forward "^subject:\\s-+\\(.*\\)" nil t) | ||
| 11108 | (setq s (match-string 1))))) | ||
| 11109 | (if (string-match "\\`[ \t\]+" s) (setq s (replace-match "" t t s))) | ||
| 11110 | (if (string-match "[ \t\]+\\'" s) (setq s (replace-match "" t t s))) | ||
| 11111 | s))) | ||
| 11112 | |||
| 11113 | |||
| 11114 | (defun org-fixup-message-id-for-http (s) | ||
| 11115 | "Replace special characters in a message id, so it can be used in an http query." | ||
| 11116 | (while (string-match "<" s) | ||
| 11117 | (setq s (replace-match "%3C" t t s))) | ||
| 11118 | (while (string-match ">" s) | ||
| 11119 | (setq s (replace-match "%3E" t t s))) | ||
| 11120 | (while (string-match "@" s) | ||
| 11121 | (setq s (replace-match "%40" t t s))) | ||
| 11122 | s) | ||
| 11123 | |||
| 11124 | (defun org-insert-link (&optional complete-file) | ||
| 11125 | "Insert a link. At the prompt, enter the link. | ||
| 11126 | |||
| 11127 | Completion can be used to select a link previously stored with | ||
| 11128 | `org-store-link'. When the empty string is entered (i.e. if you just | ||
| 11129 | press RET at the prompt), the link defaults to the most recently | ||
| 11130 | stored link. As SPC triggers completion in the minibuffer, you need to | ||
| 11131 | use M-SPC or C-q SPC to force the insertion of a space character. | ||
| 11132 | |||
| 11133 | You will also be prompted for a description, and if one is given, it will | ||
| 11134 | be displayed in the buffer instead of the link. | ||
| 11135 | |||
| 11136 | If there is already a link at point, this command will allow you to edit link | ||
| 11137 | and description parts. | ||
| 11138 | 16070 | ||
| 11139 | With a \\[universal-argument] prefix, prompts for a file to link to. The file name can be | ||
| 11140 | selected using completion. The path to the file will be relative to | ||
| 11141 | the current directory if the file is in the current directory or a | ||
| 11142 | subdirectory. Otherwise, the link will be the absolute path as | ||
| 11143 | completed in the minibuffer (i.e. normally ~/path/to/file). | ||
| 11144 | 16071 | ||
| 11145 | With two \\[universal-argument] prefixes, enforce an absolute path even if the file | 16072 | (defun org-try-cdlatex-tab () |
| 11146 | is in the current directory or below. | 16073 | "Check if it makes sense to execute `cdlatex-tab', and do it if yes. |
| 11147 | With three \\[universal-argument] prefixes, negate the meaning of | 16074 | It makes sense to do so if `org-cdlatex-mode' is active and if the cursor is |
| 11148 | `org-keep-stored-link-after-insertion'." | 16075 | - inside a LaTeX fragment, or |
| 11149 | (interactive "P") | 16076 | - after the first word in a line, where an abbreviation expansion could |
| 11150 | (let (link desc entry remove file (pos (point))) | 16077 | insert a LaTeX environment." |
| 16078 | (when org-cdlatex-mode | ||
| 11151 | (cond | 16079 | (cond |
| 11152 | ((save-excursion | 16080 | ((save-excursion |
| 11153 | (skip-chars-forward "^]\n\r") | 16081 | (skip-chars-backward "a-zA-Z0-9*") |
| 11154 | (and (re-search-backward "\\[\\[" nil t) | 16082 | (skip-chars-backward " \t") |
| 11155 | (looking-at org-bracket-link-regexp) | 16083 | (bolp)) |
| 11156 | (<= (match-beginning 0) pos) | 16084 | (cdlatex-tab) t) |
| 11157 | (>= (match-end 0) pos))) | 16085 | ((org-inside-LaTeX-fragment-p) |
| 11158 | ;; We do have a link at point, and we are going to edit it. | 16086 | (cdlatex-tab) t) |
| 11159 | (setq remove (list (match-beginning 0) (match-end 0))) | 16087 | (t nil)))) |
| 11160 | (setq desc (if (match-end 3) (org-match-string-no-properties 3))) | ||
| 11161 | (setq link (read-string "Link: " | ||
| 11162 | (org-link-unescape | ||
| 11163 | (org-match-string-no-properties 1))))) | ||
| 11164 | ((equal complete-file '(4)) | ||
| 11165 | ;; Completing read for file names. | ||
| 11166 | (setq file (read-file-name "File: ")) | ||
| 11167 | (let ((pwd (file-name-as-directory (expand-file-name "."))) | ||
| 11168 | (pwd1 (file-name-as-directory (abbreviate-file-name | ||
| 11169 | (expand-file-name "."))))) | ||
| 11170 | (cond | ||
| 11171 | ((equal complete-file '(16)) | ||
| 11172 | (setq link (org-make-link | ||
| 11173 | "file:" | ||
| 11174 | (abbreviate-file-name (expand-file-name file))))) | ||
| 11175 | ((string-match (concat "^" (regexp-quote pwd1) "\\(.+\\)") file) | ||
| 11176 | (setq link (org-make-link "file:" (match-string 1 file)))) | ||
| 11177 | ((string-match (concat "^" (regexp-quote pwd) "\\(.+\\)") | ||
| 11178 | (expand-file-name file)) | ||
| 11179 | (setq link (org-make-link | ||
| 11180 | "file:" (match-string 1 (expand-file-name file))))) | ||
| 11181 | (t (setq link (org-make-link "file:" file)))))) | ||
| 11182 | (t | ||
| 11183 | ;; Read link, with completion for stored links. | ||
| 11184 | (setq link (org-completing-read | ||
| 11185 | "Link: " org-stored-links nil nil nil | ||
| 11186 | org-insert-link-history | ||
| 11187 | (or (car (car org-stored-links))))) | ||
| 11188 | (setq entry (assoc link org-stored-links)) | ||
| 11189 | (if (funcall (if (equal complete-file '(64)) 'not 'identity) | ||
| 11190 | (not org-keep-stored-link-after-insertion)) | ||
| 11191 | (setq org-stored-links (delq (assoc link org-stored-links) | ||
| 11192 | org-stored-links))) | ||
| 11193 | (setq link (if entry (nth 1 entry) link) | ||
| 11194 | desc (or desc (nth 2 entry))))) | ||
| 11195 | |||
| 11196 | (if (string-match org-plain-link-re link) | ||
| 11197 | ;; URL-like link, normalize the use of angular brackets. | ||
| 11198 | (setq link (org-make-link (org-remove-angle-brackets link)))) | ||
| 11199 | |||
| 11200 | ;; Check if we are linking to the current file with a search option | ||
| 11201 | ;; If yes, simplify the link by using only the search option. | ||
| 11202 | (when (and buffer-file-name | ||
| 11203 | (string-match "\\<file:\\(.+?\\)::\\([^>]+\\)" link)) | ||
| 11204 | (let* ((path (match-string 1 link)) | ||
| 11205 | (case-fold-search nil) | ||
| 11206 | (search (match-string 2 link))) | ||
| 11207 | (save-match-data | ||
| 11208 | (if (equal (file-truename buffer-file-name) (file-truename path)) | ||
| 11209 | ;; We are linking to this same file, with a search option | ||
| 11210 | (setq link search))))) | ||
| 11211 | |||
| 11212 | ;; Check if we can/should use a relative path. If yes, simplify the link | ||
| 11213 | (when (string-match "\\<file:\\(.*\\)" link) | ||
| 11214 | (let* ((path (match-string 1 link)) | ||
| 11215 | (case-fold-search nil)) | ||
| 11216 | (cond | ||
| 11217 | ((eq org-link-file-path-type 'absolute) | ||
| 11218 | (setq path (abbreviate-file-name (expand-file-name path)))) | ||
| 11219 | ((eq org-link-file-path-type 'noabbrev) | ||
| 11220 | (setq path (expand-file-name path))) | ||
| 11221 | ((eq org-link-file-path-type 'relative) | ||
| 11222 | (setq path (file-relative-name path))) | ||
| 11223 | (t | ||
| 11224 | (save-match-data | ||
| 11225 | (if (string-match (concat "^" (regexp-quote | ||
| 11226 | (file-name-as-directory | ||
| 11227 | (expand-file-name ".")))) | ||
| 11228 | (expand-file-name path)) | ||
| 11229 | ;; We are linking a file with relative path name. | ||
| 11230 | (setq path (substring (expand-file-name path) | ||
| 11231 | (match-end 0))))))) | ||
| 11232 | (setq link (concat "file:" path)))) | ||
| 11233 | |||
| 11234 | (setq desc (read-string "Description: " desc)) | ||
| 11235 | (unless (string-match "\\S-" desc) (setq desc nil)) | ||
| 11236 | (if remove (apply 'delete-region remove)) | ||
| 11237 | (insert (org-make-link-string link desc)))) | ||
| 11238 | |||
| 11239 | (defun org-completing-read (&rest args) | ||
| 11240 | (let ((minibuffer-local-completion-map | ||
| 11241 | (copy-keymap minibuffer-local-completion-map))) | ||
| 11242 | (define-key minibuffer-local-completion-map " " 'self-insert-command) | ||
| 11243 | (apply 'completing-read args))) | ||
| 11244 | |||
| 11245 | ;;; Hooks for remember.el | ||
| 11246 | |||
| 11247 | (defvar org-finish-function nil) | ||
| 11248 | |||
| 11249 | ;;;###autoload | ||
| 11250 | (defun org-remember-annotation () | ||
| 11251 | "Return a link to the current location as an annotation for remember.el. | ||
| 11252 | If you are using Org-mode files as target for data storage with | ||
| 11253 | remember.el, then the annotations should include a link compatible with the | ||
| 11254 | conventions in Org-mode. This function returns such a link." | ||
| 11255 | (org-store-link nil)) | ||
| 11256 | |||
| 11257 | (defconst org-remember-help | ||
| 11258 | "Select a destination location for the note. | ||
| 11259 | UP/DOWN=headline TAB=cycle visibility [Q]uit RET/<left>/<right>=Store | ||
| 11260 | RET at beg-of-buf -> Append to file as level 2 headline | ||
| 11261 | RET on headline -> Store as sublevel entry to current headline | ||
| 11262 | <left>/<right> -> before/after current headline, same headings level") | ||
| 11263 | |||
| 11264 | ;;;###autoload | ||
| 11265 | (defun org-remember-apply-template () | ||
| 11266 | "Initialize *remember* buffer with template, invoke `org-mode'. | ||
| 11267 | This function should be placed into `remember-mode-hook' and in fact requires | ||
| 11268 | to be run from that hook to fucntion properly." | ||
| 11269 | (if org-remember-templates | ||
| 11270 | |||
| 11271 | (let* ((entry (if (= (length org-remember-templates) 1) | ||
| 11272 | (cdar org-remember-templates) | ||
| 11273 | (message "Select template: %s" | ||
| 11274 | (mapconcat | ||
| 11275 | (lambda (x) (char-to-string (car x))) | ||
| 11276 | org-remember-templates " ")) | ||
| 11277 | (cdr (assoc (read-char-exclusive) org-remember-templates)))) | ||
| 11278 | (tpl (car entry)) | ||
| 11279 | (file (if (consp (cdr entry)) (nth 1 entry))) | ||
| 11280 | (v-t (format-time-string (car org-time-stamp-formats) (org-current-time))) | ||
| 11281 | (v-T (format-time-string (cdr org-time-stamp-formats) (org-current-time))) | ||
| 11282 | (v-u (concat "[" (substring v-t 1 -1) "]")) | ||
| 11283 | (v-U (concat "[" (substring v-T 1 -1) "]")) | ||
| 11284 | (v-a annotation) ; defined in `remember-mode' | ||
| 11285 | (v-i initial) ; defined in `remember-mode' | ||
| 11286 | (v-n user-full-name) | ||
| 11287 | ) | ||
| 11288 | (unless tpl (setq tpl "") (message "No template") (ding)) | ||
| 11289 | (insert tpl) (goto-char (point-min)) | ||
| 11290 | (while (re-search-forward "%\\([tTuTai]\\)" nil t) | ||
| 11291 | (when (and initial (equal (match-string 0) "%i")) | ||
| 11292 | (save-match-data | ||
| 11293 | (let* ((lead (buffer-substring | ||
| 11294 | (point-at-bol) (match-beginning 0)))) | ||
| 11295 | (setq v-i (mapconcat 'identity | ||
| 11296 | (org-split-string initial "\n") | ||
| 11297 | (concat "\n" lead)))))) | ||
| 11298 | (replace-match | ||
| 11299 | (or (eval (intern (concat "v-" (match-string 1)))) "") | ||
| 11300 | t t)) | ||
| 11301 | (let ((org-startup-folded nil) | ||
| 11302 | (org-startup-with-deadline-check nil)) | ||
| 11303 | (org-mode)) | ||
| 11304 | (if (and file (string-match "\\S-" file) (not (file-directory-p file))) | ||
| 11305 | (org-set-local 'org-default-notes-file file)) | ||
| 11306 | (goto-char (point-min)) | ||
| 11307 | (if (re-search-forward "%\\?" nil t) (replace-match ""))) | ||
| 11308 | (let ((org-startup-folded nil) | ||
| 11309 | (org-startup-with-deadline-check nil)) | ||
| 11310 | (org-mode))) | ||
| 11311 | (org-set-local 'org-finish-function 'remember-buffer)) | ||
| 11312 | |||
| 11313 | ;;;###autoload | ||
| 11314 | (defun org-remember-handler () | ||
| 11315 | "Store stuff from remember.el into an org file. | ||
| 11316 | First prompts for an org file. If the user just presses return, the value | ||
| 11317 | of `org-default-notes-file' is used. | ||
| 11318 | Then the command offers the headings tree of the selected file in order to | ||
| 11319 | file the text at a specific location. | ||
| 11320 | You can either immediately press RET to get the note appended to the | ||
| 11321 | file, or you can use vertical cursor motion and visibility cycling (TAB) to | ||
| 11322 | find a better place. Then press RET or <left> or <right> in insert the note. | ||
| 11323 | |||
| 11324 | Key Cursor position Note gets inserted | ||
| 11325 | ----------------------------------------------------------------------------- | ||
| 11326 | RET buffer-start as level 2 heading at end of file | ||
| 11327 | RET on headline as sublevel of the heading at cursor | ||
| 11328 | RET no heading at cursor position, level taken from context. | ||
| 11329 | Or use prefix arg to specify level manually. | ||
| 11330 | <left> on headline as same level, before current heading | ||
| 11331 | <right> on headline as same level, after current heading | ||
| 11332 | |||
| 11333 | So the fastest way to store the note is to press RET RET to append it to | ||
| 11334 | the default file. This way your current train of thought is not | ||
| 11335 | interrupted, in accordance with the principles of remember.el. But with | ||
| 11336 | little extra effort, you can push it directly to the correct location. | ||
| 11337 | |||
| 11338 | Before being stored away, the function ensures that the text has a | ||
| 11339 | headline, i.e. a first line that starts with a \"*\". If not, a headline | ||
| 11340 | is constructed from the current date and some additional data. | ||
| 11341 | |||
| 11342 | If the variable `org-adapt-indentation' is non-nil, the entire text is | ||
| 11343 | also indented so that it starts in the same column as the headline | ||
| 11344 | \(i.e. after the stars). | ||
| 11345 | |||
| 11346 | See also the variable `org-reverse-note-order'." | ||
| 11347 | (catch 'quit | ||
| 11348 | (let* ((txt (buffer-substring (point-min) (point-max))) | ||
| 11349 | (fastp current-prefix-arg) | ||
| 11350 | (file (if fastp org-default-notes-file (org-get-org-file))) | ||
| 11351 | (visiting (find-buffer-visiting file)) | ||
| 11352 | (org-startup-with-deadline-check nil) | ||
| 11353 | (org-startup-folded nil) | ||
| 11354 | (org-startup-align-all-tables nil) | ||
| 11355 | spos level indent reversed) | ||
| 11356 | ;; Modify text so that it becomes a nice subtree which can be inserted | ||
| 11357 | ;; into an org tree. | ||
| 11358 | (let* ((lines (split-string txt "\n")) | ||
| 11359 | first) | ||
| 11360 | ;; remove empty lines at the beginning | ||
| 11361 | (while (and lines (string-match "^[ \t]*\n" (car lines))) | ||
| 11362 | (setq lines (cdr lines))) | ||
| 11363 | (setq first (car lines) lines (cdr lines)) | ||
| 11364 | (if (string-match "^\\*+" first) | ||
| 11365 | ;; Is already a headline | ||
| 11366 | (setq indent nil) | ||
| 11367 | ;; We need to add a headline: Use time and first buffer line | ||
| 11368 | (setq lines (cons first lines) | ||
| 11369 | first (concat "* " (current-time-string) | ||
| 11370 | " (" (remember-buffer-desc) ")") | ||
| 11371 | indent " ")) | ||
| 11372 | (if (and org-adapt-indentation indent) | ||
| 11373 | (setq lines (mapcar (lambda (x) (concat indent x)) lines))) | ||
| 11374 | (setq txt (concat first "\n" | ||
| 11375 | (mapconcat 'identity lines "\n")))) | ||
| 11376 | ;; Find the file | ||
| 11377 | (if (not visiting) | ||
| 11378 | (find-file-noselect file)) | ||
| 11379 | (with-current-buffer (get-file-buffer file) | ||
| 11380 | (save-excursion (and (goto-char (point-min)) | ||
| 11381 | (not (re-search-forward "^\\* " nil t)) | ||
| 11382 | (insert "\n* Notes\n"))) | ||
| 11383 | (setq reversed (org-notes-order-reversed-p)) | ||
| 11384 | (save-excursion | ||
| 11385 | (save-restriction | ||
| 11386 | (widen) | ||
| 11387 | ;; Ask the User for a location | ||
| 11388 | (setq spos (if fastp 1 (org-get-location | ||
| 11389 | (current-buffer) | ||
| 11390 | org-remember-help))) | ||
| 11391 | (if (not spos) (throw 'quit nil)) ; return nil to show we did | ||
| 11392 | ; not handle this note | ||
| 11393 | (goto-char spos) | ||
| 11394 | (cond ((bobp) | ||
| 11395 | ;; Put it at the start or end, as level 2 | ||
| 11396 | (save-restriction | ||
| 11397 | (widen) | ||
| 11398 | (goto-char (if reversed (point-min) (point-max))) | ||
| 11399 | (if (not (bolp)) (newline)) | ||
| 11400 | (org-paste-subtree 2 txt))) | ||
| 11401 | ((and (org-on-heading-p nil) (not current-prefix-arg)) | ||
| 11402 | ;; Put it below this entry, at the beg/end of the subtree | ||
| 11403 | (org-back-to-heading) | ||
| 11404 | (setq level (funcall outline-level)) | ||
| 11405 | (if reversed | ||
| 11406 | (outline-end-of-heading) | ||
| 11407 | (outline-end-of-subtree)) | ||
| 11408 | (if (not (bolp)) (newline)) | ||
| 11409 | (beginning-of-line 1) | ||
| 11410 | (org-paste-subtree (org-get-legal-level level 1) txt)) | ||
| 11411 | (t | ||
| 11412 | ;; Put it right there, with automatic level determined by | ||
| 11413 | ;; org-paste-subtree or from prefix arg | ||
| 11414 | (org-paste-subtree current-prefix-arg txt))) | ||
| 11415 | (when remember-save-after-remembering | ||
| 11416 | (save-buffer) | ||
| 11417 | (if (not visiting) (kill-buffer (current-buffer))))))))) | ||
| 11418 | t) ;; return t to indicate that we took care of this note. | ||
| 11419 | |||
| 11420 | (defun org-get-org-file () | ||
| 11421 | "Read a filename, with default directory `org-directory'." | ||
| 11422 | (let ((default (or org-default-notes-file remember-data-file))) | ||
| 11423 | (read-file-name (format "File name [%s]: " default) | ||
| 11424 | (file-name-as-directory org-directory) | ||
| 11425 | default))) | ||
| 11426 | |||
| 11427 | (defun org-notes-order-reversed-p () | ||
| 11428 | "Check if the current file should receive notes in reversed order." | ||
| 11429 | (cond | ||
| 11430 | ((not org-reverse-note-order) nil) | ||
| 11431 | ((eq t org-reverse-note-order) t) | ||
| 11432 | ((not (listp org-reverse-note-order)) nil) | ||
| 11433 | (t (catch 'exit | ||
| 11434 | (let ((all org-reverse-note-order) | ||
| 11435 | entry) | ||
| 11436 | (while (setq entry (pop all)) | ||
| 11437 | (if (string-match (car entry) buffer-file-name) | ||
| 11438 | (throw 'exit (cdr entry)))) | ||
| 11439 | nil))))) | ||
| 11440 | |||
| 11441 | ;;; Tables | ||
| 11442 | |||
| 11443 | ;; Watch out: Here we are talking about two different kind of tables. | ||
| 11444 | ;; Most of the code is for the tables created with the Org-mode table editor. | ||
| 11445 | ;; Sometimes, we talk about tables created and edited with the table.el | ||
| 11446 | ;; Emacs package. We call the former org-type tables, and the latter | ||
| 11447 | ;; table.el-type tables. | ||
| 11448 | |||
| 11449 | |||
| 11450 | (defun org-before-change-function (beg end) | ||
| 11451 | "Every change indicates that a table might need an update." | ||
| 11452 | (setq org-table-may-need-update t)) | ||
| 11453 | |||
| 11454 | (defconst org-table-line-regexp "^[ \t]*|" | ||
| 11455 | "Detects an org-type table line.") | ||
| 11456 | (defconst org-table-dataline-regexp "^[ \t]*|[^-]" | ||
| 11457 | "Detects an org-type table line.") | ||
| 11458 | (defconst org-table-auto-recalculate-regexp "^[ \t]*| *# *\\(|\\|$\\)" | ||
| 11459 | "Detects a table line marked for automatic recalculation.") | ||
| 11460 | (defconst org-table-recalculate-regexp "^[ \t]*| *[#*] *\\(|\\|$\\)" | ||
| 11461 | "Detects a table line marked for automatic recalculation.") | ||
| 11462 | (defconst org-table-calculate-mark-regexp "^[ \t]*| *[!$^_#*] *\\(|\\|$\\)" | ||
| 11463 | "Detects a table line marked for automatic recalculation.") | ||
| 11464 | (defconst org-table-hline-regexp "^[ \t]*|-" | ||
| 11465 | "Detects an org-type table hline.") | ||
| 11466 | (defconst org-table1-hline-regexp "^[ \t]*\\+-[-+]" | ||
| 11467 | "Detects a table-type table hline.") | ||
| 11468 | (defconst org-table-any-line-regexp "^[ \t]*\\(|\\|\\+-[-+]\\)" | ||
| 11469 | "Detects an org-type or table-type table.") | ||
| 11470 | (defconst org-table-border-regexp "^[ \t]*[^| \t]" | ||
| 11471 | "Searching from within a table (any type) this finds the first line | ||
| 11472 | outside the table.") | ||
| 11473 | (defconst org-table-any-border-regexp "^[ \t]*[^|+ \t]" | ||
| 11474 | "Searching from within a table (any type) this finds the first line | ||
| 11475 | outside the table.") | ||
| 11476 | |||
| 11477 | (defun org-table-create-with-table.el () | ||
| 11478 | "Use the table.el package to insert a new table. | ||
| 11479 | If there is already a table at point, convert between Org-mode tables | ||
| 11480 | and table.el tables." | ||
| 11481 | (interactive) | ||
| 11482 | (require 'table) | ||
| 11483 | (cond | ||
| 11484 | ((org-at-table.el-p) | ||
| 11485 | (if (y-or-n-p "Convert table to Org-mode table? ") | ||
| 11486 | (org-table-convert))) | ||
| 11487 | ((org-at-table-p) | ||
| 11488 | (if (y-or-n-p "Convert table to table.el table? ") | ||
| 11489 | (org-table-convert))) | ||
| 11490 | (t (call-interactively 'table-insert)))) | ||
| 11491 | |||
| 11492 | (defun org-table-create-or-convert-from-region (arg) | ||
| 11493 | "Convert region to table, or create an empty table. | ||
| 11494 | If there is an active region, convert it to a table. If there is no such | ||
| 11495 | region, create an empty table." | ||
| 11496 | (interactive "P") | ||
| 11497 | (if (org-region-active-p) | ||
| 11498 | (org-table-convert-region (region-beginning) (region-end) arg) | ||
| 11499 | (org-table-create arg))) | ||
| 11500 | |||
| 11501 | (defun org-table-create (&optional size) | ||
| 11502 | "Query for a size and insert a table skeleton. | ||
| 11503 | SIZE is a string Columns x Rows like for example \"3x2\"." | ||
| 11504 | (interactive "P") | ||
| 11505 | (unless size | ||
| 11506 | (setq size (read-string | ||
| 11507 | (concat "Table size Columns x Rows [e.g. " | ||
| 11508 | org-table-default-size "]: ") | ||
| 11509 | "" nil org-table-default-size))) | ||
| 11510 | |||
| 11511 | (let* ((pos (point)) | ||
| 11512 | (indent (make-string (current-column) ?\ )) | ||
| 11513 | (split (org-split-string size " *x *")) | ||
| 11514 | (rows (string-to-number (nth 1 split))) | ||
| 11515 | (columns (string-to-number (car split))) | ||
| 11516 | (line (concat (apply 'concat indent "|" (make-list columns " |")) | ||
| 11517 | "\n"))) | ||
| 11518 | (if (string-match "^[ \t]*$" (buffer-substring-no-properties | ||
| 11519 | (point-at-bol) (point))) | ||
| 11520 | (beginning-of-line 1) | ||
| 11521 | (newline)) | ||
| 11522 | ;; (mapcar (lambda (x) (insert line)) (make-list rows t)) | ||
| 11523 | (dotimes (i rows) (insert line)) | ||
| 11524 | (goto-char pos) | ||
| 11525 | (if (> rows 1) | ||
| 11526 | ;; Insert a hline after the first row. | ||
| 11527 | (progn | ||
| 11528 | (end-of-line 1) | ||
| 11529 | (insert "\n|-") | ||
| 11530 | (goto-char pos))) | ||
| 11531 | (org-table-align))) | ||
| 11532 | |||
| 11533 | (defun org-table-convert-region (beg0 end0 &optional nspace) | ||
| 11534 | "Convert region to a table. | ||
| 11535 | The region goes from BEG0 to END0, but these borders will be moved | ||
| 11536 | slightly, to make sure a beginning of line in the first line is included. | ||
| 11537 | When NSPACE is non-nil, it indicates the minimum number of spaces that | ||
| 11538 | separate columns (default: just one space)." | ||
| 11539 | (interactive "rP") | ||
| 11540 | (let* ((beg (min beg0 end0)) | ||
| 11541 | (end (max beg0 end0)) | ||
| 11542 | (tabsep t) | ||
| 11543 | re) | ||
| 11544 | (goto-char beg) | ||
| 11545 | (beginning-of-line 1) | ||
| 11546 | (setq beg (move-marker (make-marker) (point))) | ||
| 11547 | (goto-char end) | ||
| 11548 | (if (bolp) (backward-char 1) (end-of-line 1)) | ||
| 11549 | (setq end (move-marker (make-marker) (point))) | ||
| 11550 | ;; Lets see if this is tab-separated material. If every nonempty line | ||
| 11551 | ;; contains a tab, we will assume that it is tab-separated material | ||
| 11552 | (if nspace | ||
| 11553 | (setq tabsep nil) | ||
| 11554 | (goto-char beg) | ||
| 11555 | (and (re-search-forward "^[^\n\t]+$" end t) (setq tabsep nil))) | ||
| 11556 | (if nspace (setq tabsep nil)) | ||
| 11557 | (if tabsep | ||
| 11558 | (setq re "^\\|\t") | ||
| 11559 | (setq re (format "^ *\\| *\t *\\| \\{%d,\\}" | ||
| 11560 | (max 1 (prefix-numeric-value nspace))))) | ||
| 11561 | (goto-char beg) | ||
| 11562 | (while (re-search-forward re end t) | ||
| 11563 | (replace-match "| " t t)) | ||
| 11564 | (goto-char beg) | ||
| 11565 | (insert " ") | ||
| 11566 | (org-table-align))) | ||
| 11567 | |||
| 11568 | (defun org-table-import (file arg) | ||
| 11569 | "Import FILE as a table. | ||
| 11570 | The file is assumed to be tab-separated. Such files can be produced by most | ||
| 11571 | spreadsheet and database applications. If no tabs (at least one per line) | ||
| 11572 | are found, lines will be split on whitespace into fields." | ||
| 11573 | (interactive "f\nP") | ||
| 11574 | (or (bolp) (newline)) | ||
| 11575 | (let ((beg (point)) | ||
| 11576 | (pm (point-max))) | ||
| 11577 | (insert-file-contents file) | ||
| 11578 | (org-table-convert-region beg (+ (point) (- (point-max) pm)) arg))) | ||
| 11579 | |||
| 11580 | (defun org-table-export () | ||
| 11581 | "Export table as a tab-separated file. | ||
| 11582 | Such a file can be imported into a spreadsheet program like Excel." | ||
| 11583 | (interactive) | ||
| 11584 | (let* ((beg (org-table-begin)) | ||
| 11585 | (end (org-table-end)) | ||
| 11586 | (table (buffer-substring beg end)) | ||
| 11587 | (file (read-file-name "Export table to: ")) | ||
| 11588 | buf) | ||
| 11589 | (unless (or (not (file-exists-p file)) | ||
| 11590 | (y-or-n-p (format "Overwrite file %s? " file))) | ||
| 11591 | (error "Abort")) | ||
| 11592 | (with-current-buffer (find-file-noselect file) | ||
| 11593 | (setq buf (current-buffer)) | ||
| 11594 | (erase-buffer) | ||
| 11595 | (fundamental-mode) | ||
| 11596 | (insert table) | ||
| 11597 | (goto-char (point-min)) | ||
| 11598 | (while (re-search-forward "^[ \t]*|[ \t]*" nil t) | ||
| 11599 | (replace-match "" t t) | ||
| 11600 | (end-of-line 1)) | ||
| 11601 | (goto-char (point-min)) | ||
| 11602 | (while (re-search-forward "[ \t]*|[ \t]*$" nil t) | ||
| 11603 | (replace-match "" t t) | ||
| 11604 | (goto-char (min (1+ (point)) (point-max)))) | ||
| 11605 | (goto-char (point-min)) | ||
| 11606 | (while (re-search-forward "^-[-+]*$" nil t) | ||
| 11607 | (replace-match "") | ||
| 11608 | (if (looking-at "\n") | ||
| 11609 | (delete-char 1))) | ||
| 11610 | (goto-char (point-min)) | ||
| 11611 | (while (re-search-forward "[ \t]*|[ \t]*" nil t) | ||
| 11612 | (replace-match "\t" t t)) | ||
| 11613 | (save-buffer)) | ||
| 11614 | (kill-buffer buf))) | ||
| 11615 | |||
| 11616 | (defvar org-table-aligned-begin-marker (make-marker) | ||
| 11617 | "Marker at the beginning of the table last aligned. | ||
| 11618 | Used to check if cursor still is in that table, to minimize realignment.") | ||
| 11619 | (defvar org-table-aligned-end-marker (make-marker) | ||
| 11620 | "Marker at the end of the table last aligned. | ||
| 11621 | Used to check if cursor still is in that table, to minimize realignment.") | ||
| 11622 | (defvar org-table-last-alignment nil | ||
| 11623 | "List of flags for flushright alignment, from the last re-alignment. | ||
| 11624 | This is being used to correctly align a single field after TAB or RET.") | ||
| 11625 | (defvar org-table-last-column-widths nil | ||
| 11626 | "List of max width of fields in each column. | ||
| 11627 | This is being used to correctly align a single field after TAB or RET.") | ||
| 11628 | |||
| 11629 | (defvar org-last-recalc-line nil) | ||
| 11630 | (defconst org-narrow-column-arrow "=>" | ||
| 11631 | "Used as display property in narrowed table columns.") | ||
| 11632 | |||
| 11633 | (defun org-table-align () | ||
| 11634 | "Align the table at point by aligning all vertical bars." | ||
| 11635 | (interactive) | ||
| 11636 | (let* ( | ||
| 11637 | ;; Limits of table | ||
| 11638 | (beg (org-table-begin)) | ||
| 11639 | (end (org-table-end)) | ||
| 11640 | ;; Current cursor position | ||
| 11641 | (linepos (org-current-line)) | ||
| 11642 | (colpos (org-table-current-column)) | ||
| 11643 | (winstart (window-start)) | ||
| 11644 | (winstartline (org-current-line (min winstart (1- (point-max))))) | ||
| 11645 | lines (new "") lengths l typenums ty fields maxfields i | ||
| 11646 | column | ||
| 11647 | (indent "") cnt frac | ||
| 11648 | rfmt hfmt | ||
| 11649 | (spaces '(1 . 1)) | ||
| 11650 | (sp1 (car spaces)) | ||
| 11651 | (sp2 (cdr spaces)) | ||
| 11652 | (rfmt1 (concat | ||
| 11653 | (make-string sp2 ?\ ) "%%%s%ds" (make-string sp1 ?\ ) "|")) | ||
| 11654 | (hfmt1 (concat | ||
| 11655 | (make-string sp2 ?-) "%s" (make-string sp1 ?-) "+")) | ||
| 11656 | emptystrings links dates narrow fmax f1 len c e) | ||
| 11657 | (untabify beg end) | ||
| 11658 | (remove-text-properties beg end '(org-cwidth t org-dwidth t display t)) | ||
| 11659 | ;; Check if we have links or dates | ||
| 11660 | (goto-char beg) | ||
| 11661 | (setq links (re-search-forward org-bracket-link-regexp end t)) | ||
| 11662 | (goto-char beg) | ||
| 11663 | (setq dates (and org-display-custom-times | ||
| 11664 | (re-search-forward org-ts-regexp-both end t))) | ||
| 11665 | ;; Make sure the link properties are right | ||
| 11666 | (when links (goto-char beg) (while (org-activate-bracket-links end))) | ||
| 11667 | ;; Make sure the date properties are right | ||
| 11668 | (when dates (goto-char beg) (while (org-activate-dates end))) | ||
| 11669 | |||
| 11670 | ;; Check if we are narrowing any columns | ||
| 11671 | (goto-char beg) | ||
| 11672 | (setq narrow (and org-format-transports-properties-p | ||
| 11673 | (re-search-forward "<[0-9]+>" end t))) | ||
| 11674 | ;; Get the rows | ||
| 11675 | (setq lines (org-split-string | ||
| 11676 | (buffer-substring beg end) "\n")) | ||
| 11677 | ;; Store the indentation of the first line | ||
| 11678 | (if (string-match "^ *" (car lines)) | ||
| 11679 | (setq indent (make-string (- (match-end 0) (match-beginning 0)) ?\ ))) | ||
| 11680 | ;; Mark the hlines by setting the corresponding element to nil | ||
| 11681 | ;; At the same time, we remove trailing space. | ||
| 11682 | (setq lines (mapcar (lambda (l) | ||
| 11683 | (if (string-match "^ *|-" l) | ||
| 11684 | nil | ||
| 11685 | (if (string-match "[ \t]+$" l) | ||
| 11686 | (substring l 0 (match-beginning 0)) | ||
| 11687 | l))) | ||
| 11688 | lines)) | ||
| 11689 | ;; Get the data fields by splitting the lines. | ||
| 11690 | (setq fields (mapcar | ||
| 11691 | (lambda (l) | ||
| 11692 | (org-split-string l " *| *")) | ||
| 11693 | (delq nil (copy-sequence lines)))) | ||
| 11694 | ;; How many fields in the longest line? | ||
| 11695 | (condition-case nil | ||
| 11696 | (setq maxfields (apply 'max (mapcar 'length fields))) | ||
| 11697 | (error | ||
| 11698 | (kill-region beg end) | ||
| 11699 | (org-table-create org-table-default-size) | ||
| 11700 | (error "Empty table - created default table"))) | ||
| 11701 | ;; A list of empty strings to fill any short rows on output | ||
| 11702 | (setq emptystrings (make-list maxfields "")) | ||
| 11703 | ;; Check for special formatting. | ||
| 11704 | (setq i -1) | ||
| 11705 | (while (< (setq i (1+ i)) maxfields) ;; Loop over all columns | ||
| 11706 | (setq column (mapcar (lambda (x) (or (nth i x) "")) fields)) | ||
| 11707 | ;; Check if there is an explicit width specified | ||
| 11708 | (when (and org-table-limit-column-width narrow) | ||
| 11709 | (setq c column fmax nil) | ||
| 11710 | (while c | ||
| 11711 | (setq e (pop c)) | ||
| 11712 | (if (and (stringp e) (string-match "^<\\([0-9]+\\)>$" e)) | ||
| 11713 | (setq fmax (string-to-number (match-string 1 e)) c nil))) | ||
| 11714 | ;; Find fields that are wider than fmax, and shorten them | ||
| 11715 | (when fmax | ||
| 11716 | (loop for xx in column do | ||
| 11717 | (when (and (stringp xx) | ||
| 11718 | (> (org-string-width xx) fmax)) | ||
| 11719 | (org-add-props xx nil | ||
| 11720 | 'help-echo | ||
| 11721 | (concat "Clipped table field, use C-c ` to edit. Full value is:\n" (org-no-properties (copy-sequence xx)))) | ||
| 11722 | (setq f1 (min fmax (or (string-match org-bracket-link-regexp xx) fmax))) | ||
| 11723 | (unless (> f1 1) | ||
| 11724 | (error "Cannot narrow field starting with wide link \"%s\"" | ||
| 11725 | (match-string 0 xx))) | ||
| 11726 | (add-text-properties f1 (length xx) (list 'org-cwidth t) xx) | ||
| 11727 | (add-text-properties (- f1 2) f1 | ||
| 11728 | (list 'display org-narrow-column-arrow) | ||
| 11729 | xx))))) | ||
| 11730 | ;; Get the maximum width for each column | ||
| 11731 | (push (apply 'max 1 (mapcar 'org-string-width column)) lengths) | ||
| 11732 | ;; Get the fraction of numbers, to decide about alignment of the column | ||
| 11733 | (setq cnt 0 frac 0.0) | ||
| 11734 | (loop for x in column do | ||
| 11735 | (if (equal x "") | ||
| 11736 | nil | ||
| 11737 | (setq frac ( / (+ (* frac cnt) | ||
| 11738 | (if (string-match org-table-number-regexp x) 1 0)) | ||
| 11739 | (setq cnt (1+ cnt)))))) | ||
| 11740 | (push (>= frac org-table-number-fraction) typenums)) | ||
| 11741 | (setq lengths (nreverse lengths) typenums (nreverse typenums)) | ||
| 11742 | |||
| 11743 | ;; Store the alignment of this table, for later editing of single fields | ||
| 11744 | (setq org-table-last-alignment typenums | ||
| 11745 | org-table-last-column-widths lengths) | ||
| 11746 | |||
| 11747 | ;; With invisible characters, `format' does not get the field width right | ||
| 11748 | ;; So we need to make these fields wide by hand. | ||
| 11749 | (when links | ||
| 11750 | (loop for i from 0 upto (1- maxfields) do | ||
| 11751 | (setq len (nth i lengths)) | ||
| 11752 | (loop for j from 0 upto (1- (length fields)) do | ||
| 11753 | (setq c (nthcdr i (car (nthcdr j fields)))) | ||
| 11754 | (if (and (stringp (car c)) | ||
| 11755 | (string-match org-bracket-link-regexp (car c)) | ||
| 11756 | (< (org-string-width (car c)) len)) | ||
| 11757 | (setcar c (concat (car c) (make-string (- len (org-string-width (car c))) ?\ ))))))) | ||
| 11758 | |||
| 11759 | ;; Compute the formats needed for output of the table | ||
| 11760 | (setq rfmt (concat indent "|") hfmt (concat indent "|")) | ||
| 11761 | (while (setq l (pop lengths)) | ||
| 11762 | (setq ty (if (pop typenums) "" "-")) ; number types flushright | ||
| 11763 | (setq rfmt (concat rfmt (format rfmt1 ty l)) | ||
| 11764 | hfmt (concat hfmt (format hfmt1 (make-string l ?-))))) | ||
| 11765 | (setq rfmt (concat rfmt "\n") | ||
| 11766 | hfmt (concat (substring hfmt 0 -1) "|\n")) | ||
| 11767 | |||
| 11768 | (setq new (mapconcat | ||
| 11769 | (lambda (l) | ||
| 11770 | (if l (apply 'format rfmt | ||
| 11771 | (append (pop fields) emptystrings)) | ||
| 11772 | hfmt)) | ||
| 11773 | lines "")) | ||
| 11774 | ;; Replace the old one | ||
| 11775 | (delete-region beg end) | ||
| 11776 | (move-marker end nil) | ||
| 11777 | (move-marker org-table-aligned-begin-marker (point)) | ||
| 11778 | (insert new) | ||
| 11779 | (move-marker org-table-aligned-end-marker (point)) | ||
| 11780 | (when (and orgtbl-mode (not (org-mode-p))) | ||
| 11781 | (goto-char org-table-aligned-begin-marker) | ||
| 11782 | (while (org-hide-wide-columns org-table-aligned-end-marker))) | ||
| 11783 | ;; Try to move to the old location | ||
| 11784 | (goto-line winstartline) | ||
| 11785 | (setq winstart (point-at-bol)) | ||
| 11786 | (goto-line linepos) | ||
| 11787 | (set-window-start (selected-window) winstart 'noforce) | ||
| 11788 | (org-table-goto-column colpos) | ||
| 11789 | (setq org-table-may-need-update nil) | ||
| 11790 | )) | ||
| 11791 | |||
| 11792 | (defun org-string-width (s) | ||
| 11793 | "Compute width of string, ignoring invisible characters. | ||
| 11794 | This ignores character with invisibility property `org-link', and also | ||
| 11795 | characters with property `org-cwidth', because these will become invisible | ||
| 11796 | upon the next fontification round." | ||
| 11797 | (let (b l) | ||
| 11798 | (when (or (eq t buffer-invisibility-spec) | ||
| 11799 | (assq 'org-link buffer-invisibility-spec)) | ||
| 11800 | (while (setq b (text-property-any 0 (length s) | ||
| 11801 | 'invisible 'org-link s)) | ||
| 11802 | (setq s (concat (substring s 0 b) | ||
| 11803 | (substring s (or (next-single-property-change | ||
| 11804 | b 'invisible s) (length s))))))) | ||
| 11805 | (while (setq b (text-property-any 0 (length s) 'org-cwidth t s)) | ||
| 11806 | (setq s (concat (substring s 0 b) | ||
| 11807 | (substring s (or (next-single-property-change | ||
| 11808 | b 'org-cwidth s) (length s)))))) | ||
| 11809 | (setq l (string-width s) b -1) | ||
| 11810 | (while (setq b (text-property-any (1+ b) (length s) 'org-dwidth t s)) | ||
| 11811 | (setq l (- l (get-text-property b 'org-dwidth-n s)))) | ||
| 11812 | l)) | ||
| 11813 | |||
| 11814 | (defun org-table-begin (&optional table-type) | ||
| 11815 | "Find the beginning of the table and return its position. | ||
| 11816 | With argument TABLE-TYPE, go to the beginning of a table.el-type table." | ||
| 11817 | (save-excursion | ||
| 11818 | (if (not (re-search-backward | ||
| 11819 | (if table-type org-table-any-border-regexp | ||
| 11820 | org-table-border-regexp) | ||
| 11821 | nil t)) | ||
| 11822 | (progn (goto-char (point-min)) (point)) | ||
| 11823 | (goto-char (match-beginning 0)) | ||
| 11824 | (beginning-of-line 2) | ||
| 11825 | (point)))) | ||
| 11826 | |||
| 11827 | (defun org-table-end (&optional table-type) | ||
| 11828 | "Find the end of the table and return its position. | ||
| 11829 | With argument TABLE-TYPE, go to the end of a table.el-type table." | ||
| 11830 | (save-excursion | ||
| 11831 | (if (not (re-search-forward | ||
| 11832 | (if table-type org-table-any-border-regexp | ||
| 11833 | org-table-border-regexp) | ||
| 11834 | nil t)) | ||
| 11835 | (goto-char (point-max)) | ||
| 11836 | (goto-char (match-beginning 0))) | ||
| 11837 | (point-marker))) | ||
| 11838 | |||
| 11839 | (defun org-table-justify-field-maybe (&optional new) | ||
| 11840 | "Justify the current field, text to left, number to right. | ||
| 11841 | Optional argument NEW may specify text to replace the current field content." | ||
| 11842 | (cond | ||
| 11843 | ((and (not new) org-table-may-need-update)) ; Realignment will happen anyway | ||
| 11844 | ((org-at-table-hline-p)) | ||
| 11845 | ((and (not new) | ||
| 11846 | (or (not (equal (marker-buffer org-table-aligned-begin-marker) | ||
| 11847 | (current-buffer))) | ||
| 11848 | (< (point) org-table-aligned-begin-marker) | ||
| 11849 | (>= (point) org-table-aligned-end-marker))) | ||
| 11850 | ;; This is not the same table, force a full re-align | ||
| 11851 | (setq org-table-may-need-update t)) | ||
| 11852 | (t ;; realign the current field, based on previous full realign | ||
| 11853 | (let* ((pos (point)) s | ||
| 11854 | (col (org-table-current-column)) | ||
| 11855 | (num (if (> col 0) (nth (1- col) org-table-last-alignment))) | ||
| 11856 | l f n o e) | ||
| 11857 | (when (> col 0) | ||
| 11858 | (skip-chars-backward "^|\n") | ||
| 11859 | (if (looking-at " *\\([^|\n]*?\\) *\\(|\\|$\\)") | ||
| 11860 | (progn | ||
| 11861 | (setq s (match-string 1) | ||
| 11862 | o (match-string 0) | ||
| 11863 | l (max 1 (- (match-end 0) (match-beginning 0) 3)) | ||
| 11864 | e (not (= (match-beginning 2) (match-end 2)))) | ||
| 11865 | (setq f (format (if num " %%%ds %s" " %%-%ds %s") | ||
| 11866 | l (if e "|" (setq org-table-may-need-update t) "")) | ||
| 11867 | n (format f s)) | ||
| 11868 | (if new | ||
| 11869 | (if (<= (length new) l) ;; FIXME: length -> str-width? | ||
| 11870 | (setq n (format f new)) | ||
| 11871 | (setq n (concat new "|") org-table-may-need-update t))) | ||
| 11872 | (or (equal n o) | ||
| 11873 | (let (org-table-may-need-update) | ||
| 11874 | (replace-match n)))) | ||
| 11875 | (setq org-table-may-need-update t)) | ||
| 11876 | (goto-char pos)))))) | ||
| 11877 | |||
| 11878 | (defun org-table-next-field () | ||
| 11879 | "Go to the next field in the current table, creating new lines as needed. | ||
| 11880 | Before doing so, re-align the table if necessary." | ||
| 11881 | (interactive) | ||
| 11882 | (org-table-maybe-eval-formula) | ||
| 11883 | (org-table-maybe-recalculate-line) | ||
| 11884 | (if (and org-table-automatic-realign | ||
| 11885 | org-table-may-need-update) | ||
| 11886 | (org-table-align)) | ||
| 11887 | (let ((end (org-table-end))) | ||
| 11888 | (if (org-at-table-hline-p) | ||
| 11889 | (end-of-line 1)) | ||
| 11890 | (condition-case nil | ||
| 11891 | (progn | ||
| 11892 | (re-search-forward "|" end) | ||
| 11893 | (if (looking-at "[ \t]*$") | ||
| 11894 | (re-search-forward "|" end)) | ||
| 11895 | (if (and (looking-at "-") | ||
| 11896 | org-table-tab-jumps-over-hlines | ||
| 11897 | (re-search-forward "^[ \t]*|\\([^-]\\)" end t)) | ||
| 11898 | (goto-char (match-beginning 1))) | ||
| 11899 | (if (looking-at "-") | ||
| 11900 | (progn | ||
| 11901 | (beginning-of-line 0) | ||
| 11902 | (org-table-insert-row 'below)) | ||
| 11903 | (if (looking-at " ") (forward-char 1)))) | ||
| 11904 | (error | ||
| 11905 | (org-table-insert-row 'below))))) | ||
| 11906 | |||
| 11907 | (defun org-table-previous-field () | ||
| 11908 | "Go to the previous field in the table. | ||
| 11909 | Before doing so, re-align the table if necessary." | ||
| 11910 | (interactive) | ||
| 11911 | (org-table-justify-field-maybe) | ||
| 11912 | (org-table-maybe-recalculate-line) | ||
| 11913 | (if (and org-table-automatic-realign | ||
| 11914 | org-table-may-need-update) | ||
| 11915 | (org-table-align)) | ||
| 11916 | (if (org-at-table-hline-p) | ||
| 11917 | (end-of-line 1)) | ||
| 11918 | (re-search-backward "|" (org-table-begin)) | ||
| 11919 | (re-search-backward "|" (org-table-begin)) | ||
| 11920 | (while (looking-at "|\\(-\\|[ \t]*$\\)") | ||
| 11921 | (re-search-backward "|" (org-table-begin))) | ||
| 11922 | (if (looking-at "| ?") | ||
| 11923 | (goto-char (match-end 0)))) | ||
| 11924 | |||
| 11925 | (defun org-table-next-row () | ||
| 11926 | "Go to the next row (same column) in the current table. | ||
| 11927 | Before doing so, re-align the table if necessary." | ||
| 11928 | (interactive) | ||
| 11929 | (org-table-maybe-eval-formula) | ||
| 11930 | (org-table-maybe-recalculate-line) | ||
| 11931 | (if (or (looking-at "[ \t]*$") | ||
| 11932 | (save-excursion (skip-chars-backward " \t") (bolp))) | ||
| 11933 | (newline) | ||
| 11934 | (if (and org-table-automatic-realign | ||
| 11935 | org-table-may-need-update) | ||
| 11936 | (org-table-align)) | ||
| 11937 | (let ((col (org-table-current-column))) | ||
| 11938 | (beginning-of-line 2) | ||
| 11939 | (if (or (not (org-at-table-p)) | ||
| 11940 | (org-at-table-hline-p)) | ||
| 11941 | (progn | ||
| 11942 | (beginning-of-line 0) | ||
| 11943 | (org-table-insert-row 'below))) | ||
| 11944 | (org-table-goto-column col) | ||
| 11945 | (skip-chars-backward "^|\n\r") | ||
| 11946 | (if (looking-at " ") (forward-char 1))))) | ||
| 11947 | |||
| 11948 | (defun org-table-copy-down (n) | ||
| 11949 | "Copy a field down in the current column. | ||
| 11950 | If the field at the cursor is empty, copy into it the content of the nearest | ||
| 11951 | non-empty field above. With argument N, use the Nth non-empty field. | ||
| 11952 | If the current field is not empty, it is copied down to the next row, and | ||
| 11953 | the cursor is moved with it. Therefore, repeating this command causes the | ||
| 11954 | column to be filled row-by-row. | ||
| 11955 | If the variable `org-table-copy-increment' is non-nil and the field is an | ||
| 11956 | integer, it will be incremented while copying." | ||
| 11957 | (interactive "p") | ||
| 11958 | (let* ((colpos (org-table-current-column)) | ||
| 11959 | (field (org-table-get-field)) | ||
| 11960 | (non-empty (string-match "[^ \t]" field)) | ||
| 11961 | (beg (org-table-begin)) | ||
| 11962 | txt) | ||
| 11963 | (org-table-check-inside-data-field) | ||
| 11964 | (if non-empty | ||
| 11965 | (progn | ||
| 11966 | (setq txt (org-trim field)) | ||
| 11967 | (org-table-next-row) | ||
| 11968 | (org-table-blank-field)) | ||
| 11969 | (save-excursion | ||
| 11970 | (setq txt | ||
| 11971 | (catch 'exit | ||
| 11972 | (while (progn (beginning-of-line 1) | ||
| 11973 | (re-search-backward org-table-dataline-regexp | ||
| 11974 | beg t)) | ||
| 11975 | (org-table-goto-column colpos t) | ||
| 11976 | (if (and (looking-at | ||
| 11977 | "|[ \t]*\\([^| \t][^|]*?\\)[ \t]*|") | ||
| 11978 | (= (setq n (1- n)) 0)) | ||
| 11979 | (throw 'exit (match-string 1)))))))) | ||
| 11980 | (if txt | ||
| 11981 | (progn | ||
| 11982 | (if (and org-table-copy-increment | ||
| 11983 | (string-match "^[0-9]+$" txt)) | ||
| 11984 | (setq txt (format "%d" (+ (string-to-number txt) 1)))) | ||
| 11985 | (insert txt) | ||
| 11986 | (org-table-maybe-recalculate-line) | ||
| 11987 | (org-table-align)) | ||
| 11988 | (error "No non-empty field found")))) | ||
| 11989 | |||
| 11990 | (defun org-table-check-inside-data-field () | ||
| 11991 | "Is point inside a table data field? | ||
| 11992 | I.e. not on a hline or before the first or after the last column? | ||
| 11993 | This actually throws an error, so it aborts the current command." | ||
| 11994 | (if (or (not (org-at-table-p)) | ||
| 11995 | (= (org-table-current-column) 0) | ||
| 11996 | (org-at-table-hline-p) | ||
| 11997 | (looking-at "[ \t]*$")) | ||
| 11998 | (error "Not in table data field"))) | ||
| 11999 | |||
| 12000 | (defvar org-table-clip nil | ||
| 12001 | "Clipboard for table regions.") | ||
| 12002 | |||
| 12003 | (defun org-table-blank-field () | ||
| 12004 | "Blank the current table field or active region." | ||
| 12005 | (interactive) | ||
| 12006 | (org-table-check-inside-data-field) | ||
| 12007 | (if (and (interactive-p) (org-region-active-p)) | ||
| 12008 | (let (org-table-clip) | ||
| 12009 | (org-table-cut-region (region-beginning) (region-end))) | ||
| 12010 | (skip-chars-backward "^|") | ||
| 12011 | (backward-char 1) | ||
| 12012 | (if (looking-at "|[^|\n]+") | ||
| 12013 | (let* ((pos (match-beginning 0)) | ||
| 12014 | (match (match-string 0)) | ||
| 12015 | (len (org-string-width match))) | ||
| 12016 | (replace-match (concat "|" (make-string (1- len) ?\ ))) | ||
| 12017 | (goto-char (+ 2 pos)) | ||
| 12018 | (substring match 1))))) | ||
| 12019 | |||
| 12020 | (defun org-table-get-field (&optional n replace) | ||
| 12021 | "Return the value of the field in column N of current row. | ||
| 12022 | N defaults to current field. | ||
| 12023 | If REPLACE is a string, replace field with this value. The return value | ||
| 12024 | is always the old value." | ||
| 12025 | (and n (org-table-goto-column n)) | ||
| 12026 | (skip-chars-backward "^|\n") | ||
| 12027 | (backward-char 1) | ||
| 12028 | (if (looking-at "|[^|\r\n]*") | ||
| 12029 | (let* ((pos (match-beginning 0)) | ||
| 12030 | (val (buffer-substring (1+ pos) (match-end 0)))) | ||
| 12031 | (if replace | ||
| 12032 | (replace-match (concat "|" replace))) | ||
| 12033 | (goto-char (min (point-at-eol) (+ 2 pos))) | ||
| 12034 | val) | ||
| 12035 | (forward-char 1) "")) | ||
| 12036 | |||
| 12037 | (defun org-table-current-column () | ||
| 12038 | "Find out which column we are in. | ||
| 12039 | When called interactively, column is also displayed in echo area." | ||
| 12040 | (interactive) | ||
| 12041 | (if (interactive-p) (org-table-check-inside-data-field)) | ||
| 12042 | (save-excursion | ||
| 12043 | (let ((cnt 0) (pos (point))) | ||
| 12044 | (beginning-of-line 1) | ||
| 12045 | (while (search-forward "|" pos t) | ||
| 12046 | (setq cnt (1+ cnt))) | ||
| 12047 | (if (interactive-p) (message "This is table column %d" cnt)) | ||
| 12048 | cnt))) | ||
| 12049 | |||
| 12050 | (defun org-table-goto-column (n &optional on-delim force) | ||
| 12051 | "Move the cursor to the Nth column in the current table line. | ||
| 12052 | With optional argument ON-DELIM, stop with point before the left delimiter | ||
| 12053 | of the field. | ||
| 12054 | If there are less than N fields, just go to after the last delimiter. | ||
| 12055 | However, when FORCE is non-nil, create new columns if necessary." | ||
| 12056 | (interactive "p") | ||
| 12057 | (let ((pos (point-at-eol))) | ||
| 12058 | (beginning-of-line 1) | ||
| 12059 | (when (> n 0) | ||
| 12060 | (while (and (> (setq n (1- n)) -1) | ||
| 12061 | (or (search-forward "|" pos t) | ||
| 12062 | (and force | ||
| 12063 | (progn (end-of-line 1) | ||
| 12064 | (skip-chars-backward "^|") | ||
| 12065 | (insert " | ")))))) | ||
| 12066 | ; (backward-char 2) t))))) | ||
| 12067 | (when (and force (not (looking-at ".*|"))) | ||
| 12068 | (save-excursion (end-of-line 1) (insert " | "))) | ||
| 12069 | (if on-delim | ||
| 12070 | (backward-char 1) | ||
| 12071 | (if (looking-at " ") (forward-char 1)))))) | ||
| 12072 | |||
| 12073 | (defun org-at-table-p (&optional table-type) | ||
| 12074 | "Return t if the cursor is inside an org-type table. | ||
| 12075 | If TABLE-TYPE is non-nil, also check for table.el-type tables." | ||
| 12076 | (if org-enable-table-editor | ||
| 12077 | (save-excursion | ||
| 12078 | (beginning-of-line 1) | ||
| 12079 | (looking-at (if table-type org-table-any-line-regexp | ||
| 12080 | org-table-line-regexp))) | ||
| 12081 | nil)) | ||
| 12082 | |||
| 12083 | (defun org-at-table.el-p () | ||
| 12084 | "Return t if and only if we are at a table.el table." | ||
| 12085 | (and (org-at-table-p 'any) | ||
| 12086 | (save-excursion | ||
| 12087 | (goto-char (org-table-begin 'any)) | ||
| 12088 | (looking-at org-table1-hline-regexp)))) | ||
| 12089 | |||
| 12090 | (defun org-table-recognize-table.el () | ||
| 12091 | "If there is a table.el table nearby, recognize it and move into it." | ||
| 12092 | (if org-table-tab-recognizes-table.el | ||
| 12093 | (if (org-at-table.el-p) | ||
| 12094 | (progn | ||
| 12095 | (beginning-of-line 1) | ||
| 12096 | (if (looking-at org-table-dataline-regexp) | ||
| 12097 | nil | ||
| 12098 | (if (looking-at org-table1-hline-regexp) | ||
| 12099 | (progn | ||
| 12100 | (beginning-of-line 2) | ||
| 12101 | (if (looking-at org-table-any-border-regexp) | ||
| 12102 | (beginning-of-line -1))))) | ||
| 12103 | (if (re-search-forward "|" (org-table-end t) t) | ||
| 12104 | (progn | ||
| 12105 | (require 'table) | ||
| 12106 | (if (table--at-cell-p (point)) | ||
| 12107 | t | ||
| 12108 | (message "recognizing table.el table...") | ||
| 12109 | (table-recognize-table) | ||
| 12110 | (message "recognizing table.el table...done"))) | ||
| 12111 | (error "This should not happen...")) | ||
| 12112 | t) | ||
| 12113 | nil) | ||
| 12114 | nil)) | ||
| 12115 | |||
| 12116 | (defun org-at-table-hline-p () | ||
| 12117 | "Return t if the cursor is inside a hline in a table." | ||
| 12118 | (if org-enable-table-editor | ||
| 12119 | (save-excursion | ||
| 12120 | (beginning-of-line 1) | ||
| 12121 | (looking-at org-table-hline-regexp)) | ||
| 12122 | nil)) | ||
| 12123 | |||
| 12124 | (defun org-table-insert-column () | ||
| 12125 | "Insert a new column into the table." | ||
| 12126 | (interactive) | ||
| 12127 | (if (not (org-at-table-p)) | ||
| 12128 | (error "Not at a table")) | ||
| 12129 | (org-table-find-dataline) | ||
| 12130 | (let* ((col (max 1 (org-table-current-column))) | ||
| 12131 | (beg (org-table-begin)) | ||
| 12132 | (end (org-table-end)) | ||
| 12133 | ;; Current cursor position | ||
| 12134 | (linepos (org-current-line)) | ||
| 12135 | (colpos col)) | ||
| 12136 | (goto-char beg) | ||
| 12137 | (while (< (point) end) | ||
| 12138 | (if (org-at-table-hline-p) | ||
| 12139 | nil | ||
| 12140 | (org-table-goto-column col t) | ||
| 12141 | (insert "| ")) | ||
| 12142 | (beginning-of-line 2)) | ||
| 12143 | (move-marker end nil) | ||
| 12144 | (goto-line linepos) | ||
| 12145 | (org-table-goto-column colpos) | ||
| 12146 | (org-table-align) | ||
| 12147 | (org-table-modify-formulas 'insert col))) | ||
| 12148 | |||
| 12149 | (defun org-table-find-dataline () | ||
| 12150 | "Find a dataline in the current table, which is needed for column commands." | ||
| 12151 | (if (and (org-at-table-p) | ||
| 12152 | (not (org-at-table-hline-p))) | ||
| 12153 | t | ||
| 12154 | (let ((col (current-column)) | ||
| 12155 | (end (org-table-end))) | ||
| 12156 | (move-to-column col) | ||
| 12157 | (while (and (< (point) end) | ||
| 12158 | (or (not (= (current-column) col)) | ||
| 12159 | (org-at-table-hline-p))) | ||
| 12160 | (beginning-of-line 2) | ||
| 12161 | (move-to-column col)) | ||
| 12162 | (if (and (org-at-table-p) | ||
| 12163 | (not (org-at-table-hline-p))) | ||
| 12164 | t | ||
| 12165 | (error | ||
| 12166 | "Please position cursor in a data line for column operations"))))) | ||
| 12167 | |||
| 12168 | (defun org-table-delete-column () | ||
| 12169 | "Delete a column from the table." | ||
| 12170 | (interactive) | ||
| 12171 | (if (not (org-at-table-p)) | ||
| 12172 | (error "Not at a table")) | ||
| 12173 | (org-table-find-dataline) | ||
| 12174 | (org-table-check-inside-data-field) | ||
| 12175 | (let* ((col (org-table-current-column)) | ||
| 12176 | (beg (org-table-begin)) | ||
| 12177 | (end (org-table-end)) | ||
| 12178 | ;; Current cursor position | ||
| 12179 | (linepos (org-current-line)) | ||
| 12180 | (colpos col)) | ||
| 12181 | (goto-char beg) | ||
| 12182 | (while (< (point) end) | ||
| 12183 | (if (org-at-table-hline-p) | ||
| 12184 | nil | ||
| 12185 | (org-table-goto-column col t) | ||
| 12186 | (and (looking-at "|[^|\n]+|") | ||
| 12187 | (replace-match "|"))) | ||
| 12188 | (beginning-of-line 2)) | ||
| 12189 | (move-marker end nil) | ||
| 12190 | (goto-line linepos) | ||
| 12191 | (org-table-goto-column colpos) | ||
| 12192 | (org-table-align) | ||
| 12193 | (org-table-modify-formulas 'remove col))) | ||
| 12194 | |||
| 12195 | (defun org-table-move-column-right () | ||
| 12196 | "Move column to the right." | ||
| 12197 | (interactive) | ||
| 12198 | (org-table-move-column nil)) | ||
| 12199 | (defun org-table-move-column-left () | ||
| 12200 | "Move column to the left." | ||
| 12201 | (interactive) | ||
| 12202 | (org-table-move-column 'left)) | ||
| 12203 | |||
| 12204 | (defun org-table-move-column (&optional left) | ||
| 12205 | "Move the current column to the right. With arg LEFT, move to the left." | ||
| 12206 | (interactive "P") | ||
| 12207 | (if (not (org-at-table-p)) | ||
| 12208 | (error "Not at a table")) | ||
| 12209 | (org-table-find-dataline) | ||
| 12210 | (org-table-check-inside-data-field) | ||
| 12211 | (let* ((col (org-table-current-column)) | ||
| 12212 | (col1 (if left (1- col) col)) | ||
| 12213 | (beg (org-table-begin)) | ||
| 12214 | (end (org-table-end)) | ||
| 12215 | ;; Current cursor position | ||
| 12216 | (linepos (org-current-line)) | ||
| 12217 | (colpos (if left (1- col) (1+ col)))) | ||
| 12218 | (if (and left (= col 1)) | ||
| 12219 | (error "Cannot move column further left")) | ||
| 12220 | (if (and (not left) (looking-at "[^|\n]*|[^|\n]*$")) | ||
| 12221 | (error "Cannot move column further right")) | ||
| 12222 | (goto-char beg) | ||
| 12223 | (while (< (point) end) | ||
| 12224 | (if (org-at-table-hline-p) | ||
| 12225 | nil | ||
| 12226 | (org-table-goto-column col1 t) | ||
| 12227 | (and (looking-at "|\\([^|\n]+\\)|\\([^|\n]+\\)|") | ||
| 12228 | (replace-match "|\\2|\\1|"))) | ||
| 12229 | (beginning-of-line 2)) | ||
| 12230 | (move-marker end nil) | ||
| 12231 | (goto-line linepos) | ||
| 12232 | (org-table-goto-column colpos) | ||
| 12233 | (org-table-align) | ||
| 12234 | (org-table-modify-formulas 'swap col (if left (1- col) (1+ col))))) | ||
| 12235 | |||
| 12236 | (defun org-table-move-row-down () | ||
| 12237 | "Move table row down." | ||
| 12238 | (interactive) | ||
| 12239 | (org-table-move-row nil)) | ||
| 12240 | (defun org-table-move-row-up () | ||
| 12241 | "Move table row up." | ||
| 12242 | (interactive) | ||
| 12243 | (org-table-move-row 'up)) | ||
| 12244 | |||
| 12245 | (defun org-table-move-row (&optional up) | ||
| 12246 | "Move the current table line down. With arg UP, move it up." | ||
| 12247 | (interactive "P") | ||
| 12248 | (let ((col (current-column)) | ||
| 12249 | (pos (point)) | ||
| 12250 | (tonew (if up 0 2)) | ||
| 12251 | txt) | ||
| 12252 | (beginning-of-line tonew) | ||
| 12253 | (if (not (org-at-table-p)) | ||
| 12254 | (progn | ||
| 12255 | (goto-char pos) | ||
| 12256 | (error "Cannot move row further"))) | ||
| 12257 | (goto-char pos) | ||
| 12258 | (beginning-of-line 1) | ||
| 12259 | (setq pos (point)) | ||
| 12260 | (setq txt (buffer-substring (point) (1+ (point-at-eol)))) | ||
| 12261 | (delete-region (point) (1+ (point-at-eol))) | ||
| 12262 | (beginning-of-line tonew) | ||
| 12263 | (insert txt) | ||
| 12264 | (beginning-of-line 0) | ||
| 12265 | (move-to-column col))) | ||
| 12266 | 16088 | ||
| 12267 | (defun org-table-insert-row (&optional arg) | 16089 | (defun org-cdlatex-underscore-caret (&optional arg) |
| 12268 | "Insert a new row above the current line into the table. | 16090 | "Execute `cdlatex-sub-superscript' in LaTeX fragments. |
| 12269 | With prefix ARG, insert below the current line." | 16091 | Revert to the normal definition outside of these fragments." |
| 12270 | (interactive "P") | 16092 | (interactive "P") |
| 12271 | (if (not (org-at-table-p)) | 16093 | (if (org-inside-LaTeX-fragment-p) |
| 12272 | (error "Not at a table")) | 16094 | (call-interactively 'cdlatex-sub-superscript) |
| 12273 | (let* ((line (buffer-substring (point-at-bol) (point-at-eol))) | 16095 | (let (org-cdlatex-mode) |
| 12274 | (new (org-table-clean-line line))) | 16096 | (call-interactively (key-binding (vector last-input-event)))))) |
| 12275 | ;; Fix the first field if necessary | ||
| 12276 | (if (string-match "^[ \t]*| *[#$] *|" line) | ||
| 12277 | (setq new (replace-match (match-string 0 line) t t new))) | ||
| 12278 | (beginning-of-line (if arg 2 1)) | ||
| 12279 | (let (org-table-may-need-update) (insert-before-markers new "\n")) | ||
| 12280 | (beginning-of-line 0) | ||
| 12281 | (re-search-forward "| ?" (point-at-eol) t) | ||
| 12282 | (and org-table-may-need-update (org-table-align)))) | ||
| 12283 | 16097 | ||
| 12284 | (defun org-table-insert-hline (&optional arg) | 16098 | (defun org-cdlatex-math-modify (&optional arg) |
| 12285 | "Insert a horizontal-line below the current line into the table. | 16099 | "Execute `cdlatex-math-modify' in LaTeX fragments. |
| 12286 | With prefix ARG, insert above the current line." | 16100 | Revert to the normal definition outside of these fragments." |
| 12287 | (interactive "P") | 16101 | (interactive "P") |
| 12288 | (if (not (org-at-table-p)) | 16102 | (if (org-inside-LaTeX-fragment-p) |
| 12289 | (error "Not at a table")) | 16103 | (call-interactively 'cdlatex-math-modify) |
| 12290 | (let ((line (org-table-clean-line | 16104 | (let (org-cdlatex-mode) |
| 12291 | (buffer-substring (point-at-bol) (point-at-eol)))) | 16105 | (call-interactively (key-binding (vector last-input-event)))))) |
| 12292 | (col (current-column))) | ||
| 12293 | (while (string-match "|\\( +\\)|" line) | ||
| 12294 | (setq line (replace-match | ||
| 12295 | (concat "+" (make-string (- (match-end 1) (match-beginning 1)) | ||
| 12296 | ?-) "|") t t line))) | ||
| 12297 | (and (string-match "\\+" line) (setq line (replace-match "|" t t line))) | ||
| 12298 | (beginning-of-line (if arg 1 2)) | ||
| 12299 | (insert line "\n") | ||
| 12300 | (beginning-of-line (if arg 1 -1)) | ||
| 12301 | (move-to-column col))) | ||
| 12302 | |||
| 12303 | (defun org-table-clean-line (s) | ||
| 12304 | "Convert a table line S into a string with only \"|\" and space. | ||
| 12305 | In particular, this does handle wide and invisible characters." | ||
| 12306 | (if (string-match "^[ \t]*|-" s) | ||
| 12307 | ;; It's a hline, just map the characters | ||
| 12308 | (setq s (mapconcat (lambda (x) (if (member x '(?| ?+)) "|" " ")) s "")) | ||
| 12309 | (while (string-match "|\\([ \t]*?[^ \t\r\n|][^\r\n|]*\\)|" s) | ||
| 12310 | (setq s (replace-match | ||
| 12311 | (concat "|" (make-string (org-string-width (match-string 1 s)) | ||
| 12312 | ?\ ) "|") | ||
| 12313 | t t s))) | ||
| 12314 | s)) | ||
| 12315 | |||
| 12316 | (defun org-table-kill-row () | ||
| 12317 | "Delete the current row or horizontal line from the table." | ||
| 12318 | (interactive) | ||
| 12319 | (if (not (org-at-table-p)) | ||
| 12320 | (error "Not at a table")) | ||
| 12321 | (let ((col (current-column))) | ||
| 12322 | (kill-region (point-at-bol) (min (1+ (point-at-eol)) (point-max))) | ||
| 12323 | (if (not (org-at-table-p)) (beginning-of-line 0)) | ||
| 12324 | (move-to-column col))) | ||
| 12325 | |||
| 12326 | (defun org-table-sort-lines (beg end numericp) | ||
| 12327 | "Sort table lines in region. | ||
| 12328 | Point and mark define the first and last line to include. Both point and | ||
| 12329 | mark should be in the column that is used for sorting. For example, to | ||
| 12330 | sort according to column 3, put the mark in the first line to sort, in | ||
| 12331 | table column 3. Put point into the last line to be included in the sorting, | ||
| 12332 | also in table column 3. The command will prompt for the sorting method | ||
| 12333 | \(n for numerical, a for alphanumeric)." | ||
| 12334 | (interactive "r\nsSorting method: [n]=numeric [a]=alpha: ") | ||
| 12335 | (setq numericp (string-match "[nN]" numericp)) | ||
| 12336 | (org-table-align) ;; Just to be safe | ||
| 12337 | (let* (bcol ecol cmp column lns) | ||
| 12338 | (goto-char beg) | ||
| 12339 | (org-table-check-inside-data-field) | ||
| 12340 | (setq column (org-table-current-column) | ||
| 12341 | beg (move-marker (make-marker) (point-at-bol))) | ||
| 12342 | (goto-char end) | ||
| 12343 | (org-table-check-inside-data-field) | ||
| 12344 | (setq end (move-marker (make-marker) (1+ (point-at-eol)))) | ||
| 12345 | (untabify beg end) | ||
| 12346 | (goto-char beg) | ||
| 12347 | (org-table-goto-column column) | ||
| 12348 | (skip-chars-backward "^|") | ||
| 12349 | (setq bcol (current-column)) | ||
| 12350 | (org-table-goto-column (1+ column)) | ||
| 12351 | (skip-chars-backward "^|") | ||
| 12352 | (setq ecol (1- (current-column))) | ||
| 12353 | (setq cmp (if numericp | ||
| 12354 | (lambda (a b) (< (car a) (car b))) | ||
| 12355 | (lambda (a b) (string< (car a) (car b))))) | ||
| 12356 | (setq lns (mapcar (lambda(x) (cons (org-trim (substring x bcol ecol)) x)) | ||
| 12357 | (org-split-string (buffer-substring beg end) "\n"))) | ||
| 12358 | (if numericp | ||
| 12359 | (setq lns (mapcar (lambda(x) | ||
| 12360 | (cons (string-to-number (car x)) (cdr x))) | ||
| 12361 | lns))) | ||
| 12362 | (delete-region beg end) | ||
| 12363 | (move-marker beg nil) | ||
| 12364 | (move-marker end nil) | ||
| 12365 | (insert (mapconcat 'cdr (setq lns (sort lns cmp)) "\n") "\n") | ||
| 12366 | (message "%d lines sorted %s based on column %d" | ||
| 12367 | (length lns) | ||
| 12368 | (if numericp "numerically" "alphabetically") column))) | ||
| 12369 | |||
| 12370 | (defun org-table-cut-region (beg end) | ||
| 12371 | "Copy region in table to the clipboard and blank all relevant fields." | ||
| 12372 | (interactive "r") | ||
| 12373 | (org-table-copy-region beg end 'cut)) | ||
| 12374 | |||
| 12375 | (defun org-table-copy-region (beg end &optional cut) | ||
| 12376 | "Copy rectangular region in table to clipboard. | ||
| 12377 | A special clipboard is used which can only be accessed | ||
| 12378 | with `org-table-paste-rectangle'." | ||
| 12379 | (interactive "rP") | ||
| 12380 | (let* (l01 c01 l02 c02 l1 c1 l2 c2 ic1 ic2 | ||
| 12381 | region cols | ||
| 12382 | (rpl (if cut " " nil))) | ||
| 12383 | (goto-char beg) | ||
| 12384 | (org-table-check-inside-data-field) | ||
| 12385 | (setq l01 (org-current-line) | ||
| 12386 | c01 (org-table-current-column)) | ||
| 12387 | (goto-char end) | ||
| 12388 | (org-table-check-inside-data-field) | ||
| 12389 | (setq l02 (org-current-line) | ||
| 12390 | c02 (org-table-current-column)) | ||
| 12391 | (setq l1 (min l01 l02) l2 (max l01 l02) | ||
| 12392 | c1 (min c01 c02) c2 (max c01 c02)) | ||
| 12393 | (catch 'exit | ||
| 12394 | (while t | ||
| 12395 | (catch 'nextline | ||
| 12396 | (if (> l1 l2) (throw 'exit t)) | ||
| 12397 | (goto-line l1) | ||
| 12398 | (if (org-at-table-hline-p) (throw 'nextline (setq l1 (1+ l1)))) | ||
| 12399 | (setq cols nil ic1 c1 ic2 c2) | ||
| 12400 | (while (< ic1 (1+ ic2)) | ||
| 12401 | (push (org-table-get-field ic1 rpl) cols) | ||
| 12402 | (setq ic1 (1+ ic1))) | ||
| 12403 | (push (nreverse cols) region) | ||
| 12404 | (setq l1 (1+ l1))))) | ||
| 12405 | (setq org-table-clip (nreverse region)) | ||
| 12406 | (if cut (org-table-align)) | ||
| 12407 | org-table-clip)) | ||
| 12408 | |||
| 12409 | (defun org-table-paste-rectangle () | ||
| 12410 | "Paste a rectangular region into a table. | ||
| 12411 | The upper right corner ends up in the current field. All involved fields | ||
| 12412 | will be overwritten. If the rectangle does not fit into the present table, | ||
| 12413 | the table is enlarged as needed. The process ignores horizontal separator | ||
| 12414 | lines." | ||
| 12415 | (interactive) | ||
| 12416 | (unless (and org-table-clip (listp org-table-clip)) | ||
| 12417 | (error "First cut/copy a region to paste!")) | ||
| 12418 | (org-table-check-inside-data-field) | ||
| 12419 | (let* ((clip org-table-clip) | ||
| 12420 | (line (org-current-line)) | ||
| 12421 | (col (org-table-current-column)) | ||
| 12422 | (org-enable-table-editor t) | ||
| 12423 | (org-table-automatic-realign nil) | ||
| 12424 | c cols field) | ||
| 12425 | (while (setq cols (pop clip)) | ||
| 12426 | (while (org-at-table-hline-p) (beginning-of-line 2)) | ||
| 12427 | (if (not (org-at-table-p)) | ||
| 12428 | (progn (end-of-line 0) (org-table-next-field))) | ||
| 12429 | (setq c col) | ||
| 12430 | (while (setq field (pop cols)) | ||
| 12431 | (org-table-goto-column c nil 'force) | ||
| 12432 | (org-table-get-field nil field) | ||
| 12433 | (setq c (1+ c))) | ||
| 12434 | (beginning-of-line 2)) | ||
| 12435 | (goto-line line) | ||
| 12436 | (org-table-goto-column col) | ||
| 12437 | (org-table-align))) | ||
| 12438 | |||
| 12439 | (defun org-table-convert () | ||
| 12440 | "Convert from `org-mode' table to table.el and back. | ||
| 12441 | Obviously, this only works within limits. When an Org-mode table is | ||
| 12442 | converted to table.el, all horizontal separator lines get lost, because | ||
| 12443 | table.el uses these as cell boundaries and has no notion of horizontal lines. | ||
| 12444 | A table.el table can be converted to an Org-mode table only if it does not | ||
| 12445 | do row or column spanning. Multiline cells will become multiple cells. | ||
| 12446 | Beware, Org-mode does not test if the table can be successfully converted - it | ||
| 12447 | blindly applies a recipe that works for simple tables." | ||
| 12448 | (interactive) | ||
| 12449 | (require 'table) | ||
| 12450 | (if (org-at-table.el-p) | ||
| 12451 | ;; convert to Org-mode table | ||
| 12452 | (let ((beg (move-marker (make-marker) (org-table-begin t))) | ||
| 12453 | (end (move-marker (make-marker) (org-table-end t)))) | ||
| 12454 | (table-unrecognize-region beg end) | ||
| 12455 | (goto-char beg) | ||
| 12456 | (while (re-search-forward "^\\([ \t]*\\)\\+-.*\n" end t) | ||
| 12457 | (replace-match "")) | ||
| 12458 | (goto-char beg)) | ||
| 12459 | (if (org-at-table-p) | ||
| 12460 | ;; convert to table.el table | ||
| 12461 | (let ((beg (move-marker (make-marker) (org-table-begin))) | ||
| 12462 | (end (move-marker (make-marker) (org-table-end)))) | ||
| 12463 | ;; first, get rid of all horizontal lines | ||
| 12464 | (goto-char beg) | ||
| 12465 | (while (re-search-forward "^\\([ \t]*\\)|-.*\n" end t) | ||
| 12466 | (replace-match "")) | ||
| 12467 | ;; insert a hline before first | ||
| 12468 | (goto-char beg) | ||
| 12469 | (org-table-insert-hline 'above) | ||
| 12470 | (beginning-of-line -1) | ||
| 12471 | ;; insert a hline after each line | ||
| 12472 | (while (progn (beginning-of-line 3) (< (point) end)) | ||
| 12473 | (org-table-insert-hline)) | ||
| 12474 | (goto-char beg) | ||
| 12475 | (setq end (move-marker end (org-table-end))) | ||
| 12476 | ;; replace "+" at beginning and ending of hlines | ||
| 12477 | (while (re-search-forward "^\\([ \t]*\\)|-" end t) | ||
| 12478 | (replace-match "\\1+-")) | ||
| 12479 | (goto-char beg) | ||
| 12480 | (while (re-search-forward "-|[ \t]*$" end t) | ||
| 12481 | (replace-match "-+")) | ||
| 12482 | (goto-char beg))))) | ||
| 12483 | |||
| 12484 | (defun org-table-wrap-region (arg) | ||
| 12485 | "Wrap several fields in a column like a paragraph. | ||
| 12486 | This is useful if you'd like to spread the contents of a field over several | ||
| 12487 | lines, in order to keep the table compact. | ||
| 12488 | |||
| 12489 | If there is an active region, and both point and mark are in the same column, | ||
| 12490 | the text in the column is wrapped to minimum width for the given number of | ||
| 12491 | lines. Generally, this makes the table more compact. A prefix ARG may be | ||
| 12492 | used to change the number of desired lines. For example, `C-2 \\[org-table-wrap]' | ||
| 12493 | formats the selected text to two lines. If the region was longer than two | ||
| 12494 | lines, the remaining lines remain empty. A negative prefix argument reduces | ||
| 12495 | the current number of lines by that amount. The wrapped text is pasted back | ||
| 12496 | into the table. If you formatted it to more lines than it was before, fields | ||
| 12497 | further down in the table get overwritten - so you might need to make space in | ||
| 12498 | the table first. | ||
| 12499 | |||
| 12500 | If there is no region, the current field is split at the cursor position and | ||
| 12501 | the text fragment to the right of the cursor is prepended to the field one | ||
| 12502 | line down. | ||
| 12503 | 16106 | ||
| 12504 | If there is no region, but you specify a prefix ARG, the current field gets | 16107 | (defvar org-latex-fragment-image-overlays nil |
| 12505 | blank, and the content is appended to the field above." | 16108 | "List of overlays carrying the images of latex fragments.") |
| 12506 | (interactive "P") | 16109 | (make-variable-buffer-local 'org-latex-fragment-image-overlays) |
| 12507 | (org-table-check-inside-data-field) | ||
| 12508 | (if (org-region-active-p) | ||
| 12509 | ;; There is a region: fill as a paragraph | ||
| 12510 | (let ((beg (region-beginning)) | ||
| 12511 | nlines) | ||
| 12512 | (org-table-cut-region (region-beginning) (region-end)) | ||
| 12513 | (if (> (length (car org-table-clip)) 1) | ||
| 12514 | (error "Region must be limited to single column")) | ||
| 12515 | (setq nlines (if arg | ||
| 12516 | (if (< arg 1) | ||
| 12517 | (+ (length org-table-clip) arg) | ||
| 12518 | arg) | ||
| 12519 | (length org-table-clip))) | ||
| 12520 | (setq org-table-clip | ||
| 12521 | (mapcar 'list (org-wrap (mapconcat 'car org-table-clip " ") | ||
| 12522 | nil nlines))) | ||
| 12523 | (goto-char beg) | ||
| 12524 | (org-table-paste-rectangle)) | ||
| 12525 | ;; No region, split the current field at point | ||
| 12526 | (if arg | ||
| 12527 | ;; combine with field above | ||
| 12528 | (let ((s (org-table-blank-field)) | ||
| 12529 | (col (org-table-current-column))) | ||
| 12530 | (beginning-of-line 0) | ||
| 12531 | (while (org-at-table-hline-p) (beginning-of-line 0)) | ||
| 12532 | (org-table-goto-column col) | ||
| 12533 | (skip-chars-forward "^|") | ||
| 12534 | (skip-chars-backward " ") | ||
| 12535 | (insert " " (org-trim s)) | ||
| 12536 | (org-table-align)) | ||
| 12537 | ;; split field | ||
| 12538 | (when (looking-at "\\([^|]+\\)+|") | ||
| 12539 | (let ((s (match-string 1))) | ||
| 12540 | (replace-match " |") | ||
| 12541 | (goto-char (match-beginning 0)) | ||
| 12542 | (org-table-next-row) | ||
| 12543 | (insert (org-trim s) " ") | ||
| 12544 | (org-table-align)))))) | ||
| 12545 | 16110 | ||
| 12546 | (defvar org-field-marker nil) | 16111 | (defun org-remove-latex-fragment-image-overlays () |
| 16112 | "Remove all overlays with LaTeX fragment images in current buffer." | ||
| 16113 | (mapc 'org-delete-overlay org-latex-fragment-image-overlays) | ||
| 16114 | (setq org-latex-fragment-image-overlays nil)) | ||
| 12547 | 16115 | ||
| 12548 | (defun org-table-edit-field (arg) | 16116 | (defun org-preview-latex-fragment (&optional subtree) |
| 12549 | "Edit table field in a different window. | 16117 | "Preview the LaTeX fragment at point, or all locally or globally. |
| 12550 | This is mainly useful for fields that contain hidden parts. | 16118 | If the cursor is in a LaTeX fragment, create the image and overlay |
| 12551 | When called with a \\[universal-argument] prefix, just make the full field visible so that | 16119 | it over the source code. If there is no fragment at point, display |
| 12552 | it can be edited in place." | 16120 | all fragments in the current text, from one headline to the next. With |
| 16121 | prefix SUBTREE, display all fragments in the current subtree. With a | ||
| 16122 | double prefix `C-u C-u', or when the cursor is before the first headline, | ||
| 16123 | display all fragments in the buffer. | ||
| 16124 | The images can be removed again with \\[org-ctrl-c-ctrl-c]." | ||
| 12553 | (interactive "P") | 16125 | (interactive "P") |
| 12554 | (if arg | 16126 | (org-remove-latex-fragment-image-overlays) |
| 12555 | (let ((b (save-excursion (skip-chars-backward "^|") (point))) | ||
| 12556 | (e (save-excursion (skip-chars-forward "^|\r\n") (point)))) | ||
| 12557 | (remove-text-properties b e '(org-cwidth t invisible t | ||
| 12558 | display t intangible t)) | ||
| 12559 | (if (and (boundp 'font-lock-mode) font-lock-mode) | ||
| 12560 | (font-lock-fontify-block))) | ||
| 12561 | (let ((pos (move-marker (make-marker) (point))) | ||
| 12562 | (field (org-table-get-field)) | ||
| 12563 | (cw (current-window-configuration)) | ||
| 12564 | p) | ||
| 12565 | (switch-to-buffer-other-window "*Org tmp*") | ||
| 12566 | (erase-buffer) | ||
| 12567 | (insert "#\n# Edit field and finish with C-c C-c\n#\n") | ||
| 12568 | (org-mode) | ||
| 12569 | (goto-char (setq p (point-max))) | ||
| 12570 | (insert (org-trim field)) | ||
| 12571 | (remove-text-properties p (point-max) | ||
| 12572 | '(invisible t org-cwidth t display t | ||
| 12573 | intangible t)) | ||
| 12574 | (goto-char p) | ||
| 12575 | (org-set-local 'org-finish-function | ||
| 12576 | 'org-table-finish-edit-field) | ||
| 12577 | (org-set-local 'org-window-configuration cw) | ||
| 12578 | (org-set-local 'org-field-marker pos) | ||
| 12579 | (message "Edit and finish with C-c C-c")))) | ||
| 12580 | |||
| 12581 | (defun org-table-finish-edit-field () | ||
| 12582 | "Finish editing a table data field. | ||
| 12583 | Remove all newline characters, insert the result into the table, realign | ||
| 12584 | the table and kill the editing buffer." | ||
| 12585 | (let ((pos org-field-marker) | ||
| 12586 | (cw org-window-configuration) | ||
| 12587 | (cb (current-buffer)) | ||
| 12588 | text) | ||
| 12589 | (goto-char (point-min)) | ||
| 12590 | (while (re-search-forward "^#.*\n?" nil t) (replace-match "")) | ||
| 12591 | (while (re-search-forward "\\([ \t]*\n[ \t]*\\)+" nil t) | ||
| 12592 | (replace-match " ")) | ||
| 12593 | (setq text (org-trim (buffer-string))) | ||
| 12594 | (set-window-configuration cw) | ||
| 12595 | (kill-buffer cb) | ||
| 12596 | (select-window (get-buffer-window (marker-buffer pos))) | ||
| 12597 | (goto-char pos) | ||
| 12598 | (move-marker pos nil) | ||
| 12599 | (org-table-check-inside-data-field) | ||
| 12600 | (org-table-get-field nil text) | ||
| 12601 | (org-table-align) | ||
| 12602 | (message "New field value inserted"))) | ||
| 12603 | |||
| 12604 | (defun org-trim (s) | ||
| 12605 | "Remove whitespace at beginning and end of string." | ||
| 12606 | (if (string-match "^[ \t]+" s) (setq s (replace-match "" t t s))) | ||
| 12607 | (if (string-match "[ \t]+$" s) (setq s (replace-match "" t t s))) | ||
| 12608 | s) | ||
| 12609 | |||
| 12610 | (defun org-wrap (string &optional width lines) | ||
| 12611 | "Wrap string to either a number of lines, or a width in characters. | ||
| 12612 | If WIDTH is non-nil, the string is wrapped to that width, however many lines | ||
| 12613 | that costs. If there is a word longer than WIDTH, the text is actually | ||
| 12614 | wrapped to the length of that word. | ||
| 12615 | IF WIDTH is nil and LINES is non-nil, the string is forced into at most that | ||
| 12616 | many lines, whatever width that takes. | ||
| 12617 | The return value is a list of lines, without newlines at the end." | ||
| 12618 | (let* ((words (org-split-string string "[ \t\n]+")) | ||
| 12619 | (maxword (apply 'max (mapcar 'org-string-width words))) | ||
| 12620 | w ll) | ||
| 12621 | (cond (width | ||
| 12622 | (org-do-wrap words (max maxword width))) | ||
| 12623 | (lines | ||
| 12624 | (setq w maxword) | ||
| 12625 | (setq ll (org-do-wrap words maxword)) | ||
| 12626 | (if (<= (length ll) lines) | ||
| 12627 | ll | ||
| 12628 | (setq ll words) | ||
| 12629 | (while (> (length ll) lines) | ||
| 12630 | (setq w (1+ w)) | ||
| 12631 | (setq ll (org-do-wrap words w))) | ||
| 12632 | ll)) | ||
| 12633 | (t (error "Cannot wrap this"))))) | ||
| 12634 | |||
| 12635 | |||
| 12636 | (defun org-do-wrap (words width) | ||
| 12637 | "Create lines of maximum width WIDTH (in characters) from word list WORDS." | ||
| 12638 | (let (lines line) | ||
| 12639 | (while words | ||
| 12640 | (setq line (pop words)) | ||
| 12641 | (while (and words (< (+ (length line) (length (car words))) width)) | ||
| 12642 | (setq line (concat line " " (pop words)))) | ||
| 12643 | (setq lines (push line lines))) | ||
| 12644 | (nreverse lines))) | ||
| 12645 | |||
| 12646 | (defun org-split-string (string &optional separators) | ||
| 12647 | "Splits STRING into substrings at SEPARATORS. | ||
| 12648 | No empty strings are returned if there are matches at the beginning | ||
| 12649 | and end of string." | ||
| 12650 | (let ((rexp (or separators "[ \f\t\n\r\v]+")) | ||
| 12651 | (start 0) | ||
| 12652 | notfirst | ||
| 12653 | (list nil)) | ||
| 12654 | (while (and (string-match rexp string | ||
| 12655 | (if (and notfirst | ||
| 12656 | (= start (match-beginning 0)) | ||
| 12657 | (< start (length string))) | ||
| 12658 | (1+ start) start)) | ||
| 12659 | (< (match-beginning 0) (length string))) | ||
| 12660 | (setq notfirst t) | ||
| 12661 | (or (eq (match-beginning 0) 0) | ||
| 12662 | (and (eq (match-beginning 0) (match-end 0)) | ||
| 12663 | (eq (match-beginning 0) start)) | ||
| 12664 | (setq list | ||
| 12665 | (cons (substring string start (match-beginning 0)) | ||
| 12666 | list))) | ||
| 12667 | (setq start (match-end 0))) | ||
| 12668 | (or (eq start (length string)) | ||
| 12669 | (setq list | ||
| 12670 | (cons (substring string start) | ||
| 12671 | list))) | ||
| 12672 | (nreverse list))) | ||
| 12673 | |||
| 12674 | (defun org-table-map-tables (function) | ||
| 12675 | "Apply FUNCTION to the start of all tables in the buffer." | ||
| 12676 | (save-excursion | 16127 | (save-excursion |
| 12677 | (save-restriction | 16128 | (save-restriction |
| 12678 | (widen) | 16129 | (let (beg end at msg) |
| 12679 | (goto-char (point-min)) | 16130 | (cond |
| 12680 | (while (re-search-forward org-table-any-line-regexp nil t) | 16131 | ((or (equal subtree '(16)) |
| 12681 | (message "Mapping tables: %d%%" (/ (* 100.0 (point)) (buffer-size))) | 16132 | (not (save-excursion |
| 12682 | (beginning-of-line 1) | 16133 | (re-search-backward (concat "^" outline-regexp) nil t)))) |
| 12683 | (if (looking-at org-table-line-regexp) | 16134 | (setq beg (point-min) end (point-max) |
| 12684 | (save-excursion (funcall function))) | 16135 | msg "Creating images for buffer...%s")) |
| 12685 | (re-search-forward org-table-any-border-regexp nil 1)))) | 16136 | ((equal subtree '(4)) |
| 12686 | (message "Mapping tables: done")) | 16137 | (org-back-to-heading) |
| 12687 | 16138 | (setq beg (point) end (org-end-of-subtree t) | |
| 12688 | (defun org-table-sum (&optional beg end nlast) | 16139 | msg "Creating images for subtree...%s")) |
| 12689 | "Sum numbers in region of current table column. | 16140 | (t |
| 12690 | The result will be displayed in the echo area, and will be available | 16141 | (if (setq at (org-inside-LaTeX-fragment-p)) |
| 12691 | as kill to be inserted with \\[yank]. | 16142 | (goto-char (max (point-min) (- (cdr at) 2))) |
| 12692 | 16143 | (org-back-to-heading)) | |
| 12693 | If there is an active region, it is interpreted as a rectangle and all | 16144 | (setq beg (point) end (progn (outline-next-heading) (point)) |
| 12694 | numbers in that rectangle will be summed. If there is no active | 16145 | msg (if at "Creating image...%s" |
| 12695 | region and point is located in a table column, sum all numbers in that | 16146 | "Creating images for entry...%s")))) |
| 12696 | column. | 16147 | (message msg "") |
| 12697 | 16148 | (narrow-to-region beg end) | |
| 12698 | If at least one number looks like a time HH:MM or HH:MM:SS, all other | 16149 | (org-format-latex |
| 12699 | numbers are assumed to be times as well (in decimal hours) and the | 16150 | (concat "ltxpng/" (file-name-sans-extension |
| 12700 | numbers are added as such. | 16151 | (file-name-nondirectory |
| 12701 | 16152 | buffer-file-name))) | |
| 12702 | If NLAST is a number, only the NLAST fields will actually be summed." | 16153 | default-directory 'overlays msg at) |
| 12703 | (interactive) | 16154 | (message msg "done. Use `C-c C-c' to remove images."))))) |
| 12704 | (save-excursion | ||
| 12705 | (let (col (timecnt 0) diff h m s org-table-clip) | ||
| 12706 | (cond | ||
| 12707 | ((and beg end)) ; beg and end given explicitly | ||
| 12708 | ((org-region-active-p) | ||
| 12709 | (setq beg (region-beginning) end (region-end))) | ||
| 12710 | (t | ||
| 12711 | (setq col (org-table-current-column)) | ||
| 12712 | (goto-char (org-table-begin)) | ||
| 12713 | (unless (re-search-forward "^[ \t]*|[^-]" nil t) | ||
| 12714 | (error "No table data")) | ||
| 12715 | (org-table-goto-column col) | ||
| 12716 | ;not needed? (skip-chars-backward "^|") | ||
| 12717 | (setq beg (point)) | ||
| 12718 | (goto-char (org-table-end)) | ||
| 12719 | (unless (re-search-backward "^[ \t]*|[^-]" nil t) | ||
| 12720 | (error "No table data")) | ||
| 12721 | (org-table-goto-column col) | ||
| 12722 | ;not needed? (skip-chars-forward "^|") | ||
| 12723 | (setq end (point)))) | ||
| 12724 | (let* ((items (apply 'append (org-table-copy-region beg end))) | ||
| 12725 | (items1 (cond ((not nlast) items) | ||
| 12726 | ((>= nlast (length items)) items) | ||
| 12727 | (t (setq items (reverse items)) | ||
| 12728 | (setcdr (nthcdr (1- nlast) items) nil) | ||
| 12729 | (nreverse items)))) | ||
| 12730 | (numbers (delq nil (mapcar 'org-table-get-number-for-summing | ||
| 12731 | items1))) | ||
| 12732 | (res (apply '+ numbers)) | ||
| 12733 | (sres (if (= timecnt 0) | ||
| 12734 | (format "%g" res) | ||
| 12735 | (setq diff (* 3600 res) | ||
| 12736 | h (floor (/ diff 3600)) diff (mod diff 3600) | ||
| 12737 | m (floor (/ diff 60)) diff (mod diff 60) | ||
| 12738 | s diff) | ||
| 12739 | (format "%d:%02d:%02d" h m s)))) | ||
| 12740 | (kill-new sres) | ||
| 12741 | (if (interactive-p) | ||
| 12742 | (message "%s" | ||
| 12743 | (substitute-command-keys | ||
| 12744 | (format "Sum of %d items: %-20s (\\[yank] will insert result into buffer)" | ||
| 12745 | (length numbers) sres)))) | ||
| 12746 | sres)))) | ||
| 12747 | |||
| 12748 | (defun org-table-get-number-for-summing (s) | ||
| 12749 | (let (n) | ||
| 12750 | (if (string-match "^ *|? *" s) | ||
| 12751 | (setq s (replace-match "" nil nil s))) | ||
| 12752 | (if (string-match " *|? *$" s) | ||
| 12753 | (setq s (replace-match "" nil nil s))) | ||
| 12754 | (setq n (string-to-number s)) | ||
| 12755 | (cond | ||
| 12756 | ((and (string-match "0" s) | ||
| 12757 | (string-match "\\`[-+ \t0.edED]+\\'" s)) 0) | ||
| 12758 | ((string-match "\\`[ \t]+\\'" s) nil) | ||
| 12759 | ((string-match "\\`\\([0-9]+\\):\\([0-9]+\\)\\(:\\([0-9]+\\)\\)?\\'" s) | ||
| 12760 | (let ((h (string-to-number (or (match-string 1 s) "0"))) | ||
| 12761 | (m (string-to-number (or (match-string 2 s) "0"))) | ||
| 12762 | (s (string-to-number (or (match-string 4 s) "0")))) | ||
| 12763 | (if (boundp 'timecnt) (setq timecnt (1+ timecnt))) | ||
| 12764 | (* 1.0 (+ h (/ m 60.0) (/ s 3600.0))))) | ||
| 12765 | ((equal n 0) nil) | ||
| 12766 | (t n)))) | ||
| 12767 | |||
| 12768 | (defun org-table-get-vertical-vector (desc &optional tbeg col) | ||
| 12769 | "Get a calc vector from a column, accorting to descriptor DESC. | ||
| 12770 | Optional arguments TBEG and COL can give the beginning of the table and | ||
| 12771 | the current column, to avoid unnecessary parsing." | ||
| 12772 | (save-excursion | ||
| 12773 | (or tbeg (setq tbeg (org-table-begin))) | ||
| 12774 | (or col (setq col (org-table-current-column))) | ||
| 12775 | (let (beg end nn n n1 n2 l (thisline (org-current-line)) hline-list) | ||
| 12776 | (cond | ||
| 12777 | ((string-match "\\(I+\\)\\(-\\(I+\\)\\)?" desc) | ||
| 12778 | (setq n1 (- (match-end 1) (match-beginning 1))) | ||
| 12779 | (if (match-beginning 3) | ||
| 12780 | (setq n2 (- (match-end 2) (match-beginning 3)))) | ||
| 12781 | (setq n (if n2 (max n1 n2) n1)) | ||
| 12782 | (setq n1 (if n2 (min n1 n2))) | ||
| 12783 | (setq nn n) | ||
| 12784 | (while (and (> nn 0) | ||
| 12785 | (re-search-backward org-table-hline-regexp tbeg t)) | ||
| 12786 | (push (org-current-line) hline-list) | ||
| 12787 | (setq nn (1- nn))) | ||
| 12788 | (setq hline-list (nreverse hline-list)) | ||
| 12789 | (goto-line (nth (1- n) hline-list)) | ||
| 12790 | (when (re-search-forward org-table-dataline-regexp) | ||
| 12791 | (org-table-goto-column col) | ||
| 12792 | (setq beg (point))) | ||
| 12793 | (goto-line (if n1 (nth (1- n1) hline-list) thisline)) | ||
| 12794 | (when (re-search-backward org-table-dataline-regexp) | ||
| 12795 | (org-table-goto-column col) | ||
| 12796 | (setq end (point))) | ||
| 12797 | (setq l (apply 'append (org-table-copy-region beg end))) | ||
| 12798 | (concat "[" (mapconcat (lambda (x) (setq x (org-trim x)) | ||
| 12799 | (if (equal x "") "0" x)) | ||
| 12800 | l ",") "]")) | ||
| 12801 | ((string-match "\\([0-9]+\\)-\\([0-9]+\\)" desc) | ||
| 12802 | (setq n1 (string-to-number (match-string 1 desc)) | ||
| 12803 | n2 (string-to-number (match-string 2 desc))) | ||
| 12804 | (beginning-of-line 1) | ||
| 12805 | (save-excursion | ||
| 12806 | (when (re-search-backward org-table-dataline-regexp tbeg t n1) | ||
| 12807 | (org-table-goto-column col) | ||
| 12808 | (setq beg (point)))) | ||
| 12809 | (when (re-search-backward org-table-dataline-regexp tbeg t n2) | ||
| 12810 | (org-table-goto-column col) | ||
| 12811 | (setq end (point))) | ||
| 12812 | (setq l (apply 'append (org-table-copy-region beg end))) | ||
| 12813 | (concat "[" (mapconcat | ||
| 12814 | (lambda (x) (setq x (org-trim x)) | ||
| 12815 | (if (equal x "") "0" x)) | ||
| 12816 | l ",") "]")) | ||
| 12817 | ((string-match "\\([0-9]+\\)" desc) | ||
| 12818 | (beginning-of-line 1) | ||
| 12819 | (when (re-search-backward org-table-dataline-regexp tbeg t | ||
| 12820 | (string-to-number (match-string 0 desc))) | ||
| 12821 | (org-table-goto-column col) | ||
| 12822 | (org-trim (org-table-get-field)))))))) | ||
| 12823 | |||
| 12824 | (defvar org-table-formula-history nil) | ||
| 12825 | |||
| 12826 | (defvar org-table-column-names nil | ||
| 12827 | "Alist with column names, derived from the `!' line.") | ||
| 12828 | (defvar org-table-column-name-regexp nil | ||
| 12829 | "Regular expression matching the current column names.") | ||
| 12830 | (defvar org-table-local-parameters nil | ||
| 12831 | "Alist with parameter names, derived from the `$' line.") | ||
| 12832 | (defvar org-table-named-field-locations nil | ||
| 12833 | "Alist with locations of named fields.") | ||
| 12834 | |||
| 12835 | (defun org-table-get-formula (&optional equation named) | ||
| 12836 | "Read a formula from the minibuffer, offer stored formula as default." | ||
| 12837 | (let* ((name (car (rassoc (list (org-current-line) | ||
| 12838 | (org-table-current-column)) | ||
| 12839 | org-table-named-field-locations))) | ||
| 12840 | (scol (if named | ||
| 12841 | (if name name | ||
| 12842 | (error "Not in a named field")) | ||
| 12843 | (int-to-string (org-table-current-column)))) | ||
| 12844 | (dummy (and name (not named) | ||
| 12845 | (not (y-or-n-p "Replace named-field formula with column equation? " )) | ||
| 12846 | (error "Abort"))) | ||
| 12847 | (org-table-may-need-update nil) | ||
| 12848 | (stored-list (org-table-get-stored-formulas)) | ||
| 12849 | (stored (cdr (assoc scol stored-list))) | ||
| 12850 | (eq (cond | ||
| 12851 | ((and stored equation (string-match "^ *=? *$" equation)) | ||
| 12852 | stored) | ||
| 12853 | ((stringp equation) | ||
| 12854 | equation) | ||
| 12855 | (t (read-string | ||
| 12856 | (format "%s formula $%s=" (if named "Field" "Column") scol) | ||
| 12857 | (or stored "") 'org-table-formula-history | ||
| 12858 | ;stored | ||
| 12859 | )))) | ||
| 12860 | mustsave) | ||
| 12861 | (when (not (string-match "\\S-" eq)) | ||
| 12862 | ;; remove formula | ||
| 12863 | (setq stored-list (delq (assoc scol stored-list) stored-list)) | ||
| 12864 | (org-table-store-formulas stored-list) | ||
| 12865 | (error "Formula removed")) | ||
| 12866 | (if (string-match "^ *=?" eq) (setq eq (replace-match "" t t eq))) | ||
| 12867 | (if (string-match " *$" eq) (setq eq (replace-match "" t t eq))) | ||
| 12868 | (if (and name (not named)) | ||
| 12869 | ;; We set the column equation, delete the named one. | ||
| 12870 | (setq stored-list (delq (assoc name stored-list) stored-list) | ||
| 12871 | mustsave t)) | ||
| 12872 | (if stored | ||
| 12873 | (setcdr (assoc scol stored-list) eq) | ||
| 12874 | (setq stored-list (cons (cons scol eq) stored-list))) | ||
| 12875 | (if (or mustsave (not (equal stored eq))) | ||
| 12876 | (org-table-store-formulas stored-list)) | ||
| 12877 | eq)) | ||
| 12878 | |||
| 12879 | (defun org-table-store-formulas (alist) | ||
| 12880 | "Store the list of formulas below the current table." | ||
| 12881 | (setq alist (sort alist (lambda (a b) (string< (car a) (car b))))) | ||
| 12882 | (save-excursion | ||
| 12883 | (goto-char (org-table-end)) | ||
| 12884 | (if (looking-at "\\([ \t]*\n\\)*#\\+TBLFM:.*\n?") | ||
| 12885 | (delete-region (point) (match-end 0))) | ||
| 12886 | (insert "#+TBLFM: " | ||
| 12887 | (mapconcat (lambda (x) | ||
| 12888 | (concat "$" (car x) "=" (cdr x))) | ||
| 12889 | alist "::") | ||
| 12890 | "\n"))) | ||
| 12891 | |||
| 12892 | (defun org-table-get-stored-formulas () | ||
| 12893 | "Return an alist with the stored formulas directly after current table." | ||
| 12894 | (interactive) | ||
| 12895 | (let (scol eq eq-alist strings string seen) | ||
| 12896 | (save-excursion | ||
| 12897 | (goto-char (org-table-end)) | ||
| 12898 | (when (looking-at "\\([ \t]*\n\\)*#\\+TBLFM: *\\(.*\\)") | ||
| 12899 | (setq strings (org-split-string (match-string 2) " *:: *")) | ||
| 12900 | (while (setq string (pop strings)) | ||
| 12901 | (when (string-match "\\$\\([a-zA-Z0-9]+\\) *= *\\(.*[^ \t]\\)" string) | ||
| 12902 | (setq scol (match-string 1 string) | ||
| 12903 | eq (match-string 2 string) | ||
| 12904 | eq-alist (cons (cons scol eq) eq-alist)) | ||
| 12905 | (if (member scol seen) | ||
| 12906 | (error "Double definition `$%s=' in TBLFM line, please fix by hand" scol) | ||
| 12907 | (push scol seen)))))) | ||
| 12908 | (nreverse eq-alist))) | ||
| 12909 | |||
| 12910 | (defun org-table-modify-formulas (action &rest columns) | ||
| 12911 | "Modify the formulas stored below the current table. | ||
| 12912 | ACTION can be `remove', `insert', `swap'. For `swap', two column numbers are | ||
| 12913 | expected, for the other actions only a single column number is needed." | ||
| 12914 | (let ((list (org-table-get-stored-formulas)) | ||
| 12915 | (nmax (length (org-split-string | ||
| 12916 | (buffer-substring (point-at-bol) (point-at-eol)) | ||
| 12917 | "|"))) | ||
| 12918 | col col1 col2 scol si sc1 sc2) | ||
| 12919 | (cond | ||
| 12920 | ((null list)) ; No action needed if there are no stored formulas | ||
| 12921 | ((eq action 'remove) | ||
| 12922 | (setq col (car columns) | ||
| 12923 | scol (int-to-string col)) | ||
| 12924 | (org-table-replace-in-formulas list scol "INVALID") | ||
| 12925 | (if (assoc scol list) (setq list (delq (assoc scol list) list))) | ||
| 12926 | (loop for i from (1+ col) upto nmax by 1 do | ||
| 12927 | (setq si (int-to-string i)) | ||
| 12928 | (org-table-replace-in-formulas list si (int-to-string (1- i))) | ||
| 12929 | (if (assoc si list) (setcar (assoc si list) | ||
| 12930 | (int-to-string (1- i)))))) | ||
| 12931 | ((eq action 'insert) | ||
| 12932 | (setq col (car columns)) | ||
| 12933 | (loop for i from nmax downto col by 1 do | ||
| 12934 | (setq si (int-to-string i)) | ||
| 12935 | (org-table-replace-in-formulas list si (int-to-string (1+ i))) | ||
| 12936 | (if (assoc si list) (setcar (assoc si list) | ||
| 12937 | (int-to-string (1+ i)))))) | ||
| 12938 | ((eq action 'swap) | ||
| 12939 | (setq col1 (car columns) col2 (nth 1 columns) | ||
| 12940 | sc1 (int-to-string col1) sc2 (int-to-string col2)) | ||
| 12941 | ;; Hopefully, ZqZtZ will never be a name in a table | ||
| 12942 | (org-table-replace-in-formulas list sc1 "ZqZtZ") | ||
| 12943 | (org-table-replace-in-formulas list sc2 sc1) | ||
| 12944 | (org-table-replace-in-formulas list "ZqZtZ" sc2) | ||
| 12945 | (if (assoc sc1 list) (setcar (assoc sc1 list) "ZqZtZ")) | ||
| 12946 | (if (assoc sc2 list) (setcar (assoc sc2 list) sc1)) | ||
| 12947 | (if (assoc "ZqZtZ" list) (setcar (assoc "ZqZtZ" list) sc2))) | ||
| 12948 | (t (error "Invalid action in `org-table-modify-formulas'"))) | ||
| 12949 | (if list (org-table-store-formulas list)))) | ||
| 12950 | |||
| 12951 | (defun org-table-replace-in-formulas (list s1 s2) | ||
| 12952 | (let (elt re s) | ||
| 12953 | (setq s1 (concat "$" (if (integerp s1) (int-to-string s1) s1)) | ||
| 12954 | s2 (concat "$" (if (integerp s2) (int-to-string s2) s2)) | ||
| 12955 | re (concat (regexp-quote s1) "\\>")) | ||
| 12956 | (while (setq elt (pop list)) | ||
| 12957 | (setq s (cdr elt)) | ||
| 12958 | (while (string-match re s) | ||
| 12959 | (setq s (replace-match s2 t t s))) | ||
| 12960 | (setcdr elt s)))) | ||
| 12961 | |||
| 12962 | (defun org-table-get-specials () | ||
| 12963 | "Get the column names and local parameters for this table." | ||
| 12964 | (save-excursion | ||
| 12965 | (let ((beg (org-table-begin)) (end (org-table-end)) | ||
| 12966 | names name fields fields1 field cnt c v line col) | ||
| 12967 | (setq org-table-column-names nil | ||
| 12968 | org-table-local-parameters nil | ||
| 12969 | org-table-named-field-locations nil) | ||
| 12970 | (goto-char beg) | ||
| 12971 | (when (re-search-forward "^[ \t]*| *! *\\(|.*\\)" end t) | ||
| 12972 | (setq names (org-split-string (match-string 1) " *| *") | ||
| 12973 | cnt 1) | ||
| 12974 | (while (setq name (pop names)) | ||
| 12975 | (setq cnt (1+ cnt)) | ||
| 12976 | (if (string-match "^[a-zA-Z][a-zA-Z0-9]*$" name) | ||
| 12977 | (push (cons name (int-to-string cnt)) org-table-column-names)))) | ||
| 12978 | (setq org-table-column-names (nreverse org-table-column-names)) | ||
| 12979 | (setq org-table-column-name-regexp | ||
| 12980 | (concat "\\$\\(" (mapconcat 'car org-table-column-names "\\|") "\\)\\>")) | ||
| 12981 | (goto-char beg) | ||
| 12982 | (while (re-search-forward "^[ \t]*| *\\$ *\\(|.*\\)" end t) | ||
| 12983 | (setq fields (org-split-string (match-string 1) " *| *")) | ||
| 12984 | (while (setq field (pop fields)) | ||
| 12985 | (if (string-match "^\\([a-zA-Z][a-zA-Z0-9]*\\|%\\) *= *\\(.*\\)" field) | ||
| 12986 | (push (cons (match-string 1 field) (match-string 2 field)) | ||
| 12987 | org-table-local-parameters)))) | ||
| 12988 | (goto-char beg) | ||
| 12989 | (while (re-search-forward "^[ \t]*| *\\([_^]\\) *\\(|.*\\)" end t) | ||
| 12990 | (setq c (match-string 1) | ||
| 12991 | fields (org-split-string (match-string 2) " *| *")) | ||
| 12992 | (save-excursion | ||
| 12993 | (beginning-of-line (if (equal c "_") 2 0)) | ||
| 12994 | (setq line (org-current-line) col 1) | ||
| 12995 | (and (looking-at "^[ \t]*|[^|]*\\(|.*\\)") | ||
| 12996 | (setq fields1 (org-split-string (match-string 1) " *| *")))) | ||
| 12997 | (while (and fields1 (setq field (pop fields))) | ||
| 12998 | (setq v (pop fields1) col (1+ col)) | ||
| 12999 | (when (and (stringp field) (stringp v) | ||
| 13000 | (string-match "^[a-zA-Z][a-zA-Z0-9]*$" field)) | ||
| 13001 | (push (cons field v) org-table-local-parameters) | ||
| 13002 | (push (list field line col) org-table-named-field-locations))))))) | ||
| 13003 | |||
| 13004 | (defun org-this-word () | ||
| 13005 | ;; Get the current word | ||
| 13006 | (save-excursion | ||
| 13007 | (let ((beg (progn (skip-chars-backward "^ \t\n") (point))) | ||
| 13008 | (end (progn (skip-chars-forward "^ \t\n") (point)))) | ||
| 13009 | (buffer-substring-no-properties beg end)))) | ||
| 13010 | |||
| 13011 | (defun org-table-maybe-eval-formula () | ||
| 13012 | "Check if the current field starts with \"=\" or \":=\". | ||
| 13013 | If yes, store the formula and apply it." | ||
| 13014 | ;; We already know we are in a table. Get field will only return a formula | ||
| 13015 | ;; when appropriate. It might return a separator line, but no problem. | ||
| 13016 | (when org-table-formula-evaluate-inline | ||
| 13017 | (let* ((field (org-trim (or (org-table-get-field) ""))) | ||
| 13018 | named eq) | ||
| 13019 | (when (string-match "^:?=\\(.*\\)" field) | ||
| 13020 | (setq named (equal (string-to-char field) ?:) | ||
| 13021 | eq (match-string 1 field)) | ||
| 13022 | (if (fboundp 'calc-eval) | ||
| 13023 | (org-table-eval-formula (if named '(4) nil) eq)))))) | ||
| 13024 | |||
| 13025 | (defvar org-recalc-commands nil | ||
| 13026 | "List of commands triggering the recalculation of a line. | ||
| 13027 | Will be filled automatically during use.") | ||
| 13028 | 16155 | ||
| 13029 | (defvar org-recalc-marks | 16156 | (defvar org-latex-regexps |
| 13030 | '((" " . "Unmarked: no special line, no automatic recalculation") | 16157 | '(("begin" "^[ \t]*\\(\\\\begin{\\([a-zA-Z0-9\\*]+\\)[^\000]+?\\\\end{\\2}\\)" 1 t) |
| 13031 | ("#" . "Automatically recalculate this line upon TAB, RET, and C-c C-c in the line") | 16158 | ;; ("$" "\\([ (]\\|^\\)\\(\\(\\([$]\\)\\([^ \r\n,.$].*?\\(\n.*?\\)\\{0,5\\}[^ \r\n,.$]\\)\\4\\)\\)\\([ .,?;:'\")]\\|$\\)" 2 nil) |
| 13032 | ("*" . "Recalculate only when entire table is recalculated with `C-u C-c *'") | 16159 | ;; \000 in the following regex is needed for org-inside-LaTeX-fragment-p |
| 13033 | ("!" . "Column name definition line. Reference in formula as $name.") | 16160 | ("$" "\\([^$]\\)\\(\\(\\$\\([^ \r\n,;.$][^$\n\r]*?\\(\n[^$\n\r]*?\\)\\{0,2\\}[^ \r\n,.$]\\)\\$\\)\\)\\([ .,?;:'\")\000]\\|$\\)" 2 nil) |
| 13034 | ("$" . "Parameter definition line name=value. Reference in formula as $name.") | 16161 | ("\\(" "\\\\([^\000]*?\\\\)" 0 nil) |
| 13035 | ("_" . "Names for values in row below this one.") | 16162 | ("\\[" "\\\\\\[[^\000]*?\\\\\\]" 0 t) |
| 13036 | ("^" . "Names for values in row above this one."))) | 16163 | ("$$" "\\$\\$[^\000]*?\\$\\$" 0 t)) |
| 16164 | "Regular expressions for matching embedded LaTeX.") | ||
| 13037 | 16165 | ||
| 13038 | (defun org-table-rotate-recalc-marks (&optional newchar) | 16166 | (defun org-format-latex (prefix &optional dir overlays msg at) |
| 13039 | "Rotate the recalculation mark in the first column. | 16167 | "Replace LaTeX fragments with links to an image, and produce images." |
| 13040 | If in any row, the first field is not consistent with a mark, | 16168 | (if (and overlays (fboundp 'clear-image-cache)) (clear-image-cache)) |
| 13041 | insert a new column for the markers. | 16169 | (let* ((prefixnodir (file-name-nondirectory prefix)) |
| 13042 | When there is an active region, change all the lines in the region, | 16170 | (absprefix (expand-file-name prefix dir)) |
| 13043 | after prompting for the marking character. | 16171 | (todir (file-name-directory absprefix)) |
| 13044 | After each change, a message will be displayed indicating the meaning | 16172 | (opt org-format-latex-options) |
| 13045 | of the new mark." | 16173 | (matchers (plist-get opt :matchers)) |
| 13046 | (interactive) | 16174 | (re-list org-latex-regexps) |
| 13047 | (unless (org-at-table-p) (error "Not at a table")) | 16175 | (cnt 0) txt link beg end re e checkdir |
| 13048 | (let* ((marks (append (mapcar 'car org-recalc-marks) '(" "))) | 16176 | m n block linkfile movefile ov) |
| 13049 | (beg (org-table-begin)) | 16177 | ;; Check if there are old images files with this prefix, and remove them |
| 13050 | (end (org-table-end)) | 16178 | (when (file-directory-p todir) |
| 13051 | (l (org-current-line)) | 16179 | (mapc 'delete-file |
| 13052 | (l1 (if (org-region-active-p) (org-current-line (region-beginning)))) | 16180 | (directory-files |
| 13053 | (l2 (if (org-region-active-p) (org-current-line (region-end)))) | 16181 | todir 'full |
| 13054 | (have-col | 16182 | (concat (regexp-quote prefixnodir) "_[0-9]+\\.png$")))) |
| 13055 | (save-excursion | 16183 | ;; Check the different regular expressions |
| 16184 | (while (setq e (pop re-list)) | ||
| 16185 | (setq m (car e) re (nth 1 e) n (nth 2 e) | ||
| 16186 | block (if (nth 3 e) "\n\n" "")) | ||
| 16187 | (when (member m matchers) | ||
| 16188 | (goto-char (point-min)) | ||
| 16189 | (while (re-search-forward re nil t) | ||
| 16190 | (when (or (not at) (equal (cdr at) (match-beginning n))) | ||
| 16191 | (setq txt (match-string n) | ||
| 16192 | beg (match-beginning n) end (match-end n) | ||
| 16193 | cnt (1+ cnt) | ||
| 16194 | linkfile (format "%s_%04d.png" prefix cnt) | ||
| 16195 | movefile (format "%s_%04d.png" absprefix cnt) | ||
| 16196 | link (concat block "[[file:" linkfile "]]" block)) | ||
| 16197 | (if msg (message msg cnt)) | ||
| 13056 | (goto-char beg) | 16198 | (goto-char beg) |
| 13057 | (not (re-search-forward "^[ \t]*|[^-|][^|]*[^#!$*_^| \t][^|]*|" end t)))) | 16199 | (unless checkdir ; make sure the directory exists |
| 13058 | (col (org-table-current-column)) | 16200 | (setq checkdir t) |
| 13059 | (forcenew (car (assoc newchar org-recalc-marks))) | 16201 | (or (file-directory-p todir) (make-directory todir))) |
| 13060 | epos new) | 16202 | (org-create-formula-image |
| 13061 | (when l1 | 16203 | txt movefile opt) |
| 13062 | (message "Change region to what mark? Type # * ! $ or SPC: ") | 16204 | (if overlays |
| 13063 | (setq newchar (char-to-string (read-char-exclusive)) | 16205 | (progn |
| 13064 | forcenew (car (assoc newchar org-recalc-marks)))) | 16206 | (setq ov (org-make-overlay beg end)) |
| 13065 | (if (and newchar (not forcenew)) | 16207 | (if (featurep 'xemacs) |
| 13066 | (error "Invalid NEWCHAR `%s' in `org-table-rotate-recalc-marks'" | 16208 | (progn |
| 13067 | newchar)) | 16209 | (org-overlay-put ov 'invisible t) |
| 13068 | (if l1 (goto-line l1)) | 16210 | (org-overlay-put |
| 13069 | (save-excursion | 16211 | ov 'end-glyph |
| 13070 | (beginning-of-line 1) | 16212 | (make-glyph (vector 'png :file movefile)))) |
| 13071 | (unless (looking-at org-table-dataline-regexp) | 16213 | (org-overlay-put |
| 13072 | (error "Not at a table data line"))) | 16214 | ov 'display |
| 13073 | (unless have-col | 16215 | (list 'image :type 'png :file movefile :ascent 'center))) |
| 13074 | (org-table-goto-column 1) | 16216 | (push ov org-latex-fragment-image-overlays) |
| 13075 | (org-table-insert-column) | 16217 | (goto-char end)) |
| 13076 | (org-table-goto-column (1+ col))) | 16218 | (delete-region beg end) |
| 13077 | (setq epos (point-at-eol)) | 16219 | (insert link)))))))) |
| 13078 | (save-excursion | ||
| 13079 | (beginning-of-line 1) | ||
| 13080 | (org-table-get-field | ||
| 13081 | 1 (if (looking-at "^[ \t]*| *\\([#!$*^_ ]\\) *|") | ||
| 13082 | (concat " " | ||
| 13083 | (setq new (or forcenew | ||
| 13084 | (cadr (member (match-string 1) marks)))) | ||
| 13085 | " ") | ||
| 13086 | " # "))) | ||
| 13087 | (if (and l1 l2) | ||
| 13088 | (progn | ||
| 13089 | (goto-line l1) | ||
| 13090 | (while (progn (beginning-of-line 2) (not (= (org-current-line) l2))) | ||
| 13091 | (and (looking-at org-table-dataline-regexp) | ||
| 13092 | (org-table-get-field 1 (concat " " new " ")))) | ||
| 13093 | (goto-line l1))) | ||
| 13094 | (if (not (= epos (point-at-eol))) (org-table-align)) | ||
| 13095 | (goto-line l) | ||
| 13096 | (and (interactive-p) (message (cdr (assoc new org-recalc-marks)))))) | ||
| 13097 | |||
| 13098 | (defun org-table-maybe-recalculate-line () | ||
| 13099 | "Recompute the current line if marked for it, and if we haven't just done it." | ||
| 13100 | (interactive) | ||
| 13101 | (and org-table-allow-automatic-line-recalculation | ||
| 13102 | (not (and (memq last-command org-recalc-commands) | ||
| 13103 | (equal org-last-recalc-line (org-current-line)))) | ||
| 13104 | (save-excursion (beginning-of-line 1) | ||
| 13105 | (looking-at org-table-auto-recalculate-regexp)) | ||
| 13106 | (fboundp 'calc-eval) | ||
| 13107 | (org-table-recalculate) t)) | ||
| 13108 | |||
| 13109 | (defvar org-table-formula-debug nil | ||
| 13110 | "Non-nil means, debug table formulas. | ||
| 13111 | When nil, simply write \"#ERROR\" in corrupted fields.") | ||
| 13112 | |||
| 13113 | (defvar modes) | ||
| 13114 | (defsubst org-set-calc-mode (var &optional value) | ||
| 13115 | (if (stringp var) | ||
| 13116 | (setq var (assoc var '(("D" calc-angle-mode deg) | ||
| 13117 | ("R" calc-angle-mode rad) | ||
| 13118 | ("F" calc-prefer-frac t) | ||
| 13119 | ("S" calc-symbolic-mode t))) | ||
| 13120 | value (nth 2 var) var (nth 1 var))) | ||
| 13121 | (if (memq var modes) | ||
| 13122 | (setcar (cdr (memq var modes)) value) | ||
| 13123 | (cons var (cons value modes))) | ||
| 13124 | modes) | ||
| 13125 | |||
| 13126 | (defun org-table-eval-formula (&optional arg equation | ||
| 13127 | suppress-align suppress-const | ||
| 13128 | suppress-store) | ||
| 13129 | "Replace the table field value at the cursor by the result of a calculation. | ||
| 13130 | |||
| 13131 | This function makes use of Dave Gillespie's Calc package, in my view the | ||
| 13132 | most exciting program ever written for GNU Emacs. So you need to have Calc | ||
| 13133 | installed in order to use this function. | ||
| 13134 | |||
| 13135 | In a table, this command replaces the value in the current field with the | ||
| 13136 | result of a formula. It also installs the formula as the \"current\" column | ||
| 13137 | formula, by storing it in a special line below the table. When called | ||
| 13138 | with a `C-u' prefix, the current field must ba a named field, and the | ||
| 13139 | formula is installed as valid in only this specific field. | ||
| 13140 | |||
| 13141 | When called, the command first prompts for a formula, which is read in | ||
| 13142 | the minibuffer. Previously entered formulas are available through the | ||
| 13143 | history list, and the last used formula is offered as a default. | ||
| 13144 | These stored formulas are adapted correctly when moving, inserting, or | ||
| 13145 | deleting columns with the corresponding commands. | ||
| 13146 | |||
| 13147 | The formula can be any algebraic expression understood by the Calc package. | ||
| 13148 | For details, see the Org-mode manual. | ||
| 13149 | |||
| 13150 | This function can also be called from Lisp programs and offers | ||
| 13151 | additional arguments: EQUATION can be the formula to apply. If this | ||
| 13152 | argument is given, the user will not be prompted. SUPPRESS-ALIGN is | ||
| 13153 | used to speed-up recursive calls by by-passing unnecessary aligns. | ||
| 13154 | SUPPRESS-CONST suppresses the interpretation of constants in the | ||
| 13155 | formula, assuming that this has been done already outside the function. | ||
| 13156 | SUPPRESS-STORE means the formula should not be stored, either because | ||
| 13157 | it is already stored, or because it is a modified equation that should | ||
| 13158 | not overwrite the stored one." | ||
| 13159 | (interactive "P") | ||
| 13160 | (require 'calc) | ||
| 13161 | (org-table-check-inside-data-field) | ||
| 13162 | (org-table-get-specials) | ||
| 13163 | (let* (fields | ||
| 13164 | (ndown (if (integerp arg) arg 1)) | ||
| 13165 | (org-table-automatic-realign nil) | ||
| 13166 | (case-fold-search nil) | ||
| 13167 | (down (> ndown 1)) | ||
| 13168 | (formula (if (and equation suppress-store) | ||
| 13169 | equation | ||
| 13170 | (org-table-get-formula equation (equal arg '(4))))) | ||
| 13171 | (n0 (org-table-current-column)) | ||
| 13172 | (modes (copy-sequence org-calc-default-modes)) | ||
| 13173 | n form fmt x ev orig c lispp) | ||
| 13174 | ;; Parse the format string. Since we have a lot of modes, this is | ||
| 13175 | ;; a lot of work. However, I think calc still uses most of the time. | ||
| 13176 | (if (string-match ";" formula) | ||
| 13177 | (let ((tmp (org-split-string formula ";"))) | ||
| 13178 | (setq formula (car tmp) | ||
| 13179 | fmt (concat (cdr (assoc "%" org-table-local-parameters)) | ||
| 13180 | (nth 1 tmp))) | ||
| 13181 | (while (string-match "\\([pnfse]\\)\\(-?[0-9]+\\)" fmt) | ||
| 13182 | (setq c (string-to-char (match-string 1 fmt)) | ||
| 13183 | n (string-to-number (match-string 2 fmt))) | ||
| 13184 | (if (= c ?p) | ||
| 13185 | (setq modes (org-set-calc-mode 'calc-internal-prec n)) | ||
| 13186 | (setq modes (org-set-calc-mode | ||
| 13187 | 'calc-float-format | ||
| 13188 | (list (cdr (assoc c '((?n . float) (?f . fix) | ||
| 13189 | (?s . sci) (?e . eng)))) | ||
| 13190 | n)))) | ||
| 13191 | (setq fmt (replace-match "" t t fmt))) | ||
| 13192 | (while (string-match "[DRFS]" fmt) | ||
| 13193 | (setq modes (org-set-calc-mode (match-string 0 fmt))) | ||
| 13194 | (setq fmt (replace-match "" t t fmt))) | ||
| 13195 | (unless (string-match "\\S-" fmt) | ||
| 13196 | (setq fmt nil)))) | ||
| 13197 | (if (and (not suppress-const) org-table-formula-use-constants) | ||
| 13198 | (setq formula (org-table-formula-substitute-names formula))) | ||
| 13199 | (setq orig (or (get-text-property 1 :orig-formula formula) "?")) | ||
| 13200 | (while (> ndown 0) | ||
| 13201 | (setq fields (org-split-string | ||
| 13202 | (buffer-substring | ||
| 13203 | (point-at-bol) (point-at-eol)) " *| *")) | ||
| 13204 | (if org-table-formula-numbers-only | ||
| 13205 | (setq fields (mapcar | ||
| 13206 | (lambda (x) (number-to-string (string-to-number x))) | ||
| 13207 | fields))) | ||
| 13208 | (setq ndown (1- ndown)) | ||
| 13209 | (setq form (copy-sequence formula) | ||
| 13210 | lispp (equal (substring form 0 2) "'(")) | ||
| 13211 | ;; Insert the references to fields in same row | ||
| 13212 | (while (string-match "\\$\\([0-9]+\\)?" form) | ||
| 13213 | (setq n (if (match-beginning 1) | ||
| 13214 | (string-to-number (match-string 1 form)) | ||
| 13215 | n0) | ||
| 13216 | x (nth (1- n) fields)) | ||
| 13217 | (unless x (error "Invalid field specifier \"%s\"" | ||
| 13218 | (match-string 0 form))) | ||
| 13219 | (if (equal x "") (setq x "0")) | ||
| 13220 | (setq form (replace-match | ||
| 13221 | (if lispp x (concat "(" x ")")) | ||
| 13222 | t t form))) | ||
| 13223 | ;; Insert ranges in current column | ||
| 13224 | (while (string-match "\\&[-I0-9]+" form) | ||
| 13225 | (setq form (replace-match | ||
| 13226 | (save-match-data | ||
| 13227 | (org-table-get-vertical-vector (match-string 0 form) | ||
| 13228 | nil n0)) | ||
| 13229 | t t form))) | ||
| 13230 | (if lispp | ||
| 13231 | (setq ev (eval (eval (read form))) | ||
| 13232 | ev (if (numberp ev) (number-to-string ev) ev)) | ||
| 13233 | (setq ev (calc-eval (cons form modes) | ||
| 13234 | (if org-table-formula-numbers-only 'num)))) | ||
| 13235 | |||
| 13236 | (when org-table-formula-debug | ||
| 13237 | (with-output-to-temp-buffer "*Help*" | ||
| 13238 | (princ (format "Substitution history of formula | ||
| 13239 | Orig: %s | ||
| 13240 | $xyz-> %s | ||
| 13241 | $1-> %s\n" orig formula form)) | ||
| 13242 | (if (listp ev) | ||
| 13243 | (princ (format " %s^\nError: %s" | ||
| 13244 | (make-string (car ev) ?\-) (nth 1 ev))) | ||
| 13245 | (princ (format "Result: %s\nFormat: %s\nFinal: %s" | ||
| 13246 | ev (or fmt "NONE") | ||
| 13247 | (if fmt (format fmt (string-to-number ev)) ev))))) | ||
| 13248 | (shrink-window-if-larger-than-buffer (get-buffer-window "*Help*")) | ||
| 13249 | (unless (and (interactive-p) (not ndown)) | ||
| 13250 | (unless (let (inhibit-redisplay) | ||
| 13251 | (y-or-n-p "Debugging Formula. Continue to next? ")) | ||
| 13252 | (org-table-align) | ||
| 13253 | (error "Abort")) | ||
| 13254 | (delete-window (get-buffer-window "*Help*")) | ||
| 13255 | (message ""))) | ||
| 13256 | (if (listp ev) (setq fmt nil ev "#ERROR")) | ||
| 13257 | (org-table-justify-field-maybe | ||
| 13258 | (if fmt (format fmt (string-to-number ev)) ev)) | ||
| 13259 | (if (and down (> ndown 0) (looking-at ".*\n[ \t]*|[^-]")) | ||
| 13260 | (call-interactively 'org-return) | ||
| 13261 | (setq ndown 0))) | ||
| 13262 | (and down (org-table-maybe-recalculate-line)) | ||
| 13263 | (or suppress-align (and org-table-may-need-update | ||
| 13264 | (org-table-align))))) | ||
| 13265 | |||
| 13266 | (defun org-table-recalculate (&optional all noalign) | ||
| 13267 | "Recalculate the current table line by applying all stored formulas. | ||
| 13268 | With prefix arg ALL, do this for all lines in the table." | ||
| 13269 | (interactive "P") | ||
| 13270 | (or (memq this-command org-recalc-commands) | ||
| 13271 | (setq org-recalc-commands (cons this-command org-recalc-commands))) | ||
| 13272 | (unless (org-at-table-p) (error "Not at a table")) | ||
| 13273 | (org-table-get-specials) | ||
| 13274 | (let* ((eqlist (sort (org-table-get-stored-formulas) | ||
| 13275 | (lambda (a b) (string< (car a) (car b))))) | ||
| 13276 | (inhibit-redisplay t) | ||
| 13277 | (line-re org-table-dataline-regexp) | ||
| 13278 | (thisline (org-current-line)) | ||
| 13279 | (thiscol (org-table-current-column)) | ||
| 13280 | beg end entry eqlnum eqlname eql (cnt 0) eq a name) | ||
| 13281 | ;; Insert constants in all formulas | ||
| 13282 | (setq eqlist | ||
| 13283 | (mapcar (lambda (x) | ||
| 13284 | (setcdr x (org-table-formula-substitute-names (cdr x))) | ||
| 13285 | x) | ||
| 13286 | eqlist)) | ||
| 13287 | ;; Split the equation list | ||
| 13288 | (while (setq eq (pop eqlist)) | ||
| 13289 | (if (<= (string-to-char (car eq)) ?9) | ||
| 13290 | (push eq eqlnum) | ||
| 13291 | (push eq eqlname))) | ||
| 13292 | (setq eqlnum (nreverse eqlnum) eqlname (nreverse eqlname)) | ||
| 13293 | (if all | ||
| 13294 | (progn | ||
| 13295 | (setq end (move-marker (make-marker) (1+ (org-table-end)))) | ||
| 13296 | (goto-char (setq beg (org-table-begin))) | ||
| 13297 | (if (re-search-forward org-table-calculate-mark-regexp end t) | ||
| 13298 | ;; This is a table with marked lines, only compute selected lines | ||
| 13299 | (setq line-re org-table-recalculate-regexp) | ||
| 13300 | ;; Move forward to the first non-header line | ||
| 13301 | (if (and (re-search-forward org-table-dataline-regexp end t) | ||
| 13302 | (re-search-forward org-table-hline-regexp end t) | ||
| 13303 | (re-search-forward org-table-dataline-regexp end t)) | ||
| 13304 | (setq beg (match-beginning 0)) | ||
| 13305 | nil))) ;; just leave beg where it is | ||
| 13306 | (setq beg (point-at-bol) | ||
| 13307 | end (move-marker (make-marker) (1+ (point-at-eol))))) | ||
| 13308 | (goto-char beg) | ||
| 13309 | (and all (message "Re-applying formulas to full table...")) | ||
| 13310 | (while (re-search-forward line-re end t) | ||
| 13311 | (unless (string-match "^ *[_^!$] *$" (org-table-get-field 1)) | ||
| 13312 | ;; Unprotected line, recalculate | ||
| 13313 | (and all (message "Re-applying formulas to full table...(line %d)" | ||
| 13314 | (setq cnt (1+ cnt)))) | ||
| 13315 | (setq org-last-recalc-line (org-current-line)) | ||
| 13316 | (setq eql eqlnum) | ||
| 13317 | (while (setq entry (pop eql)) | ||
| 13318 | (goto-line org-last-recalc-line) | ||
| 13319 | (org-table-goto-column (string-to-number (car entry)) nil 'force) | ||
| 13320 | (org-table-eval-formula nil (cdr entry) 'noalign 'nocst 'nostore)))) | ||
| 13321 | (goto-line thisline) | ||
| 13322 | (org-table-goto-column thiscol) | ||
| 13323 | (or noalign (and org-table-may-need-update (org-table-align)) | ||
| 13324 | (and all (message "Re-applying formulas to %d lines...done" cnt))) | ||
| 13325 | ;; Now do the names fields | ||
| 13326 | (while (setq eq (pop eqlname)) | ||
| 13327 | (setq name (car eq) | ||
| 13328 | a (assoc name org-table-named-field-locations)) | ||
| 13329 | (when a | ||
| 13330 | (message "Re-applying formula to named field: %s" name) | ||
| 13331 | (goto-line (nth 1 a)) | ||
| 13332 | (org-table-goto-column (nth 2 a)) | ||
| 13333 | (org-table-eval-formula nil (cdr eq) 'noalign 'nocst 'nostore))) | ||
| 13334 | ;; back to initial position | ||
| 13335 | (goto-line thisline) | ||
| 13336 | (org-table-goto-column thiscol) | ||
| 13337 | (or noalign (and org-table-may-need-update (org-table-align)) | ||
| 13338 | (and all (message "Re-applying formulas...done"))))) | ||
| 13339 | |||
| 13340 | (defun org-table-formula-substitute-names (f) | ||
| 13341 | "Replace $const with values in string F." | ||
| 13342 | (let ((start 0) a n1 n2 nn1 nn2 s (f1 f)) | ||
| 13343 | ;; First, check for column names | ||
| 13344 | (while (setq start (string-match org-table-column-name-regexp f start)) | ||
| 13345 | (setq start (1+ start)) | ||
| 13346 | (setq a (assoc (match-string 1 f) org-table-column-names)) | ||
| 13347 | (setq f (replace-match (concat "$" (cdr a)) t t f))) | ||
| 13348 | ;; Expand ranges to vectors | ||
| 13349 | (while (string-match "\\$\\([0-9]+\\)\\.\\.\\.?\\$\\([0-9]+\\)" f) | ||
| 13350 | (setq n1 (string-to-number (match-string 1 f)) | ||
| 13351 | n2 (string-to-number (match-string 2 f)) | ||
| 13352 | nn1 (1+ (min n1 n2)) nn2 (max n1 n2) | ||
| 13353 | s (concat "[($" (number-to-string (1- nn1)) ")")) | ||
| 13354 | (loop for i from nn1 upto nn2 do | ||
| 13355 | (setq s (concat s ",($" (int-to-string i) ")"))) | ||
| 13356 | (setq s (concat s "]")) | ||
| 13357 | (if (< n2 n1) (setq s (concat "rev(" s ")"))) | ||
| 13358 | (setq f (replace-match s t t f))) | ||
| 13359 | ;; Parameters and constants | ||
| 13360 | (setq start 0) | ||
| 13361 | (while (setq start (string-match "\\$\\([a-zA-Z][a-zA-Z0-9]*\\)" f start)) | ||
| 13362 | (setq start (1+ start)) | ||
| 13363 | (if (setq a (save-match-data | ||
| 13364 | (org-table-get-constant (match-string 1 f)))) | ||
| 13365 | (setq f (replace-match (concat "(" a ")") t t f)))) | ||
| 13366 | (if org-table-formula-debug | ||
| 13367 | (put-text-property 0 (length f) :orig-formula f1 f)) | ||
| 13368 | f)) | ||
| 13369 | |||
| 13370 | (defun org-table-get-constant (const) | ||
| 13371 | "Find the value for a parameter or constant in a formula. | ||
| 13372 | Parameters get priority." | ||
| 13373 | (or (cdr (assoc const org-table-local-parameters)) | ||
| 13374 | (cdr (assoc const org-table-formula-constants)) | ||
| 13375 | (and (fboundp 'constants-get) (constants-get const)) | ||
| 13376 | "#UNDEFINED_NAME")) | ||
| 13377 | |||
| 13378 | (defvar org-edit-formulas-map (make-sparse-keymap)) | ||
| 13379 | (define-key org-edit-formulas-map "\C-c\C-c" 'org-finish-edit-formulas) | ||
| 13380 | (define-key org-edit-formulas-map "\C-c\C-q" 'org-abort-edit-formulas) | ||
| 13381 | (define-key org-edit-formulas-map "\C-c?" 'org-show-variable) | ||
| 13382 | |||
| 13383 | (defvar org-pos) | ||
| 13384 | 16220 | ||
| 13385 | (defun org-table-edit-formulas () | 16221 | ;; This function borrows from Ganesh Swami's latex2png.el |
| 13386 | "Edit the formulas of the current table in a separate buffer." | 16222 | (defun org-create-formula-image (string tofile options) |
| 13387 | (interactive) | 16223 | (let* ((tmpdir (if (featurep 'xemacs) |
| 13388 | (unless (org-at-table-p) | 16224 | (temp-directory) |
| 13389 | (error "Not at a table")) | 16225 | temporary-file-directory)) |
| 13390 | (org-table-get-specials) | 16226 | (texfilebase (make-temp-name |
| 13391 | (let ((eql (org-table-get-stored-formulas)) | 16227 | (expand-file-name "orgtex" tmpdir))) |
| 13392 | (pos (move-marker (make-marker) (point))) | ||
| 13393 | (wc (current-window-configuration)) | ||
| 13394 | entry loc s) | ||
| 13395 | (switch-to-buffer-other-window "*Edit Formulas*") | ||
| 13396 | (erase-buffer) | ||
| 13397 | (fundamental-mode) | ||
| 13398 | (org-set-local 'org-pos pos) | ||
| 13399 | (org-set-local 'org-window-configuration wc) | ||
| 13400 | (use-local-map org-edit-formulas-map) | ||
| 13401 | (setq s "# Edit formulas and finish with `C-c C-c'. | ||
| 13402 | # Use `C-u C-c C-c' to also appy them immediately to the entire table. | ||
| 13403 | # Use `C-c ?' to get information about $name at point. | ||
| 13404 | # To cancel editing, press `C-c C-q'.\n") | ||
| 13405 | (put-text-property 0 (length s) 'face 'font-lock-comment-face s) | ||
| 13406 | (insert s) | ||
| 13407 | (while (setq entry (pop eql)) | ||
| 13408 | (when (setq loc (assoc (car entry) org-table-named-field-locations)) | ||
| 13409 | (setq s (format "# Named formula, referring to column %d in line %d\n" | ||
| 13410 | (nth 2 loc) (nth 1 loc))) | ||
| 13411 | (put-text-property 0 (length s) 'face 'font-lock-comment-face s) | ||
| 13412 | (insert s)) | ||
| 13413 | (setq s (concat "$" (car entry) "=" (cdr entry) "\n")) | ||
| 13414 | (remove-text-properties 0 (length s) '(face nil) s) | ||
| 13415 | (insert s)) | ||
| 13416 | (goto-char (point-min)) | ||
| 13417 | (message "Edit formulas and finish with `C-c C-c'."))) | ||
| 13418 | 16228 | ||
| 13419 | (defun org-show-variable () | 16229 | ;(texfilebase (make-temp-file "orgtex")) |
| 13420 | "Show the location/value of the $ expression at point." | 16230 | ; (dummy (delete-file texfilebase)) |
| 13421 | (interactive) | 16231 | (texfile (concat texfilebase ".tex")) |
| 13422 | (let (var (pos org-pos) (win (selected-window)) e) | 16232 | (dvifile (concat texfilebase ".dvi")) |
| 13423 | (save-excursion | 16233 | (pngfile (concat texfilebase ".png")) |
| 13424 | (or (looking-at "\\$") (skip-chars-backward "$a-zA-Z0-9")) | 16234 | (scale (number-to-string (* 1000 (or (plist-get options :scale) 1.0)))) |
| 13425 | (if (looking-at "\\$\\([a-zA-Z0-9]+\\)") | 16235 | (fg (or (plist-get options :foreground) "Black")) |
| 13426 | (setq var (match-string 1)) | 16236 | (bg (or (plist-get options :background) "Transparent"))) |
| 13427 | (error "No variable at point"))) | 16237 | (with-temp-file texfile |
| 13428 | (cond | 16238 | (insert "\\documentclass{article} |
| 13429 | ((setq e (assoc var org-table-named-field-locations)) | 16239 | \\usepackage{fullpage} |
| 13430 | (switch-to-buffer-other-window (marker-buffer pos)) | 16240 | \\usepackage{amssymb} |
| 13431 | (goto-line (nth 1 e)) | 16241 | \\usepackage[usenames]{color} |
| 13432 | (org-table-goto-column (nth 2 e)) | 16242 | \\usepackage{amsmath} |
| 13433 | (select-window win) | 16243 | \\usepackage{latexsym} |
| 13434 | (message "Named field, column %d of line %d" (nth 2 e) (nth 1 e))) | 16244 | \\usepackage[mathscr]{eucal} |
| 13435 | ((setq e (assoc var org-table-column-names)) | 16245 | \\pagestyle{empty} |
| 13436 | (switch-to-buffer-other-window (marker-buffer pos)) | 16246 | \\begin{document}\n" string "\n\\end{document}\n")) |
| 13437 | (goto-char pos) | 16247 | (let ((dir default-directory)) |
| 13438 | (goto-char (org-table-begin)) | 16248 | (condition-case nil |
| 13439 | (if (re-search-forward (concat "^[ \t]*| *! *.*?| *\\(" var "\\) *|") | ||
| 13440 | (org-table-end) t) | ||
| 13441 | (progn | ||
| 13442 | (goto-char (match-beginning 1)) | ||
| 13443 | (message "Named column (column %s)" (cdr e))) | ||
| 13444 | (error "Column name not found")) | ||
| 13445 | (select-window win)) | ||
| 13446 | ((string-match "^[0-9]$" var) | ||
| 13447 | ;; column number | ||
| 13448 | (switch-to-buffer-other-window (marker-buffer pos)) | ||
| 13449 | (goto-char pos) | ||
| 13450 | (goto-char (org-table-begin)) | ||
| 13451 | (recenter 1) | ||
| 13452 | (if (re-search-forward org-table-dataline-regexp | ||
| 13453 | (org-table-end) t) | ||
| 13454 | (progn | ||
| 13455 | (goto-char (match-beginning 0)) | ||
| 13456 | (org-table-goto-column (string-to-number var)) | ||
| 13457 | (message "Column %s" var)) | ||
| 13458 | (error "Column name not found")) | ||
| 13459 | (select-window win)) | ||
| 13460 | ((setq e (assoc var org-table-local-parameters)) | ||
| 13461 | (switch-to-buffer-other-window (marker-buffer pos)) | ||
| 13462 | (goto-char pos) | ||
| 13463 | (goto-char (org-table-begin)) | ||
| 13464 | (if (re-search-forward (concat "^[ \t]*| *\\$ *.*?| *\\(" var "=\\)") nil t) | ||
| 13465 | (progn | 16249 | (progn |
| 13466 | (goto-char (match-beginning 1)) | 16250 | (cd tmpdir) |
| 13467 | (message "Local parameter.")) | 16251 | (call-process "latex" nil nil nil texfile)) |
| 13468 | (error "Parameter not found")) | 16252 | (error nil)) |
| 13469 | (select-window win)) | 16253 | (cd dir)) |
| 13470 | (t | 16254 | (if (not (file-exists-p dvifile)) |
| 13471 | (cond | 16255 | (progn (message "Failed to create dvi file from %s" texfile) nil) |
| 13472 | ((setq e (assoc var org-table-formula-constants)) | 16256 | (call-process "dvipng" nil nil nil |
| 13473 | (message "Constant: $%s=%s in `org-table-formula-constants'." var (cdr e))) | 16257 | "-E" "-fg" fg "-bg" bg |
| 13474 | ((setq e (and (fboundp 'constants-get) (constants-get var))) | 16258 | "-x" scale "-y" scale "-T" "tight" |
| 13475 | (message "Constant: $%s=%s, retrieved from `constants.el'." var e)) | 16259 | "-o" pngfile |
| 13476 | (t (error "Undefined name $%s" var))))))) | 16260 | dvifile) |
| 13477 | 16261 | (if (not (file-exists-p pngfile)) | |
| 13478 | (defun org-finish-edit-formulas (&optional arg) | 16262 | (progn (message "Failed to create png file from %s" texfile) nil) |
| 13479 | "Parse the buffer for formula definitions and install them. | 16263 | ;; Use the requested file name and clean up |
| 13480 | With prefix ARG, apply the new formulas to the table." | 16264 | (copy-file pngfile tofile 'replace) |
| 13481 | (interactive "P") | 16265 | (loop for e in '(".dvi" ".tex" ".aux" ".log" ".png") do |
| 13482 | (let ((pos org-pos) eql) | 16266 | (delete-file (concat texfilebase e))) |
| 13483 | (goto-char (point-min)) | 16267 | pngfile)))) |
| 13484 | (while (re-search-forward "^\\$\\([a-zA-Z0-9]+\\) *= *\\(.*?\\) *$" nil t) | ||
| 13485 | (push (cons (match-string 1) (match-string 2)) eql)) | ||
| 13486 | (set-window-configuration org-window-configuration) | ||
| 13487 | (select-window (get-buffer-window (marker-buffer pos))) | ||
| 13488 | (goto-char pos) | ||
| 13489 | (unless (org-at-table-p) | ||
| 13490 | (error "Lost table position - cannot install formulae")) | ||
| 13491 | (org-table-store-formulas eql) | ||
| 13492 | (move-marker pos nil) | ||
| 13493 | (kill-buffer "*Edit Formulas*") | ||
| 13494 | (if arg | ||
| 13495 | (org-table-recalculate 'all) | ||
| 13496 | (message "New formulas installed - press C-u C-c C-c to apply.")))) | ||
| 13497 | |||
| 13498 | (defun org-abort-edit-formulas () | ||
| 13499 | "Abort editing formulas, without installing the changes." | ||
| 13500 | (interactive) | ||
| 13501 | (let ((pos org-pos)) | ||
| 13502 | (set-window-configuration org-window-configuration) | ||
| 13503 | (select-window (get-buffer-window (marker-buffer pos))) | ||
| 13504 | (goto-char pos) | ||
| 13505 | (message "Formula editing aborted without installing changes"))) | ||
| 13506 | |||
| 13507 | ;;; The orgtbl minor mode | ||
| 13508 | |||
| 13509 | ;; Define a minor mode which can be used in other modes in order to | ||
| 13510 | ;; integrate the org-mode table editor. | ||
| 13511 | |||
| 13512 | ;; This is really a hack, because the org-mode table editor uses several | ||
| 13513 | ;; keys which normally belong to the major mode, for example the TAB and | ||
| 13514 | ;; RET keys. Here is how it works: The minor mode defines all the keys | ||
| 13515 | ;; necessary to operate the table editor, but wraps the commands into a | ||
| 13516 | ;; function which tests if the cursor is currently inside a table. If that | ||
| 13517 | ;; is the case, the table editor command is executed. However, when any of | ||
| 13518 | ;; those keys is used outside a table, the function uses `key-binding' to | ||
| 13519 | ;; look up if the key has an associated command in another currently active | ||
| 13520 | ;; keymap (minor modes, major mode, global), and executes that command. | ||
| 13521 | ;; There might be problems if any of the keys used by the table editor is | ||
| 13522 | ;; otherwise used as a prefix key. | ||
| 13523 | |||
| 13524 | ;; Another challenge is that the key binding for TAB can be tab or \C-i, | ||
| 13525 | ;; likewise the binding for RET can be return or \C-m. Orgtbl-mode | ||
| 13526 | ;; addresses this by checking explicitly for both bindings. | ||
| 13527 | |||
| 13528 | ;; The optimized version (see variable `orgtbl-optimized') takes over | ||
| 13529 | ;; all keys which are bound to `self-insert-command' in the *global map*. | ||
| 13530 | ;; Some modes bind other commands to simple characters, for example | ||
| 13531 | ;; AUCTeX binds the double quote to `Tex-insert-quote'. With orgtbl-mode | ||
| 13532 | ;; active, this binding is ignored inside tables and replaced with a | ||
| 13533 | ;; modified self-insert. | ||
| 13534 | |||
| 13535 | (defvar orgtbl-mode nil | ||
| 13536 | "Variable controlling `orgtbl-mode', a minor mode enabling the `org-mode' | ||
| 13537 | table editor in arbitrary modes.") | ||
| 13538 | (make-variable-buffer-local 'orgtbl-mode) | ||
| 13539 | |||
| 13540 | (defvar orgtbl-mode-map (make-keymap) | ||
| 13541 | "Keymap for `orgtbl-mode'.") | ||
| 13542 | |||
| 13543 | ;;;###autoload | ||
| 13544 | (defun turn-on-orgtbl () | ||
| 13545 | "Unconditionally turn on `orgtbl-mode'." | ||
| 13546 | (orgtbl-mode 1)) | ||
| 13547 | |||
| 13548 | ;;;###autoload | ||
| 13549 | (defun orgtbl-mode (&optional arg) | ||
| 13550 | "The `org-mode' table editor as a minor mode for use in other modes." | ||
| 13551 | (interactive) | ||
| 13552 | (if (org-mode-p) | ||
| 13553 | ;; Exit without error, in case some hook functions calls this | ||
| 13554 | ;; by accident in org-mode. | ||
| 13555 | (message "Orgtbl-mode is not useful in org-mode, command ignored") | ||
| 13556 | (setq orgtbl-mode | ||
| 13557 | (if arg (> (prefix-numeric-value arg) 0) (not orgtbl-mode))) | ||
| 13558 | (if orgtbl-mode | ||
| 13559 | (progn | ||
| 13560 | (and (orgtbl-setup) (defun orgtbl-setup () nil)) | ||
| 13561 | ;; Make sure we are first in minor-mode-map-alist | ||
| 13562 | (let ((c (assq 'orgtbl-mode minor-mode-map-alist))) | ||
| 13563 | (and c (setq minor-mode-map-alist | ||
| 13564 | (cons c (delq c minor-mode-map-alist))))) | ||
| 13565 | (org-set-local (quote org-table-may-need-update) t) | ||
| 13566 | (org-add-hook 'before-change-functions 'org-before-change-function | ||
| 13567 | nil 'local) | ||
| 13568 | (org-set-local 'org-old-auto-fill-inhibit-regexp | ||
| 13569 | auto-fill-inhibit-regexp) | ||
| 13570 | (org-set-local 'auto-fill-inhibit-regexp | ||
| 13571 | (if auto-fill-inhibit-regexp | ||
| 13572 | (concat "\\([ \t]*|\\|" auto-fill-inhibit-regexp) | ||
| 13573 | "[ \t]*|")) | ||
| 13574 | (org-add-to-invisibility-spec '(org-cwidth)) | ||
| 13575 | (easy-menu-add orgtbl-mode-menu) | ||
| 13576 | (run-hooks 'orgtbl-mode-hook)) | ||
| 13577 | (setq auto-fill-inhibit-regexp org-old-auto-fill-inhibit-regexp) | ||
| 13578 | (org-cleanup-narrow-column-properties) | ||
| 13579 | (org-remove-from-invisibility-spec '(org-cwidth)) | ||
| 13580 | (remove-hook 'before-change-functions 'org-before-change-function t) | ||
| 13581 | (easy-menu-remove orgtbl-mode-menu) | ||
| 13582 | (force-mode-line-update 'all)))) | ||
| 13583 | |||
| 13584 | (defun org-cleanup-narrow-column-properties () | ||
| 13585 | "Remove all properties related to narrow-column invisibility." | ||
| 13586 | (let ((s 1)) | ||
| 13587 | (while (setq s (text-property-any s (point-max) | ||
| 13588 | 'display org-narrow-column-arrow)) | ||
| 13589 | (remove-text-properties s (1+ s) '(display t))) | ||
| 13590 | (setq s 1) | ||
| 13591 | (while (setq s (text-property-any s (point-max) 'org-cwidth 1)) | ||
| 13592 | (remove-text-properties s (1+ s) '(org-cwidth t))) | ||
| 13593 | (setq s 1) | ||
| 13594 | (while (setq s (text-property-any s (point-max) 'invisible 'org-cwidth)) | ||
| 13595 | (remove-text-properties s (1+ s) '(invisible t))))) | ||
| 13596 | |||
| 13597 | ;; Install it as a minor mode. | ||
| 13598 | (put 'orgtbl-mode :included t) | ||
| 13599 | (put 'orgtbl-mode :menu-tag "Org Table Mode") | ||
| 13600 | (add-minor-mode 'orgtbl-mode " OrgTbl" orgtbl-mode-map) | ||
| 13601 | |||
| 13602 | (defun orgtbl-make-binding (fun n &rest keys) | ||
| 13603 | "Create a function for binding in the table minor mode. | ||
| 13604 | FUN is the command to call inside a table. N is used to create a unique | ||
| 13605 | command name. KEYS are keys that should be checked in for a command | ||
| 13606 | to execute outside of tables." | ||
| 13607 | (eval | ||
| 13608 | (list 'defun | ||
| 13609 | (intern (concat "orgtbl-hijacker-command-" (int-to-string n))) | ||
| 13610 | '(arg) | ||
| 13611 | (concat "In tables, run `" (symbol-name fun) "'.\n" | ||
| 13612 | "Outside of tables, run the binding of `" | ||
| 13613 | (mapconcat (lambda (x) (format "%s" x)) keys "' or `") | ||
| 13614 | "'.") | ||
| 13615 | '(interactive "p") | ||
| 13616 | (list 'if | ||
| 13617 | '(org-at-table-p) | ||
| 13618 | (list 'call-interactively (list 'quote fun)) | ||
| 13619 | (list 'let '(orgtbl-mode) | ||
| 13620 | (list 'call-interactively | ||
| 13621 | (append '(or) | ||
| 13622 | (mapcar (lambda (k) | ||
| 13623 | (list 'key-binding k)) | ||
| 13624 | keys) | ||
| 13625 | '('orgtbl-error)))))))) | ||
| 13626 | |||
| 13627 | (defun orgtbl-error () | ||
| 13628 | "Error when there is no default binding for a table key." | ||
| 13629 | (interactive) | ||
| 13630 | (error "This key is has no function outside tables")) | ||
| 13631 | |||
| 13632 | (defun orgtbl-setup () | ||
| 13633 | "Setup orgtbl keymaps." | ||
| 13634 | (let ((nfunc 0) | ||
| 13635 | (bindings | ||
| 13636 | (list | ||
| 13637 | '([(meta shift left)] org-table-delete-column) | ||
| 13638 | '([(meta left)] org-table-move-column-left) | ||
| 13639 | '([(meta right)] org-table-move-column-right) | ||
| 13640 | '([(meta shift right)] org-table-insert-column) | ||
| 13641 | '([(meta shift up)] org-table-kill-row) | ||
| 13642 | '([(meta shift down)] org-table-insert-row) | ||
| 13643 | '([(meta up)] org-table-move-row-up) | ||
| 13644 | '([(meta down)] org-table-move-row-down) | ||
| 13645 | '("\C-c\C-w" org-table-cut-region) | ||
| 13646 | '("\C-c\M-w" org-table-copy-region) | ||
| 13647 | '("\C-c\C-y" org-table-paste-rectangle) | ||
| 13648 | '("\C-c-" org-table-insert-hline) | ||
| 13649 | ; '([(shift tab)] org-table-previous-field) | ||
| 13650 | '("\C-m" org-table-next-row) | ||
| 13651 | (list (org-key 'S-return) 'org-table-copy-down) | ||
| 13652 | '([(meta return)] org-table-wrap-region) | ||
| 13653 | '("\C-c\C-q" org-table-wrap-region) | ||
| 13654 | '("\C-c?" org-table-current-column) | ||
| 13655 | '("\C-c " org-table-blank-field) | ||
| 13656 | '("\C-c+" org-table-sum) | ||
| 13657 | '("\C-c=" org-table-eval-formula) | ||
| 13658 | '("\C-c'" org-table-edit-formulas) | ||
| 13659 | '("\C-c`" org-table-edit-field) | ||
| 13660 | '("\C-c*" org-table-recalculate) | ||
| 13661 | '("\C-c|" org-table-create-or-convert-from-region) | ||
| 13662 | '("\C-c^" org-table-sort-lines) | ||
| 13663 | '([(control ?#)] org-table-rotate-recalc-marks))) | ||
| 13664 | elt key fun cmd) | ||
| 13665 | (while (setq elt (pop bindings)) | ||
| 13666 | (setq nfunc (1+ nfunc)) | ||
| 13667 | (setq key (car elt) | ||
| 13668 | fun (nth 1 elt) | ||
| 13669 | cmd (orgtbl-make-binding fun nfunc key)) | ||
| 13670 | (define-key orgtbl-mode-map key cmd)) | ||
| 13671 | ;; Special treatment needed for TAB and RET | ||
| 13672 | (define-key orgtbl-mode-map [(return)] | ||
| 13673 | (orgtbl-make-binding 'orgtbl-ret 100 [(return)] "\C-m")) | ||
| 13674 | (define-key orgtbl-mode-map "\C-m" | ||
| 13675 | (orgtbl-make-binding 'orgtbl-ret 101 "\C-m" [(return)])) | ||
| 13676 | (define-key orgtbl-mode-map [(tab)] | ||
| 13677 | (orgtbl-make-binding 'orgtbl-tab 102 [(tab)] "\C-i")) | ||
| 13678 | (define-key orgtbl-mode-map "\C-i" | ||
| 13679 | (orgtbl-make-binding 'orgtbl-tab 103 "\C-i" [(tab)]))) | ||
| 13680 | (define-key orgtbl-mode-map "\C-i" | ||
| 13681 | (orgtbl-make-binding 'orgtbl-tab 104 [(shift tab)])) | ||
| 13682 | (define-key orgtbl-mode-map "\C-c\C-c" | ||
| 13683 | (orgtbl-make-binding 'org-ctrl-c-ctrl-c 105 "\C-c\C-c")) | ||
| 13684 | (when orgtbl-optimized | ||
| 13685 | ;; If the user wants maximum table support, we need to hijack | ||
| 13686 | ;; some standard editing functions | ||
| 13687 | (org-remap orgtbl-mode-map | ||
| 13688 | 'self-insert-command 'orgtbl-self-insert-command | ||
| 13689 | 'delete-char 'org-delete-char | ||
| 13690 | 'delete-backward-char 'org-delete-backward-char) | ||
| 13691 | (define-key orgtbl-mode-map "|" 'org-force-self-insert)) | ||
| 13692 | (easy-menu-define orgtbl-mode-menu orgtbl-mode-map "OrgTbl menu" | ||
| 13693 | '("OrgTbl" | ||
| 13694 | ["Align" org-ctrl-c-ctrl-c :active (org-at-table-p) :keys "C-c C-c"] | ||
| 13695 | ["Next Field" org-cycle :active (org-at-table-p) :keys "TAB"] | ||
| 13696 | ["Previous Field" org-shifttab :active (org-at-table-p) :keys "S-TAB"] | ||
| 13697 | ["Next Row" org-return :active (org-at-table-p) :keys "RET"] | ||
| 13698 | "--" | ||
| 13699 | ["Blank Field" org-table-blank-field :active (org-at-table-p) :keys "C-c SPC"] | ||
| 13700 | ["Edit Field" org-table-edit-field :active (org-at-table-p) :keys "C-c ` "] | ||
| 13701 | ["Copy Field from Above" | ||
| 13702 | org-table-copy-down :active (org-at-table-p) :keys "S-RET"] | ||
| 13703 | "--" | ||
| 13704 | ("Column" | ||
| 13705 | ["Move Column Left" org-metaleft :active (org-at-table-p) :keys "M-<left>"] | ||
| 13706 | ["Move Column Right" org-metaright :active (org-at-table-p) :keys "M-<right>"] | ||
| 13707 | ["Delete Column" org-shiftmetaleft :active (org-at-table-p) :keys "M-S-<left>"] | ||
| 13708 | ["Insert Column" org-shiftmetaright :active (org-at-table-p) :keys "M-S-<right>"] | ||
| 13709 | "--" | ||
| 13710 | ["Enable Narrowing" (setq org-table-limit-column-width (not org-table-limit-column-width)) :active (org-at-table-p) :selected org-table-limit-column-width :style toggle]) | ||
| 13711 | ("Row" | ||
| 13712 | ["Move Row Up" org-metaup :active (org-at-table-p) :keys "M-<up>"] | ||
| 13713 | ["Move Row Down" org-metadown :active (org-at-table-p) :keys "M-<down>"] | ||
| 13714 | ["Delete Row" org-shiftmetaup :active (org-at-table-p) :keys "M-S-<up>"] | ||
| 13715 | ["Insert Row" org-shiftmetadown :active (org-at-table-p) :keys "M-S-<down>"] | ||
| 13716 | ["Sort lines in region" org-table-sort-lines (org-at-table-p) :keys "C-c ^"] | ||
| 13717 | "--" | ||
| 13718 | ["Insert Hline" org-table-insert-hline :active (org-at-table-p) :keys "C-c -"]) | ||
| 13719 | ("Rectangle" | ||
| 13720 | ["Copy Rectangle" org-copy-special :active (org-at-table-p)] | ||
| 13721 | ["Cut Rectangle" org-cut-special :active (org-at-table-p)] | ||
| 13722 | ["Paste Rectangle" org-paste-special :active (org-at-table-p)] | ||
| 13723 | ["Fill Rectangle" org-table-wrap-region :active (org-at-table-p)]) | ||
| 13724 | "--" | ||
| 13725 | ["Set Column Formula" org-table-eval-formula :active (org-at-table-p) :keys "C-c ="] | ||
| 13726 | ["Set Named Field Formula" (org-table-eval-formula '(4)) :active (org-at-table-p) :keys "C-u C-c ="] | ||
| 13727 | ["Edit Formulas" org-table-edit-formulas :active (org-at-table-p) :keys "C-c '"] | ||
| 13728 | ["Recalculate line" org-table-recalculate :active (org-at-table-p) :keys "C-c *"] | ||
| 13729 | ["Recalculate all" (org-table-recalculate '(4)) :active (org-at-table-p) :keys "C-u C-c *"] | ||
| 13730 | ["Toggle Recalculate Mark" org-table-rotate-recalc-marks :active (org-at-table-p) :keys "C-c #"] | ||
| 13731 | ["Sum Column/Rectangle" org-table-sum | ||
| 13732 | :active (or (org-at-table-p) (org-region-active-p)) :keys "C-c +"] | ||
| 13733 | ["Which Column?" org-table-current-column :active (org-at-table-p) :keys "C-c ?"] | ||
| 13734 | ["Debug Formulas" | ||
| 13735 | (setq org-table-formula-debug (not org-table-formula-debug)) | ||
| 13736 | :style toggle :selected org-table-formula-debug] | ||
| 13737 | )) | ||
| 13738 | t) | ||
| 13739 | |||
| 13740 | (defun orgtbl-tab (arg) | ||
| 13741 | "Justification and field motion for `orgtbl-mode'." | ||
| 13742 | (interactive "P") | ||
| 13743 | (if arg (org-table-edit-field t) | ||
| 13744 | (org-table-justify-field-maybe) | ||
| 13745 | (org-table-next-field))) | ||
| 13746 | |||
| 13747 | (defun orgtbl-ret () | ||
| 13748 | "Justification and field motion for `orgtbl-mode'." | ||
| 13749 | (interactive) | ||
| 13750 | (org-table-justify-field-maybe) | ||
| 13751 | (org-table-next-row)) | ||
| 13752 | |||
| 13753 | (defun orgtbl-self-insert-command (N) | ||
| 13754 | "Like `self-insert-command', use overwrite-mode for whitespace in tables. | ||
| 13755 | If the cursor is in a table looking at whitespace, the whitespace is | ||
| 13756 | overwritten, and the table is not marked as requiring realignment." | ||
| 13757 | (interactive "p") | ||
| 13758 | (if (and (org-at-table-p) | ||
| 13759 | (or | ||
| 13760 | (and org-table-auto-blank-field | ||
| 13761 | (member last-command | ||
| 13762 | '(orgtbl-hijacker-command-100 | ||
| 13763 | orgtbl-hijacker-command-101 | ||
| 13764 | orgtbl-hijacker-command-102 | ||
| 13765 | orgtbl-hijacker-command-103 | ||
| 13766 | orgtbl-hijacker-command-104 | ||
| 13767 | orgtbl-hijacker-command-105)) | ||
| 13768 | (org-table-blank-field)) | ||
| 13769 | t) | ||
| 13770 | (eq N 1) | ||
| 13771 | (looking-at "[^|\n]* +|")) | ||
| 13772 | (let (org-table-may-need-update) | ||
| 13773 | (goto-char (1- (match-end 0))) | ||
| 13774 | (delete-backward-char 1) | ||
| 13775 | (goto-char (match-beginning 0)) | ||
| 13776 | (self-insert-command N)) | ||
| 13777 | (setq org-table-may-need-update t) | ||
| 13778 | (let (orgtbl-mode) | ||
| 13779 | (call-interactively (key-binding (vector last-input-event)))))) | ||
| 13780 | 16268 | ||
| 13781 | (defun org-force-self-insert (N) | 16269 | ;;;; Exporting |
| 13782 | "Needed to enforce self-insert under remapping." | ||
| 13783 | (interactive "p") | ||
| 13784 | (self-insert-command N)) | ||
| 13785 | 16270 | ||
| 13786 | ;;; Exporting | 16271 | ;;; Variables, constants, and parameter plists |
| 13787 | 16272 | ||
| 13788 | (defconst org-level-max 20) | 16273 | (defconst org-level-max 20) |
| 13789 | 16274 | ||
| @@ -13795,9 +16280,13 @@ overwritten, and the table is not marked as requiring realignment." | |||
| 13795 | "Should default preamble be inserted? Set by publishing functions.") | 16280 | "Should default preamble be inserted? Set by publishing functions.") |
| 13796 | (defvar org-export-html-auto-postamble t | 16281 | (defvar org-export-html-auto-postamble t |
| 13797 | "Should default postamble be inserted? Set by publishing functions.") | 16282 | "Should default postamble be inserted? Set by publishing functions.") |
| 16283 | (defvar org-current-export-file nil) ; dynamically scoped parameter | ||
| 16284 | (defvar org-current-export-dir nil) ; dynamically scoped parameter | ||
| 16285 | |||
| 13798 | 16286 | ||
| 13799 | (defconst org-export-plist-vars | 16287 | (defconst org-export-plist-vars |
| 13800 | '((:language . org-export-default-language) | 16288 | '((:language . org-export-default-language) |
| 16289 | (:customtime . org-display-custom-times) | ||
| 13801 | (:headline-levels . org-export-headline-levels) | 16290 | (:headline-levels . org-export-headline-levels) |
| 13802 | (:section-numbers . org-export-with-section-numbers) | 16291 | (:section-numbers . org-export-with-section-numbers) |
| 13803 | (:table-of-contents . org-export-with-toc) | 16292 | (:table-of-contents . org-export-with-toc) |
| @@ -13871,20 +16360,6 @@ overwritten, and the table is not marked as requiring realignment." | |||
| 13871 | (match-string 1 options))))))))) | 16360 | (match-string 1 options))))))))) |
| 13872 | p))) | 16361 | p))) |
| 13873 | 16362 | ||
| 13874 | (defun org-combine-plists (&rest plists) | ||
| 13875 | "Create a single property list from all plists in PLISTS. | ||
| 13876 | The process starts by copying the last list, and then setting properties | ||
| 13877 | from the other lists. Settings in the first list are the most significant | ||
| 13878 | ones and overrule settings in the other lists." | ||
| 13879 | (let ((rtn (copy-sequence (pop plists))) | ||
| 13880 | p v ls) | ||
| 13881 | (while plists | ||
| 13882 | (setq ls (pop plists)) | ||
| 13883 | (while ls | ||
| 13884 | (setq p (pop ls) v (pop ls)) | ||
| 13885 | (setq rtn (plist-put rtn p v)))) | ||
| 13886 | rtn)) | ||
| 13887 | |||
| 13888 | (defun org-export-directory (type plist) | 16363 | (defun org-export-directory (type plist) |
| 13889 | (let* ((val (plist-get plist :publishing-directory)) | 16364 | (let* ((val (plist-get plist :publishing-directory)) |
| 13890 | (dir (if (listp val) | 16365 | (dir (if (listp val) |
| @@ -13972,8 +16447,6 @@ ones and overrule settings in the other lists." | |||
| 13972 | (call-interactively (cdr ass)) | 16447 | (call-interactively (cdr ass)) |
| 13973 | (error "No command associated with key %c" r1)))) | 16448 | (error "No command associated with key %c" r1)))) |
| 13974 | 16449 | ||
| 13975 | ;; ASCII | ||
| 13976 | |||
| 13977 | (defconst org-html-entities | 16450 | (defconst org-html-entities |
| 13978 | '(("nbsp") | 16451 | '(("nbsp") |
| 13979 | ("iexcl") | 16452 | ("iexcl") |
| @@ -14272,6 +16745,8 @@ The list contains HTML entities for Latin-1, Greek and other symbols. | |||
| 14272 | It is supplemented by a number of commonly used TeX macros with appropriate | 16745 | It is supplemented by a number of commonly used TeX macros with appropriate |
| 14273 | translations. There is currently no way for users to extend this.") | 16746 | translations. There is currently no way for users to extend this.") |
| 14274 | 16747 | ||
| 16748 | ;;; General functions for all backends | ||
| 16749 | |||
| 14275 | (defun org-cleaned-string-for-export (string &rest parameters) | 16750 | (defun org-cleaned-string-for-export (string &rest parameters) |
| 14276 | "Cleanup a buffer substring so that links can be created safely." | 16751 | "Cleanup a buffer substring so that links can be created safely." |
| 14277 | (interactive) | 16752 | (interactive) |
| @@ -14280,12 +16755,16 @@ translations. There is currently no way for users to extend this.") | |||
| 14280 | (re-plain-link (concat "\\([^[<]\\)" org-plain-link-re)) | 16755 | (re-plain-link (concat "\\([^[<]\\)" org-plain-link-re)) |
| 14281 | (re-angle-link (concat "\\([^[]\\)" org-angle-link-re)) | 16756 | (re-angle-link (concat "\\([^[]\\)" org-angle-link-re)) |
| 14282 | (re-archive (concat ":" org-archive-tag ":")) | 16757 | (re-archive (concat ":" org-archive-tag ":")) |
| 16758 | (re-quote (concat "^\\*+[ \t]+" org-quote-string "\\>")) | ||
| 16759 | (htmlp (memq :for-html parameters)) | ||
| 16760 | (outline-regexp "\\*+") | ||
| 14283 | rtn) | 16761 | rtn) |
| 14284 | (save-excursion | 16762 | (save-excursion |
| 14285 | (set-buffer (get-buffer-create " org-mode-tmp")) | 16763 | (set-buffer (get-buffer-create " org-mode-tmp")) |
| 14286 | (erase-buffer) | 16764 | (erase-buffer) |
| 14287 | (insert string) | 16765 | (insert string) |
| 14288 | (let ((org-inhibit-startup t)) (org-mode)) | 16766 | (let ((org-inhibit-startup t)) (org-mode)) |
| 16767 | (untabify (point-min) (point-max)) | ||
| 14289 | 16768 | ||
| 14290 | ;; Get rid of archived trees | 16769 | ;; Get rid of archived trees |
| 14291 | (when (not (eq org-export-with-archived-trees t)) | 16770 | (when (not (eq org-export-with-archived-trees t)) |
| @@ -14298,6 +16777,32 @@ translations. There is currently no way for users to extend this.") | |||
| 14298 | (if org-export-with-archived-trees (1+ (point-at-eol)) (point)) | 16777 | (if org-export-with-archived-trees (1+ (point-at-eol)) (point)) |
| 14299 | (org-end-of-subtree t))))) | 16778 | (org-end-of-subtree t))))) |
| 14300 | 16779 | ||
| 16780 | ;; Protect stuff from HTML processing | ||
| 16781 | (goto-char (point-min)) | ||
| 16782 | (while (re-search-forward "^[ \t]*:.*\\(\n[ \t]*:.*\\)*" nil t) | ||
| 16783 | (add-text-properties (match-beginning 0) (match-end 0) | ||
| 16784 | '(org-protected t))) | ||
| 16785 | (when htmlp | ||
| 16786 | (goto-char (point-min)) | ||
| 16787 | (while (re-search-forward "^#\\+HTML:[ \t]*\\(.*\\)" nil t) | ||
| 16788 | (replace-match "\\1" t) | ||
| 16789 | (add-text-properties | ||
| 16790 | (point-at-bol) (min (1+ (point-at-eol)) (point-max)) | ||
| 16791 | '(org-protected t)))) | ||
| 16792 | (goto-char (point-min)) | ||
| 16793 | (while (re-search-forward | ||
| 16794 | "^#\\+BEGIN_HTML\\>.*\\(\n.*\\)*?\n#\\+END_HTML\\>.*\n?" nil t) | ||
| 16795 | (if htmlp | ||
| 16796 | (add-text-properties (match-beginning 1) (1+ (match-end 1)) | ||
| 16797 | '(org-protected t)) | ||
| 16798 | (delete-region (match-beginning 0) (match-end 0)))) | ||
| 16799 | (goto-char (point-min)) | ||
| 16800 | (while (re-search-forward re-quote nil t) | ||
| 16801 | (goto-char (match-beginning 0)) | ||
| 16802 | (end-of-line 1) | ||
| 16803 | (add-text-properties (point) (org-end-of-subtree t) | ||
| 16804 | '(org-protected t))) | ||
| 16805 | |||
| 14301 | ;; Find targets in comments and move them out of comments, | 16806 | ;; Find targets in comments and move them out of comments, |
| 14302 | ;; but mark them as targets that should be invisible | 16807 | ;; but mark them as targets that should be invisible |
| 14303 | (goto-char (point-min)) | 16808 | (goto-char (point-min)) |
| @@ -14313,13 +16818,15 @@ translations. There is currently no way for users to extend this.") | |||
| 14313 | (goto-char (point-min)) | 16818 | (goto-char (point-min)) |
| 14314 | (when re-radio | 16819 | (when re-radio |
| 14315 | (while (re-search-forward re-radio nil t) | 16820 | (while (re-search-forward re-radio nil t) |
| 14316 | (replace-match "\\1[[\\2]]"))) | 16821 | (org-if-unprotected |
| 16822 | (replace-match "\\1[[\\2]]")))) | ||
| 14317 | 16823 | ||
| 14318 | ;; Find all links that contain a newline and put them into a single line | 16824 | ;; Find all links that contain a newline and put them into a single line |
| 14319 | (goto-char (point-min)) | 16825 | (goto-char (point-min)) |
| 14320 | (while (re-search-forward "\\(\\(\\[\\|\\]\\)\\[[^]]*?\\)[ \t]*\n[ \t]*\\([^]]*\\]\\(\\[\\|\\]\\)\\)" nil t) | 16826 | (while (re-search-forward "\\(\\(\\[\\|\\]\\)\\[[^]]*?\\)[ \t]*\n[ \t]*\\([^]]*\\]\\(\\[\\|\\]\\)\\)" nil t) |
| 14321 | (replace-match "\\1 \\3") | 16827 | (org-if-unprotected |
| 14322 | (goto-char (match-beginning 0))) | 16828 | (replace-match "\\1 \\3") |
| 16829 | (goto-char (match-beginning 0)))) | ||
| 14323 | 16830 | ||
| 14324 | ;; Convert LaTeX fragments to images | 16831 | ;; Convert LaTeX fragments to images |
| 14325 | (when (memq :LaTeX-fragments parameters) | 16832 | (when (memq :LaTeX-fragments parameters) |
| @@ -14334,34 +16841,38 @@ translations. There is currently no way for users to extend this.") | |||
| 14334 | ;; Expand link abbreviations | 16841 | ;; Expand link abbreviations |
| 14335 | (goto-char (point-min)) | 16842 | (goto-char (point-min)) |
| 14336 | (while (re-search-forward re-plain-link nil t) | 16843 | (while (re-search-forward re-plain-link nil t) |
| 14337 | (replace-match | 16844 | (org-if-unprotected |
| 14338 | (concat | 16845 | (replace-match |
| 14339 | (match-string 1) "[[" (match-string 2) ":" (match-string 3) "]]") | 16846 | (concat |
| 14340 | t t)) | 16847 | (match-string 1) "[[" (match-string 2) ":" (match-string 3) "]]") |
| 16848 | t t))) | ||
| 14341 | (goto-char (point-min)) | 16849 | (goto-char (point-min)) |
| 14342 | (while (re-search-forward re-angle-link nil t) | 16850 | (while (re-search-forward re-angle-link nil t) |
| 14343 | (replace-match | 16851 | (org-if-unprotected |
| 14344 | (concat | 16852 | (replace-match |
| 14345 | (match-string 1) "[[" (match-string 2) ":" (match-string 3) "]]") | 16853 | (concat |
| 14346 | t t)) | 16854 | (match-string 1) "[[" (match-string 2) ":" (match-string 3) "]]") |
| 16855 | t t))) | ||
| 14347 | (goto-char (point-min)) | 16856 | (goto-char (point-min)) |
| 14348 | (while (re-search-forward org-bracket-link-regexp nil t) | 16857 | (while (re-search-forward org-bracket-link-regexp nil t) |
| 14349 | (replace-match | 16858 | (org-if-unprotected |
| 14350 | (concat "[[" (save-match-data | 16859 | (replace-match |
| 14351 | (org-link-expand-abbrev (match-string 1))) | 16860 | (concat "[[" (save-match-data |
| 14352 | "]" | 16861 | (org-link-expand-abbrev (match-string 1))) |
| 14353 | (if (match-end 3) | 16862 | "]" |
| 14354 | (match-string 2) | 16863 | (if (match-end 3) |
| 14355 | (concat "[" (match-string 1) "]")) | 16864 | (match-string 2) |
| 14356 | "]") | 16865 | (concat "[" (match-string 1) "]")) |
| 14357 | t t)) | 16866 | "]") |
| 16867 | t t))) | ||
| 14358 | 16868 | ||
| 14359 | ;; Find multiline emphasis and put them into single line | 16869 | ;; Find multiline emphasis and put them into single line |
| 14360 | (when (memq :emph-multiline parameters) | 16870 | (when (memq :emph-multiline parameters) |
| 14361 | (goto-char (point-min)) | 16871 | (goto-char (point-min)) |
| 14362 | (while (re-search-forward org-emph-re nil t) | 16872 | (while (re-search-forward org-emph-re nil t) |
| 14363 | (subst-char-in-region (match-beginning 0) (match-end 0) ?\n ?\ t) | 16873 | (org-if-unprotected |
| 14364 | (goto-char (1- (match-end 0))))) | 16874 | (subst-char-in-region (match-beginning 0) (match-end 0) ?\n ?\ t) |
| 16875 | (goto-char (1- (match-end 0)))))) | ||
| 14365 | 16876 | ||
| 14366 | (setq rtn (buffer-string))) | 16877 | (setq rtn (buffer-string))) |
| 14367 | (kill-buffer " org-mode-tmp") | 16878 | (kill-buffer " org-mode-tmp") |
| @@ -14377,48 +16888,56 @@ translations. There is currently no way for users to extend this.") | |||
| 14377 | (a (assoc rtn alist))) | 16888 | (a (assoc rtn alist))) |
| 14378 | (or (cdr a) rtn)))) | 16889 | (or (cdr a) rtn)))) |
| 14379 | 16890 | ||
| 14380 | (defun org-convert-to-odd-levels () | 16891 | ;; Variable holding the vector with section numbers |
| 14381 | "Convert an org-mode file with all levels allowed to one with odd levels. | 16892 | (defvar org-section-numbers (make-vector org-level-max 0)) |
| 14382 | This will leave level 1 alone, convert level 2 to level 3, level 3 to | ||
| 14383 | level 5 etc." | ||
| 14384 | (interactive) | ||
| 14385 | (when (yes-or-no-p "Are you sure you want to globally change levels to odd? ") | ||
| 14386 | (let ((org-odd-levels-only nil) n) | ||
| 14387 | (save-excursion | ||
| 14388 | (goto-char (point-min)) | ||
| 14389 | (while (re-search-forward "^\\*\\*+" nil t) | ||
| 14390 | (setq n (1- (length (match-string 0)))) | ||
| 14391 | (while (>= (setq n (1- n)) 0) | ||
| 14392 | (org-demote)) | ||
| 14393 | (end-of-line 1)))))) | ||
| 14394 | 16893 | ||
| 16894 | (defun org-init-section-numbers () | ||
| 16895 | "Initialize the vector for the section numbers." | ||
| 16896 | (let* ((level -1) | ||
| 16897 | (numbers (nreverse (org-split-string "" "\\."))) | ||
| 16898 | (depth (1- (length org-section-numbers))) | ||
| 16899 | (i depth) number-string) | ||
| 16900 | (while (>= i 0) | ||
| 16901 | (if (> i level) | ||
| 16902 | (aset org-section-numbers i 0) | ||
| 16903 | (setq number-string (or (car numbers) "0")) | ||
| 16904 | (if (string-match "\\`[A-Z]\\'" number-string) | ||
| 16905 | (aset org-section-numbers i | ||
| 16906 | (- (string-to-char number-string) ?A -1)) | ||
| 16907 | (aset org-section-numbers i (string-to-number number-string))) | ||
| 16908 | (pop numbers)) | ||
| 16909 | (setq i (1- i))))) | ||
| 14395 | 16910 | ||
| 14396 | (defun org-convert-to-oddeven-levels () | 16911 | (defun org-section-number (&optional level) |
| 14397 | "Convert an org-mode file with only odd levels to one with odd and even levels. | 16912 | "Return a string with the current section number. |
| 14398 | This promotes level 3 to level 2, level 5 to level 3 etc. If the file contains a | 16913 | When LEVEL is non-nil, increase section numbers on that level." |
| 14399 | section with an even level, conversion would destroy the structure of the file. An error | 16914 | (let* ((depth (1- (length org-section-numbers))) idx n (string "")) |
| 14400 | is signaled in this case." | 16915 | (when level |
| 14401 | (interactive) | 16916 | (when (> level -1) |
| 14402 | (goto-char (point-min)) | 16917 | (aset org-section-numbers |
| 14403 | ;; First check if there are no even levels | 16918 | level (1+ (aref org-section-numbers level)))) |
| 14404 | (when (re-search-forward "^\\(\\*\\*\\)+[^*]" nil t) | 16919 | (setq idx (1+ level)) |
| 14405 | (org-show-context t) | 16920 | (while (<= idx depth) |
| 14406 | (error "Not all levels are odd in this file. Conversion not possible.")) | 16921 | (if (not (= idx 1)) |
| 14407 | (when (yes-or-no-p "Are you sure you want to globally change levels to odd-even? ") | 16922 | (aset org-section-numbers idx 0)) |
| 14408 | (let ((org-odd-levels-only nil) n) | 16923 | (setq idx (1+ idx)))) |
| 14409 | (save-excursion | 16924 | (setq idx 0) |
| 14410 | (goto-char (point-min)) | 16925 | (while (<= idx depth) |
| 14411 | (while (re-search-forward "^\\*\\*+" nil t) | 16926 | (setq n (aref org-section-numbers idx)) |
| 14412 | (setq n (/ (length (match-string 0)) 2)) | 16927 | (setq string (concat string (if (not (string= string "")) "." "") |
| 14413 | (while (>= (setq n (1- n)) 0) | 16928 | (int-to-string n))) |
| 14414 | (org-promote)) | 16929 | (setq idx (1+ idx))) |
| 14415 | (end-of-line 1)))))) | 16930 | (save-match-data |
| 16931 | (if (string-match "\\`\\([@0]\\.\\)+" string) | ||
| 16932 | (setq string (replace-match "" t nil string))) | ||
| 16933 | (if (string-match "\\(\\.0\\)+\\'" string) | ||
| 16934 | (setq string (replace-match "" t nil string)))) | ||
| 16935 | string)) | ||
| 14416 | 16936 | ||
| 14417 | (defun org-tr-level (n) | 16937 | ;;; ASCII export |
| 14418 | "Make N odd if required." | ||
| 14419 | (if org-odd-levels-only (1+ (/ n 2)) n)) | ||
| 14420 | 16938 | ||
| 14421 | (defvar org-last-level nil) ; dynamically scoped variable | 16939 | (defvar org-last-level nil) ; dynamically scoped variable |
| 16940 | (defvar org-levels-open nil) ; dynamically scoped parameter | ||
| 14422 | (defvar org-ascii-current-indentation nil) ; For communication | 16941 | (defvar org-ascii-current-indentation nil) ; For communication |
| 14423 | 16942 | ||
| 14424 | (defun org-export-as-ascii (arg) | 16943 | (defun org-export-as-ascii (arg) |
| @@ -14434,15 +16953,16 @@ underlined headlines. The default is 3." | |||
| 14434 | (buffer-substring | 16953 | (buffer-substring |
| 14435 | (if (org-region-active-p) (region-beginning) (point-min)) | 16954 | (if (org-region-active-p) (region-beginning) (point-min)) |
| 14436 | (if (org-region-active-p) (region-end) (point-max)))) | 16955 | (if (org-region-active-p) (region-end) (point-max)))) |
| 16956 | (custom-times org-display-custom-times) | ||
| 14437 | (lines (org-export-find-first-heading-line | 16957 | (lines (org-export-find-first-heading-line |
| 14438 | (org-skip-comments | 16958 | (org-skip-comments |
| 14439 | (org-split-string | 16959 | (org-split-string |
| 14440 | (org-cleaned-string-for-export region) | 16960 | (org-cleaned-string-for-export region) |
| 14441 | "[\r\n]")))) | 16961 | "[\r\n]")))) |
| 14442 | (org-ascii-current-indentation '(0 . 0)) | 16962 | (org-ascii-current-indentation '(0 . 0)) |
| 14443 | (org-startup-with-deadline-check nil) | ||
| 14444 | (level 0) line txt | 16963 | (level 0) line txt |
| 14445 | (umax nil) | 16964 | (umax nil) |
| 16965 | (umax-toc nil) | ||
| 14446 | (case-fold-search nil) | 16966 | (case-fold-search nil) |
| 14447 | (filename (concat (file-name-as-directory | 16967 | (filename (concat (file-name-as-directory |
| 14448 | (org-export-directory :ascii opt-plist)) | 16968 | (org-export-directory :ascii opt-plist)) |
| @@ -14450,7 +16970,7 @@ underlined headlines. The default is 3." | |||
| 14450 | (file-name-nondirectory buffer-file-name)) | 16970 | (file-name-nondirectory buffer-file-name)) |
| 14451 | ".txt")) | 16971 | ".txt")) |
| 14452 | (buffer (find-file-noselect filename)) | 16972 | (buffer (find-file-noselect filename)) |
| 14453 | (levels-open (make-vector org-level-max nil)) | 16973 | (org-levels-open (make-vector org-level-max nil)) |
| 14454 | (odd org-odd-levels-only) | 16974 | (odd org-odd-levels-only) |
| 14455 | (date (format-time-string "%Y/%m/%d" (current-time))) | 16975 | (date (format-time-string "%Y/%m/%d" (current-time))) |
| 14456 | (time (format-time-string "%X" (org-current-time))) | 16976 | (time (format-time-string "%X" (org-current-time))) |
| @@ -14461,7 +16981,7 @@ underlined headlines. The default is 3." | |||
| 14461 | (email (plist-get opt-plist :email)) | 16981 | (email (plist-get opt-plist :email)) |
| 14462 | (language (plist-get opt-plist :language)) | 16982 | (language (plist-get opt-plist :language)) |
| 14463 | (quote-re0 (concat "^[ \t]*" org-quote-string "\\>")) | 16983 | (quote-re0 (concat "^[ \t]*" org-quote-string "\\>")) |
| 14464 | (quote-re (concat "^\\(\\*+\\)\\([ \t]*" org-quote-string "\\>\\)")) | 16984 | ; (quote-re (concat "^\\(\\*+\\)\\([ \t]*" org-quote-string "\\>\\)")) |
| 14465 | (text nil) | 16985 | (text nil) |
| 14466 | (todo nil) | 16986 | (todo nil) |
| 14467 | (lang-words nil)) | 16987 | (lang-words nil)) |
| @@ -14473,9 +16993,7 @@ underlined headlines. The default is 3." | |||
| 14473 | 16993 | ||
| 14474 | (setq lang-words (or (assoc language org-export-language-setup) | 16994 | (setq lang-words (or (assoc language org-export-language-setup) |
| 14475 | (assoc "en" org-export-language-setup))) | 16995 | (assoc "en" org-export-language-setup))) |
| 14476 | (if org-export-ascii-show-new-buffer | 16996 | (switch-to-buffer-other-window buffer) |
| 14477 | (switch-to-buffer-other-window buffer) | ||
| 14478 | (set-buffer buffer)) | ||
| 14479 | (erase-buffer) | 16997 | (erase-buffer) |
| 14480 | (fundamental-mode) | 16998 | (fundamental-mode) |
| 14481 | ;; create local variables for all options, to make sure all called | 16999 | ;; create local variables for all options, to make sure all called |
| @@ -14487,6 +17005,9 @@ underlined headlines. The default is 3." | |||
| 14487 | (org-set-local 'org-odd-levels-only odd) | 17005 | (org-set-local 'org-odd-levels-only odd) |
| 14488 | (setq umax (if arg (prefix-numeric-value arg) | 17006 | (setq umax (if arg (prefix-numeric-value arg) |
| 14489 | org-export-headline-levels)) | 17007 | org-export-headline-levels)) |
| 17008 | (setq umax-toc (if (integerp org-export-with-toc) | ||
| 17009 | (min org-export-with-toc umax) | ||
| 17010 | umax)) | ||
| 14490 | 17011 | ||
| 14491 | ;; File header | 17012 | ;; File header |
| 14492 | (if title (org-insert-centered title ?=)) | 17013 | (if title (org-insert-centered title ?=)) |
| @@ -14520,7 +17041,7 @@ underlined headlines. The default is 3." | |||
| 14520 | org-done-string))) | 17041 | org-done-string))) |
| 14521 | ; TODO, not DONE | 17042 | ; TODO, not DONE |
| 14522 | (and org-export-mark-todo-in-toc | 17043 | (and org-export-mark-todo-in-toc |
| 14523 | (= level umax) | 17044 | (= level umax-toc) |
| 14524 | (org-search-todo-below | 17045 | (org-search-todo-below |
| 14525 | line lines level)))) | 17046 | line lines level)))) |
| 14526 | (setq txt (org-html-expand-for-ascii txt)) | 17047 | (setq txt (org-html-expand-for-ascii txt)) |
| @@ -14534,7 +17055,7 @@ underlined headlines. The default is 3." | |||
| 14534 | (if org-export-with-section-numbers | 17055 | (if org-export-with-section-numbers |
| 14535 | (setq txt (concat (org-section-number level) | 17056 | (setq txt (concat (org-section-number level) |
| 14536 | " " txt))) | 17057 | " " txt))) |
| 14537 | (if (<= level umax) | 17058 | (if (<= level umax-toc) |
| 14538 | (progn | 17059 | (progn |
| 14539 | (insert | 17060 | (insert |
| 14540 | (make-string (* (1- level) 4) ?\ ) | 17061 | (make-string (* (1- level) 4) ?\ ) |
| @@ -14555,6 +17076,8 @@ underlined headlines. The default is 3." | |||
| 14555 | (setq line (replace-match | 17076 | (setq line (replace-match |
| 14556 | (if (match-end 3) "[\\3]" "[\\1]") | 17077 | (if (match-end 3) "[\\3]" "[\\1]") |
| 14557 | t nil line))) | 17078 | t nil line))) |
| 17079 | (when custom-times | ||
| 17080 | (setq line (org-translate-time line))) | ||
| 14558 | (cond | 17081 | (cond |
| 14559 | ((string-match "^\\(\\*+\\)[ \t]*\\(.*\\)" line) | 17082 | ((string-match "^\\(\\*+\\)[ \t]*\\(.*\\)" line) |
| 14560 | ;; a Headline | 17083 | ;; a Headline |
| @@ -14709,7 +17232,7 @@ command." | |||
| 14709 | (not (get-char-property s 'invisible)))) | 17232 | (not (get-char-property s 'invisible)))) |
| 14710 | s)) | 17233 | s)) |
| 14711 | 17234 | ||
| 14712 | ;; HTML | 17235 | ;;; HTML export |
| 14713 | 17236 | ||
| 14714 | (defun org-get-current-options () | 17237 | (defun org-get-current-options () |
| 14715 | "Return a string with current options as keyword options. | 17238 | "Return a string with current options as keyword options. |
| @@ -14724,7 +17247,7 @@ Does include HTML export options as well as TODO and CATEGORY stuff." | |||
| 14724 | #+CATEGORY: %s | 17247 | #+CATEGORY: %s |
| 14725 | #+SEQ_TODO: %s | 17248 | #+SEQ_TODO: %s |
| 14726 | #+TYP_TODO: %s | 17249 | #+TYP_TODO: %s |
| 14727 | #+STARTUP: %s %s %s %s %s %s | 17250 | #+STARTUP: %s %s %s %s %s |
| 14728 | #+TAGS: %s | 17251 | #+TAGS: %s |
| 14729 | #+ARCHIVE: %s | 17252 | #+ARCHIVE: %s |
| 14730 | #+LINK: %s | 17253 | #+LINK: %s |
| @@ -14750,11 +17273,14 @@ Does include HTML export options as well as TODO and CATEGORY stuff." | |||
| 14750 | "Me Jason Marie DONE") | 17273 | "Me Jason Marie DONE") |
| 14751 | (cdr (assoc org-startup-folded | 17274 | (cdr (assoc org-startup-folded |
| 14752 | '((nil . "showall") (t . "overview") (content . "content")))) | 17275 | '((nil . "showall") (t . "overview") (content . "content")))) |
| 14753 | (if org-startup-with-deadline-check "dlcheck" "nodlcheck") | ||
| 14754 | (if org-odd-levels-only "odd" "oddeven") | 17276 | (if org-odd-levels-only "odd" "oddeven") |
| 14755 | (if org-hide-leading-stars "hidestars" "showstars") | 17277 | (if org-hide-leading-stars "hidestars" "showstars") |
| 14756 | (if org-startup-align-all-tables "align" "noalign") | 17278 | (if org-startup-align-all-tables "align" "noalign") |
| 14757 | (if org-log-done "logging" "nologging") | 17279 | (cond ((eq t org-log-done) "logdone") |
| 17280 | ((not org-log-done) "nologging") | ||
| 17281 | ((listp org-log-done) | ||
| 17282 | (mapconcat (lambda (x) (concat "lognote" (symbol-name x))) | ||
| 17283 | org-log-done " "))) | ||
| 14758 | (or (mapconcat (lambda (x) | 17284 | (or (mapconcat (lambda (x) |
| 14759 | (cond | 17285 | (cond |
| 14760 | ((equal '(:startgroup) x) "{") | 17286 | ((equal '(:startgroup) x) "{") |
| @@ -14849,6 +17375,7 @@ org-mode's default settings, but still inferior to file-local settings." | |||
| 14849 | (setq-default org-todo-line-regexp org-todo-line-regexp) | 17375 | (setq-default org-todo-line-regexp org-todo-line-regexp) |
| 14850 | (setq-default org-deadline-line-regexp org-deadline-line-regexp) | 17376 | (setq-default org-deadline-line-regexp org-deadline-line-regexp) |
| 14851 | (setq-default org-done-string org-done-string) | 17377 | (setq-default org-done-string org-done-string) |
| 17378 | (setq-default org-maybe-keyword-time-regexp org-maybe-keyword-time-regexp) | ||
| 14852 | (let* ((opt-plist (org-combine-plists (org-default-export-plist) | 17379 | (let* ((opt-plist (org-combine-plists (org-default-export-plist) |
| 14853 | ext-plist | 17380 | ext-plist |
| 14854 | (org-infile-export-plist))) | 17381 | (org-infile-export-plist))) |
| @@ -14869,13 +17396,14 @@ org-mode's default settings, but still inferior to file-local settings." | |||
| 14869 | (all_lines | 17396 | (all_lines |
| 14870 | (org-skip-comments (org-split-string | 17397 | (org-skip-comments (org-split-string |
| 14871 | (org-cleaned-string-for-export | 17398 | (org-cleaned-string-for-export |
| 14872 | region :emph-multiline | 17399 | region :emph-multiline :for-html |
| 14873 | (if (plist-get opt-plist :LaTeX-fragments) | 17400 | (if (plist-get opt-plist :LaTeX-fragments) |
| 14874 | :LaTeX-fragments)) | 17401 | :LaTeX-fragments)) |
| 14875 | "[\r\n]"))) | 17402 | "[\r\n]"))) |
| 14876 | (lines (org-export-find-first-heading-line all_lines)) | 17403 | (lines (org-export-find-first-heading-line all_lines)) |
| 14877 | (level 0) (line "") (origline "") txt todo | 17404 | (level 0) (line "") (origline "") txt todo |
| 14878 | (umax nil) | 17405 | (umax nil) |
| 17406 | (umax-toc nil) | ||
| 14879 | (filename (concat (file-name-as-directory | 17407 | (filename (concat (file-name-as-directory |
| 14880 | (org-export-directory :html opt-plist)) | 17408 | (org-export-directory :html opt-plist)) |
| 14881 | (file-name-sans-extension | 17409 | (file-name-sans-extension |
| @@ -14883,7 +17411,7 @@ org-mode's default settings, but still inferior to file-local settings." | |||
| 14883 | ".html")) | 17411 | ".html")) |
| 14884 | (current-dir (file-name-directory buffer-file-name)) | 17412 | (current-dir (file-name-directory buffer-file-name)) |
| 14885 | (buffer (find-file-noselect filename)) | 17413 | (buffer (find-file-noselect filename)) |
| 14886 | (levels-open (make-vector org-level-max nil)) | 17414 | (org-levels-open (make-vector org-level-max nil)) |
| 14887 | (date (format-time-string "%Y/%m/%d" (current-time))) | 17415 | (date (format-time-string "%Y/%m/%d" (current-time))) |
| 14888 | (time (format-time-string "%X" (org-current-time))) | 17416 | (time (format-time-string "%X" (org-current-time))) |
| 14889 | (author (plist-get opt-plist :author)) | 17417 | (author (plist-get opt-plist :author)) |
| @@ -14927,7 +17455,7 @@ org-mode's default settings, but still inferior to file-local settings." | |||
| 14927 | (assoc "en" org-export-language-setup))) | 17455 | (assoc "en" org-export-language-setup))) |
| 14928 | 17456 | ||
| 14929 | ;; Switch to the output buffer | 17457 | ;; Switch to the output buffer |
| 14930 | (if (or hidden (not org-export-html-show-new-buffer)) | 17458 | (if (or hidden t) |
| 14931 | (set-buffer buffer) | 17459 | (set-buffer buffer) |
| 14932 | (switch-to-buffer-other-window buffer)) | 17460 | (switch-to-buffer-other-window buffer)) |
| 14933 | (erase-buffer) | 17461 | (erase-buffer) |
| @@ -14942,6 +17470,9 @@ org-mode's default settings, but still inferior to file-local settings." | |||
| 14942 | org-export-plist-vars) | 17470 | org-export-plist-vars) |
| 14943 | (setq umax (if arg (prefix-numeric-value arg) | 17471 | (setq umax (if arg (prefix-numeric-value arg) |
| 14944 | org-export-headline-levels)) | 17472 | org-export-headline-levels)) |
| 17473 | (setq umax-toc (if (integerp org-export-with-toc) | ||
| 17474 | (min org-export-with-toc umax) | ||
| 17475 | umax)) | ||
| 14945 | 17476 | ||
| 14946 | ;; File header | 17477 | ;; File header |
| 14947 | (insert (format | 17478 | (insert (format |
| @@ -14994,7 +17525,7 @@ lang=\"%s\" xml:lang=\"%s\"> | |||
| 14994 | org-done-string))) | 17525 | org-done-string))) |
| 14995 | ; TODO, not DONE | 17526 | ; TODO, not DONE |
| 14996 | (and org-export-mark-todo-in-toc | 17527 | (and org-export-mark-todo-in-toc |
| 14997 | (= level umax) | 17528 | (= level umax-toc) |
| 14998 | (org-search-todo-below | 17529 | (org-search-todo-below |
| 14999 | line lines level)))) | 17530 | line lines level)))) |
| 15000 | (if (and (memq org-export-with-tags '(not-in-toc nil)) | 17531 | (if (and (memq org-export-with-tags '(not-in-toc nil)) |
| @@ -15005,7 +17536,7 @@ lang=\"%s\" xml:lang=\"%s\"> | |||
| 15005 | (if org-export-with-section-numbers | 17536 | (if org-export-with-section-numbers |
| 15006 | (setq txt (concat (org-section-number level) | 17537 | (setq txt (concat (org-section-number level) |
| 15007 | " " txt))) | 17538 | " " txt))) |
| 15008 | (if (<= level umax) | 17539 | (if (<= level umax-toc) |
| 15009 | (progn | 17540 | (progn |
| 15010 | (setq head-count (+ head-count 1)) | 17541 | (setq head-count (+ head-count 1)) |
| 15011 | (if (> level org-last-level) | 17542 | (if (> level org-last-level) |
| @@ -15075,6 +17606,15 @@ lang=\"%s\" xml:lang=\"%s\"> | |||
| 15075 | (insert "</pre>\n")) | 17606 | (insert "</pre>\n")) |
| 15076 | (throw 'nextline nil)) | 17607 | (throw 'nextline nil)) |
| 15077 | 17608 | ||
| 17609 | ;; Protected HTML | ||
| 17610 | (when (get-text-property 0 'org-protected line) | ||
| 17611 | (insert line "\n") | ||
| 17612 | (throw 'nextline nil)) | ||
| 17613 | |||
| 17614 | ;; Horizontal line | ||
| 17615 | (when (string-match "^[ \t]*-\\{5,\\}[ \t]*$" line) | ||
| 17616 | (insert "\n<hr/>\n") | ||
| 17617 | (throw 'nextline nil)) | ||
| 15078 | 17618 | ||
| 15079 | ;; make targets to anchors | 17619 | ;; make targets to anchors |
| 15080 | (while (string-match "<<<?\\([^<>]*\\)>>>?\\((INVISIBLE)\\)?[ \t]*\n?" line) | 17620 | (while (string-match "<<<?\\([^<>]*\\)>>>?\\((INVISIBLE)\\)?[ \t]*\n?" line) |
| @@ -15114,6 +17654,12 @@ lang=\"%s\" xml:lang=\"%s\"> | |||
| 15114 | desc2 (if (match-end 2) (concat type ":" path) path) | 17654 | desc2 (if (match-end 2) (concat type ":" path) path) |
| 15115 | descp (and desc1 (not (equal desc1 desc2))) | 17655 | descp (and desc1 (not (equal desc1 desc2))) |
| 15116 | desc (or desc1 desc2)) | 17656 | desc (or desc1 desc2)) |
| 17657 | ;; Make an image out of the description if that is so wanted | ||
| 17658 | (when (and descp (org-file-image-p desc)) | ||
| 17659 | (save-match-data | ||
| 17660 | (if (string-match "^file:" desc) | ||
| 17661 | (setq desc (substring desc (match-end 0))))) | ||
| 17662 | (setq desc (concat "<img src=\"" desc "\"/>"))) | ||
| 15117 | ;; FIXME: do we need to unescape here somewhere? | 17663 | ;; FIXME: do we need to unescape here somewhere? |
| 15118 | (cond | 17664 | (cond |
| 15119 | ((equal type "internal") | 17665 | ((equal type "internal") |
| @@ -15122,7 +17668,15 @@ lang=\"%s\" xml:lang=\"%s\"> | |||
| 15122 | "<a href=\"#" | 17668 | "<a href=\"#" |
| 15123 | (org-solidify-link-text path target-alist) | 17669 | (org-solidify-link-text path target-alist) |
| 15124 | "\">" desc "</a>"))) | 17670 | "\">" desc "</a>"))) |
| 15125 | ((member type '("http" "https" "ftp" "mailto" "news")) | 17671 | ((member type '("http" "https")) ; FIXME: need to test this. |
| 17672 | ;; standard URL, just check if we need to inline an image | ||
| 17673 | (if (and (or (eq t org-export-html-inline-images) | ||
| 17674 | (and org-export-html-inline-images (not descp))) | ||
| 17675 | (org-file-image-p path)) | ||
| 17676 | (setq rpl (concat "<img src=\"" type ":" path "\"/>")) | ||
| 17677 | (setq link (concat type ":" path)) | ||
| 17678 | (setq rpl (concat "<a href=\"" link "\">" desc "</a>")))) | ||
| 17679 | ((member type '("ftp" "mailto" "news")) | ||
| 15126 | ;; standard URL | 17680 | ;; standard URL |
| 15127 | (setq link (concat type ":" path)) | 17681 | (setq link (concat type ":" path)) |
| 15128 | (setq rpl (concat "<a href=\"" link "\">" desc "</a>"))) | 17682 | (setq rpl (concat "<a href=\"" link "\">" desc "</a>"))) |
| @@ -15139,8 +17693,7 @@ lang=\"%s\" xml:lang=\"%s\"> | |||
| 15139 | (if (functionp link-validate) | 17693 | (if (functionp link-validate) |
| 15140 | (funcall link-validate filename current-dir) | 17694 | (funcall link-validate filename current-dir) |
| 15141 | t)) | 17695 | t)) |
| 15142 | (setq file-is-image-p | 17696 | (setq file-is-image-p (org-file-image-p filename)) |
| 15143 | (string-match (org-image-file-name-regexp) filename)) | ||
| 15144 | (setq thefile (if abs-p (expand-file-name filename) filename)) | 17697 | (setq thefile (if abs-p (expand-file-name filename) filename)) |
| 15145 | (when (and org-export-html-link-org-files-as-html | 17698 | (when (and org-export-html-link-org-files-as-html |
| 15146 | (string-match "\\.org$" thefile)) | 17699 | (string-match "\\.org$" thefile)) |
| @@ -15351,8 +17904,9 @@ lang=\"%s\" xml:lang=\"%s\"> | |||
| 15351 | ;; Need to use the code generator in table.el, with the original text. | 17904 | ;; Need to use the code generator in table.el, with the original text. |
| 15352 | (org-format-table-table-html-using-table-generate-source olines))))) | 17905 | (org-format-table-table-html-using-table-generate-source olines))))) |
| 15353 | 17906 | ||
| 15354 | (defun org-format-org-table-html (lines) | 17907 | (defun org-format-org-table-html (lines &optional splice) |
| 15355 | "Format a table into HTML." | 17908 | "Format a table into HTML." |
| 17909 | ;; Get rid of hlines at beginning and end | ||
| 15356 | (if (string-match "^[ \t]*|-" (car lines)) (setq lines (cdr lines))) | 17910 | (if (string-match "^[ \t]*|-" (car lines)) (setq lines (cdr lines))) |
| 15357 | (setq lines (nreverse lines)) | 17911 | (setq lines (nreverse lines)) |
| 15358 | (if (string-match "^[ \t]*|-" (car lines)) (setq lines (cdr lines))) | 17912 | (if (string-match "^[ \t]*|-" (car lines)) (setq lines (cdr lines))) |
| @@ -15360,52 +17914,79 @@ lang=\"%s\" xml:lang=\"%s\"> | |||
| 15360 | (when org-export-table-remove-special-lines | 17914 | (when org-export-table-remove-special-lines |
| 15361 | ;; Check if the table has a marking column. If yes remove the | 17915 | ;; Check if the table has a marking column. If yes remove the |
| 15362 | ;; column and the special lines | 17916 | ;; column and the special lines |
| 15363 | (let* ((special | 17917 | (setq lines (org-table-clean-before-export lines))) |
| 15364 | (not | ||
| 15365 | (memq nil | ||
| 15366 | (mapcar | ||
| 15367 | (lambda (x) | ||
| 15368 | (or (string-match "^[ \t]*|-" x) | ||
| 15369 | (string-match "^[ \t]*| *\\([#!$*_^ ]\\) *|" x))) | ||
| 15370 | lines))))) | ||
| 15371 | (if special | ||
| 15372 | (setq lines | ||
| 15373 | (delq nil | ||
| 15374 | (mapcar | ||
| 15375 | (lambda (x) | ||
| 15376 | (if (string-match "^[ \t]*| *[!_^] *|" x) | ||
| 15377 | nil ; ignore this line | ||
| 15378 | (and (or (string-match "^[ \t]*|-+\\+" x) | ||
| 15379 | (string-match "^[ \t]*|[^|]*|" x)) | ||
| 15380 | (replace-match "|" t t x)))) | ||
| 15381 | lines)))))) | ||
| 15382 | 17918 | ||
| 15383 | (let ((head (and org-export-highlight-first-table-line | 17919 | (let ((head (and org-export-highlight-first-table-line |
| 15384 | (delq nil (mapcar | 17920 | (delq nil (mapcar |
| 15385 | (lambda (x) (string-match "^[ \t]*|-" x)) | 17921 | (lambda (x) (string-match "^[ \t]*|-" x)) |
| 15386 | (cdr lines))))) | 17922 | (cdr lines))))) |
| 15387 | line fields html) | 17923 | (nlines 0) fnum i |
| 15388 | (setq html (concat org-export-html-table-tag "\n")) | 17924 | tbopen line fields html) |
| 17925 | (if splice (setq head nil)) | ||
| 17926 | (unless splice (push (if head "<thead>" "<tbody>") html)) | ||
| 17927 | (setq tbopen t) | ||
| 15389 | (while (setq line (pop lines)) | 17928 | (while (setq line (pop lines)) |
| 15390 | (catch 'next-line | 17929 | (catch 'next-line |
| 15391 | (if (string-match "^[ \t]*|-" line) | 17930 | (if (string-match "^[ \t]*|-" line) |
| 15392 | (progn | 17931 | (progn |
| 17932 | (unless splice | ||
| 17933 | (push (if head "</thead>" "</tbody>") html) | ||
| 17934 | (if lines (push "<tbody>" html) (setq tbopen nil))) | ||
| 15393 | (setq head nil) ;; head ends here, first time around | 17935 | (setq head nil) ;; head ends here, first time around |
| 15394 | ;; ignore this line | 17936 | ;; ignore this line |
| 15395 | (throw 'next-line t))) | 17937 | (throw 'next-line t))) |
| 15396 | ;; Break the line into fields | 17938 | ;; Break the line into fields |
| 15397 | (setq fields (org-split-string line "[ \t]*|[ \t]*")) | 17939 | (setq fields (org-split-string line "[ \t]*|[ \t]*")) |
| 15398 | (setq html (concat | 17940 | (unless fnum (setq fnum (make-vector (length fields) 0))) |
| 15399 | html | 17941 | (setq nlines (1+ nlines) i -1) |
| 15400 | "<tr>" | 17942 | (push (concat "<tr>" |
| 15401 | (mapconcat (lambda (x) | 17943 | (mapconcat |
| 15402 | (if head | 17944 | (lambda (x) |
| 15403 | (concat "<th>" x "</th>") | 17945 | (setq i (1+ i)) |
| 15404 | (concat "<td>" x "</td>"))) | 17946 | (if (and (< i nlines) |
| 15405 | fields "") | 17947 | (string-match org-table-number-regexp x)) |
| 15406 | "</tr>\n")))) | 17948 | (incf (aref fnum i))) |
| 15407 | (setq html (concat html "</table>\n")) | 17949 | (if head |
| 15408 | html)) | 17950 | (concat "<th>" x "</th>") |
| 17951 | (concat "<td>" x "</td>"))) | ||
| 17952 | fields "") | ||
| 17953 | "</tr>") | ||
| 17954 | html))) | ||
| 17955 | (unless splice (if tbopen (push "</tbody>" html))) | ||
| 17956 | (unless splice (push "</table>\n" html)) | ||
| 17957 | (setq html (nreverse html)) | ||
| 17958 | (unless splice | ||
| 17959 | ;; Put in COL tags with the alignment (unfortuntely often ignored...) | ||
| 17960 | (push (mapconcat | ||
| 17961 | (lambda (x) | ||
| 17962 | (format "<COL align=\"%s\">" | ||
| 17963 | (if (> (/ (float x) nlines) org-table-number-fraction) | ||
| 17964 | "right" "left"))) | ||
| 17965 | fnum "") | ||
| 17966 | html) | ||
| 17967 | (push org-export-html-table-tag html)) | ||
| 17968 | (concat (mapconcat 'identity html "\n") "\n"))) | ||
| 17969 | |||
| 17970 | (defun org-table-clean-before-export (lines) | ||
| 17971 | "Check if the table has a marking column. | ||
| 17972 | If yes remove the column and the special lines." | ||
| 17973 | (if (memq nil | ||
| 17974 | (mapcar | ||
| 17975 | (lambda (x) (or (string-match "^[ \t]*|-" x) | ||
| 17976 | (string-match "^[ \t]*| *\\([#!$*_^ /]\\) *|" x))) | ||
| 17977 | lines)) | ||
| 17978 | (progn | ||
| 17979 | (setq org-table-clean-did-remove-column-1 nil) | ||
| 17980 | lines) | ||
| 17981 | (setq org-table-clean-did-remove-column-1 t) | ||
| 17982 | (delq nil | ||
| 17983 | (mapcar | ||
| 17984 | (lambda (x) (if (string-match "^[ \t]*| *[!_^/] *|" x) | ||
| 17985 | nil ; ignore this line | ||
| 17986 | (and (or (string-match "^[ \t]*|-+\\+" x) | ||
| 17987 | (string-match "^[ \t]*|[^|]*|" x)) | ||
| 17988 | (replace-match "|" t t x)))) | ||
| 17989 | lines)))) | ||
| 15409 | 17990 | ||
| 15410 | (defun org-fake-empty-table-line (line) | 17991 | (defun org-fake-empty-table-line (line) |
| 15411 | "Replace everything except \"|\" with spaces." | 17992 | "Replace everything except \"|\" with spaces." |
| @@ -15494,7 +18075,8 @@ But it has the disadvantage, that Org-mode's HTML conversions cannot be used." | |||
| 15494 | (format "@<span class=\"timestamp-kwd\">%s @</span>" | 18075 | (format "@<span class=\"timestamp-kwd\">%s @</span>" |
| 15495 | (match-string 1 s))) | 18076 | (match-string 1 s))) |
| 15496 | (format " @<span class=\"timestamp\">%s@</span>" | 18077 | (format " @<span class=\"timestamp\">%s@</span>" |
| 15497 | (substring (match-string 3 s) 1 -1))) | 18078 | (substring |
| 18079 | (org-translate-time (match-string 3 s)) 1 -1))) | ||
| 15498 | s (substring s (match-end 0))))) | 18080 | s (substring s (match-end 0))))) |
| 15499 | ;; Line break if line started and ended with time stamp stuff | 18081 | ;; Line break if line started and ended with time stamp stuff |
| 15500 | (if (not r) | 18082 | (if (not r) |
| @@ -15635,10 +18217,10 @@ When TITLE is nil, just close all open levels." | |||
| 15635 | (org-close-par-maybe) | 18217 | (org-close-par-maybe) |
| 15636 | (let ((l (1+ (max level umax)))) | 18218 | (let ((l (1+ (max level umax)))) |
| 15637 | (while (<= l org-level-max) | 18219 | (while (<= l org-level-max) |
| 15638 | (if (aref levels-open (1- l)) | 18220 | (if (aref org-levels-open (1- l)) |
| 15639 | (progn | 18221 | (progn |
| 15640 | (org-html-level-close l) | 18222 | (org-html-level-close l) |
| 15641 | (aset levels-open (1- l) nil))) | 18223 | (aset org-levels-open (1- l) nil))) |
| 15642 | (setq l (1+ l))) | 18224 | (setq l (1+ l))) |
| 15643 | (when title | 18225 | (when title |
| 15644 | ;; If title is nil, this means this function is called to close | 18226 | ;; If title is nil, this means this function is called to close |
| @@ -15657,11 +18239,11 @@ When TITLE is nil, just close all open levels." | |||
| 15657 | t t title))) | 18239 | t t title))) |
| 15658 | (if (> level umax) | 18240 | (if (> level umax) |
| 15659 | (progn | 18241 | (progn |
| 15660 | (if (aref levels-open (1- level)) | 18242 | (if (aref org-levels-open (1- level)) |
| 15661 | (progn | 18243 | (progn |
| 15662 | (org-close-li) | 18244 | (org-close-li) |
| 15663 | (insert "<li>" title "<br/>\n")) | 18245 | (insert "<li>" title "<br/>\n")) |
| 15664 | (aset levels-open (1- level) t) | 18246 | (aset org-levels-open (1- level) t) |
| 15665 | (org-close-par-maybe) | 18247 | (org-close-par-maybe) |
| 15666 | (insert "<ul>\n<li>" title "<br/>\n"))) | 18248 | (insert "<ul>\n<li>" title "<br/>\n"))) |
| 15667 | (if org-export-with-section-numbers | 18249 | (if org-export-with-section-numbers |
| @@ -15678,52 +18260,7 @@ When TITLE is nil, just close all open levels." | |||
| 15678 | (org-close-li) | 18260 | (org-close-li) |
| 15679 | (insert "</ul>")) | 18261 | (insert "</ul>")) |
| 15680 | 18262 | ||
| 15681 | ;; Variable holding the vector with section numbers | 18263 | ;;; iCalendar export |
| 15682 | (defvar org-section-numbers (make-vector org-level-max 0)) | ||
| 15683 | |||
| 15684 | (defun org-init-section-numbers () | ||
| 15685 | "Initialize the vector for the section numbers." | ||
| 15686 | (let* ((level -1) | ||
| 15687 | (numbers (nreverse (org-split-string "" "\\."))) | ||
| 15688 | (depth (1- (length org-section-numbers))) | ||
| 15689 | (i depth) number-string) | ||
| 15690 | (while (>= i 0) | ||
| 15691 | (if (> i level) | ||
| 15692 | (aset org-section-numbers i 0) | ||
| 15693 | (setq number-string (or (car numbers) "0")) | ||
| 15694 | (if (string-match "\\`[A-Z]\\'" number-string) | ||
| 15695 | (aset org-section-numbers i | ||
| 15696 | (- (string-to-char number-string) ?A -1)) | ||
| 15697 | (aset org-section-numbers i (string-to-number number-string))) | ||
| 15698 | (pop numbers)) | ||
| 15699 | (setq i (1- i))))) | ||
| 15700 | |||
| 15701 | (defun org-section-number (&optional level) | ||
| 15702 | "Return a string with the current section number. | ||
| 15703 | When LEVEL is non-nil, increase section numbers on that level." | ||
| 15704 | (let* ((depth (1- (length org-section-numbers))) idx n (string "")) | ||
| 15705 | (when level | ||
| 15706 | (when (> level -1) | ||
| 15707 | (aset org-section-numbers | ||
| 15708 | level (1+ (aref org-section-numbers level)))) | ||
| 15709 | (setq idx (1+ level)) | ||
| 15710 | (while (<= idx depth) | ||
| 15711 | (if (not (= idx 1)) | ||
| 15712 | (aset org-section-numbers idx 0)) | ||
| 15713 | (setq idx (1+ idx)))) | ||
| 15714 | (setq idx 0) | ||
| 15715 | (while (<= idx depth) | ||
| 15716 | (setq n (aref org-section-numbers idx)) | ||
| 15717 | (setq string (concat string (if (not (string= string "")) "." "") | ||
| 15718 | (int-to-string n))) | ||
| 15719 | (setq idx (1+ idx))) | ||
| 15720 | (save-match-data | ||
| 15721 | (if (string-match "\\`\\([@0]\\.\\)+" string) | ||
| 15722 | (setq string (replace-match "" t nil string))) | ||
| 15723 | (if (string-match "\\(\\.0\\)+\\'" string) | ||
| 15724 | (setq string (replace-match "" t nil string)))) | ||
| 15725 | string)) | ||
| 15726 | |||
| 15727 | 18264 | ||
| 15728 | ;;;###autoload | 18265 | ;;;###autoload |
| 15729 | (defun org-export-icalendar-this-file () | 18266 | (defun org-export-icalendar-this-file () |
| @@ -15733,89 +18270,6 @@ file, but with extension `.ics'." | |||
| 15733 | (interactive) | 18270 | (interactive) |
| 15734 | (org-export-icalendar nil buffer-file-name)) | 18271 | (org-export-icalendar nil buffer-file-name)) |
| 15735 | 18272 | ||
| 15736 | (defun org-export-as-xoxo-insert-into (buffer &rest output) | ||
| 15737 | (with-current-buffer buffer | ||
| 15738 | (apply 'insert output))) | ||
| 15739 | (put 'org-export-as-xoxo-insert-into 'lisp-indent-function 1) | ||
| 15740 | |||
| 15741 | (defun org-export-as-xoxo (&optional buffer) | ||
| 15742 | "Export the org buffer as XOXO. | ||
| 15743 | The XOXO buffer is named *xoxo-<source buffer name>*" | ||
| 15744 | (interactive (list (current-buffer))) | ||
| 15745 | ;; A quickie abstraction | ||
| 15746 | |||
| 15747 | ;; Output everything as XOXO | ||
| 15748 | (with-current-buffer (get-buffer buffer) | ||
| 15749 | (goto-char (point-min)) ;; CD: beginning-of-buffer is not allowed. | ||
| 15750 | (let* ((opt-plist (org-combine-plists (org-default-export-plist) | ||
| 15751 | (org-infile-export-plist))) | ||
| 15752 | (filename (concat (file-name-as-directory | ||
| 15753 | (org-export-directory :xoxo opt-plist)) | ||
| 15754 | (file-name-sans-extension | ||
| 15755 | (file-name-nondirectory buffer-file-name)) | ||
| 15756 | ".html")) | ||
| 15757 | (out (find-file-noselect filename)) | ||
| 15758 | (last-level 1) | ||
| 15759 | (hanging-li nil)) | ||
| 15760 | ;; Check the output buffer is empty. | ||
| 15761 | (with-current-buffer out (erase-buffer)) | ||
| 15762 | ;; Kick off the output | ||
| 15763 | (org-export-as-xoxo-insert-into out "<ol class='xoxo'>\n") | ||
| 15764 | (while (re-search-forward "^\\(\\*+\\) \\(.+\\)" (point-max) 't) | ||
| 15765 | (let* ((hd (match-string-no-properties 1)) | ||
| 15766 | (level (length hd)) | ||
| 15767 | (text (concat | ||
| 15768 | (match-string-no-properties 2) | ||
| 15769 | (save-excursion | ||
| 15770 | (goto-char (match-end 0)) | ||
| 15771 | (let ((str "")) | ||
| 15772 | (catch 'loop | ||
| 15773 | (while 't | ||
| 15774 | (forward-line) | ||
| 15775 | (if (looking-at "^[ \t]\\(.*\\)") | ||
| 15776 | (setq str (concat str (match-string-no-properties 1))) | ||
| 15777 | (throw 'loop str))))))))) | ||
| 15778 | |||
| 15779 | ;; Handle level rendering | ||
| 15780 | (cond | ||
| 15781 | ((> level last-level) | ||
| 15782 | (org-export-as-xoxo-insert-into out "\n<ol>\n")) | ||
| 15783 | |||
| 15784 | ((< level last-level) | ||
| 15785 | (dotimes (- (- last-level level) 1) | ||
| 15786 | (if hanging-li | ||
| 15787 | (org-export-as-xoxo-insert-into out "</li>\n")) | ||
| 15788 | (org-export-as-xoxo-insert-into out "</ol>\n")) | ||
| 15789 | (when hanging-li | ||
| 15790 | (org-export-as-xoxo-insert-into out "</li>\n") | ||
| 15791 | (setq hanging-li nil))) | ||
| 15792 | |||
| 15793 | ((equal level last-level) | ||
| 15794 | (if hanging-li | ||
| 15795 | (org-export-as-xoxo-insert-into out "</li>\n"))) | ||
| 15796 | ) | ||
| 15797 | |||
| 15798 | (setq last-level level) | ||
| 15799 | |||
| 15800 | ;; And output the new li | ||
| 15801 | (setq hanging-li 't) | ||
| 15802 | (if (equal ?+ (elt text 0)) | ||
| 15803 | (org-export-as-xoxo-insert-into out "<li class='" (substring text 1) "'>") | ||
| 15804 | (org-export-as-xoxo-insert-into out "<li>" text)))) | ||
| 15805 | |||
| 15806 | ;; Finally finish off the ol | ||
| 15807 | (dotimes (- last-level 1) | ||
| 15808 | (if hanging-li | ||
| 15809 | (org-export-as-xoxo-insert-into out "</li>\n")) | ||
| 15810 | (org-export-as-xoxo-insert-into out "</ol>\n")) | ||
| 15811 | |||
| 15812 | ;; Finish the buffer off and clean it up. | ||
| 15813 | (switch-to-buffer-other-window out) | ||
| 15814 | (indent-region (point-min) (point-max) nil) | ||
| 15815 | (save-buffer) | ||
| 15816 | (goto-char (point-min)) | ||
| 15817 | ))) | ||
| 15818 | |||
| 15819 | ;;;###autoload | 18273 | ;;;###autoload |
| 15820 | (defun org-export-icalendar-all-agenda-files () | 18274 | (defun org-export-icalendar-all-agenda-files () |
| 15821 | "Export all files in `org-agenda-files' to iCalendar .ics files. | 18275 | "Export all files in `org-agenda-files' to iCalendar .ics files. |
| @@ -15868,7 +18322,7 @@ file and store it under the name `org-combined-agenda-icalendar-file'." | |||
| 15868 | (and (not started) (setq started t) | 18322 | (and (not started) (setq started t) |
| 15869 | (org-start-icalendar-file org-icalendar-combined-name)) | 18323 | (org-start-icalendar-file org-icalendar-combined-name)) |
| 15870 | (org-start-icalendar-file category)) | 18324 | (org-start-icalendar-file category)) |
| 15871 | (org-print-icalendar-entries combine category) | 18325 | (org-print-icalendar-entries combine) |
| 15872 | (when (or (and combine (not files)) (not combine)) | 18326 | (when (or (and combine (not files)) (not combine)) |
| 15873 | (org-finish-icalendar-file) | 18327 | (org-finish-icalendar-file) |
| 15874 | (set-buffer ical-buffer) | 18328 | (set-buffer ical-buffer) |
| @@ -15882,21 +18336,24 @@ The iCalendar buffer is still current when this hook is run. | |||
| 15882 | A good way to use this is to tell a desktop calenndar application to re-read | 18336 | A good way to use this is to tell a desktop calenndar application to re-read |
| 15883 | the iCalendar file.") | 18337 | the iCalendar file.") |
| 15884 | 18338 | ||
| 15885 | (defun org-print-icalendar-entries (&optional combine category) | 18339 | (defun org-print-icalendar-entries (&optional combine) |
| 15886 | "Print iCalendar entries for the current Org-mode file to `standard-output'. | 18340 | "Print iCalendar entries for the current Org-mode file to `standard-output'. |
| 15887 | When COMBINE is non nil, add the category to each line." | 18341 | When COMBINE is non nil, add the category to each line." |
| 15888 | (let ((re2 (concat "--?-?\\(" org-ts-regexp "\\)")) | 18342 | (let ((re2 (concat "--?-?\\(" org-ts-regexp "\\)")) |
| 18343 | (org-category-table (org-get-category-table)) | ||
| 15889 | (dts (org-ical-ts-to-string | 18344 | (dts (org-ical-ts-to-string |
| 15890 | (format-time-string (cdr org-time-stamp-formats) (current-time)) | 18345 | (format-time-string (cdr org-time-stamp-formats) (current-time)) |
| 15891 | "DTSTART")) | 18346 | "DTSTART")) |
| 15892 | hd ts ts2 state (inc t) pos scheduledp deadlinep tmp pri) | 18347 | hd ts ts2 state status (inc t) pos |
| 18348 | scheduledp deadlinep tmp pri category) | ||
| 15893 | (save-excursion | 18349 | (save-excursion |
| 15894 | (goto-char (point-min)) | 18350 | (goto-char (point-min)) |
| 15895 | (while (re-search-forward org-ts-regexp nil t) | 18351 | (while (re-search-forward org-ts-regexp nil t) |
| 15896 | (setq pos (match-beginning 0) | 18352 | (setq pos (match-beginning 0) |
| 15897 | ts (match-string 0) | 18353 | ts (match-string 0) |
| 15898 | inc t | 18354 | inc t |
| 15899 | hd (org-get-heading)) | 18355 | hd (org-get-heading) |
| 18356 | category (org-get-category)) | ||
| 15900 | (if (looking-at re2) | 18357 | (if (looking-at re2) |
| 15901 | (progn | 18358 | (progn |
| 15902 | (goto-char (match-end 0)) | 18359 | (goto-char (match-end 0)) |
| @@ -15912,28 +18369,35 @@ When COMBINE is non nil, add the category to each line." | |||
| 15912 | (if (or (string-match org-tr-regexp hd) | 18369 | (if (or (string-match org-tr-regexp hd) |
| 15913 | (string-match org-ts-regexp hd)) | 18370 | (string-match org-ts-regexp hd)) |
| 15914 | (setq hd (replace-match "" t t hd))) | 18371 | (setq hd (replace-match "" t t hd))) |
| 15915 | (if combine | 18372 | (if (string-match org-bracket-link-regexp hd) |
| 15916 | (setq hd (concat hd " (category " category ")"))) | 18373 | (setq hd (replace-match (if (match-end 3) (match-string 3 hd) |
| 15917 | (if deadlinep (setq hd (concat "DL: " hd " This is a deadline"))) | 18374 | (match-string 1 hd)) |
| 15918 | (if scheduledp (setq hd (concat "S: " hd " Scheduled for this date"))) | 18375 | t t hd))) |
| 18376 | (if deadlinep (setq hd (concat "DL: " hd))) | ||
| 18377 | (if scheduledp (setq hd (concat "S: " hd))) | ||
| 15919 | (princ (format "BEGIN:VEVENT | 18378 | (princ (format "BEGIN:VEVENT |
| 15920 | %s | 18379 | %s |
| 15921 | %s | 18380 | %s |
| 15922 | SUMMARY:%s | 18381 | SUMMARY:%s |
| 18382 | CATEGORIES:%s | ||
| 15923 | END:VEVENT\n" | 18383 | END:VEVENT\n" |
| 15924 | (org-ical-ts-to-string ts "DTSTART") | 18384 | (org-ical-ts-to-string ts "DTSTART") |
| 15925 | (org-ical-ts-to-string ts2 "DTEND" inc) | 18385 | (org-ical-ts-to-string ts2 "DTEND" inc) |
| 15926 | hd))) | 18386 | hd category))) |
| 15927 | (when org-icalendar-include-todo | 18387 | (when org-icalendar-include-todo |
| 15928 | (goto-char (point-min)) | 18388 | (goto-char (point-min)) |
| 15929 | (while (re-search-forward org-todo-line-regexp nil t) | 18389 | (while (re-search-forward org-todo-line-regexp nil t) |
| 15930 | (setq state (match-string 1)) | 18390 | (setq state (match-string 2)) |
| 15931 | (unless (equal state org-done-string) | 18391 | (setq status (if (equal state org-done-string) |
| 18392 | "COMPLETED" "NEEDS-ACTION")) | ||
| 18393 | (when (and state | ||
| 18394 | (or (not (equal state org-done-string)) | ||
| 18395 | (eq org-icalendar-include-todo 'all))) | ||
| 15932 | (setq hd (match-string 3)) | 18396 | (setq hd (match-string 3)) |
| 15933 | (if (string-match org-priority-regexp hd) | 18397 | (if (string-match org-priority-regexp hd) |
| 15934 | (setq pri (string-to-char (match-string 2 hd)) | 18398 | (setq pri (string-to-char (match-string 2 hd)) |
| 15935 | hd (concat (substring hd 0 (match-beginning 1)) | 18399 | hd (concat (substring hd 0 (match-beginning 1)) |
| 15936 | (substring hd (- (match-end 1))))) | 18400 | (substring hd (match-end 1)))) |
| 15937 | (setq pri org-default-priority)) | 18401 | (setq pri org-default-priority)) |
| 15938 | (setq pri (floor (1+ (* 8. (/ (float (- org-lowest-priority pri)) | 18402 | (setq pri (floor (1+ (* 8. (/ (float (- org-lowest-priority pri)) |
| 15939 | (- org-lowest-priority ?A)))))) | 18403 | (- org-lowest-priority ?A)))))) |
| @@ -15941,10 +18405,12 @@ END:VEVENT\n" | |||
| 15941 | (princ (format "BEGIN:VTODO | 18405 | (princ (format "BEGIN:VTODO |
| 15942 | %s | 18406 | %s |
| 15943 | SUMMARY:%s | 18407 | SUMMARY:%s |
| 18408 | CATEGORIES:%s | ||
| 15944 | SEQUENCE:1 | 18409 | SEQUENCE:1 |
| 15945 | PRIORITY:%d | 18410 | PRIORITY:%d |
| 18411 | STATUS:%s | ||
| 15946 | END:VTODO\n" | 18412 | END:VTODO\n" |
| 15947 | dts hd pri)))))))) | 18413 | dts hd category pri status)))))))) |
| 15948 | 18414 | ||
| 15949 | (defun org-start-icalendar-file (name) | 18415 | (defun org-start-icalendar-file (name) |
| 15950 | "Start an iCalendar file by inserting the header." | 18416 | "Start an iCalendar file by inserting the header." |
| @@ -15981,294 +18447,93 @@ a time), or the day by one (if it does not contain a time)." | |||
| 15981 | (setq fmt (if have-time ":%Y%m%dT%H%M%S" ";VALUE=DATE:%Y%m%d")) | 18447 | (setq fmt (if have-time ":%Y%m%dT%H%M%S" ";VALUE=DATE:%Y%m%d")) |
| 15982 | (concat keyword (format-time-string fmt time)))) | 18448 | (concat keyword (format-time-string fmt time)))) |
| 15983 | 18449 | ||
| 15984 | ;;; LaTeX stuff | 18450 | ;;; XOXO export |
| 15985 | |||
| 15986 | (defvar org-cdlatex-mode-map (make-sparse-keymap) | ||
| 15987 | "Keymap for the minor `org-cdlatex-mode'.") | ||
| 15988 | |||
| 15989 | (define-key org-cdlatex-mode-map "_" 'org-cdlatex-underscore-caret) | ||
| 15990 | (define-key org-cdlatex-mode-map "^" 'org-cdlatex-underscore-caret) | ||
| 15991 | (define-key org-cdlatex-mode-map "`" 'cdlatex-math-symbol) | ||
| 15992 | (define-key org-cdlatex-mode-map "'" 'org-cdlatex-math-modify) | ||
| 15993 | (define-key org-cdlatex-mode-map "\C-c{" 'cdlatex-environment) | ||
| 15994 | |||
| 15995 | (defvar org-cdlatex-texmathp-advice-is-done nil | ||
| 15996 | "Flag remembering if we have applied the advice to texmathp already.") | ||
| 15997 | |||
| 15998 | (define-minor-mode org-cdlatex-mode | ||
| 15999 | "Toggle the minor `org-cdlatex-mode'. | ||
| 16000 | This mode supports entering LaTeX environment and math in LaTeX fragments | ||
| 16001 | in Org-mode. | ||
| 16002 | \\{org-cdlatex-mode-map}" | ||
| 16003 | nil " OCDL" nil | ||
| 16004 | (when org-cdlatex-mode (require 'cdlatex)) | ||
| 16005 | (unless org-cdlatex-texmathp-advice-is-done | ||
| 16006 | (setq org-cdlatex-texmathp-advice-is-done t) | ||
| 16007 | (defadvice texmathp (around org-math-always-on activate) | ||
| 16008 | "Always return t in org-mode buffers. | ||
| 16009 | This is because we want to insert math symbols without dollars even outside | ||
| 16010 | the LaTeX math segments. If Orgmode thinks that point is actually inside | ||
| 16011 | en embedded LaTeX fragement, let texmathp do its job. | ||
| 16012 | \\[org-cdlatex-mode-map]" | ||
| 16013 | (interactive) | ||
| 16014 | (let (p) | ||
| 16015 | (cond | ||
| 16016 | ((not (org-mode-p)) ad-do-it) | ||
| 16017 | ((eq this-command 'cdlatex-math-symbol) | ||
| 16018 | (setq ad-return-value t | ||
| 16019 | texmathp-why '("cdlatex-math-symbol in org-mode" . 0))) | ||
| 16020 | (t | ||
| 16021 | (let ((p (org-inside-LaTeX-fragment-p))) | ||
| 16022 | (if (and p (member (car p) (plist-get org-format-latex-options :matchers))) | ||
| 16023 | (setq ad-return-value t | ||
| 16024 | texmathp-why '("Org-mode embedded math" . 0)) | ||
| 16025 | (if p ad-do-it))))))))) | ||
| 16026 | |||
| 16027 | (defun turn-on-org-cdlatex () | ||
| 16028 | "Unconditionally turn on `org-cdlatex-mode'." | ||
| 16029 | (org-cdlatex-mode 1)) | ||
| 16030 | |||
| 16031 | (defun org-inside-LaTeX-fragment-p () | ||
| 16032 | "Test if point is inside a LaTeX fragment. | ||
| 16033 | I.e. after a \\begin, \\(, \\[, $, or $$, without the corresponding closing | ||
| 16034 | sequence appearing also before point. | ||
| 16035 | Even though the matchers for math are configurable, this function assumes | ||
| 16036 | that \\begin, \\(, \\[, and $$ are always used. Only the single dollar | ||
| 16037 | delimiters are skipped when they have been removed by customization. | ||
| 16038 | The return value is nil, or a cons cell with the delimiter and | ||
| 16039 | and the position of this delimiter. | ||
| 16040 | |||
| 16041 | This function does a reasonably good job, but can locally be fooled by | ||
| 16042 | for example currency specifications. For example it will assume being in | ||
| 16043 | inline math after \"$22.34\". The LaTeX fragment formatter will only format | ||
| 16044 | fragments that are properly closed, but during editing, we have to live | ||
| 16045 | with the uncertainty caused by missing closing delimiters. This function | ||
| 16046 | looks only before point, not after." | ||
| 16047 | (catch 'exit | ||
| 16048 | (let ((pos (point)) | ||
| 16049 | (dodollar (member "$" (plist-get org-format-latex-options :matchers))) | ||
| 16050 | (lim (progn | ||
| 16051 | (re-search-backward (concat "^\\(" paragraph-start "\\)") nil t) | ||
| 16052 | (point))) | ||
| 16053 | dd-on str (start 0) m re) | ||
| 16054 | (goto-char pos) | ||
| 16055 | (when dodollar | ||
| 16056 | (setq str (concat (buffer-substring lim (point)) "\000 X$.") | ||
| 16057 | re (nth 1 (assoc "$" org-latex-regexps))) | ||
| 16058 | (while (string-match re str start) | ||
| 16059 | (cond | ||
| 16060 | ((= (match-end 0) (length str)) | ||
| 16061 | (throw 'exit (cons "$" (+ lim (match-beginning 0))))) | ||
| 16062 | ((= (match-end 0) (- (length str) 5)) | ||
| 16063 | (throw 'exit nil)) | ||
| 16064 | (t (setq start (match-end 0)))))) | ||
| 16065 | (when (setq m (re-search-backward "\\(\\\\begin{[^}]*}\\|\\\\(\\|\\\\\\[\\)\\|\\(\\\\end{[^}]*}\\|\\\\)\\|\\\\\\]\\)\\|\\(\\$\\$\\)" lim t)) | ||
| 16066 | (goto-char pos) | ||
| 16067 | (and (match-beginning 1) (throw 'exit (cons (match-string 1) m))) | ||
| 16068 | (and (match-beginning 2) (throw 'exit nil)) | ||
| 16069 | ;; count $$ | ||
| 16070 | (while (re-search-backward "\\$\\$" lim t) | ||
| 16071 | (setq dd-on (not dd-on))) | ||
| 16072 | (goto-char pos) | ||
| 16073 | (if dd-on (cons "$$" m)))))) | ||
| 16074 | 18451 | ||
| 18452 | (defun org-export-as-xoxo-insert-into (buffer &rest output) | ||
| 18453 | (with-current-buffer buffer | ||
| 18454 | (apply 'insert output))) | ||
| 18455 | (put 'org-export-as-xoxo-insert-into 'lisp-indent-function 1) | ||
| 16075 | 18456 | ||
| 16076 | (defun org-try-cdlatex-tab () | 18457 | (defun org-export-as-xoxo (&optional buffer) |
| 16077 | "Check if it makes sense to execute `cdlatex-tab', and do it if yes. | 18458 | "Export the org buffer as XOXO. |
| 16078 | It makes sense to do so if `org-cdlatex-mode' is active and if the cursor is | 18459 | The XOXO buffer is named *xoxo-<source buffer name>*" |
| 16079 | - inside a LaTeX fragment, or | 18460 | (interactive (list (current-buffer))) |
| 16080 | - after the first word in a line, where an abbreviation expansion could | 18461 | ;; A quickie abstraction |
| 16081 | insert a LaTeX environment." | ||
| 16082 | (when org-cdlatex-mode | ||
| 16083 | (cond | ||
| 16084 | ((save-excursion | ||
| 16085 | (skip-chars-backward "a-zA-Z0-9*") | ||
| 16086 | (skip-chars-backward " \t") | ||
| 16087 | (bolp)) | ||
| 16088 | (cdlatex-tab) t) | ||
| 16089 | ((org-inside-LaTeX-fragment-p) | ||
| 16090 | (cdlatex-tab) t) | ||
| 16091 | (t nil)))) | ||
| 16092 | 18462 | ||
| 16093 | (defun org-cdlatex-underscore-caret (&optional arg) | 18463 | ;; Output everything as XOXO |
| 16094 | "Execute `cdlatex-sub-superscript' in LaTeX fragments. | 18464 | (with-current-buffer (get-buffer buffer) |
| 16095 | Revert to the normal definition outside of these fragments." | 18465 | (goto-char (point-min)) ;; CD: beginning-of-buffer is not allowed. |
| 16096 | (interactive "P") | 18466 | (let* ((opt-plist (org-combine-plists (org-default-export-plist) |
| 16097 | (if (org-inside-LaTeX-fragment-p) | 18467 | (org-infile-export-plist))) |
| 16098 | (call-interactively 'cdlatex-sub-superscript) | 18468 | (filename (concat (file-name-as-directory |
| 16099 | (let (org-cdlatex-mode) | 18469 | (org-export-directory :xoxo opt-plist)) |
| 16100 | (call-interactively (key-binding (vector last-input-event)))))) | 18470 | (file-name-sans-extension |
| 18471 | (file-name-nondirectory buffer-file-name)) | ||
| 18472 | ".html")) | ||
| 18473 | (out (find-file-noselect filename)) | ||
| 18474 | (last-level 1) | ||
| 18475 | (hanging-li nil)) | ||
| 18476 | ;; Check the output buffer is empty. | ||
| 18477 | (with-current-buffer out (erase-buffer)) | ||
| 18478 | ;; Kick off the output | ||
| 18479 | (org-export-as-xoxo-insert-into out "<ol class='xoxo'>\n") | ||
| 18480 | (while (re-search-forward "^\\(\\*+\\) \\(.+\\)" (point-max) 't) | ||
| 18481 | (let* ((hd (match-string-no-properties 1)) | ||
| 18482 | (level (length hd)) | ||
| 18483 | (text (concat | ||
| 18484 | (match-string-no-properties 2) | ||
| 18485 | (save-excursion | ||
| 18486 | (goto-char (match-end 0)) | ||
| 18487 | (let ((str "")) | ||
| 18488 | (catch 'loop | ||
| 18489 | (while 't | ||
| 18490 | (forward-line) | ||
| 18491 | (if (looking-at "^[ \t]\\(.*\\)") | ||
| 18492 | (setq str (concat str (match-string-no-properties 1))) | ||
| 18493 | (throw 'loop str))))))))) | ||
| 16101 | 18494 | ||
| 16102 | (defun org-cdlatex-math-modify (&optional arg) | 18495 | ;; Handle level rendering |
| 16103 | "Execute `cdlatex-math-modify' in LaTeX fragments. | 18496 | (cond |
| 16104 | Revert to the normal definition outside of these fragments." | 18497 | ((> level last-level) |
| 16105 | (interactive "P") | 18498 | (org-export-as-xoxo-insert-into out "\n<ol>\n")) |
| 16106 | (if (org-inside-LaTeX-fragment-p) | ||
| 16107 | (call-interactively 'cdlatex-math-modify) | ||
| 16108 | (let (org-cdlatex-mode) | ||
| 16109 | (call-interactively (key-binding (vector last-input-event)))))) | ||
| 16110 | 18499 | ||
| 16111 | (defvar org-latex-fragment-image-overlays nil | 18500 | ((< level last-level) |
| 16112 | "List of overlays carrying the images of latex fragments.") | 18501 | (dotimes (- (- last-level level) 1) |
| 16113 | (make-variable-buffer-local 'org-latex-fragment-image-overlays) | 18502 | (if hanging-li |
| 18503 | (org-export-as-xoxo-insert-into out "</li>\n")) | ||
| 18504 | (org-export-as-xoxo-insert-into out "</ol>\n")) | ||
| 18505 | (when hanging-li | ||
| 18506 | (org-export-as-xoxo-insert-into out "</li>\n") | ||
| 18507 | (setq hanging-li nil))) | ||
| 16114 | 18508 | ||
| 16115 | (defun org-remove-latex-fragment-image-overlays () | 18509 | ((equal level last-level) |
| 16116 | "Remove all overlays with LaTeX fragment images in current buffer." | 18510 | (if hanging-li |
| 16117 | (mapc 'org-delete-overlay org-latex-fragment-image-overlays) | 18511 | (org-export-as-xoxo-insert-into out "</li>\n"))) |
| 16118 | (setq org-latex-fragment-image-overlays nil)) | 18512 | ) |
| 16119 | 18513 | ||
| 16120 | (defun org-preview-latex-fragment (&optional subtree) | 18514 | (setq last-level level) |
| 16121 | "Preview the LaTeX fragment at point, or all locally or globally. | ||
| 16122 | If the cursor is in a LaTeX fragment, create the image and overlay | ||
| 16123 | it over the source code. If there is no fragment at point, display | ||
| 16124 | all fragments in the current text, from one headline to the next. With | ||
| 16125 | prefix SUBTREE, display all fragments in the current subtree. With a | ||
| 16126 | double prefix `C-u C-u', or when the cursor is before the first headline, | ||
| 16127 | display all fragments in the buffer. | ||
| 16128 | The images can be removed again with \\[org-ctrl-c-ctrl-c]." | ||
| 16129 | (interactive "P") | ||
| 16130 | (org-remove-latex-fragment-image-overlays) | ||
| 16131 | (save-excursion | ||
| 16132 | (save-restriction | ||
| 16133 | (let (beg end at msg) | ||
| 16134 | (cond | ||
| 16135 | ((or (equal subtree '(16)) | ||
| 16136 | (not (save-excursion | ||
| 16137 | (re-search-backward (concat "^" outline-regexp) nil t)))) | ||
| 16138 | (setq beg (point-min) end (point-max) | ||
| 16139 | msg "Creating images for buffer...%s")) | ||
| 16140 | ((equal subtree '(4)) | ||
| 16141 | (org-back-to-heading) | ||
| 16142 | (setq beg (point) end (org-end-of-subtree t) | ||
| 16143 | msg "Creating images for subtree...%s")) | ||
| 16144 | (t | ||
| 16145 | (if (setq at (org-inside-LaTeX-fragment-p)) | ||
| 16146 | (goto-char (max (point-min) (- (cdr at) 2))) | ||
| 16147 | (org-back-to-heading)) | ||
| 16148 | (setq beg (point) end (progn (outline-next-heading) (point)) | ||
| 16149 | msg (if at "Creating image...%s" | ||
| 16150 | "Creating images for entry...%s")))) | ||
| 16151 | (message msg "") | ||
| 16152 | (narrow-to-region beg end) | ||
| 16153 | (org-format-latex | ||
| 16154 | (concat "ltxpng/" (file-name-sans-extension | ||
| 16155 | (file-name-nondirectory | ||
| 16156 | buffer-file-name))) | ||
| 16157 | default-directory 'overlays msg at) | ||
| 16158 | (message msg "done. Use `C-c C-c' to remove images."))))) | ||
| 16159 | 18515 | ||
| 16160 | (defvar org-latex-regexps | 18516 | ;; And output the new li |
| 16161 | '(("begin" "^[ \t]*\\(\\\\begin{\\([a-zA-Z0-9\\*]+\\)[^\000]+?\\\\end{\\2}\\)" 1 t) | 18517 | (setq hanging-li 't) |
| 16162 | ;; ("$" "\\([ (]\\|^\\)\\(\\(\\([$]\\)\\([^ \r\n,.$].*?\\(\n.*?\\)\\{0,5\\}[^ \r\n,.$]\\)\\4\\)\\)\\([ .,?;:'\")]\\|$\\)" 2 nil) | 18518 | (if (equal ?+ (elt text 0)) |
| 16163 | ;; \000 in the following regex is needed for org-inside-LaTeX-fragment-p | 18519 | (org-export-as-xoxo-insert-into out "<li class='" (substring text 1) "'>") |
| 16164 | ("$" "\\([^$]\\)\\(\\(\\$\\([^ \r\n,;.$][^$\n\r]*?\\(\n[^$\n\r]*?\\)\\{0,2\\}[^ \r\n,.$]\\)\\$\\)\\)\\([ .,?;:'\")\000]\\|$\\)" 2 nil) | 18520 | (org-export-as-xoxo-insert-into out "<li>" text)))) |
| 16165 | ("\\(" "\\\\([^\000]*?\\\\)" 0 nil) | ||
| 16166 | ("\\[" "\\\\\\[[^\000]*?\\\\\\]" 0 t) | ||
| 16167 | ("$$" "\\$\\$[^\000]*?\\$\\$" 0 t)) | ||
| 16168 | "Regular expressions for matching embedded LaTeX.") | ||
| 16169 | 18521 | ||
| 16170 | (defun org-format-latex (prefix &optional dir overlays msg at) | 18522 | ;; Finally finish off the ol |
| 16171 | "Replace LaTeX fragments with links to an image, and produce images." | 18523 | (dotimes (- last-level 1) |
| 16172 | (if (and overlays (fboundp 'clear-image-cache)) (clear-image-cache)) | 18524 | (if hanging-li |
| 16173 | (let* ((prefixnodir (file-name-nondirectory prefix)) | 18525 | (org-export-as-xoxo-insert-into out "</li>\n")) |
| 16174 | (absprefix (expand-file-name prefix dir)) | 18526 | (org-export-as-xoxo-insert-into out "</ol>\n")) |
| 16175 | (todir (file-name-directory absprefix)) | ||
| 16176 | (opt org-format-latex-options) | ||
| 16177 | (matchers (plist-get opt :matchers)) | ||
| 16178 | (re-list org-latex-regexps) | ||
| 16179 | (cnt 0) txt link beg end re e oldfiles | ||
| 16180 | m n block linkfile movefile ov) | ||
| 16181 | ;; Make sure the directory exists | ||
| 16182 | (or (file-directory-p todir) (make-directory todir)) | ||
| 16183 | ;; Check if there are old images files with this prefix, and remove them | ||
| 16184 | (setq oldfiles (directory-files | ||
| 16185 | todir 'full | ||
| 16186 | (concat (regexp-quote prefixnodir) "_[0-9]+\\.png$"))) | ||
| 16187 | (while oldfiles (delete-file (pop oldfiles))) | ||
| 16188 | ;; Check the different regular expressions | ||
| 16189 | (while (setq e (pop re-list)) | ||
| 16190 | (setq m (car e) re (nth 1 e) n (nth 2 e) | ||
| 16191 | block (if (nth 3 e) "\n\n" "")) | ||
| 16192 | (when (member m matchers) | ||
| 16193 | (goto-char (point-min)) | ||
| 16194 | (while (re-search-forward re nil t) | ||
| 16195 | (when (or (not at) (equal (cdr at) (match-beginning n))) | ||
| 16196 | (setq txt (match-string n) | ||
| 16197 | beg (match-beginning n) end (match-end n) | ||
| 16198 | cnt (1+ cnt) | ||
| 16199 | linkfile (format "%s_%04d.png" prefix cnt) | ||
| 16200 | movefile (format "%s_%04d.png" absprefix cnt) | ||
| 16201 | link (concat block "[[file:" linkfile "]]" block)) | ||
| 16202 | (if msg (message msg cnt)) | ||
| 16203 | (goto-char beg) | ||
| 16204 | (org-create-formula-image | ||
| 16205 | txt movefile opt) | ||
| 16206 | (if overlays | ||
| 16207 | (progn | ||
| 16208 | (setq ov (org-make-overlay beg end)) | ||
| 16209 | (if (featurep 'xemacs) | ||
| 16210 | (progn | ||
| 16211 | (org-overlay-put ov 'invisible t) | ||
| 16212 | (org-overlay-put | ||
| 16213 | ov 'end-glyph | ||
| 16214 | (make-glyph (vector 'png :file movefile)))) | ||
| 16215 | (org-overlay-put | ||
| 16216 | ov 'display | ||
| 16217 | (list 'image :type 'png :file movefile :ascent 'center))) | ||
| 16218 | (push ov org-latex-fragment-image-overlays) | ||
| 16219 | (goto-char end)) | ||
| 16220 | (delete-region beg end) | ||
| 16221 | (insert link)))))))) | ||
| 16222 | 18527 | ||
| 16223 | ;; This function borrows from Ganesh Swami's latex2png.el | 18528 | ;; Finish the buffer off and clean it up. |
| 16224 | (defun org-create-formula-image (string tofile options) | 18529 | (switch-to-buffer-other-window out) |
| 16225 | (let* ((tmpdir (if (featurep 'xemacs) | 18530 | (indent-region (point-min) (point-max) nil) |
| 16226 | (temp-directory) | 18531 | (save-buffer) |
| 16227 | temporary-file-directory)) | 18532 | (goto-char (point-min)) |
| 16228 | (texfilebase (make-temp-name | 18533 | ))) |
| 16229 | (expand-file-name "orgtex" tmpdir))) | ||
| 16230 | 18534 | ||
| 16231 | ;(texfilebase (make-temp-file "orgtex")) | ||
| 16232 | ; (dummy (delete-file texfilebase)) | ||
| 16233 | (texfile (concat texfilebase ".tex")) | ||
| 16234 | (dvifile (concat texfilebase ".dvi")) | ||
| 16235 | (pngfile (concat texfilebase ".png")) | ||
| 16236 | (scale (number-to-string (* 1000 (or (plist-get options :scale) 1.0)))) | ||
| 16237 | (fg (or (plist-get options :foreground) "Black")) | ||
| 16238 | (bg (or (plist-get options :background) "Transparent"))) | ||
| 16239 | (with-temp-file texfile | ||
| 16240 | (insert "\\documentclass{article} | ||
| 16241 | \\usepackage{fullpage} | ||
| 16242 | \\usepackage{amssymb} | ||
| 16243 | \\usepackage[usenames]{color} | ||
| 16244 | \\usepackage{amsmath} | ||
| 16245 | \\usepackage{latexsym} | ||
| 16246 | \\usepackage[mathscr]{eucal} | ||
| 16247 | \\pagestyle{empty} | ||
| 16248 | \\begin{document}\n" string "\n\\end{document}\n")) | ||
| 16249 | (let ((dir default-directory)) | ||
| 16250 | (condition-case nil | ||
| 16251 | (progn | ||
| 16252 | (cd tmpdir) | ||
| 16253 | (call-process "latex" nil nil nil texfile)) | ||
| 16254 | (error nil)) | ||
| 16255 | (cd dir)) | ||
| 16256 | (if (not (file-exists-p dvifile)) | ||
| 16257 | (progn (message "Failed to create dvi file from %s" texfile) nil) | ||
| 16258 | (call-process "dvipng" nil nil nil | ||
| 16259 | "-E" "-fg" fg "-bg" bg | ||
| 16260 | "-x" scale "-y" scale "-T" "tight" | ||
| 16261 | "-o" pngfile | ||
| 16262 | dvifile) | ||
| 16263 | (if (not (file-exists-p pngfile)) | ||
| 16264 | (progn (message "Failed to create png file from %s" texfile) nil) | ||
| 16265 | ;; Use the requested file name and clean up | ||
| 16266 | (copy-file pngfile tofile 'replace) | ||
| 16267 | (loop for e in '(".dvi" ".tex" ".aux" ".log" ".png") do | ||
| 16268 | (delete-file (concat texfilebase e))) | ||
| 16269 | pngfile)))) | ||
| 16270 | 18535 | ||
| 16271 | ;;; Key bindings | 18536 | ;;;; Key bindings |
| 16272 | 18537 | ||
| 16273 | ;; - Bindings in Org-mode map are currently | 18538 | ;; - Bindings in Org-mode map are currently |
| 16274 | ;; 0123456789abcdefghijklmnopqrstuvwxyz!?@#$%^&-+*/=()_{}[]:;"|,.<>~`'\t the alphabet | 18539 | ;; 0123456789abcdefghijklmnopqrstuvwxyz!?@#$%^&-+*/=()_{}[]:;"|,.<>~`'\t the alphabet |
| @@ -16286,6 +18551,7 @@ The images can be removed again with \\[org-ctrl-c-ctrl-c]." | |||
| 16286 | (define-key org-mode-map [(control tab)] 'org-force-cycle-archived) | 18551 | (define-key org-mode-map [(control tab)] 'org-force-cycle-archived) |
| 16287 | (define-key org-mode-map [(meta tab)] 'org-complete) | 18552 | (define-key org-mode-map [(meta tab)] 'org-complete) |
| 16288 | (define-key org-mode-map "\M-\t" 'org-complete) | 18553 | (define-key org-mode-map "\M-\t" 'org-complete) |
| 18554 | (define-key org-mode-map "\M-\C-i" 'org-complete) | ||
| 16289 | ;; The following line is necessary under Suse GNU/Linux | 18555 | ;; The following line is necessary under Suse GNU/Linux |
| 16290 | (unless (featurep 'xemacs) | 18556 | (unless (featurep 'xemacs) |
| 16291 | (define-key org-mode-map [S-iso-lefttab] 'org-shifttab)) | 18557 | (define-key org-mode-map [S-iso-lefttab] 'org-shifttab)) |
| @@ -16311,12 +18577,12 @@ The images can be removed again with \\[org-ctrl-c-ctrl-c]." | |||
| 16311 | (define-key org-mode-map (org-key 'S-left) 'org-shiftleft) | 18577 | (define-key org-mode-map (org-key 'S-left) 'org-shiftleft) |
| 16312 | (define-key org-mode-map (org-key 'S-right) 'org-shiftright) | 18578 | (define-key org-mode-map (org-key 'S-right) 'org-shiftright) |
| 16313 | 18579 | ||
| 16314 | ;; Extra keys for tty access. We only set them when really needed | 18580 | ;;; Extra keys for tty access. |
| 16315 | ;; because otherwise the menus don't show the simple keys | 18581 | ;; We only set them when really needed because otherwise the |
| 18582 | ;; menus don't show the simple keys | ||
| 16316 | 18583 | ||
| 16317 | (when (or (featurep 'xemacs) ;; because XEmacs supports multi-device stuff | 18584 | (when (or (featurep 'xemacs) ;; because XEmacs supports multi-device stuff |
| 16318 | (not window-system)) | 18585 | (not window-system)) |
| 16319 | (define-key org-mode-map "\M-\C-i" 'org-complete) | ||
| 16320 | (define-key org-mode-map "\C-c\C-xc" 'org-table-copy-down) | 18586 | (define-key org-mode-map "\C-c\C-xc" 'org-table-copy-down) |
| 16321 | (define-key org-mode-map "\C-c\C-xM" 'org-insert-todo-heading) | 18587 | (define-key org-mode-map "\C-c\C-xM" 'org-insert-todo-heading) |
| 16322 | (define-key org-mode-map "\C-c\C-xm" 'org-meta-return) | 18588 | (define-key org-mode-map "\C-c\C-xm" 'org-meta-return) |
| @@ -16337,14 +18603,16 @@ The images can be removed again with \\[org-ctrl-c-ctrl-c]." | |||
| 16337 | (define-key org-mode-map [?\C-c ?\C-x (down)] 'org-shiftdown) | 18603 | (define-key org-mode-map [?\C-c ?\C-x (down)] 'org-shiftdown) |
| 16338 | (define-key org-mode-map [?\C-c ?\C-x (left)] 'org-shiftleft) | 18604 | (define-key org-mode-map [?\C-c ?\C-x (left)] 'org-shiftleft) |
| 16339 | (define-key org-mode-map [?\C-c ?\C-x (right)] 'org-shiftright)) | 18605 | (define-key org-mode-map [?\C-c ?\C-x (right)] 'org-shiftright)) |
| 16340 | 18606 | ||
| 16341 | ;; All the other keys | 18607 | ;; All the other keys |
| 16342 | 18608 | ||
| 16343 | (define-key org-mode-map "\C-c\C-a" 'show-all) ; in case allout messed up. | 18609 | (define-key org-mode-map "\C-c\C-a" 'show-all) ; in case allout messed up. |
| 16344 | (define-key org-mode-map "\C-c\C-r" 'org-reveal) | 18610 | (define-key org-mode-map "\C-c\C-r" 'org-reveal) |
| 16345 | (define-key org-mode-map "\C-xns" 'org-narrow-to-subtree) | 18611 | (define-key org-mode-map "\C-xns" 'org-narrow-to-subtree) |
| 16346 | (define-key org-mode-map "\C-c$" 'org-archive-subtree) | 18612 | (define-key org-mode-map "\C-c$" 'org-archive-subtree) |
| 18613 | (define-key org-mode-map "\C-c\C-x\C-s" 'org-advertized-archive-subtree) | ||
| 16347 | (define-key org-mode-map "\C-c\C-x\C-a" 'org-toggle-archive-tag) | 18614 | (define-key org-mode-map "\C-c\C-x\C-a" 'org-toggle-archive-tag) |
| 18615 | (define-key org-mode-map "\C-c\C-xb" 'org-tree-to-indirect-buffer) | ||
| 16348 | (define-key org-mode-map "\C-c\C-j" 'org-goto) | 18616 | (define-key org-mode-map "\C-c\C-j" 'org-goto) |
| 16349 | (define-key org-mode-map "\C-c\C-t" 'org-todo) | 18617 | (define-key org-mode-map "\C-c\C-t" 'org-todo) |
| 16350 | (define-key org-mode-map "\C-c\C-s" 'org-schedule) | 18618 | (define-key org-mode-map "\C-c\C-s" 'org-schedule) |
| @@ -16356,6 +18624,8 @@ The images can be removed again with \\[org-ctrl-c-ctrl-c]." | |||
| 16356 | (define-key org-mode-map "\C-c\\" 'org-tags-sparse-tree) ; Minor-mode res. | 18624 | (define-key org-mode-map "\C-c\\" 'org-tags-sparse-tree) ; Minor-mode res. |
| 16357 | (define-key org-mode-map "\C-c\C-m" 'org-insert-heading) | 18625 | (define-key org-mode-map "\C-c\C-m" 'org-insert-heading) |
| 16358 | (define-key org-mode-map "\M-\C-m" 'org-insert-heading) | 18626 | (define-key org-mode-map "\M-\C-m" 'org-insert-heading) |
| 18627 | (define-key org-mode-map "\C-c\C-x\C-n" 'org-next-link) | ||
| 18628 | (define-key org-mode-map "\C-c\C-x\C-p" 'org-previous-link) | ||
| 16359 | (define-key org-mode-map "\C-c\C-l" 'org-insert-link) | 18629 | (define-key org-mode-map "\C-c\C-l" 'org-insert-link) |
| 16360 | (define-key org-mode-map "\C-c\C-o" 'org-open-at-point) | 18630 | (define-key org-mode-map "\C-c\C-o" 'org-open-at-point) |
| 16361 | (define-key org-mode-map "\C-c%" 'org-mark-ring-push) | 18631 | (define-key org-mode-map "\C-c%" 'org-mark-ring-push) |
| @@ -16368,31 +18638,34 @@ The images can be removed again with \\[org-ctrl-c-ctrl-c]." | |||
| 16368 | (define-key org-mode-map "\C-c>" 'org-goto-calendar) | 18638 | (define-key org-mode-map "\C-c>" 'org-goto-calendar) |
| 16369 | (define-key org-mode-map "\C-c<" 'org-date-from-calendar) | 18639 | (define-key org-mode-map "\C-c<" 'org-date-from-calendar) |
| 16370 | (define-key org-mode-map [(control ?,)] 'org-cycle-agenda-files) | 18640 | (define-key org-mode-map [(control ?,)] 'org-cycle-agenda-files) |
| 18641 | (define-key org-mode-map [(control ?\')] 'org-cycle-agenda-files) | ||
| 16371 | (define-key org-mode-map "\C-c[" 'org-agenda-file-to-front) | 18642 | (define-key org-mode-map "\C-c[" 'org-agenda-file-to-front) |
| 16372 | (define-key org-mode-map "\C-c]" 'org-remove-file) | 18643 | (define-key org-mode-map "\C-c]" 'org-remove-file) |
| 16373 | (define-key org-mode-map "\C-c-" 'org-table-insert-hline) | 18644 | (define-key org-mode-map "\C-c-" 'org-table-insert-hline) |
| 16374 | (define-key org-mode-map "\C-c^" 'org-table-sort-lines) | 18645 | (define-key org-mode-map "\C-c^" 'org-sort) |
| 16375 | (define-key org-mode-map "\C-c\C-c" 'org-ctrl-c-ctrl-c) | 18646 | (define-key org-mode-map "\C-c\C-c" 'org-ctrl-c-ctrl-c) |
| 16376 | (define-key org-mode-map "\C-c#" 'org-update-checkbox-count) | 18647 | (define-key org-mode-map "\C-c#" 'org-update-checkbox-count) |
| 16377 | (define-key org-mode-map "\C-m" 'org-return) | 18648 | (define-key org-mode-map "\C-m" 'org-return) |
| 16378 | (define-key org-mode-map "\C-c?" 'org-table-current-column) | 18649 | (define-key org-mode-map "\C-c?" 'org-table-field-info) |
| 16379 | (define-key org-mode-map "\C-c " 'org-table-blank-field) | 18650 | (define-key org-mode-map "\C-c " 'org-table-blank-field) |
| 16380 | (define-key org-mode-map "\C-c+" 'org-table-sum) | 18651 | (define-key org-mode-map "\C-c+" 'org-table-sum) |
| 16381 | (define-key org-mode-map "\C-c=" 'org-table-eval-formula) | 18652 | (define-key org-mode-map "\C-c=" 'org-table-eval-formula) |
| 16382 | (define-key org-mode-map "\C-c'" 'org-table-edit-formulas) | 18653 | (define-key org-mode-map "\C-c'" 'org-table-edit-formulas) |
| 16383 | (define-key org-mode-map "\C-c`" 'org-table-edit-field) | 18654 | (define-key org-mode-map "\C-c`" 'org-table-edit-field) |
| 16384 | (define-key org-mode-map "\C-c|" 'org-table-create-or-convert-from-region) | 18655 | (define-key org-mode-map "\C-c|" 'org-table-create-or-convert-from-region) |
| 16385 | (define-key org-mode-map "\C-c*" 'org-table-recalculate) | 18656 | (define-key org-mode-map "\C-c*" 'org-table-recalculate) |
| 16386 | (define-key org-mode-map [(control ?#)] 'org-table-rotate-recalc-marks) | 18657 | (define-key org-mode-map [(control ?#)] 'org-table-rotate-recalc-marks) |
| 16387 | (define-key org-mode-map "\C-c~" 'org-table-create-with-table.el) | 18658 | (define-key org-mode-map "\C-c~" 'org-table-create-with-table.el) |
| 16388 | (define-key org-mode-map "\C-c\C-q" 'org-table-wrap-region) | 18659 | (define-key org-mode-map "\C-c\C-q" 'org-table-wrap-region) |
| 16389 | (define-key org-mode-map "\C-c\C-e" 'org-export) | 18660 | (define-key org-mode-map "\C-c}" 'org-table-toggle-coordinate-overlays) |
| 16390 | (define-key org-mode-map "\C-c:" 'org-toggle-fixed-width-section) | 18661 | (define-key org-mode-map "\C-c{" 'org-table-toggle-formula-debugger) |
| 16391 | 18662 | (define-key org-mode-map "\C-c\C-e" 'org-export) | |
| 16392 | (define-key org-mode-map "\C-c\C-x\C-k" 'org-cut-special) | 18663 | (define-key org-mode-map "\C-c:" 'org-toggle-fixed-width-section) |
| 16393 | (define-key org-mode-map "\C-c\C-x\C-w" 'org-cut-special) | 18664 | |
| 16394 | (define-key org-mode-map "\C-c\C-x\M-w" 'org-copy-special) | 18665 | (define-key org-mode-map "\C-c\C-x\C-k" 'org-cut-special) |
| 16395 | (define-key org-mode-map "\C-c\C-x\C-y" 'org-paste-special) | 18666 | (define-key org-mode-map "\C-c\C-x\C-w" 'org-cut-special) |
| 18667 | (define-key org-mode-map "\C-c\C-x\M-w" 'org-copy-special) | ||
| 18668 | (define-key org-mode-map "\C-c\C-x\C-y" 'org-paste-special) | ||
| 16396 | 18669 | ||
| 16397 | (define-key org-mode-map "\C-c\C-x\C-t" 'org-toggle-time-stamp-overlays) | 18670 | (define-key org-mode-map "\C-c\C-x\C-t" 'org-toggle-time-stamp-overlays) |
| 16398 | (define-key org-mode-map "\C-c\C-x\C-i" 'org-clock-in) | 18671 | (define-key org-mode-map "\C-c\C-x\C-i" 'org-clock-in) |
| @@ -16524,6 +18797,9 @@ See the individual commands for more information." | |||
| 16524 | (interactive "P") | 18797 | (interactive "P") |
| 16525 | (cond | 18798 | (cond |
| 16526 | ((org-at-table-p) (call-interactively 'org-table-previous-field)) | 18799 | ((org-at-table-p) (call-interactively 'org-table-previous-field)) |
| 18800 | (arg (message "Content view to level: ") | ||
| 18801 | (org-content (prefix-numeric-value arg)) | ||
| 18802 | (setq org-cycle-global-status 'overview)) | ||
| 16527 | (t (call-interactively 'org-global-cycle)))) | 18803 | (t (call-interactively 'org-global-cycle)))) |
| 16528 | 18804 | ||
| 16529 | (defun org-shiftmetaleft () | 18805 | (defun org-shiftmetaleft () |
| @@ -16803,9 +19079,7 @@ See the individual commands for more information." | |||
| 16803 | ["Move Column Left" org-metaleft (org-at-table-p)] | 19079 | ["Move Column Left" org-metaleft (org-at-table-p)] |
| 16804 | ["Move Column Right" org-metaright (org-at-table-p)] | 19080 | ["Move Column Right" org-metaright (org-at-table-p)] |
| 16805 | ["Delete Column" org-shiftmetaleft (org-at-table-p)] | 19081 | ["Delete Column" org-shiftmetaleft (org-at-table-p)] |
| 16806 | ["Insert Column" org-shiftmetaright (org-at-table-p)] | 19082 | ["Insert Column" org-shiftmetaright (org-at-table-p)]) |
| 16807 | "--" | ||
| 16808 | ["Enable Narrowing" (setq org-table-limit-column-width (not org-table-limit-column-width)) :active (org-at-table-p) :selected org-table-limit-column-width :style toggle]) | ||
| 16809 | ("Row" | 19083 | ("Row" |
| 16810 | ["Move Row Up" org-metaup (org-at-table-p)] | 19084 | ["Move Row Up" org-metaup (org-at-table-p)] |
| 16811 | ["Move Row Down" org-metadown (org-at-table-p)] | 19085 | ["Move Row Down" org-metadown (org-at-table-p)] |
| @@ -16822,19 +19096,24 @@ See the individual commands for more information." | |||
| 16822 | "--" | 19096 | "--" |
| 16823 | ("Calculate" | 19097 | ("Calculate" |
| 16824 | ["Set Column Formula" org-table-eval-formula (org-at-table-p)] | 19098 | ["Set Column Formula" org-table-eval-formula (org-at-table-p)] |
| 16825 | ["Set Named Field Formula" (org-table-eval-formula '(4)) :active (org-at-table-p) :keys "C-u C-c ="] | 19099 | ["Set Field Formula" (org-table-eval-formula '(4)) :active (org-at-table-p) :keys "C-u C-c ="] |
| 16826 | ["Edit Formulas" org-table-edit-formulas (org-at-table-p)] | 19100 | ["Edit Formulas" org-table-edit-formulas (org-at-table-p)] |
| 16827 | "--" | 19101 | "--" |
| 16828 | ["Recalculate line" org-table-recalculate (org-at-table-p)] | 19102 | ["Recalculate line" org-table-recalculate (org-at-table-p)] |
| 16829 | ["Recalculate all" (lambda () (interactive) (org-table-recalculate '(4))) :active (org-at-table-p) :keys "C-u C-c *"] | 19103 | ["Recalculate all" (lambda () (interactive) (org-table-recalculate '(4))) :active (org-at-table-p) :keys "C-u C-c *"] |
| 19104 | ["Iterate all" (lambda () (interactive) (org-table-recalculate '(16))) :active (org-at-table-p) :keys "C-u C-u C-c *"] | ||
| 19105 | "--" | ||
| 16830 | ["Toggle Recalculate Mark" org-table-rotate-recalc-marks (org-at-table-p)] | 19106 | ["Toggle Recalculate Mark" org-table-rotate-recalc-marks (org-at-table-p)] |
| 16831 | "--" | 19107 | "--" |
| 16832 | ["Sum Column/Rectangle" org-table-sum | 19108 | ["Sum Column/Rectangle" org-table-sum |
| 16833 | (or (org-at-table-p) (org-region-active-p))] | 19109 | (or (org-at-table-p) (org-region-active-p))] |
| 16834 | ["Which Column?" org-table-current-column (org-at-table-p)]) | 19110 | ["Which Column?" org-table-current-column (org-at-table-p)]) |
| 16835 | ["Debug Formulas" | 19111 | ["Debug Formulas" |
| 16836 | (setq org-table-formula-debug (not org-table-formula-debug)) | 19112 | org-table-toggle-formula-debugger |
| 16837 | :style toggle :selected org-table-formula-debug] | 19113 | :style toggle :selected org-table-formula-debug] |
| 19114 | ["Show Col/Row Numbers" | ||
| 19115 | org-table-toggle-coordinate-overlays | ||
| 19116 | :style toggle :selected org-table-overlay-coordinates] | ||
| 16838 | "--" | 19117 | "--" |
| 16839 | ["Create" org-table-create (and (not (org-at-table-p)) | 19118 | ["Create" org-table-create (and (not (org-at-table-p)) |
| 16840 | org-enable-table-editor)] | 19119 | org-enable-table-editor)] |
| @@ -16851,7 +19130,9 @@ See the individual commands for more information." | |||
| 16851 | ["Cycle Global Visibility" org-shifttab (not (org-at-table-p))] | 19130 | ["Cycle Global Visibility" org-shifttab (not (org-at-table-p))] |
| 16852 | ["Sparse Tree" org-occur t] | 19131 | ["Sparse Tree" org-occur t] |
| 16853 | ["Reveal Context" org-reveal t] | 19132 | ["Reveal Context" org-reveal t] |
| 16854 | ["Show All" show-all t]) | 19133 | ["Show All" show-all t] |
| 19134 | "--" | ||
| 19135 | ["Subtree to indirect buffer" org-tree-to-indirect-buffer t]) | ||
| 16855 | "--" | 19136 | "--" |
| 16856 | ["New Heading" org-insert-heading t] | 19137 | ["New Heading" org-insert-heading t] |
| 16857 | ("Navigate Headings" | 19138 | ("Navigate Headings" |
| @@ -16875,12 +19156,14 @@ See the individual commands for more information." | |||
| 16875 | ["Demote Heading" org-metaright (not (org-at-table-p))] | 19156 | ["Demote Heading" org-metaright (not (org-at-table-p))] |
| 16876 | ["Demote Subtree" org-shiftmetaright (not (org-at-table-p))] | 19157 | ["Demote Subtree" org-shiftmetaright (not (org-at-table-p))] |
| 16877 | "--" | 19158 | "--" |
| 19159 | ["Sort Region/Children" org-sort (not (org-at-table-p))] | ||
| 19160 | "--" | ||
| 16878 | ["Convert to odd levels" org-convert-to-odd-levels t] | 19161 | ["Convert to odd levels" org-convert-to-odd-levels t] |
| 16879 | ["Convert to odd/even levels" org-convert-to-oddeven-levels t]) | 19162 | ["Convert to odd/even levels" org-convert-to-oddeven-levels t]) |
| 16880 | ("Archive" | 19163 | ("Archive" |
| 16881 | ["Toggle ARCHIVE tag" org-toggle-archive-tag t] | 19164 | ["Toggle ARCHIVE tag" org-toggle-archive-tag t] |
| 16882 | ["Check and Tag Children" (org-toggle-archive-tag (4)) | 19165 | ; ["Check and Tag Children" (org-toggle-archive-tag (4)) |
| 16883 | :active t :keys "C-u C-c C-x C-a"] | 19166 | ; :active t :keys "C-u C-c C-x C-a"] |
| 16884 | ["Sparse trees open ARCHIVE trees" | 19167 | ["Sparse trees open ARCHIVE trees" |
| 16885 | (setq org-sparse-tree-open-archived-trees | 19168 | (setq org-sparse-tree-open-archived-trees |
| 16886 | (not org-sparse-tree-open-archived-trees)) | 19169 | (not org-sparse-tree-open-archived-trees)) |
| @@ -16892,9 +19175,10 @@ See the individual commands for more information." | |||
| 16892 | (setq org-agenda-skip-archived-trees (not org-agenda-skip-archived-trees)) | 19175 | (setq org-agenda-skip-archived-trees (not org-agenda-skip-archived-trees)) |
| 16893 | :style toggle :selected (not org-agenda-skip-archived-trees)] | 19176 | :style toggle :selected (not org-agenda-skip-archived-trees)] |
| 16894 | "--" | 19177 | "--" |
| 16895 | ["Move Subtree to Archive" org-archive-subtree t] | 19178 | ["Move Subtree to Archive" org-advertized-archive-subtree t] |
| 16896 | ["Check and Move Children" (org-archive-subtree '(4)) | 19179 | ; ["Check and Move Children" (org-archive-subtree '(4)) |
| 16897 | :active t :keys "C-u C-c $"]) | 19180 | ; :active t :keys "C-u C-c C-x C-s"] |
| 19181 | ) | ||
| 16898 | "--" | 19182 | "--" |
| 16899 | ("TODO Lists" | 19183 | ("TODO Lists" |
| 16900 | ["TODO/DONE/-" org-todo t] | 19184 | ["TODO/DONE/-" org-todo t] |
| @@ -16961,17 +19245,16 @@ See the individual commands for more information." | |||
| 16961 | ["Insert Link" org-insert-link t] | 19245 | ["Insert Link" org-insert-link t] |
| 16962 | ["Follow Link" org-open-at-point t] | 19246 | ["Follow Link" org-open-at-point t] |
| 16963 | "--" | 19247 | "--" |
| 19248 | ["Next link" org-next-link t] | ||
| 19249 | ["Previous link" org-previous-link t] | ||
| 19250 | "--" | ||
| 16964 | ["Descriptive Links" | 19251 | ["Descriptive Links" |
| 16965 | (progn (org-add-to-invisibility-spec '(org-link)) (org-restart-font-lock)) | 19252 | (progn (org-add-to-invisibility-spec '(org-link)) (org-restart-font-lock)) |
| 16966 | :style radio :selected (member '(org-link) buffer-invisibility-spec)] | 19253 | :style radio :selected (member '(org-link) buffer-invisibility-spec)] |
| 16967 | ["Literal Links" | 19254 | ["Literal Links" |
| 16968 | (progn | 19255 | (progn |
| 16969 | (org-remove-from-invisibility-spec '(org-link)) (org-restart-font-lock)) | 19256 | (org-remove-from-invisibility-spec '(org-link)) (org-restart-font-lock)) |
| 16970 | :style radio :selected (not (member '(org-link) buffer-invisibility-spec))] | 19257 | :style radio :selected (not (member '(org-link) buffer-invisibility-spec))]) |
| 16971 | "--" | ||
| 16972 | ["Upgrade all <link> to [[link][desc]]" org-upgrade-old-links | ||
| 16973 | (save-excursion (goto-char (point-min)) | ||
| 16974 | (re-search-forward "<[a-z]+:" nil t))]) | ||
| 16975 | "--" | 19258 | "--" |
| 16976 | ["Export/Publish..." org-export t] | 19259 | ["Export/Publish..." org-export t] |
| 16977 | ("LaTeX" | 19260 | ("LaTeX" |
| @@ -16997,6 +19280,15 @@ See the individual commands for more information." | |||
| 16997 | ["Refresh setup" org-mode-restart t] | 19280 | ["Refresh setup" org-mode-restart t] |
| 16998 | )) | 19281 | )) |
| 16999 | 19282 | ||
| 19283 | (defun org-toggle-log-option (type) | ||
| 19284 | (if (not (listp org-log-done)) (setq org-log-done nil)) | ||
| 19285 | (if (memq type org-log-done) | ||
| 19286 | (setq org-log-done (delq type org-log-done)) | ||
| 19287 | (add-to-list 'org-log-done type))) | ||
| 19288 | |||
| 19289 | (defun org-check-log-option (type) | ||
| 19290 | (and (listp org-log-done) (memq type org-log-done))) | ||
| 19291 | |||
| 17000 | (defun org-info (&optional node) | 19292 | (defun org-info (&optional node) |
| 17001 | "Read documentation for Org-mode in the info system. | 19293 | "Read documentation for Org-mode in the info system. |
| 17002 | With optional NODE, go directly to that node." | 19294 | With optional NODE, go directly to that node." |
| @@ -17022,7 +19314,7 @@ With optional NODE, go directly to that node." | |||
| 17022 | "--") | 19314 | "--") |
| 17023 | (mapcar 'org-file-menu-entry (org-agenda-files t)))))))) | 19315 | (mapcar 'org-file-menu-entry (org-agenda-files t)))))))) |
| 17024 | 19316 | ||
| 17025 | ;;; Documentation | 19317 | ;;;; Documentation |
| 17026 | 19318 | ||
| 17027 | (defun org-customize () | 19319 | (defun org-customize () |
| 17028 | "Call the customize function with org as argument." | 19320 | "Call the customize function with org as argument." |
| @@ -17047,7 +19339,10 @@ With optional NODE, go directly to that node." | |||
| 17047 | (message "\"Org\"-menu now contains full customization menu")) | 19339 | (message "\"Org\"-menu now contains full customization menu")) |
| 17048 | (error "Cannot expand menu (outdated version of cus-edit.el)"))) | 19340 | (error "Cannot expand menu (outdated version of cus-edit.el)"))) |
| 17049 | 19341 | ||
| 17050 | ;;; Miscellaneous stuff | 19342 | ;;;; Miscellaneous stuff |
| 19343 | |||
| 19344 | |||
| 19345 | ;;; Generally useful functions | ||
| 17051 | 19346 | ||
| 17052 | (defun org-context () | 19347 | (defun org-context () |
| 17053 | "Return a list of contexts of the current cursor position. | 19348 | "Return a list of contexts of the current cursor position. |
| @@ -17067,7 +19362,7 @@ contexts are: | |||
| 17067 | :table in an org-mode table | 19362 | :table in an org-mode table |
| 17068 | :table-special on a special filed in a table | 19363 | :table-special on a special filed in a table |
| 17069 | :table-table in a table.el table | 19364 | :table-table in a table.el table |
| 17070 | :link on a hyperline | 19365 | :link on a hyperlink |
| 17071 | :keyword on a keyword: SCHEDULED, DEADLINE, CLOSE,COMMENT, QUOTE. | 19366 | :keyword on a keyword: SCHEDULED, DEADLINE, CLOSE,COMMENT, QUOTE. |
| 17072 | :target on a <<target>> | 19367 | :target on a <<target>> |
| 17073 | :radio-target on a <<<radio-target>>> | 19368 | :radio-target on a <<<radio-target>>> |
| @@ -17147,6 +19442,23 @@ and :keyword." | |||
| 17147 | (setq clist (nreverse (delq nil clist))) | 19442 | (setq clist (nreverse (delq nil clist))) |
| 17148 | clist)) | 19443 | clist)) |
| 17149 | 19444 | ||
| 19445 | (defun org-in-regexp (re &optional nlines visually) | ||
| 19446 | "Check if point is inside a match of regexp. | ||
| 19447 | Normally only the current line is checked, but you can include NLINES extra | ||
| 19448 | lines both before and after point into the search. | ||
| 19449 | If VISUALLY is set, require that the cursor is not after the match but | ||
| 19450 | really on, so that the block visually is on the match." | ||
| 19451 | (catch 'exit | ||
| 19452 | (let ((pos (point)) | ||
| 19453 | (eol (point-at-eol (+ 1 (or nlines 0)))) | ||
| 19454 | (inc (if visually 1 0))) | ||
| 19455 | (save-excursion | ||
| 19456 | (beginning-of-line (- 1 (or nlines 0))) | ||
| 19457 | (while (re-search-forward re eol t) | ||
| 19458 | (if (and (<= (match-beginning 0) pos) | ||
| 19459 | (>= (+ inc (match-end 0)) pos)) | ||
| 19460 | (throw 'exit (cons (match-beginning 0) (match-end 0))))))))) | ||
| 19461 | |||
| 17150 | (defun org-point-in-group (point group &optional context) | 19462 | (defun org-point-in-group (point group &optional context) |
| 17151 | "Check if POINT is in match-group GROUP. | 19463 | "Check if POINT is in match-group GROUP. |
| 17152 | If CONTEXT is non-nil, return a list with CONTEXT and the boundaries of the | 19464 | If CONTEXT is non-nil, return a list with CONTEXT and the boundaries of the |
| @@ -17159,6 +19471,20 @@ return nil." | |||
| 17159 | (list context (match-beginning group) (match-end group)) | 19471 | (list context (match-beginning group) (match-end group)) |
| 17160 | t))) | 19472 | t))) |
| 17161 | 19473 | ||
| 19474 | (defun org-combine-plists (&rest plists) | ||
| 19475 | "Create a single property list from all plists in PLISTS. | ||
| 19476 | The process starts by copying the first list, and then setting properties | ||
| 19477 | from the other lists. Settings in the last list are the most significant | ||
| 19478 | ones and overrule settings in the other lists." | ||
| 19479 | (let ((rtn (copy-sequence (pop plists))) | ||
| 19480 | p v ls) | ||
| 19481 | (while plists | ||
| 19482 | (setq ls (pop plists)) | ||
| 19483 | (while ls | ||
| 19484 | (setq p (pop ls) v (pop ls)) | ||
| 19485 | (setq rtn (plist-put rtn p v)))) | ||
| 19486 | rtn)) | ||
| 19487 | |||
| 17162 | (defun org-move-line-down (arg) | 19488 | (defun org-move-line-down (arg) |
| 17163 | "Move the current line down. With prefix argument, move it past ARG lines." | 19489 | "Move the current line down. With prefix argument, move it past ARG lines." |
| 17164 | (interactive "p") | 19490 | (interactive "p") |
| @@ -17185,8 +19511,54 @@ return nil." | |||
| 17185 | (goto-char pos) | 19511 | (goto-char pos) |
| 17186 | (move-to-column col))) | 19512 | (move-to-column col))) |
| 17187 | 19513 | ||
| 17188 | ;; Paragraph filling stuff. | 19514 | (defun org-replace-escapes (string table) |
| 19515 | "Replace %-escapes in STRING with values in TABLE. | ||
| 19516 | TABLE is an association list with keys line \"%a\" and string values. | ||
| 19517 | The sequences in STRING may contain normal field width and padding information, | ||
| 19518 | for example \"%-5s\". Replacements happen in the sequence given by TABLE, | ||
| 19519 | so values can contain further %-escapes if they are define later in TABLE." | ||
| 19520 | (let ((case-fold-search nil) | ||
| 19521 | e re rpl) | ||
| 19522 | (while (setq e (pop table)) | ||
| 19523 | (setq re (concat "%-?[0-9.]*" (substring (car e) 1))) | ||
| 19524 | (while (string-match re string) | ||
| 19525 | (setq rpl (format (concat (substring (match-string 0 string) 0 -1) "s") | ||
| 19526 | (cdr e))) | ||
| 19527 | (setq string (replace-match rpl t t string)))) | ||
| 19528 | string)) | ||
| 19529 | |||
| 19530 | |||
| 19531 | (defun org-sublist (list start end) | ||
| 19532 | "Return a section of LIST, from START to END. | ||
| 19533 | Counting starts at 1." | ||
| 19534 | (let (rtn (c start)) | ||
| 19535 | (setq list (nthcdr (1- start) list)) | ||
| 19536 | (while (and list (<= c end)) | ||
| 19537 | (push (pop list) rtn) | ||
| 19538 | (setq c (1+ c))) | ||
| 19539 | (nreverse rtn))) | ||
| 19540 | |||
| 19541 | (defun org-at-regexp-p (regexp) | ||
| 19542 | "Is point inside a match of REGEXP in the current line?" | ||
| 19543 | (catch 'exit | ||
| 19544 | (save-excursion | ||
| 19545 | (let ((pos (point)) (end (point-at-eol))) | ||
| 19546 | (beginning-of-line 1) | ||
| 19547 | (while (re-search-forward regexp end t) | ||
| 19548 | (if (and (<= (match-beginning 0) pos) | ||
| 19549 | (>= (match-end 0) pos)) | ||
| 19550 | (throw 'exit t))) | ||
| 19551 | nil)))) | ||
| 19552 | |||
| 19553 | (defun org-find-base-buffer-visiting (file) | ||
| 19554 | "Like `find-buffer-visiting' but alway return the base buffer and | ||
| 19555 | not an indirect buffer" | ||
| 19556 | (let ((buf (find-buffer-visiting file))) | ||
| 19557 | (or (buffer-base-buffer buf) buf))) | ||
| 19558 | |||
| 19559 | ;;; Paragraph filling stuff. | ||
| 17189 | ;; We want this to be just right, so use the full arsenal. | 19560 | ;; We want this to be just right, so use the full arsenal. |
| 19561 | ;; FIXME: configure filladapt for XEmacs | ||
| 17190 | 19562 | ||
| 17191 | (defun org-set-autofill-regexps () | 19563 | (defun org-set-autofill-regexps () |
| 17192 | (interactive) | 19564 | (interactive) |
| @@ -17202,7 +19574,7 @@ return nil." | |||
| 17202 | ;; But only if the user has not turned off tables or fixed-width regions | 19574 | ;; But only if the user has not turned off tables or fixed-width regions |
| 17203 | (org-set-local | 19575 | (org-set-local |
| 17204 | 'auto-fill-inhibit-regexp | 19576 | 'auto-fill-inhibit-regexp |
| 17205 | (concat "\\*\\|#" | 19577 | (concat "\\*\\|#\\+" |
| 17206 | "\\|[ \t]*" org-keyword-time-regexp | 19578 | "\\|[ \t]*" org-keyword-time-regexp |
| 17207 | (if (or org-enable-table-editor org-enable-fixed-width-editor) | 19579 | (if (or org-enable-table-editor org-enable-fixed-width-editor) |
| 17208 | (concat | 19580 | (concat |
| @@ -17236,52 +19608,12 @@ return nil." | |||
| 17236 | "Return a fill prefix for org-mode files. | 19608 | "Return a fill prefix for org-mode files. |
| 17237 | In particular, this makes sure hanging paragraphs for hand-formatted lists | 19609 | In particular, this makes sure hanging paragraphs for hand-formatted lists |
| 17238 | work correctly." | 19610 | work correctly." |
| 17239 | (if (looking-at " *\\([-*+] \\|[0-9]+[.)] \\)?") | 19611 | (cond ((looking-at "#[ \t]+") |
| 17240 | (make-string (- (match-end 0) (match-beginning 0)) ?\ ))) | 19612 | (match-string 0)) |
| 17241 | 19613 | ((looking-at " *\\([-*+] \\|[0-9]+[.)] \\)?") | |
| 17242 | ;; Functions needed for Emacs/XEmacs region compatibility | 19614 | (make-string (- (match-end 0) (match-beginning 0)) ?\ )) |
| 17243 | 19615 | (t nil))) | |
| 17244 | (defun org-add-hook (hook function &optional append local) | ||
| 17245 | "Add-hook, compatible with both Emacsen." | ||
| 17246 | (if (and local (featurep 'xemacs)) | ||
| 17247 | (add-local-hook hook function append) | ||
| 17248 | (add-hook hook function append local))) | ||
| 17249 | |||
| 17250 | (defun org-region-active-p () | ||
| 17251 | "Is `transient-mark-mode' on and the region active? | ||
| 17252 | Works on both Emacs and XEmacs." | ||
| 17253 | (if org-ignore-region | ||
| 17254 | nil | ||
| 17255 | (if (featurep 'xemacs) | ||
| 17256 | (and zmacs-regions (region-active-p)) | ||
| 17257 | (and transient-mark-mode mark-active)))) | ||
| 17258 | |||
| 17259 | (defun org-add-to-invisibility-spec (arg) | ||
| 17260 | "Add elements to `buffer-invisibility-spec'. | ||
| 17261 | See documentation for `buffer-invisibility-spec' for the kind of elements | ||
| 17262 | that can be added." | ||
| 17263 | (cond | ||
| 17264 | ((fboundp 'add-to-invisibility-spec) | ||
| 17265 | (add-to-invisibility-spec arg)) | ||
| 17266 | ((or (null buffer-invisibility-spec) (eq buffer-invisibility-spec t)) | ||
| 17267 | (setq buffer-invisibility-spec (list arg))) | ||
| 17268 | (t | ||
| 17269 | (setq buffer-invisibility-spec | ||
| 17270 | (cons arg buffer-invisibility-spec))))) | ||
| 17271 | |||
| 17272 | (defun org-remove-from-invisibility-spec (arg) | ||
| 17273 | "Remove elements from `buffer-invisibility-spec'." | ||
| 17274 | (if (fboundp 'remove-from-invisibility-spec) | ||
| 17275 | (remove-from-invisibility-spec arg) | ||
| 17276 | (if (consp buffer-invisibility-spec) | ||
| 17277 | (setq buffer-invisibility-spec | ||
| 17278 | (delete arg buffer-invisibility-spec))))) | ||
| 17279 | 19616 | ||
| 17280 | (defun org-in-invisibility-spec-p (arg) | ||
| 17281 | "Is ARG a member of `buffer-invisibility-spec'?" | ||
| 17282 | (if (consp buffer-invisibility-spec) | ||
| 17283 | (member arg buffer-invisibility-spec) | ||
| 17284 | nil)) | ||
| 17285 | 19617 | ||
| 17286 | (defun org-image-file-name-regexp () | 19618 | (defun org-image-file-name-regexp () |
| 17287 | "Return regexp matching the file names of images." | 19619 | "Return regexp matching the file names of images." |
| @@ -17297,7 +19629,12 @@ that can be added." | |||
| 17297 | t) | 19629 | t) |
| 17298 | "\\'")))) | 19630 | "\\'")))) |
| 17299 | 19631 | ||
| 17300 | ;; Functions extending outline functionality | 19632 | (defun org-file-image-p (file) |
| 19633 | "Return non-nil if FILE is an image." | ||
| 19634 | (save-match-data | ||
| 19635 | (string-match (org-image-file-name-regexp) file))) | ||
| 19636 | |||
| 19637 | ;;;; Functions extending outline functionality | ||
| 17301 | 19638 | ||
| 17302 | ;; C-a should go to the beginning of a *visible* line, also in the | 19639 | ;; C-a should go to the beginning of a *visible* line, also in the |
| 17303 | ;; new outline.el. I guess this should be patched into Emacs? | 19640 | ;; new outline.el. I guess this should be patched into Emacs? |
| @@ -17337,14 +19674,8 @@ to a visible line beginning. This makes the function of C-a more intuitive." | |||
| 17337 | (defalias 'org-on-heading-p 'outline-on-heading-p) | 19674 | (defalias 'org-on-heading-p 'outline-on-heading-p) |
| 17338 | 19675 | ||
| 17339 | (defun org-on-target-p () | 19676 | (defun org-on-target-p () |
| 17340 | (let ((pos (point))) | 19677 | (or (org-in-regexp org-radio-target-regexp) |
| 17341 | (save-excursion | 19678 | (org-in-regexp org-target-regexp))) |
| 17342 | (skip-chars-forward "<") | ||
| 17343 | (and (re-search-backward "<<" nil t) | ||
| 17344 | (or (looking-at org-radio-target-regexp) | ||
| 17345 | (looking-at org-target-regexp)) | ||
| 17346 | (<= (match-beginning 0) pos) | ||
| 17347 | (>= (1+ (match-end 0)) pos))))) | ||
| 17348 | 19679 | ||
| 17349 | (defun org-up-heading-all (arg) | 19680 | (defun org-up-heading-all (arg) |
| 17350 | "Move to the heading line of which the present line is a subheading. | 19681 | "Move to the heading line of which the present line is a subheading. |
| @@ -17374,6 +19705,14 @@ move point." | |||
| 17374 | (goto-char pos) | 19705 | (goto-char pos) |
| 17375 | nil))) | 19706 | nil))) |
| 17376 | 19707 | ||
| 19708 | (defun org-show-siblings () | ||
| 19709 | "Show all siblings of the current headline." | ||
| 19710 | (save-excursion | ||
| 19711 | (while (org-goto-sibling) (org-flag-heading nil))) | ||
| 19712 | (save-excursion | ||
| 19713 | (while (org-goto-sibling 'previous) | ||
| 19714 | (org-flag-heading nil)))) | ||
| 19715 | |||
| 17377 | (defun org-show-hidden-entry () | 19716 | (defun org-show-hidden-entry () |
| 17378 | "Show an entry where even the heading is hidden." | 19717 | "Show an entry where even the heading is hidden." |
| 17379 | (save-excursion | 19718 | (save-excursion |
| @@ -17446,6 +19785,30 @@ Show the heading too, if it is currently invisible." | |||
| 17446 | "\\):[ \t]*" | 19785 | "\\):[ \t]*" |
| 17447 | "\\(.+\\)")) | 19786 | "\\(.+\\)")) |
| 17448 | 19787 | ||
| 19788 | ;; Make isearch reveal the necessary context | ||
| 19789 | (defun org-isearch-end () | ||
| 19790 | "Reveal context after isearch exits." | ||
| 19791 | (when isearch-success ; only if search was successful | ||
| 19792 | (if (featurep 'xemacs) | ||
| 19793 | ;; Under XEmacs, the hook is run in the correct place, | ||
| 19794 | ;; we directly show the context. | ||
| 19795 | (org-show-context 'isearch) | ||
| 19796 | ;; In Emacs the hook runs *before* restoring the overlays. | ||
| 19797 | ;; So we have to use a one-time post-command-hook to do this. | ||
| 19798 | ;; (Emacs 22 has a special variable, see function `org-mode') | ||
| 19799 | (unless (and (boundp 'isearch-mode-end-hook-quit) | ||
| 19800 | isearch-mode-end-hook-quit) | ||
| 19801 | ;; Only when the isearch was not quitted. | ||
| 19802 | (org-add-hook 'post-command-hook 'org-isearch-post-command | ||
| 19803 | 'append 'local))))) | ||
| 19804 | |||
| 19805 | (defun org-isearch-post-command () | ||
| 19806 | "Remove self from hook, and show context." | ||
| 19807 | (remove-hook 'post-command-hook 'org-isearch-post-command 'local) | ||
| 19808 | (org-show-context 'isearch)) | ||
| 19809 | |||
| 19810 | ;;;; Repair problems with some other packages | ||
| 19811 | |||
| 17449 | ;; Make `bookmark-jump' show the jump location if it was hidden. | 19812 | ;; Make `bookmark-jump' show the jump location if it was hidden. |
| 17450 | (eval-after-load "bookmark" | 19813 | (eval-after-load "bookmark" |
| 17451 | '(if (boundp 'bookmark-after-jump-hook) | 19814 | '(if (boundp 'bookmark-after-jump-hook) |
| @@ -17468,9 +19831,10 @@ Show the heading too, if it is currently invisible." | |||
| 17468 | (eval-after-load "session" | 19831 | (eval-after-load "session" |
| 17469 | '(add-to-list 'session-globals-exclude 'org-mark-ring)) | 19832 | '(add-to-list 'session-globals-exclude 'org-mark-ring)) |
| 17470 | 19833 | ||
| 17471 | ;;; Experimental code | 19834 | ;;;; Experimental code |
| 17472 | 19835 | ||
| 17473 | ;;; Finish up | 19836 | |
| 19837 | ;;;; Finish up | ||
| 17474 | 19838 | ||
| 17475 | (provide 'org) | 19839 | (provide 'org) |
| 17476 | 19840 | ||
| @@ -17478,3 +19842,4 @@ Show the heading too, if it is currently invisible." | |||
| 17478 | 19842 | ||
| 17479 | ;; arch-tag: e77da1a7-acc7-4336-b19e-efa25af3f9fd | 19843 | ;; arch-tag: e77da1a7-acc7-4336-b19e-efa25af3f9fd |
| 17480 | ;;; org.el ends here | 19844 | ;;; org.el ends here |
| 19845 | |||