-;;;; org.el --- Outline-based notes management and organize
+;;; org.el --- Outline-based notes management and organizer
;; Carstens outline-mode for keeping track of everything.
;; Copyright (C) 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
;;
-;; Author: Carsten Dominik <dominik at science dot uva dot nl>
+;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
-;; Homepage: http://www.astro.uva.nl/~dominik/Tools/org/
-;; Version: 4.67d
+;; Homepage: http://orgmode.org
+;; Version: 5.23a
;;
;; This file is part of GNU Emacs.
;;
;; ---------------------------
;; See the corresponding sections in the manual at
;;
-;; http://staff.science.uva.nl/~dominik/Tools/org/org.html#Installation
+;; http://orgmode.org/org.html#Installation
;;
;; Documentation
;; -------------
;; in the etc/ directory of Emacs 22.
;;
;; A list of recent changes can be found at
-;; http://www.astro.uva.nl/~dominik/Tools/org/Changes
+;; http://orgmode.org/Changes.html
;;
;;; Code:
(require 'outline) (require 'noutline)
;; Other stuff we need.
(require 'time-date)
+(unless (fboundp 'time-subtract) (defalias 'time-subtract 'subtract-time))
(require 'easymenu)
;;;; Customization variables
;;; Version
-(defvar org-version "4.67c"
+(defconst org-version "5.23a"
"The version number of the file org.el.")
-(defun org-version ()
- (interactive)
- (message "Org-mode version %s" org-version))
+
+(defun org-version (&optional here)
+ "Show the org-mode version in the echo area.
+With prefix arg HERE, insert it at point."
+ (interactive "P")
+ (let ((version (format "Org-mode version %s" org-version)))
+ (message version)
+ (if here
+ (insert version))))
;;; Compatibility constants
(defconst org-xemacs-p (featurep 'xemacs)) ; not used by org.el itself
(get-text-property 0 'test (format "%s" x)))
"Does format transport text properties?")
+(defmacro org-bound-and-true-p (var)
+ "Return the value of symbol VAR if it is bound, else nil."
+ `(and (boundp (quote ,var)) ,var))
+
+(defmacro org-unmodified (&rest body)
+ "Execute body without changing `buffer-modified-p'."
+ `(set-buffer-modified-p
+ (prog1 (buffer-modified-p) ,@body)))
+
+(defmacro org-re (s)
+ "Replace posix classes in regular expression."
+ (if (featurep 'xemacs)
+ (let ((ss s))
+ (save-match-data
+ (while (string-match "\\[:alnum:\\]" ss)
+ (setq ss (replace-match "a-zA-Z0-9" t t ss)))
+ (while (string-match "\\[:alpha:\\]" ss)
+ (setq ss (replace-match "a-zA-Z" t t ss)))
+ ss))
+ s))
+
+(defmacro org-preserve-lc (&rest body)
+ `(let ((_line (org-current-line))
+ (_col (current-column)))
+ (unwind-protect
+ (progn ,@body)
+ (goto-line _line)
+ (move-to-column _col))))
+
+(defmacro org-without-partial-completion (&rest body)
+ `(let ((pc-mode (and (boundp 'partial-completion-mode)
+ partial-completion-mode)))
+ (unwind-protect
+ (progn
+ (if pc-mode (partial-completion-mode -1))
+ ,@body)
+ (if pc-mode (partial-completion-mode 1)))))
+
;;; The custom variables
(defgroup org nil
:group 'hypermedia
:group 'calendar)
+(defcustom org-load-hook nil
+ "Hook that is run after org.el has been loaded."
+ :group 'org
+ :type 'hook)
+
+;(defcustom org-default-extensions '(org-irc)
+; "Extensions that should always be loaded together with org.el.
+;If the description starts with <A>, this means the extension
+;will be autoloaded when needed, preloading is not necessary.
+;FIXME: this does not ork correctly, ignore it for now."
+; :group 'org
+; :type
+; '(set :greedy t
+; (const :tag " Mouse support (org-mouse.el)" org-mouse)
+; (const :tag "<A> Publishing (org-publish.el)" org-publish)
+; (const :tag "<A> LaTeX export (org-export-latex.el)" org-export-latex)
+; (const :tag " IRC/ERC links (org-irc.el)" org-irc)
+; (const :tag " Apple Mail message links under OS X (org-mac-message.el)" org-mac-message)))
+;
+;(defun org-load-default-extensions ()
+; "Load all extensions listed in `org-default-extensions'."
+; (mapc (lambda (ext)
+; (condition-case nil (require ext)
+; (error (message "Problems while trying to load feature `%s'" ext))))
+; org-default-extensions))
+
+;(eval-after-load "org" '(org-load-default-extensions))
+
+;; FIXME: Needs a separate group...
+(defcustom org-completion-fallback-command 'hippie-expand
+ "The expansion command called by \\[org-complete] in normal context.
+Normal means, no org-mode-specific context."
+ :group 'org
+ :type 'function)
+
(defgroup org-startup nil
"Options concerning startup of Org-mode."
:tag "Org Startup"
:group 'org-startup
:type 'boolean)
-(defcustom org-CUA-compatible nil
- "Non-nil means use alternative key bindings for S-<cursor movement>.
-Org-mode used S-<cursor movement> for changing timestamps and priorities.
-S-<cursor movement> is also used for example by `CUA-mode' to select text.
-If you want to use Org-mode together with `CUA-mode', Org-mode needs to use
-alternative bindings. Setting this variable to t will replace the following
-keys both in Org-mode and in the Org-agenda buffer.
-
-S-RET -> C-S-RET
-S-up -> M-p
-S-down -> M-n
-S-left -> M--
-S-right -> M-+
-
-If you do not like the alternative keys, take a look at the variable
+(defcustom org-replace-disputed-keys nil
+ "Non-nil means use alternative key bindings for some keys.
+Org-mode uses S-<cursor> keys for changing timestamps and priorities.
+These keys are also used by other packages like `CUA-mode' or `windmove.el'.
+If you want to use Org-mode together with one of these other modes,
+or more generally if you would like to move some Org-mode commands to
+other keys, set this variable and configure the keys with the variable
`org-disputed-keys'.
This option is only relevant at load-time of Org-mode, and must be set
:group 'org-startup
:type 'boolean)
-(defvar org-disputed-keys
- '((S-up [(shift up)] [(meta ?p)])
- (S-down [(shift down)] [(meta ?n)])
- (S-left [(shift left)] [(meta ?-)])
- (S-right [(shift right)] [(meta ?+)])
- (S-return [(shift return)] [(control shift return)]))
+(if (fboundp 'defvaralias)
+ (defvaralias 'org-CUA-compatible 'org-replace-disputed-keys))
+
+(defcustom org-disputed-keys
+ '(([(shift up)] . [(meta p)])
+ ([(shift down)] . [(meta n)])
+ ([(shift left)] . [(meta -)])
+ ([(shift right)] . [(meta +)])
+ ([(control shift right)] . [(meta shift +)])
+ ([(control shift left)] . [(meta shift -)]))
"Keys for which Org-mode and other modes compete.
-This is an alist, cars are symbols for lookup, 1st element is the default key,
-second element will be used when `org-CUA-compatible' is t.")
+This is an alist, cars are the default keys, second element specifies
+the alternative to use when `org-replace-disputed-keys' is t.
+
+Keys can be specified in any syntax supported by `define-key'.
+The value of this option takes effect only at Org-mode's startup,
+therefore you'll have to restart Emacs to apply it after changing."
+ :group 'org-startup
+ :type 'alist)
(defun org-key (key)
- "Select a key according to `org-CUA-compatible'."
- (nth (if org-CUA-compatible 2 1)
- (or (assq key org-disputed-keys)
- (error "Invalid Key %s in `org-key'" key))))
+ "Select key according to `org-replace-disputed-keys' and `org-disputed-keys'.
+Or return the original if not disputed."
+ (if org-replace-disputed-keys
+ (let* ((nkey (key-description key))
+ (x (org-find-if (lambda (x)
+ (equal (key-description (car x)) nkey))
+ org-disputed-keys)))
+ (if x (cdr x) key))
+ key))
+
+(defun org-find-if (predicate seq)
+ (catch 'exit
+ (while seq
+ (if (funcall predicate (car seq))
+ (throw 'exit (car seq))
+ (pop seq)))))
+
+(defun org-defkey (keymap key def)
+ "Define a key, possibly translated, as returned by `org-key'."
+ (define-key keymap (org-key key) def))
(defcustom org-ellipsis nil
"The ellipsis to use in the Org-mode outline.
When nil, just use the standard three dots. When a string, use that instead,
-and just in Org-mode (which will then use its own display table).
+When a face, use the standart 3 dots, but with the specified face.
+The change affects only Org-mode (which will then use its own display table).
Changing this requires executing `M-x org-mode' in a buffer to become
effective."
:group 'org-startup
:type '(choice (const :tag "Default" nil)
+ (face :tag "Face" :value org-warning)
(string :tag "String" :value "...#")))
(defvar org-display-table nil
:group 'org-keywords
:type 'string)
-(defvar org-repeat-re "\\<REPEAT(\\([-+ 0-9dwmy]+\\))"
+(defconst org-repeat-re
+ "<[0-9]\\{4\\}-[0-9][0-9]-[0-9][0-9] [^>\n]*\\([.+]?\\+[0-9]+[dwmy]\\)"
"Regular expression for specifying repeated events.
After a match, group 1 contains the repeat expression.")
:tag "Org Reveal Location"
:group 'org-structure)
+(defconst org-context-choice
+ '(choice
+ (const :tag "Always" t)
+ (const :tag "Never" nil)
+ (repeat :greedy t :tag "Individual contexts"
+ (cons
+ (choice :tag "Context"
+ (const agenda)
+ (const org-goto)
+ (const occur-tree)
+ (const tags-tree)
+ (const link-search)
+ (const mark-goto)
+ (const bookmark-jump)
+ (const isearch)
+ (const default))
+ (boolean))))
+ "Contexts for the reveal options.")
+
(defcustom org-show-hierarchy-above '((default . t))
"Non-nil means, show full hierarchy when revealing a location.
Org-mode often shows locations in an org-mode file which might have
isearch when exiting from an incremental search
default default for all contexts not set explicitly"
:group 'org-reveal-location
- :type '(choice
- (const :tag "Always" t)
- (const :tag "Never" nil)
- (repeat :greedy t :tag "Individual contexts"
- (cons
- (choice :tag "Context"
- (const agenda)
- (const org-goto)
- (const occur-tree)
- (const tags-tree)
- (const link-search)
- (const mark-goto)
- (const bookmark-jump)
- (const isearch)
- (const default))
- (boolean)))))
+ :type org-context-choice)
-(defcustom org-show-following-heading '((default . t))
+(defcustom org-show-following-heading '((default . nil))
"Non-nil means, show following heading when revealing a location.
Org-mode often shows locations in an org-mode file which might have
been invisible before. When this is set, the heading following the
Instead of t, this can also be an alist specifying this option for different
contexts. See `org-show-hierarchy-above' for valid contexts."
:group 'org-reveal-location
- :type '(choice
- (const :tag "Always" t)
- (const :tag "Never" nil)
- (repeat :greedy t :tag "Individual contexts"
- (cons
- (choice :tag "Context"
- (const agenda)
- (const org-goto)
- (const occur-tree)
- (const tags-tree)
- (const link-search)
- (const mark-goto)
- (const bookmark-jump)
- (const isearch)
- (const default))
- (boolean)))))
+ :type org-context-choice)
(defcustom org-show-siblings '((default . nil) (isearch t))
"Non-nil means, show all sibling heading when revealing a location.
Instead of t, this can also be an alist specifying this option for different
contexts. See `org-show-hierarchy-above' for valid contexts."
:group 'org-reveal-location
- :type '(choice
- (const :tag "Always" t)
- (const :tag "Never" nil)
- (repeat :greedy t :tag "Individual contexts"
- (cons
- (choice :tag "Context"
- (const agenda)
- (const org-goto)
- (const occur-tree)
- (const tags-tree)
- (const link-search)
- (const mark-goto)
- (const bookmark-jump)
- (const isearch)
- (const default))
- (boolean)))))
+ :type org-context-choice)
+
+(defcustom org-show-entry-below '((default . nil))
+ "Non-nil means, show the entry below a headline when revealing a location.
+Org-mode often shows locations in an org-mode file which might have
+been invisible before. When this is set, the text below the headline that is
+exposed is also shown.
+
+By default this is off for all contexts.
+Instead of t, this can also be an alist specifying this option for different
+contexts. See `org-show-hierarchy-above' for valid contexts."
+ :group 'org-reveal-location
+ :type org-context-choice)
(defgroup org-cycle nil
"Options concerning visibility cycling in Org-mode."
:tag "Org Cycle"
:group 'org-structure)
-(defcustom org-cycle-global-at-bob t
+(defcustom org-drawers '("PROPERTIES" "CLOCK")
+ "Names of drawers. Drawers are not opened by cycling on the headline above.
+Drawers only open with a TAB on the drawer line itself. A drawer looks like
+this:
+ :DRAWERNAME:
+ .....
+ :END:
+The drawer \"PROPERTIES\" is special for capturing properties through
+the property API.
+
+Drawers can be defined on the per-file basis with a line like:
+
+#+DRAWERS: HIDDEN STATE PROPERTIES"
+ :group 'org-structure
+ :type '(repeat (string :tag "Drawer Name")))
+
+(defcustom org-cycle-global-at-bob nil
"Cycle globally if cursor is at beginning of buffer and not at a headline.
This makes it possible to do global cycling without having to use S-TAB or
C-u TAB. For this special case to work, the first line of the buffer
"Where should `org-cycle' emulate TAB.
nil Never
white Only in completely white lines
-whitestart Only at the beginning of lines, before the first non-white char.
+whitestart Only at the beginning of lines, before the first non-white char
t Everywhere except in headlines
+exc-hl-bol Everywhere except at the start of a headline
If TAB is used in a place where it does not emulate TAB, the current subtree
visibility is cycled."
:group 'org-cycle
(const :tag "Only in completely white lines" white)
(const :tag "Before first char in a line" whitestart)
(const :tag "Everywhere except in headlines" t)
+ (const :tag "Everywhere except at bol in headlines" exc-hl-bol)
))
+(defcustom org-cycle-separator-lines 2
+ "Number of empty lines needed to keep an empty line between collapsed trees.
+If you leave an empty line between the end of a subtree and the following
+headline, this empty line is hidden when the subtree is folded.
+Org-mode will leave (exactly) one empty line visible if the number of
+empty lines is equal or larger to the number given in this variable.
+So the default 2 means, at least 2 empty lines after the end of a subtree
+are needed to produce free space between a collapsed subtree and the
+following headline.
+
+Special case: when 0, never leave empty lines in collapsed view."
+ :group 'org-cycle
+ :type 'integer)
+
(defcustom org-cycle-hook '(org-cycle-hide-archived-subtrees
+ org-cycle-hide-drawers
+ org-cycle-show-empty-lines
org-optimize-window-after-visibility-change)
"Hook that is run after `org-cycle' has changed the buffer visibility.
The function(s) in this hook must accept a single argument which indicates
:group 'org-cycle
:type 'hook)
-
(defgroup org-edit-structure nil
"Options concerning structure editing in Org-mode."
:tag "Org Edit Structure"
:group 'org-edit-structure
:type 'boolean)
+(defcustom org-special-ctrl-a/e nil
+ "Non-nil means `C-a' and `C-e' behave specially in headlines and items.
+When t, `C-a' will bring back the cursor to the beginning of the
+headline text, i.e. after the stars and after a possible TODO keyword.
+In an item, this will be the position after the bullet.
+When the cursor is already at that position, another `C-a' will bring
+it to the beginning of the line.
+`C-e' will jump to the end of the headline, ignoring the presence of tags
+in the headline. A second `C-e' will then jump to the true end of the
+line, after any tags.
+When set to the symbol `reversed', the first `C-a' or `C-e' works normally,
+and only a directly following, identical keypress will bring the cursor
+to the special positions."
+ :group 'org-edit-structure
+ :type '(choice
+ (const :tag "off" nil)
+ (const :tag "after bullet first" t)
+ (const :tag "border first" reversed)))
+
+(if (fboundp 'defvaralias)
+ (defvaralias 'org-special-ctrl-a 'org-special-ctrl-a/e))
+
+(defcustom org-special-ctrl-k nil
+ "Non-nil means `C-k' will behave specially in headlines.
+When nil, `C-k' will call the default `kill-line' command.
+When t, the following will happen while the cursor is in the headline:
+
+- When the cursor is at the beginning of a headline, kill the entire
+ line and possible the folded subtree below the line.
+- When in the middle of the headline text, kill the headline up to the tags.
+- When after the headline text, kill the tags."
+ :group 'org-edit-structure
+ :type 'boolean)
+
+(defcustom org-M-RET-may-split-line '((default . t))
+ "Non-nil means, M-RET will split the line at the cursor position.
+When nil, it will go to the end of the line before making a
+new line.
+You may also set this option in a different way for different
+contexts. Valid contexts are:
+
+headline when creating a new headline
+item when creating a new item
+table in a table field
+default the value to be used for all contexts not explicitly
+ customized"
+ :group 'org-structure
+ :group 'org-table
+ :type '(choice
+ (const :tag "Always" t)
+ (const :tag "Never" nil)
+ (repeat :greedy t :tag "Individual contexts"
+ (cons
+ (choice :tag "Context"
+ (const headline)
+ (const item)
+ (const table)
+ (const default))
+ (boolean)))))
+
+
(defcustom org-blank-before-new-entry '((heading . nil)
(plain-list-item . nil))
"Should `org-insert-heading' leave a blank line before new heading/item?
(defcustom org-insert-heading-hook nil
"Hook being run after inserting a new heading."
:group 'org-edit-structure
- :type 'boolean)
+ :type 'hook)
(defcustom org-enable-fixed-width-editor t
"Non-nil means, lines starting with \":\" are treated as fixed-width.
:group 'org-edit-structure
:type 'boolean)
+(defcustom org-goto-auto-isearch t
+ "Non-nil means, typing characters in org-goto starts incremental search."
+ :group 'org-edit-structure
+ :type 'boolean)
+
(defgroup org-sparse-trees nil
"Options concerning sparse trees in Org-mode."
:tag "Org Sparse Trees"
(defcustom org-archive-tag "ARCHIVE"
"The tag that marks a subtree as archived.
An archived subtree does not open during visibility cycling, and does
-not contribute to the agenda listings."
+not contribute to the agenda listings.
+After changing this, font-lock must be restarted in the relevant buffers to
+get the proper fontification."
:group 'org-archive
:group 'org-keywords
:type 'string)
:type 'string)
(defcustom org-archive-mark-done t
- "Non-nil means, mark entries as DONE when they are moved to the archive file."
+ "Non-nil means, mark entries as DONE when they are moved to the archive file.
+This can be a string to set the keyword to use. When t, Org-mode will
+use the first keyword in its list that means done."
:group 'org-archive
- :type 'boolean)
+ :type '(choice
+ (const :tag "No" nil)
+ (const :tag "Yes" t)
+ (string :tag "Use this keyword")))
(defcustom org-archive-stamp-time t
"Non-nil means, add a time stamp to entries moved to an archive file.
-The time stamp will be added directly after the TODO state keyword in the
-first line, so it is probably best to use this in combinations with
-`org-archive-mark-done'."
+This variable is obsolete and has no effect anymore, instead add ot remove
+`time' from the variablle `org-archive-save-context-info'."
:group 'org-archive
:type 'boolean)
+(defcustom org-archive-save-context-info '(time file olpath category todo itags)
+ "Parts of context info that should be stored as properties when archiving.
+When a subtree is moved to an archive file, it looses information given by
+context, like inherited tags, the category, and possibly also the TODO
+state (depending on the variable `org-archive-mark-done').
+This variable can be a list of any of the following symbols:
+
+time The time of archiving.
+file The file where the entry originates.
+itags The local tags, in the headline of the subtree.
+ltags The tags the subtree inherits from further up the hierarchy.
+todo The pre-archive TODO state.
+category The category, taken from file name or #+CATEGORY lines.
+olpath The outline path to the item. These are all headlines above
+ the current item, separated by /, like a file path.
+
+For each symbol present in the list, a property will be created in
+the archived entry, with a prefix \"PRE_ARCHIVE_\", to remember this
+information."
+ :group 'org-archive
+ :type '(set :greedy t
+ (const :tag "Time" time)
+ (const :tag "File" file)
+ (const :tag "Category" category)
+ (const :tag "TODO state" todo)
+ (const :tag "TODO state" priority)
+ (const :tag "Inherited tags" itags)
+ (const :tag "Outline path" olpath)
+ (const :tag "Local tags" ltags)))
+
+(defgroup org-imenu-and-speedbar nil
+ "Options concerning imenu and speedbar in Org-mode."
+ :tag "Org Imenu and Speedbar"
+ :group 'org-structure)
+
+(defcustom org-imenu-depth 2
+ "The maximum level for Imenu access to Org-mode headlines.
+This also applied for speedbar access."
+ :group 'org-imenu-and-speedbar
+ :type 'number)
+
(defgroup org-table nil
"Options concerning tables in Org-mode."
:tag "Org Table"
:type 'string)
(defcustom org-table-number-regexp
- "^\\([<>]?[-+^.0-9]*[0-9][-+^.0-9eEdDx()%:]*\\|\\(0[xX]\\)[0-9a-fA-F]+\\)$"
+ "^\\([<>]?[-+^.0-9]*[0-9][-+^.0-9eEdDx()%:]*\\|\\(0[xX]\\)[0-9a-fA-F]+\\|nan\\)$"
"Regular expression for recognizing numbers in table columns.
If a table column contains mostly numbers, it will be aligned to the
right. If not, it will be aligned to the left.
(const :tag "Exponential, Floating point, Integer"
"^[-+]?[0-9.]+\\([eEdD][-+0-9]+\\)?$")
(const :tag "Very General Number-Like, including hex"
- "^\\([<>]?[-+^.0-9]*[0-9][-+^.0-9eEdDx()%]*\\|\\(0[xX]\\)[0-9a-fA-F]+\\)$")
+ "^\\([<>]?[-+^.0-9]*[0-9][-+^.0-9eEdDx()%]*\\|\\(0[xX]\\)[0-9a-fA-F]+\\|nan\\)$")
(string :tag "Regexp:")))
(defcustom org-table-number-fraction 0.5
:type 'number)
(defgroup org-table-editing nil
- "Bahavior of tables during editing in Org-mode."
+ "Behavior of tables during editing in Org-mode."
:tag "Org Table Editing"
:group 'org-table)
:tag "Org Table Calculation"
:group 'org-table)
+(defcustom org-table-use-standard-references t
+ "Should org-mode work with table refrences like B3 instead of @3$2?
+Possible values are:
+nil never use them
+from accept as input, do not present for editing
+t: accept as input and present for editing"
+ :group 'org-table-calculation
+ :type '(choice
+ (const :tag "Never, don't even check unser input for them" nil)
+ (const :tag "Always, both as user input, and when editing" t)
+ (const :tag "Convert user input, don't offer during editing" 'from)))
+
(defcustom org-table-copy-increment t
"Non-nil means, increment when copying current field with \\[org-table-copy-down]."
:group 'org-table-calculation
:group 'org-table-calculation
:type 'boolean)
-;; FIXME this is also a variable that makes Org-mode files non-portable
-;; Maybe I should have a #+ options for constants?
-;; How about the SI/cgs issue?
(defcustom org-table-formula-use-constants t
"Non-nil means, interpret constants in formulas in tables.
A constant looks like `$c' or `$Grav' and will be replaced before evaluation
(setq org-table-formula-constants '((\"c\" . \"299792458.\")))
-and then use it in an equation like `$1*$c'."
+and then use it in an equation like `$1*$c'.
+
+Constants can also be defined on a per-file basis using a line like
+
+#+CONSTANTS: c=299792458. pi=3.14 eps=2.4e-6"
:group 'org-table-calculation
:type '(repeat
(cons (string :tag "name")
(string :tag "value"))))
+(defvar org-table-formula-constants-local nil
+ "Local version of `org-table-formula-constants'.")
+(make-variable-buffer-local 'org-table-formula-constants-local)
+
(defcustom org-table-allow-automatic-line-recalculation t
"Non-nil means, lines marked with |#| or |*| will be recomputed automatically.
Automatically means, when TAB or RET or C-c C-c are pressed in the line."
:group 'org)
(defvar org-link-abbrev-alist-local nil
- "buffer-local version of `org-link-abbrev-alist', which see.
+ "Buffer-local version of `org-link-abbrev-alist', which see.
The value of this is taken from the #+LINK lines.")
(make-variable-buffer-local 'org-link-abbrev-alist-local)
[[linkkey:tag][description]]
If REPLACE is a string, the tag will simply be appended to create the link.
-If the string contains \"%s\", the tag will be inserted there. REPLACE may
-also be a function that will be called with the tag as the only argument to
-create the link. See the manual for examples."
+If the string contains \"%s\", the tag will be inserted there.
+
+REPLACE may also be a function that will be called with the tag as the
+only argument to create the link, which should be returned as a string.
+
+See the manual for examples."
:group 'org-link
:type 'alist)
(defcustom org-descriptive-links t
"Non-nil means, hide link part and only show description of bracket links.
-Bracket links are like [[link][descritpion]]. This variable sets the initial
+Bracket links are like [[link][descritpion]]. This variable sets the initial
state in new org-mode buffers. The setting can then be toggled on a
per-buffer basis from the Org->Hyperlinks menu."
:group 'org-link
"How the path name in file links should be stored.
Valid values are:
-relative relative to the current directory, i.e. the directory of the file
+relative Relative to the current directory, i.e. the directory of the file
into which the link is being inserted.
-absolute absolute path, if possible with ~ for home directory.
-noabbrev absolute path, no abbreviation of home directory.
+absolute Absolute path, if possible with ~ for home directory.
+noabbrev Absolute path, no abbreviation of home directory.
adaptive Use relative path for files in the current directory and sub-
directories of it. For other files, use an absolute path."
:group 'org-link
:group 'org-link
:type '(set (const :tag "Double bracket links (new style)" bracket)
(const :tag "Angular bracket links (old style)" angular)
- (const :tag "plain text links" plain)
+ (const :tag "Plain text links" plain)
(const :tag "Radio target matches" radio)
(const :tag "Tags" tag)
(const :tag "Timestamps" date)))
(defgroup org-link-store nil
- "Options concerning storing links in Org-mode"
+ "Options concerning storing links in Org-mode."
:tag "Org Store Link"
:group 'org-link)
:type 'boolean)
(defgroup org-link-follow nil
- "Options concerning following links in Org-mode"
+ "Options concerning following links in Org-mode."
:tag "Org Follow Link"
:group 'org-link)
+(defcustom org-follow-link-hook nil
+ "Hook that is run after a link has been followed."
+ :group 'org-link-follow
+ :type 'hook)
+
(defcustom org-tab-follows-link nil
"Non-nil means, on links TAB will follow the link.
Needs to be set before org.el is loaded."
:group 'org-link-follow
:type 'boolean)
-(defcustom org-mouse-1-follows-link t
+(defcustom org-mouse-1-follows-link
+ (if (boundp 'mouse-1-click-follows-link) mouse-1-click-follows-link t)
"Non-nil means, mouse-1 on a link will follow the link.
-A longer mouse click will still set point. Does not wortk on XEmacs.
+A longer mouse click will still set point. Does not work on XEmacs.
Needs to be set before org.el is loaded."
:group 'org-link-follow
:type 'boolean)
(defcustom org-confirm-shell-link-function 'yes-or-no-p
"Non-nil means, ask for confirmation before executing shell links.
-Shell links can be dangerous, just thing about a link
+Shell links can be dangerous: just think about a link
[[shell:rm -rf ~/*][Google Search]]
-This link would show up in your Org-mode document as \"Google Search\"
+This link would show up in your Org-mode document as \"Google Search\",
but really it would remove your entire home directory.
-Therefore I *definitely* advise against setting this variable to nil.
-Just change it to `y-or-n-p' of you want to confirm with a single key press
-rather than having to type \"yes\"."
+Therefore we advise against setting this variable to nil.
+Just change it to `y-or-n-p' of you want to confirm with a
+single keystroke rather than having to type \"yes\"."
:group 'org-link-follow
:type '(choice
(const :tag "with yes-or-no (safer)" yes-or-no-p)
(const :tag "no confirmation (dangerous)" nil)))
(defcustom org-confirm-elisp-link-function 'yes-or-no-p
- "Non-nil means, ask for confirmation before executing elisp links.
-Elisp links can be dangerous, just think about a link
+ "Non-nil means, ask for confirmation before executing Emacs Lisp links.
+Elisp links can be dangerous: just think about a link
[[elisp:(shell-command \"rm -rf ~/*\")][Google Search]]
-This link would show up in your Org-mode document as \"Google Search\"
+This link would show up in your Org-mode document as \"Google Search\",
but really it would remove your entire home directory.
-Therefore I *definitely* advise against setting this variable to nil.
-Just change it to `y-or-n-p' of you want to confirm with a single key press
-rather than having to type \"yes\"."
+Therefore we advise against setting this variable to nil.
+Just change it to `y-or-n-p' of you want to confirm with a
+single keystroke rather than having to type \"yes\"."
:group 'org-link-follow
:type '(choice
(const :tag "with yes-or-no (safer)" yes-or-no-p)
(const :tag "Default from remember-data-file" nil)
file))
+(defcustom org-remember-store-without-prompt t
+ "Non-nil means, `C-c C-c' stores remember note without further promts.
+In this case, you need `C-u C-c C-c' to get the prompts for
+note file and headline.
+When this variable is nil, `C-c C-c' give you the prompts, and
+`C-u C-c C-c' trigger the fasttrack."
+ :group 'org-remember
+ :type 'boolean)
+
+(defcustom org-remember-interactive-interface 'refile
+ "The interface to be used for interactive filing of remember notes.
+This is only used when the interactive mode for selecting a filing
+location is used (see the variable `org-remember-store-without-prompt').
+Allowed vaues are:
+outline The interface shows an outline of the relevant file
+ and the correct heading is found by moving through
+ the outline or by searching with incremental search.
+outline-path-completion Headlines in the current buffer are offered via
+ completion.
+refile Use the refile interface, and offer headlines,
+ possibly from different buffers."
+ :group 'org-remember
+ :type '(choice
+ (const :tag "Refile" refile)
+ (const :tag "Outline" outline)
+ (const :tag "Outline-path-completion" outline-path-completion)))
+
+(defcustom org-goto-interface 'outline
+ "The default interface to be used for `org-goto'.
+Allowed vaues are:
+outline The interface shows an outline of the relevant file
+ and the correct heading is found by moving through
+ the outline or by searching with incremental search.
+outline-path-completion Headlines in the current buffer are offered via
+ completion."
+ :group 'org-remember ; FIXME: different group for org-goto and org-refile
+ :type '(choice
+ (const :tag "Outline" outline)
+ (const :tag "Outline-path-completion" outline-path-completion)))
+
(defcustom org-remember-default-headline ""
"The headline that should be the default location in the notes file.
When filing remember notes, the cursor will start at that position.
(defcustom org-remember-templates nil
"Templates for the creation of remember buffers.
When nil, just let remember make the buffer.
-When not nil, this is a list of 4-element lists. In each entry, the first
-element is a character, a unique key to select this template.
-The second element is the template. The third element is optional and can
+When not nil, this is a list of 5-element lists. In each entry, the first
+element is the name of the template, which should be a single short word.
+The second element is a character, a unique key to select this template.
+The third element is the template. The fourth element is optional and can
specify a destination file for remember items created with this template.
-The default file is given by `org-default-notes-file'. An optional third
+The default file is given by `org-default-notes-file'. An optional fifth
element can specify the headline in that file that should be offered
first when the user is asked to file the entry. The default headline is
given in the variable `org-remember-default-headline'.
+An optional sixth element specifies the contexts in which the user can
+select the template. This element can be either a list of major modes
+or a function. `org-remember' will first check whether the function
+returns `t' or if we are in any of the listed major modes, and select
+the template accordingly.
+
The template specifies the structure of the remember buffer. It should have
a first line starting with a star, to act as the org-mode headline.
Furthermore, the following %-escapes will be replaced with content:
- %^{prompt} prompt the user for a string and replace this sequence with it.
+ %^{prompt} Prompt the user for a string and replace this sequence with it.
+ A default value and a completion table ca be specified like this:
+ %^{prompt|default|completion2|completion3|...}
%t time stamp, date only
%T time stamp with date and time
%u, %U like the above, but inactive time stamps
You may define a prompt like %^{Please specify birthday}t
%n user name (taken from `user-full-name')
%a annotation, normally the link created with org-store-link
- %i initial content, the region when remember is called with C-u.
- If %i is indented, the entire inserted text will be indented
- as well.
+ %i initial content, the region active. If %i is indented,
+ the entire inserted text will be indented as well.
+ %c content of the clipboard, or current kill ring head
+ %^g prompt for tags, with completion on tags in target file
+ %^G prompt for tags, with completion all tags in all agenda files
+ %:keyword specific information for certain link types, see below
+ %[pathname] insert the contents of the file given by `pathname'
+ %(sexp) evaluate elisp `(sexp)' and replace with the result
+ %! Store this note immediately after filling the template
%? After completing the template, position cursor here.
info | %:type %:file %:node
calendar | %:type %:date"
:group 'org-remember
- :get (lambda (var) ; Make sure all entries have 4 elements
+ :get (lambda (var) ; Make sure all entries have at least 5 elements
(mapcar (lambda (x)
- (cond ((= (length x) 3) (append x '("")))
- ((= (length x) 2) (append x '("" "")))
+ (if (not (stringp (car x))) (setq x (cons "" x)))
+ (cond ((= (length x) 4) (append x '("")))
+ ((= (length x) 3) (append x '("" "")))
(t x)))
(default-value var)))
:type '(repeat
:tag "enabled"
- (list :value (?a "\n" nil nil)
+ (list :value ("" ?a "\n" nil nil nil)
+ (string :tag "Name")
(character :tag "Selection Key")
(string :tag "Template")
- (file :tag "Destination file (optional)")
- (string :tag "Destination headline (optional)"))))
+ (choice
+ (file :tag "Destination file")
+ (const :tag "Prompt for file" nil))
+ (choice
+ (string :tag "Destination headline")
+ (const :tag "Selection interface for heading"))
+ (choice
+ (const :tag "Use by default" nil)
+ (const :tag "Use in all contexts" t)
+ (repeat :tag "Use only if in major mode"
+ (symbol :tag "Major mode"))
+ (function :tag "Perform a check against function")))))
(defcustom org-reverse-note-order nil
"Non-nil means, store new notes at the beginning of a file or entry.
-When nil, new notes will be filed to the end of a file or entry."
+When nil, new notes will be filed to the end of a file or entry.
+This can also be a list with cons cells of regular expressions that
+are matched against file names, and values."
:group 'org-remember
:type '(choice
(const :tag "Reverse always" t)
(repeat :tag "By file name regexp"
(cons regexp boolean))))
+(defcustom org-refile-targets nil
+ "Targets for refiling entries with \\[org-refile].
+This is list of cons cells. Each cell contains:
+- a specification of the files to be considered, either a list of files,
+ or a symbol whose function or value fields will be used to retrieve
+ a file name or a list of file names. Nil means, refile to a different
+ heading in the current buffer.
+- A specification of how to find candidate refile targets. This may be
+ any of
+ - a cons cell (:tag . \"TAG\") to identify refile targets by a tag.
+ This tag has to be present in all target headlines, inheritance will
+ not be considered.
+ - a cons cell (:todo . \"KEYWORD\") to identify refile targets by
+ todo keyword.
+ - a cons cell (:regexp . \"REGEXP\") with a regular expression matching
+ headlines that are refiling targets.
+ - a cons cell (:level . N). Any headline of level N is considered a target.
+ - a cons cell (:maxlevel . N). Any headline with level <= N is a target."
+;; FIXME: what if there are a var and func with same name???
+ :group 'org-remember
+ :type '(repeat
+ (cons
+ (choice :value org-agenda-files
+ (const :tag "All agenda files" org-agenda-files)
+ (const :tag "Current buffer" nil)
+ (function) (variable) (file))
+ (choice :tag "Identify target headline by"
+ (cons :tag "Specific tag" (const :tag) (string))
+ (cons :tag "TODO keyword" (const :todo) (string))
+ (cons :tag "Regular expression" (const :regexp) (regexp))
+ (cons :tag "Level number" (const :level) (integer))
+ (cons :tag "Max Level number" (const :maxlevel) (integer))))))
+
+(defcustom org-refile-use-outline-path nil
+ "Non-nil means, provide refile targets as paths.
+So a level 3 headline will be available as level1/level2/level3.
+When the value is `file', also include the file name (without directory)
+into the path. When `full-file-path', include the full file path."
+ :group 'org-remember
+ :type '(choice
+ (const :tag "Not" nil)
+ (const :tag "Yes" t)
+ (const :tag "Start with file name" file)
+ (const :tag "Start with full file path" full-file-path)))
+
(defgroup org-todo nil
"Options concerning TODO items in Org-mode."
:tag "Org TODO"
:tag "Org Progress"
:group 'org-time)
-(defcustom org-todo-keywords '("TODO" "DONE")
- "List of TODO entry keywords.
-\\<org-mode-map>By default, this is '(\"TODO\" \"DONE\"). The last entry in the list is
-considered to mean that the entry is \"done\". All the other mean that
-action is required, and will make the entry show up in todo lists, diaries
-etc.
-The command \\[org-todo] cycles an entry through these states, and an
+(defcustom org-todo-keywords '((sequence "TODO" "DONE"))
+ "List of TODO entry keyword sequences and their interpretation.
+\\<org-mode-map>This is a list of sequences.
+
+Each sequence starts with a symbol, either `sequence' or `type',
+indicating if the keywords should be interpreted as a sequence of
+action steps, or as different types of TODO items. The first
+keywords are states requiring action - these states will select a headline
+for inclusion into the global TODO list Org-mode produces. If one of
+the \"keywords\" is the vertical bat \"|\" the remaining keywords
+signify that no further action is necessary. If \"|\" is not found,
+the last keyword is treated as the only DONE state of the sequence.
+
+The command \\[org-todo] cycles an entry through these states, and one
additional state where no keyword is present. For details about this
-cycling, see also the variable `org-todo-interpretation'
-Changes become only effective after restarting Emacs."
+cycling, see the manual.
+
+TODO keywords and interpretation can also be set on a per-file basis with
+the special #+SEQ_TODO and #+TYP_TODO lines.
+
+Each keyword can optionally specify a character for fast state selection
+\(in combination with the variable `org-use-fast-todo-selection')
+and specifiers for state change logging, using the same syntax
+that is used in the \"#+TODO:\" lines. For example, \"WAIT(w)\" says
+that the WAIT state can be selected with the \"w\" key. \"WAIT(w!)\"
+indicates to record a time stamp each time this state is selected.
+
+Each keyword may also specify if a timestamp or a note should be
+recorded when entering or leaving the state, by adding additional
+characters in the parenthesis after the keyword. This looks like this:
+\"WAIT(w@/!)\". \"@\" means to add a note (with time), \"!\" means to
+record only the time of the state change. With X and Y being either
+\"@\" or \"!\", \"X/Y\" means use X when entering the state, and use
+Y when leaving the state if and only if the *target* state does not
+define X. You may omit any of the fast-selection key or X or /Y,
+so WAIT(w@), WAIT(w/@) and WAIT(@/@) are all valid.
+
+For backward compatibility, this variable may also be just a list
+of keywords - in this case the interptetation (sequence or type) will be
+taken from the (otherwise obsolete) variable `org-todo-interpretation'."
:group 'org-todo
:group 'org-keywords
- :type '(repeat (string :tag "Keyword")))
+ :type '(choice
+ (repeat :tag "Old syntax, just keywords"
+ (string :tag "Keyword"))
+ (repeat :tag "New syntax"
+ (cons
+ (choice
+ :tag "Interpretation"
+ (const :tag "Sequence (cycling hits every state)" sequence)
+ (const :tag "Type (cycling directly to DONE)" type))
+ (repeat
+ (string :tag "Keyword"))))))
+
+(defvar org-todo-keywords-1 nil
+ "All TODO and DONE keywords active in a buffer.")
+(make-variable-buffer-local 'org-todo-keywords-1)
+(defvar org-todo-keywords-for-agenda nil)
+(defvar org-done-keywords-for-agenda nil)
+(defvar org-not-done-keywords nil)
+(make-variable-buffer-local 'org-not-done-keywords)
+(defvar org-done-keywords nil)
+(make-variable-buffer-local 'org-done-keywords)
+(defvar org-todo-heads nil)
+(make-variable-buffer-local 'org-todo-heads)
+(defvar org-todo-sets nil)
+(make-variable-buffer-local 'org-todo-sets)
+(defvar org-todo-log-states nil)
+(make-variable-buffer-local 'org-todo-log-states)
+(defvar org-todo-kwd-alist nil)
+(make-variable-buffer-local 'org-todo-kwd-alist)
+(defvar org-todo-key-alist nil)
+(make-variable-buffer-local 'org-todo-key-alist)
+(defvar org-todo-key-trigger nil)
+(make-variable-buffer-local 'org-todo-key-trigger)
(defcustom org-todo-interpretation 'sequence
"Controls how TODO keywords are interpreted.
-This variable is only relevant if `org-todo-keywords' contains more than two
-states. \\<org-mode-map>Possible values are `sequence' and `type'.
-
-When `sequence', \\[org-todo] will always switch to the next state in the
-`org-todo-keywords' list. When `type', \\[org-todo] only cycles from state
-to state when executed several times in direct succession. Otherwise, it
-switches directly to DONE from any state.
-See the manual for more information."
+This variable is in principle obsolete and is only used for
+backward compatibility, if the interpretation of todo keywords is
+not given already in `org-todo-keywords'. See that variable for
+more information."
:group 'org-todo
:group 'org-keywords
:type '(choice (const sequence)
(const type)))
+(defcustom org-use-fast-todo-selection 'prefix
+ "Non-nil means, use the fast todo selection scheme with C-c C-t.
+This variable describes if and under what circumstances the cycling
+mechanism for TODO keywords will be replaced by a single-key, direct
+selection scheme.
+
+When nil, fast selection is never used.
+
+When the symbol `prefix', it will be used when `org-todo' is called with
+a prefix argument, i.e. `C-u C-c C-t' in an Org-mode buffer, and `C-u t'
+in an agenda buffer.
+
+When t, fast selection is used by default. In this case, the prefix
+argument forces cycling instead.
+
+In all cases, the special interface is only used if access keys have actually
+been assigned by the user, i.e. if keywords in the configuration are followed
+by a letter in parenthesis, like TODO(t)."
+ :group 'org-todo
+ :type '(choice
+ (const :tag "Never" nil)
+ (const :tag "By default" t)
+ (const :tag "Only with C-u C-c C-t" prefix)))
+
(defcustom org-after-todo-state-change-hook nil
"Hook which is run after the state of a TODO item was changed.
The new state (a string with a TODO keyword, or nil) is available in the
:type 'hook)
(defcustom org-log-done nil
- "When set, insert a (non-active) time stamp when TODO entry is marked DONE.
-When the state of an entry is changed from nothing to TODO, remove a previous
-closing date.
-
-This can also be a list of symbols indicating under which conditions
-the time stamp recording the action should be annotated with a short note.
-Valid members of this list are
-
- done Offer to record a note when marking entries done
- state Offer to record a note whenever changing the TODO state
- of an item. This is only relevant if TODO keywords are
- interpreted as sequence, see variable `org-todo-interpretation'.
- When `state' is set, this includes tracking `done'.
- clock-out Offer to record a note when clocking out of an item.
-
-A separate window will then pop up and allow you to type a note.
-After finishing with C-c C-c, the note will be added directly after the
-timestamp, as a plain list item. See also the variable
-`org-log-note-headings'.
-
-Logging can also be configured on a per-file basis by adding one of
+ "Non-nil means, record a CLOSED timestamp when moving an entry to DONE.
+When equal to the list (done), also prompt for a closing note.
+This can also be configured on a per-file basis by adding one of
the following lines anywhere in the buffer:
#+STARTUP: logdone
- #+STARTUP: nologging
#+STARTUP: lognotedone
- #+STARTUP: lognotestate
- #+STARTUP: lognoteclock-out"
+ #+STARTUP: nologdone"
:group 'org-todo
:group 'org-progress
:type '(choice
- (const :tag "off" nil)
- (const :tag "on" t)
- (set :tag "on, with notes, detailed control" :greedy t :value (done)
- (const :tag "when item is marked DONE" done)
- (const :tag "when TODO state changes" state)
- (const :tag "when clocking out" clock-out))))
+ (const :tag "No logging" nil)
+ (const :tag "Record CLOSED timestamp" time)
+ (const :tag "Record CLOSED timestamp with closing note." note)))
+
+;; Normalize old uses of org-log-done.
+(cond
+ ((eq org-log-done t) (setq org-log-done 'time))
+ ((and (listp org-log-done) (memq 'done org-log-done))
+ (setq org-log-done 'note)))
+
+;; FIXME: document
+(defcustom org-log-note-clock-out nil
+ "Non-nil means, recored a note when clocking out of an item.
+This can also be configured on a per-file basis by adding one of
+the following lines anywhere in the buffer:
+
+ #+STARTUP: lognoteclock-out
+ #+STARTUP: nolognoteclock-out"
+ :group 'org-todo
+ :group 'org-progress
+ :type 'boolean)
+
+(defcustom org-log-done-with-time t
+ "Non-nil means, the CLOSED time stamp will contain date and time.
+When nil, only the date will be recorded."
+ :group 'org-progress
+ :type 'boolean)
(defcustom org-log-note-headings
'((done . "CLOSING NOTE %t")
(state . "State %-12s %t")
(clock-out . ""))
"Headings for notes added when clocking out or closing TODO items.
-The value is an alist, with the car being a sympol indicating the note
+The value is an alist, with the car being a symbol indicating the note
context, and the cdr is the heading to be used. The heading may also be the
empty string.
%t in the heading will be replaced by a time stamp.
state) string)
(cons (const :tag "Heading when clocking out" clock-out) string)))
-(defcustom org-allow-auto-repeat t
- "Non-nil means, find REPEAT cookies in entries and apply them.
-A repeat cookie looks like REPEAT(+1m) and causes deadlines and schedules
-to repeat themselves shifted by a certain amount of time, each time an
-entry is marked DONE."
+(defcustom org-log-states-order-reversed t
+ "Non-nil means, the latest state change note will be directly after heading.
+When nil, the notes will be orderer according to time."
+ :group 'org-todo
+ :group 'org-progress
+ :type 'boolean)
+
+(defcustom org-log-repeat 'time
+ "Non-nil means, record moving through the DONE state when triggering repeat.
+An auto-repeating tasks is immediately switched back to TODO when marked
+done. If you are not logging state changes (by adding \"@\" or \"!\" to
+the TODO keyword definition, or recording a cloing note by setting
+`org-log-done', there will be no record of the task moving trhough DONE.
+This variable forces taking a note anyway. Possible values are:
+
+nil Don't force a record
+time Record a time stamp
+note Record a note
+
+This option can also be set with on a per-file-basis with
+
+ #+STARTUP: logrepeat
+ #+STARTUP: lognoterepeat
+ #+STARTUP: nologrepeat
+
+You can have local logging settings for a subtree by setting the LOGGING
+property to one or more of these keywords."
+ :group 'org-todo
+ :group 'org-progress
+ :type '(choice
+ (const :tag "Don't force a record" nil)
+ (const :tag "Force recording the DONE state" time)
+ (const :tag "Force recording a note with the DONE state" note)))
+
+(defcustom org-clock-into-drawer 2
+ "Should clocking info be wrapped into a drawer?
+When t, clocking info will always be inserted into a :CLOCK: drawer.
+If necessary, the drawer will be created.
+When nil, the drawer will not be created, but used when present.
+When an integer and the number of clocking entries in an item
+reaches or exceeds this number, a drawer will be created."
:group 'org-todo
+ :group 'org-progress
+ :type '(choice
+ (const :tag "Always" t)
+ (const :tag "Only when drawer exists" nil)
+ (integer :tag "When at least N clock entries")))
+
+(defcustom org-clock-out-when-done t
+ "When t, the clock will be stopped when the relevant entry is marked DONE.
+Nil means, clock will keep running until stopped explicitly with
+`C-c C-x C-o', or until the clock is started in a different item."
:group 'org-progress
:type 'boolean)
+(defcustom org-clock-in-switch-to-state nil
+ "Set task to a special todo state while clocking it.
+The value should be the state to which the entry should be switched."
+ :group 'org-progress
+ :group 'org-todo
+ :type '(choice
+ (const :tag "Don't force a state" nil)
+ (string :tag "State")))
+
(defgroup org-priorities nil
"Priorities in Org-mode."
:tag "Org Priorities"
:group 'org-todo)
+(defcustom org-highest-priority ?A
+ "The highest priority of TODO items. A character like ?A, ?B etc.
+Must have a smaller ASCII number than `org-lowest-priority'."
+ :group 'org-priorities
+ :type 'character)
+
+(defcustom org-lowest-priority ?C
+ "The lowest priority of TODO items. A character like ?A, ?B etc.
+Must have a larger ASCII number than `org-highest-priority'."
+ :group 'org-priorities
+ :type 'character)
+
(defcustom org-default-priority ?B
"The default priority of TODO items.
This is the priority an item get if no explicit priority is given."
:group 'org-priorities
:type 'character)
-(defcustom org-lowest-priority ?C
- "The lowest priority of TODO items. A character like ?A, ?B etc."
+(defcustom org-priority-start-cycle-with-default t
+ "Non-nil means, start with default priority when starting to cycle.
+When this is nil, the first step in the cycle will be (depending on the
+command used) one higher or lower that the default priority."
:group 'org-priorities
- :type 'character)
+ :type 'boolean)
(defgroup org-time nil
"Options concerning time stamps and deadlines in Org-mode."
"Formats for `format-time-string' which are used for time stamps.
It is not recommended to change this constant.")
-(defcustom org-time-stamp-rounding-minutes 0
- "Number of minutes to round time stamps to upon insertion.
-When zero, insert the time unmodified. Useful rounding numbers
-should be factors of 60, so for example 5, 10, 15.
-When this is not zero, you can still force an exact time-stamp by using
-a double prefix argument to a time-stamp command like `C-c .' or `C-c !'."
+(defcustom org-time-stamp-rounding-minutes '(0 5)
+ "Number of minutes to round time stamps to.
+These are two values, the first applies when first creating a time stamp.
+The second applies when changing it with the commands `S-up' and `S-down'.
+When changing the time stamp, this means that it will change in steps
+of N minutes, as given by the second value.
+
+When a setting is 0 or 1, insert the time unmodified. Useful rounding
+numbers should be factors of 60, so for example 5, 10, 15.
+
+When this is larger than 1, you can still force an exact time-stamp by using
+a double prefix argument to a time-stamp command like `C-c .' or `C-c !',
+and by using a prefix arg to `S-up/down' to specify the exact number
+of minutes to shift."
:group 'org-time
- :type 'integer)
+ :get '(lambda (var) ; Make sure all entries have 5 elements
+ (if (integerp (default-value var))
+ (list (default-value var) 5)
+ (default-value var)))
+ :type '(list
+ (integer :tag "when inserting times")
+ (integer :tag "when modifying times")))
+
+;; Make sure old customizations of this variable don't lead to problems.
+(when (integerp org-time-stamp-rounding-minutes)
+ (setq org-time-stamp-rounding-minutes
+ (list org-time-stamp-rounding-minutes
+ org-time-stamp-rounding-minutes)))
(defcustom org-display-custom-times nil
"Non-nil means, overlay custom formats over all time stamps.
'("<%m/%d/%y %a>" . "<%m/%d/%y %a %H:%M>") ; american
"Custom formats for time stamps. See `format-time-string' for the syntax.
These are overlayed over the default ISO format if the variable
-`org-display-custom-times' is set."
+`org-display-custom-times' is set. Time like %H:%M should be at the
+end of the second format."
:group 'org-time
:type 'sexp)
(concat "[" (substring f 1 -1) "]")
f)))
-(defcustom org-deadline-warning-days 30
- "No. of days before expiration during which a deadline becomes active.
-This variable governs the display in sparse trees and in the agenda."
+(defcustom org-read-date-prefer-future t
+ "Non-nil means, assume future for incomplete date input from user.
+This affects the following situations:
+1. The user gives a day, but no month.
+ For example, if today is the 15th, and you enter \"3\", Org-mode will
+ read this as the third of *next* month. However, if you enter \"17\",
+ it will be considered as *this* month.
+2. The user gives a month but not a year.
+ For example, if it is april and you enter \"feb 2\", this will be read
+ as feb 2, *next* year. \"May 5\", however, will be this year.
+
+When this option is nil, the current month and year will always be used
+as defaults."
:group 'org-time
- :type 'number)
+ :type 'boolean)
-(defcustom org-popup-calendar-for-date-prompt t
+(defcustom org-read-date-display-live t
+ "Non-nil means, display current interpretation of date prompt live.
+This display will be in an overlay, in the minibuffer."
+ :group 'org-time
+ :type 'boolean)
+
+(defcustom org-read-date-popup-calendar t
"Non-nil means, pop up a calendar when prompting for a date.
In the calendar, the date can be selected with mouse-1. However, the
minibuffer will also be active, and you can simply enter the date as well.
When nil, only the minibuffer will be available."
:group 'org-time
:type 'boolean)
+(if (fboundp 'defvaralias)
+ (defvaralias 'org-popup-calendar-for-date-prompt
+ 'org-read-date-popup-calendar))
+
+(defcustom org-extend-today-until 0
+ "The hour when your day really ends.
+This has influence for the following applications:
+- When switching the agenda to \"today\". It it is still earlier than
+ the time given here, the day recognized as TODAY is actually yesterday.
+- When a date is read from the user and it is still before the time given
+ here, the current date and time will be assumed to be yesterday, 23:59.
+
+FIXME:
+IMPORTANT: This is still a very experimental feature, it may disappear
+again or it may be extended to mean more things."
+ :group 'org-time
+ :type 'number)
+
+(defcustom org-edit-timestamp-down-means-later nil
+ "Non-nil means, S-down will increase the time in a time stamp.
+When nil, S-up will increase."
+ :group 'org-time
+ :type 'boolean)
(defcustom org-calendar-follow-timestamp-change t
"Non-nil means, make the calendar window follow timestamp changes.
:group 'org-time
:type 'boolean)
+(defcustom org-clock-heading-function nil
+ "When non-nil, should be a function to create `org-clock-heading'.
+This is the string shown in the mode line when a clock is running.
+The function is called with point at the beginning of the headline."
+ :group 'org-time ; FIXME: Should we have a separate group????
+ :type 'function)
+
(defgroup org-tags nil
"Options concerning tags in Org-mode."
:tag "Org Tags"
"List of tags allowed in Org-mode files.
When this list is nil, Org-mode will base TAG input on what is already in the
buffer.
-The value of this variable is an alist, the car may be (and should) be a
-character that is used to select that tag through the fast-tag-selection
-interface. See the manual for details."
+The value of this variable is an alist, the car of each entry must be a
+keyword as a string, the cdr may be a character that is used to select
+that tag through the fast-tag-selection interface.
+See the manual for details."
:group 'org-tags
:type '(repeat
(choice
(const :tag "Yes" t)
(const :tag "Expert" expert)))
-(defcustom org-tags-column 48
+(defvar org-fast-tag-selection-include-todo nil
+ "Non-nil means, fast tags selection interface will also offer TODO states.
+This is an undocumented feature, you should not rely on it.")
+
+(defcustom org-tags-column -80
"The column to which tags should be indented in a headline.
If this number is positive, it specifies the column. If it is negative,
it means that the tags should be flushright to that column. For example,
--79 works well for a normal 80 character screen."
+-80 works well for a normal 80 character screen."
:group 'org-tags
:type 'integer)
"History of minibuffer reads for tags.")
(defvar org-last-tags-completion-table nil
"The last used completion table for tags.")
+(defvar org-after-tags-change-hook nil
+ "Hook that is run after the tags in a line have changed.")
+
+(defgroup org-properties nil
+ "Options concerning properties in Org-mode."
+ :tag "Org Properties"
+ :group 'org)
+
+(defcustom org-property-format "%-10s %s"
+ "How property key/value pairs should be formatted by `indent-line'.
+When `indent-line' hits a property definition, it will format the line
+according to this format, mainly to make sure that the values are
+lined-up with respect to each other."
+ :group 'org-properties
+ :type 'string)
+
+(defcustom org-use-property-inheritance nil
+ "Non-nil means, properties apply also for sublevels.
+This setting is only relevant during property searches, not when querying
+an entry with `org-entry-get'. To retrieve a property with inheritance,
+you need to call `org-entry-get' with the inheritance flag.
+Turning this on can cause significant overhead when doing a search, so
+this is turned off by default.
+When nil, only the properties directly given in the current entry count.
+The value may also be a list of properties that shouldhave inheritance.
+
+However, note that some special properties use inheritance under special
+circumstances (not in searches). Examples are CATEGORY, ARCHIVE, COLUMNS,
+and the properties ending in \"_ALL\" when they are used as descriptor
+for valid values of a property."
+ :group 'org-properties
+ :type '(choice
+ (const :tag "Not" nil)
+ (const :tag "Always" nil)
+ (repeat :tag "Specific properties" (string :tag "Property"))))
+
+(defcustom org-columns-default-format "%25ITEM %TODO %3PRIORITY %TAGS"
+ "The default column format, if no other format has been defined.
+This variable can be set on the per-file basis by inserting a line
+
+#+COLUMNS: %25ITEM ....."
+ :group 'org-properties
+ :type 'string)
+
+(defcustom org-global-properties nil
+ "List of property/value pairs that can be inherited by any entry.
+You can set buffer-local values for this by adding lines like
+
+#+PROPERTY: NAME VALUE"
+ :group 'org-properties
+ :type '(repeat
+ (cons (string :tag "Property")
+ (string :tag "Value"))))
+
+(defvar org-local-properties nil
+ "List of property/value pairs that can be inherited by any entry.
+Valid for the current buffer.
+This variable is populated from #+PROPERTY lines.")
(defgroup org-agenda nil
"Options concerning agenda views in Org-mode."
"Variable used by org files to set a category for agenda display.
Such files should use a file variable to set it, for example
- -*- mode: org; org-category: \"ELisp\"
+# -*- mode: org; org-category: \"ELisp\"
or contain a special line
Entries may be added to this list with \\[org-agenda-file-to-front] and removed with
\\[org-remove-file]. You can also use customize to edit the list.
+If an entry is a directory, all files in that directory that are matched by
+`org-agenda-file-regexp' will be part of the file list.
+
If the value of the variable is not a list but a single file name, then
the list of agenda files is actually stored and maintained in that file, one
agenda file per line."
:group 'org-agenda
:type '(choice
- (repeat :tag "List of files" file)
+ (repeat :tag "List of files and directories" file)
(file :tag "Store list in a file\n" :value "~/.agenda_files")))
+(defcustom org-agenda-file-regexp "\\`[^.].*\\.org\\'"
+ "Regular expression to match files for `org-agenda-files'.
+If any element in the list in that variable contains a directory instead
+of a normal file, all files in that directory that are matched by this
+regular expression will be included."
+ :group 'org-agenda
+ :type 'regexp)
+
+(defcustom org-agenda-skip-unavailable-files nil
+ "t means to just skip non-reachable files in `org-agenda-files'.
+Nil means to remove them, after a query, from the list."
+ :group 'org-agenda
+ :type 'boolean)
+
+(defcustom org-agenda-text-search-extra-files nil
+ "List of extra files to be searched by text search commands.
+These files will be search in addition to the agenda files bu the
+commands `org-search-view' (`C-c a s') and `org-occur-in-agenda-files'.
+Note that these files will only be searched for text search commands,
+not for the other agenda views like todo lists, tag earches or the weekly
+agenda. This variable is intended to list notes and possibly archive files
+that should also be searched by these two commands."
+ :group 'org-agenda
+ :type '(repeat file))
+
+(if (fboundp 'defvaralias)
+ (defvaralias 'org-agenda-multi-occur-extra-files
+ 'org-agenda-text-search-extra-files))
(defcustom org-agenda-confirm-kill 1
"When set, remote killing from the agenda buffer needs confirmation.
:group 'org-agenda
:type 'sexp)
+(defcustom org-agenda-compact-blocks nil
+ "Non-nil means, make the block agenda more compact.
+This is done by leaving out unnecessary lines."
+ :group 'org-agenda
+ :type nil)
+
+(defgroup org-agenda-export nil
+ "Options concerning exporting agenda views in Org-mode."
+ :tag "Org Agenda Export"
+ :group 'org-agenda)
+
+(defcustom org-agenda-with-colors t
+ "Non-nil means, use colors in agenda views."
+ :group 'org-agenda-export
+ :type 'boolean)
+
+(defcustom org-agenda-exporter-settings nil
+ "Alist of variable/value pairs that should be active during agenda export.
+This is a good place to set uptions for ps-print and for htmlize."
+ :group 'org-agenda-export
+ :type '(repeat
+ (list
+ (variable)
+ (sexp :tag "Value"))))
+
+(defcustom org-agenda-export-html-style ""
+ "The style specification for exported HTML Agenda files.
+If this variable contains a string, it will replace the default <style>
+section as produced by `htmlize'.
+Since there are different ways of setting style information, this variable
+needs to contain the full HTML structure to provide a style, including the
+surrounding HTML tags. The style specifications should include definitions
+the fonts used by the agenda, here is an example:
+
+ <style type=\"text/css\">
+ p { font-weight: normal; color: gray; }
+ .org-agenda-structure {
+ font-size: 110%;
+ color: #003399;
+ font-weight: 600;
+ }
+ .org-todo {
+ color: #cc6666;
+ font-weight: bold;
+ }
+ .org-done {
+ color: #339933;
+ }
+ .title { text-align: center; }
+ .todo, .deadline { color: red; }
+ .done { color: green; }
+ </style>
+
+or, if you want to keep the style in a file,
+
+ <link rel=\"stylesheet\" type=\"text/css\" href=\"mystyles.css\">
+
+As the value of this option simply gets inserted into the HTML <head> header,
+you can \"misuse\" it to also add other text to the header. However,
+<style>...</style> is required, if not present the variable will be ignored."
+ :group 'org-agenda-export
+ :group 'org-export-html
+ :type 'string)
+
(defgroup org-agenda-custom-commands nil
"Options concerning agenda views in Org-mode."
:tag "Org Agenda Custom Commands"
:group 'org-agenda)
-(defcustom org-agenda-custom-commands '(("w" todo "WAITING"))
+(defconst org-sorting-choice
+ '(choice
+ (const time-up) (const time-down)
+ (const category-keep) (const category-up) (const category-down)
+ (const tag-down) (const tag-up)
+ (const priority-up) (const priority-down))
+ "Sorting choices.")
+
+(defconst org-agenda-custom-commands-local-options
+ `(repeat :tag "Local settings for this command. Remember to quote values"
+ (choice :tag "Setting"
+ (list :tag "Any variable"
+ (variable :tag "Variable")
+ (sexp :tag "Value"))
+ (list :tag "Files to be searched"
+ (const org-agenda-files)
+ (list
+ (const :format "" quote)
+ (repeat
+ (file))))
+ (list :tag "Sorting strategy"
+ (const org-agenda-sorting-strategy)
+ (list
+ (const :format "" quote)
+ (repeat
+ ,org-sorting-choice)))
+ (list :tag "Prefix format"
+ (const org-agenda-prefix-format :value " %-12:c%?-12t% s")
+ (string))
+ (list :tag "Number of days in agenda"
+ (const org-agenda-ndays)
+ (integer :value 1))
+ (list :tag "Fixed starting date"
+ (const org-agenda-start-day)
+ (string :value "2007-11-01"))
+ (list :tag "Start on day of week"
+ (const org-agenda-start-on-weekday)
+ (choice :value 1
+ (const :tag "Today" nil)
+ (number :tag "Weekday No.")))
+ (list :tag "Include data from diary"
+ (const org-agenda-include-diary)
+ (boolean))
+ (list :tag "Deadline Warning days"
+ (const org-deadline-warning-days)
+ (integer :value 1))
+ (list :tag "Standard skipping condition"
+ :value (org-agenda-skip-function '(org-agenda-skip-entry-if))
+ (const org-agenda-skip-function)
+ (list
+ (const :format "" quote)
+ (list
+ (choice
+ :tag "Skiping range"
+ (const :tag "Skip entry" org-agenda-skip-entry-if)
+ (const :tag "Skip subtree" org-agenda-skip-subtree-if))
+ (repeat :inline t :tag "Conditions for skipping"
+ (choice
+ :tag "Condition type"
+ (list :tag "Regexp matches" :inline t (const :format "" 'regexp) (regexp))
+ (list :tag "Regexp does not match" :inline t (const :format "" 'notregexp) (regexp))
+ (const :tag "scheduled" 'scheduled)
+ (const :tag "not scheduled" 'notscheduled)
+ (const :tag "deadline" 'deadline)
+ (const :tag "no deadline" 'notdeadline))))))
+ (list :tag "Non-standard skipping condition"
+ :value (org-agenda-skip-function)
+ (list
+ (const org-agenda-skip-function)
+ (sexp :tag "Function or form (quoted!)")))))
+ "Selection of examples for agenda command settings.
+This will be spliced into the custom type of
+`org-agenda-custom-commands'.")
+
+
+(defcustom org-agenda-custom-commands nil
"Custom commands for the agenda.
These commands will be offered on the splash screen displayed by the
agenda dispatcher \\[org-agenda]. Each entry is a list like this:
- (key type match options)
-
-key The key (a single char as a string) to be associated with the command.
-type The command type, any of the following symbols:
- todo Entries with a specific TODO keyword, in all agenda files.
- tags Tags match in all agenda files.
- tags-todo Tags match in all agenda files, TODO entries only.
- todo-tree Sparse tree of specific TODO keyword in *current* file.
- tags-tree Sparse tree with all tags matches in *current* file.
- occur-tree Occur sparse tree for *current* file.
-match What to search for:
- - a single keyword for TODO keyword searches
- - a tags match expression for tags searches
- - a regular expression for occur searches
-options A list of option setttings, similar to that in a let form, so like
- this: ((opt1 val1) (opt2 val2) ...)
+ (key desc type match settings files)
+
+key The key (one or more characters as a string) to be associated
+ with the command.
+desc A description of the command, when omitted or nil, a default
+ description is built using MATCH.
+type The command type, any of the following symbols:
+ agenda The daily/weekly agenda.
+ todo Entries with a specific TODO keyword, in all agenda files.
+ search Entries containing search words entry or headline.
+ tags Tags/Property/TODO match in all agenda files.
+ tags-todo Tags/P/T match in all agenda files, TODO entries only.
+ todo-tree Sparse tree of specific TODO keyword in *current* file.
+ tags-tree Sparse tree with all tags matches in *current* file.
+ occur-tree Occur sparse tree for *current* file.
+ ... A user-defined function.
+match What to search for:
+ - a single keyword for TODO keyword searches
+ - a tags match expression for tags searches
+ - a word search expression for text searches.
+ - a regular expression for occur searches
+ For all other commands, this should be the empty string.
+settings A list of option settings, similar to that in a let form, so like
+ this: ((opt1 val1) (opt2 val2) ...). The values will be
+ evaluated at the moment of execution, so quote them when needed.
+files A list of files file to write the produced agenda buffer to
+ with the command `org-store-agenda-views'.
+ If a file name ends in \".html\", an HTML version of the buffer
+ is written out. If it ends in \".ps\", a postscript version is
+ produced. Otherwide, only the plain text is written to the file.
You can also define a set of commands, to create a composite agenda buffer.
In this case, an entry looks like this:
- (key desc (cmd1 cmd2 ...) general-options)
+ (key desc (cmd1 cmd2 ...) general-settings-for-whole-set files)
where
cmd An agenda command, similar to the above. However, tree commands
are no allowed, but instead you can get agenda and global todo list.
So valid commands for a set are:
- (agenda)
- (alltodo)
- (stuck)
- (todo \"match\" options)
- (tags \"match\" options )
- (tags-todo \"match\" options)
+ (agenda \"\" settings)
+ (alltodo \"\" settings)
+ (stuck \"\" settings)
+ (todo \"match\" settings files)
+ (search \"match\" settings files)
+ (tags \"match\" settings files)
+ (tags-todo \"match\" settings files)
Each command can carry a list of options, and another set of options can be
given for the whole set of commands. Individual command options take
-precedence over the general options."
+precedence over the general options.
+
+When using several characters as key to a command, the first characters
+are prefix commands. For the dispatcher to display useful information, you
+should provide a description for the prefix, like
+
+ (setq org-agenda-custom-commands
+ '((\"h\" . \"HOME + Name tag searches\") ; describe prefix \"h\"
+ (\"hl\" tags \"+HOME+Lisa\")
+ (\"hp\" tags \"+HOME+Peter\")
+ (\"hk\" tags \"+HOME+Kim\")))"
:group 'org-agenda-custom-commands
- :type '(repeat
- (choice
+ :type `(repeat
+ (choice :value ("x" "Describe command here" tags "" nil)
(list :tag "Single command"
- (string :tag "Key")
+ (string :tag "Access Key(s) ")
+ (option (string :tag "Description"))
(choice
+ (const :tag "Agenda" agenda)
+ (const :tag "TODO list" alltodo)
+ (const :tag "Search words" search)
+ (const :tag "Stuck projects" stuck)
(const :tag "Tags search (all agenda files)" tags)
(const :tag "Tags search of TODO entries (all agenda files)" tags-todo)
(const :tag "TODO keyword search (all agenda files)" todo)
(const :tag "Tags sparse tree (current buffer)" tags-tree)
(const :tag "TODO keyword tree (current buffer)" todo-tree)
(const :tag "Occur tree (current buffer)" occur-tree)
- (symbol :tag "Other, user-defined function"))
- (string :tag "Match")
- (repeat :tag "Local options"
- (list (variable :tag "Option") (sexp :tag "Value"))))
+ (sexp :tag "Other, user-defined function"))
+ (string :tag "Match (only for some commands)")
+ ,org-agenda-custom-commands-local-options
+ (option (repeat :tag "Export" (file :tag "Export to"))))
(list :tag "Command series, all agenda files"
- (string :tag "Key")
- (string :tag "Description")
- (repeat
+ (string :tag "Access Key(s)")
+ (string :tag "Description ")
+ (repeat :tag "Component"
(choice
- (const :tag "Agenda" (agenda))
- (const :tag "TODO list" (alltodo))
- (const :tag "Stuck projects" (stuck))
+ (list :tag "Agenda"
+ (const :format "" agenda)
+ (const :tag "" :format "" "")
+ ,org-agenda-custom-commands-local-options)
+ (list :tag "TODO list (all keywords)"
+ (const :format "" alltodo)
+ (const :tag "" :format "" "")
+ ,org-agenda-custom-commands-local-options)
+ (list :tag "Search words"
+ (const :format "" search)
+ (string :tag "Match")
+ ,org-agenda-custom-commands-local-options)
+ (list :tag "Stuck projects"
+ (const :format "" stuck)
+ (const :tag "" :format "" "")
+ ,org-agenda-custom-commands-local-options)
(list :tag "Tags search"
(const :format "" tags)
(string :tag "Match")
- (repeat :tag "Local options"
- (list (variable :tag "Option")
- (sexp :tag "Value"))))
-
+ ,org-agenda-custom-commands-local-options)
(list :tag "Tags search, TODO entries only"
(const :format "" tags-todo)
(string :tag "Match")
- (repeat :tag "Local options"
- (list (variable :tag "Option")
- (sexp :tag "Value"))))
-
+ ,org-agenda-custom-commands-local-options)
(list :tag "TODO keyword search"
(const :format "" todo)
(string :tag "Match")
- (repeat :tag "Local options"
- (list (variable :tag "Option")
- (sexp :tag "Value"))))
-
+ ,org-agenda-custom-commands-local-options)
(list :tag "Other, user-defined function"
(symbol :tag "function")
(string :tag "Match")
- (repeat :tag "Local options"
- (list (variable :tag "Option")
- (sexp :tag "Value"))))))
-
- (repeat :tag "General options"
- (list (variable :tag "Option")
- (sexp :tag "Value")))))))
+ ,org-agenda-custom-commands-local-options)))
+
+ (repeat :tag "Settings for entire command set"
+ (list (variable :tag "Any variable")
+ (sexp :tag "Value")))
+ (option (repeat :tag "Export" (file :tag "Export to"))))
+ (cons :tag "Prefix key documentation"
+ (string :tag "Access Key(s)")
+ (string :tag "Description ")))))
+
+(defcustom org-agenda-query-register ?o
+ "The register holding the current query string.
+The prupose of this is that if you construct a query string interactively,
+you can then use it to define a custom command."
+ :group 'org-agenda-custom-commands
+ :type 'character)
(defcustom org-stuck-projects
- '("+LEVEL=2/-DONE" ("TODO" "NEXT" "NEXTACTION") nil)
+ '("+LEVEL=2/-DONE" ("TODO" "NEXT" "NEXTACTION") nil "")
"How to identify stuck projects.
-This is a list of three items:
+This is a list of four items:
1. A tags/todo matcher string that is used to identify a project.
- The entire tree below a headline matched by this is considered a project.
-2. A list of TODO keywords itentifying non-stuck projects.
+ The entire tree below a headline matched by this is considered one project.
+2. A list of TODO keywords identifying non-stuck projects.
If the project subtree contains any headline with one of these todo
- keywords, the project is consitered to be not stuck.
+ keywords, the project is considered to be not stuck. If you specify
+ \"*\" as a keyword, any TODO keyword will mark the project unstuck.
3. A list of tags identifying non-stuck projects.
If the project subtree contains any headline with one of these tags,
- the project is consitered to be not stuck.
+ the project is considered to be not stuck. If you specify \"*\" as
+ a tag, any tag will mark the project unstuck.
+4. An arbitrary regular expression matching non-stuck projects.
After defining this variable, you may use \\[org-agenda-list-stuck-projects]
or `C-c a #' to produce the list."
:type '(list
(string :tag "Tags/TODO match to identify a project")
(repeat :tag "Projects are *not* stuck if they have an entry with TODO keyword any of" (string))
- (repeat :tag "Projects are *not* stuck if they have an entry with TAG being any of" (string))))
+ (repeat :tag "Projects are *not* stuck if they have an entry with TAG being any of" (string))
+ (regexp :tag "Projects are *not* stuck if this regexp matches\ninside the subtree")))
(defgroup org-agenda-skip nil
:group 'org-todo
:type 'boolean)
+(defcustom org-agenda-todo-ignore-with-date nil
+ "Non-nil means, don't show entries with a date in the global todo list.
+You can use this if you prefer to mark mere appointments with a TODO keyword,
+but don't want them to show up in the TODO list.
+When this is set, it also covers deadlines and scheduled items, the settings
+of `org-agenda-todo-ignore-scheduled' and `org-agenda-todo-ignore-deadlines'
+will be ignored."
+ :group 'org-agenda-skip
+ :group 'org-todo
+ :type 'boolean)
+
(defcustom org-agenda-todo-ignore-scheduled nil
"Non-nil means, don't show scheduled entries in the global todo list.
The idea behind this is that by scheduling it, you have already taken care
-of this item."
+of this item.
+See also `org-agenda-todo-ignore-with-date'."
:group 'org-agenda-skip
:group 'org-todo
:type 'boolean)
(defcustom org-agenda-todo-ignore-deadlines nil
"Non-nil means, don't show near deadline entries in the global todo list.
Near means closer than `org-deadline-warning-days' days.
-The idea behind this is that such items will appear in the agenda anyway."
+The idea behind this is that such items will appear in the agenda anyway.
+See also `org-agenda-todo-ignore-with-date'."
:group 'org-agenda-skip
:group 'org-todo
:type 'boolean)
(defcustom org-agenda-skip-scheduled-if-done nil
"Non-nil means don't show scheduled items in agenda when they are done.
-This is relevant for the daily/weekly agenda, not for the TODO list."
+This is relevant for the daily/weekly agenda, not for the TODO list. And
+it applies only to the actual date of the scheduling. Warnings about
+an item with a past scheduling dates are always turned off when the item
+is DONE."
:group 'org-agenda-skip
:type 'boolean)
-(defcustom org-timeline-show-empty-dates 3
- "Non-nil means, `org-timeline' also shows dates without an entry.
-When nil, only the days which actually have entries are shown.
-When t, all days between the first and the last date are shown.
+(defcustom org-agenda-skip-deadline-if-done nil
+ "Non-nil means don't show deadines when the corresponding item is done.
+When nil, the deadline is still shown and should give you a happy feeling.
+This is relevant for the daily/weekly agenda. And it applied only to the
+actualy date of the deadline. Warnings about approching and past-due
+deadlines are always turned off when the item is DONE."
+ :group 'org-agenda-skip
+ :type 'boolean)
+
+(defcustom org-agenda-skip-timestamp-if-done nil
+ "Non-nil means don't select item by timestamp or -range if it is DONE."
+ :group 'org-agenda-skip
+ :type 'boolean)
+
+(defcustom org-timeline-show-empty-dates 3
+ "Non-nil means, `org-timeline' also shows dates without an entry.
+When nil, only the days which actually have entries are shown.
+When t, all days between the first and the last date are shown.
When an integer, show also empty dates, but if there is a gap of more than
N days, just insert a special line indicating the size of the gap."
:group 'org-agenda-skip
(defcustom org-agenda-mouse-1-follows-link nil
"Non-nil means, mouse-1 on a link will follow the link in the agenda.
-A longer mouse click will still set point. Does not wortk on XEmacs.
+A longer mouse click will still set point. Does not work on XEmacs.
Needs to be set before org.el is loaded."
:group 'org-agenda-startup
:type 'boolean)
(defcustom org-agenda-start-with-follow-mode nil
- "The initial value of follwo-mode in a newly created agenda window."
+ "The initial value of follow-mode in a newly created agenda window."
:group 'org-agenda-startup
:type 'boolean)
(const other-window)
(const reorganize-frame)))
+(defcustom org-agenda-window-frame-fractions '(0.5 . 0.75)
+ "The min and max height of the agenda window as a fraction of frame height.
+The value of the variable is a cons cell with two numbers between 0 and 1.
+It only matters if `org-agenda-window-setup' is `reorganize-frame'."
+ :group 'org-agenda-windows
+ :type '(cons (number :tag "Minimum") (number :tag "Maximum")))
+
(defcustom org-agenda-restore-windows-after-quit nil
"Non-nil means, restore window configuration open exiting agenda.
Before the window configuration is changed for displaying the agenda,
current-window Display in the current window
other-window Just display in another window.
dedicated-frame Create one new frame, and re-use it each time.
-new-frame Make a new frame each time."
+new-frame Make a new frame each time. Note that in this case
+ previously-made indirect buffers are kept, and you need to
+ kill these buffers yourself."
:group 'org-structure
:group 'org-agenda-windows
:type '(choice
:group 'org-agenda-daily/weekly
:type 'boolean)
-(defcustom org-agenda-date-format "%A %d %B %Y"
+(defcustom org-agenda-format-date 'org-agenda-format-date-aligned
"Format string for displaying dates in the agenda.
Used by the daily/weekly agenda and by the timeline. This should be
-a format string understood by `format-time-string'.
-FIXME: Not used currently, because of timezone problem."
+a format string understood by `format-time-string', or a function returning
+the formatted date as a string. The function must take a single argument,
+a calendar-style date list like (month day year)."
:group 'org-agenda-daily/weekly
- :type 'string)
+ :type '(choice
+ (string :tag "Format string")
+ (function :tag "Function")))
+
+(defun org-agenda-format-date-aligned (date)
+ "Format a date string for display in the daily/weekly agenda, or timeline.
+This function makes sure that dates are aligned for easy reading."
+ (format "%-9s %2d %s %4d"
+ (calendar-day-name date)
+ (cadr date) ; day
+ (calendar-month-name (car date)) ; month
+ (nth 2 date))) ; year
(defcustom org-agenda-include-diary nil
"If non-nil, include in the agenda entries from the Emacs Calendar's diary."
:group 'org-agenda-daily/weekly
:type 'boolean)
+(defcustom org-agenda-repeating-timestamp-show-all t
+ "Non-nil means, show all occurences of a repeating stamp in the agenda.
+When nil, only one occurence is shown, either today or the
+nearest into the future."
+ :group 'org-agenda-daily/weekly
+ :type 'boolean)
+
+(defcustom org-deadline-warning-days 14
+ "No. of days before expiration during which a deadline becomes active.
+This variable governs the display in sparse trees and in the agenda.
+When 0 or negative, it means use this number (the absolute value of it)
+even if a deadline has a different individual lead time specified."
+ :group 'org-time
+ :group 'org-agenda-daily/weekly
+ :type 'number)
+
+(defcustom org-scheduled-past-days 10000
+ "No. of days to continue listing scheduled items that are not marked DONE.
+When an item is scheduled on a date, it shows up in the agenda on this
+day and will be listed until it is marked done for the number of days
+given here."
+ :group 'org-agenda-daily/weekly
+ :type 'number)
+
(defgroup org-agenda-time-grid nil
"Options concerning the time grid in the Org-mode Agenda."
:tag "Org Agenda Time Grid"
:tag "Org Agenda Sorting"
:group 'org-agenda)
-(let ((sorting-choice
- '(choice
- (const time-up) (const time-down)
- (const category-keep) (const category-up) (const category-down)
- (const tag-down) (const tag-up)
- (const priority-up) (const priority-down))))
-
- (defcustom org-agenda-sorting-strategy
- '((agenda time-up category-keep priority-down)
- (todo category-keep priority-down)
- (tags category-keep))
- "Sorting structure for the agenda items of a single day.
+(defcustom org-agenda-sorting-strategy
+ '((agenda time-up category-keep priority-down)
+ (todo category-keep priority-down)
+ (tags category-keep priority-down)
+ (search category-keep))
+ "Sorting structure for the agenda items of a single day.
This is a list of symbols which will be used in sequence to determine
if an entry should be listed before another entry. The following
symbols are recognized:
priority.
Leaving out `category-keep' would mean that items will be sorted across
-categories by priority."
+categories by priority.
+
+Instead of a single list, this can also be a set of list for specific
+contents, with a context symbol in the car of the list, any of
+`agenda', `todo', `tags' for the corresponding agenda views."
:group 'org-agenda-sorting
:type `(choice
- (repeat :tag "General" ,sorting-choice)
+ (repeat :tag "General" ,org-sorting-choice)
(list :tag "Individually"
(cons (const :tag "Strategy for Weekly/Daily agenda" agenda)
- (repeat ,sorting-choice))
+ (repeat ,org-sorting-choice))
(cons (const :tag "Strategy for TODO lists" todo)
- (repeat ,sorting-choice))
+ (repeat ,org-sorting-choice))
(cons (const :tag "Strategy for Tags matches" tags)
- (repeat ,sorting-choice))))))
+ (repeat ,org-sorting-choice)))))
(defcustom org-sort-agenda-notime-is-late t
"Non-nil means, items without time are considered late.
:group 'org-agenda-sorting
:type 'boolean)
-(defgroup org-agenda-prefix nil
+(defgroup org-agenda-line-format nil
"Options concerning the entry prefix in the Org-mode agenda display."
- :tag "Org Agenda Prefix"
+ :tag "Org Agenda Line Format"
:group 'org-agenda)
(defcustom org-agenda-prefix-format
'((agenda . " %-12:c%?-12t% s")
(timeline . " % s")
(todo . " %-12:c")
- (tags . " %-12:c"))
+ (tags . " %-12:c")
+ (search . " %-12:c"))
"Format specifications for the prefix of items in the agenda views.
An alist with four entries, for the different agenda types. The keys to the
sublists are `agenda', `timeline', `todo', and `tags'. The values
(setq org-agenda-prefix-format \" %-11:c% s\")
See also the variables `org-agenda-remove-times-when-in-prefix' and
-`org-agenda-remove-tags-when-in-prefix'."
+`org-agenda-remove-tags'."
:type '(choice
(string :tag "General format")
(list :greedy t :tag "View dependent"
(cons (const agenda) (string :tag "Format"))
(cons (const timeline) (string :tag "Format"))
(cons (const todo) (string :tag "Format"))
- (cons (const tags) (string :tag "Format"))))
- :group 'org-agenda-prefix)
+ (cons (const tags) (string :tag "Format"))
+ (cons (const search) (string :tag "Format"))))
+ :group 'org-agenda-line-format)
(defvar org-prefix-format-compiled nil
"The compiled version of the most recently used prefix format.
See the variable `org-agenda-prefix-format'.")
+(defcustom org-agenda-todo-keyword-format "%-1s"
+ "Format for the TODO keyword in agenda lines.
+Set this to something like \"%-12s\" if you want all TODO keywords
+to occupy a fixed space in the agenda display."
+ :group 'org-agenda-line-format
+ :type 'string)
+
+(defcustom org-agenda-scheduled-leaders '("Scheduled: " "Sched.%2dx: ")
+ "Text preceeding scheduled items in the agenda view.
+This is a list with two strings. The first applies when the item is
+scheduled on the current day. The second applies when it has been scheduled
+previously, it may contain a %d to capture how many days ago the item was
+scheduled."
+ :group 'org-agenda-line-format
+ :type '(list
+ (string :tag "Scheduled today ")
+ (string :tag "Scheduled previously")))
+
+(defcustom org-agenda-deadline-leaders '("Deadline: " "In %3d d.: ")
+ "Text preceeding deadline items in the agenda view.
+This is a list with two strings. The first applies when the item has its
+deadline on the current day. The second applies when it is in the past or
+in the future, it may contain %d to capture how many days away the deadline
+is (was)."
+ :group 'org-agenda-line-format
+ :type '(list
+ (string :tag "Deadline today ")
+ (string :tag "Deadline relative")))
+
(defcustom org-agenda-remove-times-when-in-prefix t
"Non-nil means, remove duplicate time specifications in agenda items.
When the format `org-agenda-prefix-format' contains a `%t' specifier, a
The option can be t or nil. It may also be the symbol `beg', indicating
that the time should only be removed what it is located at the beginning of
the headline/diary entry."
- :group 'org-agenda-prefix
+ :group 'org-agenda-line-format
:type '(choice
(const :tag "Always" t)
(const :tag "Never" nil)
(const :tag "When at beginning of entry" beg)))
-(defcustom org-agenda-remove-tags-when-in-prefix nil
+
+(defcustom org-agenda-default-appointment-duration nil
+ "Default duration for appointments that only have a starting time.
+When nil, no duration is specified in such cases.
+When non-nil, this must be the number of minutes, e.g. 60 for one hour."
+ :group 'org-agenda-line-format
+ :type '(choice
+ (integer :tag "Minutes")
+ (const :tag "No default duration")))
+
+
+(defcustom org-agenda-remove-tags nil
"Non-nil means, remove the tags from the headline copy in the agenda.
When this is the symbol `prefix', only remove tags when
`org-agenda-prefix-format' contains a `%T' specifier."
- :group 'org-agenda-prefix
+ :group 'org-agenda-line-format
:type '(choice
(const :tag "Always" t)
(const :tag "Never" nil)
(const :tag "When prefix format contains %T" prefix)))
-(defcustom org-agenda-align-tags-to-column 65
- "Shift tags in agenda items to this column."
- :group 'org-agenda-prefix
+(if (fboundp 'defvaralias)
+ (defvaralias 'org-agenda-remove-tags-when-in-prefix
+ 'org-agenda-remove-tags))
+
+(defcustom org-agenda-tags-column -80
+ "Shift tags in agenda items to this column.
+If this number is positive, it specifies the column. If it is negative,
+it means that the tags should be flushright to that column. For example,
+-80 works well for a normal 80 character screen."
+ :group 'org-agenda-line-format
:type 'integer)
+(if (fboundp 'defvaralias)
+ (defvaralias 'org-agenda-align-tags-to-column 'org-agenda-tags-column))
+
+(defcustom org-agenda-fontify-priorities t
+ "Non-nil means, highlight low and high priorities in agenda.
+When t, the highest priority entries are bold, lowest priority italic.
+This may also be an association list of priority faces. The face may be
+a names face, or a list like `(:background \"Red\")'."
+ :group 'org-agenda-line-format
+ :type '(choice
+ (const :tag "Never" nil)
+ (const :tag "Defaults" t)
+ (repeat :tag "Specify"
+ (list (character :tag "Priority" :value ?A)
+ (sexp :tag "face")))))
+
(defgroup org-latex nil
- "Options for embedding LaTeX code into Org-mode"
+ "Options for embedding LaTeX code into Org-mode."
:tag "Org LaTeX"
:group 'org)
(defcustom org-format-latex-options
- '(:foreground "Black" :background "Transparent" :scale 1.0
- :matchers ("begin" "$" "$$" "\\(" "\\["))
+ '(:foreground default :background default :scale 1.0
+ :html-foreground "Black" :html-background "Transparent" :html-scale 1.0
+ :matchers ("begin" "$" "$$" "\\(" "\\["))
"Options for creating images from LaTeX fragments.
This is a property list with the following properties:
-:foreground the foreground color, for example \"Black\".
+:foreground the foreground color for images embedded in emacs, e.g. \"Black\".
+ `default' means use the forground of the default face.
:background the background color, or \"Transparent\".
+ `default' means use the background of the default face.
:scale a scaling factor for the size of the images
+:html-foreground, :html-background, :html-scale
+ The same numbers for HTML export.
:matchers a list indicating which matchers should be used to
find LaTeX fragments. Valid members of this list are:
\"begin\" find environments
:group 'org-latex
:type 'plist)
+(defcustom org-format-latex-header "\\documentclass{article}
+\\usepackage{fullpage} % do not remove
+\\usepackage{amssymb}
+\\usepackage[usenames]{color}
+\\usepackage{amsmath}
+\\usepackage{latexsym}
+\\usepackage[mathscr]{eucal}
+\\pagestyle{empty} % do not remove"
+ "The document header used for processing LaTeX fragments."
+ :group 'org-latex
+ :type 'string)
+
(defgroup org-export nil
"Options for exporting org-listings."
:tag "Org Export"
:tag "Org Export General"
:group 'org-export)
-(defcustom org-export-publishing-directory "."
- "Path to the location where exported files should be located.
-This path may be relative to the directory where the Org-mode file lives.
-The default is to put them into the same directory as the Org-mode file.
-The variable may also be an alist with export types `:html', `:ascii',
-`:ical', or `:xoxo' and the corresponding directories. If a direcoty path
-is relative, it is interpreted relative to the directory where the exported
-Org-mode files lives."
- :group 'org-export-general
- :type '(choice
- (directory)
- (repeat
- (cons
- (choice :tag "Type"
- (const :html) (const :ascii) (const :ical) (const :xoxo))
- (directory)))))
+;; FIXME
+(defvar org-export-publishing-directory nil)
+
+(defcustom org-export-with-special-strings t
+ "Non-nil means, interpret \"\-\", \"--\" and \"---\" for export.
+When this option is turned on, these strings will be exported as:
+
+ Org HTML LaTeX
+ -----+----------+--------
+ \\- ­ \\-
+ -- – --
+ --- — ---
+ ... … \ldots
+
+This option can also be set with the +OPTIONS line, e.g. \"-:nil\"."
+ :group 'org-export-translation
+ :type 'boolean)
(defcustom org-export-language-setup
'(("en" "Author" "Date" "Table of Contents")
("cs" "Autor" "Datum" "Obsah")
("da" "Ophavsmand" "Dato" "Indhold")
("de" "Autor" "Datum" "Inhaltsverzeichnis")
- ("es" "Autor" "Fecha" "\xccndice")
- ("fr" "Auteur" "Date" "Table des Mati\xe8res")
+ ("es" "Autor" "Fecha" "\xcdndice")
+ ("fr" "Auteur" "Date" "Table des mati\xe8res")
("it" "Autore" "Data" "Indice")
("nl" "Auteur" "Datum" "Inhoudsopgave")
("nn" "Forfattar" "Dato" "Innhold") ;; nn = Norsk (nynorsk)
:group 'org-export-general
:type 'string)
+(defcustom org-export-skip-text-before-1st-heading t
+ "Non-nil means, skip all text before the first headline when exporting.
+When nil, that text is exported as well."
+ :group 'org-export-general
+ :type 'boolean)
+
(defcustom org-export-headline-levels 3
"The last level which is still exported as a headline.
Inferior levels will produce itemize lists when exported.
(const :tag "headline only" 'headline)
(const :tag "entirely" t)))
+(defcustom org-export-author-info t
+ "Non-nil means, insert author name and email into the exported file.
+
+This option can also be set with the +OPTIONS line,
+e.g. \"author-info:nil\"."
+ :group 'org-export-general
+ :type 'boolean)
+
+(defcustom org-export-time-stamp-file t
+ "Non-nil means, insert a time stamp into the exported file.
+The time stamp shows when the file was created.
+
+This option can also be set with the +OPTIONS line,
+e.g. \"timestamp:nil\"."
+ :group 'org-export-general
+ :type 'boolean)
+
(defcustom org-export-with-timestamps t
"If nil, do not export time stamps and associated keywords."
:group 'org-export-general
(defcustom org-export-with-tags 'not-in-toc
"If nil, do not export tags, just remove them from headlines.
If this is the symbol `not-in-toc', tags will be removed from table of
-contents entries, but still be shown in the headlines of the document."
+contents entries, but still be shown in the headlines of the document.
+
+This option can also be set with the +OPTIONS line, e.g. \"tags:nil\"."
:group 'org-export-general
:type '(choice
(const :tag "Off" nil)
(const :tag "Not in TOC" not-in-toc)
(const :tag "On" t)))
+(defcustom org-export-with-drawers nil
+ "Non-nil means, export with drawers like the property drawer.
+When t, all drawers are exported. This may also be a list of
+drawer names to export."
+ :group 'org-export-general
+ :type '(choice
+ (const :tag "All drawers" t)
+ (const :tag "None" nil)
+ (repeat :tag "Selected drawers"
+ (string :tag "Drawer name"))))
+
(defgroup org-export-translation nil
"Options for translating special ascii sequences for the export backends."
:tag "Org Export Translation"
:group 'org-export-translation
:type 'boolean)
+(defcustom org-export-with-footnotes t
+ "If nil, export [1] as a footnote marker.
+Lines starting with [1] will be formatted as footnotes.
+
+This option can also be set with the +OPTIONS line, e.g. \"f:nil\"."
+ :group 'org-export-translation
+ :type 'boolean)
+
(defcustom org-export-with-sub-superscripts t
"Non-nil means, interpret \"_\" and \"^\" for export.
When this option is turned on, you can use TeX-like syntax for sub- and
x_{i^2} or x^(2-i) braces or parenthesis do grouping.
Still, ambiguity is possible - so when in doubt use {} to enclose the
-sub/superscript.
+sub/superscript. If you set this variable to the symbol `{}',
+the braces are *required* in order to trigger interpretations as
+sub/superscript. This can be helpful in documents that need \"_\"
+frequently in plain text.
+
Not all export backends support this, but HTML does.
This option can also be set with the +OPTIONS line, e.g. \"^:nil\"."
+ :group 'org-export-translation
+ :type '(choice
+ (const :tag "Always interpret" t)
+ (const :tag "Only with braces" {})
+ (const :tag "Never interpret" nil)))
+
+(defcustom org-export-with-special-strings t
+ "Non-nil means, interpret \"\-\", \"--\" and \"---\" for export.
+When this option is turned on, these strings will be exported as:
+
+\\- : ­
+-- : –
+--- : —
+
+Not all export backends support this, but HTML does.
+
+This option can also be set with the +OPTIONS line, e.g. \"-:nil\"."
:group 'org-export-translation
:type 'boolean)
This option can also be set with the +OPTIONS line, e.g. \"TeX:nil\"."
:group 'org-export-translation
- :group 'org-latex
+ :group 'org-export-latex
:type 'boolean)
(defcustom org-export-with-LaTeX-fragments nil
This option can also be set with the +OPTIONS line, e.g. \"LaTeX:t\"."
:group 'org-export-translation
- :group 'org-latex
+ :group 'org-export-latex
:type 'boolean)
(defcustom org-export-with-fixed-width t
:tag "Org Export HTML"
:group 'org-export)
+(defcustom org-export-html-coding-system nil
+ ""
+ :group 'org-export-html
+ :type 'coding-system)
+
+(defcustom org-export-html-extension "html"
+ "The extension for exported HTML files."
+ :group 'org-export-html
+ :type 'string)
+
(defcustom org-export-html-style
"<style type=\"text/css\">
html {
Since there are different ways of setting style information, this variable
needs to contain the full HTML structure to provide a style, including the
surrounding HTML tags. The style specifications should include definitions
-for new classes todo, done, title, and deadline. For example, legal values
+for new classes todo, done, title, and deadline. For example, valid values
would be:
<style type=\"text/css\">
:group 'org-export-html
:type 'string)
+
(defcustom org-export-html-title-format "<h1 class=\"title\">%s</h1>\n"
"Format for typesetting the document title in HTML export."
:group 'org-export-html
(defcustom org-export-html-table-tag
"<table border=\"2\" cellspacing=\"0\" cellpadding=\"6\" rules=\"groups\" frame=\"hsides\">"
- "The HTML tag used to start a table.
+ "The HTML tag that is used to start a table.
This must be a <table> tag, but you may change the options like
borders and spacing."
:group 'org-export-html
:type 'string)
+(defcustom org-export-table-header-tags '("<th>" . "</th>")
+ "The opening tag for table header fields.
+This is customizable so that alignment options can be specified."
+ :group 'org-export-tables
+ :type '(cons (string :tag "Opening tag") (string :tag "Closing tag")))
+
+(defcustom org-export-table-data-tags '("<td>" . "</td>")
+ "The opening tag for table data fields.
+This is customizable so that alignment options can be specified."
+ :group 'org-export-tables
+ :type '(cons (string :tag "Opening tag") (string :tag "Closing tag")))
+
(defcustom org-export-html-with-timestamp nil
"If non-nil, write `org-export-html-html-helper-timestamp'
into the exported HTML text. Otherwise, the buffer will just be saved
(defcustom org-combined-agenda-icalendar-file "~/org.ics"
"The file name for the iCalendar file covering all agenda files.
This file is created with the command \\[org-export-icalendar-all-agenda-files].
-The file name should be absolute."
+The file name should be absolute, the file will be overwritten without warning."
:group 'org-export-icalendar
:type 'file)
(const :tag "Unfinished" t)
(const :tag "All" all)))
+(defcustom org-icalendar-include-sexps t
+ "Non-nil means, export to iCalendar files should also cover sexp entries.
+These are entries like in the diary, but directly in an Org-mode file."
+ :group 'org-export-icalendar
+ :type 'boolean)
+
+(defcustom org-icalendar-include-body 100
+ "Amount of text below headline to be included in iCalendar export.
+This is a number of characters that should maximally be included.
+Properties, scheduling and clocking lines will always be removed.
+The text will be inserted into the DESCRIPTION field."
+ :group 'org-export-icalendar
+ :type '(choice
+ (const :tag "Nothing" nil)
+ (const :tag "Everything" t)
+ (integer :tag "Max characters")))
+
(defcustom org-icalendar-combined-name "OrgMode"
"Calendar name for the combined iCalendar representing all agenda files."
:group 'org-export-icalendar
:group 'org-font-lock
:type 'boolean)
+(defcustom org-highlight-latex-fragments-and-specials nil
+ "Non-nil means, fontify what is treated specially by the exporters."
+ :group 'org-font-lock
+ :type 'boolean)
+
+(defcustom org-hide-emphasis-markers nil
+ "Non-nil mean font-lock should hide the emphasis marker characters."
+ :group 'org-font-lock
+ :type 'boolean)
+
(defvar org-emph-re nil
"Regular expression for matching emphasis.")
+(defvar org-verbatim-re nil
+ "Regular expression for matching verbatim text.")
(defvar org-emphasis-regexp-components) ; defined just below
(defvar org-emphasis-alist) ; defined just below
(defun org-set-emph-re (var val)
(border (nth 2 e))
(body (nth 3 e))
(nl (nth 4 e))
- (stacked (nth 5 e))
+ (stacked (and nil (nth 5 e))) ; stacked is no longer allowed, forced to nil
(body1 (concat body "*?"))
- (markers (mapconcat 'car org-emphasis-alist "")))
+ (markers (mapconcat 'car org-emphasis-alist ""))
+ (vmarkers (mapconcat
+ (lambda (x) (if (eq (nth 4 x) 'verbatim) (car x) ""))
+ org-emphasis-alist "")))
;; make sure special characters appear at the right position in the class
(if (string-match "\\^" markers)
(setq markers (concat (replace-match "" t t markers) "^")))
(if (string-match "-" markers)
(setq markers (concat (replace-match "" t t markers) "-")))
-; (while (>= (setq nl (1- nl)) 0) (setq body1 (concat body1 "\n?" body "*?")))
-; (while (>= (setq nl (1- nl)) 0) (setq body1 (concat body1 "\\(?:\n?" body "*?\\)?")))
+ (if (string-match "\\^" vmarkers)
+ (setq vmarkers (concat (replace-match "" t t vmarkers) "^")))
+ (if (string-match "-" vmarkers)
+ (setq vmarkers (concat (replace-match "" t t vmarkers) "-")))
(if (> nl 0)
(setq body1 (concat body1 "\\(?:\n" body "*?\\)\\{0,"
(int-to-string nl) "\\}")))
;; Make the regexp
(setq org-emph-re
- (concat "\\([" pre (if stacked markers) "]\\|^\\)"
+ (concat "\\([" pre (if (and nil stacked) markers) "]\\|^\\)"
"\\("
"\\([" markers "]\\)"
"\\("
- "[^" border markers "]"
+ "[^" border "]\\|"
+ "[^" border (if (and nil stacked) markers) "]"
+ body1
+ "[^" border (if (and nil stacked) markers) "]"
+ "\\)"
+ "\\3\\)"
+ "\\([" post (if (and nil stacked) markers) "]\\|$\\)"))
+ (setq org-verbatim-re
+ (concat "\\([" pre "]\\|^\\)"
+ "\\("
+ "\\([" vmarkers "]\\)"
+ "\\("
+ "[^" border "]\\|"
+ "[^" border "]"
body1
- "[^" border markers "]"
+ "[^" border "]"
"\\)"
"\\3\\)"
- "\\([" post (if stacked markers) "]\\|$\\)")))))
+ "\\([" post "]\\|$\\)")))))
(defcustom org-emphasis-regexp-components
- '(" \t('\"" " \t.,?;'\")" " \t\r\n," "." 1 nil)
- "Components used to build the reqular expression for emphasis.
+ '(" \t('\"" "- \t.,:?;'\")" " \t\r\n,\"'" "." 1)
+ "Components used to build the regular expression for emphasis.
This is a list with 6 entries. Terminology: In an emphasis string
like \" *strong word* \", we call the initial space PREMATCH, the final
space POSTMATCH, the stars MARKERS, \"s\" and \"d\" are BORDER characters
pre Chars allowed as prematch. Beginning of line will be allowed too.
post Chars allowed as postmatch. End of line will be allowed too.
-border The chars *forbidden* as border characters. In addition to the
- characters given here, all marker characters are forbidden too.
+border The chars *forbidden* as border characters.
body-regexp A regexp like \".\" to match a body character. Don't use
non-shy groups here, and don't allow newline here.
newline The maximum number of newlines allowed in an emphasis exp.
-stacked Non-nil means, allow stacked styles. This works only in HTML
- export. When this is set, all marker characters (as given in
- `org-emphasis-alist') will be allowed as pre/post, aiding
- inside-out matching.
+
Use customize to modify this, or restart Emacs after changing it."
:group 'org-font-lock
:set 'org-set-emph-re
(sexp :tag "Forbidden chars in border ")
(sexp :tag "Regexp for body ")
(integer :tag "number of newlines allowed")
- (boolean :tag "Stacking allowed ")))
+ (option (boolean :tag "Stacking (DISABLED) "))))
(defcustom org-emphasis-alist
'(("*" bold "<b>" "</b>")
("/" italic "<i>" "</i>")
("_" underline "<u>" "</u>")
- ("=" shadow "<code>" "</code>")
+ ("=" org-code "<code>" "</code>" verbatim)
+ ("~" org-verbatim "" "" verbatim)
("+" (:strike-through t) "<del>" "</del>")
-)
-"Special syntax for emphasized text.
+ )
+ "Special syntax for emphasized text.
Text starting and ending with a special character will be emphasized, for
example *bold*, _underlined_ and /italic/. This variable sets the marker
-characters, the face to bbe used by font-lock for highlighting in Org-mode
+characters, the face to be used by font-lock for highlighting in Org-mode
Emacs buffers, and the HTML tags to be used for this.
Use customize to modify this, or restart Emacs after changing it."
:group 'org-font-lock
(face :tag "Font-lock-face")
(plist :tag "Face property list"))
(string :tag "HTML start tag")
- (string :tag "HTML end tag"))))
+ (string :tag "HTML end tag")
+ (option (const verbatim)))))
;;; The faces
:tag "Org Faces"
:group 'org-font-lock)
-(defun org-compatible-face (specs)
+(defun org-compatible-face (inherits specs)
"Make a compatible face specification.
+If INHERITS is an existing face and if the Emacs version supports it,
+just inherit the face. If not, use SPECS to define the face.
XEmacs and Emacs 21 do not know about the `min-colors' attribute.
For them we convert a (min-colors 8) entry to a `tty' entry and move it
to the top of the list. The `min-colors' attribute will be removed from
any other entries, and any resulting duplicates will be removed entirely."
- (if (or (featurep 'xemacs) (< emacs-major-version 22))
- (let (r e a)
- (while (setq e (pop specs))
- (cond
- ((memq (car e) '(t default)) (push e r))
- ((setq a (member '(min-colors 8) (car e)))
- (nconc r (list (cons (cons '(type tty) (delq (car a) (car e)))
- (cdr e)))))
- ((setq a (assq 'min-colors (car e)))
- (setq e (cons (delq a (car e)) (cdr e)))
- (or (assoc (car e) r) (push e r)))
- (t (or (assoc (car e) r) (push e r)))))
- (nreverse r))
- specs))
+ (cond
+ ((and inherits (facep inherits)
+ (not (featurep 'xemacs)) (> emacs-major-version 22))
+ ;; In Emacs 23, we use inheritance where possible.
+ ;; We only do this in Emacs 23, because only there the outline
+ ;; faces have been changed to the original org-mode-level-faces.
+ (list (list t :inherit inherits)))
+ ((or (featurep 'xemacs) (< emacs-major-version 22))
+ ;; These do not understand the `min-colors' attribute.
+ (let (r e a)
+ (while (setq e (pop specs))
+ (cond
+ ((memq (car e) '(t default)) (push e r))
+ ((setq a (member '(min-colors 8) (car e)))
+ (nconc r (list (cons (cons '(type tty) (delq (car a) (car e)))
+ (cdr e)))))
+ ((setq a (assq 'min-colors (car e)))
+ (setq e (cons (delq a (car e)) (cdr e)))
+ (or (assoc (car e) r) (push e r)))
+ (t (or (assoc (car e) r) (push e r)))))
+ (nreverse r)))
+ (t specs)))
+(put 'org-compatible-face 'lisp-indent-function 1)
(defface org-hide
'((((background light)) (:foreground "white"))
:group 'org-faces)
(defface org-level-1 ;; font-lock-function-name-face
- (org-compatible-face
- '((((class color) (min-colors 88) (background light)) (:foreground "Blue1"))
- (((class color) (min-colors 88) (background dark)) (:foreground "LightSkyBlue"))
- (((class color) (min-colors 16) (background light)) (:foreground "Blue"))
- (((class color) (min-colors 16) (background dark)) (:foreground "LightSkyBlue"))
- (((class color) (min-colors 8)) (:foreground "blue" :bold t))
- (t (:bold t))))
+ (org-compatible-face 'outline-1
+ '((((class color) (min-colors 88) (background light)) (:foreground "Blue1"))
+ (((class color) (min-colors 88) (background dark)) (:foreground "LightSkyBlue"))
+ (((class color) (min-colors 16) (background light)) (:foreground "Blue"))
+ (((class color) (min-colors 16) (background dark)) (:foreground "LightSkyBlue"))
+ (((class color) (min-colors 8)) (:foreground "blue" :bold t))
+ (t (:bold t))))
"Face used for level 1 headlines."
:group 'org-faces)
(defface org-level-2 ;; font-lock-variable-name-face
- (org-compatible-face
- '((((class color) (min-colors 16) (background light)) (:foreground "DarkGoldenrod"))
- (((class color) (min-colors 16) (background dark)) (:foreground "LightGoldenrod"))
- (((class color) (min-colors 8) (background light)) (:foreground "yellow"))
- (((class color) (min-colors 8) (background dark)) (:foreground "yellow" :bold t))
- (t (:bold t))))
+ (org-compatible-face 'outline-2
+ '((((class color) (min-colors 16) (background light)) (:foreground "DarkGoldenrod"))
+ (((class color) (min-colors 16) (background dark)) (:foreground "LightGoldenrod"))
+ (((class color) (min-colors 8) (background light)) (:foreground "yellow"))
+ (((class color) (min-colors 8) (background dark)) (:foreground "yellow" :bold t))
+ (t (:bold t))))
"Face used for level 2 headlines."
:group 'org-faces)
(defface org-level-3 ;; font-lock-keyword-face
- (org-compatible-face
- '((((class color) (min-colors 88) (background light)) (:foreground "Purple"))
- (((class color) (min-colors 88) (background dark)) (:foreground "Cyan1"))
- (((class color) (min-colors 16) (background light)) (:foreground "Purple"))
- (((class color) (min-colors 16) (background dark)) (:foreground "Cyan"))
- (((class color) (min-colors 8) (background light)) (:foreground "purple" :bold t))
- (((class color) (min-colors 8) (background dark)) (:foreground "cyan" :bold t))
- (t (:bold t))))
+ (org-compatible-face 'outline-3
+ '((((class color) (min-colors 88) (background light)) (:foreground "Purple"))
+ (((class color) (min-colors 88) (background dark)) (:foreground "Cyan1"))
+ (((class color) (min-colors 16) (background light)) (:foreground "Purple"))
+ (((class color) (min-colors 16) (background dark)) (:foreground "Cyan"))
+ (((class color) (min-colors 8) (background light)) (:foreground "purple" :bold t))
+ (((class color) (min-colors 8) (background dark)) (:foreground "cyan" :bold t))
+ (t (:bold t))))
"Face used for level 3 headlines."
:group 'org-faces)
(defface org-level-4 ;; font-lock-comment-face
- (org-compatible-face
- '((((class color) (min-colors 88) (background light)) (:foreground "Firebrick"))
- (((class color) (min-colors 88) (background dark)) (:foreground "chocolate1"))
- (((class color) (min-colors 16) (background light)) (:foreground "red"))
- (((class color) (min-colors 16) (background dark)) (:foreground "red1"))
- (((class color) (min-colors 8) (background light)) (:foreground "red" :bold t))
- (((class color) (min-colors 8) (background dark)) (:foreground "red" :bold t))
- (t (:bold t))))
+ (org-compatible-face 'outline-4
+ '((((class color) (min-colors 88) (background light)) (:foreground "Firebrick"))
+ (((class color) (min-colors 88) (background dark)) (:foreground "chocolate1"))
+ (((class color) (min-colors 16) (background light)) (:foreground "red"))
+ (((class color) (min-colors 16) (background dark)) (:foreground "red1"))
+ (((class color) (min-colors 8) (background light)) (:foreground "red" :bold t))
+ (((class color) (min-colors 8) (background dark)) (:foreground "red" :bold t))
+ (t (:bold t))))
"Face used for level 4 headlines."
:group 'org-faces)
(defface org-level-5 ;; font-lock-type-face
- (org-compatible-face
- '((((class color) (min-colors 16) (background light)) (:foreground "ForestGreen"))
- (((class color) (min-colors 16) (background dark)) (:foreground "PaleGreen"))
- (((class color) (min-colors 8)) (:foreground "green"))))
+ (org-compatible-face 'outline-5
+ '((((class color) (min-colors 16) (background light)) (:foreground "ForestGreen"))
+ (((class color) (min-colors 16) (background dark)) (:foreground "PaleGreen"))
+ (((class color) (min-colors 8)) (:foreground "green"))))
"Face used for level 5 headlines."
:group 'org-faces)
(defface org-level-6 ;; font-lock-constant-face
- (org-compatible-face
- '((((class color) (min-colors 16) (background light)) (:foreground "CadetBlue"))
- (((class color) (min-colors 16) (background dark)) (:foreground "Aquamarine"))
- (((class color) (min-colors 8)) (:foreground "magenta"))))
+ (org-compatible-face 'outline-6
+ '((((class color) (min-colors 16) (background light)) (:foreground "CadetBlue"))
+ (((class color) (min-colors 16) (background dark)) (:foreground "Aquamarine"))
+ (((class color) (min-colors 8)) (:foreground "magenta"))))
"Face used for level 6 headlines."
:group 'org-faces)
(defface org-level-7 ;; font-lock-builtin-face
- (org-compatible-face
- '((((class color) (min-colors 16) (background light)) (:foreground "Orchid"))
- (((class color) (min-colors 16) (background dark)) (:foreground "LightSteelBlue"))
- (((class color) (min-colors 8)) (:foreground "blue"))))
+ (org-compatible-face 'outline-7
+ '((((class color) (min-colors 16) (background light)) (:foreground "Orchid"))
+ (((class color) (min-colors 16) (background dark)) (:foreground "LightSteelBlue"))
+ (((class color) (min-colors 8)) (:foreground "blue"))))
"Face used for level 7 headlines."
:group 'org-faces)
(defface org-level-8 ;; font-lock-string-face
- (org-compatible-face
- '((((class color) (min-colors 16) (background light)) (:foreground "RosyBrown"))
- (((class color) (min-colors 16) (background dark)) (:foreground "LightSalmon"))
- (((class color) (min-colors 8)) (:foreground "green"))))
+ (org-compatible-face 'outline-8
+ '((((class color) (min-colors 16) (background light)) (:foreground "RosyBrown"))
+ (((class color) (min-colors 16) (background dark)) (:foreground "LightSalmon"))
+ (((class color) (min-colors 8)) (:foreground "green"))))
"Face used for level 8 headlines."
:group 'org-faces)
(defface org-special-keyword ;; font-lock-string-face
- (org-compatible-face
- '((((class color) (min-colors 16) (background light)) (:foreground "RosyBrown"))
- (((class color) (min-colors 16) (background dark)) (:foreground "LightSalmon"))
- (t (:italic t))))
+ (org-compatible-face nil
+ '((((class color) (min-colors 16) (background light)) (:foreground "RosyBrown"))
+ (((class color) (min-colors 16) (background dark)) (:foreground "LightSalmon"))
+ (t (:italic t))))
"Face used for special keywords."
:group 'org-faces)
-(defface org-warning ;; font-lock-warning-face
- (org-compatible-face
- '((((class color) (min-colors 16) (background light)) (:foreground "Red1" :bold t))
- (((class color) (min-colors 16) (background dark)) (:foreground "Pink" :bold t))
- (((class color) (min-colors 8) (background light)) (:foreground "red" :bold t))
- (((class color) (min-colors 8) (background dark)) (:foreground "red" :bold t))
- (t (:bold t))))
- "Face for deadlines and TODO keywords."
+(defface org-drawer ;; font-lock-function-name-face
+ (org-compatible-face nil
+ '((((class color) (min-colors 88) (background light)) (:foreground "Blue1"))
+ (((class color) (min-colors 88) (background dark)) (:foreground "LightSkyBlue"))
+ (((class color) (min-colors 16) (background light)) (:foreground "Blue"))
+ (((class color) (min-colors 16) (background dark)) (:foreground "LightSkyBlue"))
+ (((class color) (min-colors 8)) (:foreground "blue" :bold t))
+ (t (:bold t))))
+ "Face used for drawers."
:group 'org-faces)
-(defface org-headline-done ;; font-lock-string-face
- (org-compatible-face
- '((((class color) (min-colors 16) (background light)) (:foreground "RosyBrown"))
- (((class color) (min-colors 16) (background dark)) (:foreground "LightSalmon"))
- (((class color) (min-colors 8) (background light)) (:bold nil))))
- "Face used to indicate that a headline is DONE.
-This face is only used if `org-fontify-done-headline' is set."
+(defface org-property-value nil
+ "Face used for the value of a property."
+ :group 'org-faces)
+
+(defface org-column
+ (org-compatible-face nil
+ '((((class color) (min-colors 16) (background light))
+ (:background "grey90"))
+ (((class color) (min-colors 16) (background dark))
+ (:background "grey30"))
+ (((class color) (min-colors 8))
+ (:background "cyan" :foreground "black"))
+ (t (:inverse-video t))))
+ "Face for column display of entry properties."
+ :group 'org-faces)
+
+(when (fboundp 'set-face-attribute)
+ ;; Make sure that a fixed-width face is used when we have a column table.
+ (set-face-attribute 'org-column nil
+ :height (face-attribute 'default :height)
+ :family (face-attribute 'default :family)))
+
+(defface org-warning
+ (org-compatible-face 'font-lock-warning-face
+ '((((class color) (min-colors 16) (background light)) (:foreground "Red1" :bold t))
+ (((class color) (min-colors 16) (background dark)) (:foreground "Pink" :bold t))
+ (((class color) (min-colors 8) (background light)) (:foreground "red" :bold t))
+ (((class color) (min-colors 8) (background dark)) (:foreground "red" :bold t))
+ (t (:bold t))))
+ "Face for deadlines and TODO keywords."
:group 'org-faces)
(defface org-archived ; similar to shadow
- (org-compatible-face
- '((((class color grayscale) (min-colors 88) (background light))
- (:foreground "grey50"))
- (((class color grayscale) (min-colors 88) (background dark))
- (:foreground "grey70"))
- (((class color) (min-colors 8) (background light))
- (:foreground "green"))
- (((class color) (min-colors 8) (background dark))
- (:foreground "yellow"))))
- "Face for headline with the ARCHIVE tag."
- :group 'org-faces)
+ (org-compatible-face 'shadow
+ '((((class color grayscale) (min-colors 88) (background light))
+ (:foreground "grey50"))
+ (((class color grayscale) (min-colors 88) (background dark))
+ (:foreground "grey70"))
+ (((class color) (min-colors 8) (background light))
+ (:foreground "green"))
+ (((class color) (min-colors 8) (background dark))
+ (:foreground "yellow"))))
+ "Face for headline with the ARCHIVE tag."
+ :group 'org-faces)
(defface org-link
'((((class color) (background light)) (:foreground "Purple" :underline t))
"Face for links."
:group 'org-faces)
+(defface org-ellipsis
+ '((((class color) (background light)) (:foreground "DarkGoldenrod" :underline t))
+ (((class color) (background dark)) (:foreground "LightGoldenrod" :underline t))
+ (t (:strike-through t)))
+ "Face for the ellipsis in folded text."
+ :group 'org-faces)
+
+(defface org-target
+ '((((class color) (background light)) (:underline t))
+ (((class color) (background dark)) (:underline t))
+ (t (:underline t)))
+ "Face for links."
+ :group 'org-faces)
+
(defface org-date
'((((class color) (background light)) (:foreground "Purple" :underline t))
(((class color) (background dark)) (:foreground "Cyan" :underline t))
"Face for links."
:group 'org-faces)
+(defface org-sexp-date
+ '((((class color) (background light)) (:foreground "Purple"))
+ (((class color) (background dark)) (:foreground "Cyan"))
+ (t (:underline t)))
+ "Face for links."
+ :group 'org-faces)
+
(defface org-tag
'((t (:bold t)))
"Face for tags."
:group 'org-faces)
-(defface org-todo ;; font-lock-warning-face
- (org-compatible-face
- '((((class color) (min-colors 16) (background light)) (:foreground "Red1" :bold t))
- (((class color) (min-colors 16) (background dark)) (:foreground "Pink" :bold t))
- (((class color) (min-colors 8) (background light)) (:foreground "red" :bold t))
- (((class color) (min-colors 8) (background dark)) (:foreground "red" :bold t))
- (t (:inverse-video t :bold t))))
+(defface org-todo ; font-lock-warning-face
+ (org-compatible-face nil
+ '((((class color) (min-colors 16) (background light)) (:foreground "Red1" :bold t))
+ (((class color) (min-colors 16) (background dark)) (:foreground "Pink" :bold t))
+ (((class color) (min-colors 8) (background light)) (:foreground "red" :bold t))
+ (((class color) (min-colors 8) (background dark)) (:foreground "red" :bold t))
+ (t (:inverse-video t :bold t))))
"Face for TODO keywords."
:group 'org-faces)
(defface org-done ;; font-lock-type-face
- (org-compatible-face
- '((((class color) (min-colors 16) (background light)) (:foreground "ForestGreen" :bold t))
- (((class color) (min-colors 16) (background dark)) (:foreground "PaleGreen" :bold t))
- (((class color) (min-colors 8)) (:foreground "green"))
- (t (:bold t))))
- "Face used for DONE."
+ (org-compatible-face nil
+ '((((class color) (min-colors 16) (background light)) (:foreground "ForestGreen" :bold t))
+ (((class color) (min-colors 16) (background dark)) (:foreground "PaleGreen" :bold t))
+ (((class color) (min-colors 8)) (:foreground "green"))
+ (t (:bold t))))
+ "Face used for todo keywords that indicate DONE items."
+ :group 'org-faces)
+
+(defface org-headline-done ;; font-lock-string-face
+ (org-compatible-face nil
+ '((((class color) (min-colors 16) (background light)) (:foreground "RosyBrown"))
+ (((class color) (min-colors 16) (background dark)) (:foreground "LightSalmon"))
+ (((class color) (min-colors 8) (background light)) (:bold nil))))
+ "Face used to indicate that a headline is DONE.
+This face is only used if `org-fontify-done-headline' is set. If applies
+to the part of the headline after the DONE keyword."
:group 'org-faces)
+(defcustom org-todo-keyword-faces nil
+ "Faces for specific TODO keywords.
+This is a list of cons cells, with TODO keywords in the car
+and faces in the cdr. The face can be a symbol, or a property
+list of attributes, like (:foreground \"blue\" :weight bold :underline t)."
+ :group 'org-faces
+ :group 'org-todo
+ :type '(repeat
+ (cons
+ (string :tag "keyword")
+ (sexp :tag "face"))))
+
(defface org-table ;; font-lock-function-name-face
- (org-compatible-face
- '((((class color) (min-colors 88) (background light)) (:foreground "Blue1"))
- (((class color) (min-colors 88) (background dark)) (:foreground "LightSkyBlue"))
- (((class color) (min-colors 16) (background light)) (:foreground "Blue"))
- (((class color) (min-colors 16) (background dark)) (:foreground "LightSkyBlue"))
- (((class color) (min-colors 8) (background light)) (:foreground "blue"))
- (((class color) (min-colors 8) (background dark)))))
+ (org-compatible-face nil
+ '((((class color) (min-colors 88) (background light)) (:foreground "Blue1"))
+ (((class color) (min-colors 88) (background dark)) (:foreground "LightSkyBlue"))
+ (((class color) (min-colors 16) (background light)) (:foreground "Blue"))
+ (((class color) (min-colors 16) (background dark)) (:foreground "LightSkyBlue"))
+ (((class color) (min-colors 8) (background light)) (:foreground "blue"))
+ (((class color) (min-colors 8) (background dark)))))
"Face used for tables."
:group 'org-faces)
(defface org-formula
- (org-compatible-face
- '((((class color) (min-colors 88) (background light)) (:foreground "Firebrick"))
- (((class color) (min-colors 88) (background dark)) (:foreground "chocolate1"))
- (((class color) (min-colors 8) (background light)) (:foreground "red"))
- (((class color) (min-colors 8) (background dark)) (:foreground "red"))
- (t (:bold t :italic t))))
+ (org-compatible-face nil
+ '((((class color) (min-colors 88) (background light)) (:foreground "Firebrick"))
+ (((class color) (min-colors 88) (background dark)) (:foreground "chocolate1"))
+ (((class color) (min-colors 8) (background light)) (:foreground "red"))
+ (((class color) (min-colors 8) (background dark)) (:foreground "red"))
+ (t (:bold t :italic t))))
"Face for formulas."
:group 'org-faces)
+(defface org-code
+ (org-compatible-face nil
+ '((((class color grayscale) (min-colors 88) (background light))
+ (:foreground "grey50"))
+ (((class color grayscale) (min-colors 88) (background dark))
+ (:foreground "grey70"))
+ (((class color) (min-colors 8) (background light))
+ (:foreground "green"))
+ (((class color) (min-colors 8) (background dark))
+ (:foreground "yellow"))))
+ "Face for fixed-with text like code snippets."
+ :group 'org-faces
+ :version "22.1")
+
+(defface org-verbatim
+ (org-compatible-face nil
+ '((((class color grayscale) (min-colors 88) (background light))
+ (:foreground "grey50" :underline t))
+ (((class color grayscale) (min-colors 88) (background dark))
+ (:foreground "grey70" :underline t))
+ (((class color) (min-colors 8) (background light))
+ (:foreground "green" :underline t))
+ (((class color) (min-colors 8) (background dark))
+ (:foreground "yellow" :underline t))))
+ "Face for fixed-with text like code snippets."
+ :group 'org-faces
+ :version "22.1")
+
+(defface org-agenda-structure ;; font-lock-function-name-face
+ (org-compatible-face nil
+ '((((class color) (min-colors 88) (background light)) (:foreground "Blue1"))
+ (((class color) (min-colors 88) (background dark)) (:foreground "LightSkyBlue"))
+ (((class color) (min-colors 16) (background light)) (:foreground "Blue"))
+ (((class color) (min-colors 16) (background dark)) (:foreground "LightSkyBlue"))
+ (((class color) (min-colors 8)) (:foreground "blue" :bold t))
+ (t (:bold t))))
+ "Face used in agenda for captions and dates."
+ :group 'org-faces)
+
(defface org-scheduled-today
- (org-compatible-face
- '((((class color) (min-colors 88) (background light)) (:foreground "DarkGreen"))
- (((class color) (min-colors 88) (background dark)) (:foreground "PaleGreen"))
- (((class color) (min-colors 8)) (:foreground "green"))
- (t (:bold t :italic t))))
+ (org-compatible-face nil
+ '((((class color) (min-colors 88) (background light)) (:foreground "DarkGreen"))
+ (((class color) (min-colors 88) (background dark)) (:foreground "PaleGreen"))
+ (((class color) (min-colors 8)) (:foreground "green"))
+ (t (:bold t :italic t))))
"Face for items scheduled for a certain day."
:group 'org-faces)
(defface org-scheduled-previously
- (org-compatible-face
- '((((class color) (min-colors 88) (background light)) (:foreground "Firebrick"))
- (((class color) (min-colors 88) (background dark)) (:foreground "chocolate1"))
- (((class color) (min-colors 8) (background light)) (:foreground "red"))
- (((class color) (min-colors 8) (background dark)) (:foreground "red" :bold t))
- (t (:bold t))))
+ (org-compatible-face nil
+ '((((class color) (min-colors 88) (background light)) (:foreground "Firebrick"))
+ (((class color) (min-colors 88) (background dark)) (:foreground "chocolate1"))
+ (((class color) (min-colors 8) (background light)) (:foreground "red"))
+ (((class color) (min-colors 8) (background dark)) (:foreground "red" :bold t))
+ (t (:bold t))))
"Face for items scheduled previously, and not yet done."
:group 'org-faces)
(defface org-upcoming-deadline
- (org-compatible-face
- '((((class color) (min-colors 88) (background light)) (:foreground "Firebrick"))
- (((class color) (min-colors 88) (background dark)) (:foreground "chocolate1"))
- (((class color) (min-colors 8) (background light)) (:foreground "red"))
- (((class color) (min-colors 8) (background dark)) (:foreground "red" :bold t))
- (t (:bold t))))
+ (org-compatible-face nil
+ '((((class color) (min-colors 88) (background light)) (:foreground "Firebrick"))
+ (((class color) (min-colors 88) (background dark)) (:foreground "chocolate1"))
+ (((class color) (min-colors 8) (background light)) (:foreground "red"))
+ (((class color) (min-colors 8) (background dark)) (:foreground "red" :bold t))
+ (t (:bold t))))
"Face for items scheduled previously, and not yet done."
:group 'org-faces)
+(defcustom org-agenda-deadline-faces
+ '((1.0 . org-warning)
+ (0.5 . org-upcoming-deadline)
+ (0.0 . default))
+ "Faces for showing deadlines in the agenda.
+This is a list of cons cells. The cdr of each cell is a face to be used,
+and it can also just be like '(:foreground \"yellow\").
+Each car is a fraction of the head-warning time that must have passed for
+this the face in the cdr to be used for display. The numbers must be
+given in descending order. The head-warning time is normally taken
+from `org-deadline-warning-days', but can also be specified in the deadline
+timestamp itself, like this:
+
+ DEADLINE: <2007-08-13 Mon -8d>
+
+You may use d for days, w for weeks, m for months and y for years. Months
+and years will only be treated in an approximate fashion (30.4 days for a
+month and 365.24 days for a year)."
+ :group 'org-faces
+ :group 'org-agenda-daily/weekly
+ :type '(repeat
+ (cons
+ (number :tag "Fraction of head-warning time passed")
+ (sexp :tag "Face"))))
+
+;; FIXME: this is not a good face yet.
+(defface org-agenda-restriction-lock
+ (org-compatible-face nil
+ '((((class color) (min-colors 88) (background light)) (:background "yellow1"))
+ (((class color) (min-colors 88) (background dark)) (:background "skyblue4"))
+ (((class color) (min-colors 16) (background light)) (:background "yellow1"))
+ (((class color) (min-colors 16) (background dark)) (:background "skyblue4"))
+ (((class color) (min-colors 8)) (:background "cyan" :foreground "black"))
+ (t (:inverse-video t))))
+ "Face for showing the agenda restriction lock."
+ :group 'org-faces)
+
(defface org-time-grid ;; font-lock-variable-name-face
- (org-compatible-face
- '((((class color) (min-colors 16) (background light)) (:foreground "DarkGoldenrod"))
- (((class color) (min-colors 16) (background dark)) (:foreground "LightGoldenrod"))
- (((class color) (min-colors 8)) (:foreground "yellow" :weight light))))
+ (org-compatible-face nil
+ '((((class color) (min-colors 16) (background light)) (:foreground "DarkGoldenrod"))
+ (((class color) (min-colors 16) (background dark)) (:foreground "LightGoldenrod"))
+ (((class color) (min-colors 8)) (:foreground "yellow" :weight light))))
"Face used for time grids."
:group 'org-faces)
'(org-level-1 org-level-2 org-level-3 org-level-4
org-level-5 org-level-6 org-level-7 org-level-8
))
-(defconst org-n-levels (length org-level-faces))
+(defcustom org-n-level-faces (length org-level-faces)
+ "The number of different faces to be used for headlines.
+Org-mode defines 8 different headline faces, so this can be at most 8.
+If it is less than 8, the level-1 face gets re-used for level N+1 etc."
+ :type 'number
+ :group 'org-faces)
+
+;;; Variables from ther packages declared here to avoid compiler warnings
+
+;; XEmacs only
+(defvar outline-mode-menu-heading)
+(defvar outline-mode-menu-show)
+(defvar outline-mode-menu-hide)
+(defvar zmacs-regions) ; XEmacs regions
+
+;; Emacs only
+(defvar mark-active)
+
+;; Various packages
+;; FIXME: get the argument lists for the UNKNOWN stuff
+(defvar calc-embedded-close-formula)
+(defvar calc-embedded-open-formula)
+(defvar calendar-mode-map)
+(defvar original-date) ; dynamically scoped in calendar.el does scope this
+(defvar font-lock-unfontify-region-function)
+(defvar gnus-other-frame-object)
+(defvar gnus-group-name)
+(defvar gnus-article-current)
+(defvar Info-current-file)
+(defvar Info-current-node)
+(defvar mh-progs)
+(defvar mh-current-folder)
+(defvar mh-show-folder-buffer)
+(defvar mh-index-folder)
+(defvar mh-searcher)
+
+(defvar remember-save-after-remembering)
+(defvar remember-data-file)
+(defvar remember-register)
+(defvar remember-buffer)
+(defvar remember-handler-functions)
+(defvar remember-annotation-functions)
+(defvar rmail-current-message)
+(defvar texmathp-why)
+(defvar vm-message-pointer)
+(defvar vm-folder-directory)
+(defvar w3m-current-url)
+(defvar w3m-current-title)
+;; backward compatibility to old version of wl
+(defvar wl-summary-buffer-elmo-folder)
+(defvar wl-summary-buffer-folder-name)
+
+(defvar org-latex-regexps)
+(defvar constants-unit-system)
;;; Variables for pre-computed regular expressions, all buffer local
-(defvar org-done-string nil
- "The last string in `org-todo-keywords', indicating an item is DONE.")
-(make-variable-buffer-local 'org-done-string)
+(defvar org-drawer-regexp nil
+ "Matches first line of a hidden block.")
+(make-variable-buffer-local 'org-drawer-regexp)
(defvar org-todo-regexp nil
"Matches any of the TODO state keywords.")
(make-variable-buffer-local 'org-todo-regexp)
(defvar org-todo-line-regexp nil
"Matches a headline and puts TODO state into group 2 if present.")
(make-variable-buffer-local 'org-todo-line-regexp)
+(defvar org-complex-heading-regexp nil
+ "Matches a headline and puts everything into groups:
+group 1: the stars
+group 2: The todo keyword, maybe
+group 3: Priority cookie
+group 4: True headline
+group 5: Tags")
+(make-variable-buffer-local 'org-complex-heading-regexp)
(defvar org-todo-line-tags-regexp nil
"Matches a headline and puts TODO state into group 2 if present.
Also put tags into group 4 if tags are present.")
(defvar org-looking-at-done-regexp nil
"Matches the DONE keyword a point.")
(make-variable-buffer-local 'org-looking-at-done-regexp)
-(defvar org-todo-kwd-priority-p nil
- "Do TODO items have priorities?")
-(make-variable-buffer-local 'org-todo-kwd-priority-p)
-(defvar org-todo-kwd-max-priority nil
- "Maximum priority of TODO items.")
-(make-variable-buffer-local 'org-todo-kwd-max-priority)
(defvar org-ds-keyword-length 12
"Maximum length of the Deadline and SCHEDULED keywords.")
(make-variable-buffer-local 'org-ds-keyword-length)
(defvar org-maybe-keyword-time-regexp nil
"Matches a timestamp, possibly preceeded by a keyword.")
(make-variable-buffer-local 'org-maybe-keyword-time-regexp)
+(defvar org-planning-or-clock-line-re nil
+ "Matches a line with planning or clock info.")
+(make-variable-buffer-local 'org-planning-or-clock-line-re)
(defconst org-rm-props '(invisible t face t keymap t intangible t mouse-face t
rear-nonsticky t mouse-map t fontified t)
(match-string-no-properties num string)))
(defsubst org-no-properties (s)
- (remove-text-properties 0 (length s) org-rm-props s)
+ (if (fboundp 'set-text-properties)
+ (set-text-properties 0 (length s) nil s)
+ (remove-text-properties 0 (length s) org-rm-props s))
s)
(defsubst org-get-alist-option (option key)
((assoc key option) (cdr (assoc key option)))
(t (cdr (assq 'default option)))))
+(defsubst org-inhibit-invisibility ()
+ "Modified `buffer-invisibility-spec' for Emacs 21.
+Some ops with invisible text do not work correctly on Emacs 21. For these
+we turn off invisibility temporarily. Use this in a `let' form."
+ (if (< emacs-major-version 22) nil buffer-invisibility-spec))
+
(defsubst org-set-local (var value)
"Make VAR local in current buffer and set it to VALUE."
(set (make-variable-buffer-local var) value))
("align" org-startup-align-all-tables t)
("noalign" org-startup-align-all-tables nil)
("customtime" org-display-custom-times t)
- ("logging" org-log-done t)
- ("logdone" org-log-done t)
- ("nologging" org-log-done nil)
- ("lognotedone" org-log-done done push)
- ("lognotestate" org-log-done state push)
- ("lognoteclock-out" org-log-done clock-out push))
+ ("logdone" org-log-done time)
+ ("lognotedone" org-log-done note)
+ ("nologdone" org-log-done nil)
+ ("lognoteclock-out" org-log-note-clock-out t)
+ ("nolognoteclock-out" org-log-note-clock-out nil)
+ ("logrepeat" org-log-repeat state)
+ ("lognoterepeat" org-log-repeat note)
+ ("nologrepeat" org-log-repeat nil)
+ ("constcgs" constants-unit-system cgs)
+ ("constSI" constants-unit-system SI))
"Variable associated with STARTUP options for org-mode.
Each element is a list of three items: The startup options as written
in the #+STARTUP line, the corresponding variable, and the value to
(defun org-set-regexps-and-options ()
"Precompute regular expressions for current buffer."
(when (org-mode-p)
+ (org-set-local 'org-todo-kwd-alist nil)
+ (org-set-local 'org-todo-key-alist nil)
+ (org-set-local 'org-todo-key-trigger nil)
+ (org-set-local 'org-todo-keywords-1 nil)
+ (org-set-local 'org-done-keywords nil)
+ (org-set-local 'org-todo-heads nil)
+ (org-set-local 'org-todo-sets nil)
+ (org-set-local 'org-todo-log-states nil)
(let ((re (org-make-options-regexp
- '("CATEGORY" "SEQ_TODO" "PRI_TODO" "TYP_TODO"
- "STARTUP" "ARCHIVE" "TAGS" "LINK")))
+ '("CATEGORY" "SEQ_TODO" "TYP_TODO" "TODO" "COLUMNS"
+ "STARTUP" "ARCHIVE" "TAGS" "LINK" "PRIORITIES"
+ "CONSTANTS" "PROPERTY" "DRAWERS")))
(splitre "[ \t]+")
- kwds int key value cat arch tags links)
+ kwds kws0 kwsa key log value cat arch tags const links hw dws
+ tail sep kws1 prio props drawers)
(save-excursion
(save-restriction
(widen)
((equal key "CATEGORY")
(if (string-match "[ \t]+$" value)
(setq value (replace-match "" t t value)))
- (setq cat (intern value)))
- ((equal key "SEQ_TODO")
- (setq int 'sequence
- kwds (append kwds (org-split-string value splitre))))
- ((equal key "PRI_TODO")
- (setq int 'priority
- kwds (append kwds (org-split-string value splitre))))
+ (setq cat value))
+ ((member key '("SEQ_TODO" "TODO"))
+ (push (cons 'sequence (org-split-string value splitre)) kwds))
((equal key "TYP_TODO")
- (setq int 'type
- kwds (append kwds (org-split-string value splitre))))
+ (push (cons 'type (org-split-string value splitre)) kwds))
((equal key "TAGS")
(setq tags (append tags (org-split-string value splitre))))
+ ((equal key "COLUMNS")
+ (org-set-local 'org-columns-default-format value))
((equal key "LINK")
(when (string-match "^\\(\\S-+\\)[ \t]+\\(.+\\)" value)
(push (cons (match-string 1 value)
(org-trim (match-string 2 value)))
links)))
+ ((equal key "PRIORITIES")
+ (setq prio (org-split-string value " +")))
+ ((equal key "PROPERTY")
+ (when (string-match "\\(\\S-+\\)\\s-+\\(.*\\)" value)
+ (push (cons (match-string 1 value) (match-string 2 value))
+ props)))
+ ((equal key "DRAWERS")
+ (setq drawers (org-split-string value splitre)))
+ ((equal key "CONSTANTS")
+ (setq const (append const (org-split-string value splitre))))
((equal key "STARTUP")
(let ((opts (org-split-string value splitre))
l var val)
- (while (setq l (assoc (pop opts) org-startup-options))
- (setq var (nth 1 l) val (nth 2 l))
- (if (not (nth 3 l))
- (set (make-local-variable var) val)
- (if (not (listp (symbol-value var)))
- (set (make-local-variable var) nil))
- (set (make-local-variable var) (symbol-value var))
- (add-to-list var val)))))
+ (while (setq l (pop opts))
+ (when (setq l (assoc l org-startup-options))
+ (setq var (nth 1 l) val (nth 2 l))
+ (if (not (nth 3 l))
+ (set (make-local-variable var) val)
+ (if (not (listp (symbol-value var)))
+ (set (make-local-variable var) nil))
+ (set (make-local-variable var) (symbol-value var))
+ (add-to-list var val))))))
((equal key "ARCHIVE")
(string-match " *$" value)
(setq arch (replace-match "" t t value))
(remove-text-properties 0 (length arch)
'(face t fontified t) arch)))
)))
- (and cat (org-set-local 'org-category cat))
- (and kwds (org-set-local 'org-todo-keywords kwds))
+ (when cat
+ (org-set-local 'org-category (intern cat))
+ (push (cons "CATEGORY" cat) props))
+ (when prio
+ (if (< (length prio) 3) (setq prio '("A" "C" "B")))
+ (setq prio (mapcar 'string-to-char prio))
+ (org-set-local 'org-highest-priority (nth 0 prio))
+ (org-set-local 'org-lowest-priority (nth 1 prio))
+ (org-set-local 'org-default-priority (nth 2 prio)))
+ (and props (org-set-local 'org-local-properties (nreverse props)))
+ (and drawers (org-set-local 'org-drawers drawers))
(and arch (org-set-local 'org-archive-location arch))
- (and int (org-set-local 'org-todo-interpretation int))
(and links (setq org-link-abbrev-alist-local (nreverse links)))
+ ;; Process the TODO keywords
+ (unless kwds
+ ;; Use the global values as if they had been given locally.
+ (setq kwds (default-value 'org-todo-keywords))
+ (if (stringp (car kwds))
+ (setq kwds (list (cons org-todo-interpretation
+ (default-value 'org-todo-keywords)))))
+ (setq kwds (reverse kwds)))
+ (setq kwds (nreverse kwds))
+ (let (inter kws kw)
+ (while (setq kws (pop kwds))
+ (setq inter (pop kws) sep (member "|" kws)
+ kws0 (delete "|" (copy-sequence kws))
+ kwsa nil
+ kws1 (mapcar
+ (lambda (x)
+ ;; 1 2
+ (if (string-match "^\\(.*?\\)\\(?:(\\([^!@/]\\)?.*?)\\)?$" x)
+ (progn
+ (setq kw (match-string 1 x)
+ key (and (match-end 2) (match-string 2 x))
+ log (org-extract-log-state-settings x))
+ (push (cons kw (and key (string-to-char key))) kwsa)
+ (and log (push log org-todo-log-states))
+ kw)
+ (error "Invalid TODO keyword %s" x)))
+ kws0)
+ kwsa (if kwsa (append '((:startgroup))
+ (nreverse kwsa)
+ '((:endgroup))))
+ hw (car kws1)
+ dws (if sep (org-remove-keyword-keys (cdr sep)) (last kws1))
+ tail (list inter hw (car dws) (org-last dws)))
+ (add-to-list 'org-todo-heads hw 'append)
+ (push kws1 org-todo-sets)
+ (setq org-done-keywords (append org-done-keywords dws nil))
+ (setq org-todo-key-alist (append org-todo-key-alist kwsa))
+ (mapc (lambda (x) (push (cons x tail) org-todo-kwd-alist)) kws1)
+ (setq org-todo-keywords-1 (append org-todo-keywords-1 kws1 nil)))
+ (setq org-todo-sets (nreverse org-todo-sets)
+ org-todo-kwd-alist (nreverse org-todo-kwd-alist)
+ org-todo-key-trigger (delq nil (mapcar 'cdr org-todo-key-alist))
+ org-todo-key-alist (org-assign-fast-keys org-todo-key-alist)))
+ ;; Process the constants
+ (when const
+ (let (e cst)
+ (while (setq e (pop const))
+ (if (string-match "^\\([a-zA-Z0][_a-zA-Z0-9]*\\)=\\(.*\\)" e)
+ (push (cons (match-string 1 e) (match-string 2 e)) cst)))
+ (setq org-table-formula-constants-local cst)))
+
+ ;; Process the tags.
(when tags
(let (e tgs)
(while (setq e (pop tags))
(cond
((equal e "{") (push '(:startgroup) tgs))
((equal e "}") (push '(:endgroup) tgs))
- ((string-match "^\\([0-9a-zA-Z_@]+\\)(\\(.\\))$" e)
+ ((string-match (org-re "^\\([[:alnum:]_@]+\\)(\\(.\\))$") e)
(push (cons (match-string 1 e)
(string-to-char (match-string 2 e)))
tgs))
(push e org-tag-alist))))))
;; Compute the regular expressions and other local variables
- (setq org-todo-kwd-priority-p (equal org-todo-interpretation 'priority)
- org-todo-kwd-max-priority (1- (length org-todo-keywords))
- org-ds-keyword-length (+ 2 (max (length org-deadline-string)
+ (if (not org-done-keywords)
+ (setq org-done-keywords (list (org-last org-todo-keywords-1))))
+ (setq org-ds-keyword-length (+ 2 (max (length org-deadline-string)
(length org-scheduled-string)))
- org-done-string
- (nth (1- (length org-todo-keywords)) org-todo-keywords)
+ org-drawer-regexp
+ (concat "^[ \t]*:\\("
+ (mapconcat 'regexp-quote org-drawers "\\|")
+ "\\):[ \t]*$")
+ org-not-done-keywords
+ (org-delete-all org-done-keywords (copy-sequence org-todo-keywords-1))
org-todo-regexp
- (concat "\\<\\(" (mapconcat 'regexp-quote org-todo-keywords
+ (concat "\\<\\(" (mapconcat 'regexp-quote org-todo-keywords-1
"\\|") "\\)\\>")
org-not-done-regexp
(concat "\\<\\("
- (mapconcat 'regexp-quote
- (nreverse (cdr (reverse org-todo-keywords)))
- "\\|")
+ (mapconcat 'regexp-quote org-not-done-keywords "\\|")
"\\)\\>")
org-todo-line-regexp
- (concat "^\\(\\*+\\)[ \t]*\\(?:\\("
- (mapconcat 'regexp-quote org-todo-keywords "\\|")
- "\\)\\>\\)? *\\(.*\\)")
+ (concat "^\\(\\*+\\)[ \t]+\\(?:\\("
+ (mapconcat 'regexp-quote org-todo-keywords-1 "\\|")
+ "\\)\\>\\)?[ \t]*\\(.*\\)")
+ org-complex-heading-regexp
+ (concat "^\\(\\*+\\)\\(?:[ \t]+\\("
+ (mapconcat 'regexp-quote org-todo-keywords-1 "\\|")
+ "\\)\\>\\)?\\(?:[ \t]*\\(\\[#.\\]\\)\\)?[ \t]*\\(.*?\\)"
+ "\\(?:[ \t]+\\(:[[:alnum:]_@:]+:\\)\\)?[ \t]*$")
org-nl-done-regexp
- (concat "[\r\n]\\*+[ \t]+" org-done-string "\\>")
+ (concat "\n\\*+[ \t]+"
+ "\\(?:" (mapconcat 'regexp-quote org-done-keywords "\\|")
+ "\\)" "\\>")
org-todo-line-tags-regexp
- (concat "^\\(\\*+\\)[ \t]*\\(?:\\("
- (mapconcat 'regexp-quote org-todo-keywords "\\|")
- "\\)\\>\\)? *\\(.*?\\([ \t]:[a-zA-Z0-9:_@]+:[ \t]*\\)?$\\)")
- org-looking-at-done-regexp (concat "^" org-done-string "\\>")
+ (concat "^\\(\\*+\\)[ \t]+\\(?:\\("
+ (mapconcat 'regexp-quote org-todo-keywords-1 "\\|")
+ (org-re
+ "\\)\\>\\)? *\\(.*?\\([ \t]:[[:alnum:]:_@]+:[ \t]*\\)?$\\)"))
+ org-looking-at-done-regexp
+ (concat "^" "\\(?:"
+ (mapconcat 'regexp-quote org-done-keywords "\\|") "\\)"
+ "\\>")
org-deadline-regexp (concat "\\<" org-deadline-string)
org-deadline-time-regexp
(concat "\\<" org-deadline-string " *<\\([^>]+\\)>")
org-keyword-time-not-clock-regexp
(concat "\\<\\(" org-scheduled-string
"\\|" org-deadline-string
- "\\|" org-closed-string "\\)"
+ "\\|" org-closed-string
+ "\\)"
" *[[<]\\([^]>]+\\)[]>]")
org-maybe-keyword-time-regexp
(concat "\\(\\<\\(" org-scheduled-string
"\\|" org-deadline-string
"\\|" org-closed-string
"\\|" org-clock-string "\\)\\)?"
- " *\\([[<][0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\}[^]\r\n>]*?[]>]\\)"))
-
+ " *\\([[<][0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\} [^]\r\n>]*?[]>]\\|<%%([^\r\n>]*>\\)")
+ org-planning-or-clock-line-re
+ (concat "\\(?:^[ \t]*\\(" org-scheduled-string
+ "\\|" org-deadline-string
+ "\\|" org-closed-string "\\|" org-clock-string
+ "\\)\\>\\)")
+ )
+ (org-compute-latex-and-specials-regexp)
(org-set-font-lock-defaults)))
+(defun org-extract-log-state-settings (x)
+ "Extract the log state setting from a TODO keyword string.
+This will extract info from a string like \"WAIT(w@/!)\"."
+ (let (kw key log1 log2)
+ (when (string-match "^\\(.*?\\)\\(?:(\\([^!@/]\\)?\\([!@]\\)?\\(?:/\\([!@]\\)\\)?)\\)?$" x)
+ (setq kw (match-string 1 x)
+ key (and (match-end 2) (match-string 2 x))
+ log1 (and (match-end 3) (match-string 3 x))
+ log2 (and (match-end 4) (match-string 4 x)))
+ (and (or log1 log2)
+ (list kw
+ (and log1 (if (equal log1 "!") 'time 'note))
+ (and log2 (if (equal log2 "!") 'time 'note)))))))
+
+(defun org-remove-keyword-keys (list)
+ "Remove a pair of parenthesis at the end of each string in LIST."
+ (mapcar (lambda (x)
+ (if (string-match "(.*)$" x)
+ (substring x 0 (match-beginning 0))
+ x))
+ list))
+
+;; FIXME: this could be done much better, using second characters etc.
+(defun org-assign-fast-keys (alist)
+ "Assign fast keys to a keyword-key alist.
+Respect keys that are already there."
+ (let (new e k c c1 c2 (char ?a))
+ (while (setq e (pop alist))
+ (cond
+ ((equal e '(:startgroup)) (push e new))
+ ((equal e '(:endgroup)) (push e new))
+ (t
+ (setq k (car e) c2 nil)
+ (if (cdr e)
+ (setq c (cdr e))
+ ;; automatically assign a character.
+ (setq c1 (string-to-char
+ (downcase (substring
+ k (if (= (string-to-char k) ?@) 1 0)))))
+ (if (or (rassoc c1 new) (rassoc c1 alist))
+ (while (or (rassoc char new) (rassoc char alist))
+ (setq char (1+ char)))
+ (setq c2 c1))
+ (setq c (or c2 char)))
+ (push (cons k c) new))))
+ (nreverse new)))
;;; Some variables ujsed in various places
"Function to be called when `C-c C-c' is used.
This is for getting out of special buffers like remember.")
-;;; Foreign variables, to inform the compiler
-
-;; XEmacs only
-(defvar outline-mode-menu-heading)
-(defvar outline-mode-menu-show)
-(defvar outline-mode-menu-hide)
-(defvar zmacs-regions) ; XEmacs regions
-;; Emacs only
-(defvar mark-active)
-
-;; Packages that org-mode interacts with
-(defvar calc-embedded-close-formula)
-(defvar calc-embedded-open-formula)
-(defvar font-lock-unfontify-region-function)
-(defvar org-goto-start-pos)
-(defvar vm-message-pointer)
-(defvar vm-folder-directory)
-(defvar wl-summary-buffer-elmo-folder)
-(defvar wl-summary-buffer-folder-name)
-(defvar gnus-other-frame-object)
-(defvar gnus-group-name)
-(defvar gnus-article-current)
-(defvar w3m-current-url)
-(defvar w3m-current-title)
-(defvar mh-progs)
-(defvar mh-current-folder)
-(defvar mh-show-folder-buffer)
-(defvar mh-index-folder)
-(defvar mh-searcher)
-(defvar calendar-mode-map)
-(defvar Info-current-file)
-(defvar Info-current-node)
-(defvar texmathp-why)
-(defvar remember-save-after-remembering)
-(defvar remember-data-file)
-(defvar annotation) ; from remember.el, dynamically scoped in `remember-mode'
-(defvar initial) ; from remember.el, dynamically scoped in `remember-mode'
-(defvar org-latex-regexps)
-
-(defvar original-date) ; dynamically scoped in calendar.el does scope this
;; FIXME: Occasionally check by commenting these, to make sure
;; no other functions uses these, forgetting to let-bind them.
(defvar date)
(defvar description)
-
;; Defined somewhere in this file, but used before definition.
(defvar orgtbl-mode-menu) ; defined when orgtbl mode get initialized
+(defvar org-agenda-buffer-name)
(defvar org-agenda-undo-list)
(defvar org-agenda-pending-undo-list)
(defvar org-agenda-overriding-header)
(defvar org-org-menu)
(defvar org-tbl-menu)
(defvar org-agenda-keymap)
-(defvar org-category-table)
;;;; Emacs/XEmacs compatibility
nil
(if (featurep 'xemacs)
(and zmacs-regions (region-active-p))
- (and transient-mark-mode mark-active))))
+ (if (fboundp 'use-region-p)
+ (use-region-p)
+ (and transient-mark-mode mark-active))))) ; Emacs 22 and before
;; Invisibility compatibility
(defvar org-mode-hook nil)
(defvar org-inhibit-startup nil) ; Dynamically-scoped param.
(defvar org-agenda-keep-modes nil) ; Dynamically-scoped param.
-
+(defvar org-table-buffer-is-an nil)
+(defconst org-outline-regexp "\\*+ ")
;;;###autoload
(define-derived-mode org-mode outline-mode "Org"
(org-add-to-invisibility-spec '(org-cwidth))
(when (featurep 'xemacs)
(org-set-local 'line-move-ignore-invisible t))
- (setq outline-regexp "\\*+")
- ;;(setq outline-regexp "\\(?:\\*+\\|[ \t]*\\(?:[-+*]\\|[0-9]+[.)]\\) \\)")
- (setq outline-level 'org-outline-level)
- (when (and org-ellipsis (stringp org-ellipsis)
- (fboundp 'set-display-table-slot) (boundp 'buffer-display-table))
+ (org-set-local 'outline-regexp org-outline-regexp)
+ (org-set-local 'outline-level 'org-outline-level)
+ (when (and org-ellipsis
+ (fboundp 'set-display-table-slot) (boundp 'buffer-display-table)
+ (fboundp 'make-glyph-code))
(unless org-display-table
(setq org-display-table (make-display-table)))
- (set-display-table-slot org-display-table
- 4 (string-to-vector org-ellipsis))
+ (set-display-table-slot
+ org-display-table 4
+ (vconcat (mapcar
+ (lambda (c) (make-glyph-code c (and (not (stringp org-ellipsis))
+ org-ellipsis)))
+ (if (stringp org-ellipsis) org-ellipsis "..."))))
(setq buffer-display-table org-display-table))
(org-set-regexps-and-options)
;; Calc embedded
(org-set-local 'calc-embedded-open-mode "# ")
(modify-syntax-entry ?# "<")
+ (modify-syntax-entry ?@ "w")
(if org-startup-truncated (setq truncate-lines t))
(org-set-local 'font-lock-unfontify-region-function
'org-unfontify-region)
(org-add-hook 'kill-buffer-hook 'org-check-running-clock nil 'local)
;; Paragraphs and auto-filling
(org-set-autofill-regexps)
+ (setq indent-line-function 'org-indent-line-function)
(org-update-radio-target-regexp)
;; Comment characters
; (org-set-local 'comment-start "#") ;; FIXME: this breaks wrapping
(org-set-local 'comment-padding " ")
+ ;; Align options lines
+ (org-set-local
+ 'align-mode-rules-list
+ '((org-in-buffer-settings
+ (regexp . "^#\\+[A-Z_]+:\\(\\s-*\\)\\S-+")
+ (modes . '(org-mode)))))
+
+ ;; Imenu
+ (org-set-local 'imenu-create-index-function
+ 'org-imenu-get-tree)
+
;; Make isearch reveal context
(if (or (featurep 'xemacs)
(not (boundp 'outline-isearch-open-invisible-function)))
(if (and org-insert-mode-line-in-empty-file
(interactive-p)
(= (point-min) (point-max)))
- (insert " -*- mode: org -*-\n\n"))
+ (insert "# -*- mode: org -*-\n\n"))
(unless org-inhibit-startup
(when org-startup-align-all-tables
(let ((bmp (buffer-modified-p)))
(org-table-map-tables 'org-table-align)
(set-buffer-modified-p bmp)))
+ (org-cycle-hide-drawers 'all)
(cond
((eq org-startup-folded t)
(org-cycle '(4)))
(let ((this-command 'org-cycle) (last-command 'org-cycle))
(org-cycle '(4)) (org-cycle '(4)))))))
+(put 'org-mode 'flyspell-mode-predicate 'org-mode-flyspell-verify)
+
(defsubst org-call-with-arg (command arg)
"Call COMMAND interactively, but pretend prefix are was ARG."
(let ((current-prefix-arg arg)) (call-interactively command)))
(defsubst org-current-line (&optional pos)
(save-excursion
(and pos (goto-char pos))
+ ;; works also in narrowed buffer, because we start at 1, not point-min
(+ (if (bolp) 1 0) (count-lines 1 (point)))))
(defun org-current-time ()
"Current time, possibly rounded to `org-time-stamp-rounding-minutes'."
- (if (> org-time-stamp-rounding-minutes 0)
- (let ((r org-time-stamp-rounding-minutes)
+ (if (> (car org-time-stamp-rounding-minutes) 1)
+ (let ((r (car org-time-stamp-rounding-minutes))
(time (decode-time)))
(apply 'encode-time
(append (list 0 (* r (floor (+ .5 (/ (float (nth 1 time)) r)))))
;;;; Font-Lock stuff, including the activators
(defvar org-mouse-map (make-sparse-keymap))
-(define-key org-mouse-map
+(org-defkey org-mouse-map
(if (featurep 'xemacs) [button2] [mouse-2]) 'org-open-at-mouse)
-(define-key org-mouse-map
+(org-defkey org-mouse-map
(if (featurep 'xemacs) [button3] [mouse-3]) 'org-find-file-at-mouse)
(when org-mouse-1-follows-link
- (define-key org-mouse-map [follow-link] 'mouse-face))
+ (org-defkey org-mouse-map [follow-link] 'mouse-face))
(when org-tab-follows-link
- (define-key org-mouse-map [(tab)] 'org-open-at-point)
- (define-key org-mouse-map "\C-i" 'org-open-at-point))
+ (org-defkey org-mouse-map [(tab)] 'org-open-at-point)
+ (org-defkey org-mouse-map "\C-i" 'org-open-at-point))
(when org-return-follows-link
- (define-key org-mouse-map [(return)] 'org-open-at-point)
- (define-key org-mouse-map "\C-m" 'org-open-at-point))
+ (org-defkey org-mouse-map [(return)] 'org-open-at-point)
+ (org-defkey org-mouse-map "\C-m" 'org-open-at-point))
(require 'font-lock)
(defconst org-non-link-chars "]\t\n\r<>")
-(defconst org-link-types '("https?" "ftp" "mailto" "file" "news" "bbdb" "vm"
- "wl" "mhe" "rmail" "gnus" "shell" "info" "elisp"))
-(defconst org-link-re-with-space
- (concat
- "<?\\(" (mapconcat 'identity org-link-types "\\|") "\\):"
- "\\([^" org-non-link-chars " ]"
- "[^" org-non-link-chars "]*"
- "[^" org-non-link-chars " ]\\)>?")
+(defvar org-link-types '("http" "https" "ftp" "mailto" "file" "news" "bbdb" "vm"
+ "wl" "mhe" "rmail" "gnus" "shell" "info" "elisp" "message"))
+(defvar org-link-re-with-space nil
"Matches a link with spaces, optional angular brackets around it.")
-
-(defconst org-link-re-with-space2
- (concat
- "<?\\(" (mapconcat 'identity org-link-types "\\|") "\\):"
- "\\([^" org-non-link-chars " ]"
- "[^]\t\n\r]*"
- "[^" org-non-link-chars " ]\\)>?")
+(defvar org-link-re-with-space2 nil
"Matches a link with spaces, optional angular brackets around it.")
-
-(defconst org-angle-link-re
- (concat
- "<\\(" (mapconcat 'identity org-link-types "\\|") "\\):"
- "\\([^" org-non-link-chars " ]"
- "[^" org-non-link-chars "]*"
- "\\)>")
+(defvar org-angle-link-re nil
"Matches link with angular brackets, spaces are allowed.")
-(defconst org-plain-link-re
- (concat
- "\\(" (mapconcat 'identity org-link-types "\\|") "\\):"
- "\\([^]\t\n\r<>,;() ]+\\)")
+(defvar org-plain-link-re nil
"Matches plain link, without spaces.")
-
-(defconst org-bracket-link-regexp
- "\\[\\[\\([^]]+\\)\\]\\(\\[\\([^]]+\\)\\]\\)?\\]"
+(defvar org-bracket-link-regexp nil
"Matches a link in double brackets.")
-
-(defconst org-bracket-link-analytic-regexp
- (concat
- "\\[\\["
- "\\(\\(" (mapconcat 'identity org-link-types "\\|") "\\):\\)?"
- "\\([^]]+\\)"
- "\\]"
- "\\(\\[" "\\([^]]+\\)" "\\]\\)?"
- "\\]"))
-; 1: http:
-; 2: http
-; 3: path
-; 4: [desc]
-; 5: desc
-
-(defconst org-any-link-re
- (concat "\\(" org-bracket-link-regexp "\\)\\|\\("
- org-angle-link-re "\\)\\|\\("
- org-plain-link-re "\\)")
+(defvar org-bracket-link-analytic-regexp nil
+ "Regular expression used to analyze links.
+Here is what the match groups contain after a match:
+1: http:
+2: http
+3: path
+4: [desc]
+5: desc")
+(defvar org-any-link-re nil
"Regular expression matching any link.")
-(defconst org-ts-lengths
- (cons (length (format-time-string (car org-time-stamp-formats)))
- (length (format-time-string (cdr org-time-stamp-formats))))
- "This holds the lengths of the two different time formats.")
-(defconst org-ts-regexp "<\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\}[^\r\n>]*?\\)>"
+(defun org-make-link-regexps ()
+ "Update the link regular expressions.
+This should be called after the variable `org-link-types' has changed."
+ (setq org-link-re-with-space
+ (concat
+ "<?\\(" (mapconcat 'identity org-link-types "\\|") "\\):"
+ "\\([^" org-non-link-chars " ]"
+ "[^" org-non-link-chars "]*"
+ "[^" org-non-link-chars " ]\\)>?")
+ org-link-re-with-space2
+ (concat
+ "<?\\(" (mapconcat 'identity org-link-types "\\|") "\\):"
+ "\\([^" org-non-link-chars " ]"
+ "[^]\t\n\r]*"
+ "[^" org-non-link-chars " ]\\)>?")
+ org-angle-link-re
+ (concat
+ "<\\(" (mapconcat 'identity org-link-types "\\|") "\\):"
+ "\\([^" org-non-link-chars " ]"
+ "[^" org-non-link-chars "]*"
+ "\\)>")
+ org-plain-link-re
+ (concat
+ "\\<\\(" (mapconcat 'identity org-link-types "\\|") "\\):"
+ "\\([^]\t\n\r<>() ]+[^]\t\n\r<>,.;() ]\\)")
+ org-bracket-link-regexp
+ "\\[\\[\\([^][]+\\)\\]\\(\\[\\([^][]+\\)\\]\\)?\\]"
+ org-bracket-link-analytic-regexp
+ (concat
+ "\\[\\["
+ "\\(\\(" (mapconcat 'identity org-link-types "\\|") "\\):\\)?"
+ "\\([^]]+\\)"
+ "\\]"
+ "\\(\\[" "\\([^]]+\\)" "\\]\\)?"
+ "\\]")
+ org-any-link-re
+ (concat "\\(" org-bracket-link-regexp "\\)\\|\\("
+ org-angle-link-re "\\)\\|\\("
+ org-plain-link-re "\\)")))
+
+(org-make-link-regexps)
+
+(defconst org-ts-regexp "<\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\} [^\r\n>]*?\\)>"
"Regular expression for fast time stamp matching.")
-(defconst org-ts-regexp-both "[[<]\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\}[^\r\n>]*?\\)[]>]"
+(defconst org-ts-regexp-both "[[<]\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\} [^\r\n>]*?\\)[]>]"
"Regular expression for fast time stamp matching.")
-(defconst org-ts-regexp1 "\\(\\([0-9]\\{4\\}\\)-\\([0-9]\\{2\\}\\)-\\([0-9]\\{2\\}\\)\\([^]0-9>\r\n]*\\)\\(\\([0-9]\\{2\\}\\):\\([0-9]\\{2\\}\\)\\)?\\)"
+(defconst org-ts-regexp0 "\\(\\([0-9]\\{4\\}\\)-\\([0-9]\\{2\\}\\)-\\([0-9]\\{2\\}\\) *\\([^]-+0-9>\r\n ]*\\)\\( \\([0-9]\\{2\\}\\):\\([0-9]\\{2\\}\\)\\)?\\)"
+ "Regular expression matching time strings for analysis.
+This one does not require the space after the date, so it can be used
+on a string that terminates immediately after the date.")
+(defconst org-ts-regexp1 "\\(\\([0-9]\\{4\\}\\)-\\([0-9]\\{2\\}\\)-\\([0-9]\\{2\\}\\) +\\([^]-+0-9>\r\n ]*\\)\\( \\([0-9]\\{2\\}\\):\\([0-9]\\{2\\}\\)\\)?\\)"
"Regular expression matching time strings for analysis.")
-(defconst org-ts-regexp2 (concat "<" org-ts-regexp1 ">")
+(defconst org-ts-regexp2 (concat "<" org-ts-regexp1 "[^>\n]\\{0,16\\}>")
"Regular expression matching time stamps, with groups.")
-(defconst org-ts-regexp3 (concat "[[<]" org-ts-regexp1 "[]>]")
+(defconst org-ts-regexp3 (concat "[[<]" org-ts-regexp1 "[^]>\n]\\{0,16\\}[]>]")
"Regular expression matching time stamps (also [..]), with groups.")
(defconst org-tr-regexp (concat org-ts-regexp "--?-?" org-ts-regexp)
"Regular expression matching a time stamp range.")
(defun org-do-emphasis-faces (limit)
"Run through the buffer and add overlays to links."
- (if (re-search-forward org-emph-re limit t)
- (progn
- (font-lock-prepend-text-property (match-beginning 2) (match-end 2)
- 'face
- (nth 1 (assoc (match-string 3)
- org-emphasis-alist)))
- (add-text-properties (match-beginning 2) (match-end 2)
- '(font-lock-multiline t))
- (backward-char 1)
- t)))
+ (let (rtn)
+ (while (and (not rtn) (re-search-forward org-emph-re limit t))
+ (if (not (= (char-after (match-beginning 3))
+ (char-after (match-beginning 4))))
+ (progn
+ (setq rtn t)
+ (font-lock-prepend-text-property (match-beginning 2) (match-end 2)
+ 'face
+ (nth 1 (assoc (match-string 3)
+ org-emphasis-alist)))
+ (add-text-properties (match-beginning 2) (match-end 2)
+ '(font-lock-multiline t))
+ (when org-hide-emphasis-markers
+ (add-text-properties (match-end 4) (match-beginning 5)
+ '(invisible org-link))
+ (add-text-properties (match-beginning 3) (match-end 3)
+ '(invisible org-link)))))
+ (backward-char 1))
+ rtn))
-(defun org-activate-plain-links (limit)
- "Run through the buffer and add overlays to links."
- (if (re-search-forward org-plain-link-re limit t)
- (progn
- (add-text-properties (match-beginning 0) (match-end 0)
- (list 'mouse-face 'highlight
- 'rear-nonsticky t
- 'keymap org-mouse-map
- ))
+(defun org-emphasize (&optional char)
+ "Insert or change an emphasis, i.e. a font like bold or italic.
+If there is an active region, change that region to a new emphasis.
+If there is no region, just insert the marker characters and position
+the cursor between them.
+CHAR should be either the marker character, or the first character of the
+HTML tag associated with that emphasis. If CHAR is a space, the means
+to remove the emphasis of the selected region.
+If char is not given (for example in an interactive call) it
+will be prompted for."
+ (interactive)
+ (let ((eal org-emphasis-alist) e det
+ (erc org-emphasis-regexp-components)
+ (prompt "")
+ (string "") beg end move tag c s)
+ (if (org-region-active-p)
+ (setq beg (region-beginning) end (region-end)
+ string (buffer-substring beg end))
+ (setq move t))
+
+ (while (setq e (pop eal))
+ (setq tag (car (org-split-string (nth 2 e) "[ <>/]+"))
+ c (aref tag 0))
+ (push (cons c (string-to-char (car e))) det)
+ (setq prompt (concat prompt (format " [%s%c]%s" (car e) c
+ (substring tag 1)))))
+ (unless char
+ (message "%s" (concat "Emphasis marker or tag:" prompt))
+ (setq char (read-char-exclusive)))
+ (setq char (or (cdr (assoc char det)) char))
+ (if (equal char ?\ )
+ (setq s "" move nil)
+ (unless (assoc (char-to-string char) org-emphasis-alist)
+ (error "No such emphasis marker: \"%c\"" char))
+ (setq s (char-to-string char)))
+ (while (and (> (length string) 1)
+ (equal (substring string 0 1) (substring string -1))
+ (assoc (substring string 0 1) org-emphasis-alist))
+ (setq string (substring string 1 -1)))
+ (setq string (concat s string s))
+ (if beg (delete-region beg end))
+ (unless (or (bolp)
+ (string-match (concat "[" (nth 0 erc) "\n]")
+ (char-to-string (char-before (point)))))
+ (insert " "))
+ (unless (string-match (concat "[" (nth 1 erc) "\n]")
+ (char-to-string (char-after (point))))
+ (insert " ") (backward-char 1))
+ (insert string)
+ (and move (backward-char 1))))
+
+(defconst org-nonsticky-props
+ '(mouse-face highlight keymap invisible intangible help-echo org-linked-text))
+
+
+(defun org-activate-plain-links (limit)
+ "Run through the buffer and add overlays to links."
+ (catch 'exit
+ (let (f)
+ (while (re-search-forward org-plain-link-re limit t)
+ (setq f (get-text-property (match-beginning 0) 'face))
+ (if (or (eq f 'org-tag)
+ (and (listp f) (memq 'org-tag f)))
+ nil
+ (add-text-properties (match-beginning 0) (match-end 0)
+ (list 'mouse-face 'highlight
+ 'rear-nonsticky org-nonsticky-props
+ 'keymap org-mouse-map
+ ))
+ (throw 'exit t))))))
+
+(defun org-activate-code (limit)
+ (if (re-search-forward "^[ \t]*\\(:.*\\)" limit t)
+ (unless (get-text-property (match-beginning 1) 'face)
+ (remove-text-properties (match-beginning 0) (match-end 0)
+ '(display t invisible t intangible t))
t)))
(defun org-activate-angle-links (limit)
(progn
(add-text-properties (match-beginning 0) (match-end 0)
(list 'mouse-face 'highlight
- 'rear-nonsticky t
+ 'rear-nonsticky org-nonsticky-props
'keymap org-mouse-map
))
t)))
;; but that requires another match, protecting match data,
;; a lot of overhead for font-lock.
(ip (org-maybe-intangible
- (list 'invisible 'org-link 'rear-nonsticky t
+ (list 'invisible 'org-link 'rear-nonsticky org-nonsticky-props
'keymap org-mouse-map 'mouse-face 'highlight
- 'help-echo help)))
- (vp (list 'rear-nonsticky t
+ 'font-lock-multiline t 'help-echo help)))
+ (vp (list 'rear-nonsticky org-nonsticky-props
'keymap org-mouse-map 'mouse-face 'highlight
- 'help-echo help)))
+ ' font-lock-multiline t 'help-echo help)))
;; We need to remove the invisible property here. Table narrowing
;; may have made some of this invisible.
(remove-text-properties (match-beginning 0) (match-end 0)
(progn
(add-text-properties (match-beginning 0) (match-end 0)
(list 'mouse-face 'highlight
- 'rear-nonsticky t
+ 'rear-nonsticky org-nonsticky-props
'keymap org-mouse-map))
(when org-display-custom-times
(if (match-end 3)
(defvar org-target-regexp "<<\\([^<>\n\r]+\\)>>"
"Regular expression matching a link target.")
(defvar org-radio-target-regexp "<<<\\([^<>\n\r]+\\)>>>"
- "Regular expression matching a link target.")
+ "Regular expression matching a radio target.")
+(defvar org-any-target-regexp "<<<?\\([^<>\n\r]+\\)>>>?" ; FIXME, not exact, would match <<<aaa>> as a radio target.
+ "Regular expression matching any target.")
(defun org-activate-target-links (limit)
"Run through the buffer and add overlays to target matches."
(progn
(add-text-properties (match-beginning 0) (match-end 0)
(list 'mouse-face 'highlight
- 'rear-nonsticky t
+ 'rear-nonsticky org-nonsticky-props
'keymap org-mouse-map
'help-echo "Radio target link"
'org-linked-text t))
(goto-char e)
t)))
+(defvar org-latex-and-specials-regexp nil
+ "Regular expression for highlighting export special stuff.")
+(defvar org-match-substring-regexp)
+(defvar org-match-substring-with-braces-regexp)
+(defvar org-export-html-special-string-regexps)
+
+(defun org-compute-latex-and-specials-regexp ()
+ "Compute regular expression for stuff treated specially by exporters."
+ (if (not org-highlight-latex-fragments-and-specials)
+ (org-set-local 'org-latex-and-specials-regexp nil)
+ (let*
+ ((matchers (plist-get org-format-latex-options :matchers))
+ (latexs (delq nil (mapcar (lambda (x) (if (member (car x) matchers) x))
+ org-latex-regexps)))
+ (options (org-combine-plists (org-default-export-plist)
+ (org-infile-export-plist)))
+ (org-export-with-sub-superscripts (plist-get options :sub-superscript))
+ (org-export-with-LaTeX-fragments (plist-get options :LaTeX-fragments))
+ (org-export-with-TeX-macros (plist-get options :TeX-macros))
+ (org-export-html-expand (plist-get options :expand-quoted-html))
+ (org-export-with-special-strings (plist-get options :special-strings))
+ (re-sub
+ (cond
+ ((equal org-export-with-sub-superscripts '{})
+ (list org-match-substring-with-braces-regexp))
+ (org-export-with-sub-superscripts
+ (list org-match-substring-regexp))
+ (t nil)))
+ (re-latex
+ (if org-export-with-LaTeX-fragments
+ (mapcar (lambda (x) (nth 1 x)) latexs)))
+ (re-macros
+ (if org-export-with-TeX-macros
+ (list (concat "\\\\"
+ (regexp-opt
+ (append (mapcar 'car org-html-entities)
+ (if (boundp 'org-latex-entities)
+ org-latex-entities nil))
+ 'words))) ; FIXME
+ ))
+ ;; (list "\\\\\\(?:[a-zA-Z]+\\)")))
+ (re-special (if org-export-with-special-strings
+ (mapcar (lambda (x) (car x))
+ org-export-html-special-string-regexps)))
+ (re-rest
+ (delq nil
+ (list
+ (if org-export-html-expand "@<[^>\n]+>")
+ ))))
+ (org-set-local
+ 'org-latex-and-specials-regexp
+ (mapconcat 'identity (append re-latex re-sub re-macros re-special
+ re-rest) "\\|")))))
+
+(defface org-latex-and-export-specials
+ (let ((font (cond ((assq :inherit custom-face-attributes)
+ '(:inherit underline))
+ (t '(:underline t)))))
+ `((((class grayscale) (background light))
+ (:foreground "DimGray" ,@font))
+ (((class grayscale) (background dark))
+ (:foreground "LightGray" ,@font))
+ (((class color) (background light))
+ (:foreground "SaddleBrown"))
+ (((class color) (background dark))
+ (:foreground "burlywood"))
+ (t (,@font))))
+ "Face used to highlight math latex and other special exporter stuff."
+ :group 'org-faces)
+
+(defun org-do-latex-and-special-faces (limit)
+ "Run through the buffer and add overlays to links."
+ (when org-latex-and-specials-regexp
+ (let (rtn d)
+ (while (and (not rtn) (re-search-forward org-latex-and-specials-regexp
+ limit t))
+ (if (not (memq (car-safe (get-text-property (1+ (match-beginning 0))
+ 'face))
+ '(org-code org-verbatim underline)))
+ (progn
+ (setq rtn t
+ d (cond ((member (char-after (1+ (match-beginning 0)))
+ '(?_ ?^)) 1)
+ (t 0)))
+ (font-lock-prepend-text-property
+ (+ d (match-beginning 0)) (match-end 0)
+ 'face 'org-latex-and-export-specials)
+ (add-text-properties (+ d (match-beginning 0)) (match-end 0)
+ '(font-lock-multiline t)))))
+ rtn)))
+
(defun org-restart-font-lock ()
"Restart font-lock-mode, to force refontification."
(when (and (boundp 'font-lock-mode) font-lock-mode)
"\\)\\>")))
(defun org-activate-tags (limit)
- (if (re-search-forward "[ \t]\\(:[A-Za-z_@0-9:]+:\\)[ \r\n]" limit t)
+ (if (re-search-forward (org-re "^\\*+.*[ \t]\\(:[[:alnum:]_@:]+:\\)[ \r\n]") limit t)
(progn
(add-text-properties (match-beginning 1) (match-end 1)
(list 'mouse-face 'highlight
- 'rear-nonsticky t
+ 'rear-nonsticky org-nonsticky-props
'keymap org-mouse-map))
t)))
-(defun org-font-lock-level ()
- (save-excursion
- (org-back-to-heading t)
- (- (match-end 0) (match-beginning 0))))
-
(defun org-outline-level ()
(save-excursion
(looking-at outline-regexp)
(if (match-beginning 1)
(+ (org-get-string-indentation (match-string 1)) 1000)
- (- (match-end 0) (match-beginning 0)))))
+ (1- (- (match-end 0) (match-beginning 0))))))
(defvar org-font-lock-keywords nil)
+(defconst org-property-re (org-re "^[ \t]*\\(:\\([[:alnum:]_]+\\):\\)[ \t]*\\(\\S-.*\\)")
+ "Regular expression matching a property line.")
+
(defun org-set-font-lock-defaults ()
(let* ((em org-fontify-emphasized-text)
(lk org-activate-links)
(org-font-lock-extra-keywords
- ;; Headlines
(list
- '("^\\(\\**\\)\\(\\*\\)\\(.*\\)" (1 (org-get-level-face 1))
+ ;; Headlines
+ '("^\\(\\**\\)\\(\\* \\)\\(.*\\)" (1 (org-get-level-face 1))
(2 (org-get-level-face 2)) (3 (org-get-level-face 3)))
+ ;; Table lines
'("^[ \t]*\\(\\(|\\|\\+-[-+]\\).*\\S-\\)"
- (1 'org-table))
+ (1 'org-table t))
+ ;; Table internals
+ '("^[ \t]*|\\(?:.*?|\\)? *\\(:?=[^|\n]*\\)" (1 'org-formula t))
+ '("^[ \t]*| *\\([#*]\\) *|" (1 'org-formula t))
+ '("^[ \t]*|\\( *\\([$!_^/]\\) *|.*\\)|" (1 'org-formula t))
+ ;; Drawers
+ (list org-drawer-regexp '(0 'org-special-keyword t))
+ (list "^[ \t]*:END:" '(0 'org-special-keyword t))
+ ;; Properties
+ (list org-property-re
+ '(1 'org-special-keyword t)
+ '(3 'org-property-value t))
+ (if org-format-transports-properties-p
+ '("| *\\(<[0-9]+>\\) *" (1 'org-formula t)))
;; Links
+ (if (memq 'tag lk) '(org-activate-tags (1 'org-tag prepend)))
(if (memq 'angle lk) '(org-activate-angle-links (0 'org-link t)))
(if (memq 'plain lk) '(org-activate-plain-links (0 'org-link t)))
(if (memq 'bracket lk) '(org-activate-bracket-links (0 'org-link t)))
(if (memq 'radio lk) '(org-activate-target-links (0 'org-link t)))
(if (memq 'date lk) '(org-activate-dates (0 'org-date t)))
- (if (memq 'tag lk) '(org-activate-tags (1 'org-tag prepend)))
+ '("^&?%%(.*\\|<%%([^>\n]*?>" (0 'org-sexp-date t))
'(org-hide-wide-columns (0 nil append))
;; TODO lines
- (list (concat "^\\*+[ \t]*" org-not-done-regexp)
- '(1 'org-todo t))
+ (list (concat "^\\*+[ \t]+" org-todo-regexp)
+ '(1 (org-get-todo-face 1) t))
+ ;; DONE
+ (if org-fontify-done-headline
+ (list (concat "^[*]+ +\\<\\("
+ (mapconcat 'regexp-quote org-done-keywords "\\|")
+ "\\)\\(.*\\)")
+ '(2 'org-headline-done t))
+ nil)
;; Priorities
- (list (concat "\\[#[A-Z]\\]") '(0 'org-special-keyword t))
+ (list (concat "\\[#[A-Z0-9]\\]") '(0 'org-special-keyword t))
;; Special keywords
- (list org-repeat-re '(0 'org-special-keyword t))
(list (concat "\\<" org-deadline-string) '(0 'org-special-keyword t))
(list (concat "\\<" org-scheduled-string) '(0 'org-special-keyword t))
(list (concat "\\<" org-closed-string) '(0 'org-special-keyword t))
(if (featurep 'xemacs)
'(org-do-emphasis-faces (0 nil append))
'(org-do-emphasis-faces)))
- ;; Checkboxes, similar to Frank Ruell's org-checklet.el
- '("^[ \t]*\\([-+*]\\|[0-9]+[.)]\\) +\\(\\[[ X]\\]\\)"
+ ;; Checkboxes
+ '("^[ \t]*\\([-+*]\\|[0-9]+[.)]\\) +\\(\\[[- X]\\]\\)"
2 'bold prepend)
(if org-provide-checkbox-statistics
'("\\[\\([0-9]*%\\)\\]\\|\\[\\([0-9]*\\)/\\([0-9]*\\)\\]"
(0 (org-get-checkbox-statistics-face) t)))
+ (list (concat "^\\*+ \\(.*:" org-archive-tag ":.*\\)")
+ '(1 'org-archived prepend))
+ ;; Specials
+ '(org-do-latex-and-special-faces)
+ ;; Code
+ '(org-activate-code (1 'org-code t))
;; COMMENT
- (list (concat "^\\*+[ \t]*\\<\\(" org-comment-string
+ (list (concat "^\\*+[ \t]+\\<\\(" org-comment-string
"\\|" org-quote-string "\\)\\>")
'(1 'org-special-keyword t))
'("^#.*" (0 'font-lock-comment-face t))
- ;; DONE
- (if org-fontify-done-headline
- (list (concat "^[*]+ +\\<\\(" org-done-string "\\)\\(.*\\)\\>")
- '(1 'org-done t) '(2 'org-headline-done t))
- (list (concat "^[*]+ +\\<\\(" org-done-string "\\)\\>")
- '(1 'org-done t)))
- ;; Table stuff
- '("^[ \t]*\\(:.*\\)" (1 'org-table t))
- '("| *\\(:?=[^|\n]*\\)" (1 'org-formula t))
- '("^[ \t]*| *\\([#!$*_^]\\) *|" (1 'org-formula t))
- (if org-format-transports-properties-p
- '("| *\\(<[0-9]+>\\) *" (1 'org-formula t)))
- '("^\\*+ \\(.*:ARCHIVE:.*\\)" (1 'org-archived prepend))
)))
(setq org-font-lock-extra-keywords (delq nil org-font-lock-extra-keywords))
;; Now set the full font-lock-keywords
(defvar org-f nil)
(defun org-get-level-face (n)
"Get the right face for match N in font-lock matching of healdines."
- (setq org-l (- (match-end 2) (match-beginning 1)))
+ (setq org-l (- (match-end 2) (match-beginning 1) 1))
(if org-odd-levels-only (setq org-l (1+ (/ org-l 2))))
-; (setq org-f (nth (1- (% org-l org-n-levels)) org-level-faces))
- (setq org-f (nth (% (1- org-l) org-n-levels) org-level-faces))
+ (setq org-f (nth (% (1- org-l) org-n-level-faces) org-level-faces))
(cond
((eq n 1) (if org-hide-leading-stars 'org-hide org-f))
((eq n 2) org-f)
(t (if org-level-color-stars-only nil org-f))))
+(defun org-get-todo-face (kwd)
+ "Get the right face for a TODO keyword KWD.
+If KWD is a number, get the corresponding match group."
+ (if (numberp kwd) (setq kwd (match-string kwd)))
+ (or (cdr (assoc kwd org-todo-keyword-faces))
+ (and (member kwd org-done-keywords) 'org-done)
+ 'org-todo))
+
(defun org-unfontify-region (beg end &optional maybe_loudly)
"Remove fontification and activation overlays from links."
(font-lock-default-unfontify-region beg end)
deactivate-mark buffer-file-name buffer-file-truename)
(remove-text-properties beg end
'(mouse-face t keymap t org-linked-text t
- rear-nonsticky t
invisible t intangible t))))
;;;; Visibility cycling, including org-goto and indirect buffer
`indent-relative', like TAB normally does. See the option
`org-cycle-emulate-tab' for details.
-- Special case: if point is the beginning of the buffer and there is no
- headline in line 1, this function will act as if called with prefix arg."
+- Special case: if point is at the beginning of the buffer and there is
+ no headline in line 1, this function will act as if called with prefix arg.
+ But only if also the variable `org-cycle-global-at-bob' is t."
(interactive "P")
(let* ((outline-regexp
(if (and (org-mode-p) org-cycle-include-plain-lists)
- "\\(?:\\*+\\|\\([ \t]*\\)\\([-+*]\\|[0-9]+[.)]\\) \\)"
+ "\\(?:\\*+ \\|\\([ \t]*\\)\\([-+*]\\|[0-9]+[.)]\\) \\)"
outline-regexp))
(bob-special (and org-cycle-global-at-bob (bobp)
(not (looking-at outline-regexp))))
(setq org-cycle-global-status 'overview)
(run-hook-with-args 'org-cycle-hook 'overview))))
+ ((and org-drawers org-drawer-regexp
+ (save-excursion
+ (beginning-of-line 1)
+ (looking-at org-drawer-regexp)))
+ ;; Toggle block visibility
+ (org-flag-drawer
+ (not (get-char-property (match-end 0) 'invisible))))
+
((integerp arg)
;; Show-subtree, ARG levels up from here.
(save-excursion
(- (funcall outline-level) arg)))
(org-show-subtree)))
- ((save-excursion (beginning-of-line 1) (looking-at outline-regexp))
+ ((and (save-excursion (beginning-of-line 1) (looking-at outline-regexp))
+ (or (bolp) (not (eq org-cycle-emulate-tab 'exc-hl-bol))))
;; At a heading: rotate between three different views
(org-back-to-heading)
(let ((goal-column 0) eoh eol eos)
(beginning-of-line 2)) (setq eol (point)))
(outline-end-of-heading) (setq eoh (point))
(org-end-of-subtree t)
- (skip-chars-forward " \t\n")
- (beginning-of-line 1) ; in case this is an item
+ (unless (eobp)
+ (skip-chars-forward " \t\n")
+ (beginning-of-line 1) ; in case this is an item
+ )
(setq eos (1- (point))))
;; Find out what to do next and set `this-command'
(cond
((= eos eoh)
;; Nothing is hidden behind this heading
(message "EMPTY ENTRY")
- (setq org-cycle-subtree-status nil))
- ((>= eol eos)
+ (setq org-cycle-subtree-status nil)
+ (save-excursion
+ (goto-char eos)
+ (outline-next-heading)
+ (if (org-invisible-p) (org-flag-heading nil))))
+ ((or (>= eol eos)
+ (not (string-match "\\S-" (buffer-substring eol eos))))
;; Entire subtree is hidden in one line: open it
(org-show-entry)
(show-children)
(message "CHILDREN")
+ (save-excursion
+ (goto-char eos)
+ (outline-next-heading)
+ (if (org-invisible-p) (org-flag-heading nil)))
(setq org-cycle-subtree-status 'children)
(run-hook-with-args 'org-cycle-hook 'children))
((and (eq last-command this-command)
((org-try-cdlatex-tab))
+ ((and (eq org-cycle-emulate-tab 'exc-hl-bol)
+ (or (not (bolp))
+ (not (looking-at outline-regexp))))
+ (call-interactively (global-key-binding "\t")))
+
((if (and (memq org-cycle-emulate-tab '(white whitestart))
(save-excursion (beginning-of-line 1) (looking-at "[ \t]*"))
(or (and (eq org-cycle-emulate-tab 'white)
(>= (match-end 0) pos))))
t
(eq org-cycle-emulate-tab t))
- (if (and (looking-at "[ \n\r\t]")
- (string-match "^[ \t]*$" (buffer-substring
- (point-at-bol) (point))))
- (progn
- (beginning-of-line 1)
- (and (looking-at "[ \t]+") (replace-match ""))))
- (indent-relative))
+; (if (and (looking-at "[ \n\r\t]")
+; (string-match "^[ \t]*$" (buffer-substring
+; (point-at-bol) (point))))
+; (progn
+; (beginning-of-line 1)
+; (and (looking-at "[ \t]+") (replace-match ""))))
+ (call-interactively (global-key-binding "\t")))
(t (save-excursion
(org-back-to-heading)
first headline is not level one, then (hide-sublevels 1) gives confusing
results."
(interactive)
- (hide-sublevels (save-excursion
- (goto-char (point-min))
- (if (re-search-forward (concat "^" outline-regexp) nil t)
- (progn
- (goto-char (match-beginning 0))
- (funcall outline-level))
- 1))))
+ (let ((level (save-excursion
+ (goto-char (point-min))
+ (if (re-search-forward (concat "^" outline-regexp) nil t)
+ (progn
+ (goto-char (match-beginning 0))
+ (funcall outline-level))))))
+ (and level (hide-sublevels level))))
(defun org-content (&optional arg)
"Show all headlines in the buffer, like a table of contents.
This function is the default value of the hook `org-cycle-hook'."
(when (get-buffer-window (current-buffer))
(cond
- ((eq state 'overview) (org-first-headline-recenter 1))
+; ((eq state 'overview) (org-first-headline-recenter 1))
+; ((eq state 'overview) (org-beginning-of-line))
((eq state 'content) nil)
((eq state 'all) nil)
((eq state 'folded) nil)
((eq state 'children) (or (org-subtree-end-visible-p) (recenter 1)))
((eq state 'subtree) (or (org-subtree-end-visible-p) (recenter 1))))))
+(defun org-compact-display-after-subtree-move ()
+ (let (beg end)
+ (save-excursion
+ (if (org-up-heading-safe)
+ (progn
+ (hide-subtree)
+ (show-entry)
+ (show-children)
+ (org-cycle-show-empty-lines 'children)
+ (org-cycle-hide-drawers 'children))
+ (org-overview)))))
+
+(defun org-cycle-show-empty-lines (state)
+ "Show empty lines above all visible headlines.
+The region to be covered depends on STATE when called through
+`org-cycle-hook'. Lisp program can use t for STATE to get the
+entire buffer covered. Note that an empty line is only shown if there
+are at least `org-cycle-separator-lines' empty lines before the headeline."
+ (when (> org-cycle-separator-lines 0)
+ (save-excursion
+ (let* ((n org-cycle-separator-lines)
+ (re (cond
+ ((= n 1) "\\(\n[ \t]*\n\\*+\\) ")
+ ((= n 2) "^[ \t]*\\(\n[ \t]*\n\\*+\\) ")
+ (t (let ((ns (number-to-string (- n 2))))
+ (concat "^\\(?:[ \t]*\n\\)\\{" ns "," ns "\\}"
+ "[ \t]*\\(\n[ \t]*\n\\*+\\) ")))))
+ beg end)
+ (cond
+ ((memq state '(overview contents t))
+ (setq beg (point-min) end (point-max)))
+ ((memq state '(children folded))
+ (setq beg (point) end (progn (org-end-of-subtree t t)
+ (beginning-of-line 2)
+ (point)))))
+ (when beg
+ (goto-char beg)
+ (while (re-search-forward re end t)
+ (if (not (get-char-property (match-end 1) 'invisible))
+ (outline-flag-region
+ (match-beginning 1) (match-end 1) nil)))))))
+ ;; Never hide empty lines at the end of the file.
+ (save-excursion
+ (goto-char (point-max))
+ (outline-previous-heading)
+ (outline-end-of-heading)
+ (if (and (looking-at "[ \t\n]+")
+ (= (match-end 0) (point-max)))
+ (outline-flag-region (point) (match-end 0) nil))))
+
(defun org-subtree-end-visible-p ()
"Is the end of the current subtree visible?"
(pos-visible-in-window-p
(defvar org-goto-window-configuration nil)
(defvar org-goto-marker nil)
-(defvar org-goto-map (make-sparse-keymap))
-(let ((cmds '(isearch-forward isearch-backward)) cmd)
- (while (setq cmd (pop cmds))
- (substitute-key-definition cmd cmd org-goto-map global-map)))
-(define-key org-goto-map "\C-m" 'org-goto-ret)
-(define-key org-goto-map [(left)] 'org-goto-left)
-(define-key org-goto-map [(right)] 'org-goto-right)
-(define-key org-goto-map [(?q)] 'org-goto-quit)
-(define-key org-goto-map [(control ?g)] 'org-goto-quit)
-(define-key org-goto-map "\C-i" 'org-cycle)
-(define-key org-goto-map [(tab)] 'org-cycle)
-(define-key org-goto-map [(down)] 'outline-next-visible-heading)
-(define-key org-goto-map [(up)] 'outline-previous-visible-heading)
-(define-key org-goto-map "n" 'outline-next-visible-heading)
-(define-key org-goto-map "p" 'outline-previous-visible-heading)
-(define-key org-goto-map "f" 'outline-forward-same-level)
-(define-key org-goto-map "b" 'outline-backward-same-level)
-(define-key org-goto-map "u" 'outline-up-heading)
-(define-key org-goto-map "\C-c\C-n" 'outline-next-visible-heading)
-(define-key org-goto-map "\C-c\C-p" 'outline-previous-visible-heading)
-(define-key org-goto-map "\C-c\C-f" 'outline-forward-same-level)
-(define-key org-goto-map "\C-c\C-b" 'outline-backward-same-level)
-(define-key org-goto-map "\C-c\C-u" 'outline-up-heading)
-(let ((l '(1 2 3 4 5 6 7 8 9 0)))
- (while l (define-key org-goto-map (int-to-string (pop l)) 'digit-argument)))
+(defvar org-goto-map
+ (let ((map (make-sparse-keymap)))
+ (let ((cmds '(isearch-forward isearch-backward kill-ring-save set-mark-command mouse-drag-region universal-argument org-occur)) cmd)
+ (while (setq cmd (pop cmds))
+ (substitute-key-definition cmd cmd map global-map)))
+ (suppress-keymap map)
+ (org-defkey map "\C-m" 'org-goto-ret)
+ (org-defkey map [(return)] 'org-goto-ret)
+ (org-defkey map [(left)] 'org-goto-left)
+ (org-defkey map [(right)] 'org-goto-right)
+ (org-defkey map [(control ?g)] 'org-goto-quit)
+ (org-defkey map "\C-i" 'org-cycle)
+ (org-defkey map [(tab)] 'org-cycle)
+ (org-defkey map [(down)] 'outline-next-visible-heading)
+ (org-defkey map [(up)] 'outline-previous-visible-heading)
+ (if org-goto-auto-isearch
+ (if (fboundp 'define-key-after)
+ (define-key-after map [t] 'org-goto-local-auto-isearch)
+ nil)
+ (org-defkey map "q" 'org-goto-quit)
+ (org-defkey map "n" 'outline-next-visible-heading)
+ (org-defkey map "p" 'outline-previous-visible-heading)
+ (org-defkey map "f" 'outline-forward-same-level)
+ (org-defkey map "b" 'outline-backward-same-level)
+ (org-defkey map "u" 'outline-up-heading))
+ (org-defkey map "/" 'org-occur)
+ (org-defkey map "\C-c\C-n" 'outline-next-visible-heading)
+ (org-defkey map "\C-c\C-p" 'outline-previous-visible-heading)
+ (org-defkey map "\C-c\C-f" 'outline-forward-same-level)
+ (org-defkey map "\C-c\C-b" 'outline-backward-same-level)
+ (org-defkey map "\C-c\C-u" 'outline-up-heading)
+ map))
(defconst org-goto-help
-"Select a location to jump to, press RET
-\[Up]/[Down]=next/prev headline TAB=cycle visibility RET=select [Q]uit")
+"Browse buffer copy, to find location or copy text. Just type for auto-isearch.
+RET=jump to location [Q]uit and return to previous location
+\[Up]/[Down]=next/prev headline TAB=cycle visibility [/] org-occur")
-(defun org-goto ()
- "Go to a different location of the document, keeping current visibility.
+(defvar org-goto-start-pos) ; dynamically scoped parameter
-When you want to go to a different location in a document, the fastest way
-is often to fold the entire buffer and then dive into the tree. This
-method has the disadvantage, that the previous location will be folded,
+(defun org-goto (&optional alternative-interface)
+ "Look up a different location in the current file, keeping current visibility.
+
+When you want look-up or go to a different location in a document, the
+fastest way is often to fold the entire buffer and then dive into the tree.
+This method has the disadvantage, that the previous location will be folded,
which may not be what you want.
-This command works around this by showing a copy of the current buffer in
-overview mode. You can dive into the tree in that copy, to find the
-location you want to reach. When pressing RET, the command returns to the
-original buffer in which the visibility is still unchanged. It then jumps
-to the new location, making it and the headline hierarchy above it visible."
- (interactive)
- (let* ((org-goto-start-pos (point))
+This command works around this by showing a copy of the current buffer
+in an indirect buffer, in overview mode. You can dive into the tree in
+that copy, use org-occur and incremental search to find a location.
+When pressing RET or `Q', the command returns to the original buffer in
+which the visibility is still unchanged. After RET is will also jump to
+the location selected in the indirect buffer and expose the
+the headline hierarchy above."
+ (interactive "P")
+ (let* ((org-refile-targets '((nil . (:maxlevel . 10))))
+ (org-refile-use-outline-path t)
+ (interface
+ (if (not alternative-interface)
+ org-goto-interface
+ (if (eq org-goto-interface 'outline)
+ 'outline-path-completion
+ 'outline)))
+ (org-goto-start-pos (point))
(selected-point
- (org-get-location (current-buffer) org-goto-help)))
+ (if (eq interface 'outline)
+ (car (org-get-location (current-buffer) org-goto-help))
+ (nth 3 (org-refile-get-location "Goto: ")))))
(if selected-point
(progn
(org-mark-ring-push org-goto-start-pos)
(goto-char selected-point)
(if (or (org-invisible-p) (org-invisible-p2))
(org-show-context 'org-goto)))
- (error "Quit"))))
+ (message "Quit"))))
-(defvar org-selected-point nil) ; dynamically scoped parameter
+(defvar org-goto-selected-point nil) ; dynamically scoped parameter
+(defvar org-goto-exit-command nil) ; dynamically scoped parameter
+(defvar org-goto-local-auto-isearch-map) ; defined below
(defun org-get-location (buf help)
"Let the user select a location in the Org-mode buffer BUF.
This function uses a recursive edit. It returns the selected position
or nil."
- (let (org-selected-point)
+ (let ((isearch-mode-map org-goto-local-auto-isearch-map)
+ (isearch-hide-immediately nil)
+ (isearch-search-fun-function
+ (lambda () 'org-goto-local-search-forward-headings))
+ (org-goto-selected-point org-goto-exit-command))
(save-excursion
(save-window-excursion
(delete-other-windows)
- (switch-to-buffer (get-buffer-create "*org-goto*"))
+ (and (get-buffer "*org-goto*") (kill-buffer "*org-goto*"))
+ (switch-to-buffer
+ (condition-case nil
+ (make-indirect-buffer (current-buffer) "*org-goto*")
+ (error (make-indirect-buffer (current-buffer) "*org-goto*"))))
(with-output-to-temp-buffer "*Help*"
(princ help))
(shrink-window-if-larger-than-buffer (get-buffer-window "*Help*"))
(setq buffer-read-only nil)
- (erase-buffer)
- (insert-buffer-substring buf)
(let ((org-startup-truncated t)
- (org-startup-folded t)
+ (org-startup-folded nil)
(org-startup-align-all-tables nil))
- (org-mode))
+ (org-mode)
+ (org-overview))
(setq buffer-read-only t)
(if (and (boundp 'org-goto-start-pos)
(integer-or-marker-p org-goto-start-pos))
(goto-char (point-min)))
(org-beginning-of-line)
(message "Select location and press RET")
- ;; now we make sure that during selection, ony very few keys work
- ;; and that it is impossible to switch to another window.
- (let ((gm (current-global-map))
- (overriding-local-map org-goto-map))
- (unwind-protect
- (progn
- (use-global-map org-goto-map)
- (recursive-edit))
- (use-global-map gm)))))
+ (use-local-map org-goto-map)
+ (recursive-edit)
+ ))
(kill-buffer "*org-goto*")
- org-selected-point))
+ (cons org-goto-selected-point org-goto-exit-command)))
+
+(defvar org-goto-local-auto-isearch-map (make-sparse-keymap))
+(set-keymap-parent org-goto-local-auto-isearch-map isearch-mode-map)
+(define-key org-goto-local-auto-isearch-map "\C-i" 'isearch-other-control-char)
+(define-key org-goto-local-auto-isearch-map "\C-m" 'isearch-other-control-char)
+
+(defun org-goto-local-search-forward-headings (string bound noerror)
+ "Search and make sure that anu matches are in headlines."
+ (catch 'return
+ (while (search-forward string bound noerror)
+ (when (let ((context (mapcar 'car (save-match-data (org-context)))))
+ (and (member :headline context)
+ (not (member :tags context))))
+ (throw 'return (point))))))
+
+(defun org-goto-local-auto-isearch ()
+ "Start isearch."
+ (interactive)
+ (goto-char (point-min))
+ (let ((keys (this-command-keys)))
+ (when (eq (lookup-key isearch-mode-map keys) 'isearch-printing-char)
+ (isearch-mode t)
+ (isearch-process-search-char (string-to-char keys)))))
(defun org-goto-ret (&optional arg)
"Finish `org-goto' by going to the new location."
(interactive "P")
- (setq org-selected-point (point)
- current-prefix-arg arg)
+ (setq org-goto-selected-point (point)
+ org-goto-exit-command 'return)
(throw 'exit nil))
(defun org-goto-left ()
(if (org-on-heading-p)
(progn
(beginning-of-line 1)
- (setq org-selected-point (point)
- current-prefix-arg (- (match-end 0) (match-beginning 0)))
+ (setq org-goto-selected-point (point)
+ org-goto-exit-command 'left)
(throw 'exit nil))
(error "Not on a heading")))
(interactive)
(if (org-on-heading-p)
(progn
- (outline-end-of-subtree)
- (or (eobp) (forward-char 1))
- (setq org-selected-point (point)
- current-prefix-arg (- (match-end 0) (match-beginning 0)))
+ (setq org-goto-selected-point (point)
+ org-goto-exit-command 'right)
(throw 'exit nil))
(error "Not on a heading")))
(defun org-goto-quit ()
"Finish `org-goto' without cursor motion."
(interactive)
- (setq org-selected-point nil)
+ (setq org-goto-selected-point nil)
+ (setq org-goto-exit-command 'quit)
(throw 'exit nil))
;;; Indirect buffer display of subtrees
"Create indirect buffer and narrow it to current subtree.
With numerical prefix ARG, go up to this level and then take that tree.
If ARG is negative, go up that many levels.
-Normally this command removes the indirect buffer previously made
-with this command. However, when called with a C-u prefix, the last buffer
+If `org-indirect-buffer-display' is not `new-frame', the command removes the
+indirect buffer previously made with this command, to avoid proliferation of
+indirect buffers. However, when you call the command with a `C-u' prefix, or
+when `org-indirect-buffer-display' is `new-frame', the last buffer
is kept so that you can work with several indirect buffers at the same time.
If `org-indirect-buffer-display' is `dedicated-frame', the C-u prefix also
requests that a new frame be made for the new buffer, so that the dedicated
(setq beg (point)
heading (org-get-heading))
(org-end-of-subtree t) (setq end (point)))
- (if (and (not arg)
- (buffer-live-p org-last-indirect-buffer))
+ (if (and (buffer-live-p org-last-indirect-buffer)
+ (not (eq org-indirect-buffer-display 'new-frame))
+ (not arg))
(kill-buffer org-last-indirect-buffer))
(setq ibuf (org-get-indirect-buffer cbuf)
org-last-indirect-buffer ibuf)
"Insert a new heading or item with same depth at point.
If point is in a plain list and FORCE-HEADING is nil, create a new list item.
If point is at the beginning of a headline, insert a sibling before the
-current headline. If point is in the middle of a headline, split the headline
-at that position and make the rest of the headline part of the sibling below
-the current headline."
+current headline. If point is not at the beginning, do not split the line,
+but create the new hedline after the current line."
(interactive "P")
(if (= (buffer-size) 0)
(insert "\n* ")
pos)
(cond
((and (org-on-heading-p) (bolp)
- (save-excursion (backward-char 1) (not (org-invisible-p))))
+ (or (bobp)
+ (save-excursion (backward-char 1) (not (org-invisible-p)))))
+ ;; insert before the current line
(open-line (if blank 2 1)))
- ((and (bolp) (save-excursion
- (backward-char 1) (not (org-invisible-p))))
+ ((and (bolp)
+ (or (bobp)
+ (save-excursion
+ (backward-char 1) (not (org-invisible-p)))))
+ ;; insert right here
nil)
- (t (newline (if blank 2 1))))
+ (t
+; ;; in the middle of the line
+; (org-show-entry)
+; (if (org-get-alist-option org-M-RET-may-split-line 'headline)
+; (if (and
+; (org-on-heading-p)
+; (looking-at ".*?\\([ \t]+\\(:[[:alnum:]_@:]+:\\)\\)[ \r\n]"))
+; ;; protect the tags
+;; (let ((tags (match-string 2)) pos)
+; (delete-region (match-beginning 1) (match-end 1))
+; (setq pos (point-at-bol))
+; (newline (if blank 2 1))
+; (save-excursion
+; (goto-char pos)
+; (end-of-line 1)
+; (insert " " tags)
+; (org-set-tags nil 'align)))
+; (newline (if blank 2 1)))
+; (newline (if blank 2 1))))
+
+
+ ;; in the middle of the line
+ (org-show-entry)
+ (let ((split
+ (org-get-alist-option org-M-RET-may-split-line 'headline))
+ tags pos)
+ (if (org-on-heading-p)
+ (progn
+ (looking-at ".*?\\([ \t]+\\(:[[:alnum:]_@:]+:\\)\\)?[ \t]*$")
+ (setq tags (and (match-end 2) (match-string 2)))
+ (and (match-end 1)
+ (delete-region (match-beginning 1) (match-end 1)))
+ (setq pos (point-at-bol))
+ (or split (end-of-line 1))
+ (delete-horizontal-space)
+ (newline (if blank 2 1))
+ (when tags
+ (save-excursion
+ (goto-char pos)
+ (end-of-line 1)
+ (insert " " tags)
+ (org-set-tags nil 'align))))
+ (or split (end-of-line 1))
+ (newline (if blank 2 1))))))
(insert head) (just-one-space)
(setq pos (point))
(end-of-line 1)
(unless (= (point) pos) (just-one-space) (backward-delete-char 1))
(run-hooks 'org-insert-heading-hook)))))
+(defun org-insert-heading-after-current ()
+ "Insert a new heading with same level as current, after current subtree."
+ (interactive)
+ (org-back-to-heading)
+ (org-insert-heading)
+ (org-move-subtree-down)
+ (end-of-line 1))
(defun org-insert-todo-heading (arg)
"Insert a new heading with the same level and TODO state as current heading.
(looking-at org-todo-line-regexp))
(if (or arg
(not (match-beginning 2))
- (equal (match-string 2) org-done-string))
- (insert (car org-todo-keywords) " ")
+ (member (match-string 2) org-done-keywords))
+ (insert (car org-todo-keywords-1) " ")
(insert (match-string 2) " "))))
+(defun org-insert-subheading (arg)
+ "Insert a new subheading and demote it.
+Works for outline headings and for plain lists alike."
+ (interactive "P")
+ (org-insert-heading arg)
+ (cond
+ ((org-on-heading-p) (org-do-demote))
+ ((org-at-item-p) (org-indent-item 1))))
+
+(defun org-insert-todo-subheading (arg)
+ "Insert a new subheading with TODO keyword or checkbox and demote it.
+Works for outline headings and for plain lists alike."
+ (interactive "P")
+ (org-insert-todo-heading arg)
+ (cond
+ ((org-on-heading-p) (org-do-demote))
+ ((org-at-item-p) (org-indent-item 1))))
+
;;; Promotion and Demotion
(defun org-promote-subtree ()
((eolp) (insert " "))
((equal (char-after) ?\ ) (forward-char 1))))))
-(defun org-get-legal-level (level &optional change)
+(defun org-reduced-level (l)
+ (if org-odd-levels-only (1+ (floor (/ l 2))) l))
+
+(defun org-get-valid-level (level &optional change)
"Rectify a level change under the influence of `org-odd-levels-only'
LEVEL is a current level, CHANGE is by how much the level should be
modified. Even if CHANGE is nil, LEVEL may be returned modified because
((< change 0) (max 1 (1+ (* 2 (/ (+ level (* 2 change)) 2))))))
(max 1 (+ level change))))
+(define-obsolete-function-alias 'org-get-legal-level
+ 'org-get-valid-level "23.1")
+
(defun org-promote ()
"Promote the current heading higher up the tree.
If the region is active in `transient-mark-mode', promote all headings
in the region."
(org-back-to-heading t)
(let* ((level (save-match-data (funcall outline-level)))
- (up-head (make-string (org-get-legal-level level -1) ?*))
- (diff (abs (- level (length up-head)))))
+ (up-head (concat (make-string (org-get-valid-level level -1) ?*) " "))
+ (diff (abs (- level (length up-head) -1))))
(if (= level 1) (error "Cannot promote to level 0. UNDO to recover if necessary"))
(replace-match up-head nil t)
;; Fixup tag positioning
in the region."
(org-back-to-heading t)
(let* ((level (save-match-data (funcall outline-level)))
- (down-head (make-string (org-get-legal-level level 1) ?*))
- (diff (abs (- level (length down-head)))))
+ (down-head (concat (make-string (org-get-valid-level level 1) ?*) " "))
+ (diff (abs (- level (length down-head) -1))))
(replace-match down-head nil t)
;; Fixup tag positioning
(and org-auto-align-tags (org-set-tags nil t))
"^\\S-"
(concat "^ \\{0," (int-to-string (- diff)) "\\}\\S-")))
col)
- (unless (save-excursion (re-search-forward prohibit end t))
- (while (re-search-forward "^[ \t]+" end t)
+ (unless (save-excursion (end-of-line 1)
+ (re-search-forward prohibit end t))
+ (while (and (< (point) end)
+ (re-search-forward "^[ \t]+" end t))
(goto-char (match-end 0))
(setq col (current-column))
(if (< diff 0) (replace-match ""))
(let ((org-odd-levels-only nil) n)
(save-excursion
(goto-char (point-min))
- (while (re-search-forward "^\\*\\*+" nil t)
- (setq n (1- (length (match-string 0))))
+ (while (re-search-forward "^\\*\\*+ " nil t)
+ (setq n (- (length (match-string 0)) 2))
(while (>= (setq n (1- n)) 0)
(org-demote))
(end-of-line 1))))))
(interactive)
(goto-char (point-min))
;; First check if there are no even levels
- (when (re-search-forward "^\\(\\*\\*\\)+[^*]" nil t)
+ (when (re-search-forward "^\\(\\*\\*\\)+ " nil t)
(org-show-context t)
(error "Not all levels are odd in this file. Conversion not possible."))
(when (yes-or-no-p "Are you sure you want to globally change levels to odd-even? ")
(let ((org-odd-levels-only nil) n)
(save-excursion
(goto-char (point-min))
- (while (re-search-forward "^\\*\\*+" nil t)
- (setq n (/ (length (match-string 0)) 2))
+ (while (re-search-forward "^\\*\\*+ " nil t)
+ (setq n (/ (1- (length (match-string 0))) 2))
(while (>= (setq n (1- n)) 0)
(org-promote))
(end-of-line 1))))))
'outline-get-last-sibling))
(ins-point (make-marker))
(cnt (abs arg))
- beg end txt folded)
+ beg beg0 end txt folded ne-beg ne-end ne-ins ins-end)
;; Select the tree
(org-back-to-heading)
- (setq beg (point))
+ (setq beg0 (point))
+ (save-excursion
+ (setq ne-beg (org-back-over-empty-lines))
+ (setq beg (point)))
(save-match-data
(save-excursion (outline-end-of-heading)
(setq folded (org-invisible-p)))
(outline-end-of-subtree))
(outline-next-heading)
+ (setq ne-end (org-back-over-empty-lines))
(setq end (point))
+ (goto-char beg0)
+ (when (and (> arg 0) (org-first-sibling-p) (< ne-end ne-beg))
+ ;; include less whitespace
+ (save-excursion
+ (goto-char beg)
+ (forward-line (- ne-beg ne-end))
+ (setq beg (point))))
;; Find insertion point, with error handling
- (goto-char beg)
(while (> cnt 0)
(or (and (funcall movfunc) (looking-at outline-regexp))
- (progn (goto-char beg)
+ (progn (goto-char beg0)
(error "Cannot move past superior level or buffer limit")))
(setq cnt (1- cnt)))
(if (> arg 0)
;; Moving forward - still need to move over subtree
- (progn (outline-end-of-subtree)
- (outline-next-heading)
- (if (not (or (looking-at (concat "^" outline-regexp))
- (bolp)))
- (newline))))
+ (progn (org-end-of-subtree t t)
+ (save-excursion
+ (org-back-over-empty-lines)
+ (or (bolp) (newline)))))
+ (setq ne-ins (org-back-over-empty-lines))
(move-marker ins-point (point))
(setq txt (buffer-substring beg end))
(delete-region beg end)
+ (outline-flag-region (1- beg) beg nil)
+ (outline-flag-region (1- (point)) (point) nil)
(insert txt)
+ (or (bolp) (insert "\n"))
+ (setq ins-end (point))
(goto-char ins-point)
- (if folded (hide-subtree))
- (move-marker ins-point nil)))
+ (org-skip-whitespace)
+ (when (and (< arg 0)
+ (org-first-sibling-p)
+ (> ne-ins ne-beg))
+ ;; Move whitespace back to beginning
+ (save-excursion
+ (goto-char ins-end)
+ (let ((kill-whole-line t))
+ (kill-line (- ne-ins ne-beg)) (point)))
+ (insert (make-string (- ne-ins ne-beg) ?\n)))
+ (move-marker ins-point nil)
+ (org-compact-display-after-subtree-move)
+ (unless folded
+ (org-show-entry)
+ (show-children)
+ (org-cycle-hide-drawers 'children))))
(defvar org-subtree-clip ""
"Clipboard for cut and paste of subtrees.
"Was the last copied subtree folded?
This is used to fold the tree back after pasting.")
-(defun org-cut-subtree ()
+(defun org-cut-subtree (&optional n)
"Cut the current subtree into the clipboard.
+With prefix arg N, cut this many sequential subtrees.
This is a short-hand for marking the subtree and then cutting it."
- (interactive)
- (org-copy-subtree 'cut))
+ (interactive "p")
+ (org-copy-subtree n 'cut))
-(defun org-copy-subtree (&optional cut)
+(defun org-copy-subtree (&optional n cut)
"Cut the current subtree into the clipboard.
+With prefix arg N, cut this many sequential subtrees.
This is a short-hand for marking the subtree and then copying it.
If CUT is non-nil, actually cut the subtree."
- (interactive)
- (let (beg end folded)
- (org-back-to-heading)
+ (interactive "p")
+ (let (beg end folded (beg0 (point)))
+ (if (interactive-p)
+ (org-back-to-heading nil) ; take what looks like a subtree
+ (org-back-to-heading t)) ; take what is really there
+ (org-back-over-empty-lines)
(setq beg (point))
+ (skip-chars-forward " \t\r\n")
(save-match-data
(save-excursion (outline-end-of-heading)
(setq folded (org-invisible-p)))
- (outline-end-of-subtree))
- (if (equal (char-after) ?\n) (forward-char 1))
+ (condition-case nil
+ (outline-forward-same-level (1- n))
+ (error nil))
+ (org-end-of-subtree t t))
+ (org-back-over-empty-lines)
(setq end (point))
- (goto-char beg)
+ (goto-char beg0)
(when (> end beg)
(setq org-subtree-clip-folded folded)
(if cut (kill-region beg end) (copy-region-as-kill beg end))
(setq org-subtree-clip (current-kill 0))
- (message "%s: Subtree with %d characters"
+ (message "%s: Subtree(s) with %d characters"
(if cut "Cut" "Copied")
(length org-subtree-clip)))))
If optional TREE is given, use this text instead of the kill ring."
(interactive "P")
(unless (org-kill-is-subtree-p tree)
- (error
+ (error "%s"
(substitute-command-keys
"The kill is not a (set of) tree(s) - please use \\[yank] to yank anyway")))
(let* ((txt (or tree (and kill-ring (current-kill 0))))
(^re (concat "^\\(" outline-regexp "\\)"))
(re (concat "\\(" outline-regexp "\\)"))
- (^re_ (concat "\\(" outline-regexp "\\)[ \t]*"))
+ (^re_ (concat "\\(\\*+\\)[ \t]*"))
(old-level (if (string-match ^re txt)
- (- (match-end 0) (match-beginning 0))
+ (- (match-end 0) (match-beginning 0) 1)
-1))
(force-level (cond (level (prefix-numeric-value level))
((string-match
^re_ (buffer-substring (point-at-bol) (point)))
- (- (match-end 0) (match-beginning 0)))
+ (- (match-end 1) (match-beginning 1)))
(t nil)))
(previous-level (save-excursion
(condition-case nil
(progn
(outline-previous-visible-heading 1)
(if (looking-at re)
- (- (match-end 0) (match-beginning 0))
+ (- (match-end 0) (match-beginning 0) 1)
1))
(error 1))))
(next-level (save-excursion
(condition-case nil
(progn
- (outline-next-visible-heading 1)
+ (or (looking-at outline-regexp)
+ (outline-next-visible-heading 1))
(if (looking-at re)
- (- (match-end 0) (match-beginning 0))
+ (- (match-end 0) (match-beginning 0) 1)
1))
(error 1))))
(new-level (or force-level (max previous-level next-level)))
(= old-level new-level))
0
(- new-level old-level)))
- (shift1 shift)
(delta (if (> shift 0) -1 1))
(func (if (> shift 0) 'org-demote 'org-promote))
(org-odd-levels-only nil)
beg end)
- ;; Remove the forces level indicator
+ ;; Remove the forced level indicator
(if force-level
(delete-region (point-at-bol) (point)))
- ;; Make sure we start at the beginning of an empty line
- (if (not (bolp)) (insert "\n"))
- (if (not (looking-at "[ \t]*$"))
- (progn (insert "\n") (backward-char 1)))
;; Paste
+ (beginning-of-line 1)
+ (org-back-over-empty-lines) ;; FIXME: correct fix????
(setq beg (point))
- (if (string-match "[ \t\r\n]+\\'" txt)
- (setq txt (replace-match "\n" t t txt)))
- (insert txt)
+ (insert-before-markers txt) ;; FIXME: correct fix????
+ (unless (string-match "\n\\'" txt) (insert "\n"))
(setq end (point))
- (if (looking-at "[ \t\r\n]+")
- (replace-match "\n"))
(goto-char beg)
+ (skip-chars-forward " \t\n\r")
+ (setq beg (point))
;; Shift if necessary
- (if (= shift 0)
- (message "Pasted at level %d, without shift" new-level)
+ (unless (= shift 0)
(save-restriction
(narrow-to-region beg end)
(while (not (= shift 0))
(org-map-region func (point-min) (point-max))
(setq shift (+ delta shift)))
- (goto-char (point-min))
- (message "Pasted at level %d, with shift by %d levels"
- new-level shift1)))
+ (goto-char (point-min))))
+ (when (interactive-p)
+ (message "Clipboard pasted as level %d subtree" new-level))
(if (and kill-ring
(eq org-subtree-clip (current-kill 0))
org-subtree-clip-folded)
If optional TXT is given, check this string instead of the current kill."
(let* ((kill (or txt (and kill-ring (current-kill 0)) ""))
(start-level (and kill
- (string-match (concat "\\`" outline-regexp) kill)
- (- (match-end 0) (match-beginning 0))))
- (re (concat "^" outline-regexp))
- (start 1))
+ (string-match (concat "\\`\\([ \t\n\r]*?\n\\)?\\("
+ org-outline-regexp "\\)")
+ kill)
+ (- (match-end 2) (match-beginning 2) 1)))
+ (re (concat "^" org-outline-regexp))
+ (start (1+ (match-beginning 2))))
(if (not start-level)
- nil ;; does not even start with a heading
+ (progn
+ nil) ;; does not even start with a heading
(catch 'exit
(while (setq start (string-match re kill (1+ start)))
- (if (< (- (match-end 0) (match-beginning 0)) start-level)
- (throw 'exit nil)))
+ (when (< (- (match-end 0) (match-beginning 0) 1) start-level)
+ (throw 'exit nil)))
t))))
(defun org-narrow-to-subtree ()
"Narrow buffer to the current subtree."
(interactive)
(save-excursion
- (narrow-to-region
- (progn (org-back-to-heading) (point))
- (progn (org-end-of-subtree t) (point)))))
+ (save-match-data
+ (narrow-to-region
+ (progn (org-back-to-heading) (point))
+ (progn (org-end-of-subtree t t) (point))))))
;;; Outline Sorting
(defun org-sort (with-case)
- "Call `org-sort-entries' or `org-table-sort-lines', depending on context."
+ "Call `org-sort-entries-or-items' or `org-table-sort-lines'.
+Optional argument WITH-CASE means sort case-sensitively."
(interactive "P")
(if (org-at-table-p)
(org-call-with-arg 'org-table-sort-lines with-case)
- (org-call-with-arg 'org-sort-entries with-case)))
+ (org-call-with-arg 'org-sort-entries-or-items with-case)))
-(defun org-sort-entries (&optional with-case sorting-type)
+(defvar org-priority-regexp) ; defined later in the file
+
+(defun org-sort-entries-or-items (&optional with-case sorting-type getkey-func property)
"Sort entries on a certain level of an outline tree.
If there is an active region, the entries in the region are sorted.
Else, if the cursor is before the first entry, sort the top-level items.
Sorting can be alphabetically, numerically, and by date/time as given by
the first time stamp in the entry. The command prompts for the sorting
type unless it has been given to the function through the SORTING-TYPE
-argument, which needs to a character, any of (?n ?N ?a ?A ?t ?T).
+argument, which needs to a character, any of (?n ?N ?a ?A ?t ?T ?p ?P ?f ?F).
+If the SORTING-TYPE is ?f or ?F, then GETKEY-FUNC specifies a function to be
+called with point at the beginning of the record. It must return either
+a string or a number that should serve as the sorting key for that record.
Comparing entries ignores case by default. However, with an optional argument
-WITH-CASE, the sorting considers case as well. With two prefix arguments
-`C-u C-u', sorting is case-sensitive and duplicate entries will be removed."
+WITH-CASE, the sorting considers case as well."
(interactive "P")
- (let ((unique (equal with-case '(16)))
- start beg end entries stars re re2 p nentries (nremoved 0)
- last txt what)
+ (let ((case-func (if with-case 'identity 'downcase))
+ start beg end stars re re2
+ txt what tmp plain-list-p)
;; Find beginning and end of region to sort
(cond
((org-region-active-p)
;; we will sort the region
(setq end (region-end)
- what "region")
+ what "region")
(goto-char (region-beginning))
(if (not (org-on-heading-p)) (outline-next-heading))
(setq start (point)))
+ ((org-at-item-p)
+ ;; we will sort this plain list
+ (org-beginning-of-item-list) (setq start (point))
+ (org-end-of-item-list) (setq end (point))
+ (goto-char start)
+ (setq plain-list-p t
+ what "plain list"))
((or (org-on-heading-p)
- (condition-case nil (progn (org-back-to-heading) t) (error nil)))
+ (condition-case nil (progn (org-back-to-heading) t) (error nil)))
;; we will sort the children of the current headline
(org-back-to-heading)
- (setq start (point) end (org-end-of-subtree) what "children")
+ (setq start (point)
+ end (progn (org-end-of-subtree t t)
+ (org-back-over-empty-lines)
+ (point))
+ what "children")
(goto-char start)
(show-subtree)
(outline-next-heading))
(setq start (point) end (point-max) what "top-level")
(goto-char start)
(show-all)))
+
(setq beg (point))
- (if (>= (point) end) (error "Nothing to sort"))
- (looking-at "\\(\\*+\\)")
- (setq stars (match-string 1)
- re (concat "^" (regexp-quote stars) " +")
- re2 (concat "^" (regexp-quote (substring stars 0 -1)) "[^*]")
- txt (buffer-substring beg end))
- (if (not (equal (substring txt -1) "\n")) (setq txt (concat txt "\n")))
- (if (and (not (equal stars "*")) (string-match re2 txt))
- (error "Region to sort contains a level above the first entry"))
- ;; Make a list that can be sorted.
- ;; The car is the string for comparison, the cdr is the subtree
- (message "Sorting entries...")
- (setq entries
- (mapcar
- (lambda (x)
- (string-match "^.*\\(\n.*\\)?" x) ; take two lines
- (cons (match-string 0 x) x))
- (org-split-string txt re)))
+ (if (>= beg end) (error "Nothing to sort"))
+
+ (unless plain-list-p
+ (looking-at "\\(\\*+\\)")
+ (setq stars (match-string 1)
+ re (concat "^" (regexp-quote stars) " +")
+ re2 (concat "^" (regexp-quote (substring stars 0 -1)) "[^*]")
+ txt (buffer-substring beg end))
+ (if (not (equal (substring txt -1) "\n")) (setq txt (concat txt "\n")))
+ (if (and (not (equal stars "*")) (string-match re2 txt))
+ (error "Region to sort contains a level above the first entry")))
+
+ (unless sorting-type
+ (message
+ (if plain-list-p
+ "Sort %s: [a]lpha [n]umeric [t]ime [f]unc A/N/T/F means reversed:"
+ "Sort %s: [a]lpha [n]umeric [t]ime [p]riority p[r]operty [f]unc A/N/T/P/F means reversed:")
+ what)
+ (setq sorting-type (read-char-exclusive))
+
+ (and (= (downcase sorting-type) ?f)
+ (setq getkey-func
+ (completing-read "Sort using function: "
+ obarray 'fboundp t nil nil))
+ (setq getkey-func (intern getkey-func)))
+
+ (and (= (downcase sorting-type) ?r)
+ (setq property
+ (completing-read "Property: "
+ (mapcar 'list (org-buffer-property-keys t))
+ nil t))))
- ;; Sort the list
- (save-excursion
- (goto-char start)
- (setq entries (org-do-sort entries what with-case sorting-type)))
+ (message "Sorting entries...")
- ;; Delete the old stuff
- (goto-char beg)
- (kill-region beg end)
- (setq nentries (length entries))
- ;; Insert the sorted entries, and remove duplicates if this is required
- (while (setq p (pop entries))
- (if (and unique (equal last (setq last (org-trim (cdr p)))))
- (setq nremoved (1+ nremoved)) ; same entry as before, skip it
- (insert stars " " (cdr p))))
- (goto-char start)
- (message "Sorting entries...done (%d entries%s)"
- nentries
- (if unique (format ", %d duplicates removed" nremoved) ""))))
+ (save-restriction
+ (narrow-to-region start end)
+
+ (let ((dcst (downcase sorting-type))
+ (now (current-time)))
+ (sort-subr
+ (/= dcst sorting-type)
+ ;; This function moves to the beginning character of the "record" to
+ ;; be sorted.
+ (if plain-list-p
+ (lambda nil
+ (if (org-at-item-p) t (goto-char (point-max))))
+ (lambda nil
+ (if (re-search-forward re nil t)
+ (goto-char (match-beginning 0))
+ (goto-char (point-max)))))
+ ;; This function moves to the last character of the "record" being
+ ;; sorted.
+ (if plain-list-p
+ 'org-end-of-item
+ (lambda nil
+ (save-match-data
+ (condition-case nil
+ (outline-forward-same-level 1)
+ (error
+ (goto-char (point-max)))))))
+
+ ;; This function returns the value that gets sorted against.
+ (if plain-list-p
+ (lambda nil
+ (when (looking-at "[ \t]*[-+*0-9.)]+[ \t]+")
+ (cond
+ ((= dcst ?n)
+ (string-to-number (buffer-substring (match-end 0)
+ (point-at-eol))))
+ ((= dcst ?a)
+ (buffer-substring (match-end 0) (point-at-eol)))
+ ((= dcst ?t)
+ (if (re-search-forward org-ts-regexp
+ (point-at-eol) t)
+ (org-time-string-to-time (match-string 0))
+ now))
+ ((= dcst ?f)
+ (if getkey-func
+ (progn
+ (setq tmp (funcall getkey-func))
+ (if (stringp tmp) (setq tmp (funcall case-func tmp)))
+ tmp)
+ (error "Invalid key function `%s'" getkey-func)))
+ (t (error "Invalid sorting type `%c'" sorting-type)))))
+ (lambda nil
+ (cond
+ ((= dcst ?n)
+ (if (looking-at outline-regexp)
+ (string-to-number (buffer-substring (match-end 0)
+ (point-at-eol)))
+ nil))
+ ((= dcst ?a)
+ (funcall case-func (buffer-substring (point-at-bol)
+ (point-at-eol))))
+ ((= dcst ?t)
+ (if (re-search-forward org-ts-regexp
+ (save-excursion
+ (forward-line 2)
+ (point)) t)
+ (org-time-string-to-time (match-string 0))
+ now))
+ ((= dcst ?p)
+ (if (re-search-forward org-priority-regexp (point-at-eol) t)
+ (string-to-char (match-string 2))
+ org-default-priority))
+ ((= dcst ?r)
+ (or (org-entry-get nil property) ""))
+ ((= dcst ?f)
+ (if getkey-func
+ (progn
+ (setq tmp (funcall getkey-func))
+ (if (stringp tmp) (setq tmp (funcall case-func tmp)))
+ tmp)
+ (error "Invalid key function `%s'" getkey-func)))
+ (t (error "Invalid sorting type `%c'" sorting-type)))))
+ nil
+ (cond
+ ((= dcst ?a) 'string<)
+ ((= dcst ?t) 'time-less-p)
+ (t nil)))))
+ (message "Sorting entries...done")))
(defun org-do-sort (table what &optional with-case sorting-type)
"Sort TABLE of WHAT according to SORTING-TYPE.
If WITH-CASE is non-nil, the sorting will be case-sensitive."
(unless sorting-type
(message
- "Sort %s: [a]lphabetically [n]umerically [t]ime. A/N/T means reversed:"
+ "Sort %s: [a]lphabetic. [n]umeric. [t]ime. A/N/T means reversed:"
what)
(setq sorting-type (read-char-exclusive)))
(let ((dcst (downcase sorting-type))
(setq extractfun 'string-to-number
comparefun (if (= dcst sorting-type) '< '>)))
((= dcst ?a)
- (setq extractfun (if with-case 'identity 'downcase)
+ (setq extractfun (if with-case (lambda(x) (org-sort-remove-invisible x))
+ (lambda(x) (downcase (org-sort-remove-invisible x))))
comparefun (if (= dcst sorting-type)
'string<
(lambda (a b) (and (not (string< a b))
(cond
((eq llt t) "\\([ \t]*\\([-+]\\|\\([0-9]+[.)]\\)\\)\\|[ \t]+\\*\\)\\( \\|$\\)")
((= llt ?.) "\\([ \t]*\\([-+]\\|\\([0-9]+\\.\\)\\)\\|[ \t]+\\*\\)\\( \\|$\\)")
- ((= llt ?\)) "\\([ \t]*\\([-+]\\|\\([0-9]+)\\)\\)\\|[ \t]+\\*\\)\\( \\|$\\)")
+ ((= llt ?\)) "\\([ \t]*\\([-+]\\|\\([0-9]+))\\)\\|[ \t]+\\*\\)\\( \\|$\\)")
(t (error "Invalid value of `org-plain-list-ordered-item-terminator'")))))))
-
(defun org-in-item-p ()
"It the cursor inside a plain list item.
Does not have to be the first line."
(open-line (if blank 2 1)))
((<= (point) eow)
(beginning-of-line 1))
- (t (newline (if blank 2 1))))
+ (t
+ (unless (org-get-alist-option org-M-RET-may-split-line 'item)
+ (end-of-line 1)
+ (delete-horizontal-space))
+ (newline (if blank 2 1))))
(insert bul (if checkbox "[ ]" ""))
(just-one-space)
(setq pos (point))
(save-excursion
(goto-char (match-end 0))
(skip-chars-forward " \t")
- (looking-at "\\[[ X]\\]"))))
+ (looking-at "\\[[- X]\\]"))))
(defun org-toggle-checkbox (&optional arg)
"Toggle the checkbox in the current line."
((org-on-heading-p)
(setq beg (point) end (save-excursion (outline-next-heading) (point))))
((org-at-item-checkbox-p)
- (save-excursion
- (replace-match (if (equal (match-string 0) "[ ]") "[X]" "[ ]") t t))
+ (let ((pos (point)))
+ (replace-match
+ (cond (arg "[-]")
+ ((member (match-string 0) '("[ ]" "[-]")) "[X]")
+ (t "[ ]"))
+ t t)
+ (goto-char pos))
(throw 'exit t))
(t (error "Not at a checkbox or heading, and no active region")))
(save-excursion
(org-update-checkbox-count)))
(defun org-update-checkbox-count (&optional all)
- "Update the checkbox statistics in the current section.
+ "Update the checkbox statistics in the current section.
This will find all statistic cookies like [57%] and [6/12] and update them
with the current numbers. With optional prefix argument ALL, do this for
the whole buffer."
- (interactive "P")
- (save-excursion
- (let* ((buffer-invisibility-spec nil) ; Emacs 21 compatibility
- (beg (progn (outline-back-to-heading) (point)))
- (end (move-marker (make-marker)
- (progn (outline-next-heading) (point))))
- (re "\\(\\[[0-9]*%\\]\\)\\|\\(\\[[0-9]*/[0-9]*\\]\\)")
- (re-box "^[ \t]*\\([-+*]\\|[0-9]+[.)]\\) +\\(\\[[ X]\\]\\)")
- b1 e1 f1 c-on c-off lim (cstat 0))
- (when all
- (goto-char (point-min))
- (outline-next-heading)
- (setq beg (point) end (point-max)))
- (goto-char beg)
- (while (re-search-forward re end t)
- (setq cstat (1+ cstat)
- b1 (match-beginning 0)
- e1 (match-end 0)
- f1 (match-beginning 1)
- lim (cond
- ((org-on-heading-p) (outline-next-heading) (point))
- ((org-at-item-p) (org-end-of-item) (point))
- (t nil))
- c-on 0 c-off 0)
- (goto-char e1)
- (when lim
- (while (re-search-forward re-box lim t)
- (if (equal (match-string 2) "[ ]")
- (setq c-off (1+ c-off))
- (setq c-on (1+ c-on))))
- (delete-region b1 e1)
- (goto-char b1)
- (insert (if f1
- (format "[%d%%]" (/ (* 100 c-on) (max 1 (+ c-on c-off))))
- (format "[%d/%d]" c-on (+ c-on c-off))))))
- (when (interactive-p)
- (message "Checkbox satistics updated %s (%d places)"
- (if all "in entire file" "in current outline entry") cstat)))))
+ (interactive "P")
+ (save-excursion
+ (let* ((buffer-invisibility-spec (org-inhibit-invisibility)) ; Emacs 21
+ (beg (condition-case nil
+ (progn (outline-back-to-heading) (point))
+ (error (point-min))))
+ (end (move-marker (make-marker)
+ (progn (outline-next-heading) (point))))
+ (re "\\(\\(\\[[0-9]*%\\]\\)\\|\\(\\[[0-9]*/[0-9]*\\]\\)\\)")
+ (re-box "^[ \t]*\\([-+*]\\|[0-9]+[.)]\\) +\\(\\[[- X]\\]\\)")
+ (re-find (concat re "\\|" re-box))
+ beg-cookie end-cookie is-percent c-on c-off lim
+ eline curr-ind next-ind continue-from startsearch
+ (cstat 0)
+ )
+ (when all
+ (goto-char (point-min))
+ (outline-next-heading)
+ (setq beg (point) end (point-max)))
+ (goto-char end)
+ ;; find each statistic cookie
+ (while (re-search-backward re-find beg t)
+ (setq beg-cookie (match-beginning 1)
+ end-cookie (match-end 1)
+ cstat (+ cstat (if end-cookie 1 0))
+ startsearch (point-at-eol)
+ continue-from (point-at-bol)
+ is-percent (match-beginning 2)
+ lim (cond
+ ((org-on-heading-p) (outline-next-heading) (point))
+ ((org-at-item-p) (org-end-of-item) (point))
+ (t nil))
+ c-on 0
+ c-off 0)
+ (when lim
+ ;; find first checkbox for this cookie and gather
+ ;; statistics from all that are at this indentation level
+ (goto-char startsearch)
+ (if (re-search-forward re-box lim t)
+ (progn
+ (org-beginning-of-item)
+ (setq curr-ind (org-get-indentation))
+ (setq next-ind curr-ind)
+ (while (= curr-ind next-ind)
+ (save-excursion (end-of-line) (setq eline (point)))
+ (if (re-search-forward re-box eline t)
+ (if (member (match-string 2) '("[ ]" "[-]"))
+ (setq c-off (1+ c-off))
+ (setq c-on (1+ c-on))
+ )
+ )
+ (org-end-of-item)
+ (setq next-ind (org-get-indentation))
+ )))
+ (goto-char continue-from)
+ ;; update cookie
+ (when end-cookie
+ (delete-region beg-cookie end-cookie)
+ (goto-char beg-cookie)
+ (insert
+ (if is-percent
+ (format "[%d%%]" (/ (* 100 c-on) (max 1 (+ c-on c-off))))
+ (format "[%d/%d]" c-on (+ c-on c-off)))))
+ ;; update items checkbox if it has one
+ (when (org-at-item-p)
+ (org-beginning-of-item)
+ (when (and (> (+ c-on c-off) 0)
+ (re-search-forward re-box (point-at-eol) t))
+ (setq beg-cookie (match-beginning 2)
+ end-cookie (match-end 2))
+ (delete-region beg-cookie end-cookie)
+ (goto-char beg-cookie)
+ (cond ((= c-off 0) (insert "[X]"))
+ ((= c-on 0) (insert "[ ]"))
+ (t (insert "[-]")))
+ )))
+ (goto-char continue-from))
+ (when (interactive-p)
+ (message "Checkbox satistics updated %s (%d places)"
+ (if all "in entire file" "in current outline entry") cstat)))))
(defun org-get-checkbox-statistics-face ()
"Select the face for checkbox statistics.
(concat (make-string i1 ?\ ) l)
l)))
+(defcustom org-empty-line-terminates-plain-lists nil
+ "Non-nil means, an empty line ends all plain list levels.
+When nil, empty lines are part of the preceeding item."
+ :group 'org-plain-lists
+ :type 'boolean)
+
(defun org-beginning-of-item ()
"Go to the beginning of the current hand-formatted item.
If the cursor is not in an item, throw an error."
(interactive)
(let ((pos (point))
- (limit (save-excursion (org-back-to-heading)
- (beginning-of-line 2) (point)))
+ (limit (save-excursion
+ (condition-case nil
+ (progn
+ (org-back-to-heading)
+ (beginning-of-line 2) (point))
+ (error (point-min)))))
+ (ind-empty (if org-empty-line-terminates-plain-lists 0 10000))
ind ind1)
(if (org-at-item-p)
(beginning-of-line 1)
(if (catch 'exit
(while t
(beginning-of-line 0)
- (if (< (point) limit) (throw 'exit nil))
- (unless (looking-at "[ \t]*$")
+ (if (or (bobp) (< (point) limit)) (throw 'exit nil))
+
+ (if (looking-at "[ \t]*$")
+ (setq ind1 ind-empty)
(skip-chars-forward " \t")
- (setq ind1 (current-column))
- (if (< ind1 ind)
- (throw 'exit (org-at-item-p))))))
+ (setq ind1 (current-column)))
+ (if (< ind1 ind)
+ (progn (beginning-of-line 1) (throw 'exit (org-at-item-p))))))
nil
(goto-char pos)
(error "Not in an item")))))
"Go to the end of the current hand-formatted item.
If the cursor is not in an item, throw an error."
(interactive)
- (let ((pos (point))
- (limit (save-excursion (outline-next-heading) (point)))
- (ind (save-excursion
- (org-beginning-of-item)
- (skip-chars-forward " \t")
- (current-column)))
- ind1)
- (if (catch 'exit
- (while t
- (beginning-of-line 2)
- (if (>= (point) limit) (throw 'exit t))
- (unless (looking-at "[ \t]*$")
- (skip-chars-forward " \t")
- (setq ind1 (current-column))
- (if (<= ind1 ind) (throw 'exit t)))))
- (beginning-of-line 1)
+ (let* ((pos (point))
+ ind1
+ (ind-empty (if org-empty-line-terminates-plain-lists 0 10000))
+ (limit (save-excursion (outline-next-heading) (point)))
+ (ind (save-excursion
+ (org-beginning-of-item)
+ (skip-chars-forward " \t")
+ (current-column)))
+ (end (catch 'exit
+ (while t
+ (beginning-of-line 2)
+ (if (eobp) (throw 'exit (point)))
+ (if (>= (point) limit) (throw 'exit (point-at-bol)))
+ (if (looking-at "[ \t]*$")
+ (setq ind1 ind-empty)
+ (skip-chars-forward " \t")
+ (setq ind1 (current-column)))
+ (if (<= ind1 ind)
+ (throw 'exit (point-at-bol)))))))
+ (if end
+ (goto-char end)
(goto-char pos)
(error "Not in an item"))))
(defun org-previous-item ()
"Move to the beginning of the previous item in the current plain list.
-Error if not at a plain list, or if this is the last item in the list."
+Error if not at a plain list, or if this is the first item in the list."
(interactive)
- (let (beg ind (pos (point)))
+ (let (beg ind ind1 (pos (point)))
(org-beginning-of-item)
(setq beg (point))
(setq ind (org-get-indentation))
(beginning-of-line 0)
(if (looking-at "[ \t]*$")
nil
- (if (<= (org-get-indentation) ind)
+ (if (<= (setq ind1 (org-get-indentation)) ind)
(throw 'exit t)))))
(condition-case nil
- (org-beginning-of-item)
+ (if (or (not (org-at-item-p))
+ (< ind1 (1- ind)))
+ (error "")
+ (org-beginning-of-item))
(error (goto-char pos)
(error "On first item")))))
+(defun org-first-list-item-p ()
+ "Is this heading the item in a plain list?"
+ (unless (org-at-item-p)
+ (error "Not at a plain list item"))
+ (org-beginning-of-item)
+ (= (point) (save-excursion (org-beginning-of-item-list))))
+
(defun org-move-item-down ()
"Move the plain list item at point down, i.e. swap with following item.
Subitems (items with larger indentation) are considered part of the item,
so this really moves item trees."
(interactive)
- (let (beg end ind ind1 (pos (point)) txt)
+ (let (beg beg0 end end0 ind ind1 (pos (point)) txt ne-end ne-beg)
(org-beginning-of-item)
- (setq beg (point))
+ (setq beg0 (point))
+ (save-excursion
+ (setq ne-beg (org-back-over-empty-lines))
+ (setq beg (point)))
+ (goto-char beg0)
(setq ind (org-get-indentation))
(org-end-of-item)
- (setq end (point))
+ (setq end0 (point))
(setq ind1 (org-get-indentation))
+ (setq ne-end (org-back-over-empty-lines))
+ (setq end (point))
+ (goto-char beg0)
+ (when (and (org-first-list-item-p) (< ne-end ne-beg))
+ ;; include less whitespace
+ (save-excursion
+ (goto-char beg)
+ (forward-line (- ne-beg ne-end))
+ (setq beg (point))))
+ (goto-char end0)
(if (and (org-at-item-p) (= ind ind1))
(progn
(org-end-of-item)
+ (org-back-over-empty-lines)
(setq txt (buffer-substring beg end))
(save-excursion
(delete-region beg end))
(setq pos (point))
(insert txt)
- (goto-char pos)
+ (goto-char pos) (org-skip-whitespace)
(org-maybe-renumber-ordered-list))
(goto-char pos)
(error "Cannot move this item further down"))))
Subitems (items with larger indentation) are considered part of the item,
so this really moves item trees."
(interactive "p")
- (let (beg end ind ind1 (pos (point)) txt)
+ (let (beg beg0 end ind ind1 (pos (point)) txt
+ ne-beg ne-ins ins-end)
(org-beginning-of-item)
- (setq beg (point))
+ (setq beg0 (point))
(setq ind (org-get-indentation))
+ (save-excursion
+ (setq ne-beg (org-back-over-empty-lines))
+ (setq beg (point)))
+ (goto-char beg0)
(org-end-of-item)
(setq end (point))
- (goto-char beg)
+ (goto-char beg0)
(catch 'exit
(while t
(beginning-of-line 0)
(if (looking-at "[ \t]*$")
- nil
+ (if org-empty-line-terminates-plain-lists
+ (progn
+ (goto-char pos)
+ (error "Cannot move this item further up"))
+ nil)
(if (<= (setq ind1 (org-get-indentation)) ind)
(throw 'exit t)))))
(condition-case nil
(setq ind1 (org-get-indentation))
(if (and (org-at-item-p) (= ind ind1))
(progn
+ (setq ne-ins (org-back-over-empty-lines))
(setq txt (buffer-substring beg end))
(save-excursion
(delete-region beg end))
(setq pos (point))
(insert txt)
- (goto-char pos)
+ (setq ins-end (point))
+ (goto-char pos) (org-skip-whitespace)
+
+ (when (and (org-first-list-item-p) (> ne-ins ne-beg))
+ ;; Move whitespace back to beginning
+ (save-excursion
+ (goto-char ins-end)
+ (let ((kill-whole-line t))
+ (kill-line (- ne-ins ne-beg)) (point)))
+ (insert (make-string (- ne-ins ne-beg) ?\n)))
+
(org-maybe-renumber-ordered-list))
(goto-char pos)
(error "Cannot move this item further up"))))
"Renumber the ordered list at point if setup allows it.
This tests the user option `org-auto-renumber-ordered-lists' before
doing the renumbering."
- (and org-auto-renumber-ordered-lists
- (org-at-item-p)
- (match-beginning 3)
- (org-renumber-ordered-list 1)))
+ (interactive)
+ (when (and org-auto-renumber-ordered-lists
+ (org-at-item-p))
+ (if (match-beginning 3)
+ (org-renumber-ordered-list 1)
+ (org-fix-bullet-type))))
+
+(defun org-maybe-renumber-ordered-list-safe ()
+ (condition-case nil
+ (save-excursion
+ (org-maybe-renumber-ordered-list))
+ (error nil)))
+
+(defun org-cycle-list-bullet (&optional which)
+ "Cycle through the different itemize/enumerate bullets.
+This cycle the entire list level through the sequence:
+
+ `-' -> `+' -> `*' -> `1.' -> `1)'
+
+If WHICH is a string, use that as the new bullet. If WHICH is an integer,
+0 meand `-', 1 means `+' etc."
+ (interactive "P")
+ (org-preserve-lc
+ (org-beginning-of-item-list)
+ (org-at-item-p)
+ (beginning-of-line 1)
+ (let ((current (match-string 0))
+ (prevp (eq which 'previous))
+ new)
+ (setq new (cond
+ ((and (numberp which)
+ (nth (1- which) '("-" "+" "*" "1." "1)"))))
+ ((string-match "-" current) (if prevp "1)" "+"))
+ ((string-match "\\+" current)
+ (if prevp "-" (if (looking-at "\\S-") "1." "*")))
+ ((string-match "\\*" current) (if prevp "+" "1."))
+ ((string-match "\\." current) (if prevp "*" "1)"))
+ ((string-match ")" current) (if prevp "1." "-"))
+ (t (error "This should not happen"))))
+ (and (looking-at "\\([ \t]*\\)\\S-+") (replace-match (concat "\\1" new)))
+ (org-fix-bullet-type)
+ (org-maybe-renumber-ordered-list))))
(defun org-get-string-indentation (s)
"What indentation has S due to SPACE and TAB at the beginning of the string?"
(ind (org-get-string-indentation
(buffer-substring (point-at-bol) (match-beginning 3))))
;; (term (substring (match-string 3) -1))
- ind1 (n (1- arg)))
+ ind1 (n (1- arg))
+ fmt)
;; find where this list begins
+ (org-beginning-of-item-list)
+ (looking-at "[ \t]*[0-9]+\\([.)]\\)")
+ (setq fmt (concat "%d" (match-string 1)))
+ (beginning-of-line 0)
+ ;; walk forward and replace these numbers
(catch 'exit
(while t
(catch 'next
- (beginning-of-line 0)
- (if (looking-at "[ \t]*$") (throw 'next t))
+ (beginning-of-line 2)
+ (if (eobp) (throw 'exit nil))
+ (if (looking-at "[ \t]*$") (throw 'next nil))
(skip-chars-forward " \t") (setq ind1 (current-column))
- (if (or (< ind1 ind)
- (and (= ind1 ind)
- (not (org-at-item-p))))
- (throw 'exit t)))))
- ;; Walk forward and replace these numbers
+ (if (> ind1 ind) (throw 'next t))
+ (if (< ind1 ind) (throw 'exit t))
+ (if (not (org-at-item-p)) (throw 'exit nil))
+ (delete-region (match-beginning 2) (match-end 2))
+ (goto-char (match-beginning 2))
+ (insert (format fmt (setq n (1+ n)))))))
+ (goto-line line)
+ (move-to-column col)))
+
+(defun org-fix-bullet-type ()
+ "Make sure all items in this list have the same bullet as the firsst item."
+ (interactive)
+ (unless (org-at-item-p) (error "This is not a list"))
+ (let ((line (org-current-line))
+ (col (current-column))
+ (ind (current-indentation))
+ ind1 bullet)
+ ;; find where this list begins
+ (org-beginning-of-item-list)
+ (beginning-of-line 1)
+ ;; find out what the bullet type is
+ (looking-at "[ \t]*\\(\\S-+\\)")
+ (setq bullet (match-string 1))
+ ;; walk forward and replace these numbers
+ (beginning-of-line 0)
(catch 'exit
(while t
(catch 'next
(if (> ind1 ind) (throw 'next t))
(if (< ind1 ind) (throw 'exit t))
(if (not (org-at-item-p)) (throw 'exit nil))
- (if (not (match-beginning 3))
- (error "unordered bullet in ordered list. Press \\[undo] to recover"))
- (delete-region (match-beginning 3) (1- (match-end 3)))
- (goto-char (match-beginning 3))
- (insert (format "%d" (setq n (1+ n)))))))
+ (skip-chars-forward " \t")
+ (looking-at "\\S-+")
+ (replace-match bullet))))
(goto-line line)
- (move-to-column col)))
+ (move-to-column col)
+ (if (string-match "[0-9]" bullet)
+ (org-renumber-ordered-list 1))))
+
+(defun org-beginning-of-item-list ()
+ "Go to the beginning of the current item list.
+I.e. to the first item in this list."
+ (interactive)
+ (org-beginning-of-item)
+ (let ((pos (point-at-bol))
+ (ind (org-get-indentation))
+ ind1)
+ ;; find where this list begins
+ (catch 'exit
+ (while t
+ (catch 'next
+ (beginning-of-line 0)
+ (if (looking-at "[ \t]*$")
+ (throw (if (bobp) 'exit 'next) t))
+ (skip-chars-forward " \t") (setq ind1 (current-column))
+ (if (or (< ind1 ind)
+ (and (= ind1 ind)
+ (not (org-at-item-p)))
+ (bobp))
+ (throw 'exit t)
+ (when (org-at-item-p) (setq pos (point-at-bol)))))))
+ (goto-char pos)))
+
+
+(defun org-end-of-item-list ()
+ "Go to the end of the current item list.
+I.e. to the text after the last item."
+ (interactive)
+ (org-beginning-of-item)
+ (let ((pos (point-at-bol))
+ (ind (org-get-indentation))
+ ind1)
+ ;; find where this list begins
+ (catch 'exit
+ (while t
+ (catch 'next
+ (beginning-of-line 2)
+ (if (looking-at "[ \t]*$")
+ (throw (if (eobp) 'exit 'next) t))
+ (skip-chars-forward " \t") (setq ind1 (current-column))
+ (if (or (< ind1 ind)
+ (and (= ind1 ind)
+ (not (org-at-item-p)))
+ (eobp))
+ (progn
+ (setq pos (point-at-bol))
+ (throw 'exit t))))))
+ (goto-char pos)))
+
(defvar org-last-indent-begin-marker (make-marker))
(defvar org-last-indent-end-marker (make-marker))
(unless (org-at-item-p)
(error "Not on an item"))
(save-excursion
- (let (beg end ind ind1)
+ (let (beg end ind ind1 tmp delta ind-down ind-up)
(if (memq last-command '(org-shiftmetaright org-shiftmetaleft))
(setq beg org-last-indent-begin-marker
end org-last-indent-end-marker)
(org-end-of-item)
(setq end (move-marker org-last-indent-end-marker (point))))
(goto-char beg)
- (skip-chars-forward " \t") (setq ind (current-column))
- (if (< (+ arg ind) 0) (error "Cannot outdent beyond margin"))
+ (setq tmp (org-item-indent-positions)
+ ind (car tmp)
+ ind-down (nth 2 tmp)
+ ind-up (nth 1 tmp)
+ delta (if (> arg 0)
+ (if ind-down (- ind-down ind) 2)
+ (if ind-up (- ind-up ind) -2)))
+ (if (< (+ delta ind) 0) (error "Cannot outdent beyond margin"))
(while (< (point) end)
(beginning-of-line 1)
(skip-chars-forward " \t") (setq ind1 (current-column))
(delete-region (point-at-bol) (point))
- (indent-to-column (+ ind1 arg))
- (beginning-of-line 2)))))
+ (or (eolp) (indent-to-column (+ ind1 delta)))
+ (beginning-of-line 2))))
+ (org-fix-bullet-type)
+ (org-maybe-renumber-ordered-list-safe)
+ (save-excursion
+ (beginning-of-line 0)
+ (condition-case nil (org-beginning-of-item) (error nil))
+ (org-maybe-renumber-ordered-list-safe)))
+
+(defun org-item-indent-positions ()
+ "Return indentation for plain list items.
+This returns a list with three values: The current indentation, the
+parent indentation and the indentation a child should habe.
+Assumes cursor in item line."
+ (let* ((bolpos (point-at-bol))
+ (ind (org-get-indentation))
+ ind-down ind-up pos)
+ (save-excursion
+ (org-beginning-of-item-list)
+ (skip-chars-backward "\n\r \t")
+ (when (org-in-item-p)
+ (org-beginning-of-item)
+ (setq ind-up (org-get-indentation))))
+ (setq pos (point))
+ (save-excursion
+ (cond
+ ((and (condition-case nil (progn (org-previous-item) t)
+ (error nil))
+ (or (forward-char 1) t)
+ (re-search-forward "^\\([ \t]*\\([-+]\\|\\([0-9]+[.)]\\)\\)\\|[ \t]+\\*\\)\\( \\|$\\)" bolpos t))
+ (setq ind-down (org-get-indentation)))
+ ((and (goto-char pos)
+ (org-at-item-p))
+ (goto-char (match-end 0))
+ (skip-chars-forward " \t")
+ (setq ind-down (current-column)))))
+ (list ind ind-up ind-down)))
+
+;;; The orgstruct minor mode
-;;;; Archiving
+;; Define a minor mode which can be used in other modes in order to
+;; integrate the org-mode structure editing commands.
+
+;; This is really a hack, because the org-mode structure commands use
+;; keys which normally belong to the major mode. Here is how it
+;; works: The minor mode defines all the keys necessary to operate the
+;; structure commands, but wraps the commands into a function which
+;; tests if the cursor is currently at a headline or a plain list
+;; item. If that is the case, the structure command is used,
+;; temporarily setting many Org-mode variables like regular
+;; expressions for filling etc. However, when any of those keys is
+;; used at a different location, function uses `key-binding' to look
+;; up if the key has an associated command in another currently active
+;; keymap (minor modes, major mode, global), and executes that
+;; command. There might be problems if any of the keys is otherwise
+;; used as a prefix key.
-(defalias 'org-advertized-archive-subtree 'org-archive-subtree)
+;; Another challenge is that the key binding for TAB can be tab or \C-i,
+;; likewise the binding for RET can be return or \C-m. Orgtbl-mode
+;; addresses this by checking explicitly for both bindings.
-(defun org-archive-subtree (&optional find-done)
- "Move the current subtree to the archive.
-The archive can be a certain top-level heading in the current file, or in
-a different file. The tree will be moved to that location, the subtree
-heading be marked DONE, and the current time will be added.
+(defvar orgstruct-mode-map (make-sparse-keymap)
+ "Keymap for the minor `orgstruct-mode'.")
-When called with prefix argument FIND-DONE, find whole trees without any
-open TODO items and archive them (after getting confirmation from the user).
-If the cursor is not at a headline when this comand is called, try all level
-1 trees. If the cursor is on a headline, only try the direct children of
-this heading. "
- (interactive "P")
- (if find-done
- (org-archive-all-done)
- ;; Save all relevant TODO keyword-relatex variables
+(defvar org-local-vars nil
+ "List of local variables, for use by `orgstruct-mode'")
- (let ((tr-org-todo-line-regexp org-todo-line-regexp) ; keep despite compiler
- (tr-org-todo-keywords org-todo-keywords)
- (tr-org-todo-interpretation org-todo-interpretation)
- (tr-org-done-string org-done-string)
- (tr-org-todo-regexp org-todo-regexp)
- (tr-org-todo-line-regexp org-todo-line-regexp)
- (tr-org-odd-levels-only org-odd-levels-only)
- (this-buffer (current-buffer))
- (org-archive-location org-archive-location)
- (re "^#\\+ARCHIVE:[ \t]+\\(\\S-.*\\S-\\)[ \t]*$")
- file heading buffer level newfile-p)
+;;;###autoload
+(define-minor-mode orgstruct-mode
+ "Toggle the minor more `orgstruct-mode'.
+This mode is for using Org-mode structure commands in other modes.
+The following key behave as if Org-mode was active, if the cursor
+is on a headline, or on a plain list item (both in the definition
+of Org-mode).
+
+M-up Move entry/item up
+M-down Move entry/item down
+M-left Promote
+M-right Demote
+M-S-up Move entry/item up
+M-S-down Move entry/item down
+M-S-left Promote subtree
+M-S-right Demote subtree
+M-q Fill paragraph and items like in Org-mode
+C-c ^ Sort entries
+C-c - Cycle list bullet
+TAB Cycle item visibility
+M-RET Insert new heading/item
+S-M-RET Insert new TODO heading / Chekbox item
+C-c C-c Set tags / toggle checkbox"
+ nil " OrgStruct" nil
+ (and (orgstruct-setup) (defun orgstruct-setup () nil)))
- ;; Try to find a local archive location
- (save-excursion
- (if (or (re-search-backward re nil t) (re-search-forward re nil t))
- (setq org-archive-location (match-string 1))))
+;;;###autoload
+(defun turn-on-orgstruct ()
+ "Unconditionally turn on `orgstruct-mode'."
+ (orgstruct-mode 1))
- (if (string-match "\\(.*\\)::\\(.*\\)" org-archive-location)
- (progn
- (setq file (format (match-string 1 org-archive-location)
+;;;###autoload
+(defun turn-on-orgstruct++ ()
+ "Unconditionally turn on `orgstruct-mode', and force org-mode indentations.
+In addition to setting orgstruct-mode, this also exports all indentation and
+autofilling variables from org-mode into the buffer. Note that turning
+off orgstruct-mode will *not* remove these additional settings."
+ (orgstruct-mode 1)
+ (let (var val)
+ (mapc
+ (lambda (x)
+ (when (string-match
+ "^\\(paragraph-\\|auto-fill\\|fill-paragraph\\|adaptive-fill\\|indent-\\)"
+ (symbol-name (car x)))
+ (setq var (car x) val (nth 1 x))
+ (org-set-local var (if (eq (car-safe val) 'quote) (nth 1 val) val))))
+ org-local-vars)))
+
+(defun orgstruct-error ()
+ "Error when there is no default binding for a structure key."
+ (interactive)
+ (error "This key has no function outside structure elements"))
+
+(defun orgstruct-setup ()
+ "Setup orgstruct keymaps."
+ (let ((nfunc 0)
+ (bindings
+ (list
+ '([(meta up)] org-metaup)
+ '([(meta down)] org-metadown)
+ '([(meta left)] org-metaleft)
+ '([(meta right)] org-metaright)
+ '([(meta shift up)] org-shiftmetaup)
+ '([(meta shift down)] org-shiftmetadown)
+ '([(meta shift left)] org-shiftmetaleft)
+ '([(meta shift right)] org-shiftmetaright)
+ '([(shift up)] org-shiftup)
+ '([(shift down)] org-shiftdown)
+ '("\C-c\C-c" org-ctrl-c-ctrl-c)
+ '("\M-q" fill-paragraph)
+ '("\C-c^" org-sort)
+ '("\C-c-" org-cycle-list-bullet)))
+ elt key fun cmd)
+ (while (setq elt (pop bindings))
+ (setq nfunc (1+ nfunc))
+ (setq key (org-key (car elt))
+ fun (nth 1 elt)
+ cmd (orgstruct-make-binding fun nfunc key))
+ (org-defkey orgstruct-mode-map key cmd))
+
+ ;; Special treatment needed for TAB and RET
+ (org-defkey orgstruct-mode-map [(tab)]
+ (orgstruct-make-binding 'org-cycle 102 [(tab)] "\C-i"))
+ (org-defkey orgstruct-mode-map "\C-i"
+ (orgstruct-make-binding 'org-cycle 103 "\C-i" [(tab)]))
+
+ (org-defkey orgstruct-mode-map "\M-\C-m"
+ (orgstruct-make-binding 'org-insert-heading 105
+ "\M-\C-m" [(meta return)]))
+ (org-defkey orgstruct-mode-map [(meta return)]
+ (orgstruct-make-binding 'org-insert-heading 106
+ [(meta return)] "\M-\C-m"))
+
+ (org-defkey orgstruct-mode-map [(shift meta return)]
+ (orgstruct-make-binding 'org-insert-todo-heading 107
+ [(meta return)] "\M-\C-m"))
+
+ (unless org-local-vars
+ (setq org-local-vars (org-get-local-variables)))
+
+ t))
+
+(defun orgstruct-make-binding (fun n &rest keys)
+ "Create a function for binding in the structure minor mode.
+FUN is the command to call inside a table. N is used to create a unique
+command name. KEYS are keys that should be checked in for a command
+to execute outside of tables."
+ (eval
+ (list 'defun
+ (intern (concat "orgstruct-hijacker-command-" (int-to-string n)))
+ '(arg)
+ (concat "In Structure, run `" (symbol-name fun) "'.\n"
+ "Outside of structure, run the binding of `"
+ (mapconcat (lambda (x) (format "%s" x)) keys "' or `")
+ "'.")
+ '(interactive "p")
+ (list 'if
+ '(org-context-p 'headline 'item)
+ (list 'org-run-like-in-org-mode (list 'quote fun))
+ (list 'let '(orgstruct-mode)
+ (list 'call-interactively
+ (append '(or)
+ (mapcar (lambda (k)
+ (list 'key-binding k))
+ keys)
+ '('orgstruct-error))))))))
+
+(defun org-context-p (&rest contexts)
+ "Check if local context is and of CONTEXTS.
+Possible values in the list of contexts are `table', `headline', and `item'."
+ (let ((pos (point)))
+ (goto-char (point-at-bol))
+ (prog1 (or (and (memq 'table contexts)
+ (looking-at "[ \t]*|"))
+ (and (memq 'headline contexts)
+ (looking-at "\\*+"))
+ (and (memq 'item contexts)
+ (looking-at "[ \t]*\\([-+*] \\|[0-9]+[.)] \\)")))
+ (goto-char pos))))
+
+(defun org-get-local-variables ()
+ "Return a list of all local variables in an org-mode buffer."
+ (let (varlist)
+ (with-current-buffer (get-buffer-create "*Org tmp*")
+ (erase-buffer)
+ (org-mode)
+ (setq varlist (buffer-local-variables)))
+ (kill-buffer "*Org tmp*")
+ (delq nil
+ (mapcar
+ (lambda (x)
+ (setq x
+ (if (symbolp x)
+ (list x)
+ (list (car x) (list 'quote (cdr x)))))
+ (if (string-match
+ "^\\(org-\\|orgtbl-\\|outline-\\|comment-\\|paragraph-\\|auto-fill\\|fill-paragraph\\|adaptive-fill\\|indent-\\)"
+ (symbol-name (car x)))
+ x nil))
+ varlist))))
+
+;;;###autoload
+(defun org-run-like-in-org-mode (cmd)
+ (unless org-local-vars
+ (setq org-local-vars (org-get-local-variables)))
+ (eval (list 'let org-local-vars
+ (list 'call-interactively (list 'quote cmd)))))
+
+;;;; Archiving
+
+(defalias 'org-advertized-archive-subtree 'org-archive-subtree)
+
+(defun org-archive-subtree (&optional find-done)
+ "Move the current subtree to the archive.
+The archive can be a certain top-level heading in the current file, or in
+a different file. The tree will be moved to that location, the subtree
+heading be marked DONE, and the current time will be added.
+
+When called with prefix argument FIND-DONE, find whole trees without any
+open TODO items and archive them (after getting confirmation from the user).
+If the cursor is not at a headline when this comand is called, try all level
+1 trees. If the cursor is on a headline, only try the direct children of
+this heading."
+ (interactive "P")
+ (if find-done
+ (org-archive-all-done)
+ ;; Save all relevant TODO keyword-relatex variables
+
+ (let ((tr-org-todo-line-regexp org-todo-line-regexp) ; keep despite compiler
+ (tr-org-todo-keywords-1 org-todo-keywords-1)
+ (tr-org-todo-kwd-alist org-todo-kwd-alist)
+ (tr-org-done-keywords org-done-keywords)
+ (tr-org-todo-regexp org-todo-regexp)
+ (tr-org-todo-line-regexp org-todo-line-regexp)
+ (tr-org-odd-levels-only org-odd-levels-only)
+ (this-buffer (current-buffer))
+ (org-archive-location org-archive-location)
+ (re "^#\\+ARCHIVE:[ \t]+\\(\\S-.*\\S-\\)[ \t]*$")
+ ;; start of variables that will be used for saving context
+ ;; The compiler complains about them - keep them anyway!
+ (file (abbreviate-file-name (buffer-file-name)))
+ (olpath (mapconcat 'identity (org-get-outline-path) "/"))
+ (time (format-time-string
+ (substring (cdr org-time-stamp-formats) 1 -1)
+ (current-time)))
+ afile heading buffer level newfile-p
+ category todo priority
+ ;; start of variables that will be used for savind context
+ ltags itags prop)
+
+ ;; Try to find a local archive location
+ (save-excursion
+ (save-restriction
+ (widen)
+ (setq prop (org-entry-get nil "ARCHIVE" 'inherit))
+ (if (and prop (string-match "\\S-" prop))
+ (setq org-archive-location prop)
+ (if (or (re-search-backward re nil t)
+ (re-search-forward re nil t))
+ (setq org-archive-location (match-string 1))))))
+
+ (if (string-match "\\(.*\\)::\\(.*\\)" org-archive-location)
+ (progn
+ (setq afile (format (match-string 1 org-archive-location)
(file-name-nondirectory buffer-file-name))
heading (match-string 2 org-archive-location)))
(error "Invalid `org-archive-location'"))
- (if (> (length file) 0)
- (setq newfile-p (not (file-exists-p file))
- buffer (find-file-noselect file))
+ (if (> (length afile) 0)
+ (setq newfile-p (not (file-exists-p afile))
+ buffer (find-file-noselect afile))
(setq buffer (current-buffer)))
(unless buffer
- (error "Cannot access file \"%s\"" file))
+ (error "Cannot access file \"%s\"" afile))
(if (and (> (length heading) 0)
(string-match "^\\*+" heading))
(setq level (match-end 0))
(setq heading nil level 0))
(save-excursion
+ (org-back-to-heading t)
+ ;; Get context information that will be lost by moving the tree
+ (org-refresh-category-properties)
+ (setq category (org-get-category)
+ todo (and (looking-at org-todo-line-regexp)
+ (match-string 2))
+ priority (org-get-priority (if (match-end 3) (match-string 3) ""))
+ ltags (org-get-tags)
+ itags (org-delete-all ltags (org-get-tags-at)))
+ (setq ltags (mapconcat 'identity ltags " ")
+ itags (mapconcat 'identity itags " "))
;; We first only copy, in case something goes wrong
;; we need to protect this-command, to avoid kill-region sets it,
;; which would lead to duplication of subtrees
;; Enforce org-mode for the archive buffer
(if (not (org-mode-p))
;; Force the mode for future visits.
- (let ((org-insert-mode-line-in-empty-file t))
+ (let ((org-insert-mode-line-in-empty-file t)
+ (org-inhibit-startup t))
(call-interactively 'org-mode)))
(when newfile-p
(goto-char (point-max))
(buffer-file-name this-buffer))))
;; Force the TODO keywords of the original buffer
(let ((org-todo-line-regexp tr-org-todo-line-regexp)
- (org-todo-keywords tr-org-todo-keywords)
- (org-todo-interpretation tr-org-todo-interpretation)
- (org-done-string tr-org-done-string)
+ (org-todo-keywords-1 tr-org-todo-keywords-1)
+ (org-todo-kwd-alist tr-org-todo-kwd-alist)
+ (org-done-keywords tr-org-done-keywords)
(org-todo-regexp tr-org-todo-regexp)
(org-todo-line-regexp tr-org-todo-line-regexp)
(org-odd-levels-only
- (if (local-variable-p 'org-odd-levels-only)
+ (if (local-variable-p 'org-odd-levels-only (current-buffer))
org-odd-levels-only
tr-org-odd-levels-only)))
(goto-char (point-min))
+ (show-all)
(if heading
(progn
(if (re-search-forward
- (concat "\\(^\\|\r\\)"
- (regexp-quote heading) "[ \t]*\\(:[a-zA-Z0-9_@:]+:\\)?[ \t]*\\($\\|\r\\)")
+ (concat "^" (regexp-quote heading)
+ (org-re "[ \t]*\\(:[[:alnum:]_@:]+:\\)?[ \t]*\\($\\|\r\\)"))
nil t)
(goto-char (match-end 0))
;; Heading not found, just insert it at the end
;; No specific heading, just go to end of file.
(goto-char (point-max)) (insert "\n"))
;; Paste
- (org-paste-subtree (org-get-legal-level level 1))
- ;; Mark the entry as done, i.e. set to last work in org-todo-keywords
- (if org-archive-mark-done
- (let (org-log-done)
- (org-todo (length org-todo-keywords))))
- ;; Move cursor to right after the TODO keyword
- (when org-archive-stamp-time
- (beginning-of-line 1)
- (looking-at org-todo-line-regexp)
- (goto-char (or (match-end 2) (match-beginning 3)))
- (org-insert-time-stamp (org-current-time) t t "(" ")"))
- ;; Save the buffer, if it is not the same buffer.
- (if (not (eq this-buffer buffer)) (save-buffer))))
+ (org-paste-subtree (org-get-valid-level level 1))
+
+ ;; Mark the entry as done
+ (when (and org-archive-mark-done
+ (looking-at org-todo-line-regexp)
+ (or (not (match-end 2))
+ (not (member (match-string 2) org-done-keywords))))
+ (let (org-log-done org-todo-log-states)
+ (org-todo
+ (car (or (member org-archive-mark-done org-done-keywords)
+ org-done-keywords)))))
+
+ ;; Add the context info
+ (when org-archive-save-context-info
+ (let ((l org-archive-save-context-info) e n v)
+ (while (setq e (pop l))
+ (when (and (setq v (symbol-value e))
+ (stringp v) (string-match "\\S-" v))
+ (setq n (concat "ARCHIVE_" (upcase (symbol-name e))))
+ (org-entry-put (point) n v)))))
+
+ ;; Save and kill the buffer, if it is not the same buffer.
+ (if (not (eq this-buffer buffer))
+ (progn (save-buffer) (kill-buffer buffer)))))
;; Here we are back in the original buffer. Everything seems to have
;; worked. So now cut the tree and finish up.
(let (this-command) (org-cut-subtree))
(message "Subtree archived %s"
(if (eq this-buffer buffer)
(concat "under heading: " heading)
- (concat "in file: " (abbreviate-file-name file)))))))
+ (concat "in file: " (abbreviate-file-name afile)))))))
+
+(defun org-refresh-category-properties ()
+ "Refresh category text properties in teh buffer."
+ (let ((def-cat (cond
+ ((null org-category)
+ (if buffer-file-name
+ (file-name-sans-extension
+ (file-name-nondirectory buffer-file-name))
+ "???"))
+ ((symbolp org-category) (symbol-name org-category))
+ (t org-category)))
+ beg end cat pos optionp)
+ (org-unmodified
+ (save-excursion
+ (save-restriction
+ (widen)
+ (goto-char (point-min))
+ (put-text-property (point) (point-max) 'org-category def-cat)
+ (while (re-search-forward
+ "^\\(#\\+CATEGORY:\\|[ \t]*:CATEGORY:\\)\\(.*\\)" nil t)
+ (setq pos (match-end 0)
+ optionp (equal (char-after (match-beginning 0)) ?#)
+ cat (org-trim (match-string 2)))
+ (if optionp
+ (setq beg (point-at-bol) end (point-max))
+ (org-back-to-heading t)
+ (setq beg (point) end (org-end-of-subtree t t)))
+ (put-text-property beg end 'org-category cat)
+ (goto-char pos)))))))
(defun org-archive-all-done (&optional tag)
"Archive sublevels of the current tree without open TODO items.
(progn
(setq re1 (concat "^" (regexp-quote
(make-string
- (1+ (- (match-end 0) (match-beginning 0)))
+ (1+ (- (match-end 0) (match-beginning 0) 1))
?*))
" "))
(move-marker begm (point))
(goto-char end)))))
(message "%d trees archived" cntarch)))
+(defun org-cycle-hide-drawers (state)
+ "Re-hide all drawers after a visibility state change."
+ (when (and (org-mode-p)
+ (not (memq state '(overview folded))))
+ (save-excursion
+ (let* ((globalp (memq state '(contents all)))
+ (beg (if globalp (point-min) (point)))
+ (end (if globalp (point-max) (org-end-of-subtree t))))
+ (goto-char beg)
+ (while (re-search-forward org-drawer-regexp end t)
+ (org-flag-drawer t))))))
+
+(defun org-flag-drawer (flag)
+ (save-excursion
+ (beginning-of-line 1)
+ (when (looking-at "^[ \t]*:[a-zA-Z][a-zA-Z0-9]*:")
+ (let ((b (match-end 0))
+ (outline-regexp org-outline-regexp))
+ (if (re-search-forward
+ "^[ \t]*:END:"
+ (save-excursion (outline-next-heading) (point)) t)
+ (outline-flag-region b (point-at-eol) flag)
+ (error ":END: line missing"))))))
+
(defun org-cycle-hide-archived-subtrees (state)
"Re-hide all archived subtrees after a visibility state change."
(when (and (not org-cycle-open-archived-trees)
(org-hide-archived-subtrees beg end)
(goto-char beg)
(if (looking-at (concat ".*:" org-archive-tag ":"))
- (message (substitute-command-keys
- "Subtree is archived and stays closed. Use \\[org-force-cycle-archived] to cycle it anyway.")))))))
+ (message "%s" (substitute-command-keys
+ "Subtree is archived and stays closed. Use \\[org-force-cycle-archived] to cycle it anyway.")))))))
(defun org-force-cycle-archived ()
"Cycle subtree even if it is archived."
(defun org-toggle-tag (tag &optional onoff)
"Toggle the tag TAG for the current line.
If ONOFF is `on' or `off', don't toggle but set to this state."
- (unless (org-on-heading-p) (error "Not on headling"))
+ (unless (org-on-heading-p t) (error "Not on headling"))
(let (res current)
(save-excursion
(beginning-of-line)
- (if (re-search-forward "[ \t]:\\([a-zA-Z0-9_@:]+\\):[ \t]*$"
+ (if (re-search-forward (org-re "[ \t]:\\([[:alnum:]_@:]+\\):[ \t]*$")
(point-at-eol) t)
(progn
(setq current (match-string 1))
(setq res t)
(push tag current))))
(end-of-line 1)
- (when current
- (insert " :" (mapconcat 'identity (nreverse current) ":") ":"))
- (org-set-tags nil t))
+ (if current
+ (progn
+ (insert " :" (mapconcat 'identity (nreverse current) ":") ":")
+ (org-set-tags nil t))
+ (delete-horizontal-space))
+ (run-hooks 'org-after-tags-change-hook))
res))
(defun org-toggle-archive-tag (&optional arg)
"Table row types, non-nil only for the duration of a comand.")
(defvar org-table-current-begin-line nil
"Table begin line, non-nil only for the duration of a comand.")
+(defvar org-table-current-begin-pos nil
+ "Table begin position, non-nil only for the duration of a comand.")
(defvar org-table-dlines nil
"Vector of data line line numbers in the current table.")
(defvar org-table-hlines nil
"Regular expression for matching ranges in formulas.")
(defconst org-table-range-regexp2
- "@\\([-+]?I*[-+]?[0-9]*\\)?\\(\\$[-+]?[a-zA-Z0-9]+\\)?\\(\\.\\.@?\\([-+]?I*[-+]?[0-9]*\\)?\\(\\$[-+]?[a-zA-Z0-9]+\\)?\\)?\\|\\$[a-zA-Z0-9]+\\.\\.\\$[a-zA-Z0-9]+"
- "Regular expression to recognize ranges in formulas for highlighting.")
+ (concat
+ "\\(" "@[-0-9I$&]+" "\\|" "[a-zA-Z]\\{1,2\\}\\([0-9]+\\|&\\)" "\\|" "\\$[a-zA-Z0-9]+" "\\)"
+ "\\.\\."
+ "\\(" "@?[-0-9I$&]+" "\\|" "[a-zA-Z]\\{1,2\\}\\([0-9]+\\|&\\)" "\\|" "\\$[a-zA-Z0-9]+" "\\)")
+ "Match a range for reference display.")
-(defvar org-inhibit-highlight-removal nil)
+(defconst org-table-translate-regexp
+ (concat "\\(" "@[-0-9I$]+" "\\|" "[a-zA-Z]\\{1,2\\}\\([0-9]+\\|&\\)" "\\)")
+ "Match a reference that needs translation, for reference display.")
+(defvar org-inhibit-highlight-removal nil) ; dynamically scoped param
(defun org-table-create-with-table.el ()
"Use the table.el package to insert a new table.
(defun org-table-create-or-convert-from-region (arg)
"Convert region to table, or create an empty table.
-If there is an active region, convert it to a table. If there is no such
-region, create an empty table."
+If there is an active region, convert it to a table, using the function
+`org-table-convert-region'. See the documentation of that function
+to learn how the prefix argument is interpreted to determine the field
+separator.
+If there is no such region, create an empty table with `org-table-create'."
(interactive "P")
(if (org-region-active-p)
(org-table-convert-region (region-beginning) (region-end) arg)
(goto-char pos)))
(org-table-align)))
-(defun org-table-convert-region (beg0 end0 &optional nspace)
+(defun org-table-convert-region (beg0 end0 &optional separator)
"Convert region to a table.
The region goes from BEG0 to END0, but these borders will be moved
slightly, to make sure a beginning of line in the first line is included.
-When NSPACE is non-nil, it indicates the minimum number of spaces that
-separate columns (default: just one space)."
+
+SEPARATOR specifies the field separator in the lines. It can have the
+following values:
+
+'(4) Use the comma as a field separator
+'(16) Use a TAB as field separator
+integer When a number, use that many spaces as field separator
+nil When nil, the command tries to be smart and figure out the
+ separator in the following way:
+ - when each line contains a TAB, assume TAB-separated material
+ - when each line contains a comme, assume CSV material
+ - else, assume one or more SPACE charcters as separator."
(interactive "rP")
(let* ((beg (min beg0 end0))
(end (max beg0 end0))
- (tabsep t)
re)
(goto-char beg)
(beginning-of-line 1)
(goto-char end)
(if (bolp) (backward-char 1) (end-of-line 1))
(setq end (move-marker (make-marker) (point)))
- ;; Lets see if this is tab-separated material. If every nonempty line
- ;; contains a tab, we will assume that it is tab-separated material
- (if nspace
- (setq tabsep nil)
+ ;; Get the right field separator
+ (unless separator
(goto-char beg)
- (and (re-search-forward "^[^\n\t]+$" end t) (setq tabsep nil)))
- (if nspace (setq tabsep nil))
- (if tabsep
- (setq re "^\\|\t")
- (setq re (format "^ *\\| *\t *\\| \\{%d,\\}"
- (max 1 (prefix-numeric-value nspace)))))
+ (setq separator
+ (cond
+ ((not (re-search-forward "^[^\n\t]+$" end t)) '(16))
+ ((not (re-search-forward "^[^\n,]+$" end t)) '(4))
+ (t 1))))
+ (setq re (cond
+ ((equal separator '(4)) "^\\|\"?[ \t]*,[ \t]*\"?")
+ ((equal separator '(16)) "^\\|\t")
+ ((integerp separator)
+ (format "^ *\\| *\t *\\| \\{%d,\\}" separator))
+ (t (error "This should not happen"))))
(goto-char beg)
(while (re-search-forward re end t)
(replace-match "| " t t))
(make-string sp2 ?\ ) "%%%s%ds" (make-string sp1 ?\ ) "|"))
(hfmt1 (concat
(make-string sp2 ?-) "%s" (make-string sp1 ?-) "+"))
- emptystrings links dates narrow fmax f1 len c e)
+ emptystrings links dates emph narrow fmax f1 len c e)
(untabify beg end)
(remove-text-properties beg end '(org-cwidth t org-dwidth t display t))
;; Check if we have links or dates
(goto-char beg)
(setq links (re-search-forward org-bracket-link-regexp end t))
(goto-char beg)
+ (setq emph (and org-hide-emphasis-markers
+ (re-search-forward org-emph-re end t)))
+ (goto-char beg)
(setq dates (and org-display-custom-times
(re-search-forward org-ts-regexp-both end t)))
;; Make sure the link properties are right
(when links (goto-char beg) (while (org-activate-bracket-links end)))
;; Make sure the date properties are right
(when dates (goto-char beg) (while (org-activate-dates end)))
+ (when emph (goto-char beg) (while (org-do-emphasis-faces end)))
;; Check if we are narrowing any columns
(goto-char beg)
;; With invisible characters, `format' does not get the field width right
;; So we need to make these fields wide by hand.
- (when links
+ (when (or links emph)
(loop for i from 0 upto (1- maxfields) do
(setq len (nth i lengths))
(loop for j from 0 upto (1- (length fields)) do
(setq c (nthcdr i (car (nthcdr j fields))))
(if (and (stringp (car c))
- (string-match org-bracket-link-regexp (car c))
+ (text-property-any 0 (length (car c)) 'invisible 'org-link (car c))
+; (string-match org-bracket-link-regexp (car c))
(< (org-string-width (car c)) len))
(setcar c (concat (car c) (make-string (- len (org-string-width (car c))) ?\ )))))))
(setq n (concat new "|") org-table-may-need-update t)))
(or (equal n o)
(let (org-table-may-need-update)
- (replace-match n))))
+ (replace-match n t t))))
(setq org-table-may-need-update t))
(goto-char pos))))))
the cursor is moved with it. Therefore, repeating this command causes the
column to be filled row-by-row.
If the variable `org-table-copy-increment' is non-nil and the field is an
-integer, it will be incremented while copying."
+integer or a timestamp, it will be incremented while copying. In the case of
+a timestamp, if the cursor is on the year, change the year. If it is on the
+month or the day, change that. Point will stay on the current date field
+in order to easily repeat the interval."
(interactive "p")
(let* ((colpos (org-table-current-column))
+ (col (current-column))
(field (org-table-get-field))
(non-empty (string-match "[^ \t]" field))
(beg (org-table-begin))
(string-match "^[0-9]+$" txt))
(setq txt (format "%d" (+ (string-to-number txt) 1))))
(insert txt)
- (org-table-maybe-recalculate-line)
- (org-table-align))
+ (move-to-column col)
+ (if (and org-table-copy-increment (org-at-timestamp-p t))
+ (org-timestamp-up 1)
+ (org-table-maybe-recalculate-line))
+ (org-table-align)
+ (move-to-column col))
(error "No non-empty field found"))))
(defun org-table-check-inside-data-field ()
val)
(forward-char 1) ""))
-
(defun org-table-field-info (arg)
"Show info about the current field, and highlight any reference at point."
(interactive "P")
(eql (org-table-get-stored-formulas))
(dline (org-table-current-dline))
(ref (format "@%d$%d" dline col))
+ (ref1 (org-table-convert-refs-to-an ref))
(fequation (or (assoc name eql) (assoc ref eql)))
- (cequation (assoc (int-to-string col) eql)))
+ (cequation (assoc (int-to-string col) eql))
+ (eqn (or fequation cequation)))
(goto-char pos)
(condition-case nil
- (org-show-reference 'local)
+ (org-table-show-reference 'local)
(error nil))
- (message "line @%d, col $%s%s, ref @%d$%d%s%s"
+ (message "line @%d, col $%s%s, ref @%d$%d or %s%s%s"
dline col
(if cname (concat " or $" cname) "")
- dline col
+ dline col ref1
(if name (concat " or $" name) "")
;; FIXME: formula info not correct if special table line
- (if (or fequation cequation)
- (concat ", " (if fequation "field" "column")
- " formula applies" "")
+ (if eqn
+ (concat ", formula: "
+ (org-table-formula-to-user
+ (concat
+ (if (string-match "^[$@]"(car eqn)) "" "$")
+ (car eqn) "=" (cdr eqn))))
"")))))
(defun org-table-current-column ()
(org-table-align))
(org-table-fix-formulas "@" nil (1- (org-table-current-dline)) 1)))
-(defun org-table-insert-hline (&optional arg)
+(defun org-table-insert-hline (&optional above)
"Insert a horizontal-line below the current line into the table.
-With prefix ARG, insert above the current line."
+With prefix ABOVE, insert above the current line."
(interactive "P")
(if (not (org-at-table-p))
(error "Not at a table"))
(concat "+" (make-string (- (match-end 1) (match-beginning 1))
?-) "|") t t line)))
(and (string-match "\\+" line) (setq line (replace-match "|" t t line)))
- (beginning-of-line (if arg 1 2))
+ (beginning-of-line (if above 1 2))
(insert line "\n")
- (beginning-of-line (if arg 1 -1))
+ (beginning-of-line (if above 1 -1))
(move-to-column col)
(and org-table-overlay-coordinates (org-table-align))))
+(defun org-table-hline-and-move (&optional same-column)
+ "Insert a hline and move to the row below that line."
+ (interactive "P")
+ (let ((col (org-table-current-column)))
+ (org-table-maybe-eval-formula)
+ (org-table-maybe-recalculate-line)
+ (org-table-insert-hline)
+ (end-of-line 2)
+ (if (looking-at "\n[ \t]*|-")
+ (progn (insert "\n|") (org-table-align))
+ (org-table-next-field))
+ (if same-column (org-table-goto-column col))))
+
(defun org-table-clean-line (s)
"Convert a table line S into a string with only \"|\" and space.
In particular, this does handle wide and invisible characters."
(org-table-fix-formulas "@" (list (cons (number-to-string dline) "INVALID"))
dline -1 dline)))
-
(defun org-table-sort-lines (with-case &optional sorting-type)
"Sort table lines according to the column at point.
(setq beg (point-at-bol 1)))
(goto-char pos)
(if (re-search-forward org-table-hline-regexp tend t)
- (setq beg (point-at-bol 0))
+ (setq end (point-at-bol 1))
(goto-char tend)
(setq end (point-at-bol))))
(setq beg (move-marker (make-marker) beg)
(skip-chars-backward "^|")
(setq ecol (1- (current-column)))
(org-table-goto-column column)
- (setq lns (mapcar (lambda(x) (cons (org-trim (substring x bcol ecol)) x))
+ (setq lns (mapcar (lambda(x) (cons
+ (org-sort-remove-invisible
+ (nth (1- column)
+ (org-split-string x "[ \t]*|[ \t]*")))
+ x))
(org-split-string (buffer-substring beg end) "\n")))
(setq lns (org-do-sort lns "Table" with-case sorting-type))
(delete-region beg end)
(org-table-goto-column thiscol)
(message "%d lines sorted, based on column %d" (length lns) column)))
+;; FIXME: maybe we will not need this? Table sorting is broken....
+(defun org-sort-remove-invisible (s)
+ (remove-text-properties 0 (length s) org-rm-props s)
+ (while (string-match org-bracket-link-regexp s)
+ (setq s (replace-match (if (match-end 2)
+ (match-string 3 s)
+ (match-string 1 s)) t t s)))
+ s)
+
(defun org-table-cut-region (beg end)
"Copy region in table to the clipboard and blank all relevant fields."
(interactive "r")
(org-table-goto-column ccol)
(org-table-paste-rectangle))
;; No region, split the current field at point
+ (unless (org-get-alist-option org-M-RET-may-split-line 'table)
+ (skip-chars-forward "^\r\n|"))
(if arg
;; combine with field above
(let ((s (org-table-blank-field))
(insert " " (org-trim s))
(org-table-align))
;; split field
- (when (looking-at "\\([^|]+\\)+|")
- (let ((s (match-string 1)))
- (replace-match " |")
- (goto-char (match-beginning 0))
- (org-table-next-row)
- (insert (org-trim s) " ")
- (org-table-align))))))
+ (if (looking-at "\\([^|]+\\)+|")
+ (let ((s (match-string 1)))
+ (replace-match " |")
+ (goto-char (match-beginning 0))
+ (org-table-next-row)
+ (insert (org-trim s) " ")
+ (org-table-align))
+ (org-table-next-row)))))
(defvar org-field-marker nil)
(field (org-table-get-field))
(cw (current-window-configuration))
p)
- (switch-to-buffer-other-window "*Org tmp*")
+ (org-switch-to-buffer-other-window "*Org tmp*")
(erase-buffer)
(insert "#\n# Edit field and finish with C-c C-c\n#\n")
- (org-mode)
+ (let ((org-inhibit-startup t)) (org-mode))
(goto-char (setq p (point-max)))
(insert (org-trim field))
(remove-text-properties p (point-max)
'(invisible t org-cwidth t display t
intangible t))
(goto-char p)
- (org-set-local 'org-finish-function
- 'org-table-finish-edit-field)
+ (org-set-local 'org-finish-function 'org-table-finish-edit-field)
(org-set-local 'org-window-configuration cw)
(org-set-local 'org-field-marker pos)
(message "Edit and finish with C-c C-c"))))
(defun org-trim (s)
"Remove whitespace at beginning and end of string."
- (if (string-match "^[ \t]+" s) (setq s (replace-match "" t t s)))
- (if (string-match "[ \t]+$" s) (setq s (replace-match "" t t s)))
+ (if (string-match "\\`[ \t\n\r]+" s) (setq s (replace-match "" t t s)))
+ (if (string-match "[ \t\n\r]+\\'" s) (setq s (replace-match "" t t s)))
s)
(defun org-wrap (string &optional width lines)
((equal n 0) nil)
(t n))))
-(defun org-table-current-field-formula ()
+(defun org-table-current-field-formula (&optional key noerror)
"Return the formula active for the current field.
-Assumes that specials are in place."
+Assumes that specials are in place.
+If KEY is given, return the key to this formula.
+Otherwise return the formula preceeded with \"=\" or \":=\"."
(let* ((name (car (rassoc (list (org-current-line)
(org-table-current-column))
org-table-named-field-locations)))
(col (org-table-current-column))
(scol (int-to-string col))
(ref (format "@%d$%d" (org-table-current-dline) col))
- (stored-list (org-table-get-stored-formulas))
+ (stored-list (org-table-get-stored-formulas noerror))
(ass (or (assoc name stored-list)
(assoc ref stored-list)
(assoc scol stored-list))))
- (if ass (concat (if (string-match "^[0-9]+$" (car ass)) "=" ":=")
- (cdr ass)))))
+ (if key
+ (car ass)
+ (if ass (concat (if (string-match "^[0-9]+$" (car ass)) "=" ":=")
+ (cdr ass))))))
(defun org-table-get-formula (&optional equation named)
"Read a formula from the minibuffer, offer stored formula as default.
stored)
((stringp equation)
equation)
- (t (read-string
- (format "%s formula $%s=" (if named "Field" "Column") scol)
- (or stored "") 'org-table-formula-history
- ;stored
- ))))
+ (t (org-table-formula-from-user
+ (read-string
+ (org-table-formula-to-user
+ (format "%s formula %s%s="
+ (if named "Field" "Column")
+ (if (member (string-to-char scol) '(?$ ?@)) "" "$")
+ scol))
+ (if stored (org-table-formula-to-user stored) "")
+ 'org-table-formula-history
+ )))))
mustsave)
(when (not (string-match "\\S-" eq))
;; remove formula
(defun org-table-store-formulas (alist)
"Store the list of formulas below the current table."
- (setq alist (sort alist (lambda (a b) (string< (car a) (car b)))))
+ (setq alist (sort alist 'org-table-formula-less-p))
(save-excursion
(goto-char (org-table-end))
(if (looking-at "\\([ \t]*\n\\)*#\\+TBLFM:\\(.*\n?\\)")
alist "::")
"\n")))
-(defun org-table-get-stored-formulas ()
+(defsubst org-table-formula-make-cmp-string (a)
+ (when (string-match "^\\(@\\([0-9]+\\)\\)?\\(\\$?\\([0-9]+\\)\\)?\\(\\$?[a-zA-Z0-9]+\\)?" a)
+ (concat
+ (if (match-end 2) (format "@%05d" (string-to-number (match-string 2 a))) "")
+ (if (match-end 4) (format "$%05d" (string-to-number (match-string 4 a))) "")
+ (if (match-end 5) (concat "@@" (match-string 5 a))))))
+
+(defun org-table-formula-less-p (a b)
+ "Compare two formulas for sorting."
+ (let ((as (org-table-formula-make-cmp-string (car a)))
+ (bs (org-table-formula-make-cmp-string (car b))))
+ (and as bs (string< as bs))))
+
+(defun org-table-get-stored-formulas (&optional noerror)
"Return an alist with the stored formulas directly after current table."
(interactive)
(let (scol eq eq-alist strings string seen)
eq (match-string 3 string)
eq-alist (cons (cons scol eq) eq-alist))
(if (member scol seen)
- (error "Double definition `$%s=' in TBLFM line, please fix by hand" scol)
+ (if noerror
+ (progn
+ (message "Double definition `$%s=' in TBLFM line, please fix by hand" scol)
+ (ding)
+ (sit-for 2))
+ (error "Double definition `$%s=' in TBLFM line, please fix by hand" scol))
(push scol seen))))))
(nreverse eq-alist)))
org-table-local-parameters nil
org-table-named-field-locations nil
org-table-current-begin-line nil
+ org-table-current-begin-pos nil
org-table-current-line-types nil)
(goto-char beg)
(when (re-search-forward "^[ \t]*| *! *\\(|.*\\)" end t)
(while (re-search-forward "^[ \t]*| *\\$ *\\(|.*\\)" end t)
(setq fields (org-split-string (match-string 1) " *| *"))
(while (setq field (pop fields))
- (if (string-match "^\\([a-zA-Z][a-zA-Z0-9]*\\|%\\) *= *\\(.*\\)" field)
+ (if (string-match "^\\([a-zA-Z][_a-zA-Z0-9]*\\|%\\) *= *\\(.*\\)" field)
(push (cons (match-string 1 field) (match-string 2 field))
org-table-local-parameters))))
(goto-char beg)
;; Analyse the line types
(goto-char beg)
(setq org-table-current-begin-line (org-current-line)
+ org-table-current-begin-pos (point)
l org-table-current-begin-line)
(while (looking-at "[ \t]*|\\(-\\)?")
(push (if (match-end 1) 'hline 'dline) types)
org-table-dlines (apply 'vector (cons nil (nreverse dlines)))
org-table-hlines (apply 'vector (cons nil (nreverse hlines)))))))
-(defun org-this-word ()
- ;; Get the current word
- (save-excursion
- (let ((beg (progn (skip-chars-backward "^ \t\n") (point)))
- (end (progn (skip-chars-forward "^ \t\n") (point))))
- (buffer-substring-no-properties beg end))))
-
(defun org-table-maybe-eval-formula ()
"Check if the current field starts with \"=\" or \":=\".
If yes, store the formula and apply it."
eq (match-string 1 field))
(if (or (fboundp 'calc-eval)
(equal (substring eq 0 (min 2 (length eq))) "'("))
- (org-table-eval-formula (if named '(4) nil) eq)
+ (org-table-eval-formula (if named '(4) nil)
+ (org-table-formula-from-user eq))
(error "Calc does not seem to be installed, and is needed to evaluate the formula"))))))
(defvar org-recalc-commands nil
(goto-line l1)))
(if (not (= epos (point-at-eol))) (org-table-align))
(goto-line l)
- (and (interactive-p) (message (cdr (assoc new org-recalc-marks))))))
+ (and (interactive-p) (message "%s" (cdr (assoc new org-recalc-marks))))))
(defun org-table-maybe-recalculate-line ()
"Recompute the current line if marked for it, and if we haven't just done it."
When called with two `C-u' prefixes, insert the active equation
for the field back into the current field, so that it can be
-edited there. This is useful in order to use \\[org-show-reference]
+edited there. This is useful in order to use \\[org-table-show-reference]
to check the referenced fields.
When called, the command first prompts for a formula, which is read in
(modes (copy-sequence org-calc-default-modes))
(numbers nil) ; was a variable, now fixed default
(keep-empty nil)
- n form form0 bw fmt x ev orig c lispp)
+ n form form0 bw fmt x ev orig c lispp literal)
;; Parse the format string. Since we have a lot of modes, this is
;; a lot of work. However, I think calc still uses most of the time.
(if (string-match ";" formula)
(if (string-match "[NT]" fmt)
(setq numbers (equal (match-string 0 fmt) "N")
fmt (replace-match "" t t fmt)))
+ (if (string-match "L" fmt)
+ (setq literal t
+ fmt (replace-match "" t t fmt)))
(if (string-match "E" fmt)
(setq keep-empty t
fmt (replace-match "" t t fmt)))
(org-no-properties
(buffer-substring (point-at-bol) (point-at-eol)))
" *| *"))
- (if numbers
+ (if (eq numbers t)
(setq fields (mapcar
(lambda (x) (number-to-string (string-to-number x)))
fields)))
(setq ndown (1- ndown))
(setq form (copy-sequence formula)
lispp (and (> (length form) 2)(equal (substring form 0 2) "'(")))
+ (if (and lispp literal) (setq lispp 'literal))
;; Check for old vertical references
(setq form (org-rewrite-old-row-references form))
;; Insert complex ranges
t t form)))
(setq form0 form)
;; Insert the references to fields in same row
- (while (string-match "\\$\\([0-9]+\\)?" form)
- (setq n (if (match-beginning 1)
- (string-to-number (match-string 1 form))
- n0)
- x (nth (1- n) fields))
+ (while (string-match "\\$\\([0-9]+\\)" form)
+ (setq n (string-to-number (match-string 1 form))
+ x (nth (1- (if (= n 0) n0 n)) fields))
(unless x (error "Invalid field specifier \"%s\""
(match-string 0 form)))
(setq form (replace-match
(save-match-data
(org-table-make-reference x nil numbers lispp))
t t form)))
+
(if lispp
(setq ev (condition-case nil
(eval (eval (read form)))
(or suppress-align (and org-table-may-need-update
(org-table-align))))))
+(defun org-table-put-field-property (prop value)
+ (save-excursion
+ (put-text-property (progn (skip-chars-backward "^|") (point))
+ (progn (skip-chars-forward "^|") (point))
+ prop value)))
+
(defun org-table-get-range (desc &optional tbeg col highlight)
"Get a calc vector from a column, accorting to descriptor DESC.
Optional arguments TBEG and COL can give the beginning of the table and
(goto-line r1)
(while (not (looking-at org-table-dataline-regexp))
(beginning-of-line 2))
- (prog1 (org-table-get-field c1)
+ (prog1 (org-trim (org-table-get-field c1))
(if highlight (org-table-highlight-rectangle (point) (point)))))
;; A range, return a vector
;; First sort the numbers to get a regular ractangle
(org-table-highlight-rectangle
beg (progn (skip-chars-forward "^|\n") (point))))
;; return string representation of calc vector
- (apply 'append (org-table-copy-region beg end))))))
+ (mapcar 'org-trim
+ (apply 'append (org-table-copy-region beg end)))))))
(defun org-table-get-descriptor-line (desc &optional cline bline table)
"Analyze descriptor DESC and retrieve the corresponding line number.
(setq i 0 hdir "+")
(if (eq (aref table 0) 'hline) (setq hn (1- hn)))))
(if (and (not hn) on (not odir))
- (error "should never happen");;(aref org-table-dlines on) FIXME
+ (error "should never happen");;(aref org-table-dlines on)
(if (and hn (> hn 0))
(setq i (org-find-row-type table i 'hline (equal hdir "-") nil hn)))
(if on
LISPP means to return something appropriate for a Lisp list."
(if (stringp elements) ; just a single val
(if lispp
- (prin1-to-string (if numbers (string-to-number elements) elements))
+ (if (eq lispp 'literal)
+ elements
+ (prin1-to-string (if numbers (string-to-number elements) elements)))
(if (equal elements "") (setq elements "0"))
(if numbers (number-to-string (string-to-number elements)) elements))
(unless keep-empty
elements))))
(setq elements (or elements '("0")))
(if lispp
- (mapconcat 'prin1-to-string
- (if numbers (mapcar 'string-to-number elements) elements)
- " ")
+ (mapconcat
+ (lambda (x)
+ (if (eq lispp 'literal)
+ x
+ (prin1-to-string (if numbers (string-to-number x) x))))
+ elements " ")
(concat "[" (mapconcat
(lambda (x)
(if numbers (number-to-string (string-to-number x)) x))
(line-re org-table-dataline-regexp)
(thisline (org-current-line))
(thiscol (org-table-current-column))
- beg end entry eqlnum eqlname eql (cnt 0) eq a name)
+ beg end entry eqlnum eqlname eqlname1 eql (cnt 0) eq a name)
;; Insert constants in all formulas
(setq eqlist
(mapcar (lambda (x)
end (move-marker (make-marker) (1+ (point-at-eol)))))
(goto-char beg)
(and all (message "Re-applying formulas to full table..."))
+
+ ;; First find the named fields, and mark them untouchanble
+ (remove-text-properties beg end '(org-untouchable t))
+ (while (setq eq (pop eqlname))
+ (setq name (car eq)
+ a (assoc name org-table-named-field-locations))
+ (and (not a)
+ (string-match "@\\([0-9]+\\)\\$\\([0-9]+\\)" name)
+ (setq a (list name
+ (aref org-table-dlines
+ (string-to-number (match-string 1 name)))
+ (string-to-number (match-string 2 name)))))
+ (when (and a (or all (equal (nth 1 a) thisline)))
+ (message "Re-applying formula to field: %s" name)
+ (goto-line (nth 1 a))
+ (org-table-goto-column (nth 2 a))
+ (push (append a (list (cdr eq))) eqlname1)
+ (org-table-put-field-property :org-untouchable t)))
+
+ ;; Now evauluate the column formulas, but skip fields covered by
+ ;; field formulas
+ (goto-char beg)
(while (re-search-forward line-re end t)
- (unless (string-match "^ *[_^!$] *$" (org-table-get-field 1))
+ (unless (string-match "^ *[_^!$/] *$" (org-table-get-field 1))
;; Unprotected line, recalculate
(and all (message "Re-applying formulas to full table...(line %d)"
(setq cnt (1+ cnt))))
(while (setq entry (pop eql))
(goto-line org-last-recalc-line)
(org-table-goto-column (string-to-number (car entry)) nil 'force)
- (org-table-eval-formula nil (cdr entry)
- 'noalign 'nocst 'nostore 'noanalysis))))
+ (unless (get-text-property (point) :org-untouchable)
+ (org-table-eval-formula nil (cdr entry)
+ 'noalign 'nocst 'nostore 'noanalysis)))))
+
+ ;; Now evaluate the field formulas
+ (while (setq eq (pop eqlname1))
+ (message "Re-applying formula to field: %s" (car eq))
+ (goto-line (nth 1 eq))
+ (org-table-goto-column (nth 2 eq))
+ (org-table-eval-formula nil (nth 3 eq) 'noalign 'nocst
+ 'nostore 'noanalysis))
+
(goto-line thisline)
(org-table-goto-column thiscol)
+ (remove-text-properties (point-min) (point-max) '(org-untouchable t))
(or noalign (and org-table-may-need-update (org-table-align))
(and all (message "Re-applying formulas to %d lines...done" cnt)))
- ;; Now do the named fields
- (while (setq eq (pop eqlname))
- (setq name (car eq)
- a (assoc name org-table-named-field-locations))
- (and (not a)
- (string-match "@\\([0-9]+\\)\\$\\([0-9]+\\)" name)
- (setq a
- (list
- name
- (aref org-table-dlines
- (string-to-number (match-string 1 name)))
- (string-to-number (match-string 2 name)))))
- (when (and a (or all (equal (nth 1 a) thisline)))
- (message "Re-applying formula to field: %s" name)
- (goto-line (nth 1 a))
- (org-table-goto-column (nth 2 a))
- (org-table-eval-formula nil (cdr eq) 'noalign 'nocst
- 'nostore 'noanalysis)))
+
;; back to initial position
(message "Re-applying formulas...done")
(goto-line thisline)
(defun org-table-formula-substitute-names (f)
"Replace $const with values in string F."
- (let ((start 0) a (f1 f))
+ (let ((start 0) a (f1 f) (pp (/= (string-to-char f) ?')))
;; First, check for column names
(while (setq start (string-match org-table-column-name-regexp f start))
(setq start (1+ start))
(setq f (replace-match (concat "$" (cdr a)) t t f)))
;; Parameters and constants
(setq start 0)
- (while (setq start (string-match "\\$\\([a-zA-Z][a-zA-Z0-9]*\\)" f start))
+ (while (setq start (string-match "\\$\\([a-zA-Z][_a-zA-Z0-9]*\\)" f start))
(setq start (1+ start))
(if (setq a (save-match-data
(org-table-get-constant (match-string 1 f))))
- (setq f (replace-match (concat "(" a ")") t t f))))
+ (setq f (replace-match
+ (concat (if pp "(") a (if pp ")")) t t f))))
(if org-table-formula-debug
(put-text-property 0 (length f) :orig-formula f1 f))
f))
"Find the value for a parameter or constant in a formula.
Parameters get priority."
(or (cdr (assoc const org-table-local-parameters))
+ (cdr (assoc const org-table-formula-constants-local))
(cdr (assoc const org-table-formula-constants))
(and (fboundp 'constants-get) (constants-get const))
+ (and (string= (substring const 0 (min 5 (length const))) "PROP_")
+ (org-entry-get nil (substring const 5) 'inherit))
"#UNDEFINED_NAME"))
-(defvar org-edit-formulas-map (make-sparse-keymap))
-(define-key org-edit-formulas-map "\C-c\C-c" 'org-finish-edit-formulas)
-(define-key org-edit-formulas-map "\C-c\C-q" 'org-abort-edit-formulas)
-(define-key org-edit-formulas-map "\C-c?" 'org-show-reference)
-(define-key org-edit-formulas-map [(shift up)] 'org-table-edit-line-up)
-(define-key org-edit-formulas-map [(shift down)] 'org-table-edit-line-down)
-(define-key org-edit-formulas-map [(shift left)] 'org-table-edit-backward-field)
-(define-key org-edit-formulas-map [(shift right)] 'org-table-edit-next-field)
-(define-key org-edit-formulas-map [(meta up)] 'org-table-edit-scroll-down)
-(define-key org-edit-formulas-map [(meta down)] 'org-table-edit-scroll)
-(define-key org-edit-formulas-map [(meta tab)] 'lisp-complete-symbol)
-(define-key org-edit-formulas-map "\M-\C-i" 'lisp-complete-symbol)
-(define-key org-edit-formulas-map [(tab)] 'org-edit-formula-lisp-indent)
-(define-key org-edit-formulas-map "\C-i" 'org-edit-formula-lisp-indent)
+(defvar org-table-fedit-map
+ (let ((map (make-sparse-keymap)))
+ (org-defkey map "\C-x\C-s" 'org-table-fedit-finish)
+ (org-defkey map "\C-c\C-s" 'org-table-fedit-finish)
+ (org-defkey map "\C-c\C-c" 'org-table-fedit-finish)
+ (org-defkey map "\C-c\C-q" 'org-table-fedit-abort)
+ (org-defkey map "\C-c?" 'org-table-show-reference)
+ (org-defkey map [(meta shift up)] 'org-table-fedit-line-up)
+ (org-defkey map [(meta shift down)] 'org-table-fedit-line-down)
+ (org-defkey map [(shift up)] 'org-table-fedit-ref-up)
+ (org-defkey map [(shift down)] 'org-table-fedit-ref-down)
+ (org-defkey map [(shift left)] 'org-table-fedit-ref-left)
+ (org-defkey map [(shift right)] 'org-table-fedit-ref-right)
+ (org-defkey map [(meta up)] 'org-table-fedit-scroll-down)
+ (org-defkey map [(meta down)] 'org-table-fedit-scroll)
+ (org-defkey map [(meta tab)] 'lisp-complete-symbol)
+ (org-defkey map "\M-\C-i" 'lisp-complete-symbol)
+ (org-defkey map [(tab)] 'org-table-fedit-lisp-indent)
+ (org-defkey map "\C-i" 'org-table-fedit-lisp-indent)
+ (org-defkey map "\C-c\C-r" 'org-table-fedit-toggle-ref-type)
+ (org-defkey map "\C-c}" 'org-table-fedit-toggle-coordinates)
+ map))
+
+(easy-menu-define org-table-fedit-menu org-table-fedit-map "Org Edit Formulas Menu"
+ '("Edit-Formulas"
+ ["Finish and Install" org-table-fedit-finish t]
+ ["Finish, Install, and Apply" (org-table-fedit-finish t) :keys "C-u C-c C-c"]
+ ["Abort" org-table-fedit-abort t]
+ "--"
+ ["Pretty-Print Lisp Formula" org-table-fedit-lisp-indent t]
+ ["Complete Lisp Symbol" lisp-complete-symbol t]
+ "--"
+ "Shift Reference at Point"
+ ["Up" org-table-fedit-ref-up t]
+ ["Down" org-table-fedit-ref-down t]
+ ["Left" org-table-fedit-ref-left t]
+ ["Right" org-table-fedit-ref-right t]
+ "-"
+ "Change Test Row for Column Formulas"
+ ["Up" org-table-fedit-line-up t]
+ ["Down" org-table-fedit-line-down t]
+ "--"
+ ["Scroll Table Window" org-table-fedit-scroll t]
+ ["Scroll Table Window down" org-table-fedit-scroll-down t]
+ ["Show Table Grid" org-table-fedit-toggle-coordinates
+ :style toggle :selected (with-current-buffer (marker-buffer org-pos)
+ org-table-overlay-coordinates)]
+ "--"
+ ["Standard Refs (B3 instead of @3$2)" org-table-fedit-toggle-ref-type
+ :style toggle :selected org-table-buffer-is-an]))
(defvar org-pos)
(defun org-table-edit-formulas ()
"Edit the formulas of the current table in a separate buffer."
(interactive)
+ (when (save-excursion (beginning-of-line 1) (looking-at "#\\+TBLFM"))
+ (beginning-of-line 0))
(unless (org-at-table-p) (error "Not at a table"))
(org-table-get-specials)
- (let ((eql (org-table-get-stored-formulas))
+ (let ((key (org-table-current-field-formula 'key 'noerror))
+ (eql (sort (org-table-get-stored-formulas 'noerror)
+ 'org-table-formula-less-p))
(pos (move-marker (make-marker) (point)))
+ (startline 1)
(wc (current-window-configuration))
- entry s)
- (switch-to-buffer-other-window "*Edit Formulas*")
+ (titles '((column . "# Column Formulas\n")
+ (field . "# Field Formulas\n")
+ (named . "# Named Field Formulas\n")))
+ entry s type title)
+ (org-switch-to-buffer-other-window "*Edit Formulas*")
(erase-buffer)
;; Keep global-font-lock-mode from turning on font-lock-mode
(let ((font-lock-global-modes '(not fundamental-mode)))
(org-set-local 'font-lock-global-modes (list 'not major-mode))
(org-set-local 'org-pos pos)
(org-set-local 'org-window-configuration wc)
- (use-local-map org-edit-formulas-map)
- (org-add-hook 'post-command-hook 'org-table-edit-formulas-post-command t t)
- (setq s "# `C-c C-c' to finish, `C-u C-c C-c' to also apply, `C-c C-q' to abort.
-# `TAB' to pretty-print Lisp expressions, `M-TAB' to complete List symbols
-# `M-up/down' to scroll table, `S-up/down' to change line for column formulas\n\n")
-
- (put-text-property 0 (length s) 'face 'font-lock-comment-face s)
- (insert s)
+ (use-local-map org-table-fedit-map)
+ (org-add-hook 'post-command-hook 'org-table-fedit-post-command t t)
+ (easy-menu-add org-table-fedit-menu)
+ (setq startline (org-current-line))
(while (setq entry (pop eql))
+ (setq type (cond
+ ((equal (string-to-char (car entry)) ?@) 'field)
+ ((string-match "^[0-9]" (car entry)) 'column)
+ (t 'named)))
+ (when (setq title (assq type titles))
+ (or (bobp) (insert "\n"))
+ (insert (org-add-props (cdr title) nil 'face font-lock-comment-face))
+ (setq titles (delq title titles)))
+ (if (equal key (car entry)) (setq startline (org-current-line)))
(setq s (concat (if (equal (string-to-char (car entry)) ?@) "" "$")
(car entry) " = " (cdr entry) "\n"))
(remove-text-properties 0 (length s) '(face nil) s)
(insert s))
- (goto-char (point-min))
- (message "Edit formulas and finish with `C-c C-c'.")))
+ (if (eq org-table-use-standard-references t)
+ (org-table-fedit-toggle-ref-type))
+ (goto-line startline)
+ (message "Edit formulas and finish with `C-c C-c'. See menu for more commands.")))
-(defun org-table-edit-formulas-post-command ()
+(defun org-table-fedit-post-command ()
(when (not (memq this-command '(lisp-complete-symbol)))
(let ((win (selected-window)))
(save-excursion
(condition-case nil
- (org-show-reference)
+ (org-table-show-reference)
(error nil))
(select-window win)))))
-(defun org-finish-edit-formulas (&optional arg)
+(defun org-table-formula-to-user (s)
+ "Convert a formula from internal to user representation."
+ (if (eq org-table-use-standard-references t)
+ (org-table-convert-refs-to-an s)
+ s))
+
+(defun org-table-formula-from-user (s)
+ "Convert a formula from user to internal representation."
+ (if org-table-use-standard-references
+ (org-table-convert-refs-to-rc s)
+ s))
+
+(defun org-table-convert-refs-to-rc (s)
+ "Convert spreadsheet references from AB7 to @7$28.
+Works for single references, but also for entire formulas and even the
+full TBLFM line."
+ (let ((start 0))
+ (while (string-match "\\<\\([a-zA-Z]+\\)\\([0-9]+\\>\\|&\\)\\|\\(;[^\r\n:]+\\)" s start)
+ (cond
+ ((match-end 3)
+ ;; format match, just advance
+ (setq start (match-end 0)))
+ ((and (> (match-beginning 0) 0)
+ (equal ?. (aref s (max (1- (match-beginning 0)) 0)))
+ (not (equal ?. (aref s (max (- (match-beginning 0) 2) 0)))))
+ ;; 3.e5 or something like this.
+ (setq start (match-end 0)))
+ (t
+ (setq start (match-beginning 0)
+ s (replace-match
+ (if (equal (match-string 2 s) "&")
+ (format "$%d" (org-letters-to-number (match-string 1 s)))
+ (format "@%d$%d"
+ (string-to-number (match-string 2 s))
+ (org-letters-to-number (match-string 1 s))))
+ t t s)))))
+ s))
+
+(defun org-table-convert-refs-to-an (s)
+ "Convert spreadsheet references from to @7$28 to AB7.
+Works for single references, but also for entire formulas and even the
+full TBLFM line."
+ (while (string-match "@\\([0-9]+\\)\\$\\([0-9]+\\)" s)
+ (setq s (replace-match
+ (format "%s%d"
+ (org-number-to-letters
+ (string-to-number (match-string 2 s)))
+ (string-to-number (match-string 1 s)))
+ t t s)))
+ (while (string-match "\\(^\\|[^0-9a-zA-Z]\\)\\$\\([0-9]+\\)" s)
+ (setq s (replace-match (concat "\\1"
+ (org-number-to-letters
+ (string-to-number (match-string 2 s))) "&")
+ t nil s)))
+ s)
+
+(defun org-letters-to-number (s)
+ "Convert a base 26 number represented by letters into an integer.
+For example: AB -> 28."
+ (let ((n 0))
+ (setq s (upcase s))
+ (while (> (length s) 0)
+ (setq n (+ (* n 26) (string-to-char s) (- ?A) 1)
+ s (substring s 1)))
+ n))
+
+(defun org-number-to-letters (n)
+ "Convert an integer into a base 26 number represented by letters.
+For example: 28 -> AB."
+ (let ((s ""))
+ (while (> n 0)
+ (setq s (concat (char-to-string (+ (mod (1- n) 26) ?A)) s)
+ n (/ (1- n) 26)))
+ s))
+
+(defun org-table-fedit-convert-buffer (function)
+ "Convert all references in this buffer, using FUNTION."
+ (let ((line (org-current-line)))
+ (goto-char (point-min))
+ (while (not (eobp))
+ (insert (funcall function (buffer-substring (point) (point-at-eol))))
+ (delete-region (point) (point-at-eol))
+ (or (eobp) (forward-char 1)))
+ (goto-line line)))
+
+(defun org-table-fedit-toggle-ref-type ()
+ "Convert all references in the buffer from B3 to @3$2 and back."
+ (interactive)
+ (org-set-local 'org-table-buffer-is-an (not org-table-buffer-is-an))
+ (org-table-fedit-convert-buffer
+ (if org-table-buffer-is-an
+ 'org-table-convert-refs-to-an 'org-table-convert-refs-to-rc))
+ (message "Reference type switched to %s"
+ (if org-table-buffer-is-an "A1 etc" "@row$column")))
+
+(defun org-table-fedit-ref-up ()
+ "Shift the reference at point one row/hline up."
+ (interactive)
+ (org-table-fedit-shift-reference 'up))
+(defun org-table-fedit-ref-down ()
+ "Shift the reference at point one row/hline down."
+ (interactive)
+ (org-table-fedit-shift-reference 'down))
+(defun org-table-fedit-ref-left ()
+ "Shift the reference at point one field to the left."
+ (interactive)
+ (org-table-fedit-shift-reference 'left))
+(defun org-table-fedit-ref-right ()
+ "Shift the reference at point one field to the right."
+ (interactive)
+ (org-table-fedit-shift-reference 'right))
+
+(defun org-table-fedit-shift-reference (dir)
+ (cond
+ ((org-at-regexp-p "\\(\\<[a-zA-Z]\\)&")
+ (if (memq dir '(left right))
+ (org-rematch-and-replace 1 (eq dir 'left))
+ (error "Cannot shift reference in this direction")))
+ ((org-at-regexp-p "\\(\\<[a-zA-Z]\\{1,2\\}\\)\\([0-9]+\\)")
+ ;; A B3-like reference
+ (if (memq dir '(up down))
+ (org-rematch-and-replace 2 (eq dir 'up))
+ (org-rematch-and-replace 1 (eq dir 'left))))
+ ((org-at-regexp-p
+ "\\(@\\|\\.\\.\\)\\([-+]?\\(I+\\>\\|[0-9]+\\)\\)\\(\\$\\([-+]?[0-9]+\\)\\)?")
+ ;; An internal reference
+ (if (memq dir '(up down))
+ (org-rematch-and-replace 2 (eq dir 'up) (match-end 3))
+ (org-rematch-and-replace 5 (eq dir 'left))))))
+
+(defun org-rematch-and-replace (n &optional decr hline)
+ "Re-match the group N, and replace it with the shifted refrence."
+ (or (match-end n) (error "Cannot shift reference in this direction"))
+ (goto-char (match-beginning n))
+ (and (looking-at (regexp-quote (match-string n)))
+ (replace-match (org-shift-refpart (match-string 0) decr hline)
+ t t)))
+
+(defun org-shift-refpart (ref &optional decr hline)
+ "Shift a refrence part REF.
+If DECR is set, decrease the references row/column, else increase.
+If HLINE is set, this may be a hline reference, it certainly is not
+a translation reference."
+ (save-match-data
+ (let* ((sign (string-match "^[-+]" ref)) n)
+
+ (if sign (setq sign (substring ref 0 1) ref (substring ref 1)))
+ (cond
+ ((and hline (string-match "^I+" ref))
+ (setq n (string-to-number (concat sign (number-to-string (length ref)))))
+ (setq n (+ n (if decr -1 1)))
+ (if (= n 0) (setq n (+ n (if decr -1 1))))
+ (if sign
+ (setq sign (if (< n 0) "-" "+") n (abs n))
+ (setq n (max 1 n)))
+ (concat sign (make-string n ?I)))
+
+ ((string-match "^[0-9]+" ref)
+ (setq n (string-to-number (concat sign ref)))
+ (setq n (+ n (if decr -1 1)))
+ (if sign
+ (concat (if (< n 0) "-" "+") (number-to-string (abs n)))
+ (number-to-string (max 1 n))))
+
+ ((string-match "^[a-zA-Z]+" ref)
+ (org-number-to-letters
+ (max 1 (+ (org-letters-to-number ref) (if decr -1 1)))))
+
+ (t (error "Cannot shift reference"))))))
+
+(defun org-table-fedit-toggle-coordinates ()
+ "Toggle the display of coordinates in the refrenced table."
+ (interactive)
+ (let ((pos (marker-position org-pos)))
+ (with-current-buffer (marker-buffer org-pos)
+ (save-excursion
+ (goto-char pos)
+ (org-table-toggle-coordinate-overlays)))))
+
+(defun org-table-fedit-finish (&optional arg)
"Parse the buffer for formula definitions and install them.
With prefix ARG, apply the new formulas to the table."
(interactive "P")
(org-table-remove-rectangle-highlight)
+ (if org-table-use-standard-references
+ (progn
+ (org-table-fedit-convert-buffer 'org-table-convert-refs-to-rc)
+ (setq org-table-buffer-is-an nil)))
(let ((pos org-pos) eql var form)
- (setq org-pos nil)
(goto-char (point-min))
(while (re-search-forward
"^\\(@[0-9]+\\$[0-9]+\\|\\$\\([a-zA-Z0-9]+\\)\\) *= *\\(.*\\(\n[ \t]+.*$\\)*\\)"
(setq var (if (match-end 2) (match-string 2) (match-string 1))
form (match-string 3))
(setq form (org-trim form))
- (while (string-match "[ \t]*\n[ \t]*" form)
- (setq form (replace-match " " t t form)))
- (push (cons var form) eql))
+ (when (not (equal form ""))
+ (while (string-match "[ \t]*\n[ \t]*" form)
+ (setq form (replace-match " " t t form)))
+ (when (assoc var eql)
+ (error "Double formulas for %s" var))
+ (push (cons var form) eql)))
+ (setq org-pos nil)
(set-window-configuration org-window-configuration)
(select-window (get-buffer-window (marker-buffer pos)))
(goto-char pos)
(org-table-recalculate 'all)
(message "New formulas installed - press C-u C-c C-c to apply."))))
-(defun org-abort-edit-formulas ()
+(defun org-table-fedit-abort ()
"Abort editing formulas, without installing the changes."
(interactive)
(org-table-remove-rectangle-highlight)
(move-marker pos nil)
(message "Formula editing aborted without installing changes")))
-(defun org-edit-formula-lisp-indent ()
+(defun org-table-fedit-lisp-indent ()
"Pretty-print and re-indent Lisp expressions in the Formula Editor."
(interactive)
(let ((pos (point)) beg end ind)
((looking-at "[ \t]")
(goto-char pos)
(call-interactively 'lisp-indent-line))
- ((looking-at "[$@0-9a-zA-Z]+ *= *[^ \t\n']") (goto-char pos))
+ ((looking-at "[$&@0-9a-zA-Z]+ *= *[^ \t\n']") (goto-char pos))
((not (fboundp 'pp-buffer))
(error "Cannot pretty-print. Command `pp-buffer' is not available."))
- ((looking-at "[$@0-9a-zA-Z]+ *= *'(")
+ ((looking-at "[$&@0-9a-zA-Z]+ *= *'(")
(goto-char (- (match-end 0) 2))
(setq beg (point))
(setq ind (make-string (current-column) ?\ ))
(defvar org-show-positions nil)
-(defun org-show-reference (&optional local)
+(defun org-table-show-reference (&optional local)
"Show the location/value of the $ expression at point."
(interactive)
(org-table-remove-rectangle-highlight)
var name e what match dest)
(if local (org-table-get-specials))
(setq what (cond
- ((org-at-regexp-p org-table-range-regexp2) 'range)
+ ((or (org-at-regexp-p org-table-range-regexp2)
+ (org-at-regexp-p org-table-translate-regexp)
+ (org-at-regexp-p org-table-range-regexp))
+ (setq match
+ (save-match-data
+ (org-table-convert-refs-to-rc (match-string 0))))
+ 'range)
((org-at-regexp-p "\\$[a-zA-Z][a-zA-Z0-9]*") 'name)
((org-at-regexp-p "\\$[0-9]+") 'column)
((not local) nil)
(t (error "No reference at point")))
- match (and what (match-string 0)))
+ match (and what (or match (match-string 0))))
(when (and match (not (equal (match-beginning 0) (point-at-bol))))
(org-table-add-rectangle-overlay (match-beginning 0) (match-end 0)
'secondary-selection))
(setq match (org-table-formula-substitute-names match)))
(unless local
(save-excursion
+ (end-of-line 1)
+ (re-search-backward "^\\S-" nil t)
(beginning-of-line 1)
- (when (looking-at "\\(\\$[0-9a-zA-Z]+\\|@[0-9]+\\$[0-9]+\\)=")
- (setq dest (match-string 1))
+ (when (looking-at "\\(\\$[0-9a-zA-Z]+\\|@[0-9]+\\$[0-9]+\\|[a-zA-Z]+\\([0-9]+\\|&\\)\\) *=")
+ (setq dest
+ (save-match-data
+ (org-table-convert-refs-to-rc (match-string 1))))
(org-table-add-rectangle-overlay
(match-beginning 1) (match-end 1) face2))))
(if (and (markerp pos) (marker-buffer pos))
(if (get-buffer-window (marker-buffer pos))
(select-window (get-buffer-window (marker-buffer pos)))
- (switch-to-buffer-other-window (get-buffer-window
+ (org-switch-to-buffer-other-window (get-buffer-window
(marker-buffer pos)))))
(goto-char pos)
(org-table-force-dataline)
(t
(cond
((not var) (error "No reference at point"))
+ ((setq e (assoc var org-table-formula-constants-local))
+ (message "Local Constant: $%s=%s in #+CONSTANTS line."
+ var (cdr e)))
((setq e (assoc var org-table-formula-constants))
(message "Constant: $%s=%s in `org-table-formula-constants'."
var (cdr e)))
((setq e (and (fboundp 'constants-get) (constants-get var)))
- (message "Constant: $%s=%s, retrieved from `constants.el'." var e))
+ (message "Constant: $%s=%s, from `constants.el'%s."
+ var e (format " (%s units)" constants-unit-system)))
(t (error "Undefined name $%s" var)))))
(goto-char pos)
- (when org-show-positions
+ (when (and org-show-positions
+ (not (memq this-command '(org-table-fedit-scroll
+ org-table-fedit-scroll-down))))
(push pos org-show-positions)
+ (push org-table-current-begin-pos org-show-positions)
(let ((min (apply 'min org-show-positions))
(max (apply 'max org-show-positions)))
- (when (or (not (pos-visible-in-window-p min))
- (not (pos-visible-in-window-p max)))
- (goto-char min)
- (set-window-start (selected-window) (point-at-bol))
- (goto-char pos))))
+ (goto-char min) (recenter 0)
+ (goto-char max)
+ (or (pos-visible-in-window-p max) (recenter -1))))
(select-window win))))
(defun org-table-force-dataline ()
((or p1 p2) (goto-char (or p1 p2)))
(t (error "No table dataline around here"))))))
-(defun org-table-edit-line-up ()
+(defun org-table-fedit-line-up ()
"Move cursor one line up in the window showing the table."
(interactive)
- (org-table-edit-move 'previous-line))
+ (org-table-fedit-move 'previous-line))
-(defun org-table-edit-line-down ()
+(defun org-table-fedit-line-down ()
"Move cursor one line down in the window showing the table."
(interactive)
- (org-table-edit-move 'next-line))
-
-(defun org-table-edit-backward-field ()
- "Move cursor one field backward in the window showing the table."
- (interactive)
- (org-table-edit-move 'org-table-previous-field))
-
-(defun org-table-edit-next-field ()
- "Move cursor one field forward in the window showing the table."
- (interactive)
- (org-table-edit-move 'org-table-next-field))
+ (org-table-fedit-move 'next-line))
-(defun org-table-edit-move (command)
+(defun org-table-fedit-move (command)
"Move the cursor in the window shoinw the table.
Use COMMAND to do the motion, repeat if necessary to end up in a data line."
(let ((org-table-allow-automatic-line-recalculation nil)
(move-marker pos (point))
(select-window win)))
-(defun org-table-edit-scroll (N)
+(defun org-table-fedit-scroll (N)
(interactive "p")
(let ((other-window-scroll-buffer (marker-buffer org-pos)))
(scroll-other-window N)))
-(defun org-table-edit-scroll-down (N)
+(defun org-table-fedit-scroll-down (N)
(interactive "p")
- (org-table-edit-scroll (- N)))
+ (org-table-fedit-scroll (- N)))
(defvar org-table-rectangle-overlays nil)
(mapc 'org-delete-overlay org-table-coordinate-overlays)
(setq org-table-coordinate-overlays nil)
(save-excursion
- (let ((id 0) (ih 0) hline eol str ic ov beg)
+ (let ((id 0) (ih 0) hline eol s1 s2 str ic ov beg)
(goto-char (org-table-begin))
(while (org-at-table-p)
(setq eol (point-at-eol))
(setq hline (looking-at org-table-hline-regexp))
(setq str (if hline (format "I*%-2d" (setq ih (1+ ih)))
(format "%4d" (setq id (1+ id)))))
- (org-overlay-before-string ov str 'org-formula 'evaporate)
+ (org-overlay-before-string ov str 'org-special-keyword 'evaporate)
(when hline
(setq ic 0)
- (while (re-search-forward "[+|]-+" eol t)
+ (while (re-search-forward "[+|]\\(-+\\)" eol t)
(setq beg (1+ (match-beginning 0))
- str (concat "$" (int-to-string (setq ic (1+ ic)))))
+ ic (1+ ic)
+ s1 (concat "$" (int-to-string ic))
+ s2 (org-number-to-letters ic)
+ str (if (eq org-table-use-standard-references t) s2 s1))
(setq ov (org-make-overlay beg (+ beg (length str))))
(push ov org-table-coordinate-overlays)
- (org-overlay-display ov str 'org-formula 'evaporate)))
+ (org-overlay-display ov str 'org-special-keyword 'evaporate)))
(beginning-of-line 2)))))
(defun org-table-toggle-coordinate-overlays ()
(defun orgtbl-error ()
"Error when there is no default binding for a table key."
(interactive)
- (error "This key is has no function outside tables"))
+ (error "This key has no function outside tables"))
(defun orgtbl-setup ()
"Setup orgtbl keymaps."
'("\C-c}" org-table-toggle-coordinate-overlays)
'("\C-c{" org-table-toggle-formula-debugger)
'("\C-m" org-table-next-row)
- (list (org-key 'S-return) 'org-table-copy-down)
+ '([(shift return)] org-table-copy-down)
'("\C-c\C-q" org-table-wrap-region)
'("\C-c?" org-table-field-info)
'("\C-c " org-table-blank-field)
elt key fun cmd)
(while (setq elt (pop bindings))
(setq nfunc (1+ nfunc))
- (setq key (car elt)
+ (setq key (org-key (car elt))
fun (nth 1 elt)
cmd (orgtbl-make-binding fun nfunc key))
- (define-key orgtbl-mode-map key cmd))
+ (org-defkey orgtbl-mode-map key cmd))
;; Special treatment needed for TAB and RET
- (define-key orgtbl-mode-map [(return)]
+ (org-defkey orgtbl-mode-map [(return)]
(orgtbl-make-binding 'orgtbl-ret 100 [(return)] "\C-m"))
- (define-key orgtbl-mode-map "\C-m"
+ (org-defkey orgtbl-mode-map "\C-m"
(orgtbl-make-binding 'orgtbl-ret 101 "\C-m" [(return)]))
- (define-key orgtbl-mode-map [(tab)]
+ (org-defkey orgtbl-mode-map [(tab)]
(orgtbl-make-binding 'orgtbl-tab 102 [(tab)] "\C-i"))
- (define-key orgtbl-mode-map "\C-i"
+ (org-defkey orgtbl-mode-map "\C-i"
(orgtbl-make-binding 'orgtbl-tab 103 "\C-i" [(tab)]))
- (define-key orgtbl-mode-map [(shift tab)]
+ (org-defkey orgtbl-mode-map [(shift tab)]
(orgtbl-make-binding 'org-table-previous-field 104
[(shift tab)] [(tab)] "\C-i"))
- (define-key orgtbl-mode-map "\M-\C-m"
+ (org-defkey orgtbl-mode-map "\M-\C-m"
(orgtbl-make-binding 'org-table-wrap-region 105
"\M-\C-m" [(meta return)]))
- (define-key orgtbl-mode-map [(meta return)]
+ (org-defkey orgtbl-mode-map [(meta return)]
(orgtbl-make-binding 'org-table-wrap-region 106
[(meta return)] "\M-\C-m"))
- (define-key orgtbl-mode-map "\C-c\C-c" 'orgtbl-ctrl-c-ctrl-c)
+ (org-defkey orgtbl-mode-map "\C-c\C-c" 'orgtbl-ctrl-c-ctrl-c)
(when orgtbl-optimized
;; If the user wants maximum table support, we need to hijack
;; some standard editing functions
'self-insert-command 'orgtbl-self-insert-command
'delete-char 'org-delete-char
'delete-backward-char 'org-delete-backward-char)
- (define-key orgtbl-mode-map "|" 'org-force-self-insert))
+ (org-defkey orgtbl-mode-map "|" 'org-force-self-insert))
(easy-menu-define orgtbl-mode-menu orgtbl-mode-map "OrgTbl menu"
'("OrgTbl"
["Align" org-ctrl-c-ctrl-c :active (org-at-table-p) :keys "C-c C-c"]
["Move Row Down" org-metadown :active (org-at-table-p) :keys "M-<down>"]
["Delete Row" org-shiftmetaup :active (org-at-table-p) :keys "M-S-<up>"]
["Insert Row" org-shiftmetadown :active (org-at-table-p) :keys "M-S-<down>"]
- ["Sort lines in region" org-table-sort-lines (org-at-table-p) :keys "C-c ^"]
+ ["Sort lines in region" org-table-sort-lines :active (org-at-table-p) :keys "C-c ^"]
"--"
["Insert Hline" org-table-insert-hline :active (org-at-table-p) :keys "C-c -"])
("Rectangle"
(defvar orgtbl-exp-regexp "^\\([-+]?[0-9][0-9.]*\\)[eE]\\([-+]?[0-9]+\\)$"
"Regula expression matching exponentials as produced by calc.")
-(defvar org-table-clean-did-remove-column-1 nil)
+(defvar org-table-clean-did-remove-column nil)
+
+(defun orgtbl-export (table target)
+ (let ((func (intern (concat "orgtbl-to-" (symbol-name target))))
+ (lines (org-split-string table "[ \t]*\n[ \t]*"))
+ org-table-last-alignment org-table-last-column-widths
+ maxcol column)
+ (if (not (fboundp func))
+ (error "Cannot export orgtbl table to %s" target))
+ (setq lines (org-table-clean-before-export lines))
+ (setq table
+ (mapcar
+ (lambda (x)
+ (if (string-match org-table-hline-regexp x)
+ 'hline
+ (org-split-string (org-trim x) "\\s-*|\\s-*")))
+ lines))
+ (setq maxcol (apply 'max (mapcar (lambda (x) (if (listp x) (length x) 0))
+ table)))
+ (loop for i from (1- maxcol) downto 0 do
+ (setq column (mapcar (lambda (x) (if (listp x) (nth i x) nil)) table))
+ (setq column (delq nil column))
+ (push (apply 'max (mapcar 'string-width column)) org-table-last-column-widths)
+ (push (> (/ (apply '+ (mapcar (lambda (x) (if (string-match org-table-number-regexp x) 1 0)) column)) maxcol) org-table-number-fraction) org-table-last-alignment))
+ (funcall func table nil)))
(defun orgtbl-send-table (&optional maybe)
"Send a tranformed version of this table to the receiver position.
(org-table-begin) (org-table-end)))
(lines (nthcdr (or skip 0) (org-split-string txt "[ \t]*\n[ \t]*")))
(lines (org-table-clean-before-export lines))
- (i0 (if org-table-clean-did-remove-column-1 2 1))
+ (i0 (if org-table-clean-did-remove-column 2 1))
(table (mapcar
(lambda (x)
(if (string-match org-table-hline-regexp x)
%s for the original field value. For example, to wrap
everything in dollars, you could use :fmt \"$%s$\".
This may also be a property list with column numbers and
- formats. for example :fmt (2 \"$%s$\" 4 \"%s%%\")
+ formats. For example :fmt (2 \"$%s$\" 4 \"%s%%\")
:hlstart :hlend :hlsep :hlfmt :hfmt
Same as above, specific for the header lines in the table.
:fmt A format to be used to wrap the field, should contain %s for the
original field value. For example, to wrap everything in dollars,
use :fmt \"$%s$\". This may also be a property list with column
- numbers and formats. for example :fmt (2 \"$%s$\" 4 \"%s%%\")
+ numbers and formats. For example :fmt (2 \"$%s$\" 4 \"%s%%\")
:efmt Format for transforming numbers with exponentials. The format
should have %s twice for inserting mantissa and exponent, for
%s for the original field value. For example, to wrap
everything in @kbd{}, you could use :fmt \"@kbd{%s}\".
This may also be a property list with column numbers and
- formats. for example :fmt (2 \"@kbd{%s}\" 4 \"@code{%s}\").
+ formats. For example :fmt (2 \"@kbd{%s}\" 4 \"@code{%s}\").
-:cf \"f1 f2..\" The column fractions for the table. Bye default these
+:cf \"f1 f2..\" The column fractions for the table. By default these
are computed automatically from the width of the columns
under org-mode.
(defun org-link-expand-abbrev (link)
"Apply replacements as defined in `org-link-abbrev-alist."
- (if (string-match "^\\([a-zA-Z]+\\)\\(::?\\(.*\\)\\)?$" link)
+ (if (string-match "^\\([a-zA-Z][-_a-zA-Z0-9]*\\)\\(::?\\(.*\\)\\)?$" link)
(let* ((key (match-string 1 link))
(as (or (assoc key org-link-abbrev-alist-local)
(assoc key org-link-abbrev-alist)))
(defvar org-store-link-plist nil
"Plist with info about the most recently link created with `org-store-link'.")
+(defvar org-link-protocols nil
+ "Link protocols added to Org-mode using `org-add-link-type'.")
+
+(defvar org-store-link-functions nil
+ "List of functions that are called to create and store a link.
+Each function will be called in turn until one returns a non-nil
+value. Each function should check if it is responsible for creating
+this link (for example by looking at the major mode).
+If not, it must exit and return nil.
+If yes, it should return a non-nil value after a calling
+`org-store-link-props' with a list of properties and values.
+Special properties are:
+
+:type The link prefix. like \"http\". This must be given.
+:link The link, like \"http://www.astro.uva.nl/~dominik\".
+ This is obligatory as well.
+:description Optional default description for the second pair
+ of brackets in an Org-mode link. The user can still change
+ this when inserting this link into an Org-mode buffer.
+
+In addition to these, any additional properties can be specified
+and then used in remember templates.")
+
+(defun org-add-link-type (type &optional follow publish)
+ "Add TYPE to the list of `org-link-types'.
+Re-compute all regular expressions depending on `org-link-types'
+FOLLOW and PUBLISH are two functions. Both take the link path as
+an argument.
+FOLLOW should do whatever is necessary to follow the link, for example
+to find a file or display a mail message.
+
+PUBLISH takes the path and retuns the string that should be used when
+this document is published. FIMXE: This is actually not yet implemented."
+ (add-to-list 'org-link-types type t)
+ (org-make-link-regexps)
+ (add-to-list 'org-link-protocols
+ (list type follow publish)))
+
+(defun org-add-agenda-custom-command (entry)
+ "Replace or add a command in `org-agenda-custom-commands'.
+This is mostly for hacking and trying a new command - once the command
+works you probably want to add it to `org-agenda-custom-commands' for good."
+ (let ((ass (assoc (car entry) org-agenda-custom-commands)))
+ (if ass
+ (setcdr ass (cdr entry))
+ (push entry org-agenda-custom-commands))))
+
;;;###autoload
(defun org-store-link (arg)
"\\<org-mode-map>Store an org-link to the current location.
-This link can later be inserted into an org-buffer with
-\\[org-insert-link].
+This link is added to `org-stored-links' and can later be inserted
+into an org-buffer with \\[org-insert-link].
+
For some link types, a prefix arg is interpreted:
For links to usenet articles, arg negates `org-usenet-links-prefer-google'.
For file links, arg negates `org-context-in-file-links'."
(interactive "P")
+ (require 'org-irc)
(setq org-store-link-plist nil) ; reset
(let (link cpltxt desc description search txt)
(cond
+ ((run-hook-with-args-until-success 'org-store-link-functions)
+ (setq link (plist-get org-store-link-plist :link)
+ desc (or (plist-get org-store-link-plist :description) link)))
+
((eq major-mode 'bbdb-mode)
(let ((name (bbdb-record-name (bbdb-current-record)))
- (company (bbdb-record-company (bbdb-current-record))))
+ (company (bbdb-record-getprop (bbdb-current-record) 'company)))
(setq cpltxt (concat "bbdb:" (or name company))
link (org-make-link cpltxt))
(org-store-link-props :type "bbdb" :name name :company company)))
(if (fboundp 'elmo-message-entity)
(elmo-message-entity
wl-summary-buffer-elmo-folder msgnum)
- (elmo-msgdb-overview-get-entity
- msgnum (wl-summary-buffer-msgdb))))
+ (elmo-msgdb-overview-get-entity
+ msgnum (wl-summary-buffer-msgdb))))
(from (wl-summary-line-from))
(to (car (elmo-message-entity-field wl-message-entity 'to)))
(subject (let (wl-thr-indent-string wl-parent-message-entity)
(setq link (org-make-link "mhe:" (org-mhe-get-message-real-folder) "#"
(org-remove-angle-brackets message-id)))))
- ((eq major-mode 'rmail-mode)
- (save-excursion
+ ((or (eq major-mode 'rmail-mode)
+ (eq major-mode 'rmail-summary-mode))
+ (save-window-excursion
(save-restriction
+ (when (eq major-mode 'rmail-summary-mode)
+ (rmail-show-message rmail-current-message))
(rmail-narrow-to-non-pruned-header)
(let ((folder buffer-file-name)
(message-id (mail-fetch-field "message-id"))
:subject subject :message-id message-id)
(setq message-id (org-remove-angle-brackets message-id))
(setq cpltxt (org-email-link-description))
- (setq link (org-make-link "rmail:" folder "#" message-id))))))
+ (setq link (org-make-link "rmail:" folder "#" message-id)))
+ (rmail-show-message rmail-current-message))))
((eq major-mode 'gnus-group-mode)
(let ((group (cond ((fboundp 'gnus-group-group-name) ; depending on Gnus
(setq cpltxt (substring cpltxt 0 -2)))
(setq link (org-make-link cpltxt)))
- (buffer-file-name
+ ((buffer-file-name (buffer-base-buffer))
;; Just link to this file here.
(setq cpltxt (concat "file:"
- (abbreviate-file-name buffer-file-name)))
+ (abbreviate-file-name
+ (buffer-file-name (buffer-base-buffer)))))
;; Add a context string
(when (org-xor org-context-in-file-links arg)
(setq txt (if (org-region-active-p)
(if (and (interactive-p) link)
(progn
(setq org-stored-links
- (cons (list cpltxt link desc) org-stored-links))
- (message "Stored: %s" (or cpltxt link)))
- (org-make-link-string link desc))))
+ (cons (list link desc) org-stored-links))
+ (message "Stored: %s" (or desc link)))
+ (and link (org-make-link-string link desc)))))
(defun org-store-link-props (&rest plist)
"Store link properties, extract names and addresses."
;; We are using a headline, clean up garbage in there.
(if (string-match org-todo-regexp s)
(setq s (replace-match "" t t s)))
- (if (string-match ":[a-zA-Z_@0-9:]+:[ \t]*$" s)
+ (if (string-match (org-re ":[[:alnum:]_@:]+:[ \t]*$") s)
(setq s (replace-match "" t t s)))
(setq s (org-trim s))
(if (string-match (concat "^\\(" org-quote-string "\\|"
(mapconcat 'identity (org-split-string s "[ \t]+") " ")))
(defun org-make-link (&rest strings)
- "Concatenate STRINGS, format resulting string with `org-link-format'."
+ "Concatenate STRINGS."
(apply 'concat strings))
(defun org-make-link-string (link &optional description)
"Make a link with brackets, consisting of LINK and DESCRIPTION."
+ (unless (string-match "\\S-" link)
+ (error "Empty link"))
(when (stringp description)
;; Remove brackets from the description, they are fatal.
- (while (string-match "\\[\\|\\]" description)
- (setq description (replace-match "" t t description))))
+ (while (string-match "\\[" description)
+ (setq description (replace-match "{" t t description)))
+ (while (string-match "\\]" description)
+ (setq description (replace-match "}" t t description))))
(when (equal (org-link-escape link) description)
;; No description needed, it is identical
(setq description nil))
(if description (concat "[" description "]") "")
"]"))
-(defconst org-link-escape-chars '(("[" . "%5B") ("]" . "%5D") (" " . "%20"))
- "Association list of escapes for some characters problematic in links.")
+(defconst org-link-escape-chars
+ '((?\ . "%20")
+ (?\[ . "%5B")
+ (?\] . "%5D")
+ (?\340 . "%E0") ; `a
+ (?\342 . "%E2") ; ^a
+ (?\347 . "%E7") ; ,c
+ (?\350 . "%E8") ; `e
+ (?\351 . "%E9") ; 'e
+ (?\352 . "%EA") ; ^e
+ (?\356 . "%EE") ; ^i
+ (?\364 . "%F4") ; ^o
+ (?\371 . "%F9") ; `u
+ (?\373 . "%FB") ; ^u
+ (?\; . "%3B")
+ (?? . "%3F")
+ (?= . "%3D")
+ (?+ . "%2B")
+ )
+ "Association list of escapes for some characters problematic in links.
+This is the list that is used for internal purposes.")
+
+(defconst org-link-escape-chars-browser
+ '((?\ . "%20")) ; 32 for the SPC char
+ "Association list of escapes for some characters problematic in links.
+This is the list that is used before handing over to the browser.")
-(defun org-link-escape (text)
+(defun org-link-escape (text &optional table)
"Escape charaters in TEXT that are problematic for links."
+ (setq table (or table org-link-escape-chars))
(when text
- (let ((re (mapconcat (lambda (x) (regexp-quote (car x)))
- org-link-escape-chars "\\|")))
+ (let ((re (mapconcat (lambda (x) (regexp-quote
+ (char-to-string (car x))))
+ table "\\|")))
(while (string-match re text)
(setq text
(replace-match
- (cdr (assoc (match-string 0 text) org-link-escape-chars))
+ (cdr (assoc (string-to-char (match-string 0 text))
+ table))
t t text)))
text)))
-(defun org-link-unescape (text)
+(defun org-link-unescape (text &optional table)
"Reverse the action of `org-link-escape'."
+ (setq table (or table org-link-escape-chars))
(when text
(let ((re (mapconcat (lambda (x) (regexp-quote (cdr x)))
- org-link-escape-chars "\\|")))
+ table "\\|")))
(while (string-match re text)
(setq text
(replace-match
- (car (rassoc (match-string 0 text) org-link-escape-chars))
+ (char-to-string (car (rassoc (match-string 0 text) table)))
t t text)))
text)))
(setq s (replace-match "%40" t t s)))
s)
+;;;###autoload
+(defun org-insert-link-global ()
+ "Insert a link like Org-mode does.
+This command can be called in any mode to insert a link in Org-mode syntax."
+ (interactive)
+ (org-run-like-in-org-mode 'org-insert-link))
+
(defun org-insert-link (&optional complete-file)
"Insert a link. At the prompt, enter the link.
With three \\[universal-argument] prefixes, negate the meaning of
`org-keep-stored-link-after-insertion'."
(interactive "P")
- (let ((region (if (org-region-active-p)
- (prog1 (buffer-substring (region-beginning) (region-end))
- (delete-region (region-beginning) (region-end)))))
- tmphist ; byte-compile incorrectly complains about this
- link desc entry remove file)
+ (let* ((wcf (current-window-configuration))
+ (region (if (org-region-active-p)
+ (buffer-substring (region-beginning) (region-end))))
+ (remove (and region (list (region-beginning) (region-end))))
+ (desc region)
+ tmphist ; byte-compile incorrectly complains about this
+ link entry file)
(cond
((org-in-regexp org-bracket-link-regexp 1)
;; We do have a link at point, and we are going to edit it.
(t (setq link (org-make-link "file:" file))))))
(t
;; Read link, with completion for stored links.
- ;; Fake a link history
+ (with-output-to-temp-buffer "*Org Links*"
+ (princ "Insert a link. Use TAB to complete valid link prefixes.\n")
+ (when org-stored-links
+ (princ "\nStored links are available with <up>/<down> or M-p/n (most recent with RET):\n\n")
+ (princ (mapconcat
+ (lambda (x)
+ (if (nth 1 x) (concat (car x) " (" (nth 1 x) ")") (car x)))
+ (reverse org-stored-links) "\n"))))
+ (let ((cw (selected-window)))
+ (select-window (get-buffer-window "*Org Links*"))
+ (shrink-window-if-larger-than-buffer)
+ (setq truncate-lines t)
+ (select-window cw))
+ ;; Fake a link history, containing the stored links.
(setq tmphist (append (mapcar 'car org-stored-links)
org-insert-link-history))
- (setq link (org-completing-read
- "Link: " org-stored-links nil nil nil
- 'tmphist
- (or (car (car org-stored-links)))))
+ (unwind-protect
+ (setq link (org-completing-read
+ "Link: "
+ (append
+ (mapcar (lambda (x) (list (concat (car x) ":")))
+ (append org-link-abbrev-alist-local org-link-abbrev-alist))
+ (mapcar (lambda (x) (list (concat x ":")))
+ org-link-types))
+ nil nil nil
+ 'tmphist
+ (or (car (car org-stored-links)))))
+ (set-window-configuration wcf)
+ (kill-buffer "*Org Links*"))
(setq entry (assoc link org-stored-links))
(or entry (push link org-insert-link-history))
(if (funcall (if (equal complete-file '(64)) 'not 'identity)
(not org-keep-stored-link-after-insertion))
(setq org-stored-links (delq (assoc link org-stored-links)
org-stored-links)))
- (setq link (if entry (nth 1 entry) link)
- desc (or region desc (nth 2 entry)))))
+ (setq desc (or desc (nth 1 entry)))))
(if (string-match org-plain-link-re link)
;; URL-like link, normalize the use of angular brackets.
;; Check if we can/should use a relative path. If yes, simplify the link
(when (string-match "\\<file:\\(.*\\)" link)
(let* ((path (match-string 1 link))
+ (origpath path)
(case-fold-search nil))
(cond
((eq org-link-file-path-type 'absolute)
;; We are linking a file with relative path name.
(setq path (substring (expand-file-name path)
(match-end 0)))))))
- (setq link (concat "file:" path))))
+ (setq link (concat "file:" path))
+ (if (equal desc origpath)
+ (setq desc path))))
(setq desc (read-string "Description: " desc))
(unless (string-match "\\S-" desc) (setq desc nil))
(defun org-completing-read (&rest args)
(let ((minibuffer-local-completion-map
(copy-keymap minibuffer-local-completion-map)))
- (define-key minibuffer-local-completion-map " " 'self-insert-command)
+ (org-defkey minibuffer-local-completion-map " " 'self-insert-command)
(apply 'completing-read args)))
;;; Opening/following a link
(defvar org-open-link-marker (make-marker)
"Marker pointing to the location where `org-open-at-point; was called.")
+;;;###autoload
+(defun org-open-at-point-global ()
+ "Follow a link like Org-mode does.
+This command can be called in any mode to follow a link that has
+Org-mode syntax."
+ (interactive)
+ (org-run-like-in-org-mode 'org-open-at-point))
+
(defun org-open-at-point (&optional in-emacs)
"Open link at or after point.
If there is no link at point, this function will search forward up to
Normally, files will be opened by an appropriate application. If the
optional argument IN-EMACS is non-nil, Emacs will visit the file."
(interactive "P")
+ (require 'org-irc)
(move-marker org-open-link-marker (point))
(setq org-window-config-before-follow-link (current-window-configuration))
(org-remove-occur-highlights nil nil t)
(org-in-regexp org-plain-link-re))
(setq type (match-string 1) path (match-string 2))
(throw 'match t)))
+ (when (org-in-regexp "\\<\\([^><\n]+\\)\\>")
+ (setq type "tree-match"
+ path (match-string 1))
+ (throw 'match t))
(save-excursion
- (when (org-in-regexp "\\(:[A-Za-z_@0-9:]+\\):[ \t\r\n]")
+ (when (org-in-regexp (org-re "\\(:[[:alnum:]_@:]+\\):[ \t]*$"))
(setq type "tags"
path (match-string 1))
(while (string-match ":" path)
(cond
+ ((assoc type org-link-protocols)
+ (funcall (nth 1 (assoc type org-link-protocols)) path))
+
((equal type "mailto")
(let ((cmd (car org-link-mailto-program))
(args (cdr org-link-mailto-program)) args1
(apply cmd (nreverse args1))))
((member type '("http" "https" "ftp" "news"))
+ (browse-url (concat type ":" (org-link-escape
+ path org-link-escape-chars-browser))))
+
+ ((member type '("message"))
(browse-url (concat type ":" path)))
((string= type "tags")
(switch-to-buffer-other-window
(org-get-buffer-for-internal-link (current-buffer)))
(org-mark-ring-push))
- (org-link-search
- path
- (cond ((equal in-emacs '(4)) 'occur)
- ((equal in-emacs '(16)) 'org-occur)
- (t nil))
- pos))
+ (let ((cmd `(org-link-search
+ ,path
+ ,(cond ((equal in-emacs '(4)) 'occur)
+ ((equal in-emacs '(16)) 'org-occur)
+ (t nil))
+ ,pos)))
+ (condition-case nil (eval cmd)
+ (error (progn (widen) (eval cmd))))))
+
+ ((string= type "tree-match")
+ (org-occur (concat "\\[" (regexp-quote path) "\\]")))
((string= type "file")
(if (string-match "::\\([0-9]+\\)\\'" path)
(if (string-match "::\\(.+\\)\\'" path)
(setq search (match-string 1 path)
path (substring path 0 (match-beginning 0)))))
- (org-open-file path in-emacs line search))
+ (if (string-match "[*?{]" (file-name-nondirectory path))
+ (dired path)
+ (org-open-file path in-emacs line search)))
((string= type "news")
(org-follow-gnus-link path))
((string= type "shell")
(let ((cmd path))
- ;; FIXME: the following is only for backward compatibility
- (while (string-match "@{" cmd) (setq cmd (replace-match "<" t t cmd)))
- (while (string-match "@}" cmd) (setq cmd (replace-match ">" t t cmd)))
(if (or (not org-confirm-shell-link-function)
(funcall org-confirm-shell-link-function
(format "Execute \"%s\" in shell? "
(funcall org-confirm-elisp-link-function
(format "Execute \"%s\" as elisp? "
(org-add-props cmd nil
- 'face 'org-warning))))
- (message "%s => %s" cmd (eval (read cmd)))
+ 'face 'org-warning))))
+ (message "%s => %s" cmd (eval (read cmd)))
(error "Abort"))))
(t
(browse-url-at-point)))))
- (move-marker org-open-link-marker nil))
-
+ (move-marker org-open-link-marker nil)
+ (run-hook-with-args 'org-follow-link-hook))
;;; File search
in all files. If AVOID-POS is given, ignore matches near that position."
(let ((case-fold-search t)
(s0 (mapconcat 'identity (org-split-string s "[ \t\r\n]+") " "))
+ (markers (concat "\\(?:" (mapconcat (lambda (x) (regexp-quote (car x)))
+ (append '(("") (" ") ("\t") ("\n"))
+ org-emphasis-alist)
+ "\\|") "\\)"))
(pos (point))
(pre "") (post "")
words re0 re1 re2 re3 re4 re5 re2a reall)
;; (grep (concat "grep -n -e '" (match-string 1 s) "' *")))
(t (org-do-occur (match-string 1 s)))))
(t
- ;; A normal search string
+ ;; A normal search strings
(when (equal (string-to-char s) ?*)
;; Anchor on headlines, post may include tags.
- (setq pre "^\\*+[ \t]*\\(?:\\sw+\\)?[ \t]*"
- post "[ \t]*\\(?:[ \t]+:[a-zA-Z_@0-9:+]:[ \t]*\\)?$"
+ (setq pre "^\\*+[ \t]+\\(?:\\sw+\\)?[ \t]*"
+ post (org-re "[ \t]*\\(?:[ \t]+:[[:alnum:]_@:+]:[ \t]*\\)?$")
s (substring s 1)))
(remove-text-properties
0 (length s)
;; Make a series of regular expressions to find a match
(setq words (org-split-string s "[ \n\r\t]+")
re0 (concat "\\(<<" (regexp-quote s0) ">>\\)")
- re2 (concat "[ \t\r\n]\\(" (mapconcat 'downcase words "[ \t]+") "\\)[ \t\r\n]")
+ re2 (concat markers "\\(" (mapconcat 'downcase words "[ \t]+")
+ "\\)" markers)
re2a (concat "[ \t\r\n]\\(" (mapconcat 'downcase words "[ \t\r\n]+") "\\)[ \t\r\n]")
re4 (concat "[^a-zA-Z_]\\(" (mapconcat 'downcase words "[^a-zA-Z_\r\n]+") "\\)[^a-zA-Z_]")
re1 (concat pre re2 post)
(let ((m org-open-link-marker))
(catch 'exit
(while (apply 're-search-forward args)
- (goto-char (match-end group))
- (if (and (or (not (eq (marker-buffer m) (current-buffer)))
- (> (match-beginning 0) (marker-position m))
- (< (match-end 0) (marker-position m)))
- (save-match-data
- (or (not (org-in-regexp org-bracket-link-analytic-regexp 1))
- (not (match-end 4)) ; no description
- (and (<= (match-beginning 4) (point))
- (>= (match-end 4) (point))))))
- (throw 'exit (point)))))))
+ (unless (get-text-property (match-end group) 'intangible) ; Emacs 21
+ (goto-char (match-end group))
+ (if (and (or (not (eq (marker-buffer m) (current-buffer)))
+ (> (match-beginning 0) (marker-position m))
+ (< (match-end 0) (marker-position m)))
+ (save-match-data
+ (or (not (org-in-regexp
+ org-bracket-link-analytic-regexp 1))
+ (not (match-end 4)) ; no description
+ (and (<= (match-beginning 4) (point))
+ (>= (match-end 4) (point))))))
+ (throw 'exit (point))))))))
(defun org-get-buffer-for-internal-link (buffer)
"Return a buffer to be used for displaying the link target of internal links."
(setq beg (match-end 0))
(if (re-search-forward "^[ \t]*[0-9]+" nil t)
(setq end (1- (match-beginning 0)))))
- (and beg end (let ((buffer-read-only)) (delete-region beg end)))
+ (and beg end (let ((inhibit-read-only t)) (delete-region beg end)))
(goto-char (point-min))
(select-window cwin))))
(move-marker (car org-mark-ring)
(or pos (point))
(or buffer (current-buffer)))
- (message
+ (message "%s"
(substitute-command-keys
"Position saved to mark ring, go back with \\[org-mark-ring-goto].")))
(if (match-string 2 name) ; If there isn't a node, choose "Top"
(Info-find-node (match-string 1 name) (match-string 2 name))
(Info-find-node (match-string 1 name) "Top")))
- (message (concat "Could not open: " name))))
+ (message "Could not open: %s" name)))
(defun org-follow-gnus-link (&optional group article)
"Follow a Gnus link to GROUP and ARTICLE."
(funcall (cdr (assq 'gnus org-link-frame-setup)))
(if gnus-other-frame-object (select-frame gnus-other-frame-object))
(cond ((and group article)
- (gnus-group-read-group 0 nil group)
+ (gnus-group-read-group 1 nil group)
(gnus-summary-goto-article (string-to-number article) nil t))
(group (gnus-group-jump-to-group group))))
(string= mh-index-folder (substring folder 0 end-index)))
(if (equal major-mode 'mh-show-mode)
(save-window-excursion
- (when (buffer-live-p (get-buffer folder))
- (progn
- (pop-to-buffer folder)
- (org-mhe-get-message-folder-from-index)
- )
- ))
+ (let (pop-up-frames)
+ (when (buffer-live-p (get-buffer folder))
+ (progn
+ (pop-to-buffer folder)
+ (org-mhe-get-message-folder-from-index)
+ )
+ )))
(org-mhe-get-message-folder-from-index)
)
folder
(save-excursion
(mh-index-previous-folder)
(re-search-forward "^\\(+.*\\)$" nil t)
- (message (match-string 1))))
+ (message "%s" (match-string 1))))
(defun org-mhe-get-message-folder ()
"Return the name of the current message folder. Be careful if you
(mh-show-buffer-message-number))))
(defun org-mhe-get-header (header)
- "Return a header of the message in folder mode. This will create a
-show buffer for the corresponding message. If you have a more clever
+ "Return a header of the message in folder mode. This will create a
+show buffer for the corresponding message. If you have a more clever
idea..."
(let* ((folder (org-mhe-get-message-folder))
(num (org-mhe-get-message-num))
(if (stringp command)
(setq cmd command)
(setq cmd 'emacs))))
- (if (and (not (eq cmd 'emacs)) ; Emacs has not problems with non-ex files
+ (if (and (not (eq cmd 'emacs)) ; Emacs has no problems with non-ex files
(not (file-exists-p file))
(not org-open-non-existing-files))
(error "No such file: %s" file))
(cond
((and (stringp cmd) (not (string-match "^\\s-*$" cmd)))
;; Remove quotes around the file name - we'll use shell-quote-argument.
- (if (string-match "['\"]%s['\"]" cmd)
- (setq cmd (replace-match "%s" t t cmd)))
- (setq cmd (format cmd (shell-quote-argument file)))
+ (while (string-match "['\"]%s['\"]" cmd)
+ (setq cmd (replace-match "%s" t t cmd)))
+ (while (string-match "%s" cmd)
+ (setq cmd (replace-match
+ (save-match-data (shell-quote-argument file))
+ t t cmd)))
(save-window-excursion
- (shell-command (concat cmd " &"))))
+ (start-process-shell-command cmd nil cmd)))
((or (stringp cmd)
(eq cmd 'emacs))
(funcall (cdr (assq 'file org-link-frame-setup)) file)
+ (widen)
(if line (goto-line line)
(if search (org-link-search search))))
((consp cmd)
org-file-apps-defaults-windowsnt)
(t org-file-apps-defaults-gnu)))
-(defun org-expand-file-name (path)
- "Replace special path abbreviations and expand the file name."
- (expand-file-name path))
-
(defvar ange-ftp-name-format) ; to silence the XEmacs compiler.
(defun org-file-remote-p (file)
"Test whether FILE specifies a location on a remote system.
(t nil)))
-;;;; Hooks for remember.el
+;;;; Hooks for remember.el, and refiling
+
+(defvar annotation) ; from remember.el, dynamically scoped in `remember-mode'
+(defvar initial) ; from remember.el, dynamically scoped in `remember-mode'
+
+;;;###autoload
+(defun org-remember-insinuate ()
+ "Setup remember.el for use wiht Org-mode."
+ (require 'remember)
+ (setq remember-annotation-functions '(org-remember-annotation))
+ (setq remember-handler-functions '(org-remember-handler))
+ (add-hook 'remember-mode-hook 'org-remember-apply-template))
;;;###autoload
(defun org-remember-annotation ()
(defconst org-remember-help
"Select a destination location for the note.
UP/DOWN=headline TAB=cycle visibility [Q]uit RET/<left>/<right>=Store
-RET at beg-of-buf -> Append to file as level 2 headline
RET on headline -> Store as sublevel entry to current headline
+RET at beg-of-buf -> Append to file as level 2 headline
<left>/<right> -> before/after current headline, same headings level")
+(defvar org-remember-previous-location nil)
+(defvar org-force-remember-template-char) ;; dynamically scoped
+
+;; Save the major mode of the buffer we called remember from
+(defvar org-select-template-temp-major-mode nil)
+
+;; Temporary store the buffer where remember was called from
+(defvar org-select-template-original-buffer nil)
+
+(defun org-select-remember-template (&optional use-char)
+ (when org-remember-templates
+ (let* ((pre-selected-templates
+ (mapcar
+ (lambda (tpl)
+ (let ((ctxt (nth 5 tpl))
+ (mode org-select-template-temp-major-mode)
+ (buf org-select-template-original-buffer))
+ (and (or (not ctxt) (eq ctxt t)
+ (and (listp ctxt) (memq mode ctxt))
+ (and (functionp ctxt)
+ (with-current-buffer buf
+ ;; Protect the user-defined function from error
+ (condition-case nil (funcall ctxt) (error nil)))))
+ tpl)))
+ org-remember-templates))
+ ;; If no template at this point, add the default templates:
+ (pre-selected-templates1
+ (if (not (delq nil pre-selected-templates))
+ (mapcar (lambda(x) (if (not (nth 5 x)) x))
+ org-remember-templates)
+ pre-selected-templates))
+ ;; Then unconditionnally add template for any contexts
+ (pre-selected-templates2
+ (append (mapcar (lambda(x) (if (eq (nth 5 x) t) x))
+ org-remember-templates)
+ (delq nil pre-selected-templates1)))
+ (templates (mapcar (lambda (x)
+ (if (stringp (car x))
+ (append (list (nth 1 x) (car x)) (cddr x))
+ (append (list (car x) "") (cdr x))))
+ (delq nil pre-selected-templates2)))
+ (char (or use-char
+ (cond
+ ((= (length templates) 1)
+ (caar templates))
+ ((and (boundp 'org-force-remember-template-char)
+ org-force-remember-template-char)
+ (if (stringp org-force-remember-template-char)
+ (string-to-char org-force-remember-template-char)
+ org-force-remember-template-char))
+ (t
+ (message "Select template: %s"
+ (mapconcat
+ (lambda (x)
+ (cond
+ ((not (string-match "\\S-" (nth 1 x)))
+ (format "[%c]" (car x)))
+ ((equal (downcase (car x))
+ (downcase (aref (nth 1 x) 0)))
+ (format "[%c]%s" (car x)
+ (substring (nth 1 x) 1)))
+ (t (format "[%c]%s" (car x) (nth 1 x)))))
+ templates " "))
+ (let ((inhibit-quit t) (char0 (read-char-exclusive)))
+ (when (equal char0 ?\C-g)
+ (jump-to-register remember-register)
+ (kill-buffer remember-buffer))
+ char0))))))
+ (cddr (assoc char templates)))))
+
+(defvar x-last-selected-text)
+(defvar x-last-selected-text-primary)
+
;;;###autoload
(defun org-remember-apply-template (&optional use-char skip-interactive)
"Initialize *remember* buffer with template, invoke `org-mode'.
This function should be placed into `remember-mode-hook' and in fact requires
-to be run from that hook to fucntion properly."
+to be run from that hook to function properly."
(if org-remember-templates
-
- (let* ((char (or use-char
- (if (= (length org-remember-templates) 1)
- (caar org-remember-templates)
- (message "Select template: %s"
- (mapconcat
- (lambda (x) (char-to-string (car x)))
- org-remember-templates " "))
- (read-char-exclusive))))
- (entry (cdr (assoc char org-remember-templates)))
+ (let* ((entry (org-select-remember-template use-char))
(tpl (car entry))
(plist-p (if org-store-link-plist t nil))
(file (if (and (nth 1 entry) (stringp (nth 1 entry))
(nth 1 entry)
org-default-notes-file))
(headline (nth 2 entry))
+ (v-c (or (and (eq window-system 'x)
+ (fboundp 'x-cut-buffer-or-selection-value)
+ (x-cut-buffer-or-selection-value))
+ (org-bound-and-true-p x-last-selected-text)
+ (org-bound-and-true-p x-last-selected-text-primary)
+ (and (> (length kill-ring) 0) (current-kill 0))))
(v-t (format-time-string (car org-time-stamp-formats) (org-current-time)))
(v-T (format-time-string (cdr org-time-stamp-formats) (org-current-time)))
(v-u (concat "[" (substring v-t 1 -1) "]"))
(v-U (concat "[" (substring v-T 1 -1) "]"))
- (v-i initial) ; defined in `remember-mode'
- (v-a (if (equal annotation "[[]]") "" annotation)) ; likewise
+ ;; `initial' and `annotation' are bound in `remember'
+ (v-i (if (boundp 'initial) initial))
+ (v-a (if (and (boundp 'annotation) annotation)
+ (if (equal annotation "[[]]") "" annotation)
+ ""))
+ (v-A (if (and v-a
+ (string-match "\\[\\(\\[.*?\\]\\)\\(\\[.*?\\]\\)?\\]" v-a))
+ (replace-match "[\\1[%^{Link description}]]" nil nil v-a)
+ v-a))
(v-n user-full-name)
(org-startup-folded nil)
- org-time-was-given x prompt char time)
+ org-time-was-given org-end-time-was-given x
+ prompt completions char time pos default histvar)
(setq org-store-link-plist
- (append (list :annotation v-a :initial v-i)))
- (unless tpl (setq tpl "") (message "No template") (ding))
+ (append (list :annotation v-a :initial v-i)
+ org-store-link-plist))
+ (unless tpl (setq tpl "") (message "No template") (ding) (sit-for 1))
(erase-buffer)
(insert (substitute-command-keys
(format
- "## `C-c C-c' to file interactively, `C-u C-c C-c' to file directly.
-## Target file \"%s\", headline \"%s\"
-## To switch templates, use `\\[org-remember]'.\n\n"
+"## Filing location: Select interactively, default, or last used:
+## %s to select file and header location interactively.
+## %s \"%s\" -> \"* %s\"
+## C-u C-u C-c C-c \"%s\" -> \"* %s\"
+## To switch templates, use `\\[org-remember]'. To abort use `C-c C-k'.\n\n"
+ (if org-remember-store-without-prompt " C-u C-c C-c" " C-c C-c")
+ (if org-remember-store-without-prompt " C-c C-c" " C-u C-c C-c")
(abbreviate-file-name (or file org-default-notes-file))
- (or headline ""))))
+ (or headline "")
+ (or (car org-remember-previous-location) "???")
+ (or (cdr org-remember-previous-location) "???"))))
(insert tpl) (goto-char (point-min))
;; Simple %-escapes
- (while (re-search-forward "%\\([tTuUai]\\)" nil t)
+ (while (re-search-forward "%\\([tTuUaiAc]\\)" nil t)
(when (and initial (equal (match-string 0) "%i"))
(save-match-data
(let* ((lead (buffer-substring
(replace-match
(or (eval (intern (concat "v-" (match-string 1)))) "")
t t))
+
+ ;; %[] Insert contents of a file.
+ (goto-char (point-min))
+ (while (re-search-forward "%\\[\\(.+\\)\\]" nil t)
+ (let ((start (match-beginning 0))
+ (end (match-end 0))
+ (filename (expand-file-name (match-string 1))))
+ (goto-char start)
+ (delete-region start end)
+ (condition-case error
+ (insert-file-contents filename)
+ (error (insert (format "%%![Couldn't insert %s: %s]"
+ filename error))))))
+ ;; %() embedded elisp
+ (goto-char (point-min))
+ (while (re-search-forward "%\\((.+)\\)" nil t)
+ (goto-char (match-beginning 0))
+ (let ((template-start (point)))
+ (forward-char 1)
+ (let ((result
+ (condition-case error
+ (eval (read (current-buffer)))
+ (error (format "%%![Error: %s]" error)))))
+ (delete-region template-start (point))
+ (insert result))))
+
;; From the property list
(when plist-p
(goto-char (point-min))
(while (re-search-forward "%\\(:[-a-zA-Z]+\\)" nil t)
- (and (setq x (plist-get org-store-link-plist
- (intern (match-string 1))))
+ (and (setq x (or (plist-get org-store-link-plist
+ (intern (match-string 1))) ""))
(replace-match x t t))))
+
;; Turn on org-mode in the remember buffer, set local variables
(org-mode)
- (org-set-local 'org-finish-function 'remember-buffer)
+ (org-set-local 'org-finish-function 'org-remember-finalize)
(if (and file (string-match "\\S-" file) (not (file-directory-p file)))
(org-set-local 'org-default-notes-file file))
(if (and headline (stringp headline) (string-match "\\S-" headline))
(org-set-local 'org-remember-default-headline headline))
;; Interactive template entries
(goto-char (point-min))
- (while (re-search-forward "%^\\({\\([^}]*\\)}\\)?\\([uUtT]\\)?" nil t)
+ (while (re-search-forward "%^\\({\\([^}]*\\)}\\)?\\([gGuUtT]\\)?" nil t)
(setq char (if (match-end 3) (match-string 3))
prompt (if (match-end 2) (match-string 2)))
(goto-char (match-beginning 0))
(replace-match "")
- (if char
- (progn
- (setq org-time-was-given (equal (upcase char) char))
- (setq time (org-read-date (equal (upcase char) "U") t nil
- prompt))
- (org-insert-time-stamp time org-time-was-given
- (member char '("u" "U"))))
- (insert (read-string
- (if prompt (concat prompt ": ") "Enter string")))))
+ (setq completions nil default nil)
+ (when prompt
+ (setq completions (org-split-string prompt "|")
+ prompt (pop completions)
+ default (car completions)
+ histvar (intern (concat
+ "org-remember-template-prompt-history::"
+ (or prompt "")))
+ completions (mapcar 'list completions)))
+ (cond
+ ((member char '("G" "g"))
+ (let* ((org-last-tags-completion-table
+ (org-global-tags-completion-table
+ (if (equal char "G") (org-agenda-files) (and file (list file)))))
+ (org-add-colon-after-tag-completion t)
+ (ins (completing-read
+ (if prompt (concat prompt ": ") "Tags: ")
+ 'org-tags-completion-function nil nil nil
+ 'org-tags-history)))
+ (setq ins (mapconcat 'identity
+ (org-split-string ins (org-re "[^[:alnum:]_@]+"))
+ ":"))
+ (when (string-match "\\S-" ins)
+ (or (equal (char-before) ?:) (insert ":"))
+ (insert ins)
+ (or (equal (char-after) ?:) (insert ":")))))
+ (char
+ (setq org-time-was-given (equal (upcase char) char))
+ (setq time (org-read-date (equal (upcase char) "U") t nil
+ prompt))
+ (org-insert-time-stamp time org-time-was-given
+ (member char '("u" "U"))
+ nil nil (list org-end-time-was-given)))
+ (t
+ (insert (org-completing-read
+ (concat (if prompt prompt "Enter string")
+ (if default (concat " [" default "]"))
+ ": ")
+ completions nil nil nil histvar default)))))
(goto-char (point-min))
(if (re-search-forward "%\\?" nil t)
(replace-match "")
(and (re-search-forward "^[^#\n]" nil t) (backward-char 1))))
(org-mode)
- (org-set-local 'org-finish-function 'remember-buffer)))
+ (org-set-local 'org-finish-function 'org-remember-finalize))
+ (when (save-excursion
+ (goto-char (point-min))
+ (re-search-forward "%!" nil t))
+ (replace-match "")
+ (add-hook 'post-command-hook 'org-remember-finish-immediately 'append)))
+
+(defun org-remember-finish-immediately ()
+ "File remember note immediately.
+This should be run in `post-command-hook' and will remove itself
+from that hook."
+ (remove-hook 'post-command-hook 'org-remember-finish-immediately)
+ (when org-finish-function
+ (funcall org-finish-function)))
+
+(defvar org-clock-marker) ; Defined below
+(defun org-remember-finalize ()
+ "Finalize the remember process."
+ (unless (fboundp 'remember-finalize)
+ (defalias 'remember-finalize 'remember-buffer))
+ (when (and org-clock-marker
+ (equal (marker-buffer org-clock-marker) (current-buffer)))
+ ;; FIXME: test this, this is w/o notetaking!
+ (let (org-log-note-clock-out) (org-clock-out)))
+ (when buffer-file-name
+ (save-buffer)
+ (setq buffer-file-name nil))
+ (remember-finalize))
;;;###autoload
-(defun org-remember ()
+(defun org-remember (&optional goto org-force-remember-template-char)
"Call `remember'. If this is already a remember buffer, re-apply template.
If there is an active region, make sure remember uses it as initial content
-of the remember buffer."
+of the remember buffer.
+
+When called interactively with a `C-u' prefix argument GOTO, don't remember
+anything, just go to the file/headline where the selected template usually
+stores its notes. With a double prefix arg `C-u C-u', go to the last
+note stored by remember.
+
+Lisp programs can set ORG-FORCE-REMEMBER-TEMPLATE-CHAR to a character
+associated with a template in `org-remember-templates'."
+ (interactive "P")
+ (cond
+ ((equal goto '(4)) (org-go-to-remember-target))
+ ((equal goto '(16)) (org-remember-goto-last-stored))
+ (t
+ ;; set temporary variables that will be needed in
+ ;; `org-select-remember-template'
+ (setq org-select-template-temp-major-mode major-mode)
+ (setq org-select-template-original-buffer (current-buffer))
+ (if (memq org-finish-function '(remember-buffer remember-finalize))
+ (progn
+ (when (< (length org-remember-templates) 2)
+ (error "No other template available"))
+ (erase-buffer)
+ (let ((annotation (plist-get org-store-link-plist :annotation))
+ (initial (plist-get org-store-link-plist :initial)))
+ (org-remember-apply-template))
+ (message "Press C-c C-c to remember data"))
+ (if (org-region-active-p)
+ (remember (buffer-substring (point) (mark)))
+ (call-interactively 'remember))))))
+
+(defun org-remember-goto-last-stored ()
+ "Go to the location where the last remember note was stored."
(interactive)
- (if (eq org-finish-function 'remember-buffer)
- (progn
- (when (< (length org-remember-templates) 2)
- (error "No other template available"))
- (erase-buffer)
- (let ((annotation (plist-get org-store-link-plist :annotation))
- (initial (plist-get org-store-link-plist :initial)))
- (org-remember-apply-template))
- (message "Press C-c C-c to remember data"))
- (if (org-region-active-p)
- (remember (buffer-substring (point) (mark)))
- (call-interactively 'remember))))
+ (bookmark-jump "org-remember-last-stored")
+ (message "This is the last note stored by remember"))
-;;;###autoload
-(defun org-remember-handler ()
+(defun org-go-to-remember-target (&optional template-key)
+ "Go to the target location of a remember template.
+The user is queried for the template."
+ (interactive)
+ (let* (org-select-template-temp-major-mode
+ (entry (org-select-remember-template template-key))
+ (file (nth 1 entry))
+ (heading (nth 2 entry))
+ visiting)
+ (unless (and file (stringp file) (string-match "\\S-" file))
+ (setq file org-default-notes-file))
+ (unless (and heading (stringp heading) (string-match "\\S-" heading))
+ (setq heading org-remember-default-headline))
+ (setq visiting (org-find-base-buffer-visiting file))
+ (if (not visiting) (find-file-noselect file))
+ (switch-to-buffer (or visiting (get-file-buffer file)))
+ (widen)
+ (goto-char (point-min))
+ (if (re-search-forward
+ (concat "^\\*+[ \t]+" (regexp-quote heading)
+ (org-re "\\([ \t]+:[[:alnum:]@_:]*\\)?[ \t]*$"))
+ nil t)
+ (goto-char (match-beginning 0))
+ (error "Target headline not found: %s" heading))))
+
+(defvar org-note-abort nil) ; dynamically scoped
+
+;;;###autoload
+(defun org-remember-handler ()
"Store stuff from remember.el into an org file.
First prompts for an org file. If the user just presses return, the value
of `org-default-notes-file' is used.
Key Cursor position Note gets inserted
-----------------------------------------------------------------------------
-RET buffer-start as level 2 heading at end of file
+RET buffer-start as level 1 heading at end of file
RET on headline as sublevel of the heading at cursor
RET no heading at cursor position, level taken from context.
Or use prefix arg to specify level manually.
So the fastest way to store the note is to press RET RET to append it to
the default file. This way your current train of thought is not
-interrupted, in accordance with the principles of remember.el. But with
-little extra effort, you can push it directly to the correct location.
+interrupted, in accordance with the principles of remember.el.
+You can also get the fast execution without prompting by using
+C-u C-c C-c to exit the remember buffer. See also the variable
+`org-remember-store-without-prompt'.
Before being stored away, the function ensures that the text has a
headline, i.e. a first line that starts with a \"*\". If not, a headline
(goto-char (point-min))
(while (looking-at "^[ \t]*\n\\|^##.*\n")
(replace-match ""))
+ (goto-char (point-max))
+ (beginning-of-line 1)
+ (while (looking-at "[ \t]*$\\|##.*")
+ (delete-region (1- (point)) (point-max))
+ (beginning-of-line 1))
(catch 'quit
+ (if org-note-abort (throw 'quit nil))
(let* ((txt (buffer-substring (point-min) (point-max)))
- (fastp current-prefix-arg)
- (file (if fastp org-default-notes-file (org-get-org-file)))
+ (fastp (org-xor (equal current-prefix-arg '(4))
+ org-remember-store-without-prompt))
+ (file (cond
+ (fastp org-default-notes-file)
+ ((and (eq org-remember-interactive-interface 'refile)
+ org-refile-targets)
+ org-default-notes-file)
+ ((not (and (equal current-prefix-arg '(16))
+ org-remember-previous-location))
+ (org-get-org-file))))
(heading org-remember-default-headline)
- (visiting (org-find-base-buffer-visiting file))
+ (visiting (and file (org-find-base-buffer-visiting file)))
(org-startup-folded nil)
(org-startup-align-all-tables nil)
(org-goto-start-pos 1)
- spos level indent reversed)
+ spos exitcmd level indent reversed)
+ (if (and (equal current-prefix-arg '(16)) org-remember-previous-location)
+ (setq file (car org-remember-previous-location)
+ heading (cdr org-remember-previous-location)
+ fastp t))
+ (setq current-prefix-arg nil)
+ (if (string-match "[ \t\n]+\\'" txt)
+ (setq txt (replace-match "" t t txt)))
;; Modify text so that it becomes a nice subtree which can be inserted
;; into an org tree.
(let* ((lines (split-string txt "\n"))
first)
(setq first (car lines) lines (cdr lines))
- (if (string-match "^\\*+" first)
+ (if (string-match "^\\*+ " first)
;; Is already a headline
(setq indent nil)
;; We need to add a headline: Use time and first buffer line
" (" (remember-buffer-desc) ")")
indent " "))
(if (and org-adapt-indentation indent)
- (setq lines (mapcar (lambda (x) (concat indent x)) lines)))
+ (setq lines (mapcar
+ (lambda (x)
+ (if (string-match "\\S-" x)
+ (concat indent x) x))
+ lines)))
(setq txt (concat first "\n"
(mapconcat 'identity lines "\n"))))
+ (if (string-match "\n[ \t]*\n[ \t\n]*\\'" txt)
+ (setq txt (replace-match "\n\n" t t txt))
+ (if (string-match "[ \t\n]*\\'" txt)
+ (setq txt (replace-match "\n" t t txt))))
+ ;; Put the modified text back into the remember buffer, for refile.
+ (erase-buffer)
+ (insert txt)
+ (goto-char (point-min))
+ (when (and (eq org-remember-interactive-interface 'refile)
+ (not fastp))
+ (org-refile nil (or visiting (find-file-noselect file)))
+ (throw 'quit t))
;; Find the file
(if (not visiting) (find-file-noselect file))
(with-current-buffer (or visiting (get-file-buffer file))
- (save-excursion (and (goto-char (point-min))
- (not (re-search-forward "^\\* " nil t))
- (insert "\n* Notes\n")))
- (setq reversed (org-notes-order-reversed-p))
+ (unless (org-mode-p)
+ (error "Target files for remember notes must be in Org-mode"))
(save-excursion
(save-restriction
(widen)
+ (and (goto-char (point-min))
+ (not (re-search-forward "^\\* " nil t))
+ (insert "\n* " (or heading "Notes") "\n"))
+ (setq reversed (org-notes-order-reversed-p))
;; Find the default location
(when (and heading (stringp heading) (string-match "\\S-" heading))
(goto-char (point-min))
(if (re-search-forward
(concat "^\\*+[ \t]+" (regexp-quote heading)
- "\\([ \t]+:[@a-zA-Z0-9_:]*\\)?[ \t]*$")
+ (org-re "\\([ \t]+:[[:alnum:]@_:]*\\)?[ \t]*$"))
nil t)
- (setq org-goto-start-pos (match-beginning 0))))
+ (setq org-goto-start-pos (match-beginning 0))
+ (when fastp
+ (goto-char (point-max))
+ (unless (bolp) (newline))
+ (insert "* " heading "\n")
+ (setq org-goto-start-pos (point-at-bol 0)))))
- ;; Ask the User for a location
- (setq spos (if fastp
- org-goto-start-pos
- (org-get-location (current-buffer) org-remember-help)))
+ ;; Ask the User for a location, using the appropriate interface
+ (cond
+ (fastp (setq spos org-goto-start-pos
+ exitcmd 'return))
+ ((eq org-remember-interactive-interface 'outline)
+ (setq spos (org-get-location (current-buffer)
+ org-remember-help)
+ exitcmd (cdr spos)
+ spos (car spos)))
+ ((eq org-remember-interactive-interface 'outline-path-completion)
+ (let ((org-refile-targets '((nil . (:maxlevel . 10))))
+ (org-refile-use-outline-path t))
+ (setq spos (org-refile-get-location "Heading: ")
+ exitcmd 'return
+ spos (nth 3 spos))))
+ (t (error "this should not hapen")))
(if (not spos) (throw 'quit nil)) ; return nil to show we did
- ; not handle this note
+ ; not handle this note
(goto-char spos)
- (cond ((and (bobp) (not reversed))
+ (cond ((org-on-heading-p t)
+ (org-back-to-heading t)
+ (setq level (funcall outline-level))
+ (cond
+ ((eq exitcmd 'return)
+ ;; sublevel of current
+ (setq org-remember-previous-location
+ (cons (abbreviate-file-name file)
+ (org-get-heading 'notags)))
+ (if reversed
+ (outline-next-heading)
+ (org-end-of-subtree t)
+ (if (not (bolp))
+ (if (looking-at "[ \t]*\n")
+ (beginning-of-line 2)
+ (end-of-line 1)
+ (insert "\n"))))
+ (bookmark-set "org-remember-last-stored")
+ (org-paste-subtree (org-get-valid-level level 1) txt))
+ ((eq exitcmd 'left)
+ ;; before current
+ (bookmark-set "org-remember-last-stored")
+ (org-paste-subtree level txt))
+ ((eq exitcmd 'right)
+ ;; after current
+ (org-end-of-subtree t)
+ (bookmark-set "org-remember-last-stored")
+ (org-paste-subtree level txt))
+ (t (error "This should not happen"))))
+
+ ((and (bobp) (not reversed))
;; Put it at the end, one level below level 1
(save-restriction
(widen)
(goto-char (point-max))
(if (not (bolp)) (newline))
- (org-paste-subtree (org-get-legal-level 1 1) txt)))
+ (bookmark-set "org-remember-last-stored")
+ (org-paste-subtree (org-get-valid-level 1 1) txt)))
+
((and (bobp) reversed)
;; Put it at the start, as level 1
(save-restriction
(widen)
(goto-char (point-min))
- (re-search-forward "^\\*" nil t)
+ (re-search-forward "^\\*+ " nil t)
(beginning-of-line 1)
+ (bookmark-set "org-remember-last-stored")
(org-paste-subtree 1 txt)))
- ((and (org-on-heading-p nil) (not current-prefix-arg))
- ;; Put it below this entry, at the beg/end of the subtree
- (org-back-to-heading t)
- (setq level (funcall outline-level))
- (if reversed
- (outline-end-of-heading)
- (org-end-of-subtree t))
- (if (not (bolp)) (newline))
- (beginning-of-line 1)
- (org-paste-subtree (org-get-legal-level level 1) txt))
(t
;; Put it right there, with automatic level determined by
;; org-paste-subtree or from prefix arg
- (org-paste-subtree current-prefix-arg txt)))
+ (bookmark-set "org-remember-last-stored")
+ (org-paste-subtree
+ (if (numberp current-prefix-arg) current-prefix-arg)
+ txt)))
(when remember-save-after-remembering
(save-buffer)
(if (not visiting) (kill-buffer (current-buffer)))))))))
+
t) ;; return t to indicate that we took care of this note.
(defun org-get-org-file ()
(throw 'exit (cdr entry))))
nil)))))
+;;; Refiling
+
+(defvar org-refile-target-table nil
+ "The list of refile targets, created by `org-refile'.")
+
+(defvar org-agenda-new-buffers nil
+ "Buffers created to visit agenda files.")
+
+(defun org-get-refile-targets (&optional default-buffer)
+ "Produce a table with refile targets."
+ (let ((entries (or org-refile-targets '((nil . (:level . 1)))))
+ targets txt re files f desc descre)
+ (with-current-buffer (or default-buffer (current-buffer))
+ (while (setq entry (pop entries))
+ (setq files (car entry) desc (cdr entry))
+ (cond
+ ((null files) (setq files (list (current-buffer))))
+ ((eq files 'org-agenda-files)
+ (setq files (org-agenda-files 'unrestricted)))
+ ((and (symbolp files) (fboundp files))
+ (setq files (funcall files)))
+ ((and (symbolp files) (boundp files))
+ (setq files (symbol-value files))))
+ (if (stringp files) (setq files (list files)))
+ (cond
+ ((eq (car desc) :tag)
+ (setq descre (concat "^\\*+[ \t]+.*?:" (regexp-quote (cdr desc)) ":")))
+ ((eq (car desc) :todo)
+ (setq descre (concat "^\\*+[ \t]+" (regexp-quote (cdr desc)) "[ \t]")))
+ ((eq (car desc) :regexp)
+ (setq descre (cdr desc)))
+ ((eq (car desc) :level)
+ (setq descre (concat "^\\*\\{" (number-to-string
+ (if org-odd-levels-only
+ (1- (* 2 (cdr desc)))
+ (cdr desc)))
+ "\\}[ \t]")))
+ ((eq (car desc) :maxlevel)
+ (setq descre (concat "^\\*\\{1," (number-to-string
+ (if org-odd-levels-only
+ (1- (* 2 (cdr desc)))
+ (cdr desc)))
+ "\\}[ \t]")))
+ (t (error "Bad refiling target description %s" desc)))
+ (while (setq f (pop files))
+ (save-excursion
+ (set-buffer (if (bufferp f) f (org-get-agenda-file-buffer f)))
+ (if (bufferp f) (setq f (buffer-file-name (buffer-base-buffer f))))
+ (save-excursion
+ (save-restriction
+ (widen)
+ (goto-char (point-min))
+ (while (re-search-forward descre nil t)
+ (goto-char (point-at-bol))
+ (when (looking-at org-complex-heading-regexp)
+ (setq txt (match-string 4)
+ re (concat "^" (regexp-quote
+ (buffer-substring (match-beginning 1)
+ (match-end 4)))))
+ (if (match-end 5) (setq re (concat re "[ \t]+"
+ (regexp-quote
+ (match-string 5)))))
+ (setq re (concat re "[ \t]*$"))
+ (when org-refile-use-outline-path
+ (setq txt (mapconcat 'identity
+ (append
+ (if (eq org-refile-use-outline-path 'file)
+ (list (file-name-nondirectory
+ (buffer-file-name (buffer-base-buffer))))
+ (if (eq org-refile-use-outline-path 'full-file-path)
+ (list (buffer-file-name (buffer-base-buffer)))))
+ (org-get-outline-path)
+ (list txt))
+ "/")))
+ (push (list txt f re (point)) targets))
+ (goto-char (point-at-eol))))))))
+ (nreverse targets))))
+
+(defun org-get-outline-path ()
+ "Return the outline path to the current entry, as a list."
+ (let (rtn)
+ (save-excursion
+ (while (org-up-heading-safe)
+ (when (looking-at org-complex-heading-regexp)
+ (push (org-match-string-no-properties 4) rtn)))
+ rtn)))
+
+(defvar org-refile-history nil
+ "History for refiling operations.")
+
+(defun org-refile (&optional goto default-buffer)
+ "Move the entry at point to another heading.
+The list of target headings is compiled using the information in
+`org-refile-targets', which see. This list is created upon first use, and
+you can update it by calling this command with a double prefix (`C-u C-u').
+FIXME: Can we find a better way of updating?
+
+At the target location, the entry is filed as a subitem of the target heading.
+Depending on `org-reverse-note-order', the new subitem will either be the
+first of the last subitem.
+
+With prefix arg GOTO, the command will only visit the target location,
+not actually move anything.
+With a double prefix `C-c C-c', go to the location where the last refiling
+operation has put the subtree.
+
+With a double prefix argument, the command can be used to jump to any
+heading in the current buffer."
+ (interactive "P")
+ (let* ((cbuf (current-buffer))
+ (filename (buffer-file-name (buffer-base-buffer cbuf)))
+ pos it nbuf file re level reversed)
+ (if (equal goto '(16))
+ (org-refile-goto-last-stored)
+ (when (setq it (org-refile-get-location
+ (if goto "Goto: " "Refile to: ") default-buffer))
+ (setq file (nth 1 it)
+ re (nth 2 it)
+ pos (nth 3 it))
+ (setq nbuf (or (find-buffer-visiting file)
+ (find-file-noselect file)))
+ (if goto
+ (progn
+ (switch-to-buffer nbuf)
+ (goto-char pos)
+ (org-show-context 'org-goto))
+ (org-copy-special)
+ (save-excursion
+ (set-buffer (setq nbuf (or (find-buffer-visiting file)
+ (find-file-noselect file))))
+ (setq reversed (org-notes-order-reversed-p))
+ (save-excursion
+ (save-restriction
+ (widen)
+ (goto-char pos)
+ (looking-at outline-regexp)
+ (setq level (org-get-valid-level (funcall outline-level) 1))
+ (goto-char
+ (if reversed
+ (outline-next-heading)
+ (or (save-excursion (outline-get-next-sibling))
+ (org-end-of-subtree t t)
+ (point-max))))
+ (bookmark-set "org-refile-last-stored")
+ (org-paste-subtree level))))
+ (org-cut-special)
+ (message "Entry refiled to \"%s\"" (car it)))))))
+
+(defun org-refile-goto-last-stored ()
+ "Go to the location where the last refile was stored."
+ (interactive)
+ (bookmark-jump "org-refile-last-stored")
+ (message "This is the location of the last refile"))
+
+(defun org-refile-get-location (&optional prompt default-buffer)
+ "Prompt the user for a refile location, using PROMPT."
+ (let ((org-refile-targets org-refile-targets)
+ (org-refile-use-outline-path org-refile-use-outline-path))
+ (setq org-refile-target-table (org-get-refile-targets default-buffer)))
+ (unless org-refile-target-table
+ (error "No refile targets"))
+ (let* ((cbuf (current-buffer))
+ (filename (buffer-file-name (buffer-base-buffer cbuf)))
+ (fname (and filename (file-truename filename)))
+ (tbl (mapcar
+ (lambda (x)
+ (if (not (equal fname (file-truename (nth 1 x))))
+ (cons (concat (car x) " (" (file-name-nondirectory
+ (nth 1 x)) ")")
+ (cdr x))
+ x))
+ org-refile-target-table))
+ (completion-ignore-case t))
+ (assoc (completing-read prompt tbl nil t nil 'org-refile-history)
+ tbl)))
+
;;;; Dynamic blocks
(defun org-find-dblock (name)
(unless (looking-at org-dblock-start-re)
(error "Not at a dynamic block"))
(let* ((begdel (1+ (match-end 0)))
- (name (match-string 1))
+ (name (org-no-properties (match-string 1)))
(params (append (list :name name)
(read (concat "(" (match-string 3) ")")))))
(unless (re-search-forward org-dblock-end-re nil t)
(error "Dynamic block not terminated"))
+ (setq params
+ (append params
+ (list :content (buffer-substring
+ begdel (match-beginning 0)))))
(delete-region begdel (match-beginning 0))
(goto-char begdel)
(open-line 1)
"Update the dynamic block at point
This means to empty the block, parse for parameters and then call
the correct writing function."
- (let* ((pos (point))
- (params (org-prepare-dblock))
- (name (plist-get params :name))
- (cmd (intern (concat "org-dblock-write:" name))))
- (funcall cmd params)
- (goto-char pos)))
+ (save-window-excursion
+ (let* ((pos (point))
+ (line (org-current-line))
+ (params (org-prepare-dblock))
+ (name (plist-get params :name))
+ (cmd (intern (concat "org-dblock-write:" name))))
+ (message "Updating dynamic block `%s' at line %d..." name line)
+ (funcall cmd params)
+ (message "Updating dynamic block `%s' at line %d...done" name line)
+ (goto-char pos))))
(defun org-beginning-of-dblock ()
"Find the beginning of the dynamic block at point.
;;;; Completion
+(defconst org-additional-option-like-keywords
+ '("BEGIN_HTML" "BEGIN_LaTeX" "END_HTML" "END_LaTeX"
+ "ORGTBL" "HTML:" "LaTeX:" "BEGIN:" "END:" "DATE:" "TBLFM"
+ "BEGIN_EXAMPLE" "END_EXAMPLE"))
+
(defun org-complete (&optional arg)
"Perform completion on word at point.
At the beginning of a headline, this completes TODO keywords as given in
If the current word is preceded by \"#+\", completes special words for
setting file options.
In the line after \"#+STARTUP:, complete valid keywords.\"
-At all other locations, this simply calls `ispell-complete-word'."
+At all other locations, this simply calls the value of
+`org-completion-fallback-command'."
(interactive "P")
- (catch 'exit
- (let* ((end (point))
- (beg1 (save-excursion
- (skip-chars-backward "a-zA-Z_@0-9")
+ (org-without-partial-completion
+ (catch 'exit
+ (let* ((end (point))
+ (beg1 (save-excursion
+ (skip-chars-backward (org-re "[:alnum:]_@"))
+ (point)))
+ (beg (save-excursion
+ (skip-chars-backward "a-zA-Z0-9_:$")
(point)))
- (beg (save-excursion
- (skip-chars-backward "a-zA-Z0-9_:$")
- (point)))
- (confirm (lambda (x) (stringp (car x))))
- (searchhead (equal (char-before beg) ?*))
- (tag (equal (char-before beg1) ?:))
- (texp (equal (char-before beg) ?\\))
- (link (equal (char-before beg) ?\[))
- (opt (equal (buffer-substring (max (point-at-bol) (- beg 2))
- beg)
- "#+"))
- (startup (string-match "^#\\+STARTUP:.*"
- (buffer-substring (point-at-bol) (point))))
- (completion-ignore-case opt)
- (type nil)
- (tbl nil)
- (table (cond
- (opt
- (setq type :opt)
- (mapcar (lambda (x)
- (string-match "^#\\+\\(\\([A-Z_]+:?\\).*\\)" x)
- (cons (match-string 2 x) (match-string 1 x)))
- (org-split-string (org-get-current-options) "\n")))
- (startup
- (setq type :startup)
- org-startup-options)
- (link (append org-link-abbrev-alist-local
- org-link-abbrev-alist))
- (texp
- (setq type :tex)
- org-html-entities)
- ((string-match "\\`\\*+[ \t]*\\'"
- (buffer-substring (point-at-bol) beg))
- (setq type :todo)
- (mapcar 'list org-todo-keywords))
- (searchhead
- (setq type :searchhead)
- (save-excursion
- (goto-char (point-min))
- (while (re-search-forward org-todo-line-regexp nil t)
- (push (list
- (org-make-org-heading-search-string
- (match-string 3) t))
- tbl)))
- tbl)
- (tag (setq type :tag beg beg1)
- (or org-tag-alist (org-get-buffer-tags)))
- (t (progn (ispell-complete-word arg) (throw 'exit nil)))))
- (pattern (buffer-substring-no-properties beg end))
- (completion (try-completion pattern table confirm)))
- (cond ((eq completion t)
- (if (equal type :opt)
- (insert (substring (cdr (assoc (upcase pattern) table))
- (length pattern)))
- (if (equal type :tag) (insert ":"))))
- ((null completion)
- (message "Can't find completion for \"%s\"" pattern)
- (ding))
- ((not (string= pattern completion))
- (delete-region beg end)
- (if (string-match " +$" completion)
- (setq completion (replace-match "" t t completion)))
- (insert completion)
- (if (get-buffer-window "*Completions*")
- (delete-window (get-buffer-window "*Completions*")))
- (if (assoc completion table)
- (if (eq type :todo) (insert " ")
- (if (eq type :tag) (insert ":"))))
- (if (and (equal type :opt) (assoc completion table))
- (message "%s" (substitute-command-keys
- "Press \\[org-complete] again to insert example settings"))))
- (t
- (message "Making completion list...")
- (let ((list (sort (all-completions pattern table confirm)
- 'string<)))
- (with-output-to-temp-buffer "*Completions*"
- (condition-case nil
- ;; Protection needed for XEmacs and emacs 21
- (display-completion-list list pattern)
- (error (display-completion-list list)))))
- (message "Making completion list...%s" "done"))))))
+ (confirm (lambda (x) (stringp (car x))))
+ (searchhead (equal (char-before beg) ?*))
+ (tag (and (equal (char-before beg1) ?:)
+ (equal (char-after (point-at-bol)) ?*)))
+ (prop (and (equal (char-before beg1) ?:)
+ (not (equal (char-after (point-at-bol)) ?*))))
+ (texp (equal (char-before beg) ?\\))
+ (link (equal (char-before beg) ?\[))
+ (opt (equal (buffer-substring (max (point-at-bol) (- beg 2))
+ beg)
+ "#+"))
+ (startup (string-match "^#\\+STARTUP:.*"
+ (buffer-substring (point-at-bol) (point))))
+ (completion-ignore-case opt)
+ (type nil)
+ (tbl nil)
+ (table (cond
+ (opt
+ (setq type :opt)
+ (append
+ (mapcar
+ (lambda (x)
+ (string-match "^#\\+\\(\\([A-Z_]+:?\\).*\\)" x)
+ (cons (match-string 2 x) (match-string 1 x)))
+ (org-split-string (org-get-current-options) "\n"))
+ (mapcar 'list org-additional-option-like-keywords)))
+ (startup
+ (setq type :startup)
+ org-startup-options)
+ (link (append org-link-abbrev-alist-local
+ org-link-abbrev-alist))
+ (texp
+ (setq type :tex)
+ org-html-entities)
+ ((string-match "\\`\\*+[ \t]+\\'"
+ (buffer-substring (point-at-bol) beg))
+ (setq type :todo)
+ (mapcar 'list org-todo-keywords-1))
+ (searchhead
+ (setq type :searchhead)
+ (save-excursion
+ (goto-char (point-min))
+ (while (re-search-forward org-todo-line-regexp nil t)
+ (push (list
+ (org-make-org-heading-search-string
+ (match-string 3) t))
+ tbl)))
+ tbl)
+ (tag (setq type :tag beg beg1)
+ (or org-tag-alist (org-get-buffer-tags)))
+ (prop (setq type :prop beg beg1)
+ (mapcar 'list (org-buffer-property-keys nil t t)))
+ (t (progn
+ (call-interactively org-completion-fallback-command)
+ (throw 'exit nil)))))
+ (pattern (buffer-substring-no-properties beg end))
+ (completion (try-completion pattern table confirm)))
+ (cond ((eq completion t)
+ (if (not (assoc (upcase pattern) table))
+ (message "Already complete")
+ (if (equal type :opt)
+ (insert (substring (cdr (assoc (upcase pattern) table))
+ (length pattern)))
+ (if (memq type '(:tag :prop)) (insert ":")))))
+ ((null completion)
+ (message "Can't find completion for \"%s\"" pattern)
+ (ding))
+ ((not (string= pattern completion))
+ (delete-region beg end)
+ (if (string-match " +$" completion)
+ (setq completion (replace-match "" t t completion)))
+ (insert completion)
+ (if (get-buffer-window "*Completions*")
+ (delete-window (get-buffer-window "*Completions*")))
+ (if (assoc completion table)
+ (if (eq type :todo) (insert " ")
+ (if (memq type '(:tag :prop)) (insert ":"))))
+ (if (and (equal type :opt) (assoc completion table))
+ (message "%s" (substitute-command-keys
+ "Press \\[org-complete] again to insert example settings"))))
+ (t
+ (message "Making completion list...")
+ (let ((list (sort (all-completions pattern table confirm)
+ 'string<)))
+ (with-output-to-temp-buffer "*Completions*"
+ (condition-case nil
+ ;; Protection needed for XEmacs and emacs 21
+ (display-completion-list list pattern)
+ (error (display-completion-list list)))))
+ (message "Making completion list...%s" "done")))))))
;;;; TODO, DEADLINE, Comments
(interactive)
(save-excursion
(org-back-to-heading)
- (if (looking-at (concat outline-regexp
- "\\( +\\<" org-comment-string "\\>\\)"))
- (replace-match "" t t nil 1)
- (if (looking-at outline-regexp)
- (progn
- (goto-char (match-end 0))
- (insert " " org-comment-string))))))
+ (let (case-fold-search)
+ (if (looking-at (concat outline-regexp
+ "\\( *\\<" org-comment-string "\\>[ \t]*\\)"))
+ (replace-match "" t t nil 1)
+ (if (looking-at outline-regexp)
+ (progn
+ (goto-char (match-end 0))
+ (insert org-comment-string " ")))))))
(defvar org-last-todo-state-is-todo nil
"This is non-nil when the last TODO state change led to a TODO state.
If the last change removed the TODO tag or switched to DONE, then
this is nil.")
+(defvar org-setting-tags nil) ; dynamically skiped
+
+;; FIXME: better place
+(defun org-property-or-variable-value (var &optional inherit)
+ "Check if there is a property fixing the value of VAR.
+If yes, return this value. If not, return the current value of the variable."
+ (let ((prop (org-entry-get nil (symbol-name var) inherit)))
+ (if (and prop (stringp prop) (string-match "\\S-" prop))
+ (read prop)
+ (symbol-value var))))
+
+(defun org-parse-local-options (string var)
+ "Parse STRING for startup setting relevant for variable VAR."
+ (let ((rtn (symbol-value var))
+ e opts)
+ (save-match-data
+ (if (or (not string) (not (string-match "\\S-" string)))
+ rtn
+ (setq opts (delq nil (mapcar (lambda (x)
+ (setq e (assoc x org-startup-options))
+ (if (eq (nth 1 e) var) e nil))
+ (org-split-string string "[ \t]+"))))
+ (if (not opts)
+ rtn
+ (setq rtn nil)
+ (while (setq e (pop opts))
+ (if (not (nth 3 e))
+ (setq rtn (nth 2 e))
+ (if (not (listp rtn)) (setq rtn nil))
+ (push (nth 2 e) rtn)))
+ rtn)))))
+
+(defvar org-blocker-hook nil
+ "Hook for functions that are allowed to block a state change.
+
+Each function gets as its single argument a property list, see
+`org-trigger-hook' for more information about this list.
+
+If any of the functions in this hook returns nil, the state change
+is blocked.")
+
+(defvar org-trigger-hook nil
+ "Hook for functions that are triggered by a state change.
+
+Each function gets as its single argument a property list with at least
+the following elements:
+
+ (:type type-of-change :position pos-at-entry-start
+ :from old-state :to new-state)
+
+Depending on the type, more properties may be present.
+
+This mechanism is currently implemented for:
+
+TODO state changes
+------------------
+:type todo-state-change
+:from previous state (keyword as a string), or nil
+:to new state (keyword as a string), or nil")
+
+
(defun org-todo (&optional arg)
"Change the TODO state of an item.
The state of an item is given by a keyword at the start of the heading,
'none -> empty state
\"\"(empty string) -> switch to empty state
'done -> switch to DONE
+'nextset -> switch to the next set of keywords
+'previousset -> switch to the previous set of keywords
\"WAITING\" -> switch to the specified keyword, but only if it
really is a member of `org-todo-keywords'."
(interactive "P")
(save-excursion
- (org-back-to-heading)
- (if (looking-at outline-regexp) (goto-char (match-end 0)))
- (or (looking-at (concat " +" org-todo-regexp " *"))
- (looking-at " *"))
- (let* ((this (match-string 1))
- (last-state (or this ""))
- (completion-ignore-case t)
- (member (member this org-todo-keywords))
- (tail (cdr member))
- (state (cond
- ((equal arg '(4))
- ;; Read a state with completion
- (completing-read "State: " (mapcar (lambda(x) (list x))
- org-todo-keywords)
- nil t))
- ((eq arg 'right)
- (if this
- (if tail (car tail) nil)
- (car org-todo-keywords)))
- ((eq arg 'left)
- (if (equal member org-todo-keywords)
- nil
+ (catch 'exit
+ (org-back-to-heading)
+ (if (looking-at outline-regexp) (goto-char (1- (match-end 0))))
+ (or (looking-at (concat " +" org-todo-regexp " *"))
+ (looking-at " *"))
+ (let* ((match-data (match-data))
+ (startpos (point-at-bol))
+ (logging (save-match-data (org-entry-get nil "LOGGING" t)))
+ (org-log-done org-log-done)
+ (org-log-repeat org-log-repeat)
+ (org-todo-log-states org-todo-log-states)
+ (this (match-string 1))
+ (hl-pos (match-beginning 0))
+ (head (org-get-todo-sequence-head this))
+ (ass (assoc head org-todo-kwd-alist))
+ (interpret (nth 1 ass))
+ (done-word (nth 3 ass))
+ (final-done-word (nth 4 ass))
+ (last-state (or this ""))
+ (completion-ignore-case t)
+ (member (member this org-todo-keywords-1))
+ (tail (cdr member))
+ (state (cond
+ ((and org-todo-key-trigger
+ (or (and (equal arg '(4)) (eq org-use-fast-todo-selection 'prefix))
+ (and (not arg) org-use-fast-todo-selection
+ (not (eq org-use-fast-todo-selection 'prefix)))))
+ ;; Use fast selection
+ (org-fast-todo-selection))
+ ((and (equal arg '(4))
+ (or (not org-use-fast-todo-selection)
+ (not org-todo-key-trigger)))
+ ;; Read a state with completion
+ (completing-read "State: " (mapcar (lambda(x) (list x))
+ org-todo-keywords-1)
+ nil t))
+ ((eq arg 'right)
(if this
- (nth (- (length org-todo-keywords) (length tail) 2)
- org-todo-keywords)
- org-done-string)))
- (arg
- ;; user requests a specific state
- (cond
- ((equal arg "") nil)
- ((eq arg 'none) nil)
- ((eq arg 'done) (org-last org-todo-keywords))
- ((car (member arg org-todo-keywords)))
- ((nth (1- (prefix-numeric-value arg))
- org-todo-keywords))))
- ((null member) (car org-todo-keywords))
- ((null tail) nil) ;; -> first entry
- ((eq org-todo-interpretation 'sequence)
- (car tail))
- ((memq org-todo-interpretation '(type priority))
- (if (eq this-command last-command)
- (car tail)
- (if (> (length tail) 0) org-done-string nil)))
- (t nil)))
- (next (if state (concat " " state " ") " "))
- dostates)
- (replace-match next t t)
- (setq org-last-todo-state-is-todo
- (not (equal state org-done-string)))
- (when org-log-done
- (setq dostates (and (eq org-todo-interpretation 'sequence)
- (listp org-log-done) (memq 'state org-log-done)))
+ (if tail (car tail) nil)
+ (car org-todo-keywords-1)))
+ ((eq arg 'left)
+ (if (equal member org-todo-keywords-1)
+ nil
+ (if this
+ (nth (- (length org-todo-keywords-1) (length tail) 2)
+ org-todo-keywords-1)
+ (org-last org-todo-keywords-1))))
+ ((and (eq org-use-fast-todo-selection t) (equal arg '(4))
+ (setq arg nil))) ; hack to fall back to cycling
+ (arg
+ ;; user or caller requests a specific state
+ (cond
+ ((equal arg "") nil)
+ ((eq arg 'none) nil)
+ ((eq arg 'done) (or done-word (car org-done-keywords)))
+ ((eq arg 'nextset)
+ (or (car (cdr (member head org-todo-heads)))
+ (car org-todo-heads)))
+ ((eq arg 'previousset)
+ (let ((org-todo-heads (reverse org-todo-heads)))
+ (or (car (cdr (member head org-todo-heads)))
+ (car org-todo-heads))))
+ ((car (member arg org-todo-keywords-1)))
+ ((nth (1- (prefix-numeric-value arg))
+ org-todo-keywords-1))))
+ ((null member) (or head (car org-todo-keywords-1)))
+ ((equal this final-done-word) nil) ;; -> make empty
+ ((null tail) nil) ;; -> first entry
+ ((eq interpret 'sequence)
+ (car tail))
+ ((memq interpret '(type priority))
+ (if (eq this-command last-command)
+ (car tail)
+ (if (> (length tail) 0)
+ (or done-word (car org-done-keywords))
+ nil)))
+ (t nil)))
+ (next (if state (concat " " state " ") " "))
+ (change-plist (list :type 'todo-state-change :from this :to state
+ :position startpos))
+ dolog now-done-p)
+ (when org-blocker-hook
+ (unless (save-excursion
+ (save-match-data
+ (run-hook-with-args-until-failure
+ 'org-blocker-hook change-plist)))
+ (if (interactive-p)
+ (error "TODO state change from %s to %s blocked" this state)
+ ;; fail silently
+ (message "TODO state change from %s to %s blocked" this state)
+ (throw 'exit nil))))
+ (store-match-data match-data)
+ (replace-match next t t)
+ (unless (pos-visible-in-window-p hl-pos)
+ (message "TODO state changed to %s" (org-trim next)))
+ (unless head
+ (setq head (org-get-todo-sequence-head state)
+ ass (assoc head org-todo-kwd-alist)
+ interpret (nth 1 ass)
+ done-word (nth 3 ass)
+ final-done-word (nth 4 ass)))
+ (when (memq arg '(nextset previousset))
+ (message "Keyword-Set %d/%d: %s"
+ (- (length org-todo-sets) -1
+ (length (memq (assoc state org-todo-sets) org-todo-sets)))
+ (length org-todo-sets)
+ (mapconcat 'identity (assoc state org-todo-sets) " ")))
+ (setq org-last-todo-state-is-todo
+ (not (member state org-done-keywords)))
+ (setq now-done-p (and (member state org-done-keywords)
+ (not (member this org-done-keywords))))
+ (and logging (org-local-logging logging))
+ (when (and (or org-todo-log-states org-log-done)
+ (not (memq arg '(nextset previousset))))
+ ;; we need to look at recording a time and note
+ (setq dolog (or (nth 1 (assoc state org-todo-log-states))
+ (nth 2 (assoc this org-todo-log-states))))
+ (when (and state
+ (member state org-not-done-keywords)
+ (not (member this org-not-done-keywords)))
+ ;; This is now a todo state and was not one before
+ ;; If there was a CLOSED time stamp, get rid of it.
+ (org-add-planning-info nil nil 'closed))
+ (when (and now-done-p org-log-done)
+ ;; It is now done, and it was not done before
+ (org-add-planning-info 'closed (org-current-time))
+ (if (and (not dolog) (eq 'note org-log-done))
+ (org-add-log-maybe 'done state 'findpos 'note)))
+ (when (and state dolog)
+ ;; This is a non-nil state, and we need to log it
+ (org-add-log-maybe 'state state 'findpos dolog)))
+ ;; Fixup tag positioning
+ (and org-auto-align-tags (not org-setting-tags) (org-set-tags nil t))
+ (run-hooks 'org-after-todo-state-change-hook)
+ (if (and arg (not (member state org-done-keywords)))
+ (setq head (org-get-todo-sequence-head state)))
+ (put-text-property (point-at-bol) (point-at-eol) 'org-todo-head head)
+ ;; Do we need to trigger a repeat?
+ (when now-done-p (org-auto-repeat-maybe state))
+ ;; Fixup cursor location if close to the keyword
+ (if (and (outline-on-heading-p)
+ (not (bolp))
+ (save-excursion (beginning-of-line 1)
+ (looking-at org-todo-line-regexp))
+ (< (point) (+ 2 (or (match-end 2) (match-end 1)))))
+ (progn
+ (goto-char (or (match-end 2) (match-end 1)))
+ (just-one-space)))
+ (when org-trigger-hook
+ (save-excursion
+ (run-hook-with-args 'org-trigger-hook change-plist)))))))
+
+(defun org-local-logging (value)
+ "Get logging settings from a property VALUE."
+ (let* (words w a)
+ ;; directly set the variables, they are already local.
+ (setq org-log-done nil
+ org-log-repeat nil
+ org-todo-log-states nil)
+ (setq words (org-split-string value))
+ (while (setq w (pop words))
+ (cond
+ ((setq a (assoc w org-startup-options))
+ (and (member (nth 1 a) '(org-log-done org-log-repeat))
+ (set (nth 1 a) (nth 2 a))))
+ ((setq a (org-extract-log-state-settings w))
+ (and (member (car a) org-todo-keywords-1)
+ (push a org-todo-log-states)))))))
+
+(defun org-get-todo-sequence-head (kwd)
+ "Return the head of the TODO sequence to which KWD belongs.
+If KWD is not set, check if there is a text property remembering the
+right sequence."
+ (let (p)
+ (cond
+ ((not kwd)
+ (or (get-text-property (point-at-bol) 'org-todo-head)
+ (progn
+ (setq p (next-single-property-change (point-at-bol) 'org-todo-head
+ nil (point-at-eol)))
+ (get-text-property p 'org-todo-head))))
+ ((not (member kwd org-todo-keywords-1))
+ (car org-todo-keywords-1))
+ (t (nth 2 (assoc kwd org-todo-kwd-alist))))))
+
+(defun org-fast-todo-selection ()
+ "Fast TODO keyword selection with single keys.
+Returns the new TODO keyword, or nil if no state change should occur."
+ (let* ((fulltable org-todo-key-alist)
+ (done-keywords org-done-keywords) ;; needed for the faces.
+ (maxlen (apply 'max (mapcar
+ (lambda (x)
+ (if (stringp (car x)) (string-width (car x)) 0))
+ fulltable)))
+ (expert nil)
+ (fwidth (+ maxlen 3 1 3))
+ (ncol (/ (- (window-width) 4) fwidth))
+ tg cnt e c tbl
+ groups ingroup)
+ (save-window-excursion
+ (if expert
+ (set-buffer (get-buffer-create " *Org todo*"))
+ (org-switch-to-buffer-other-window (get-buffer-create " *Org todo*")))
+ (erase-buffer)
+ (org-set-local 'org-done-keywords done-keywords)
+ (setq tbl fulltable cnt 0)
+ (while (setq e (pop tbl))
(cond
- ((and state (not this))
- (org-add-planning-info nil nil 'closed)
- (and dostates (org-add-log-maybe 'state state 'findpos)))
- ((and state dostates)
- (org-add-log-maybe 'state state 'findpos))
- ((equal state org-done-string)
- ;; Planning info calls the note-setting command.
- (org-add-planning-info 'closed (org-current-time)
- (if (org-get-repeat) nil 'scheduled))
- (org-add-log-maybe 'done state 'findpos))))
- ;; Fixup tag positioning
- (and org-auto-align-tags (org-set-tags nil t))
- (run-hooks 'org-after-todo-state-change-hook)
- (and (equal state org-done-string) (org-auto-repeat-maybe))
- ))
- ;; Fixup cursor location if close to the keyword
- (if (and (outline-on-heading-p)
- (not (bolp))
- (save-excursion (beginning-of-line 1)
- (looking-at org-todo-line-regexp))
- (< (point) (+ 2 (or (match-end 2) (match-end 1)))))
- (progn
- (goto-char (or (match-end 2) (match-end 1)))
- (just-one-space))))
+ ((equal e '(:startgroup))
+ (push '() groups) (setq ingroup t)
+ (when (not (= cnt 0))
+ (setq cnt 0)
+ (insert "\n"))
+ (insert "{ "))
+ ((equal e '(:endgroup))
+ (setq ingroup nil cnt 0)
+ (insert "}\n"))
+ (t
+ (setq tg (car e) c (cdr e))
+ (if ingroup (push tg (car groups)))
+ (setq tg (org-add-props tg nil 'face
+ (org-get-todo-face tg)))
+ (if (and (= cnt 0) (not ingroup)) (insert " "))
+ (insert "[" c "] " tg (make-string
+ (- fwidth 4 (length tg)) ?\ ))
+ (when (= (setq cnt (1+ cnt)) ncol)
+ (insert "\n")
+ (if ingroup (insert " "))
+ (setq cnt 0)))))
+ (insert "\n")
+ (goto-char (point-min))
+ (if (and (not expert) (fboundp 'fit-window-to-buffer))
+ (fit-window-to-buffer))
+ (message "[a-z..]:Set [SPC]:clear")
+ (setq c (let ((inhibit-quit t)) (read-char-exclusive)))
+ (cond
+ ((or (= c ?\C-g)
+ (and (= c ?q) (not (rassoc c fulltable))))
+ (setq quit-flag t))
+ ((= c ?\ ) nil)
+ ((setq e (rassoc c fulltable) tg (car e))
+ tg)
+ (t (setq quit-flag t))))))
(defun org-get-repeat ()
- "Return the REPEAT statement of this entry."
+ "Check if tere is a deadline/schedule with repeater in this entry."
(save-match-data
(save-excursion
(org-back-to-heading t)
(defvar org-last-changed-timestamp)
(defvar org-log-post-message)
-(defun org-auto-repeat-maybe ()
- "Check if the current headline contains a REPEAT key.
-If yes, set TODO state back to what it was and change any SCHEDULED
-or DEADLINE times the new date.
-This function should be run in the `org-after-todo-state-change-hook'."
+(defvar org-log-note-purpose)
+(defun org-auto-repeat-maybe (done-word)
+ "Check if the current headline contains a repeated deadline/schedule.
+If yes, set TODO state back to what it was and change the base date
+of repeating deadline/scheduled time stamps to new date.
+This function is run automatically after each state change to a DONE state."
;; last-state is dynamically scoped into this function
- (let ((repeat (org-get-repeat))
- (whata '(("d" . day) ("m" . month) ("y" . year)))
- (msg "Entry repeats: ")
- (org-log-done)
- re type n what start)
+ (let* ((repeat (org-get-repeat))
+ (aa (assoc last-state org-todo-kwd-alist))
+ (interpret (nth 1 aa))
+ (head (nth 2 aa))
+ (whata '(("d" . day) ("m" . month) ("y" . year)))
+ (msg "Entry repeats: ")
+ (org-log-done nil)
+ (org-todo-log-states nil)
+ (nshiftmax 10) (nshift 0)
+ re type n what ts mb0 time)
(when repeat
- (org-todo (if (eq 'org-todo-interpretation 'type)
- last-state
- (car org-todo-keywords)))
- (unless (memq 'org-add-log-note (default-value 'post-command-hook))
- ;; Make sure a note is taken
- (let ((org-log-done '(done)))
- (org-add-log-maybe 'done org-done-string 'findpos)))
+ (if (eq org-log-repeat t) (setq org-log-repeat 'state))
+ (org-todo (if (eq interpret 'type) last-state head))
+ (when (and org-log-repeat
+ (or (not (memq 'org-add-log-note
+ (default-value 'post-command-hook)))
+ (eq org-log-note-purpose 'done)))
+ ;; Make sure a note is taken;
+ (org-add-log-maybe 'state (or done-word (car org-done-keywords))
+ 'findpos org-log-repeat))
(org-back-to-heading t)
(org-add-planning-info nil nil 'closed)
(setq re (concat "\\(" org-scheduled-time-regexp "\\)\\|\\("
- org-deadline-time-regexp "\\)"))
+ org-deadline-time-regexp "\\)\\|\\("
+ org-ts-regexp "\\)"))
(while (re-search-forward
re (save-excursion (outline-next-heading) (point)) t)
- (setq type (if (match-end 1) org-scheduled-string org-deadline-string)
- start 0)
- (while (string-match "\\([-+]?[0-9]+\\)\\([dwmy]\\)" repeat start)
- (setq start (match-end 0)
- n (string-to-number (match-string 1 repeat))
- what (match-string 2 repeat))
+ (setq type (if (match-end 1) org-scheduled-string
+ (if (match-end 3) org-deadline-string "Plain:"))
+ ts (match-string (if (match-end 2) 2 (if (match-end 4) 4 0)))
+ mb0 (match-beginning 0))
+ (when (string-match "\\([.+]\\)?\\(\\+[0-9]+\\)\\([dwmy]\\)" ts)
+ (setq n (string-to-number (match-string 2 ts))
+ what (match-string 3 ts))
(if (equal what "w") (setq n (* n 7) what "d"))
- (org-timestamp-change n (cdr (assoc what whata))))
- (setq msg (concat msg type org-last-changed-timestamp " ")))
+ ;; Preparation, see if we need to modify the start date for the change
+ (when (match-end 1)
+ (setq time (save-match-data (org-time-string-to-time ts)))
+ (cond
+ ((equal (match-string 1 ts) ".")
+ ;; Shift starting date to today
+ (org-timestamp-change
+ (- (time-to-days (current-time)) (time-to-days time))
+ 'day))
+ ((equal (match-string 1 ts) "+")
+ (while (< (time-to-days time) (time-to-days (current-time)))
+ (when (= (incf nshift) nshiftmax)
+ (or (y-or-n-p (message "%d repeater intervals were not enough to shift date past today. Continue? " nshift))
+ (error "Abort")))
+ (org-timestamp-change n (cdr (assoc what whata)))
+ (sit-for .0001) ;; so we can watch the date shifting
+ (org-at-timestamp-p t)
+ (setq ts (match-string 1))
+ (setq time (save-match-data (org-time-string-to-time ts))))
+ (org-timestamp-change (- n) (cdr (assoc what whata)))
+ ;; rematch, so that we have everything in place for the real shift
+ (org-at-timestamp-p t)
+ (setq ts (match-string 1))
+ (string-match "\\([.+]\\)?\\(\\+[0-9]+\\)\\([dwmy]\\)" ts))))
+ (org-timestamp-change n (cdr (assoc what whata)))
+ (setq msg (concat msg type org-last-changed-timestamp " "))))
(setq org-log-post-message msg)
- (message msg))))
+ (message "%s" msg))))
(defun org-show-todo-tree (arg)
"Make a compact tree which shows all headlines marked with TODO.
The tree will show the lines where the regexp matches, and all higher
headlines above the match.
-With \\[universal-argument] prefix, also show the DONE entries.
+With a \\[universal-argument] prefix, also show the DONE entries.
With a numeric prefix N, construct a sparse tree for the Nth element
-of `org-todo-keywords'."
+of `org-todo-keywords-1'."
(interactive "P")
(let ((case-fold-search nil)
(kwd-re
(cond ((null arg) org-not-done-regexp)
- ((equal arg '(4)) org-todo-regexp)
- ((<= (prefix-numeric-value arg) (length org-todo-keywords))
+ ((equal arg '(4))
+ (let ((kwd (completing-read "Keyword (or KWD1|KWD2|...): "
+ (mapcar 'list org-todo-keywords-1))))
+ (concat "\\("
+ (mapconcat 'identity (org-split-string kwd "|") "\\|")
+ "\\)\\>")))
+ ((<= (prefix-numeric-value arg) (length org-todo-keywords-1))
(regexp-quote (nth (1- (prefix-numeric-value arg))
- org-todo-keywords)))
+ org-todo-keywords-1)))
(t (error "Invalid prefix argument: %s" arg)))))
(message "%d TODO entries found"
- (org-occur (concat "^" outline-regexp " +" kwd-re )))))
+ (org-occur (concat "^" outline-regexp " *" kwd-re )))))
-(defun org-deadline ()
- "Insert the DEADLINE: string to make a deadline.
-A timestamp is also inserted - use \\[org-timestamp-up] and \\[org-timestamp-down]
-to modify it to the correct date."
- (interactive)
- (org-add-planning-info 'deadline nil 'closed))
+(defun org-deadline (&optional remove)
+ "Insert the \"DEADLINE:\" string with a timestamp to make a deadline.
+With argument REMOVE, remove any deadline from the item."
+ (interactive "P")
+ (if remove
+ (progn
+ (org-remove-timestamp-with-keyword org-deadline-string)
+ (message "Item no longer has a deadline."))
+ (org-add-planning-info 'deadline nil 'closed)))
-(defun org-schedule ()
- "Insert the SCHEDULED: string to schedule a TODO item.
-A timestamp is also inserted - use \\[org-timestamp-up] and \\[org-timestamp-down]
-to modify it to the correct date."
- (interactive)
- (org-add-planning-info 'scheduled nil 'closed))
+(defun org-schedule (&optional remove)
+ "Insert the SCHEDULED: string with a timestamp to schedule a TODO item.
+With argument REMOVE, remove any scheduling date from the item."
+ (interactive "P")
+ (if remove
+ (progn
+ (org-remove-timestamp-with-keyword org-scheduled-string)
+ (message "Item is no longer scheduled."))
+ (org-add-planning-info 'scheduled nil 'closed)))
+
+(defun org-remove-timestamp-with-keyword (keyword)
+ "Remove all time stamps with KEYWORD in the current entry."
+ (let ((re (concat "\\<" (regexp-quote keyword) " +<[^>\n]+>[ \t]*"))
+ beg)
+ (save-excursion
+ (org-back-to-heading t)
+ (setq beg (point))
+ (org-end-of-subtree t t)
+ (while (re-search-backward re beg t)
+ (replace-match "")
+ (unless (string-match "\\S-" (buffer-substring (point-at-bol) (point)))
+ (delete-region (point-at-bol) (min (1+ (point)) (point-max))))))))
(defun org-add-planning-info (what &optional time &rest remove)
"Insert new timestamp with keyword in the line directly after the headline.
REMOVE indicates what kind of entries to remove. An old WHAT entry will also
be removed."
(interactive)
- (let (org-time-was-given)
+ (let (org-time-was-given org-end-time-was-given)
(when what (setq time (or time (org-read-date nil 'to-time))))
(when (and org-insert-labeled-timestamps-at-point
(member what '(scheduled deadline)))
(insert
(if (eq what 'scheduled) org-scheduled-string org-deadline-string) " ")
- (org-insert-time-stamp time org-time-was-given)
+ (org-insert-time-stamp time org-time-was-given
+ nil nil nil (list org-end-time-was-given))
(setq what nil))
(save-excursion
(save-restriction
(looking-at (concat outline-regexp "\\( *\\)[^\r\n]*"))
(goto-char (match-end 1))
(setq col (current-column))
- (goto-char (1+ (match-end 0)))
+ (goto-char (match-end 0))
+ (if (eobp) (insert "\n") (forward-char 1))
(if (and (not (looking-at outline-regexp))
(looking-at (concat "[^\r\n]*?" org-keyword-time-regexp
"[^\r\n]*"))
(not (equal (match-string 1) org-clock-string)))
(narrow-to-region (match-beginning 0) (match-end 0))
- (insert "\n")
+ (insert-before-markers "\n")
(backward-char 1)
(narrow-to-region (point) (point))
(indent-to-column col))
((eq what 'deadline) org-deadline-string)
((eq what 'closed) org-closed-string))
" ")
- (org-insert-time-stamp time
- (or org-time-was-given (eq what 'closed))
- (eq what 'closed))
+ (setq ts (org-insert-time-stamp
+ time
+ (or org-time-was-given
+ (and (eq what 'closed) org-log-done-with-time))
+ (eq what 'closed)
+ nil nil (list org-end-time-was-given)))
(end-of-line 1))
(goto-char (point-min))
(widen)
(defvar org-log-note-marker (make-marker))
(defvar org-log-note-purpose nil)
(defvar org-log-note-state nil)
+(defvar org-log-note-how nil)
(defvar org-log-note-window-configuration nil)
(defvar org-log-note-return-to (make-marker))
(defvar org-log-post-message nil
"Message to be displayed after a log note has been stored.
The auto-repeater uses this.")
-(defun org-add-log-maybe (&optional purpose state findpos)
+(defun org-add-log-maybe (&optional purpose state findpos how)
+ "Set up the post command hook to take a note.
+If this is about to TODO state change, the new state is expected in STATE.
+When FINDPOS is non-nil, find the correct position for the note in
+the current entry. If not, assume that it can be inserted at point."
(save-excursion
- (when (and (listp org-log-done)
- (memq purpose org-log-done))
- (when findpos
- (org-back-to-heading t)
- (looking-at (concat outline-regexp "\\( *\\)[^\r\n]*"
- "\\(\n[^\r\n]*?" org-keyword-time-not-clock-regexp
- "[^\r\n]*\\)?"))
- (goto-char (match-end 0)))
- (move-marker org-log-note-marker (point))
- (setq org-log-note-purpose purpose)
- (setq org-log-note-state state)
- (add-hook 'post-command-hook 'org-add-log-note 'append))))
+ (when findpos
+ (org-back-to-heading t)
+ (looking-at (concat outline-regexp "\\( *\\)[^\r\n]*"
+ "\\(\n[^\r\n]*?" org-keyword-time-not-clock-regexp
+ "[^\r\n]*\\)?"))
+ (goto-char (match-end 0))
+ (unless org-log-states-order-reversed
+ (and (= (char-after) ?\n) (forward-char 1))
+ (org-skip-over-state-notes)
+ (skip-chars-backward " \t\n\r")))
+ (move-marker org-log-note-marker (point))
+ (setq org-log-note-purpose purpose
+ org-log-note-state state
+ org-log-note-how how)
+ (add-hook 'post-command-hook 'org-add-log-note 'append)))
+
+(defun org-skip-over-state-notes ()
+ "Skip past the list of State notes in an entry."
+ (if (looking-at "\n[ \t]*- State") (forward-char 1))
+ (while (looking-at "[ \t]*- State")
+ (condition-case nil
+ (org-next-item)
+ (error (org-end-of-item)))))
(defun org-add-log-note (&optional purpose)
"Pop up a window for taking a note, and add this note later at point."
(move-marker org-log-note-return-to (point))
(switch-to-buffer (marker-buffer org-log-note-marker))
(goto-char org-log-note-marker)
- (switch-to-buffer-other-window "*Org Note*")
+ (org-switch-to-buffer-other-window "*Org Note*")
(erase-buffer)
- (let ((org-inhibit-startup t)) (org-mode))
- (insert (format "# Insert note for %s, finish with C-c C-c.\n\n"
- (cond
- ((eq org-log-note-purpose 'clock-out) "stopped clock")
- ((eq org-log-note-purpose 'done) "closed todo item")
- ((eq org-log-note-purpose 'state) "state change")
+ (if (memq org-log-note-how '(time state)) ; FIXME: time or state????????????
+ (org-store-log-note)
+ (let ((org-inhibit-startup t)) (org-mode))
+ (insert (format "# Insert note for %s.
+# Finish with C-c C-c, or cancel with C-c C-k.\n\n"
+ (cond
+ ((eq org-log-note-purpose 'clock-out) "stopped clock")
+ ((eq org-log-note-purpose 'done) "closed todo item")
+ ((eq org-log-note-purpose 'state)
+ (format "state change to \"%s\"" org-log-note-state))
(t (error "This should not happen")))))
- (org-set-local 'org-finish-function 'org-store-log-note))
+ (org-set-local 'org-finish-function 'org-store-log-note)))
(defun org-store-log-note ()
"Finish taking a log note, and insert it to where it belongs."
(note (cdr (assq org-log-note-purpose org-log-note-headings)))
lines ind)
(kill-buffer (current-buffer))
- (if (string-match "^#.*\n[ \t\n]*" txt)
- (setq txt (replace-match "" t t txt)))
+ (while (string-match "\\`#.*\n[ \t\n]*" txt)
+ (setq txt (replace-match "" t t txt)))
(if (string-match "\\s-+\\'" txt)
(setq txt (replace-match "" t t txt)))
(setq lines (org-split-string txt "\n"))
"")))))
(if lines (setq note (concat note " \\\\")))
(push note lines))
- (save-excursion
- (set-buffer (marker-buffer org-log-note-marker))
+ (when (or current-prefix-arg org-note-abort) (setq lines nil))
+ (when lines
(save-excursion
- (goto-char org-log-note-marker)
- (move-marker org-log-note-marker nil)
- (end-of-line 1)
- (if (not (bolp)) (insert "\n")) (indent-relative nil)
- (setq ind (concat (buffer-substring (point-at-bol) (point)) " "))
- (insert " - " (pop lines))
- (while lines
- (insert "\n" ind (pop lines))))))
+ (set-buffer (marker-buffer org-log-note-marker))
+ (save-excursion
+ (goto-char org-log-note-marker)
+ (move-marker org-log-note-marker nil)
+ (end-of-line 1)
+ (if (not (bolp)) (let ((inhibit-read-only t)) (insert "\n")))
+ (indent-relative nil)
+ (insert "- " (pop lines))
+ (org-indent-line-function)
+ (beginning-of-line 1)
+ (looking-at "[ \t]*")
+ (setq ind (concat (match-string 0) " "))
+ (end-of-line 1)
+ (while lines (insert "\n" ind (pop lines)))))))
(set-window-configuration org-log-note-window-configuration)
(with-current-buffer (marker-buffer org-log-note-return-to)
(goto-char org-log-note-return-to))
(move-marker org-log-note-return-to nil)
- (and org-log-post-message (message org-log-post-message)))
-
-(defvar org-occur-highlights nil)
+ (and org-log-post-message (message "%s" org-log-post-message)))
+
+;; FIXME: what else would be useful?
+;; - priority
+;; - date
+
+(defun org-sparse-tree (&optional arg)
+ "Create a sparse tree, prompt for the details.
+This command can create sparse trees. You first need to select the type
+of match used to create the tree:
+
+t Show entries with a specific TODO keyword.
+T Show entries selected by a tags match.
+p Enter a property name and its value (both with completion on existing
+ names/values) and show entries with that property.
+r Show entries matching a regular expression
+d Show deadlines due within `org-deadline-warning-days'."
+ (interactive "P")
+ (let (ans kwd value)
+ (message "Sparse tree: [/]regexp [t]odo-kwd [T]ag [p]roperty [d]eadlines [b]efore-date")
+ (setq ans (read-char-exclusive))
+ (cond
+ ((equal ans ?d)
+ (call-interactively 'org-check-deadlines))
+ ((equal ans ?b)
+ (call-interactively 'org-check-before-date))
+ ((equal ans ?t)
+ (org-show-todo-tree '(4)))
+ ((equal ans ?T)
+ (call-interactively 'org-tags-sparse-tree))
+ ((member ans '(?p ?P))
+ (setq kwd (completing-read "Property: "
+ (mapcar 'list (org-buffer-property-keys))))
+ (setq value (completing-read "Value: "
+ (mapcar 'list (org-property-values kwd))))
+ (unless (string-match "\\`{.*}\\'" value)
+ (setq value (concat "\"" value "\"")))
+ (org-tags-sparse-tree arg (concat kwd "=" value)))
+ ((member ans '(?r ?R ?/))
+ (call-interactively 'org-occur))
+ (t (error "No such sparse tree command \"%c\"" ans)))))
+
+(defvar org-occur-highlights nil
+ "List of overlays used for occur matches.")
(make-variable-buffer-local 'org-occur-highlights)
+(defvar org-occur-parameters nil
+ "Parameters of the active org-occur calls.
+This is a list, each call to org-occur pushes as cons cell,
+containing the regular expression and the callback, onto the list.
+The list can contain several entries if `org-occur' has been called
+several time with the KEEP-PREVIOUS argument. Otherwise, this list
+will only contain one set of parameters. When the highlights are
+removed (for example with `C-c C-c', or with the next edit (depending
+on `org-remove-highlights-with-change'), this variable is emptied
+as well.")
+(make-variable-buffer-local 'org-occur-parameters)
(defun org-occur (regexp &optional keep-previous callback)
"Make a compact tree which shows all matches of REGEXP.
If CALLBACK is non-nil, it is a function which is called to confirm
that the match should indeed be shown."
(interactive "sRegexp: \nP")
- (or keep-previous (org-remove-occur-highlights nil nil t))
+ (unless keep-previous
+ (org-remove-occur-highlights nil nil t))
+ (push (cons regexp callback) org-occur-parameters)
(let ((cnt 0))
(save-excursion
(goto-char (point-min))
(when (or (not callback)
(save-match-data (funcall callback)))
(setq cnt (1+ cnt))
- (org-highlight-new-match (match-beginning 0) (match-end 0))
+ (when org-highlight-sparse-tree-matches
+ (org-highlight-new-match (match-beginning 0) (match-end 0)))
(org-show-context 'occur-tree))))
(when org-remove-highlights-with-change
(org-add-hook 'before-change-functions 'org-remove-occur-highlights
(let ((heading-p (org-on-heading-p t))
(hierarchy-p (org-get-alist-option org-show-hierarchy-above key))
(following-p (org-get-alist-option org-show-following-heading key))
+ (entry-p (org-get-alist-option org-show-entry-below key))
(siblings-p (org-get-alist-option org-show-siblings key)))
(catch 'exit
;; Show heading or entry text
- (if heading-p
+ (if (and heading-p (not entry-p))
(org-flag-heading nil) ; only show the heading
- (and (or (org-invisible-p) (org-invisible-p2))
+ (and (or entry-p (org-invisible-p) (org-invisible-p2))
(org-show-hidden-entry))) ; show entire entry
(when following-p
;; Show next sibling, or heading below text
(unless org-inhibit-highlight-removal
(mapc 'org-delete-overlay org-occur-highlights)
(setq org-occur-highlights nil)
+ (setq org-occur-parameters nil)
(unless noremove
(remove-hook 'before-change-functions
'org-remove-occur-highlights 'local))))
;;;; Priorities
-(defvar org-priority-regexp ".*?\\(\\[#\\([A-Z]\\)\\] ?\\)"
+(defvar org-priority-regexp ".*?\\(\\[#\\([A-Z0-9]\\)\\] ?\\)"
"Regular expression matching the priority indicator.")
(defvar org-remove-priority-next-time nil)
(defun org-priority (&optional action)
"Change the priority of an item by ARG.
-ACTION can be set, up, or down."
+ACTION can be `set', `up', `down', or a character."
(interactive)
(setq action (or action 'set))
(let (current new news have remove)
have t)
(setq current org-default-priority))
(cond
- ((eq action 'set)
- (message "Priority A-%c, SPC to remove: " org-lowest-priority)
- (setq new (read-char-exclusive))
+ ((or (eq action 'set) (integerp action))
+ (if (integerp action)
+ (setq new action)
+ (message "Priority %c-%c, SPC to remove: " org-highest-priority org-lowest-priority)
+ (setq new (read-char-exclusive)))
+ (if (and (= (upcase org-highest-priority) org-highest-priority)
+ (= (upcase org-lowest-priority) org-lowest-priority))
+ (setq new (upcase new)))
(cond ((equal new ?\ ) (setq remove t))
- ((or (< (upcase new) ?A) (> (upcase new) org-lowest-priority))
+ ((or (< (upcase new) org-highest-priority) (> (upcase new) org-lowest-priority))
(error "Priority must be between `%c' and `%c'"
- ?A org-lowest-priority))))
+ org-highest-priority org-lowest-priority))))
((eq action 'up)
- (setq new (1- current)))
+ (if (and (not have) (eq last-command this-command))
+ (setq new org-lowest-priority)
+ (setq new (if (and org-priority-start-cycle-with-default (not have))
+ org-default-priority (1- current)))))
((eq action 'down)
- (setq new (1+ current)))
+ (if (and (not have) (eq last-command this-command))
+ (setq new org-highest-priority)
+ (setq new (if (and org-priority-start-cycle-with-default (not have))
+ org-default-priority (1+ current)))))
(t (error "Invalid action")))
- (setq new (min (max ?A (upcase new)) org-lowest-priority))
+ (if (or (< (upcase new) org-highest-priority)
+ (> (upcase new) org-lowest-priority))
+ (setq remove t))
(setq news (format "%c" new))
(if have
(if remove
(insert " [#" news "]"))
(goto-char (match-beginning 3))
(insert "[#" news "] ")))))
+ (org-preserve-lc (org-set-tags nil 'align))
(if remove
(message "Priority removed")
(message "Priority of current item set to %s" news))))
inclusion. When TODO-ONLY is non-nil, only lines with a TODO keyword
are included in the output."
(let* ((re (concat "[\n\r]" outline-regexp " *\\(\\<\\("
- (mapconcat 'regexp-quote
- (nreverse (cdr (reverse org-todo-keywords)))
- "\\|")
- "\\>\\)\\)? *\\(.*?\\)\\(:[A-Za-z_@0-9:]+:\\)?[ \t]*$"))
+ (mapconcat 'regexp-quote org-todo-keywords-1 "\\|")
+ (org-re
+ "\\>\\)\\)? *\\(.*?\\)\\(:[[:alnum:]_@:]+:\\)?[ \t]*$")))
(props (list 'face nil
'done-face 'org-done
'undone-face nil
'mouse-face 'highlight
'org-not-done-regexp org-not-done-regexp
+ 'org-todo-regexp org-todo-regexp
'keymap org-agenda-keymap
'help-echo
(format "mouse-2 or RET jump to org file %s"
- (abbreviate-file-name buffer-file-name))))
+ (abbreviate-file-name
+ (or (buffer-file-name (buffer-base-buffer))
+ (buffer-name (buffer-base-buffer)))))))
(case-fold-search nil)
lspos
tags tags-list tags-alist (llast 0) rtn level category i txt
- todo marker entry)
+ todo marker entry priority)
(save-excursion
(goto-char (point-min))
- (when (eq action 'sparse-tree) (org-overview))
+ (when (eq action 'sparse-tree)
+ (org-overview)
+ (org-remove-occur-highlights))
(while (re-search-forward re nil t)
(catch :skip
(setq todo (if (match-end 1) (match-string 2))
tags (if (match-end 4) (match-string 4)))
(goto-char (setq lspos (1+ (match-beginning 0))))
- (setq level (funcall outline-level)
+ (setq level (org-reduced-level (funcall outline-level))
category (org-get-category))
(setq i llast llast level)
;; remove tag lists from same and sublevels
(if org-use-tag-inheritance
(apply 'append (mapcar 'cdr tags-alist))
tags))
- (when (and (or (not todo-only) todo)
+ (when (and (or (not todo-only) (member todo org-not-done-keywords))
(eval matcher)
(or (not org-agenda-skip-archived-trees)
(not (member org-archive-tag tags-list))))
(and (eq action 'agenda) (org-agenda-skip))
;; list this headline
+
(if (eq action 'sparse-tree)
(progn
+ (and org-highlight-sparse-tree-matches
+ (org-get-heading) (match-end 0)
+ (org-highlight-new-match
+ (match-beginning 0) (match-beginning 1)))
(org-show-context 'tags-tree))
(setq txt (org-format-agenda-item
""
(if org-tags-match-list-sublevels
(make-string (1- level) ?.) "")
(org-get-heading))
- category tags-list))
+ category tags-list)
+ priority (org-get-priority txt))
(goto-char lspos)
(setq marker (org-agenda-new-marker))
(org-add-props txt props
- 'org-marker marker 'org-hd-marker marker 'org-category category)
+ 'org-marker marker 'org-hd-marker marker 'org-category category
+ 'priority priority 'type "tagsmatch")
(push txt rtn))
;; if we are to skip sublevels, jump to end of subtree
(or org-tags-match-list-sublevels (org-end-of-subtree t))))))
If optional argument TODO_ONLY is non-nil, only select lines that are
also TODO lines."
(interactive "P")
+ (org-prepare-agenda-buffers (list (current-buffer)))
(org-scan-tags 'sparse-tree (cdr (org-make-tags-matcher match)) todo-only))
+(defvar org-cached-props nil)
+(defun org-cached-entry-get (pom property)
+ (if (or (eq t org-use-property-inheritance)
+ (member property org-use-property-inheritance))
+ ;; Caching is not possible, check it directly
+ (org-entry-get pom property 'inherit)
+ ;; Get all properties, so that we can do complicated checks easily
+ (cdr (assoc property (or org-cached-props
+ (setq org-cached-props
+ (org-entry-properties pom)))))))
+
+(defun org-global-tags-completion-table (&optional files)
+ "Return the list of all tags in all agenda buffer/files."
+ (save-excursion
+ (org-uniquify
+ (delq nil
+ (apply 'append
+ (mapcar
+ (lambda (file)
+ (set-buffer (find-file-noselect file))
+ (append (org-get-buffer-tags)
+ (mapcar (lambda (x) (if (stringp (car-safe x))
+ (list (car-safe x)) nil))
+ org-tag-alist)))
+ (if (and files (car files))
+ files
+ (org-agenda-files))))))))
+
(defun org-make-tags-matcher (match)
"Create the TAGS//TODO matcher form for the selection string MATCH."
;; todo-only is scoped dynamically into this function, and the function
;; may change it it the matcher asksk for it.
(unless match
;; Get a new match request, with completion
- (setq org-last-tags-completion-table
- (or org-tag-alist
- org-last-tags-completion-table))
- (setq match (completing-read
- "Match: " 'org-tags-completion-function nil nil nil
- 'org-tags-history)))
+ (let ((org-last-tags-completion-table
+ (org-global-tags-completion-table)))
+ (setq match (completing-read
+ "Match: " 'org-tags-completion-function nil nil nil
+ 'org-tags-history))))
;; Parse the string and create a lisp form
(let ((match0 match)
- (re "^&?\\([-+:]\\)?\\({[^}]+}\\|LEVEL=\\([0-9]+\\)\\|[A-Za-z_@0-9]+\\)")
+ (re (org-re "^&?\\([-+:]\\)?\\({[^}]+}\\|LEVEL=\\([0-9]+\\)\\|\\([[:alnum:]_]+\\)=\\({[^}]+}\\|\"[^\"]*\"\\)\\|[[:alnum:]_@]+\\)"))
minus tag mm
tagsmatch todomatch tagsmatcher todomatcher kwd matcher
- orterms term orlist re-p level-p)
+ orterms term orlist re-p level-p prop-p pn pv cat-p gv)
(if (string-match "/+" match)
;; match contains also a todo-matching request
(progn
tag (match-string 2 term)
re-p (equal (string-to-char tag) ?{)
level-p (match-end 3)
+ prop-p (match-end 4)
mm (cond
(re-p `(org-match-any-p ,(substring tag 1 -1) tags-list))
(level-p `(= level ,(string-to-number
(match-string 3 term))))
+ (prop-p
+ (setq pn (match-string 4 term)
+ pv (match-string 5 term)
+ cat-p (equal pn "CATEGORY")
+ re-p (equal (string-to-char pv) ?{)
+ pv (substring pv 1 -1))
+ (if (equal pn "CATEGORY")
+ (setq gv '(get-text-property (point) 'org-category))
+ (setq gv `(org-cached-entry-get nil ,pn)))
+ (if re-p
+ `(string-match ,pv (or ,gv ""))
+ `(equal ,pv (or ,gv ""))))
(t `(member ,(downcase tag) tags-list)))
mm (if minus (list 'not mm) mm)
term (substring term (match-end 0)))
(car tagsmatcher))
orlist)
(setq tagsmatcher nil))
- (setq tagsmatcher (if (> (length orlist) 1) (cons 'or orlist) (car orlist))))
+ (setq tagsmatcher (if (> (length orlist) 1) (cons 'or orlist) (car orlist)))
+ (setq tagsmatcher
+ (list 'progn '(setq org-cached-props nil) tagsmatcher)))
;; Make the todo matcher
(if (or (not todomatch) (not (string-match "\\S-" todomatch)))
(defvar org-tags-overlay (org-make-overlay 1 1))
(org-detach-overlay org-tags-overlay)
+(defun org-align-tags-here (to-col)
+ ;; Assumes that this is a headline
+ (let ((pos (point)) (col (current-column)) tags)
+ (beginning-of-line 1)
+ (if (and (looking-at (org-re ".*?\\([ \t]+\\)\\(:[[:alnum:]_@:]+:\\)[ \t]*$"))
+ (< pos (match-beginning 2)))
+ (progn
+ (setq tags (match-string 2))
+ (goto-char (match-beginning 1))
+ (insert " ")
+ (delete-region (point) (1+ (match-end 0)))
+ (backward-char 1)
+ (move-to-column
+ (max (1+ (current-column))
+ (1+ col)
+ (if (> to-col 0)
+ to-col
+ (- (abs to-col) (length tags))))
+ t)
+ (insert tags)
+ (move-to-column (min (current-column) col) t))
+ (goto-char pos))))
+
(defun org-set-tags (&optional arg just-align)
"Set the tags for the current headline.
With prefix ARG, realign all tags in headings in the current buffer."
(interactive "P")
(let* ((re (concat "^" outline-regexp))
- (current (org-get-tags))
+ (current (org-get-tags-string))
+ (col (current-column))
+ (org-setting-tags t)
table current-tags inherited-tags ; computed below when needed
tags p0 c0 c1 rpl)
(if arg
(save-excursion
(goto-char (point-min))
- (let (buffer-invisibility-spec) ; Emacs 21 compatibility
+ (let ((buffer-invisibility-spec (org-inhibit-invisibility)))
(while (re-search-forward re nil t)
(org-set-tags nil t)
(end-of-line 1)))
(if (or (eq t org-use-fast-tag-selection)
(and org-use-fast-tag-selection
(delq nil (mapcar 'cdr table))))
- (org-fast-tag-selection current-tags inherited-tags table)
+ (org-fast-tag-selection
+ current-tags inherited-tags table
+ (if org-fast-tag-selection-include-todo org-todo-key-alist))
(let ((org-add-colon-after-tag-completion t))
(org-trim
- (completing-read "Tags: " 'org-tags-completion-function
- nil nil current 'org-tags-history))))))
+ (org-without-partial-completion
+ (completing-read "Tags: " 'org-tags-completion-function
+ nil nil current 'org-tags-history)))))))
(while (string-match "[-+&]+" tags)
;; No boolean logic, just a list
(setq tags (replace-match ":" t t tags))))
+
(if (string-match "\\`[\t ]*\\'" tags)
(setq tags "")
(unless (string-match ":$" tags) (setq tags (concat tags ":")))
;; Insert new tags at the correct column
(beginning-of-line 1)
- (if (re-search-forward
- (concat "\\([ \t]*" (regexp-quote current) "\\)[ \t]*$")
- (point-at-eol) t)
- (progn
- (if (equal tags "")
- (setq rpl "")
- (goto-char (match-beginning 0))
- (setq c0 (current-column) p0 (point)
- c1 (max (1+ c0) (if (> org-tags-column 0)
- org-tags-column
- (- (- org-tags-column) (length tags))))
- rpl (concat (make-string (max 0 (- c1 c0)) ?\ ) tags)))
- (replace-match rpl t t)
- (and (not (featurep 'xemacs)) c0 (tabify p0 (point)))
- tags)
- (error "Tags alignment failed")))))
+ (cond
+ ((and (equal current "") (equal tags "")))
+ ((re-search-forward
+ (concat "\\([ \t]*" (regexp-quote current) "\\)[ \t]*$")
+ (point-at-eol) t)
+ (if (equal tags "")
+ (setq rpl "")
+ (goto-char (match-beginning 0))
+ (setq c0 (current-column) p0 (point)
+ c1 (max (1+ c0) (if (> org-tags-column 0)
+ org-tags-column
+ (- (- org-tags-column) (length tags))))
+ rpl (concat (make-string (max 0 (- c1 c0)) ?\ ) tags)))
+ (replace-match rpl t t)
+ (and (not (featurep 'xemacs)) c0 indent-tabs-mode (tabify p0 (point)))
+ tags)
+ (t (error "Tags alignment failed")))
+ (move-to-column col)
+ (unless just-align
+ (run-hooks 'org-after-tags-change-hook)))))
+
+(defun org-change-tag-in-region (beg end tag off)
+ "Add or remove TAG for each entry in the region.
+This works in the agenda, and also in an org-mode buffer."
+ (interactive
+ (list (region-beginning) (region-end)
+ (let ((org-last-tags-completion-table
+ (if (org-mode-p)
+ (org-get-buffer-tags)
+ (org-global-tags-completion-table))))
+ (completing-read
+ "Tag: " 'org-tags-completion-function nil nil nil
+ 'org-tags-history))
+ (progn
+ (message "[s]et or [r]emove? ")
+ (equal (read-char-exclusive) ?r))))
+ (if (fboundp 'deactivate-mark) (deactivate-mark))
+ (let ((agendap (equal major-mode 'org-agenda-mode))
+ l1 l2 m buf pos newhead (cnt 0))
+ (goto-char end)
+ (setq l2 (1- (org-current-line)))
+ (goto-char beg)
+ (setq l1 (org-current-line))
+ (loop for l from l1 to l2 do
+ (goto-line l)
+ (setq m (get-text-property (point) 'org-hd-marker))
+ (when (or (and (org-mode-p) (org-on-heading-p))
+ (and agendap m))
+ (setq buf (if agendap (marker-buffer m) (current-buffer))
+ pos (if agendap m (point)))
+ (with-current-buffer buf
+ (save-excursion
+ (save-restriction
+ (goto-char pos)
+ (setq cnt (1+ cnt))
+ (org-toggle-tag tag (if off 'off 'on))
+ (setq newhead (org-get-heading)))))
+ (and agendap (org-agenda-change-all-lines newhead m))))
+ (message "Tag :%s: %s in %d headings" tag (if off "removed" "set") cnt)))
(defun org-tags-completion-function (string predicate &optional flag)
(let (s1 s2 rtn (ctable org-last-tags-completion-table)
;; try completion
(setq rtn (try-completion s2 ctable confirm))
(if (stringp rtn)
- (concat s1 s2 (substring rtn (length s2))
- (if (and org-add-colon-after-tag-completion
- (assoc rtn ctable))
- ":" "")))
- )
+ (setq rtn
+ (concat s1 s2 (substring rtn (length s2))
+ (if (and org-add-colon-after-tag-completion
+ (assoc rtn ctable))
+ ":" ""))))
+ rtn)
((eq flag t)
;; all-completions
(all-completions s2 ctable confirm)
(put-text-property 0 (length s) 'face '(secondary-selection org-tag) s)
(org-overlay-display org-tags-overlay (concat prefix s)))))
-(defun org-fast-tag-selection (current inherited table)
+(defun org-fast-tag-selection (current inherited table &optional todo-table)
"Fast tag selection with single keys.
CURRENT is the current list of tags in the headline, INHERITED is the
list of inherited tags, and TABLE is an alist of tags and corresponding keys,
-possibly with grouping information.
+possibly with grouping information. TODO-TABLE is a similar table with
+TODO keywords, should these have keys assigned to them.
If the keys are nil, a-z are automatically assigned.
Returns the new tags string, or nil to not change the current settings."
- (let* ((maxlen (apply 'max (mapcar
+ (let* ((fulltable (append table todo-table))
+ (maxlen (apply 'max (mapcar
(lambda (x)
(if (stringp (car x)) (string-width (car x)) 0))
- table)))
+ fulltable)))
(buf (current-buffer))
(expert (eq org-fast-tag-selection-single-key 'expert))
(buffer-tags nil)
(fwidth (+ maxlen 3 1 3))
(ncol (/ (- (window-width) 4) fwidth))
(i-face 'org-done)
- (c-face 'org-tag)
+ (c-face 'org-todo)
tg cnt e c char c1 c2 ntable tbl rtn
ov-start ov-end ov-prefix
(exit-after-next org-fast-tag-selection-single-key)
+ (done-keywords org-done-keywords)
groups ingroup)
(save-excursion
(beginning-of-line 1)
- (if (looking-at ".*[ \t]\\(:[A-Za-z_@0-9:]+:\\)[ \t]*\\(\r\\|$\\)")
+ (if (looking-at
+ (org-re ".*[ \t]\\(:[[:alnum:]_@:]+:\\)[ \t]*$"))
(setq ov-start (match-beginning 1)
ov-end (match-end 1)
ov-prefix "")
(set-buffer (get-buffer-create " *Org tags*"))
(delete-other-windows)
(split-window-vertically)
- (switch-to-buffer-other-window (get-buffer-create " *Org tags*")))
+ (org-switch-to-buffer-other-window (get-buffer-create " *Org tags*")))
(erase-buffer)
+ (org-set-local 'org-done-keywords done-keywords)
(org-fast-tag-insert "Inherited" inherited i-face "\n")
(org-fast-tag-insert "Current" current c-face "\n\n")
(org-fast-tag-show-exit exit-after-next)
(org-set-current-tags-overlay current ov-prefix)
- (setq tbl table char ?a cnt 0)
+ (setq tbl fulltable char ?a cnt 0)
(while (setq e (pop tbl))
(cond
((equal e '(:startgroup))
(if ingroup (push tg (car groups)))
(setq tg (org-add-props tg nil 'face
(cond
+ ((not (assoc tg table))
+ (org-get-todo-face tg))
((member tg current) c-face)
((member tg inherited) i-face)
(t nil))))
(setq expert nil)
(delete-other-windows)
(split-window-vertically)
- (switch-to-buffer-other-window " *Org tags*")
+ (org-switch-to-buffer-other-window " *Org tags*")
(and (fboundp 'fit-window-to-buffer)
(fit-window-to-buffer))))
((or (= c ?\C-g)
(setq current (delete tg current))
(push tg current)))
(if exit-after-next (setq exit-after-next 'now)))
+ ((setq e (rassoc c todo-table) tg (car e))
+ (with-current-buffer buf
+ (save-excursion (org-todo tg)))
+ (if exit-after-next (setq exit-after-next 'now)))
((setq e (rassoc c ntable) tg (car e))
(if (member tg current)
(setq current (delete tg current))
(loop for g in groups do
(if (member tg g)
- (mapcar (lambda (x)
- (setq current (delete x current)))
- g)))
+ (mapc (lambda (x)
+ (setq current (delete x current)))
+ g)))
(push tg current))
(if exit-after-next (setq exit-after-next 'now))))
(delete-region (point) (point-at-eol))
(org-fast-tag-insert "Current" current c-face)
(org-set-current-tags-overlay current ov-prefix)
- (while (re-search-forward "\\[.\\] \\([a-zA-Z0-9_@]+\\)" nil t)
+ (while (re-search-forward
+ (org-re "\\[.\\] \\([[:alnum:]_@]+\\)") nil t)
(setq tg (match-string 1))
- (add-text-properties (match-beginning 1) (match-end 1)
- (list 'face
- (cond
- ((member tg current) c-face)
- ((member tg inherited) i-face)
- (t nil)))))
+ (add-text-properties
+ (match-beginning 1) (match-end 1)
+ (list 'face
+ (cond
+ ((member tg current) c-face)
+ ((member tg inherited) i-face)
+ (t (get-text-property (match-beginning 1) 'face))))))
(goto-char (point-min)))))
(org-detach-overlay org-tags-overlay)
(if rtn
(mapconcat 'identity current ":")
nil))))
-(defun org-get-tags ()
+(defun org-get-tags-string ()
"Get the TAGS string in the current headline."
(unless (org-on-heading-p t)
(error "Not on a heading"))
(save-excursion
(beginning-of-line 1)
- (if (looking-at ".*[ \t]\\(:[A-Za-z_@0-9:]+:\\)[ \t]*\\(\r\\|$\\)")
+ (if (looking-at (org-re ".*[ \t]\\(:[[:alnum:]_@:]+:\\)[ \t]*$"))
(org-match-string-no-properties 1)
"")))
+(defun org-get-tags ()
+ "Get the list of tags specified in the current headline."
+ (org-split-string (org-get-tags-string) ":"))
+
(defun org-get-buffer-tags ()
"Get a table of all tags used in the buffer, for completion."
(let (tags)
(save-excursion
(goto-char (point-min))
- (while (re-search-forward "[ \t]:\\([A-Za-z_@0-9:]+\\):[ \t\r\n]" nil t)
- (mapc (lambda (x) (add-to-list 'tags x))
- (org-split-string (org-match-string-no-properties 1) ":"))))
+ (while (re-search-forward
+ (org-re "[ \t]:\\([[:alnum:]_@:]+\\):[ \t\r\n]") nil t)
+ (when (equal (char-after (point-at-bol 0)) ?*)
+ (mapc (lambda (x) (add-to-list 'tags x))
+ (org-split-string (org-match-string-no-properties 1) ":")))))
(mapcar 'list tags)))
+
+;;;; Properties
+
+;;; Setting and retrieving properties
+
+(defconst org-special-properties
+ '("TODO" "TAGS" "ALLTAGS" "DEADLINE" "SCHEDULED" "CLOCK" "PRIORITY"
+ "TIMESTAMP" "TIMESTAMP_IA")
+ "The special properties valid in Org-mode.
+
+These are properties that are not defined in the property drawer,
+but in some other way.")
+
+(defconst org-default-properties
+ '("ARCHIVE" "CATEGORY" "SUMMARY" "DESCRIPTION"
+ "LOCATION" "LOGGING" "COLUMNS")
+ "Some properties that are used by Org-mode for various purposes.
+Being in this list makes sure that they are offered for completion.")
+
+(defconst org-property-start-re "^[ \t]*:PROPERTIES:[ \t]*$"
+ "Regular expression matching the first line of a property drawer.")
+
+(defconst org-property-end-re "^[ \t]*:END:[ \t]*$"
+ "Regular expression matching the first line of a property drawer.")
+
+(defun org-property-action ()
+ "Do an action on properties."
+ (interactive)
+ (let (c)
+ (org-at-property-p)
+ (message "Property Action: [s]et [d]elete [D]elete globally [c]ompute")
+ (setq c (read-char-exclusive))
+ (cond
+ ((equal c ?s)
+ (call-interactively 'org-set-property))
+ ((equal c ?d)
+ (call-interactively 'org-delete-property))
+ ((equal c ?D)
+ (call-interactively 'org-delete-property-globally))
+ ((equal c ?c)
+ (call-interactively 'org-compute-property-at-point))
+ (t (error "No such property action %c" c)))))
+
+(defun org-at-property-p ()
+ "Is the cursor in a property line?"
+ ;; FIXME: Does not check if we are actually in the drawer.
+ ;; FIXME: also returns true on any drawers.....
+ ;; This is used by C-c C-c for property action.
+ (save-excursion
+ (beginning-of-line 1)
+ (looking-at (org-re "^[ \t]*\\(:\\([[:alpha:]][[:alnum:]_-]*\\):\\)[ \t]*\\(.*\\)"))))
+
+(defmacro org-with-point-at (pom &rest body)
+ "Move to buffer and point of point-or-marker POM for the duration of BODY."
+ (declare (indent 1) (debug t))
+ `(save-excursion
+ (if (markerp pom) (set-buffer (marker-buffer pom)))
+ (save-excursion
+ (goto-char (or pom (point)))
+ ,@body)))
+
+(defun org-get-property-block (&optional beg end force)
+ "Return the (beg . end) range of the body of the property drawer.
+BEG and END can be beginning and end of subtree, if not given
+they will be found.
+If the drawer does not exist and FORCE is non-nil, create the drawer."
+ (catch 'exit
+ (save-excursion
+ (let* ((beg (or beg (progn (org-back-to-heading t) (point))))
+ (end (or end (progn (outline-next-heading) (point)))))
+ (goto-char beg)
+ (if (re-search-forward org-property-start-re end t)
+ (setq beg (1+ (match-end 0)))
+ (if force
+ (save-excursion
+ (org-insert-property-drawer)
+ (setq end (progn (outline-next-heading) (point))))
+ (throw 'exit nil))
+ (goto-char beg)
+ (if (re-search-forward org-property-start-re end t)
+ (setq beg (1+ (match-end 0)))))
+ (if (re-search-forward org-property-end-re end t)
+ (setq end (match-beginning 0))
+ (or force (throw 'exit nil))
+ (goto-char beg)
+ (setq end beg)
+ (org-indent-line-function)
+ (insert ":END:\n"))
+ (cons beg end)))))
+
+(defun org-entry-properties (&optional pom which)
+ "Get all properties of the entry at point-or-marker POM.
+This includes the TODO keyword, the tags, time strings for deadline,
+scheduled, and clocking, and any additional properties defined in the
+entry. The return value is an alist, keys may occur multiple times
+if the property key was used several times.
+POM may also be nil, in which case the current entry is used.
+If WHICH is nil or `all', get all properties. If WHICH is
+`special' or `standard', only get that subclass."
+ (setq which (or which 'all))
+ (org-with-point-at pom
+ (let ((clockstr (substring org-clock-string 0 -1))
+ (excluded '("TODO" "TAGS" "ALLTAGS" "PRIORITY"))
+ beg end range props sum-props key value string clocksum)
+ (save-excursion
+ (when (condition-case nil (org-back-to-heading t) (error nil))
+ (setq beg (point))
+ (setq sum-props (get-text-property (point) 'org-summaries))
+ (setq clocksum (get-text-property (point) :org-clock-minutes))
+ (outline-next-heading)
+ (setq end (point))
+ (when (memq which '(all special))
+ ;; Get the special properties, like TODO and tags
+ (goto-char beg)
+ (when (and (looking-at org-todo-line-regexp) (match-end 2))
+ (push (cons "TODO" (org-match-string-no-properties 2)) props))
+ (when (looking-at org-priority-regexp)
+ (push (cons "PRIORITY" (org-match-string-no-properties 2)) props))
+ (when (and (setq value (org-get-tags-string))
+ (string-match "\\S-" value))
+ (push (cons "TAGS" value) props))
+ (when (setq value (org-get-tags-at))
+ (push (cons "ALLTAGS" (concat ":" (mapconcat 'identity value ":") ":"))
+ props))
+ (while (re-search-forward org-maybe-keyword-time-regexp end t)
+ (setq key (if (match-end 1) (substring (org-match-string-no-properties 1) 0 -1))
+ string (if (equal key clockstr)
+ (org-no-properties
+ (org-trim
+ (buffer-substring
+ (match-beginning 3) (goto-char (point-at-eol)))))
+ (substring (org-match-string-no-properties 3) 1 -1)))
+ (unless key
+ (if (= (char-after (match-beginning 3)) ?\[)
+ (setq key "TIMESTAMP_IA")
+ (setq key "TIMESTAMP")))
+ (when (or (equal key clockstr) (not (assoc key props)))
+ (push (cons key string) props)))
+
+ )
+
+ (when (memq which '(all standard))
+ ;; Get the standard properties, like :PORP: ...
+ (setq range (org-get-property-block beg end))
+ (when range
+ (goto-char (car range))
+ (while (re-search-forward
+ (org-re "^[ \t]*:\\([[:alpha:]][[:alnum:]_-]*\\):[ \t]*\\(\\S-.*\\)?")
+ (cdr range) t)
+ (setq key (org-match-string-no-properties 1)
+ value (org-trim (or (org-match-string-no-properties 2) "")))
+ (unless (member key excluded)
+ (push (cons key (or value "")) props)))))
+ (if clocksum
+ (push (cons "CLOCKSUM"
+ (org-column-number-to-string (/ (float clocksum) 60.)
+ 'add_times))
+ props))
+ (append sum-props (nreverse props)))))))
+
+(defun org-entry-get (pom property &optional inherit)
+ "Get value of PROPERTY for entry at point-or-marker POM.
+If INHERIT is non-nil and the entry does not have the property,
+then also check higher levels of the hierarchy.
+If the property is present but empty, the return value is the empty string.
+If the property is not present at all, nil is returned."
+ (org-with-point-at pom
+ (if inherit
+ (org-entry-get-with-inheritance property)
+ (if (member property org-special-properties)
+ ;; We need a special property. Use brute force, get all properties.
+ (cdr (assoc property (org-entry-properties nil 'special)))
+ (let ((range (org-get-property-block)))
+ (if (and range
+ (goto-char (car range))
+ (re-search-forward
+ (concat "^[ \t]*:" property ":[ \t]*\\(.*\\S-\\)?")
+ (cdr range) t))
+ ;; Found the property, return it.
+ (if (match-end 1)
+ (org-match-string-no-properties 1)
+ "")))))))
+
+(defun org-entry-delete (pom property)
+ "Delete the property PROPERTY from entry at point-or-marker POM."
+ (org-with-point-at pom
+ (if (member property org-special-properties)
+ nil ; cannot delete these properties.
+ (let ((range (org-get-property-block)))
+ (if (and range
+ (goto-char (car range))
+ (re-search-forward
+ (concat "^[ \t]*:" property ":[ \t]*\\(.*\\S-\\)")
+ (cdr range) t))
+ (progn
+ (delete-region (match-beginning 0) (1+ (point-at-eol)))
+ t)
+ nil)))))
+
+;; Multi-values properties are properties that contain multiple values
+;; These values are assumed to be single words, separated by whitespace.
+(defun org-entry-add-to-multivalued-property (pom property value)
+ "Add VALUE to the words in the PROPERTY in entry at point-or-marker POM."
+ (let* ((old (org-entry-get pom property))
+ (values (and old (org-split-string old "[ \t]"))))
+ (unless (member value values)
+ (setq values (cons value values))
+ (org-entry-put pom property
+ (mapconcat 'identity values " ")))))
+
+(defun org-entry-remove-from-multivalued-property (pom property value)
+ "Remove VALUE from words in the PROPERTY in entry at point-or-marker POM."
+ (let* ((old (org-entry-get pom property))
+ (values (and old (org-split-string old "[ \t]"))))
+ (when (member value values)
+ (setq values (delete value values))
+ (org-entry-put pom property
+ (mapconcat 'identity values " ")))))
+
+(defun org-entry-member-in-multivalued-property (pom property value)
+ "Is VALUE one of the words in the PROPERTY in entry at point-or-marker POM?"
+ (let* ((old (org-entry-get pom property))
+ (values (and old (org-split-string old "[ \t]"))))
+ (member value values)))
+
+(defvar org-entry-property-inherited-from (make-marker))
+
+(defun org-entry-get-with-inheritance (property)
+ "Get entry property, and search higher levels if not present."
+ (let (tmp)
+ (save-excursion
+ (save-restriction
+ (widen)
+ (catch 'ex
+ (while t
+ (when (setq tmp (org-entry-get nil property))
+ (org-back-to-heading t)
+ (move-marker org-entry-property-inherited-from (point))
+ (throw 'ex tmp))
+ (or (org-up-heading-safe) (throw 'ex nil)))))
+ (or tmp (cdr (assoc property org-local-properties))
+ (cdr (assoc property org-global-properties))))))
+
+(defun org-entry-put (pom property value)
+ "Set PROPERTY to VALUE for entry at point-or-marker POM."
+ (org-with-point-at pom
+ (org-back-to-heading t)
+ (let ((beg (point)) (end (save-excursion (outline-next-heading) (point)))
+ range)
+ (cond
+ ((equal property "TODO")
+ (when (and (stringp value) (string-match "\\S-" value)
+ (not (member value org-todo-keywords-1)))
+ (error "\"%s\" is not a valid TODO state" value))
+ (if (or (not value)
+ (not (string-match "\\S-" value)))
+ (setq value 'none))
+ (org-todo value)
+ (org-set-tags nil 'align))
+ ((equal property "PRIORITY")
+ (org-priority (if (and value (stringp value) (string-match "\\S-" value))
+ (string-to-char value) ?\ ))
+ (org-set-tags nil 'align))
+ ((equal property "SCHEDULED")
+ (if (re-search-forward org-scheduled-time-regexp end t)
+ (cond
+ ((eq value 'earlier) (org-timestamp-change -1 'day))
+ ((eq value 'later) (org-timestamp-change 1 'day))
+ (t (call-interactively 'org-schedule)))
+ (call-interactively 'org-schedule)))
+ ((equal property "DEADLINE")
+ (if (re-search-forward org-deadline-time-regexp end t)
+ (cond
+ ((eq value 'earlier) (org-timestamp-change -1 'day))
+ ((eq value 'later) (org-timestamp-change 1 'day))
+ (t (call-interactively 'org-deadline)))
+ (call-interactively 'org-deadline)))
+ ((member property org-special-properties)
+ (error "The %s property can not yet be set with `org-entry-put'"
+ property))
+ (t ; a non-special property
+ (let ((buffer-invisibility-spec (org-inhibit-invisibility))) ; Emacs 21
+ (setq range (org-get-property-block beg end 'force))
+ (goto-char (car range))
+ (if (re-search-forward
+ (concat "^[ \t]*:" property ":\\(.*\\)") (cdr range) t)
+ (progn
+ (delete-region (match-beginning 1) (match-end 1))
+ (goto-char (match-beginning 1)))
+ (goto-char (cdr range))
+ (insert "\n")
+ (backward-char 1)
+ (org-indent-line-function)
+ (insert ":" property ":"))
+ (and value (insert " " value))
+ (org-indent-line-function)))))))
+
+(defun org-buffer-property-keys (&optional include-specials include-defaults include-columns)
+ "Get all property keys in the current buffer.
+With INCLUDE-SPECIALS, also list the special properties that relect things
+like tags and TODO state.
+With INCLUDE-DEFAULTS, also include properties that has special meaning
+internally: ARCHIVE, CATEGORY, SUMMARY, DESCRIPTION, LOCATION, and LOGGING.
+With INCLUDE-COLUMNS, also include property names given in COLUMN
+formats in the current buffer."
+ (let (rtn range cfmt cols s p)
+ (save-excursion
+ (save-restriction
+ (widen)
+ (goto-char (point-min))
+ (while (re-search-forward org-property-start-re nil t)
+ (setq range (org-get-property-block))
+ (goto-char (car range))
+ (while (re-search-forward
+ (org-re "^[ \t]*:\\([-[:alnum:]_]+\\):")
+ (cdr range) t)
+ (add-to-list 'rtn (org-match-string-no-properties 1)))
+ (outline-next-heading))))
+
+ (when include-specials
+ (setq rtn (append org-special-properties rtn)))
+
+ (when include-defaults
+ (mapc (lambda (x) (add-to-list 'rtn x)) org-default-properties))
+
+ (when include-columns
+ (save-excursion
+ (save-restriction
+ (widen)
+ (goto-char (point-min))
+ (while (re-search-forward
+ "^\\(#\\+COLUMNS:\\|[ \t]*:COLUMNS:\\)[ \t]*\\(.*\\)"
+ nil t)
+ (setq cfmt (match-string 2) s 0)
+ (while (string-match (org-re "%[0-9]*\\([-[:alnum:]_]+\\)")
+ cfmt s)
+ (setq s (match-end 0)
+ p (match-string 1 cfmt))
+ (unless (or (equal p "ITEM")
+ (member p org-special-properties))
+ (add-to-list 'rtn (match-string 1 cfmt))))))))
+
+ (sort rtn (lambda (a b) (string< (upcase a) (upcase b))))))
+
+(defun org-property-values (key)
+ "Return a list of all values of property KEY."
+ (save-excursion
+ (save-restriction
+ (widen)
+ (goto-char (point-min))
+ (let ((re (concat "^[ \t]*:" key ":[ \t]*\\(\\S-.*\\)"))
+ values)
+ (while (re-search-forward re nil t)
+ (add-to-list 'values (org-trim (match-string 1))))
+ (delete "" values)))))
+
+(defun org-insert-property-drawer ()
+ "Insert a property drawer into the current entry."
+ (interactive)
+ (org-back-to-heading t)
+ (looking-at outline-regexp)
+ (let ((indent (- (match-end 0)(match-beginning 0)))
+ (beg (point))
+ (re (concat "^[ \t]*" org-keyword-time-regexp))
+ end hiddenp)
+ (outline-next-heading)
+ (setq end (point))
+ (goto-char beg)
+ (while (re-search-forward re end t))
+ (setq hiddenp (org-invisible-p))
+ (end-of-line 1)
+ (and (equal (char-after) ?\n) (forward-char 1))
+ (org-skip-over-state-notes)
+ (skip-chars-backward " \t\n\r")
+ (if (eq (char-before) ?*) (forward-char 1))
+ (let ((inhibit-read-only t)) (insert "\n:PROPERTIES:\n:END:"))
+ (beginning-of-line 0)
+ (indent-to-column indent)
+ (beginning-of-line 2)
+ (indent-to-column indent)
+ (beginning-of-line 0)
+ (if hiddenp
+ (save-excursion
+ (org-back-to-heading t)
+ (hide-entry))
+ (org-flag-drawer t))))
+
+(defun org-set-property (property value)
+ "In the current entry, set PROPERTY to VALUE.
+When called interactively, this will prompt for a property name, offering
+completion on existing and default properties. And then it will prompt
+for a value, offering competion either on allowed values (via an inherited
+xxx_ALL property) or on existing values in other instances of this property
+in the current file."
+ (interactive
+ (let* ((prop (completing-read
+ "Property: " (mapcar 'list (org-buffer-property-keys nil t t))))
+ (cur (org-entry-get nil prop))
+ (allowed (org-property-get-allowed-values nil prop 'table))
+ (existing (mapcar 'list (org-property-values prop)))
+ (val (if allowed
+ (completing-read "Value: " allowed nil 'req-match)
+ (completing-read
+ (concat "Value" (if (and cur (string-match "\\S-" cur))
+ (concat "[" cur "]") "")
+ ": ")
+ existing nil nil "" nil cur))))
+ (list prop (if (equal val "") cur val))))
+ (unless (equal (org-entry-get nil property) value)
+ (org-entry-put nil property value)))
+
+(defun org-delete-property (property)
+ "In the current entry, delete PROPERTY."
+ (interactive
+ (let* ((prop (completing-read
+ "Property: " (org-entry-properties nil 'standard))))
+ (list prop)))
+ (message "Property %s %s" property
+ (if (org-entry-delete nil property)
+ "deleted"
+ "was not present in the entry")))
+
+(defun org-delete-property-globally (property)
+ "Remove PROPERTY globally, from all entries."
+ (interactive
+ (let* ((prop (completing-read
+ "Globally remove property: "
+ (mapcar 'list (org-buffer-property-keys)))))
+ (list prop)))
+ (save-excursion
+ (save-restriction
+ (widen)
+ (goto-char (point-min))
+ (let ((cnt 0))
+ (while (re-search-forward
+ (concat "^[ \t]*:" (regexp-quote property) ":.*\n?")
+ nil t)
+ (setq cnt (1+ cnt))
+ (replace-match ""))
+ (message "Property \"%s\" removed from %d entries" property cnt)))))
+
+(defvar org-columns-current-fmt-compiled) ; defined below
+
+(defun org-compute-property-at-point ()
+ "Compute the property at point.
+This looks for an enclosing column format, extracts the operator and
+then applies it to the proerty in the column format's scope."
+ (interactive)
+ (unless (org-at-property-p)
+ (error "Not at a property"))
+ (let ((prop (org-match-string-no-properties 2)))
+ (org-columns-get-format-and-top-level)
+ (unless (nth 3 (assoc prop org-columns-current-fmt-compiled))
+ (error "No operator defined for property %s" prop))
+ (org-columns-compute prop)))
+
+(defun org-property-get-allowed-values (pom property &optional table)
+ "Get allowed values for the property PROPERTY.
+When TABLE is non-nil, return an alist that can directly be used for
+completion."
+ (let (vals)
+ (cond
+ ((equal property "TODO")
+ (setq vals (org-with-point-at pom
+ (append org-todo-keywords-1 '("")))))
+ ((equal property "PRIORITY")
+ (let ((n org-lowest-priority))
+ (while (>= n org-highest-priority)
+ (push (char-to-string n) vals)
+ (setq n (1- n)))))
+ ((member property org-special-properties))
+ (t
+ (setq vals (org-entry-get pom (concat property "_ALL") 'inherit))
+
+ (when (and vals (string-match "\\S-" vals))
+ (setq vals (car (read-from-string (concat "(" vals ")"))))
+ (setq vals (mapcar (lambda (x)
+ (cond ((stringp x) x)
+ ((numberp x) (number-to-string x))
+ ((symbolp x) (symbol-name x))
+ (t "???")))
+ vals)))))
+ (if table (mapcar 'list vals) vals)))
+
+(defun org-property-previous-allowed-value (&optional previous)
+ "Switch to the next allowed value for this property."
+ (interactive)
+ (org-property-next-allowed-value t))
+
+(defun org-property-next-allowed-value (&optional previous)
+ "Switch to the next allowed value for this property."
+ (interactive)
+ (unless (org-at-property-p)
+ (error "Not at a property"))
+ (let* ((key (match-string 2))
+ (value (match-string 3))
+ (allowed (or (org-property-get-allowed-values (point) key)
+ (and (member value '("[ ]" "[-]" "[X]"))
+ '("[ ]" "[X]"))))
+ nval)
+ (unless allowed
+ (error "Allowed values for this property have not been defined"))
+ (if previous (setq allowed (reverse allowed)))
+ (if (member value allowed)
+ (setq nval (car (cdr (member value allowed)))))
+ (setq nval (or nval (car allowed)))
+ (if (equal nval value)
+ (error "Only one allowed value for this property"))
+ (org-at-property-p)
+ (replace-match (concat " :" key ": " nval) t t)
+ (org-indent-line-function)
+ (beginning-of-line 1)
+ (skip-chars-forward " \t")))
+
+(defun org-find-entry-with-id (ident)
+ "Locate the entry that contains the ID property with exact value IDENT.
+IDENT can be a string, a symbol or a number, this function will search for
+the string representation of it.
+Return the position where this entry starts, or nil if there is no such entry."
+ (let ((id (cond
+ ((stringp ident) ident)
+ ((symbol-name ident) (symbol-name ident))
+ ((numberp ident) (number-to-string ident))
+ (t (error "IDENT %s must be a string, symbol or number" ident))))
+ (case-fold-search nil))
+ (save-excursion
+ (save-restriction
+ (widen)
+ (goto-char (point-min))
+ (when (re-search-forward
+ (concat "^[ \t]*:ID:[ \t]+" (regexp-quote id) "[ \t]*$")
+ nil t)
+ (org-back-to-heading)
+ (point))))))
+
+;;; Column View
+
+(defvar org-columns-overlays nil
+ "Holds the list of current column overlays.")
+
+(defvar org-columns-current-fmt nil
+ "Local variable, holds the currently active column format.")
+(defvar org-columns-current-fmt-compiled nil
+ "Local variable, holds the currently active column format.
+This is the compiled version of the format.")
+(defvar org-columns-current-widths nil
+ "Loval variable, holds the currently widths of fields.")
+(defvar org-columns-current-maxwidths nil
+ "Loval variable, holds the currently active maximum column widths.")
+(defvar org-columns-begin-marker (make-marker)
+ "Points to the position where last a column creation command was called.")
+(defvar org-columns-top-level-marker (make-marker)
+ "Points to the position where current columns region starts.")
+
+(defvar org-columns-map (make-sparse-keymap)
+ "The keymap valid in column display.")
+
+(defun org-columns-content ()
+ "Switch to contents view while in columns view."
+ (interactive)
+ (org-overview)
+ (org-content))
+
+(org-defkey org-columns-map "c" 'org-columns-content)
+(org-defkey org-columns-map "o" 'org-overview)
+(org-defkey org-columns-map "e" 'org-columns-edit-value)
+(org-defkey org-columns-map "\C-c\C-t" 'org-columns-todo)
+(org-defkey org-columns-map "\C-c\C-c" 'org-columns-set-tags-or-toggle)
+(org-defkey org-columns-map "\C-c\C-o" 'org-columns-open-link)
+(org-defkey org-columns-map "v" 'org-columns-show-value)
+(org-defkey org-columns-map "q" 'org-columns-quit)
+(org-defkey org-columns-map "r" 'org-columns-redo)
+(org-defkey org-columns-map "g" 'org-columns-redo)
+(org-defkey org-columns-map [left] 'backward-char)
+(org-defkey org-columns-map "\M-b" 'backward-char)
+(org-defkey org-columns-map "a" 'org-columns-edit-allowed)
+(org-defkey org-columns-map "s" 'org-columns-edit-attributes)
+(org-defkey org-columns-map "\M-f" (lambda () (interactive) (goto-char (1+ (point)))))
+(org-defkey org-columns-map [right] (lambda () (interactive) (goto-char (1+ (point)))))
+(org-defkey org-columns-map [(shift right)] 'org-columns-next-allowed-value)
+(org-defkey org-columns-map "n" 'org-columns-next-allowed-value)
+(org-defkey org-columns-map [(shift left)] 'org-columns-previous-allowed-value)
+(org-defkey org-columns-map "p" 'org-columns-previous-allowed-value)
+(org-defkey org-columns-map "<" 'org-columns-narrow)
+(org-defkey org-columns-map ">" 'org-columns-widen)
+(org-defkey org-columns-map [(meta right)] 'org-columns-move-right)
+(org-defkey org-columns-map [(meta left)] 'org-columns-move-left)
+(org-defkey org-columns-map [(shift meta right)] 'org-columns-new)
+(org-defkey org-columns-map [(shift meta left)] 'org-columns-delete)
+
+(easy-menu-define org-columns-menu org-columns-map "Org Column Menu"
+ '("Column"
+ ["Edit property" org-columns-edit-value t]
+ ["Next allowed value" org-columns-next-allowed-value t]
+ ["Previous allowed value" org-columns-previous-allowed-value t]
+ ["Show full value" org-columns-show-value t]
+ ["Edit allowed values" org-columns-edit-allowed t]
+ "--"
+ ["Edit column attributes" org-columns-edit-attributes t]
+ ["Increase column width" org-columns-widen t]
+ ["Decrease column width" org-columns-narrow t]
+ "--"
+ ["Move column right" org-columns-move-right t]
+ ["Move column left" org-columns-move-left t]
+ ["Add column" org-columns-new t]
+ ["Delete column" org-columns-delete t]
+ "--"
+ ["CONTENTS" org-columns-content t]
+ ["OVERVIEW" org-overview t]
+ ["Refresh columns display" org-columns-redo t]
+ "--"
+ ["Open link" org-columns-open-link t]
+ "--"
+ ["Quit" org-columns-quit t]))
+
+(defun org-columns-new-overlay (beg end &optional string face)
+ "Create a new column overlay and add it to the list."
+ (let ((ov (org-make-overlay beg end)))
+ (org-overlay-put ov 'face (or face 'secondary-selection))
+ (org-overlay-display ov string face)
+ (push ov org-columns-overlays)
+ ov))
+
+(defun org-columns-display-here (&optional props)
+ "Overlay the current line with column display."
+ (interactive)
+ (let* ((fmt org-columns-current-fmt-compiled)
+ (beg (point-at-bol))
+ (level-face (save-excursion
+ (beginning-of-line 1)
+ (and (looking-at "\\(\\**\\)\\(\\* \\)")
+ (org-get-level-face 2))))
+ (color (list :foreground
+ (face-attribute (or level-face 'default) :foreground)))
+ props pom property ass width f string ov column val modval)
+ ;; Check if the entry is in another buffer.
+ (unless props
+ (if (eq major-mode 'org-agenda-mode)
+ (setq pom (or (get-text-property (point) 'org-hd-marker)
+ (get-text-property (point) 'org-marker))
+ props (if pom (org-entry-properties pom) nil))
+ (setq props (org-entry-properties nil))))
+ ;; Walk the format
+ (while (setq column (pop fmt))
+ (setq property (car column)
+ ass (if (equal property "ITEM")
+ (cons "ITEM"
+ (save-match-data
+ (org-no-properties
+ (org-remove-tabs
+ (buffer-substring-no-properties
+ (point-at-bol) (point-at-eol))))))
+ (assoc property props))
+ width (or (cdr (assoc property org-columns-current-maxwidths))
+ (nth 2 column)
+ (length property))
+ f (format "%%-%d.%ds | " width width)
+ val (or (cdr ass) "")
+ modval (if (equal property "ITEM")
+ (org-columns-cleanup-item val org-columns-current-fmt-compiled))
+ string (format f (or modval val)))
+ ;; Create the overlay
+ (org-unmodified
+ (setq ov (org-columns-new-overlay
+ beg (setq beg (1+ beg)) string
+ (list color 'org-column)))
+;;; (list (get-text-property (point-at-bol) 'face) 'org-column)))
+ (org-overlay-put ov 'keymap org-columns-map)
+ (org-overlay-put ov 'org-columns-key property)
+ (org-overlay-put ov 'org-columns-value (cdr ass))
+ (org-overlay-put ov 'org-columns-value-modified modval)
+ (org-overlay-put ov 'org-columns-pom pom)
+ (org-overlay-put ov 'org-columns-format f))
+ (if (or (not (char-after beg))
+ (equal (char-after beg) ?\n))
+ (let ((inhibit-read-only t))
+ (save-excursion
+ (goto-char beg)
+ (org-unmodified (insert " ")))))) ;; FIXME: add props and remove later?
+ ;; Make the rest of the line disappear.
+ (org-unmodified
+ (setq ov (org-columns-new-overlay beg (point-at-eol)))
+ (org-overlay-put ov 'invisible t)
+ (org-overlay-put ov 'keymap org-columns-map)
+ (org-overlay-put ov 'intangible t)
+ (push ov org-columns-overlays)
+ (setq ov (org-make-overlay (1- (point-at-eol)) (1+ (point-at-eol))))
+ (org-overlay-put ov 'keymap org-columns-map)
+ (push ov org-columns-overlays)
+ (let ((inhibit-read-only t))
+ (put-text-property (max (point-min) (1- (point-at-bol)))
+ (min (point-max) (1+ (point-at-eol)))
+ 'read-only "Type `e' to edit property")))))
+
+(defvar org-previous-header-line-format nil
+ "The header line format before column view was turned on.")
+(defvar org-columns-inhibit-recalculation nil
+ "Inhibit recomputing of columns on column view startup.")
+
+
+(defvar header-line-format)
+(defun org-columns-display-here-title ()
+ "Overlay the newline before the current line with the table title."
+ (interactive)
+ (let ((fmt org-columns-current-fmt-compiled)
+ string (title "")
+ property width f column str widths)
+ (while (setq column (pop fmt))
+ (setq property (car column)
+ str (or (nth 1 column) property)
+ width (or (cdr (assoc property org-columns-current-maxwidths))
+ (nth 2 column)
+ (length str))
+ widths (push width widths)
+ f (format "%%-%d.%ds | " width width)
+ string (format f str)
+ title (concat title string)))
+ (setq title (concat
+ (org-add-props " " nil 'display '(space :align-to 0))
+ (org-add-props title nil 'face '(:weight bold :underline t))))
+ (org-set-local 'org-previous-header-line-format header-line-format)
+ (org-set-local 'org-columns-current-widths (nreverse widths))
+ (setq header-line-format title)))
+
+(defun org-columns-remove-overlays ()
+ "Remove all currently active column overlays."
+ (interactive)
+ (when (marker-buffer org-columns-begin-marker)
+ (with-current-buffer (marker-buffer org-columns-begin-marker)
+ (when (local-variable-p 'org-previous-header-line-format)
+ (setq header-line-format org-previous-header-line-format)
+ (kill-local-variable 'org-previous-header-line-format))
+ (move-marker org-columns-begin-marker nil)
+ (move-marker org-columns-top-level-marker nil)
+ (org-unmodified
+ (mapc 'org-delete-overlay org-columns-overlays)
+ (setq org-columns-overlays nil)
+ (let ((inhibit-read-only t))
+ (remove-text-properties (point-min) (point-max) '(read-only t)))))))
+
+(defun org-columns-cleanup-item (item fmt)
+ "Remove from ITEM what is a column in the format FMT."
+ (if (not org-complex-heading-regexp)
+ item
+ (when (string-match org-complex-heading-regexp item)
+ (concat
+ (org-add-props (concat (match-string 1 item) " ") nil
+ 'org-whitespace (* 2 (1- (org-reduced-level (- (match-end 1) (match-beginning 1))))))
+ (and (match-end 2) (not (assoc "TODO" fmt)) (concat " " (match-string 2 item)))
+ (and (match-end 3) (not (assoc "PRIORITY" fmt)) (concat " " (match-string 3 item)))
+ " " (match-string 4 item)
+ (and (match-end 5) (not (assoc "TAGS" fmt)) (concat " " (match-string 5 item)))))))
+
+(defun org-columns-show-value ()
+ "Show the full value of the property."
+ (interactive)
+ (let ((value (get-char-property (point) 'org-columns-value)))
+ (message "Value is: %s" (or value ""))))
+
+(defun org-columns-quit ()
+ "Remove the column overlays and in this way exit column editing."
+ (interactive)
+ (org-unmodified
+ (org-columns-remove-overlays)
+ (let ((inhibit-read-only t))
+ (remove-text-properties (point-min) (point-max) '(read-only t))))
+ (when (eq major-mode 'org-agenda-mode)
+ (message
+ "Modification not yet reflected in Agenda buffer, use `r' to refresh")))
+
+(defun org-columns-check-computed ()
+ "Check if this column value is computed.
+If yes, throw an error indicating that changing it does not make sense."
+ (let ((val (get-char-property (point) 'org-columns-value)))
+ (when (and (stringp val)
+ (get-char-property 0 'org-computed val))
+ (error "This value is computed from the entry's children"))))
+
+(defun org-columns-todo (&optional arg)
+ "Change the TODO state during column view."
+ (interactive "P")
+ (org-columns-edit-value "TODO"))
+
+(defun org-columns-set-tags-or-toggle (&optional arg)
+ "Toggle checkbox at point, or set tags for current headline."
+ (interactive "P")
+ (if (string-match "\\`\\[[ xX-]\\]\\'"
+ (get-char-property (point) 'org-columns-value))
+ (org-columns-next-allowed-value)
+ (org-columns-edit-value "TAGS")))
+
+(defun org-columns-edit-value (&optional key)
+ "Edit the value of the property at point in column view.
+Where possible, use the standard interface for changing this line."
+ (interactive)
+ (org-columns-check-computed)
+ (let* ((external-key key)
+ (col (current-column))
+ (key (or key (get-char-property (point) 'org-columns-key)))
+ (value (get-char-property (point) 'org-columns-value))
+ (bol (point-at-bol)) (eol (point-at-eol))
+ (pom (or (get-text-property bol 'org-hd-marker)
+ (point))) ; keep despite of compiler waring
+ (line-overlays
+ (delq nil (mapcar (lambda (x)
+ (and (eq (overlay-buffer x) (current-buffer))
+ (>= (overlay-start x) bol)
+ (<= (overlay-start x) eol)
+ x))
+ org-columns-overlays)))
+ nval eval allowed)
+ (cond
+ ((equal key "CLOCKSUM")
+ (error "This special column cannot be edited"))
+ ((equal key "ITEM")
+ (setq eval '(org-with-point-at pom
+ (org-edit-headline))))
+ ((equal key "TODO")
+ (setq eval '(org-with-point-at pom
+ (let ((current-prefix-arg
+ (if external-key current-prefix-arg '(4))))
+ (call-interactively 'org-todo)))))
+ ((equal key "PRIORITY")
+ (setq eval '(org-with-point-at pom
+ (call-interactively 'org-priority))))
+ ((equal key "TAGS")
+ (setq eval '(org-with-point-at pom
+ (let ((org-fast-tag-selection-single-key
+ (if (eq org-fast-tag-selection-single-key 'expert)
+ t org-fast-tag-selection-single-key)))
+ (call-interactively 'org-set-tags)))))
+ ((equal key "DEADLINE")
+ (setq eval '(org-with-point-at pom
+ (call-interactively 'org-deadline))))
+ ((equal key "SCHEDULED")
+ (setq eval '(org-with-point-at pom
+ (call-interactively 'org-schedule))))
+ (t
+ (setq allowed (org-property-get-allowed-values pom key 'table))
+ (if allowed
+ (setq nval (completing-read "Value: " allowed nil t))
+ (setq nval (read-string "Edit: " value)))
+ (setq nval (org-trim nval))
+ (when (not (equal nval value))
+ (setq eval '(org-entry-put pom key nval)))))
+ (when eval
+ (let ((inhibit-read-only t))
+ (remove-text-properties (max (point-min) (1- bol)) eol '(read-only t))
+ (unwind-protect
+ (progn
+ (setq org-columns-overlays
+ (org-delete-all line-overlays org-columns-overlays))
+ (mapc 'org-delete-overlay line-overlays)
+ (org-columns-eval eval))
+ (org-columns-display-here))))
+ (move-to-column col)
+ (if (and (org-mode-p)
+ (nth 3 (assoc key org-columns-current-fmt-compiled)))
+ (org-columns-update key))))
+
+(defun org-edit-headline () ; FIXME: this is not columns specific
+ "Edit the current headline, the part without TODO keyword, TAGS."
+ (org-back-to-heading)
+ (when (looking-at org-todo-line-regexp)
+ (let ((pre (buffer-substring (match-beginning 0) (match-beginning 3)))
+ (txt (match-string 3))
+ (post "")
+ txt2)
+ (if (string-match (org-re "[ \t]+:[[:alnum:]:_@]+:[ \t]*$") txt)
+ (setq post (match-string 0 txt)
+ txt (substring txt 0 (match-beginning 0))))
+ (setq txt2 (read-string "Edit: " txt))
+ (when (not (equal txt txt2))
+ (beginning-of-line 1)
+ (insert pre txt2 post)
+ (delete-region (point) (point-at-eol))
+ (org-set-tags nil t)))))
+
+(defun org-columns-edit-allowed ()
+ "Edit the list of allowed values for the current property."
+ (interactive)
+ (let* ((key (get-char-property (point) 'org-columns-key))
+ (key1 (concat key "_ALL"))
+ (allowed (org-entry-get (point) key1 t))
+ nval)
+ ;; FIXME: Cover editing TODO, TAGS etc in-buffer settings.????
+ (setq nval (read-string "Allowed: " allowed))
+ (org-entry-put
+ (cond ((marker-position org-entry-property-inherited-from)
+ org-entry-property-inherited-from)
+ ((marker-position org-columns-top-level-marker)
+ org-columns-top-level-marker))
+ key1 nval)))
+
+(defmacro org-no-warnings (&rest body)
+ (cons (if (fboundp 'with-no-warnings) 'with-no-warnings 'progn) body))
+
+(defun org-columns-eval (form)
+ (let (hidep)
+ (save-excursion
+ (beginning-of-line 1)
+ ;; `next-line' is needed here, because it skips invisible line.
+ (condition-case nil (org-no-warnings (next-line 1)) (error nil))
+ (setq hidep (org-on-heading-p 1)))
+ (eval form)
+ (and hidep (hide-entry))))
+
+(defun org-columns-previous-allowed-value ()
+ "Switch to the previous allowed value for this column."
+ (interactive)
+ (org-columns-next-allowed-value t))
+
+(defun org-columns-next-allowed-value (&optional previous)
+ "Switch to the next allowed value for this column."
+ (interactive)
+ (org-columns-check-computed)
+ (let* ((col (current-column))
+ (key (get-char-property (point) 'org-columns-key))
+ (value (get-char-property (point) 'org-columns-value))
+ (bol (point-at-bol)) (eol (point-at-eol))
+ (pom (or (get-text-property bol 'org-hd-marker)
+ (point))) ; keep despite of compiler waring
+ (line-overlays
+ (delq nil (mapcar (lambda (x)
+ (and (eq (overlay-buffer x) (current-buffer))
+ (>= (overlay-start x) bol)
+ (<= (overlay-start x) eol)
+ x))
+ org-columns-overlays)))
+ (allowed (or (org-property-get-allowed-values pom key)
+ (and (memq
+ (nth 4 (assoc key org-columns-current-fmt-compiled))
+ '(checkbox checkbox-n-of-m checkbox-percent))
+ '("[ ]" "[X]"))))
+ nval)
+ (when (equal key "ITEM")
+ (error "Cannot edit item headline from here"))
+ (unless (or allowed (member key '("SCHEDULED" "DEADLINE")))
+ (error "Allowed values for this property have not been defined"))
+ (if (member key '("SCHEDULED" "DEADLINE"))
+ (setq nval (if previous 'earlier 'later))
+ (if previous (setq allowed (reverse allowed)))
+ (if (member value allowed)
+ (setq nval (car (cdr (member value allowed)))))
+ (setq nval (or nval (car allowed)))
+ (if (equal nval value)
+ (error "Only one allowed value for this property")))
+ (let ((inhibit-read-only t))
+ (remove-text-properties (1- bol) eol '(read-only t))
+ (unwind-protect
+ (progn
+ (setq org-columns-overlays
+ (org-delete-all line-overlays org-columns-overlays))
+ (mapc 'org-delete-overlay line-overlays)
+ (org-columns-eval '(org-entry-put pom key nval)))
+ (org-columns-display-here)))
+ (move-to-column col)
+ (if (and (org-mode-p)
+ (nth 3 (assoc key org-columns-current-fmt-compiled)))
+ (org-columns-update key))))
+
+(defun org-verify-version (task)
+ (cond
+ ((eq task 'columns)
+ (if (or (featurep 'xemacs)
+ (< emacs-major-version 22))
+ (error "Emacs 22 is required for the columns feature")))))
+
+(defun org-columns-open-link (&optional arg)
+ (interactive "P")
+ (let ((value (get-char-property (point) 'org-columns-value)))
+ (org-open-link-from-string value arg)))
+
+(defun org-open-link-from-string (s &optional arg)
+ "Open a link in the string S, as if it was in Org-mode."
+ (interactive)
+ (with-temp-buffer
+ (let ((org-inhibit-startup t))
+ (org-mode)
+ (insert s)
+ (goto-char (point-min))
+ (org-open-at-point arg))))
+
+(defun org-columns-get-format-and-top-level ()
+ (let (fmt)
+ (when (condition-case nil (org-back-to-heading) (error nil))
+ (move-marker org-entry-property-inherited-from nil)
+ (setq fmt (org-entry-get nil "COLUMNS" t)))
+ (setq fmt (or fmt org-columns-default-format))
+ (org-set-local 'org-columns-current-fmt fmt)
+ (org-columns-compile-format fmt)
+ (if (marker-position org-entry-property-inherited-from)
+ (move-marker org-columns-top-level-marker
+ org-entry-property-inherited-from)
+ (move-marker org-columns-top-level-marker (point)))
+ fmt))
+
+(defun org-columns ()
+ "Turn on column view on an org-mode file."
+ (interactive)
+ (org-verify-version 'columns)
+ (org-columns-remove-overlays)
+ (move-marker org-columns-begin-marker (point))
+ (let (beg end fmt cache maxwidths)
+ (setq fmt (org-columns-get-format-and-top-level))
+ (save-excursion
+ (goto-char org-columns-top-level-marker)
+ (setq beg (point))
+ (unless org-columns-inhibit-recalculation
+ (org-columns-compute-all))
+ (setq end (or (condition-case nil (org-end-of-subtree t t) (error nil))
+ (point-max)))
+ ;; Get and cache the properties
+ (goto-char beg)
+ (when (assoc "CLOCKSUM" org-columns-current-fmt-compiled)
+ (save-excursion
+ (save-restriction
+ (narrow-to-region beg end)
+ (org-clock-sum))))
+ (while (re-search-forward (concat "^" outline-regexp) end t)
+ (push (cons (org-current-line) (org-entry-properties)) cache))
+ (when cache
+ (setq maxwidths (org-columns-get-autowidth-alist fmt cache))
+ (org-set-local 'org-columns-current-maxwidths maxwidths)
+ (org-columns-display-here-title)
+ (mapc (lambda (x)
+ (goto-line (car x))
+ (org-columns-display-here (cdr x)))
+ cache)))))
+
+(defun org-columns-new (&optional prop title width op fmt &rest rest)
+ "Insert a new column, to the left of the current column."
+ (interactive)
+ (let ((editp (and prop (assoc prop org-columns-current-fmt-compiled)))
+ cell)
+ (setq prop (completing-read
+ "Property: " (mapcar 'list (org-buffer-property-keys t nil t))
+ nil nil prop))
+ (setq title (read-string (concat "Column title [" prop "]: ") (or title prop)))
+ (setq width (read-string "Column width: " (if width (number-to-string width))))
+ (if (string-match "\\S-" width)
+ (setq width (string-to-number width))
+ (setq width nil))
+ (setq fmt (completing-read "Summary [none]: "
+ '(("none") ("add_numbers") ("currency") ("add_times") ("checkbox") ("checkbox-n-of-m") ("checkbox-percent"))
+ nil t))
+ (if (string-match "\\S-" fmt)
+ (setq fmt (intern fmt))
+ (setq fmt nil))
+ (if (eq fmt 'none) (setq fmt nil))
+ (if editp
+ (progn
+ (setcar editp prop)
+ (setcdr editp (list title width nil fmt)))
+ (setq cell (nthcdr (1- (current-column))
+ org-columns-current-fmt-compiled))
+ (setcdr cell (cons (list prop title width nil fmt)
+ (cdr cell))))
+ (org-columns-store-format)
+ (org-columns-redo)))
+
+(defun org-columns-delete ()
+ "Delete the column at point from columns view."
+ (interactive)
+ (let* ((n (current-column))
+ (title (nth 1 (nth n org-columns-current-fmt-compiled))))
+ (when (y-or-n-p
+ (format "Are you sure you want to remove column \"%s\"? " title))
+ (setq org-columns-current-fmt-compiled
+ (delq (nth n org-columns-current-fmt-compiled)
+ org-columns-current-fmt-compiled))
+ (org-columns-store-format)
+ (org-columns-redo)
+ (if (>= (current-column) (length org-columns-current-fmt-compiled))
+ (backward-char 1)))))
+
+(defun org-columns-edit-attributes ()
+ "Edit the attributes of the current column."
+ (interactive)
+ (let* ((n (current-column))
+ (info (nth n org-columns-current-fmt-compiled)))
+ (apply 'org-columns-new info)))
+
+(defun org-columns-widen (arg)
+ "Make the column wider by ARG characters."
+ (interactive "p")
+ (let* ((n (current-column))
+ (entry (nth n org-columns-current-fmt-compiled))
+ (width (or (nth 2 entry)
+ (cdr (assoc (car entry) org-columns-current-maxwidths)))))
+ (setq width (max 1 (+ width arg)))
+ (setcar (nthcdr 2 entry) width)
+ (org-columns-store-format)
+ (org-columns-redo)))
+
+(defun org-columns-narrow (arg)
+ "Make the column nrrower by ARG characters."
+ (interactive "p")
+ (org-columns-widen (- arg)))
+
+(defun org-columns-move-right ()
+ "Swap this column with the one to the right."
+ (interactive)
+ (let* ((n (current-column))
+ (cell (nthcdr n org-columns-current-fmt-compiled))
+ e)
+ (when (>= n (1- (length org-columns-current-fmt-compiled)))
+ (error "Cannot shift this column further to the right"))
+ (setq e (car cell))
+ (setcar cell (car (cdr cell)))
+ (setcdr cell (cons e (cdr (cdr cell))))
+ (org-columns-store-format)
+ (org-columns-redo)
+ (forward-char 1)))
+
+(defun org-columns-move-left ()
+ "Swap this column with the one to the left."
+ (interactive)
+ (let* ((n (current-column)))
+ (when (= n 0)
+ (error "Cannot shift this column further to the left"))
+ (backward-char 1)
+ (org-columns-move-right)
+ (backward-char 1)))
+
+(defun org-columns-store-format ()
+ "Store the text version of the current columns format in appropriate place.
+This is either in the COLUMNS property of the node starting the current column
+display, or in the #+COLUMNS line of the current buffer."
+ (let (fmt (cnt 0))
+ (setq fmt (org-columns-uncompile-format org-columns-current-fmt-compiled))
+ (org-set-local 'org-columns-current-fmt fmt)
+ (if (marker-position org-columns-top-level-marker)
+ (save-excursion
+ (goto-char org-columns-top-level-marker)
+ (if (and (org-at-heading-p)
+ (org-entry-get nil "COLUMNS"))
+ (org-entry-put nil "COLUMNS" fmt)
+ (goto-char (point-min))
+ ;; Overwrite all #+COLUMNS lines....
+ (while (re-search-forward "^#\\+COLUMNS:.*" nil t)
+ (setq cnt (1+ cnt))
+ (replace-match (concat "#+COLUMNS: " fmt) t t))
+ (unless (> cnt 0)
+ (goto-char (point-min))
+ (or (org-on-heading-p t) (outline-next-heading))
+ (let ((inhibit-read-only t))
+ (insert-before-markers "#+COLUMNS: " fmt "\n")))
+ (org-set-local 'org-columns-default-format fmt))))))
+
+(defvar org-overriding-columns-format nil
+ "When set, overrides any other definition.")
+(defvar org-agenda-view-columns-initially nil
+ "When set, switch to columns view immediately after creating the agenda.")
+
+(defun org-agenda-columns ()
+ "Turn on column view in the agenda."
+ (interactive)
+ (org-verify-version 'columns)
+ (org-columns-remove-overlays)
+ (move-marker org-columns-begin-marker (point))
+ (let (fmt cache maxwidths m)
+ (cond
+ ((and (local-variable-p 'org-overriding-columns-format)
+ org-overriding-columns-format)
+ (setq fmt org-overriding-columns-format))
+ ((setq m (get-text-property (point-at-bol) 'org-hd-marker))
+ (setq fmt (org-entry-get m "COLUMNS" t)))
+ ((and (boundp 'org-columns-current-fmt)
+ (local-variable-p 'org-columns-current-fmt)
+ org-columns-current-fmt)
+ (setq fmt org-columns-current-fmt))
+ ((setq m (next-single-property-change (point-min) 'org-hd-marker))
+ (setq m (get-text-property m 'org-hd-marker))
+ (setq fmt (org-entry-get m "COLUMNS" t))))
+ (setq fmt (or fmt org-columns-default-format))
+ (org-set-local 'org-columns-current-fmt fmt)
+ (org-columns-compile-format fmt)
+ (save-excursion
+ ;; Get and cache the properties
+ (goto-char (point-min))
+ (while (not (eobp))
+ (when (setq m (or (get-text-property (point) 'org-hd-marker)
+ (get-text-property (point) 'org-marker)))
+ (push (cons (org-current-line) (org-entry-properties m)) cache))
+ (beginning-of-line 2))
+ (when cache
+ (setq maxwidths (org-columns-get-autowidth-alist fmt cache))
+ (org-set-local 'org-columns-current-maxwidths maxwidths)
+ (org-columns-display-here-title)
+ (mapc (lambda (x)
+ (goto-line (car x))
+ (org-columns-display-here (cdr x)))
+ cache)))))
+
+(defun org-columns-get-autowidth-alist (s cache)
+ "Derive the maximum column widths from the format and the cache."
+ (let ((start 0) rtn)
+ (while (string-match (org-re "%\\([[:alpha:]][[:alnum:]_-]*\\)") s start)
+ (push (cons (match-string 1 s) 1) rtn)
+ (setq start (match-end 0)))
+ (mapc (lambda (x)
+ (setcdr x (apply 'max
+ (mapcar
+ (lambda (y)
+ (length (or (cdr (assoc (car x) (cdr y))) " ")))
+ cache))))
+ rtn)
+ rtn))
+
+(defun org-columns-compute-all ()
+ "Compute all columns that have operators defined."
+ (org-unmodified
+ (remove-text-properties (point-min) (point-max) '(org-summaries t)))
+ (let ((columns org-columns-current-fmt-compiled) col)
+ (while (setq col (pop columns))
+ (when (nth 3 col)
+ (save-excursion
+ (org-columns-compute (car col)))))))
+
+(defun org-columns-update (property)
+ "Recompute PROPERTY, and update the columns display for it."
+ (org-columns-compute property)
+ (let (fmt val pos)
+ (save-excursion
+ (mapc (lambda (ov)
+ (when (equal (org-overlay-get ov 'org-columns-key) property)
+ (setq pos (org-overlay-start ov))
+ (goto-char pos)
+ (when (setq val (cdr (assoc property
+ (get-text-property
+ (point-at-bol) 'org-summaries))))
+ (setq fmt (org-overlay-get ov 'org-columns-format))
+ (org-overlay-put ov 'org-columns-value val)
+ (org-overlay-put ov 'display (format fmt val)))))
+ org-columns-overlays))))
+
+(defun org-columns-compute (property)
+ "Sum the values of property PROPERTY hierarchically, for the entire buffer."
+ (interactive)
+ (let* ((re (concat "^" outline-regexp))
+ (lmax 30) ; Does anyone use deeper levels???
+ (lsum (make-vector lmax 0))
+ (lflag (make-vector lmax nil))
+ (level 0)
+ (ass (assoc property org-columns-current-fmt-compiled))
+ (format (nth 4 ass))
+ (printf (nth 5 ass))
+ (beg org-columns-top-level-marker)
+ last-level val valflag flag end sumpos sum-alist sum str str1 useval)
+ (save-excursion
+ ;; Find the region to compute
+ (goto-char beg)
+ (setq end (condition-case nil (org-end-of-subtree t) (error (point-max))))
+ (goto-char end)
+ ;; Walk the tree from the back and do the computations
+ (while (re-search-backward re beg t)
+ (setq sumpos (match-beginning 0)
+ last-level level
+ level (org-outline-level)
+ val (org-entry-get nil property)
+ valflag (and val (string-match "\\S-" val)))
+ (cond
+ ((< level last-level)
+ ;; put the sum of lower levels here as a property
+ (setq sum (aref lsum last-level) ; current sum
+ flag (aref lflag last-level) ; any valid entries from children?
+ str (org-column-number-to-string sum format printf)
+ str1 (org-add-props (copy-sequence str) nil 'org-computed t 'face 'bold)
+ useval (if flag str1 (if valflag val ""))
+ sum-alist (get-text-property sumpos 'org-summaries))
+ (if (assoc property sum-alist)
+ (setcdr (assoc property sum-alist) useval)
+ (push (cons property useval) sum-alist)
+ (org-unmodified
+ (add-text-properties sumpos (1+ sumpos)
+ (list 'org-summaries sum-alist))))
+ (when val
+ (org-entry-put nil property (if flag str val)))
+ ;; add current to current level accumulator
+ (when (or flag valflag)
+ (aset lsum level (+ (aref lsum level)
+ (if flag sum (org-column-string-to-number
+ (if flag str val) format))))
+ (aset lflag level t))
+ ;; clear accumulators for deeper levels
+ (loop for l from (1+ level) to (1- lmax) do
+ (aset lsum l 0)
+ (aset lflag l nil)))
+ ((>= level last-level)
+ ;; add what we have here to the accumulator for this level
+ (aset lsum level (+ (aref lsum level)
+ (org-column-string-to-number (or val "0") format)))
+ (and valflag (aset lflag level t)))
+ (t (error "This should not happen")))))))
+
+(defun org-columns-redo ()
+ "Construct the column display again."
+ (interactive)
+ (message "Recomputing columns...")
+ (save-excursion
+ (if (marker-position org-columns-begin-marker)
+ (goto-char org-columns-begin-marker))
+ (org-columns-remove-overlays)
+ (if (org-mode-p)
+ (call-interactively 'org-columns)
+ (call-interactively 'org-agenda-columns)))
+ (message "Recomputing columns...done"))
+
+(defun org-columns-not-in-agenda ()
+ (if (eq major-mode 'org-agenda-mode)
+ (error "This command is only allowed in Org-mode buffers")))
+
+
+(defun org-string-to-number (s)
+ "Convert string to number, and interpret hh:mm:ss."
+ (if (not (string-match ":" s))
+ (string-to-number s)
+ (let ((l (nreverse (org-split-string s ":"))) (sum 0.0))
+ (while l
+ (setq sum (+ (string-to-number (pop l)) (/ sum 60))))
+ sum)))
+
+(defun org-column-number-to-string (n fmt &optional printf)
+ "Convert a computed column number to a string value, according to FMT."
+ (cond
+ ((eq fmt 'add_times)
+ (let* ((h (floor n)) (m (floor (+ 0.5 (* 60 (- n h))))))
+ (format "%d:%02d" h m)))
+ ((eq fmt 'checkbox)
+ (cond ((= n (floor n)) "[X]")
+ ((> n 1.) "[-]")
+ (t "[ ]")))
+ ((memq fmt '(checkbox-n-of-m checkbox-percent))
+ (let* ((n1 (floor n)) (n2 (floor (+ .5 (* 1000000 (- n n1))))))
+ (org-nofm-to-completion n1 (+ n2 n1) (eq fmt 'checkbox-percent))))
+ (printf (format printf n))
+ ((eq fmt 'currency)
+ (format "%.2f" n))
+ (t (number-to-string n))))
+
+(defun org-nofm-to-completion (n m &optional percent)
+ (if (not percent)
+ (format "[%d/%d]" n m)
+ (format "[%d%%]"(floor (+ 0.5 (* 100. (/ (* 1.0 n) m)))))))
+
+(defun org-column-string-to-number (s fmt)
+ "Convert a column value to a number that can be used for column computing."
+ (cond
+ ((string-match ":" s)
+ (let ((l (nreverse (org-split-string s ":"))) (sum 0.0))
+ (while l
+ (setq sum (+ (string-to-number (pop l)) (/ sum 60))))
+ sum))
+ ((memq fmt '(checkbox checkbox-n-of-m checkbox-percent))
+ (if (equal s "[X]") 1. 0.000001))
+ (t (string-to-number s))))
+
+(defun org-columns-uncompile-format (cfmt)
+ "Turn the compiled columns format back into a string representation."
+ (let ((rtn "") e s prop title op width fmt printf)
+ (while (setq e (pop cfmt))
+ (setq prop (car e)
+ title (nth 1 e)
+ width (nth 2 e)
+ op (nth 3 e)
+ fmt (nth 4 e)
+ printf (nth 5 e))
+ (cond
+ ((eq fmt 'add_times) (setq op ":"))
+ ((eq fmt 'checkbox) (setq op "X"))
+ ((eq fmt 'checkbox-n-of-m) (setq op "X/"))
+ ((eq fmt 'checkbox-percent) (setq op "X%"))
+ ((eq fmt 'add_numbers) (setq op "+"))
+ ((eq fmt 'currency) (setq op "$")))
+ (if (and op printf) (setq op (concat op ";" printf)))
+ (if (equal title prop) (setq title nil))
+ (setq s (concat "%" (if width (number-to-string width))
+ prop
+ (if title (concat "(" title ")"))
+ (if op (concat "{" op "}"))))
+ (setq rtn (concat rtn " " s)))
+ (org-trim rtn)))
+
+(defun org-columns-compile-format (fmt)
+ "Turn a column format string into an alist of specifications.
+The alist has one entry for each column in the format. The elements of
+that list are:
+property the property
+title the title field for the columns
+width the column width in characters, can be nil for automatic
+operator the operator if any
+format the output format for computed results, derived from operator
+printf a printf format for computed values"
+ (let ((start 0) width prop title op f printf)
+ (setq org-columns-current-fmt-compiled nil)
+ (while (string-match
+ (org-re "%\\([0-9]+\\)?\\([[:alnum:]_-]+\\)\\(?:(\\([^)]+\\))\\)?\\(?:{\\([^}]+\\)}\\)?\\s-*")
+ fmt start)
+ (setq start (match-end 0)
+ width (match-string 1 fmt)
+ prop (match-string 2 fmt)
+ title (or (match-string 3 fmt) prop)
+ op (match-string 4 fmt)
+ f nil
+ printf nil)
+ (if width (setq width (string-to-number width)))
+ (when (and op (string-match ";" op))
+ (setq printf (substring op (match-end 0))
+ op (substring op 0 (match-beginning 0))))
+ (cond
+ ((equal op "+") (setq f 'add_numbers))
+ ((equal op "$") (setq f 'currency))
+ ((equal op ":") (setq f 'add_times))
+ ((equal op "X") (setq f 'checkbox))
+ ((equal op "X/") (setq f 'checkbox-n-of-m))
+ ((equal op "X%") (setq f 'checkbox-percent))
+ )
+ (push (list prop title width op f printf) org-columns-current-fmt-compiled))
+ (setq org-columns-current-fmt-compiled
+ (nreverse org-columns-current-fmt-compiled))))
+
+
+;;; Dynamic block for Column view
+
+(defun org-columns-capture-view (&optional maxlevel skip-empty-rows)
+ "Get the column view of the current buffer or subtree.
+The first optional argument MAXLEVEL sets the level limit. A
+second optional argument SKIP-EMPTY-ROWS tells whether to skip
+empty rows, an empty row being one where all the column view
+specifiers except ITEM are empty. This function returns a list
+containing the title row and all other rows. Each row is a list
+of fields."
+ (save-excursion
+ (let* ((title (mapcar 'cadr org-columns-current-fmt-compiled))
+ (n (length title)) row tbl)
+ (goto-char (point-min))
+ (while (and (re-search-forward "^\\(\\*+\\) " nil t)
+ (or (null maxlevel)
+ (>= maxlevel
+ (if org-odd-levels-only
+ (/ (1+ (length (match-string 1))) 2)
+ (length (match-string 1))))))
+ (when (get-char-property (match-beginning 0) 'org-columns-key)
+ (setq row nil)
+ (loop for i from 0 to (1- n) do
+ (push (or (get-char-property (+ (match-beginning 0) i) 'org-columns-value-modified)
+ (get-char-property (+ (match-beginning 0) i) 'org-columns-value)
+ "")
+ row))
+ (setq row (nreverse row))
+ (unless (and skip-empty-rows
+ (eq 1 (length (delete "" (delete-dups row)))))
+ (push row tbl))))
+ (append (list title 'hline) (nreverse tbl)))))
+
+(defun org-dblock-write:columnview (params)
+ "Write the column view table.
+PARAMS is a property list of parameters:
+
+:width enforce same column widths with <N> specifiers.
+:id the :ID: property of the entry where the columns view
+ should be built, as a string. When `local', call locally.
+ When `global' call column view with the cursor at the beginning
+ of the buffer (usually this means that the whole buffer switches
+ to column view).
+:hlines When t, insert a hline before each item. When a number, insert
+ a hline before each level <= that number.
+:vlines When t, make each column a colgroup to enforce vertical lines.
+:maxlevel When set to a number, don't capture headlines below this level.
+:skip-empty-rows
+ When t, skip rows where all specifiers other than ITEM are empty."
+ (let ((pos (move-marker (make-marker) (point)))
+ (hlines (plist-get params :hlines))
+ (vlines (plist-get params :vlines))
+ (maxlevel (plist-get params :maxlevel))
+ (skip-empty-rows (plist-get params :skip-empty-rows))
+ tbl id idpos nfields tmp)
+ (save-excursion
+ (save-restriction
+ (when (setq id (plist-get params :id))
+ (cond ((not id) nil)
+ ((eq id 'global) (goto-char (point-min)))
+ ((eq id 'local) nil)
+ ((setq idpos (org-find-entry-with-id id))
+ (goto-char idpos))
+ (t (error "Cannot find entry with :ID: %s" id))))
+ (org-columns)
+ (setq tbl (org-columns-capture-view maxlevel skip-empty-rows))
+ (setq nfields (length (car tbl)))
+ (org-columns-quit)))
+ (goto-char pos)
+ (move-marker pos nil)
+ (when tbl
+ (when (plist-get params :hlines)
+ (setq tmp nil)
+ (while tbl
+ (if (eq (car tbl) 'hline)
+ (push (pop tbl) tmp)
+ (if (string-match "\\` *\\(\\*+\\)" (caar tbl))
+ (if (and (not (eq (car tmp) 'hline))
+ (or (eq hlines t)
+ (and (numberp hlines) (<= (- (match-end 1) (match-beginning 1)) hlines))))
+ (push 'hline tmp)))
+ (push (pop tbl) tmp)))
+ (setq tbl (nreverse tmp)))
+ (when vlines
+ (setq tbl (mapcar (lambda (x)
+ (if (eq 'hline x) x (cons "" x)))
+ tbl))
+ (setq tbl (append tbl (list (cons "/" (make-list nfields "<>"))))))
+ (setq pos (point))
+ (insert (org-listtable-to-string tbl))
+ (when (plist-get params :width)
+ (insert "\n|" (mapconcat (lambda (x) (format "<%d>" (max 3 x)))
+ org-columns-current-widths "|")))
+ (goto-char pos)
+ (org-table-align))))
+
+(defun org-listtable-to-string (tbl)
+ "Convert a listtable TBL to a string that contains the Org-mode table.
+The table still need to be alligned. The resulting string has no leading
+and tailing newline characters."
+ (mapconcat
+ (lambda (x)
+ (cond
+ ((listp x)
+ (concat "|" (mapconcat 'identity x "|") "|"))
+ ((eq x 'hline) "|-|")
+ (t (error "Garbage in listtable: %s" x))))
+ tbl "\n"))
+
+(defun org-insert-columns-dblock ()
+ "Create a dynamic block capturing a column view table."
+ (interactive)
+ (let ((defaults '(:name "columnview" :hlines 1))
+ (id (completing-read
+ "Capture columns (local, global, entry with :ID: property) [local]: "
+ (append '(("global") ("local"))
+ (mapcar 'list (org-property-values "ID"))))))
+ (if (equal id "") (setq id 'local))
+ (if (equal id "global") (setq id 'global))
+ (setq defaults (append defaults (list :id id)))
+ (org-create-dblock defaults)
+ (org-update-dblock)))
+
;;;; Timestamps
(defvar org-last-changed-timestamp nil)
(defvar org-time-was-given) ; dynamically scoped parameter
+(defvar org-end-time-was-given) ; dynamically scoped parameter
(defvar org-ts-what) ; dynamically scoped parameter
(defun org-time-stamp (arg)
will represent the current date/time. If there is already a timestamp
at the cursor, it will be modified."
(interactive "P")
- (let (org-time-was-given time)
+ (let* ((ts nil)
+ (default-time
+ ;; Default time is either today, or, when entering a range,
+ ;; the range start.
+ (if (or (and (org-at-timestamp-p t) (setq ts (match-string 0)))
+ (save-excursion
+ (re-search-backward
+ (concat org-ts-regexp "--?-?\\=") ; 1-3 minuses
+ (- (point) 20) t)))
+ (apply 'encode-time (org-parse-time-string (match-string 1)))
+ (current-time)))
+ (default-input (and ts (org-get-compact-tod ts)))
+ org-time-was-given org-end-time-was-given time)
(cond
((and (org-at-timestamp-p)
(eq last-command 'org-time-stamp)
(eq this-command 'org-time-stamp))
(insert "--")
(setq time (let ((this-command this-command))
- (org-read-date arg 'totime)))
+ (org-read-date arg 'totime nil nil default-time default-input)))
(org-insert-time-stamp time (or org-time-was-given arg)))
((org-at-timestamp-p)
(setq time (let ((this-command this-command))
- (org-read-date arg 'totime)))
+ (org-read-date arg 'totime nil nil default-time default-input)))
(when (org-at-timestamp-p) ; just to get the match data
(replace-match "")
(setq org-last-changed-timestamp
- (org-insert-time-stamp time (or org-time-was-given arg))))
+ (org-insert-time-stamp
+ time (or org-time-was-given arg)
+ nil nil nil (list org-end-time-was-given))))
(message "Timestamp updated"))
(t
(setq time (let ((this-command this-command))
- (org-read-date arg 'totime)))
- (org-insert-time-stamp time (or org-time-was-given arg))))))
+ (org-read-date arg 'totime nil nil default-time default-input)))
+ (org-insert-time-stamp time (or org-time-was-given arg)
+ nil nil nil (list org-end-time-was-given))))))
+
+;; FIXME: can we use this for something else????
+;; like computing time differences?????
+(defun org-get-compact-tod (s)
+ (when (string-match "\\(\\([012]?[0-9]\\):\\([0-5][0-9]\\)\\)\\(-\\(\\([012]?[0-9]\\):\\([0-5][0-9]\\)\\)\\)?" s)
+ (let* ((t1 (match-string 1 s))
+ (h1 (string-to-number (match-string 2 s)))
+ (m1 (string-to-number (match-string 3 s)))
+ (t2 (and (match-end 4) (match-string 5 s)))
+ (h2 (and t2 (string-to-number (match-string 6 s))))
+ (m2 (and t2 (string-to-number (match-string 7 s))))
+ dh dm)
+ (if (not t2)
+ t1
+ (setq dh (- h2 h1) dm (- m2 m1))
+ (if (< dm 0) (setq dm (+ dm 60) dh (1- dh)))
+ (concat t1 "+" (number-to-string dh)
+ (if (/= 0 dm) (concat ":" (number-to-string dm))))))))
(defun org-time-stamp-inactive (&optional arg)
"Insert an inactive time stamp.
does not link to the calendar and cannot be changed with the S-cursor keys.
So these are more for recording a certain time/date."
(interactive "P")
- (let (org-time-was-given time)
+ (let (org-time-was-given org-end-time-was-given time)
(setq time (org-read-date arg 'totime))
- (org-insert-time-stamp time (or org-time-was-given arg) 'inactive)))
+ (org-insert-time-stamp time (or org-time-was-given arg) 'inactive
+ nil nil (list org-end-time-was-given))))
(defvar org-date-ovl (org-make-overlay 1 1))
(org-overlay-put org-date-ovl 'face 'org-warning)
(defvar org-ans1) ; dynamically scoped parameter
(defvar org-ans2) ; dynamically scoped parameter
-(defun org-read-date (&optional with-time to-time from-string prompt)
- "Read a date and make things smooth for the user.
+(defvar org-plain-time-of-day-regexp) ; defined below
+
+(defvar org-read-date-overlay nil)
+(defvar org-dcst nil) ; dynamically scoped
+
+(defun org-read-date (&optional with-time to-time from-string prompt
+ default-time default-input)
+ "Read a date, possibly a time, and make things smooth for the user.
The prompt will suggest to enter an ISO date, but you can also enter anything
which will at least partially be understood by `parse-time-string'.
Unrecognized parts of the date will default to the current day, month, year,
-hour and minute. For example,
+hour and minute. If this command is called to replace a timestamp at point,
+of to enter the second timestamp of a range, the default time is taken from the
+existing stamp. For example,
3-2-5 --> 2003-02-05
feb 15 --> currentyear-02-15
sep 12 9 --> 2009-09-12
22 sept 0:34 --> currentyear-09-22 0:34
12 --> currentyear-currentmonth-12
Fri --> nearest Friday (today or later)
- +4 --> four days from today (only if +N is the only thing given)
etc.
+
+Furthermore you can specify a relative date by giving, as the *first* thing
+in the input: a plus/minus sign, a number and a letter [dwmy] to indicate
+change in days weeks, months, years.
+With a single plus or minus, the date is relative to today. With a double
+plus or minus, it is relative to the date in DEFAULT-TIME. E.g.
+ +4d --> four days from today
+ +4 --> same as above
+ +2w --> two weeks from today
+ ++5 --> five days from default date
+
The function understands only English month and weekday abbreviations,
but this can be configured with the variables `parse-time-months' and
`parse-time-weekdays'.
date with the mouse (button 1). The calendar shows a period of three
months. To scroll it to other months, use the keys `>' and `<'.
If you don't like the calendar, turn it off with
- \(setq org-popup-calendar-for-date-prompt nil)
+ \(setq org-read-date-popup-calendar nil)
With optional argument TO-TIME, the date will immediately be converted
to an internal time.
insert a time. Note that when WITH-TIME is not set, you can still
enter a time, and this function will inform the calling routine about
this change. The calling routine may then choose to change the format
-used to insert the time stamp into the buffer to include the time."
+used to insert the time stamp into the buffer to include the time.
+With optional argument FROM-STRING, read from this string instead from
+the user. PROMPT can overwrite the default prompt. DEFAULT-TIME is
+the time/date that is used for everything that is not specified by the
+user."
(require 'parse-time)
(let* ((org-time-stamp-rounding-minutes
- (if (equal with-time '(16)) 0 org-time-stamp-rounding-minutes))
+ (if (equal with-time '(16)) '(0 0) org-time-stamp-rounding-minutes))
+ (org-dcst org-display-custom-times)
(ct (org-current-time))
- (default-time
- ;; Default time is either today, or, when entering a range,
- ;; the range start.
- (if (save-excursion
- (re-search-backward
- (concat org-ts-regexp "--?-?\\=") ; 1-3 minuses
- (- (point) 20) t))
- (apply
- 'encode-time
- (mapcar (lambda(x) (or x 0))
- (parse-time-string (match-string 1))))
- ct))
+ (def (or default-time ct))
+ (defdecode (decode-time def))
+ (dummy (progn
+ (when (< (nth 2 defdecode) org-extend-today-until)
+ (setcar (nthcdr 2 defdecode) -1)
+ (setcar (nthcdr 1 defdecode) 59)
+ (setq def (apply 'encode-time defdecode)
+ defdecode (decode-time def)))))
(calendar-move-hook nil)
+ (calendar-view-diary-initially-flag nil)
(view-diary-entries-initially nil)
+ (calendar-view-holidays-initially-flag nil)
(view-calendar-holidays-initially nil)
(timestr (format-time-string
- (if with-time "%Y-%m-%d %H:%M" "%Y-%m-%d") default-time))
+ (if with-time "%Y-%m-%d %H:%M" "%Y-%m-%d") def))
(prompt (concat (if prompt (concat prompt " ") "")
- (format "YYYY-MM-DD [%s]: " timestr)))
- ans (org-ans0 "") org-ans1 org-ans2 (deltadays 0)
- second minute hour day month year tl wday wday1)
+ (format "Date+time [%s]: " timestr)))
+ ans (org-ans0 "") org-ans1 org-ans2 final)
(cond
(from-string (setq ans from-string))
- (org-popup-calendar-for-date-prompt
+ (org-read-date-popup-calendar
(save-excursion
(save-window-excursion
(calendar)
- (calendar-forward-day (- (time-to-days default-time)
+ (calendar-forward-day (- (time-to-days def)
(calendar-absolute-from-gregorian
(calendar-current-date))))
- (org-eval-in-calendar nil)
+ (org-eval-in-calendar nil t)
(let* ((old-map (current-local-map))
(map (copy-keymap calendar-mode-map))
(minibuffer-local-map (copy-keymap minibuffer-local-map)))
- (define-key map (kbd "RET") 'org-calendar-select)
- (define-key map (if (featurep 'xemacs) [button1] [mouse-1])
+ (org-defkey map (kbd "RET") 'org-calendar-select)
+ (org-defkey map (if (featurep 'xemacs) [button1] [mouse-1])
'org-calendar-select-mouse)
- (define-key map (if (featurep 'xemacs) [button2] [mouse-2])
+ (org-defkey map (if (featurep 'xemacs) [button2] [mouse-2])
'org-calendar-select-mouse)
- (define-key minibuffer-local-map [(meta shift left)]
+ (org-defkey minibuffer-local-map [(meta shift left)]
(lambda () (interactive)
(org-eval-in-calendar '(calendar-backward-month 1))))
- (define-key minibuffer-local-map [(meta shift right)]
+ (org-defkey minibuffer-local-map [(meta shift right)]
(lambda () (interactive)
(org-eval-in-calendar '(calendar-forward-month 1))))
- (define-key minibuffer-local-map [(shift up)]
+ (org-defkey minibuffer-local-map [(meta shift up)]
+ (lambda () (interactive)
+ (org-eval-in-calendar '(calendar-backward-year 1))))
+ (org-defkey minibuffer-local-map [(meta shift down)]
+ (lambda () (interactive)
+ (org-eval-in-calendar '(calendar-forward-year 1))))
+ (org-defkey minibuffer-local-map [(shift up)]
(lambda () (interactive)
(org-eval-in-calendar '(calendar-backward-week 1))))
- (define-key minibuffer-local-map [(shift down)]
+ (org-defkey minibuffer-local-map [(shift down)]
(lambda () (interactive)
(org-eval-in-calendar '(calendar-forward-week 1))))
- (define-key minibuffer-local-map [(shift left)]
+ (org-defkey minibuffer-local-map [(shift left)]
(lambda () (interactive)
(org-eval-in-calendar '(calendar-backward-day 1))))
- (define-key minibuffer-local-map [(shift right)]
+ (org-defkey minibuffer-local-map [(shift right)]
(lambda () (interactive)
(org-eval-in-calendar '(calendar-forward-day 1))))
- (define-key minibuffer-local-map ">"
+ (org-defkey minibuffer-local-map ">"
(lambda () (interactive)
(org-eval-in-calendar '(scroll-calendar-left 1))))
- (define-key minibuffer-local-map "<"
+ (org-defkey minibuffer-local-map "<"
(lambda () (interactive)
(org-eval-in-calendar '(scroll-calendar-right 1))))
(unwind-protect
(progn
(use-local-map map)
- (setq org-ans0 (read-string prompt "" nil nil))
-; (if (not (string-match "\\S-" org-ans0)) (setq org-ans0 nil))
+ (add-hook 'post-command-hook 'org-read-date-display)
+ (setq org-ans0 (read-string prompt default-input nil nil))
;; org-ans0: from prompt
;; org-ans1: from mouse click
;; org-ans2: from calendar motion
(setq ans (concat org-ans0 " " (or org-ans1 org-ans2))))
- (use-local-map old-map))))))
+ (remove-hook 'post-command-hook 'org-read-date-display)
+ (use-local-map old-map)
+ (when org-read-date-overlay
+ (org-delete-overlay org-read-date-overlay)
+ (setq org-read-date-overlay nil)))))))
+
(t ; Naked prompt only
- (setq ans (read-string prompt "" nil timestr))))
- (org-detach-overlay org-date-ovl)
+ (unwind-protect
+ (setq ans (read-string prompt default-input nil timestr))
+ (when org-read-date-overlay
+ (org-delete-overlay org-read-date-overlay)
+ (setq org-read-date-overlay nil)))))
- (if (string-match "^[ \t]*[-+][0-9]+[ \t]*$" org-ans0)
- (setq deltadays (string-to-number ans) ans ""))
+ (setq final (org-read-date-analyze ans def defdecode))
+
+ (if to-time
+ (apply 'encode-time final)
+ (if (and (boundp 'org-time-was-given) org-time-was-given)
+ (format "%04d-%02d-%02d %02d:%02d"
+ (nth 5 final) (nth 4 final) (nth 3 final)
+ (nth 2 final) (nth 1 final))
+ (format "%04d-%02d-%02d" (nth 5 final) (nth 4 final) (nth 3 final))))))
+(defvar def)
+(defvar defdecode)
+(defvar with-time)
+(defun org-read-date-display ()
+ "Display the currrent date prompt interpretation in the minibuffer."
+ (when org-read-date-display-live
+ (when org-read-date-overlay
+ (org-delete-overlay org-read-date-overlay))
+ (let ((p (point)))
+ (end-of-line 1)
+ (while (not (equal (buffer-substring
+ (max (point-min) (- (point) 4)) (point))
+ " "))
+ (insert " "))
+ (goto-char p))
+ (let* ((ans (concat (buffer-substring (point-at-bol) (point-max))
+ " " (or org-ans1 org-ans2)))
+ (org-end-time-was-given nil)
+ (f (org-read-date-analyze ans def defdecode))
+ (fmts (if org-dcst
+ org-time-stamp-custom-formats
+ org-time-stamp-formats))
+ (fmt (if (or with-time
+ (and (boundp 'org-time-was-given) org-time-was-given))
+ (cdr fmts)
+ (car fmts)))
+ (txt (concat "=> " (format-time-string fmt (apply 'encode-time f)))))
+ (when (and org-end-time-was-given
+ (string-match org-plain-time-of-day-regexp txt))
+ (setq txt (concat (substring txt 0 (match-end 0)) "-"
+ org-end-time-was-given
+ (substring txt (match-end 0)))))
+ (setq org-read-date-overlay
+ (make-overlay (1- (point-at-eol)) (point-at-eol)))
+ (org-overlay-display org-read-date-overlay txt 'secondary-selection))))
+
+(defun org-read-date-analyze (ans def defdecode)
+ "Analyze the combined answer of the date prompt."
+ ;; FIXME: cleanup and comment
+ (let (delta deltan deltaw deltadef year month day
+ hour minute second wday pm h2 m2 tl wday1)
+
+ (when (setq delta (org-read-date-get-relative ans (current-time) def))
+ (setq ans (replace-match "" t t ans)
+ deltan (car delta)
+ deltaw (nth 1 delta)
+ deltadef (nth 2 delta)))
+
+ ;; Help matching ISO dates with single digit month ot day, like 2006-8-11.
+ (when (string-match
+ "^ *\\(\\([0-9]+\\)-\\)?\\([0-1]?[0-9]\\)-\\([0-3]?[0-9]\\)\\([^-0-9]\\|$\\)" ans)
+ (setq year (if (match-end 2)
+ (string-to-number (match-string 2 ans))
+ (string-to-number (format-time-string "%Y")))
+ month (string-to-number (match-string 3 ans))
+ day (string-to-number (match-string 4 ans)))
+ (if (< year 100) (setq year (+ 2000 year)))
+ (setq ans (replace-match (format "%04d-%02d-%02d\\5" year month day)
+ t nil ans)))
+ ;; Help matching am/pm times, because `parse-time-string' does not do that.
+ ;; If there is a time with am/pm, and *no* time without it, we convert
+ ;; so that matching will be successful.
+ (loop for i from 1 to 2 do ; twice, for end time as well
+ (when (and (not (string-match "\\(\\`\\|[^+]\\)[012]?[0-9]:[0-9][0-9]\\([ \t\n]\\|$\\)" ans))
+ (string-match "\\([012]?[0-9]\\)\\(:\\([0-5][0-9]\\)\\)?\\(am\\|AM\\|pm\\|PM\\)\\>" ans))
+ (setq hour (string-to-number (match-string 1 ans))
+ minute (if (match-end 3)
+ (string-to-number (match-string 3 ans))
+ 0)
+ pm (equal ?p
+ (string-to-char (downcase (match-string 4 ans)))))
+ (if (and (= hour 12) (not pm))
+ (setq hour 0)
+ (if (and pm (< hour 12)) (setq hour (+ 12 hour))))
+ (setq ans (replace-match (format "%02d:%02d" hour minute)
+ t t ans))))
+
+ ;; Check if a time range is given as a duration
+ (when (string-match "\\([012]?[0-9]\\):\\([0-6][0-9]\\)\\+\\([012]?[0-9]\\)\\(:\\([0-5][0-9]\\)\\)?" ans)
+ (setq hour (string-to-number (match-string 1 ans))
+ h2 (+ hour (string-to-number (match-string 3 ans)))
+ minute (string-to-number (match-string 2 ans))
+ m2 (+ minute (if (match-end 5) (string-to-number (match-string 5 ans))0)))
+ (if (>= m2 60) (setq h2 (1+ h2) m2 (- m2 60)))
+ (setq ans (replace-match (format "%02d:%02d-%02d:%02d" hour minute h2 m2) t t ans)))
+
+ ;; Check if there is a time range
+ (when (boundp 'org-end-time-was-given)
+ (setq org-time-was-given nil)
+ (when (and (string-match org-plain-time-of-day-regexp ans)
+ (match-end 8))
+ (setq org-end-time-was-given (match-string 8 ans))
+ (setq ans (concat (substring ans 0 (match-beginning 7))
+ (substring ans (match-end 7))))))
- (if (string-match
- "^ *\\(\\([0-9]+\\)-\\)?\\([0-1]?[0-9]\\)-\\([0-3]?[0-9]\\)\\([^-0-9]\\|$\\)" ans)
- (progn
- (setq year (if (match-end 2)
- (string-to-number (match-string 2 ans))
- (string-to-number (format-time-string "%Y")))
- month (string-to-number (match-string 3 ans))
- day (string-to-number (match-string 4 ans)))
- (if (< year 100) (setq year (+ 2000 year)))
- (setq ans (replace-match (format "%04d-%02d-%02d\\5" year month day)
- t nil ans))))
(setq tl (parse-time-string ans)
- year (or (nth 5 tl) (string-to-number (format-time-string "%Y" ct)))
- month (or (nth 4 tl) (string-to-number (format-time-string "%m" ct)))
- day (or (nth 3 tl) (string-to-number (format-time-string "%d" ct)))
- hour (or (nth 2 tl) (string-to-number (format-time-string "%H" ct)))
- minute (or (nth 1 tl) (string-to-number (format-time-string "%M" ct)))
+ day (or (nth 3 tl) (nth 3 defdecode))
+ month (or (nth 4 tl)
+ (if (and org-read-date-prefer-future
+ (nth 3 tl) (< (nth 3 tl) (nth 3 defdecode)))
+ (1+ (nth 4 defdecode))
+ (nth 4 defdecode)))
+ year (or (nth 5 tl)
+ (if (and org-read-date-prefer-future
+ (nth 4 tl) (< (nth 4 tl) (nth 4 defdecode)))
+ (1+ (nth 5 defdecode))
+ (nth 5 defdecode)))
+ hour (or (nth 2 tl) (nth 2 defdecode))
+ minute (or (nth 1 tl) (nth 1 defdecode))
second (or (nth 0 tl) 0)
wday (nth 6 tl))
- (setq day (+ day deltadays))
+ (when deltan
+ (unless deltadef
+ (let ((now (decode-time (current-time))))
+ (setq day (nth 3 now) month (nth 4 now) year (nth 5 now))))
+ (cond ((member deltaw '("d" "")) (setq day (+ day deltan)))
+ ((equal deltaw "w") (setq day (+ day (* 7 deltan))))
+ ((equal deltaw "m") (setq month (+ month deltan)))
+ ((equal deltaw "y") (setq year (+ year deltan)))))
(when (and wday (not (nth 3 tl)))
;; Weekday was given, but no day, so pick that day in the week
;; on or after the derived date.
(nth 2 tl))
(setq org-time-was-given t))
(if (< year 100) (setq year (+ 2000 year)))
- (if to-time
- (encode-time second minute hour day month year)
- (if (or (nth 1 tl) (nth 2 tl))
- (format "%04d-%02d-%02d %02d:%02d" year month day hour minute)
- (format "%04d-%02d-%02d" year month day)))))
+ (if (< year 1970) (setq year (nth 5 defdecode))) ; not representable
+ (list second minute hour day month year)))
+
+(defvar parse-time-weekdays)
+
+(defun org-read-date-get-relative (s today default)
+ "Check string S for special relative date string.
+TODAY and DEFAULT are internal times, for today and for a default.
+Return shift list (N what def-flag)
+WHAT is \"d\", \"w\", \"m\", or \"y\" for day, week, month, year.
+N is the number of WHATs to shift.
+DEF-FLAG is t when a double ++ or -- indicates shift relative to
+ the DEFAULT date rather than TODAY."
+ (when (string-match
+ (concat
+ "\\`[ \t]*\\([-+]\\{1,2\\}\\)"
+ "\\([0-9]+\\)?"
+ "\\([dwmy]\\|\\(" (mapconcat 'car parse-time-weekdays "\\|") "\\)\\)?"
+ "\\([ \t]\\|$\\)") s)
+ (let* ((dir (if (match-end 1)
+ (string-to-char (substring (match-string 1 s) -1))
+ ?+))
+ (rel (and (match-end 1) (= 2 (- (match-end 1) (match-beginning 1)))))
+ (n (if (match-end 2) (string-to-number (match-string 2 s)) 1))
+ (what (if (match-end 3) (match-string 3 s) "d"))
+ (wday1 (cdr (assoc (downcase what) parse-time-weekdays)))
+ (date (if rel default today))
+ (wday (nth 6 (decode-time date)))
+ delta)
+ (if wday1
+ (progn
+ (setq delta (mod (+ 7 (- wday1 wday)) 7))
+ (if (= dir ?-) (setq delta (- delta 7)))
+ (if (> n 1) (setq delta (+ delta (* (1- n) (if (= dir ?-) -7 7)))))
+ (list delta "d" rel))
+ (list (* n (if (= dir ?-) -1 1)) what rel)))))
-(defun org-eval-in-calendar (form)
+(defun org-eval-in-calendar (form &optional keepdate)
"Eval FORM in the calendar window and return to current window.
Also, store the cursor date in variable org-ans2."
(let ((sw (selected-window)))
(select-window (get-buffer-window "*Calendar*"))
(eval form)
- (when (calendar-cursor-to-date)
+ (when (and (not keepdate) (calendar-cursor-to-date))
(let* ((date (calendar-cursor-to-date))
(time (encode-time 0 0 0 (nth 1 date) (nth 0 date) (nth 2 date))))
(setq org-ans2 (format-time-string "%Y-%m-%d" time))))
(org-move-overlay org-date-ovl (1- (point)) (1+ (point)) (current-buffer))
(select-window sw)))
+; ;; Update the prompt to show new default date
+; (save-excursion
+; (goto-char (point-min))
+; (when (and org-ans2
+; (re-search-forward "\\[[-0-9]+\\]" nil t)
+; (get-text-property (match-end 0) 'field))
+; (let ((inhibit-read-only t))
+; (replace-match (concat "[" org-ans2 "]") t t)
+; (add-text-properties (point-min) (1+ (match-end 0))
+; (text-properties-at (1+ (point-min)))))))))
+
(defun org-calendar-select ()
"Return to `org-read-date' with the date currently selected.
This is used by `org-read-date' in a temporary keymap for the calendar buffer."
(setq org-ans1 (format-time-string "%Y-%m-%d" time)))
(if (active-minibuffer-window) (exit-minibuffer))))
-(defun org-insert-time-stamp (time &optional with-hm inactive pre post)
+(defun org-insert-time-stamp (time &optional with-hm inactive pre post extra)
"Insert a date stamp for the date given by the internal TIME.
WITH-HM means, use the stamp format that includes the time of the day.
INACTIVE means use square brackets instead of angular ones, so that the
(let ((fmt (funcall (if with-hm 'cdr 'car) org-time-stamp-formats))
stamp)
(if inactive (setq fmt (concat "[" (substring fmt 1 -1) "]")))
- (insert (or pre ""))
- (insert (setq stamp (format-time-string fmt time)))
- (insert (or post ""))
+ (insert-before-markers (or pre ""))
+ (insert-before-markers (setq stamp (format-time-string fmt time)))
+ (when (listp extra)
+ (setq extra (car extra))
+ (if (and (stringp extra)
+ (string-match "\\([0-9]+\\):\\([0-9]+\\)" extra))
+ (setq extra (format "-%02d:%02d"
+ (string-to-number (match-string 1 extra))
+ (string-to-number (match-string 2 extra))))
+ (setq extra nil)))
+ (when extra
+ (backward-char 1)
+ (insert-before-markers extra)
+ (forward-char 1))
+ (insert-before-markers (or post ""))
stamp))
(defun org-toggle-time-stamp-overlays ()
(defun org-display-custom-time (beg end)
"Overlay modified time stamp format over timestamp between BED and END."
- (let* ((t1 (save-match-data
- (org-parse-time-string (buffer-substring beg end) t)))
- (w1 (- end beg))
- (with-hm (and (nth 1 t1) (nth 2 t1)))
- (tf (funcall (if with-hm 'cdr 'car) org-time-stamp-custom-formats))
- (time (org-fix-decoded-time t1))
- (str (org-add-props
+ (let* ((ts (buffer-substring beg end))
+ t1 w1 with-hm tf time str w2 (off 0))
+ (save-match-data
+ (setq t1 (org-parse-time-string ts t))
+ (if (string-match "\\(-[0-9]+:[0-9]+\\)?\\( [.+]?\\+[0-9]+[dwmy]\\)?\\'" ts)
+ (setq off (- (match-end 0) (match-beginning 0)))))
+ (setq end (- end off))
+ (setq w1 (- end beg)
+ with-hm (and (nth 1 t1) (nth 2 t1))
+ tf (funcall (if with-hm 'cdr 'car) org-time-stamp-custom-formats)
+ time (org-fix-decoded-time t1)
+ str (org-add-props
(format-time-string
(substring tf 1 -1) (apply 'encode-time time))
- nil 'mouse-face 'highlight))
- (w2 (length str)))
+ nil 'mouse-face 'highlight)
+ w2 (length str))
(if (not (= w2 w1))
(add-text-properties (1+ beg) (+ 2 beg)
(list 'org-dwidth t 'org-dwidth-n (- w1 w2))))
(defun org-deadline-close (timestamp-string &optional ndays)
"Is the time in TIMESTAMP-STRING close to the current date?"
- (and (< (org-days-to-time timestamp-string)
- (or ndays org-deadline-warning-days))
+ (setq ndays (or ndays (org-get-wdays timestamp-string)))
+ (and (< (org-days-to-time timestamp-string) ndays)
(not (org-entry-is-done-p))))
+(defun org-get-wdays (ts)
+ "Get the deadline lead time appropriate for timestring TS."
+ (cond
+ ((<= org-deadline-warning-days 0)
+ ;; 0 or negative, enforce this value no matter what
+ (- org-deadline-warning-days))
+ ((string-match "-\\([0-9]+\\)\\([dwmy]\\)\\(\\'\\|>\\)" ts)
+ ;; lead time is specified.
+ (floor (* (string-to-number (match-string 1 ts))
+ (cdr (assoc (match-string 2 ts)
+ '(("d" . 1) ("w" . 7)
+ ("m" . 30.4) ("y" . 365.25)))))))
+ ;; go for the default.
+ (t org-deadline-warning-days)))
+
(defun org-calendar-select-mouse (ev)
"Return to `org-read-date' with the date currently selected.
This is used by `org-read-date' in a temporary keymap for the calendar buffer."
(cond
((equal ndays '(4)) 100000)
(ndays (prefix-numeric-value ndays))
- (t org-deadline-warning-days)))
+ (t (abs org-deadline-warning-days))))
(case-fold-search nil)
(regexp (concat "\\<" org-deadline-string " *<\\([^>]+\\)>"))
(callback
(org-occur regexp nil callback)
org-warn-days)))
+(defun org-check-before-date (date)
+ "Check if there are deadlines or scheduled entries before DATE."
+ (interactive (list (org-read-date)))
+ (let ((case-fold-search nil)
+ (regexp (concat "\\<\\(" org-deadline-string
+ "\\|" org-scheduled-string
+ "\\) *<\\([^>]+\\)>"))
+ (callback
+ (lambda () (time-less-p
+ (org-time-string-to-time (match-string 2))
+ (org-time-string-to-time date)))))
+ (message "%d entries before %s"
+ (org-occur regexp nil callback) date)))
+
(defun org-evaluate-time-range (&optional to-buffer)
"Evaluate a time range by computing the difference between start and end.
Normally the result is just printed in the echo area, but with prefix arg
(or
(org-clock-update-time-maybe)
(save-excursion
- (unless (org-at-date-range-p)
+ (unless (org-at-date-range-p t)
(goto-char (point-at-bol))
- (re-search-forward org-tr-regexp (point-at-eol) t))
- (if (not (org-at-date-range-p))
+ (re-search-forward org-tr-regexp-both (point-at-eol) t))
+ (if (not (org-at-date-range-p t))
(error "Not at a time-stamp range, and none found in current line")))
(let* ((ts1 (match-string 1))
(ts2 (match-string 2))
d (floor (+ (/ diff ds) 0.5))
h 0 m 0))
(if (not to-buffer)
- (message (org-make-tdiff-string y d h m))
- (when (org-at-table-p)
- (goto-char match-end)
- (setq align t)
- (and (looking-at " *|") (goto-char (match-end 0))))
+ (message "%s" (org-make-tdiff-string y d h m))
+ (if (org-at-table-p)
+ (progn
+ (goto-char match-end)
+ (setq align t)
+ (and (looking-at " *|") (goto-char (match-end 0))))
+ (goto-char match-end))
(if (looking-at
"\\( *-? *[0-9]+y\\)?\\( *[0-9]+d\\)? *[0-9][0-9]:[0-9][0-9]")
(replace-match ""))
(defun org-time-string-to-time (s)
(apply 'encode-time (org-parse-time-string s)))
+(defun org-time-string-to-absolute (s &optional daynr prefer)
+ "Convert a time stamp to an absolute day number.
+If there is a specifyer for a cyclic time stamp, get the closest date to
+DAYNR."
+ (cond
+ ((and daynr (string-match "\\`%%\\((.*)\\)" s))
+ (if (org-diary-sexp-entry (match-string 1 s) "" date)
+ daynr
+ (+ daynr 1000)))
+ ((and daynr (string-match "\\+[0-9]+[dwmy]" s))
+ (org-closest-date s (if (and (boundp 'daynr) (integerp daynr)) daynr
+ (time-to-days (current-time))) (match-string 0 s)
+ prefer))
+ (t (time-to-days (apply 'encode-time (org-parse-time-string s))))))
+
+(defun org-time-from-absolute (d)
+ "Return the time corresponding to date D.
+D may be an absolute day number, or a calendar-type list (month day year)."
+ (if (numberp d) (setq d (calendar-gregorian-from-absolute d)))
+ (encode-time 0 0 0 (nth 1 d) (car d) (nth 2 d)))
+
+(defun org-calendar-holiday ()
+ "List of holidays, for Diary display in Org-mode."
+ (require 'holidays)
+ (let ((hl (funcall
+ (if (fboundp 'calendar-check-holidays)
+ 'calendar-check-holidays 'check-calendar-holidays) date)))
+ (if hl (mapconcat 'identity hl "; "))))
+
+(defun org-diary-sexp-entry (sexp entry date)
+ "Process a SEXP diary ENTRY for DATE."
+ (require 'diary-lib)
+ (let ((result (if calendar-debug-sexp
+ (let ((stack-trace-on-error t))
+ (eval (car (read-from-string sexp))))
+ (condition-case nil
+ (eval (car (read-from-string sexp)))
+ (error
+ (beep)
+ (message "Bad sexp at line %d in %s: %s"
+ (org-current-line)
+ (buffer-file-name) sexp)
+ (sleep-for 2))))))
+ (cond ((stringp result) result)
+ ((and (consp result)
+ (stringp (cdr result))) (cdr result))
+ (result entry)
+ (t nil))))
+
+(defun org-diary-to-ical-string (frombuf)
+ "Get iCalendar entries from diary entries in buffer FROMBUF.
+This uses the icalendar.el library."
+ (let* ((tmpdir (if (featurep 'xemacs)
+ (temp-directory)
+ temporary-file-directory))
+ (tmpfile (make-temp-name
+ (expand-file-name "orgics" tmpdir)))
+ buf rtn b e)
+ (save-excursion
+ (set-buffer frombuf)
+ (icalendar-export-region (point-min) (point-max) tmpfile)
+ (setq buf (find-buffer-visiting tmpfile))
+ (set-buffer buf)
+ (goto-char (point-min))
+ (if (re-search-forward "^BEGIN:VEVENT" nil t)
+ (setq b (match-beginning 0)))
+ (goto-char (point-max))
+ (if (re-search-backward "^END:VEVENT" nil t)
+ (setq e (match-end 0)))
+ (setq rtn (if (and b e) (concat (buffer-substring b e) "\n") "")))
+ (kill-buffer buf)
+ (kill-buffer frombuf)
+ (delete-file tmpfile)
+ rtn))
+
+(defun org-closest-date (start current change prefer)
+ "Find the date closest to CURRENT that is consistent with START and CHANGE.
+When PREFER is `past' return a date that is either CURRENT or past.
+When PREFER is `future', return a date that is either CURRENT or future."
+ ;; Make the proper lists from the dates
+ (catch 'exit
+ (let ((a1 '(("d" . day) ("w" . week) ("m" . month) ("y" . year)))
+ dn dw sday cday n1 n2
+ d m y y1 y2 date1 date2 nmonths nm ny m2)
+
+ (setq start (org-date-to-gregorian start)
+ current (org-date-to-gregorian
+ (if org-agenda-repeating-timestamp-show-all
+ current
+ (time-to-days (current-time))))
+ sday (calendar-absolute-from-gregorian start)
+ cday (calendar-absolute-from-gregorian current))
+
+ (if (<= cday sday) (throw 'exit sday))
+
+ (if (string-match "\\(\\+[0-9]+\\)\\([dwmy]\\)" change)
+ (setq dn (string-to-number (match-string 1 change))
+ dw (cdr (assoc (match-string 2 change) a1)))
+ (error "Invalid change specifyer: %s" change))
+ (if (eq dw 'week) (setq dw 'day dn (* 7 dn)))
+ (cond
+ ((eq dw 'day)
+ (setq n1 (+ sday (* dn (floor (/ (- cday sday) dn))))
+ n2 (+ n1 dn)))
+ ((eq dw 'year)
+ (setq d (nth 1 start) m (car start) y1 (nth 2 start) y2 (nth 2 current))
+ (setq y1 (+ (* (floor (/ (- y2 y1) dn)) dn) y1))
+ (setq date1 (list m d y1)
+ n1 (calendar-absolute-from-gregorian date1)
+ date2 (list m d (+ y1 (* (if (< n1 cday) 1 -1) dn)))
+ n2 (calendar-absolute-from-gregorian date2)))
+ ((eq dw 'month)
+ ;; approx number of month between the tow dates
+ (setq nmonths (floor (/ (- cday sday) 30.436875)))
+ ;; How often does dn fit in there?
+ (setq d (nth 1 start) m (car start) y (nth 2 start)
+ nm (* dn (max 0 (1- (floor (/ nmonths dn)))))
+ m (+ m nm)
+ ny (floor (/ m 12))
+ y (+ y ny)
+ m (- m (* ny 12)))
+ (while (> m 12) (setq m (- m 12) y (1+ y)))
+ (setq n1 (calendar-absolute-from-gregorian (list m d y)))
+ (setq m2 (+ m dn) y2 y)
+ (if (> m2 12) (setq y2 (1+ y2) m2 (- m2 12)))
+ (setq n2 (calendar-absolute-from-gregorian (list m2 d y2)))
+ (while (< n2 cday)
+ (setq n1 n2 m m2 y y2)
+ (setq m2 (+ m dn) y2 y)
+ (if (> m2 12) (setq y2 (1+ y2) m2 (- m2 12)))
+ (setq n2 (calendar-absolute-from-gregorian (list m2 d y2))))))
+
+ (if org-agenda-repeating-timestamp-show-all
+ (cond
+ ((eq prefer 'past) n1)
+ ((eq prefer 'future) (if (= cday n1) n1 n2))
+ (t (if (> (abs (- cday n1)) (abs (- cday n2))) n2 n1)))
+ (cond
+ ((eq prefer 'past) n1)
+ ((eq prefer 'future) (if (= cday n1) n1 n2))
+ (t (if (= cday n1) n1 n2)))))))
+
+(defun org-date-to-gregorian (date)
+ "Turn any specification of DATE into a gregorian date for the calendar."
+ (cond ((integerp date) (calendar-gregorian-from-absolute date))
+ ((and (listp date) (= (length date) 3)) date)
+ ((stringp date)
+ (setq date (org-parse-time-string date))
+ (list (nth 4 date) (nth 3 date) (nth 5 date)))
+ ((listp date)
+ (list (nth 4 date) (nth 3 date) (nth 5 date)))))
+
(defun org-parse-time-string (s &optional nodefault)
"Parse the standard Org-mode time string.
This should be a lot faster than the normal `parse-time-string'.
If time is not given, defaults to 0:00. However, with optional NODEFAULT,
hour and minute fields will be nil if not given."
- (if (string-match org-ts-regexp1 s)
+ (if (string-match org-ts-regexp0 s)
(list 0
(if (or (match-beginning 8) (not nodefault))
(string-to-number (or (match-string 8 s) "0")))
(ans (or (looking-at tsr)
(save-excursion
(skip-chars-backward "^[<\n\r\t")
- (if (> (point) 1) (backward-char 1))
+ (if (> (point) (point-min)) (backward-char 1))
(and (looking-at tsr)
(> (- (match-end 0) pos) -1))))))
- (and (boundp 'org-ts-what)
+ (and ans
+ (boundp 'org-ts-what)
(setq org-ts-what
(cond
+ ((= pos (match-beginning 0)) 'bracket)
+ ((= pos (1- (match-end 0))) 'bracket)
((org-pos-in-match-range pos 2) 'year)
((org-pos-in-match-range pos 3) 'month)
((org-pos-in-match-range pos 7) 'hour)
((org-pos-in-match-range pos 8) 'minute)
((or (org-pos-in-match-range pos 4)
(org-pos-in-match-range pos 5)) 'day)
+ ((and (> pos (or (match-end 8) (match-end 5)))
+ (< pos (match-end 0)))
+ (- pos (or (match-end 8) (match-end 5))))
(t 'day))))
ans))
+(defun org-toggle-timestamp-type ()
+ "Toggle the type (<active> or [inactive]) of a time stamp."
+ (interactive)
+ (when (org-at-timestamp-p t)
+ (save-excursion
+ (goto-char (match-beginning 0))
+ (insert (if (equal (char-after) ?<) "[" "<")) (delete-char 1)
+ (goto-char (1- (match-end 0)))
+ (insert (if (equal (char-after) ?>) "]" ">")) (delete-char 1))
+ (message "Timestamp is now %sactive"
+ (if (equal (char-before) ?>) "in" ""))))
+
(defun org-timestamp-change (n &optional what)
"Change the date in the time stamp at point.
The date will be changed by N times WHAT. WHAT can be `day', `month',
in the timestamp determines what will be changed."
(let ((pos (point))
with-hm inactive
+ (dm (max (nth 1 org-time-stamp-rounding-minutes) 1))
org-ts-what
+ extra rem
ts time time0)
(if (not (org-at-timestamp-p t))
(error "Not at a timestamp"))
- (if (and (not what) (not (eq org-ts-what 'day))
- org-display-custom-times
- (get-text-property (point) 'display)
- (not (get-text-property (1- (point)) 'display)))
- (setq org-ts-what 'day))
- (setq org-ts-what (or what org-ts-what)
- with-hm (<= (abs (- (cdr org-ts-lengths)
- (- (match-end 0) (match-beginning 0))))
- 1)
- inactive (= (char-after (match-beginning 0)) ?\[)
- ts (match-string 0))
- (replace-match "")
- (setq time0 (org-parse-time-string ts))
- (setq time
- (apply 'encode-time
- (append
- (list (or (car time0) 0))
- (list (+ (if (eq org-ts-what 'minute) n 0) (nth 1 time0)))
- (list (+ (if (eq org-ts-what 'hour) n 0) (nth 2 time0)))
- (list (+ (if (eq org-ts-what 'day) n 0) (nth 3 time0)))
- (list (+ (if (eq org-ts-what 'month) n 0) (nth 4 time0)))
- (list (+ (if (eq org-ts-what 'year) n 0) (nth 5 time0)))
- (nthcdr 6 time0))))
- (if (eq what 'calendar)
- (let ((cal-date
- (save-excursion
- (save-match-data
- (set-buffer "*Calendar*")
- (calendar-cursor-to-date)))))
- (setcar (nthcdr 4 time0) (nth 0 cal-date)) ; month
- (setcar (nthcdr 3 time0) (nth 1 cal-date)) ; day
- (setcar (nthcdr 5 time0) (nth 2 cal-date)) ; year
- (setcar time0 (or (car time0) 0))
- (setcar (nthcdr 1 time0) (or (nth 1 time0) 0))
- (setcar (nthcdr 2 time0) (or (nth 1 time0) 0))
- (setq time (apply 'encode-time time0))))
- (setq org-last-changed-timestamp
- (org-insert-time-stamp time with-hm inactive))
- (org-clock-update-time-maybe)
- (goto-char pos)
- ;; Try to recenter the calendar window, if any
- (if (and org-calendar-follow-timestamp-change
- (get-buffer-window "*Calendar*" t)
- (memq org-ts-what '(day month year)))
- (org-recenter-calendar (time-to-days time)))))
+ (if (and (not what) (eq org-ts-what 'bracket))
+ (org-toggle-timestamp-type)
+ (if (and (not what) (not (eq org-ts-what 'day))
+ org-display-custom-times
+ (get-text-property (point) 'display)
+ (not (get-text-property (1- (point)) 'display)))
+ (setq org-ts-what 'day))
+ (setq org-ts-what (or what org-ts-what)
+ inactive (= (char-after (match-beginning 0)) ?\[)
+ ts (match-string 0))
+ (replace-match "")
+ (if (string-match
+ "\\(\\(-[012][0-9]:[0-5][0-9]\\)?\\( +[.+]?[-+][0-9]+[dwmy]\\)*\\)[]>]"
+ ts)
+ (setq extra (match-string 1 ts)))
+ (if (string-match "^.\\{10\\}.*?[0-9]+:[0-9][0-9]" ts)
+ (setq with-hm t))
+ (setq time0 (org-parse-time-string ts))
+ (when (and (eq org-ts-what 'minute)
+ (eq current-prefix-arg nil))
+ (setq n (* dm (org-no-warnings (signum n))))
+ (when (not (= 0 (setq rem (% (nth 1 time0) dm))))
+ (setcar (cdr time0) (+ (nth 1 time0)
+ (if (> n 0) (- rem) (- dm rem))))))
+ (setq time
+ (encode-time (or (car time0) 0)
+ (+ (if (eq org-ts-what 'minute) n 0) (nth 1 time0))
+ (+ (if (eq org-ts-what 'hour) n 0) (nth 2 time0))
+ (+ (if (eq org-ts-what 'day) n 0) (nth 3 time0))
+ (+ (if (eq org-ts-what 'month) n 0) (nth 4 time0))
+ (+ (if (eq org-ts-what 'year) n 0) (nth 5 time0))
+ (nthcdr 6 time0)))
+ (when (integerp org-ts-what)
+ (setq extra (org-modify-ts-extra extra org-ts-what n dm)))
+ (if (eq what 'calendar)
+ (let ((cal-date (org-get-date-from-calendar)))
+ (setcar (nthcdr 4 time0) (nth 0 cal-date)) ; month
+ (setcar (nthcdr 3 time0) (nth 1 cal-date)) ; day
+ (setcar (nthcdr 5 time0) (nth 2 cal-date)) ; year
+ (setcar time0 (or (car time0) 0))
+ (setcar (nthcdr 1 time0) (or (nth 1 time0) 0))
+ (setcar (nthcdr 2 time0) (or (nth 2 time0) 0))
+ (setq time (apply 'encode-time time0))))
+ (setq org-last-changed-timestamp
+ (org-insert-time-stamp time with-hm inactive nil nil extra))
+ (org-clock-update-time-maybe)
+ (goto-char pos)
+ ;; Try to recenter the calendar window, if any
+ (if (and org-calendar-follow-timestamp-change
+ (get-buffer-window "*Calendar*" t)
+ (memq org-ts-what '(day month year)))
+ (org-recenter-calendar (time-to-days time))))))
+
+;; FIXME: does not yet work for lead times
+(defun org-modify-ts-extra (s pos n dm)
+ "Change the different parts of the lead-time and repeat fields in timestamp."
+ (let ((idx '(("d" . 0) ("w" . 1) ("m" . 2) ("y" . 3) ("d" . -1) ("y" . 4)))
+ ng h m new rem)
+ (when (string-match "\\(-\\([012][0-9]\\):\\([0-5][0-9]\\)\\)?\\( +\\+\\([0-9]+\\)\\([dmwy]\\)\\)?\\( +-\\([0-9]+\\)\\([dmwy]\\)\\)?" s)
+ (cond
+ ((or (org-pos-in-match-range pos 2)
+ (org-pos-in-match-range pos 3))
+ (setq m (string-to-number (match-string 3 s))
+ h (string-to-number (match-string 2 s)))
+ (if (org-pos-in-match-range pos 2)
+ (setq h (+ h n))
+ (setq n (* dm (org-no-warnings (signum n))))
+ (when (not (= 0 (setq rem (% m dm))))
+ (setq m (+ m (if (> n 0) (- rem) (- dm rem)))))
+ (setq m (+ m n)))
+ (if (< m 0) (setq m (+ m 60) h (1- h)))
+ (if (> m 59) (setq m (- m 60) h (1+ h)))
+ (setq h (min 24 (max 0 h)))
+ (setq ng 1 new (format "-%02d:%02d" h m)))
+ ((org-pos-in-match-range pos 6)
+ (setq ng 6 new (car (rassoc (+ n (cdr (assoc (match-string 6 s) idx))) idx))))
+ ((org-pos-in-match-range pos 5)
+ (setq ng 5 new (format "%d" (max 1 (+ n (string-to-number (match-string 5 s)))))))
+
+ ((org-pos-in-match-range pos 9)
+ (setq ng 9 new (car (rassoc (+ n (cdr (assoc (match-string 9 s) idx))) idx))))
+ ((org-pos-in-match-range pos 8)
+ (setq ng 8 new (format "%d" (max 0 (+ n (string-to-number (match-string 8 s))))))))
+
+ (when ng
+ (setq s (concat
+ (substring s 0 (match-beginning ng))
+ new
+ (substring s (match-end ng))))))
+ s))
(defun org-recenter-calendar (date)
"If the calendar is visible, recenter it to DATE."
(interactive "P")
(let ((tsr org-ts-regexp) diff
(calendar-move-hook nil)
+ (calendar-view-holidays-initially-flag nil)
(view-calendar-holidays-initially nil)
+ (calendar-view-diary-initially-flag nil)
(view-diary-entries-initially nil))
(if (or (org-at-timestamp-p)
(save-excursion
(calendar-goto-today)
(if (and diff (not arg)) (calendar-forward-day diff))))
+(defun org-get-date-from-calendar ()
+ "Return a list (month day year) of date at point in calendar."
+ (with-current-buffer "*Calendar*"
+ (save-match-data
+ (calendar-cursor-to-date))))
+
(defun org-date-from-calendar ()
"Insert time stamp corresponding to cursor date in *Calendar* buffer.
If there is already a time stamp at the cursor position, update it."
(interactive)
- (org-timestamp-change 0 'calendar))
+ (if (org-at-timestamp-p t)
+ (org-timestamp-change 0 'calendar)
+ (let ((cal-date (org-get-date-from-calendar)))
+ (org-insert-time-stamp
+ (encode-time 0 0 0 (nth 1 cal-date) (car cal-date) (nth 2 cal-date))))))
+
+(defvar appt-time-msg-list)
+
+;;;###autoload
+(defun org-agenda-to-appt (&optional refresh filter)
+ "Activate appointments found in `org-agenda-files'.
+With a \\[universal-argument] prefix, refresh the list of
+appointements.
+
+If FILTER is t, interactively prompt the user for a regular
+expression, and filter out entries that don't match it.
+
+If FILTER is a string, use this string as a regular expression
+for filtering entries out.
+
+FILTER can also be an alist with the car of each cell being
+either 'headline or 'category. For example:
+
+ '((headline \"IMPORTANT\")
+ (category \"Work\"))
+
+will only add headlines containing IMPORTANT or headlines
+belonging to the \"Work\" category."
+ (interactive "P")
+ (require 'calendar)
+ (if refresh (setq appt-time-msg-list nil))
+ (if (eq filter t)
+ (setq filter (read-from-minibuffer "Regexp filter: ")))
+ (let* ((cnt 0) ; count added events
+ (org-agenda-new-buffers nil)
+ (org-deadline-warning-days 0)
+ (today (org-date-to-gregorian
+ (time-to-days (current-time))))
+ (files (org-agenda-files)) entries file)
+ ;; Get all entries which may contain an appt
+ (while (setq file (pop files))
+ (setq entries
+ (append entries
+ (org-agenda-get-day-entries
+ file today :timestamp :scheduled :deadline))))
+ (setq entries (delq nil entries))
+ ;; Map thru entries and find if we should filter them out
+ (mapc
+ (lambda(x)
+ (let* ((evt (org-trim (get-text-property 1 'txt x)))
+ (cat (get-text-property 1 'org-category x))
+ (tod (get-text-property 1 'time-of-day x))
+ (ok (or (null filter)
+ (and (stringp filter) (string-match filter evt))
+ (and (listp filter)
+ (or (string-match
+ (cadr (assoc 'category filter)) cat)
+ (string-match
+ (cadr (assoc 'headline filter)) evt))))))
+ ;; FIXME: Shall we remove text-properties for the appt text?
+ ;; (setq evt (set-text-properties 0 (length evt) nil evt))
+ (when (and ok tod)
+ (setq tod (number-to-string tod)
+ tod (when (string-match
+ "\\([0-9]\\{1,2\\}\\)\\([0-9]\\{2\\}\\)" tod)
+ (concat (match-string 1 tod) ":"
+ (match-string 2 tod))))
+ (appt-add tod evt)
+ (setq cnt (1+ cnt))))) entries)
+ (org-release-buffers org-agenda-new-buffers)
+ (if (eq cnt 0)
+ (message "No event to add")
+ (message "Added %d event%s for today" cnt (if (> cnt 1) "s" "")))))
+
+;;; The clock for measuring work time.
+
+(defvar org-mode-line-string "")
+(put 'org-mode-line-string 'risky-local-variable t)
+
+(defvar org-mode-line-timer nil)
+(defvar org-clock-heading "")
+(defvar org-clock-start-time "")
-;;; The clock for measuring work time.
+(defun org-update-mode-line ()
+ (let* ((delta (- (time-to-seconds (current-time))
+ (time-to-seconds org-clock-start-time)))
+ (h (floor delta 3600))
+ (m (floor (- delta (* 3600 h)) 60)))
+ (setq org-mode-line-string
+ (propertize (format "-[%d:%02d (%s)]" h m org-clock-heading)
+ 'help-echo "Org-mode clock is running"))
+ (force-mode-line-update)))
(defvar org-clock-marker (make-marker)
"Marker recording the last clock-in.")
+(defvar org-clock-mode-line-entry nil
+ "Information for the modeline about the running clock.")
(defun org-clock-in ()
"Start the clock on the current item.
(let (ts)
(save-excursion
(org-back-to-heading t)
- (beginning-of-line 2)
- (when (and (looking-at (concat "[ \t]*" org-keyword-time-regexp))
- (not (equal (match-string 1) org-clock-string)))
- ;; First line hast scheduling info, move one further
- (beginning-of-line 2)
- (or (bolp) (newline)))
+ (when (and org-clock-in-switch-to-state
+ (not (looking-at (concat outline-regexp "[ \t]*"
+ org-clock-in-switch-to-state
+ "\\>"))))
+ (org-todo org-clock-in-switch-to-state))
+ (if (and org-clock-heading-function
+ (functionp org-clock-heading-function))
+ (setq org-clock-heading (funcall org-clock-heading-function))
+ (if (looking-at org-complex-heading-regexp)
+ (setq org-clock-heading (match-string 4))
+ (setq org-clock-heading "???")))
+ (setq org-clock-heading (propertize org-clock-heading 'face nil))
+ (org-clock-find-position)
+
(insert "\n") (backward-char 1)
(indent-relative)
(insert org-clock-string " ")
+ (setq org-clock-start-time (current-time))
(setq ts (org-insert-time-stamp (current-time) 'with-hm 'inactive))
(move-marker org-clock-marker (point) (buffer-base-buffer))
+ (or global-mode-string (setq global-mode-string '("")))
+ (or (memq 'org-mode-line-string global-mode-string)
+ (setq global-mode-string
+ (append global-mode-string '(org-mode-line-string))))
+ (org-update-mode-line)
+ (setq org-mode-line-timer (run-with-timer 60 60 'org-update-mode-line))
(message "Clock started at %s" ts))))
+(defun org-clock-find-position ()
+ "Find the location where the next clock line should be inserted."
+ (org-back-to-heading t)
+ (catch 'exit
+ (let ((beg (point-at-bol 2)) (end (progn (outline-next-heading) (point)))
+ (re (concat "^[ \t]*" org-clock-string))
+ (cnt 0)
+ first last)
+ (goto-char beg)
+ (when (eobp) (newline) (setq end (max (point) end)))
+ (when (re-search-forward "^[ \t]*:CLOCK:" end t)
+ ;; we seem to have a CLOCK drawer, so go there.
+ (beginning-of-line 2)
+ (throw 'exit t))
+ ;; Lets count the CLOCK lines
+ (goto-char beg)
+ (while (re-search-forward re end t)
+ (setq first (or first (match-beginning 0))
+ last (match-beginning 0)
+ cnt (1+ cnt)))
+ (when (and (integerp org-clock-into-drawer)
+ (>= (1+ cnt) org-clock-into-drawer))
+ ;; Wrap current entries into a new drawer
+ (goto-char last)
+ (beginning-of-line 2)
+ (if (org-at-item-p) (org-end-of-item))
+ (insert ":END:\n")
+ (beginning-of-line 0)
+ (org-indent-line-function)
+ (goto-char first)
+ (insert ":CLOCK:\n")
+ (beginning-of-line 0)
+ (org-indent-line-function)
+ (org-flag-drawer t)
+ (beginning-of-line 2)
+ (throw 'exit nil))
+
+ (goto-char beg)
+ (while (and (looking-at (concat "[ \t]*" org-keyword-time-regexp))
+ (not (equal (match-string 1) org-clock-string)))
+ ;; Planning info, skip to after it
+ (beginning-of-line 2)
+ (or (bolp) (newline)))
+ (when (eq t org-clock-into-drawer)
+ (insert ":CLOCK:\n:END:\n")
+ (beginning-of-line -1)
+ (org-indent-line-function)
+ (org-flag-drawer t)
+ (beginning-of-line 2)
+ (org-indent-line-function)))))
+
(defun org-clock-out (&optional fail-quietly)
"Stop the currently running clock.
If there is no running clock, throw an error, unless FAIL-QUIETLY is set."
(equal (match-string 1) org-clock-string))
(setq ts (match-string 2))
(if fail-quietly (throw 'exit nil) (error "Clock start time is gone")))
- (goto-char org-clock-marker)
+ (goto-char (match-end 0))
+ (delete-region (point) (point-at-eol))
(insert "--")
(setq te (org-insert-time-stamp (current-time) 'with-hm 'inactive))
(setq s (- (time-to-seconds (apply 'encode-time (org-parse-time-string te)))
s (- s (* 60 s)))
(insert " => " (format "%2d:%02d" h m))
(move-marker org-clock-marker nil)
- (org-add-log-maybe 'clock-out)
+ (when org-log-note-clock-out
+ (org-add-log-maybe 'clock-out))
+ (when org-mode-line-timer
+ (cancel-timer org-mode-line-timer)
+ (setq org-mode-line-timer nil))
+ (setq global-mode-string
+ (delq 'org-mode-line-string global-mode-string))
+ (force-mode-line-update)
(message "Clock stopped at %s after HH:MM = %d:%02d" te h m)))))
(defun org-clock-cancel ()
(set-buffer (marker-buffer org-clock-marker))
(goto-char org-clock-marker)
(delete-region (1- (point-at-bol)) (point-at-eol)))
+ (setq global-mode-string
+ (delq 'org-mode-line-string global-mode-string))
+ (force-mode-line-update)
(message "Clock canceled"))
+(defun org-clock-goto (&optional delete-windows)
+ "Go to the currently clocked-in entry."
+ (interactive "P")
+ (if (not (marker-buffer org-clock-marker))
+ (error "No active clock"))
+ (switch-to-buffer-other-window
+ (marker-buffer org-clock-marker))
+ (if delete-windows (delete-other-windows))
+ (goto-char org-clock-marker)
+ (org-show-entry)
+ (org-back-to-heading)
+ (recenter))
+
(defvar org-clock-file-total-minutes nil
"Holds the file total time in minutes, after a call to `org-clock-sum'.")
(make-variable-buffer-local 'org-clock-file-total-minutes)
(let* ((bmp (buffer-modified-p))
(re (concat "^\\(\\*+\\)[ \t]\\|^[ \t]*"
org-clock-string
- "[ \t]*\\(\\[.*?\\]\\)-+\\(\\[.*?\\]\\)"))
+ "[ \t]*\\(?:\\(\\[.*?\\]\\)-+\\(\\[.*?\\]\\)\\|=>[ \t]+\\([0-9]+\\):\\([0-9]+\\)\\)"))
(lmax 30)
(ltimes (make-vector lmax 0))
(t1 0)
(save-excursion
(goto-char (point-max))
(while (re-search-backward re nil t)
- (if (match-end 2)
- ;; A time
- (setq ts (match-string 2)
- te (match-string 3)
- ts (time-to-seconds
- (apply 'encode-time (org-parse-time-string ts)))
- te (time-to-seconds
- (apply 'encode-time (org-parse-time-string te)))
- ts (if tstart (max ts tstart) ts)
- te (if tend (min te tend) te)
- dt (- te ts)
- t1 (if (> dt 0) (+ t1 (floor (/ dt 60))) t1))
- ;; A headline
+ (cond
+ ((match-end 2)
+ ;; Two time stamps
+ (setq ts (match-string 2)
+ te (match-string 3)
+ ts (time-to-seconds
+ (apply 'encode-time (org-parse-time-string ts)))
+ te (time-to-seconds
+ (apply 'encode-time (org-parse-time-string te)))
+ ts (if tstart (max ts tstart) ts)
+ te (if tend (min te tend) te)
+ dt (- te ts)
+ t1 (if (> dt 0) (+ t1 (floor (/ dt 60))) t1)))
+ ((match-end 4)
+ ;; A naket time
+ (setq t1 (+ t1 (string-to-number (match-string 5))
+ (* 60 (string-to-number (match-string 4))))))
+ (t ;; A headline
(setq level (- (match-end 1) (match-beginning 1)))
(when (or (> t1 0) (> (aref ltimes level) 0))
(loop for l from 0 to level do
(loop for l from level to (1- lmax) do
(aset ltimes l 0))
(goto-char (match-beginning 0))
- (put-text-property (point) (point-at-eol) :org-clock-minutes time))))
+ (put-text-property (point) (point-at-eol) :org-clock-minutes time)))))
(setq org-clock-file-total-minutes (aref ltimes 0)))
(set-buffer-modified-p bmp)))
(unless total-only
(save-excursion
(goto-char (point-min))
- (while (setq p (next-single-property-change (point) :org-clock-minutes))
+ (while (or (and (equal (setq p (point)) (point-min))
+ (get-text-property p :org-clock-minutes))
+ (setq p (next-single-property-change
+ (point) :org-clock-minutes)))
(goto-char p)
(when (setq time (get-text-property p :org-clock-minutes))
(org-put-clock-overlay time (funcall outline-level))))
This creates a new overlay and stores it in `org-clock-overlays', so that it
will be easy to remove."
(let* ((c 60) (h (floor (/ time 60))) (m (- time (* 60 h)))
- (l (if level (org-get-legal-level level 0) 0))
+ (l (if level (org-get-valid-level level 0) 0))
(off 0)
ov tx)
(move-to-column c)
(make-string (+ off (max 0 (- c (current-column)))) ?.)
(org-add-props (format "%s %2d:%02d%s"
(make-string l ?*) h m
- (make-string (- 10 l) ?\ ))
+ (make-string (- 16 l) ?\ ))
'(face secondary-selection))
""))
(if (not (featurep 'xemacs))
(defun org-clock-out-if-current ()
"Clock out if the current entry contains the running clock.
-This is used to stop the clock after a TODO entry is marked DONE."
- (when (and (equal state org-done-string)
+This is used to stop the clock after a TODO entry is marked DONE,
+and is only done if the variable `org-clock-out-when-done' is not nil."
+ (when (and org-clock-out-when-done
+ (member state org-done-keywords)
(equal (marker-buffer org-clock-marker) (current-buffer))
(< (point) org-clock-marker)
(> (save-excursion (outline-next-heading) (point))
org-clock-marker))
;; Clock out, but don't accept a logging message for this.
- (let ((org-log-done (if (and (listp org-log-done)
- (member 'clock-out org-log-done))
- '(done)
- org-log-done)))
+ (let ((org-log-note-clock-out nil))
(org-clock-out))))
(add-hook 'org-after-todo-state-change-hook
(when (y-or-n-p "Save changed buffer?")
(save-buffer))))
-(defun org-clock-report ()
+(defun org-clock-report (&optional arg)
"Create a table containing a report about clocked time.
-If the buffer contains lines
-#+BEGIN: clocktable :maxlevel 3 :emphasize nil
-
-#+END: clocktable
-then the table will be inserted between these lines, replacing whatever
-is was there before. If these lines are not in the buffer, the table
-is inserted at point, surrounded by the special lines.
-The BEGIN line can contain parameters. Allowed are:
-:maxlevel The maximum level to be included in the table. Default is 3.
-:emphasize t/nil, if levell 1 and level 2 should be bold/italic in the table."
- (interactive)
+If the cursor is inside an existing clocktable block, then the table
+will be updated. If not, a new clocktable will be inserted.
+When called with a prefix argument, move to the first clock table in the
+buffer and update it."
+ (interactive "P")
(org-remove-clock-overlays)
- (unless (org-find-dblock "clocktable")
+ (when arg
+ (org-find-dblock "clocktable")
+ (org-show-entry))
+ (if (org-in-clocktable-p)
+ (goto-char (org-in-clocktable-p))
(org-create-dblock (list :name "clocktable"
- :maxlevel 2 :emphasize nil)))
+ :maxlevel 2 :scope 'file)))
(org-update-dblock))
+(defun org-in-clocktable-p ()
+ "Check if the cursor is in a clocktable."
+ (let ((pos (point)) start)
+ (save-excursion
+ (end-of-line 1)
+ (and (re-search-backward "^#\\+BEGIN:[ \t]+clocktable" nil t)
+ (setq start (match-beginning 0))
+ (re-search-forward "^#\\+END:.*" nil t)
+ (>= (match-end 0) pos)
+ start))))
+
(defun org-clock-update-time-maybe ()
"If this is a CLOCK line, update it and return t.
Otherwise, return nil."
(defun org-dblock-write:clocktable (params)
"Write the standard clocktable."
- (let ((hlchars '((1 . "*") (2 . ?/)))
- (emph nil)
- (ins (make-marker))
- ipos time h m p level hlc hdl maxlevel
- ts te cc block)
- (setq maxlevel (or (plist-get params :maxlevel) 3)
- emph (plist-get params :emphasize)
- ts (plist-get params :tstart)
- te (plist-get params :tend)
- block (plist-get params :block))
+ (catch 'exit
+ (let* ((hlchars '((1 . "*") (2 . "/")))
+ (ins (make-marker))
+ (total-time nil)
+ (scope (plist-get params :scope))
+ (tostring (plist-get params :tostring))
+ (multifile (plist-get params :multifile))
+ (header (plist-get params :header))
+ (maxlevel (or (plist-get params :maxlevel) 3))
+ (step (plist-get params :step))
+ (emph (plist-get params :emphasize))
+ (ts (plist-get params :tstart))
+ (te (plist-get params :tend))
+ (block (plist-get params :block))
+ (link (plist-get params :link))
+ ipos time h m p level hlc hdl
+ cc beg end pos tbl)
+ (when step
+ (org-clocktable-steps params)
+ (throw 'exit nil))
+ (when block
+ (setq cc (org-clock-special-range block nil t)
+ ts (car cc) te (cdr cc)))
+ (if ts (setq ts (time-to-seconds
+ (apply 'encode-time (org-parse-time-string ts)))))
+ (if te (setq te (time-to-seconds
+ (apply 'encode-time (org-parse-time-string te)))))
+ (move-marker ins (point))
+ (setq ipos (point))
+
+ ;; Get the right scope
+ (setq pos (point))
+ (save-restriction
+ (cond
+ ((not scope))
+ ((eq scope 'file) (widen))
+ ((eq scope 'subtree) (org-narrow-to-subtree))
+ ((eq scope 'tree)
+ (while (org-up-heading-safe))
+ (org-narrow-to-subtree))
+ ((and (symbolp scope) (string-match "^tree\\([0-9]+\\)$"
+ (symbol-name scope)))
+ (setq level (string-to-number (match-string 1 (symbol-name scope))))
+ (catch 'exit
+ (while (org-up-heading-safe)
+ (looking-at outline-regexp)
+ (if (<= (org-reduced-level (funcall outline-level)) level)
+ (throw 'exit nil))))
+ (org-narrow-to-subtree))
+ ((or (listp scope) (eq scope 'agenda))
+ (let* ((files (if (listp scope) scope (org-agenda-files)))
+ (scope 'agenda)
+ (p1 (copy-sequence params))
+ file)
+ (plist-put p1 :tostring t)
+ (plist-put p1 :multifile t)
+ (plist-put p1 :scope 'file)
+ (org-prepare-agenda-buffers files)
+ (while (setq file (pop files))
+ (with-current-buffer (find-buffer-visiting file)
+ (push (org-clocktable-add-file
+ file (org-dblock-write:clocktable p1)) tbl)
+ (setq total-time (+ (or total-time 0)
+ org-clock-file-total-minutes)))))))
+ (goto-char pos)
+
+ (unless (eq scope 'agenda)
+ (org-clock-sum ts te)
+ (goto-char (point-min))
+ (while (setq p (next-single-property-change (point) :org-clock-minutes))
+ (goto-char p)
+ (when (setq time (get-text-property p :org-clock-minutes))
+ (save-excursion
+ (beginning-of-line 1)
+ (when (and (looking-at (org-re "\\(\\*+\\)[ \t]+\\(.*?\\)\\([ \t]+:[[:alnum:]_@:]+:\\)?[ \t]*$"))
+ (setq level (org-reduced-level
+ (- (match-end 1) (match-beginning 1))))
+ (<= level maxlevel))
+ (setq hlc (if emph (or (cdr (assoc level hlchars)) "") "")
+ hdl (if (not link)
+ (match-string 2)
+ (org-make-link-string
+ (format "file:%s::%s"
+ (buffer-file-name)
+ (save-match-data
+ (org-make-org-heading-search-string
+ (match-string 2))))
+ (match-string 2)))
+ h (/ time 60)
+ m (- time (* 60 h)))
+ (if (and (not multifile) (= level 1)) (push "|-" tbl))
+ (push (concat
+ "| " (int-to-string level) "|" hlc hdl hlc " |"
+ (make-string (1- level) ?|)
+ hlc (format "%d:%02d" h m) hlc
+ " |") tbl))))))
+ (setq tbl (nreverse tbl))
+ (if tostring
+ (if tbl (mapconcat 'identity tbl "\n") nil)
+ (goto-char ins)
+ (insert-before-markers
+ (or header
+ (concat
+ "Clock summary at ["
+ (substring
+ (format-time-string (cdr org-time-stamp-formats))
+ 1 -1)
+ "]."
+ (if block
+ (format " Considered range is /%s/." block)
+ "")
+ "\n\n"))
+ (if (eq scope 'agenda) "|File" "")
+ "|L|Headline|Time|\n")
+ (setq total-time (or total-time org-clock-file-total-minutes)
+ h (/ total-time 60)
+ m (- total-time (* 60 h)))
+ (insert-before-markers
+ "|-\n|"
+ (if (eq scope 'agenda) "|" "")
+ "|"
+ "*Total time*| "
+ (format "*%d:%02d*" h m)
+ "|\n|-\n")
+ (setq tbl (delq nil tbl))
+ (if (and (stringp (car tbl)) (> (length (car tbl)) 1)
+ (equal (substring (car tbl) 0 2) "|-"))
+ (pop tbl))
+ (insert-before-markers (mapconcat
+ 'identity (delq nil tbl)
+ (if (eq scope 'agenda) "\n|-\n" "\n")))
+ (backward-delete-char 1)
+ (goto-char ipos)
+ (skip-chars-forward "^|")
+ (org-table-align))))))
+
+(defun org-clocktable-steps (params)
+ (let* ((p1 (copy-sequence params))
+ (ts (plist-get p1 :tstart))
+ (te (plist-get p1 :tend))
+ (step0 (plist-get p1 :step))
+ (step (cdr (assoc step0 '((day . 86400) (week . 604800)))))
+ (block (plist-get p1 :block))
+ cc)
(when block
(setq cc (org-clock-special-range block nil t)
ts (car cc) te (cdr cc)))
(apply 'encode-time (org-parse-time-string ts)))))
(if te (setq te (time-to-seconds
(apply 'encode-time (org-parse-time-string te)))))
- (move-marker ins (point))
- (setq ipos (point))
- (insert-before-markers "Clock summary at ["
- (substring
- (format-time-string (cdr org-time-stamp-formats))
- 1 -1)
- "]."
- (if block
- (format " Considered range is /%s/." block)
- "")
- "\n\n|L|Headline|Time|\n")
- (org-clock-sum ts te)
- (setq h (/ org-clock-file-total-minutes 60)
- m (- org-clock-file-total-minutes (* 60 h)))
- (insert-before-markers "|-\n|0|" "*Total file time*| "
- (format "*%d:%02d*" h m)
- "|\n")
- (goto-char (point-min))
- (while (setq p (next-single-property-change (point) :org-clock-minutes))
- (goto-char p)
- (when (setq time (get-text-property p :org-clock-minutes))
- (save-excursion
- (beginning-of-line 1)
- (when (and (looking-at "\\(\\*+\\)[ \t]+\\(.*?\\)\\([ \t]+:[0-9a-zA-Z_@:]+:\\)?[ \t]*$")
- (setq level (- (match-end 1) (match-beginning 1)))
- (<= level maxlevel))
- (setq hlc (if emph (or (cdr (assoc level hlchars)) "") "")
- hdl (match-string 2)
- h (/ time 60)
- m (- time (* 60 h)))
- (goto-char ins)
- (if (= level 1) (insert-before-markers "|-\n"))
- (insert-before-markers
- "| " (int-to-string level) "|" hlc hdl hlc " |"
- (make-string (1- level) ?|)
- hlc
- (format "%d:%02d" h m)
- hlc
- " |\n")))))
- (goto-char ins)
- (backward-delete-char 1)
- (goto-char ipos)
- (skip-chars-forward "^|")
- (org-table-align)))
+ (plist-put p1 :header "")
+ (plist-put p1 :step nil)
+ (plist-put p1 :block nil)
+ (while (< ts te)
+ (or (bolp) (insert "\n"))
+ (plist-put p1 :tstart (format-time-string
+ (car org-time-stamp-formats)
+ (seconds-to-time ts)))
+ (plist-put p1 :tend (format-time-string
+ (car org-time-stamp-formats)
+ (seconds-to-time (setq ts (+ ts step)))))
+ (insert "\n" (if (eq step0 'day) "Daily report: " "Weekly report starting on: ")
+ (plist-get p1 :tstart) "\n")
+ (org-dblock-write:clocktable p1)
+ (re-search-forward "#\\+END:")
+ (end-of-line 0))))
+
+
+(defun org-clocktable-add-file (file table)
+ (if table
+ (let ((lines (org-split-string table "\n"))
+ (ff (file-name-nondirectory file)))
+ (mapconcat 'identity
+ (mapcar (lambda (x)
+ (if (string-match org-table-dataline-regexp x)
+ (concat "|" ff x)
+ x))
+ lines)
+ "\n"))))
;; FIXME: I don't think anybody uses this, ask David
(defun org-collect-clock-time-entries ()
(defvar org-agenda-follow-mode nil)
(defvar org-agenda-show-log nil)
(defvar org-agenda-redo-command nil)
+(defvar org-agenda-query-string nil)
(defvar org-agenda-mode-hook nil)
(defvar org-agenda-type nil)
(defvar org-agenda-force-single-file nil)
(substitute-key-definition 'undo 'org-agenda-undo
org-agenda-mode-map global-map)
-(define-key org-agenda-mode-map "\C-i" 'org-agenda-goto)
-(define-key org-agenda-mode-map [(tab)] 'org-agenda-goto)
-(define-key org-agenda-mode-map "\C-m" 'org-agenda-switch-to)
-(define-key org-agenda-mode-map "\C-k" 'org-agenda-kill)
-(define-key org-agenda-mode-map "\C-c$" 'org-agenda-archive)
-(define-key org-agenda-mode-map "\C-c\C-x\C-s" 'org-agenda-archive)
-(define-key org-agenda-mode-map "$" 'org-agenda-archive)
-(define-key org-agenda-mode-map "\C-c\C-o" 'org-agenda-open-link)
-(define-key org-agenda-mode-map " " 'org-agenda-show)
-(define-key org-agenda-mode-map "\C-c\C-t" 'org-agenda-todo)
-(define-key org-agenda-mode-map "\C-c\C-xb" 'org-agenda-tree-to-indirect-buffer)
-(define-key org-agenda-mode-map "b" 'org-agenda-tree-to-indirect-buffer)
-(define-key org-agenda-mode-map "o" 'delete-other-windows)
-(define-key org-agenda-mode-map "L" 'org-agenda-recenter)
-(define-key org-agenda-mode-map "t" 'org-agenda-todo)
-(define-key org-agenda-mode-map "a" 'org-agenda-toggle-archive-tag)
-(define-key org-agenda-mode-map ":" 'org-agenda-set-tags)
-(define-key org-agenda-mode-map "." 'org-agenda-goto-today)
-(define-key org-agenda-mode-map "d" 'org-agenda-day-view)
-(define-key org-agenda-mode-map "w" 'org-agenda-week-view)
-(define-key org-agenda-mode-map (org-key 'S-right) 'org-agenda-date-later)
-(define-key org-agenda-mode-map (org-key 'S-left) 'org-agenda-date-earlier)
-(define-key org-agenda-mode-map [?\C-c ?\C-x (right)] 'org-agenda-date-later)
-(define-key org-agenda-mode-map [?\C-c ?\C-x (left)] 'org-agenda-date-earlier)
-
-(define-key org-agenda-mode-map ">" 'org-agenda-date-prompt)
-(define-key org-agenda-mode-map "\C-c\C-s" 'org-agenda-schedule)
-(define-key org-agenda-mode-map "\C-c\C-d" 'org-agenda-deadline)
+(org-defkey org-agenda-mode-map "\C-i" 'org-agenda-goto)
+(org-defkey org-agenda-mode-map [(tab)] 'org-agenda-goto)
+(org-defkey org-agenda-mode-map "\C-m" 'org-agenda-switch-to)
+(org-defkey org-agenda-mode-map "\C-k" 'org-agenda-kill)
+(org-defkey org-agenda-mode-map "\C-c$" 'org-agenda-archive)
+(org-defkey org-agenda-mode-map "\C-c\C-x\C-s" 'org-agenda-archive)
+(org-defkey org-agenda-mode-map "$" 'org-agenda-archive)
+(org-defkey org-agenda-mode-map "\C-c\C-o" 'org-agenda-open-link)
+(org-defkey org-agenda-mode-map " " 'org-agenda-show)
+(org-defkey org-agenda-mode-map "\C-c\C-t" 'org-agenda-todo)
+(org-defkey org-agenda-mode-map [(control shift right)] 'org-agenda-todo-nextset)
+(org-defkey org-agenda-mode-map [(control shift left)] 'org-agenda-todo-previousset)
+(org-defkey org-agenda-mode-map "\C-c\C-xb" 'org-agenda-tree-to-indirect-buffer)
+(org-defkey org-agenda-mode-map "b" 'org-agenda-tree-to-indirect-buffer)
+(org-defkey org-agenda-mode-map "o" 'delete-other-windows)
+(org-defkey org-agenda-mode-map "L" 'org-agenda-recenter)
+(org-defkey org-agenda-mode-map "t" 'org-agenda-todo)
+(org-defkey org-agenda-mode-map "a" 'org-agenda-toggle-archive-tag)
+(org-defkey org-agenda-mode-map ":" 'org-agenda-set-tags)
+(org-defkey org-agenda-mode-map "." 'org-agenda-goto-today)
+(org-defkey org-agenda-mode-map "j" 'org-agenda-goto-date)
+(org-defkey org-agenda-mode-map "d" 'org-agenda-day-view)
+(org-defkey org-agenda-mode-map "w" 'org-agenda-week-view)
+(org-defkey org-agenda-mode-map "m" 'org-agenda-month-view)
+(org-defkey org-agenda-mode-map "y" 'org-agenda-year-view)
+(org-defkey org-agenda-mode-map [(shift right)] 'org-agenda-date-later)
+(org-defkey org-agenda-mode-map [(shift left)] 'org-agenda-date-earlier)
+(org-defkey org-agenda-mode-map [?\C-c ?\C-x (right)] 'org-agenda-date-later)
+(org-defkey org-agenda-mode-map [?\C-c ?\C-x (left)] 'org-agenda-date-earlier)
+
+(org-defkey org-agenda-mode-map ">" 'org-agenda-date-prompt)
+(org-defkey org-agenda-mode-map "\C-c\C-s" 'org-agenda-schedule)
+(org-defkey org-agenda-mode-map "\C-c\C-d" 'org-agenda-deadline)
(let ((l '(1 2 3 4 5 6 7 8 9 0)))
- (while l (define-key org-agenda-mode-map
+ (while l (org-defkey org-agenda-mode-map
(int-to-string (pop l)) 'digit-argument)))
-(define-key org-agenda-mode-map "f" 'org-agenda-follow-mode)
-(define-key org-agenda-mode-map "l" 'org-agenda-log-mode)
-(define-key org-agenda-mode-map "D" 'org-agenda-toggle-diary)
-(define-key org-agenda-mode-map "g" 'org-agenda-toggle-time-grid)
-(define-key org-agenda-mode-map "r" 'org-agenda-redo)
-(define-key org-agenda-mode-map "q" 'org-agenda-quit)
-(define-key org-agenda-mode-map "x" 'org-agenda-exit)
-(define-key org-agenda-mode-map "s" 'org-save-all-org-buffers)
-(define-key org-agenda-mode-map "P" 'org-agenda-show-priority)
-(define-key org-agenda-mode-map "T" 'org-agenda-show-tags)
-(define-key org-agenda-mode-map "n" 'next-line)
-(define-key org-agenda-mode-map "p" 'previous-line)
-(define-key org-agenda-mode-map "\C-n" 'org-agenda-next-date-line)
-(define-key org-agenda-mode-map "\C-p" 'org-agenda-previous-date-line)
-(define-key org-agenda-mode-map "," 'org-agenda-priority)
-(define-key org-agenda-mode-map "\C-c," 'org-agenda-priority)
-(define-key org-agenda-mode-map "i" 'org-agenda-diary-entry)
-(define-key org-agenda-mode-map "c" 'org-agenda-goto-calendar)
+(org-defkey org-agenda-mode-map "f" 'org-agenda-follow-mode)
+(org-defkey org-agenda-mode-map "l" 'org-agenda-log-mode)
+(org-defkey org-agenda-mode-map "D" 'org-agenda-toggle-diary)
+(org-defkey org-agenda-mode-map "G" 'org-agenda-toggle-time-grid)
+(org-defkey org-agenda-mode-map "r" 'org-agenda-redo)
+(org-defkey org-agenda-mode-map "g" 'org-agenda-redo)
+(org-defkey org-agenda-mode-map "e" 'org-agenda-execute)
+(org-defkey org-agenda-mode-map "q" 'org-agenda-quit)
+(org-defkey org-agenda-mode-map "x" 'org-agenda-exit)
+(org-defkey org-agenda-mode-map "\C-x\C-w" 'org-write-agenda)
+(org-defkey org-agenda-mode-map "s" 'org-save-all-org-buffers)
+(org-defkey org-agenda-mode-map "\C-x\C-s" 'org-save-all-org-buffers)
+(org-defkey org-agenda-mode-map "P" 'org-agenda-show-priority)
+(org-defkey org-agenda-mode-map "T" 'org-agenda-show-tags)
+(org-defkey org-agenda-mode-map "n" 'next-line)
+(org-defkey org-agenda-mode-map "p" 'previous-line)
+(org-defkey org-agenda-mode-map "\C-c\C-n" 'org-agenda-next-date-line)
+(org-defkey org-agenda-mode-map "\C-c\C-p" 'org-agenda-previous-date-line)
+(org-defkey org-agenda-mode-map "," 'org-agenda-priority)
+(org-defkey org-agenda-mode-map "\C-c," 'org-agenda-priority)
+(org-defkey org-agenda-mode-map "i" 'org-agenda-diary-entry)
+(org-defkey org-agenda-mode-map "c" 'org-agenda-goto-calendar)
(eval-after-load "calendar"
- '(define-key calendar-mode-map org-calendar-to-agenda-key
+ '(org-defkey calendar-mode-map org-calendar-to-agenda-key
'org-calendar-goto-agenda))
-(define-key org-agenda-mode-map "C" 'org-agenda-convert-date)
-(define-key org-agenda-mode-map "m" 'org-agenda-phases-of-moon)
-(define-key org-agenda-mode-map "M" 'org-agenda-phases-of-moon)
-(define-key org-agenda-mode-map "S" 'org-agenda-sunrise-sunset)
-(define-key org-agenda-mode-map "h" 'org-agenda-holidays)
-(define-key org-agenda-mode-map "H" 'org-agenda-holidays)
-(define-key org-agenda-mode-map "+" 'org-agenda-priority-up)
-(define-key org-agenda-mode-map "I" 'org-agenda-clock-in)
-(define-key org-agenda-mode-map "O" 'org-agenda-clock-out)
-(define-key org-agenda-mode-map "X" 'org-agenda-clock-cancel)
-(define-key org-agenda-mode-map "-" 'org-agenda-priority-down)
-(define-key org-agenda-mode-map (org-key 'S-up) 'org-agenda-priority-up)
-(define-key org-agenda-mode-map (org-key 'S-down) 'org-agenda-priority-down)
-(define-key org-agenda-mode-map [?\C-c ?\C-x (up)] 'org-agenda-priority-up)
-(define-key org-agenda-mode-map [?\C-c ?\C-x (down)] 'org-agenda-priority-down)
-(define-key org-agenda-mode-map [(right)] 'org-agenda-later)
-(define-key org-agenda-mode-map [(left)] 'org-agenda-earlier)
-(define-key org-agenda-mode-map "\C-c\C-x\C-c" 'org-export-icalendar-combine-agenda-files)
+(org-defkey org-agenda-mode-map "C" 'org-agenda-convert-date)
+(org-defkey org-agenda-mode-map "M" 'org-agenda-phases-of-moon)
+(org-defkey org-agenda-mode-map "S" 'org-agenda-sunrise-sunset)
+(org-defkey org-agenda-mode-map "h" 'org-agenda-holidays)
+(org-defkey org-agenda-mode-map "H" 'org-agenda-holidays)
+(org-defkey org-agenda-mode-map "\C-c\C-x\C-i" 'org-agenda-clock-in)
+(org-defkey org-agenda-mode-map "I" 'org-agenda-clock-in)
+(org-defkey org-agenda-mode-map "\C-c\C-x\C-o" 'org-agenda-clock-out)
+(org-defkey org-agenda-mode-map "O" 'org-agenda-clock-out)
+(org-defkey org-agenda-mode-map "\C-c\C-x\C-x" 'org-agenda-clock-cancel)
+(org-defkey org-agenda-mode-map "X" 'org-agenda-clock-cancel)
+(org-defkey org-agenda-mode-map "\C-c\C-x\C-j" 'org-clock-goto)
+(org-defkey org-agenda-mode-map "J" 'org-clock-goto)
+(org-defkey org-agenda-mode-map "+" 'org-agenda-priority-up)
+(org-defkey org-agenda-mode-map "-" 'org-agenda-priority-down)
+(org-defkey org-agenda-mode-map [(shift up)] 'org-agenda-priority-up)
+(org-defkey org-agenda-mode-map [(shift down)] 'org-agenda-priority-down)
+(org-defkey org-agenda-mode-map [?\C-c ?\C-x (up)] 'org-agenda-priority-up)
+(org-defkey org-agenda-mode-map [?\C-c ?\C-x (down)] 'org-agenda-priority-down)
+(org-defkey org-agenda-mode-map [(right)] 'org-agenda-later)
+(org-defkey org-agenda-mode-map [(left)] 'org-agenda-earlier)
+(org-defkey org-agenda-mode-map "\C-c\C-x\C-c" 'org-agenda-columns)
+
+(org-defkey org-agenda-mode-map "[" 'org-agenda-manipulate-query-add)
+(org-defkey org-agenda-mode-map "]" 'org-agenda-manipulate-query-subtract)
+(org-defkey org-agenda-mode-map "{" 'org-agenda-manipulate-query-add-re)
+(org-defkey org-agenda-mode-map "}" 'org-agenda-manipulate-query-subtract-re)
+
(defvar org-agenda-keymap (copy-keymap org-agenda-mode-map)
"Local keymap for agenda entries from Org-mode.")
-(define-key org-agenda-keymap
+(org-defkey org-agenda-keymap
(if (featurep 'xemacs) [(button2)] [(mouse-2)]) 'org-agenda-goto-mouse)
-(define-key org-agenda-keymap
+(org-defkey org-agenda-keymap
(if (featurep 'xemacs) [(button3)] [(mouse-3)]) 'org-agenda-show-mouse)
(when org-agenda-mouse-1-follows-link
- (define-key org-agenda-keymap [follow-link] 'mouse-face))
+ (org-defkey org-agenda-keymap [follow-link] 'mouse-face))
(easy-menu-define org-agenda-menu org-agenda-mode-map "Agenda menu"
'("Agenda"
("Agenda Files")
["Goto Today" org-agenda-goto-today (org-agenda-check-type nil 'agenda 'timeline)]
["Next Dates" org-agenda-later (org-agenda-check-type nil 'agenda)]
["Previous Dates" org-agenda-earlier (org-agenda-check-type nil 'agenda)]
+ ["Jump to date" org-agenda-goto-date (org-agenda-check-type nil 'agenda)]
"--"
- ("Tags"
+ ("Tags and Properties"
["Show all Tags" org-agenda-show-tags t]
- ["Set Tags" org-agenda-set-tags t])
+ ["Set Tags current line" org-agenda-set-tags (not (org-region-active-p))]
+ ["Change tag in region" org-agenda-set-tags (org-region-active-p)]
+ "--"
+ ["Column View" org-columns t])
("Date/Schedule"
["Schedule" org-agenda-schedule t]
["Set Deadline" org-agenda-deadline t]
"--"
- ["Change date +1 day" org-agenda-date-later (org-agenda-check-type nil 'agenda 'timeline)]
- ["Change date -1 day" org-agenda-date-earlier (org-agenda-check-type nil 'agenda 'timeline)]
- ["Change date to ..." org-agenda-date-prompt (org-agenda-check-type nil 'agenda 'timeline)])
+ ["Change Date +1 day" org-agenda-date-later (org-agenda-check-type nil 'agenda 'timeline)]
+ ["Change Date -1 day" org-agenda-date-earlier (org-agenda-check-type nil 'agenda 'timeline)]
+ ["Change Date to ..." org-agenda-date-prompt (org-agenda-check-type nil 'agenda 'timeline)])
+ ("Clock"
+ ["Clock in" org-agenda-clock-in t]
+ ["Clock out" org-agenda-clock-out t]
+ ["Clock cancel" org-agenda-clock-cancel t]
+ ["Goto running clock" org-clock-goto t])
("Priority"
["Set Priority" org-agenda-priority t]
["Increase Priority" org-agenda-priority-up t]
:style radio :selected (equal org-agenda-ndays 1)]
["Week View" org-agenda-week-view :active (org-agenda-check-type nil 'agenda)
:style radio :selected (equal org-agenda-ndays 7)]
+ ["Month View" org-agenda-month-view :active (org-agenda-check-type nil 'agenda)
+ :style radio :selected (member org-agenda-ndays '(28 29 30 31))]
+ ["Year View" org-agenda-year-view :active (org-agenda-check-type nil 'agenda)
+ :style radio :selected (member org-agenda-ndays '(365 366))]
"--"
["Show Logbook entries" org-agenda-log-mode
:style toggle :selected org-agenda-show-log :active (org-agenda-check-type nil 'agenda 'timeline)]
:style toggle :selected org-agenda-include-diary :active (org-agenda-check-type nil 'agenda)]
["Use Time Grid" org-agenda-toggle-time-grid
:style toggle :selected org-agenda-use-time-grid :active (org-agenda-check-type nil 'agenda)])
+ ["Write view to file" org-write-agenda t]
["Rebuild buffer" org-agenda-redo t]
["Save all Org-mode Buffers" org-save-all-org-buffers t]
"--"
"In a series of undo commands, this is the list of remaning undo items.")
(defmacro org-if-unprotected (&rest body)
- "Execute BODY if ther is no `org-protected' text property at point."
+ "Execute BODY if there is no `org-protected' text property at point."
(declare (debug t))
`(unless (get-text-property (point) 'org-protected)
,@body))
(if (pop entry)
(with-current-buffer buf
(let ((last-undo-buffer buf)
- buffer-read-only)
+ (inhibit-read-only t))
(unless (memq buf org-agenda-undo-has-started-in)
(push buf org-agenda-undo-has-started-in)
(make-local-variable 'pending-undo-list)
(defvar org-agenda-restrict-begin (make-marker))
(defvar org-agenda-restrict-end (make-marker))
(defvar org-agenda-last-dispatch-buffer nil)
+(defvar org-agenda-overriding-restriction nil)
;;;###autoload
-(defun org-agenda (arg)
+(defun org-agenda (arg &optional keys restriction)
"Dispatch agenda commands to collect entries to the agenda buffer.
-Prompts for a character to select a command. Any prefix arg will be passed
+Prompts for a command to execute. Any prefix arg will be passed
on to the selected command. The default selections are:
-g
+
a Call `org-agenda-list' to display the agenda for current day or week.
t Call `org-todo-list' to display the global todo list.
T Call `org-todo-list' to display the global todo list, select only
m Call `org-tags-view' to display headlines with tags matching
a condition (the user is prompted for the condition).
M Like `m', but select only TODO entries, no ordinary headlines.
-l Create a timeeline for the current buffer.
+L Create a timeline for the current buffer.
+e Export views to associated files.
More commands can be added by configuring the variable
`org-agenda-custom-commands'. In particular, specific tags and TODO keyword
searches can be pre-defined in this way.
If the current buffer is in Org-mode and visiting a file, you can also
-first press `1' to indicate that the agenda should be temporarily (until the
-next use of \\[org-agenda]) restricted to the current file."
+first press `<' once to indicate that the agenda should be temporarily
+\(until the next use of \\[org-agenda]) restricted to the current file.
+Pressing `<' twice means to restrict to the current subtree or region
+\(if active)."
(interactive "P")
(catch 'exit
- (let* ((buf (current-buffer))
+ (let* ((prefix-descriptions nil)
+ (org-agenda-custom-commands-orig org-agenda-custom-commands)
+ (org-agenda-custom-commands
+ ;; normalize different versions
+ (delq nil
+ (mapcar
+ (lambda (x)
+ (cond ((stringp (cdr x))
+ (push x prefix-descriptions)
+ nil)
+ ((stringp (nth 1 x)) x)
+ ((not (nth 1 x)) (cons (car x) (cons "" (cddr x))))
+ (t (cons (car x) (cons "" (cdr x))))))
+ org-agenda-custom-commands)))
+ (buf (current-buffer))
(bfn (buffer-file-name (buffer-base-buffer)))
- (restrict-ok (and bfn (org-mode-p)))
- (custom org-agenda-custom-commands)
- c entry key type match lprops)
- ;; Turn off restriction
- (put 'org-agenda-files 'org-restrict nil)
- (setq org-agenda-restrict nil)
- (move-marker org-agenda-restrict-begin nil)
- (move-marker org-agenda-restrict-end nil)
+ entry key type match lprops ans)
+ ;; Turn off restriction unless there is an overriding one
+ (unless org-agenda-overriding-restriction
+ (put 'org-agenda-files 'org-restrict nil)
+ (setq org-agenda-restrict nil)
+ (move-marker org-agenda-restrict-begin nil)
+ (move-marker org-agenda-restrict-end nil))
+ ;; Delete old local properties
+ (put 'org-agenda-redo-command 'org-lprops nil)
;; Remember where this call originated
(setq org-agenda-last-dispatch-buffer (current-buffer))
- (save-window-excursion
- (delete-other-windows)
- (switch-to-buffer-other-window " *Agenda Commands*")
- (erase-buffer)
- (insert (eval-when-compile
- (let ((header
-"Press key for an agenda command:
--------------------------------- C Configure custom agenda commands
-a Agenda for current week or day
-t List of all TODO entries T Entries with special TODO kwd
-m Match a TAGS query M Like m, but only TODO entries
-L Timeline for current buffer # List stuck projects (!=configure)
-")
- (start 0))
- (while (string-match "\\(^\\| \\|(\\)\\(\\S-\\)\\( \\|=\\)" header start)
- (setq start (match-end 0))
- (add-text-properties (match-beginning 2) (match-end 2)
- '(face bold) header))
- header)))
- (while (setq entry (pop custom))
- (setq key (car entry) type (nth 1 entry) match (nth 2 entry))
- (insert (format "\n%-4s%-14s: %s"
- (org-add-props (copy-sequence key)
- '(face bold))
- (cond
- ((stringp type) type)
- ((eq type 'todo) "TODO keyword")
- ((eq type 'tags) "Tags query")
- ((eq type 'tags-todo) "Tags (TODO)")
- ((eq type 'tags-tree) "Tags tree")
- ((eq type 'todo-tree) "TODO kwd tree")
- ((eq type 'occur-tree) "Occur tree")
- ((functionp type) (symbol-name type))
- (t "???"))
- (if (stringp match)
- (org-add-props match nil 'face 'org-warning)
- (format "set of %d commands" (length match))))))
- (if restrict-ok
- (insert "\n"
- (org-add-props "1 Restrict call to current buffer 0 Restrict call to region or subtree" nil 'face 'org-table)))
- (goto-char (point-min))
- (if (fboundp 'fit-window-to-buffer) (fit-window-to-buffer))
- (message "Press key for agenda command%s"
- (if restrict-ok ", or [1] or [0] to restrict" ""))
- (setq c (read-char-exclusive))
- (message "")
- (when (memq c '(?L ?1 ?0))
- (if restrict-ok
- (put 'org-agenda-files 'org-restrict (list bfn))
- (error "Cannot restrict agenda to current buffer"))
- (with-current-buffer " *Agenda Commands*"
- (goto-char (point-max))
- (delete-region (point-at-bol) (point))
- (goto-char (point-min)))
- (when (eq c ?0)
+ (unless keys
+ (setq ans (org-agenda-get-restriction-and-command prefix-descriptions)
+ keys (car ans)
+ restriction (cdr ans)))
+ ;; Estabish the restriction, if any
+ (when (and (not org-agenda-overriding-restriction) restriction)
+ (put 'org-agenda-files 'org-restrict (list bfn))
+ (cond
+ ((eq restriction 'region)
+ (setq org-agenda-restrict t)
+ (move-marker org-agenda-restrict-begin (region-beginning))
+ (move-marker org-agenda-restrict-end (region-end)))
+ ((eq restriction 'subtree)
+ (save-excursion
(setq org-agenda-restrict t)
- (with-current-buffer buf
- (if (org-region-active-p)
- (progn
- (move-marker org-agenda-restrict-begin (region-beginning))
- (move-marker org-agenda-restrict-end (region-end)))
- (save-excursion
- (org-back-to-heading t)
- (move-marker org-agenda-restrict-begin (point))
- (move-marker org-agenda-restrict-end
- (progn (org-end-of-subtree t)))))))
- (unless (eq c ?L)
- (message "Press key for agenda command%s"
- (if restrict-ok " (restricted to current file)" ""))
- (setq c (read-char-exclusive)))
- (message "")))
+ (org-back-to-heading t)
+ (move-marker org-agenda-restrict-begin (point))
+ (move-marker org-agenda-restrict-end
+ (progn (org-end-of-subtree t)))))))
+
(require 'calendar) ; FIXME: can we avoid this for some commands?
;; For example the todo list should not need it (but does...)
(cond
- ((setq entry (assoc (char-to-string c) org-agenda-custom-commands))
- (if (symbolp (nth 1 entry))
+ ((setq entry (assoc keys org-agenda-custom-commands))
+ (if (or (symbolp (nth 2 entry)) (functionp (nth 2 entry)))
(progn
- (setq type (nth 1 entry) match (nth 2 entry) lprops (nth 3 entry)
- lprops (nth 3 entry))
+ (setq type (nth 2 entry) match (nth 3 entry) lprops (nth 4 entry))
+ (put 'org-agenda-redo-command 'org-lprops lprops)
(cond
+ ((eq type 'agenda)
+ (org-let lprops '(org-agenda-list current-prefix-arg)))
+ ((eq type 'alltodo)
+ (org-let lprops '(org-todo-list current-prefix-arg)))
+ ((eq type 'search)
+ (org-let lprops '(org-search-view current-prefix-arg match)))
+ ((eq type 'stuck)
+ (org-let lprops '(org-agenda-list-stuck-projects
+ current-prefix-arg)))
((eq type 'tags)
(org-let lprops '(org-tags-view current-prefix-arg match)))
((eq type 'tags-todo)
((eq type 'occur-tree)
(org-check-for-org-mode)
(org-let lprops '(org-occur match)))
+ ((functionp type)
+ (org-let lprops '(funcall type match)))
((fboundp type)
(org-let lprops '(funcall type match)))
(t (error "Invalid custom agenda command type %s" type))))
- (org-run-agenda-series (cddr entry))))
- ((equal c ?C) (customize-variable 'org-agenda-custom-commands))
- ((equal c ?a) (call-interactively 'org-agenda-list))
- ((equal c ?t) (call-interactively 'org-todo-list))
- ((equal c ?T) (org-call-with-arg 'org-todo-list (or arg '(4))))
- ((equal c ?m) (call-interactively 'org-tags-view))
- ((equal c ?M) (org-call-with-arg 'org-tags-view (or arg '(4))))
- ((equal c ?L)
- (unless restrict-ok
+ (org-run-agenda-series (nth 1 entry) (cddr entry))))
+ ((equal keys "C")
+ (setq org-agenda-custom-commands org-agenda-custom-commands-orig)
+ (customize-variable 'org-agenda-custom-commands))
+ ((equal keys "a") (call-interactively 'org-agenda-list))
+ ((equal keys "s") (call-interactively 'org-search-view))
+ ((equal keys "t") (call-interactively 'org-todo-list))
+ ((equal keys "T") (org-call-with-arg 'org-todo-list (or arg '(4))))
+ ((equal keys "m") (call-interactively 'org-tags-view))
+ ((equal keys "M") (org-call-with-arg 'org-tags-view (or arg '(4))))
+ ((equal keys "e") (call-interactively 'org-store-agenda-views))
+ ((equal keys "L")
+ (unless (org-mode-p)
(error "This is not an Org-mode file"))
- (org-call-with-arg 'org-timeline arg))
- ((equal c ?#) (call-interactively 'org-agenda-list-stuck-projects))
- ((equal c ?!) (customize-variable 'org-stuck-projects))
- (t (error "Invalid key"))))))
-
-(defun org-run-agenda-series (series)
- (org-prepare-agenda)
+ (unless restriction
+ (put 'org-agenda-files 'org-restrict (list bfn))
+ (org-call-with-arg 'org-timeline arg)))
+ ((equal keys "#") (call-interactively 'org-agenda-list-stuck-projects))
+ ((equal keys "/") (call-interactively 'org-occur-in-agenda-files))
+ ((equal keys "!") (customize-variable 'org-stuck-projects))
+ (t (error "Invalid agenda key"))))))
+
+(defun org-agenda-normalize-custom-commands (cmds)
+ (delq nil
+ (mapcar
+ (lambda (x)
+ (cond ((stringp (cdr x)) nil)
+ ((stringp (nth 1 x)) x)
+ ((not (nth 1 x)) (cons (car x) (cons "" (cddr x))))
+ (t (cons (car x) (cons "" (cdr x))))))
+ cmds)))
+
+(defun org-agenda-get-restriction-and-command (prefix-descriptions)
+ "The user interface for selecting an agenda command."
+ (catch 'exit
+ (let* ((bfn (buffer-file-name (buffer-base-buffer)))
+ (restrict-ok (and bfn (org-mode-p)))
+ (region-p (org-region-active-p))
+ (custom org-agenda-custom-commands)
+ (selstring "")
+ restriction second-time
+ c entry key type match prefixes rmheader header-end custom1 desc)
+ (save-window-excursion
+ (delete-other-windows)
+ (org-switch-to-buffer-other-window " *Agenda Commands*")
+ (erase-buffer)
+ (insert (eval-when-compile
+ (let ((header
+"
+Press key for an agenda command: < Buffer,subtree/region restriction
+-------------------------------- > Remove restriction
+a Agenda for current week or day e Export agenda views
+t List of all TODO entries T Entries with special TODO kwd
+m Match a TAGS query M Like m, but only TODO entries
+L Timeline for current buffer # List stuck projects (!=configure)
+s Search for keywords C Configure custom agenda commands
+/ Multi-occur
+")
+ (start 0))
+ (while (string-match
+ "\\(^\\| \\|(\\)\\(\\S-\\)\\( \\|=\\)"
+ header start)
+ (setq start (match-end 0))
+ (add-text-properties (match-beginning 2) (match-end 2)
+ '(face bold) header))
+ header)))
+ (setq header-end (move-marker (make-marker) (point)))
+ (while t
+ (setq custom1 custom)
+ (when (eq rmheader t)
+ (goto-line 1)
+ (re-search-forward ":" nil t)
+ (delete-region (match-end 0) (point-at-eol))
+ (forward-char 1)
+ (looking-at "-+")
+ (delete-region (match-end 0) (point-at-eol))
+ (move-marker header-end (match-end 0)))
+ (goto-char header-end)
+ (delete-region (point) (point-max))
+ (while (setq entry (pop custom1))
+ (setq key (car entry) desc (nth 1 entry)
+ type (nth 2 entry) match (nth 3 entry))
+ (if (> (length key) 1)
+ (add-to-list 'prefixes (string-to-char key))
+ (insert
+ (format
+ "\n%-4s%-14s: %s"
+ (org-add-props (copy-sequence key)
+ '(face bold))
+ (cond
+ ((string-match "\\S-" desc) desc)
+ ((eq type 'agenda) "Agenda for current week or day")
+ ((eq type 'alltodo) "List of all TODO entries")
+ ((eq type 'search) "Word search")
+ ((eq type 'stuck) "List of stuck projects")
+ ((eq type 'todo) "TODO keyword")
+ ((eq type 'tags) "Tags query")
+ ((eq type 'tags-todo) "Tags (TODO)")
+ ((eq type 'tags-tree) "Tags tree")
+ ((eq type 'todo-tree) "TODO kwd tree")
+ ((eq type 'occur-tree) "Occur tree")
+ ((functionp type) (if (symbolp type)
+ (symbol-name type)
+ "Lambda expression"))
+ (t "???"))
+ (cond
+ ((stringp match)
+ (org-add-props match nil 'face 'org-warning))
+ (match
+ (format "set of %d commands" (length match)))
+ (t ""))))))
+ (when prefixes
+ (mapc (lambda (x)
+ (insert
+ (format "\n%s %s"
+ (org-add-props (char-to-string x)
+ nil 'face 'bold)
+ (or (cdr (assoc (concat selstring (char-to-string x))
+ prefix-descriptions))
+ "Prefix key"))))
+ prefixes))
+ (goto-char (point-min))
+ (when (fboundp 'fit-window-to-buffer)
+ (if second-time
+ (if (not (pos-visible-in-window-p (point-max)))
+ (fit-window-to-buffer))
+ (setq second-time t)
+ (fit-window-to-buffer)))
+ (message "Press key for agenda command%s:"
+ (if (or restrict-ok org-agenda-overriding-restriction)
+ (if org-agenda-overriding-restriction
+ " (restriction lock active)"
+ (if restriction
+ (format " (restricted to %s)" restriction)
+ " (unrestricted)"))
+ ""))
+ (setq c (read-char-exclusive))
+ (message "")
+ (cond
+ ((assoc (char-to-string c) custom)
+ (setq selstring (concat selstring (char-to-string c)))
+ (throw 'exit (cons selstring restriction)))
+ ((memq c prefixes)
+ (setq selstring (concat selstring (char-to-string c))
+ prefixes nil
+ rmheader (or rmheader t)
+ custom (delq nil (mapcar
+ (lambda (x)
+ (if (or (= (length (car x)) 1)
+ (/= (string-to-char (car x)) c))
+ nil
+ (cons (substring (car x) 1) (cdr x))))
+ custom))))
+ ((and (not restrict-ok) (memq c '(?1 ?0 ?<)))
+ (message "Restriction is only possible in Org-mode buffers")
+ (ding) (sit-for 1))
+ ((eq c ?1)
+ (org-agenda-remove-restriction-lock 'noupdate)
+ (setq restriction 'buffer))
+ ((eq c ?0)
+ (org-agenda-remove-restriction-lock 'noupdate)
+ (setq restriction (if region-p 'region 'subtree)))
+ ((eq c ?<)
+ (org-agenda-remove-restriction-lock 'noupdate)
+ (setq restriction
+ (cond
+ ((eq restriction 'buffer)
+ (if region-p 'region 'subtree))
+ ((memq restriction '(subtree region))
+ nil)
+ (t 'buffer))))
+ ((eq c ?>)
+ (org-agenda-remove-restriction-lock 'noupdate)
+ (setq restriction nil))
+ ((and (equal selstring "") (memq c '(?s ?a ?t ?m ?L ?C ?e ?T ?M ?# ?! ?/)))
+ (throw 'exit (cons (setq selstring (char-to-string c)) restriction)))
+ ((and (> (length selstring) 0) (eq c ?\d))
+ (delete-window)
+ (org-agenda-get-restriction-and-command prefix-descriptions))
+
+ ((equal c ?q) (error "Abort"))
+ (t (error "Invalid key %c" c))))))))
+
+(defun org-run-agenda-series (name series)
+ (org-prepare-agenda name)
(let* ((org-agenda-multi t)
- (redo (list 'org-run-agenda-series (list 'quote series)))
+ (redo (list 'org-run-agenda-series name (list 'quote series)))
(cmds (car series))
(gprops (nth 1 series))
match ;; The byte compiler incorrectly complains about this. Keep it!
(setq type (car cmd) match (nth 1 cmd) lprops (nth 2 cmd))
(cond
((eq type 'agenda)
- (call-interactively 'org-agenda-list))
+ (org-let2 gprops lprops
+ '(call-interactively 'org-agenda-list)))
((eq type 'alltodo)
- (call-interactively 'org-todo-list))
+ (org-let2 gprops lprops
+ '(call-interactively 'org-todo-list)))
+ ((eq type 'search)
+ (org-let2 gprops lprops
+ '(org-search-view current-prefix-arg match)))
((eq type 'stuck)
- (call-interactively 'org-agenda-list-stuck-projects))
+ (org-let2 gprops lprops
+ '(call-interactively 'org-agenda-list-stuck-projects)))
((eq type 'tags)
(org-let2 gprops lprops
'(org-tags-view current-prefix-arg match)))
;;;###autoload
(defmacro org-batch-agenda (cmd-key &rest parameters)
- "Run an agenda command in batch mode, send result to STDOUT.
-CMD-KEY is a string that is also a key in `org-agenda-custom-commands'.
+ "Run an agenda command in batch mode and send the result to STDOUT.
+If CMD-KEY is a string of length 1, it is used as a key in
+`org-agenda-custom-commands' and triggers this command. If it is a
+longer string it is used as a tags/todo match string.
Paramters are alternating variable names and values that will be bound
before running the agenda command."
(let (pars)
(while parameters
(push (list (pop parameters) (if parameters (pop parameters))) pars))
- (flet ((read-char-exclusive () (string-to-char cmd-key)))
- (eval (list 'let (nreverse pars) '(org-agenda nil))))
- (set-buffer "*Org Agenda*")
- (princ (buffer-string))))
+ (if (> (length cmd-key) 2)
+ (eval (list 'let (nreverse pars)
+ (list 'org-tags-view nil cmd-key)))
+ (eval (list 'let (nreverse pars) (list 'org-agenda nil cmd-key))))
+ (set-buffer org-agenda-buffer-name)
+ (princ (org-encode-for-stdout (buffer-string)))))
+
+(defun org-encode-for-stdout (string)
+ (if (fboundp 'encode-coding-string)
+ (encode-coding-string string buffer-file-coding-system)
+ string))
+
+(defvar org-agenda-info nil)
+
+;;;###autoload
+(defmacro org-batch-agenda-csv (cmd-key &rest parameters)
+ "Run an agenda command in batch mode and send the result to STDOUT.
+If CMD-KEY is a string of length 1, it is used as a key in
+`org-agenda-custom-commands' and triggers this command. If it is a
+longer string it is used as a tags/todo match string.
+Paramters are alternating variable names and values that will be bound
+before running the agenda command.
+
+The output gives a line for each selected agenda item. Each
+item is a list of comma-separated values, like this:
+
+category,head,type,todo,tags,date,time,extra,priority-l,priority-n
+
+category The category of the item
+head The headline, without TODO kwd, TAGS and PRIORITY
+type The type of the agenda entry, can be
+ todo selected in TODO match
+ tagsmatch selected in tags match
+ diary imported from diary
+ deadline a deadline on given date
+ scheduled scheduled on given date
+ timestamp entry has timestamp on given date
+ closed entry was closed on given date
+ upcoming-deadline warning about deadline
+ past-scheduled forwarded scheduled item
+ block entry has date block including g. date
+todo The todo keyword, if any
+tags All tags including inherited ones, separated by colons
+date The relevant date, like 2007-2-14
+time The time, like 15:00-16:50
+extra Sting with extra planning info
+priority-l The priority letter if any was given
+priority-n The computed numerical priority
+agenda-day The day in the agenda where this is listed"
+
+ (let (pars)
+ (while parameters
+ (push (list (pop parameters) (if parameters (pop parameters))) pars))
+ (push (list 'org-agenda-remove-tags t) pars)
+ (if (> (length cmd-key) 2)
+ (eval (list 'let (nreverse pars)
+ (list 'org-tags-view nil cmd-key)))
+ (eval (list 'let (nreverse pars) (list 'org-agenda nil cmd-key))))
+ (set-buffer org-agenda-buffer-name)
+ (let* ((lines (org-split-string (buffer-string) "\n"))
+ line)
+ (while (setq line (pop lines))
+ (catch 'next
+ (if (not (get-text-property 0 'org-category line)) (throw 'next nil))
+ (setq org-agenda-info
+ (org-fix-agenda-info (text-properties-at 0 line)))
+ (princ
+ (org-encode-for-stdout
+ (mapconcat 'org-agenda-export-csv-mapper
+ '(org-category txt type todo tags date time-of-day extra
+ priority-letter priority agenda-day)
+ ",")))
+ (princ "\n"))))))
+
+(defun org-fix-agenda-info (props)
+ "Make sure all properties on an agenda item have a canonical form,
+so the export commands can easily use it."
+ (let (tmp re)
+ (when (setq tmp (plist-get props 'tags))
+ (setq props (plist-put props 'tags (mapconcat 'identity tmp ":"))))
+ (when (setq tmp (plist-get props 'date))
+ (if (integerp tmp) (setq tmp (calendar-gregorian-from-absolute tmp)))
+ (let ((calendar-date-display-form '(year "-" month "-" day)))
+ '((format "%4d, %9s %2s, %4s" dayname monthname day year))
+
+ (setq tmp (calendar-date-string tmp)))
+ (setq props (plist-put props 'date tmp)))
+ (when (setq tmp (plist-get props 'day))
+ (if (integerp tmp) (setq tmp (calendar-gregorian-from-absolute tmp)))
+ (let ((calendar-date-display-form '(year "-" month "-" day)))
+ (setq tmp (calendar-date-string tmp)))
+ (setq props (plist-put props 'day tmp))
+ (setq props (plist-put props 'agenda-day tmp)))
+ (when (setq tmp (plist-get props 'txt))
+ (when (string-match "\\[#\\([A-Z0-9]\\)\\] ?" tmp)
+ (plist-put props 'priority-letter (match-string 1 tmp))
+ (setq tmp (replace-match "" t t tmp)))
+ (when (and (setq re (plist-get props 'org-todo-regexp))
+ (setq re (concat "\\`\\.*" re " ?"))
+ (string-match re tmp))
+ (plist-put props 'todo (match-string 1 tmp))
+ (setq tmp (replace-match "" t t tmp)))
+ (plist-put props 'txt tmp)))
+ props)
+
+(defun org-agenda-export-csv-mapper (prop)
+ (let ((res (plist-get org-agenda-info prop)))
+ (setq res
+ (cond
+ ((not res) "")
+ ((stringp res) res)
+ (t (prin1-to-string res))))
+ (while (string-match "," res)
+ (setq res (replace-match ";" t t res)))
+ (org-trim res)))
+
+
+;;;###autoload
+(defun org-store-agenda-views (&rest parameters)
+ (interactive)
+ (eval (list 'org-batch-store-agenda-views)))
+
+;; FIXME, why is this a macro?????
+;;;###autoload
+(defmacro org-batch-store-agenda-views (&rest parameters)
+ "Run all custom agenda commands that have a file argument."
+ (let ((cmds (org-agenda-normalize-custom-commands org-agenda-custom-commands))
+ (pop-up-frames nil)
+ (dir default-directory)
+ pars cmd thiscmdkey files opts)
+ (while parameters
+ (push (list (pop parameters) (if parameters (pop parameters))) pars))
+ (setq pars (reverse pars))
+ (save-window-excursion
+ (while cmds
+ (setq cmd (pop cmds)
+ thiscmdkey (car cmd)
+ opts (nth 4 cmd)
+ files (nth 5 cmd))
+ (if (stringp files) (setq files (list files)))
+ (when files
+ (eval (list 'let (append org-agenda-exporter-settings opts pars)
+ (list 'org-agenda nil thiscmdkey)))
+ (set-buffer org-agenda-buffer-name)
+ (while files
+ (eval (list 'let (append org-agenda-exporter-settings opts pars)
+ (list 'org-write-agenda
+ (expand-file-name (pop files) dir) t))))
+ (and (get-buffer org-agenda-buffer-name)
+ (kill-buffer org-agenda-buffer-name)))))))
+
+(defun org-write-agenda (file &optional nosettings)
+ "Write the current buffer (an agenda view) as a file.
+Depending on the extension of the file name, plain text (.txt),
+HTML (.html or .htm) or Postscript (.ps) is produced.
+If the extension is .ics, run icalendar export over all files used
+to construct the agenda and limit the export to entries listed in the
+agenda now.
+If NOSETTINGS is given, do not scope the settings of
+`org-agenda-exporter-settings' into the export commands. This is used when
+the settings have already been scoped and we do not wish to overrule other,
+higher priority settings."
+ (interactive "FWrite agenda to file: ")
+ (if (not (file-writable-p file))
+ (error "Cannot write agenda to file %s" file))
+ (cond
+ ((string-match "\\.html?\\'" file) (require 'htmlize))
+ ((string-match "\\.ps\\'" file) (require 'ps-print)))
+ (org-let (if nosettings nil org-agenda-exporter-settings)
+ '(save-excursion
+ (save-window-excursion
+ (cond
+ ((string-match "\\.html?\\'" file)
+ (set-buffer (htmlize-buffer (current-buffer)))
+
+ (when (and org-agenda-export-html-style
+ (string-match "<style>" org-agenda-export-html-style))
+ ;; replace <style> section with org-agenda-export-html-style
+ (goto-char (point-min))
+ (kill-region (- (search-forward "<style") 6)
+ (search-forward "</style>"))
+ (insert org-agenda-export-html-style))
+ (write-file file)
+ (kill-buffer (current-buffer))
+ (message "HTML written to %s" file))
+ ((string-match "\\.ps\\'" file)
+ (ps-print-buffer-with-faces file)
+ (message "Postscript written to %s" file))
+ ((string-match "\\.ics\\'" file)
+ (let ((org-agenda-marker-table
+ (org-create-marker-find-array
+ (org-agenda-collect-markers)))
+ (org-icalendar-verify-function 'org-check-agenda-marker-table)
+ (org-combined-agenda-icalendar-file file))
+ (apply 'org-export-icalendar 'combine (org-agenda-files))))
+ (t
+ (let ((bs (buffer-string)))
+ (find-file file)
+ (insert bs)
+ (save-buffer 0)
+ (kill-buffer (current-buffer))
+ (message "Plain text written to %s" file))))))
+ (set-buffer org-agenda-buffer-name)))
+
+(defun org-agenda-collect-markers ()
+ "Collect the markers pointing to entries in the agenda buffer."
+ (let (m markers)
+ (save-excursion
+ (goto-char (point-min))
+ (while (not (eobp))
+ (when (setq m (or (get-text-property (point) 'org-hd-marker)
+ (get-text-property (point) 'org-marker)))
+ (push m markers))
+ (beginning-of-line 2)))
+ (nreverse markers)))
+
+(defun org-create-marker-find-array (marker-list)
+ "Create a alist of files names with all marker positions in that file."
+ (let (f tbl m a p)
+ (while (setq m (pop marker-list))
+ (setq p (marker-position m)
+ f (buffer-file-name (or (buffer-base-buffer
+ (marker-buffer m))
+ (marker-buffer m))))
+ (if (setq a (assoc f tbl))
+ (push (marker-position m) (cdr a))
+ (push (list f p) tbl)))
+ (mapcar (lambda (x) (setcdr x (sort (copy-sequence (cdr x)) '<)) x)
+ tbl)))
+
+(defvar org-agenda-marker-table nil) ; dyamically scoped parameter
+(defun org-check-agenda-marker-table ()
+ "Check of the current entry is on the marker list."
+ (let ((file (buffer-file-name (or (buffer-base-buffer) (current-buffer))))
+ a)
+ (and (setq a (assoc file org-agenda-marker-table))
+ (save-match-data
+ (save-excursion
+ (org-back-to-heading t)
+ (member (point) (cdr a)))))))
(defmacro org-no-read-only (&rest body)
"Inhibit read-only for BODY."
"Fit the window to the buffer size."
(and (memq org-agenda-window-setup '(reorganize-frame))
(fboundp 'fit-window-to-buffer)
- (fit-window-to-buffer nil (/ (* (frame-height) 3) 4)
- (/ (frame-height) 2))))
+ (fit-window-to-buffer
+ nil
+ (floor (* (frame-height) (cdr org-agenda-window-frame-fractions)))
+ (floor (* (frame-height) (car org-agenda-window-frame-fractions))))))
;;; Agenda file list
"Get the list of agenda files.
Optional UNRESTRICTED means return the full list even if a restriction
is currently in place."
- (cond
- ((and (not unrestricted) (get 'org-agenda-files 'org-restrict)))
- ((stringp org-agenda-files) (org-read-agenda-file-list))
- ((listp org-agenda-files) org-agenda-files)
- (t (error "Invalid value of `org-agenda-files'"))))
+ (let ((files
+ (cond
+ ((and (not unrestricted) (get 'org-agenda-files 'org-restrict)))
+ ((stringp org-agenda-files) (org-read-agenda-file-list))
+ ((listp org-agenda-files) org-agenda-files)
+ (t (error "Invalid value of `org-agenda-files'")))))
+ (setq files (apply 'append
+ (mapcar (lambda (f)
+ (if (file-directory-p f)
+ (directory-files f t
+ org-agenda-file-regexp)
+ (list f)))
+ files)))
+ (if org-agenda-skip-unavailable-files
+ (delq nil
+ (mapcar (function
+ (lambda (file)
+ (and (file-readable-p file) file)))
+ files))
+ files))) ; `org-check-agenda-file' will remove them from the list
(defun org-edit-agenda-file-list ()
"Edit the list of agenda files.
(org-install-agenda-files-menu)
(message "New agenda file list installed"))
nil 'local)
- (message (substitute-command-keys
- "Edit list and finish with \\[save-buffer]")))
+ (message "%s" (substitute-command-keys
+ "Edit list and finish with \\[save-buffer]")))
(customize-variable 'org-agenda-files)))
(defun org-store-new-agenda-file-list (list)
(find-file (car fs)))
(if (buffer-base-buffer) (switch-to-buffer (buffer-base-buffer)))))
-(defun org-agenda-file-to-end ()
- "Move/add the current file to the end of the agenda file list.
-If the file is not present in the list, it is appended to the list. If it is
-present, it is moved there."
- (interactive)
- (org-agenda-file-to-front 'to-end))
-
(defun org-agenda-file-to-front (&optional to-end)
"Move/add the current file to the top of the agenda file list.
If the file is not present in the list, it is added to the front. If it is
present, it is moved there. With optional argument TO-END, add/move to the
end of the list."
(interactive "P")
- (let ((file-alist (mapcar (lambda (x)
+ (let ((org-agenda-skip-unavailable-files nil)
+ (file-alist (mapcar (lambda (x)
(cons (file-truename x) x))
(org-agenda-files t)))
(ctf (file-truename buffer-file-name))
These are the files which are being checked for agenda entries.
Optional argument FILE means, use this file instead of the current."
(interactive)
- (let* ((file (or file buffer-file-name))
+ (let* ((org-agenda-skip-unavailable-files nil)
+ (file (or file buffer-file-name))
(true-file (file-truename file))
(afile (abbreviate-file-name file))
(files (delq nil (mapcar
(org-store-new-agenda-file-list files)
(org-install-agenda-files-menu)
(message "Removed file: %s" afile))
- (message "File was not in list: %s" afile))))
+ (message "File was not in list: %s (not removed)" afile))))
(defun org-file-menu-entry (file)
(vector file (list 'find-file file) t))
(defvar org-agenda-multi nil) ; dynammically scoped
(defvar org-agenda-buffer-name "*Org Agenda*")
(defvar org-pre-agenda-window-conf nil)
-(defun org-prepare-agenda ()
+(defvar org-agenda-name nil)
+(defun org-prepare-agenda (&optional name)
+ (setq org-todo-keywords-for-agenda nil)
+ (setq org-done-keywords-for-agenda nil)
(if org-agenda-multi
(progn
(setq buffer-read-only nil)
(goto-char (point-max))
- (unless (= (point) 1)
+ (unless (or (bobp) org-agenda-compact-blocks)
(insert "\n" (make-string (window-width) ?=) "\n"))
(narrow-to-region (point) (point-max)))
- (org-agenda-maybe-reset-markers 'force)
+ (org-agenda-reset-markers)
(org-prepare-agenda-buffers (org-agenda-files))
+ (setq org-todo-keywords-for-agenda
+ (org-uniquify org-todo-keywords-for-agenda))
+ (setq org-done-keywords-for-agenda
+ (org-uniquify org-done-keywords-for-agenda))
(let* ((abuf (get-buffer-create org-agenda-buffer-name))
(awin (get-buffer-window abuf)))
(cond
((equal org-agenda-window-setup 'current-window)
(switch-to-buffer abuf))
((equal org-agenda-window-setup 'other-window)
- (switch-to-buffer-other-window abuf))
+ (org-switch-to-buffer-other-window abuf))
((equal org-agenda-window-setup 'other-frame)
(switch-to-buffer-other-frame abuf))
((equal org-agenda-window-setup 'reorganize-frame)
(delete-other-windows)
- (switch-to-buffer-other-window abuf))))
+ (org-switch-to-buffer-other-window abuf))))
(setq buffer-read-only nil)
(erase-buffer)
- (org-agenda-mode))
+ (org-agenda-mode)
+ (and name (not org-agenda-name)
+ (org-set-local 'org-agenda-name name)))
(setq buffer-read-only nil))
(defun org-finalize-agenda ()
"Finishing touch for the agenda buffer, called just before displaying it."
(unless org-agenda-multi
- (org-agenda-align-tags)
(save-excursion
- (let ((buffer-read-only))
+ (let ((inhibit-read-only t))
(goto-char (point-min))
(while (org-activate-bracket-links (point-max))
(add-text-properties (match-beginning 0) (match-end 0)
- '(face org-link))))
- (run-hooks 'org-finalize-agenda-hook))))
+ '(face org-link)))
+ (org-agenda-align-tags)
+ (unless org-agenda-with-colors
+ (remove-text-properties (point-min) (point-max) '(face nil))))
+ (if (and (boundp 'org-overriding-columns-format)
+ org-overriding-columns-format)
+ (org-set-local 'org-overriding-columns-format
+ org-overriding-columns-format))
+ (if (and (boundp 'org-agenda-view-columns-initially)
+ org-agenda-view-columns-initially)
+ (org-agenda-columns))
+ (when org-agenda-fontify-priorities
+ (org-fontify-priorities))
+ (run-hooks 'org-finalize-agenda-hook)
+ (setq org-agenda-type (get-text-property (point) 'org-agenda-type))
+ )))
+
+(defun org-fontify-priorities ()
+ "Make highest priority lines bold, and lowest italic."
+ (interactive)
+ (mapc (lambda (o) (if (eq (org-overlay-get o 'org-type) 'org-priority)
+ (org-delete-overlay o)))
+ (org-overlays-in (point-min) (point-max)))
+ (save-excursion
+ (let ((inhibit-read-only t)
+ b e p ov h l)
+ (goto-char (point-min))
+ (while (re-search-forward "\\[#\\(.\\)\\]" nil t)
+ (setq h (or (get-char-property (point) 'org-highest-priority)
+ org-highest-priority)
+ l (or (get-char-property (point) 'org-lowest-priority)
+ org-lowest-priority)
+ p (string-to-char (match-string 1))
+ b (match-beginning 0) e (point-at-eol)
+ ov (org-make-overlay b e))
+ (org-overlay-put
+ ov 'face
+ (cond ((listp org-agenda-fontify-priorities)
+ (cdr (assoc p org-agenda-fontify-priorities)))
+ ((equal p l) 'italic)
+ ((equal p h) 'bold)))
+ (org-overlay-put ov 'org-type 'org-priority)))))
(defun org-prepare-agenda-buffers (files)
"Create buffers for all agenda files, protect archived trees and comments."
(let ((pa '(:org-archived t))
(pc '(:org-comment t))
(pall '(:org-archived t :org-comment t))
+ (inhibit-read-only t)
(rea (concat ":" org-archive-tag ":"))
bmp file re)
(save-excursion
(save-restriction
(while (setq file (pop files))
- (org-check-agenda-file file)
- (set-buffer (org-get-agenda-file-buffer file))
+ (if (bufferp file)
+ (set-buffer file)
+ (org-check-agenda-file file)
+ (set-buffer (org-get-agenda-file-buffer file)))
(widen)
(setq bmp (buffer-modified-p))
+ (org-refresh-category-properties)
+ (setq org-todo-keywords-for-agenda
+ (append org-todo-keywords-for-agenda org-todo-keywords-1))
+ (setq org-done-keywords-for-agenda
+ (append org-done-keywords-for-agenda org-done-keywords))
(save-excursion
(remove-text-properties (point-min) (point-max) pall)
(when org-agenda-skip-archived-trees
(defvar org-agenda-skip-function nil
"Function to be called at each match during agenda construction.
-If this function return nil, the current match should not be skipped.
+If this function returns nil, the current match should not be skipped.
Otherwise, the function must return a position from where the search
should be continued.
+This may also be a Lisp form, it will be evaluated.
Never set this variable using `setq' or so, because then it will apply
to all future agenda commands. Instead, bind it with `let' to scope
-it dynamically into the agenda-constructing command.")
+it dynamically into the agenda-constructing command. A good way to set
+it is through options in org-agenda-custom-commands.")
(defun org-agenda-skip ()
"Throw to `:skip' in places that should be skipped.
Also moves point to the end of the skipped region, so that search can
continue from there."
- (let ((p (point-at-bol)) to)
+ (let ((p (point-at-bol)) to fp)
(and org-agenda-skip-archived-trees
(get-text-property p :org-archived)
(org-end-of-subtree t)
(org-end-of-subtree t)
(throw :skip t))
(if (equal (char-after p) ?#) (throw :skip t))
- (when (and (functionp org-agenda-skip-function)
+ (when (and (or (setq fp (functionp org-agenda-skip-function))
+ (consp org-agenda-skip-function))
(setq to (save-excursion
(save-match-data
- (funcall org-agenda-skip-function)))))
+ (if fp
+ (funcall org-agenda-skip-function)
+ (eval org-agenda-skip-function))))))
(goto-char to)
(throw :skip t))))
(push m org-agenda-markers)
m))
-(defun org-agenda-maybe-reset-markers (&optional force)
- "Reset markers created by `org-agenda'. But only if they are old enough."
- (if (or (and force (not org-agenda-multi))
- (> (- (time-to-seconds (current-time))
- org-agenda-last-marker-time)
- 5))
- (while org-agenda-markers
- (move-marker (pop org-agenda-markers) nil))))
-
-(defvar org-agenda-new-buffers nil
- "Buffers created to visit agenda files.")
+(defun org-agenda-reset-markers ()
+ "Reset markers created by `org-agenda'."
+ (while org-agenda-markers
+ (move-marker (pop org-agenda-markers) nil)))
(defun org-get-agenda-file-buffer (file)
"Get a buffer visiting FILE. If the buffer needs to be created, add
(with-current-buffer buf (save-buffer)))
(kill-buffer buf))))
-(defvar org-category-table nil)
-(defun org-get-category-table ()
- "Get the table of categories and positions in current buffer."
- (let (tbl)
- (save-excursion
- (goto-char (point-min))
- (while (re-search-forward "\\(^\\|\r\\)#\\+CATEGORY:[ \t]*\\(.*\\)" nil t)
- (push (cons (point) (org-trim (match-string 2))) tbl)))
- tbl))
-
(defun org-get-category (&optional pos)
"Get the category applying to position POS."
- (if (not org-category-table)
- (cond
- ((null org-category)
- (setq org-category
- (if buffer-file-name
- (file-name-sans-extension
- (file-name-nondirectory buffer-file-name))
- "???")))
- ((symbolp org-category) (symbol-name org-category))
- (t org-category))
- (let ((tbl org-category-table)
- (pos (or pos (point))))
- (while (and tbl (> (caar tbl) pos))
- (pop tbl))
- (or (cdar tbl) (cdr (nth (1- (length org-category-table))
- org-category-table))))))
+ (get-text-property (or pos (point)) 'org-category))
+
;;; Agenda timeline
+(defvar org-agenda-only-exact-dates nil) ; dynamically scoped
+
(defun org-timeline (&optional include-all)
"Show a time-sorted view of the entries in the current org file.
Only entries with a time stamp of today or later will be listed. With
(day-numbers (org-get-all-dates beg end 'no-ranges
t doclosed ; always include today
org-timeline-show-empty-dates))
+ (org-deadline-warning-days 0)
+ (org-agenda-only-exact-dates t)
(today (time-to-days (current-time)))
(past t)
args
s e rtn d emptyp)
(setq org-agenda-redo-command
(list 'progn
- (list 'switch-to-buffer-other-window (current-buffer))
+ (list 'org-switch-to-buffer-other-window (current-buffer))
(list 'org-timeline (list 'quote include-all))))
(if (not dopast)
;; Remove past dates from the list of dates.
(setq day-numbers (delq nil (mapcar (lambda(x)
(if (>= x today) x nil))
day-numbers))))
- (org-prepare-agenda)
+ (org-prepare-agenda (concat "Timeline "
+ (file-name-nondirectory buffer-file-name)))
(if doclosed (push :closed args))
(push :timestamp args)
+ (push :deadline args)
+ (push :scheduled args)
+ (push :sexp args)
(if dotodo (push :todo args))
(while (setq d (pop day-numbers))
(if (and (listp d) (eq (car d) :omitted))
(progn
(setq s (point))
(insert (format "\n[... %d empty days omitted]\n\n" (cdr d)))
- (put-text-property s (1- (point)) 'face 'org-level-3))
+ (put-text-property s (1- (point)) 'face 'org-agenda-structure))
(if (listp d) (setq d (car d) emptyp t) (setq emptyp nil))
(if (and (>= d today)
dopast
(setq date (calendar-gregorian-from-absolute d))
(setq s (point))
(setq rtn (and (not emptyp)
- (apply 'org-agenda-get-day-entries
- entry date args)))
+ (apply 'org-agenda-get-day-entries entry
+ date args)))
(if (or rtn (equal d today) org-timeline-show-empty-dates)
(progn
- (insert (calendar-day-name date) " "
- (number-to-string (extract-calendar-day date)) " "
- (calendar-month-name (extract-calendar-month date)) " "
- (number-to-string (extract-calendar-year date)) "\n")
-; FIXME: this gives a timezone problem
-; (insert (format-time-string org-agenda-date-format
-; (calendar-time-from-absolute d 0))
-; "\n")
- (put-text-property s (1- (point)) 'face 'org-level-3)
+ (insert
+ (if (stringp org-agenda-format-date)
+ (format-time-string org-agenda-format-date
+ (org-time-from-absolute date))
+ (funcall org-agenda-format-date date))
+ "\n")
+ (put-text-property s (1- (point)) 'face 'org-agenda-structure)
(put-text-property s (1- (point)) 'org-date-line t)
(if (equal d today)
(put-text-property s (1- (point)) 'org-today t))
(org-finalize-agenda)
(setq buffer-read-only t)))
-(defun org-get-all-dates (beg end &optional no-ranges force-today inactive empty)
+(defun org-get-all-dates (beg end &optional no-ranges force-today inactive empty pre-re)
"Return a list of all relevant day numbers from BEG to END buffer positions.
If NO-RANGES is non-nil, include only the start and end dates of a range,
not every single day in the range. If FORCE-TODAY is non-nil, make
sure that TODAY is included in the list. If INACTIVE is non-nil, also
inactive time stamps (those in square brackets) are included.
When EMPTY is non-nil, also include days without any entries."
- (let ((re (if inactive org-ts-regexp-both org-ts-regexp))
+ (let ((re (concat
+ (if pre-re pre-re "")
+ (if inactive org-ts-regexp-both org-ts-regexp)))
dates dates1 date day day1 day2 ts1 ts2)
(if force-today
(setq dates (list (time-to-days (current-time)))))
;;; Agenda Daily/Weekly
(defvar org-agenda-overriding-arguments nil) ; dynamically scoped parameter
+(defvar org-agenda-start-day nil) ; dynamically scoped parameter
(defvar org-agenda-last-arguments nil
"The arguments of the previous call to org-agenda")
(defvar org-starting-day nil) ; local variable in the agenda buffer
+(defvar org-agenda-span nil) ; local variable in the agenda buffer
(defvar org-include-all-loc nil) ; local variable
-
+(defvar org-agenda-remove-date nil) ; dynamically scoped FIXME: not used???
;;;###autoload
(defun org-agenda-list (&optional include-all start-day ndays)
- "Produce a weekly view from all files in variable `org-agenda-files'.
-The view will be for the current week, but from the overview buffer you
-will be able to go to other weeks.
-With one \\[universal-argument] prefix argument INCLUDE-ALL, all unfinished TODO items will
-also be shown, under the current date.
-With two \\[universal-argument] prefix argument INCLUDE-ALL, all TODO entries marked DONE
-on the days are also shown. See the variable `org-log-done' for how
-to turn on logging.
+ "Produce a daily/weekly view from all files in variable `org-agenda-files'.
+The view will be for the current day or week, but from the overview buffer
+you will be able to go to other days/weeks.
+
+With one \\[universal-argument] prefix argument INCLUDE-ALL,
+all unfinished TODO items will also be shown, before the agenda.
+This feature is considered obsolete, please use the TODO list or a block
+agenda instead.
+
+With a numeric prefix argument in an interactive call, the agenda will
+span INCLUDE-ALL days. Lisp programs should instead specify NDAYS to change
+the number of days. NDAYS defaults to `org-agenda-ndays'.
+
START-DAY defaults to TODAY, or to the most recent match for the weekday
-given in `org-agenda-start-on-weekday'.
-NDAYS defaults to `org-agenda-ndays'."
+given in `org-agenda-start-on-weekday'."
(interactive "P")
+ (if (and (integerp include-all) (> include-all 0))
+ (setq ndays include-all include-all nil))
+ (setq ndays (or ndays org-agenda-ndays)
+ start-day (or start-day org-agenda-start-day))
(if org-agenda-overriding-arguments
(setq include-all (car org-agenda-overriding-arguments)
start-day (nth 1 org-agenda-overriding-arguments)
ndays (nth 2 org-agenda-overriding-arguments)))
+ (if (stringp start-day)
+ ;; Convert to an absolute day number
+ (setq start-day (time-to-days (org-read-date nil t start-day))))
(setq org-agenda-last-arguments (list include-all start-day ndays))
(org-compile-prefix-format 'agenda)
(org-set-sorting-strategy 'agenda)
(require 'calendar)
(let* ((org-agenda-start-on-weekday
- (if (or (equal ndays 1)
- (and (null ndays) (equal 1 org-agenda-ndays)))
- nil org-agenda-start-on-weekday))
+ (if (or (equal ndays 7) (and (null ndays) (equal 7 org-agenda-ndays)))
+ org-agenda-start-on-weekday nil))
(thefiles (org-agenda-files))
(files thefiles)
- (today (time-to-days (current-time)))
+ (today (time-to-days
+ (time-subtract (current-time)
+ (list 0 (* 3600 org-extend-today-until) 0))))
(sd (or start-day today))
(start (if (or (null org-agenda-start-on-weekday)
(< org-agenda-ndays 7))
(d (- nt n1)))
(- sd (+ (if (< d 0) 7 0) d)))))
(day-numbers (list start))
+ (day-cnt 0)
(inhibit-redisplay (not debug-on-error))
s e rtn rtnall file date d start-pos end-pos todayp nd)
(setq org-agenda-redo-command
(push (1+ (car day-numbers)) day-numbers)
(setq ndays (1- ndays)))
(setq day-numbers (nreverse day-numbers))
- (org-prepare-agenda)
+ (org-prepare-agenda "Day/Week")
(org-set-local 'org-starting-day (car day-numbers))
(org-set-local 'org-include-all-loc include-all)
+ (org-set-local 'org-agenda-span
+ (org-agenda-ndays-to-span nd))
(when (and (or include-all org-agenda-include-all-todo)
(member today day-numbers))
(setq files thefiles
(when rtnall
(insert "ALL CURRENTLY OPEN TODO ITEMS:\n")
(add-text-properties (point-min) (1- (point))
- (list 'face 'org-level-3))
+ (list 'face 'org-agenda-structure))
(insert (org-finalize-agenda-entries rtnall) "\n")))
- (setq s (point))
- (insert (if (= nd 7) "Week-" "Day-") "agenda:\n")
- (add-text-properties s (1- (point)) (list 'face 'org-level-3))
+ (unless org-agenda-compact-blocks
+ (setq s (point))
+ (insert (capitalize (symbol-name (org-agenda-ndays-to-span nd)))
+ "-agenda:\n")
+ (add-text-properties s (1- (point)) (list 'face 'org-agenda-structure
+ 'org-date-line t)))
(while (setq d (pop day-numbers))
(setq date (calendar-gregorian-from-absolute d)
s (point))
(if org-agenda-show-log
(setq rtn (org-agenda-get-day-entries
file date
- :deadline :scheduled :timestamp :closed))
+ :deadline :scheduled :timestamp :sexp :closed))
(setq rtn (org-agenda-get-day-entries
file date
- :deadline :scheduled :timestamp)))
+ :deadline :scheduled :sexp :timestamp)))
(setq rtnall (append rtnall rtn))))
(if org-agenda-include-diary
(progn
(setq rtnall (append rtnall rtn))))
(if (or rtnall org-agenda-show-all-dates)
(progn
- (insert (format "%-9s %2d %s %4d\n"
- (calendar-day-name date)
- (extract-calendar-day date)
- (calendar-month-name (extract-calendar-month date))
- (extract-calendar-year date)))
-; FIXME: this gives a timezone problem
-; (insert (format-time-string org-agenda-date-format
-; (calendar-time-from-absolute d 0)) "\n")
- (put-text-property s (1- (point)) 'face 'org-level-3)
+ (setq day-cnt (1+ day-cnt))
+ (insert
+ (if (stringp org-agenda-format-date)
+ (format-time-string org-agenda-format-date
+ (org-time-from-absolute date))
+ (funcall org-agenda-format-date date))
+ "\n")
+ (put-text-property s (1- (point)) 'face 'org-agenda-structure)
(put-text-property s (1- (point)) 'org-date-line t)
+ (put-text-property s (1- (point)) 'org-day-cnt day-cnt)
(if todayp (put-text-property s (1- (point)) 'org-today t))
(if rtnall (insert
(org-finalize-agenda-entries
(org-agenda-add-time-grid-maybe
rtnall nd todayp))
"\n"))
- (put-text-property s (1- (point)) 'day d))))
+ (put-text-property s (1- (point)) 'day d)
+ (put-text-property s (1- (point)) 'org-day-cnt day-cnt))))
(goto-char (point-min))
(org-fit-agenda-window)
(unless (and (pos-visible-in-window-p (point-min))
(setq buffer-read-only t)
(message "")))
+(defun org-agenda-ndays-to-span (n)
+ (cond ((< n 7) 'day) ((= n 7) 'week) ((< n 32) 'month) (t 'year)))
+
+;;; Agenda word search
+
+(defvar org-agenda-search-history nil)
+
+;;;###autoload
+(defun org-search-view (&optional arg string)
+ "Show all entries that contain words or regular expressions.
+If the first character of the search string is an asterisks,
+search only the headlines.
+
+The search string is broken into \"words\" by splitting at whitespace.
+The individual words are then interpreted as a boolean expression with
+logical AND. Words prefixed with a minus must not occur in the entry.
+Words without a prefix or prefixed with a plus must occur in the entry.
+Matching is case-insensitive and the words are enclosed by word delimiters.
+
+Words enclosed by curly braces are interpreted as regular expressions
+that must or must not match in the entry.
+
+This command searches the agenda files, and in addition the files listed
+in `org-agenda-text-search-extra-files'."
+ (interactive "P")
+ (org-compile-prefix-format 'search)
+ (org-set-sorting-strategy 'search)
+ (org-prepare-agenda "SEARCH")
+ (let* ((props (list 'face nil
+ 'done-face 'org-done
+ 'org-not-done-regexp org-not-done-regexp
+ 'org-todo-regexp org-todo-regexp
+ 'mouse-face 'highlight
+ 'keymap org-agenda-keymap
+ 'help-echo (format "mouse-2 or RET jump to location")))
+ regexp rtn rtnall files file pos
+ marker priority category tags c neg re
+ ee txt beg end words regexps+ regexps- hdl-only buffer beg1 str)
+ (unless (and (not arg)
+ (stringp string)
+ (string-match "\\S-" string))
+ (setq string (read-string "[+-]Word/{Regexp} ...: "
+ (cond
+ ((integerp arg) (cons string arg))
+ (arg string))
+ 'org-agenda-search-history)))
+ (setq org-agenda-redo-command
+ (list 'org-search-view 'current-prefix-arg string))
+ (setq org-agenda-query-string string)
+
+ (if (equal (string-to-char string) ?*)
+ (setq hdl-only t
+ words (substring string 1))
+ (setq words string))
+ (setq words (org-split-string words))
+ (mapc (lambda (w)
+ (setq c (string-to-char w))
+ (if (equal c ?-)
+ (setq neg t w (substring w 1))
+ (if (equal c ?+)
+ (setq neg nil w (substring w 1))
+ (setq neg nil)))
+ (if (string-match "\\`{.*}\\'" w)
+ (setq re (substring w 1 -1))
+ (setq re (concat "\\<" (regexp-quote (downcase w)) "\\>")))
+ (if neg (push re regexps-) (push re regexps+)))
+ words)
+ (setq regexps+ (sort regexps+ (lambda (a b) (> (length a) (length b)))))
+ (if (not regexps+)
+ (setq regexp (concat "^" org-outline-regexp))
+ (setq regexp (pop regexps+))
+ (if hdl-only (setq regexp (concat "^" org-outline-regexp ".*?"
+ regexp))))
+ (setq files (append (org-agenda-files) org-agenda-text-search-extra-files)
+ rtnall nil)
+ (while (setq file (pop files))
+ (setq ee nil)
+ (catch 'nextfile
+ (org-check-agenda-file file)
+ (setq buffer (if (file-exists-p file)
+ (org-get-agenda-file-buffer file)
+ (error "No such file %s" file)))
+ (if (not buffer)
+ ;; If file does not exist, make sure an error message is sent
+ (setq rtn (list (format "ORG-AGENDA-ERROR: No such org-file %s"
+ file))))
+ (with-current-buffer buffer
+ (unless (org-mode-p)
+ (error "Agenda file %s is not in `org-mode'" file))
+ (let ((case-fold-search t))
+ (save-excursion
+ (save-restriction
+ (if org-agenda-restrict
+ (narrow-to-region org-agenda-restrict-begin
+ org-agenda-restrict-end)
+ (widen))
+ (goto-char (point-min))
+ (unless (or (org-on-heading-p)
+ (outline-next-heading))
+ (throw 'nextfile t))
+ (goto-char (max (point-min) (1- (point))))
+ (while (re-search-forward regexp nil t)
+ (org-back-to-heading t)
+ (skip-chars-forward "* ")
+ (setq beg (point-at-bol)
+ beg1 (point)
+ end (progn (outline-next-heading) (point)))
+ (catch :skip
+ (goto-char beg)
+ (org-agenda-skip)
+ (setq str (buffer-substring-no-properties
+ (point-at-bol)
+ (if hdl-only (point-at-eol) end)))
+ (mapc (lambda (wr) (when (string-match wr str)
+ (goto-char (1- end))
+ (throw :skip t)))
+ regexps-)
+ (mapc (lambda (wr) (unless (string-match wr str)
+ (goto-char (1- end))
+ (throw :skip t)))
+ regexps+)
+ (goto-char beg)
+ (setq marker (org-agenda-new-marker (point))
+ category (org-get-category)
+ tags (org-get-tags-at (point))
+ txt (org-format-agenda-item
+ ""
+ (buffer-substring-no-properties
+ beg1 (point-at-eol))
+ category tags))
+ (org-add-props txt props
+ 'org-marker marker 'org-hd-marker marker
+ 'priority 1000 'org-category category
+ 'type "search")
+ (push txt ee)
+ (goto-char (1- end)))))))))
+ (setq rtn (nreverse ee))
+ (setq rtnall (append rtnall rtn)))
+ (if org-agenda-overriding-header
+ (insert (org-add-props (copy-sequence org-agenda-overriding-header)
+ nil 'face 'org-agenda-structure) "\n")
+ (insert "Search words: ")
+ (add-text-properties (point-min) (1- (point))
+ (list 'face 'org-agenda-structure))
+ (setq pos (point))
+ (insert string "\n")
+ (add-text-properties pos (1- (point)) (list 'face 'org-warning))
+ (setq pos (point))
+ (unless org-agenda-multi
+ (insert "Press `[', `]' to add/sub word, `{', `}' to add/sub regexp, `C-u r' to edit\n")
+ (add-text-properties pos (1- (point))
+ (list 'face 'org-agenda-structure))))
+ (when rtnall
+ (insert (org-finalize-agenda-entries rtnall) "\n"))
+ (goto-char (point-min))
+ (org-fit-agenda-window)
+ (add-text-properties (point-min) (point-max) '(org-agenda-type search))
+ (org-finalize-agenda)
+ (setq buffer-read-only t)))
+
;;; Agenda TODO list
(defvar org-select-this-todo-keyword nil)
The prefix arg can be used to select a specific TODO keyword and limit
the list to these. When using \\[universal-argument], you will be prompted
for a keyword. A numeric prefix directly selects the Nth keyword in
-`org-todo-keywords'."
+`org-todo-keywords-1'."
(interactive "P")
(require 'calendar)
(org-compile-prefix-format 'todo)
(org-set-sorting-strategy 'todo)
+ (org-prepare-agenda "TODO")
(let* ((today (time-to-days (current-time)))
(date (calendar-gregorian-from-absolute today))
- (kwds org-todo-keywords)
+ (kwds org-todo-keywords-for-agenda)
(completion-ignore-case t)
(org-select-this-todo-keyword
(if (stringp arg) arg
(and arg (integerp arg) (> arg 0)
- (nth (1- arg) org-todo-keywords))))
+ (nth (1- arg) kwds))))
rtn rtnall files file pos)
(when (equal arg '(4))
(setq org-select-this-todo-keyword
- (completing-read "Keyword: " (mapcar 'list org-todo-keywords)
- nil t)))
+ (completing-read "Keyword (or KWD1|K2D2|...): "
+ (mapcar 'list kwds) nil nil)))
(and (equal 0 arg) (setq org-select-this-todo-keyword nil))
- (org-prepare-agenda)
(org-set-local 'org-last-arg arg)
- (org-set-local 'org-todo-keywords kwds)
(setq org-agenda-redo-command
'(org-todo-list (or current-prefix-arg org-last-arg)))
(setq files (org-agenda-files)
(setq rtnall (append rtnall rtn))))
(if org-agenda-overriding-header
(insert (org-add-props (copy-sequence org-agenda-overriding-header)
- nil 'face 'org-level-3) "\n")
+ nil 'face 'org-agenda-structure) "\n")
(insert "Global list of TODO items of type: ")
(add-text-properties (point-min) (1- (point))
- (list 'face 'org-level-3))
+ (list 'face 'org-agenda-structure))
(setq pos (point))
(insert (or org-select-this-todo-keyword "ALL") "\n")
(add-text-properties pos (1- (point)) (list 'face 'org-warning))
(setq pos (point))
(unless org-agenda-multi
- (insert
- "Available with `N r': (0)ALL "
- (let ((n 0))
- (mapconcat (lambda (x)
- (format "(%d)%s" (setq n (1+ n)) x))
- org-todo-keywords " "))
- "\n"))
- (add-text-properties pos (1- (point)) (list 'face 'org-level-3)))
+ (insert "Available with `N r': (0)ALL")
+ (let ((n 0) s)
+ (mapc (lambda (x)
+ (setq s (format "(%d)%s" (setq n (1+ n)) x))
+ (if (> (+ (current-column) (string-width s) 1) (frame-width))
+ (insert "\n "))
+ (insert " " s))
+ kwds))
+ (insert "\n"))
+ (add-text-properties pos (1- (point)) (list 'face 'org-agenda-structure)))
(when rtnall
(insert (org-finalize-agenda-entries rtnall) "\n"))
(goto-char (point-min))
buffer)
(setq matcher (org-make-tags-matcher match)
match (car matcher) matcher (cdr matcher))
- (org-prepare-agenda)
+ (org-prepare-agenda (concat "TAGS " match))
+ (setq org-agenda-query-string match)
(setq org-agenda-redo-command
(list 'org-tags-view (list 'quote todo-only)
- (list 'if 'current-prefix-arg nil match)))
+ (list 'if 'current-prefix-arg nil 'org-agenda-query-string)))
(setq files (org-agenda-files)
rtnall nil)
(while (setq file (pop files))
(with-current-buffer buffer
(unless (org-mode-p)
(error "Agenda file %s is not in `org-mode'" file))
- (setq org-category-table (org-get-category-table))
(save-excursion
(save-restriction
(if org-agenda-restrict
(setq rtnall (append rtnall rtn))))))))
(if org-agenda-overriding-header
(insert (org-add-props (copy-sequence org-agenda-overriding-header)
- nil 'face 'org-level-3) "\n")
+ nil 'face 'org-agenda-structure) "\n")
(insert "Headlines with TAGS match: ")
(add-text-properties (point-min) (1- (point))
- (list 'face 'org-level-3))
+ (list 'face 'org-agenda-structure))
(setq pos (point))
(insert match "\n")
(add-text-properties pos (1- (point)) (list 'face 'org-warning))
(setq pos (point))
(unless org-agenda-multi
(insert "Press `C-u r' to search again with new search string\n"))
- (add-text-properties pos (1- (point)) (list 'face 'org-level-3)))
+ (add-text-properties pos (1- (point)) (list 'face 'org-agenda-structure)))
(when rtnall
(insert (org-finalize-agenda-entries rtnall) "\n"))
(goto-char (point-min))
If yes, it returns the end position of this tree, causing agenda commands
to skip this subtree. This is a function that can be put into
`org-agenda-skip-function' for the duration of a command."
- (save-match-data
- (let ((end (save-excursion (org-end-of-subtree t)))
- skip)
- (save-excursion
- (setq skip (re-search-forward org-agenda-skip-regexp end t)))
- (and skip end))))
+ (let ((end (save-excursion (org-end-of-subtree t)))
+ skip)
+ (save-excursion
+ (setq skip (re-search-forward org-agenda-skip-regexp end t)))
+ (and skip end)))
+
+(defun org-agenda-skip-entry-if (&rest conditions)
+ "Skip entry if any of CONDITIONS is true.
+See `org-agenda-skip-if' for details."
+ (org-agenda-skip-if nil conditions))
+
+(defun org-agenda-skip-subtree-if (&rest conditions)
+ "Skip entry if any of CONDITIONS is true.
+See `org-agenda-skip-if' for details."
+ (org-agenda-skip-if t conditions))
+
+(defun org-agenda-skip-if (subtree conditions)
+ "Checks current entity for CONDITIONS.
+If SUBTREE is non-nil, the entire subtree is checked. Otherwise, only
+the entry, i.e. the text before the next heading is checked.
+
+CONDITIONS is a list of symbols, boolean OR is used to combine the results
+from different tests. Valid conditions are:
+
+scheduled Check if there is a scheduled cookie
+notscheduled Check if there is no scheduled cookie
+deadline Check if there is a deadline
+notdeadline Check if there is no deadline
+regexp Check if regexp matches
+notregexp Check if regexp does not match.
+
+The regexp is taken from the conditions list, it must come right after
+the `regexp' or `notregexp' element.
+
+If any of these conditions is met, this function returns the end point of
+the entity, causing the search to continue from there. This is a function
+that can be put into `org-agenda-skip-function' for the duration of a command."
+ (let (beg end m)
+ (org-back-to-heading t)
+ (setq beg (point)
+ end (if subtree
+ (progn (org-end-of-subtree t) (point))
+ (progn (outline-next-heading) (1- (point)))))
+ (goto-char beg)
+ (and
+ (or
+ (and (memq 'scheduled conditions)
+ (re-search-forward org-scheduled-time-regexp end t))
+ (and (memq 'notscheduled conditions)
+ (not (re-search-forward org-scheduled-time-regexp end t)))
+ (and (memq 'deadline conditions)
+ (re-search-forward org-deadline-time-regexp end t))
+ (and (memq 'notdeadline conditions)
+ (not (re-search-forward org-deadline-time-regexp end t)))
+ (and (setq m (memq 'regexp conditions))
+ (stringp (nth 1 m))
+ (re-search-forward (nth 1 m) end t))
+ (and (setq m (memq 'notregexp conditions))
+ (stringp (nth 1 m))
+ (not (re-search-forward (nth 1 m) end t))))
+ end)))
+;;;###autoload
(defun org-agenda-list-stuck-projects (&rest ignore)
"Create agenda view for projects that are stuck.
Stuck projects are project that have no next actions. For the definitions
MATCH is being ignored."
(interactive)
(let* ((org-agenda-skip-function 'org-agenda-skip-subtree-when-regexp-matches)
+ ;; FIXME: we could have used org-agenda-skip-if here.
(org-agenda-overriding-header "List of stuck projects: ")
(matcher (nth 0 org-stuck-projects))
(todo (nth 1 org-stuck-projects))
- (tags (nth 2 org-stuck-projects))
+ (todo-wds (if (member "*" todo)
+ (progn
+ (org-prepare-agenda-buffers (org-agenda-files))
+ (org-delete-all
+ org-done-keywords-for-agenda
+ (copy-sequence org-todo-keywords-for-agenda)))
+ todo))
(todo-re (concat "^\\*+[ \t]+\\("
- (mapconcat 'identity todo "\\|")
+ (mapconcat 'identity todo-wds "\\|")
"\\)\\>"))
- (tags-re (concat "^\\*+.*:\\("
- (mapconcat 'identity tags "\\|")
- "\\):[a-zA-Z0-9_@:]*[ \t]*$")))
-
+ (tags (nth 2 org-stuck-projects))
+ (tags-re (if (member "*" tags)
+ (org-re "^\\*+ .*:[[:alnum:]_@]+:[ \t]*$")
+ (concat "^\\*+ .*:\\("
+ (mapconcat 'identity tags "\\|")
+ (org-re "\\):[[:alnum:]_@:]*[ \t]*$"))))
+ (gen-re (nth 3 org-stuck-projects))
+ (re-list
+ (delq nil
+ (list
+ (if todo todo-re)
+ (if tags tags-re)
+ (and gen-re (stringp gen-re) (string-match "\\S-" gen-re)
+ gen-re)))))
(setq org-agenda-skip-regexp
- (cond
- ((and todo tags)
- (concat todo-re "\\|" tags-re))
- (todo todo-re)
- (tags tags-re)
- (t (error "No information how to identify unstuck projects"))))
+ (if re-list
+ (mapconcat 'identity re-list "\\|")
+ (error "No information how to identify unstuck projects")))
(org-tags-view nil matcher)
(with-current-buffer org-agenda-buffer-name
(setq org-agenda-redo-command
;;; Diary integration
(defvar org-disable-agenda-to-diary nil) ;Dynamically-scoped param.
+(defvar list-diary-entries-hook)
(defun org-get-entries-from-diary (date)
"Get the (Emacs Calendar) diary entries for DATE."
- (let* ((fancy-diary-buffer "*temporary-fancy-diary-buffer*")
+ (require 'diary-lib)
+ (let* ((diary-fancy-buffer "*temporary-fancy-diary-buffer*")
+ (fancy-diary-buffer diary-fancy-buffer)
(diary-display-hook '(fancy-diary-display))
+ (pop-up-frames nil)
(list-diary-entries-hook
(cons 'org-diary-default-entry list-diary-entries-hook))
(diary-file-name-prefix-function nil) ; turn this feature off
(org-disable-agenda-to-diary t))
(save-excursion
(save-window-excursion
- (list-diary-entries date 1))) ;; Keep this name for now, compatibility
- (if (not (get-buffer fancy-diary-buffer))
+ (funcall (if (fboundp 'diary-list-entries)
+ 'diary-list-entries 'list-diary-entries)
+ date 1)))
+ (if (not (get-buffer diary-fancy-buffer))
(setq entries nil)
- (with-current-buffer fancy-diary-buffer
+ (with-current-buffer diary-fancy-buffer
(setq buffer-read-only nil)
- (if (= (point-max) 1)
+ (if (zerop (buffer-size))
;; No entries
(setq entries nil)
;; Omit the date and other unnecessary stuff
(org-agenda-cleanup-fancy-diary)
;; Add prefix to each line and extend the text properties
- (if (= (point-max) 1)
+ (if (zerop (buffer-size))
(setq entries nil)
(setq entries (buffer-substring (point-min) (- (point-max) 1)))))
(set-buffer-modified-p nil)
- (kill-buffer fancy-diary-buffer)))
+ (kill-buffer diary-fancy-buffer)))
(when entries
(setq entries (org-split-string entries "\n"))
(setq entries
(lambda (x)
(setq x (org-format-agenda-item "" x "Diary" nil 'time))
;; Extend the text properties to the beginning of the line
- (org-add-props x (text-properties-at (1- (length x)) x)))
+ (org-add-props x (text-properties-at (1- (length x)) x)
+ 'type "diary" 'date date))
entries)))))
(defun org-agenda-cleanup-fancy-diary ()
(org-add-props string nil
'mouse-face 'highlight
'keymap org-agenda-keymap
- 'help-echo (format "mouse-2 or RET jump to diary file %s"
- (abbreviate-file-name buffer-file-name))
+ 'help-echo (if buffer-file-name
+ (format "mouse-2 or RET jump to diary file %s"
+ (abbreviate-file-name buffer-file-name))
+ "")
'org-agenda-diary-link t
'org-marker (org-agenda-new-marker (point-at-bol))))
date range matching the selected date. Deadlines will
also be listed, on the expiration day.
+ :sexp List entries resulting from diary-like sexps.
+
:deadline List any deadlines past due, or due within
`org-deadline-warning-days'. The listing occurs only
in the diary for *today*, not at any other date. If
&%%(org-diary)
If you don't give any arguments (as in the example above), the default
-arguments (:deadline :scheduled :timestamp) are used. So the example above may
-also be written as
+arguments (:deadline :scheduled :timestamp :sexp) are used.
+So the example above may also be written as
- &%%(org-diary :deadline :timestamp :scheduled)
+ &%%(org-diary :deadline :timestamp :sexp :scheduled)
The function expects the lisp variables `entry' and `date' to be provided
by the caller, because this is how the calendar works. Don't use this
function from a program - use `org-agenda-get-day-entries' instead."
- (org-agenda-maybe-reset-markers)
+ (when (> (- (time-to-seconds (current-time))
+ org-agenda-last-marker-time)
+ 5)
+ (org-agenda-reset-markers))
(org-compile-prefix-format 'agenda)
(org-set-sorting-strategy 'agenda)
- (setq args (or args '(:deadline :scheduled :timestamp)))
+ (setq args (or args '(:deadline :scheduled :timestamp :sexp)))
(let* ((files (if (and entry (stringp entry) (string-match "\\S-" entry))
(list entry)
(org-agenda-files t)))
file rtn results)
+ (org-prepare-agenda-buffers files)
;; If this is called during org-agenda, don't return any entries to
;; the calendar. Org Agenda will list these entries itself.
(if org-disable-agenda-to-diary (setq files nil))
the one returned by `calendar-current-date'. ARGS are symbols indicating
which kind of entries should be extracted. For details about these, see
the documentation of `org-diary'."
- (setq args (or args '(:deadline :scheduled :timestamp)))
+ (setq args (or args '(:deadline :scheduled :timestamp :sexp)))
(let* ((org-startup-folded nil)
(org-startup-align-all-tables nil)
(buffer (if (file-exists-p file)
(with-current-buffer buffer
(unless (org-mode-p)
(error "Agenda file %s is not in `org-mode'" file))
- (setq org-category-table (org-get-category-table))
(let ((case-fold-search nil))
(save-excursion
(save-restriction
(setq results (append results rtn))
(setq rtn (org-agenda-get-timestamps))
(setq results (append results rtn)))
+ ((eq arg :sexp)
+ (setq rtn (org-agenda-get-sexps))
+ (setq results (append results rtn)))
((eq arg :scheduled)
(setq rtn (org-agenda-get-scheduled))
(setq results (append results rtn)))
((eq arg :closed)
(setq rtn (org-agenda-get-closed))
(setq results (append results rtn)))
- ((and (eq arg :deadline)
- (equal date (calendar-current-date)))
+ ((eq arg :deadline)
(setq rtn (org-agenda-get-deadlines))
(setq results (append results rtn))))))))
results))))
+(defun org-entry-is-todo-p ()
+ (member (org-get-todo-state) org-not-done-keywords))
+
(defun org-entry-is-done-p ()
- "Is the current entry marked DONE?"
+ (member (org-get-todo-state) org-done-keywords))
+
+(defun org-get-todo-state ()
(save-excursion
- (and (re-search-backward "[\r\n]\\*" nil t)
- (looking-at org-nl-done-regexp))))
+ (org-back-to-heading t)
+ (and (looking-at org-todo-line-regexp)
+ (match-end 2)
+ (match-string 2))))
(defun org-at-date-range-p (&optional inactive-ok)
"Is the cursor inside a date range?"
(let* ((props (list 'face nil
'done-face 'org-done
'org-not-done-regexp org-not-done-regexp
+ 'org-todo-regexp org-todo-regexp
'mouse-face 'highlight
'keymap org-agenda-keymap
'help-echo
(format "mouse-2 or RET jump to org file %s"
(abbreviate-file-name buffer-file-name))))
- (regexp (concat "[\n\r]\\*+ *\\("
+ ;; FIXME: get rid of the \n at some point but watch out
+ (regexp (concat "^\\*+[ \t]+\\("
(if org-select-this-todo-keyword
- (concat "\\<\\(" org-select-this-todo-keyword
- "\\)\\>")
+ (if (equal org-select-this-todo-keyword "*")
+ org-todo-regexp
+ (concat "\\<\\("
+ (mapconcat 'identity (org-split-string org-select-this-todo-keyword "|") "\\|")
+ "\\)\\>"))
org-not-done-regexp)
"[^\n\r]*\\)"))
marker priority category tags
(save-match-data
(beginning-of-line)
(setq beg (point) end (progn (outline-next-heading) (point)))
- (when (or (and org-agenda-todo-ignore-scheduled (goto-char beg)
+ (when (or (and org-agenda-todo-ignore-with-date (goto-char beg)
+ (re-search-forward org-ts-regexp end t))
+ (and org-agenda-todo-ignore-scheduled (goto-char beg)
(re-search-forward org-scheduled-time-regexp end t))
(and org-agenda-todo-ignore-deadlines (goto-char beg)
(re-search-forward org-deadline-time-regexp end t)
(org-deadline-close (match-string 1))))
- (goto-char beg)
+ (goto-char (1+ beg))
(or org-agenda-todo-list-sublevels (org-end-of-subtree 'invisible))
(throw :skip nil)))
(goto-char beg)
(org-agenda-skip)
(goto-char (match-beginning 1))
- (setq marker (org-agenda-new-marker (1+ (match-beginning 0)))
+ (setq marker (org-agenda-new-marker (match-beginning 0))
category (org-get-category)
tags (org-get-tags-at (point))
txt (org-format-agenda-item "" (match-string 1) category tags)
- priority
- (+ (org-get-priority txt)
- (if org-todo-kwd-priority-p
- (- org-todo-kwd-max-priority -2
- (length
- (member (match-string 2) org-todo-keywords)))
- 1)))
+ priority (1+ (org-get-priority txt)))
(org-add-props txt props
'org-marker marker 'org-hd-marker marker
- 'priority priority 'org-category category)
+ 'priority priority 'org-category category
+ 'type "todo")
(push txt ee)
(if org-agenda-todo-list-sublevels
(goto-char (match-end 1))
"Return the date stamp information for agenda display."
(let* ((props (list 'face nil
'org-not-done-regexp org-not-done-regexp
+ 'org-todo-regexp org-todo-regexp
'mouse-face 'highlight
'keymap org-agenda-keymap
'help-echo
(format "mouse-2 or RET jump to org file %s"
(abbreviate-file-name buffer-file-name))))
- (regexp (regexp-quote
- (substring
- (format-time-string
- (car org-time-stamp-formats)
- (apply 'encode-time ; DATE bound by calendar
- (list 0 0 0 (nth 1 date) (car date) (nth 2 date))))
- 0 11)))
+ (d1 (calendar-absolute-from-gregorian date))
+ (remove-re
+ (concat
+ (regexp-quote
+ (format-time-string
+ "<%Y-%m-%d"
+ (encode-time 0 0 0 (nth 1 date) (nth 0 date) (nth 2 date))))
+ ".*?>"))
+ (regexp
+ (concat
+ (regexp-quote
+ (substring
+ (format-time-string
+ (car org-time-stamp-formats)
+ (apply 'encode-time ; DATE bound by calendar
+ (list 0 0 0 (nth 1 date) (car date) (nth 2 date))))
+ 0 11))
+ "\\|\\(<[0-9]+-[0-9]+-[0-9]+[^>\n]+?\\+[0-9]+[dwmy]>\\)"
+ "\\|\\(<%%\\(([^>\n]+)\\)>\\)"))
marker hdmarker deadlinep scheduledp donep tmp priority category
- ee txt timestr tags)
+ ee txt timestr tags b0 b3 e3 head)
(goto-char (point-min))
(while (re-search-forward regexp nil t)
+ (setq b0 (match-beginning 0)
+ b3 (match-beginning 3) e3 (match-end 3))
(catch :skip
- (and (save-match-data (org-at-date-range-p)) (throw :skip nil))
+ (and (org-at-date-range-p) (throw :skip nil))
(org-agenda-skip)
- (setq marker (org-agenda-new-marker (match-beginning 0))
- category (org-get-category (match-beginning 0))
+ (if (and (match-end 1)
+ (not (= d1 (org-time-string-to-absolute (match-string 1) d1))))
+ (throw :skip nil))
+ (if (and e3
+ (not (org-diary-sexp-entry (buffer-substring b3 e3) "" date)))
+ (throw :skip nil))
+ (setq marker (org-agenda-new-marker b0)
+ category (org-get-category b0)
tmp (buffer-substring (max (point-min)
- (- (match-beginning 0)
- org-ds-keyword-length))
- (match-beginning 0))
- timestr (buffer-substring (match-beginning 0) (point-at-eol))
+ (- b0 org-ds-keyword-length))
+ b0)
+ timestr (if b3 "" (buffer-substring b0 (point-at-eol)))
deadlinep (string-match org-deadline-regexp tmp)
scheduledp (string-match org-scheduled-regexp tmp)
donep (org-entry-is-done-p))
- (and org-agenda-skip-scheduled-if-done
- scheduledp donep
- (throw :skip t))
+ (if (or scheduledp deadlinep) (throw :skip t))
(if (string-match ">" timestr)
;; substring should only run to end of time stamp
(setq timestr (substring timestr 0 (match-end 0))))
(save-excursion
- (if (re-search-backward "\\(^\\|\r\\)\\*+" nil t)
+ (if (re-search-backward "^\\*+ " nil t)
(progn
- (goto-char (match-end 1))
+ (goto-char (match-beginning 0))
(setq hdmarker (org-agenda-new-marker)
tags (org-get-tags-at))
- (looking-at "\\*+[ \t]*\\([^\r\n]+\\)")
+ (looking-at "\\*+[ \t]+\\([^\r\n]+\\)")
+ (setq head (match-string 1))
+ (and org-agenda-skip-timestamp-if-done donep (throw :skip t))
(setq txt (org-format-agenda-item
- (format "%s%s"
- (if deadlinep "Deadline: " "")
- (if scheduledp "Scheduled: " ""))
- (match-string 1) category tags timestr)))
+ nil head category tags timestr nil
+ remove-re)))
(setq txt org-agenda-no-heading-message))
(setq priority (org-get-priority txt))
(org-add-props txt props
'org-marker marker 'org-hd-marker hdmarker)
- (if deadlinep
- (org-add-props txt nil
- 'face (if donep 'org-done 'org-warning)
- 'undone-face 'org-warning 'done-face 'org-done
- 'org-category category 'priority (+ 100 priority))
- (if scheduledp
- (org-add-props txt nil
- 'face 'org-scheduled-today
- 'undone-face 'org-scheduled-today 'done-face 'org-done
- 'org-category category 'priority (+ 99 priority))
- (org-add-props txt nil 'priority priority 'org-category category)))
+ (org-add-props txt nil 'priority priority
+ 'org-category category 'date date
+ 'type "timestamp")
(push txt ee))
(outline-next-heading)))
(nreverse ee)))
+(defun org-agenda-get-sexps ()
+ "Return the sexp information for agenda display."
+ (require 'diary-lib)
+ (let* ((props (list 'face nil
+ 'mouse-face 'highlight
+ 'keymap org-agenda-keymap
+ 'help-echo
+ (format "mouse-2 or RET jump to org file %s"
+ (abbreviate-file-name buffer-file-name))))
+ (regexp "^&?%%(")
+ marker category ee txt tags entry result beg b sexp sexp-entry)
+ (goto-char (point-min))
+ (while (re-search-forward regexp nil t)
+ (catch :skip
+ (org-agenda-skip)
+ (setq beg (match-beginning 0))
+ (goto-char (1- (match-end 0)))
+ (setq b (point))
+ (forward-sexp 1)
+ (setq sexp (buffer-substring b (point)))
+ (setq sexp-entry (if (looking-at "[ \t]*\\(\\S-.*\\)")
+ (org-trim (match-string 1))
+ ""))
+ (setq result (org-diary-sexp-entry sexp sexp-entry date))
+ (when result
+ (setq marker (org-agenda-new-marker beg)
+ category (org-get-category beg))
+
+ (if (string-match "\\S-" result)
+ (setq txt result)
+ (setq txt "SEXP entry returned empty string"))
+
+ (setq txt (org-format-agenda-item
+ "" txt category tags 'time))
+ (org-add-props txt props 'org-marker marker)
+ (org-add-props txt nil
+ 'org-category category 'date date
+ 'type "sexp")
+ (push txt ee))))
+ (nreverse ee)))
+
(defun org-agenda-get-closed ()
"Return the logged TODO entries for agenda display."
(let* ((props (list 'mouse-face 'highlight
'org-not-done-regexp org-not-done-regexp
+ 'org-todo-regexp org-todo-regexp
'keymap org-agenda-keymap
'help-echo
(format "mouse-2 or RET jump to org file %s"
;; substring should only run to end of time stamp
(setq timestr (substring timestr 0 (match-end 0))))
(save-excursion
- (if (re-search-backward "\\(^\\|\r\\)\\*+" nil t)
+ (if (re-search-backward "^\\*+ " nil t)
(progn
- (goto-char (match-end 1))
+ (goto-char (match-beginning 0))
(setq hdmarker (org-agenda-new-marker)
tags (org-get-tags-at))
- (looking-at "\\*+[ \t]*\\([^\r\n]+\\)")
+ (looking-at "\\*+[ \t]+\\([^\r\n]+\\)")
(setq txt (org-format-agenda-item
(if closedp "Closed: " "Clocked: ")
(match-string 1) category tags timestr)))
(org-add-props txt props
'org-marker marker 'org-hd-marker hdmarker 'face 'org-done
'priority priority 'org-category category
+ 'type "closed" 'date date
'undone-face 'org-warning 'done-face 'org-done)
(push txt ee))
- (outline-next-heading)))
+ (goto-char (point-at-eol))))
(nreverse ee)))
(defun org-agenda-get-deadlines ()
"Return the deadline information for agenda display."
- (let* ((wdays org-deadline-warning-days)
- (props (list 'mouse-face 'highlight
+ (let* ((props (list 'mouse-face 'highlight
'org-not-done-regexp org-not-done-regexp
+ 'org-todo-regexp org-todo-regexp
'keymap org-agenda-keymap
'help-echo
(format "mouse-2 or RET jump to org file %s"
(regexp org-deadline-time-regexp)
(todayp (equal date (calendar-current-date))) ; DATE bound by calendar
(d1 (calendar-absolute-from-gregorian date)) ; DATE bound by calendar
- d2 diff pos pos1 category tags
- ee txt head face)
+ d2 diff dfrac wdays pos pos1 category tags
+ ee txt head face s upcomingp donep timestr)
(goto-char (point-min))
(while (re-search-forward regexp nil t)
(catch :skip
(org-agenda-skip)
- (setq pos (1- (match-beginning 1))
- d2 (time-to-days
- (org-time-string-to-time (match-string 1)))
- diff (- d2 d1))
+ (setq s (match-string 1)
+ pos (1- (match-beginning 1))
+ d2 (org-time-string-to-absolute (match-string 1) d1 'past)
+ diff (- d2 d1)
+ wdays (org-get-wdays s)
+ dfrac (/ (* 1.0 (- wdays diff)) (max wdays 1))
+ upcomingp (and todayp (> diff 0)))
;; When to show a deadline in the calendar:
;; If the expiration is within wdays warning time.
;; Past-due deadlines are only shown on the current date
- (if (and (< diff wdays) todayp (not (= diff 0)))
+ (if (or (and (<= diff wdays)
+ (and todayp (not org-agenda-only-exact-dates)))
+ (= diff 0))
(save-excursion
(setq category (org-get-category))
- (if (re-search-backward "\\(^\\|\r\\)\\*+[ \t]*" nil t)
+ (if (re-search-backward "^\\*+[ \t]+" nil t)
(progn
(goto-char (match-end 0))
- (setq pos1 (match-end 1))
+ (setq pos1 (match-beginning 0))
(setq tags (org-get-tags-at pos1))
(setq head (buffer-substring-no-properties
(point)
(progn (skip-chars-forward "^\r\n")
(point))))
- (if (string-match org-looking-at-done-regexp head)
+ (setq donep (string-match org-looking-at-done-regexp head))
+ (if (string-match " \\([012]?[0-9]:[0-9][0-9]\\)" s)
+ (setq timestr
+ (concat (substring s (match-beginning 1)) " "))
+ (setq timestr 'time))
+ (if (and donep
+ (or org-agenda-skip-deadline-if-done
+ (not (= diff 0))))
(setq txt nil)
(setq txt (org-format-agenda-item
- (format "In %3d d.: " diff) head category tags))))
+ (if (= diff 0)
+ (car org-agenda-deadline-leaders)
+ (format (nth 1 org-agenda-deadline-leaders)
+ diff))
+ head category tags timestr))))
(setq txt org-agenda-no-heading-message))
(when txt
- (setq face (cond ((<= diff 0) 'org-warning)
- ((<= diff 5) 'org-upcoming-deadline)
- (t nil)))
+ (setq face (org-agenda-deadline-face dfrac wdays))
(org-add-props txt props
'org-marker (org-agenda-new-marker pos)
'org-hd-marker (org-agenda-new-marker pos1)
- 'priority (+ (- 10 diff) (org-get-priority txt))
+ 'priority (+ (- diff)
+ (org-get-priority txt))
'org-category category
- 'face face 'undone-face face 'done-face 'org-done)
+ 'type (if upcomingp "upcoming-deadline" "deadline")
+ 'date (if upcomingp date d2)
+ 'face (if donep 'org-done face)
+ 'undone-face face 'done-face 'org-done)
(push txt ee))))))
- ee))
+ (nreverse ee)))
+
+(defun org-agenda-deadline-face (fraction &optional wdays)
+ "Return the face to displaying a deadline item.
+FRACTION is what fraction of the head-warning time has passed."
+ (if (equal wdays 0) (setq fraction 1.))
+ (let ((faces org-agenda-deadline-faces) f)
+ (catch 'exit
+ (while (setq f (pop faces))
+ (if (>= fraction (car f)) (throw 'exit (cdr f)))))))
(defun org-agenda-get-scheduled ()
"Return the scheduled information for agenda display."
- (let* ((props (list 'face 'org-scheduled-previously
- 'org-not-done-regexp org-not-done-regexp
- 'undone-face 'org-scheduled-previously
+ (let* ((props (list 'org-not-done-regexp org-not-done-regexp
+ 'org-todo-regexp org-todo-regexp
'done-face 'org-done
'mouse-face 'highlight
'keymap org-agenda-keymap
(todayp (equal date (calendar-current-date))) ; DATE bound by calendar
(d1 (calendar-absolute-from-gregorian date)) ; DATE bound by calendar
d2 diff pos pos1 category tags
- ee txt head)
+ ee txt head pastschedp donep face timestr s)
(goto-char (point-min))
(while (re-search-forward regexp nil t)
(catch :skip
(org-agenda-skip)
- (setq pos (1- (match-beginning 1))
- d2 (time-to-days
- (org-time-string-to-time (match-string 1)))
+ (setq s (match-string 1)
+ pos (1- (match-beginning 1))
+ d2 (org-time-string-to-absolute (match-string 1) d1 'past)
+;;; is this right?
+;;; do we need to do this for deadleine too????
+;;; d2 (org-time-string-to-absolute (match-string 1) (if todayp nil d1))
diff (- d2 d1))
+ (setq pastschedp (and todayp (< diff 0)))
;; When to show a scheduled item in the calendar:
;; If it is on or past the date.
- (if (and (< diff 0) todayp)
+ (if (or (and (< diff 0)
+ (and todayp (not org-agenda-only-exact-dates)))
+ (= diff 0))
(save-excursion
(setq category (org-get-category))
- (if (re-search-backward "\\(^\\|\r\\)\\*+[ \t]*" nil t)
+ (if (re-search-backward "^\\*+[ \t]+" nil t)
(progn
(goto-char (match-end 0))
- (setq pos1 (match-end 1))
+ (setq pos1 (match-beginning 0))
(setq tags (org-get-tags-at))
(setq head (buffer-substring-no-properties
(point)
(progn (skip-chars-forward "^\r\n") (point))))
- (if (string-match org-looking-at-done-regexp head)
+ (setq donep (string-match org-looking-at-done-regexp head))
+ (if (string-match " \\([012]?[0-9]:[0-9][0-9]\\)" s)
+ (setq timestr
+ (concat (substring s (match-beginning 1)) " "))
+ (setq timestr 'time))
+ (if (and donep
+ (or org-agenda-skip-scheduled-if-done
+ (not (= diff 0))))
(setq txt nil)
(setq txt (org-format-agenda-item
- (format "Sched.%2dx: " (- 1 diff)) head
- category tags))))
+ (if (= diff 0)
+ (car org-agenda-scheduled-leaders)
+ (format (nth 1 org-agenda-scheduled-leaders)
+ (- 1 diff)))
+ head category tags timestr))))
(setq txt org-agenda-no-heading-message))
(when txt
+ (setq face (if pastschedp
+ 'org-scheduled-previously
+ 'org-scheduled-today))
(org-add-props txt props
+ 'undone-face face
+ 'face (if donep 'org-done face)
'org-marker (org-agenda-new-marker pos)
'org-hd-marker (org-agenda-new-marker pos1)
- 'priority (+ (- 5 diff) (org-get-priority txt))
+ 'type (if pastschedp "past-scheduled" "scheduled")
+ 'date (if pastschedp d2 date)
+ 'priority (+ 94 (- 5 diff) (org-get-priority txt))
'org-category category)
(push txt ee))))))
- ee))
+ (nreverse ee)))
(defun org-agenda-get-blocks ()
"Return the date-range information for agenda display."
(let* ((props (list 'face nil
'org-not-done-regexp org-not-done-regexp
+ 'org-todo-regexp org-todo-regexp
'mouse-face 'highlight
'keymap org-agenda-keymap
'help-echo
(abbreviate-file-name buffer-file-name))))
(regexp org-tr-regexp)
(d0 (calendar-absolute-from-gregorian date))
- marker hdmarker ee txt d1 d2 s1 s2 timestr category tags pos)
+ marker hdmarker ee txt d1 d2 s1 s2 timestr category tags pos
+ donep head)
(goto-char (point-min))
(while (re-search-forward regexp nil t)
(catch :skip
(save-excursion
(setq marker (org-agenda-new-marker (point)))
(setq category (org-get-category))
- (if (re-search-backward "\\(^\\|\r\\)\\*+" nil t)
+ (if (re-search-backward "^\\*+ " nil t)
(progn
- (setq hdmarker (org-agenda-new-marker (match-end 1)))
- (goto-char (match-end 1))
+ (goto-char (match-beginning 0))
+ (setq hdmarker (org-agenda-new-marker (point)))
(setq tags (org-get-tags-at))
- (looking-at "\\*+[ \t]*\\([^\r\n]+\\)")
+ (looking-at "\\*+[ \t]+\\([^\r\n]+\\)")
+ (setq head (match-string 1))
+ (and org-agenda-skip-timestamp-if-done
+ (org-entry-is-done-p)
+ (throw :skip t))
(setq txt (org-format-agenda-item
(format (if (= d1 d2) "" "(%d/%d): ")
(1+ (- d0 d1)) (1+ (- d2 d1)))
- (match-string 1) category tags
+ head category tags
(if (= d0 d1) timestr))))
(setq txt org-agenda-no-heading-message))
(org-add-props txt props
'org-marker marker 'org-hd-marker hdmarker
+ 'type "block" 'date date
'priority (org-get-priority txt) 'org-category category)
(push txt ee)))
(goto-char pos)))
;;; Agenda presentation and sorting
-;; FIXME: should I allow spaces around the dash?
(defconst org-plain-time-of-day-regexp
(concat
"\\(\\<[012]?[0-9]"
Examples: 11:45 or 8am-13:15 or 2:45-2:45pm. After a match, the following
groups carry important information:
0 the full match
-1 the first time, range or not
-8 the second time, if it is a range.")
+1 the first time, range or not
+8 the second time, if it is a range.")
+
+(defconst org-plain-time-extension-regexp
+ (concat
+ "\\(\\<[012]?[0-9]"
+ "\\(\\(:\\([0-5][0-9]\\([AaPp][Mm]\\)?\\)\\)\\|\\([AaPp][Mm]\\)\\)\\>\\)"
+ "\\+\\([0-9]+\\)\\(:\\([0-5][0-9]\\)\\)?")
+ "Regular expression to match a time range like 13:30+2:10 = 13:30-15:40.
+Examples: 11:45 or 8am-13:15 or 2:45-2:45pm. After a match, the following
+groups carry important information:
+0 the full match
+7 hours of duration
+9 minutes of duration")
(defconst org-stamp-time-of-day-regexp
(concat
"<\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\} +\\sw+ +\\)"
- "\\([012][0-9]:[0-5][0-9]\\)>"
+ "\\([012][0-9]:[0-5][0-9]\\(-\\([012][0-9]:[0-5][0-9]\\)\\)?[^\n\r>]*?\\)>"
"\\(--?"
"<\\1\\([012][0-9]:[0-5][0-9]\\)>\\)?")
"Regular expression to match a timestamp time or time range.
The flag is set if the currently compiled format contains a `%T'.")
(defun org-format-agenda-item (extra txt &optional category tags dotime
- noprefix)
+ noprefix remove-re)
"Format TXT to be inserted into the agenda buffer.
In particular, it adds the prefix and corresponding text properties. EXTRA
must be a string and replaces the `%s' specifier in the prefix format.
the `%t' specifier in the format. When DOTIME is a string, this string is
searched for a time before TXT is. NOPREFIX is a flag and indicates that
only the correctly processes TXT should be returned - this is used by
-`org-agenda-change-all-lines'. TAGS can be the tags of the headline."
+`org-agenda-change-all-lines'. TAGS can be the tags of the headline.
+Any match of REMOVE-RE will be removed from TXT."
(save-match-data
;; Diary entries sometimes have extra whitespace at the beginning
(if (string-match "^ +" txt) (setq txt (replace-match "" nil nil txt)))
time ; time and tag are needed for the eval of the prefix format
(ts (if dotime (concat (if (stringp dotime) dotime "") txt)))
(time-of-day (and dotime (org-get-time-of-day ts)))
- stamp plain s0 s1 s2 rtn)
+ stamp plain s0 s1 s2 rtn srp)
(when (and dotime time-of-day org-prefix-has-time)
;; Extract starting and ending time and move them to prefix
(when (or (setq stamp (string-match org-stamp-time-of-day-regexp ts))
(setq plain (string-match org-plain-time-of-day-regexp ts)))
(setq s0 (match-string 0 ts)
+ srp (and stamp (match-end 3))
s1 (match-string (if plain 1 2) ts)
- s2 (match-string (if plain 8 4) ts))
+ s2 (match-string (if plain 8 (if srp 4 6)) ts))
;; If the times are in TXT (not in DOTIMES), and the prefix will list
;; them, we might want to remove them there to avoid duplication.
;; The user can turn this off with a variable.
(if (and org-agenda-remove-times-when-in-prefix (or stamp plain)
(string-match (concat (regexp-quote s0) " *") txt)
+ (not (equal ?\] (string-to-char (substring txt (match-end 0)))))
(if (eq org-agenda-remove-times-when-in-prefix 'beg)
(= (match-beginning 0) 0)
t))
(if s1 (setq s1 (org-get-time-of-day s1 'string t)))
(if s2 (setq s2 (org-get-time-of-day s2 'string t))))
- (when (string-match "\\([ \t]+\\)\\(:[a-zA-Z_@0-9:]+:\\)[ \t]*$" txt)
+ (when (and s1 (not s2) org-agenda-default-appointment-duration
+ (string-match "\\([0-9]+\\):\\([0-9]+\\)" s1))
+ (let ((m (+ (string-to-number (match-string 2 s1))
+ (* 60 (string-to-number (match-string 1 s1)))
+ org-agenda-default-appointment-duration))
+ h)
+ (setq h (/ m 60) m (- m (* h 60)))
+ (setq s2 (format "%02d:%02d" h m))))
+
+ (when (string-match (org-re "\\([ \t]+\\)\\(:[[:alnum:]_@:]+:\\)[ \t]*$")
+ txt)
;; Tags are in the string
- (if (or (eq org-agenda-remove-tags-when-in-prefix t)
- (and org-agenda-remove-tags-when-in-prefix
+ (if (or (eq org-agenda-remove-tags t)
+ (and org-agenda-remove-tags
org-prefix-has-tag))
(setq txt (replace-match "" t t txt))
(setq txt (replace-match
(match-string 2 txt))
t t txt))))
+ (when remove-re
+ (while (string-match remove-re txt)
+ (setq txt (replace-match "" t t txt))))
+
;; Create the final string
(if noprefix
(setq rtn txt)
;; And finally add the text properties
(org-add-props rtn nil
'org-category (downcase category) 'tags tags
+ 'org-highest-priority org-highest-priority
+ 'org-lowest-priority org-lowest-priority
'prefix-length (- (length rtn) (length txt))
'time-of-day time-of-day
+ 'txt txt
+ 'time time
+ 'extra extra
'dotime dotime))))
-(defvar org-agenda-sorting-strategy)
+(defvar org-agenda-sorting-strategy) ;; because the def is in a let form
(defvar org-agenda-sorting-strategy-selected nil)
(defun org-agenda-add-time-grid-maybe (list ndays todayp)
HH:MM."
(save-match-data
(when
- (or
- (string-match
- "\\<\\([012]?[0-9]\\)\\(:\\([0-5][0-9]\\)\\)\\([AaPp][Mm]\\)?\\> *" s)
- (string-match
- "\\<\\([012]?[0-9]\\)\\(:\\([0-5][0-9]\\)\\)?\\([AaPp][Mm]\\)\\> *" s))
+ (or (string-match "\\<\\([012]?[0-9]\\)\\(:\\([0-5][0-9]\\)\\)\\([AaPp][Mm]\\)?\\> *" s)
+ (string-match "\\<\\([012]?[0-9]\\)\\(:\\([0-5][0-9]\\)\\)?\\([AaPp][Mm]\\)\\> *" s))
(let* ((h (string-to-number (match-string 1 s)))
(m (if (match-end 3) (string-to-number (match-string 3 s)) 0))
(ampm (if (match-end 4) (downcase (match-string 4 s))))
(if (eq x 'line)
(save-excursion
(beginning-of-line 1)
- (setq re (get-text-property (point) 'org-not-done-regexp))
+ (setq re (get-text-property (point) 'org-todo-regexp))
(goto-char (+ (point) (or (get-text-property (point) 'prefix-length) 0)))
- (and (looking-at (concat "[ \t]*\\.*" re))
- (add-text-properties (match-beginning 0) (match-end 0)
- '(face org-todo))))
- (setq re (concat (get-text-property 0 'org-not-done-regexp x))
+ (when (looking-at (concat "[ \t]*\\.*" re " +"))
+ (add-text-properties (match-beginning 0) (match-end 0)
+ (list 'face (org-get-todo-face 0)))
+ (let ((s (buffer-substring (match-beginning 1) (match-end 1))))
+ (delete-region (match-beginning 1) (1- (match-end 0)))
+ (goto-char (match-beginning 1))
+ (insert (format org-agenda-todo-keyword-format s)))))
+ (setq re (concat (get-text-property 0 'org-todo-regexp x))
pl (get-text-property 0 'prefix-length x))
- (and re (equal (string-match (concat "\\(\\.*\\)" re) x (or pl 0)) pl)
- (add-text-properties (or (match-end 1) (match-end 0)) (match-end 0)
- '(face org-todo) x))
+ (when (and re
+ (equal (string-match (concat "\\(\\.*\\)" re "\\( +\\)")
+ x (or pl 0)) pl))
+ (add-text-properties
+ (or (match-end 1) (match-end 0)) (match-end 0)
+ (list 'face (org-get-todo-face (match-string 2 x)))
+ x)
+ (setq x (concat (substring x 0 (match-end 1))
+ (format org-agenda-todo-keyword-format
+ (match-string 2 x))
+ " "
+ (substring x (match-end 3)))))
x)))
(defsubst org-cmp-priority (a b)
(defsubst org-cmp-category (a b)
"Compare the string values of categories of strings A and B."
- (let ((ca (or (get-text-property 1 'category a) ""))
- (cb (or (get-text-property 1 'category b) "")))
+ (let ((ca (or (get-text-property 1 'org-category a) ""))
+ (cb (or (get-text-property 1 'org-category b) "")))
(cond ((string-lessp ca cb) -1)
((string-lessp cb ca) +1)
(t nil))))
(eval (cons 'or org-agenda-sorting-strategy-selected))
'((-1 . t) (1 . nil) (nil . nil))))))
+;;; Agenda restriction lock
+
+(defvar org-agenda-restriction-lock-overlay (org-make-overlay 1 1)
+ "Overlay to mark the headline to which arenda commands are restricted.")
+(org-overlay-put org-agenda-restriction-lock-overlay
+ 'face 'org-agenda-restriction-lock)
+(org-overlay-put org-agenda-restriction-lock-overlay
+ 'help-echo "Agendas are currently limited to this subtree.")
+(org-detach-overlay org-agenda-restriction-lock-overlay)
+(defvar org-speedbar-restriction-lock-overlay (org-make-overlay 1 1)
+ "Overlay marking the agenda restriction line in speedbar.")
+(org-overlay-put org-speedbar-restriction-lock-overlay
+ 'face 'org-agenda-restriction-lock)
+(org-overlay-put org-speedbar-restriction-lock-overlay
+ 'help-echo "Agendas are currently limited to this item.")
+(org-detach-overlay org-speedbar-restriction-lock-overlay)
+
+(defun org-agenda-set-restriction-lock (&optional type)
+ "Set restriction lock for agenda, to current subtree or file.
+Restriction will be the file if TYPE is `file', or if type is the
+universal prefix '(4), or if the cursor is before the first headline
+in the file. Otherwise, restriction will be to the current subtree."
+ (interactive "P")
+ (and (equal type '(4)) (setq type 'file))
+ (setq type (cond
+ (type type)
+ ((org-at-heading-p) 'subtree)
+ ((condition-case nil (org-back-to-heading t) (error nil))
+ 'subtree)
+ (t 'file)))
+ (if (eq type 'subtree)
+ (progn
+ (setq org-agenda-restrict t)
+ (setq org-agenda-overriding-restriction 'subtree)
+ (put 'org-agenda-files 'org-restrict
+ (list (buffer-file-name (buffer-base-buffer))))
+ (org-back-to-heading t)
+ (org-move-overlay org-agenda-restriction-lock-overlay (point) (point-at-eol))
+ (move-marker org-agenda-restrict-begin (point))
+ (move-marker org-agenda-restrict-end
+ (save-excursion (org-end-of-subtree t)))
+ (message "Locking agenda restriction to subtree"))
+ (put 'org-agenda-files 'org-restrict
+ (list (buffer-file-name (buffer-base-buffer))))
+ (setq org-agenda-restrict nil)
+ (setq org-agenda-overriding-restriction 'file)
+ (move-marker org-agenda-restrict-begin nil)
+ (move-marker org-agenda-restrict-end nil)
+ (message "Locking agenda restriction to file"))
+ (setq current-prefix-arg nil)
+ (org-agenda-maybe-redo))
+
+(defun org-agenda-remove-restriction-lock (&optional noupdate)
+ "Remove the agenda restriction lock."
+ (interactive "P")
+ (org-detach-overlay org-agenda-restriction-lock-overlay)
+ (org-detach-overlay org-speedbar-restriction-lock-overlay)
+ (setq org-agenda-overriding-restriction nil)
+ (setq org-agenda-restrict nil)
+ (put 'org-agenda-files 'org-restrict nil)
+ (move-marker org-agenda-restrict-begin nil)
+ (move-marker org-agenda-restrict-end nil)
+ (setq current-prefix-arg nil)
+ (message "Agenda restriction lock removed")
+ (or noupdate (org-agenda-maybe-redo)))
+
+(defun org-agenda-maybe-redo ()
+ "If there is any window showing the agenda view, update it."
+ (let ((w (get-buffer-window org-agenda-buffer-name t))
+ (w0 (selected-window)))
+ (when w
+ (select-window w)
+ (org-agenda-redo)
+ (select-window w0)
+ (if org-agenda-overriding-restriction
+ (message "Agenda view shifted to new %s restriction"
+ org-agenda-overriding-restriction)
+ (message "Agenda restriction lock removed")))))
+
;;; Agenda commands
(defun org-agenda-check-type (error &rest types)
(let ((buf (current-buffer)))
(if (not (one-window-p)) (delete-window))
(kill-buffer buf)
- (org-agenda-maybe-reset-markers 'force))
+ (org-agenda-reset-markers)
+ (org-columns-remove-overlays))
;; Maybe restore the pre-agenda window configuration.
(and org-agenda-restore-windows-after-quit
(not (eq org-agenda-window-setup 'other-frame))
(setq org-agenda-new-buffers nil)
(org-agenda-quit))
+(defun org-agenda-execute (arg)
+ "Execute another agenda command, keeping same window.\\<global-map>
+So this is just a shortcut for `\\[org-agenda]', available in the agenda."
+ (interactive "P")
+ (let ((org-agenda-window-setup 'current-window))
+ (org-agenda arg)))
+
(defun org-save-all-org-buffers ()
"Save all Org-mode buffers without user confirmation."
(interactive)
(interactive)
(let* ((org-agenda-keep-modes t)
(line (org-current-line))
- (window-line (- line (org-current-line (window-start)))))
+ (window-line (- line (org-current-line (window-start))))
+ (lprops (get 'org-agenda-redo-command 'org-lprops)))
(message "Rebuilding agenda buffer...")
- (eval org-agenda-redo-command)
+ (org-let lprops '(eval org-agenda-redo-command))
(setq org-agenda-undo-list nil
org-agenda-pending-undo-list nil)
(message "Rebuilding agenda buffer...done")
(goto-line line)
(recenter window-line)))
+(defun org-agenda-manipulate-query-add ()
+ "Manipulate the query by adding a search term with positive selection.
+Positive selection means, the term must be matched for selection of an entry."
+ (interactive)
+ (org-agenda-manipulate-query ?\[))
+(defun org-agenda-manipulate-query-subtract ()
+ "Manipulate the query by adding a search term with negative selection.
+Negative selection means, term must not be matched for selection of an entry."
+ (interactive)
+ (org-agenda-manipulate-query ?\]))
+(defun org-agenda-manipulate-query-add-re ()
+ "Manipulate the query by adding a search regexp with positive selection.
+Positive selection means, the regexp must match for selection of an entry."
+ (interactive)
+ (org-agenda-manipulate-query ?\{))
+(defun org-agenda-manipulate-query-subtract-re ()
+ "Manipulate the query by adding a search regexp with negative selection.
+Negative selection means, regexp must not match for selection of an entry."
+ (interactive)
+ (org-agenda-manipulate-query ?\}))
+(defun org-agenda-manipulate-query (char)
+ (cond
+ ((eq org-agenda-type 'search)
+ (org-add-to-string
+ 'org-agenda-query-string
+ (cdr (assoc char '((?\[ . " +") (?\] . " -")
+ (?\{ . " +{}") (?\} . " -{}")))))
+ (setq org-agenda-redo-command
+ (list 'org-search-view
+ (+ (length org-agenda-query-string)
+ (if (member char '(?\{ ?\})) 0 1))
+ org-agenda-query-string))
+ (set-register org-agenda-query-register org-agenda-query-string)
+ (org-agenda-redo))
+ (t (error "Canot manipulate query for %s-type agenda buffers"
+ org-agenda-type))))
+
+(defun org-add-to-string (var string)
+ (set var (concat (symbol-value var) string)))
+
+(defun org-agenda-goto-date (date)
+ "Jump to DATE in agenda."
+ (interactive (list (org-read-date)))
+ (org-agenda-list nil date))
+
(defun org-agenda-goto-today ()
"Go to today."
(interactive)
(cond
(tdpos (goto-char tdpos))
((eq org-agenda-type 'agenda)
- (let ((org-agenda-overriding-arguments org-agenda-last-arguments))
- (setf (nth 1 org-agenda-overriding-arguments) nil)
+ (let* ((sd (time-to-days
+ (time-subtract (current-time)
+ (list 0 (* 3600 org-extend-today-until) 0))))
+ (comp (org-agenda-compute-time-span sd org-agenda-span))
+ (org-agenda-overriding-arguments org-agenda-last-arguments))
+ (setf (nth 1 org-agenda-overriding-arguments) (car comp))
+ (setf (nth 2 org-agenda-overriding-arguments) (cdr comp))
(org-agenda-redo)
- (org-agenda-find-today-or-agenda)))
+ (org-agenda-find-same-or-today-or-agenda)))
(t (error "Cannot find today")))))
-(defun org-agenda-find-today-or-agenda ()
+(defun org-agenda-find-same-or-today-or-agenda (&optional cnt)
(goto-char
- (or (text-property-any (point-min) (point-max) 'org-today t)
+ (or (and cnt (text-property-any (point-min) (point-max) 'org-day-cnt cnt))
+ (text-property-any (point-min) (point-max) 'org-today t)
(text-property-any (point-min) (point-max) 'org-agenda-type 'agenda)
(point-min))))
(defun org-agenda-later (arg)
- "Go forward in time by `org-agenda-ndays' days.
-With prefix ARG, go forward that many times `org-agenda-ndays'."
+ "Go forward in time by thee current span.
+With prefix ARG, go forward that many times the current span."
(interactive "p")
(org-agenda-check-type t 'agenda)
- (let ((org-agenda-overriding-arguments
- (list (car org-agenda-last-arguments)
- (+ org-starting-day (* arg org-agenda-ndays))
- nil t)))
- (org-agenda-redo)
- (org-agenda-find-today-or-agenda)))
+ (let* ((span org-agenda-span)
+ (sd org-starting-day)
+ (greg (calendar-gregorian-from-absolute sd))
+ (cnt (get-text-property (point) 'org-day-cnt))
+ greg2 nd)
+ (cond
+ ((eq span 'day)
+ (setq sd (+ arg sd) nd 1))
+ ((eq span 'week)
+ (setq sd (+ (* 7 arg) sd) nd 7))
+ ((eq span 'month)
+ (setq greg2 (list (+ (car greg) arg) (nth 1 greg) (nth 2 greg))
+ sd (calendar-absolute-from-gregorian greg2))
+ (setcar greg2 (1+ (car greg2)))
+ (setq nd (- (calendar-absolute-from-gregorian greg2) sd)))
+ ((eq span 'year)
+ (setq greg2 (list (car greg) (nth 1 greg) (+ arg (nth 2 greg)))
+ sd (calendar-absolute-from-gregorian greg2))
+ (setcar (nthcdr 2 greg2) (1+ (nth 2 greg2)))
+ (setq nd (- (calendar-absolute-from-gregorian greg2) sd))))
+ (let ((org-agenda-overriding-arguments
+ (list (car org-agenda-last-arguments) sd nd t)))
+ (org-agenda-redo)
+ (org-agenda-find-same-or-today-or-agenda cnt))))
(defun org-agenda-earlier (arg)
- "Go back in time by `org-agenda-ndays' days.
-With prefix ARG, go back that many times `org-agenda-ndays'."
+ "Go backward in time by the current span.
+With prefix ARG, go backward that many times the current span."
(interactive "p")
- (org-agenda-check-type t 'agenda)
- (let ((org-agenda-overriding-arguments
- (list (car org-agenda-last-arguments)
- (- org-starting-day (* arg org-agenda-ndays))
- nil t)))
- (org-agenda-redo)
- (org-agenda-find-today-or-agenda)))
+ (org-agenda-later (- arg)))
+(defun org-agenda-day-view ()
+ "Switch to daily view for agenda."
+ (interactive)
+ (setq org-agenda-ndays 1)
+ (org-agenda-change-time-span 'day))
(defun org-agenda-week-view ()
- "Switch to weekly view for agenda."
+ "Switch to daily view for agenda."
(interactive)
- (org-agenda-check-type t 'agenda)
- (if (= org-agenda-ndays 7)
- (error "This is already the week view"))
(setq org-agenda-ndays 7)
- (let ((org-agenda-overriding-arguments
- (list (car org-agenda-last-arguments)
- (or (get-text-property (point) 'day)
- org-starting-day)
- nil t)))
- (org-agenda-redo)
- (org-agenda-find-today-or-agenda))
- (org-agenda-set-mode-name)
- (message "Switched to week view"))
-
-(defun org-agenda-day-view ()
+ (org-agenda-change-time-span 'week))
+(defun org-agenda-month-view ()
+ "Switch to daily view for agenda."
+ (interactive)
+ (org-agenda-change-time-span 'month))
+(defun org-agenda-year-view ()
"Switch to daily view for agenda."
(interactive)
+ (if (y-or-n-p "Are you sure you want to compute the agenda for an entire year? ")
+ (org-agenda-change-time-span 'year)
+ (error "Abort")))
+
+(defun org-agenda-change-time-span (span)
+ "Change the agenda view to SPAN.
+SPAN may be `day', `week', `month', `year'."
(org-agenda-check-type t 'agenda)
- (if (= org-agenda-ndays 1)
- (error "This is already the day view"))
- (setq org-agenda-ndays 1)
- (let ((org-agenda-overriding-arguments
- (list (car org-agenda-last-arguments)
- (or (get-text-property (point) 'day)
- org-starting-day)
- nil t)))
+ (if (equal org-agenda-span span)
+ (error "Viewing span is already \"%s\"" span))
+ (let* ((sd (or (get-text-property (point) 'day)
+ org-starting-day))
+ (computed (org-agenda-compute-time-span sd span))
+ (org-agenda-overriding-arguments
+ (list (car org-agenda-last-arguments)
+ (car computed) (cdr computed) t)))
(org-agenda-redo)
- (org-agenda-find-today-or-agenda))
+ (org-agenda-find-same-or-today-or-agenda))
(org-agenda-set-mode-name)
- (message "Switched to day view"))
-
-;; FIXME: this no longer works if user make date format that starts with a blank
+ (message "Switched to %s view" span))
+
+(defun org-agenda-compute-time-span (sd span)
+ "Compute starting date and number of days for agenda.
+SPAN may be `day', `week', `month', `year'. The return value
+is a cons cell with the starting date and the number of days,
+so that the date SD will be in that range."
+ (let* ((greg (calendar-gregorian-from-absolute sd))
+ nd)
+ (cond
+ ((eq span 'day)
+ (setq nd 1))
+ ((eq span 'week)
+ (let* ((nt (calendar-day-of-week
+ (calendar-gregorian-from-absolute sd)))
+ (d (if org-agenda-start-on-weekday
+ (- nt org-agenda-start-on-weekday)
+ 0)))
+ (setq sd (- sd (+ (if (< d 0) 7 0) d)))
+ (setq nd 7)))
+ ((eq span 'month)
+ (setq sd (calendar-absolute-from-gregorian
+ (list (car greg) 1 (nth 2 greg)))
+ nd (- (calendar-absolute-from-gregorian
+ (list (1+ (car greg)) 1 (nth 2 greg)))
+ sd)))
+ ((eq span 'year)
+ (setq sd (calendar-absolute-from-gregorian
+ (list 1 1 (nth 2 greg)))
+ nd (- (calendar-absolute-from-gregorian
+ (list 1 1 (1+ (nth 2 greg))))
+ sd))))
+ (cons sd nd)))
+
+;; FIXME: does not work if user makes date format that starts with a blank
(defun org-agenda-next-date-line (&optional arg)
"Jump to the next line indicating a date in agenda buffer."
(interactive "p")
"Detach overlay INDEX."
(funcall (if (featurep 'xemacs) 'detach-extent 'delete-overlay) org-hl))
+;; FIXME this is currently not used.
(defun org-highlight-until-next-command (beg end &optional buffer)
(org-highlight beg end buffer)
(add-hook 'pre-command-hook 'org-unhighlight-once))
-
(defun org-unhighlight-once ()
(remove-hook 'pre-command-hook 'org-unhighlight-once)
(org-unhighlight))
(save-excursion
(and (outline-next-heading)
(org-flag-heading nil)))) ; show the next heading
+ (recenter (/ (window-height) 2))
+ (run-hooks 'org-agenda-after-show-hook)
(and highlight (org-highlight (point-at-bol) (point-at-eol)))))
+(defvar org-agenda-after-show-hook nil
+ "Normal hook run after an item has been shown from the agenda.
+Point is in the buffer where the item originated.")
+
(defun org-agenda-kill ()
"Kill the entry or subtree belonging to the current agenda entry."
(interactive)
(org-agenda-error)))
(buffer (marker-buffer marker))
(pos (marker-position marker))
+ (type (get-text-property (point) 'type))
dbeg dend (n 0) conf)
(org-with-remote-undo buffer
(with-current-buffer buffer
(save-excursion
(goto-char pos)
- (if (org-mode-p)
+ (if (and (org-mode-p) (not (member type '("sexp"))))
(setq dbeg (progn (org-back-to-heading t) (point))
- dend (org-end-of-subtree t))
+ dend (org-end-of-subtree t t))
(setq dbeg (point-at-bol)
dend (min (point-max) (1+ (point-at-eol)))))
(goto-char dbeg)
(setq p (marker-position m))
(>= p beg)
(<= p end))
- (let (buffer-read-only)
+ (let ((inhibit-read-only t))
(delete-region (point-at-bol) (1+ (point-at-eol)))))
(beginning-of-line 0))))))
(defun org-agenda-open-link ()
"Follow the link in the current line, if any."
(interactive)
- (let ((eol (point-at-eol)))
- (save-excursion
- (if (or (re-search-forward org-bracket-link-regexp eol t)
- (re-search-forward org-angle-link-re eol t)
- (re-search-forward org-plain-link-re eol t))
- (call-interactively 'org-open-at-point)
- (error "No link in current line")))))
+ (org-agenda-copy-local-variable 'org-link-abbrev-alist-local)
+ (save-excursion
+ (save-restriction
+ (narrow-to-region (point-at-bol) (point-at-eol))
+ (org-open-at-point))))
+
+(defun org-agenda-copy-local-variable (var)
+ "Get a variable from a referenced buffer and install it here."
+ (let ((m (get-text-property (point) 'org-marker)))
+ (when (and m (buffer-live-p (marker-buffer m)))
+ (org-set-local var (with-current-buffer (marker-buffer m)
+ (symbol-value var))))))
(defun org-agenda-switch-to (&optional delete-other-windows)
"Go to the Org-mode file which contains the item at point."
"Marker pointing to the headline that last changed its TODO state
by a remote command from the agenda.")
+(defun org-agenda-todo-nextset ()
+ "Switch TODO entry to next sequence."
+ (interactive)
+ (org-agenda-todo 'nextset))
+
+(defun org-agenda-todo-previousset ()
+ "Switch TODO entry to previous sequence."
+ (interactive)
+ (org-agenda-todo 'previousset))
+
(defun org-agenda-todo (&optional arg)
"Cycle TODO state of line at point, also in Org-mode file.
This changes the line at point, all other lines in the agenda referring to
(buffer (marker-buffer marker))
(pos (marker-position marker))
(hdmarker (get-text-property (point) 'org-hd-marker))
- (buffer-read-only nil)
+ (inhibit-read-only t)
newhead)
(org-with-remote-undo buffer
(with-current-buffer buffer
`equal' against all `org-hd-marker' text properties in the file.
If FIXFACE is non-nil, the face of each item is modified acording to
the new TODO state."
- (let* ((buffer-read-only nil)
+ (let* ((inhibit-read-only t)
props m pl undone-face done-face finish new dotime cat tags)
(save-excursion
(goto-char (point-max))
(beginning-of-line 0)))
(org-finalize-agenda)))
-;; FIXME: allow negative value for org-agenda-align-tags-to-column
-;; See the code in set-tags for the way to do this.
(defun org-agenda-align-tags (&optional line)
- "Align all tags in agenda items to `org-agenda-align-tags-to-column'."
- (let ((buffer-read-only))
+ "Align all tags in agenda items to `org-agenda-tags-column'."
+ (let ((inhibit-read-only t) l c)
(save-excursion
(goto-char (if line (point-at-bol) (point-min)))
- (while (re-search-forward "\\([ \t]+\\):[a-zA-Z0-9_@:]+:[ \t]*$"
+ (while (re-search-forward (org-re "\\([ \t]+\\)\\(:[[:alnum:]_@:]+:\\)[ \t]*$")
(if line (point-at-eol) nil) t)
+ (add-text-properties
+ (match-beginning 2) (match-end 2)
+ (list 'face (delq nil (list 'org-tag (get-text-property
+ (match-beginning 2) 'face)))))
+ (setq l (- (match-end 2) (match-beginning 2))
+ c (if (< org-agenda-tags-column 0)
+ (- (abs org-agenda-tags-column) l)
+ org-agenda-tags-column))
(delete-region (match-beginning 1) (match-end 1))
(goto-char (match-beginning 1))
(insert (org-add-props
- (make-string (max 1 (- org-agenda-align-tags-to-column
- (current-column))) ?\ )
+ (make-string (max 1 (- c (current-column))) ?\ )
(text-properties-at (point))))))))
(defun org-agenda-priority-up ()
(org-agenda-check-no-diary)
(let* ((marker (or (get-text-property (point) 'org-marker)
(org-agenda-error)))
- (buffer (marker-buffer marker))
- (pos (marker-position marker))
(hdmarker (get-text-property (point) 'org-hd-marker))
- (buffer-read-only nil)
+ (buffer (marker-buffer hdmarker))
+ (pos (marker-position hdmarker))
+ (inhibit-read-only t)
newhead)
(org-with-remote-undo buffer
(with-current-buffer buffer
the targets in the same sequence as the headlines appear, i.e.
the tags of the current headline come last."
(interactive)
- (let (tags)
+ (let (tags lastpos)
(save-excursion
(save-restriction
(widen)
(goto-char (or pos (point)))
(save-match-data
- (org-back-to-heading t)
(condition-case nil
- (while t
- (if (looking-at "[^\r\n]+?:\\([a-zA-Z_@0-9:]+\\):[ \t]*\\([\n\r]\\|\\'\\)")
- (setq tags (append (org-split-string
- (org-match-string-no-properties 1) ":")
- tags)))
- (or org-use-tag-inheritance (error ""))
- (org-up-heading-all 1))
+ (progn
+ (org-back-to-heading t)
+ (while (not (equal lastpos (point)))
+ (setq lastpos (point))
+ (if (looking-at (org-re "[^\r\n]+?:\\([[:alnum:]_@:]+\\):[ \t]*$"))
+ (setq tags (append (org-split-string
+ (org-match-string-no-properties 1) ":")
+ tags)))
+ (or org-use-tag-inheritance (error ""))
+ (org-up-heading-all 1)))
(error nil))))
tags)))
"Set tags for the current headline."
(interactive)
(org-agenda-check-no-diary)
- (org-agenda-show) ;;; FIXME This is a stupid hack and should not be needed
- (let* ((hdmarker (or (get-text-property (point) 'org-hd-marker)
- (org-agenda-error)))
- (buffer (marker-buffer hdmarker))
- (pos (marker-position hdmarker))
- (buffer-read-only nil)
- newhead)
- (org-with-remote-undo buffer
- (with-current-buffer buffer
- (widen)
- (goto-char pos)
- (org-show-context 'agenda)
- (save-excursion
- (and (outline-next-heading)
- (org-flag-heading nil))) ; show the next heading
- (call-interactively 'org-set-tags)
- (end-of-line 1)
- (setq newhead (org-get-heading)))
- (org-agenda-change-all-lines newhead hdmarker)
- (beginning-of-line 1))))
+ (if (and (org-region-active-p) (interactive-p))
+ (call-interactively 'org-change-tag-in-region)
+ (org-agenda-show) ;;; FIXME This is a stupid hack and should not be needed
+ (let* ((hdmarker (or (get-text-property (point) 'org-hd-marker)
+ (org-agenda-error)))
+ (buffer (marker-buffer hdmarker))
+ (pos (marker-position hdmarker))
+ (inhibit-read-only t)
+ newhead)
+ (org-with-remote-undo buffer
+ (with-current-buffer buffer
+ (widen)
+ (goto-char pos)
+ (save-excursion
+ (org-show-context 'agenda))
+ (save-excursion
+ (and (outline-next-heading)
+ (org-flag-heading nil))) ; show the next heading
+ (goto-char pos)
+ (call-interactively 'org-set-tags)
+ (end-of-line 1)
+ (setq newhead (org-get-heading)))
+ (org-agenda-change-all-lines newhead hdmarker)
+ (beginning-of-line 1)))))
(defun org-agenda-toggle-archive-tag ()
"Toggle the archive tag for the current entry."
(org-agenda-error)))
(buffer (marker-buffer hdmarker))
(pos (marker-position hdmarker))
- (buffer-read-only nil)
+ (inhibit-read-only t)
newhead)
(org-with-remote-undo buffer
(with-current-buffer buffer
(interactive "p")
(org-agenda-date-later (- arg) what))
-(defun org-agenda-show-new-time (marker stamp)
+(defun org-agenda-show-new-time (marker stamp &optional prefix)
"Show new date stamp via text properties."
;; We use text properties to make this undoable
- (let ((buffer-read-only nil))
- (setq stamp (concat " => " stamp))
+ (let ((inhibit-read-only t))
+ (setq stamp (concat " " prefix " => " stamp))
(save-excursion
(goto-char (point-max))
(while (not (bobp))
(org-agenda-check-no-diary)
(let* ((marker (or (get-text-property (point) 'org-marker)
(org-agenda-error)))
+ (type (marker-insertion-type marker))
(buffer (marker-buffer marker))
(pos (marker-position marker))
(org-insert-labeled-timestamps-at-point nil)
ts)
+ (when type (message "%s" type) (sit-for 3))
+ (set-marker-insertion-type marker t)
(org-with-remote-undo buffer
(with-current-buffer buffer
(widen)
(goto-char pos)
- (setq ts (org-schedule))
- (message "Item scheduled for %s" ts)))))
+ (setq ts (org-schedule arg)))
+ (org-agenda-show-new-time marker ts "S"))
+ (message "Item scheduled for %s" ts)))
(defun org-agenda-deadline (arg)
"Schedule the item at point."
(with-current-buffer buffer
(widen)
(goto-char pos)
- (setq ts (org-deadline))
- (message "Deadline for this item set to %s" ts)))))
+ (setq ts (org-deadline arg)))
+ (org-agenda-show-new-time marker ts "S"))
+ (message "Deadline for this item set to %s" ts)))
-(defun org-get-heading ()
+(defun org-get-heading (&optional no-tags)
"Return the heading of the current entry, without the stars."
(save-excursion
(org-back-to-heading t)
- (if (looking-at "\\*+[ \t]+\\([^\r\n]*\\)") (match-string 1) "")))
+ (if (looking-at
+ (if no-tags
+ (org-re "\\*+[ \t]+\\([^\n\r]*?\\)\\([ \t]+:[[:alnum:]:_@]+:[ \t]*\\)?$")
+ "\\*+[ \t]+\\([^\r\n]*\\)"))
+ (match-string 1) "")))
(defun org-agenda-clock-in (&optional arg)
"Start the clock on the currently selected item."
(point (point))
(date (calendar-gregorian-from-absolute
(get-text-property point 'day)))
- ;; the following 3 vars are needed in the calendar
- (displayed-day (extract-calendar-day date))
- (displayed-month (extract-calendar-month date))
- (displayed-year (extract-calendar-year date)))
+ ;; the following 2 vars are needed in the calendar
+ (displayed-month (car date))
+ (displayed-year (nth 2 date)))
(unwind-protect
(progn
(fset 'calendar-cursor-to-date
(interactive)
(org-agenda-execute-calendar-command 'list-calendar-holidays))
+(defvar calendar-longitude)
+(defvar calendar-latitude)
+(defvar calendar-location-name)
+
(defun org-agenda-sunrise-sunset (arg)
"Display sunrise and sunset for the cursor date.
Latitude and longitude can be specified with the variables
`calendar-latitude' and `calendar-longitude'. When called with prefix
argument, latitude and longitude will be prompted for."
(interactive "P")
+ (require 'solar)
(let ((calendar-longitude (if arg nil calendar-longitude))
(calendar-latitude (if arg nil calendar-latitude))
(calendar-location-name
(error "Don't know which date to open in calendar")))
(date (calendar-gregorian-from-absolute day))
(calendar-move-hook nil)
+ (calendar-view-holidays-initially-flag nil)
(view-calendar-holidays-initially nil)
+ (calendar-view-diary-initially-flag nil)
(view-diary-entries-initially nil))
(calendar)
(calendar-goto-date date)))
"Hebrew: " (calendar-hebrew-date-string date) " (until sunset)\n"
"Islamic: " (calendar-islamic-date-string date) " (until sunset)\n"
"French: " (calendar-french-date-string date) "\n"
+ "Baha'i: " (calendar-bahai-date-string date) " (until sunset)\n"
"Mayan: " (calendar-mayan-date-string date) "\n"
"Coptic: " (calendar-coptic-date-string date) "\n"
"Ethiopic: " (calendar-ethiopic-date-string date) "\n"
(defvar org-cdlatex-mode-map (make-sparse-keymap)
"Keymap for the minor `org-cdlatex-mode'.")
-(define-key org-cdlatex-mode-map "_" 'org-cdlatex-underscore-caret)
-(define-key org-cdlatex-mode-map "^" 'org-cdlatex-underscore-caret)
-(define-key org-cdlatex-mode-map "`" 'cdlatex-math-symbol)
-(define-key org-cdlatex-mode-map "'" 'org-cdlatex-math-modify)
-(define-key org-cdlatex-mode-map "\C-c{" 'cdlatex-environment)
+(org-defkey org-cdlatex-mode-map "_" 'org-cdlatex-underscore-caret)
+(org-defkey org-cdlatex-mode-map "^" 'org-cdlatex-underscore-caret)
+(org-defkey org-cdlatex-mode-map "`" 'cdlatex-math-symbol)
+(org-defkey org-cdlatex-mode-map "'" 'org-cdlatex-math-modify)
+(org-defkey org-cdlatex-mode-map "\C-c{" 'cdlatex-environment)
(defvar org-cdlatex-texmathp-advice-is-done nil
"Flag remembering if we have applied the advice to texmathp already.")
(while (string-match re str start)
(cond
((= (match-end 0) (length str))
- (throw 'exit (cons "$" (+ lim (match-beginning 0)))))
+ (throw 'exit (cons "$" (+ lim (match-beginning 0) 1))))
((= (match-end 0) (- (length str) 5))
(throw 'exit nil))
(t (setq start (match-end 0))))))
"Creating images for entry...%s"))))
(message msg "")
(narrow-to-region beg end)
+ (goto-char beg)
(org-format-latex
(concat "ltxpng/" (file-name-sans-extension
(file-name-nondirectory
buffer-file-name)))
- default-directory 'overlays msg at)
+ default-directory 'overlays msg at 'forbuffer)
(message msg "done. Use `C-c C-c' to remove images.")))))
(defvar org-latex-regexps
("$$" "\\$\\$[^\000]*?\\$\\$" 0 t))
"Regular expressions for matching embedded LaTeX.")
-(defun org-format-latex (prefix &optional dir overlays msg at)
+(defun org-format-latex (prefix &optional dir overlays msg at forbuffer)
"Replace LaTeX fragments with links to an image, and produce images."
(if (and overlays (fboundp 'clear-image-cache)) (clear-image-cache))
(let* ((prefixnodir (file-name-nondirectory prefix))
(setq checkdir t)
(or (file-directory-p todir) (make-directory todir)))
(org-create-formula-image
- txt movefile opt)
+ txt movefile opt forbuffer)
(if overlays
(progn
(setq ov (org-make-overlay beg end))
(insert link))))))))
;; This function borrows from Ganesh Swami's latex2png.el
-(defun org-create-formula-image (string tofile options)
+(defun org-create-formula-image (string tofile options buffer)
(let* ((tmpdir (if (featurep 'xemacs)
(temp-directory)
temporary-file-directory))
(texfilebase (make-temp-name
(expand-file-name "orgtex" tmpdir)))
-
-;(texfilebase (make-temp-file "orgtex"))
-; (dummy (delete-file texfilebase))
(texfile (concat texfilebase ".tex"))
(dvifile (concat texfilebase ".dvi"))
(pngfile (concat texfilebase ".png"))
- (scale (number-to-string (* 1000 (or (plist-get options :scale) 1.0))))
- (fg (or (plist-get options :foreground) "Black"))
- (bg (or (plist-get options :background) "Transparent")))
+ (fnh (face-attribute 'default :height nil))
+ (scale (or (plist-get options (if buffer :scale :html-scale)) 1.0))
+ (dpi (number-to-string (* scale (floor (* 0.9 (if buffer fnh 140.))))))
+ (fg (or (plist-get options (if buffer :foreground :html-foreground))
+ "Black"))
+ (bg (or (plist-get options (if buffer :background :html-background))
+ "Transparent")))
+ (if (eq fg 'default) (setq fg (org-dvipng-color :foreground)))
+ (if (eq bg 'default) (setq bg (org-dvipng-color :background)))
(with-temp-file texfile
- (insert "\\documentclass{article}
-\\usepackage{fullpage}
-\\usepackage{amssymb}
-\\usepackage[usenames]{color}
-\\usepackage{amsmath}
-\\usepackage{latexsym}
-\\usepackage[mathscr]{eucal}
-\\pagestyle{empty}
-\\begin{document}\n" string "\n\\end{document}\n"))
+ (insert org-format-latex-header
+ "\n\\begin{document}\n" string "\n\\end{document}\n"))
(let ((dir default-directory))
(condition-case nil
(progn
(progn (message "Failed to create dvi file from %s" texfile) nil)
(call-process "dvipng" nil nil nil
"-E" "-fg" fg "-bg" bg
- "-x" scale "-y" scale "-T" "tight"
+ "-D" dpi
+ ;;"-x" scale "-y" scale
+ "-T" "tight"
"-o" pngfile
dvifile)
(if (not (file-exists-p pngfile))
(delete-file (concat texfilebase e)))
pngfile))))
+(defun org-dvipng-color (attr)
+ "Return an rgb color specification for dvipng."
+ (apply 'format "rgb %s %s %s"
+ (mapcar 'org-normalize-color
+ (color-values (face-attribute 'default attr nil)))))
+
+(defun org-normalize-color (value)
+ "Return string to be used as color value for an RGB component."
+ (format "%g" (/ value 65535.0)))
+
;;;; Exporting
;;; Variables, constants, and parameter plists
(:headline-levels . org-export-headline-levels)
(:section-numbers . org-export-with-section-numbers)
(:table-of-contents . org-export-with-toc)
+ (:preserve-breaks . org-export-preserve-breaks)
(:archived-trees . org-export-with-archived-trees)
(:emphasize . org-export-with-emphasize)
(:sub-superscript . org-export-with-sub-superscripts)
+ (:special-strings . org-export-with-special-strings)
+ (:footnotes . org-export-with-footnotes)
+ (:drawers . org-export-with-drawers)
+ (:tags . org-export-with-tags)
(:TeX-macros . org-export-with-TeX-macros)
(:LaTeX-fragments . org-export-with-LaTeX-fragments)
+ (:skip-before-1st-heading . org-export-skip-text-before-1st-heading)
(:fixed-width . org-export-with-fixed-width)
(:timestamps . org-export-with-timestamps)
+ (:author-info . org-export-author-info)
+ (:time-stamp-file . org-export-time-stamp-file)
(:tables . org-export-with-tables)
(:table-auto-headline . org-export-highlight-first-table-line)
(:style . org-export-html-style)
+ (:agenda-style . org-agenda-export-html-style)
(:convert-org-links . org-export-html-link-org-files-as-html)
(:inline-images . org-export-html-inline-images)
+ (:html-extension . org-export-html-extension)
+ (:html-table-tag . org-export-html-table-tag)
(:expand-quoted-html . org-export-html-expand)
(:timestamp . org-export-html-with-timestamp)
(:publishing-directory . org-export-publishing-directory)
(defun org-infile-export-plist ()
"Return the property list with file-local settings for export."
(save-excursion
- (goto-char 0)
- (let ((re (org-make-options-regexp
- '("TITLE" "AUTHOR" "EMAIL" "TEXT" "OPTIONS" "LANGUAGE")))
- p key val text options)
- (while (re-search-forward re nil t)
- (setq key (org-match-string-no-properties 1)
- val (org-match-string-no-properties 2))
- (cond
- ((string-equal key "TITLE") (setq p (plist-put p :title val)))
- ((string-equal key "AUTHOR")(setq p (plist-put p :author val)))
- ((string-equal key "EMAIL") (setq p (plist-put p :email val)))
- ((string-equal key "LANGUAGE") (setq p (plist-put p :language val)))
- ((string-equal key "TEXT")
- (setq text (if text (concat text "\n" val) val)))
- ((string-equal key "OPTIONS") (setq options val))))
- (setq p (plist-put p :text text))
- (when options
- (let ((op '(("H" . :headline-levels)
- ("num" . :section-numbers)
- ("toc" . :table-of-contents)
- ("\\n" . :preserve-breaks)
- ("@" . :expand-quoted-html)
- (":" . :fixed-width)
- ("|" . :tables)
- ("^" . :sub-superscript)
- ("*" . :emphasize)
- ("TeX" . :TeX-macros)
- ("LaTeX" . :LaTeX-fragments)))
- o)
- (while (setq o (pop op))
- (if (string-match (concat (regexp-quote (car o))
- ":\\([^ \t\n\r;,.]*\\)")
- options)
- (setq p (plist-put p (cdr o)
- (car (read-from-string
- (match-string 1 options)))))))))
- p)))
+ (save-restriction
+ (widen)
+ (goto-char 0)
+ (let ((re (org-make-options-regexp
+ '("TITLE" "AUTHOR" "DATE" "EMAIL" "TEXT" "OPTIONS" "LANGUAGE")))
+ p key val text options)
+ (while (re-search-forward re nil t)
+ (setq key (org-match-string-no-properties 1)
+ val (org-match-string-no-properties 2))
+ (cond
+ ((string-equal key "TITLE") (setq p (plist-put p :title val)))
+ ((string-equal key "AUTHOR")(setq p (plist-put p :author val)))
+ ((string-equal key "EMAIL") (setq p (plist-put p :email val)))
+ ((string-equal key "DATE") (setq p (plist-put p :date val)))
+ ((string-equal key "LANGUAGE") (setq p (plist-put p :language val)))
+ ((string-equal key "TEXT")
+ (setq text (if text (concat text "\n" val) val)))
+ ((string-equal key "OPTIONS") (setq options val))))
+ (setq p (plist-put p :text text))
+ (when options
+ (let ((op '(("H" . :headline-levels)
+ ("num" . :section-numbers)
+ ("toc" . :table-of-contents)
+ ("\\n" . :preserve-breaks)
+ ("@" . :expand-quoted-html)
+ (":" . :fixed-width)
+ ("|" . :tables)
+ ("^" . :sub-superscript)
+ ("-" . :special-strings)
+ ("f" . :footnotes)
+ ("d" . :drawers)
+ ("tags" . :tags)
+ ("*" . :emphasize)
+ ("TeX" . :TeX-macros)
+ ("LaTeX" . :LaTeX-fragments)
+ ("skip" . :skip-before-1st-heading)
+ ("author" . :author-info)
+ ("timestamp" . :time-stamp-file)))
+ o)
+ (while (setq o (pop op))
+ (if (string-match (concat (regexp-quote (car o))
+ ":\\([^ \t\n\r;,.]*\\)")
+ options)
+ (setq p (plist-put p (cdr o)
+ (car (read-from-string
+ (match-string 1 options)))))))))
+ p))))
(defun org-export-directory (type plist)
(let* ((val (plist-get plist :publishing-directory))
val)))
dir))
-(defun org-export-find-first-heading-line (list)
- "Remove all lines from LIST which are before the first headline."
- (let ((orig-list list)
- (re (concat "^" outline-regexp)))
- (while (and list
- (not (string-match re (car list))))
- (pop list))
- (or list orig-list)))
-
(defun org-skip-comments (lines)
"Skip lines starting with \"#\" and subtrees starting with COMMENT."
(let ((re1 (concat "^\\(\\*+\\)[ \t]+" org-comment-string))
(re2 "^\\(\\*+\\)[ \t\n\r]")
+ (case-fold-search nil)
rtn line level)
(while (setq line (pop lines))
(cond
\[v] limit export to visible part of outline tree
\[a] export as ASCII
+
\[h] export as HTML
+\[H] export as HTML to temporary buffer
+\[R] export region as HTML
\[b] export as HTML and browse immediately
\[x] export as XOXO
+\[l] export as LaTeX
+\[L] export as LaTeX to temporary buffer
+
\[i] export current file as iCalendar file
\[I] export all agenda files as iCalendar files
\[c] export agenda files into combined iCalendar file
(?a . org-export-as-ascii)
(?h . org-export-as-html)
(?b . org-export-as-html-and-open)
+ (?H . org-export-as-html-to-buffer)
+ (?R . org-export-region-as-html)
(?x . org-export-as-xoxo)
+ (?l . org-export-as-latex)
+ (?L . org-export-as-latex-to-buffer)
(?i . org-export-icalendar-this-file)
(?I . org-export-icalendar-all-agenda-files)
(?c . org-export-icalendar-combine-agenda-files)
("curren")
("yen")
("brvbar")
+ ("vert" . "|")
("sect")
("uml")
("copy")
("prop") ("proptp"."∝")
("infin") ("infty"."∞")
("ang") ("angle"."∠")
- ("and") ("vee"."∧")
- ("or") ("wedge"."∨")
+ ("and") ("wedge"."∧")
+ ("or") ("vee"."∨")
("cap")
("cup")
("int")
("clubs") ("clubsuit"."♣")
("hearts") ("diamondsuit"."♥")
("diams") ("diamondsuit"."♦")
+ ("smile"."☺") ("blacksmile"."☻") ("sad"."☹")
("quot")
("amp")
("lt")
;;; General functions for all backends
(defun org-cleaned-string-for-export (string &rest parameters)
- "Cleanup a buffer substring so that links can be created safely."
+ "Cleanup a buffer STRING so that links can be created safely."
(interactive)
(let* ((re-radio (and org-target-link-regexp
(concat "\\([^<]\\)\\(" org-target-link-regexp "\\)")))
(re-angle-link (concat "\\([^[]\\)" org-angle-link-re))
(re-archive (concat ":" org-archive-tag ":"))
(re-quote (concat "^\\*+[ \t]+" org-quote-string "\\>"))
- (htmlp (memq :for-html parameters))
- (outline-regexp "\\*+")
- rtn)
- (save-excursion
- (set-buffer (get-buffer-create " org-mode-tmp"))
+ (re-commented (concat "^\\*+[ \t]+" org-comment-string "\\>"))
+ (htmlp (plist-get parameters :for-html))
+ (asciip (plist-get parameters :for-ascii))
+ (latexp (plist-get parameters :for-LaTeX))
+ (commentsp (plist-get parameters :comments))
+ (archived-trees (plist-get parameters :archived-trees))
+ (inhibit-read-only t)
+ (drawers org-drawers)
+ (exp-drawers (plist-get parameters :drawers))
+ (outline-regexp "\\*+ ")
+ a b xx
+ rtn p)
+ (with-current-buffer (get-buffer-create " org-mode-tmp")
(erase-buffer)
(insert string)
+ ;; Remove license-to-kill stuff
+ (while (setq p (text-property-any (point-min) (point-max)
+ :org-license-to-kill t))
+ (delete-region p (next-single-property-change p :org-license-to-kill)))
+
(let ((org-inhibit-startup t)) (org-mode))
(untabify (point-min) (point-max))
+ ;; Get rid of drawers
+ (unless (eq t exp-drawers)
+ (goto-char (point-min))
+ (let ((re (concat "^[ \t]*:\\("
+ (mapconcat
+ 'identity
+ (org-delete-all exp-drawers
+ (copy-sequence drawers))
+ "\\|")
+ "\\):[ \t]*\n\\([^@]*?\n\\)?[ \t]*:END:[ \t]*\n")))
+ (while (re-search-forward re nil t)
+ (replace-match ""))))
+
+ ;; Get the correct stuff before the first headline
+ (when (plist-get parameters :skip-before-1st-heading)
+ (goto-char (point-min))
+ (when (re-search-forward "^\\*+[ \t]" nil t)
+ (delete-region (point-min) (match-beginning 0))
+ (goto-char (point-min))
+ (insert "\n")))
+ (when (plist-get parameters :add-text)
+ (goto-char (point-min))
+ (insert (plist-get parameters :add-text) "\n"))
+
;; Get rid of archived trees
- (when (not (eq org-export-with-archived-trees t))
+ (when (not (eq archived-trees t))
(goto-char (point-min))
(while (re-search-forward re-archive nil t)
- (if (not (org-on-heading-p))
+ (if (not (org-on-heading-p t))
(org-end-of-subtree t)
(beginning-of-line 1)
- (delete-region
- (if org-export-with-archived-trees (1+ (point-at-eol)) (point))
- (org-end-of-subtree t)))))
+ (setq a (if archived-trees
+ (1+ (point-at-eol)) (point))
+ b (org-end-of-subtree t))
+ (if (> b a) (delete-region a b)))))
- ;; Protect stuff from HTML processing
+ ;; Find targets in comments and move them out of comments,
+ ;; but mark them as targets that should be invisible
(goto-char (point-min))
- (while (re-search-forward "^[ \t]*:.*\\(\n[ \t]*:.*\\)*" nil t)
- (add-text-properties (match-beginning 0) (match-end 0)
- '(org-protected t)))
- (when htmlp
+ (while (re-search-forward "^#.*?\\(<<<?[^>\r\n]+>>>?\\).*" nil t)
+ (replace-match "\\1(INVISIBLE)"))
+
+ ;; Protect backend specific stuff, throw away the others.
+ (let ((formatters
+ `((,htmlp "HTML" "BEGIN_HTML" "END_HTML")
+ (,asciip "ASCII" "BEGIN_ASCII" "END_ASCII")
+ (,latexp "LaTeX" "BEGIN_LaTeX" "END_LaTeX")))
+ fmt)
(goto-char (point-min))
- (while (re-search-forward "^#\\+HTML:[ \t]*\\(.*\\)" nil t)
- (replace-match "\\1" t)
- (add-text-properties
- (point-at-bol) (min (1+ (point-at-eol)) (point-max))
- '(org-protected t))))
- (goto-char (point-min))
- (while (re-search-forward
- "^#\\+BEGIN_HTML\\>.*\\(\n.*\\)*?\n#\\+END_HTML\\>.*\n?" nil t)
- (if htmlp
- (add-text-properties (match-beginning 1) (1+ (match-end 1))
- '(org-protected t))
- (delete-region (match-beginning 0) (match-end 0))))
+ (while (re-search-forward "^#\\+BEGIN_EXAMPLE[ \t]*\n" nil t)
+ (goto-char (match-end 0))
+ (while (not (looking-at "#\\+END_EXAMPLE"))
+ (insert ": ")
+ (beginning-of-line 2)))
+ (goto-char (point-min))
+ (while (re-search-forward "^[ \t]*:.*\\(\n[ \t]*:.*\\)*" nil t)
+ (add-text-properties (match-beginning 0) (match-end 0)
+ '(org-protected t)))
+ (while formatters
+ (setq fmt (pop formatters))
+ (when (car fmt)
+ (goto-char (point-min))
+ (while (re-search-forward (concat "^#\\+" (cadr fmt)
+ ":[ \t]*\\(.*\\)") nil t)
+ (replace-match "\\1" t)
+ (add-text-properties
+ (point-at-bol) (min (1+ (point-at-eol)) (point-max))
+ '(org-protected t))))
+ (goto-char (point-min))
+ (while (re-search-forward
+ (concat "^#\\+"
+ (caddr fmt) "\\>.*\\(\\(\n.*\\)*?\n\\)#\\+"
+ (cadddr fmt) "\\>.*\n?") nil t)
+ (if (car fmt)
+ (add-text-properties (match-beginning 1) (1+ (match-end 1))
+ '(org-protected t))
+ (delete-region (match-beginning 0) (match-end 0))))))
+
+ ;; Protect quoted subtrees
(goto-char (point-min))
(while (re-search-forward re-quote nil t)
(goto-char (match-beginning 0))
(add-text-properties (point) (org-end-of-subtree t)
'(org-protected t)))
- ;; Find targets in comments and move them out of comments,
- ;; but mark them as targets that should be invisible
+ ;; Protect verbatim elements
(goto-char (point-min))
- (while (re-search-forward "^#.*?\\(<<<?[^>\r\n]+>>>?\\).*" nil t)
- (replace-match "\\1(INVISIBLE)"))
+ (while (re-search-forward org-verbatim-re nil t)
+ (add-text-properties (match-beginning 4) (match-end 4)
+ '(org-protected t))
+ (goto-char (1+ (match-end 4))))
- ;; Remove comments
+ ;; Remove subtrees that are commented
(goto-char (point-min))
- (while (re-search-forward "^#.*\n?" nil t)
- (replace-match ""))
+ (while (re-search-forward re-commented nil t)
+ (goto-char (match-beginning 0))
+ (delete-region (point) (org-end-of-subtree t)))
+
+ ;; Remove special table lines
+ (when org-export-table-remove-special-lines
+ (goto-char (point-min))
+ (while (re-search-forward "^[ \t]*|" nil t)
+ (beginning-of-line 1)
+ (if (or (looking-at "[ \t]*| *[!_^] *|")
+ (and (looking-at ".*?| *<[0-9]+> *|")
+ (not (looking-at ".*?| *[^ <|]"))))
+ (delete-region (max (point-min) (1- (point-at-bol)))
+ (point-at-eol))
+ (end-of-line 1))))
+
+ ;; Specific LaTeX stuff
+ (when latexp
+ (require 'org-export-latex nil)
+ (org-export-latex-cleaned-string))
+
+ (when asciip
+ (org-export-ascii-clean-string))
+
+ ;; Specific HTML stuff
+ (when htmlp
+ ;; Convert LaTeX fragments to images
+ (when (plist-get parameters :LaTeX-fragments)
+ (org-format-latex
+ (concat "ltxpng/" (file-name-sans-extension
+ (file-name-nondirectory
+ org-current-export-file)))
+ org-current-export-dir nil "Creating LaTeX image %s"))
+ (message "Exporting..."))
+
+ ;; Remove or replace comments
+ (goto-char (point-min))
+ (while (re-search-forward "^#\\(.*\n?\\)" nil t)
+ (if commentsp
+ (progn (add-text-properties
+ (match-beginning 0) (match-end 0) '(org-protected t))
+ (replace-match (format commentsp (match-string 1)) t t))
+ (replace-match "")))
;; Find matches for radio targets and turn them into internal links
(goto-char (point-min))
(replace-match "\\1 \\3")
(goto-char (match-beginning 0))))
- ;; Convert LaTeX fragments to images
- (when (memq :LaTeX-fragments parameters)
- (org-format-latex
- (concat "ltxpng/" (file-name-sans-extension
- (file-name-nondirectory
- org-current-export-file)))
- org-current-export-dir nil "Creating LaTeX image %s"))
- (message "Exporting...")
;; Normalize links: Convert angle and plain links into bracket links
;; Expand link abbreviations
(goto-char (point-min))
(while (re-search-forward re-plain-link nil t)
+ (goto-char (1- (match-end 0)))
(org-if-unprotected
- (replace-match
- (concat
- (match-string 1) "[[" (match-string 2) ":" (match-string 3) "]]")
- t t)))
+ (let* ((s (concat (match-string 1) "[[" (match-string 2)
+ ":" (match-string 3) "]]")))
+ ;; added 'org-link face to links
+ (put-text-property 0 (length s) 'face 'org-link s)
+ (replace-match s t t))))
(goto-char (point-min))
(while (re-search-forward re-angle-link nil t)
+ (goto-char (1- (match-end 0)))
(org-if-unprotected
- (replace-match
- (concat
- (match-string 1) "[[" (match-string 2) ":" (match-string 3) "]]")
- t t)))
+ (let* ((s (concat (match-string 1) "[[" (match-string 2)
+ ":" (match-string 3) "]]")))
+ (put-text-property 0 (length s) 'face 'org-link s)
+ (replace-match s t t))))
(goto-char (point-min))
(while (re-search-forward org-bracket-link-regexp nil t)
(org-if-unprotected
- (replace-match
- (concat "[[" (save-match-data
- (org-link-expand-abbrev (match-string 1)))
- "]"
- (if (match-end 3)
- (match-string 2)
- (concat "[" (match-string 1) "]"))
- "]")
- t t)))
+ (let* ((s (concat "[[" (setq xx (save-match-data
+ (org-link-expand-abbrev (match-string 1))))
+ "]"
+ (if (match-end 3)
+ (match-string 2)
+ (concat "[" xx "]"))
+ "]")))
+ (put-text-property 0 (length s) 'face 'org-link s)
+ (replace-match s t t))))
;; Find multiline emphasis and put them into single line
- (when (memq :emph-multiline parameters)
+ (when (plist-get parameters :emph-multiline)
(goto-char (point-min))
(while (re-search-forward org-emph-re nil t)
- (org-if-unprotected
- (subst-char-in-region (match-beginning 0) (match-end 0) ?\n ?\ t)
- (goto-char (1- (match-end 0))))))
+ (if (not (= (char-after (match-beginning 3))
+ (char-after (match-beginning 4))))
+ (org-if-unprotected
+ (subst-char-in-region (match-beginning 0) (match-end 0)
+ ?\n ?\ t)
+ (goto-char (1- (match-end 0))))
+ (goto-char (1+ (match-beginning 0))))))
(setq rtn (buffer-string)))
(kill-buffer " org-mode-tmp")
rtn))
+(defun org-export-grab-title-from-buffer ()
+ "Get a title for the current document, from looking at the buffer."
+ (let ((inhibit-read-only t))
+ (save-excursion
+ (goto-char (point-min))
+ (let ((end (save-excursion (outline-next-heading) (point))))
+ (when (re-search-forward "^[ \t]*[^|# \t\r\n].*\n" end t)
+ ;; Mark the line so that it will not be exported as normal text.
+ (org-unmodified
+ (add-text-properties (match-beginning 0) (match-end 0)
+ (list :org-license-to-kill t)))
+ ;; Return the title string
+ (org-trim (match-string 0)))))))
+
+(defun org-export-get-title-from-subtree ()
+ "Return subtree title and exclude it from export."
+ (let (title (m (mark)))
+ (save-excursion
+ (goto-char (region-beginning))
+ (when (and (org-at-heading-p)
+ (>= (org-end-of-subtree t t) (region-end)))
+ ;; This is a subtree, we take the title from the first heading
+ (goto-char (region-beginning))
+ (looking-at org-todo-line-regexp)
+ (setq title (match-string 3))
+ (org-unmodified
+ (add-text-properties (point) (1+ (point-at-eol))
+ (list :org-license-to-kill t)))))
+ title))
+
(defun org-solidify-link-text (s &optional alist)
"Take link text and make a safe target out of it."
(save-match-data
(a (assoc rtn alist)))
(or (cdr a) rtn))))
+(defun org-get-min-level (lines)
+ "Get the minimum level in LINES."
+ (let ((re "^\\(\\*+\\) ") l min)
+ (catch 'exit
+ (while (setq l (pop lines))
+ (if (string-match re l)
+ (throw 'exit (org-tr-level (length (match-string 1 l))))))
+ 1)))
+
;; Variable holding the vector with section numbers
(defvar org-section-numbers (make-vector org-level-max 0))
;;; ASCII export
(defvar org-last-level nil) ; dynamically scoped variable
+(defvar org-min-level nil) ; dynamically scoped variable
(defvar org-levels-open nil) ; dynamically scoped parameter
(defvar org-ascii-current-indentation nil) ; For communication
(setq-default org-todo-line-regexp org-todo-line-regexp)
(let* ((opt-plist (org-combine-plists (org-default-export-plist)
(org-infile-export-plist)))
- (region
- (buffer-substring
- (if (org-region-active-p) (region-beginning) (point-min))
- (if (org-region-active-p) (region-end) (point-max))))
+ (region-p (org-region-active-p))
+ (subtree-p
+ (when region-p
+ (save-excursion
+ (goto-char (region-beginning))
+ (and (org-at-heading-p)
+ (>= (org-end-of-subtree t t) (region-end))))))
(custom-times org-display-custom-times)
- (lines (org-export-find-first-heading-line
- (org-skip-comments
- (org-split-string
- (org-cleaned-string-for-export region)
- "[\r\n]"))))
(org-ascii-current-indentation '(0 . 0))
(level 0) line txt
(umax nil)
(filename (concat (file-name-as-directory
(org-export-directory :ascii opt-plist))
(file-name-sans-extension
- (file-name-nondirectory buffer-file-name))
+ (or (and subtree-p
+ (org-entry-get (region-beginning)
+ "EXPORT_FILE_NAME" t))
+ (file-name-nondirectory buffer-file-name)))
".txt"))
+ (filename (if (equal (file-truename filename)
+ (file-truename buffer-file-name))
+ (concat filename ".txt")
+ filename))
(buffer (find-file-noselect filename))
(org-levels-open (make-vector org-level-max nil))
(odd org-odd-levels-only)
- (date (format-time-string "%Y/%m/%d" (current-time)))
- (time (format-time-string "%X" (org-current-time)))
+ (date (plist-get opt-plist :date))
(author (plist-get opt-plist :author))
- (title (or (plist-get opt-plist :title)
+ (title (or (and subtree-p (org-export-get-title-from-subtree))
+ (plist-get opt-plist :title)
+ (and (not
+ (plist-get opt-plist :skip-before-1st-heading))
+ (org-export-grab-title-from-buffer))
(file-name-sans-extension
(file-name-nondirectory buffer-file-name))))
(email (plist-get opt-plist :email))
(language (plist-get opt-plist :language))
(quote-re0 (concat "^[ \t]*" org-quote-string "\\>"))
; (quote-re (concat "^\\(\\*+\\)\\([ \t]*" org-quote-string "\\>\\)"))
- (text nil)
(todo nil)
- (lang-words nil))
-
- (setq org-last-level 1)
+ (lang-words nil)
+ (region
+ (buffer-substring
+ (if (org-region-active-p) (region-beginning) (point-min))
+ (if (org-region-active-p) (region-end) (point-max))))
+ (lines (org-split-string
+ (org-cleaned-string-for-export
+ region
+ :for-ascii t
+ :skip-before-1st-heading
+ (plist-get opt-plist :skip-before-1st-heading)
+ :drawers (plist-get opt-plist :drawers)
+ :verbatim-multiline t
+ :archived-trees
+ (plist-get opt-plist :archived-trees)
+ :add-text (plist-get opt-plist :text))
+ "\n"))
+ thetoc have-headings first-heading-pos
+ table-open table-buffer)
+
+ (let ((inhibit-read-only t))
+ (org-unmodified
+ (remove-text-properties (point-min) (point-max)
+ '(:org-license-to-kill t))))
+
+ (setq org-min-level (org-get-min-level lines))
+ (setq org-last-level org-min-level)
(org-init-section-numbers)
(find-file-noselect filename)
(fundamental-mode)
;; create local variables for all options, to make sure all called
;; functions get the correct information
- (mapcar (lambda (x)
- (set (make-local-variable (cdr x))
- (plist-get opt-plist (car x))))
- org-export-plist-vars)
+ (mapc (lambda (x)
+ (set (make-local-variable (cdr x))
+ (plist-get opt-plist (car x))))
+ org-export-plist-vars)
(org-set-local 'org-odd-levels-only odd)
(setq umax (if arg (prefix-numeric-value arg)
org-export-headline-levels))
;; File header
(if title (org-insert-centered title ?=))
(insert "\n")
- (if (or author email)
+ (if (and (or author email)
+ org-export-author-info)
(insert (concat (nth 1 lang-words) ": " (or author "")
(if email (concat " <" email ">") "")
"\n")))
- (if (and date time)
- (insert (concat (nth 2 lang-words) ": " date " " time "\n")))
- (if text (insert (concat (org-html-expand-for-ascii text) "\n\n")))
+
+ (cond
+ ((and date (string-match "%" date))
+ (setq date (format-time-string date (current-time))))
+ (date)
+ (t (setq date (format-time-string "%Y/%m/%d %X" (current-time)))))
+
+ (if (and date org-export-time-stamp-file)
+ (insert (concat (nth 2 lang-words) ": " date"\n")))
(insert "\n\n")
(if org-export-with-toc
(progn
- (insert (nth 3 lang-words) "\n"
- (make-string (length (nth 3 lang-words)) ?=) "\n")
- (mapcar '(lambda (line)
- (if (string-match org-todo-line-regexp
- line)
- ;; This is a headline
- (progn
- (setq level (- (match-end 1) (match-beginning 1))
- level (org-tr-level level)
- txt (match-string 3 line)
- todo
- (or (and org-export-mark-todo-in-toc
- (match-beginning 2)
- (not (equal (match-string 2 line)
- org-done-string)))
+ (push (concat (nth 3 lang-words) "\n") thetoc)
+ (push (concat (make-string (length (nth 3 lang-words)) ?=) "\n") thetoc)
+ (mapc '(lambda (line)
+ (if (string-match org-todo-line-regexp
+ line)
+ ;; This is a headline
+ (progn
+ (setq have-headings t)
+ (setq level (- (match-end 1) (match-beginning 1))
+ level (org-tr-level level)
+ txt (match-string 3 line)
+ todo
+ (or (and org-export-mark-todo-in-toc
+ (match-beginning 2)
+ (not (member (match-string 2 line)
+ org-done-keywords)))
; TODO, not DONE
- (and org-export-mark-todo-in-toc
- (= level umax-toc)
- (org-search-todo-below
- line lines level))))
- (setq txt (org-html-expand-for-ascii txt))
-
- (if (and (memq org-export-with-tags '(not-in-toc nil))
- (string-match "[ \t]+:[a-zA-Z0-9_@:]+:[ \t]*$" txt))
- (setq txt (replace-match "" t t txt)))
- (if (string-match quote-re0 txt)
- (setq txt (replace-match "" t t txt)))
-
- (if org-export-with-section-numbers
- (setq txt (concat (org-section-number level)
- " " txt)))
- (if (<= level umax-toc)
- (progn
- (insert
- (make-string (* (1- level) 4) ?\ )
- (format (if todo "%s (*)\n" "%s\n") txt))
- (setq org-last-level level))
- ))))
- lines)))
+ (and org-export-mark-todo-in-toc
+ (= level umax-toc)
+ (org-search-todo-below
+ line lines level))))
+ (setq txt (org-html-expand-for-ascii txt))
+
+ (while (string-match org-bracket-link-regexp txt)
+ (setq txt
+ (replace-match
+ (match-string (if (match-end 2) 3 1) txt)
+ t t txt)))
+
+ (if (and (memq org-export-with-tags '(not-in-toc nil))
+ (string-match
+ (org-re "[ \t]+:[[:alnum:]_@:]+:[ \t]*$")
+ txt))
+ (setq txt (replace-match "" t t txt)))
+ (if (string-match quote-re0 txt)
+ (setq txt (replace-match "" t t txt)))
+
+ (if org-export-with-section-numbers
+ (setq txt (concat (org-section-number level)
+ " " txt)))
+ (if (<= level umax-toc)
+ (progn
+ (push
+ (concat
+ (make-string
+ (* (max 0 (- level org-min-level)) 4) ?\ )
+ (format (if todo "%s (*)\n" "%s\n") txt))
+ thetoc)
+ (setq org-last-level level))
+ ))))
+ lines)
+ (setq thetoc (if have-headings (nreverse thetoc) nil))))
(org-init-section-numbers)
(while (setq line (pop lines))
(when custom-times
(setq line (org-translate-time line)))
(cond
- ((string-match "^\\(\\*+\\)[ \t]*\\(.*\\)" line)
+ ((string-match "^\\(\\*+\\)[ \t]+\\(.*\\)" line)
;; a Headline
+ (setq first-heading-pos (or first-heading-pos (point)))
(setq level (org-tr-level (- (match-end 1) (match-beginning 1)))
txt (match-string 2 line))
(org-ascii-level-start level txt umax lines))
+
+ ((and org-export-with-tables
+ (string-match "^\\([ \t]*\\)\\(|\\|\\+-+\\+\\)" line))
+ (if (not table-open)
+ ;; New table starts
+ (setq table-open t table-buffer nil))
+ ;; Accumulate lines
+ (setq table-buffer (cons line table-buffer))
+ (when (or (not lines)
+ (not (string-match "^\\([ \t]*\\)\\(|\\|\\+-+\\+\\)"
+ (car lines))))
+ (setq table-open nil
+ table-buffer (nreverse table-buffer))
+ (insert (mapconcat
+ (lambda (x)
+ (org-fix-indentation x org-ascii-current-indentation))
+ (org-format-table-ascii table-buffer)
+ "\n") "\n")))
(t
- (insert (org-fix-indentation line org-ascii-current-indentation) "\n"))))
+ (setq line (org-fix-indentation line org-ascii-current-indentation))
+ (if (and org-export-with-fixed-width
+ (string-match "^\\([ \t]*\\)\\(:\\)" line))
+ (setq line (replace-match "\\1" nil nil line)))
+ (insert line "\n"))))
+
(normal-mode)
+
+ ;; insert the table of contents
+ (when thetoc
+ (goto-char (point-min))
+ (if (re-search-forward "^[ \t]*\\[TABLE-OF-CONTENTS\\][ \t]*$" nil t)
+ (progn
+ (goto-char (match-beginning 0))
+ (replace-match ""))
+ (goto-char first-heading-pos))
+ (mapc 'insert thetoc)
+ (or (looking-at "[ \t]*\n[ \t]*\n")
+ (insert "\n\n")))
+
+ ;; Convert whitespace place holders
+ (goto-char (point-min))
+ (let (beg end)
+ (while (setq beg (next-single-property-change (point) 'org-whitespace))
+ (setq end (next-single-property-change beg 'org-whitespace))
+ (goto-char beg)
+ (delete-region beg end)
+ (insert (make-string (- end beg) ?\ ))))
+
(save-buffer)
;; remove display and invisible chars
(let (beg end)
(goto-char beg)))
(goto-char (point-min))))
+(defun org-export-ascii-clean-string ()
+ "Do extra work for ASCII export"
+ (goto-char (point-min))
+ (while (re-search-forward org-verbatim-re nil t)
+ (goto-char (match-end 2))
+ (backward-delete-char 1) (insert "'")
+ (goto-char (match-beginning 2))
+ (delete-char 1) (insert "`")
+ (goto-char (match-end 2))))
+
(defun org-search-todo-below (line lines level)
"Search the subtree below LINE for any TODO entries."
(let ((rest (cdr (memq line lines)))
(progn
(setq lv (- (match-end 1) (match-beginning 1))
todo (and (match-beginning 2)
- (not (equal (match-string 2 line)
- org-done-string))))
+ (not (member (match-string 2 line)
+ org-done-keywords))))
; TODO, not DONE
(if (<= lv level) (throw 'exit nil))
(if todo (throw 'exit t))))))))
;; find the indentation of the next non-empty line
(catch 'stop
(while lines
- (if (string-match "^\\*" (car lines)) (throw 'stop nil))
+ (if (string-match "^\\* " (car lines)) (throw 'stop nil))
(if (string-match "^\\([ \t]*\\)\\S-" (car lines))
(throw 'stop (setq ind (org-get-indentation (car lines)))))
(pop lines)))
(insert "\n"))
(setq char (nth (- umax level) (reverse org-export-ascii-underline)))
(unless org-export-with-tags
- (if (string-match "[ \t]+\\(:[a-zA-Z0-9_@:]+:\\)[ \t]*$" title)
+ (if (string-match (org-re "[ \t]+\\(:[[:alnum:]_@:]+:\\)[ \t]*$") title)
(setq title (replace-match "" t t title))))
(if org-export-with-section-numbers
(setq title (concat (org-section-number level) " " title)))
command."
(interactive
(list (progn
- (message "Export visible: [a]SCII [h]tml [b]rowse HTML [x]OXO [ ]keep buffer")
+ (message "Export visible: [a]SCII [h]tml [b]rowse HTML [H/R]uffer with HTML [x]OXO [ ]keep buffer")
(read-char-exclusive))
current-prefix-arg))
(if (not (member type '(?a ?\C-a ?b ?\C-b ?h ?x ?\ )))
(?b . org-export-as-html-and-open)
(?\C-b . org-export-as-html-and-open)
(?h . org-export-as-html)
+ (?H . org-export-as-html-to-buffer)
+ (?R . org-export-region-as-html)
(?x . org-export-as-xoxo)))))
(keepp (equal type ?\ ))
(file buffer-file-name)
(buffer (get-buffer-create "*Org Export Visible*"))
s e)
+ ;; Need to hack the drawers here.
+ (save-excursion
+ (goto-char (point-min))
+ (while (re-search-forward org-drawer-regexp nil t)
+ (goto-char (match-beginning 1))
+ (or (org-invisible-p) (org-flag-drawer nil))))
(with-current-buffer buffer (erase-buffer))
(save-excursion
(setq s (goto-char (point-min)))
(goto-char (org-find-invisible))
(append-to-buffer buffer s (point))
(setq s (goto-char (org-find-visible))))
+ (org-cycle-hide-drawers 'all)
(goto-char (point-min))
(unless keepp
;; Copy all comment lines to the end, to make sure #+ settings are
#+EMAIL: %s
#+LANGUAGE: %s
#+TEXT: Some descriptive text to be emitted. Several lines OK.
-#+OPTIONS: H:%d num:%s toc:%s \\n:%s @:%s ::%s |:%s ^:%s *:%s TeX:%s LaTeX:%s
+#+OPTIONS: H:%d num:%s toc:%s \\n:%s @:%s ::%s |:%s ^:%s -:%s f:%s *:%s TeX:%s LaTeX:%s skip:%s d:%s tags:%s
#+CATEGORY: %s
#+SEQ_TODO: %s
#+TYP_TODO: %s
+#+PRIORITIES: %c %c %c
+#+DRAWERS: %s
#+STARTUP: %s %s %s %s %s
#+TAGS: %s
#+ARCHIVE: %s
org-export-with-fixed-width
org-export-with-tables
org-export-with-sub-superscripts
+ org-export-with-special-strings
+ org-export-with-footnotes
org-export-with-emphasize
org-export-with-TeX-macros
org-export-with-LaTeX-fragments
+ org-export-skip-text-before-1st-heading
+ org-export-with-drawers
+ org-export-with-tags
(file-name-nondirectory buffer-file-name)
- (if (equal org-todo-interpretation 'sequence)
- (mapconcat 'identity org-todo-keywords " ")
- "TODO FEEDBACK VERIFY DONE")
- (if (equal org-todo-interpretation 'type)
- (mapconcat 'identity org-todo-keywords " ")
- "Me Jason Marie DONE")
+ "TODO FEEDBACK VERIFY DONE"
+ "Me Jason Marie DONE"
+ org-highest-priority org-lowest-priority org-default-priority
+ (mapconcat 'identity org-drawers " ")
(cdr (assoc org-startup-folded
'((nil . "showall") (t . "overview") (content . "content"))))
(if org-odd-levels-only "odd" "oddeven")
(if org-hide-leading-stars "hidestars" "showstars")
(if org-startup-align-all-tables "align" "noalign")
- (cond ((eq t org-log-done) "logdone")
- ((not org-log-done) "nologging")
- ((listp org-log-done)
- (mapconcat (lambda (x) (concat "lognote" (symbol-name x)))
- org-log-done " ")))
+ (cond ((eq org-log-done t) "logdone")
+ ((equal org-log-done 'note) "lognotedone")
+ ((not org-log-done) "nologdone"))
(or (mapconcat (lambda (x)
(cond
((equal '(:startgroup) x) "{")
(beg (if regionp (region-beginning) (point)))
(end (if regionp (region-end)))
(nlines (or arg (if (and beg end) (count-lines beg end) 1)))
+ (case-fold-search nil)
(re "[ \t]*\\(:\\)")
off)
(if regionp
(save-excursion
(org-back-to-heading)
(if (looking-at (concat outline-regexp
- "\\( +\\<" org-quote-string "\\>\\)"))
+ "\\( *\\<" org-quote-string "\\>[ \t]*\\)"))
(replace-match "" t t nil 1)
(if (looking-at outline-regexp)
(progn
(goto-char (match-end 0))
- (insert " " org-quote-string))))))))
+ (insert org-quote-string " "))))))))
(defun org-export-as-html-and-open (arg)
"Export the outline as HTML and immediately open it with a browser.
--visit=MyFile --funcall org-export-as-html-batch"
(org-export-as-html org-export-headline-levels 'hidden))
-(defun org-export-as-html (arg &optional hidden ext-plist)
+(defun org-export-as-html-to-buffer (arg)
+ "Call `org-exort-as-html` with output to a temporary buffer.
+No file is created. The prefix ARG is passed through to `org-export-as-html'."
+ (interactive "P")
+ (org-export-as-html arg nil nil "*Org HTML Export*")
+ (switch-to-buffer-other-window "*Org HTML Export*"))
+
+(defun org-replace-region-by-html (beg end)
+ "Assume the current region has org-mode syntax, and convert it to HTML.
+This can be used in any buffer. For example, you could write an
+itemized list in org-mode syntax in an HTML buffer and then use this
+command to convert it."
+ (interactive "r")
+ (let (reg html buf pop-up-frames)
+ (save-window-excursion
+ (if (org-mode-p)
+ (setq html (org-export-region-as-html
+ beg end t 'string))
+ (setq reg (buffer-substring beg end)
+ buf (get-buffer-create "*Org tmp*"))
+ (with-current-buffer buf
+ (erase-buffer)
+ (insert reg)
+ (org-mode)
+ (setq html (org-export-region-as-html
+ (point-min) (point-max) t 'string)))
+ (kill-buffer buf)))
+ (delete-region beg end)
+ (insert html)))
+
+(defun org-export-region-as-html (beg end &optional body-only buffer)
+ "Convert region from BEG to END in org-mode buffer to HTML.
+If prefix arg BODY-ONLY is set, omit file header, footer, and table of
+contents, and only produce the region of converted text, useful for
+cut-and-paste operations.
+If BUFFER is a buffer or a string, use/create that buffer as a target
+of the converted HTML. If BUFFER is the symbol `string', return the
+produced HTML as a string and leave not buffer behind. For example,
+a Lisp program could call this function in the following way:
+
+ (setq html (org-export-region-as-html beg end t 'string))
+
+When called interactively, the output buffer is selected, and shown
+in a window. A non-interactive call will only retunr the buffer."
+ (interactive "r\nP")
+ (when (interactive-p)
+ (setq buffer "*Org HTML Export*"))
+ (let ((transient-mark-mode t) (zmacs-regions t)
+ rtn)
+ (goto-char end)
+ (set-mark (point)) ;; to activate the region
+ (goto-char beg)
+ (setq rtn (org-export-as-html
+ nil nil nil
+ buffer body-only))
+ (if (fboundp 'deactivate-mark) (deactivate-mark))
+ (if (and (interactive-p) (bufferp rtn))
+ (switch-to-buffer-other-window rtn)
+ rtn)))
+
+(defvar html-table-tag nil) ; dynamically scoped into this.
+(defun org-export-as-html (arg &optional hidden ext-plist
+ to-buffer body-only pub-dir)
"Export the outline as a pretty HTML file.
-If there is an active region, export only the region.
-The prefix ARG specifies how many levels of the outline should become
-headlines. The default is 3. Lower levels will become bulleted lists.
-When HIDDEN is non-nil, don't display the HTML buffer.
+If there is an active region, export only the region. The prefix
+ARG specifies how many levels of the outline should become
+headlines. The default is 3. Lower levels will become bulleted
+lists. When HIDDEN is non-nil, don't display the HTML buffer.
EXT-PLIST is a property list with external parameters overriding
-org-mode's default settings, but still inferior to file-local settings."
+org-mode's default settings, but still inferior to file-local
+settings. When TO-BUFFER is non-nil, create a buffer with that
+name and export to that buffer. If TO-BUFFER is the symbol
+`string', don't leave any buffer behind but just return the
+resulting HTML as a string. When BODY-ONLY is set, don't produce
+the file header and footer, simply return the content of
+<body>...</body>, without even the body tags themselves. When
+PUB-DIR is set, use this as the publishing directory."
(interactive "P")
+
+ ;; Make sure we have a file name when we need it.
+ (when (and (not (or to-buffer body-only))
+ (not buffer-file-name))
+ (if (buffer-base-buffer)
+ (org-set-local 'buffer-file-name
+ (with-current-buffer (buffer-base-buffer)
+ buffer-file-name))
+ (error "Need a file name to be able to export.")))
+
(message "Exporting...")
(setq-default org-todo-line-regexp org-todo-line-regexp)
(setq-default org-deadline-line-regexp org-deadline-line-regexp)
- (setq-default org-done-string org-done-string)
+ (setq-default org-done-keywords org-done-keywords)
(setq-default org-maybe-keyword-time-regexp org-maybe-keyword-time-regexp)
(let* ((opt-plist (org-combine-plists (org-default-export-plist)
ext-plist
(org-infile-export-plist)))
(style (plist-get opt-plist :style))
+ (html-extension (plist-get opt-plist :html-extension))
(link-validate (plist-get opt-plist :link-validation-function))
- valid
+ valid thetoc have-headings first-heading-pos
(odd org-odd-levels-only)
(region-p (org-region-active-p))
- (region
- (buffer-substring
- (if region-p (region-beginning) (point-min))
- (if region-p (region-end) (point-max))))
+ (subtree-p
+ (when region-p
+ (save-excursion
+ (goto-char (region-beginning))
+ (and (org-at-heading-p)
+ (>= (org-end-of-subtree t t) (region-end))))))
;; The following two are dynamically scoped into other
;; routines below.
- (org-current-export-dir (org-export-directory :html opt-plist))
+ (org-current-export-dir
+ (or pub-dir (org-export-directory :html opt-plist)))
(org-current-export-file buffer-file-name)
- (all_lines
- (org-skip-comments (org-split-string
- (org-cleaned-string-for-export
- region :emph-multiline :for-html
- (if (plist-get opt-plist :LaTeX-fragments)
- :LaTeX-fragments))
- "[\r\n]")))
- (lines (org-export-find-first-heading-line all_lines))
(level 0) (line "") (origline "") txt todo
(umax nil)
(umax-toc nil)
- (filename (concat (file-name-as-directory
- (org-export-directory :html opt-plist))
- (file-name-sans-extension
- (file-name-nondirectory buffer-file-name))
- ".html"))
- (current-dir (file-name-directory buffer-file-name))
- (buffer (find-file-noselect filename))
+ (filename (if to-buffer nil
+ (expand-file-name
+ (concat
+ (file-name-sans-extension
+ (or (and subtree-p
+ (org-entry-get (region-beginning)
+ "EXPORT_FILE_NAME" t))
+ (file-name-nondirectory buffer-file-name)))
+ "." html-extension)
+ (file-name-as-directory
+ (or pub-dir (org-export-directory :html opt-plist))))))
+ (current-dir (if buffer-file-name
+ (file-name-directory buffer-file-name)
+ default-directory))
+ (buffer (if to-buffer
+ (cond
+ ((eq to-buffer 'string) (get-buffer-create "*Org HTML Export*"))
+ (t (get-buffer-create to-buffer)))
+ (find-file-noselect filename)))
(org-levels-open (make-vector org-level-max nil))
- (date (format-time-string "%Y/%m/%d" (current-time)))
- (time (format-time-string "%X" (org-current-time)))
+ (date (plist-get opt-plist :date))
(author (plist-get opt-plist :author))
- (title (or (plist-get opt-plist :title)
- (file-name-sans-extension
- (file-name-nondirectory buffer-file-name))))
+ (title (or (and subtree-p (org-export-get-title-from-subtree))
+ (plist-get opt-plist :title)
+ (and (not
+ (plist-get opt-plist :skip-before-1st-heading))
+ (org-export-grab-title-from-buffer))
+ (and buffer-file-name
+ (file-name-sans-extension
+ (file-name-nondirectory buffer-file-name)))
+ "UNTITLED"))
+ (html-table-tag (plist-get opt-plist :html-table-tag))
(quote-re0 (concat "^[ \t]*" org-quote-string "\\>"))
- (quote-re (concat "^\\(\\*+\\)\\([ \t]*" org-quote-string "\\>\\)"))
+ (quote-re (concat "^\\(\\*+\\)\\([ \t]+" org-quote-string "\\>\\)"))
(inquote nil)
(infixed nil)
(in-local-list nil)
(llt org-plain-list-ordered-item-terminator)
(email (plist-get opt-plist :email))
(language (plist-get opt-plist :language))
- (text (plist-get opt-plist :text))
(lang-words nil)
(target-alist nil) tg
(head-count 0) cnt
(start 0)
(coding-system (and (boundp 'buffer-file-coding-system)
buffer-file-coding-system))
- (coding-system-for-write coding-system)
- (save-buffer-coding-system coding-system)
- (charset (and coding-system
+ (coding-system-for-write (or org-export-html-coding-system
+ coding-system))
+ (save-buffer-coding-system (or org-export-html-coding-system
+ coding-system))
+ (charset (and coding-system-for-write
(fboundp 'coding-system-get)
- (coding-system-get coding-system 'mime-charset)))
+ (coding-system-get coding-system-for-write
+ 'mime-charset)))
+ (region
+ (buffer-substring
+ (if region-p (region-beginning) (point-min))
+ (if region-p (region-end) (point-max))))
+ (lines
+ (org-split-string
+ (org-cleaned-string-for-export
+ region
+ :emph-multiline t
+ :for-html t
+ :skip-before-1st-heading
+ (plist-get opt-plist :skip-before-1st-heading)
+ :drawers (plist-get opt-plist :drawers)
+ :archived-trees
+ (plist-get opt-plist :archived-trees)
+ :add-text
+ (plist-get opt-plist :text)
+ :LaTeX-fragments
+ (plist-get opt-plist :LaTeX-fragments))
+ "[\r\n]"))
table-open type
table-buffer table-orig-buffer
- ind start-is-num starter
+ ind start-is-num starter didclose
rpl path desc descp desc1 desc2 link
)
+
+ (let ((inhibit-read-only t))
+ (org-unmodified
+ (remove-text-properties (point-min) (point-max)
+ '(:org-license-to-kill t))))
+
(message "Exporting...")
- (setq org-last-level 1)
+ (setq org-min-level (org-get-min-level lines))
+ (setq org-last-level org-min-level)
(org-init-section-numbers)
+ (cond
+ ((and date (string-match "%" date))
+ (setq date (format-time-string date (current-time))))
+ (date)
+ (t (setq date (format-time-string "%Y/%m/%d %X" (current-time)))))
+
;; Get the language-dependent settings
(setq lang-words (or (assoc language org-export-language-setup)
(assoc "en" org-export-language-setup)))
;; Switch to the output buffer
- (if (or hidden t)
- (set-buffer buffer)
- (switch-to-buffer-other-window buffer))
- (erase-buffer)
+ (set-buffer buffer)
+ (let ((inhibit-read-only t)) (erase-buffer))
(fundamental-mode)
+
+ (and (fboundp 'set-buffer-file-coding-system)
+ (set-buffer-file-coding-system coding-system-for-write))
+
(let ((case-fold-search nil)
(org-odd-levels-only odd))
;; create local variables for all options, to make sure all called
;; functions get the correct information
- (mapcar (lambda (x)
- (set (make-local-variable (cdr x))
- (plist-get opt-plist (car x))))
- org-export-plist-vars)
+ (mapc (lambda (x)
+ (set (make-local-variable (cdr x))
+ (plist-get opt-plist (car x))))
+ org-export-plist-vars)
(setq umax (if arg (prefix-numeric-value arg)
org-export-headline-levels))
(setq umax-toc (if (integerp org-export-with-toc)
(min org-export-with-toc umax)
umax))
-
- ;; File header
- (insert (format
- "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\"
+ (unless body-only
+ ;; File header
+ (insert (format
+ "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\"
\"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">
<html xmlns=\"http://www.w3.org/1999/xhtml\"
lang=\"%s\" xml:lang=\"%s\">
<title>%s</title>
<meta http-equiv=\"Content-Type\" content=\"text/html;charset=%s\"/>
<meta name=\"generator\" content=\"Org-mode\"/>
-<meta name=\"generated\" content=\"%s %s\"/>
+<meta name=\"generated\" content=\"%s\"/>
<meta name=\"author\" content=\"%s\"/>
%s
</head><body>
"
- language language (org-html-expand title) (or charset "iso-8859-1")
- date time author style))
-
+ language language (org-html-expand title)
+ (or charset "iso-8859-1") date author style))
- (insert (or (plist-get opt-plist :preamble) ""))
+ (insert (or (plist-get opt-plist :preamble) ""))
- (when (plist-get opt-plist :auto-preamble)
- (if title (insert (format org-export-html-title-format
- (org-html-expand title))))
- (if text (insert "<p>\n" (org-html-expand text) "</p>")))
+ (when (plist-get opt-plist :auto-preamble)
+ (if title (insert (format org-export-html-title-format
+ (org-html-expand title))))))
- (if org-export-with-toc
+ (if (and org-export-with-toc (not body-only))
(progn
- (insert (format "<h%d>%s</h%d>\n"
- org-export-html-toplevel-hlevel
- (nth 3 lang-words)
- org-export-html-toplevel-hlevel))
- (insert "<ul>\n<li>")
+ (push (format "<h%d>%s</h%d>\n"
+ org-export-html-toplevel-hlevel
+ (nth 3 lang-words)
+ org-export-html-toplevel-hlevel)
+ thetoc)
+ (push "<ul>\n<li>" thetoc)
(setq lines
- (mapcar '(lambda (line)
- (if (string-match org-todo-line-regexp line)
- ;; This is a headline
- (progn
- (setq level (- (match-end 1) (match-beginning 1))
- level (org-tr-level level)
- txt (save-match-data
- (org-html-expand
- (org-export-cleanup-toc-line
- (match-string 3 line))))
- todo
- (or (and org-export-mark-todo-in-toc
- (match-beginning 2)
- (not (equal (match-string 2 line)
- org-done-string)))
+ (mapcar '(lambda (line)
+ (if (string-match org-todo-line-regexp line)
+ ;; This is a headline
+ (progn
+ (setq have-headings t)
+ (setq level (- (match-end 1) (match-beginning 1))
+ level (org-tr-level level)
+ txt (save-match-data
+ (org-html-expand
+ (org-export-cleanup-toc-line
+ (match-string 3 line))))
+ todo
+ (or (and org-export-mark-todo-in-toc
+ (match-beginning 2)
+ (not (member (match-string 2 line)
+ org-done-keywords)))
; TODO, not DONE
- (and org-export-mark-todo-in-toc
- (= level umax-toc)
- (org-search-todo-below
- line lines level))))
- (if (and (memq org-export-with-tags '(not-in-toc nil))
- (string-match "[ \t]+:[a-zA-Z0-9_@:]+:[ \t]*$" txt))
- (setq txt (replace-match "" t t txt)))
- (if (string-match quote-re0 txt)
- (setq txt (replace-match "" t t txt)))
- (if org-export-with-section-numbers
- (setq txt (concat (org-section-number level)
- " " txt)))
- (if (<= level umax-toc)
- (progn
- (setq head-count (+ head-count 1))
- (if (> level org-last-level)
- (progn
- (setq cnt (- level org-last-level))
- (while (>= (setq cnt (1- cnt)) 0)
- (insert "\n<ul>\n<li>"))
- (insert "\n")))
- (if (< level org-last-level)
- (progn
- (setq cnt (- org-last-level level))
- (while (>= (setq cnt (1- cnt)) 0)
- (insert "</li>\n</ul>"))
- (insert "\n")))
- ;; Check for targets
- (while (string-match org-target-regexp line)
- (setq tg (match-string 1 line)
- line (replace-match
- (concat "@<span class=\"target\">" tg "@</span> ")
- t t line))
- (push (cons (org-solidify-link-text tg)
- (format "sec-%d" head-count))
- target-alist))
- (while (string-match "<\\(<\\)+\\|>\\(>\\)+" txt)
- (setq txt (replace-match "" t t txt)))
- (insert
- (format
- (if todo
- "</li>\n<li><a href=\"#sec-%d\"><span class=\"todo\">%s</span></a>"
- "</li>\n<li><a href=\"#sec-%d\">%s</a>")
- head-count txt))
-
- (setq org-last-level level))
- )))
- line)
- lines))
- (while (> org-last-level 0)
+ (and org-export-mark-todo-in-toc
+ (= level umax-toc)
+ (org-search-todo-below
+ line lines level))))
+ (if (string-match
+ (org-re "[ \t]+:\\([[:alnum:]_@:]+\\):[ \t]*$") txt)
+ (setq txt (replace-match " <span class=\"tag\"> \\1</span>" t nil txt)))
+ (if (string-match quote-re0 txt)
+ (setq txt (replace-match "" t t txt)))
+ (if org-export-with-section-numbers
+ (setq txt (concat (org-section-number level)
+ " " txt)))
+ (if (<= level (max umax umax-toc))
+ (setq head-count (+ head-count 1)))
+ (if (<= level umax-toc)
+ (progn
+ (if (> level org-last-level)
+ (progn
+ (setq cnt (- level org-last-level))
+ (while (>= (setq cnt (1- cnt)) 0)
+ (push "\n<ul>\n<li>" thetoc))
+ (push "\n" thetoc)))
+ (if (< level org-last-level)
+ (progn
+ (setq cnt (- org-last-level level))
+ (while (>= (setq cnt (1- cnt)) 0)
+ (push "</li>\n</ul>" thetoc))
+ (push "\n" thetoc)))
+ ;; Check for targets
+ (while (string-match org-target-regexp line)
+ (setq tg (match-string 1 line)
+ line (replace-match
+ (concat "@<span class=\"target\">" tg "@</span> ")
+ t t line))
+ (push (cons (org-solidify-link-text tg)
+ (format "sec-%d" head-count))
+ target-alist))
+ (while (string-match "<\\(<\\)+\\|>\\(>\\)+" txt)
+ (setq txt (replace-match "" t t txt)))
+ (push
+ (format
+ (if todo
+ "</li>\n<li><a href=\"#sec-%d\"><span class=\"todo\">%s</span></a>"
+ "</li>\n<li><a href=\"#sec-%d\">%s</a>")
+ head-count txt) thetoc)
+
+ (setq org-last-level level))
+ )))
+ line)
+ lines))
+ (while (> org-last-level (1- org-min-level))
(setq org-last-level (1- org-last-level))
- (insert "</li>\n</ul>\n"))
- ))
+ (push "</li>\n</ul>\n" thetoc))
+ (setq thetoc (if have-headings (nreverse thetoc) nil))))
+
(setq head-count 0)
(org-init-section-numbers)
(catch 'nextline
;; end of quote section?
- (when (and inquote (string-match "^\\*+" line))
+ (when (and inquote (string-match "^\\*+ " line))
(insert "</pre>\n")
(setq inquote nil))
;; inside a quote section?
;; Protected HTML
(when (get-text-property 0 'org-protected line)
- (insert line "\n")
+ (let (par)
+ (when (re-search-backward
+ "\\(<p>\\)\\([ \t\r\n]*\\)\\=" (- (point) 100) t)
+ (setq par (match-string 1))
+ (replace-match "\\2\n"))
+ (insert line "\n")
+ (while (and lines
+ (or (= (length (car lines)) 0)
+ (get-text-property 0 'org-protected (car lines))))
+ (insert (pop lines) "\n"))
+ (and par (insert "<p>\n")))
(throw 'nextline nil))
;; Horizontal line
;; replace "&" by "&", "<" and ">" by "<" and ">"
;; handle @<..> HTML tags (replace "@>..<" by "<..>")
;; Also handle sub_superscripts and checkboxes
- (setq line (org-html-expand line))
+ (or (string-match org-table-hline-regexp line)
+ (setq line (org-html-expand line)))
;; Format the links
(setq start 0)
(setq rpl
(concat
"<a href=\"#"
- (org-solidify-link-text path target-alist)
+ (org-solidify-link-text
+ (save-match-data (org-link-unescape path)) target-alist)
"\">" desc "</a>")))
- ((member type '("http" "https")) ; FIXME: need to test this.
+ ((member type '("http" "https"))
;; standard URL, just check if we need to inline an image
(if (and (or (eq t org-export-html-inline-images)
(and org-export-html-inline-images (not descp)))
(string-match "\\.org$" thefile))
(setq thefile (concat (substring thefile 0
(match-beginning 0))
- ".html"))
+ "." html-extension))
(if (and search
;; make sure this is can be used as target search
(not (string-match "^[0-9]*$" search))
"></i>"))))
(setq line (replace-match rpl t t line)
start (+ start (length rpl))))
+
;; TODO items
(if (and (string-match org-todo-line-regexp line)
(match-beginning 2))
- (if (equal (match-string 2 line) org-done-string)
- (setq line (replace-match
- "<span class=\"done\">\\2</span>"
- t nil line 2))
- (setq line (replace-match "<span class=\"todo\">\\2</span>"
- t nil line 2))))
+
+ (setq line
+ (concat (substring line 0 (match-beginning 2))
+ "<span class=\""
+ (if (member (match-string 2 line)
+ org-done-keywords)
+ "done" "todo")
+ "\">" (match-string 2 line)
+ "</span>" (substring line (match-end 2)))))
+
+ ;; Does this contain a reference to a footnote?
+ (when org-export-with-footnotes
+ (setq start 0)
+ (while (string-match "\\([^* \t].*?\\)\\[\\([0-9]+\\)\\]" line start)
+ (if (get-text-property (match-beginning 2) 'org-protected line)
+ (setq start (match-end 2))
+ (let ((n (match-string 2 line)))
+ (setq line
+ (replace-match
+ (format
+ "%s<sup><a class=\"footref\" name=\"fnr.%s\" href=\"#fn.%s\">%s</a></sup>"
+ (match-string 1 line) n n n)
+ t t line))))))
(cond
- ((string-match "^\\(\\*+\\)[ \t]*\\(.*\\)" line)
+ ((string-match "^\\(\\*+\\)[ \t]+\\(.*\\)" line)
;; This is a headline
(setq level (org-tr-level (- (match-end 1) (match-beginning 1)))
txt (match-string 2 line))
(if (string-match quote-re0 txt)
(setq txt (replace-match "" t t txt)))
- (if (<= level umax) (setq head-count (+ head-count 1)))
+ (if (<= level (max umax umax-toc))
+ (setq head-count (+ head-count 1)))
(when in-local-list
;; Close any local lists before inserting a new header line
(while local-list-num
(pop local-list-num))
(setq local-list-indent nil
in-local-list nil))
+ (setq first-heading-pos (or first-heading-pos (point)))
(org-html-level-start level txt umax
(and org-export-with-toc (<= level umax))
head-count)
(cond
((eq llt t) "^\\([ \t]*\\)\\(\\([-+*] \\)\\|\\([0-9]+[.)]\\) \\)?\\( *[^ \t\n\r]\\|[ \t]*$\\)")
((= llt ?.) "^\\([ \t]*\\)\\(\\([-+*] \\)\\|\\([0-9]+\\.\\) \\)?\\( *[^ \t\n\r]\\|[ \t]*$\\)")
- ((= llt ?\)) "^\\( \t]*\\)\\(\\([-+*] \\)\\|\\([0-9]+)\\) \\)?\\( *[^ \t\n\r]\\|[ \t]*$\\)")
+ ((= llt ?\)) "^\\([ \t]*\\)\\(\\([-+*] \\)\\|\\([0-9]+)\\) \\)?\\( *[^ \t\n\r]\\|[ \t]*$\\)")
(t (error "Invalid value of `org-plain-list-ordered-item-terminator'")))
line)
(setq ind (org-get-string-indentation line)
line (substring line (match-beginning 5)))
(unless (string-match "[^ \t]" line)
;; empty line. Pretend indentation is large.
- (setq ind (1+ (or (car local-list-indent) 1))))
+ (setq ind (if org-empty-line-terminates-plain-lists
+ 0
+ (1+ (or (car local-list-indent) 1)))))
+ (setq didclose nil)
(while (and in-local-list
(or (and (= ind (car local-list-indent))
(not starter))
(< ind (car local-list-indent))))
+ (setq didclose t)
(org-close-li)
(insert (if (car local-list-num) "</ol>\n" "</ul>"))
(pop local-list-num) (pop local-list-indent)
((and starter
(or (not in-local-list)
(> ind (car local-list-indent))))
- ;; Start new (level of ) list
+ ;; Start new (level of) list
(org-close-par-maybe)
(insert (if start-is-num "<ol>\n<li>\n" "<ul>\n<li>\n"))
(push start-is-num local-list-num)
(starter
;; continue current list
(org-close-li)
- (insert "<li>\n")))
+ (insert "<li>\n"))
+ (didclose
+ ;; we did close a list, normal text follows: need <p>
+ (org-open-par)))
(if (string-match "^[ \t]*\\[\\([X ]\\)\\]" line)
(setq line
(replace-match
;; also start a new paragraph.
(if (string-match "^ [-+*]-\\|^[ \t]*$" line) (org-open-par))
+ ;; Is this the start of a footnote?
+ (when org-export-with-footnotes
+ (when (string-match "^[ \t]*\\[\\([0-9]+\\)\\]" line)
+ (org-close-par-maybe)
+ (let ((n (match-string 1 line)))
+ (setq line (replace-match
+ (format "<p class=\"footnote\"><sup><a class=\"footnum\" name=\"fn.%s\" href=\"#fnr.%s\">%s</a></sup>" n n n) t t line)))))
+
;; Check if the line break needs to be conserved
(cond
((string-match "\\\\\\\\[ \t]*$" line)
(and org-export-with-toc (<= level umax))
head-count)
- (when (plist-get opt-plist :auto-postamble)
- (when author
- (insert "<p class=\"author\"> "
- (nth 1 lang-words) ": " author "\n")
- (when email
- (insert "<a href=\"mailto:" email "\"><"
- email "></a>\n"))
- (insert "</p>\n"))
- (when (and date time)
- (insert "<p class=\"date\"> "
- (nth 2 lang-words) ": "
- date " " time "</p>\n")))
-
- (if org-export-html-with-timestamp
- (insert org-export-html-html-helper-timestamp))
- (insert (or (plist-get opt-plist :postamble) ""))
- (insert "</body>\n</html>\n")
+ (unless body-only
+ (when (plist-get opt-plist :auto-postamble)
+ (insert "<div id=\"postamble\">")
+ (when (and org-export-author-info author)
+ (insert "<p class=\"author\"> "
+ (nth 1 lang-words) ": " author "\n")
+ (when email
+ (if (listp (split-string email ",+ *"))
+ (mapc (lambda(e)
+ (insert "<a href=\"mailto:" e "\"><"
+ e "></a>\n"))
+ (split-string email ",+ *"))
+ (insert "<a href=\"mailto:" email "\"><"
+ email "></a>\n")))
+ (insert "</p>\n"))
+ (when (and date org-export-time-stamp-file)
+ (insert "<p class=\"date\"> "
+ (nth 2 lang-words) ": "
+ date "</p>\n"))
+ (insert "</div>"))
+
+ (if org-export-html-with-timestamp
+ (insert org-export-html-html-helper-timestamp))
+ (insert (or (plist-get opt-plist :postamble) ""))
+ (insert "</body>\n</html>\n"))
+
(normal-mode)
+ (if (eq major-mode default-major-mode) (html-mode))
+
+ ;; insert the table of contents
+ (goto-char (point-min))
+ (when thetoc
+ (if (or (re-search-forward
+ "<p>\\s-*\\[TABLE-OF-CONTENTS\\]\\s-*</p>" nil t)
+ (re-search-forward
+ "\\[TABLE-OF-CONTENTS\\]" nil t))
+ (progn
+ (goto-char (match-beginning 0))
+ (replace-match ""))
+ (goto-char first-heading-pos)
+ (when (looking-at "\\s-*</p>")
+ (goto-char (match-end 0))
+ (insert "\n")))
+ (insert "<div id=\"table-of-contents\">\n")
+ (mapc 'insert thetoc)
+ (insert "</div>\n"))
;; remove empty paragraphs and lists
(goto-char (point-min))
(while (re-search-forward "<p>[ \r\n\t]*</p>" nil t)
(replace-match ""))
(goto-char (point-min))
- (while (re-search-forward "<li>[ \r\n\t]*</li>\n?" nil t)
+ (while (re-search-forward "<li>[ \r\n\t]*</li>\n?" nil t)
+ (replace-match ""))
+ (goto-char (point-min))
+ (while (re-search-forward "</ul>\\s-*<ul>\n?" nil t)
(replace-match ""))
- (save-buffer)
+ ;; Convert whitespace place holders
(goto-char (point-min))
- (message "Exporting... done"))))
-
+ (let (beg end n)
+ (while (setq beg (next-single-property-change (point) 'org-whitespace))
+ (setq n (get-text-property beg 'org-whitespace)
+ end (next-single-property-change beg 'org-whitespace))
+ (goto-char beg)
+ (delete-region beg end)
+ (insert (format "<span style=\"visibility:hidden;\">%s</span>"
+ (make-string n ?x)))))
+ (or to-buffer (save-buffer))
+ (goto-char (point-min))
+ (message "Exporting... done")
+ (if (eq to-buffer 'string)
+ (prog1 (buffer-substring (point-min) (point-max))
+ (kill-buffer (current-buffer)))
+ (current-buffer)))))
+
+(defvar org-table-colgroup-info nil)
+(defun org-format-table-ascii (lines)
+ "Format a table for ascii export."
+ (if (stringp lines)
+ (setq lines (org-split-string lines "\n")))
+ (if (not (string-match "^[ \t]*|" (car lines)))
+ ;; Table made by table.el - test for spanning
+ lines
+
+ ;; A normal org table
+ ;; Get rid of hlines at beginning and end
+ (if (string-match "^[ \t]*|-" (car lines)) (setq lines (cdr lines)))
+ (setq lines (nreverse lines))
+ (if (string-match "^[ \t]*|-" (car lines)) (setq lines (cdr lines)))
+ (setq lines (nreverse lines))
+ (when org-export-table-remove-special-lines
+ ;; Check if the table has a marking column. If yes remove the
+ ;; column and the special lines
+ (setq lines (org-table-clean-before-export lines)))
+ ;; Get rid of the vertical lines except for grouping
+ (let ((vl (org-colgroup-info-to-vline-list org-table-colgroup-info))
+ rtn line vl1 start)
+ (while (setq line (pop lines))
+ (if (string-match org-table-hline-regexp line)
+ (and (string-match "|\\(.*\\)|" line)
+ (setq line (replace-match " \\1" t nil line)))
+ (setq start 0 vl1 vl)
+ (while (string-match "|" line start)
+ (setq start (match-end 0))
+ (or (pop vl1) (setq line (replace-match " " t t line)))))
+ (push line rtn))
+ (nreverse rtn))))
+
+(defun org-colgroup-info-to-vline-list (info)
+ (let (vl new last)
+ (while info
+ (setq last new new (pop info))
+ (if (or (memq last '(:end :startend))
+ (memq new '(:start :startend)))
+ (push t vl)
+ (push nil vl)))
+ (setq vl (nreverse vl))
+ (and vl (setcar vl nil))
+ vl))
(defun org-format-table-html (lines olines)
"Find out which HTML converter to use and return the HTML code."
+ (if (stringp lines)
+ (setq lines (org-split-string lines "\n")))
(if (string-match "^[ \t]*|" (car lines))
;; A normal org table
(org-format-org-table-html lines)
(lambda (x) (string-match "^[ \t]*|-" x))
(cdr lines)))))
(nlines 0) fnum i
- tbopen line fields html)
+ tbopen line fields html gr colgropen)
(if splice (setq head nil))
(unless splice (push (if head "<thead>" "<tbody>") html))
(setq tbopen t)
(string-match org-table-number-regexp x))
(incf (aref fnum i)))
(if head
- (concat "<th>" x "</th>")
- (concat "<td>" x "</td>")))
+ (concat (car org-export-table-header-tags) x
+ (cdr org-export-table-header-tags))
+ (concat (car org-export-table-data-tags) x
+ (cdr org-export-table-data-tags))))
fields "")
"</tr>")
html)))
(unless splice (push "</table>\n" html))
(setq html (nreverse html))
(unless splice
- ;; Put in COL tags with the alignment (unfortuntely often ignored...)
+ ;; Put in col tags with the alignment (unfortuntely often ignored...)
(push (mapconcat
(lambda (x)
- (format "<COL align=\"%s\">"
+ (setq gr (pop org-table-colgroup-info))
+ (format "%s<col align=\"%s\"></col>%s"
+ (if (memq gr '(:start :startend))
+ (prog1
+ (if colgropen "</colgroup>\n<colgroup>" "<colgroup>")
+ (setq colgropen t))
+ "")
(if (> (/ (float x) nlines) org-table-number-fraction)
- "right" "left")))
+ "right" "left")
+ (if (memq gr '(:end :startend))
+ (progn (setq colgropen nil) "</colgroup>")
+ "")))
fnum "")
html)
- (push org-export-html-table-tag html))
+ (if colgropen (setq html (cons (car html) (cons "</colgroup>" (cdr html)))))
+ (push html-table-tag html))
(concat (mapconcat 'identity html "\n") "\n")))
(defun org-table-clean-before-export (lines)
"Check if the table has a marking column.
If yes remove the column and the special lines."
+ (setq org-table-colgroup-info nil)
(if (memq nil
(mapcar
(lambda (x) (or (string-match "^[ \t]*|-" x)
(string-match "^[ \t]*| *\\([#!$*_^ /]\\) *|" x)))
lines))
(progn
- (setq org-table-clean-did-remove-column-1 nil)
- lines)
- (setq org-table-clean-did-remove-column-1 t)
+ (setq org-table-clean-did-remove-column nil)
+ (delq nil
+ (mapcar
+ (lambda (x)
+ (cond
+ ((string-match "^[ \t]*| */ *|" x)
+ (setq org-table-colgroup-info
+ (mapcar (lambda (x)
+ (cond ((member x '("<" "<")) :start)
+ ((member x '(">" ">")) :end)
+ ((member x '("<>" "<>")) :startend)
+ (t nil)))
+ (org-split-string x "[ \t]*|[ \t]*")))
+ nil)
+ (t x)))
+ lines)))
+ (setq org-table-clean-did-remove-column t)
(delq nil
(mapcar
- (lambda (x) (if (string-match "^[ \t]*| *[!_^/] *|" x)
- nil ; ignore this line
- (and (or (string-match "^[ \t]*|-+\\+" x)
- (string-match "^[ \t]*|[^|]*|" x))
- (replace-match "|" t t x))))
+ (lambda (x)
+ (cond
+ ((string-match "^[ \t]*| */ *|" x)
+ (setq org-table-colgroup-info
+ (mapcar (lambda (x)
+ (cond ((member x '("<" "<")) :start)
+ ((member x '(">" ">")) :end)
+ ((member x '("<>" "<>")) :startend)
+ (t nil)))
+ (cdr (org-split-string x "[ \t]*|[ \t]*"))))
+ nil)
+ ((string-match "^[ \t]*| *[!_^/] *|" x)
+ nil) ; ignore this line
+ ((or (string-match "^\\([ \t]*\\)|-+\\+" x)
+ (string-match "^\\([ \t]*\\)|[^|]*|" x))
+ ;; remove the first column
+ (replace-match "\\1|" t nil x))))
lines))))
-(defun org-fake-empty-table-line (line)
- "Replace everything except \"|\" with spaces."
- (let ((i (length line))
- (newstr (copy-sequence line)))
- (while (> i 0)
- (setq i (1- i))
- (if (not (eq (aref newstr i) ?|))
- (aset newstr i ?\ )))
- newstr))
-
(defun org-format-table-table-html (lines)
"Format a table generated by table.el into HTML.
This conversion does *not* use `table-generate-source' from table.el.
(let (line field-buffer
(head org-export-highlight-first-table-line)
fields html empty)
- (setq html (concat org-export-html-table-tag "\n"))
+ (setq html (concat html-table-tag "\n"))
(while (setq line (pop lines))
(setq empty " ")
(catch 'next-line
(progn
(if field-buffer
(progn
- (setq html (concat
- html
- "<tr>"
- (mapconcat
- (lambda (x)
- (if (equal x "") (setq x empty))
- (if head
- (concat "<th>" x "</th>\n")
- (concat "<td>" x "</td>\n")))
- field-buffer "\n")
- "</tr>\n"))
+ (setq
+ html
+ (concat
+ html
+ "<tr>"
+ (mapconcat
+ (lambda (x)
+ (if (equal x "") (setq x empty))
+ (if head
+ (concat (car org-export-table-header-tags) x
+ (cdr org-export-table-header-tags))
+ (concat (car org-export-table-data-tags) x
+ (cdr org-export-table-data-tags))))
+ field-buffer "\n")
+ "</tr>\n"))
(setq head nil)
(setq field-buffer nil)))
;; Ignore this line
(defun org-export-cleanup-toc-line (s)
"Remove tags and time staps from lines going into the toc."
- (if (string-match " +:[a-zA-Z0-9_@:]+: *$" s)
- (setq s (replace-match "" t t s)))
+ (when (memq org-export-with-tags '(not-in-toc nil))
+ (if (string-match (org-re " +:[[:alnum:]_@:]+: *$") s)
+ (setq s (replace-match "" t t s))))
(when org-export-remove-timestamps-from-toc
(while (string-match org-maybe-keyword-time-regexp s)
(setq s (replace-match "" t t s))))
+ (while (string-match org-bracket-link-regexp s)
+ (setq s (replace-match (match-string (if (match-end 3) 3 1) s)
+ t t s)))
s)
(defun org-html-expand (string)
"Prepare STRING for HTML export. Applies all active conversions.
If there are links in the string, don't modify these."
- (let* (m s l res)
- (while (setq m (string-match org-bracket-link-regexp string))
+ (let* ((re (concat org-bracket-link-regexp "\\|"
+ (org-re "[ \t]+\\(:[[:alnum:]_@:]+:\\)[ \t]*$")))
+ m s l res)
+ (while (setq m (string-match re string))
(setq s (substring string 0 m)
l (match-string 0 string)
string (substring string (match-end 0)))
"Apply all active conversions to translate special ASCII to HTML."
(setq s (org-html-protect s))
(if org-export-html-expand
- (while (string-match "@<\\([^&]*\\)>" s)
- (setq s (replace-match "<\\1>" t nil s))))
+ (let ((start 0))
+ (while (string-match "@<\\([^&]*\\)>" s)
+ (setq s (replace-match "<\\1>" t nil s)))))
(if org-export-with-emphasize
(setq s (org-export-html-convert-emphasize s)))
+ (if org-export-with-special-strings
+ (setq s (org-export-html-convert-special-strings s)))
(if org-export-with-sub-superscripts
(setq s (org-export-html-convert-sub-super s)))
(if org-export-with-TeX-macros
(let ((start 0) wd ass)
(while (setq start (string-match "\\\\\\([a-zA-Z]+\\)" s start))
- (setq wd (match-string 1 s))
- (if (setq ass (assoc wd org-html-entities))
- (setq s (replace-match (or (cdr ass)
- (concat "&" (car ass) ";"))
- t t s))
- (setq start (+ start (length wd)))))))
+ (if (get-text-property (match-beginning 0) 'org-protected s)
+ (setq start (match-end 0))
+ (setq wd (match-string 1 s))
+ (if (setq ass (assoc wd org-html-entities))
+ (setq s (replace-match (or (cdr ass)
+ (concat "&" (car ass) ";"))
+ t t s))
+ (setq start (+ start (length wd))))))))
s)
(defun org-create-multibrace-regexp (left right n)
"\\(\\(?:\\*\\|[-+]?[^-+*!@#$%^_ \t\r\n,:\"?<>~;./{}=()]+\\)\\)\\)")
"The regular expression matching a sub- or superscript.")
+(defvar org-match-substring-with-braces-regexp
+ (concat
+ "\\([^\\]\\)\\([_^]\\)\\("
+ "\\(" (org-create-multibrace-regexp "{" "}" org-match-sexp-depth) "\\)"
+ "\\)")
+ "The regular expression matching a sub- or superscript, forcing braces.")
+
+(defconst org-export-html-special-string-regexps
+ '(("\\\\-" . "­")
+ ("---\\([^-]\\)" . "—\\1")
+ ("--\\([^-]\\)" . "–\\1")
+ ("\\.\\.\\." . "…"))
+ "Regular expressions for special string conversion.")
+
+(defun org-export-html-convert-special-strings (string)
+ "Convert special characters in STRING to HTML."
+ (let ((all org-export-html-special-string-regexps)
+ e a re rpl start)
+ (while (setq a (pop all))
+ (setq re (car a) rpl (cdr a) start 0)
+ (while (string-match re string start)
+ (if (get-text-property (match-beginning 0) 'org-protected string)
+ (setq start (match-end 0))
+ (setq string (replace-match rpl t nil string)))))
+ string))
+
(defun org-export-html-convert-sub-super (string)
"Convert sub- and superscripts in STRING to HTML."
- (let (key c)
- (while (string-match org-match-substring-regexp string)
- (setq key (if (string= (match-string 2 string) "_") "sub" "sup"))
- (setq c (or (match-string 8 string)
- (match-string 6 string)
- (match-string 5 string)))
- (setq string (replace-match
- (concat (match-string 1 string)
- "<" key ">" c "</" key ">")
- t t string)))
+ (let (key c (s 0) (requireb (eq org-export-with-sub-superscripts '{})))
+ (while (string-match org-match-substring-regexp string s)
+ (cond
+ ((and requireb (match-end 8)) (setq s (match-end 2)))
+ ((get-text-property (match-beginning 2) 'org-protected string)
+ (setq s (match-end 2)))
+ (t
+ (setq s (match-end 1)
+ key (if (string= (match-string 2 string) "_") "sub" "sup")
+ c (or (match-string 8 string)
+ (match-string 6 string)
+ (match-string 5 string))
+ string (replace-match
+ (concat (match-string 1 string)
+ "<" key ">" c "</" key ">")
+ t t string)))))
(while (string-match "\\\\\\([_^]\\)" string)
- (setq string (replace-match (match-string 1 string) t t string))))
- string)
+ (setq string (replace-match (match-string 1 string) t t string)))
+ string))
(defun org-export-html-convert-emphasize (string)
"Apply emphasis."
- (while (string-match org-emph-re string)
- (setq string (replace-match (concat "\\1" (nth 2 (assoc (match-string 3 string) org-emphasis-alist)) "\\4" (nth 3 (assoc (match-string 3 string) org-emphasis-alist)) "\\5") t nil string)))
- string)
+ (let ((s 0) rpl)
+ (while (string-match org-emph-re string s)
+ (if (not (equal
+ (substring string (match-beginning 3) (1+ (match-beginning 3)))
+ (substring string (match-beginning 4) (1+ (match-beginning 4)))))
+ (setq s (match-beginning 0)
+ rpl
+ (concat
+ (match-string 1 string)
+ (nth 2 (assoc (match-string 3 string) org-emphasis-alist))
+ (match-string 4 string)
+ (nth 3 (assoc (match-string 3 string)
+ org-emphasis-alist))
+ (match-string 5 string))
+ string (replace-match rpl t t string)
+ s (+ s (- (length rpl) 2)))
+ (setq s (1+ s))))
+ string))
(defvar org-par-open nil)
(defun org-open-par ()
"Close <li> if necessary."
(org-close-par-maybe)
(insert "</li>\n"))
-; (when (save-excursion
-; (re-search-backward "</?\\(ul\\|ol\\|li\\|[hH][0-9]\\)>" nil t))
-; (if (member (match-string 0) '("</ul>" "</ol>" "<li>"))
-; (insert "</li>"))))
+(defvar body-only) ; dynamically scoped into this.
(defun org-html-level-start (level title umax with-toc head-count)
"Insert a new level in HTML export.
When TITLE is nil, just close all open levels."
(org-close-par-maybe)
- (let ((l (1+ (max level umax))))
- (while (<= l org-level-max)
+ (let ((l org-level-max))
+ (while (>= l level)
(if (aref org-levels-open (1- l))
(progn
- (org-html-level-close l)
+ (org-html-level-close l umax)
(aset org-levels-open (1- l) nil)))
- (setq l (1+ l)))
+ (setq l (1- l)))
(when title
;; If title is nil, this means this function is called to close
;; all levels, so the rest is done only if title is given
- (when (string-match "\\(:[a-zA-Z0-9_@:]+:\\)[ \t]*$" title)
+ (when (string-match (org-re "\\(:[[:alnum:]_@:]+:\\)[ \t]*$") title)
(setq title (replace-match
(if org-export-with-tags
(save-match-data
(aset org-levels-open (1- level) t)
(org-close-par-maybe)
(insert "<ul>\n<li>" title "<br/>\n")))
- (if org-export-with-section-numbers
+ (aset org-levels-open (1- level) t)
+ (if (and org-export-with-section-numbers (not body-only))
(setq title (concat (org-section-number level) " " title)))
(setq level (+ level org-export-html-toplevel-hlevel -1))
(if with-toc
- (insert (format "\n<h%d><a name=\"sec-%d\">%s</a></h%d>\n"
- level head-count title level))
- (insert (format "\n<h%d>%s</h%d>\n" level title level)))
+ (insert (format "\n<div class=\"outline-%d\">\n<h%d id=\"sec-%d\">%s</h%d>\n"
+ level level head-count title level))
+ (insert (format "\n<div class=\"outline-%d\">\n<h%d>%s</h%d>\n" level level title level)))
(org-open-par)))))
-(defun org-html-level-close (&rest args)
+(defun org-html-level-close (level max-outline-level)
"Terminate one level in HTML export."
- (org-close-li)
- (insert "</ul>"))
+ (if (<= level max-outline-level)
+ (insert "</div>\n")
+ (org-close-li)
+ (insert "</ul>\n")))
;;; iCalendar export
If COMBINE is non-nil, combine all calendar entries into a single large
file and store it under the name `org-combined-agenda-icalendar-file'."
(save-excursion
+ (org-prepare-agenda-buffers files)
(let* ((dir (org-export-directory
:ical (list :publishing-directory
org-export-publishing-directory)))
file ical-file ical-buffer category started org-agenda-new-buffers)
-
+ (and (get-buffer "*ical-tmp*") (kill-buffer "*ical-tmp*"))
(when combine
(setq ical-file
(if (file-name-absolute-p org-combined-agenda-icalendar-file)
(defun org-print-icalendar-entries (&optional combine)
"Print iCalendar entries for the current Org-mode file to `standard-output'.
When COMBINE is non nil, add the category to each line."
- (let ((re2 (concat "--?-?\\(" org-ts-regexp "\\)"))
- (org-category-table (org-get-category-table))
+ (let ((re1 (concat org-ts-regexp "\\|<%%([^>\n]+>"))
+ (re2 (concat "--?-?\\(" org-ts-regexp "\\)"))
(dts (org-ical-ts-to-string
(format-time-string (cdr org-time-stamp-formats) (current-time))
"DTSTART"))
- hd ts ts2 state status (inc t) pos
- scheduledp deadlinep tmp pri category)
+ hd ts ts2 state status (inc t) pos b sexp rrule
+ scheduledp deadlinep tmp pri category entry location summary desc
+ (sexp-buffer (get-buffer-create "*ical-tmp*")))
+ (org-refresh-category-properties)
(save-excursion
(goto-char (point-min))
- (while (re-search-forward org-ts-regexp nil t)
- (setq pos (match-beginning 0)
- ts (match-string 0)
- inc t
- hd (org-get-heading)
- category (org-get-category))
- (if (looking-at re2)
- (progn
- (goto-char (match-end 0))
- (setq ts2 (match-string 1) inc nil))
- (setq ts2 ts
- tmp (buffer-substring (max (point-min)
+ (while (re-search-forward re1 nil t)
+ (catch :skip
+ (org-agenda-skip)
+ (when (boundp 'org-icalendar-verify-function)
+ (unless (funcall org-icalendar-verify-function)
+ (outline-next-heading)
+ (backward-char 1)
+ (throw :skip nil)))
+ (setq pos (match-beginning 0)
+ ts (match-string 0)
+ inc t
+ hd (org-get-heading)
+ summary (org-icalendar-cleanup-string
+ (org-entry-get nil "SUMMARY"))
+ desc (org-icalendar-cleanup-string
+ (or (org-entry-get nil "DESCRIPTION")
+ (and org-icalendar-include-body (org-get-entry)))
+ t org-icalendar-include-body)
+ location (org-icalendar-cleanup-string
+ (org-entry-get nil "LOCATION"))
+ category (org-get-category))
+ (if (looking-at re2)
+ (progn
+ (goto-char (match-end 0))
+ (setq ts2 (match-string 1) inc nil))
+ (setq tmp (buffer-substring (max (point-min)
(- pos org-ds-keyword-length))
- pos)
- deadlinep (string-match org-deadline-regexp tmp)
- scheduledp (string-match org-scheduled-regexp tmp)
- ;; donep (org-entry-is-done-p)
- ))
- (if (or (string-match org-tr-regexp hd)
- (string-match org-ts-regexp hd))
- (setq hd (replace-match "" t t hd)))
- (if (string-match org-bracket-link-regexp hd)
- (setq hd (replace-match (if (match-end 3) (match-string 3 hd)
- (match-string 1 hd))
- t t hd)))
- (if deadlinep (setq hd (concat "DL: " hd)))
- (if scheduledp (setq hd (concat "S: " hd)))
- (princ (format "BEGIN:VEVENT
+ pos)
+ ts2 (if (string-match "[0-9]\\{1,2\\}:[0-9][0-9]-\\([0-9]\\{1,2\\}:[0-9][0-9]\\)" ts)
+ (progn
+ (setq inc nil)
+ (replace-match "\\1" t nil ts))
+ ts)
+ deadlinep (string-match org-deadline-regexp tmp)
+ scheduledp (string-match org-scheduled-regexp tmp)
+ ;; donep (org-entry-is-done-p)
+ ))
+ (if (or (string-match org-tr-regexp hd)
+ (string-match org-ts-regexp hd))
+ (setq hd (replace-match "" t t hd)))
+ (if (string-match "\\+\\([0-9]+\\)\\([dwmy]\\)>" ts)
+ (setq rrule
+ (concat "\nRRULE:FREQ="
+ (cdr (assoc
+ (match-string 2 ts)
+ '(("d" . "DAILY")("w" . "WEEKLY")
+ ("m" . "MONTHLY")("y" . "YEARLY"))))
+ ";INTERVAL=" (match-string 1 ts)))
+ (setq rrule ""))
+ (setq summary (or summary hd))
+ (if (string-match org-bracket-link-regexp summary)
+ (setq summary
+ (replace-match (if (match-end 3)
+ (match-string 3 summary)
+ (match-string 1 summary))
+ t t summary)))
+ (if deadlinep (setq summary (concat "DL: " summary)))
+ (if scheduledp (setq summary (concat "S: " summary)))
+ (if (string-match "\\`<%%" ts)
+ (with-current-buffer sexp-buffer
+ (insert (substring ts 1 -1) " " summary "\n"))
+ (princ (format "BEGIN:VEVENT
%s
-%s
-SUMMARY:%s
+%s%s
+SUMMARY:%s%s%s
CATEGORIES:%s
END:VEVENT\n"
- (org-ical-ts-to-string ts "DTSTART")
- (org-ical-ts-to-string ts2 "DTEND" inc)
- hd category)))
+ (org-ical-ts-to-string ts "DTSTART")
+ (org-ical-ts-to-string ts2 "DTEND" inc)
+ rrule summary
+ (if (and desc (string-match "\\S-" desc))
+ (concat "\nDESCRIPTION: " desc) "")
+ (if (and location (string-match "\\S-" location))
+ (concat "\nLOCATION: " location) "")
+ category)))))
+
+ (when (and org-icalendar-include-sexps
+ (condition-case nil (require 'icalendar) (error nil))
+ (fboundp 'icalendar-export-region))
+ ;; Get all the literal sexps
+ (goto-char (point-min))
+ (while (re-search-forward "^&?%%(" nil t)
+ (catch :skip
+ (org-agenda-skip)
+ (setq b (match-beginning 0))
+ (goto-char (1- (match-end 0)))
+ (forward-sexp 1)
+ (end-of-line 1)
+ (setq sexp (buffer-substring b (point)))
+ (with-current-buffer sexp-buffer
+ (insert sexp "\n"))
+ (princ (org-diary-to-ical-string sexp-buffer)))))
+
(when org-icalendar-include-todo
(goto-char (point-min))
(while (re-search-forward org-todo-line-regexp nil t)
- (setq state (match-string 2))
- (setq status (if (equal state org-done-string)
- "COMPLETED" "NEEDS-ACTION"))
- (when (and state
- (or (not (equal state org-done-string))
- (eq org-icalendar-include-todo 'all)))
- (setq hd (match-string 3))
- (if (string-match org-priority-regexp hd)
- (setq pri (string-to-char (match-string 2 hd))
- hd (concat (substring hd 0 (match-beginning 1))
- (substring hd (match-end 1))))
- (setq pri org-default-priority))
- (setq pri (floor (1+ (* 8. (/ (float (- org-lowest-priority pri))
- (- org-lowest-priority ?A))))))
-
- (princ (format "BEGIN:VTODO
+ (catch :skip
+ (org-agenda-skip)
+ (when (boundp 'org-icalendar-verify-function)
+ (unless (funcall org-icalendar-verify-function)
+ (outline-next-heading)
+ (backward-char 1)
+ (throw :skip nil)))
+ (setq state (match-string 2))
+ (setq status (if (member state org-done-keywords)
+ "COMPLETED" "NEEDS-ACTION"))
+ (when (and state
+ (or (not (member state org-done-keywords))
+ (eq org-icalendar-include-todo 'all))
+ (not (member org-archive-tag (org-get-tags-at)))
+ )
+ (setq hd (match-string 3)
+ summary (org-icalendar-cleanup-string
+ (org-entry-get nil "SUMMARY"))
+ desc (org-icalendar-cleanup-string
+ (or (org-entry-get nil "DESCRIPTION")
+ (and org-icalendar-include-body (org-get-entry)))
+ t org-icalendar-include-body)
+ location (org-icalendar-cleanup-string
+ (org-entry-get nil "LOCATION")))
+ (if (string-match org-bracket-link-regexp hd)
+ (setq hd (replace-match (if (match-end 3) (match-string 3 hd)
+ (match-string 1 hd))
+ t t hd)))
+ (if (string-match org-priority-regexp hd)
+ (setq pri (string-to-char (match-string 2 hd))
+ hd (concat (substring hd 0 (match-beginning 1))
+ (substring hd (match-end 1))))
+ (setq pri org-default-priority))
+ (setq pri (floor (1+ (* 8. (/ (float (- org-lowest-priority pri))
+ (- org-lowest-priority org-highest-priority))))))
+
+ (princ (format "BEGIN:VTODO
%s
-SUMMARY:%s
+SUMMARY:%s%s%s
CATEGORIES:%s
SEQUENCE:1
PRIORITY:%d
STATUS:%s
END:VTODO\n"
- dts hd category pri status))))))))
+ dts
+ (or summary hd)
+ (if (and location (string-match "\\S-" location))
+ (concat "\nLOCATION: " location) "")
+ (if (and desc (string-match "\\S-" desc))
+ (concat "\nDESCRIPTION: " desc) "")
+ category pri status)))))))))
+
+(defun org-icalendar-cleanup-string (s &optional is-body maxlength)
+ "Take out stuff and quote what needs to be quoted.
+When IS-BODY is non-nil, assume that this is the body of an item, clean up
+whitespace, newlines, drawers, and timestamps, and cut it down to MAXLENGTH
+characters."
+ (if (not s)
+ nil
+ (when is-body
+ (let ((re (concat "\\(" org-drawer-regexp "\\)[^\000]*?:END:.*\n?"))
+ (re2 (concat "^[ \t]*" org-keyword-time-regexp ".*\n?")))
+ (while (string-match re s) (setq s (replace-match "" t t s)))
+ (while (string-match re2 s) (setq s (replace-match "" t t s)))))
+ (let ((start 0))
+ (while (string-match "\\([,;\\]\\)" s start)
+ (setq start (+ (match-beginning 0) 2)
+ s (replace-match "\\\\\\1" nil nil s))))
+ (when is-body
+ (while (string-match "[ \t]*\n[ \t]*" s)
+ (setq s (replace-match "\\n" t t s))))
+ (setq s (org-trim s))
+ (if is-body
+ (if maxlength
+ (if (and (numberp maxlength)
+ (> (length s) maxlength))
+ (setq s (substring s 0 maxlength)))))
+ s))
+
+(defun org-get-entry ()
+ "Clean-up description string."
+ (save-excursion
+ (org-back-to-heading t)
+ (buffer-substring (point-at-bol 2) (org-end-of-subtree t))))
(defun org-start-icalendar-file (name)
"Start an iCalendar file by inserting the header."
(let ((s (car t2)) (mi (nth 1 t2)) (h (nth 2 t2))
(d (nth 3 t2)) (m (nth 4 t2)) (y (nth 5 t2)))
(when inc
- (if have-time (setq h (+ 2 h)) (setq d (1+ d))))
+ (if have-time
+ (if org-agenda-default-appointment-duration
+ (setq mi (+ org-agenda-default-appointment-duration mi))
+ (setq h (+ 2 h)))
+ (setq d (1+ d))))
(setq time (encode-time s mi h d m y)))
(setq fmt (if have-time ":%Y%m%dT%H%M%S" ";VALUE=DATE:%Y%m%d"))
(concat keyword (format-time-string fmt time))))
;; Output everything as XOXO
(with-current-buffer (get-buffer buffer)
- (goto-char (point-min)) ;; CD: beginning-of-buffer is not allowed.
- (let* ((opt-plist (org-combine-plists (org-default-export-plist)
+ (let* ((pos (point))
+ (opt-plist (org-combine-plists (org-default-export-plist)
(org-infile-export-plist)))
(filename (concat (file-name-as-directory
(org-export-directory :xoxo opt-plist))
(out (find-file-noselect filename))
(last-level 1)
(hanging-li nil))
+ (goto-char (point-min)) ;; CD: beginning-of-buffer is not allowed.
;; Check the output buffer is empty.
(with-current-buffer out (erase-buffer))
;; Kick off the output
(org-export-as-xoxo-insert-into out "<ol class='xoxo'>\n")
- (while (re-search-forward "^\\(\\*+\\) \\(.+\\)" (point-max) 't)
+ (while (re-search-forward "^\\(\\*+\\)[ \t]+\\(.+\\)" (point-max) 't)
(let* ((hd (match-string-no-properties 1))
(level (length hd))
(text (concat
(org-export-as-xoxo-insert-into out "</li>\n"))
(org-export-as-xoxo-insert-into out "</ol>\n"))
+ (goto-char pos)
;; Finish the buffer off and clean it up.
(switch-to-buffer-other-window out)
(indent-region (point-min) (point-max) nil)
;;;; Key bindings
-;; - Bindings in Org-mode map are currently
-;; 0123456789abcdefghijklmnopqrstuvwxyz!?@#$%^&-+*/=()_{}[]:;"|,.<>~`'\t the alphabet
-;; abcd fgh j lmnopqrstuvwxyz!? #$ ^ -+*/= [] ; |,.<>~ '\t necessary bindings
-;; e (?) useful from outline-mode
-;; i k @ expendable from outline-mode
-;; 0123456789 % & ()_{} " ` free
-
;; Make `C-c C-x' a prefix key
-(define-key org-mode-map "\C-c\C-x" (make-sparse-keymap))
+(org-defkey org-mode-map "\C-c\C-x" (make-sparse-keymap))
;; TAB key with modifiers
-(define-key org-mode-map "\C-i" 'org-cycle)
-(define-key org-mode-map [(tab)] 'org-cycle)
-(define-key org-mode-map [(control tab)] 'org-force-cycle-archived)
-(define-key org-mode-map [(meta tab)] 'org-complete)
-(define-key org-mode-map "\M-\t" 'org-complete)
-(define-key org-mode-map "\M-\C-i" 'org-complete)
+(org-defkey org-mode-map "\C-i" 'org-cycle)
+(org-defkey org-mode-map [(tab)] 'org-cycle)
+(org-defkey org-mode-map [(control tab)] 'org-force-cycle-archived)
+(org-defkey org-mode-map [(meta tab)] 'org-complete)
+(org-defkey org-mode-map "\M-\t" 'org-complete)
+(org-defkey org-mode-map "\M-\C-i" 'org-complete)
;; The following line is necessary under Suse GNU/Linux
(unless (featurep 'xemacs)
- (define-key org-mode-map [S-iso-lefttab] 'org-shifttab))
-(define-key org-mode-map [(shift tab)] 'org-shifttab)
+ (org-defkey org-mode-map [S-iso-lefttab] 'org-shifttab))
+(org-defkey org-mode-map [(shift tab)] 'org-shifttab)
+(define-key org-mode-map [backtab] 'org-shifttab)
-(define-key org-mode-map (org-key 'S-return) 'org-table-copy-down)
-(define-key org-mode-map [(meta shift return)] 'org-insert-todo-heading)
-(define-key org-mode-map [(meta return)] 'org-meta-return)
+(org-defkey org-mode-map [(shift return)] 'org-table-copy-down)
+(org-defkey org-mode-map [(meta shift return)] 'org-insert-todo-heading)
+(org-defkey org-mode-map [(meta return)] 'org-meta-return)
;; Cursor keys with modifiers
-(define-key org-mode-map [(meta left)] 'org-metaleft)
-(define-key org-mode-map [(meta right)] 'org-metaright)
-(define-key org-mode-map [(meta up)] 'org-metaup)
-(define-key org-mode-map [(meta down)] 'org-metadown)
+(org-defkey org-mode-map [(meta left)] 'org-metaleft)
+(org-defkey org-mode-map [(meta right)] 'org-metaright)
+(org-defkey org-mode-map [(meta up)] 'org-metaup)
+(org-defkey org-mode-map [(meta down)] 'org-metadown)
-(define-key org-mode-map [(meta shift left)] 'org-shiftmetaleft)
-(define-key org-mode-map [(meta shift right)] 'org-shiftmetaright)
-(define-key org-mode-map [(meta shift up)] 'org-shiftmetaup)
-(define-key org-mode-map [(meta shift down)] 'org-shiftmetadown)
+(org-defkey org-mode-map [(meta shift left)] 'org-shiftmetaleft)
+(org-defkey org-mode-map [(meta shift right)] 'org-shiftmetaright)
+(org-defkey org-mode-map [(meta shift up)] 'org-shiftmetaup)
+(org-defkey org-mode-map [(meta shift down)] 'org-shiftmetadown)
-(define-key org-mode-map (org-key 'S-up) 'org-shiftup)
-(define-key org-mode-map (org-key 'S-down) 'org-shiftdown)
-(define-key org-mode-map (org-key 'S-left) 'org-shiftleft)
-(define-key org-mode-map (org-key 'S-right) 'org-shiftright)
+(org-defkey org-mode-map [(shift up)] 'org-shiftup)
+(org-defkey org-mode-map [(shift down)] 'org-shiftdown)
+(org-defkey org-mode-map [(shift left)] 'org-shiftleft)
+(org-defkey org-mode-map [(shift right)] 'org-shiftright)
+
+(org-defkey org-mode-map [(control shift right)] 'org-shiftcontrolright)
+(org-defkey org-mode-map [(control shift left)] 'org-shiftcontrolleft)
;;; Extra keys for tty access.
;; We only set them when really needed because otherwise the
(when (or (featurep 'xemacs) ;; because XEmacs supports multi-device stuff
(not window-system))
- (define-key org-mode-map "\C-c\C-xc" 'org-table-copy-down)
- (define-key org-mode-map "\C-c\C-xM" 'org-insert-todo-heading)
- (define-key org-mode-map "\C-c\C-xm" 'org-meta-return)
- (define-key org-mode-map [?\e (return)] 'org-meta-return)
- (define-key org-mode-map [?\e (left)] 'org-metaleft)
- (define-key org-mode-map "\C-c\C-xl" 'org-metaleft)
- (define-key org-mode-map [?\e (right)] 'org-metaright)
- (define-key org-mode-map "\C-c\C-xr" 'org-metaright)
- (define-key org-mode-map [?\e (up)] 'org-metaup)
- (define-key org-mode-map "\C-c\C-xu" 'org-metaup)
- (define-key org-mode-map [?\e (down)] 'org-metadown)
- (define-key org-mode-map "\C-c\C-xd" 'org-metadown)
- (define-key org-mode-map "\C-c\C-xL" 'org-shiftmetaleft)
- (define-key org-mode-map "\C-c\C-xR" 'org-shiftmetaright)
- (define-key org-mode-map "\C-c\C-xU" 'org-shiftmetaup)
- (define-key org-mode-map "\C-c\C-xD" 'org-shiftmetadown)
- (define-key org-mode-map [?\C-c ?\C-x (up)] 'org-shiftup)
- (define-key org-mode-map [?\C-c ?\C-x (down)] 'org-shiftdown)
- (define-key org-mode-map [?\C-c ?\C-x (left)] 'org-shiftleft)
- (define-key org-mode-map [?\C-c ?\C-x (right)] 'org-shiftright))
+ (org-defkey org-mode-map "\C-c\C-xc" 'org-table-copy-down)
+ (org-defkey org-mode-map "\C-c\C-xM" 'org-insert-todo-heading)
+ (org-defkey org-mode-map "\C-c\C-xm" 'org-meta-return)
+ (org-defkey org-mode-map [?\e (return)] 'org-meta-return)
+ (org-defkey org-mode-map [?\e (left)] 'org-metaleft)
+ (org-defkey org-mode-map "\C-c\C-xl" 'org-metaleft)
+ (org-defkey org-mode-map [?\e (right)] 'org-metaright)
+ (org-defkey org-mode-map "\C-c\C-xr" 'org-metaright)
+ (org-defkey org-mode-map [?\e (up)] 'org-metaup)
+ (org-defkey org-mode-map "\C-c\C-xu" 'org-metaup)
+ (org-defkey org-mode-map [?\e (down)] 'org-metadown)
+ (org-defkey org-mode-map "\C-c\C-xd" 'org-metadown)
+ (org-defkey org-mode-map "\C-c\C-xL" 'org-shiftmetaleft)
+ (org-defkey org-mode-map "\C-c\C-xR" 'org-shiftmetaright)
+ (org-defkey org-mode-map "\C-c\C-xU" 'org-shiftmetaup)
+ (org-defkey org-mode-map "\C-c\C-xD" 'org-shiftmetadown)
+ (org-defkey org-mode-map [?\C-c (up)] 'org-shiftup)
+ (org-defkey org-mode-map [?\C-c (down)] 'org-shiftdown)
+ (org-defkey org-mode-map [?\C-c (left)] 'org-shiftleft)
+ (org-defkey org-mode-map [?\C-c (right)] 'org-shiftright)
+ (org-defkey org-mode-map [?\C-c ?\C-x (right)] 'org-shiftcontrolright)
+ (org-defkey org-mode-map [?\C-c ?\C-x (left)] 'org-shiftcontrolleft))
;; All the other keys
-(define-key org-mode-map "\C-c\C-a" 'show-all) ; in case allout messed up.
-(define-key org-mode-map "\C-c\C-r" 'org-reveal)
-(define-key org-mode-map "\C-xns" 'org-narrow-to-subtree)
-(define-key org-mode-map "\C-c$" 'org-archive-subtree)
-(define-key org-mode-map "\C-c\C-x\C-s" 'org-advertized-archive-subtree)
-(define-key org-mode-map "\C-c\C-x\C-a" 'org-toggle-archive-tag)
-(define-key org-mode-map "\C-c\C-xb" 'org-tree-to-indirect-buffer)
-(define-key org-mode-map "\C-c\C-j" 'org-goto)
-(define-key org-mode-map "\C-c\C-t" 'org-todo)
-(define-key org-mode-map "\C-c\C-s" 'org-schedule)
-(define-key org-mode-map "\C-c\C-d" 'org-deadline)
-(define-key org-mode-map "\C-c;" 'org-toggle-comment)
-(define-key org-mode-map "\C-c\C-v" 'org-show-todo-tree)
-(define-key org-mode-map "\C-c\C-w" 'org-check-deadlines)
-(define-key org-mode-map "\C-c/" 'org-occur) ; Minor-mode reserved
-(define-key org-mode-map "\C-c\\" 'org-tags-sparse-tree) ; Minor-mode res.
-(define-key org-mode-map "\C-c\C-m" 'org-insert-heading)
-(define-key org-mode-map "\M-\C-m" 'org-insert-heading)
-(define-key org-mode-map "\C-c\C-x\C-n" 'org-next-link)
-(define-key org-mode-map "\C-c\C-x\C-p" 'org-previous-link)
-(define-key org-mode-map "\C-c\C-l" 'org-insert-link)
-(define-key org-mode-map "\C-c\C-o" 'org-open-at-point)
-(define-key org-mode-map "\C-c%" 'org-mark-ring-push)
-(define-key org-mode-map "\C-c&" 'org-mark-ring-goto)
-(define-key org-mode-map "\C-c\C-z" 'org-time-stamp) ; Alternative binding
-(define-key org-mode-map "\C-c." 'org-time-stamp) ; Minor-mode reserved
-(define-key org-mode-map "\C-c!" 'org-time-stamp-inactive) ; Minor-mode r.
-(define-key org-mode-map "\C-c," 'org-priority) ; Minor-mode reserved
-(define-key org-mode-map "\C-c\C-y" 'org-evaluate-time-range)
-(define-key org-mode-map "\C-c>" 'org-goto-calendar)
-(define-key org-mode-map "\C-c<" 'org-date-from-calendar)
-(define-key org-mode-map [(control ?,)] 'org-cycle-agenda-files)
-(define-key org-mode-map [(control ?\')] 'org-cycle-agenda-files)
-(define-key org-mode-map "\C-c[" 'org-agenda-file-to-front)
-(define-key org-mode-map "\C-c]" 'org-remove-file)
-(define-key org-mode-map "\C-c-" 'org-table-insert-hline)
-(define-key org-mode-map "\C-c^" 'org-sort)
-(define-key org-mode-map "\C-c\C-c" 'org-ctrl-c-ctrl-c)
-(define-key org-mode-map "\C-c#" 'org-update-checkbox-count)
-(define-key org-mode-map "\C-m" 'org-return)
-(define-key org-mode-map "\C-c?" 'org-table-field-info)
-(define-key org-mode-map "\C-c " 'org-table-blank-field)
-(define-key org-mode-map "\C-c+" 'org-table-sum)
-(define-key org-mode-map "\C-c=" 'org-table-eval-formula)
-(define-key org-mode-map "\C-c'" 'org-table-edit-formulas)
-(define-key org-mode-map "\C-c`" 'org-table-edit-field)
-(define-key org-mode-map "\C-c|" 'org-table-create-or-convert-from-region)
-(define-key org-mode-map "\C-c*" 'org-table-recalculate)
-(define-key org-mode-map [(control ?#)] 'org-table-rotate-recalc-marks)
-(define-key org-mode-map "\C-c~" 'org-table-create-with-table.el)
-(define-key org-mode-map "\C-c\C-q" 'org-table-wrap-region)
-(define-key org-mode-map "\C-c}" 'org-table-toggle-coordinate-overlays)
-(define-key org-mode-map "\C-c{" 'org-table-toggle-formula-debugger)
-(define-key org-mode-map "\C-c\C-e" 'org-export)
-(define-key org-mode-map "\C-c:" 'org-toggle-fixed-width-section)
-
-(define-key org-mode-map "\C-c\C-x\C-k" 'org-cut-special)
-(define-key org-mode-map "\C-c\C-x\C-w" 'org-cut-special)
-(define-key org-mode-map "\C-c\C-x\M-w" 'org-copy-special)
-(define-key org-mode-map "\C-c\C-x\C-y" 'org-paste-special)
-
-(define-key org-mode-map "\C-c\C-x\C-t" 'org-toggle-time-stamp-overlays)
-(define-key org-mode-map "\C-c\C-x\C-i" 'org-clock-in)
-(define-key org-mode-map "\C-c\C-x\C-o" 'org-clock-out)
-(define-key org-mode-map "\C-c\C-x\C-x" 'org-clock-cancel)
-(define-key org-mode-map "\C-c\C-x\C-d" 'org-clock-display)
-(define-key org-mode-map "\C-c\C-x\C-r" 'org-clock-report)
-(define-key org-mode-map "\C-c\C-x\C-u" 'org-dblock-update)
-(define-key org-mode-map "\C-c\C-x\C-l" 'org-preview-latex-fragment)
-(define-key org-mode-map "\C-c\C-x\C-b" 'org-toggle-checkbox)
+(org-defkey org-mode-map "\C-c\C-a" 'show-all) ; in case allout messed up.
+(org-defkey org-mode-map "\C-c\C-r" 'org-reveal)
+(org-defkey org-mode-map "\C-xns" 'org-narrow-to-subtree)
+(org-defkey org-mode-map "\C-c$" 'org-archive-subtree)
+(org-defkey org-mode-map "\C-c\C-x\C-s" 'org-advertized-archive-subtree)
+(org-defkey org-mode-map "\C-c\C-x\C-a" 'org-toggle-archive-tag)
+(org-defkey org-mode-map "\C-c\C-xb" 'org-tree-to-indirect-buffer)
+(org-defkey org-mode-map "\C-c\C-j" 'org-goto)
+(org-defkey org-mode-map "\C-c\C-t" 'org-todo)
+(org-defkey org-mode-map "\C-c\C-s" 'org-schedule)
+(org-defkey org-mode-map "\C-c\C-d" 'org-deadline)
+(org-defkey org-mode-map "\C-c;" 'org-toggle-comment)
+(org-defkey org-mode-map "\C-c\C-v" 'org-show-todo-tree)
+(org-defkey org-mode-map "\C-c\C-w" 'org-refile)
+(org-defkey org-mode-map "\C-c/" 'org-sparse-tree) ; Minor-mode reserved
+(org-defkey org-mode-map "\C-c\\" 'org-tags-sparse-tree) ; Minor-mode res.
+(org-defkey org-mode-map "\C-c\C-m" 'org-ctrl-c-ret)
+(org-defkey org-mode-map "\M-\C-m" 'org-insert-heading)
+(org-defkey org-mode-map [(control return)] 'org-insert-heading-after-current)
+(org-defkey org-mode-map "\C-c\C-x\C-n" 'org-next-link)
+(org-defkey org-mode-map "\C-c\C-x\C-p" 'org-previous-link)
+(org-defkey org-mode-map "\C-c\C-l" 'org-insert-link)
+(org-defkey org-mode-map "\C-c\C-o" 'org-open-at-point)
+(org-defkey org-mode-map "\C-c%" 'org-mark-ring-push)
+(org-defkey org-mode-map "\C-c&" 'org-mark-ring-goto)
+(org-defkey org-mode-map "\C-c\C-z" 'org-time-stamp) ; Alternative binding
+(org-defkey org-mode-map "\C-c." 'org-time-stamp) ; Minor-mode reserved
+(org-defkey org-mode-map "\C-c!" 'org-time-stamp-inactive) ; Minor-mode r.
+(org-defkey org-mode-map "\C-c," 'org-priority) ; Minor-mode reserved
+(org-defkey org-mode-map "\C-c\C-y" 'org-evaluate-time-range)
+(org-defkey org-mode-map "\C-c>" 'org-goto-calendar)
+(org-defkey org-mode-map "\C-c<" 'org-date-from-calendar)
+(org-defkey org-mode-map [(control ?,)] 'org-cycle-agenda-files)
+(org-defkey org-mode-map [(control ?\')] 'org-cycle-agenda-files)
+(org-defkey org-mode-map "\C-c[" 'org-agenda-file-to-front)
+(org-defkey org-mode-map "\C-c]" 'org-remove-file)
+(org-defkey org-mode-map "\C-c\C-x<" 'org-agenda-set-restriction-lock)
+(org-defkey org-mode-map "\C-c\C-x>" 'org-agenda-remove-restriction-lock)
+(org-defkey org-mode-map "\C-c-" 'org-ctrl-c-minus)
+(org-defkey org-mode-map "\C-c*" 'org-ctrl-c-star)
+(org-defkey org-mode-map "\C-c^" 'org-sort)
+(org-defkey org-mode-map "\C-c\C-c" 'org-ctrl-c-ctrl-c)
+(org-defkey org-mode-map "\C-c\C-k" 'org-kill-note-or-show-branches)
+(org-defkey org-mode-map "\C-c#" 'org-update-checkbox-count)
+(org-defkey org-mode-map "\C-m" 'org-return)
+(org-defkey org-mode-map "\C-j" 'org-return-indent)
+(org-defkey org-mode-map "\C-c?" 'org-table-field-info)
+(org-defkey org-mode-map "\C-c " 'org-table-blank-field)
+(org-defkey org-mode-map "\C-c+" 'org-table-sum)
+(org-defkey org-mode-map "\C-c=" 'org-table-eval-formula)
+(org-defkey org-mode-map "\C-c'" 'org-table-edit-formulas)
+(org-defkey org-mode-map "\C-c`" 'org-table-edit-field)
+(org-defkey org-mode-map "\C-c|" 'org-table-create-or-convert-from-region)
+(org-defkey org-mode-map [(control ?#)] 'org-table-rotate-recalc-marks)
+(org-defkey org-mode-map "\C-c~" 'org-table-create-with-table.el)
+(org-defkey org-mode-map "\C-c\C-q" 'org-table-wrap-region)
+(org-defkey org-mode-map "\C-c}" 'org-table-toggle-coordinate-overlays)
+(org-defkey org-mode-map "\C-c{" 'org-table-toggle-formula-debugger)
+(org-defkey org-mode-map "\C-c\C-e" 'org-export)
+(org-defkey org-mode-map "\C-c:" 'org-toggle-fixed-width-section)
+(org-defkey org-mode-map "\C-c\C-x\C-f" 'org-emphasize)
+
+(org-defkey org-mode-map "\C-c\C-x\C-k" 'org-cut-special)
+(org-defkey org-mode-map "\C-c\C-x\C-w" 'org-cut-special)
+(org-defkey org-mode-map "\C-c\C-x\M-w" 'org-copy-special)
+(org-defkey org-mode-map "\C-c\C-x\C-y" 'org-paste-special)
+
+(org-defkey org-mode-map "\C-c\C-x\C-t" 'org-toggle-time-stamp-overlays)
+(org-defkey org-mode-map "\C-c\C-x\C-i" 'org-clock-in)
+(org-defkey org-mode-map "\C-c\C-x\C-o" 'org-clock-out)
+(org-defkey org-mode-map "\C-c\C-x\C-j" 'org-clock-goto)
+(org-defkey org-mode-map "\C-c\C-x\C-x" 'org-clock-cancel)
+(org-defkey org-mode-map "\C-c\C-x\C-d" 'org-clock-display)
+(org-defkey org-mode-map "\C-c\C-x\C-r" 'org-clock-report)
+(org-defkey org-mode-map "\C-c\C-x\C-u" 'org-dblock-update)
+(org-defkey org-mode-map "\C-c\C-x\C-l" 'org-preview-latex-fragment)
+(org-defkey org-mode-map "\C-c\C-x\C-b" 'org-toggle-checkbox)
+(org-defkey org-mode-map "\C-c\C-xp" 'org-set-property)
+(org-defkey org-mode-map "\C-c\C-xr" 'org-insert-columns-dblock)
+
+(define-key org-mode-map "\C-c\C-x\C-c" 'org-columns)
(when (featurep 'xemacs)
- (define-key org-mode-map 'button3 'popup-mode-menu))
+ (org-defkey org-mode-map 'button3 'popup-mode-menu))
(defsubst org-table-p () (org-at-table-p))
(goto-char (match-beginning 0))
(self-insert-command N))
(setq org-table-may-need-update t)
- (self-insert-command N)))
+ (self-insert-command N)
+ (org-fix-tags-on-the-fly)))
+
+(defun org-fix-tags-on-the-fly ()
+ (when (and (equal (char-after (point-at-bol)) ?*)
+ (org-on-heading-p))
+ (org-align-tags-here org-tags-column)))
(defun org-delete-backward-char (N)
"Like `delete-backward-char', insert whitespace at field end in tables.
;; noalign: if there were two spaces at the end, this field
;; does not determine the width of the column.
(if noalign (setq org-table-may-need-update c)))
- (backward-delete-char N)))
+ (backward-delete-char N)
+ (org-fix-tags-on-the-fly)))
(defun org-delete-char (N)
"Like `delete-char', but insert whitespace at field end in tables.
;; does not determine the width of the column.
(if noalign (setq org-table-may-need-update c)))
(delete-char N))
- (delete-char N)))
+ (delete-char N)
+ (org-fix-tags-on-the-fly)))
;; Make `delete-selection-mode' work with org-mode and orgtbl-mode
(put 'org-self-insert-command 'delete-selection t)
(put 'org-delete-char 'flyspell-delayed t)
(put 'org-delete-backward-char 'flyspell-delayed t)
+;; Make pabbrev-mode expand after org-mode commands
+(put 'org-self-insert-command 'pabbrev-expand-after-command t)
+(put 'orgybl-self-insert-command 'pabbrev-expand-after-command t)
;; How to do this: Measure non-white length of current string
;; If equal to column width, we should realign.
(while commands
(setq old (pop commands) new (pop commands))
(if (fboundp 'command-remapping)
- (define-key map (vector 'remap old) new)
+ (org-defkey map (vector 'remap old) new)
(substitute-key-definition old new map global-map)))))
(when (eq org-enable-table-editor 'optimized)
'self-insert-command 'org-self-insert-command
'delete-char 'org-delete-char
'delete-backward-char 'org-delete-backward-char)
- (define-key org-mode-map "|" 'org-force-self-insert))
+ (org-defkey org-mode-map "|" 'org-force-self-insert))
(defun org-shiftcursor-error ()
"Throw an error because Shift-Cursor command was applied in wrong context."
(defun org-shiftmetaleft ()
"Promote subtree or delete table column.
-Calls `org-promote-subtree' or `org-table-delete-column', depending on context.
+Calls `org-promote-subtree', `org-outdent-item',
+or `org-table-delete-column', depending on context.
See the individual commands for more information."
(interactive)
(cond
(defun org-shiftmetaright ()
"Demote subtree or insert table column.
-Calls `org-demote-subtree' or `org-table-insert-column', depending on context.
+Calls `org-demote-subtree', `org-indent-item',
+or `org-table-insert-column', depending on context.
See the individual commands for more information."
(interactive)
(cond
((org-at-table-p) (org-call-with-arg 'org-table-move-row 'up))
((org-on-heading-p) (call-interactively 'org-move-subtree-up))
((org-at-item-p) (call-interactively 'org-move-item-up))
- (t (org-shiftcursor-error))))
+ (t (transpose-lines 1) (beginning-of-line -1))))
(defun org-metadown (&optional arg)
"Move subtree down or move table row down.
((org-at-table-p) (call-interactively 'org-table-move-row))
((org-on-heading-p) (call-interactively 'org-move-subtree-down))
((org-at-item-p) (call-interactively 'org-move-item-down))
- (t (org-shiftcursor-error))))
+ (t (beginning-of-line 2) (transpose-lines 1) (beginning-of-line 0))))
(defun org-shiftup (&optional arg)
"Increase item in timestamp or increase priority of current headline.
-Calls `org-timestamp-up' or `org-priority-up', depending on context.
-See the individual commands for more information."
+Calls `org-timestamp-up' or `org-priority-up', or `org-previous-item',
+depending on context. See the individual commands for more information."
(interactive "P")
(cond
- ((org-at-timestamp-p t) (call-interactively 'org-timestamp-up))
+ ((org-at-timestamp-p t)
+ (call-interactively (if org-edit-timestamp-down-means-later
+ 'org-timestamp-down 'org-timestamp-up)))
((org-on-heading-p) (call-interactively 'org-priority-up))
((org-at-item-p) (call-interactively 'org-previous-item))
(t (call-interactively 'org-beginning-of-item) (beginning-of-line 1))))
(defun org-shiftdown (&optional arg)
"Decrease item in timestamp or decrease priority of current headline.
-Calls `org-timestamp-down' or `org-priority-down', depending on context.
-See the individual commands for more information."
+Calls `org-timestamp-down' or `org-priority-down', or `org-next-item'
+depending on context. See the individual commands for more information."
(interactive "P")
(cond
- ((org-at-timestamp-p t) (call-interactively 'org-timestamp-down))
+ ((org-at-timestamp-p t)
+ (call-interactively (if org-edit-timestamp-down-means-later
+ 'org-timestamp-up 'org-timestamp-down)))
((org-on-heading-p) (call-interactively 'org-priority-down))
(t (call-interactively 'org-next-item))))
(cond
((org-at-timestamp-p t) (call-interactively 'org-timestamp-up-day))
((org-on-heading-p) (org-call-with-arg 'org-todo 'right))
+ ((org-at-item-p) (org-call-with-arg 'org-cycle-list-bullet nil))
+ ((org-at-property-p) (call-interactively 'org-property-next-allowed-value))
(t (org-shiftcursor-error))))
(defun org-shiftleft ()
(cond
((org-at-timestamp-p t) (call-interactively 'org-timestamp-down-day))
((org-on-heading-p) (org-call-with-arg 'org-todo 'left))
+ ((org-at-item-p) (org-call-with-arg 'org-cycle-list-bullet 'previous))
+ ((org-at-property-p)
+ (call-interactively 'org-property-previous-allowed-value))
+ (t (org-shiftcursor-error))))
+
+(defun org-shiftcontrolright ()
+ "Switch to next TODO set."
+ (interactive)
+ (cond
+ ((org-on-heading-p) (org-call-with-arg 'org-todo 'nextset))
+ (t (org-shiftcursor-error))))
+
+(defun org-shiftcontrolleft ()
+ "Switch to previous TODO set."
+ (interactive)
+ (cond
+ ((org-on-heading-p) (org-call-with-arg 'org-todo 'previousset))
(t (org-shiftcursor-error))))
+(defun org-ctrl-c-ret ()
+ "Call `org-table-hline-and-move' or `org-insert-heading' dep. on context."
+ (interactive)
+ (cond
+ ((org-at-table-p) (call-interactively 'org-table-hline-and-move))
+ (t (call-interactively 'org-insert-heading))))
+
(defun org-copy-special ()
"Copy region in table or copy current subtree.
Calls `org-table-copy' or `org-copy-subtree', depending on context.
- If the cursor is on a #+TBLFM line, re-apply the formulas to
the entire table.
+- If the cursor is a the beginning of a dynamic block, update it.
+
- If the cursor is inside a table created by the table.el package,
activate that table.
links in this buffer.
- If the cursor is on a numbered item in a plain list, renumber the
- ordered list."
+ ordered list.
+
+- If the cursor is on a checkbox, toggle it."
(interactive "P")
(let ((org-enable-table-editor t))
(cond
((and (local-variable-p 'org-finish-function (current-buffer))
(fboundp org-finish-function))
(funcall org-finish-function))
+ ((org-at-property-p)
+ (call-interactively 'org-property-action))
((org-on-target-p) (call-interactively 'org-update-radio-target-regexp))
((org-on-heading-p) (call-interactively 'org-set-tags))
((org-at-table.el-p)
((org-at-item-checkbox-p)
(call-interactively 'org-toggle-checkbox))
((org-at-item-p)
- (call-interactively 'org-renumber-ordered-list))
+ (call-interactively 'org-maybe-renumber-ordered-list))
+ ((save-excursion (beginning-of-line 1) (looking-at "#\\+BEGIN:"))
+ ;; Dynamic block
+ (beginning-of-line 1)
+ (org-update-dblock))
((save-excursion (beginning-of-line 1) (looking-at "#\\+\\([A-Z]+\\)"))
(cond
((equal (match-string 1) "TBLFM")
(let ((org-inhibit-startup t)) (org-mode))
(message "Org-mode restarted to refresh keyword and special line setup"))
-(defun org-return ()
+(defun org-kill-note-or-show-branches ()
+ "If this is a Note buffer, abort storing the note. Else call `show-branches'."
+ (interactive)
+ (if (not org-finish-function)
+ (call-interactively 'show-branches)
+ (let ((org-note-abort t))
+ (funcall org-finish-function))))
+
+(defun org-return (&optional indent)
"Goto next table row or insert a newline.
Calls `org-table-next-row' or `newline', depending on context.
See the individual commands for more information."
(interactive)
(cond
+ ((bobp) (if indent (newline-and-indent) (newline)))
+ ((and (org-at-heading-p)
+ (looking-at
+ (org-re "\\([ \t]+\\(:[[:alnum:]_@:]+:\\)\\)[ \t]*$")))
+ (org-show-entry)
+ (end-of-line 1)
+ (newline))
((org-at-table-p)
(org-table-justify-field-maybe)
(call-interactively 'org-table-next-row))
- (t (newline))))
+ (t (if indent (newline-and-indent) (newline)))))
+
+(defun org-return-indent ()
+ "Goto next table row or insert a newline and indent.
+Calls `org-table-next-row' or `newline-and-indent', depending on
+context. See the individual commands for more information."
+ (interactive)
+ (org-return t))
+
+(defun org-ctrl-c-star ()
+ "Compute table, or change heading status of lines.
+Calls `org-table-recalculate' or `org-toggle-region-headlines',
+depending on context. This will also turn a plain list item or a normal
+line into a subheading."
+ (interactive)
+ (cond
+ ((org-at-table-p)
+ (call-interactively 'org-table-recalculate))
+ ((org-region-active-p)
+ ;; Convert all lines in region to list items
+ (call-interactively 'org-toggle-region-headings))
+ ((org-on-heading-p)
+ (org-toggle-region-headings (point-at-bol)
+ (min (1+ (point-at-eol)) (point-max))))
+ ((org-at-item-p)
+ ;; Convert to heading
+ (let ((level (save-match-data
+ (save-excursion
+ (condition-case nil
+ (progn
+ (org-back-to-heading t)
+ (funcall outline-level))
+ (error 0))))))
+ (replace-match
+ (concat (make-string (org-get-valid-level level 1) ?*) " ") t t)))
+ (t (org-toggle-region-headings (point-at-bol)
+ (min (1+ (point-at-eol)) (point-max))))))
+
+(defun org-ctrl-c-minus ()
+ "Insert separator line in table or modify bullet status of line.
+Also turns a plain line or a region of lines into list items.
+Calls `org-table-insert-hline', `org-toggle-region-items', or
+`org-cycle-list-bullet', depending on context."
+ (interactive)
+ (cond
+ ((org-at-table-p)
+ (call-interactively 'org-table-insert-hline))
+ ((org-on-heading-p)
+ ;; Convert to item
+ (save-excursion
+ (beginning-of-line 1)
+ (if (looking-at "\\*+ ")
+ (replace-match (concat (make-string (- (match-end 0) (point) 1) ?\ ) "- ")))))
+ ((org-region-active-p)
+ ;; Convert all lines in region to list items
+ (call-interactively 'org-toggle-region-items))
+ ((org-in-item-p)
+ (call-interactively 'org-cycle-list-bullet))
+ (t (org-toggle-region-items (point-at-bol)
+ (min (1+ (point-at-eol)) (point-max))))))
+
+(defun org-toggle-region-items (beg end)
+ "Convert all lines in region to list items.
+If the first line is already an item, convert all list items in the region
+to normal lines."
+ (interactive "r")
+ (let (l2 l)
+ (save-excursion
+ (goto-char end)
+ (setq l2 (org-current-line))
+ (goto-char beg)
+ (beginning-of-line 1)
+ (setq l (1- (org-current-line)))
+ (if (org-at-item-p)
+ ;; We already have items, de-itemize
+ (while (< (setq l (1+ l)) l2)
+ (when (org-at-item-p)
+ (goto-char (match-beginning 2))
+ (delete-region (match-beginning 2) (match-end 2))
+ (and (looking-at "[ \t]+") (replace-match "")))
+ (beginning-of-line 2))
+ (while (< (setq l (1+ l)) l2)
+ (unless (org-at-item-p)
+ (if (looking-at "\\([ \t]*\\)\\(\\S-\\)")
+ (replace-match "\\1- \\2")))
+ (beginning-of-line 2))))))
+
+(defun org-toggle-region-headings (beg end)
+ "Convert all lines in region to list items.
+If the first line is already an item, convert all list items in the region
+to normal lines."
+ (interactive "r")
+ (let (l2 l)
+ (save-excursion
+ (goto-char end)
+ (setq l2 (org-current-line))
+ (goto-char beg)
+ (beginning-of-line 1)
+ (setq l (1- (org-current-line)))
+ (if (org-on-heading-p)
+ ;; We already have headlines, de-star them
+ (while (< (setq l (1+ l)) l2)
+ (when (org-on-heading-p t)
+ (and (looking-at outline-regexp) (replace-match "")))
+ (beginning-of-line 2))
+ (let* ((stars (save-excursion
+ (re-search-backward org-complex-heading-regexp nil t)
+ (or (match-string 1) "*")))
+ (add-stars (if org-odd-levels-only "**" "*"))
+ (rpl (concat stars add-stars " \\2")))
+ (while (< (setq l (1+ l)) l2)
+ (unless (org-on-heading-p)
+ (if (looking-at "\\([ \t]*\\)\\(\\S-\\)")
+ (replace-match rpl)))
+ (beginning-of-line 2)))))))
(defun org-meta-return (&optional arg)
"Insert a new heading or wrap a region in a table.
["Insert Row" org-shiftmetadown (org-at-table-p)]
["Sort lines in region" org-table-sort-lines (org-at-table-p)]
"--"
- ["Insert Hline" org-table-insert-hline (org-at-table-p)])
+ ["Insert Hline" org-ctrl-c-minus (org-at-table-p)])
("Rectangle"
["Copy Rectangle" org-copy-special (org-at-table-p)]
["Cut Rectangle" org-cut-special (org-at-table-p)]
"--"
["Convert to odd levels" org-convert-to-odd-levels t]
["Convert to odd/even levels" org-convert-to-oddeven-levels t])
+ ("Editing"
+ ["Emphasis..." org-emphasize t])
("Archive"
["Toggle ARCHIVE tag" org-toggle-archive-tag t]
; ["Check and Tag Children" (org-toggle-archive-tag (4))
("Select keyword"
["Next keyword" org-shiftright (org-on-heading-p)]
["Previous keyword" org-shiftleft (org-on-heading-p)]
- ["Complete Keyword" org-complete (assq :todo-keyword (org-context))])
+ ["Complete Keyword" org-complete (assq :todo-keyword (org-context))]
+ ["Next keyword set" org-shiftcontrolright (and (> (length org-todo-sets) 1) (org-on-heading-p))]
+ ["Previous keyword set" org-shiftcontrolright (and (> (length org-todo-sets) 1) (org-on-heading-p))])
["Show TODO Tree" org-show-todo-tree t]
["Global TODO list" org-todo-list t]
"--"
["Set Priority" org-priority t]
["Priority Up" org-shiftup t]
- ["Priority Down" org-shiftdown t]
+ ["Priority Down" org-shiftdown t])
+ ("TAGS and Properties"
+ ["Set Tags" 'org-ctrl-c-ctrl-c (org-at-heading-p)]
+ ["Change tag in region" 'org-change-tag-in-region (org-region-active-p)]
"--"
-; ["Insert Checkbox" org-insert-todo-heading (org-in-item-p)]
-; ["Toggle Checkbox" org-ctrl-c-ctrl-c (org-at-item-checkbox-p)]
-; ["Insert [n/m] cookie" (progn (insert "[/]") (org-update-checkbox-count))
-; (or (org-on-heading-p) (org-at-item-p))]
-; ["Insert [%] cookie" (progn (insert "[%]") (org-update-checkbox-count))
-; (or (org-on-heading-p) (org-at-item-p))]
-; ["Update Statistics" org-update-checkbox-count t]
- )
+ ["Set property" 'org-set-property t]
+ ["Column view of properties" org-columns t]
+ ["Insert Column View DBlock" org-insert-columns-dblock t])
("Dates and Scheduling"
["Timestamp" org-time-stamp t]
["Timestamp (inactive)" org-time-stamp-inactive t]
["Clock in" org-clock-in t]
["Clock out" org-clock-out t]
["Clock cancel" org-clock-cancel t]
+ ["Goto running clock" org-clock-goto t]
["Display times" org-clock-display t]
["Create clock table" org-clock-report t]
"--"
["Record DONE time"
(progn (setq org-log-done (not org-log-done))
(message "Switching to %s will %s record a timestamp"
- org-done-string
+ (car org-done-keywords)
(if org-log-done "automatically" "not")))
:style toggle :selected org-log-done])
"--"
["Agenda Command..." org-agenda t]
+ ["Set Restriction Lock" org-agenda-set-restriction-lock t]
("File List for Agenda")
("Special views current file"
["TODO Tree" org-show-todo-tree t]
["Refresh setup" org-mode-restart t]
))
-(defun org-toggle-log-option (type)
- (if (not (listp org-log-done)) (setq org-log-done nil))
- (if (memq type org-log-done)
- (setq org-log-done (delq type org-log-done))
- (add-to-list 'org-log-done type)))
-
-(defun org-check-log-option (type)
- (and (listp org-log-done) (memq type org-log-done)))
-
(defun org-info (&optional node)
"Read documentation for Org-mode in the info system.
With optional NODE, go directly to that node."
(interactive)
- (require 'info)
- (Info-goto-node (format "(org)%s" (or node ""))))
+ (info (format "(org)%s" (or node ""))))
(defun org-install-agenda-files-menu ()
(let ((bl (buffer-list)))
["Add/Move Current File to Front of List" org-agenda-file-to-front t]
["Remove Current File from List" org-remove-file t]
["Cycle through agenda files" org-cycle-agenda-files t]
+ ["Occur in all agenda files" org-occur-in-agenda-files t]
"--")
(mapcar 'org-file-menu-entry (org-agenda-files t))))))))
(p (point)) clist o)
;; First the large context
(cond
- ((org-on-heading-p)
+ ((org-on-heading-p t)
(push (list :headline (point-at-bol) (point-at-eol)) clist)
(when (progn
(beginning-of-line 1)
(push (org-point-in-group p 4 :tags) clist))
(goto-char p)
(skip-chars-backward "^[\n\r \t") (or (eobp) (backward-char 1))
- (if (looking-at "\\[#[A-Z]\\]")
+ (if (looking-at "\\[#[A-Z0-9]\\]")
(push (org-point-in-group p 0 :priority) clist)))
((org-at-item-p)
(setq clist (nreverse (delq nil clist)))
clist))
+;; FIXME: Compare with at-regexp-p Do we need both?
(defun org-in-regexp (re &optional nlines visually)
"Check if point is inside a match of regexp.
Normally only the current line is checked, but you can include NLINES extra
(>= (+ inc (match-end 0)) pos))
(throw 'exit (cons (match-beginning 0) (match-end 0)))))))))
+(defun org-at-regexp-p (regexp)
+ "Is point inside a match of REGEXP in the current line?"
+ (catch 'exit
+ (save-excursion
+ (let ((pos (point)) (end (point-at-eol)))
+ (beginning-of-line 1)
+ (while (re-search-forward regexp end t)
+ (if (and (<= (match-beginning 0) pos)
+ (>= (match-end 0) pos))
+ (throw 'exit t)))
+ nil))))
+
+(defun org-occur-in-agenda-files (regexp &optional nlines)
+ "Call `multi-occur' with buffers for all agenda files."
+ (interactive "sOrg-files matching: \np")
+ (let* ((files (org-agenda-files))
+ (tnames (mapcar 'file-truename files))
+ (extra org-agenda-text-search-extra-files)
+ f)
+ (while (setq f (pop extra))
+ (unless (member (file-truename f) tnames)
+ (add-to-list 'files f 'append)
+ (add-to-list 'tnames (file-truename f) 'append)))
+ (multi-occur
+ (mapcar (lambda (x) (or (get-file-buffer x) (find-file-noselect x))) files)
+ regexp)))
+
+(if (boundp 'occur-mode-find-occurrence-hook)
+ ;; Emacs 23
+ (add-hook 'occur-mode-find-occurrence-hook
+ (lambda ()
+ (when (org-mode-p)
+ (org-reveal))))
+ ;; Emacs 22
+ (defadvice occur-mode-goto-occurrence
+ (after org-occur-reveal activate)
+ (and (org-mode-p) (org-reveal)))
+ (defadvice occur-mode-goto-occurrence-other-window
+ (after org-occur-reveal activate)
+ (and (org-mode-p) (org-reveal)))
+ (defadvice occur-mode-display-occurrence
+ (after org-occur-reveal activate)
+ (when (org-mode-p)
+ (let ((pos (occur-mode-find-occurrence)))
+ (with-current-buffer (marker-buffer pos)
+ (save-excursion
+ (goto-char pos)
+ (org-reveal)))))))
+
+(defun org-uniquify (list)
+ "Remove duplicate elements from LIST."
+ (let (res)
+ (mapc (lambda (x) (add-to-list 'res x 'append)) list)
+ res))
+
+(defun org-delete-all (elts list)
+ "Remove all elements in ELTS from LIST."
+ (while elts
+ (setq list (delete (pop elts) list)))
+ list)
+
+(defun org-back-over-empty-lines ()
+ "Move backwards over witespace, to the beginning of the first empty line.
+Returns the number of empty lines passed."
+ (let ((pos (point)))
+ (skip-chars-backward " \t\n\r")
+ (beginning-of-line 2)
+ (goto-char (min (point) pos))
+ (count-lines (point) pos)))
+
+(defun org-skip-whitespace ()
+ (skip-chars-forward " \t\n\r"))
+
(defun org-point-in-group (point group &optional context)
"Check if POINT is in match-group GROUP.
If CONTEXT is non-nil, return a list with CONTEXT and the boundaries of the
(list context (match-beginning group) (match-end group))
t)))
+(defun org-switch-to-buffer-other-window (&rest args)
+ "Switch to buffer in a second window on the current frame.
+In particular, do not allow pop-up frames."
+ (let (pop-up-frames special-display-buffer-names special-display-regexps
+ special-display-function)
+ (apply 'switch-to-buffer-other-window args)))
+
(defun org-combine-plists (&rest plists)
"Create a single property list from all plists in PLISTS.
The process starts by copying the first list, and then setting properties
(defun org-replace-escapes (string table)
"Replace %-escapes in STRING with values in TABLE.
-TABLE is an association list with keys line \"%a\" and string values.
+TABLE is an association list with keys like \"%a\" and string values.
The sequences in STRING may contain normal field width and padding information,
for example \"%-5s\". Replacements happen in the sequence given by TABLE,
so values can contain further %-escapes if they are define later in TABLE."
(setq c (1+ c)))
(nreverse rtn)))
-(defun org-at-regexp-p (regexp)
- "Is point inside a match of REGEXP in the current line?"
- (catch 'exit
- (save-excursion
- (let ((pos (point)) (end (point-at-eol)))
- (beginning-of-line 1)
- (while (re-search-forward regexp end t)
- (if (and (<= (match-beginning 0) pos)
- (>= (match-end 0) pos))
- (throw 'exit t)))
- nil))))
-
(defun org-find-base-buffer-visiting (file)
"Like `find-buffer-visiting' but alway return the base buffer and
-not an indirect buffer"
+not an indirect buffer."
(let ((buf (find-buffer-visiting file)))
- (or (buffer-base-buffer buf) buf)))
+ (if buf
+ (or (buffer-base-buffer buf) buf)
+ nil)))
+
+(defun org-image-file-name-regexp ()
+ "Return regexp matching the file names of images."
+ (if (fboundp 'image-file-name-regexp)
+ (image-file-name-regexp)
+ (let ((image-file-name-extensions
+ '("png" "jpeg" "jpg" "gif" "tiff" "tif"
+ "xbm" "xpm" "pbm" "pgm" "ppm")))
+ (concat "\\."
+ (regexp-opt (nconc (mapcar 'upcase
+ image-file-name-extensions)
+ image-file-name-extensions)
+ t)
+ "\\'"))))
+
+(defun org-file-image-p (file)
+ "Return non-nil if FILE is an image."
+ (save-match-data
+ (string-match (org-image-file-name-regexp) file)))
;;; Paragraph filling stuff.
;; We want this to be just right, so use the full arsenal.
-;; FIXME: configure filladapt for XEmacs
+
+(defun org-indent-line-function ()
+ "Indent line like previous, but further if previous was headline or item."
+ (interactive)
+ (let* ((pos (point))
+ (itemp (org-at-item-p))
+ column bpos bcol tpos tcol bullet btype bullet-type)
+ ;; Find the previous relevant line
+ (beginning-of-line 1)
+ (cond
+ ((looking-at "#") (setq column 0))
+ ((looking-at "\\*+ ") (setq column 0))
+ (t
+ (beginning-of-line 0)
+ (while (and (not (bobp)) (looking-at "[ \t]*[\n:#|]"))
+ (beginning-of-line 0))
+ (cond
+ ((looking-at "\\*+[ \t]+")
+ (goto-char (match-end 0))
+ (setq column (current-column)))
+ ((org-in-item-p)
+ (org-beginning-of-item)
+; (looking-at "[ \t]*\\(\\S-+\\)[ \t]*")
+ (looking-at "[ \t]*\\(\\S-+\\)[ \t]*\\(\\[[- X]\\][ \t]*\\)?")
+ (setq bpos (match-beginning 1) tpos (match-end 0)
+ bcol (progn (goto-char bpos) (current-column))
+ tcol (progn (goto-char tpos) (current-column))
+ bullet (match-string 1)
+ bullet-type (if (string-match "[0-9]" bullet) "n" bullet))
+ (if (not itemp)
+ (setq column tcol)
+ (goto-char pos)
+ (beginning-of-line 1)
+ (if (looking-at "\\S-")
+ (progn
+ (looking-at "[ \t]*\\(\\S-+\\)[ \t]*")
+ (setq bullet (match-string 1)
+ btype (if (string-match "[0-9]" bullet) "n" bullet))
+ (setq column (if (equal btype bullet-type) bcol tcol)))
+ (setq column (org-get-indentation)))))
+ (t (setq column (org-get-indentation))))))
+ (goto-char pos)
+ (if (<= (current-column) (current-indentation))
+ (indent-line-to column)
+ (save-excursion (indent-line-to column)))
+ (setq column (current-column))
+ (beginning-of-line 1)
+ (if (looking-at
+ "\\([ \t]+\\)\\(:[-_0-9a-zA-Z]+:\\)[ \t]*\\(\\S-.*\\(\\S-\\|$\\)\\)")
+ (replace-match (concat "\\1" (format org-property-format
+ (match-string 2) (match-string 3)))
+ t nil))
+ (move-to-column column)))
(defun org-set-autofill-regexps ()
(interactive)
;; text in a line directly attached to a headline would otherwise
;; fill the headline as well.
(org-set-local 'comment-start-skip "^#+[ \t]*")
- (org-set-local 'paragraph-separate "\f\\|\\*\\|[ ]*$\\|[ \t]*[:|]")
+ (org-set-local 'paragraph-separate "\f\\|\\*+ \\|[ ]*$\\|[ \t]*[:|]")
;; The paragraph starter includes hand-formatted lists.
(org-set-local 'paragraph-start
- "\f\\|[ ]*$\\|\\([*\f]+\\)\\|[ \t]*\\([-+*][ \t]+\\|[0-9]+[.)][ \t]+\\)\\|[ \t]*[:|]")
+ "\f\\|[ ]*$\\|\\*+ \\|\f\\|[ \t]*\\([-+*][ \t]+\\|[0-9]+[.)][ \t]+\\)\\|[ \t]*[:|]")
;; Inhibit auto-fill for headers, tables and fixed-width lines.
;; But only if the user has not turned off tables or fixed-width regions
(org-set-local
'auto-fill-inhibit-regexp
- (concat "\\*\\|#\\+"
+ (concat "\\*+ \\|#\\+"
"\\|[ \t]*" org-keyword-time-regexp
(if (or org-enable-table-editor org-enable-fixed-width-editor)
(concat
;; `adaptive-fill-regexp' never matches. Then install our own matcher.
(org-set-local 'adaptive-fill-regexp "\000")
(org-set-local 'adaptive-fill-function
- 'org-adaptive-fill-function))
+ 'org-adaptive-fill-function)
+ (org-set-local
+ 'align-mode-rules-list
+ '((org-in-buffer-settings
+ (regexp . "^#\\+[A-Z_]+:\\(\\s-*\\)\\S-+")
+ (modes . '(org-mode))))))
(defun org-fill-paragraph (&optional justify)
"Re-align a table, pass through to fill-paragraph if no table."
(let ((table-p (org-at-table-p))
(table.el-p (org-at-table.el-p)))
- (cond ((equal (char-after (point-at-bol)) ?*) t) ; skip headlines
- (table.el-p t) ; skip table.el tables
- (table-p (org-table-align) t) ; align org-mode tables
- (t nil)))) ; call paragraph-fill
+ (cond ((and (equal (char-after (point-at-bol)) ?*)
+ (save-excursion (goto-char (point-at-bol))
+ (looking-at outline-regexp)))
+ t) ; skip headlines
+ (table.el-p t) ; skip table.el tables
+ (table-p (org-table-align) t) ; align org-mode tables
+ (t nil)))) ; call paragraph-fill
;; For reference, this is the default value of adaptive-fill-regexp
;; "[ \t]*\\([-|#;>*]+[ \t]*\\|(?[0-9]+[.)][ \t]*\\)*"
work correctly."
(cond ((looking-at "#[ \t]+")
(match-string 0))
- ((looking-at " *\\([-*+] \\|[0-9]+[.)] \\)?")
- (make-string (- (match-end 0) (match-beginning 0)) ?\ ))
+ ((looking-at "[ \t]*\\([-*+] \\|[0-9]+[.)] \\)?")
+ (save-excursion
+ (goto-char (match-end 0))
+ (make-string (current-column) ?\ )))
(t nil)))
-
-(defun org-image-file-name-regexp ()
- "Return regexp matching the file names of images."
- (if (fboundp 'image-file-name-regexp)
- (image-file-name-regexp)
- (let ((image-file-name-extensions
- '("png" "jpeg" "jpg" "gif" "tiff" "tif"
- "xbm" "xpm" "pbm" "pgm" "ppm")))
- (concat "\\."
- (regexp-opt (nconc (mapcar 'upcase
- image-file-name-extensions)
- image-file-name-extensions)
- t)
- "\\'"))))
-
-(defun org-file-image-p (file)
- "Return non-nil if FILE is an image."
- (save-match-data
- (string-match (org-image-file-name-regexp) file)))
-
;;;; Functions extending outline functionality
-;; C-a should go to the beginning of a *visible* line, also in the
-;; new outline.el. I guess this should be patched into Emacs?
-(defun org-beginning-of-line ()
+
+(defun org-beginning-of-line (&optional arg)
"Go to the beginning of the current line. If that is invisible, continue
-to a visible line beginning. This makes the function of C-a more intuitive."
- (interactive)
- (beginning-of-line 1)
- (if (bobp)
- nil
- (backward-char 1)
- (if (org-invisible-p)
- (while (and (not (bobp)) (org-invisible-p))
- (backward-char 1)
- (beginning-of-line 1))
- (forward-char 1))))
+to a visible line beginning. This makes the function of C-a more intuitive.
+If this is a headline, and `org-special-ctrl-a/e' is set, ignore tags on the
+first attempt, and only move to after the tags when the cursor is already
+beyond the end of the headline."
+ (interactive "P")
+ (let ((pos (point)))
+ (beginning-of-line 1)
+ (if (bobp)
+ nil
+ (backward-char 1)
+ (if (org-invisible-p)
+ (while (and (not (bobp)) (org-invisible-p))
+ (backward-char 1)
+ (beginning-of-line 1))
+ (forward-char 1)))
+ (when org-special-ctrl-a/e
+ (cond
+ ((and (looking-at org-todo-line-regexp)
+ (= (char-after (match-end 1)) ?\ ))
+ (goto-char
+ (if (eq org-special-ctrl-a/e t)
+ (cond ((> pos (match-beginning 3)) (match-beginning 3))
+ ((= pos (point)) (match-beginning 3))
+ (t (point)))
+ (cond ((> pos (point)) (point))
+ ((not (eq last-command this-command)) (point))
+ (t (match-beginning 3))))))
+ ((org-at-item-p)
+ (goto-char
+ (if (eq org-special-ctrl-a/e t)
+ (cond ((> pos (match-end 4)) (match-end 4))
+ ((= pos (point)) (match-end 4))
+ (t (point)))
+ (cond ((> pos (point)) (point))
+ ((not (eq last-command this-command)) (point))
+ (t (match-end 4))))))))))
+
+(defun org-end-of-line (&optional arg)
+ "Go to the end of the line.
+If this is a headline, and `org-special-ctrl-a/e' is set, ignore tags on the
+first attempt, and only move to after the tags when the cursor is already
+beyond the end of the headline."
+ (interactive "P")
+ (if (or (not org-special-ctrl-a/e)
+ (not (org-on-heading-p)))
+ (end-of-line arg)
+ (let ((pos (point)))
+ (beginning-of-line 1)
+ (if (looking-at (org-re ".*?\\([ \t]*\\)\\(:[[:alnum:]_@:]+:\\)[ \t]*$"))
+ (if (eq org-special-ctrl-a/e t)
+ (if (or (< pos (match-beginning 1))
+ (= pos (match-end 0)))
+ (goto-char (match-beginning 1))
+ (goto-char (match-end 0)))
+ (if (or (< pos (match-end 0)) (not (eq this-command last-command)))
+ (goto-char (match-end 0))
+ (goto-char (match-beginning 1))))
+ (end-of-line arg)))))
(define-key org-mode-map "\C-a" 'org-beginning-of-line)
+(define-key org-mode-map "\C-e" 'org-end-of-line)
+
+(defun org-kill-line (&optional arg)
+ "Kill line, to tags or end of line."
+ (interactive "P")
+ (cond
+ ((or (not org-special-ctrl-k)
+ (bolp)
+ (not (org-on-heading-p)))
+ (call-interactively 'kill-line))
+ ((looking-at (org-re ".*?\\S-\\([ \t]+\\(:[[:alnum:]_@:]+:\\)\\)[ \t]*$"))
+ (kill-region (point) (match-beginning 1))
+ (org-set-tags nil t))
+ (t (kill-region (point) (point-at-eol)))))
+
+(define-key org-mode-map "\C-k" 'org-kill-line)
(defun org-invisible-p ()
"Check if point is at a character currently not visible."
(defalias 'org-back-to-heading 'outline-back-to-heading)
(defalias 'org-on-heading-p 'outline-on-heading-p)
+(defalias 'org-at-heading-p 'outline-on-heading-p)
+(defun org-at-heading-or-item-p ()
+ (or (org-on-heading-p) (org-at-item-p)))
(defun org-on-target-p ()
(or (org-in-regexp org-radio-target-regexp)
(outline-up-heading-all arg) ; emacs 21 version of outline.el
(outline-up-heading arg t))) ; emacs 22 version of outline.el
+(defun org-up-heading-safe ()
+ "Move to the heading line of which the present line is a subheading.
+This version will not throw an error. It will return the level of the
+headline found, or nil if no higher level is found."
+ (let ((pos (point)) start-level level
+ (re (concat "^" outline-regexp)))
+ (catch 'exit
+ (outline-back-to-heading t)
+ (setq start-level (funcall outline-level))
+ (if (equal start-level 1) (throw 'exit nil))
+ (while (re-search-backward re nil t)
+ (setq level (funcall outline-level))
+ (if (< level start-level) (throw 'exit level)))
+ nil)))
+
+(defun org-first-sibling-p ()
+ "Is this heading the first child of its parents?"
+ (interactive)
+ (let ((re (concat "^" outline-regexp))
+ level l)
+ (unless (org-at-heading-p t)
+ (error "Not at a heading"))
+ (setq level (funcall outline-level))
+ (save-excursion
+ (if (not (re-search-backward re nil t))
+ t
+ (setq l (funcall outline-level))
+ (< l level)))))
+
(defun org-goto-sibling (&optional previous)
"Goto the next sibling, even if it is invisible.
When PREVIOUS is set, go to the previous sibling instead. Returns t
(pos (point))
(re (concat "^" outline-regexp))
level l)
- (org-back-to-heading t)
- (setq level (funcall outline-level))
- (catch 'exit
- (or previous (forward-char 1))
- (while (funcall fun re nil t)
- (setq l (funcall outline-level))
- (when (< l level) (goto-char pos) (throw 'exit nil))
- (when (= l level) (goto-char (match-beginning 0)) (throw 'exit t)))
- (goto-char pos)
- nil)))
+ (when (condition-case nil (org-back-to-heading t) (error nil))
+ (setq level (funcall outline-level))
+ (catch 'exit
+ (or previous (forward-char 1))
+ (while (funcall fun re nil t)
+ (setq l (funcall outline-level))
+ (when (< l level) (goto-char pos) (throw 'exit nil))
+ (when (= l level) (goto-char (match-beginning 0)) (throw 'exit t)))
+ (goto-char pos)
+ nil))))
(defun org-show-siblings ()
"Show all siblings of the current headline."
(save-excursion
(and (outline-next-heading)
(org-flag-heading nil))))
- (outline-flag-region (max 1 (1- (point)))
+ (outline-flag-region (max (point-min) (1- (point)))
(save-excursion (outline-end-of-heading) (point))
flag))))
-(defun org-end-of-subtree (&optional invisible-OK)
+(defun org-end-of-subtree (&optional invisible-OK to-heading)
;; This is an exact copy of the original function, but it uses
;; `org-back-to-heading', to make it work also in invisible
;; trees. And is uses an invisible-OK argument.
(or first (> (funcall outline-level) level)))
(setq first nil)
(outline-next-heading))
- (if (memq (preceding-char) '(?\n ?\^M))
- (progn
- ;; Go to end of line before heading
- (forward-char -1)
- (if (memq (preceding-char) '(?\n ?\^M))
- ;; leave blank line before heading
- (forward-char -1)))))
+ (unless to-heading
+ (if (memq (preceding-char) '(?\n ?\^M))
+ (progn
+ ;; Go to end of line before heading
+ (forward-char -1)
+ (if (memq (preceding-char) '(?\n ?\^M))
+ ;; leave blank line before heading
+ (forward-char -1))))))
(point))
(defun org-show-subtree ()
Show the heading too, if it is currently invisible."
(interactive)
(save-excursion
- (org-back-to-heading t)
- (outline-flag-region
- (max 1 (1- (point)))
- (save-excursion
- (re-search-forward (concat "[\r\n]\\(" outline-regexp "\\)") nil 'move)
- (or (match-beginning 1) (point-max)))
- nil)))
+ (condition-case nil
+ (progn
+ (org-back-to-heading t)
+ (outline-flag-region
+ (max (point-min) (1- (point)))
+ (save-excursion
+ (re-search-forward
+ (concat "[\r\n]\\(" outline-regexp "\\)") nil 'move)
+ (or (match-beginning 1) (point-max)))
+ nil))
+ (error nil))))
(defun org-make-options-regexp (kwds)
"Make a regular expression for keyword lines."
(remove-hook 'post-command-hook 'org-isearch-post-command 'local)
(org-show-context 'isearch))
-;;;; Repair problems with some other packages
+
+;;;; Integration with and fixes for other packages
+
+;;; Imenu support
+
+(defvar org-imenu-markers nil
+ "All markers currently used by Imenu.")
+(make-variable-buffer-local 'org-imenu-markers)
+
+(defun org-imenu-new-marker (&optional pos)
+ "Return a new marker for use by Imenu, and remember the marker."
+ (let ((m (make-marker)))
+ (move-marker m (or pos (point)))
+ (push m org-imenu-markers)
+ m))
+
+(defun org-imenu-get-tree ()
+ "Produce the index for Imenu."
+ (mapc (lambda (x) (move-marker x nil)) org-imenu-markers)
+ (setq org-imenu-markers nil)
+ (let* ((n org-imenu-depth)
+ (re (concat "^" outline-regexp))
+ (subs (make-vector (1+ n) nil))
+ (last-level 0)
+ m tree level head)
+ (save-excursion
+ (save-restriction
+ (widen)
+ (goto-char (point-max))
+ (while (re-search-backward re nil t)
+ (setq level (org-reduced-level (funcall outline-level)))
+ (when (<= level n)
+ (looking-at org-complex-heading-regexp)
+ (setq head (org-match-string-no-properties 4)
+ m (org-imenu-new-marker))
+ (org-add-props head nil 'org-imenu-marker m 'org-imenu t)
+ (if (>= level last-level)
+ (push (cons head m) (aref subs level))
+ (push (cons head (aref subs (1+ level))) (aref subs level))
+ (loop for i from (1+ level) to n do (aset subs i nil)))
+ (setq last-level level)))))
+ (aref subs 1)))
+
+(eval-after-load "imenu"
+ '(progn
+ (add-hook 'imenu-after-jump-hook
+ (lambda () (org-show-context 'org-goto)))))
+
+;; Speedbar support
+
+(defun org-speedbar-set-agenda-restriction ()
+ "Restrict future agenda commands to the location at point in speedbar.
+To get rid of the restriction, use \\[org-agenda-remove-restriction-lock]."
+ (interactive)
+ (let (p m tp np dir txt w)
+ (cond
+ ((setq p (text-property-any (point-at-bol) (point-at-eol)
+ 'org-imenu t))
+ (setq m (get-text-property p 'org-imenu-marker))
+ (save-excursion
+ (save-restriction
+ (set-buffer (marker-buffer m))
+ (goto-char m)
+ (org-agenda-set-restriction-lock 'subtree))))
+ ((setq p (text-property-any (point-at-bol) (point-at-eol)
+ 'speedbar-function 'speedbar-find-file))
+ (setq tp (previous-single-property-change
+ (1+ p) 'speedbar-function)
+ np (next-single-property-change
+ tp 'speedbar-function)
+ dir (speedbar-line-directory)
+ txt (buffer-substring-no-properties (or tp (point-min))
+ (or np (point-max))))
+ (save-excursion
+ (save-restriction
+ (set-buffer (find-file-noselect
+ (let ((default-directory dir))
+ (expand-file-name txt))))
+ (unless (org-mode-p)
+ (error "Cannot restrict to non-Org-mode file"))
+ (org-agenda-set-restriction-lock 'file))))
+ (t (error "Don't know how to restrict Org-mode's agenda")))
+ (org-move-overlay org-speedbar-restriction-lock-overlay
+ (point-at-bol) (point-at-eol))
+ (setq current-prefix-arg nil)
+ (org-agenda-maybe-redo)))
+
+(eval-after-load "speedbar"
+ '(progn
+ (speedbar-add-supported-extension ".org")
+ (define-key speedbar-file-key-map "<" 'org-speedbar-set-agenda-restriction)
+ (define-key speedbar-file-key-map "\C-c\C-x<" 'org-speedbar-set-agenda-restriction)
+ (define-key speedbar-file-key-map ">" 'org-agenda-remove-restriction-lock)
+ (define-key speedbar-file-key-map "\C-c\C-x>" 'org-agenda-remove-restriction-lock)
+ (add-hook 'speedbar-visiting-tag-hook
+ (lambda () (org-show-context 'org-goto)))))
+
+
+;;; Fixes and Hacks
+
+;; Make flyspell not check words in links, to not mess up our keymap
+(defun org-mode-flyspell-verify ()
+ "Don't let flyspell put overlays at active buttons."
+ (not (get-text-property (point) 'keymap)))
;; Make `bookmark-jump' show the jump location if it was hidden.
(eval-after-load "bookmark"
;;;; Experimental code
+(defun org-closed-in-range ()
+ "Sparse tree of items closed in a certain time range.
+Still experimental, may disappear in the future."
+ (interactive)
+ ;; Get the time interval from the user.
+ (let* ((time1 (time-to-seconds
+ (org-read-date nil 'to-time nil "Starting date: ")))
+ (time2 (time-to-seconds
+ (org-read-date nil 'to-time nil "End date:")))
+ ;; callback function
+ (callback (lambda ()
+ (let ((time
+ (time-to-seconds
+ (apply 'encode-time
+ (org-parse-time-string
+ (match-string 1))))))
+ ;; check if time in interval
+ (and (>= time time1) (<= time time2))))))
+ ;; make tree, check each match with the callback
+ (org-occur "CLOSED: +\\[\\(.*?\\)\\]" nil callback)))
+
;;;; Finish up
projects / emacs.git / commitdiff