aboutsummaryrefslogtreecommitdiffstats
path: root/lisp/textmodes
diff options
context:
space:
mode:
Diffstat (limited to 'lisp/textmodes')
-rw-r--r--lisp/textmodes/org.el15101
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.
177This means, if you start editing an org file, you will get an
178immediate reminder of any due deadlines.
179This can also be configured on a per-file basis by adding one of
180the 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.
188When the function `org-mode' is called interactively in an empty file, this 148When the function `org-mode' is called interactively in an empty file, this
@@ -210,8 +170,9 @@ S-right -> M-+
210If you do not like the alternative keys, take a look at the variable 170If you do not like the alternative keys, take a look at the variable
211`org-disputed-keys'. 171`org-disputed-keys'.
212 172
213This option is only relevant at load-time of Org-mode. Changing it requires 173This option is only relevant at load-time of Org-mode, and must be set
214a restart of Emacs to become effective." 174*before* org.el is loaded. Changing it requires a restart of Emacs to
175become 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.
260After 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.
274Org-mode often shows locations in an org-mode file which might have
275been invisible before. When this is set, the hierarchy of headings
276above the exposed location is shown.
277Turning this off for example for sparse trees makes them very compact.
278Instead of t, this can also be an alist specifying this option for different
279contexts. 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.
309Org-mode often shows locations in an org-mode file which might have
310been invisible before. When this is set, the heading following the
311match is shown.
312Turning this off for example for sparse trees makes them very compact,
313but makes it harder to edit the location of the match. In such a case,
314use the command \\[org-reveal] to show more context.
315Instead of t, this can also be an alist specifying this option for different
316contexts. 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.
337Org-mode often shows locations in an org-mode file which might have
338been invisible before. When this is set, the sibling of the current entry
339heading are all made visible. If `org-show-hierarchy-above' is t,
340the same happens on each level of the hierarchy above the current entry.
341
342By default this is on for the isearch context, off for all other contexts.
343Turning this off for example for sparse trees makes them very compact,
344but makes it harder to edit the location of the match. In such a case,
345use the command \\[org-reveal] to show more context.
346Instead of t, this can also be an alist specifying this option for different
347contexts. 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.
422Turning this off makes sparse trees more compact, but also less clear.
423Instead of t, this can also be an alist specifying this option for different
424contexts. 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'.
452When doing an `org-occur' it is useful to show the headline which
453follows the match, even if they do not match the regexp. This makes it
454easier to edit directly inside the sparse tree. However, if you use
455`org-occur' mainly as an overview, the following headlines are
456unnecessary clutter.
457Instead of t, this can also be an alist specifying this option for different
458contexts. 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."
519When this is set, checkbox statistics is updated each time you either insert 529When this is set, checkbox statistics is updated each time you either insert
520a new checkbox with \\[org-insert-todo-heading] or toggle a checkbox 530a new checkbox with \\[org-insert-todo-heading] or toggle a checkbox
521with \\[org-ctrl-c-ctrl-c\\]." 531with \\[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.
540An archived tree is a tree marked with the tag ARCHIVE." 550An 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.
691All occurrences of %n in a template will be replaced with the name of the
692table, 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.
674If a table column contains mostly numbers, it will be aligned to the 711If a table column contains mostly numbers, it will be aligned to the
675right. If not, it will be aligned to the left. 712right. 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.
727This only happens when typing immediately after a field motion 759This 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.
789A constant looks like `$c' or `$Grav' and will be replaced before evaluation 823A 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.
811Then all input fields will be converted to a number, and the result
812must also be a number. When nil, calc's full potential is available
813in 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.
819Automatically means, when TAB or RET or C-c C-c are pressed in the line." 845Automatically 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.
836The cdrs are replacement values, like (\"linkkey\" . REPLACE). Abbreviated 862The cdrs are replacement values, like (\"linkkey\" . REPLACE). Abbreviated
837links in Org-mode buffers can have an optional tag after a double colon, e.g. 863links 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
841If REPLACE is a string, the tag will simply be appended to create the link. 867If REPLACE is a string, the tag will simply be appended to create the link.
842If the string contains \"%s\", the tag will be inserted there. REPLACE may 868If 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].
858Possible values are:
859bracket [[link][description]]. This is recommended
860plain 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.
868This is a format string for printf, %s will be replaced by the link text.
869The recommended value is just \"%s\", since links will be protected by
870enclosing them in double brackets. If you prefer plain links (see variable
871`org-link-style'), \"<%s>\" is useful. Some people also recommend an
872additional 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.
882Valid values are: 884Valid values are:
@@ -907,7 +909,6 @@ plain Plain links in normal text, no whitespace, like http://google.com.
907radio Text that is matched by a radio target, see manual for details. 909radio Text that is matched by a radio target, see manual for details.
908tag Tag settings in a headline (link to tag search). 910tag Tag settings in a headline (link to tag search).
909date Time stamps (link to calendar). 911date Time stamps (link to calendar).
910camel CamelCase words defining text searches.
911 912
912Changing this variable requires a restart of Emacs to become effective." 913Changing 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.
929The 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
940You may use normal field width specification between the % and the letter.
941This is for example useful to limit the length of the subject.
942
943Examples: \"%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.
955It 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.
929A search string will be added to the file name with :: as separator and 961A 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.
939When nil, the search string simply consists of the words of the string.
940CamelCase 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.
1047When nil, an error will be generated." 1071When 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
1178all folders if the message cannot be found in the folder given in the link. 1202all folders if the message cannot be found in the folder given in the link.
1179Searching all folders is very effective with one of the search engines 1203Searching all folders is very efficient with one of the search engines
1180supported by MH-E, but will be slow with pick." 1204supported 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.
1198Used by the hooks for remember.el. This can be a string, or nil to mean 1222Used by the hooks for remember.el. This can be a string, or nil to mean
1199the value of `remember-data-file'." 1223the value of `remember-data-file'.
1224You 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.
1233When filing remember notes, the cursor will start at that position.
1234You 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.
1207When nil, just let remember make the buffer. 1241When nil, just let remember make the buffer.
1208When not nil, this is a list of 3-element lists. In each entry, the first 1242When not nil, this is a list of 4-element lists. In each entry, the first
1209element is a character, a unique key to select this template. 1243element is a character, a unique key to select this template.
1210The second element is the template. The third element is optional and can 1244The second element is the template. The third element is optional and can
1211specify a destination file for remember items created with this template. 1245specify a destination file for remember items created with this template.
1212The default file is given by `org-default-notes-file'. 1246The default file is given by `org-default-notes-file'. An optional third
1247element can specify the headline in that file that should be offered
1248first when the user is asked to file the entry. The default headline is
1249given in the variable `org-remember-default-headline'.
1213 1250
1214The template specifies the structure of the remember buffer. It should have 1251The template specifies the structure of the remember buffer. It should have
1215a first line starting with a star, to act as the org-mode headline. 1252a first line starting with a star, to act as the org-mode headline.
1216Furthermore, the following %-escapes will be replaced with content: 1253Furthermore, 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
1269Apart from these general escapes, you can access information specific to the
1270link type that is created. For example, calling `remember' in emails or gnus
1271will record the author and the subject of the message, which you can access
1272with %:author and %:subject, respectively. Here is a complete list of what
1273is recorded for each link type.
1274
1275Link type | Available information
1276-------------------+------------------------------------------------------
1277bbdb | %:type %:name %:company
1278vm, wl, mh, rmail | %:type %:subject %:message-id
1279 | %:from %:fromname %:fromaddress
1280 | %:to %:toname %:toaddress
1281 | %:fromto (either \"to NAME\" or \"from NAME\")
1282gnus | %:group, for messages also all email fields
1283w3, w3m | %:type %:url
1284info | %:type %:file %:node
1285calendar | %: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.
1291Valid members of this list are 1364Valid 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
1296A separate window will then pop up and allow you to type a note. 1373A 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
1301Logging can also be configured on a per-file basis by adding one of 1378Logging can also be configured on a per-file basis by adding one of
1302the following lines anywhere in the buffer: 1379the 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.
1316The value is an alist, with the car being a sympol indicating the note 1401The value is an alist, with the car being a sympol indicating the note
1317context, and the cdr is the heading to be used. The heading may also be the 1402context, and the cdr is the heading to be used. The heading may also be the
1318empty string." 1403empty 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.
1419A repeat cookie looks like REPEAT(+1m) and causes deadlines and schedules
1420to repeat themselves shifted by a certain amount of time, each time an
1421entry 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.
1386This variable governs the display in sparse trees and in the agenda." 1496This 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.
1442When nil, you have to press RET to exit it. 1552When nil, you have to press RET to exit it.
1443During fast tag selection, you can toggle this flag with `C-c'." 1553During fast tag selection, you can toggle this flag with `C-c'.
1554This variable can also have the value `expert'. In this case, the window
1555displaying 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.
1641When t, a confirmation is always needed. When a number N, confirmation is
1642only 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.
1651The command `org-calendar-goto-agenda' will be bound to this key. The
1652default is the character `c' because then `c' can be used to switch back and
1653forth 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.
1526These commands will be offered on the splash screen displayed by the 1664These commands will be offered on the splash screen displayed by the
1527agenda dispatcher \\[org-agenda]. Each entry is a list like this: 1665agenda 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
1563Each command can carry a list of options, and another set of options can be 1702Each command can carry a list of options, and another set of options can be
1564given for the whole set of commands. Individual command options take 1703given for the whole set of commands. Individual command options take
1565precedence over the general options." 1704precedence 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.
1764This is a list of three items:
17651. 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.
17672. 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.
17703. 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
1774After defining this variable, you may use \\[org-agenda-list-stuck-projects]
1775or `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.
1614When nil, the sublevels of a TODO entry are not checked, resulting in 1790When nil, the sublevels of a TODO entry are not checked, resulting in
1615potentially much shorter TODO lists." 1791potentially 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.
1622The idea behind this is that by scheduling it, you have already taken care 1798The idea behind this is that by scheduling it, you have already taken care
1623of this item." 1799of 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.
1630Near means closer than `org-deadline-warning-days' days. 1806Near means closer than `org-deadline-warning-days' days.
1631The idea behind this is that such items will appear in the agenda anyway." 1807The 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.
1814This 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.
1640When t, all days between the first and the last date are shown. 1821When t, all days between the first and the last date are shown.
1641When an integer, show also empty dates, but if there is a gap of more than 1822When an integer, show also empty dates, but if there is a gap of more than
1642N days, just insert a special line indicating the size of the gap." 1823N 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.
1651When t, a confirmation is always needed. When a number N, confirmation is
1652only 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"
1662The TODO entries will be listed at the top of the agenda, before 1834 :group 'org-agenda)
1663the 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.
1843A longer mouse click will still set point. Does not wortk on XEmacs.
1844Needs 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."
1674The command `org-calendar-goto-agenda' will be bound to this key. The 1850 :group 'org-agenda-startup
1675default is the character `c' because then `c' can be used to switch back and 1851 :type 'boolean)
1676forth 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.
1690other-frame Use `switch-to-buffer-other-frame' to display agenda. 1863other-frame Use `switch-to-buffer-other-frame' to display agenda.
1691other-window Use `switch-to-buffer-other-window' to display agenda. 1864other-window Use `switch-to-buffer-other-window' to display agenda.
1692reorganize-frame Show only two windows on the current frame, the current 1865reorganize-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.
1696See also the variable `org-agenda-restore-windows-after-quit'." 1867See 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
1710option will be ignored.." 1881option 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.
1717When 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. 1887This applies to indirect buffers created with the commands
1724This 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 1889Valid values are:
1726 :type 'boolean) 1890current-window Display in the current window
1727 1891other-window Just display in another window.
1728(defcustom org-finalize-agenda-hook nil 1892dedicated-frame Create one new frame, and re-use it each time.
1729 "Hook run just before displaying an agenda buffer." 1893new-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)
1735A longer mouse click will still set point. Does not wortk on XEmacs. 1899 (const :tag "Each time a new frame" new-frame)
1736Needs 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.
1752When nil, only the days which actually have entries are shown." 1909Should 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.
17580 denotes Sunday, 1 denotes Monday etc. 19150 denotes Sunday, 1 denotes Monday etc.
1759When nil, always start on the current day." 1916When 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.
1766Should be 1 or 7." 1923When 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.
1929Used by the daily/weekly agenda and by the timeline. This should be
1930a format string understood by `format-time-string'.
1931FIXME: 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.
1942The TODO entries will be listed at the top of the agenda, before
1943the 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
1774sorted in between these lines. 1956sorted in between these lines.
1775For details about when the grid will be shown, and what it will look like, see 1957For details about when the grid will be shown, and what it will look like, see
1776the variable `org-agenda-time-grid'." 1958the 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
1796The third item is a list of integers, indicating the times that should have 1978The third item is a list of integers, indicating the times that should have
1797a grid line." 1979a 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
1849Leaving out `category-keep' would mean that items will be sorted across 2036Leaving out `category-keep' would mean that items will be sorted across
1850categories by priority." 2037categories 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
1866do have a time. When nil, the default time is before 0:00. You can use this 2053do have a time. When nil, the default time is before 0:00. You can use this
1867option to decide if the schedule for today should come before or after timeless 2054option to decide if the schedule for today should come before or after timeless
1868agenda entries." 2055agenda 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.
2072The TOC contains headlines with levels up to`org-export-headline-levels'. 2259The TOC contains headlines with levels up to`org-export-headline-levels'.
2260When an integer, include levels up to N in the toc, this may then be
2261different from `org-export-headline-levels', but it will not be allowed
2262to be larger than the number of headline levels.
2263When nil, no table of contents is made.
2073 2264
2074Headlines which contain any TODO items will be marked with \"(*)\" in 2265Headlines which contain any TODO items will be marked with \"(*)\" in
2075ASCII export, and with red color in HTML output. 2266ASCII export, and with red color in HTML output, if the option
2267`org-export-mark-todo-in-toc' is set.
2076 2268
2077In HTML output, the TOC will be clickable. 2269In HTML output, the TOC will be clickable.
2078 2270
2079This option can also be set with the +OPTIONS line, e.g. \"toc:nil\"." 2271This option can also be set with the +OPTIONS line, e.g. \"toc:nil\"
2272or \"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.
2284Otherwise 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.
2382When nil, these tags will be exported as plain text and therefore 2573When 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.
2392This must be a <table> tag, but you may change the options like 2583This must be a <table> tag, but you may change the options like
2393borders and spacing." 2584borders 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.
2412Otherwise, 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.
2526This is a list with 6 entries. Terminology: In an emphasis string 2714This is a list with 6 entries. Terminology: In an emphasis string
2527like \" *strong word* \", we call the initial space PREMATCH, the final 2715like \" *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.
3144Each element is a list of three items: The startup options as written
3145in the #+STARTUP line, the corresponding variable, and the value to
3146set this variable to if the option is found. An optional forth element PUSH
3147means 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.
3288This 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.
3407If 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?
3428Works 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'.
3439See documentation for `buffer-invisibility-spec' for the kind of elements
3440that 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" 4189With 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.
3953This function uses a recursive edit. It returns the selected position 4295This 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.
4379With numerical prefix ARG, go up to this level and then take that tree.
4380If ARG is negative, go up that many levels.
4381Normally this command removes the indirect buffer previously made
4382with this command. However, when called with a C-u prefix, the last buffer
4383is kept so that you can work with several indirect buffers at the same time.
4384If `org-indirect-buffer-display' is `dedicated-frame', the C-u prefix also
4385requests that a new frame be made for the new buffer, so that the dedicated
4386frame 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.
4065Does 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.
4076Return 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.
4126See also `org-promote'." 4510See 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.
4644This will leave level 1 alone, convert level 2 to level 3, level 3 to
4645level 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.
4660This promotes level 3 to level 2, level 5 to level 3 etc. If the file contains a
4661section with an even level, conversion would destroy the structure of the file. An error
4662is 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.
4904If there is an active region, the entries in the region are sorted.
4905Else, if the cursor is before the first entry, sort the top-level items.
4906Else, the children of the entry at point are sorted.
4907
4908Sorting can be alphabetically, numerically, and by date/time as given by
4909the first time stamp in the entry. The command prompts for the sorting
4910type unless it has been given to the function through the SORTING-TYPE
4911argument, which needs to a character, any of (?n ?N ?a ?A ?t ?T).
4912
4913Comparing entries ignores case by default. However, with an optional argument
4914WITH-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.
4985The user will be prompted for the SORTING-TYPE if the call to this
4986function does not specify it. WHAT is only for the prompt, to indicate
4987what is being sorted. The sorting key will be extracted from
4988the car of the elements of the table.
4989If 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.
5041Does 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.
5052Return 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.
4602If it is larger than ind, reduce it by ind." 5205IND is a cons cell with target and minimum indentation.
5206If the current indenation in LINE is smaller than the minimum,
5207leave 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
5729outside the table.")
5730(defconst org-table-any-border-regexp "^[ \t]*[^|+ \t]"
5731 "Searching from within a table (any type) this finds the first line
5732outside 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.
5769If there is already a table at point, convert between Org-mode tables
5770and 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.
5784If there is an active region, convert it to a table. If there is no such
5785region, 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.
5793SIZE 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.
5825The region goes from BEG0 to END0, but these borders will be moved
5826slightly, to make sure a beginning of line in the first line is included.
5827When NSPACE is non-nil, it indicates the minimum number of spaces that
5828separate 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.
5860The file is assumed to be tab-separated. Such files can be produced by most
5861spreadsheet and database applications. If no tabs (at least one per line)
5862are 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.
5872Such 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.
5908Used 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.
5911Used 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.
5914This 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.
5917This 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.
6088This ignores character with invisibility property `org-link', and also
6089characters with property `org-cwidth', because these will become invisible
6090upon 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.
6110With 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.
6123With 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)) 6135Optional 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.
6174Before 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.
6203Before 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.
6221Before 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.
6244If the field at the cursor is empty, copy into it the content of the nearest
6245non-empty field above. With argument N, use the Nth non-empty field.
6246If the current field is not empty, it is copied down to the next row, and
6247the cursor is moved with it. Therefore, repeating this command causes the
6248column to be filled row-by-row.
6249If the variable `org-table-copy-increment' is non-nil and the field is an
6250integer, 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?
6286I.e. not on a hline or before the first or after the last column?
6287This 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.
6316N defaults to current field.
6317If REPLACE is a string, replace field with this value. The return value
6318is 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.
6364When 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.
6377Only 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.
6391With optional argument ON-DELIM, stop with point before the left delimiter
6392of the field.
6393If there are less than N fields, just go to after the last delimiter.
6394However, 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.
6414If 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.
6619With 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.
6638With 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.
6658In 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
6686The position of point indicates the column to be used for
6687sorting, and the range of lines is the range between the nearest
6688horizontal separator lines, or the entire table of no such lines
6689exist. If point is before the first column, you will be prompted
6690for the sorting column. If there is an active region, the mark
6691specifies the first line and the sorting column, while point
6692should be in the last line to be included into the sorting.
6693
6694The command then prompts for the sorting type which can be
6695alphabetically, numerically, or by time (as given in a time stamp
6696in the field). Sorting in reverse order is also possible.
6697
6698With prefix argument WITH-CASE, alphabetic sorting will be case-sensitive.
6699
6700If SORTING-TYPE is specified when this function is called from a Lisp
6701program, no prompting will take place. SORTING-TYPE must be a character,
6702any of (?a ?A ?n ?N ?t ?T) where the capital letter indicate that sorting
6703should 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.
6766A special clipboard is used which can only be accessed
6767with `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.
6800The upper right corner ends up in the current field. All involved fields
6801will be overwritten. If the rectangle does not fit into the present table,
6802the table is enlarged as needed. The process ignores horizontal separator
6803lines."
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.
6830Obviously, this only works within limits. When an Org-mode table is
6831converted to table.el, all horizontal separator lines get lost, because
6832table.el uses these as cell boundaries and has no notion of horizontal lines.
6833A table.el table can be converted to an Org-mode table only if it does not
6834do row or column spanning. Multiline cells will become multiple cells.
6835Beware, Org-mode does not test if the table can be successfully converted - it
6836blindly 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.
6875This is useful if you'd like to spread the contents of a field over several
6876lines, in order to keep the table compact.
6877
6878If there is an active region, and both point and mark are in the same column,
6879the text in the column is wrapped to minimum width for the given number of
6880lines. Generally, this makes the table more compact. A prefix ARG may be
6881used to change the number of desired lines. For example, `C-2 \\[org-table-wrap]'
6882formats the selected text to two lines. If the region was longer than two
6883lines, the remaining lines remain empty. A negative prefix argument reduces
6884the current number of lines by that amount. The wrapped text is pasted back
6885into the table. If you formatted it to more lines than it was before, fields
6886further down in the table get overwritten - so you might need to make space in
6887the table first.
6888
6889If there is no region, the current field is split at the cursor position and
6890the text fragment to the right of the cursor is prepended to the field one
6891line down.
6892
6893If there is no region, but you specify a prefix ARG, the current field gets
6894blank, 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.
6942This is mainly useful for fields that contain hidden parts.
6943When called with a \\[universal-argument] prefix, just make the full field visible so that
6944it 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.
6975Remove all newline characters, insert the result into the table, realign
6976the 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.
7004If WIDTH is non-nil, the string is wrapped to that width, however many lines
7005that costs. If there is a word longer than WIDTH, the text is actually
7006wrapped to the length of that word.
7007IF WIDTH is nil and LINES is non-nil, the string is forced into at most that
7008many lines, whatever width that takes.
7009The 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.
7040No empty strings are returned if there are matches at the beginning
7041and 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.
7084The result will be displayed in the echo area, and will be available
7085as kill to be inserted with \\[yank].
7086
7087If there is an active region, it is interpreted as a rectangle and all
7088numbers in that rectangle will be summed. If there is no active
7089region and point is located in a table column, sum all numbers in that
7090column.
7091
7092If at least one number looks like a time HH:MM or HH:MM:SS, all other
7093numbers are assumed to be times as well (in decimal hours) and the
7094numbers are added as such.
7095
7096If 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.
7162Assumes 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.
7178When 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.
7265KEY is \"@\" or \"$\". REPLACE is an alist of numbers to replace.
7266For 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 \":=\".
7354If 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.
7370Will 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.
7383If in any row, the first field is not consistent with a mark,
7384insert a new column for the markers.
7385When there is an active region, change all the lines in the region,
7386after prompting for the marking character.
7387After each change, a message will be displayed indicating the meaning
7388of 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.
7453When 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
7474This function makes use of Dave Gillespie's Calc package, in my view the
7475most exciting program ever written for GNU Emacs. So you need to have Calc
7476installed in order to use this function.
7477
7478In a table, this command replaces the value in the current field with the
7479result of a formula. It also installs the formula as the \"current\" column
7480formula, by storing it in a special line below the table. When called
7481with a `C-u' prefix, the current field must ba a named field, and the
7482formula is installed as valid in only this specific field.
7483
7484When called with two `C-u' prefixes, insert the active equation
7485for the field back into the current field, so that it can be
7486edited there. This is useful in order to use \\[org-show-reference]
7487to check the referenced fields.
7488
7489When called, the command first prompts for a formula, which is read in
7490the minibuffer. Previously entered formulas are available through the
7491history list, and the last used formula is offered as a default.
7492These stored formulas are adapted correctly when moving, inserting, or
7493deleting columns with the corresponding commands.
7494
7495The formula can be any algebraic expression understood by the Calc package.
7496For details, see the Org-mode manual.
7497
7498This function can also be called from Lisp programs and offers
7499additional arguments: EQUATION can be the formula to apply. If this
7500argument is given, the user will not be prompted. SUPPRESS-ALIGN is
7501used to speed-up recursive calls by by-passing unnecessary aligns.
7502SUPPRESS-CONST suppresses the interpretation of constants in the
7503formula, assuming that this has been done already outside the function.
7504SUPPRESS-STORE means the formula should not be stored, either because
7505it is already stored, or because it is a modified equation that should
7506not 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
7621Orig: %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.
7652Optional arguments TBEG and COL can give the beginning of the table and
7653the current column, to avoid unnecessary parsing.
7654HIGHLIGHT 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.
7713The cursor is currently in line CLINE, the table begins in line BLINE,
7714and 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.
7767KEEP-EMPTY indicated to keep empty fields, default is to skip them.
7768NUMBERS indicates that everything should be converted to numbers.
7769LISPP 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.
7793With 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.
7919Parameters 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.
7983With 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.
8213Use 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'
8357table 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.
8442FUN is the command to call inside a table. N is used to create a unique
8443command name. KEYS are keys that should be checked in for a command
8444to 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.
8600It it is a table to be sent away to a receiver, do it.
8601With 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.
8642If the cursor is in a table looking at whitespace, the whitespace is
8643overwritten, 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.
8680With argument MAYBE, fail quietly if no transformation is defined for
8681this 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.
8743First 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.
8790If this is a header line, actually get the value for the symbol with an
8791additional \"h\" inserted after the colon.
8792If the value is a protperty list, get the element for the current column.
8793Assumes 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.
8800This generic routine can be used for many standard cases.
8801TABLE is a list, each entry either the symbol `hline' for a horizontal
8802separator line, or a list of fields for that line.
8803PARAMS is a property list of parameters that can influence the conversion.
8804For the generic converter, some parameters are obligatory: You need to
8805specify either :lfmt, or all of (:lstart :lend :sep). If you do not use
8806:splice, you must have :tstart and :tend.
8807
8808Valid 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
8841In addition to this, the parameters :skip and :skipcols are always handled
8842directly 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.
8892TABLE is a list, each entry either the symbol `hline' for a horizontal
8893separator line, or a list of fields for that line.
8894PARAMS is a property list of parameters that can influence the conversion.
8895Supports all parameters from `orgtbl-to-generic'. Most important for
8896LaTeX 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
8911The general parameters :skip and :skipcols have already been applied when
8912this 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.
8925TABLE is a list, each entry either the symbol `hline' for a horizontal
8926separator line, or a list of fields for that line.
8927PARAMS is a property list of parameters that can influence the conversion.
8928Currently 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
8933The general parameters :skip and :skipcols have already been applied when
8934this function is called. The function does *not* use `orgtbl-to-generic',
8935so 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.
8954TABLE is a list, each entry either the symbol `hline' for a horizontal
8955separator line, or a list of fields for that line.
8956PARAMS is a property list of parameters that can influence the conversion.
8957Supports all parameters from `orgtbl-to-generic'. Most important for
8958TeXInfo 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
8973The general parameters :skip and :skipcols have already been applied when
8974this 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.
9023This link can later be inserted into an org-buffer with
9024\\[org-insert-link].
9025For some link types, a prefix arg is interpreted:
9026For links to usenet articles, arg negates `org-usenet-links-prefer-google'.
9027For 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.
9273This takes information from `org-store-link-plist' and formats it
9274according 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
9405Completion 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
9407press RET at the prompt), the link defaults to the most recently
9408stored link. As SPC triggers completion in the minibuffer, you need to
9409use M-SPC or C-q SPC to force the insertion of a space character.
9410
9411You will also be prompted for a description, and if one is given, it will
9412be displayed in the buffer instead of the link.
9413
9414If there is already a link at point, this command will allow you to edit link
9415and description parts.
9416
9417With a \\[universal-argument] prefix, prompts for a file to link to. The file name can be
9418selected using completion. The path to the file will be relative to
9419the current directory if the file is in the current directory or a
9420subdirectory. Otherwise, the link will be the absolute path as
9421completed in the minibuffer (i.e. normally ~/path/to/file).
9422
9423With two \\[universal-argument] prefixes, enforce an absolute path even if the file
9424is in the current directory or below.
9425With 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.
9537If 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.
9557If 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.
9589This 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.
9596If there is no link at point, this function will search forward up to
9597the end of the current subtree.
9598Normally, files will be opened by an appropriate application. If the
9599optional 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.
9777These functions are called in turn with point at the location to
9778which the link should point.
9779
9780A function in the hook should first test if it would like to
9781handle this file type, for example by checking the major-mode or
9782the file extension. If it decides not to handle this file, it
9783should just return nil to give other functions a chance. If it
9784does handle the file, it must return the search string to be used
9785when following the link. The search string will be part of the
9786file link, given after a double colon, and `org-open-at-point'
9787will automatically search for it. If special measures must be
9788taken to make the search successful, another function should be
9789added to the companion hook `org-execute-file-search-functions',
9790which see.
9791
9792A function in this hook may also use `setq' to set the variable
9793`description' to provide a suggestion for the descriptive text to
9794be used for this link when it gets inserted into an Org-mode
9795buffer 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
9800Functions added to this hook must accept a single argument, the
9801search string that was part of the file link, the part after the
9802double colon. The function must first check if it would like to
9803handle this search, for example by checking the major-mode or the
9804file extension. If it decides not to handle this search, it
9805should just return nil to give other functions a chance. If it
9806does handle the search, it must return a non-nil value to keep
9807other functions from trying.
9808
9809Each function can access the current prefix argument through the
9810variable `current-prefix-argument'. Note that a single prefix is
9811used to force opening a link in Emacs, so it may be good to only
9812use a numeric or double prefix to guide the search function.
9813
9814In case this is needed, a function in this hook can also restore
9815the 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.
9821If S is surrounded by forward slashes, it is interpreted as a
9822regular expression. In org-mode files, this will create an `org-occur'
9823sparse tree. In ordinary files, `occur' will be used to list matches.
9824If the current buffer is in `dired-mode', grep will be used to search
9825in 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
9902enclose 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'.
9935If CLEANUP is non-nil, remove the printout of the regular expression
9936in the *Occur* buffer. This is useful if the regex is long and not useful
9937to 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.
9979With prefix arg N, jump back that many stored positions. When
9980called several times in succession, walk through the entire ring.
9981Org-mode commands jumping to a different position in the current file,
9982or to another Org-mode file, automatically push the old position
9983onto 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
10144sequences, 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
10182use 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
10191use 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
10200show buffer for the corresponding message. If you have a more clever
10201idea..."
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.
10220If ARTICLE is nil FOLDER is shown. If the configuration variable
10221`org-mhe-search-all-folders' is t and `mh-searcher' is pick,
10222ARTICLE is searched in all folders. Indexed searches (swish++,
10223namazu, and others supported by MH-E) will always search in all
10224folders."
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.
10305First, this expands any special file name abbreviations. Then the
10306configuration variable `org-file-apps' is checked if it contains an
10307entry for this file type, and if yes, the corresponding command is launched.
10308If no application is found, Emacs simply visits the file.
10309With optional argument IN-EMACS, Emacs will visit the file.
10310Optional LINE specifies a line to go to, optional SEARCH a string to
10311search for. If LINE or SEARCH is given, the file will always be
10312opened in Emacs.
10313If 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.
10385Return non-nil if the location is indeed remote.
10386
10387For example, the filename \"/user@host:/foo\" specifies a location
10388on 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.
10404If you are using Org-mode files as target for data storage with
10405remember.el, then the annotations should include a link compatible with the
10406conventions 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.
10411UP/DOWN=headline TAB=cycle visibility [Q]uit RET/<left>/<right>=Store
10412RET at beg-of-buf -> Append to file as level 2 headline
10413RET 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'.
10419This function should be placed into `remember-mode-hook' and in fact requires
10420to 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.
10512If there is an active region, make sure remember uses it as initial content
10513of 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.
10531First prompts for an org file. If the user just presses return, the value
10532of `org-default-notes-file' is used.
10533Then the command offers the headings tree of the selected file in order to
10534file the text at a specific location.
10535You can either immediately press RET to get the note appended to the
10536file, or you can use vertical cursor motion and visibility cycling (TAB) to
10537find a better place. Then press RET or <left> or <right> in insert the note.
10538
10539Key Cursor position Note gets inserted
10540-----------------------------------------------------------------------------
10541RET buffer-start as level 2 heading at end of file
10542RET on headline as sublevel of the heading at cursor
10543RET 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
10548So the fastest way to store the note is to press RET RET to append it to
10549the default file. This way your current train of thought is not
10550interrupted, in accordance with the principles of remember.el. But with
10551little extra effort, you can push it directly to the correct location.
10552
10553Before being stored away, the function ensures that the text has a
10554headline, i.e. a first line that starts with a \"*\". If not, a headline
10555is constructed from the current date and some additional data.
10556
10557If the variable `org-adapt-indentation' is non-nil, the entire text is
10558also indented so that it starts in the same column as the headline
10559\(i.e. after the stars).
10560
10561See 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.
5426When it starts with DONE, the DONE is removed. And when neither TODO nor 10914When it starts with DONE, the DONE is removed. And when neither TODO nor
5427DONE are present, add TODO at the beginning of the heading. 10915DONE are present, add TODO at the beginning of the heading.
5428 10916
5429With prefix arg, use completion to determine the new state. With numeric 10917With C-u prefix arg, use completion to determine the new state.
5430prefix arg, switch to that state." 10918With numeric prefix arg, switch to that state.
10919
10920For 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.
11019If yes, set TODO state back to what it was and change any SCHEDULED
11020or DEADLINE times the new date.
11021This 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.
5495The tree will show the lines where the regexp matches, and all higher 11056The 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.
5530REMOVE indicates what kind of entries to remove. An old WHAT entry will also 11091REMOVE indicates what kind of entries to remove. An old WHAT entry will also
5531be removed." 11092be 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.
11158The 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.
5680How much context is shown depends upon the variables 11276How 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
5682When 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'
5720not t for the search context. 11309not t for the search context.
5721 11310
5722With optional argument SIBLINGS, on each level of the hierarchy all 11311With optional argument SIBLINGS, on each level of the hierarchy all
5723siblings are shown. This repairs the tree structure so what it would 11312siblings are shown. This repairs the tree structure to what it would
5724look like when opend with successive calls to `org-cycle'." 11313look 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.
5780BEG and END are ignored. If NOREMOVE is nil, remove this function 11328BEG 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.
11412ACTION can be `sparse-tree' or `agenda'. MATCHER is a Lisp form to be
11413evaluated, testing if a given set of tags qualifies a headline for
11414inclusion. When TODO-ONLY is non-nil, only lines with a TODO keyword
11415are 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.
11492MATCH can contain positive and negative selection of tags, like
11493\"+WORK+URGENT-WITHBOSS\".
11494If optional argument TODO_ONLY is non-nil, only select lines that are
11495also 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.
11599With 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.
11710CURRENT is the current list of tags in the headline, INHERITED is the
11711list of inherited tags, and TABLE is an alist of tags and corresponding keys,
11712possibly with grouping information.
11713If the keys are nil, a-z are automatically assigned.
11714Returns 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.
5913The prompt will suggest to enter an ISO date, but you can also enter anything 11959The prompt will suggest to enter an ISO date, but you can also enter anything
5914which will at least partially be understood by `parse-time-string'. 11960which 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.
5925The function understands only English month and weekday abbreviations, 11972The function understands only English month and weekday abbreviations,
5926but this can be configured with the variables `parse-time-months' and 11973but 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.
6057Also, store the cursor date in variable ans2." 12112Also, 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.
12194But 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.
6141Don't touch the rest." 12221Don'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.
6801This list has one entry for each CLOCK interval. 12883This 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.
13166This undoes changes both in the agenda buffer and in the remote buffer
13167that 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
7069a Agenda for current week or day 13255a Agenda for current week or day
7070t List of all TODO entries T Entries with special TODO kwd 13256t List of all TODO entries T Entries with special TODO kwd
7071m Match a TAGS query M Like m, but only TODO entries 13257m Match a TAGS query M Like m, but only TODO entries
7072L Timeline for current buffer C Configure custom agenda commands") 13258L 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.
7229Optional UNRESTRICTED means return the full list even if a restriction 13432Optional 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.
7241Depending on setup, this either uses customize to edit the variable 13442Depending 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'.
13485If the current buffer visits an agenda file, find the next one in the list.
13486If 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.
13504If the file is not present in the list, it is appended to the list. If it is
13505present, 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.
13511If the file is not present in the list, it is added to the front. If it is
13512present, it is moved there. With optional argument TO-END, add/move to the
13513end 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'.
13533These are the files which are being checked for agenda entries.
13534Optional 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.
13645If this function return nil, the current match should not be skipped.
13646Otherwise, the function must return a position from where the search
13647should be continued.
13648Never set this variable using `setq' or so, because then it will apply
13649to all future agenda commands. Instead, bind it with `let' to scope
13650it dynamically into the agenda-constructing command.")
13651
13652(defun org-agenda-skip ()
13653 "Throw to `:skip' in places that should be skipped.
13654Also moves point to the end of the skipped region, so that search can
13655continue 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
7308it to the list of buffers which might be released later." 13700it 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.
7332Only entries with a time stamp of today or later will be listed. With 13754Only 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.
13833If NO-RANGES is non-nil, include only the start and end dates of a range,
13834not every single day in the range. If FORCE-TODAY is non-nil, make
13835sure that TODAY is included in the list. If INACTIVE is non-nil, also
13836inactive time stamps (those in square brackets) are included.
13837When 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.
7626If 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.
7648Also kill all Org-mode buffers which have been loaded by `org-agenda'.
7649Org-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.
7664When 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.
7697With 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.
7709With 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.
14087The 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) 14152This is basically a temporary global variable that can be set and then
7798 (org-agenda-check-type t 'agenda 'timeline) 14153used 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'.
14160If yes, it returns the end position of this tree, causing agenda commands
14161to 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.
14172Stuck projects are project that have no next actions. For the definitions
14173of what a project is and how to check if it stuck, customize the variable
14174`org-stuck-projects'.
14175MATCH 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'.
7941If the current buffer visits an agenda file, find the next one in the list.
7942If 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.
7959If the file is not present in the list, it is appended to the list. If it is
7960present, 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.
7966If the file is not present in the list, it is added to the front. If it is
7967present, it is moved there. With optional argument TO-END, add/move to the
7968end 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'.
7988These are the files which are being checked for agenda entries.
7989Optional 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.
8012If NO-RANGES is non-nil, include only the start and end dates of a range,
8013not every single day in the range. If FORCE-TODAY is non-nil, make
8014sure that TODAY is included in the list. If INACTIVE is non-nil, also
8015inactive time stamps (those in square brackets) are included.
8016When 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.
8053This function can be used in a \"sexp\" diary entry in the Emacs calendar. 14301This 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
8142which kind of entries should be extracted. For details about these, see 14365which kind of entries should be extracted. For details about these, see
8143the documentation of `org-diary'." 14366the 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.
15073If 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.
15095Also kill all Org-mode buffers which have been loaded by `org-agenda'.
15096Org-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.
15111When 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.
15146With 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.
15158With 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.
8845This priority is composed of the main priority given with the [#A] cookies, 15303This 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)))) 15387The subtree is the one in buffer BUF, starting at BEG and ending at END.
8900 (and conf 15388If 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.
15475This calls the command `org-tree-to-indirect-buffer' from the original
15476Org-mode buffer.
15477With numerical prefix arg ARG, go up to this level and then take that tree.
15478With a C-u prefix, make a separate frame for this tree (i.e. don't use the
15479dedicated 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
8965by a remote command from the agenda.") 15493by 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.
9165The prefix ARG is passed to the `org-time-stamp' command and can therefore 15752The 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.
9377ACTION can be `sparse-tree' or `agenda'. MATCHER is a Lisp form to be
9378evaluated, testing if a given set of tags qualifies a headline for
9379inclusion. When TODO-ONLY is non-nil, only lines with a TODO keyword
9380are 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.
9455MATCH 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.
9532The 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.
9598With 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'.
9709CURRENT is the current list of tags in the headline, INHERITED is the 15996This mode supports entering LaTeX environment and math in LaTeX fragments
9710list of inherited tags, and TABLE is an alist of tags and corresponding keys, 15997in Org-mode.
9711possibly with grouping information. 15998\\{org-cdlatex-mode-map}"
9712If the keys are nil, a-z are automatically assigned. 15999 nil " OCDL" nil
9713Returns 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)) 16005This is because we want to insert math symbols without dollars even outside
9719 (buffer-tags nil) 16006the LaTeX math segments. If Orgmode thinks that point is actually inside
9720 (fwidth (+ maxlen 3 1 3)) 16007en 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.
9893These functions are called in turn with point at the location to
9894which the link should point.
9895
9896A function in the hook should first test if it would like to
9897handle this file type, for example by checking the major-mode or
9898the file extension. If it decides not to handle this file, it
9899should just return nil to give other functions a chance. If it
9900does handle the file, it must return the search string to be used
9901when following the link. The search string will be part of the
9902file link, given after a double colon, and `org-open-at-point'
9903will automatically search for it. If special measures must be
9904taken to make the search successful, another function should be
9905added to the companion hook `org-execute-file-search-functions',
9906which see.
9907
9908A function in this hook may also use `setq' to set the variable
9909`description' to provide a suggestion for the descriptive text to
9910be used for this link when it gets inserted into an Org-mode
9911buffer 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
9916Functions added to this hook must accept a single argument, the
9917search string that was part of the file link, the part after the
9918double colon. The function must first check if it would like to
9919handle this search, for example by checking the major-mode or the
9920file extension. If it decides not to handle this search, it
9921should just return nil to give other functions a chance. If it
9922does handle the search, it must return a non-nil value to keep
9923other functions from trying.
9924
9925Each function can access the current prefix argument through the
9926variable `current-prefix-argument'. Note that a single prefix is
9927used to force opening a link in Emacs, so it may be good to only
9928use a numeric or double prefix to guide the search function.
9929
9930In case this is needed, a function in this hook can also restore
9931the 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.
9949This 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.
9954If there is no link at point, this function will search forward up to
9955the end of the current subtree.
9956Normally, files will be opened by an appropriate application. If the
9957optional 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.
10169When S is a CamelCaseWord, search for a target, or for a sentence containing 16029I.e. after a \\begin, \\(, \\[, $, or $$, without the corresponding closing
10170the words. If S is surrounded by forward slashes, it is interpreted as a 16030sequence appearing also before point.
10171regular expression. In org-mode files, this will create an `org-occur' 16031Even though the matchers for math are configurable, this function assumes
10172sparse tree. In ordinary files, `occur' will be used to list matches. 16032that \\begin, \\(, \\[, and $$ are always used. Only the single dollar
10173If the current buffer is in `dired-mode', grep will be used to search 16033delimiters are skipped when they have been removed by customization.
10174in all files." 16034The return value is nil, or a cons cell with the delimiter and
10175 (let ((case-fold-search t) 16035and 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) 16037This 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." 16038for example currency specifications. For example it will assume being in
16039inline math after \"$22.34\". The LaTeX fragment formatter will only format
16040fragments that are properly closed, but during editing, we have to live
16041with the uncertainty caused by missing closing delimiters. This function
16042looks 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'.
10286If CLEANUP is non-nil, remove the printout of the regular expression
10287in the *Occur* buffer. This is useful if the regex is long and not useful
10288to 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.
10328With prefix arg N, jump back that many stored positions. When
10329called several times in succession, walk through the entire ring.
10330Org-mode commands jumping to a different position in the current file,
10331or to another Org-mode file, automatically push the old position
10332onto 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
10496sequences, 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
10534use 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
10543use 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
10552show buffer for the corresponding message. If you have a more clever
10553idea..."
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.
10572If ARTICLE is nil FOLDER is shown. If the configuration variable
10573`org-mhe-search-all-folders' is t and `mh-searcher' is pick,
10574ARTICLE is searched in all folders. Indexed searches (swish++,
10575namazu, and others supported by MH-E) will always search in all
10576folders."
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.
10655With arg query-description, ask at each match for a description text to use
10656for 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.
10677First, this expands any special file name abbreviations. Then the
10678configuration variable `org-file-apps' is checked if it contains an
10679entry for this file type, and if yes, the corresponding command is launched.
10680If no application is found, Emacs simply visits the file.
10681With optional argument IN-EMACS, Emacs will visit the file.
10682Optional LINE specifies a line to go to, optional SEARCH a string to
10683search for. If LINE or SEARCH is given, the file will always be
10684opened in Emacs.
10685If 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.
10759Return non-nil if the location is indeed remote.
10760
10761For example, the filename \"/user@host:/foo\" specifies a location
10762on 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.
10781This link can later be inserted into an org-buffer with
10782\\[org-insert-link].
10783For some link types, a prefix arg is interpreted:
10784For links to usenet articles, arg negates `org-usenet-links-prefer-google'.
10785For 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
11127Completion 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
11129press RET at the prompt), the link defaults to the most recently
11130stored link. As SPC triggers completion in the minibuffer, you need to
11131use M-SPC or C-q SPC to force the insertion of a space character.
11132
11133You will also be prompted for a description, and if one is given, it will
11134be displayed in the buffer instead of the link.
11135
11136If there is already a link at point, this command will allow you to edit link
11137and description parts.
11138 16070
11139With a \\[universal-argument] prefix, prompts for a file to link to. The file name can be
11140selected using completion. The path to the file will be relative to
11141the current directory if the file is in the current directory or a
11142subdirectory. Otherwise, the link will be the absolute path as
11143completed in the minibuffer (i.e. normally ~/path/to/file).
11144 16071
11145With two \\[universal-argument] prefixes, enforce an absolute path even if the file 16072(defun org-try-cdlatex-tab ()
11146is in the current directory or below. 16073 "Check if it makes sense to execute `cdlatex-tab', and do it if yes.
11147With three \\[universal-argument] prefixes, negate the meaning of 16074It 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.
11252If you are using Org-mode files as target for data storage with
11253remember.el, then the annotations should include a link compatible with the
11254conventions 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.
11259UP/DOWN=headline TAB=cycle visibility [Q]uit RET/<left>/<right>=Store
11260RET at beg-of-buf -> Append to file as level 2 headline
11261RET 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'.
11267This function should be placed into `remember-mode-hook' and in fact requires
11268to 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.
11316First prompts for an org file. If the user just presses return, the value
11317of `org-default-notes-file' is used.
11318Then the command offers the headings tree of the selected file in order to
11319file the text at a specific location.
11320You can either immediately press RET to get the note appended to the
11321file, or you can use vertical cursor motion and visibility cycling (TAB) to
11322find a better place. Then press RET or <left> or <right> in insert the note.
11323
11324Key Cursor position Note gets inserted
11325-----------------------------------------------------------------------------
11326RET buffer-start as level 2 heading at end of file
11327RET on headline as sublevel of the heading at cursor
11328RET 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
11333So the fastest way to store the note is to press RET RET to append it to
11334the default file. This way your current train of thought is not
11335interrupted, in accordance with the principles of remember.el. But with
11336little extra effort, you can push it directly to the correct location.
11337
11338Before being stored away, the function ensures that the text has a
11339headline, i.e. a first line that starts with a \"*\". If not, a headline
11340is constructed from the current date and some additional data.
11341
11342If the variable `org-adapt-indentation' is non-nil, the entire text is
11343also indented so that it starts in the same column as the headline
11344\(i.e. after the stars).
11345
11346See 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
11472outside the table.")
11473(defconst org-table-any-border-regexp "^[ \t]*[^|+ \t]"
11474 "Searching from within a table (any type) this finds the first line
11475outside the table.")
11476
11477(defun org-table-create-with-table.el ()
11478 "Use the table.el package to insert a new table.
11479If there is already a table at point, convert between Org-mode tables
11480and 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.
11494If there is an active region, convert it to a table. If there is no such
11495region, 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.
11503SIZE 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.
11535The region goes from BEG0 to END0, but these borders will be moved
11536slightly, to make sure a beginning of line in the first line is included.
11537When NSPACE is non-nil, it indicates the minimum number of spaces that
11538separate 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.
11570The file is assumed to be tab-separated. Such files can be produced by most
11571spreadsheet and database applications. If no tabs (at least one per line)
11572are 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.
11582Such 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.
11618Used 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.
11621Used 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.
11624This 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.
11627This 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.
11794This ignores character with invisibility property `org-link', and also
11795characters with property `org-cwidth', because these will become invisible
11796upon 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.
11816With 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.
11829With 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.
11841Optional 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.
11880Before 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.
11909Before 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.
11927Before 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.
11950If the field at the cursor is empty, copy into it the content of the nearest
11951non-empty field above. With argument N, use the Nth non-empty field.
11952If the current field is not empty, it is copied down to the next row, and
11953the cursor is moved with it. Therefore, repeating this command causes the
11954column to be filled row-by-row.
11955If the variable `org-table-copy-increment' is non-nil and the field is an
11956integer, 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?
11992I.e. not on a hline or before the first or after the last column?
11993This 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.
12022N defaults to current field.
12023If REPLACE is a string, replace field with this value. The return value
12024is 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.
12039When 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.
12052With optional argument ON-DELIM, stop with point before the left delimiter
12053of the field.
12054If there are less than N fields, just go to after the last delimiter.
12055However, 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.
12075If 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.
12269With prefix ARG, insert below the current line." 16091Revert 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.
12286With prefix ARG, insert above the current line." 16100Revert 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.
12305In 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.
12328Point and mark define the first and last line to include. Both point and
12329mark should be in the column that is used for sorting. For example, to
12330sort according to column 3, put the mark in the first line to sort, in
12331table column 3. Put point into the last line to be included in the sorting,
12332also 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.
12377A special clipboard is used which can only be accessed
12378with `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.
12411The upper right corner ends up in the current field. All involved fields
12412will be overwritten. If the rectangle does not fit into the present table,
12413the table is enlarged as needed. The process ignores horizontal separator
12414lines."
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.
12441Obviously, this only works within limits. When an Org-mode table is
12442converted to table.el, all horizontal separator lines get lost, because
12443table.el uses these as cell boundaries and has no notion of horizontal lines.
12444A table.el table can be converted to an Org-mode table only if it does not
12445do row or column spanning. Multiline cells will become multiple cells.
12446Beware, Org-mode does not test if the table can be successfully converted - it
12447blindly 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.
12486This is useful if you'd like to spread the contents of a field over several
12487lines, in order to keep the table compact.
12488
12489If there is an active region, and both point and mark are in the same column,
12490the text in the column is wrapped to minimum width for the given number of
12491lines. Generally, this makes the table more compact. A prefix ARG may be
12492used to change the number of desired lines. For example, `C-2 \\[org-table-wrap]'
12493formats the selected text to two lines. If the region was longer than two
12494lines, the remaining lines remain empty. A negative prefix argument reduces
12495the current number of lines by that amount. The wrapped text is pasted back
12496into the table. If you formatted it to more lines than it was before, fields
12497further down in the table get overwritten - so you might need to make space in
12498the table first.
12499
12500If there is no region, the current field is split at the cursor position and
12501the text fragment to the right of the cursor is prepended to the field one
12502line down.
12503 16106
12504If there is no region, but you specify a prefix ARG, the current field gets 16107(defvar org-latex-fragment-image-overlays nil
12505blank, 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.
12550This is mainly useful for fields that contain hidden parts. 16118If the cursor is in a LaTeX fragment, create the image and overlay
12551When called with a \\[universal-argument] prefix, just make the full field visible so that 16119it over the source code. If there is no fragment at point, display
12552it can be edited in place." 16120all fragments in the current text, from one headline to the next. With
16121prefix SUBTREE, display all fragments in the current subtree. With a
16122double prefix `C-u C-u', or when the cursor is before the first headline,
16123display all fragments in the buffer.
16124The 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.
12583Remove all newline characters, insert the result into the table, realign
12584the 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.
12612If WIDTH is non-nil, the string is wrapped to that width, however many lines
12613that costs. If there is a word longer than WIDTH, the text is actually
12614wrapped to the length of that word.
12615IF WIDTH is nil and LINES is non-nil, the string is forced into at most that
12616many lines, whatever width that takes.
12617The 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.
12648No empty strings are returned if there are matches at the beginning
12649and 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
12690The result will be displayed in the echo area, and will be available 16141 (if (setq at (org-inside-LaTeX-fragment-p))
12691as kill to be inserted with \\[yank]. 16142 (goto-char (max (point-min) (- (cdr at) 2)))
12692 16143 (org-back-to-heading))
12693If there is an active region, it is interpreted as a rectangle and all 16144 (setq beg (point) end (progn (outline-next-heading) (point))
12694numbers in that rectangle will be summed. If there is no active 16145 msg (if at "Creating image...%s"
12695region and point is located in a table column, sum all numbers in that 16146 "Creating images for entry...%s"))))
12696column. 16147 (message msg "")
12697 16148 (narrow-to-region beg end)
12698If at least one number looks like a time HH:MM or HH:MM:SS, all other 16149 (org-format-latex
12699numbers are assumed to be times as well (in decimal hours) and the 16150 (concat "ltxpng/" (file-name-sans-extension
12700numbers are added as such. 16151 (file-name-nondirectory
12701 16152 buffer-file-name)))
12702If 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.
12770Optional arguments TBEG and COL can give the beginning of the table and
12771the 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.
12912ACTION can be `remove', `insert', `swap'. For `swap', two column numbers are
12913expected, 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 \":=\".
13013If 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.
13027Will 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."
13040If in any row, the first field is not consistent with a mark, 16168 (if (and overlays (fboundp 'clear-image-cache)) (clear-image-cache))
13041insert a new column for the markers. 16169 (let* ((prefixnodir (file-name-nondirectory prefix))
13042When there is an active region, change all the lines in the region, 16170 (absprefix (expand-file-name prefix dir))
13043after prompting for the marking character. 16171 (todir (file-name-directory absprefix))
13044After each change, a message will be displayed indicating the meaning 16172 (opt org-format-latex-options)
13045of 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.
13111When 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
13131This function makes use of Dave Gillespie's Calc package, in my view the
13132most exciting program ever written for GNU Emacs. So you need to have Calc
13133installed in order to use this function.
13134
13135In a table, this command replaces the value in the current field with the
13136result of a formula. It also installs the formula as the \"current\" column
13137formula, by storing it in a special line below the table. When called
13138with a `C-u' prefix, the current field must ba a named field, and the
13139formula is installed as valid in only this specific field.
13140
13141When called, the command first prompts for a formula, which is read in
13142the minibuffer. Previously entered formulas are available through the
13143history list, and the last used formula is offered as a default.
13144These stored formulas are adapted correctly when moving, inserting, or
13145deleting columns with the corresponding commands.
13146
13147The formula can be any algebraic expression understood by the Calc package.
13148For details, see the Org-mode manual.
13149
13150This function can also be called from Lisp programs and offers
13151additional arguments: EQUATION can be the formula to apply. If this
13152argument is given, the user will not be prompted. SUPPRESS-ALIGN is
13153used to speed-up recursive calls by by-passing unnecessary aligns.
13154SUPPRESS-CONST suppresses the interpretation of constants in the
13155formula, assuming that this has been done already outside the function.
13156SUPPRESS-STORE means the formula should not be stored, either because
13157it is already stored, or because it is a modified equation that should
13158not 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
13239Orig: %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.
13268With 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.
13372Parameters 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
13480With 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'
13537table 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.
13604FUN is the command to call inside a table. N is used to create a unique
13605command name. KEYS are keys that should be checked in for a command
13606to 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.
13755If the cursor is in a table looking at whitespace, the whitespace is
13756overwritten, 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.
13876The process starts by copying the last list, and then setting properties
13877from the other lists. Settings in the first list are the most significant
13878ones 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.
14272It is supplemented by a number of commonly used TeX macros with appropriate 16745It is supplemented by a number of commonly used TeX macros with appropriate
14273translations. There is currently no way for users to extend this.") 16746translations. 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))
14382This will leave level 1 alone, convert level 2 to level 3, level 3 to
14383level 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.
14398This promotes level 3 to level 2, level 5 to level 3 etc. If the file contains a 16913When LEVEL is non-nil, increase section numbers on that level."
14399section 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 ""))
14400is 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.
17972If 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.
15703When 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.
15743The 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.
15882A good way to use this is to tell a desktop calenndar application to re-read 18336A good way to use this is to tell a desktop calenndar application to re-read
15883the iCalendar file.") 18337the 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'.
15887When COMBINE is non nil, add the category to each line." 18341When 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
15922SUMMARY:%s 18381SUMMARY:%s
18382CATEGORIES:%s
15923END:VEVENT\n" 18383END: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
15943SUMMARY:%s 18407SUMMARY:%s
18408CATEGORIES:%s
15944SEQUENCE:1 18409SEQUENCE:1
15945PRIORITY:%d 18410PRIORITY:%d
18411STATUS:%s
15946END:VTODO\n" 18412END: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'.
16000This mode supports entering LaTeX environment and math in LaTeX fragments
16001in 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.
16009This is because we want to insert math symbols without dollars even outside
16010the LaTeX math segments. If Orgmode thinks that point is actually inside
16011en 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.
16033I.e. after a \\begin, \\(, \\[, $, or $$, without the corresponding closing
16034sequence appearing also before point.
16035Even though the matchers for math are configurable, this function assumes
16036that \\begin, \\(, \\[, and $$ are always used. Only the single dollar
16037delimiters are skipped when they have been removed by customization.
16038The return value is nil, or a cons cell with the delimiter and
16039and the position of this delimiter.
16040
16041This function does a reasonably good job, but can locally be fooled by
16042for example currency specifications. For example it will assume being in
16043inline math after \"$22.34\". The LaTeX fragment formatter will only format
16044fragments that are properly closed, but during editing, we have to live
16045with the uncertainty caused by missing closing delimiters. This function
16046looks 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.
16078It makes sense to do so if `org-cdlatex-mode' is active and if the cursor is 18459The 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)
16095Revert 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
16104Revert 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.
16122If the cursor is in a LaTeX fragment, create the image and overlay
16123it over the source code. If there is no fragment at point, display
16124all fragments in the current text, from one headline to the next. With
16125prefix SUBTREE, display all fragments in the current subtree. With a
16126double prefix `C-u C-u', or when the cursor is before the first headline,
16127display all fragments in the buffer.
16128The 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.
17002With optional NODE, go directly to that node." 19294With 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.
19447Normally only the current line is checked, but you can include NLINES extra
19448lines both before and after point into the search.
19449If VISUALLY is set, require that the cursor is not after the match but
19450really 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.
17152If CONTEXT is non-nil, return a list with CONTEXT and the boundaries of the 19464If 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.
19476The process starts by copying the first list, and then setting properties
19477from the other lists. Settings in the last list are the most significant
19478ones 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.
19516TABLE is an association list with keys line \"%a\" and string values.
19517The sequences in STRING may contain normal field width and padding information,
19518for example \"%-5s\". Replacements happen in the sequence given by TABLE,
19519so 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.
19533Counting 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
19555not 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.
17237In particular, this makes sure hanging paragraphs for hand-formatted lists 19609In particular, this makes sure hanging paragraphs for hand-formatted lists
17238work correctly." 19610work 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?
17252Works 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'.
17261See documentation for `buffer-invisibility-spec' for the kind of elements
17262that 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