From 24501f035e7dfac34faae4cd1e43f5a026f6cc9b Mon Sep 17 00:00:00 2001 From: Juanma Barranquero Date: Tue, 13 Feb 2007 12:47:00 +0000 Subject: (with-electric-help, electric-help-exit, electric-help-retain): Doc fixes. --- lisp/ehelp.el | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) (limited to 'lisp') diff --git a/lisp/ehelp.el b/lisp/ehelp.el index 9b35298c296..80242ff2b03 100644 --- a/lisp/ehelp.el +++ b/lisp/ehelp.el @@ -113,7 +113,6 @@ ;;;###autoload (defun with-electric-help (thunk &optional buffer noerase minheight) "Pop up an \"electric\" help buffer. -The arguments are THUNK &optional BUFFER NOERASE MINHEIGHT. THUNK is a function of no arguments which is called to initialize the contents of BUFFER. BUFFER defaults to `*Help*'. BUFFER will be erased before THUNK is called unless NOERASE is non-nil. THUNK will @@ -125,7 +124,7 @@ shrink the window to fit. If THUNK returns non-nil, we don't do those things. After THUNK has been called, this function \"electrically\" pops up a window in which BUFFER is displayed and allows the user to scroll through that buffer -in electric-help-mode. The window's height will be at least MINHEIGHT if +in `electric-help-mode'. The window's height will be at least MINHEIGHT if this value is non-nil. If THUNK returns nil, we display BUFFER starting at the top, and @@ -134,7 +133,7 @@ If THUNK returns non-nil, we don't do those things. When the user exits (with `electric-help-exit', or otherwise), the help buffer's window disappears (i.e., we use `save-window-excursion'), and -BUFFER is put into `default-major-mode' (or `fundamental-mode') when we exit." +BUFFER is put into `default-major-mode' (or `fundamental-mode')." (setq buffer (get-buffer-create (or buffer "*Help*"))) (let ((one (one-window-p t)) (config (current-window-configuration)) @@ -246,7 +245,7 @@ BUFFER is put into `default-major-mode' (or `fundamental-mode') when we exit." ; (scroll-up arg))) (defun electric-help-exit () - "Exit `electric-help', restoring the previous window/buffer configuration. + "Exit `with-electric-help', restoring the previous window/buffer configuration. \(The *Help* buffer will be buried.)" (interactive) ;; Make sure that we don't throw twice, even if two events cause @@ -257,7 +256,7 @@ BUFFER is put into `default-major-mode' (or `fundamental-mode') when we exit." (throw 'exit t)))) (defun electric-help-retain () - "Exit `electric-help', retaining the current window/buffer configuration. + "Exit `with-electric-help', retaining the current window/buffer configuration. \(The *Help* buffer will not be selected, but \\[switch-to-buffer-other-window] RET will select it.)" (interactive) -- cgit v1.2.1 From df8397f30ad37a6166fbf8e0beba5215970844c7 Mon Sep 17 00:00:00 2001 From: Juanma Barranquero Date: Tue, 13 Feb 2007 12:52:13 +0000 Subject: *** empty log message *** --- lisp/ChangeLog | 3 +++ 1 file changed, 3 insertions(+) (limited to 'lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 028ca7364a9..97f3c1f5573 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,5 +1,8 @@ 2007-02-13 Juanma Barranquero + * ehelp.el (with-electric-help, electric-help-exit) + (electric-help-retain): Doc fixes. + * emacs-lisp/bytecomp.el (byte-compile-dest-file) (byte-compile-file): Doc fixes. -- cgit v1.2.1 From 3ae2a0d6ee5c2fa7e025b41b7c2f2fc20f643644 Mon Sep 17 00:00:00 2001 From: "Kim F. Storm" Date: Wed, 14 Feb 2007 11:28:19 +0000 Subject: *** empty log message *** --- lisp/ChangeLog | 10 ++++++++++ 1 file changed, 10 insertions(+) (limited to 'lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 97f3c1f5573..21af8dd7ae8 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,13 @@ +2007-02-14 Kim F. Storm + + * disp-table.el (make-glyph-code, glyph-char, glyph-face): New defuns. + (standard-display-underline): Use make-glyph-code. + + * descr-text.el (describe-char): Use glyph-char and glyph-face. + + * international/latin1-disp.el (latin1-display-char): + Use make-glyph-code. + 2007-02-13 Juanma Barranquero * ehelp.el (with-electric-help, electric-help-exit) -- cgit v1.2.1 From da55bb9600b988d1ccba72c6272b8df64e218bf2 Mon Sep 17 00:00:00 2001 From: "Kim F. Storm" Date: Wed, 14 Feb 2007 11:28:31 +0000 Subject: (describe-char): Use glyph-char and glyph-face. --- lisp/descr-text.el | 24 +++++++++--------------- 1 file changed, 9 insertions(+), 15 deletions(-) (limited to 'lisp') diff --git a/lisp/descr-text.el b/lisp/descr-text.el index 64920336db9..8b36270f46c 100644 --- a/lisp/descr-text.el +++ b/lisp/descr-text.el @@ -528,11 +528,11 @@ as well as widgets, buttons, overlays, and text properties." (setq char (aref disp-vector i)) (aset disp-vector i (cons char (describe-char-display - pos (logand char #x7ffff))))) + pos (glyph-char char))))) (format "by display table entry [%s] (see below)" (mapconcat #'(lambda (x) - (format "?%c" (logand (car x) #x7ffff))) + (format "?%c" (glyph-char (car x)))) disp-vector " "))) (composition (let ((from (car composition)) @@ -627,25 +627,19 @@ as well as widgets, buttons, overlays, and text properties." (progn (insert "these fonts (glyph codes):\n") (dotimes (i (length disp-vector)) - (insert (logand (car (aref disp-vector i)) #x7ffff) ?: + (insert (glyph-char (car (aref disp-vector i))) ?: (propertize " " 'display '(space :align-to 5)) (if (cdr (aref disp-vector i)) (format "%s (#x%02X)" (cadr (aref disp-vector i)) (cddr (aref disp-vector i))) "-- no font --") "\n") - (when (> (car (aref disp-vector i)) #x7ffff) - (let* ((face-id (lsh (car (aref disp-vector i)) -19)) - (face (car (delq nil (mapcar - (lambda (face) - (and (eq (face-id face) - face-id) face)) - (face-list)))))) - (when face - (insert (propertize " " 'display '(space :align-to 5)) - "face: ") - (insert (concat "`" (symbol-name face) "'")) - (insert "\n")))))) + (let ((face (glyph-face (car (aref disp-vector i))))) + (when face + (insert (propertize " " 'display '(space :align-to 5)) + "face: ") + (insert (concat "`" (symbol-name face) "'")) + (insert "\n"))))) (insert "these terminal codes:\n") (dotimes (i (length disp-vector)) (insert (car (aref disp-vector i)) -- cgit v1.2.1 From 7dbfbd9191092032c2878b6d0eac28773e2982e5 Mon Sep 17 00:00:00 2001 From: "Kim F. Storm" Date: Wed, 14 Feb 2007 11:28:40 +0000 Subject: (make-glyph-code, glyph-char, glyph-face): New defuns. (standard-display-underline): Use make-glyph-code. --- lisp/disp-table.el | 26 +++++++++++++++++++++++++- 1 file changed, 25 insertions(+), 1 deletion(-) (limited to 'lisp') diff --git a/lisp/disp-table.el b/lisp/disp-table.el index fa98086b0bc..2a4dd01897d 100644 --- a/lisp/disp-table.el +++ b/lisp/disp-table.el @@ -172,7 +172,7 @@ X frame." (aset standard-display-table c (vector (if window-system - (logior uc (lsh (face-id 'underline) 19)) + (make-glyph-code uc 'underline) (create-glyph (concat "\e[4m" (char-to-string uc) "\e[m")))))) ;;;###autoload @@ -186,6 +186,30 @@ X frame." (setq glyph-table (vconcat glyph-table (list string))) (1- (length glyph-table))) +;;;###autoload +(defun make-glyph-code (char &optional face) + "Return a glyph code representing char CHAR with face FACE." + ;; Due to limitations on Emacs integer values, faces with + ;; face id greater that 4091 are silently ignored. + (if (and face (<= (face-id face) #xfff)) + (logior char (lsh (face-id face) 19)) + char)) + +;;;###autoload +(defun glyph-char (glyph) + "Return the character of glyph code GLYPH." + (logand glyph #x7ffff)) + +;;;###autoload +(defun glyph-face (glyph) + "Return the face of glyph code GLYPH, or nil if glyph has default face." + (let ((face-id (lsh glyph -19))) + (and (> face-id 0) + (car (delq nil (mapcar (lambda (face) + (and (eq (get face 'face) face-id) + face)) + (face-list))))))) + ;;;###autoload (defun standard-display-european (arg) "Semi-obsolete way to toggle display of ISO 8859 European characters. -- cgit v1.2.1 From 9a184b00295e9960b7949712347c349df6fddf5c Mon Sep 17 00:00:00 2001 From: "Kim F. Storm" Date: Wed, 14 Feb 2007 11:29:05 +0000 Subject: (latin1-display-char): Use make-glyph-code. --- lisp/international/latin1-disp.el | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) (limited to 'lisp') diff --git a/lisp/international/latin1-disp.el b/lisp/international/latin1-disp.el index 6b2b6c50760..7a78e6628b9 100644 --- a/lisp/international/latin1-disp.el +++ b/lisp/international/latin1-disp.el @@ -177,14 +177,10 @@ asis." (if (eq 'default latin1-display-face) (standard-display-ascii char (format latin1-display-format display)) (aset standard-display-table char - (vconcat (mapcar (lambda (c) - (logior c (lsh (face-id latin1-display-face) - 19))) + (vconcat (mapcar (lambda (c) (make-glyph-code c latin1-display-face)) display)))) (aset standard-display-table char - (if (eq 'default latin1-display-face) - display - (logior display (lsh (face-id latin1-display-face) 19)))))) + (make-glyph-code display latin1-display-face)))) (defun latin1-display-identities (charset) "Display each character in CHARSET as the corresponding Latin-1 character. -- cgit v1.2.1 From 9d4a3d39094c2f86749f6f6c9b7c372ce3e92e08 Mon Sep 17 00:00:00 2001 From: "Kim F. Storm" Date: Wed, 14 Feb 2007 11:54:12 +0000 Subject: (grep-files-aliases): Add tex and texi aliases. (lgrep): Add DIR arg to start grep in specific directory, like rgrep. (grep): Fix lgrep reference. --- lisp/progmodes/grep.el | 29 +++++++++++++++++++---------- 1 file changed, 19 insertions(+), 10 deletions(-) (limited to 'lisp') diff --git a/lisp/progmodes/grep.el b/lisp/progmodes/grep.el index 317effca731..a0dd83fb974 100644 --- a/lisp/progmodes/grep.el +++ b/lisp/progmodes/grep.el @@ -150,6 +150,8 @@ The following place holders should be present in the string: ("asm" . "*.[sS]") ("m" . "[Mm]akefile*") ("l" . "[Cc]hange[Ll]og*") + ("tex" . "*.tex") + ("texi" . "*.texi") ) "*Alist of aliases for the FILES argument to `lgrep' and `rgrep'." :type 'alist @@ -532,7 +534,7 @@ output buffer, to go to the lines where grep found matches. For doing a recursive `grep', see the `rgrep' command. For running -`grep' in the current directory see `lgrep'. +`grep' in a specific directory, see `lgrep'. This command uses a special history list for its COMMAND-ARGS, so you can easily repeat a grep command. @@ -657,8 +659,8 @@ substitution string. Note dynamic scoping of variables.") files)))) ;;;###autoload -(defun lgrep (regexp &optional files) - "Run grep, searching for REGEXP in FILES in current directory. +(defun lgrep (regexp &optional files dir) + "Run grep, searching for REGEXP in FILES in directory DIR. The search is limited to file names matching shell pattern FILES. FILES may use abbreviations defined in `grep-files-aliases', e.g. entering `ch' is equivalent to `*.[ch]'. @@ -684,13 +686,16 @@ This command shares argument histories with \\[rgrep] and \\[grep]." (list nil (read-string "grep.el: No `grep-template' available. Press RET."))) (t (let* ((regexp (grep-read-regexp)) - (files (grep-read-files regexp))) - (list regexp files)))))) + (files (grep-read-files regexp)) + (dir (read-directory-name "In directory: " + nil default-directory t))) + (list regexp files dir)))))) (when (and (stringp regexp) (> (length regexp) 0)) (let ((command regexp)) (if (null files) (if (string= command grep-command) (setq command nil)) + (setq dir (file-name-as-directory (expand-file-name dir))) (setq command (grep-expand-template grep-template regexp @@ -702,11 +707,15 @@ This command shares argument histories with \\[rgrep] and \\[grep]." command nil nil 'grep-history)) (add-to-history 'grep-history command)))) (when command - ;; Setting process-setup-function makes exit-message-function work - ;; even when async processes aren't supported. - (compilation-start (if (and grep-use-null-device null-device) - (concat command " " null-device) - command) 'grep-mode))))) + (let ((default-directory dir)) + ;; Setting process-setup-function makes exit-message-function work + ;; even when async processes aren't supported. + (compilation-start (if (and grep-use-null-device null-device) + (concat command " " null-device) + command) 'grep-mode)) + (if (eq next-error-last-buffer (current-buffer)) + (setq default-directory dir)))))) + ;;;###autoload -- cgit v1.2.1 From 428807eae4589172780d48d88a8b41a234db1311 Mon Sep 17 00:00:00 2001 From: "Kim F. Storm" Date: Wed, 14 Feb 2007 11:59:36 +0000 Subject: *** empty log message *** --- lisp/ChangeLog | 4 ++++ 1 file changed, 4 insertions(+) (limited to 'lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 21af8dd7ae8..630f8512ef4 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,5 +1,9 @@ 2007-02-14 Kim F. Storm + * progmodes/grep.el (grep-files-aliases): Add tex and texi aliases. + (lgrep): Add DIR arg to start grep in specific directory, like rgrep. + (grep): Fix lgrep reference. + * disp-table.el (make-glyph-code, glyph-char, glyph-face): New defuns. (standard-display-underline): Use make-glyph-code. -- cgit v1.2.1 From b11a1b2e3b56fc25bbce063e00fa7b9d7f709392 Mon Sep 17 00:00:00 2001 From: Juanma Barranquero Date: Wed, 14 Feb 2007 12:42:01 +0000 Subject: (ispell-keep-choices-win, ispell-dictionary-alist, ispell-word, ispell-begin-skip-region-regexp): Fix typos in docstrings. (ispell-process-line): Doc fixes. (ispell-help): Fix typos in docstring and output message. --- lisp/ChangeLog | 8 ++++++++ lisp/textmodes/ispell.el | 30 ++++++++++++++---------------- 2 files changed, 22 insertions(+), 16 deletions(-) (limited to 'lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 630f8512ef4..a2ef2121f28 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,11 @@ +2007-02-14 Juanma Barranquero + + * textmodes/ispell.el (ispell-keep-choices-win) + (ispell-dictionary-alist, ispell-word) + (ispell-begin-skip-region-regexp): Fix typos in docstrings. + (ispell-process-line): Doc fixes. + (ispell-help): Fix typos in docstring and output message. + 2007-02-14 Kim F. Storm * progmodes/grep.el (grep-files-aliases): Add tex and texi aliases. diff --git a/lisp/textmodes/ispell.el b/lisp/textmodes/ispell.el index fe74bf8f321..f090739fd97 100644 --- a/lisp/textmodes/ispell.el +++ b/lisp/textmodes/ispell.el @@ -293,7 +293,7 @@ a [.5mm] type of number...." "Regexp matching the end of a Tib reference.") (defcustom ispell-keep-choices-win t - "*When not nil, the `*Choices*' window remains for spelling session. + "*When non-nil, the `*Choices*' window remains for spelling session. This minimizes redisplay thrashing." :type 'boolean :group 'ispell) @@ -673,8 +673,7 @@ Each element of this list is also a list: DICTIONARY-NAME is a possible string value of variable `ispell-dictionary', nil means the default dictionary. -CASECHARS is a regular expression of valid characters that comprise a -word. +CASECHARS is a regular expression of valid characters that comprise a word. NOT-CASECHARS is the opposite regexp of CASECHARS. @@ -688,7 +687,7 @@ regular expression \"[']\" for OTHERCHARS. Then \"they're\" and If you want OTHERCHARS to be empty, use the empty string. Hint: regexp syntax requires the hyphen to be declared first here. -CASECHAS, NOT-CASECHARS, and OTHERCHARS must be a unibyte string +CASECHARS, NOT-CASECHARS, and OTHERCHARS must be a unibyte string containing bytes of CHARACTER-SET. In addition, if they contain a non-ASCII byte, the regular expression must be a single `character set' construct that doesn't specify a character range @@ -1572,7 +1571,7 @@ which is in `ispell-local-dictionary-alist' or `ispell-dictionary-alist'. This will check or reload the dictionary. Use \\[ispell-change-dictionary] or \\[ispell-region] to update the Ispell process. -return values: +Return values: nil word is correct or spelling is accepted. 0 word is inserted into buffer-local definitions. \"word\" word corrected from word list. @@ -2102,9 +2101,9 @@ SPC: Accept word this time. `l': Look up typed-in replacement in alternate dictionary. Wildcards okay. `u': Like `i', but the word is lower-cased first. `m': Place typed-in value in personal dictionary, then recheck current word. -`C-l': redraws screen -`C-r': recursive edit -`C-z': suspend Emacs or iconify frame" +`C-l': Redraw screen. +`C-r': Recursive edit. +`C-z': Suspend Emacs or iconify frame." (if (equal ispell-help-in-bufferp 'electric) (progn @@ -2134,11 +2133,10 @@ SPC: Accept word this time. `l': Look up typed-in replacement in alternate dictionary. Wildcards okay. `u': Like `i', but the word is lower-cased first. `m': Place typed-in value in personal dictionary, then recheck current word. -`C-l': redraws screen -`C-r': recursive edit -`C-z': suspend Emacs or iconify frame") - nil ;undocumented requirement of with-electric-help - )))) +`C-l': Redraw screen. +`C-r': Recursive edit. +`C-z': Suspend Emacs or iconify frame.") + nil)))) (let ((help-1 (concat "[r/R]eplace word; [a/A]ccept for this session; " @@ -2772,7 +2770,7 @@ Return nil if spell session is quit, (defun ispell-begin-skip-region-regexp () "Returns a regexp of the search keys for region skipping. Includes `ispell-skip-region-alist' plus tex, tib, html, and comment keys. -Must call after ispell-buffer-local-parsing due to dependence on mode." +Must call after `ispell-buffer-local-parsing' due to dependence on mode." ;; start with regions generic to all buffers (let ((skip-regexp (ispell-begin-skip-region ispell-skip-region-alist))) ;; Comments @@ -2985,10 +2983,10 @@ Point is placed at end of skipped region." (defvar end) (defun ispell-process-line (string shift) - "Sends a LINE of text to ispell and processes the result. + "Sends STRING, a line of text, to ispell and processes the result. This will modify the buffer for spelling errors. Requires variables START and END to be defined in its lexical scope. -Returns the sum shift due to changes in word replacements." +Returns the sum SHIFT due to changes in word replacements." ;;(declare special start end) (let (poss accept-list) (if (not (numberp shift)) -- cgit v1.2.1 From ce6fb7e6233a80829b7866e0130ac06e6cfe1912 Mon Sep 17 00:00:00 2001 From: Juanma Barranquero Date: Wed, 14 Feb 2007 12:46:43 +0000 Subject: (ispell-dictionary-alist): Doc fix. --- lisp/ChangeLog | 5 ++--- lisp/textmodes/ispell.el | 2 +- 2 files changed, 3 insertions(+), 4 deletions(-) (limited to 'lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index a2ef2121f28..a565549a221 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,9 +1,8 @@ 2007-02-14 Juanma Barranquero - * textmodes/ispell.el (ispell-keep-choices-win) - (ispell-dictionary-alist, ispell-word) + * textmodes/ispell.el (ispell-keep-choices-win, ispell-word) (ispell-begin-skip-region-regexp): Fix typos in docstrings. - (ispell-process-line): Doc fixes. + (ispell-dictionary-alist, ispell-process-line): Doc fixes. (ispell-help): Fix typos in docstring and output message. 2007-02-14 Kim F. Storm diff --git a/lisp/textmodes/ispell.el b/lisp/textmodes/ispell.el index f090739fd97..73faea4e9c2 100644 --- a/lisp/textmodes/ispell.el +++ b/lisp/textmodes/ispell.el @@ -687,7 +687,7 @@ regular expression \"[']\" for OTHERCHARS. Then \"they're\" and If you want OTHERCHARS to be empty, use the empty string. Hint: regexp syntax requires the hyphen to be declared first here. -CASECHARS, NOT-CASECHARS, and OTHERCHARS must be a unibyte string +CASECHARS, NOT-CASECHARS, and OTHERCHARS must be unibyte strings containing bytes of CHARACTER-SET. In addition, if they contain a non-ASCII byte, the regular expression must be a single `character set' construct that doesn't specify a character range -- cgit v1.2.1 From 22bbca614f492025bb9c57ec7250447bc69c33c2 Mon Sep 17 00:00:00 2001 From: Juanma Barranquero Date: Wed, 14 Feb 2007 15:31:09 +0000 Subject: (color-values): Revert changes to docstring from 2007-01-31 and 2000-09-07. --- lisp/faces.el | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) (limited to 'lisp') diff --git a/lisp/faces.el b/lisp/faces.el index 749754ffb08..54388fd54ca 100644 --- a/lisp/faces.el +++ b/lisp/faces.el @@ -1536,8 +1536,9 @@ If COLOR is the symbol `unspecified' or one of the strings (defun color-values (color &optional frame) "Return a description of the color named COLOR on frame FRAME. -The value is a list of integer RGB values--\(RED GREEN BLUE\). -These values range from 0 to 65535; white is \(65535 65535 65535\). +The value is a list of integer RGB values--(RED GREEN BLUE). +These values appear to range from 0 to 65280 or 65535, depending +on the system; white is \(65280 65280 65280\) or \(65535 65535 65535\). If FRAME is omitted or nil, use the selected frame. If FRAME cannot display COLOR, the value is nil. If COLOR is the symbol `unspecified' or one of the strings -- cgit v1.2.1 From 424f6998844f72783aa38578b3f4e31b1bd4f43c Mon Sep 17 00:00:00 2001 From: Juanma Barranquero Date: Wed, 14 Feb 2007 15:49:29 +0000 Subject: *** empty log message *** --- lisp/ChangeLog | 3 +++ 1 file changed, 3 insertions(+) (limited to 'lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index a565549a221..aad7c78b4e8 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,5 +1,8 @@ 2007-02-14 Juanma Barranquero + * faces.el (color-values): Revert changes to docstring from + 2007-01-31 and 2000-09-07. + * textmodes/ispell.el (ispell-keep-choices-win, ispell-word) (ispell-begin-skip-region-regexp): Fix typos in docstrings. (ispell-dictionary-alist, ispell-process-line): Doc fixes. -- cgit v1.2.1 From c371062c1b95c89ab9aec3f57525af81ac2f9962 Mon Sep 17 00:00:00 2001 From: Chong Yidong Date: Wed, 14 Feb 2007 17:32:41 +0000 Subject: * smiley.el (smiley-regexp-alist): Add "dead" smiley. --- lisp/gnus/ChangeLog | 4 ++++ 1 file changed, 4 insertions(+) (limited to 'lisp') diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog index 15b1ae86127..8da59d47965 100644 --- a/lisp/gnus/ChangeLog +++ b/lisp/gnus/ChangeLog @@ -1,3 +1,7 @@ +2007-02-14 Chong Yidong + + * smiley.el (smiley-regexp-alist): Add "dead" smiley. + 2007-02-01 Andreas Seltenreich * nnweb.el (nnweb-google-parse-1): Update parser. -- cgit v1.2.1 From ecc7b2badedb6256f5fab464d526d8168453989f Mon Sep 17 00:00:00 2001 From: Chong Yidong Date: Wed, 14 Feb 2007 17:32:50 +0000 Subject: (smiley-regexp-alist): Add "dead" smiley. --- lisp/gnus/smiley.el | 1 + 1 file changed, 1 insertion(+) (limited to 'lisp') diff --git a/lisp/gnus/smiley.el b/lisp/gnus/smiley.el index e74d6ddee6f..82813aa9aa2 100644 --- a/lisp/gnus/smiley.el +++ b/lisp/gnus/smiley.el @@ -74,6 +74,7 @@ ("\\(:-|\\)\\W" 1 "indifferent") ("\\(:-[/\\]\\)\\W" 1 "wry") ("\\(:-(\\)\\W" 1 "sad") + ("\\(X-)\\)\\W" 1 "dead") ("\\(:-{\\)\\W" 1 "frown")) "*A list of regexps to map smilies to images. The elements are (REGEXP MATCH IMAGE), where MATCH is the submatch in -- cgit v1.2.1 From 849aa553875fab0657459a07a477379882b81b7f Mon Sep 17 00:00:00 2001 From: Juanma Barranquero Date: Thu, 15 Feb 2007 10:58:11 +0000 Subject: (5x5-crack-xor-mutate): Doc fix. (5x5-draw-grid-end, 5x5-make-xor-with-mutation, 5x5-mode, 5x5-crack, 5x5-play-solution, 5x5-y-or-n-p): Fix typos in docstrings. --- lisp/play/5x5.el | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) (limited to 'lisp') diff --git a/lisp/play/5x5.el b/lisp/play/5x5.el index e3118042220..5dad84fadc5 100644 --- a/lisp/play/5x5.el +++ b/lisp/play/5x5.el @@ -170,7 +170,7 @@ (put '5x5-mode 'mode-class 'special) (defun 5x5-mode () - "A mode for playing `5x5' + "A mode for playing `5x5'. The key bindings for 5x5-mode are: @@ -282,7 +282,7 @@ Quit current game \\[5x5-quit-game]" (loop for y from 0 to (1- 5x5-grid-size) sum (5x5-row-value (aref grid y)))) (defun 5x5-draw-grid-end () - "Draw the top/bottom of the grid" + "Draw the top/bottom of the grid." (insert "+") (loop for x from 0 to (1- 5x5-grid-size) do (insert "-" (make-string 5x5-x-scale ?-))) @@ -347,7 +347,7 @@ Quit current game \\[5x5-quit-game]" ;;;###autoload (defun 5x5-crack-xor-mutate () - "Attempt to crack 5x5 by xor the current and best solution. + "Attempt to crack 5x5 by xoring the current and best solution. Mutate the result." (interactive) (5x5-crack #'5x5-make-xor-with-mutation)) @@ -358,7 +358,7 @@ Mutate the result." 5x5-crack takes the argument BREEDER which should be a function that takes two parameters, the first will be a grid vector array that is the current -solution and the second will be the best solution so far. The function +solution and the second will be the best solution so far. The function should return a grid vector array that is the new solution." (interactive "aBreeder function: ") @@ -393,7 +393,7 @@ should return a grid vector array that is the new solution." (5x5-mutate-solution best)) (defun 5x5-make-xor-with-mutation (current best) - "xor current and best solution then mutate the result." + "Xor current and best solution then mutate the result." (let ((xored (5x5-make-new-grid))) (loop for y from 0 to (1- 5x5-grid-size) do (loop for x from 0 to (1- 5x5-grid-size) do @@ -412,8 +412,8 @@ should return a grid vector array that is the new solution." solution) (defun 5x5-play-solution (solution best) - "Play a solution on an empty grid. This destroys the current game in -progress because it is an animated attempt." + "Play a solution on an empty grid. This destroys the current game +in progress because it is an animated attempt." (5x5-new-game) (let ((inhibit-quit t)) (loop for y from 0 to (1- 5x5-grid-size) do @@ -514,7 +514,7 @@ progress because it is an animated attempt." (and (or x y) (not (and x y)))) (defun 5x5-y-or-n-p (prompt) - "5x5 wrapper for y-or-n-p which respects the 5x5-hassle-me setting." + "5x5 wrapper for `y-or-n-p' which respects the `5x5-hassle-me' setting." (if 5x5-hassle-me (y-or-n-p prompt) t)) -- cgit v1.2.1 From 8bec6ac5dfc8224801c71fcf1122bc25e08ed7ea Mon Sep 17 00:00:00 2001 From: Juanma Barranquero Date: Thu, 15 Feb 2007 11:01:16 +0000 Subject: *** empty log message *** --- lisp/ChangeLog | 6 ++++++ 1 file changed, 6 insertions(+) (limited to 'lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index aad7c78b4e8..84f07b52b83 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,9 @@ +2007-02-15 Juanma Barranquero + + * play/5x5.el (5x5-crack-xor-mutate): Doc fix. + (5x5-draw-grid-end, 5x5-make-xor-with-mutation, 5x5-mode, 5x5-crack) + (5x5-play-solution, 5x5-y-or-n-p): Fix typos in docstrings. + 2007-02-14 Juanma Barranquero * faces.el (color-values): Revert changes to docstring from -- cgit v1.2.1 From a3609743156ca71f1e33aeafb1c803ec7a5176c0 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Thu, 15 Feb 2007 16:36:58 +0000 Subject: (font-lock-extend-region-wholelines): Only return non-nil if the region has really been changed. Reported by David Hansen --- lisp/ChangeLog | 14 ++++++++++---- lisp/font-lock.el | 5 ++++- 2 files changed, 14 insertions(+), 5 deletions(-) (limited to 'lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 84f07b52b83..9ffb729822d 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,9 @@ +2007-02-15 Stefan Monnier + + * font-lock.el (font-lock-extend-region-wholelines): + Only return non-nil if the region has really been changed. + Reported by David Hansen + 2007-02-15 Juanma Barranquero * play/5x5.el (5x5-crack-xor-mutate): Doc fix. @@ -56,8 +62,8 @@ 2007-02-12 Michael Albinus * net/tramp.el (tramp-get-ls-command, tramp-get-file-exists-command) - (tramp-get-remote-ln): Handle error case. Reported by Chris Moore - . + (tramp-get-remote-ln): Handle error case. + Reported by Chris Moore . 2007-02-11 Kim F. Storm @@ -101,8 +107,8 @@ 2007-02-10 Eli Zaretskii - * info-look.el (info-lookup-make-completions): Bind - Info-fontify-maximum-menu-size to nil to speed up lookup of + * info-look.el (info-lookup-make-completions): + Bind Info-fontify-maximum-menu-size to nil to speed up lookup of index nodes. * info.el (Info-fontify-maximum-menu-size): Document the effect diff --git a/lisp/font-lock.el b/lisp/font-lock.el index 69ba694340b..62008ac295b 100644 --- a/lisp/font-lock.el +++ b/lisp/font-lock.el @@ -1090,7 +1090,10 @@ Put first the functions more likely to cause a change and cheaper to compute.") (goto-char font-lock-beg) (unless (bolp) (setq changed t font-lock-beg (line-beginning-position))) (goto-char font-lock-end) - (unless (bolp) (setq changed t font-lock-end (line-beginning-position 2))) + (unless (bolp) + (unless (eq font-lock-end + (setq font-lock-end (line-beginning-position 2))) + (setq changed t))) changed)) (defun font-lock-default-fontify-region (beg end loudly) -- cgit v1.2.1 From 51eeb2ff1b3cf4b752137c1b9249f6104b70c038 Mon Sep 17 00:00:00 2001 From: Chong Yidong Date: Thu, 15 Feb 2007 16:53:53 +0000 Subject: * isearch.el (isearch-lazy-highlight-space-regexp): New variable. (isearch-lazy-highlight-new-loop): Bind it. (isearch-lazy-highlight-search): Use it. * replace.el (replace-highlight): Bind search-whitespace-regexp to nil. --- lisp/ChangeLog | 9 +++++++++ 1 file changed, 9 insertions(+) (limited to 'lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 9ffb729822d..b10e6060668 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,12 @@ +2007-02-15 Chris Moore + + * isearch.el (isearch-lazy-highlight-space-regexp): New variable. + (isearch-lazy-highlight-new-loop): Bind it. + (isearch-lazy-highlight-search): Use it. + + * replace.el (replace-highlight): Bind search-whitespace-regexp to + nil. + 2007-02-15 Stefan Monnier * font-lock.el (font-lock-extend-region-wholelines): -- cgit v1.2.1 From 9a19394446e3b591673a2b4b66c2fd652090d47e Mon Sep 17 00:00:00 2001 From: Chong Yidong Date: Thu, 15 Feb 2007 16:54:09 +0000 Subject: (isearch-lazy-highlight-space-regexp): New variable. (isearch-lazy-highlight-new-loop): Bind it. (isearch-lazy-highlight-search): Use it. --- lisp/isearch.el | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) (limited to 'lisp') diff --git a/lisp/isearch.el b/lisp/isearch.el index 28d309f88c4..2f17af43c14 100644 --- a/lisp/isearch.el +++ b/lisp/isearch.el @@ -2321,6 +2321,7 @@ since they have special meaning in a regexp." (defvar isearch-lazy-highlight-window-end nil) (defvar isearch-lazy-highlight-case-fold-search nil) (defvar isearch-lazy-highlight-regexp nil) +(defvar isearch-lazy-highlight-space-regexp nil) (defun lazy-highlight-cleanup (&optional force) "Stop lazy highlighting and remove extra highlighting from current buffer. @@ -2374,7 +2375,8 @@ by other Emacs features." isearch-lazy-highlight-last-string isearch-string isearch-lazy-highlight-case-fold-search isearch-case-fold-search isearch-lazy-highlight-regexp isearch-regexp - isearch-lazy-highlight-wrapped nil) + isearch-lazy-highlight-wrapped nil + isearch-lazy-highlight-space-regexp search-whitespace-regexp) (unless (equal isearch-string "") (setq isearch-lazy-highlight-timer (run-with-idle-timer lazy-highlight-initial-delay nil @@ -2385,7 +2387,7 @@ by other Emacs features." Attempt to do the search exactly the way the pending isearch would." (let ((case-fold-search isearch-lazy-highlight-case-fold-search) (isearch-regexp isearch-lazy-highlight-regexp) - (search-spaces-regexp search-whitespace-regexp)) + (search-spaces-regexp isearch-lazy-highlight-space-regexp)) (condition-case nil (isearch-search-string isearch-lazy-highlight-last-string -- cgit v1.2.1 From 0b60cc090810a1b3576b2ac3e58bf2ecf822a864 Mon Sep 17 00:00:00 2001 From: Chong Yidong Date: Thu, 15 Feb 2007 16:54:24 +0000 Subject: (replace-highlight): Bind search-whitespace-regexp to nil. --- lisp/replace.el | 1 + 1 file changed, 1 insertion(+) (limited to 'lisp') diff --git a/lisp/replace.el b/lisp/replace.el index 12a99d72b9b..9790dacd82b 100644 --- a/lisp/replace.el +++ b/lisp/replace.el @@ -1728,6 +1728,7 @@ make, or the user didn't cancel the call." (if query-replace-lazy-highlight (let ((isearch-string string) (isearch-regexp regexp) + (search-whitespace-regexp nil) (isearch-case-fold-search case-fold)) (isearch-lazy-highlight-new-loop range-beg range-end)))) -- cgit v1.2.1 From 0535d51b4c2fd08dea93483d2daea7fd5f993941 Mon Sep 17 00:00:00 2001 From: Alan Mackenzie Date: Thu, 15 Feb 2007 22:28:17 +0000 Subject: *** empty log message *** --- lisp/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) (limited to 'lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index b10e6060668..140df492ea0 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,8 @@ +2007-02-15 Alan Mackenzie + + * progmodes/cc-cmds.el (c-indent-new-comment-line): When splitting + an empty one-line C-style comment, post-position point properly. + 2007-02-15 Chris Moore * isearch.el (isearch-lazy-highlight-space-regexp): New variable. -- cgit v1.2.1 From 94dd9d6dc94bcea09d78aedde0a02975be8d705f Mon Sep 17 00:00:00 2001 From: Alan Mackenzie Date: Thu, 15 Feb 2007 22:31:52 +0000 Subject: (c-indent-new-comment-line): When splitting an empty one-line C-style comment, post-position point properly. --- lisp/progmodes/cc-cmds.el | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) (limited to 'lisp') diff --git a/lisp/progmodes/cc-cmds.el b/lisp/progmodes/cc-cmds.el index f8375d7fe36..4f9e1947738 100644 --- a/lisp/progmodes/cc-cmds.el +++ b/lisp/progmodes/cc-cmds.el @@ -4238,6 +4238,7 @@ If a fill prefix is specified, it overrides all the above." (c-collect-line-comments c-lit-limits)) c-lit-type))) (pos (point)) + (start-col (current-column)) (comment-text-end (or (and (eq c-lit-type 'c) (save-excursion @@ -4254,6 +4255,11 @@ If a fill prefix is specified, it overrides all the above." ;; ;; If point is on the 'B' then the line will be ;; broken after "Bla b". + ;; + ;; If we have an empty comment, /* */, the next + ;; lot of code pushes point to the */. We fix + ;; this by never allowing point to end up to the + ;; right of where it started. (while (and (< (current-column) (cdr fill)) (not (eolp))) (forward-char 1)) @@ -4276,7 +4282,10 @@ If a fill prefix is specified, it overrides all the above." ((< (point) (+ (car c-lit-limits) 2)) (goto-char (+ (car c-lit-limits) 2)))) (funcall do-line-break) - (insert-and-inherit (car fill)))) + (insert-and-inherit (car fill)) + (if (> (current-column) start-col) + (move-to-column start-col)))) ; can this hit the + ; middle of a TAB? ;; Inside a comment that should be broken. (let ((comment-start comment-start) (comment-end comment-end) -- cgit v1.2.1 From 1452f27e47cd6d31f88e52f8242d701623f84d75 Mon Sep 17 00:00:00 2001 From: Glenn Morris Date: Fri, 16 Feb 2007 08:01:22 +0000 Subject: Add copyright and license notice (ESR states that he was probably the author). --- lisp/term/README | 23 +++++++++++++++++++++++ 1 file changed, 23 insertions(+) (limited to 'lisp') diff --git a/lisp/term/README b/lisp/term/README index 581f321d3ba..972bd49c796 100644 --- a/lisp/term/README +++ b/lisp/term/README @@ -1,3 +1,8 @@ +Copyright (C) 1993, 2001, 2002, 2003, 2004, 2005, 2006, 2007 + Free Software Foundation, Inc. +See the end of the file for license conditions. + + This directory contains files of elisp that customize Emacs for certain terminal types. @@ -217,3 +222,21 @@ it up to the user's .emacs file whether to call it. Before writing a terminal-support package, it's a good idea to read the existing ones and learn the common conventions. + + +This file is part of GNU Emacs. + +GNU Emacs is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs; see the file COPYING. If not, write to the +Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +Boston, MA 02110-1301, USA. -- cgit v1.2.1 From cf04718a317cbe9b06b96767735f1384bbb010b8 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Fri, 16 Feb 2007 16:11:05 +0000 Subject: Use (defvar ) where applicable. (ps-print-emacs-type): Remove. (ps-x-frame-property, ps-e-frame-parameter): Remove. (ps-frame-parameter): Align its call-convention with frame-parameter. (ps-begin-job): Adjust calls to it appropriately. (ps-setup): Don't print ps-print-emacs-type. (ps-e-find-composition, ps-mark-active-p, ps-color-device): Define in such a way that it's obvious that it's defined. (ps-prsc, ps-c-prsc, ps-s-prsc): Remove. (ps-rmail-mode-hook, ps-vm-mode-hook, ps-gnus-summary-setup) (ps-jts-ps-setup): Use flavor-neutral syntax instead. --- lisp/ChangeLog | 17 +++++++- lisp/ps-print.el | 119 +++++++++++++++++++++++++------------------------------ 2 files changed, 69 insertions(+), 67 deletions(-) (limited to 'lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 140df492ea0..281cdd624a9 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,17 @@ +2007-02-16 Stefan Monnier + + * ps-print.el: Use (defvar ) where applicable. + (ps-print-emacs-type): Remove. + (ps-x-frame-property, ps-e-frame-parameter): Remove. + (ps-frame-parameter): Align its call-convention with frame-parameter. + (ps-begin-job): Adjust calls to it appropriately. + (ps-setup): Don't print ps-print-emacs-type. + (ps-e-find-composition, ps-mark-active-p, ps-color-device): + Define in such a way that it's obvious that it's defined. + (ps-prsc, ps-c-prsc, ps-s-prsc): Remove. + (ps-rmail-mode-hook, ps-vm-mode-hook, ps-gnus-summary-setup) + (ps-jts-ps-setup): Use flavor-neutral syntax instead. + 2007-02-15 Alan Mackenzie * progmodes/cc-cmds.el (c-indent-new-comment-line): When splitting @@ -9,8 +23,7 @@ (isearch-lazy-highlight-new-loop): Bind it. (isearch-lazy-highlight-search): Use it. - * replace.el (replace-highlight): Bind search-whitespace-regexp to - nil. + * replace.el (replace-highlight): Bind search-whitespace-regexp to nil. 2007-02-15 Stefan Monnier diff --git a/lisp/ps-print.el b/lisp/ps-print.el index 7a9263b0ea8..751dd0fd9df 100644 --- a/lisp/ps-print.el +++ b/lisp/ps-print.el @@ -1448,19 +1448,16 @@ Please send all bug fixes and enhancements to (or (featurep 'lisp-float-type) (error "`ps-print' requires floating point support")) - -(defvar ps-print-emacs-type - (let ((case-fold-search t)) - (cond ((string-match "XEmacs" emacs-version) 'xemacs) - ((string-match "Lucid" emacs-version) - (error "`ps-print' doesn't support Lucid")) - ((string-match "Epoch" emacs-version) - (error "`ps-print' doesn't support Epoch")) - (t - (unless (and (boundp 'emacs-major-version) - (>= emacs-major-version 22)) - (error "`ps-print' only supports Emacs 22 and higher")) - 'emacs)))) +(let ((case-fold-search t)) + (cond ((string-match "XEmacs" emacs-version)) + ((string-match "Lucid" emacs-version) + (error "`ps-print' doesn't support Lucid")) + ((string-match "Epoch" emacs-version) + (error "`ps-print' doesn't support Epoch")) + (t + (unless (and (boundp 'emacs-major-version) + (>= emacs-major-version 22)) + (error "`ps-print' only supports Emacs 22 and higher"))))) ;; GNU Emacs @@ -1490,7 +1487,6 @@ Please send all bug fixes and enhancements to (defalias 'ps-x-font-instance-properties 'font-instance-properties) (defalias 'ps-x-make-color-instance 'make-color-instance) (defalias 'ps-x-map-extents 'map-extents) -(defalias 'ps-x-frame-property 'frame-property) ;; GNU Emacs (defalias 'ps-e-face-bold-p 'face-bold-p) @@ -1501,10 +1497,9 @@ Please send all bug fixes and enhancements to (defalias 'ps-e-overlay-end 'overlay-end) (defalias 'ps-e-x-color-values 'x-color-values) (defalias 'ps-e-color-values 'color-values) -(defalias 'ps-e-frame-parameter 'frame-parameter) -(if (fboundp 'find-composition) - (defalias 'ps-e-find-composition 'find-composition) - (defalias 'ps-e-find-composition 'ignore)) +(defalias 'ps-e-find-composition (if (fboundp 'find-composition) + 'find-composition + 'ignore)) (defconst ps-windows-system @@ -1518,26 +1513,25 @@ Please send all bug fixes and enhancements to (ps-x-color-name color) color)) +(defalias 'ps-frame-parameter + (if (fboundp 'frame-parameter) 'frame-parameter 'frame-property)) +(defalias 'ps-mark-active-p + (if (fboundp 'region-active-p) + 'region-active-p ; XEmacs + (defvar mark-active) ; To shup up XEmacs's byte compiler. + (lambda () mark-active))) ; Emacs -(cond ((featurep 'xemacs) ; xemacs - (defalias 'ps-mark-active-p 'region-active-p) +(cond ((featurep 'xemacs) ; XEmacs (defun ps-face-foreground-name (face) (ps-xemacs-color-name (face-foreground face))) (defun ps-face-background-name (face) (ps-xemacs-color-name (face-background face))) - (defun ps-frame-parameter (param) - (ps-x-frame-property nil param)) ) - (t ; emacs 22 or higher - (defvar mark-active nil) - (defun ps-mark-active-p () - mark-active) + (t ; Emacs 22 or higher (defun ps-face-foreground-name (face) (face-foreground face nil t)) (defun ps-face-background-name (face) (face-background face nil t)) - (defun ps-frame-parameter (param) - (ps-e-frame-parameter nil param)) )) @@ -3594,7 +3588,6 @@ The table depends on the current ps-print setup." (concat "\n;;; ps-print version " ps-print-version "\n") ";; internal vars" (ps-comment-string "emacs-version " emacs-version) - (ps-comment-string "ps-print-emacs-type" ps-print-emacs-type) (ps-comment-string "ps-windows-system " ps-windows-system) (ps-comment-string "ps-lp-system " ps-lp-system) nil @@ -3848,19 +3841,20 @@ It can be retrieved with `(ps-get ALIST-SYM KEY)'." ;; Return t if the device (which can be changed during an emacs session) ;; can handle colors. ;; This function is not yet implemented for GNU emacs. -(cond ((and (featurep 'xemacs) - ;; XEmacs change: Need to check for emacs-major-version too. - (or (> emacs-major-version 19) - (and (= emacs-major-version 19) - (>= emacs-minor-version 12)))) ; xemacs >= 19.12 - (defun ps-color-device () - (eq (ps-x-device-class) 'color))) - - (t ; emacs - (defun ps-color-device () - (if (fboundp 'color-values) - (ps-e-color-values "Green") - t)))) +(defalias 'ps-color-device + (cond ((and (featurep 'xemacs) + ;; XEmacs change: Need to check for emacs-major-version too. + (or (> emacs-major-version 19) + (and (= emacs-major-version 19) + (>= emacs-minor-version 12)))) ; XEmacs >= 19.12 + (lambda () + (eq (ps-x-device-class) 'color))) + + (t ; Emacs + (lambda () + (if (fboundp 'color-values) + (ps-e-color-values "Green") + t))))) (defun ps-mapper (extent list) @@ -3883,12 +3877,12 @@ It can be retrieved with `(ps-get ALIST-SYM KEY)'." (case-fold-search t)) (and kind-spec (string-match kind-regex kind-spec)))) -(cond ((featurep 'xemacs) ; xemacs +(cond ((featurep 'xemacs) ; XEmacs ;; to avoid XEmacs compilation gripes - (defvar coding-system-for-write nil) - (defvar coding-system-for-read nil) - (defvar buffer-file-coding-system nil) + (defvar coding-system-for-write) + (defvar coding-system-for-read) + (defvar buffer-file-coding-system) (and (fboundp 'find-coding-system) (or (ps-x-find-coding-system 'raw-text-unix) @@ -3918,7 +3912,7 @@ It can be retrieved with `(ps-get ALIST-SYM KEY)'." (memq face ps-italic-faces))) ; Kludge-compatible ) - (t ; emacs + (t ; Emacs (defun ps-color-values (x-color) (cond @@ -4941,8 +4935,8 @@ page-height == ((floor print-height ((th + ls) * zh)) * ((th + ls) * zh)) - th ;; XEmacs will have to make do with %s (princ) for floats. (defvar ps-float-format (if (featurep 'xemacs) - "%s " ; xemacs - "%0.3f ")) ; emacs + "%s " ; XEmacs + "%0.3f ")) ; Emacs (defun ps-float-format (value &optional default) @@ -5912,7 +5906,7 @@ XSTART YSTART are the relative position for the first page in a sheet.") ((eq genfunc 'ps-generate-postscript) nil) ((eq ps-default-bg 'frame-parameter) - (ps-frame-parameter 'background-color)) + (ps-frame-parameter nil 'background-color)) ((eq ps-default-bg t) (ps-face-background-name 'default)) (t @@ -5923,7 +5917,7 @@ XSTART YSTART are the relative position for the first page in a sheet.") ((eq genfunc 'ps-generate-postscript) nil) ((eq ps-default-fg 'frame-parameter) - (ps-frame-parameter 'foreground-color)) + (ps-frame-parameter nil 'foreground-color)) ((eq ps-default-fg t) (ps-face-foreground-name 'default)) (t @@ -6517,7 +6511,7 @@ If FACE is not a valid face name, use default face." (let ((face 'default) (position to)) (cond - ((featurep 'xemacs) ; xemacs + ((featurep 'xemacs) ; XEmacs ;; Build the list of extents... (let ((a (cons 'dummy nil)) record type extent extent-list) @@ -6561,7 +6555,7 @@ If FACE is not a valid face name, use default face." from position a (cdr a))))) - (t ; emacs + (t ; Emacs (let ((property-change from) (overlay-change from) (save-buffer-invisibility-spec buffer-invisibility-spec) @@ -6837,17 +6831,12 @@ If FACE is not a valid face name, use default face." ;; WARNING!!! The following code is *sample* code only. ;; Don't use it unless you understand what it does! -(defmacro ps-prsc () - `(if (featurep 'xemacs) 'f22 [f22])) -(defmacro ps-c-prsc () - `(if (featurep 'xemacs) '(control f22) [C-f22])) -(defmacro ps-s-prsc () - `(if (featurep 'xemacs) '(shift f22) [S-f22])) +;; The key `f22' should probably be replaced by `print'. --Stef ;; A hook to bind to `rmail-mode-hook' to locally bind prsc and set the ;; `ps-left-headers' specially for mail messages. (defun ps-rmail-mode-hook () - (local-set-key (ps-prsc) 'ps-rmail-print-message-from-summary) + (local-set-key [(f22)] 'ps-rmail-print-message-from-summary) (setq ps-header-lines 3 ps-left-header ;; The left headers will display the message's subject, its @@ -6921,7 +6910,7 @@ If FACE is not a valid face name, use default face." ;; A hook to bind to `vm-mode-hook' to locally bind prsc and set the ;; `ps-left-headers' specially for mail messages. (defun ps-vm-mode-hook () - (local-set-key (ps-prsc) 'ps-vm-print-message-from-summary) + (local-set-key [(f22)] 'ps-vm-print-message-from-summary) (setq ps-header-lines 3 ps-left-header ;; The left headers will display the message's subject, its @@ -6947,7 +6936,7 @@ If FACE is not a valid face name, use default face." ;; A hook to bind to bind to `gnus-summary-setup-buffer' to locally bind ;; prsc. (defun ps-gnus-summary-setup () - (local-set-key (ps-prsc) 'ps-gnus-print-article-from-summary)) + (local-set-key [(f22)] 'ps-gnus-print-article-from-summary)) ;; Look in an article or mail message for the Subject: line. To be ;; placed in `ps-left-headers'. @@ -6979,9 +6968,9 @@ If FACE is not a valid face name, use default face." ;; modification.) (defun ps-jts-ps-setup () - (global-set-key (ps-prsc) 'ps-spool-buffer-with-faces) ;f22 is prsc - (global-set-key (ps-s-prsc) 'ps-spool-region-with-faces) - (global-set-key (ps-c-prsc) 'ps-despool) + (global-set-key [(f22)] 'ps-spool-buffer-with-faces) ;f22 is prsc + (global-set-key [(shift f22)] 'ps-spool-region-with-faces) + (global-set-key [(control f22)] 'ps-despool) (add-hook 'gnus-article-prepare-hook 'ps-gnus-article-prepare-hook) (add-hook 'gnus-summary-mode-hook 'ps-gnus-summary-setup) (add-hook 'vm-mode-hook 'ps-vm-mode-hook) -- cgit v1.2.1 From ead4759c9c241f5179249859a283809e43c4b1bd Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sat, 17 Feb 2007 11:28:18 +0000 Subject: (font-lock-extend-region-wholelines): Test for EOB in addition to BOL. --- lisp/ChangeLog | 5 +++++ lisp/font-lock.el | 8 ++++---- 2 files changed, 9 insertions(+), 4 deletions(-) (limited to 'lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 281cdd624a9..832d921c20a 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,8 @@ +2007-02-17 David Hansen (tiny change) + + * font-lock.el (font-lock-extend-region-wholelines): Test for EOB + in addition to BOL. + 2007-02-16 Stefan Monnier * ps-print.el: Use (defvar ) where applicable. diff --git a/lisp/font-lock.el b/lisp/font-lock.el index 62008ac295b..fd2dedc1dae 100644 --- a/lisp/font-lock.el +++ b/lisp/font-lock.el @@ -1075,20 +1075,20 @@ Put first the functions more likely to cause a change and cheaper to compute.") (setq font-lock-beg (or (previous-single-property-change font-lock-beg 'font-lock-multiline) (point-min)))) - ;; + ;; (when (get-text-property font-lock-end 'font-lock-multiline) (setq changed t) (setq font-lock-end (or (text-property-any font-lock-end (point-max) 'font-lock-multiline nil) (point-max)))) changed)) - - + (defun font-lock-extend-region-wholelines () "Move fontification boundaries to beginning of lines." (let ((changed nil)) (goto-char font-lock-beg) - (unless (bolp) (setq changed t font-lock-beg (line-beginning-position))) + (unless (or (bolp) (eobp)) + (setq changed t font-lock-beg (line-beginning-position))) (goto-char font-lock-end) (unless (bolp) (unless (eq font-lock-end -- cgit v1.2.1 From 8e1ac0634abc10422d0739b078a096e381447786 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sat, 17 Feb 2007 11:35:22 +0000 Subject: (calculate-lisp-indent): Added indentation for the constants of Lisp. --- lisp/ChangeLog | 5 +++++ lisp/emacs-lisp/lisp-mode.el | 18 ++++++++++++++++++ 2 files changed, 23 insertions(+) (limited to 'lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 832d921c20a..234030a9a7b 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,8 @@ +2007-02-17 Alin C. Soare (tiny change) + + * emacs-lisp/lisp-mode.el (calculate-lisp-indent): Added + indentation for the constants of Lisp. + 2007-02-17 David Hansen (tiny change) * font-lock.el (font-lock-extend-region-wholelines): Test for EOB diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index 8c1cf918b36..5576a4882b0 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -909,6 +909,24 @@ is the buffer position of the start of the containing expression." (cond ((elt state 3) ;; Inside a string, don't change indentation. nil) + ((save-excursion + ;; test whether current line begins with a constant + (goto-char indent-point) + (skip-chars-forward " \t") + (looking-at ":")) + (let ((desired-indent + (save-excursion + (goto-char (1+ containing-sexp)) + (parse-partial-sexp (point) calculate-lisp-indent-last-sexp 0 t) + (point))) + (parse-sexp-ignore-comments t)) + ;; Align a constant symbol under the last constant symbol + (goto-char calculate-lisp-indent-last-sexp) + (while (> (point) desired-indent) + (if (looking-at ":") + (setq desired-indent (point)) + (backward-sexp 1)))) + (current-column)) ((and (integerp lisp-indent-offset) containing-sexp) ;; Indent by constant offset (goto-char containing-sexp) -- cgit v1.2.1 From e8d2103a83df75858aade088432fb16c2be9dcd9 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sat, 17 Feb 2007 12:03:01 +0000 Subject: (info-lookup): Bind Info-fontify-maximum-menu-size to nil to speed up lookup of the symbol in index nodes. --- lisp/ChangeLog | 5 +++++ lisp/info-look.el | 7 +++++-- 2 files changed, 10 insertions(+), 2 deletions(-) (limited to 'lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 234030a9a7b..0f7b528ba3c 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,8 @@ +2007-02-17 Eli Zaretskii + + * info-look.el (info-lookup): Bind Info-fontify-maximum-menu-size + to nil to speed up lookup of the symbol in index nodes. + 2007-02-17 Alin C. Soare (tiny change) * emacs-lisp/lisp-mode.el (calculate-lisp-indent): Added diff --git a/lisp/info-look.el b/lisp/info-look.el index 828fd3e6118..a4280e97c99 100644 --- a/lisp/info-look.el +++ b/lisp/info-look.el @@ -353,8 +353,11 @@ If optional argument QUERY is non-nil, query for the help mode." suffix (nth 3 (car doc-spec))) (when (condition-case error-data (progn - (Info-goto-node node) - (setq doc-found t)) + ;; Don't need Index menu fontifications here, and + ;; they slow down the lookup. + (let (Info-fontify-maximum-menu-size) + (Info-goto-node node) + (setq doc-found t))) (error (message "Cannot access Info node %s" node) (sit-for 1) -- cgit v1.2.1 From 73c03f767ff3d0cdaf68a6354614f2191dfa6b38 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sat, 17 Feb 2007 12:31:06 +0000 Subject: (jka-compr-compression-info-list): Recognize backups of bz2 compressed files. --- lisp/ChangeLog | 5 +++++ lisp/jka-cmpr-hook.el | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) (limited to 'lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 0f7b528ba3c..aa7f276852a 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,8 @@ +2007-02-17 Chris Moore + + * jka-cmpr-hook.el (jka-compr-compression-info-list): Recognize + backups of bz2 compressed files. + 2007-02-17 Eli Zaretskii * info-look.el (info-lookup): Bind Info-fontify-maximum-menu-size diff --git a/lisp/jka-cmpr-hook.el b/lisp/jka-cmpr-hook.el index ce00181aaa3..b13ca7181ec 100644 --- a/lisp/jka-cmpr-hook.el +++ b/lisp/jka-cmpr-hook.el @@ -191,7 +191,7 @@ options through Custom does this automatically." ;; Formerly, these had an additional arg "-c", but that fails with ;; "Version 0.1pl2, 29-Aug-97." (RedHat 5.1 GNU/Linux) and ;; "Version 0.9.0b, 9-Sept-98". - ["\\.bz2\\'" + ["\\.bz2\\(~\\|\\.~[0-9]+~\\)?\\'" "bzip2ing" "bzip2" nil "bunzip2ing" "bzip2" ("-d") nil t "BZh"] -- cgit v1.2.1 From e925d5ae3209b690ef2b11e4efb9788ea7bd31c1 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sat, 17 Feb 2007 12:36:55 +0000 Subject: Remove `(tiny change)' from Chris Moore's contributions. --- lisp/ChangeLog | 14 +++++++------- lisp/gnus/ChangeLog | 2 +- 2 files changed, 8 insertions(+), 8 deletions(-) (limited to 'lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index aa7f276852a..b1ce300df67 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -671,7 +671,7 @@ (ido-initiate-auto-merge, ido-exhibit, ido-minibuffer-setup) (ido-tidy): Use ido-active. -2007-01-22 Chris Moore (tiny change) +2007-01-22 Chris Moore * hexl.el (hexl-mode-exit): Add missing quote. @@ -800,7 +800,7 @@ * paths.el (Info-default-directory-list): Ditto. -2007-01-18 Chris Moore (tiny change) +2007-01-18 Chris Moore * hexl.el (hexl-before-revert-hook): New function. (hexl-mode): Use it. @@ -952,7 +952,7 @@ * progmodes/vhdl-mode.el (vhdl-save-caches): Fix typo in error message. -2007-01-07 Chris Moore (tiny change) +2007-01-07 Chris Moore * replace.el (replace-regexp): Fix typo in docstring. @@ -1021,7 +1021,7 @@ * progmode/cc-cmds.el (c-mask-paragraph): Fix yesterday's buggy patch. -2007-01-03 Chris Moore (tiny change) +2007-01-03 Chris Moore * tutorial.el (tutorial--describe-nonstandard-key): Fix typo. @@ -3990,7 +3990,7 @@ * international/code-pages.el (iso-8859-6): Table fixed. -2006-10-01 Chris Moore (tiny change) +2006-10-01 Chris Moore * dired.el (dired-build-subdir-alist): Fix previous change. @@ -4164,7 +4164,7 @@ * font-lock.el (font-lock-compile-keywords): Allow value of syntax-begin-function to enable paren-column-0 highlighting. -2006-09-24 Chris Moore (tiny change) +2006-09-24 Chris Moore * dired.el (dired-build-subdir-alist): When file ends in colon, don't exit the loop, just disregard that file. @@ -11517,7 +11517,7 @@ (tumme-create-thumbs, tumme-display-previous-thumbnail-original): Fix typos in docstrings. -2006-02-07 Chris Moore (tiny change) +2006-02-07 Chris Moore * wdired.el (wdired-get-filename): Fix bug: Don't re-normalize OLD. diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog index 8da59d47965..4b205529303 100644 --- a/lisp/gnus/ChangeLog +++ b/lisp/gnus/ChangeLog @@ -154,7 +154,7 @@ (gnus-sort-threads-recursive): Renamed from gnus-sort-thread-1. (gnus-sort-threads-loop): New function. -2006-12-06 Chris Moore (tiny change) +2006-12-06 Chris Moore * gnus-sum.el (gnus-sort-threads, gnus-summary-limit-children): Use `max' to avoid the value of `max-lisp-eval-depth' decreasing. -- cgit v1.2.1 From 4ebb03e66b8e198df1d65d2fe8f599454aa65a3e Mon Sep 17 00:00:00 2001 From: "Richard M. Stallman" Date: Sat, 17 Feb 2007 20:39:55 +0000 Subject: (pgg-gpg-process-region): Make USE-AGENT nil if PASSPHRASE is given. --- lisp/ChangeLog | 5 +++++ lisp/pgg-gpg.el | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) (limited to 'lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index b1ce300df67..49fd9309381 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,8 @@ +2007-02-17 Daiki Ueno + + * pgg-gpg.el (pgg-gpg-process-region): Make USE-AGENT nil + if PASSPHRASE is given. + 2007-02-17 Chris Moore * jka-cmpr-hook.el (jka-compr-compression-info-list): Recognize diff --git a/lisp/pgg-gpg.el b/lisp/pgg-gpg.el index 84bf81a858e..a2cd14eaae3 100644 --- a/lisp/pgg-gpg.el +++ b/lisp/pgg-gpg.el @@ -61,7 +61,7 @@ "GnuPG ID of your default identity.") (defun pgg-gpg-process-region (start end passphrase program args) - (let* ((use-agent (pgg-gpg-use-agent-p)) + (let* ((use-agent (and (null passphrase) (pgg-gpg-use-agent-p))) (output-file-name (pgg-make-temp-file "pgg-output")) (args `("--status-fd" "2" -- cgit v1.2.1 From 255d98f85def3fd4a3691d2a09d7885980e18d8a Mon Sep 17 00:00:00 2001 From: "Kim F. Storm" Date: Sat, 17 Feb 2007 22:02:04 +0000 Subject: *** empty log message *** --- lisp/ChangeLog | 7 +++++++ 1 file changed, 7 insertions(+) (limited to 'lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 49fd9309381..22c64f75166 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,10 @@ +2007-02-17 Kim F. Storm + + * emacs-lisp/bindat.el (bindat--unpack-u*): Optimize. + (bindat--unpack-item, bindat--length-group, bindat--pack-item) + (bindat--unpack-group, bindat--pack-group): + Handle vectors with optional element type. + 2007-02-17 Daiki Ueno * pgg-gpg.el (pgg-gpg-process-region): Make USE-AGENT nil -- cgit v1.2.1 From 4e7a0e25fdff3b3a61e218eb8feaec2bc82266df Mon Sep 17 00:00:00 2001 From: "Kim F. Storm" Date: Sat, 17 Feb 2007 22:02:25 +0000 Subject: (bindat--unpack-u*): Optimize. (bindat--unpack-item, bindat--length-group, bindat--pack-item) (bindat--unpack-group, bindat--pack-group): Handle vectors with optional element type. --- lisp/emacs-lisp/bindat.el | 62 +++++++++++++++++++++++++++++++---------------- 1 file changed, 41 insertions(+), 21 deletions(-) (limited to 'lisp') diff --git a/lisp/emacs-lisp/bindat.el b/lisp/emacs-lisp/bindat.el index c58c286ef75..1e491697430 100644 --- a/lisp/emacs-lisp/bindat.el +++ b/lisp/emacs-lisp/bindat.el @@ -147,7 +147,7 @@ ;; | u16r | u24r | u32r -- little endian byte order. ;; | str LEN -- LEN byte string ;; | strz LEN -- LEN byte (zero-terminated) string -;; | vec LEN -- LEN byte vector +;; | vec LEN [TYPE] -- vector of LEN items of TYPE (default: u8) ;; | ip -- 4 byte vector ;; | bits LEN -- List with bits set in LEN bytes. ;; @@ -207,30 +207,24 @@ (setq bindat-idx (1+ bindat-idx)))) (defun bindat--unpack-u16 () - (let* ((a (bindat--unpack-u8)) (b (bindat--unpack-u8))) - (logior (lsh a 8) b))) + (logior (lsh (bindat--unpack-u8) 8) (bindat--unpack-u8))) (defun bindat--unpack-u24 () - (let* ((a (bindat--unpack-u16)) (b (bindat--unpack-u8))) - (logior (lsh a 8) b))) + (logior (lsh (bindat--unpack-u16) 8) (bindat--unpack-u8))) (defun bindat--unpack-u32 () - (let* ((a (bindat--unpack-u16)) (b (bindat--unpack-u16))) - (logior (lsh a 16) b))) + (logior (lsh (bindat--unpack-u16) 16) (bindat--unpack-u16))) (defun bindat--unpack-u16r () - (let* ((a (bindat--unpack-u8)) (b (bindat--unpack-u8))) - (logior a (lsh b 8)))) + (logior (bindat--unpack-u8) (lsh (bindat--unpack-u8) 8))) (defun bindat--unpack-u24r () - (let* ((a (bindat--unpack-u16r)) (b (bindat--unpack-u8))) - (logior a (lsh b 16)))) + (logior (bindat--unpack-u16r) (lsh (bindat--unpack-u8) 16))) (defun bindat--unpack-u32r () - (let* ((a (bindat--unpack-u16r)) (b (bindat--unpack-u16r))) - (logior a (lsh b 16)))) + (logior (bindat--unpack-u16r) (lsh (bindat--unpack-u16r) 16))) -(defun bindat--unpack-item (type len) +(defun bindat--unpack-item (type len &optional vectype) (if (eq type 'ip) (setq type 'vec len 4)) (cond @@ -274,9 +268,14 @@ (if (stringp s) s (string-make-unibyte (concat s))))) ((eq type 'vec) - (let ((v (make-vector len 0)) (i 0)) + (let ((v (make-vector len 0)) (i 0) (vlen 1)) + (if (consp vectype) + (setq vlen (nth 1 vectype) + vectype (nth 2 vectype)) + (setq type (or vectype 'u8) + vectype nil)) (while (< i len) - (aset v i (bindat--unpack-u8)) + (aset v i (bindat--unpack-item type vlen vectype)) (setq i (1+ i))) v)) (t nil))) @@ -288,6 +287,7 @@ (field (car item)) (type (nth 1 item)) (len (nth 2 item)) + (vectype (and (eq type 'vec) (nth 3 item))) (tail 3) data) (setq spec (cdr spec)) @@ -335,7 +335,7 @@ (setq data (bindat--unpack-group (cdr case)) cases nil))))) (t - (setq data (bindat--unpack-item type len) + (setq data (bindat--unpack-item type len vectype) last data))) (if data (if field @@ -384,6 +384,7 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." (field (car item)) (type (nth 1 item)) (len (nth 2 item)) + (vectype (and (eq type 'vec) (nth 3 item))) (tail 3)) (setq spec (cdr spec)) (if (and (consp field) (eq (car field) 'eval)) @@ -401,6 +402,13 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." (setq len (apply 'bindat-get-field struct len))) (if (not len) (setq len 1)) + (while (eq type 'vec) + (let ((vlen 1)) + (if (consp vectype) + (setq len (* len (nth 1 vectype)) + type (nth 2 vectype)) + (setq type (or vectype 'u8) + vectype nil)))) (cond ((eq type 'eval) (if field @@ -434,7 +442,7 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." (setq cases nil)))))) (t (if (setq type (assq type bindat--fixed-length-alist)) - (setq len (cdr type))) + (setq len (* len (cdr type)))) (if field (setq last (bindat-get-field struct field))) (setq bindat-idx (+ bindat-idx len)))))))) @@ -478,7 +486,7 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." (bindat--pack-u16r v) (bindat--pack-u16r (lsh v -16))) -(defun bindat--pack-item (v type len) +(defun bindat--pack-item (v type len &optional vectype) (if (eq type 'ip) (setq type 'vec len 4)) (cond @@ -511,13 +519,24 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." (setq bnum (1- bnum) j (lsh j -1)))) (bindat--pack-u8 m)))) - ((memq type '(str strz vec)) + ((memq type '(str strz)) (let ((l (length v)) (i 0)) (if (> l len) (setq l len)) (while (< i l) (aset bindat-raw (+ bindat-idx i) (aref v i)) (setq i (1+ i))) (setq bindat-idx (+ bindat-idx len)))) + ((eq type 'vec) + (let ((l (length v)) (i 0) (vlen 1)) + (if (consp vectype) + (setq vlen (nth 1 vectype) + vectype (nth 2 vectype)) + (setq type (or vectype 'u8) + vectype nil)) + (if (> l len) (setq l len)) + (while (< i l) + (bindat--pack-item (aref v i) type vlen vectype) + (setq i (1+ i))))) (t (setq bindat-idx (+ bindat-idx len))))) @@ -528,6 +547,7 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." (field (car item)) (type (nth 1 item)) (len (nth 2 item)) + (vectype (and (eq type 'vec) (nth 3 item))) (tail 3)) (setq spec (cdr spec)) (if (and (consp field) (eq (car field) 'eval)) @@ -578,7 +598,7 @@ e.g. corresponding to STRUCT.FIELD1[INDEX2].FIELD3..." (setq cases nil)))))) (t (setq last (bindat-get-field struct field)) - (bindat--pack-item last type len) + (bindat--pack-item last type len vectype) )))))) (defun bindat-pack (spec struct &optional bindat-raw bindat-idx) -- cgit v1.2.1 From 602157ab37847e9b9da58453ace558811d121ea6 Mon Sep 17 00:00:00 2001 From: "Richard M. Stallman" Date: Sat, 17 Feb 2007 23:06:12 +0000 Subject: (kill-line): Doc fix. --- lisp/simple.el | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'lisp') diff --git a/lisp/simple.el b/lisp/simple.el index 6f4f5eb4073..44408c4f427 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -2836,12 +2836,12 @@ When calling from a program, nil means \"no arg\", a number counts as a prefix arg. To kill a whole line, when point is not at the beginning, type \ -\\[beginning-of-line] \\[kill-line] \\[kill-line]. +\\[move-beginning-of-line] \\[kill-line] \\[kill-line]. If `kill-whole-line' is non-nil, then this command kills the whole line including its terminating newline, when used at the beginning of a line with no argument. As a consequence, you can always kill a whole line -by typing \\[beginning-of-line] \\[kill-line]. +by typing \\[move-beginning-of-line] \\[kill-line]. If you want to append the killed line to the last killed text, use \\[append-next-kill] before \\[kill-line]. -- cgit v1.2.1 From 3ce97b735916b2e596e9d2aa21975d9496df9d2f Mon Sep 17 00:00:00 2001 From: "Richard M. Stallman" Date: Sat, 17 Feb 2007 23:07:29 +0000 Subject: *** empty log message *** --- lisp/ChangeLog | 4 ++++ 1 file changed, 4 insertions(+) (limited to 'lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 22c64f75166..29b3e166749 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,7 @@ +2007-02-17 Sven Joachim (tiny change) + + * simple.el (kill-line): Doc fix. + 2007-02-17 Kim F. Storm * emacs-lisp/bindat.el (bindat--unpack-u*): Optimize. -- cgit v1.2.1 From dfee9538a14db844e318393dd87985941526841f Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Sun, 18 Feb 2007 18:52:18 +0000 Subject: (font-lock-extend-region-wholelines): Revert last change. --- lisp/ChangeLog | 5 ----- lisp/font-lock.el | 40 ++++++++++++++++++++++++++++------------ 2 files changed, 28 insertions(+), 17 deletions(-) (limited to 'lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 29b3e166749..beb625604a7 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -29,11 +29,6 @@ * emacs-lisp/lisp-mode.el (calculate-lisp-indent): Added indentation for the constants of Lisp. -2007-02-17 David Hansen (tiny change) - - * font-lock.el (font-lock-extend-region-wholelines): Test for EOB - in addition to BOL. - 2007-02-16 Stefan Monnier * ps-print.el: Use (defvar ) where applicable. diff --git a/lisp/font-lock.el b/lisp/font-lock.el index fd2dedc1dae..1e27daa89ec 100644 --- a/lisp/font-lock.el +++ b/lisp/font-lock.el @@ -350,7 +350,7 @@ Each element in a user-level keywords list should have one of these forms: (MATCHER . SUBEXP) (MATCHER . FACENAME) (MATCHER . HIGHLIGHT) - (MATCHER HIGHLIGHT ...) + (MATCHER . HIGHLIGHTS) (eval . FORM) where MATCHER can be either the regexp to search for, or the function name to @@ -1040,6 +1040,13 @@ The region it returns may start or end in the middle of a line.") Useful for things like RMAIL and Info where the whole buffer is not a very meaningful entity to highlight.") +(defvar font-lock-syntax-props-depend-on-themselves nil + "If non-nil, syntax-table changes may influence syntactic keywords. +If the syntax-table properties set by syntactic-keywords themselves depend +on syntax-table properties set on the text before it by syntactic-keywords, +this variable should be set to non-nil, so that whenever syntaxtic-keywords +is applied, the subsequent text is marked for syntactic re-fontification.") + (defvar font-lock-beg) (defvar font-lock-end) (defvar font-lock-extend-region-functions @@ -1087,7 +1094,7 @@ Put first the functions more likely to cause a change and cheaper to compute.") "Move fontification boundaries to beginning of lines." (let ((changed nil)) (goto-char font-lock-beg) - (unless (or (bolp) (eobp)) + (unless (bolp) (setq changed t font-lock-beg (line-beginning-position))) (goto-char font-lock-end) (unless (bolp) @@ -1124,11 +1131,25 @@ Put first the functions more likely to cause a change and cheaper to compute.") (setq beg font-lock-beg end font-lock-end)) ;; Now do the fontification. (font-lock-unfontify-region beg end) - (when font-lock-syntactic-keywords - (font-lock-fontify-syntactic-keywords-region beg end)) - (unless font-lock-keywords-only - (font-lock-fontify-syntactically-region beg end loudly)) - (font-lock-fontify-keywords-region beg end loudly)) + (let ((sbeg beg)) + (cond + ((< font-lock-syntactically-fontified sbeg) + ;; Ensure the syntax-table prop is properly set on the text + ;; before beg. + (setq sbeg (max font-lock-syntactically-fontified (point-min))) + (setq font-lock-syntactically-fontified end)) + ((and font-lock-syntax-props-depend-on-themselves + (> font-lock-syntactically-fontified end)) + ;; If the syntax-table properties set by + ;; font-lock-syntactic-keywords themselves depend on + ;; syntax-table props set in the text above it, then we'll + ;; need to update all the syntax-table props below end. + (setq font-lock-syntactically-fontified end))) + (when font-lock-syntactic-keywords + (font-lock-fontify-syntactic-keywords-region sbeg end))) + (unless font-lock-keywords-only + (font-lock-fontify-syntactically-region beg end loudly)) + (font-lock-fontify-keywords-region beg end loudly)) ;; Clean up. (set-syntax-table old-syntax-table)))) @@ -1418,11 +1439,6 @@ LIMIT can be modified by the value of its PRE-MATCH-FORM." (defun font-lock-fontify-syntactic-keywords-region (start end) "Fontify according to `font-lock-syntactic-keywords' between START and END. START should be at the beginning of a line." - ;; Ensure the beginning of the file is properly syntactic-fontified. - (when (and font-lock-syntactically-fontified - (< font-lock-syntactically-fontified start)) - (setq start (max font-lock-syntactically-fontified (point-min))) - (setq font-lock-syntactically-fontified end)) ;; If `font-lock-syntactic-keywords' is a symbol, get the real keywords. (when (symbolp font-lock-syntactic-keywords) (setq font-lock-syntactic-keywords (font-lock-eval-keywords -- cgit v1.2.1 From 700b8e66472752e3709bf3cae08cc82be70432a7 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Sun, 18 Feb 2007 20:36:06 +0000 Subject: Revert the accidental commit of unrelated patches in the previous commit. --- lisp/font-lock.el | 38 +++++++++++--------------------------- 1 file changed, 11 insertions(+), 27 deletions(-) (limited to 'lisp') diff --git a/lisp/font-lock.el b/lisp/font-lock.el index 1e27daa89ec..ecd4dd56d9e 100644 --- a/lisp/font-lock.el +++ b/lisp/font-lock.el @@ -350,7 +350,7 @@ Each element in a user-level keywords list should have one of these forms: (MATCHER . SUBEXP) (MATCHER . FACENAME) (MATCHER . HIGHLIGHT) - (MATCHER . HIGHLIGHTS) + (MATCHER HIGHLIGHT ...) (eval . FORM) where MATCHER can be either the regexp to search for, or the function name to @@ -1040,13 +1040,6 @@ The region it returns may start or end in the middle of a line.") Useful for things like RMAIL and Info where the whole buffer is not a very meaningful entity to highlight.") -(defvar font-lock-syntax-props-depend-on-themselves nil - "If non-nil, syntax-table changes may influence syntactic keywords. -If the syntax-table properties set by syntactic-keywords themselves depend -on syntax-table properties set on the text before it by syntactic-keywords, -this variable should be set to non-nil, so that whenever syntaxtic-keywords -is applied, the subsequent text is marked for syntactic re-fontification.") - (defvar font-lock-beg) (defvar font-lock-end) (defvar font-lock-extend-region-functions @@ -1131,25 +1124,11 @@ Put first the functions more likely to cause a change and cheaper to compute.") (setq beg font-lock-beg end font-lock-end)) ;; Now do the fontification. (font-lock-unfontify-region beg end) - (let ((sbeg beg)) - (cond - ((< font-lock-syntactically-fontified sbeg) - ;; Ensure the syntax-table prop is properly set on the text - ;; before beg. - (setq sbeg (max font-lock-syntactically-fontified (point-min))) - (setq font-lock-syntactically-fontified end)) - ((and font-lock-syntax-props-depend-on-themselves - (> font-lock-syntactically-fontified end)) - ;; If the syntax-table properties set by - ;; font-lock-syntactic-keywords themselves depend on - ;; syntax-table props set in the text above it, then we'll - ;; need to update all the syntax-table props below end. - (setq font-lock-syntactically-fontified end))) - (when font-lock-syntactic-keywords - (font-lock-fontify-syntactic-keywords-region sbeg end))) - (unless font-lock-keywords-only - (font-lock-fontify-syntactically-region beg end loudly)) - (font-lock-fontify-keywords-region beg end loudly)) + (when font-lock-syntactic-keywords + (font-lock-fontify-syntactic-keywords-region beg end)) + (unless font-lock-keywords-only + (font-lock-fontify-syntactically-region beg end loudly)) + (font-lock-fontify-keywords-region beg end loudly)) ;; Clean up. (set-syntax-table old-syntax-table)))) @@ -1439,6 +1418,11 @@ LIMIT can be modified by the value of its PRE-MATCH-FORM." (defun font-lock-fontify-syntactic-keywords-region (start end) "Fontify according to `font-lock-syntactic-keywords' between START and END. START should be at the beginning of a line." + ;; Ensure the beginning of the file is properly syntactic-fontified. + (when (and font-lock-syntactically-fontified + (< font-lock-syntactically-fontified start)) + (setq start (max font-lock-syntactically-fontified (point-min))) + (setq font-lock-syntactically-fontified end)) ;; If `font-lock-syntactic-keywords' is a symbol, get the real keywords. (when (symbolp font-lock-syntactic-keywords) (setq font-lock-syntactic-keywords (font-lock-eval-keywords -- cgit v1.2.1 From aa260d631b3cbe96057a6b5e63cd226d3b03c638 Mon Sep 17 00:00:00 2001 From: Miles Bader Date: Mon, 19 Feb 2007 00:49:13 +0000 Subject: Merge from gnus--rel--5.10 Patches applied: * gnus--rel--5.10 (patch 202) - Update from CVS 2007-02-15 Andreas Seltenreich * lisp/gnus/nnweb.el (nnweb-google-parse-1): Fix date parsing to also match on articles posted in the last 24 hours. Revision: emacs@sv.gnu.org/emacs--devo--0--patch-642 --- lisp/gnus/ChangeLog | 5 +++++ lisp/gnus/nnweb.el | 14 ++++++++------ 2 files changed, 13 insertions(+), 6 deletions(-) (limited to 'lisp') diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog index 4b205529303..c6205eac0ce 100644 --- a/lisp/gnus/ChangeLog +++ b/lisp/gnus/ChangeLog @@ -1,3 +1,8 @@ +2007-02-15 Andreas Seltenreich + + * nnweb.el (nnweb-google-parse-1): Fix date parsing to also match on + articles posted in the last 24 hours. + 2007-02-14 Chong Yidong * smiley.el (smiley-regexp-alist): Add "dead" smiley. diff --git a/lisp/gnus/nnweb.el b/lisp/gnus/nnweb.el index 0f8df57d591..92d90eb061f 100644 --- a/lisp/gnus/nnweb.el +++ b/lisp/gnus/nnweb.el @@ -367,13 +367,15 @@ Valid types include `google', `dejanews', and `gmane'.") (goto-char (point-max)) (when (re-search-backward - "^\\(\\w+\\) \\([0-9]+\\)\\(?: \\([0-9]\\{4\\}\\)\\)? by \\(.*\\)" + "^\\(?:\\(\\w+\\) \\([0-9]+\\)\\|\\S-+\\)\\(?: \\([0-9]\\{4\\}\\)\\)? by \\(.*\\)" nil t) - (setq Date (format "%s %s 00:00:00 %s" - (match-string 1) - (match-string 2) - (or (match-string 3) - (substring (current-time-string) -4)))) + (setq Date (if (match-string 1) + (format "%s %s 00:00:00 %s" + (match-string 1) + (match-string 2) + (or (match-string 3) + (substring (current-time-string) -4))) + (current-time-string))) (setq From (match-string 4))) (widen) (incf i) -- cgit v1.2.1 From dd8925f37240cac0ff987836c1cdf625ca81f0f5 Mon Sep 17 00:00:00 2001 From: Kenichi Handa Date: Mon, 19 Feb 2007 01:55:12 +0000 Subject: ("Esperanto"): New language environment. --- lisp/language/european.el | 13 +++++++++++++ 1 file changed, 13 insertions(+) (limited to 'lisp') diff --git a/lisp/language/european.el b/lisp/language/european.el index ccbbf8318c9..75d9d1fb337 100644 --- a/lisp/language/european.el +++ b/lisp/language/european.el @@ -485,6 +485,19 @@ and it selects the Spanish tutorial.")) (sample-text . "Oi") (documentation . "Support for Brazilian Portuguese.")) '("European")) + +(set-language-info-alist + "Esperanto" '((tutorial . "TUTORIAL.eo") + (charset ascii latin-iso8859-3) + (coding-system iso-latin-3) + (coding-priority iso-latin-3) + (nonascii-translation . latin-iso8859-3) + (unibyte-syntax . "latin-3") + (unibyte-display . iso-latin-3) + (input-method . "latin-3-prefix") + (documentation . "Support for Esperanto with ISO-8859-3 character set.")) + '("European")) + ;; Definitions for the Mac Roman character sets and coding system. ;; The Mac Roman encoding uses all 128 code points in the range 128 to -- cgit v1.2.1 From 58802cd7d3d5b0a489fe9edd4d14023b994310e5 Mon Sep 17 00:00:00 2001 From: Kenichi Handa Date: Mon, 19 Feb 2007 01:59:20 +0000 Subject: (locale-language-names): Map "eo" to "Esperanto". --- lisp/international/mule-cmds.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'lisp') diff --git a/lisp/international/mule-cmds.el b/lisp/international/mule-cmds.el index eff277887d4..214ab791261 100644 --- a/lisp/international/mule-cmds.el +++ b/lisp/international/mule-cmds.el @@ -2185,7 +2185,7 @@ specifies the character set for the major languages of Western Europe." ;; en_IN -- fx. ("en_IN" "English" utf-8) ; glibc uses utf-8 for English in India ("en" "English" iso-8859-1) ; English - ("eo" . "Latin-3") ; Esperanto + ("eo" . "Esperanto") ; Esperanto ("es" "Spanish" iso-8859-1) ("et" . "Latin-1") ; Estonian ("eu" . "Latin-1") ; Basque -- cgit v1.2.1 From e79c1ab360ce911c7143f2a0120456fc2c462cec Mon Sep 17 00:00:00 2001 From: Kenichi Handa Date: Mon, 19 Feb 2007 02:02:36 +0000 Subject: *** empty log message *** --- lisp/ChangeLog | 4 ++++ 1 file changed, 4 insertions(+) (limited to 'lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index beb625604a7..a5f12e6bd21 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,7 @@ +2007-02-19 Kenichi Handa + + * language/european.el ("Esperanto"): New language environment. + 2007-02-17 Sven Joachim (tiny change) * simple.el (kill-line): Doc fix. -- cgit v1.2.1 From 8b93e342f435b1270202b63bbe4fdded70219bcf Mon Sep 17 00:00:00 2001 From: Kenichi Handa Date: Mon, 19 Feb 2007 02:52:22 +0000 Subject: *** empty log message *** --- lisp/ChangeLog | 3 +++ 1 file changed, 3 insertions(+) (limited to 'lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index a5f12e6bd21..78ef2e9c273 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,5 +1,8 @@ 2007-02-19 Kenichi Handa + * international/mule-cmds.el (locale-language-names): Map "eo" + to "Esperanto". + * language/european.el ("Esperanto"): New language environment. 2007-02-17 Sven Joachim (tiny change) -- cgit v1.2.1 From b7f61dfee8849f3057903050e85f3f372c55b478 Mon Sep 17 00:00:00 2001 From: Juanma Barranquero Date: Mon, 19 Feb 2007 13:39:33 +0000 Subject: (speedbar-frame-mode, speedbar-frame-width, speedbar-show-unknown-files, speedbar-item-info-file-helper, speedbar-item-info-tag-helper): Doc fixes. --- lisp/ChangeLog | 18 ++++++++++++------ lisp/speedbar.el | 12 ++++++------ 2 files changed, 18 insertions(+), 12 deletions(-) (limited to 'lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 78ef2e9c273..3aef0f71f4b 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,7 +1,13 @@ +2007-02-19 Juanma Barranquero + + * speedbar.el (speedbar-frame-mode, speedbar-frame-width) + (speedbar-show-unknown-files, speedbar-item-info-file-helper) + (speedbar-item-info-tag-helper): Doc fixes. + 2007-02-19 Kenichi Handa - * international/mule-cmds.el (locale-language-names): Map "eo" - to "Esperanto". + * international/mule-cmds.el (locale-language-names): + Map "eo" to "Esperanto". * language/european.el ("Esperanto"): New language environment. @@ -23,8 +29,8 @@ 2007-02-17 Chris Moore - * jka-cmpr-hook.el (jka-compr-compression-info-list): Recognize - backups of bz2 compressed files. + * jka-cmpr-hook.el (jka-compr-compression-info-list): + Recognize backups of bz2 compressed files. 2007-02-17 Eli Zaretskii @@ -33,8 +39,8 @@ 2007-02-17 Alin C. Soare (tiny change) - * emacs-lisp/lisp-mode.el (calculate-lisp-indent): Added - indentation for the constants of Lisp. + * emacs-lisp/lisp-mode.el (calculate-lisp-indent): + Add indentation for the constants of Lisp. 2007-02-16 Stefan Monnier diff --git a/lisp/speedbar.el b/lisp/speedbar.el index 711957d9cd0..87176d0c1c8 100644 --- a/lisp/speedbar.el +++ b/lisp/speedbar.el @@ -316,7 +316,7 @@ The default buffer is the buffer in the selected window in the attached frame." (defcustom speedbar-show-unknown-files nil "*Non-nil show files we can't expand with a ? in the expand button. -nil means don't show the file in the list." +A nil value means don't show the file in the list." :group 'speedbar :type 'boolean) @@ -975,7 +975,7 @@ directories.") ;;;###autoload (defun speedbar-frame-mode (&optional arg) "Enable or disable speedbar. Positive ARG means turn on, negative turn off. -nil means toggle. Once the speedbar frame is activated, a buffer in +A nil ARG means toggle. Once the speedbar frame is activated, a buffer in `speedbar-mode' will be displayed. Currently, only one speedbar is supported at a time. `speedbar-before-popup-hook' is called before popping up the speedbar frame. @@ -1071,7 +1071,7 @@ selected. If the speedbar frame is active, then select the attached frame." (defsubst speedbar-frame-width () "Return the width of the speedbar frame in characters. -nil if it doesn't exist." +Return nil if it doesn't exist." (frame-width speedbar-frame)) (defun speedbar-mode () @@ -1482,8 +1482,8 @@ This function can be replaced in `speedbar-mode-functions-list' as (defun speedbar-item-info-file-helper (&optional filename) "Display info about a file that is on the current line. -nil if not applicable. If FILENAME, then use that instead of reading -it from the speedbar buffer." +Return nil if not applicable. If FILENAME, then use that +instead of reading it from the speedbar buffer." (let* ((item (or filename (speedbar-line-file))) (attr (if item (file-attributes item) nil))) (if (and item attr) (speedbar-message "%s %-6d %s" (nth 8 attr) @@ -1492,7 +1492,7 @@ it from the speedbar buffer." (defun speedbar-item-info-tag-helper () "Display info about a tag that is on the current line. -nil if not applicable." +Return nil if not applicable." (save-excursion (beginning-of-line) (if (re-search-forward " [-+=]?> \\([^\n]+\\)" -- cgit v1.2.1 From c822571ac0c6cbd75ce3981da03513774a254375 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Mon, 19 Feb 2007 15:46:25 +0000 Subject: (list-buffers-noselect): Use explicit unicode code rather than the corresponding unicode char, to make the code more readable. --- lisp/ChangeLog | 6 ++++++ lisp/buff-menu.el | 7 ++++--- 2 files changed, 10 insertions(+), 3 deletions(-) (limited to 'lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 3aef0f71f4b..c26efc42ece 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,9 @@ +2007-02-19 Stefan Monnier + + * buff-menu.el (list-buffers-noselect): Use explicit unicode code + rather than the corresponding unicode char, to make the code + more readable. + 2007-02-19 Juanma Barranquero * speedbar.el (speedbar-frame-mode, speedbar-frame-width) diff --git a/lisp/buff-menu.el b/lisp/buff-menu.el index d67173ce733..f1336a417b9 100644 --- a/lisp/buff-menu.el +++ b/lisp/buff-menu.el @@ -721,7 +721,7 @@ For more information, see the function `buffer-menu'." (put-text-property 0 3 'face 'fixed-pitch header) ;; Add a "dummy" leading space to align the beginning of the header ;; line with the beginning of the text (rather than with the left - ;; scrollbar or the left fringe). –-Stef + ;; scrollbar or the left fringe). --Stef (setq header (concat (propertize " " 'display '(space :align-to 0)) header))) (with-current-buffer (get-buffer-create "*Buffer List*") @@ -729,8 +729,9 @@ For more information, see the function `buffer-menu'." (erase-buffer) (setq standard-output (current-buffer)) (unless Buffer-menu-use-header-line - ;; Use U+2014 (EM DASH) to underline if possible, else U+002D (HYPHEN-MINUS) - (let ((underline (if (char-displayable-p ?—) ?— ?-))) + ;; Use U+2014 (EM DASH) to underline if possible, else use ASCII + ;; (i.e. U+002D, HYPHEN-MINUS). + (let ((underline (if (char-displayable-p ?\u2014) ?\u2014 ?-))) (insert header (apply 'string (mapcar (lambda (c) -- cgit v1.2.1 From 8d683c8e16315d3cc114bc271b7ea493e8c24d2c Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Mon, 19 Feb 2007 18:48:58 +0000 Subject: (hide-sublevels): Keep empty last line, if available. --- lisp/ChangeLog | 2 ++ lisp/outline.el | 20 +++++++++++++------- 2 files changed, 15 insertions(+), 7 deletions(-) (limited to 'lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index c26efc42ece..7bea73a2329 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,5 +1,7 @@ 2007-02-19 Stefan Monnier + * outline.el (hide-sublevels): Keep empty last line, if available. + * buff-menu.el (list-buffers-noselect): Use explicit unicode code rather than the corresponding unicode char, to make the code more readable. diff --git a/lisp/outline.el b/lisp/outline.el index 20dfb2429ef..579997754f2 100644 --- a/lisp/outline.el +++ b/lisp/outline.el @@ -856,19 +856,25 @@ Show the heading too, if it is currently invisible." (t 1)))) (if (< levels 1) (error "Must keep at least one level of headers")) - (let (outline-view-change-hook) - (save-excursion - (goto-char (point-min)) - ;; Skip the prelude, if any. - (unless (outline-on-heading-p t) (outline-next-heading)) + (save-excursion + (let* (outline-view-change-hook + (beg (progn + (goto-char (point-min)) + ;; Skip the prelude, if any. + (unless (outline-on-heading-p t) (outline-next-heading)) + (point))) + (end (progn + (goto-char (point-max)) + ;; Keep empty last line, if available. + (if (bolp) (1- (point)) (point))))) ;; First hide everything. - (outline-flag-region (point) (point-max) t) + (outline-flag-region beg end t) ;; Then unhide the top level headers. (outline-map-region (lambda () (if (<= (funcall outline-level) levels) (outline-show-heading))) - (point) (point-max)))) + beg end))) (run-hooks 'outline-view-change-hook)) (defun hide-other () -- cgit v1.2.1 From fc2fb30ca60f74600060ea6fdb55560f87b350e1 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Mon, 19 Feb 2007 19:42:10 +0000 Subject: Remove the code inherited from CVSREAD and `cvs edit'. (vc-svn-use-edit): Remove unused config var. (vc-svn-update, vc-svn-revert): Checkout is always implicit. --- lisp/ChangeLog | 4 ++++ lisp/vc-svn.el | 44 ++++++++++++++------------------------------ 2 files changed, 18 insertions(+), 30 deletions(-) (limited to 'lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 7bea73a2329..794db2e53eb 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,5 +1,9 @@ 2007-02-19 Stefan Monnier + * vc-svn.el: Remove the code inherited from CVSREAD and `cvs edit'. + (vc-svn-use-edit): Remove unused config var. + (vc-svn-update, vc-svn-revert): Checkout is always implicit. + * outline.el (hide-sublevels): Keep empty last line, if available. * buff-menu.el (list-buffers-noselect): Use explicit unicode code diff --git a/lisp/vc-svn.el b/lisp/vc-svn.el index 730806fdcd0..1538a2a1ab3 100644 --- a/lisp/vc-svn.el +++ b/lisp/vc-svn.el @@ -85,18 +85,12 @@ If you want to force an empty list of arguments, use t." :type '(repeat string) :group 'vc) -(defconst vc-svn-use-edit nil - ;; Subversion does not provide this feature (yet). - "*Non-nil means to use `svn edit' to \"check out\" a file. -This is only meaningful if you don't use the implicit checkout model -\(i.e. if you have $SVNREAD set)." - ;; :type 'boolean - ;; :version "22.1" - ;; :group 'vc - ) - -(defvar vc-svn-admin-directory - (cond ((and (eq system-type 'windows-nt) +;; We want to autoload it for use by the autoloaded version of +;; vc-svn-registered, but we want the value to be compiled at startup, not +;; at dump time. +;; ;;;###autoload +(defconst vc-svn-admin-directory + (cond ((and (memq system-type '(cygwin windows-nt ms-dos)) (getenv "SVN_ASP_DOT_NET_HACK")) "_svn") (t ".svn")) @@ -111,12 +105,12 @@ This is only meaningful if you don't use the implicit checkout model ;;;###autoload (defun vc-svn-registered (f) ;;;###autoload (let ((admin-dir (cond ((and (eq system-type 'windows-nt) -;;;###autoload (getenv "SVN_ASP_DOT_NET_HACK")) -;;;###autoload "_svn") -;;;###autoload (t ".svn")))) +;;;###autoload (getenv "SVN_ASP_DOT_NET_HACK")) +;;;###autoload "_svn") +;;;###autoload (t ".svn")))) ;;;###autoload (when (file-readable-p (expand-file-name -;;;###autoload (concat admin-dir "/entries") -;;;###autoload (file-name-directory f))) +;;;###autoload (concat admin-dir "/entries") +;;;###autoload (file-name-directory f))) ;;;###autoload (load "vc-svn") ;;;###autoload (vc-svn-registered f)))) @@ -274,13 +268,8 @@ This is only possible if SVN is responsible for FILE's directory.") (defun vc-svn-update (file editable rev switches) (if (and (file-exists-p file) (not rev)) - ;; If no revision was specified, just make the file writable - ;; if necessary (using `svn-edit' if requested). - (and editable (not (eq (vc-svn-checkout-model file) 'implicit)) - (if vc-svn-use-edit - (vc-svn-command nil 0 file "edit") - (set-file-modes file (logior (file-modes file) 128)) - (if (equal file buffer-file-name) (toggle-read-only -1)))) + ;; If no revision was specified, there's nothing to do. + nil ;; Check out a particular version (or recreate the file). (vc-file-setprop file 'vc-workfile-version nil) (apply 'vc-svn-command nil 0 file @@ -302,12 +291,7 @@ This is only possible if SVN is responsible for FILE's directory.") (defun vc-svn-revert (file &optional contents-done) "Revert FILE to the version it was based on." (unless contents-done - (vc-svn-command nil 0 file "revert")) - (unless (eq (vc-checkout-model file) 'implicit) - (if vc-svn-use-edit - (vc-svn-command nil 0 file "unedit") - ;; Make the file read-only by switching off all w-bits - (set-file-modes file (logand (file-modes file) 3950))))) + (vc-svn-command nil 0 file "revert"))) (defun vc-svn-merge (file first-version &optional second-version) "Merge changes into current working copy of FILE. -- cgit v1.2.1 From 3bff434b8f6ac69a84c8777c1b88d43cb9d2534f Mon Sep 17 00:00:00 2001 From: "Kim F. Storm" Date: Thu, 22 Feb 2007 00:32:51 +0000 Subject: (widget-default-create): Undo 2007-02-04 change. (editable-field): Document need to put some text before the %v escape in :format string. --- lisp/wid-edit.el | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) (limited to 'lisp') diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el index d0ff5c0b956..1f2dba79439 100644 --- a/lisp/wid-edit.el +++ b/lisp/wid-edit.el @@ -404,7 +404,7 @@ new value.") ;; We want to avoid the face with image buttons. (unless (widget-get widget :suppress-face) (overlay-put overlay 'face (widget-apply widget :button-face-get)) - (overlay-put overlay 'mouse-face + (overlay-put overlay 'mouse-face (widget-apply widget :mouse-face-get))) (overlay-put overlay 'pointer 'hand) (overlay-put overlay 'follow-link follow-link) @@ -1509,7 +1509,7 @@ If that does not exists, call the value of `widget-complete-field'." (widget-apply widget :value-create))) (let ((from (point-min-marker)) (to (point-max-marker))) - (set-marker-insertion-type from nil) + (set-marker-insertion-type from t) (set-marker-insertion-type to nil) (widget-put widget :from from) (widget-put widget :to to))) @@ -1852,7 +1852,9 @@ If END is omitted, it defaults to the length of LIST." ;;; The `editable-field' Widget. (define-widget 'editable-field 'default - "An editable text field." + "An editable text field. +Note: In an `editable-field' widget, the `%v' escape must be preceeded +by some other text in the `:format' string (if specified)." :convert-widget 'widget-value-convert-widget :keymap widget-field-keymap :format "%v" -- cgit v1.2.1 From 10dbcdd730d785216fc6bcfb9f8286d8922026f5 Mon Sep 17 00:00:00 2001 From: "Kim F. Storm" Date: Thu, 22 Feb 2007 00:33:58 +0000 Subject: (editable-field): Fix typo in last change. --- lisp/wid-edit.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'lisp') diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el index 1f2dba79439..035f54b8980 100644 --- a/lisp/wid-edit.el +++ b/lisp/wid-edit.el @@ -1853,7 +1853,7 @@ If END is omitted, it defaults to the length of LIST." (define-widget 'editable-field 'default "An editable text field. -Note: In an `editable-field' widget, the `%v' escape must be preceeded +Note: In an `editable-field' widget, the `%v' escape must be preceded by some other text in the `:format' string (if specified)." :convert-widget 'widget-value-convert-widget :keymap widget-field-keymap -- cgit v1.2.1 From 3c00238a4a91d0b81e9eb87586ade7c5e475ebdc Mon Sep 17 00:00:00 2001 From: "Kim F. Storm" Date: Thu, 22 Feb 2007 00:35:28 +0000 Subject: *** empty log message *** --- lisp/ChangeLog | 6 ++++++ 1 file changed, 6 insertions(+) (limited to 'lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 794db2e53eb..99e6f1f3d14 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,9 @@ +2007-02-22 Kim F. Storm + + * wid-edit.el (widget-default-create): Undo 2007-02-04 change. + (editable-field): Document need to put some text before the %v + escape in :format string. + 2007-02-19 Stefan Monnier * vc-svn.el: Remove the code inherited from CVSREAD and `cvs edit'. -- cgit v1.2.1 From 6a8cc02d1c1f69a0447cd8956e2ad99ea5302414 Mon Sep 17 00:00:00 2001 From: "J.D. Smith" Date: Thu, 22 Feb 2007 20:05:16 +0000 Subject: (idlwave-shell-mode): Clean up pending commands, for restart. (idlwave-shell-current-module): Fix handling of module name by type. (idlwave-shell-break-in): Update type handling. (idlwave-shell-bp-get): Encode type in BP structure. (idlwave-shell-set-bp): Fix setting condition on disabled BPs. (idlwave-shell-module-source-query): Query routine info based on type. Fix path parsing for non-compiled files. (idlwave-shell-module-source-filter): Don't signal error in filter if no source found. (idlwave-shell-set-bp-in-module): Use fallback source to prevent filter race. --- lisp/ChangeLog | 16 +++++++ lisp/progmodes/idlw-shell.el | 103 +++++++++++++++++++++++++++---------------- 2 files changed, 81 insertions(+), 38 deletions(-) (limited to 'lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 99e6f1f3d14..933c2f04c26 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,19 @@ +2007-02-22 J.D. Smith + + * progmodes/idlw-shell.el (idlwave-shell-mode): Clean up pending + commands, for restart. + (idlwave-shell-current-module): Fix handling of module name by + type. + (idlwave-shell-break-in): Update type handling. + (idlwave-shell-bp-get): Encode type in BP structure. + (idlwave-shell-set-bp): Fix setting condition on disabled BPs. + (idlwave-shell-module-source-query): Query routine info based on + type. Fix path parsing for non-compiled files. + (idlwave-shell-module-source-filter): Don't signal error in + filter if no source found. + (idlwave-shell-set-bp-in-module): Use fallback source to prevent + filter race. + 2007-02-22 Kim F. Storm * wid-edit.el (widget-default-create): Undo 2007-02-04 change. diff --git a/lisp/progmodes/idlw-shell.el b/lisp/progmodes/idlw-shell.el index 64f359aa1e7..ecfdd035c19 100644 --- a/lisp/progmodes/idlw-shell.el +++ b/lisp/progmodes/idlw-shell.el @@ -1026,7 +1026,8 @@ IDL has currently stepped.") (setq idlwave-shell-ready nil) (setq idlwave-shell-bp-alist nil) (idlwave-shell-update-bp-overlays) ; Throw away old overlays - (setq idlwave-shell-sources-alist nil) + (setq idlwave-shell-post-command-hook nil ;clean up any old stuff + idlwave-shell-sources-alist nil) (setq idlwave-shell-default-directory default-directory) (setq idlwave-shell-hide-output nil) @@ -1303,7 +1304,7 @@ output to complete and the next prompt to arrive before returning \(useful if you need an answer now\). IDL is considered ready if the prompt is present and if `idlwave-shell-ready' is non-nil. -If SHOW-IF-ERROR is non-nil, show the output it it contains an error +If SHOW-IF-ERROR is non-nil, show the output if it contains an error message, independent of what HIDE is set to." ; (setq hide nil) ; FIXME: turn this on for debugging only @@ -2621,7 +2622,10 @@ Returns nil if unable to obtain a module name." (widen) (save-excursion (if (idlwave-prev-index-position) - (upcase (idlwave-unit-name))))))) + (let* ((module (idlwave-what-module)) + (name (idlwave-make-full-name (nth 2 module) (car module))) + (type (nth 1 module))) + (list (upcase name) type))))))) (defun idlwave-shell-clear-current-bp () "Remove breakpoint at current line. @@ -2634,7 +2638,10 @@ at a breakpoint." (defun idlwave-shell-toggle-enable-current-bp (&optional bp force no-update) - "Disable or enable current bp." + "Disable or enable current breakpoint or a breakpoint passed in BP. +If FORCE is 'disable or 'enable, for that condition instead of +toggling. If NO-UPDATE is non-nil, don't update the breakpoint +list after toggling." (interactive) (let* ((bp (or bp (idlwave-shell-find-current-bp))) (disabled (idlwave-shell-bp-get bp 'disabled))) @@ -2685,22 +2692,28 @@ The command looks for an identifier near point and sets a breakpoint for the first line of the corresponding module. If MODULE is `t', set in the current routine." (interactive) - (let ((module (idlwave-fix-module-if-obj_new (idlwave-what-module)))) + (let* ((module (idlwave-fix-module-if-obj_new (idlwave-what-module))) + (type (nth 1 module)) + (name (car module)) + (class (nth 2 module))) (if module (progn (setq module (idlwave-make-full-name (nth 2 module) (car module))) - (idlwave-shell-module-source-query module) - (idlwave-shell-set-bp-in-module module)) + (idlwave-shell-module-source-query module type) + (idlwave-shell-set-bp-in-module name type class)) (error "No identifier at point")))) -(defun idlwave-shell-set-bp-in-module (module) +(defun idlwave-shell-set-bp-in-module (name type class) "Set breakpoint in module. Assumes that `idlwave-shell-sources-alist' contains an entry for that module." - (let ((source-file (car-safe - (cdr-safe - (assoc (upcase module) - idlwave-shell-sources-alist)))) + (let ((source-file + (car-safe (cdr-safe + (or + (assoc (upcase (idlwave-make-full-name class name)) + idlwave-shell-sources-alist) + (nth 3 (idlwave-best-rinfo-assoc name type class + (idlwave-routines))))))) buf) (if (or (not source-file) (not (file-regular-p source-file)) @@ -3376,12 +3389,12 @@ Queries IDL using the string in `idlwave-shell-bp-query'." 'hide)) (defun idlwave-shell-bp-get (bp &optional item) - "Get a value for a breakpoint. -BP has the form of elements in idlwave-shell-bp-alist. Optional -second arg ITEM is the particular value to retrieve. ITEM can be -'file, 'line, 'index, 'module, 'count, 'cmd, 'condition, 'disabled or -'data. 'data returns a list of 'count, 'cmd and 'condition. Defaults -to 'index." + "Get a value for a breakpoint. BP has the form of elements in +idlwave-shell-bp-alist. Optional second arg ITEM is the +particular value to retrieve. ITEM can be 'file, 'line, 'index, +'module, 'count, 'cmd, 'condition, 'disabled, 'type, or +'data. 'data returns a list of 'count, 'cmd and 'condition. +Defaults to 'index." (cond ;; Frame ((eq item 'line) (nth 1 (car bp))) @@ -3393,7 +3406,12 @@ to 'index." ((eq item 'condition) (nth 2 (cdr (cdr bp)))) ((eq item 'disabled) (nth 3 (cdr (cdr bp)))) ;; IDL breakpoint info - ((eq item 'module) (nth 1 (car (cdr bp)))) + ((eq item 'module) + (let ((module (nth 1 (car (cdr bp))))) + (if (listp module) (car module) module))) + ((eq item 'type) + (let ((module (nth 1 (car (cdr bp))))) + (if (listp module) (nth 1 module)))) ;; index - default (t (nth 0 (car (cdr bp)))))) @@ -3486,7 +3504,9 @@ If BP frame is in `idlwave-shell-bp-alist' updates the breakpoint data." and third args, DATA and MODULE, are optional. Returns a breakpoint of the format used in `idlwave-shell-bp-alist'. Can be used in commands attempting match a breakpoint in `idlwave-shell-bp-alist'." - (cons frame (cons (list nil module) data))) + (cons frame ;; (file line) + (cons (list nil module) ;; (index_id (module type) | module) + data))) ;; (count command condition disabled) (defvar idlwave-shell-old-bp nil "List of breakpoints previous to setting a new breakpoint.") @@ -3522,7 +3542,8 @@ specified. If NO-SHOW is non-nil, don't do any updating." 'hide) ;; Get sources for this routine in the sources list - (idlwave-shell-module-source-query (idlwave-shell-bp-get bp 'module)) + (idlwave-shell-module-source-query (idlwave-shell-bp-get bp 'module) + (idlwave-shell-bp-get bp 'type)) (let* ((arg (idlwave-shell-bp-get bp 'count)) (key (cond @@ -3535,7 +3556,11 @@ specified. If NO-SHOW is non-nil, don't do any updating." (disabled (idlwave-shell-bp-get bp 'disabled)) (key (concat key (if condition (concat ",CONDITION=\"" condition "\"")))) - (key (concat key (if disabled ",/DISABLE"))) + ;; IDL can't simultaneously set a condition and disable a + ;; breakpoint, but it does keep both of these when resetting + ;; the same BP. We assume DISABLE and CONDITION are not set + ;; together for a newly created breakpoint. + (key (concat key (if (and disabled (not condition)) ",/DISABLE"))) (line (idlwave-shell-bp-get bp 'line))) (idlwave-shell-send-command (concat "breakpoint,'" @@ -3936,30 +3961,31 @@ Elements of the alist have the form: (module name . (source-file-truename idlwave-internal-filename)).") -(defun idlwave-shell-module-source-query (module) - "Determine the source file for a given module." +(defun idlwave-shell-module-source-query (module &optional type) + "Determine the source file for a given module. +Query as a function if TYPE set to something beside 'pro." (if module (idlwave-shell-send-command - (format "print,(routine_info('%s',/SOURCE)).PATH" module) + (format "print,(routine_info('%s',/SOURCE%s)).PATH" module + (if (eq type 'pro) "" ",/FUNCTIONS")) `(idlwave-shell-module-source-filter ,module) - 'hide))) + 'hide 'wait))) (defun idlwave-shell-module-source-filter (module) "Get module source, and update idlwave-shell-sources-alist." (let ((old (assoc (upcase module) idlwave-shell-sources-alist)) filename) - (if (string-match "\.PATH *[\n\r]\\([^\r\n]+\\)[\n\r]" - idlwave-shell-command-output) - (setq filename (substring idlwave-shell-command-output - (match-beginning 1) (match-end 1))) - (error "No file matching module found.")) - (if old - (setcdr old (list (idlwave-shell-file-name filename) filename)) - (setq idlwave-shell-sources-alist - (append idlwave-shell-sources-alist - (list (cons (upcase module) - (list (idlwave-shell-file-name filename) - filename)))))))) + (when (string-match "\.PATH *[\n\r]\\([^%][^\r\n]+\\)[\n\r]" + idlwave-shell-command-output) + (setq filename (substring idlwave-shell-command-output + (match-beginning 1) (match-end 1))) + (if old + (setcdr old (list (idlwave-shell-file-name filename) filename)) + (setq idlwave-shell-sources-alist + (append idlwave-shell-sources-alist + (list (cons (upcase module) + (list (idlwave-shell-file-name filename) + filename))))))))) (defun idlwave-shell-sources-query () "Determine source files for all IDL compiled procedures. @@ -4101,6 +4127,7 @@ Otherwise, just expand the file name." ;(define-key idlwave-shell-mode-map "\M-?" 'comint-dynamic-list-completions) ;(define-key idlwave-shell-mode-map "\t" 'comint-dynamic-complete) + (define-key idlwave-shell-mode-map "\C-w" 'comint-kill-region) (define-key idlwave-shell-mode-map "\t" 'idlwave-shell-complete) (define-key idlwave-shell-mode-map "\M-\t" 'idlwave-shell-complete) -- cgit v1.2.1 From ecd3d5570eb95f19f5e82d600949dc565810737c Mon Sep 17 00:00:00 2001 From: "J.D. Smith" Date: Thu, 22 Feb 2007 20:17:52 +0000 Subject: *** empty log message *** --- lisp/ChangeLog | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 933c2f04c26..028610df752 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -6,7 +6,8 @@ type. (idlwave-shell-break-in): Update type handling. (idlwave-shell-bp-get): Encode type in BP structure. - (idlwave-shell-set-bp): Fix setting condition on disabled BPs. + (idlwave-shell-set-bp): Fix setting condition/count on disabled + BPs. (idlwave-shell-module-source-query): Query routine info based on type. Fix path parsing for non-compiled files. (idlwave-shell-module-source-filter): Don't signal error in -- cgit v1.2.1 From fbc232f4e2e0e7581c57316999623a82f2b5b0ce Mon Sep 17 00:00:00 2001 From: "J.D. Smith" Date: Thu, 22 Feb 2007 20:18:17 +0000 Subject: (idlwave-shell-set-bp): Fix setting condition/count on disabled BPs. --- lisp/progmodes/idlw-shell.el | 27 +++++++++++++-------------- 1 file changed, 13 insertions(+), 14 deletions(-) (limited to 'lisp') diff --git a/lisp/progmodes/idlw-shell.el b/lisp/progmodes/idlw-shell.el index ecfdd035c19..aa2d1b32d10 100644 --- a/lisp/progmodes/idlw-shell.el +++ b/lisp/progmodes/idlw-shell.el @@ -3545,22 +3545,21 @@ specified. If NO-SHOW is non-nil, don't do any updating." (idlwave-shell-module-source-query (idlwave-shell-bp-get bp 'module) (idlwave-shell-bp-get bp 'type)) (let* - ((arg (idlwave-shell-bp-get bp 'count)) - (key (cond - ((not (and arg (numberp arg))) "") - ((= arg 1) - ",/once") - ((> arg 1) - (format ",after=%d" arg)))) + ((count (idlwave-shell-bp-get bp 'count)) (condition (idlwave-shell-bp-get bp 'condition)) (disabled (idlwave-shell-bp-get bp 'disabled)) - (key (concat key - (if condition (concat ",CONDITION=\"" condition "\"")))) - ;; IDL can't simultaneously set a condition and disable a - ;; breakpoint, but it does keep both of these when resetting - ;; the same BP. We assume DISABLE and CONDITION are not set - ;; together for a newly created breakpoint. - (key (concat key (if (and disabled (not condition)) ",/DISABLE"))) + (key (concat (if (and count (numberp count)) + (cond + ((= count 1) ",/once") + ((> count 1) (format ",after=%d" count)))) + (if condition (concat ",CONDITION=\"" condition "\"")) + ;; IDL can't simultaneously set a condition/count + ;; and disable a breakpoint, but it does keep both + ;; of these when resetting the same BP. We assume + ;; DISABLE and CONDITION/COUNT are not set + ;; together for a newly created breakpoint. + (if (and disabled (not condition) (not count)) + ",/DISABLE"))) (line (idlwave-shell-bp-get bp 'line))) (idlwave-shell-send-command (concat "breakpoint,'" -- cgit v1.2.1 From 7596c645dcc968ae10d6945a8fce6220ec191bb9 Mon Sep 17 00:00:00 2001 From: Chong Yidong Date: Fri, 23 Feb 2007 16:26:16 +0000 Subject: * startup.el (fancy-splash-screens): Make cursor-type buffer-local in splash screen. --- lisp/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) (limited to 'lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 028610df752..47494b59ef9 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,8 @@ +2007-02-23 Chong Yidong + + * startup.el (fancy-splash-screens): Make cursor-type buffer-local + in splash screen. + 2007-02-22 J.D. Smith * progmodes/idlw-shell.el (idlwave-shell-mode): Clean up pending -- cgit v1.2.1 From 333e87377557d0cc7ef26bc61de85737881351d4 Mon Sep 17 00:00:00 2001 From: Chong Yidong Date: Fri, 23 Feb 2007 16:26:28 +0000 Subject: (fancy-splash-screens): Make cursor-type buffer-local in splash screen. --- lisp/startup.el | 1 + 1 file changed, 1 insertion(+) (limited to 'lisp') diff --git a/lisp/startup.el b/lisp/startup.el index e2a80088a3e..5be0e98b4bb 100644 --- a/lisp/startup.el +++ b/lisp/startup.el @@ -1388,6 +1388,7 @@ the user caused an input event that is bound in `special-event-map'" (save-selected-window (select-frame frame) (switch-to-buffer " GNU Emacs") + (make-local-variable 'cursor-type) (setq splash-buffer (current-buffer)) (catch 'stop-splashing (unwind-protect -- cgit v1.2.1 From fc858181de5a588dfcdde19c1158ee8bdc2a2eb7 Mon Sep 17 00:00:00 2001 From: Chong Yidong Date: Fri, 23 Feb 2007 17:35:22 +0000 Subject: Regenerate. --- lisp/ldefs-boot.el | 397 ++++++++++++++++++++++++++++++----------------------- 1 file changed, 225 insertions(+), 172 deletions(-) (limited to 'lisp') diff --git a/lisp/ldefs-boot.el b/lisp/ldefs-boot.el index 6381034904f..efe2784a905 100644 --- a/lisp/ldefs-boot.el +++ b/lisp/ldefs-boot.el @@ -4,7 +4,7 @@ ;;;### (autoloads (5x5-crack 5x5-crack-xor-mutate 5x5-crack-mutating-best ;;;;;; 5x5-crack-mutating-current 5x5-crack-randomly 5x5) "5x5" -;;;;;; "play/5x5.el" (17851 10865)) +;;;;;; "play/5x5.el" (17876 36878)) ;;; Generated autoloads from play/5x5.el (autoload (quote 5x5) "5x5" "\ @@ -46,7 +46,7 @@ Attempt to crack 5x5 by mutating the best solution. \(fn)" t nil) (autoload (quote 5x5-crack-xor-mutate) "5x5" "\ -Attempt to crack 5x5 by xor the current and best solution. +Attempt to crack 5x5 by xoring the current and best solution. Mutate the result. \(fn)" t nil) @@ -56,7 +56,7 @@ Attempt to find a solution for 5x5. 5x5-crack takes the argument BREEDER which should be a function that takes two parameters, the first will be a grid vector array that is the current -solution and the second will be the best solution so far. The function +solution and the second will be the best solution so far. The function should return a grid vector array that is the new solution. \(fn BREEDER)" t nil) @@ -168,7 +168,7 @@ Completion is available. ;;;;;; change-log-mode add-change-log-entry-other-window add-change-log-entry ;;;;;; find-change-log prompt-for-change-log-name add-log-mailing-address ;;;;;; add-log-full-name add-log-current-defun-function) "add-log" -;;;;;; "add-log.el" (17851 10813)) +;;;;;; "add-log.el" (17852 50694)) ;;; Generated autoloads from add-log.el (defvar add-log-current-defun-function nil "\ @@ -827,7 +827,7 @@ setup for auto-startup. ;;;*** ;;;### (autoloads (ange-ftp-hook-function ange-ftp-reread-dir) "ange-ftp" -;;;;;; "net/ange-ftp.el" (17851 10863)) +;;;;;; "net/ange-ftp.el" (17856 1487)) ;;; Generated autoloads from net/ange-ftp.el (defalias (quote ange-ftp-re-read-dir) (quote ange-ftp-reread-dir)) @@ -1557,7 +1557,7 @@ insert a template for the file depending on the mode of the buffer. ;;;### (autoloads (batch-update-autoloads update-directory-autoloads ;;;;;; update-file-autoloads) "autoload" "emacs-lisp/autoload.el" -;;;;;; (17851 10852)) +;;;;;; (17860 50251)) ;;; Generated autoloads from emacs-lisp/autoload.el (autoload (quote update-file-autoloads) "autoload" "\ @@ -1792,7 +1792,7 @@ non-interactive use see also `benchmark-run' and ;;;*** ;;;### (autoloads (bibtex-mode) "bibtex" "textmodes/bibtex.el" (17851 -;;;;;; 10872)) +;;;;;; 39452)) ;;; Generated autoloads from textmodes/bibtex.el (autoload (quote bibtex-mode) "bibtex" "\ @@ -2668,9 +2668,10 @@ Also see `make-text-button'. ;;;;;; batch-byte-compile-if-not-done display-call-tree byte-compile ;;;;;; compile-defun byte-compile-file byte-recompile-directory ;;;;;; byte-force-recompile byte-compile-warnings-safe-p) "bytecomp" -;;;;;; "emacs-lisp/bytecomp.el" (17851 10852)) +;;;;;; "emacs-lisp/bytecomp.el" (17873 60335)) ;;; Generated autoloads from emacs-lisp/bytecomp.el (put 'byte-compile-dynamic 'safe-local-variable 'booleanp) +(put 'byte-compile-disable-print-circle 'safe-local-variable 'booleanp) (put 'byte-compile-dynamic-docstrings 'safe-local-variable 'booleanp) (autoload (quote byte-compile-warnings-safe-p) "bytecomp" "\ @@ -2705,7 +2706,8 @@ recompile every `.el' file that already has a `.elc' file. (autoload (quote byte-compile-file) "bytecomp" "\ Compile a file of Lisp code named FILENAME into a file of byte code. -The output file's name is made by appending `c' to the end of FILENAME. +The output file's name is generated by passing FILENAME to the +`byte-compile-dest-file' function (which see). With prefix arg (noninteractively: 2nd arg), LOAD the file after compiling. The value is non-nil if there were no errors, nil if errors. @@ -2875,8 +2877,8 @@ Not documented ;;;*** -;;;### (autoloads (calculator) "calculator" "calculator.el" (17851 -;;;;;; 10816)) +;;;### (autoloads (calculator) "calculator" "calculator.el" (17871 +;;;;;; 15753)) ;;; Generated autoloads from calculator.el (autoload (quote calculator) "calculator" "\ @@ -3502,7 +3504,7 @@ it fails. ;;;*** ;;;### (autoloads (c-guess-basic-syntax) "cc-engine" "progmodes/cc-engine.el" -;;;;;; (17851 10867)) +;;;;;; (17859 56529)) ;;; Generated autoloads from progmodes/cc-engine.el (autoload (quote c-guess-basic-syntax) "cc-engine" "\ @@ -3730,7 +3732,7 @@ and exists only for compatibility reasons. ;;;*** -;;;### (autoloads nil "cc-vars" "progmodes/cc-vars.el" (17851 10867)) +;;;### (autoloads nil "cc-vars" "progmodes/cc-vars.el" (17854 10614)) ;;; Generated autoloads from progmodes/cc-vars.el (put 'c-basic-offset 'safe-local-variable 'integerp) (put 'c-backslash-column 'safe-local-variable 'integerp) @@ -4462,7 +4464,7 @@ read/written by MS-DOS software, or for display on the MS-DOS terminal. ;;;### (autoloads (comint-redirect-results-list-from-process comint-redirect-results-list ;;;;;; comint-redirect-send-command-to-process comint-redirect-send-command ;;;;;; comint-run make-comint make-comint-in-buffer) "comint" "comint.el" -;;;;;; (17851 10817)) +;;;;;; (17856 42110)) ;;; Generated autoloads from comint.el (defvar comint-output-filter-functions (quote (comint-postoutput-scroll-to-bottom comint-watch-for-password-prompt)) "\ @@ -5524,7 +5526,7 @@ INHERIT-INPUT-METHOD. ;;;*** ;;;### (autoloads (cua-selection-mode cua-mode) "cua-base" "emulation/cua-base.el" -;;;;;; (17851 10853)) +;;;;;; (17853 23392)) ;;; Generated autoloads from emulation/cua-base.el (defvar cua-mode nil "\ @@ -5988,7 +5990,7 @@ Mode used for cvs status output. ;;;*** ;;;### (autoloads (global-cwarn-mode turn-on-cwarn-mode cwarn-mode) -;;;;;; "cwarn" "progmodes/cwarn.el" (17851 10867)) +;;;;;; "cwarn" "progmodes/cwarn.el" (17860 50288)) ;;; Generated autoloads from progmodes/cwarn.el (autoload (quote cwarn-mode) "cwarn" "\ @@ -6476,7 +6478,7 @@ the first time the mode is used. ;;;*** ;;;### (autoloads (describe-char describe-text-properties) "descr-text" -;;;;;; "descr-text.el" (17851 10822)) +;;;;;; "descr-text.el" (17875 14312)) ;;; Generated autoloads from descr-text.el (autoload (quote describe-text-properties) "descr-text" "\ @@ -6816,7 +6818,7 @@ With prefix arg, prompt for diff switches. ;;;*** ;;;### (autoloads (diff-minor-mode diff-mode) "diff-mode" "diff-mode.el" -;;;;;; (17851 10822)) +;;;;;; (17867 21034)) ;;; Generated autoloads from diff-mode.el (autoload (quote diff-mode) "diff-mode" "\ @@ -6846,7 +6848,7 @@ Minor mode for viewing/editing context diffs. ;;;;;; dired dired-copy-preserve-time dired-dwim-target dired-keep-marker-symlink ;;;;;; dired-keep-marker-hardlink dired-keep-marker-copy dired-keep-marker-rename ;;;;;; dired-trivial-filenames dired-ls-F-marks-symlinks dired-listing-switches) -;;;;;; "dired" "dired.el" (17851 10823)) +;;;;;; "dired" "dired.el" (17852 50694)) ;;; Generated autoloads from dired.el (defvar dired-listing-switches "-al" "\ @@ -6856,7 +6858,7 @@ may contain even `F', `b', `i' and `s'. See also the variable `dired-ls-F-marks-symlinks' concerning the `F' switch. On systems such as MS-DOS and MS-Windows, which use `ls' emulation in Lisp, some of the `ls' switches are not supported; see the doc string of -`insert-directory' on `ls-lisp.el' for more details.") +`insert-directory' in `ls-lisp.el' for more details.") (custom-autoload (quote dired-listing-switches) "dired" t) @@ -7051,7 +7053,7 @@ Keybindings: ;;;;;; dired-run-shell-command dired-do-shell-command dired-clean-directory ;;;;;; dired-do-print dired-do-touch dired-do-chown dired-do-chgrp ;;;;;; dired-do-chmod dired-compare-directories dired-backup-diff -;;;;;; dired-diff) "dired-aux" "dired-aux.el" (17851 10822)) +;;;;;; dired-diff) "dired-aux" "dired-aux.el" (17859 27906)) ;;; Generated autoloads from dired-aux.el (autoload (quote dired-diff) "dired-aux" "\ @@ -7291,6 +7293,8 @@ with the same names that the files currently have. The default suggested for the target directory depends on the value of `dired-dwim-target', which see. +For relative symlinks, use \\[dired-do-relsymlink]. + \(fn &optional ARG)" t nil) (autoload (quote dired-do-hardlink) "dired-aux" "\ @@ -7463,7 +7467,8 @@ true then the type of the file linked to by FILE is printed instead. ;;;*** -;;;### (autoloads (dired-jump) "dired-x" "dired-x.el" (17851 10823)) +;;;### (autoloads (dired-do-relsymlink dired-jump) "dired-x" "dired-x.el" +;;;;;; (17859 56528)) ;;; Generated autoloads from dired-x.el (autoload (quote dired-jump) "dired-x" "\ @@ -7475,6 +7480,21 @@ buffer and try again. \(fn &optional OTHER-WINDOW)" t nil) +(autoload (quote dired-do-relsymlink) "dired-x" "\ +Relative symlink all marked (or next ARG) files into a directory. +Otherwise make a relative symbolic link to the current file. +This creates relative symbolic links like + + foo -> ../bar/foo + +not absolute ones like + + foo -> /ugly/file/name/that/may/change/any/day/bar/foo + +For absolute symlinks, use \\[dired-do-symlink]. + +\(fn &optional ARG)" t nil) + ;;;*** ;;;### (autoloads (dirtrack) "dirtrack" "dirtrack.el" (17851 10823)) @@ -7511,11 +7531,12 @@ redefine OBJECT if it is a symbol. ;;;*** -;;;### (autoloads (standard-display-european create-glyph standard-display-underline -;;;;;; standard-display-graphic standard-display-g1 standard-display-ascii -;;;;;; standard-display-default standard-display-8bit describe-current-display-table -;;;;;; describe-display-table set-display-table-slot display-table-slot -;;;;;; make-display-table) "disp-table" "disp-table.el" (17851 10823)) +;;;### (autoloads (standard-display-european glyph-face glyph-char +;;;;;; make-glyph-code create-glyph standard-display-underline standard-display-graphic +;;;;;; standard-display-g1 standard-display-ascii standard-display-default +;;;;;; standard-display-8bit describe-current-display-table describe-display-table +;;;;;; set-display-table-slot display-table-slot make-display-table) +;;;;;; "disp-table" "disp-table.el" (17875 14312)) ;;; Generated autoloads from disp-table.el (autoload (quote make-display-table) "disp-table" "\ @@ -7588,6 +7609,21 @@ Allocate a glyph code to display by sending STRING to the terminal. \(fn STRING)" nil nil) +(autoload (quote make-glyph-code) "disp-table" "\ +Return a glyph code representing char CHAR with face FACE. + +\(fn CHAR &optional FACE)" nil nil) + +(autoload (quote glyph-char) "disp-table" "\ +Return the character of glyph code GLYPH. + +\(fn GLYPH)" nil nil) + +(autoload (quote glyph-face) "disp-table" "\ +Return the face of glyph code GLYPH, or nil if glyph has default face. + +\(fn GLYPH)" nil nil) + (autoload (quote standard-display-european) "disp-table" "\ Semi-obsolete way to toggle display of ISO 8859 European characters. @@ -7731,8 +7767,8 @@ Play sounds in message buffers. ;;;*** ;;;### (autoloads (easy-mmode-defsyntax easy-mmode-defmap easy-mmode-define-keymap -;;;;;; define-global-minor-mode define-minor-mode) "easy-mmode" -;;;;;; "emacs-lisp/easy-mmode.el" (17851 10852)) +;;;;;; define-globalized-minor-mode define-minor-mode) "easy-mmode" +;;;;;; "emacs-lisp/easy-mmode.el" (17860 50311)) ;;; Generated autoloads from emacs-lisp/easy-mmode.el (defalias (quote easy-mmode-define-minor-mode) (quote define-minor-mode)) @@ -7777,9 +7813,11 @@ For example, you could write \(fn MODE DOC &optional INIT-VALUE LIGHTER KEYMAP &rest BODY)" nil (quote macro)) -(defalias (quote easy-mmode-define-global-mode) (quote define-global-minor-mode)) +(defalias (quote easy-mmode-define-global-mode) (quote define-globalized-minor-mode)) -(autoload (quote define-global-minor-mode) "easy-mmode" "\ +(defalias (quote define-global-minor-mode) (quote define-globalized-minor-mode)) + +(autoload (quote define-globalized-minor-mode) "easy-mmode" "\ Make a global mode GLOBAL-MODE corresponding to buffer-local minor MODE. TURN-ON is a function that will be called with no args in every buffer and that should try to turn MODE on if applicable for that buffer. @@ -7789,7 +7827,7 @@ KEYS is a list of CL-style keyword arguments. As the minor mode which see. In particular, :group specifies the custom group. The most useful keywords are those that are passed on to the `defcustom'. It normally makes no sense to pass the :lighter - or :keymap keywords to `define-global-minor-mode', since these + or :keymap keywords to `define-globalized-minor-mode', since these are usually passed to the buffer-local version of the minor mode. If MODE's set-up depends on the major mode in effect when it was @@ -7974,7 +8012,7 @@ To implement dynamic menus, either call this from ;;;;;; ebnf-eps-directory ebnf-spool-region ebnf-spool-buffer ebnf-spool-file ;;;;;; ebnf-spool-directory ebnf-print-region ebnf-print-buffer ;;;;;; ebnf-print-file ebnf-print-directory ebnf-customize) "ebnf2ps" -;;;;;; "progmodes/ebnf2ps.el" (17851 10867)) +;;;;;; "progmodes/ebnf2ps.el" (17859 56529)) ;;; Generated autoloads from progmodes/ebnf2ps.el (autoload (quote ebnf-customize) "ebnf2ps" "\ @@ -8086,9 +8124,9 @@ See also `ebnf-eps-buffer'. \(fn FILE &optional DO-NOT-KILL-BUFFER-WHEN-DONE)" t nil) (autoload (quote ebnf-eps-buffer) "ebnf2ps" "\ -Generate a PostScript syntactic chart image of the buffer in a EPS file. +Generate a PostScript syntactic chart image of the buffer in an EPS file. -Indeed, for each production is generated a EPS file. +Generate an EPS file for each production in the buffer. The EPS file name has the following form: .eps @@ -8097,18 +8135,20 @@ The EPS file name has the following form: The default value is \"ebnf--\". is the production name. - The production name is mapped to form a valid file name. - For example, the production name \"A/B + C\" is mapped to - \"A_B_+_C\" and the EPS file name used is \"ebnf--A_B_+_C.eps\". + Some characters in the production file name are replaced to + produce a valid file name. For example, the production name + \"A/B + C\" is modified to produce \"A_B_+_C\", and the EPS + file name used in this case will be \"ebnf--A_B_+_C.eps\". -WARNING: It's *NOT* asked any confirmation to override an existing file. +WARNING: This function does *NOT* ask any confirmation to override existing + files. \(fn)" t nil) (autoload (quote ebnf-eps-region) "ebnf2ps" "\ -Generate a PostScript syntactic chart image of the region in a EPS file. +Generate a PostScript syntactic chart image of the region in an EPS file. -Indeed, for each production is generated a EPS file. +Generate an EPS file for each production in the region. The EPS file name has the following form: .eps @@ -8117,30 +8157,32 @@ The EPS file name has the following form: The default value is \"ebnf--\". is the production name. - The production name is mapped to form a valid file name. - For example, the production name \"A/B + C\" is mapped to - \"A_B_+_C\" and the EPS file name used is \"ebnf--A_B_+_C.eps\". + Some characters in the production file name are replaced to + produce a valid file name. For example, the production name + \"A/B + C\" is modified to produce \"A_B_+_C\", and the EPS + file name used in this case will be \"ebnf--A_B_+_C.eps\". -WARNING: It's *NOT* asked any confirmation to override an existing file. +WARNING: This function does *NOT* ask any confirmation to override existing + files. \(fn FROM TO)" t nil) (defalias (quote ebnf-despool) (quote ps-despool)) (autoload (quote ebnf-syntax-directory) "ebnf2ps" "\ -Does a syntactic analysis of the files in DIRECTORY. +Do a syntactic analysis of the files in DIRECTORY. -If DIRECTORY is nil, it's used `default-directory'. +If DIRECTORY is nil, use `default-directory'. -The files in DIRECTORY that matches `ebnf-file-suffix-regexp' (which see) are -processed. +Only the files in DIRECTORY that match `ebnf-file-suffix-regexp' (which see) +are processed. See also `ebnf-syntax-buffer'. \(fn &optional DIRECTORY)" t nil) (autoload (quote ebnf-syntax-file) "ebnf2ps" "\ -Does a syntactic analysis of the FILE. +Do a syntactic analysis of the named FILE. If optional arg DO-NOT-KILL-BUFFER-WHEN-DONE is non-nil, the buffer isn't killed after syntax checking. @@ -8150,12 +8192,12 @@ See also `ebnf-syntax-buffer'. \(fn FILE &optional DO-NOT-KILL-BUFFER-WHEN-DONE)" t nil) (autoload (quote ebnf-syntax-buffer) "ebnf2ps" "\ -Does a syntactic analysis of the current buffer. +Do a syntactic analysis of the current buffer. \(fn)" t nil) (autoload (quote ebnf-syntax-region) "ebnf2ps" "\ -Does a syntactic analysis of a region. +Do a syntactic analysis of region. \(fn FROM TO)" t nil) @@ -8188,7 +8230,7 @@ See `ebnf-style-database' documentation. (autoload (quote ebnf-apply-style) "ebnf2ps" "\ Set STYLE as the current style. -It returns the old style symbol. +Returns the old style symbol. See `ebnf-style-database' documentation. @@ -8197,25 +8239,29 @@ See `ebnf-style-database' documentation. (autoload (quote ebnf-reset-style) "ebnf2ps" "\ Reset current style. -It returns the old style symbol. +Returns the old style symbol. See `ebnf-style-database' documentation. \(fn &optional STYLE)" t nil) (autoload (quote ebnf-push-style) "ebnf2ps" "\ -Push the current style and set STYLE as the current style. +Push the current style onto a stack and set STYLE as the current style. + +Returns the old style symbol. -It returns the old style symbol. +See also `ebnf-pop-style'. See `ebnf-style-database' documentation. \(fn &optional STYLE)" t nil) (autoload (quote ebnf-pop-style) "ebnf2ps" "\ -Pop a style and set it as the current style. +Pop a style from the stack of pushed styles and set it as the current style. + +Returns the old style symbol. -It returns the old style symbol. +See also `ebnf-push-style'. See `ebnf-style-database' documentation. @@ -8233,8 +8279,8 @@ See `ebnf-style-database' documentation. ;;;;;; ebrowse-tags-find-declaration-other-window ebrowse-tags-find-definition ;;;;;; ebrowse-tags-view-definition ebrowse-tags-find-declaration ;;;;;; ebrowse-tags-view-declaration ebrowse-member-mode ebrowse-electric-choose-tree -;;;;;; ebrowse-tree-mode) "ebrowse" "progmodes/ebrowse.el" (17822 -;;;;;; 38987)) +;;;;;; ebrowse-tree-mode) "ebrowse" "progmodes/ebrowse.el" (17838 +;;;;;; 58221)) ;;; Generated autoloads from progmodes/ebrowse.el (autoload (quote ebrowse-tree-mode) "ebrowse" "\ @@ -8496,7 +8542,7 @@ Toggle edebugging of all forms. ;;;;;; ediff-merge-directory-revisions ediff-merge-directories-with-ancestor ;;;;;; ediff-merge-directories ediff-directories3 ediff-directory-revisions ;;;;;; ediff-directories ediff-buffers3 ediff-buffers ediff-backup -;;;;;; ediff-files3 ediff-files) "ediff" "ediff.el" (17851 10823)) +;;;;;; ediff-files3 ediff-files) "ediff" "ediff.el" (17851 39450)) ;;; Generated autoloads from ediff.el (autoload (quote ediff-files) "ediff" "\ @@ -8764,7 +8810,7 @@ Display Ediff's registry. ;;;*** ;;;### (autoloads (ediff-toggle-use-toolbar ediff-toggle-multiframe) -;;;;;; "ediff-util" "ediff-util.el" (17851 10823)) +;;;;;; "ediff-util" "ediff-util.el" (17851 39450)) ;;; Generated autoloads from ediff-util.el (autoload (quote ediff-toggle-multiframe) "ediff-util" "\ @@ -8856,12 +8902,11 @@ Turn on EDT Emulation. ;;;*** ;;;### (autoloads (electric-helpify with-electric-help) "ehelp" "ehelp.el" -;;;;;; (17851 10823)) +;;;;;; (17873 60335)) ;;; Generated autoloads from ehelp.el (autoload (quote with-electric-help) "ehelp" "\ Pop up an \"electric\" help buffer. -The arguments are THUNK &optional BUFFER NOERASE MINHEIGHT. THUNK is a function of no arguments which is called to initialize the contents of BUFFER. BUFFER defaults to `*Help*'. BUFFER will be erased before THUNK is called unless NOERASE is non-nil. THUNK will @@ -8873,7 +8918,7 @@ shrink the window to fit. If THUNK returns non-nil, we don't do those things. After THUNK has been called, this function \"electrically\" pops up a window in which BUFFER is displayed and allows the user to scroll through that buffer -in electric-help-mode. The window's height will be at least MINHEIGHT if +in `electric-help-mode'. The window's height will be at least MINHEIGHT if this value is non-nil. If THUNK returns nil, we display BUFFER starting at the top, and @@ -8882,7 +8927,7 @@ If THUNK returns non-nil, we don't do those things. When the user exits (with `electric-help-exit', or otherwise), the help buffer's window disappears (i.e., we use `save-window-excursion'), and -BUFFER is put into `default-major-mode' (or `fundamental-mode') when we exit. +BUFFER is put into `default-major-mode' (or `fundamental-mode'). \(fn THUNK &optional BUFFER NOERASE MINHEIGHT)" nil nil) @@ -9010,7 +9055,7 @@ Prompts for bug subject. Leaves you in a mail buffer. ;;;;;; emerge-revisions emerge-files-with-ancestor-remote emerge-files-remote ;;;;;; emerge-files-with-ancestor-command emerge-files-command emerge-buffers-with-ancestor ;;;;;; emerge-buffers emerge-files-with-ancestor emerge-files) "emerge" -;;;;;; "emerge.el" (17197 14700)) +;;;;;; "emerge.el" (17504 41540)) ;;; Generated autoloads from emerge.el (defvar menu-bar-emerge-menu (make-sparse-keymap "Emerge")) @@ -9197,7 +9242,7 @@ Otherwise, connect to HOST:PORT as USER and /join CHANNEL. ;;;*** -;;;### (autoloads nil "erc-capab" "erc/erc-capab.el" (17842 54344)) +;;;### (autoloads nil "erc-capab" "erc/erc-capab.el" (17843 27870)) ;;; Generated autoloads from erc/erc-capab.el (autoload 'erc-capab-identify-mode "erc-capab" nil t) @@ -10831,7 +10876,7 @@ Set up hooks, load the cache file -- if existing -- and build the menu. ;;;*** -;;;### (autoloads nil "fill" "textmodes/fill.el" (17851 10872)) +;;;### (autoloads nil "fill" "textmodes/fill.el" (17852 50694)) ;;; Generated autoloads from textmodes/fill.el (put 'colon-double-space 'safe-local-variable 'booleanp) @@ -11229,7 +11274,7 @@ Not documented ;;;*** ;;;### (autoloads (flymake-mode-off flymake-mode-on flymake-mode) -;;;;;; "flymake" "progmodes/flymake.el" (17851 10867)) +;;;;;; "flymake" "progmodes/flymake.el" (17854 10614)) ;;; Generated autoloads from progmodes/flymake.el (autoload (quote flymake-mode) "flymake" "\ @@ -11591,7 +11636,7 @@ and choose the directory as the fortune-file. ;;;*** ;;;### (autoloads (gdb-enable-debug gdba) "gdb-ui" "progmodes/gdb-ui.el" -;;;;;; (17851 10868)) +;;;;;; (17866 27909)) ;;; Generated autoloads from progmodes/gdb-ui.el (autoload (quote gdba) "gdb-ui" "\ @@ -11934,7 +11979,7 @@ If CLEAN, obsolete (ignore). ;;;*** ;;;### (autoloads (gnus-article-prepare-display) "gnus-art" "gnus/gnus-art.el" -;;;;;; (17851 10856)) +;;;;;; (17854 10614)) ;;; Generated autoloads from gnus/gnus-art.el (autoload (quote gnus-article-prepare-display) "gnus-art" "\ @@ -12582,7 +12627,7 @@ Also fontifies the buffer appropriately (see `goto-address-fontify-p' and ;;;### (autoloads (rgrep lgrep grep-find grep grep-mode grep-compute-defaults ;;;;;; grep-process-setup grep-setup-hook grep-find-command grep-command -;;;;;; grep-window-height) "grep" "progmodes/grep.el" (17851 10868)) +;;;;;; grep-window-height) "grep" "progmodes/grep.el" (17875 14313)) ;;; Generated autoloads from progmodes/grep.el (defvar grep-window-height nil "\ @@ -12658,6 +12703,9 @@ While grep runs asynchronously, you can use \\[next-error] (M-x next-error), or \\\\[compile-goto-error] in the grep output buffer, to go to the lines where grep found matches. +For doing a recursive `grep', see the `rgrep' command. For running +`grep' in a specific directory, see `lgrep'. + This command uses a special history list for its COMMAND-ARGS, so you can easily repeat a grep command. @@ -12682,7 +12730,7 @@ easily repeat a find command. (defalias (quote find-grep) (quote grep-find)) (autoload (quote lgrep) "grep" "\ -Run grep, searching for REGEXP in FILES in current directory. +Run grep, searching for REGEXP in FILES in directory DIR. The search is limited to file names matching shell pattern FILES. FILES may use abbreviations defined in `grep-files-aliases', e.g. entering `ch' is equivalent to `*.[ch]'. @@ -12697,7 +12745,7 @@ in the grep output buffer, to go to the lines where grep found matches. This command shares argument histories with \\[rgrep] and \\[grep]. -\(fn REGEXP &optional FILES)" t nil) +\(fn REGEXP &optional FILES DIR)" t nil) (autoload (quote rgrep) "grep" "\ Recursively grep for REGEXP in FILES in directory tree rooted at DIR. @@ -12733,7 +12781,7 @@ the form \"WINDOW-ID PIXMAP-ID\". Value is non-nil if successful. ;;;*** ;;;### (autoloads (gdb-script-mode bashdb jdb pdb perldb xdb dbx -;;;;;; sdb gdb) "gud" "progmodes/gud.el" (17851 10868)) +;;;;;; sdb gdb) "gud" "progmodes/gud.el" (17871 15754)) ;;; Generated autoloads from progmodes/gud.el (autoload (quote gdb) "gud" "\ @@ -13002,7 +13050,7 @@ different regions. With numeric argument ARG, behaves like ;;;### (autoloads (describe-categories describe-syntax describe-variable ;;;;;; variable-at-point describe-function-1 describe-simplify-lib-file-name ;;;;;; help-C-file-name describe-function) "help-fns" "help-fns.el" -;;;;;; (17851 10830)) +;;;;;; (17851 39450)) ;;; Generated autoloads from help-fns.el (autoload (quote describe-function) "help-fns" "\ @@ -13174,7 +13222,7 @@ Provide help for current mode. ;;;*** ;;;### (autoloads (hexlify-buffer hexl-find-file hexl-mode) "hexl" -;;;;;; "hexl.el" (17851 10833)) +;;;;;; "hexl.el" (17851 39450)) ;;; Generated autoloads from hexl.el (autoload (quote hexl-mode) "hexl" "\ @@ -13271,7 +13319,7 @@ This discards the buffer's undo information. ;;;### (autoloads (hi-lock-write-interactive-patterns hi-lock-unface-buffer ;;;;;; hi-lock-face-phrase-buffer hi-lock-face-buffer hi-lock-line-face-buffer ;;;;;; global-hi-lock-mode hi-lock-mode) "hi-lock" "hi-lock.el" -;;;;;; (17851 10833)) +;;;;;; (17860 50079)) ;;; Generated autoloads from hi-lock.el (autoload (quote hi-lock-mode) "hi-lock" "\ @@ -14433,7 +14481,7 @@ with no args, if that value is non-nil. ;;;*** ;;;### (autoloads (idlwave-shell) "idlw-shell" "progmodes/idlw-shell.el" -;;;;;; (17851 10868)) +;;;;;; (17887 5449)) ;;; Generated autoloads from progmodes/idlw-shell.el (autoload (quote idlwave-shell) "idlw-shell" "\ @@ -14459,7 +14507,7 @@ See also the variable `idlwave-shell-prompt-pattern'. ;;;*** ;;;### (autoloads (idlwave-mode) "idlwave" "progmodes/idlwave.el" -;;;;;; (17851 10868)) +;;;;;; (17859 27907)) ;;; Generated autoloads from progmodes/idlwave.el (autoload (quote idlwave-mode) "idlwave" "\ @@ -14594,8 +14642,8 @@ The main features of this mode are ;;;;;; ido-find-alternate-file ido-find-file-other-window ido-find-file ;;;;;; ido-find-file-in-dir ido-switch-buffer-other-frame ido-insert-buffer ;;;;;; ido-kill-buffer ido-display-buffer ido-switch-buffer-other-window -;;;;;; ido-switch-buffer ido-mode ido-mode) "ido" "ido.el" (17851 -;;;;;; 10834)) +;;;;;; ido-switch-buffer ido-mode ido-mode) "ido" "ido.el" (17864 +;;;;;; 64718)) ;;; Generated autoloads from ido.el (defvar ido-mode nil "\ @@ -14663,35 +14711,35 @@ in a separate window. (autoload (quote ido-switch-buffer-other-window) "ido" "\ Switch to another buffer and show it in another window. The buffer name is selected interactively by typing a substring. -For details of keybindings, do `\\[describe-function] ido'. +For details of keybindings, see `ido-switch-buffer'. \(fn)" t nil) (autoload (quote ido-display-buffer) "ido" "\ Display a buffer in another window but don't select it. The buffer name is selected interactively by typing a substring. -For details of keybindings, do `\\[describe-function] ido'. +For details of keybindings, see `ido-switch-buffer'. \(fn)" t nil) (autoload (quote ido-kill-buffer) "ido" "\ Kill a buffer. The buffer name is selected interactively by typing a substring. -For details of keybindings, do `\\[describe-function] ido'. +For details of keybindings, see `ido-switch-buffer'. \(fn)" t nil) (autoload (quote ido-insert-buffer) "ido" "\ Insert contents of a buffer in current buffer after point. The buffer name is selected interactively by typing a substring. -For details of keybindings, do `\\[describe-function] ido'. +For details of keybindings, see `ido-switch-buffer'. \(fn)" t nil) (autoload (quote ido-switch-buffer-other-frame) "ido" "\ Switch to another buffer and show it in another frame. The buffer name is selected interactively by typing a substring. -For details of keybindings, do `\\[describe-function] ido'. +For details of keybindings, see `ido-switch-buffer'. \(fn)" t nil) @@ -14746,70 +14794,70 @@ in a separate window. (autoload (quote ido-find-file-other-window) "ido" "\ Switch to another file and show it in another window. The file name is selected interactively by typing a substring. -For details of keybindings, do `\\[describe-function] ido-find-file'. +For details of keybindings, see `ido-find-file'. \(fn)" t nil) (autoload (quote ido-find-alternate-file) "ido" "\ Switch to another file and show it in another window. The file name is selected interactively by typing a substring. -For details of keybindings, do `\\[describe-function] ido-find-file'. +For details of keybindings, see `ido-find-file'. \(fn)" t nil) (autoload (quote ido-find-file-read-only) "ido" "\ Edit file read-only with name obtained via minibuffer. The file name is selected interactively by typing a substring. -For details of keybindings, do `\\[describe-function] ido-find-file'. +For details of keybindings, see `ido-find-file'. \(fn)" t nil) (autoload (quote ido-find-file-read-only-other-window) "ido" "\ Edit file read-only in other window with name obtained via minibuffer. The file name is selected interactively by typing a substring. -For details of keybindings, do `\\[describe-function] ido-find-file'. +For details of keybindings, see `ido-find-file'. \(fn)" t nil) (autoload (quote ido-find-file-read-only-other-frame) "ido" "\ Edit file read-only in other frame with name obtained via minibuffer. The file name is selected interactively by typing a substring. -For details of keybindings, do `\\[describe-function] ido-find-file'. +For details of keybindings, see `ido-find-file'. \(fn)" t nil) (autoload (quote ido-display-file) "ido" "\ Display a file in another window but don't select it. The file name is selected interactively by typing a substring. -For details of keybindings, do `\\[describe-function] ido-find-file'. +For details of keybindings, see `ido-find-file'. \(fn)" t nil) (autoload (quote ido-find-file-other-frame) "ido" "\ Switch to another file and show it in another frame. The file name is selected interactively by typing a substring. -For details of keybindings, do `\\[describe-function] ido-find-file'. +For details of keybindings, see `ido-find-file'. \(fn)" t nil) (autoload (quote ido-write-file) "ido" "\ Write current buffer to a file. The file name is selected interactively by typing a substring. -For details of keybindings, do `\\[describe-function] ido-find-file'. +For details of keybindings, see `ido-find-file'. \(fn)" t nil) (autoload (quote ido-insert-file) "ido" "\ Insert contents of file in current buffer. The file name is selected interactively by typing a substring. -For details of keybindings, do `\\[describe-function] ido-find-file'. +For details of keybindings, see `ido-find-file'. \(fn)" t nil) (autoload (quote ido-dired) "ido" "\ Call `dired' the ido way. The directory is selected interactively by typing a substring. -For details of keybindings, do `\\[describe-function] ido-find-file'. +For details of keybindings, see `ido-find-file'. \(fn)" t nil) @@ -14888,7 +14936,7 @@ Toggle inline image minor mode. ;;;;;; insert-image put-image create-image image-type-auto-detected-p ;;;;;; image-type-available-p image-type image-type-from-file-name ;;;;;; image-type-from-file-header image-type-from-buffer image-type-from-data) -;;;;;; "image" "image.el" (17851 10835)) +;;;;;; "image" "image.el" (17868 42183)) ;;; Generated autoloads from image.el (autoload (quote image-type-from-data) "image" "\ @@ -14938,11 +14986,16 @@ Image types are symbols like `xbm' or `jpeg'. (autoload (quote image-type-auto-detected-p) "image" "\ Return t iff the current buffer contains an auto-detectable image. -Whether image types are auto-detectable or not depends on the setting -of the variable `image-type-auto-detectable'. - This function is intended to be used from `magic-mode-alist' (which see). +First, compare the beginning of the buffer with `image-type-header-regexps'. +If an appropriate image type is found, check if that image type can be +autodetected using the variable `image-type-auto-detectable'. Finally, +if `buffer-file-name' is non-nil, check if it matches another major mode +in `auto-mode-alist' apart from `image-mode'; if there is another match, +the autodetection is considered to have failed. Return t if all the above +steps succeed. + \(fn)" nil nil) (autoload (quote create-image) "image" "\ @@ -15121,7 +15174,7 @@ Image files are those whose name has an extension in ;;;*** ;;;### (autoloads (image-mode-maybe image-minor-mode image-mode) -;;;;;; "image-mode" "image-mode.el" (17851 10835)) +;;;;;; "image-mode" "image-mode.el" (17866 8262)) ;;; Generated autoloads from image-mode.el (push '("\\.jpe?g\\'" . image-mode) auto-mode-alist) (push '("\\.png\\'" . image-mode) auto-mode-alist) @@ -15384,7 +15437,7 @@ of `inferior-lisp-program'). Runs the hooks from ;;;### (autoloads (Info-speedbar-browser Info-goto-emacs-key-command-node ;;;;;; Info-goto-emacs-command-node Info-mode info-apropos Info-index ;;;;;; Info-directory Info-on-current-buffer info-standalone info-emacs-manual -;;;;;; info info-other-window) "info" "info.el" (17851 10835)) +;;;;;; info info-other-window) "info" "info.el" (17870 6128)) ;;; Generated autoloads from info.el (autoload (quote info-other-window) "info" "\ @@ -15550,7 +15603,7 @@ This will add a speedbar major display mode. ;;;### (autoloads (info-complete-file info-complete-symbol info-lookup-file ;;;;;; info-lookup-symbol info-lookup-reset) "info-look" "info-look.el" -;;;;;; (17851 10835)) +;;;;;; (17880 31192)) ;;; Generated autoloads from info-look.el (autoload (quote info-lookup-reset) "info-look" "\ @@ -15686,8 +15739,8 @@ Not documented ;;;*** -;;;### (autoloads (isearchb-activate) "isearchb" "isearchb.el" (17851 -;;;;;; 10835)) +;;;### (autoloads (isearchb-activate) "isearchb" "isearchb.el" (17854 +;;;;;; 10613)) ;;; Generated autoloads from isearchb.el (autoload (quote isearchb-activate) "isearchb" "\ @@ -15800,7 +15853,7 @@ Add submenus to the File menu, to convert to and from various formats. ;;;;;; ispell-region ispell-change-dictionary ispell-kill-ispell ;;;;;; ispell-help ispell-pdict-save ispell-word ispell-local-dictionary-alist ;;;;;; ispell-personal-dictionary) "ispell" "textmodes/ispell.el" -;;;;;; (17851 10872)) +;;;;;; (17875 14313)) ;;; Generated autoloads from textmodes/ispell.el (put 'ispell-check-comments 'safe-local-variable (lambda (a) (memq a '(nil t exclusive)))) @@ -15845,8 +15898,7 @@ Each element of this list is also a list: DICTIONARY-NAME is a possible string value of variable `ispell-dictionary', nil means the default dictionary. -CASECHARS is a regular expression of valid characters that comprise a -word. +CASECHARS is a regular expression of valid characters that comprise a word. NOT-CASECHARS is the opposite regexp of CASECHARS. @@ -15860,7 +15912,7 @@ regular expression \"[']\" for OTHERCHARS. Then \"they're\" and If you want OTHERCHARS to be empty, use the empty string. Hint: regexp syntax requires the hyphen to be declared first here. -CASECHAS, NOT-CASECHARS, and OTHERCHARS must be a unibyte string +CASECHARS, NOT-CASECHARS, and OTHERCHARS must be unibyte strings containing bytes of CHARACTER-SET. In addition, if they contain a non-ASCII byte, the regular expression must be a single `character set' construct that doesn't specify a character range @@ -15948,7 +16000,7 @@ which is in `ispell-local-dictionary-alist' or `ispell-dictionary-alist'. This will check or reload the dictionary. Use \\[ispell-change-dictionary] or \\[ispell-region] to update the Ispell process. -return values: +Return values: nil word is correct or spelling is accepted. 0 word is inserted into buffer-local definitions. \"word\" word corrected from word list. @@ -15983,9 +16035,9 @@ SPC: Accept word this time. `l': Look up typed-in replacement in alternate dictionary. Wildcards okay. `u': Like `i', but the word is lower-cased first. `m': Place typed-in value in personal dictionary, then recheck current word. -`C-l': redraws screen -`C-r': recursive edit -`C-z': suspend Emacs or iconify frame +`C-l': Redraw screen. +`C-r': Recursive edit. +`C-z': Suspend Emacs or iconify frame. \(fn)" nil nil) @@ -16088,8 +16140,8 @@ You can bind this to the key C-c i in GNUS or mail by adding to ;;;*** -;;;### (autoloads (iswitchb-mode) "iswitchb" "iswitchb.el" (17822 -;;;;;; 38984)) +;;;### (autoloads (iswitchb-mode) "iswitchb" "iswitchb.el" (17838 +;;;;;; 58217)) ;;; Generated autoloads from iswitchb.el (defvar iswitchb-mode nil "\ @@ -16192,7 +16244,7 @@ If non-nil, second arg INITIAL-INPUT is a string to insert before reading. ;;;*** ;;;### (autoloads (jka-compr-uninstall jka-compr-handler) "jka-compr" -;;;;;; "jka-compr.el" (17851 10836)) +;;;;;; "jka-compr.el" (17853 24757)) ;;; Generated autoloads from jka-compr.el (defvar jka-compr-inhibit nil "\ @@ -16581,7 +16633,7 @@ coding system names is determined from `latex-inputenc-coding-alist'. ;;;*** ;;;### (autoloads (latin1-display-ucs-per-lynx latin1-display latin1-display) -;;;;;; "latin1-disp" "international/latin1-disp.el" (17851 10860)) +;;;;;; "latin1-disp" "international/latin1-disp.el" (17875 14313)) ;;; Generated autoloads from international/latin1-disp.el (defvar latin1-display nil "\ @@ -16688,8 +16740,8 @@ generations (this defaults to 1). ;;;*** -;;;### (autoloads (unload-feature) "loadhist" "loadhist.el" (17851 -;;;;;; 10837)) +;;;### (autoloads (unload-feature) "loadhist" "loadhist.el" (17871 +;;;;;; 15753)) ;;; Generated autoloads from loadhist.el (autoload (quote unload-feature) "loadhist" "\ @@ -16908,7 +16960,7 @@ for further customization of the printer command. ;;;*** ;;;### (autoloads (ls-lisp-support-shell-wildcards) "ls-lisp" "ls-lisp.el" -;;;;;; (17851 10838)) +;;;;;; (17851 39451)) ;;; Generated autoloads from ls-lisp.el (defvar ls-lisp-support-shell-wildcards t "\ @@ -18196,7 +18248,7 @@ Not documented ;;;*** ;;;### (autoloads (modula-2-mode) "modula2" "progmodes/modula2.el" -;;;;;; (17289 39206)) +;;;;;; (17504 41540)) ;;; Generated autoloads from progmodes/modula2.el (autoload (quote modula-2-mode) "modula2" "\ @@ -18296,7 +18348,7 @@ primary selection and region. ;;;*** -;;;### (autoloads (mpuz) "mpuz" "play/mpuz.el" (17851 10866)) +;;;### (autoloads (mpuz) "mpuz" "play/mpuz.el" (17863 20633)) ;;; Generated autoloads from play/mpuz.el (autoload (quote mpuz) "mpuz" "\ @@ -18957,7 +19009,7 @@ unless optional argument SOFT is non-nil. ;;;### (autoloads (newsticker-show-news newsticker-start-ticker newsticker-start ;;;;;; newsticker-ticker-running-p newsticker-running-p) "newsticker" -;;;;;; "net/newsticker.el" (17851 10863)) +;;;;;; "net/newsticker.el" (17873 60335)) ;;; Generated autoloads from net/newsticker.el (autoload (quote newsticker-running-p) "newsticker" "\ @@ -19270,7 +19322,7 @@ including a reproducible test case and send the message. ;;;;;; org-store-link org-tags-view org-diary org-cycle-agenda-files ;;;;;; org-todo-list org-agenda-list org-batch-agenda org-agenda ;;;;;; org-global-cycle org-cycle org-mode) "org" "textmodes/org.el" -;;;;;; (17851 10872)) +;;;;;; (17871 15754)) ;;; Generated autoloads from textmodes/org.el (autoload (quote org-mode) "org" "\ @@ -19538,7 +19590,7 @@ The file is stored under the name `org-combined-agenda-icalendar-file'. ;;;*** ;;;### (autoloads (outline-minor-mode outline-mode) "outline" "outline.el" -;;;;;; (17851 10839)) +;;;;;; (17882 17519)) ;;; Generated autoloads from outline.el (put 'outline-regexp 'safe-local-variable 'string-or-null-p) @@ -20254,7 +20306,7 @@ Import public keys in the current buffer. ;;;*** ;;;### (autoloads (pgg-gpg-symmetric-key-p) "pgg-gpg" "pgg-gpg.el" -;;;;;; (17851 10840)) +;;;;;; (17887 6558)) ;;; Generated autoloads from pgg-gpg.el (autoload (quote pgg-gpg-symmetric-key-p) "pgg-gpg" "\ @@ -20374,7 +20426,7 @@ pong-mode keybindings:\\ ;;;*** ;;;### (autoloads (pp-eval-last-sexp pp-eval-expression pp pp-buffer -;;;;;; pp-to-string) "pp" "emacs-lisp/pp.el" (17851 10853)) +;;;;;; pp-to-string) "pp" "emacs-lisp/pp.el" (17852 50694)) ;;; Generated autoloads from emacs-lisp/pp.el (autoload (quote pp-to-string) "pp" "\ @@ -20430,7 +20482,7 @@ Ignores leading comment characters. ;;;;;; pr-ps-buffer-print pr-ps-buffer-using-ghostscript pr-ps-buffer-preview ;;;;;; pr-ps-directory-ps-print pr-ps-directory-print pr-ps-directory-using-ghostscript ;;;;;; pr-ps-directory-preview pr-interface) "printing" "printing.el" -;;;;;; (17851 10840)) +;;;;;; (17866 27909)) ;;; Generated autoloads from printing.el (autoload (quote pr-interface) "printing" "\ @@ -21221,8 +21273,8 @@ Not documented ;;;;;; ps-spool-region ps-spool-buffer-with-faces ps-spool-buffer ;;;;;; ps-print-region-with-faces ps-print-region ps-print-buffer-with-faces ;;;;;; ps-print-buffer ps-print-customize ps-print-color-p ps-paper-type -;;;;;; ps-page-dimensions-database) "ps-print" "ps-print.el" (17851 -;;;;;; 10840)) +;;;;;; ps-page-dimensions-database) "ps-print" "ps-print.el" (17880 +;;;;;; 31192)) ;;; Generated autoloads from ps-print.el (defvar ps-page-dimensions-database (list (list (quote a4) (/ (* 72 21.0) 2.54) (/ (* 72 29.7) 2.54) "A4") (list (quote a3) (/ (* 72 29.7) 2.54) (/ (* 72 42.0) 2.54) "A3") (list (quote letter) (* 72 8.5) (* 72 11.0) "Letter") (list (quote legal) (* 72 8.5) (* 72 14.0) "Legal") (list (quote letter-small) (* 72 7.68) (* 72 10.16) "LetterSmall") (list (quote tabloid) (* 72 11.0) (* 72 17.0) "Tabloid") (list (quote ledger) (* 72 17.0) (* 72 11.0) "Ledger") (list (quote statement) (* 72 5.5) (* 72 8.5) "Statement") (list (quote executive) (* 72 7.5) (* 72 10.0) "Executive") (list (quote a4small) (* 72 7.47) (* 72 10.85) "A4Small") (list (quote b4) (* 72 10.125) (* 72 14.33) "B4") (list (quote b5) (* 72 7.16) (* 72 10.125) "B5")) "\ @@ -21517,7 +21569,7 @@ them into characters should be done separately. ;;;;;; quail-defrule quail-install-decode-map quail-install-map ;;;;;; quail-define-rules quail-show-keyboard-layout quail-set-keyboard-layout ;;;;;; quail-define-package quail-use-package quail-title) "quail" -;;;;;; "international/quail.el" (17851 10861)) +;;;;;; "international/quail.el" (17859 27906)) ;;; Generated autoloads from international/quail.el (autoload (quote quail-title) "quail" "\ @@ -23739,7 +23791,7 @@ Like `mail' command, but display mail buffer in another frame. ;;;*** ;;;### (autoloads (server-mode server-start) "server" "server.el" -;;;;;; (17851 10842)) +;;;;;; (17851 42899)) ;;; Generated autoloads from server.el (autoload (quote server-start) "server" "\ @@ -23749,7 +23801,8 @@ client \"editors\" can send your editing commands to this Emacs job. To use the server, set up the program `emacsclient' in the Emacs distribution as your standard \"editor\". -Prefix arg means just kill any existing server communications subprocess. +Optional argument LEAVE-DEAD (interactively, a prefix arg) means just +kill any existing server communications subprocess. \(fn &optional LEAVE-DEAD)" t nil) @@ -23938,14 +23991,14 @@ If BINARY is non-nil, return a string in binary form. ;;;*** ;;;### (autoloads (list-load-path-shadows) "shadow" "emacs-lisp/shadow.el" -;;;;;; (17851 10853)) +;;;;;; (17854 10614)) ;;; Generated autoloads from emacs-lisp/shadow.el (autoload (quote list-load-path-shadows) "shadow" "\ Display a list of Emacs Lisp files that shadow other files. -This function lists potential load-path problems. Directories in the -`load-path' variable are searched, in order, for Emacs Lisp +This function lists potential load path problems. Directories in +the `load-path' variable are searched, in order, for Emacs Lisp files. When a previously encountered file name is found again, a message is displayed indicating that the later file is \"hidden\" by the earlier. @@ -24108,7 +24161,7 @@ Turning on Sieve mode runs `sieve-mode-hook'. ;;;*** -;;;### (autoloads nil "simple" "simple.el" (17851 10843)) +;;;### (autoloads nil "simple" "simple.el" (17880 31192)) ;;; Generated autoloads from simple.el (put 'fill-prefix 'safe-local-variable 'string-or-null-p) @@ -24293,7 +24346,7 @@ Minor mode to simplify editing output from the diff3 program. ;;;*** ;;;### (autoloads (smiley-buffer smiley-region) "smiley" "gnus/smiley.el" -;;;;;; (17851 10860)) +;;;;;; (17875 18095)) ;;; Generated autoloads from gnus/smiley.el (autoload (quote smiley-region) "smiley" "\ @@ -24311,7 +24364,7 @@ interactively. If there's no argument, do it at the current buffer ;;;*** ;;;### (autoloads (smtpmail-send-queued-mail smtpmail-send-it) "smtpmail" -;;;;;; "mail/smtpmail.el" (17851 10862)) +;;;;;; "mail/smtpmail.el" (17868 41435)) ;;; Generated autoloads from mail/smtpmail.el (autoload (quote smtpmail-send-it) "smtpmail" "\ @@ -24728,14 +24781,14 @@ Spam reports will be queued with the method used when ;;;*** ;;;### (autoloads (speedbar-get-focus speedbar-frame-mode) "speedbar" -;;;;;; "speedbar.el" (17851 10844)) +;;;;;; "speedbar.el" (17882 17519)) ;;; Generated autoloads from speedbar.el (defalias (quote speedbar) (quote speedbar-frame-mode)) (autoload (quote speedbar-frame-mode) "speedbar" "\ Enable or disable speedbar. Positive ARG means turn on, negative turn off. -nil means toggle. Once the speedbar frame is activated, a buffer in +A nil ARG means toggle. Once the speedbar frame is activated, a buffer in `speedbar-mode' will be displayed. Currently, only one speedbar is supported at a time. `speedbar-before-popup-hook' is called before popping up the speedbar frame. @@ -25351,7 +25404,7 @@ Read a complex stroke and insert its glyph into the current buffer. ;;;*** ;;;### (autoloads (studlify-buffer studlify-word studlify-region) -;;;;;; "studly" "play/studly.el" (16211 27038)) +;;;;;; "studly" "play/studly.el" (17504 41540)) ;;; Generated autoloads from play/studly.el (autoload (quote studlify-region) "studly" "\ @@ -25371,7 +25424,7 @@ Studlify-case the current buffer. ;;;*** -;;;### (autoloads (locate-library) "subr" "subr.el" (17851 10844)) +;;;### (autoloads (locate-library) "subr" "subr.el" (17868 65234)) ;;; Generated autoloads from subr.el (autoload (quote locate-library) "subr" "\ @@ -25393,7 +25446,7 @@ and the file name is displayed in the echo area. ;;;*** ;;;### (autoloads (sc-cite-original) "supercite" "mail/supercite.el" -;;;;;; (17851 10862)) +;;;;;; (17854 10614)) ;;; Generated autoloads from mail/supercite.el (autoload (quote sc-cite-original) "supercite" "\ @@ -26182,8 +26235,8 @@ Normally input is edited in Emacs and sent a line at a time. ;;;*** -;;;### (autoloads (ansi-term term make-term) "term" "term.el" (17851 -;;;;;; 10845)) +;;;### (autoloads (ansi-term term make-term) "term" "term.el" (17884 +;;;;;; 57195)) ;;; Generated autoloads from term.el (autoload (quote make-term) "term" "\ @@ -26259,7 +26312,7 @@ Start coverage on function under point. ;;;*** -;;;### (autoloads (tetris) "tetris" "play/tetris.el" (17851 10866)) +;;;### (autoloads (tetris) "tetris" "play/tetris.el" (17852 64479)) ;;; Generated autoloads from play/tetris.el (autoload (quote tetris) "tetris" "\ @@ -27311,7 +27364,7 @@ be detected. ;;;*** ;;;### (autoloads (batch-titdic-convert titdic-convert) "titdic-cnv" -;;;;;; "international/titdic-cnv.el" (17851 10861)) +;;;;;; "international/titdic-cnv.el" (17871 15753)) ;;; Generated autoloads from international/titdic-cnv.el (autoload (quote titdic-convert) "titdic-cnv" "\ @@ -27625,7 +27678,7 @@ BUFFER defaults to `trace-buffer'. ;;;### (autoloads (tramp-unload-tramp tramp-completion-handle-file-name-completion ;;;;;; tramp-completion-handle-file-name-all-completions tramp-unload-file-name-handlers ;;;;;; tramp-file-name-handler tramp-completion-file-name-regexp -;;;;;; tramp-file-name-regexp) "tramp" "net/tramp.el" (17851 10865)) +;;;;;; tramp-file-name-regexp) "tramp" "net/tramp.el" (17872 44165)) ;;; Generated autoloads from net/tramp.el (defvar tramp-unified-filenames (not (featurep (quote xemacs))) "\ @@ -27884,8 +27937,8 @@ easy-to-use form. ;;;*** -;;;### (autoloads (help-with-tutorial) "tutorial" "tutorial.el" (17851 -;;;;;; 10847)) +;;;### (autoloads (help-with-tutorial) "tutorial" "tutorial.el" (17856 +;;;;;; 1486)) ;;; Generated autoloads from tutorial.el (autoload (quote help-with-tutorial) "tutorial" "\ @@ -27961,7 +28014,7 @@ First column's text sSs Second column's text ;;;;;; type-break type-break-mode type-break-keystroke-threshold ;;;;;; type-break-good-break-interval type-break-good-rest-interval ;;;;;; type-break-interval type-break-mode) "type-break" "type-break.el" -;;;;;; (17851 10847)) +;;;;;; (17855 40306)) ;;; Generated autoloads from type-break.el (defvar type-break-mode nil "\ @@ -28257,7 +28310,7 @@ no further processing). URL is either a string or a parsed URL. ;;;*** ;;;### (autoloads (url-register-auth-scheme url-get-authentication) -;;;;;; "url-auth" "url/url-auth.el" (17851 10873)) +;;;;;; "url-auth" "url/url-auth.el" (17854 10614)) ;;; Generated autoloads from url/url-auth.el (autoload (quote url-get-authentication) "url-auth" "\ @@ -28275,7 +28328,7 @@ TYPE is the type of authentication to be returned. This is either a string representing the type (basic, digest, etc), or nil or the symbol 'any' to specify that any authentication is acceptable. If requesting 'any' the strongest matching authentication will be returned. If this is - wrong, its no big deal, the error from the server will specify exactly + wrong, it's no big deal, the error from the server will specify exactly what type of auth to use PROMPT is boolean - specifies whether to ask the user for a username/password if one cannot be found in the cache @@ -28427,7 +28480,7 @@ Not documented ;;;*** ;;;### (autoloads (url-http-options url-http-file-attributes url-http-file-exists-p -;;;;;; url-http) "url-http" "url/url-http.el" (17851 10873)) +;;;;;; url-http) "url-http" "url/url-http.el" (17861 9844)) ;;; Generated autoloads from url/url-http.el (autoload (quote url-http) "url-http" "\ @@ -28822,7 +28875,7 @@ The buffer in question is current when this function is called. ;;;### (autoloads (uudecode-decode-region uudecode-decode-region-internal ;;;;;; uudecode-decode-region-external) "uudecode" "gnus/uudecode.el" -;;;;;; (17851 10860)) +;;;;;; (17856 1487)) ;;; Generated autoloads from gnus/uudecode.el (autoload (quote uudecode-decode-region-external) "uudecode" "\ @@ -29140,7 +29193,7 @@ colors. `vc-annotate-background' specifies the background color. ;;;*** -;;;### (autoloads nil "vc-arch" "vc-arch.el" (17851 10848)) +;;;### (autoloads nil "vc-arch" "vc-arch.el" (17852 50694)) ;;; Generated autoloads from vc-arch.el (defun vc-arch-registered (file) (if (vc-find-root file "{arch}/=tagging-method") @@ -29201,16 +29254,16 @@ find any project directory." (let ((project-dir (getenv "PROJECTDIR")) dirs dir) ;;;*** -;;;### (autoloads nil "vc-svn" "vc-svn.el" (17851 10848)) +;;;### (autoloads nil "vc-svn" "vc-svn.el" (17882 17519)) ;;; Generated autoloads from vc-svn.el (defun vc-svn-registered (f) (let ((admin-dir (cond ((and (eq system-type 'windows-nt) - (getenv "SVN_ASP_DOT_NET_HACK")) - "_svn") - (t ".svn")))) + (getenv "SVN_ASP_DOT_NET_HACK")) + "_svn") + (t ".svn")))) (when (file-readable-p (expand-file-name - (concat admin-dir "/entries") - (file-name-directory f))) + (concat admin-dir "/entries") + (file-name-directory f))) (load "vc-svn") (vc-svn-registered f)))) @@ -29219,7 +29272,7 @@ find any project directory." (let ((project-dir (getenv "PROJECTDIR")) dirs dir) ;;;*** ;;;### (autoloads (vhdl-mode) "vhdl-mode" "progmodes/vhdl-mode.el" -;;;;;; (17851 10871)) +;;;;;; (17854 10614)) ;;; Generated autoloads from progmodes/vhdl-mode.el (autoload (quote vhdl-mode) "vhdl-mode" "\ @@ -30088,7 +30141,7 @@ Turn on VIP emulation of VI. ;;;*** ;;;### (autoloads (viper-mode toggle-viper-mode) "viper" "emulation/viper.el" -;;;;;; (17851 10854)) +;;;;;; (17852 50694)) ;;; Generated autoloads from emulation/viper.el (autoload (quote toggle-viper-mode) "viper" "\ @@ -30098,7 +30151,7 @@ If Viper is enabled, turn it off. Otherwise, turn it on. \(fn)" t nil) (autoload (quote viper-mode) "viper" "\ -Turn on Viper emulation of Vi in Emacs. See Info node `(viper)Viper'. +Turn on Viper emulation of Vi in Emacs. See Info node `(viper)Top'. \(fn)" t nil) @@ -30194,7 +30247,7 @@ this is equivalent to `display-warning', using ;;;*** ;;;### (autoloads (wdired-change-to-wdired-mode) "wdired" "wdired.el" -;;;;;; (17851 10849)) +;;;;;; (17873 19573)) ;;; Generated autoloads from wdired.el (autoload (quote wdired-change-to-wdired-mode) "wdired" "\ @@ -30378,8 +30431,8 @@ With arg, turn widget mode on if and only if arg is positive. ;;;*** ;;;### (autoloads (widget-setup widget-insert widget-delete widget-create -;;;;;; widget-prompt-value widgetp) "wid-edit" "wid-edit.el" (17851 -;;;;;; 10849)) +;;;;;; widget-prompt-value widgetp) "wid-edit" "wid-edit.el" (17887 +;;;;;; 5449)) ;;; Generated autoloads from wid-edit.el (autoload (quote widgetp) "wid-edit" "\ @@ -30881,7 +30934,7 @@ Zone out, completely. ;;;;;; "url/url-vars.el" "url/vc-dav.el" "vc-hooks.el" "vcursor.el" ;;;;;; "version.el" "vms-patch.el" "vmsproc.el" "vt-control.el" ;;;;;; "vt100-led.el" "w32-fns.el" "w32-vars.el" "widget.el" "window.el" -;;;;;; "x-dnd.el") (17851 11084 773610)) +;;;;;; "x-dnd.el") (17887 8772 360075)) ;;;*** -- cgit v1.2.1 From 38008dcd924d42aeac69d0fa27034b80bc6687fe Mon Sep 17 00:00:00 2001 From: Chong Yidong Date: Fri, 23 Feb 2007 17:37:28 +0000 Subject: Bump to version 22.0.94. --- lisp/version.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'lisp') diff --git a/lisp/version.el b/lisp/version.el index f6ab6c4c913..fce42b67f06 100644 --- a/lisp/version.el +++ b/lisp/version.el @@ -27,7 +27,7 @@ ;;; Code: -(defconst emacs-version "22.0.93" "\ +(defconst emacs-version "22.0.94" "\ Version numbers of this version of Emacs.") (defconst emacs-major-version -- cgit v1.2.1 From c34a8a87401584b5501580890def8a2133973951 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Fri, 23 Feb 2007 19:13:40 +0000 Subject: (custom-save-all): Canonicalize custom-file before storing it in recentf-exclude. --- lisp/ChangeLog | 5 +++++ lisp/cus-edit.el | 12 +++++++----- 2 files changed, 12 insertions(+), 5 deletions(-) (limited to 'lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 47494b59ef9..33a52985550 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,8 @@ +2007-02-23 David Reitter + + * cus-edit.el (custom-save-all): Canonicalize custom-file before + storing it in recentf-exclude. + 2007-02-23 Chong Yidong * startup.el (fancy-splash-screens): Make cursor-type buffer-local diff --git a/lisp/cus-edit.el b/lisp/cus-edit.el index ce429a40823..c49328ac40d 100644 --- a/lisp/cus-edit.el +++ b/lisp/cus-edit.el @@ -4192,11 +4192,13 @@ if only the first line of the docstring is shown.")) (when (and (null custom-file) init-file-had-error) (error "Cannot save customizations; init file was not fully loaded")) (let* ((filename (custom-file)) - (recentf-exclude (if recentf-mode - (cons (concat "\\`" - (regexp-quote (custom-file)) - "\\'") - recentf-exclude))) + (recentf-exclude + (if recentf-mode + (cons (concat "\\`" + (regexp-quote + (recentf-expand-file-name (custom-file))) + "\\'") + recentf-exclude))) (old-buffer (find-buffer-visiting filename))) (with-current-buffer (let ((find-file-visit-truename t)) (or old-buffer (find-file-noselect filename))) -- cgit v1.2.1 From d695bd172e89b29d811d42b227f30e4db29abf54 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Fri, 23 Feb 2007 19:22:09 +0000 Subject: (comint-read-input-ring): Use comint-input-ring-size from the comint buffer instead of the temporary one. --- lisp/ChangeLog | 5 +++++ lisp/comint.el | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) (limited to 'lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 33a52985550..670175f4194 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,8 @@ +2007-02-23 Andreas Seltenreich + + * comint.el (comint-read-input-ring): Use comint-input-ring-size + from the comint buffer instead of the temporary one. + 2007-02-23 David Reitter * cus-edit.el (custom-save-all): Canonicalize custom-file before diff --git a/lisp/comint.el b/lisp/comint.el index eeb3e720d06..19ce168a02e 100644 --- a/lisp/comint.el +++ b/lisp/comint.el @@ -896,7 +896,7 @@ See also `comint-input-ignoredups' and `comint-write-input-ring'." ;; Watch for those date stamps in history files! (goto-char (point-max)) (let (start end history) - (while (and (< count comint-input-ring-size) + (while (and (< count size) (re-search-backward comint-input-ring-separator nil t) (setq end (match-beginning 0))) (if (re-search-backward comint-input-ring-separator nil t) -- cgit v1.2.1 From da8092ef54cc9172b56e3aa533a2f4414b792db6 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Fri, 23 Feb 2007 19:27:46 +0000 Subject: (sgml-validate): Quote the file name with shell-quote-argument. --- lisp/textmodes/sgml-mode.el | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) (limited to 'lisp') diff --git a/lisp/textmodes/sgml-mode.el b/lisp/textmodes/sgml-mode.el index 6757eb9be1c..5e599ea10e6 100644 --- a/lisp/textmodes/sgml-mode.el +++ b/lisp/textmodes/sgml-mode.el @@ -920,9 +920,10 @@ and move to the line in the SGML document that caused it." (or sgml-saved-validate-command (concat sgml-validate-command " " - (let ((name (buffer-file-name))) - (and name - (file-name-nondirectory name)))))))) + (shell-quote-argument + (let ((name (buffer-file-name))) + (and name + (file-name-nondirectory name))))))))) (setq sgml-saved-validate-command command) (save-some-buffers (not compilation-ask-about-save) nil) (compilation-start command)) -- cgit v1.2.1 From 617a675699a05b85c21d17bf34a7ee90ce8044d0 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Fri, 23 Feb 2007 19:28:42 +0000 Subject: *** empty log message *** --- lisp/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) (limited to 'lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 670175f4194..263aab350e0 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,8 @@ +2007-02-23 Eli Zaretskii + + * textmodes/sgml-mode.el (sgml-validate): Quote the file name with + shell-quote-argument. + 2007-02-23 Andreas Seltenreich * comint.el (comint-read-input-ring): Use comint-input-ring-size -- cgit v1.2.1 From 22cc1d2046b3b78115126fe3d690eb741c2aed00 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Fri, 23 Feb 2007 20:00:31 +0000 Subject: (rmail-cease-edit): Restore the Rmail toolbar. --- lisp/mail/rmailedit.el | 1 + 1 file changed, 1 insertion(+) (limited to 'lisp') diff --git a/lisp/mail/rmailedit.el b/lisp/mail/rmailedit.el index cede2816391..a03edb98629 100644 --- a/lisp/mail/rmailedit.el +++ b/lisp/mail/rmailedit.el @@ -120,6 +120,7 @@ This functions runs the normal hook `rmail-edit-mode-hook'. (force-mode-line-update) (kill-all-local-variables) (rmail-mode-1) + (set (make-local-variable 'tool-bar-map) rmail-tool-bar-map) (rmail-variables) ;; As the local value of save-buffer-coding-system is changed by ;; rmail-variables, we restore the original value. -- cgit v1.2.1 From b0629b0dab174dffc2817c6e08ff1f8c6cd443f5 Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Fri, 23 Feb 2007 20:01:24 +0000 Subject: *** empty log message *** --- lisp/ChangeLog | 2 ++ 1 file changed, 2 insertions(+) (limited to 'lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 263aab350e0..217734d83b4 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,5 +1,7 @@ 2007-02-23 Eli Zaretskii + * mail/rmailedit.el (rmail-cease-edit): Restore the Rmail toolbar. + * textmodes/sgml-mode.el (sgml-validate): Quote the file name with shell-quote-argument. -- cgit v1.2.1 From bb4c0f16cd632ec078eb8d47de597f2868da758f Mon Sep 17 00:00:00 2001 From: "Kim F. Storm" Date: Sat, 24 Feb 2007 00:07:19 +0000 Subject: 2007-02-24 Chris Moore (pgg-*-encrypt-region): Check pgg-encrypt-for-me if no other recipients. --- lisp/pgg-gpg.el | 2 +- lisp/pgg-pgp.el | 2 +- lisp/pgg-pgp5.el | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) (limited to 'lisp') diff --git a/lisp/pgg-gpg.el b/lisp/pgg-gpg.el index a2cd14eaae3..014357aa4e6 100644 --- a/lisp/pgg-gpg.el +++ b/lisp/pgg-gpg.el @@ -224,7 +224,7 @@ passphrase cache or user." (list "--batch" "--armor" "--always-trust" "--encrypt") (if pgg-text-mode (list "--textmode")) (if sign (list "--sign" "--local-user" pgg-gpg-user-id)) - (if recipients + (if (or recipients pgg-encrypt-for-me) (apply #'nconc (mapcar (lambda (rcpt) (list pgg-gpg-recipient-argument rcpt)) diff --git a/lisp/pgg-pgp.el b/lisp/pgg-pgp.el index 1e1bd6d0fd1..9bc494a5ef7 100644 --- a/lisp/pgg-pgp.el +++ b/lisp/pgg-pgp.el @@ -143,7 +143,7 @@ Bourne shell or its equivalent \(not tcsh) is needed for \"2>\"." (args (concat "+encrypttoself=off +verbose=1 +batchmode +language=us -fate " - (if recipients + (if (or recipients pgg-encrypt-for-me) (mapconcat 'shell-quote-argument (append recipients (if pgg-encrypt-for-me diff --git a/lisp/pgg-pgp5.el b/lisp/pgg-pgp5.el index b438843e73b..7525ee3d981 100644 --- a/lisp/pgg-pgp5.el +++ b/lisp/pgg-pgp5.el @@ -155,7 +155,7 @@ Bourne shell or its equivalent \(not tcsh) is needed for \"2>\"." (args (append `("+NoBatchInvalidKeys=off" "-fat" "+batchmode=1" - ,@(if recipients + ,@(if (or recipients pgg-encrypt-for-me) (apply #'append (mapcar (lambda (rcpt) (list "-r" -- cgit v1.2.1 From 948f751616e5c93e4bb8d6ec6d05d47f7e7cc7cb Mon Sep 17 00:00:00 2001 From: "Kim F. Storm" Date: Sat, 24 Feb 2007 00:12:30 +0000 Subject: *** empty log message *** --- lisp/ChangeLog | 7 +++++++ 1 file changed, 7 insertions(+) (limited to 'lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 217734d83b4..c6899bdbec8 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,10 @@ +2007-02-24 Chris Moore + + * pgg-pgp5.el (pgg-pgp5-encrypt-region): + * pgg-pgp.el (pgg-pgp-encrypt-region): + * pgg-gpg.el (pgg-gpg-encrypt-region): + Check pgg-encrypt-for-me if no other recipients. + 2007-02-23 Eli Zaretskii * mail/rmailedit.el (rmail-cease-edit): Restore the Rmail toolbar. -- cgit v1.2.1 From bfd1426943601edbd4cd7abc90b8fac2cf0bd066 Mon Sep 17 00:00:00 2001 From: Kenichi Handa Date: Sat, 24 Feb 2007 01:26:22 +0000 Subject: (utf-8-pre-write-conversion): Handle the case that BEG is a string. --- lisp/ChangeLog | 5 +++++ lisp/international/utf-8.el | 8 +++++--- 2 files changed, 10 insertions(+), 3 deletions(-) (limited to 'lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index c6899bdbec8..164dc076dae 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,8 @@ +2007-02-24 Kenichi Handa + + * international/utf-8.el (utf-8-pre-write-conversion): Handle the + case that BEG is a string. + 2007-02-24 Chris Moore * pgg-pgp5.el (pgg-pgp5-encrypt-region): diff --git a/lisp/international/utf-8.el b/lisp/international/utf-8.el index 2e4a2f6f49a..2d8791b49e3 100644 --- a/lisp/international/utf-8.el +++ b/lisp/international/utf-8.el @@ -1008,9 +1008,11 @@ Also compose particular scripts if `utf-8-compose-scripts' is non-nil." This is used as a post-read-conversion of utf-8 coding system." (if (and utf-translate-cjk-mode (not utf-translate-cjk-lang-env) - (save-excursion - (goto-char beg) - (re-search-forward "\\cc\\|\\cj\\|\\ch" end t))) + (if (stringp beg) + (string-match "\\cc\\|\\cj\\|\\ch" beg) + (save-excursion + (goto-char beg) + (re-search-forward "\\cc\\|\\cj\\|\\ch" end t)))) (utf-translate-cjk-load-tables)) nil) -- cgit v1.2.1 From 02714f8dab7805a1da831a62ccc41f3835127a4d Mon Sep 17 00:00:00 2001 From: Juanma Barranquero Date: Sat, 24 Feb 2007 03:01:11 +0000 Subject: *** empty log message *** --- lisp/ChangeLog.6 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'lisp') diff --git a/lisp/ChangeLog.6 b/lisp/ChangeLog.6 index f19459be9c1..5475a7ee100 100644 --- a/lisp/ChangeLog.6 +++ b/lisp/ChangeLog.6 @@ -5700,13 +5700,13 @@ * hippie-exp.el (he-transfer-case): Fix typo in prev change. -1995-10-13 Michael Kifer > +1995-10-13 Michael Kifer * ediff.el (ediff-version): is now autoloaded. * ediff-init.el: Moved defsubsts up. * ediff-hook.el: Now defines [window] in menu-bar-ediff-menu. -1995-10-13 Michael Kifer > +1995-10-13 Michael Kifer * viper.el (vip-set-hooks): Use view-mode-hook in emacs and view hook in xemacs. -- cgit v1.2.1 From 735895f1fa28f88c559e73910ea0ff0bda0f228c Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sat, 24 Feb 2007 13:58:35 +0000 Subject: (command-line): If simple.el cannot be found, proceed with a warning message. --- lisp/ChangeLog | 5 +++++ lisp/startup.el | 36 ++++++++++++++++++++---------------- 2 files changed, 25 insertions(+), 16 deletions(-) (limited to 'lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 164dc076dae..008979f0477 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,8 @@ +2007-02-24 Eli Zaretskii + + * startup.el (command-line): If simple.el cannot be found, proceed + with a warning message. + 2007-02-24 Kenichi Handa * international/utf-8.el (utf-8-pre-write-conversion): Handle the diff --git a/lisp/startup.el b/lisp/startup.el index 5be0e98b4bb..76bec878338 100644 --- a/lisp/startup.el +++ b/lisp/startup.el @@ -645,22 +645,26 @@ or `CVS', and any subdirectory that contains a file named `.nosearch'." (set-locale-environment nil) - ;; Convert preloaded file names to absolute. - (let ((lisp-dir - (file-truename - (file-name-directory - (locate-file "simple" load-path - (get-load-suffixes)))))) - - (setq load-history - (mapcar (lambda (elt) - (if (and (stringp (car elt)) - (not (file-name-absolute-p (car elt)))) - (cons (concat lisp-dir - (car elt)) - (cdr elt)) - elt)) - load-history))) + ;; Convert preloaded file names in load-history to absolute. + (let ((simple-file-name + (locate-file "simple" load-path (get-load-suffixes))) + lisp-dir) + ;; Don't abort if simple.el cannot be found, but print a warning. + (if (null simple-file-name) + (progn + (princ "Warning: Could not find simple.el nor simple.elc" + 'external-debugging-output) + (terpri 'external-debugging-output)) + (setq lisp-dir (file-truename (file-name-directory simple-file-name))) + (setq load-history + (mapcar (lambda (elt) + (if (and (stringp (car elt)) + (not (file-name-absolute-p (car elt)))) + (cons (concat lisp-dir + (car elt)) + (cdr elt)) + elt)) + load-history)))) ;; Convert the arguments to Emacs internal representation. (let ((args (cdr command-line-args))) -- cgit v1.2.1 From 8ae63446efeaa27dac16238ae3e2b8ffdd391fe8 Mon Sep 17 00:00:00 2001 From: John Paul Wallington Date: Sat, 24 Feb 2007 17:13:33 +0000 Subject: (rmail-message-filter): Fix custom type. --- lisp/ChangeLog | 4 ++++ lisp/mail/rmail.el | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) (limited to 'lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 008979f0477..e1ee3820644 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,7 @@ +2007-02-24 John Paul Wallington + + * mail/rmail.el (rmail-message-filter): Fix custom type. + 2007-02-24 Eli Zaretskii * startup.el (command-line): If simple.el cannot be found, proceed diff --git a/lisp/mail/rmail.el b/lisp/mail/rmail.el index 5c0412fa2be..5e534b2d47d 100644 --- a/lisp/mail/rmail.el +++ b/lisp/mail/rmail.el @@ -422,7 +422,7 @@ still the current message in the Rmail buffer.") Called with region narrowed to the message, including headers, before obeying `rmail-ignored-headers'." :group 'rmail-headers - :type 'function) + :type '(choice (const nil) function)) (defcustom rmail-automatic-folder-directives nil "List of directives specifying where to put a message. -- cgit v1.2.1 From 7c2288eaa217c795bca208a809a44de166221ee8 Mon Sep 17 00:00:00 2001 From: John Paul Wallington Date: Sat, 24 Feb 2007 17:24:29 +0000 Subject: (feedmail-message-id-generator, feedmail-date-generator): Fix custom types. --- lisp/ChangeLog | 3 +++ lisp/mail/feedmail.el | 4 ++-- 2 files changed, 5 insertions(+), 2 deletions(-) (limited to 'lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index e1ee3820644..eb1641a7742 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,5 +1,8 @@ 2007-02-24 John Paul Wallington + * mail/feedmail.el (feedmail-message-id-generator) + (feedmail-date-generator): Fix custom types. + * mail/rmail.el (rmail-message-filter): Fix custom type. 2007-02-24 Eli Zaretskii diff --git a/lisp/mail/feedmail.el b/lisp/mail/feedmail.el index 3180b05c818..b8d42debe6f 100644 --- a/lisp/mail/feedmail.el +++ b/lisp/mail/feedmail.el @@ -629,7 +629,7 @@ configurations of sendmail). Even if the latter case is true, it probably won't hurt you to generate your own, and it will then show up in the saved message if you use Fcc:." :group 'feedmail-headers - :type '(choice (const nil) function) + :type '(choice (const t) (const nil) function) ) @@ -678,7 +678,7 @@ configurations of sendmail). Even if the latter case is true, it probably won't hurt you to generate your own, and it will then show up in the saved message if you use Fcc:." :group 'feedmail-headers - :type '(choice (const nil) function) + :type '(choice (const t) (const nil) function) ) -- cgit v1.2.1 From 9bdd0e1632f3f32ac6d0fac5debcbe5f7305199b Mon Sep 17 00:00:00 2001 From: John Paul Wallington Date: Sat, 24 Feb 2007 18:07:17 +0000 Subject: (tls-certtool-program): Fix custom type. --- lisp/ChangeLog | 2 ++ lisp/net/tls.el | 2 +- 2 files changed, 3 insertions(+), 1 deletion(-) (limited to 'lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index eb1641a7742..ed6d98ab609 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,5 +1,7 @@ 2007-02-24 John Paul Wallington + * net/tls.el (tls-certtool-program): Fix custom type. + * mail/feedmail.el (feedmail-message-id-generator) (feedmail-date-generator): Fix custom types. diff --git a/lisp/net/tls.el b/lisp/net/tls.el index 0f4b1e57c14..3a9f19c819c 100644 --- a/lisp/net/tls.el +++ b/lisp/net/tls.el @@ -86,7 +86,7 @@ The default is what GNUTLS's \"gnutls-cli\" or OpenSSL's "Name of GnuTLS certtool. Used by `tls-certificate-information'." :version "22.1" - :type '(repeat string) + :type 'string :group 'tls) (defun tls-certificate-information (der) -- cgit v1.2.1 From 2863a9be6a14eefe1f7549b99932684bdb8f73e5 Mon Sep 17 00:00:00 2001 From: Dan Nicolaescu Date: Sat, 24 Feb 2007 18:29:19 +0000 Subject: (command-line): Also check if the abbrev file is readable. --- lisp/ChangeLog | 5 +++++ lisp/startup.el | 8 ++++++-- 2 files changed, 11 insertions(+), 2 deletions(-) (limited to 'lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index ed6d98ab609..a40ee053bcf 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,8 @@ +2007-02-24 Dan Nicolaescu + + * startup.el (command-line): Also check if the abbrev file is + readable. + 2007-02-24 John Paul Wallington * net/tls.el (tls-certtool-program): Fix custom type. diff --git a/lisp/startup.el b/lisp/startup.el index 76bec878338..3e26aa17409 100644 --- a/lisp/startup.el +++ b/lisp/startup.el @@ -952,8 +952,12 @@ or `CVS', and any subdirectory that contains a file named `.nosearch'." (with-current-buffer (window-buffer) (deactivate-mark))) - ;; If the user has a file of abbrevs, read it. - (if (file-exists-p abbrev-file-name) + ;; If the user has a file of abbrevs, read it. + ;; FIXME: after the 22.0 release this should be changed so + ;; that it does not read the abbrev file when -batch is used + ;; on the command line. + (when (and (file-exists-p abbrev-file-name) + (file-readable-p abbrev-file-name)) (quietly-read-abbrev-file abbrev-file-name)) ;; If the abbrevs came entirely from the init file or the -- cgit v1.2.1 From b0943f48d9c5510f1035f2aac7994a069b307195 Mon Sep 17 00:00:00 2001 From: "Kim F. Storm" Date: Sat, 24 Feb 2007 21:52:24 +0000 Subject: *** empty log message *** --- lisp/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) (limited to 'lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index a40ee053bcf..05edb5c711e 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,8 @@ +2007-02-24 Kim F. Storm + + * emulation/cua-base.el (cua-paste): Handle x-clipboard-yank. + (cua--init-keymaps): Remap x-clipboard-yank to cua-paste. + 2007-02-24 Dan Nicolaescu * startup.el (command-line): Also check if the abbrev file is -- cgit v1.2.1 From ed8bc9f8e407c104357ae8a96eef777881d4716e Mon Sep 17 00:00:00 2001 From: "Kim F. Storm" Date: Sat, 24 Feb 2007 21:52:43 +0000 Subject: (cua-paste): Handle x-clipboard-yank. (cua--init-keymaps): Remap x-clipboard-yank to cua-paste. --- lisp/emulation/cua-base.el | 3 +++ 1 file changed, 3 insertions(+) (limited to 'lisp') diff --git a/lisp/emulation/cua-base.el b/lisp/emulation/cua-base.el index 0463b01b7e3..653597fb83b 100644 --- a/lisp/emulation/cua-base.el +++ b/lisp/emulation/cua-base.el @@ -930,6 +930,8 @@ If global mark is active, copy from register or one character." (if arg (goto-char pt)))) ((eq this-original-command 'clipboard-yank) (clipboard-yank)) + ((eq this-original-command 'x-clipboard-yank) + (x-clipboard-yank)) (t (yank arg))))))) @@ -1406,6 +1408,7 @@ If ARG is the atom `-', scroll upward by nearly full screen." ;; replace region with rectangle or element on kill ring (define-key cua-global-keymap [remap yank] 'cua-paste) (define-key cua-global-keymap [remap clipboard-yank] 'cua-paste) + (define-key cua-global-keymap [remap x-clipboard-yank] 'cua-paste) ;; replace current yank with previous kill ring element (define-key cua-global-keymap [remap yank-pop] 'cua-paste-pop) ;; set mark -- cgit v1.2.1 From 483a1c2bf331a3a73241712f32cf7424b26089fe Mon Sep 17 00:00:00 2001 From: Juanma Barranquero Date: Sun, 25 Feb 2007 01:00:40 +0000 Subject: *** empty log message *** --- lisp/ChangeLog | 21 +++++++++------------ 1 file changed, 9 insertions(+), 12 deletions(-) (limited to 'lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 05edb5c711e..76da575db39 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -5,8 +5,7 @@ 2007-02-24 Dan Nicolaescu - * startup.el (command-line): Also check if the abbrev file is - readable. + * startup.el (command-line): Also check if the abbrev file is readable. 2007-02-24 John Paul Wallington @@ -27,7 +26,7 @@ * international/utf-8.el (utf-8-pre-write-conversion): Handle the case that BEG is a string. -2007-02-24 Chris Moore +2007-02-24 Chris Moore * pgg-pgp5.el (pgg-pgp5-encrypt-region): * pgg-pgp.el (pgg-pgp-encrypt-region): @@ -46,7 +45,7 @@ * comint.el (comint-read-input-ring): Use comint-input-ring-size from the comint buffer instead of the temporary one. -2007-02-23 David Reitter +2007-02-23 David Reitter * cus-edit.el (custom-save-all): Canonicalize custom-file before storing it in recentf-exclude. @@ -60,16 +59,14 @@ * progmodes/idlw-shell.el (idlwave-shell-mode): Clean up pending commands, for restart. - (idlwave-shell-current-module): Fix handling of module name by - type. + (idlwave-shell-current-module): Fix handling of module name by type. (idlwave-shell-break-in): Update type handling. (idlwave-shell-bp-get): Encode type in BP structure. - (idlwave-shell-set-bp): Fix setting condition/count on disabled - BPs. - (idlwave-shell-module-source-query): Query routine info based on - type. Fix path parsing for non-compiled files. - (idlwave-shell-module-source-filter): Don't signal error in - filter if no source found. + (idlwave-shell-set-bp): Fix setting condition/count on disabled BPs. + (idlwave-shell-module-source-query): Query routine info based on type. + Fix path parsing for non-compiled files. + (idlwave-shell-module-source-filter): Don't signal error in filter + if no source found. (idlwave-shell-set-bp-in-module): Use fallback source to prevent filter race. -- cgit v1.2.1 From d3f4dbe852fe27c5cab55ef90ae8bbbb834d98e7 Mon Sep 17 00:00:00 2001 From: Carsten Dominik Date: Sun, 25 Feb 2007 06:40:38 +0000 Subject: (org-table-overlay-coordinates) (org-table-toggle-coordinate-overlays): New functions. (org-table-overlay-coordinates, org-table-coordinate-overlays): New variables. (org-startup-with-deadline-check): Option removed. (org-mode): Remove deadline check on startup. (org-table-limit-column-width): Option removed. (org-table-formula-numbers-only): Option removed. (org-link-style, org-link-format): Options removed. (org-select-agenda-window, org-fit-agenda-window): Options removed. (org-export-ascii-show-new-buffer) (org-export-html-show-new-buffer): Options removed. (org-activate-links): Camel option removed. (org-file-link-context-use-camel-case): Option removed. (org-camel-regexp): Veriable removed. (org-activate-camels): Function removed. (org-store-link): Removed Camel stuff. (org-make-org-heading-camel): Function removed. (org-open-at-point): Removed camel stuff. (org-link-search): Removed camel stuff. (org-camel-to-words): Function removed. (org-get-agenda-file-buffer): Make sure we prepare the base buffers, not any indirect buffers. (org-sort-entries): Sort top-level when not on a headline, and no active region. (org-in-regexp): New function. (org-search-not-self): Renamed from `org-search-not-link'. (org-open-link-marker): New variable. (org-open-at-point): Set `org-open-link-marker'. (org-print-icalendar-entries): Fixed bug with excluding DONE entries from the exported list. (org-edit-formula-lisp-indent): New command. (orgtbl-to-texinfo, orgtbl-to-html): New functions. (orgtbl-to-latex, orgtbl-insert-radio-table) (orgtbl-toggle-comment, orgtbl-send-table): New functions. (orgtbl-radio-table-templates): New option. (org-store-link-props): (org-remember-templates): More possibilities to insert info into templates. (org-remember-apply-template): Make use of the extended template capabilities. (org-remember-redo-template): New command. (org-upgrade-old-links) (org-table-modify-formulas, org-table-replace-in-formulas) (org-table-find-dataline) (org-table-get-vertical-vector): Functions removed. (org-table-remove-rectangle-highlight) (org-time-stamp-format, org-toggle-log-option) (org-table-highlight-rectangle) (org-table-iterate, org-table-make-reference): (org-translate-time, org-tree-to-indirect-buffer) (org-table-field-info, org-table-fix-formulas) (org-table-force-dataline, org-table-get-descriptor-line) (org-table-get-range) (org-skip-comments, org-sort) (org-sort-entries, org-sublist, org-table-add-rectangle-overlay) (org-table-current-dline, org-table-current-field-formula) (org-table-edit-backward-field) (org-table-edit-formulas-post-command) (org-table-edit-line-down, org-table-edit-line-up) (org-agenda-archive) (org-agenda-clock-cancel) (org-agenda-clock-out, org-agenda-list-stuck-projects) (org-agenda-open-link, org-agenda-show-new-time) (org-agenda-skip-subtree-when-regexp-matches) (org-agenda-tree-to-indirect-buffer, org-agenda-undo) (org-at-regexp-p, org-auto-repeat-maybe, org-check-log-option) (org-do-sort, org-file-image-p, org-find-overlays) (org-find-row-type, org-get-indirect-buffer, org-get-repeat) (org-highlight-until-next-command, org-isearch-end) (org-match-any-p, org-next-link, org-previous-link): (org-remove-subtree-entries-from-agenda, org-replace-escapes) (org-rewrite-old-row-references) (org-isearch-post-command) (org-table-edit-move, org-table-edit-next-field) (org-table-edit-scroll, org-table-edit-scroll-down) (org-set-frame-title, org-show-reference) (org-unhighlight-once, org-verify-change-for-undo): New functions. (org-show-variable): Command removed. (org-add-log-maybe): New arguments STATE, FINDPOS (org-table-sort-lines): Rewritten from scratch. (org-link-search): New argument AVOID-POS. (org-print-icalendar-entries): Argument CATEGORY removed. (org-run-agenda-series): Argument WONDOW removed. (org-next-link, org-previous-link): New commands. (org-agenda-date-format): New option. (org-table-iterate): New command. (org-table-modify-formulas) (org-table-replace-in-formulas): Functions removed. (org-table-fix-formulas): New function. (org-table-insert-column, org-table-delete-column) (org-table-move-column): Use `org-table-fix-formulas'. (org-follow-gnus-link): Patch from Bastien/Leo. (org-table-current-field-formula): New function. (org-file-image-p): New function. (org-agenda-show-new-time): New function. (org-agenda-date-later): Call `org-agenda-show-new-time'. (org-with-remote-undo): New macro. (org-agenda-undo): New command. (org-verify-change-for-undo): New function. (org-time-stamp-format): New function. (org-agenda-get-timestamps): Skip scheduled if DONE and requested by user. (org-match-any-p): New function. (org-make-tags-matcher): Handle regular expressions for tag and todo matches. (org-read-date): Accept "+N" as input for a date relative to the current date. (org-remove-subtree-entries-from-agenda): New function. (org-agenda-archive, org-agenda-kill): Use `org-remove-subtree-entries-from-agenda'. (org-do-sort, org-sort-entries): New functions. (org-sort): New command. (org-table-sort-lines): Use `org-do-sort'. (org-fix-decoded-time): New function. (org-table-number-regexp): Require 0x... to identify as number in tables. (org-startup-options): New keywords for note taking. (org-upgrade-old-links): Function removed. (org-get-repeat): New function. (org-show-context): Also show siblings on current level. (org-show-siblings): New function. (org-isearch-end, org-isearch-post-command): New functions. (org-show-siblings): New option. (org-show-context): Use `org-show-siblings'. (org-table-maybe-recalculate-line): No longer require `calc-eval' to be bound, because user may just use elisp. --- lisp/textmodes/org.el | 21163 +++++++++++++++++++++++++++--------------------- 1 file changed, 11764 insertions(+), 9399 deletions(-) (limited to 'lisp') diff --git a/lisp/textmodes/org.el b/lisp/textmodes/org.el index a55bcdd7e25..313748e8e43 100644 --- a/lisp/textmodes/org.el +++ b/lisp/textmodes/org.el @@ -1,11 +1,11 @@ -;;; org.el --- Outline-based notes management and organize +;;;; org.el --- Outline-based notes management and organize ;; Carstens outline-mode for keeping track of everything. ;; Copyright (C) 2004, 2005, 2006, 2007 Free Software Foundation, Inc. ;; ;; Author: Carsten Dominik ;; Keywords: outlines, hypermedia, calendar, wp ;; Homepage: http://www.astro.uva.nl/~dominik/Tools/org/ -;; Version: 4.56f +;; Version: 4.67 ;; ;; This file is part of GNU Emacs. ;; @@ -59,46 +59,13 @@ ;; excellent reference card made by Philip Rooke. This card can be found ;; in the etc/ directory of Emacs 22. ;; -;; Recent changes -;; -------------- -;; Version 4.56 -;; - `C-k' in agenda kills current line and corresponding subtree in file. -;; - XEmacs compatibility issues fixed, in particular tag alignment. -;; - M-left/right now in/outdents plain list items, no Shift needed. -;; - Bug fixes. -;; -;; Version 4.55 -;; - Bug fixes. -;; -;; Version 4.54 -;; - Improvements to fast tag selection -;; + show status also in target line. -;; + option to auto-exit after first change to tags list (see manual). -;; - Tags sparse trees now also respect the settings in -;; `org-show-hierarchy-above' and `org-show-following-heading'. -;; - Bug fixes. -;; -;; Version 4.53 -;; - Custom time formats can be overlayed over time stamps. -;; - New option `org-agenda-todo-ignore-deadlines'. -;; - Work-around for flyspell bug (CVS Emacs has this fixed in flyspell.el). -;; - Work-around for session.el problem with circular data structures. -;; - Bug fixes. -;; -;; Version 4.52 -;; - TAG matches can also specify conditions on TODO keywords. -;; - The fast tag interface allows setting tags that are not in the -;; predefined list. -;; - Bug fixes. -;; -;; Version 4.51 -;; - Link abbreviations (manual section 4.5). -;; - More control over how agenda is displayed. See the new variables -;; `org-agenda-window-setup', `org-agenda-restore-windows-after-quit'. -;; - Bug fixes. +;; A list of recent changes can be found at +;; http://www.astro.uva.nl/~dominik/Tools/org/Changes ;; ;;; Code: +;;;; Require other packages + (eval-when-compile (require 'cl) (require 'gnus-sum) @@ -112,15 +79,17 @@ (require 'time-date) (require 'easymenu) -;;; Customization variables +;;;; Customization variables -(defvar org-version "4.56f" +;;; Version + +(defvar org-version "4.67" "The version number of the file org.el.") (defun org-version () (interactive) (message "Org-mode version %s" org-version)) -;; Compatibility constants +;;; Compatibility constants (defconst org-xemacs-p (featurep 'xemacs)) ; not used by org.el itself (defconst org-format-transports-properties-p (let ((x "a")) @@ -128,6 +97,8 @@ (get-text-property 0 'test (format "%s" x))) "Does format transport text properties?") +;;; The custom variables + (defgroup org nil "Outline-based notes management and organizer." :tag "Org" @@ -172,17 +143,6 @@ the following lines anywhere in the buffer: :group 'org-startup :type 'boolean) -(defcustom org-startup-with-deadline-check nil - "Non-nil means, entering Org-mode will run the deadline check. -This means, if you start editing an org file, you will get an -immediate reminder of any due deadlines. -This can also be configured on a per-file basis by adding one of -the following lines anywhere in the buffer: - #+STARTUP: dlcheck - #+STARTUP: nodlcheck" - :group 'org-startup - :type 'boolean) - (defcustom org-insert-mode-line-in-empty-file nil "Non-nil means insert the first line setting Org-mode in empty files. When the function `org-mode' is called interactively in an empty file, this @@ -210,8 +170,9 @@ S-right -> M-+ If you do not like the alternative keys, take a look at the variable `org-disputed-keys'. -This option is only relevant at load-time of Org-mode. Changing it requires -a restart of Emacs to become effective." +This option is only relevant at load-time of Org-mode, and must be set +*before* org.el is loaded. Changing it requires a restart of Emacs to +become effective." :group 'org-startup :type 'boolean) @@ -294,11 +255,114 @@ An entry can be toggled between QUOTE and normal with :group 'org-keywords :type 'string) +(defvar org-repeat-re "\\ + +\n")) + "Templates for radio tables in different major modes. +All occurrences of %n in a template will be replaced with the name of the +table, obtained by prompting the user." + :group 'org-table + :type '(repeat + (list (symbol :tag "Major mode") + (string :tag "Format")))) + (defgroup org-table-settings nil "Settings for tables in Org-mode." :tag "Org Table Settings" @@ -669,7 +706,7 @@ this variable requires a restart of Emacs to become effective." :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]+\\)$" "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. @@ -694,7 +731,7 @@ Other options offered by the customize interface are more restrictive." (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]+\\)$") (string :tag "Regexp:"))) (defcustom org-table-number-fraction 0.5 @@ -717,11 +754,6 @@ removal/insertion." :group 'org-table-editing :type 'boolean) -(defcustom org-table-limit-column-width t ;kw - "Non-nil means, allow to limit the width of table columns with fields." - :group 'org-table-editing - :type 'boolean) - (defcustom org-table-auto-blank-field t "Non-nil means, automatically blank table field when starting to type into it. This only happens when typing immediately after a field motion @@ -783,7 +815,9 @@ the command \\[org-table-eval-formula]." :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 @@ -806,14 +840,6 @@ and then use it in an equation like `$1*$c'." (cons (string :tag "name") (string :tag "value")))) -(defcustom org-table-formula-numbers-only nil - "Non-nil means, calculate only with numbers in table formulas. -Then all input fields will be converted to a number, and the result -must also be a number. When nil, calc's full potential is available -in table calculations, including symbolics etc." - :group 'org-table-calculation - :type 'boolean) - (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." @@ -836,7 +862,7 @@ The car of each element is a string, to be replaced at the start of a link. The cdrs are replacement values, like (\"linkkey\" . REPLACE). Abbreviated links in Org-mode buffers can have an optional tag after a double colon, e.g. - [[linkkey::tag][description]] + [[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 @@ -853,30 +879,6 @@ per-buffer basis from the Org->Hyperlinks menu." :group 'org-link :type 'boolean) -(defcustom org-link-style 'bracket - "The style of links to be inserted with \\[org-insert-link]. -Possible values are: -bracket [[link][description]]. This is recommended -plain Description \\n link. The old way, no longer recommended." - :group 'org-link - :type '(choice - (const :tag "Bracket (recommended)" bracket) - (const :tag "Plain (no longer recommended)" plain))) - -(defcustom org-link-format "%s" - "Default format for external, URL-like linkes in the buffer. -This is a format string for printf, %s will be replaced by the link text. -The recommended value is just \"%s\", since links will be protected by -enclosing them in double brackets. If you prefer plain links (see variable -`org-link-style'), \"<%s>\" is useful. Some people also recommend an -additional URL: prefix, so the format would be \"\"." - :group 'org-link - :type '(choice - (const :tag "\"%s\" (e.g. http://www.there.com)" "%s") - (const :tag "\"<%s>\" (e.g. )" "<%s>") - (const :tag "\"\" (e.g. )" "") - (string :tag "Other" :value "<%s>"))) - (defcustom org-link-file-path-type 'adaptive "How the path name in file links should be stored. Valid values are: @@ -907,7 +909,6 @@ plain Plain links in normal text, no whitespace, like http://google.com. radio Text that is matched by a radio target, see manual for details. tag Tag settings in a headline (link to tag search). date Time stamps (link to calendar). -camel CamelCase words defining text searches. Changing this variable requires a restart of Emacs to become effective." :group 'org-link @@ -916,14 +917,45 @@ Changing this variable requires a restart of Emacs to become effective." (const :tag "plain text links" plain) (const :tag "Radio target matches" radio) (const :tag "Tags" tag) - (const :tag "Timestamps" date) - (const :tag "CamelCase words" camel))) + (const :tag "Timestamps" date))) (defgroup org-link-store nil "Options concerning storing links in Org-mode" :tag "Org Store Link" :group 'org-link) +(defcustom org-email-link-description-format "Email %c: %.30s" + "Format of the description part of a link to an email or usenet message. +The following %-excapes will be replaced by corresponding information: + +%F full \"From\" field +%f name, taken from \"From\" field, address if no name +%T full \"To\" field +%t first name in \"To\" field, address if no name +%c correspondent. Unually \"from NAME\", but if you sent it yourself, it + will be \"to NAME\". See also the variable `org-from-is-user-regexp'. +%s subject +%m message-id. + +You may use normal field width specification between the % and the letter. +This is for example useful to limit the length of the subject. + +Examples: \"%f on: %.30s\", \"Email from %f\", \"Email %c\"" + :group 'org-link-store + :type 'string) + +(defcustom org-from-is-user-regexp + (let (r1 r2) + (when (and user-mail-address (not (string= user-mail-address ""))) + (setq r1 (concat "\\<" (regexp-quote user-mail-address) "\\>"))) + (when (and user-full-name (not (string= user-full-name ""))) + (setq r2 (concat "\\<" (regexp-quote user-full-name) "\\>"))) + (if (and r1 r2) (concat r1 "\\|" r2) (or r1 r2))) + "Regexp mached against the \"From:\" header of an email or usenet message. +It should match if the message is from the user him/herself." + :group 'org-link-store + :type 'regexp) + (defcustom org-context-in-file-links t "Non-nil means, file links from `org-store-link' contain context. A search string will be added to the file name with :: as separator and @@ -934,13 +966,6 @@ negates this setting for the duration of the command." :group 'org-link-store :type 'boolean) -(defcustom org-file-link-context-use-camel-case nil - "Non-nil means, use CamelCase to store a search context in a file link. -When nil, the search string simply consists of the words of the string. -CamelCase is deprecated, and support for it may be dropped in the future." - :group 'org-link-store - :type 'boolean) - (defcustom org-keep-stored-link-after-insertion nil "Non-nil means, keep link in list for entire session. @@ -1041,9 +1066,8 @@ changes to the current buffer." :group 'org-link-follow :type 'boolean) - (defcustom org-open-non-existing-files nil - "Non-nil means, `org-open-file' will open non-existing file. + "Non-nil means, `org-open-file' will open non-existing files. When nil, an error will be generated." :group 'org-link-follow :type 'boolean) @@ -1176,7 +1200,7 @@ For more examples, see the system specific constants (defcustom org-mhe-search-all-folders nil "Non-nil means, that the search for the mh-message will be extended to all folders if the message cannot be found in the folder given in the link. -Searching all folders is very effective with one of the search engines +Searching all folders is very efficient with one of the search engines supported by MH-E, but will be slow with pick." :group 'org-link-follow :type 'boolean) @@ -1196,39 +1220,83 @@ Used by the hooks for remember.el." (defcustom org-default-notes-file "~/.notes" "Default target for storing notes. Used by the hooks for remember.el. This can be a string, or nil to mean -the value of `remember-data-file'." +the value of `remember-data-file'. +You can set this on a per-template basis with the variable +`org-remember-templates'." :group 'org-remember :type '(choice (const :tag "Default from remember-data-file" nil) file)) +(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. +You can set this on a per-template basis with the variable +`org-remember-templates'." + :group 'org-remember + :type 'string) + (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 3-element lists. In each entry, the first +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 specify a destination file for remember items created with this template. -The default file is given by `org-default-notes-file'. +The default file is given by `org-default-notes-file'. An optional third +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'. 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: - %t time stamp, date only - %T time stamp with date and time - %u inactive time stamp, date only - %U inactive time stamp with date and time - %n user 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. - %? This will be removed, and the cursor placed at this position." + + %^{prompt} prompt the user for a string and replace this sequence with it. + %t time stamp, date only + %T time stamp with date and time + %u, %U like the above, but inactive time stamps + %^t like %t, but prompt for date. Similarly %^T, %^u, %^U + 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. + + %? After completing the template, position cursor here. + +Apart from these general escapes, you can access information specific to the +link type that is created. For example, calling `remember' in emails or gnus +will record the author and the subject of the message, which you can access +with %:author and %:subject, respectively. Here is a complete list of what +is recorded for each link type. + +Link type | Available information +-------------------+------------------------------------------------------ +bbdb | %:type %:name %:company +vm, wl, mh, rmail | %:type %:subject %:message-id + | %:from %:fromname %:fromaddress + | %:to %:toname %:toaddress + | %:fromto (either \"to NAME\" or \"from NAME\") +gnus | %:group, for messages also all email fields +w3, w3m | %:type %:url +info | %:type %:file %:node +calendar | %:type %:date" :group 'org-remember - :type '(repeat :tag "enabled" - (list :value (?a "\n" nil) - (character :tag "Selection Key") - (string :tag "Template") - (file :tag "Destination file (optional)")))) + :get (lambda (var) ; Make sure all entries have 4 elements + (mapcar (lambda (x) + (cond ((= (length x) 3) (append x '(""))) + ((= (length x) 2) (append x '("" ""))) + (t x))) + (default-value var))) + :type '(repeat + :tag "enabled" + (list :value (?a "\n" nil nil) + (character :tag "Selection Key") + (string :tag "Template") + (file :tag "Destination file (optional)") + (string :tag "Destination headline (optional)")))) (defcustom org-reverse-note-order nil "Non-nil means, store new notes at the beginning of a file or entry. @@ -1245,6 +1313,11 @@ When nil, new notes will be filed to the end of a file or entry." :tag "Org TODO" :group 'org) +(defgroup org-progress nil + "Options concerning Progress logging in Org-mode." + :tag "Org Progress" + :group 'org-time) + (defcustom org-todo-keywords '("TODO" "DONE") "List of TODO entry keywords. \\By default, this is '(\"TODO\" \"DONE\"). The last entry in the list is @@ -1291,6 +1364,10 @@ the time stamp recording the action should be annotated with a short note. 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. @@ -1301,26 +1378,51 @@ timestamp, as a plain list item. See also the variable Logging can also be configured on a per-file basis by adding one of the following lines anywhere in the buffer: - #+STARTUP: logging - #+STARTUP: nologging" -;; FIXME: in-buffer words for notes??????? + #+STARTUP: logdone + #+STARTUP: nologging + #+STARTUP: lognotedone + #+STARTUP: lognotestate + #+STARTUP: lognoteclock-out" :group 'org-todo + :group 'org-progress :type '(choice (const :tag "off" nil) (const :tag "on" t) - (set :tag "on, with notes" :greedy t :value (done) - (const done) (const clock-out)))) - -(defcustom org-log-note-headings '((done . "CLOSING NOTE") (clock-out . "")) + (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)))) + +(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 context, and the cdr is the heading to be used. The heading may also be the -empty string." +empty string. +%t in the heading will be replaced by a time stamp. +%s will be replaced by the new TODO state, in double quotes. +%u will be replaced by the user name. +%U will be replaced by the full user name." :group 'org-todo + :group 'org-progress :type '(list :greedy t (cons (const :tag "Heading when closing an item" done) string) + (cons (const :tag + "Heading when changing todo state (todo sequence only)" + 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." + :group 'org-todo + :group 'org-progress + :type 'boolean) + (defgroup org-priorities nil "Priorities in Org-mode." :tag "Org Priorities" @@ -1381,6 +1483,14 @@ These are overlayed over the default ISO format if the variable :group 'org-time :type 'sexp) +(defun org-time-stamp-format (&optional long inactive) + "Get the right format for a time string." + (let ((f (if long (cdr org-time-stamp-formats) + (car org-time-stamp-formats)))) + (if inactive + (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." @@ -1440,9 +1550,14 @@ automatically if necessary." (defcustom org-fast-tag-selection-single-key nil "Non-nil means, fast tag selection exits after first change. When nil, you have to press RET to exit it. -During fast tag selection, you can toggle this flag with `C-c'." +During fast tag selection, you can toggle this flag with `C-c'. +This variable can also have the value `expert'. In this case, the window +displaying the tags menu is not even shown, until you press C-c again." :group 'org-tags - :type 'boolean) + :type '(choice + (const :tag "No" nil) + (const :tag "Yes" t) + (const :tag "Expert" expert))) (defcustom org-tags-column 48 "The column to which tags should be indented in a headline. @@ -1489,7 +1604,7 @@ make sure all corresponding TODO items find their way into the list." "The last used completion table for tags.") (defgroup org-agenda nil - "Options concerning agenda display Org-mode." + "Options concerning agenda views in Org-mode." :tag "Org Agenda" :group 'org) @@ -1520,8 +1635,31 @@ agenda file per line." (repeat :tag "List of files" file) (file :tag "Store list in a file\n" :value "~/.agenda_files"))) -(defcustom org-agenda-custom-commands ;'(("w" todo "WAITING")) -'(("w" todo "WAITING" ((aaa 1) (bbb 2)))) + +(defcustom org-agenda-confirm-kill 1 + "When set, remote killing from the agenda buffer needs confirmation. +When t, a confirmation is always needed. When a number N, confirmation is +only needed when the text to be killed contains more than N non-white lines." + :group 'org-agenda + :type '(choice + (const :tag "Never" nil) + (const :tag "Always" t) + (number :tag "When more than N lines"))) + +(defcustom org-calendar-to-agenda-key [?c] + "The key to be installed in `calendar-mode-map' for switching to the agenda. +The command `org-calendar-goto-agenda' will be bound to this key. The +default is the character `c' because then `c' can be used to switch back and +forth between agenda and calendar." + :group 'org-agenda + :type 'sexp) + +(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")) "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: @@ -1556,6 +1694,7 @@ cmd An agenda command, similar to the above. However, tree commands So valid commands for a set are: (agenda) (alltodo) + (stuck) (todo \"match\" options) (tags \"match\" options ) (tags-todo \"match\" options) @@ -1563,7 +1702,7 @@ cmd An agenda command, similar to the above. However, tree commands 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." - :group 'org-agenda + :group 'org-agenda-custom-commands :type '(repeat (choice (list :tag "Single command" @@ -1574,7 +1713,8 @@ precedence over the general options." (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)) + (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")))) @@ -1585,6 +1725,7 @@ precedence over the general options." (choice (const :tag "Agenda" (agenda)) (const :tag "TODO list" (alltodo)) + (const :tag "Stuck projects" (stuck)) (list :tag "Tags search" (const :format "" tags) (string :tag "Match") @@ -1602,18 +1743,53 @@ precedence over the general options." (list :tag "TODO keyword search" (const :format "" todo) (string :tag "Match") + (repeat :tag "Local options" + (list (variable :tag "Option") + (sexp :tag "Value")))) + + (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"))))))) +(defcustom org-stuck-projects + '("+LEVEL=2/-DONE" ("TODO" "NEXT" "NEXTACTION") nil) + "How to identify stuck projects. +This is a list of three 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. + If the project subtree contains any headline with one of these todo + keywords, the project is consitered to be not stuck. +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. + +After defining this variable, you may use \\[org-agenda-list-stuck-projects] +or `C-c a #' to produce the list." + :group 'org-agenda-custom-commands + :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)))) + + +(defgroup org-agenda-skip nil + "Options concerning skipping parts of agenda files." + :tag "Org Agenda Skip" + :group 'org-agenda) + (defcustom org-agenda-todo-list-sublevels t "Non-nil means, check also the sublevels of a TODO entry for TODO entries. When nil, the sublevels of a TODO entry are not checked, resulting in potentially much shorter TODO lists." - :group 'org-agenda + :group 'org-agenda-skip :group 'org-todo :type 'boolean) @@ -1621,7 +1797,7 @@ potentially much shorter TODO lists." "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." - :group 'org-agenda + :group 'org-agenda-skip :group 'org-todo :type 'boolean) @@ -1629,10 +1805,15 @@ of this item." "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." - :group 'org-agenda + :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." + :group 'org-agenda-skip + :type 'boolean) (defcustom org-timeline-show-empty-dates 3 "Non-nil means, `org-timeline' also shows dates without an entry. @@ -1640,46 +1821,38 @@ When nil, only the days which actually have entries are shown. 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 + :group 'org-agenda-skip :type '(choice (const :tag "None" nil) (const :tag "All" t) (number :tag "at most"))) -(defcustom org-agenda-confirm-kill 1 - "When set, remote killing from the agenda buffer needs confirmation. -When t, a confirmation is always needed. When a number N, confirmation is -only needed when the text to be killed contains more than N non-white lines." - :group 'org-agenda ;; FIXME - :type '(choice - (const :tag "Never" nil) - (const :tag "Always" t) - (number :tag "When more than N lines"))) -;; FIXME: This variable could be removed -(defcustom org-agenda-include-all-todo nil - "Set means weekly/daily agenda will always contain all TODO entries. -The TODO entries will be listed at the top of the agenda, before -the entries for specific days." - :group 'org-agenda - :type 'boolean) +(defgroup org-agenda-startup nil + "Options concerning initial settings in the Agenda in Org Mode." + :tag "Org Agenda Startup" + :group 'org-agenda) -(defcustom org-agenda-include-diary nil - "If non-nil, include in the agenda entries from the Emacs Calendar's diary." - :group 'org-agenda +(defcustom org-finalize-agenda-hook nil + "Hook run just before displaying an agenda buffer." + :group 'org-agenda-startup + :type 'hook) + +(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. +Needs to be set before org.el is loaded." + :group 'org-agenda-startup :type 'boolean) -(defcustom org-calendar-to-agenda-key [?c] - "The key to be installed in `calendar-mode-map' for switching to the agenda. -The command `org-calendar-goto-agenda' will be bound to this key. The -default is the character `c' because then `c' can be used to switch back and -forth between agenda and calendar." - :group 'org-agenda - :type 'sexp) +(defcustom org-agenda-start-with-follow-mode nil + "The initial value of follwo-mode in a newly created agenda window." + :group 'org-agenda-startup + :type 'boolean) -(defgroup org-agenda-setup nil - "Options concerning setting up the Agenda window in Org Mode." - :tag "Org Agenda Window Setup" +(defgroup org-agenda-windows nil + "Options concerning the windows used by the Agenda in Org Mode." + :tag "Org Agenda Windows" :group 'org-agenda) (defcustom org-agenda-window-setup 'reorganize-frame @@ -1690,11 +1863,9 @@ current-window Show agenda in the current window, keeping all other windows. other-frame Use `switch-to-buffer-other-frame' to display agenda. other-window Use `switch-to-buffer-other-window' to display agenda. reorganize-frame Show only two windows on the current frame, the current - window and the agenda. Also, if the option - `org-fit-agenda-window' is set, resize the agenda window to - try to show as much as possible of the buffer content. + window and the agenda. See also the variable `org-agenda-restore-windows-after-quit'." - :group 'org-agenda-setup + :group 'org-agenda-windows :type '(choice (const current-window) (const other-frame) @@ -1708,64 +1879,75 @@ the current status is recorded. When the agenda is exited with `q' or `x' and this option is set, the old state is restored. If `org-agenda-window-setup' is `other-frame', the value of this option will be ignored.." - :group 'org-agenda-setup - :type 'boolean) - -;; FIXME: I think this variable could be removed. -(defcustom org-select-agenda-window t - "Non-nil means, after creating an agenda, move cursor into Agenda window. -When nil, cursor will remain in the current window." - :group 'org-agenda-setup + :group 'org-agenda-windows :type 'boolean) -;; FIXME: I think this variable could be removed. -(defcustom org-fit-agenda-window t - "Non-nil means, change window size of agenda to fit content. -This is only effective if `org-agenda-window-setup' is `reorganize-frame'." - :group 'org-agenda-setup - :type 'boolean) +(defcustom org-indirect-buffer-display 'other-window + "How should indirect tree buffers be displayed? +This applies to indirect buffers created with the commands +\\[org-tree-to-indirect-buffer] and \\[org-agenda-tree-to-indirect-buffer]. +Valid values are: +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." + :group 'org-structure + :group 'org-agenda-windows + :type '(choice + (const :tag "In current window" current-window) + (const :tag "In current frame, other window" other-window) + (const :tag "Each time a new frame" new-frame) + (const :tag "One dedicated frame" dedicated-frame))) + +(defgroup org-agenda-daily/weekly nil + "Options concerning the daily/weekly agenda." + :tag "Org Agenda Daily/Weekly" + :group 'org-agenda) -(defcustom org-finalize-agenda-hook nil - "Hook run just before displaying an agenda buffer." - :group 'org-agenda-setup - :type 'hook) - -(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. -Needs to be set before org.el is loaded." - :group 'org-agenda-setup - :type 'boolean) - -(defcustom org-agenda-start-with-follow-mode nil - "The initial value of follwo-mode in a newly created agenda window." - :group 'org-agenda-setup - :type 'boolean) - -(defgroup org-agenda-display nil - "Options concerning what to display initially in Agenda." - :tag "Org Agenda Display" - :group 'org-agenda) - -(defcustom org-agenda-show-all-dates t - "Non-nil means, `org-agenda' shows every day in the selected range. -When nil, only the days which actually have entries are shown." - :group 'org-agenda-display - :type 'boolean) +(defcustom org-agenda-ndays 7 + "Number of days to include in overview display. +Should be 1 or 7." + :group 'org-agenda-daily/weekly + :type 'number) (defcustom org-agenda-start-on-weekday 1 "Non-nil means, start the overview always on the specified weekday. 0 denotes Sunday, 1 denotes Monday etc. When nil, always start on the current day." - :group 'org-agenda-display + :group 'org-agenda-daily/weekly :type '(choice (const :tag "Today" nil) (number :tag "Weekday No."))) -(defcustom org-agenda-ndays 7 - "Number of days to include in overview display. -Should be 1 or 7." - :group 'org-agenda-display - :type 'number) +(defcustom org-agenda-show-all-dates t + "Non-nil means, `org-agenda' shows every day in the selected range. +When nil, only the days which actually have entries are shown." + :group 'org-agenda-daily/weekly + :type 'boolean) + +(defcustom org-agenda-date-format "%A %d %B %Y" + "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." + :group 'org-agenda-daily/weekly + :type 'string) + +(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-include-all-todo nil + "Set means weekly/daily agenda will always contain all TODO entries. +The TODO entries will be listed at the top of the agenda, before +the entries for specific days." + :group 'org-agenda-daily/weekly + :type 'boolean) + +(defgroup org-agenda-time-grid nil + "Options concerning the time grid in the Org-mode Agenda." + :tag "Org Agenda Time Grid" + :group 'org-agenda) (defcustom org-agenda-use-time-grid t "Non-nil means, show a time grid in the agenda schedule. @@ -1774,7 +1956,7 @@ A time grid is a set of lines for specific times (like every two hours between sorted in between these lines. For details about when the grid will be shown, and what it will look like, see the variable `org-agenda-time-grid'." - :group 'org-agenda-display + :group 'org-agenda-time-grid :type 'boolean) (defcustom org-agenda-time-grid @@ -1795,7 +1977,7 @@ The second item is a string which will be places behing the grid time. The third item is a list of integers, indicating the times that should have a grid line." - :group 'org-agenda-display + :group 'org-agenda-time-grid :type '(list (set :greedy t :tag "Grid Display Options" @@ -1809,6 +1991,11 @@ a grid line." (string :tag "Grid String") (repeat :tag "Grid Times" (integer :tag "Time")))) +(defgroup org-agenda-sorting nil + "Options concerning sorting in the Org-mode Agenda." + :tag "Org Agenda Sorting" + :group 'org-agenda) + (let ((sorting-choice '(choice (const time-up) (const time-down) @@ -1848,7 +2035,7 @@ priority. Leaving out `category-keep' would mean that items will be sorted across categories by priority." - :group 'org-agenda-display + :group 'org-agenda-sorting :type `(choice (repeat :tag "General" ,sorting-choice) (list :tag "Individually" @@ -1866,7 +2053,7 @@ time like 15:30 will be considered as 99:01, i.e. later than any items which do have a time. When nil, the default time is before 0:00. You can use this option to decide if the schedule for today should come before or after timeless agenda entries." - :group 'org-agenda-display + :group 'org-agenda-sorting :type 'boolean) (defgroup org-agenda-prefix nil @@ -2070,15 +2257,24 @@ This option can also be set with the +OPTIONS line, e.g. \"num:t\"." (defcustom org-export-with-toc t "Non-nil means, create a table of contents in exported files. The TOC contains headlines with levels up to`org-export-headline-levels'. +When an integer, include levels up to N in the toc, this may then be +different from `org-export-headline-levels', but it will not be allowed +to be larger than the number of headline levels. +When nil, no table of contents is made. Headlines which contain any TODO items will be marked with \"(*)\" in -ASCII export, and with red color in HTML output. +ASCII export, and with red color in HTML output, if the option +`org-export-mark-todo-in-toc' is set. In HTML output, the TOC will be clickable. -This option can also be set with the +OPTIONS line, e.g. \"toc:nil\"." +This option can also be set with the +OPTIONS line, e.g. \"toc:nil\" +or \"toc:3\"." :group 'org-export-general - :type 'boolean) + :type '(choice + (const :tag "No Table of Contents" nil) + (const :tag "Full Table of Contents" t) + (integer :tag "TOC to level"))) (defcustom org-export-mark-todo-in-toc nil "Non-nil means, mark TOC lines that contain any open TODO items." @@ -2279,12 +2475,6 @@ Org-mode file." :group 'org-export-ascii :type '(repeat character)) -(defcustom org-export-ascii-show-new-buffer t - "Non-nil means, popup buffer containing the exported ASCII text. -Otherwise the buffer will just be saved to a file and stay hidden." - :group 'org-export-ascii - :type 'boolean) - (defgroup org-export-xml nil "Options specific for XML export of Org-mode files." :tag "Org Export XML" @@ -2317,7 +2507,7 @@ Otherwise the buffer will just be saved to a file and stay hidden." table { border-collapse: collapse; } td, th { vertical-align: top; - border: 1pt solid #ADB9CC; + } " "The default style specification for exported HTML files. @@ -2377,6 +2567,7 @@ be linked only." (const :tag "Always" t) (const :tag "When there is no description" maybe))) +;; FIXME: rename (defcustom org-export-html-expand t "Non-nil means, for HTML export, treat @<...> as HTML tag. When nil, these tags will be exported as plain text and therefore @@ -2387,7 +2578,7 @@ This option can also be set with the +OPTIONS line, e.g. \"@:nil\"." :type 'boolean) (defcustom org-export-html-table-tag - "" + "
" "The HTML tag used to start a table. This must be a
tag, but you may change the options like borders and spacing." @@ -2407,12 +2598,6 @@ to a file." :group 'org-export-html :type 'string) -(defcustom org-export-html-show-new-buffer nil - "Non-nil means, popup buffer containing the exported html text. -Otherwise, the buffer will just be saved to a file and stay hidden." - :group 'org-export-html - :type 'boolean) - (defgroup org-export-icalendar nil "Options specific for iCalendar export of Org-mode files." :tag "Org Export iCalendar" @@ -2428,7 +2613,10 @@ The file name should be absolute." (defcustom org-icalendar-include-todo nil "Non-nil means, export to iCalendar files should also cover TODO items." :group 'org-export-icalendar - :type 'boolean) + :type '(choice + (const :tag "None" nil) + (const :tag "Unfinished" t) + (const :tag "All" all))) (defcustom org-icalendar-combined-name "OrgMode" "Calendar name for the combined iCalendar representing all agenda files." @@ -2521,7 +2709,7 @@ Changing this variable requires a restart of Emacs to take effect." "\\([" post (if stacked markers) "]\\|$\\)"))))) (defcustom org-emphasis-regexp-components - '(" \t(" " \t.,?;'\")" " \t\r\n," "." 1 nil) + '(" \t('\"" " \t.,?;'\")" " \t\r\n," "." 1 nil) "Components used to build the reqular 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 @@ -2575,6 +2763,8 @@ Use customize to modify this, or restart Emacs after changing it." (string :tag "HTML start tag") (string :tag "HTML end tag")))) +;;; The faces + (defgroup org-faces nil "Faces in Org-mode." :tag "Org Faces" @@ -2829,7 +3019,8 @@ This face is only used if `org-fontify-done-headline' is set." (defconst org-n-levels (length org-level-faces)) -;; Variables for pre-computed regular expressions, all buffer local +;;; 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) @@ -2881,14 +3072,17 @@ Also put tags into group 4 if tags are present.") (make-variable-buffer-local 'org-closed-time-regexp) (defvar org-keyword-time-regexp nil - "Matches any of the 3 keywords, together with the time stamp.") + "Matches any of the 4 keywords, together with the time stamp.") (make-variable-buffer-local 'org-keyword-time-regexp) +(defvar org-keyword-time-not-clock-regexp nil + "Matches any of the 3 keywords, together with the time stamp.") +(make-variable-buffer-local 'org-keyword-time-not-clock-regexp) (defvar org-maybe-keyword-time-regexp nil "Matches a timestamp, possibly preceeded by a keyword.") -(make-variable-buffer-local 'org-keyword-time-regexp) +(make-variable-buffer-local 'org-maybe-keyword-time-regexp) (defconst org-rm-props '(invisible t face t keymap t intangible t mouse-face t - rear-nonsticky t mouse-map t) + rear-nonsticky t mouse-map t fontified t) "Properties to remove when a string without properties is wanted.") (defsubst org-match-string-no-properties (num &optional string) @@ -2927,7 +3121,6 @@ Also put tags into group 4 if tags are present.") (defun org-let2 (list1 list2 &rest body) (eval (cons 'let (cons list1 (list (cons 'let (cons list2 body))))))) (put 'org-let2 'lisp-indent-function 2) - (defconst org-startup-options '(("fold" org-startup-folded t) ("overview" org-startup-folded t) @@ -2942,9 +3135,16 @@ Also put tags into group 4 if tags are present.") ("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) - ("dlcheck" org-startup-with-deadline-check t) - ("nodlcheck" org-startup-with-deadline-check nil))) + ("lognotedone" org-log-done done push) + ("lognotestate" org-log-done state push) + ("lognoteclock-out" org-log-done clock-out push)) + "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 +set this variable to if the option is found. An optional forth element PUSH +means to push this value onto the list in the variable.") (defun org-set-regexps-and-options () "Precompute regular expressions for current buffer." @@ -2986,7 +3186,12 @@ Also put tags into group 4 if tags are present.") l var val) (while (setq l (assoc (pop opts) org-startup-options)) (setq var (nth 1 l) val (nth 2 l)) - (set (make-local-variable var) val)))) + (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)) @@ -3059,6 +3264,11 @@ Also put tags into group 4 if tags are present.") "\\|" org-closed-string "\\|" org-clock-string "\\)" " *[[<]\\([^]>]+\\)[]>]") + org-keyword-time-not-clock-regexp + (concat "\\<\\(" org-scheduled-string + "\\|" org-deadline-string + "\\|" org-closed-string "\\)" + " *[[<]\\([^]>]+\\)[]>]") org-maybe-keyword-time-regexp (concat "\\(\\<\\(" org-scheduled-string "\\|" org-deadline-string @@ -3068,70 +3278,194 @@ Also put tags into group 4 if tags are present.") (org-set-font-lock-defaults))) -;; Tell the compiler about dynamically scoped variables, -;; and variables from other packages -(defvar calc-embedded-close-formula) ; defined by the calc package -(defvar calc-embedded-open-formula) ; defined by the calc package -(defvar font-lock-unfontify-region-function) ; defined by font-lock.el + +;;; Some variables ujsed in various places + +(defvar org-window-configuration nil + "Used in various places to store a window configuration.") +(defvar org-finish-function nil + "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 -(defvar original-date) ; dynamically scoped in calendar -(defvar org-old-auto-fill-inhibit-regexp) ; local variable used by `orgtbl-mode' -(defvar orgtbl-mode-menu) ; defined when orgtbl mode get initialized -(defvar org-html-entities) ; defined later in this file -(defvar org-goto-start-pos) ; dynamically scoped parameter -(defvar org-time-was-given) ; dynamically scoped parameter -(defvar org-ts-what) ; dynamically scoped parameter -(defvar org-current-export-file) ; dynamically scoped parameter -(defvar org-current-export-dir) ; dynamically scoped parameter -(defvar mark-active) ; Emacs only, not available in XEmacs. -(defvar timecnt) ; dynamically scoped parameter -(defvar levels-open) ; dynamically scoped parameter -(defvar entry) ; dynamically scoped parameter -(defvar state) ; dynamically scoped into `org-after-todo-state-change-hook' -(defvar date) ; dynamically scoped parameter -(defvar description) ; dynamically scoped parameter -(defvar ans1) ; dynamically scoped parameter -(defvar ans2) ; dynamically scoped parameter -(defvar starting-day) ; local variable -(defvar include-all-loc) ; local variable -(defvar vm-message-pointer) ; from vm -(defvar vm-folder-directory) ; from vm -(defvar gnus-other-frame-object) ; from gnus -(defvar wl-summary-buffer-elmo-folder) ; from wanderlust -(defvar wl-summary-buffer-folder-name) ; from wanderlust -(defvar gnus-group-name) ; from gnus -(defvar gnus-article-current) ; from gnus -(defvar w3m-current-url) ; from w3m -(defvar w3m-current-title) ; from w3m -(defvar mh-progs) ; from MH-E -(defvar mh-current-folder) ; from MH-E -(defvar mh-show-folder-buffer) ; from MH-E -(defvar mh-index-folder) ; from MH-E -(defvar mh-searcher) ; from MH-E -(defvar org-selected-point) ; dynamically scoped parameter -(defvar calendar-mode-map) ; from calendar.el -(defvar last-arg) ; local variable -(defvar remember-save-after-remembering) ; from remember.el -(defvar remember-data-file) ; from remember.el +;; 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 orgtbl-mode) ; defined later in this file -(defvar Info-current-file) ; from info.el -(defvar Info-current-node) ; from info.el -(defvar texmathp-why) ; from texmathp.el (defvar org-latex-regexps) -(defvar outline-mode-menu-heading) -(defvar outline-mode-menu-show) -(defvar outline-mode-menu-hide) -;;; Define the mode +(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 entry) +(defvar state) +(defvar last-state) +(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-undo-list) +(defvar org-agenda-pending-undo-list) +(defvar org-agenda-overriding-header) +(defvar orgtbl-mode) +(defvar org-html-entities) +(defvar org-struct-menu) +(defvar org-org-menu) +(defvar org-tbl-menu) +(defvar org-agenda-keymap) +(defvar org-category-table) + +;;;; Emacs/XEmacs compatibility + +;; Overlay compatibility functions +(defun org-make-overlay (beg end &optional buffer) + (if (featurep 'xemacs) + (make-extent beg end buffer) + (make-overlay beg end buffer))) +(defun org-delete-overlay (ovl) + (if (featurep 'xemacs) (delete-extent ovl) (delete-overlay ovl))) +(defun org-detach-overlay (ovl) + (if (featurep 'xemacs) (detach-extent ovl) (delete-overlay ovl))) +(defun org-move-overlay (ovl beg end &optional buffer) + (if (featurep 'xemacs) + (set-extent-endpoints ovl beg end (or buffer (current-buffer))) + (move-overlay ovl beg end buffer))) +(defun org-overlay-put (ovl prop value) + (if (featurep 'xemacs) + (set-extent-property ovl prop value) + (overlay-put ovl prop value))) +(defun org-overlay-display (ovl text &optional face evap) + "Make overlay OVL display TEXT with face FACE." + (if (featurep 'xemacs) + (let ((gl (make-glyph text))) + (and face (set-glyph-face gl face)) + (set-extent-property ovl 'invisible t) + (set-extent-property ovl 'end-glyph gl)) + (overlay-put ovl 'display text) + (if face (overlay-put ovl 'face face)) + (if evap (overlay-put ovl 'evaporate t)))) +(defun org-overlay-before-string (ovl text &optional face evap) + "Make overlay OVL display TEXT with face FACE." + (if (featurep 'xemacs) + (let ((gl (make-glyph text))) + (and face (set-glyph-face gl face)) + (set-extent-property ovl 'begin-glyph gl)) + (if face (org-add-props text nil 'face face)) + (overlay-put ovl 'before-string text) + (if evap (overlay-put ovl 'evaporate t)))) +(defun org-overlay-get (ovl prop) + (if (featurep 'xemacs) + (extent-property ovl prop) + (overlay-get ovl prop))) +(defun org-overlays-at (pos) + (if (featurep 'xemacs) (extents-at pos) (overlays-at pos))) +(defun org-overlays-in (&optional start end) + (if (featurep 'xemacs) + (extent-list nil start end) + (overlays-in start end))) +(defun org-overlay-start (o) + (if (featurep 'xemacs) (extent-start-position o) (overlay-start o))) +(defun org-overlay-end (o) + (if (featurep 'xemacs) (extent-end-position o) (overlay-end o))) +(defun org-find-overlays (prop &optional pos delete) + "Find all overlays specifying PROP at POS or point. +If DELETE is non-nil, delete all those overlays." + (let ((overlays (org-overlays-at (or pos (point)))) + ov found) + (while (setq ov (pop overlays)) + (if (org-overlay-get ov prop) + (if delete (org-delete-overlay ov) (push ov found)))) + found)) + +;; Region compatibility + +(defun org-add-hook (hook function &optional append local) + "Add-hook, compatible with both Emacsen." + (if (and local (featurep 'xemacs)) + (add-local-hook hook function append) + (add-hook hook function append local))) + +(defvar org-ignore-region nil + "To temporarily disable the active region.") + +(defun org-region-active-p () + "Is `transient-mark-mode' on and the region active? +Works on both Emacs and XEmacs." + (if org-ignore-region + nil + (if (featurep 'xemacs) + (and zmacs-regions (region-active-p)) + (and transient-mark-mode mark-active)))) + +;; Invisibility compatibility + +(defun org-add-to-invisibility-spec (arg) + "Add elements to `buffer-invisibility-spec'. +See documentation for `buffer-invisibility-spec' for the kind of elements +that can be added." + (cond + ((fboundp 'add-to-invisibility-spec) + (add-to-invisibility-spec arg)) + ((or (null buffer-invisibility-spec) (eq buffer-invisibility-spec t)) + (setq buffer-invisibility-spec (list arg))) + (t + (setq buffer-invisibility-spec + (cons arg buffer-invisibility-spec))))) + +(defun org-remove-from-invisibility-spec (arg) + "Remove elements from `buffer-invisibility-spec'." + (if (fboundp 'remove-from-invisibility-spec) + (remove-from-invisibility-spec arg) + (if (consp buffer-invisibility-spec) + (setq buffer-invisibility-spec + (delete arg buffer-invisibility-spec))))) + +(defun org-in-invisibility-spec-p (arg) + "Is ARG a member of `buffer-invisibility-spec'?" + (if (consp buffer-invisibility-spec) + (member arg buffer-invisibility-spec) + nil)) + +;;;; Define the Org-mode (if (and (not (keymapp outline-mode-map)) (featurep 'allout)) (error "Conflict with outdated version of allout.el. Load org.el before allout.el, or ugrade to newer allout, for example by switching to Emacs 22.")) -(defvar org-struct-menu) ; defined later in this file -(defvar org-org-menu) ; defined later in this file -(defvar org-tbl-menu) ; defined later in this file ;; We use a before-change function to check if a table might need ;; an update. @@ -3189,7 +3523,8 @@ The following commands are available: (setq outline-regexp "\\*+") ;;(setq outline-regexp "\\(?:\\*+\\|[ \t]*\\(?:[-+*]\\|[0-9]+[.)]\\) \\)") (setq outline-level 'org-outline-level) - (when (and org-ellipsis (stringp org-ellipsis)) + (when (and org-ellipsis (stringp org-ellipsis) + (fboundp 'set-display-table-slot) (boundp 'buffer-display-table)) (unless org-display-table (setq org-display-table (make-display-table))) (set-display-table-slot org-display-table @@ -3211,10 +3546,21 @@ The following commands are available: ;; Paragraphs and auto-filling (org-set-autofill-regexps) (org-update-radio-target-regexp) - ;; Make isearch reveal context after success - (org-set-local 'outline-isearch-open-invisible-function - (lambda (&rest ignore) (org-show-context nil t))) + ;; Comment characters +; (org-set-local 'comment-start "#") ;; FIXME: this breaks wrapping + (org-set-local 'comment-padding " ") + + ;; Make isearch reveal context + (if (or (featurep 'xemacs) + (not (boundp 'outline-isearch-open-invisible-function))) + ;; Emacs 21 and XEmacs make use of the hook + (org-add-hook 'isearch-mode-end-hook 'org-isearch-end 'append 'local) + ;; Emacs 22 deals with this through a special variable + (org-set-local 'outline-isearch-open-invisible-function + (lambda (&rest ignore) (org-show-context 'isearch)))) + + ;; If empty file that did not turn on org-mode automatically, make it to. (if (and org-insert-mode-line-in-empty-file (interactive-p) (= (point-min) (point-max))) @@ -3225,14 +3571,12 @@ The following commands are available: (let ((bmp (buffer-modified-p))) (org-table-map-tables 'org-table-align) (set-buffer-modified-p bmp))) - (if org-startup-with-deadline-check - (call-interactively 'org-check-deadlines) - (cond - ((eq org-startup-folded t) - (org-cycle '(4))) - ((eq org-startup-folded 'content) - (let ((this-command 'org-cycle) (last-command 'org-cycle)) - (org-cycle '(4)) (org-cycle '(4)))))))) + (cond + ((eq org-startup-folded t) + (org-cycle '(4))) + ((eq org-startup-folded 'content) + (let ((this-command 'org-cycle) (last-command 'org-cycle)) + (org-cycle '(4)) (org-cycle '(4))))))) (defsubst org-call-with-arg (command arg) "Call COMMAND interactively, but pretend prefix are was ARG." @@ -3263,7 +3607,7 @@ that will be added to PLIST. Returns the string that was modified." (put 'org-add-props 'lisp-indent-function 2) -;;; Font-Lock stuff +;;;; Font-Lock stuff, including the activators (defvar org-mouse-map (make-sparse-keymap)) (define-key org-mouse-map @@ -3331,6 +3675,12 @@ that will be added to PLIST. Returns the string that was modified." ; 4: [desc] ; 5: desc +(defconst org-any-link-re + (concat "\\(" org-bracket-link-regexp "\\)\\|\\(" + org-angle-link-re "\\)\\|\\(" + org-plain-link-re "\\)") + "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)))) @@ -3438,10 +3788,6 @@ We use a macro so that the test can happen at compilation time." (defun org-activate-dates (limit) "Run through the buffer and add overlays to dates." -; (if (re-search-forward org-tsr-regexp limit t) -; (if (re-search-forward -; (if org-display-custom-times org-ts-regexp-both org-tsr-regexp-both) -; limit t) (if (re-search-forward org-tsr-regexp-both limit t) (progn (add-text-properties (match-beginning 0) (match-end 0) @@ -3526,19 +3872,6 @@ between words." "\\|") "\\)\\>"))) -(defvar org-camel-regexp "\\*?\\<[A-Z]+[a-z]+[A-Z][a-zA-Z]*\\>" - "Matches CamelCase words, possibly with a star before it.") - -(defun org-activate-camels (limit) - "Run through the buffer and add overlays to dates." - (if (re-search-forward org-camel-regexp limit t) - (progn - (add-text-properties (match-beginning 0) (match-end 0) - (list 'mouse-face 'highlight - 'rear-nonsticky t - 'keymap org-mouse-map)) - t))) - (defun org-activate-tags (limit) (if (re-search-forward "[ \t]\\(:[A-Za-z_@0-9:]+:\\)[ \r\n]" limit t) (progn @@ -3578,16 +3911,14 @@ between words." (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 'camel lk) '(org-activate-camels (0 'org-link t))) (if (memq 'tag lk) '(org-activate-tags (1 'org-tag prepend))) - (if org-table-limit-column-width - '(org-hide-wide-columns (0 nil append))) ;; TODO lines (list (concat "^\\*+[ \t]*" org-not-done-regexp) '(1 'org-todo t)) ;; Priorities (list (concat "\\[#[A-Z]\\]") '(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)) @@ -3655,7 +3986,9 @@ between words." rear-nonsticky t invisible t intangible t)))) -;;; Visibility cycling +;;;; Visibility cycling, including org-goto and indirect buffer + +;;; Cycling (defvar org-cycle-global-status nil) (make-variable-buffer-local 'org-cycle-global-status) @@ -3767,14 +4100,16 @@ between words." (get-char-property (1- (point)) 'invisible)) (beginning-of-line 2)) (setq eol (point))) (outline-end-of-heading) (setq eoh (point)) - (org-end-of-subtree t) (setq eos (point)) - (outline-next-heading)) + (org-end-of-subtree t) + (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 - ((and (= eos eoh) + ((= eos eoh) ;; Nothing is hidden behind this heading (message "EMPTY ENTRY") - (setq org-cycle-subtree-status nil))) + (setq org-cycle-subtree-status nil)) ((>= eol eos) ;; Entire subtree is hidden in one line: open it (org-show-entry) @@ -3849,12 +4184,13 @@ results." (funcall outline-level)) 1)))) -;; FIXME: allow an argument to give a limiting level for this. -(defun org-content () - "Show all headlines in the buffer, like a table of contents" - (interactive) +(defun org-content (&optional arg) + "Show all headlines in the buffer, like a table of contents. +With numerical argument N, show content up to level N." + (interactive "P") (save-excursion ;; Visit all headings and show their offspring + (and (integerp arg) (org-overview)) (goto-char (point-max)) (catch 'exit (while (and (progn (condition-case nil @@ -3862,7 +4198,9 @@ results." (error (goto-char (point-min)))) t) (looking-at outline-regexp)) - (show-branches) + (if (integerp arg) + (show-children (1- arg)) + (show-branches)) (if (bobp) (throw 'exit nil)))))) @@ -3891,6 +4229,8 @@ Optional argument N means, put the headline into the Nth line of the window." (beginning-of-line) (recenter (prefix-numeric-value N)))) +;;; Org-goto + (defvar org-goto-window-configuration nil) (defvar org-goto-marker nil) (defvar org-goto-map (make-sparse-keymap)) @@ -3948,6 +4288,8 @@ to the new location, making it and the headline hierarchy above it visible." (org-show-context 'org-goto))) (error "Quit")))) +(defvar org-selected-point nil) ; dynamically scoped parameter + (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 @@ -3965,12 +4307,16 @@ or nil." (insert-buffer-substring buf) (let ((org-startup-truncated t) (org-startup-folded t) - (org-startup-align-all-tables nil) - (org-startup-with-deadline-check nil)) + (org-startup-align-all-tables nil)) (org-mode)) (setq buffer-read-only t) - (if (boundp 'org-goto-start-pos) - (goto-char org-goto-start-pos) + (if (and (boundp 'org-goto-start-pos) + (integer-or-marker-p org-goto-start-pos)) + (let ((org-show-hierarchy-above t) + (org-show-siblings t) + (org-show-following-heading t)) + (goto-char org-goto-start-pos) + (and (org-invisible-p) (org-show-context))) (goto-char (point-min))) (org-beginning-of-line) (message "Select location and press RET") @@ -4022,10 +4368,89 @@ or nil." (setq org-selected-point nil) (throw 'exit nil)) -;;; Promotion, Demotion, Inserting new headlines +;;; Indirect buffer display of subtrees + +(defvar org-indirect-dedicated-frame nil + "This is the frame being used for indirect tree display.") +(defvar org-last-indirect-buffer nil) + +(defun org-tree-to-indirect-buffer (&optional arg) + "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 +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 +frame is not changed." + (interactive "P") + (let ((cbuf (current-buffer)) + (cwin (selected-window)) + (pos (point)) + beg end level heading ibuf) + (save-excursion + (org-back-to-heading t) + (when (numberp arg) + (setq level (org-outline-level)) + (if (< arg 0) (setq arg (+ level arg))) + (while (> (setq level (org-outline-level)) arg) + (outline-up-heading 1 t))) + (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)) + (kill-buffer org-last-indirect-buffer)) + (setq ibuf (org-get-indirect-buffer cbuf) + org-last-indirect-buffer ibuf) + (cond + ((or (eq org-indirect-buffer-display 'new-frame) + (and arg (eq org-indirect-buffer-display 'dedicated-frame))) + (select-frame (make-frame)) + (delete-other-windows) + (switch-to-buffer ibuf) + (org-set-frame-title heading)) + ((eq org-indirect-buffer-display 'dedicated-frame) + (raise-frame + (select-frame (or (and org-indirect-dedicated-frame + (frame-live-p org-indirect-dedicated-frame) + org-indirect-dedicated-frame) + (setq org-indirect-dedicated-frame (make-frame))))) + (delete-other-windows) + (switch-to-buffer ibuf) + (org-set-frame-title (concat "Indirect: " heading))) + ((eq org-indirect-buffer-display 'current-window) + (switch-to-buffer ibuf)) + ((eq org-indirect-buffer-display 'other-window) + (pop-to-buffer ibuf)) + (t (error "Invalid value."))) + (if (featurep 'xemacs) + (save-excursion (org-mode) (turn-on-font-lock))) + (narrow-to-region beg end) + (show-all) + (goto-char pos) + (and (window-live-p cwin) (select-window cwin)))) + +(defun org-get-indirect-buffer (&optional buffer) + (setq buffer (or buffer (current-buffer))) + (let ((n 1) (base (buffer-name buffer)) bname) + (while (buffer-live-p + (get-buffer (setq bname (concat base "-" (number-to-string n))))) + (setq n (1+ n))) + (condition-case nil + (make-indirect-buffer buffer bname 'clone) + (error (make-indirect-buffer buffer bname))))) + +(defun org-set-frame-title (title) + "Set the title of the current frame to the string TITLE." + ;; FIXME: how to name a single frame in XEmacs??? + (unless (featurep 'xemacs) + (modify-frame-parameters (selected-frame) (list (cons 'name title))))) -(defvar org-ignore-region nil - "To temporarily disable the active region.") +;;;; Structure editing + +;;; Inserting headlines (defun org-insert-heading (&optional force-heading) "Insert a new heading or item with same depth at point. @@ -4060,49 +4485,6 @@ the current headline." (unless (= (point) pos) (just-one-space) (backward-delete-char 1)) (run-hooks 'org-insert-heading-hook))))) -(defun org-in-item-p () - "It the cursor inside a plain list item. -Does not have to be the first line." - (save-excursion - (condition-case nil - (progn - (org-beginning-of-item) - (org-at-item-p) - t) - (error nil)))) - -(defun org-insert-item (&optional checkbox) - "Insert a new item at the current level. -Return t when things worked, nil when we are not in an item." - (when (save-excursion - (condition-case nil - (progn - (org-beginning-of-item) - (org-at-item-p) - (if (org-invisible-p) (error "Invisible item")) - t) - (error nil))) - (let* ((bul (match-string 0)) - (eow (save-excursion (beginning-of-line 1) (looking-at "[ \t]*") - (match-end 0))) - (blank (cdr (assq 'plain-list-item org-blank-before-new-entry))) - pos) - (cond - ((and (org-at-item-p) (<= (point) eow)) - ;; before the bullet - (beginning-of-line 1) - (open-line (if blank 2 1))) - ((<= (point) eow) - (beginning-of-line 1)) - (t (newline (if blank 2 1)))) - (insert bul (if checkbox "[ ]" "")) - (just-one-space) - (setq pos (point)) - (end-of-line 1) - (unless (= (point) pos) (just-one-space) (backward-delete-char 1))) - (org-maybe-renumber-ordered-list) - (and checkbox (org-update-checkbox-count-maybe)) - t)) (defun org-insert-todo-heading (arg) "Insert a new heading with the same level and TODO state as current heading. @@ -4121,6 +4503,8 @@ state (TODO by default). Also with prefix arg, force first state." (insert (car org-todo-keywords) " ") (insert (match-string 2) " ")))) +;;; Promotion and Demotion + (defun org-promote-subtree () "Promote the entire subtree. See also `org-promote'." @@ -4162,14 +4546,14 @@ in the region." (defun org-fix-position-after-promote () "Make sure that after pro/demotion cursor position is right." - (if (and (equal (char-after) ?\n) - (save-excursion - (skip-chars-backward "a-zA-Z0-9_@") - (looking-at org-todo-regexp))) - (insert " ")) - (and (equal (char-after) ?\ ) - (equal (char-before) ?*) - (forward-char 1))) + (let ((pos (point))) + (when (save-excursion + (beginning-of-line 1) + (looking-at org-todo-line-regexp) + (or (equal pos (match-end 1)) (equal pos (match-end 2)))) + (cond ((eobp) (insert " ")) + ((eolp) (insert " ")) + ((equal (char-after) ?\ ) (forward-char 1)))))) (defun org-get-legal-level (level &optional change) "Rectify a level change under the influence of `org-odd-levels-only' @@ -4255,16 +4639,57 @@ would end up with no indentation after the change, nothing at all is done." (indent-to (+ diff col)))) (move-marker end nil)))) -;;; Vertical tree motion, cutting and pasting of subtrees - -(defun org-move-subtree-up (&optional arg) - "Move the current subtree up past ARG headlines of the same level." - (interactive "p") - (org-move-subtree-down (- (prefix-numeric-value arg)))) - -(defun org-move-subtree-down (&optional arg) - "Move the current subtree down past ARG headlines of the same level." - (interactive "p") +(defun org-convert-to-odd-levels () + "Convert an org-mode file with all levels allowed to one with odd levels. +This will leave level 1 alone, convert level 2 to level 3, level 3 to +level 5 etc." + (interactive) + (when (yes-or-no-p "Are you sure you want to globally change levels to odd? ") + (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 (>= (setq n (1- n)) 0) + (org-demote)) + (end-of-line 1)))))) + + +(defun org-convert-to-oddeven-levels () + "Convert an org-mode file with only odd levels to one with odd and even levels. +This promotes level 3 to level 2, level 5 to level 3 etc. If the file contains a +section with an even level, conversion would destroy the structure of the file. An error +is signaled in this case." + (interactive) + (goto-char (point-min)) + ;; First check if there are no even levels + (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 (>= (setq n (1- n)) 0) + (org-promote)) + (end-of-line 1)))))) + +(defun org-tr-level (n) + "Make N odd if required." + (if org-odd-levels-only (1+ (/ n 2)) n)) + +;;; Vertical tree motion, cutting and pasting of subtrees + +(defun org-move-subtree-up (&optional arg) + "Move the current subtree up past ARG headlines of the same level." + (interactive "p") + (org-move-subtree-down (- (prefix-numeric-value arg)))) + +(defun org-move-subtree-down (&optional arg) + "Move the current subtree down past ARG headlines of the same level." + (interactive "p") (setq arg (prefix-numeric-value arg)) (let ((movfunc (if (> arg 0) 'outline-get-next-sibling 'outline-get-last-sibling)) @@ -4464,6 +4889,138 @@ If optional TXT is given, check this string instead of the current kill." (progn (org-back-to-heading) (point)) (progn (org-end-of-subtree t) (point))))) + +;;; Outline Sorting + +(defun org-sort (with-case) + "Call `org-sort-entries' or `org-table-sort-lines', depending on context." + (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))) + +(defun org-sort-entries (&optional with-case sorting-type) + "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. +Else, the children of the entry at point are sorted. + +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). + +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." + (interactive "P") + (let ((unique (equal with-case '(16))) + start beg end entries stars re re2 p nentries (nremoved 0) + last txt what) + ;; Find beginning and end of region to sort + (cond + ((org-region-active-p) + ;; we will sort the region + (setq end (region-end) + what "region") + (goto-char (region-beginning)) + (if (not (org-on-heading-p)) (outline-next-heading)) + (setq start (point))) + ((or (org-on-heading-p) + (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") + (goto-char start) + (show-subtree) + (outline-next-heading)) + (t + ;; we will sort the top-level entries in this file + (goto-char (point-min)) + (or (org-on-heading-p) (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))) + + ;; Sort the list + (save-excursion + (goto-char start) + (setq entries (org-do-sort entries what with-case sorting-type))) + + ;; 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) "")))) + +(defun org-do-sort (table what &optional with-case sorting-type) + "Sort TABLE of WHAT according to SORTING-TYPE. +The user will be prompted for the SORTING-TYPE if the call to this +function does not specify it. WHAT is only for the prompt, to indicate +what is being sorted. The sorting key will be extracted from +the car of the elements of the table. +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:" + what) + (setq sorting-type (read-char-exclusive))) + (let ((dcst (downcase sorting-type)) + extractfun comparefun) + ;; Define the appropriate functions + (cond + ((= dcst ?n) + (setq extractfun 'string-to-number + comparefun (if (= dcst sorting-type) '< '>))) + ((= dcst ?a) + (setq extractfun (if with-case 'identity 'downcase) + comparefun (if (= dcst sorting-type) + 'string< + (lambda (a b) (and (not (string< a b)) + (not (string= a b))))))) + ((= dcst ?t) + (setq extractfun + (lambda (x) + (if (string-match org-ts-regexp x) + (time-to-seconds + (org-time-string-to-time (match-string 0 x))) + 0)) + comparefun (if (= dcst sorting-type) '< '>))) + (t (error "Invalid sorting type `%c'" sorting-type))) + + (sort (mapcar (lambda (x) (cons (funcall extractfun (car x)) (cdr x))) + table) + (lambda (a b) (funcall comparefun (car a) (car b)))))) + +;;;; Plain list items, including checkboxes + ;;; Plain list items (defun org-at-item-p () @@ -4478,6 +5035,53 @@ If optional TXT is given, check this string instead of the current kill." ((= 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." + (save-excursion + (condition-case nil + (progn + (org-beginning-of-item) + (org-at-item-p) + t) + (error nil)))) + +(defun org-insert-item (&optional checkbox) + "Insert a new item at the current level. +Return t when things worked, nil when we are not in an item." + (when (save-excursion + (condition-case nil + (progn + (org-beginning-of-item) + (org-at-item-p) + (if (org-invisible-p) (error "Invisible item")) + t) + (error nil))) + (let* ((bul (match-string 0)) + (eow (save-excursion (beginning-of-line 1) (looking-at "[ \t]*") + (match-end 0))) + (blank (cdr (assq 'plain-list-item org-blank-before-new-entry))) + pos) + (cond + ((and (org-at-item-p) (<= (point) eow)) + ;; before the bullet + (beginning-of-line 1) + (open-line (if blank 2 1))) + ((<= (point) eow) + (beginning-of-line 1)) + (t (newline (if blank 2 1)))) + (insert bul (if checkbox "[ ]" "")) + (just-one-space) + (setq pos (point)) + (end-of-line 1) + (unless (= (point) pos) (just-one-space) (backward-delete-char 1))) + (org-maybe-renumber-ordered-list) + (and checkbox (org-update-checkbox-count-maybe)) + t)) + +;;; Checkboxes + (defun org-at-item-checkbox-p () "Is point at a line starting a plain-list item with a checklet?" (and (org-at-item-p) @@ -4596,10 +5200,11 @@ Assumes that s is a single line, starting in column 0." t t s))) s) -;; FIXME: document properly. (defun org-fix-indentation (line ind) - "If the current indenation is smaller than ind1, leave it alone. -If it is larger than ind, reduce it by ind." + "Fix indentation in LINE. +IND is a cons cell with target and minimum indentation. +If the current indenation in LINE is smaller than the minimum, +leave it alone. If it is larger than ind, set it to the target." (let* ((l (org-remove-tabs line)) (i (org-get-indentation l)) (i1 (car ind)) (i2 (cdr ind))) @@ -4848,7 +5453,9 @@ with something like \"1.\" or \"2)\"." (indent-to-column (+ ind1 arg)) (beginning-of-line 2))))) -;;; Archiving +;;;; Archiving + +(defalias 'org-advertized-archive-subtree 'org-archive-subtree) (defun org-archive-subtree (&optional find-done) "Move the current subtree to the archive. @@ -4872,8 +5479,17 @@ this heading. " (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) + + ;; 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)))) + (if (string-match "\\(.*\\)::\\(.*\\)" org-archive-location) (progn (setq file (format (match-string 1 org-archive-location) @@ -4911,13 +5527,16 @@ this heading. " (org-todo-interpretation tr-org-todo-interpretation) (org-done-string tr-org-done-string) (org-todo-regexp tr-org-todo-regexp) - (org-todo-line-regexp tr-org-todo-line-regexp)) + (org-todo-line-regexp tr-org-todo-line-regexp) + (org-odd-levels-only (if (local-variable-p org-odd-levels-only) + org-odd-levels-only + tr-org-odd-levels-only))) (goto-char (point-min)) (if heading (progn (if (re-search-forward (concat "\\(^\\|\r\\)" - (regexp-quote heading) "[ \t]*\\($\\|\r\\)") + (regexp-quote heading) "[ \t]*\\(:[a-zA-Z0-9_@:]+:\\)?[ \t]*\\($\\|\r\\)") nil t) (goto-char (match-end 0)) ;; Heading not found, just insert it at the end @@ -4934,10 +5553,11 @@ this heading. " ;; No specific heading, just go to end of file. (goto-char (point-max)) (insert "\n")) ;; Paste - (org-paste-subtree (1+ level)) + (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 - (org-todo (length org-todo-keywords))) + (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) @@ -5073,8717 +5693,10582 @@ the children that do not contain any open TODO items." (and set (beginning-of-line 1)) (message "Subtree %s" (if set "archived" "unarchived"))))) -(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 () - (if org-agenda-multi - (progn - (setq buffer-read-only nil) - (goto-char (point-max)) - (unless (= (point) 1) - (insert "\n" (make-string (window-width) ?=) "\n")) - (narrow-to-region (point) (point-max))) - (org-agenda-maybe-reset-markers 'force) - (org-prepare-agenda-buffers (org-agenda-files)) - (let* ((abuf (get-buffer-create org-agenda-buffer-name)) - (awin (get-buffer-window abuf))) - (cond - ((equal (current-buffer) abuf) nil) - (awin (select-window awin)) - ((not (setq org-pre-agenda-window-conf (current-window-configuration)))) - ((equal org-agenda-window-setup 'current-window) - (switch-to-buffer abuf)) - ((equal org-agenda-window-setup 'other-window) - (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)))) - (setq buffer-read-only nil) - (erase-buffer) - (org-agenda-mode)) - (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)) - (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)))) +;;;; Tables -(defun org-prepare-agenda-buffers (files) - "Create buffers for all agenda files, protect archived trees and comments." - (interactive) - (let ((pa '(:org-archived t)) - (pc '(:org-comment t)) - (pall '(:org-archived t :org-comment t)) - (rea (concat ":" org-archive-tag ":")) - bmp file re) - (save-excursion - (while (setq file (pop files)) - (org-check-agenda-file file) - (set-buffer (org-get-agenda-file-buffer file)) - (widen) - (setq bmp (buffer-modified-p)) - (save-excursion - (remove-text-properties (point-min) (point-max) pall) - (when org-agenda-skip-archived-trees - (goto-char (point-min)) - (while (re-search-forward rea nil t) - (if (org-on-heading-p) - (add-text-properties (point-at-bol) (org-end-of-subtree t) pa)))) - (goto-char (point-min)) - (setq re (concat "^\\*+ +" org-comment-string "\\>")) - (while (re-search-forward re nil t) - (add-text-properties - (match-beginning 0) (org-end-of-subtree t) pc))) - (set-buffer-modified-p bmp))))) +;;; The table editor -(defun org-agenda-skip () - "Throw to `:skip' in places that should be skipped." - (let ((p (point-at-bol))) - (and org-agenda-skip-archived-trees - (get-text-property p :org-archived) - (org-end-of-subtree t) - (throw :skip t)) - (and (get-text-property p :org-comment) - (org-end-of-subtree t) - (throw :skip t)) - (if (equal (char-after p) ?#) (throw :skip t)))) +;; Watch out: Here we are talking about two different kind of tables. +;; Most of the code is for the tables created with the Org-mode table editor. +;; Sometimes, we talk about tables created and edited with the table.el +;; Emacs package. We call the former org-type tables, and the latter +;; table.el-type tables. -(defun org-agenda-toggle-archive-tag () - "Toggle the archive tag for the current entry." - (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) - (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-toggle-archive-tag) - (end-of-line 1) - (setq newhead (org-get-heading))) - (org-agenda-change-all-lines newhead hdmarker) - (beginning-of-line 1))) +(defun org-before-change-function (beg end) + "Every change indicates that a table might need an update." + (setq org-table-may-need-update t)) -;;; Dynamic blocks +(defconst org-table-line-regexp "^[ \t]*|" + "Detects an org-type table line.") +(defconst org-table-dataline-regexp "^[ \t]*|[^-]" + "Detects an org-type table line.") +(defconst org-table-auto-recalculate-regexp "^[ \t]*| *# *\\(|\\|$\\)" + "Detects a table line marked for automatic recalculation.") +(defconst org-table-recalculate-regexp "^[ \t]*| *[#*] *\\(|\\|$\\)" + "Detects a table line marked for automatic recalculation.") +(defconst org-table-calculate-mark-regexp "^[ \t]*| *[!$^_#*] *\\(|\\|$\\)" + "Detects a table line marked for automatic recalculation.") +(defconst org-table-hline-regexp "^[ \t]*|-" + "Detects an org-type table hline.") +(defconst org-table1-hline-regexp "^[ \t]*\\+-[-+]" + "Detects a table-type table hline.") +(defconst org-table-any-line-regexp "^[ \t]*\\(|\\|\\+-[-+]\\)" + "Detects an org-type or table-type table.") +(defconst org-table-border-regexp "^[ \t]*[^| \t]" + "Searching from within a table (any type) this finds the first line +outside the table.") +(defconst org-table-any-border-regexp "^[ \t]*[^|+ \t]" + "Searching from within a table (any type) this finds the first line +outside the table.") -(defun org-find-dblock (name) - "Find the first dynamic block with name NAME in the buffer. -If not found, stay at current position and return nil." - (let (pos) - (save-excursion - (goto-char (point-min)) - (setq pos (and (re-search-forward (concat "^#\\+BEGIN:[ \t]+" name "\\>") - nil t) - (match-beginning 0)))) - (if pos (goto-char pos)) - pos)) +(defvar org-table-last-highlighted-reference nil) +(defvar org-table-formula-history nil) -(defconst org-dblock-start-re - "^#\\+BEGIN:[ \t]+\\(\\S-+\\)\\([ \t]+\\(.*\\)\\)?" - "Matches the startline of a dynamic block, with parameters.") +(defvar org-table-column-names nil + "Alist with column names, derived from the `!' line.") +(defvar org-table-column-name-regexp nil + "Regular expression matching the current column names.") +(defvar org-table-local-parameters nil + "Alist with parameter names, derived from the `$' line.") +(defvar org-table-named-field-locations nil + "Alist with locations of named fields.") -(defconst org-dblock-end-re "^#\\+END\\([: \t\r\n]\\|$\\)" - "Matches the end of a dyhamic block.") +(defvar org-table-current-line-types nil + "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-dlines nil + "Vector of data line line numbers in the current table.") +(defvar org-table-hlines nil + "Vector of hline line numbers in the current table.") -(defun org-create-dblock (plist) - "Create a dynamic block section, with parameters taken from PLIST. -PLIST must containe a :name entry which is used as name of the block." - (unless (bolp) (newline)) - (let ((name (plist-get plist :name))) - (insert "#+BEGIN: " name) - (while plist - (if (eq (car plist) :name) - (setq plist (cddr plist)) - (insert " " (prin1-to-string (pop plist))))) - (insert "\n\n#+END:\n") - (beginning-of-line -2))) +(defconst org-table-range-regexp + "@\\([-+]?I*[-+]?[0-9]*\\)?\\(\\$[-+]?[0-9]+\\)?\\(\\.\\.@?\\([-+]?I*[-+]?[0-9]*\\)?\\(\\$[-+]?[0-9]+\\)?\\)?" + ;; 1 2 3 4 5 + "Regular expression for matching ranges in formulas.") -(defun org-prepare-dblock () - "Prepare dynamic block for refresh. -This empties the block, puts the cursor at the insert position and returns -the property list including an extra property :name with the block name." - (unless (looking-at org-dblock-start-re) - (error "Not at a dynamic block")) - (let* ((begdel (1+ (match-end 0))) - (name (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")) - (delete-region begdel (match-beginning 0)) - (goto-char begdel) - (open-line 1) - params)) +(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.") -(defun org-map-dblocks (&optional command) - "Apply COMMAND to all dynamic blocks in the current buffer. -If COMMAND is not given, use `org-update-dblock'." - (let ((cmd (or command 'org-update-dblock)) - pos) - (save-excursion - (goto-char (point-min)) - (while (re-search-forward org-dblock-start-re nil t) - (goto-char (setq pos (match-beginning 0))) - (condition-case nil - (funcall cmd) - (error (message "Error during update of dynamic block"))) - (goto-char pos) - (unless (re-search-forward org-dblock-end-re nil t) - (error "Dynamic block not terminated")))))) +(defvar org-inhibit-highlight-removal nil) -(defun org-dblock-update (&optional arg) - "User command for updating dynamic blocks. -Update the dynamic block at point. With prefix ARG, update all dynamic -blocks in the buffer." + +(defun org-table-create-with-table.el () + "Use the table.el package to insert a new table. +If there is already a table at point, convert between Org-mode tables +and table.el tables." + (interactive) + (require 'table) + (cond + ((org-at-table.el-p) + (if (y-or-n-p "Convert table to Org-mode table? ") + (org-table-convert))) + ((org-at-table-p) + (if (y-or-n-p "Convert table to table.el table? ") + (org-table-convert))) + (t (call-interactively 'table-insert)))) + +(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." (interactive "P") - (if arg - (org-update-all-dblocks) - (or (looking-at org-dblock-start-re) - (org-beginning-of-dblock)) - (org-update-dblock))) + (if (org-region-active-p) + (org-table-convert-region (region-beginning) (region-end) arg) + (org-table-create arg))) + +(defun org-table-create (&optional size) + "Query for a size and insert a table skeleton. +SIZE is a string Columns x Rows like for example \"3x2\"." + (interactive "P") + (unless size + (setq size (read-string + (concat "Table size Columns x Rows [e.g. " + org-table-default-size "]: ") + "" nil org-table-default-size))) -(defun org-update-dblock () - "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))) + (indent (make-string (current-column) ?\ )) + (split (org-split-string size " *x *")) + (rows (string-to-number (nth 1 split))) + (columns (string-to-number (car split))) + (line (concat (apply 'concat indent "|" (make-list columns " |")) + "\n"))) + (if (string-match "^[ \t]*$" (buffer-substring-no-properties + (point-at-bol) (point))) + (beginning-of-line 1) + (newline)) + ;; (mapcar (lambda (x) (insert line)) (make-list rows t)) + (dotimes (i rows) (insert line)) + (goto-char pos) + (if (> rows 1) + ;; Insert a hline after the first row. + (progn + (end-of-line 1) + (insert "\n|-") + (goto-char pos))) + (org-table-align))) -(defun org-beginning-of-dblock () - "Find the beginning of the dynamic block at point. -Error if there is no scuh block at point." - (let ((pos (point)) - beg) - (end-of-line 1) - (if (and (re-search-backward org-dblock-start-re nil t) - (setq beg (match-beginning 0)) - (re-search-forward org-dblock-end-re nil t) - (> (match-end 0) pos)) - (goto-char beg) - (goto-char pos) - (error "Not in a dynamic block")))) +(defun org-table-convert-region (beg0 end0 &optional nspace) + "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)." + (interactive "rP") + (let* ((beg (min beg0 end0)) + (end (max beg0 end0)) + (tabsep t) + re) + (goto-char beg) + (beginning-of-line 1) + (setq beg (move-marker (make-marker) (point))) + (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) + (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))))) + (goto-char beg) + (while (re-search-forward re end t) + (replace-match "| " t t)) + (goto-char beg) + (insert " ") + (org-table-align))) -(defun org-update-all-dblocks () - "Update all dynamic blocks in the buffer. -This function can be used in a hook." - (when (org-mode-p) - (org-map-dblocks 'org-update-dblock))) +(defun org-table-import (file arg) + "Import FILE as a table. +The file is assumed to be tab-separated. Such files can be produced by most +spreadsheet and database applications. If no tabs (at least one per line) +are found, lines will be split on whitespace into fields." + (interactive "f\nP") + (or (bolp) (newline)) + (let ((beg (point)) + (pm (point-max))) + (insert-file-contents file) + (org-table-convert-region beg (+ (point) (- (point-max) pm)) arg))) +(defun org-table-export () + "Export table as a tab-separated file. +Such a file can be imported into a spreadsheet program like Excel." + (interactive) + (let* ((beg (org-table-begin)) + (end (org-table-end)) + (table (buffer-substring beg end)) + (file (read-file-name "Export table to: ")) + buf) + (unless (or (not (file-exists-p file)) + (y-or-n-p (format "Overwrite file %s? " file))) + (error "Abort")) + (with-current-buffer (find-file-noselect file) + (setq buf (current-buffer)) + (erase-buffer) + (fundamental-mode) + (insert table) + (goto-char (point-min)) + (while (re-search-forward "^[ \t]*|[ \t]*" nil t) + (replace-match "" t t) + (end-of-line 1)) + (goto-char (point-min)) + (while (re-search-forward "[ \t]*|[ \t]*$" nil t) + (replace-match "" t t) + (goto-char (min (1+ (point)) (point-max)))) + (goto-char (point-min)) + (while (re-search-forward "^-[-+]*$" nil t) + (replace-match "") + (if (looking-at "\n") + (delete-char 1))) + (goto-char (point-min)) + (while (re-search-forward "[ \t]*|[ \t]*" nil t) + (replace-match "\t" t t)) + (save-buffer)) + (kill-buffer buf))) -;;; Completion +(defvar org-table-aligned-begin-marker (make-marker) + "Marker at the beginning of the table last aligned. +Used to check if cursor still is in that table, to minimize realignment.") +(defvar org-table-aligned-end-marker (make-marker) + "Marker at the end of the table last aligned. +Used to check if cursor still is in that table, to minimize realignment.") +(defvar org-table-last-alignment nil + "List of flags for flushright alignment, from the last re-alignment. +This is being used to correctly align a single field after TAB or RET.") +(defvar org-table-last-column-widths nil + "List of max width of fields in each column. +This is being used to correctly align a single field after TAB or RET.") +(defvar org-table-overlay-coordinates nil + "Overlay coordinates after each align of a table.") +(make-variable-buffer-local 'org-table-overlay-coordinates) -(defun org-complete (&optional arg) - "Perform completion on word at point. -At the beginning of a headline, this completes TODO keywords as given in -`org-todo-keywords'. -If the current word is preceded by a backslash, completes the TeX symbols -that are supported for HTML support. -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'." - (interactive "P") - (catch 'exit - (let* ((end (point)) - (beg1 (save-excursion - (skip-chars-backward "a-zA-Z_@0-9") - (point))) - (beg (save-excursion - (skip-chars-backward "a-zA-Z0-9_:$") - (point))) - (confirm (lambda (x) (stringp (car x)))) - (camel (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)) - (camel - (setq type :camel) - (save-excursion - (goto-char (point-min)) - (while (re-search-forward org-todo-line-regexp nil t) - (push (list - (if org-file-link-context-use-camel-case - (org-make-org-heading-camel (match-string 3) t) - (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))))) - ((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")))))) - -;;; Comments, TODO and DEADLINE +(defvar org-last-recalc-line nil) +(defconst org-narrow-column-arrow "=>" + "Used as display property in narrowed table columns.") -(defun org-toggle-comment () - "Change the COMMENT state of an entry." +(defun org-table-align () + "Align the table at point by aligning all vertical bars." (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* ( + ;; Limits of table + (beg (org-table-begin)) + (end (org-table-end)) + ;; Current cursor position + (linepos (org-current-line)) + (colpos (org-table-current-column)) + (winstart (window-start)) + (winstartline (org-current-line (min winstart (1- (point-max))))) + lines (new "") lengths l typenums ty fields maxfields i + column + (indent "") cnt frac + rfmt hfmt + (spaces '(1 . 1)) + (sp1 (car spaces)) + (sp2 (cdr spaces)) + (rfmt1 (concat + (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) + (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 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))) -(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.") + ;; Check if we are narrowing any columns + (goto-char beg) + (setq narrow (and org-format-transports-properties-p + (re-search-forward "<[0-9]+>" end t))) + ;; Get the rows + (setq lines (org-split-string + (buffer-substring beg end) "\n")) + ;; Store the indentation of the first line + (if (string-match "^ *" (car lines)) + (setq indent (make-string (- (match-end 0) (match-beginning 0)) ?\ ))) + ;; Mark the hlines by setting the corresponding element to nil + ;; At the same time, we remove trailing space. + (setq lines (mapcar (lambda (l) + (if (string-match "^ *|-" l) + nil + (if (string-match "[ \t]+$" l) + (substring l 0 (match-beginning 0)) + l))) + lines)) + ;; Get the data fields by splitting the lines. + (setq fields (mapcar + (lambda (l) + (org-split-string l " *| *")) + (delq nil (copy-sequence lines)))) + ;; How many fields in the longest line? + (condition-case nil + (setq maxfields (apply 'max (mapcar 'length fields))) + (error + (kill-region beg end) + (org-table-create org-table-default-size) + (error "Empty table - created default table"))) + ;; A list of empty strings to fill any short rows on output + (setq emptystrings (make-list maxfields "")) + ;; Check for special formatting. + (setq i -1) + (while (< (setq i (1+ i)) maxfields) ;; Loop over all columns + (setq column (mapcar (lambda (x) (or (nth i x) "")) fields)) + ;; Check if there is an explicit width specified + (when narrow + (setq c column fmax nil) + (while c + (setq e (pop c)) + (if (and (stringp e) (string-match "^<\\([0-9]+\\)>$" e)) + (setq fmax (string-to-number (match-string 1 e)) c nil))) + ;; Find fields that are wider than fmax, and shorten them + (when fmax + (loop for xx in column do + (when (and (stringp xx) + (> (org-string-width xx) fmax)) + (org-add-props xx nil + 'help-echo + (concat "Clipped table field, use C-c ` to edit. Full value is:\n" (org-no-properties (copy-sequence xx)))) + (setq f1 (min fmax (or (string-match org-bracket-link-regexp xx) fmax))) + (unless (> f1 1) + (error "Cannot narrow field starting with wide link \"%s\"" + (match-string 0 xx))) + (add-text-properties f1 (length xx) (list 'org-cwidth t) xx) + (add-text-properties (- f1 2) f1 + (list 'display org-narrow-column-arrow) + xx))))) + ;; Get the maximum width for each column + (push (apply 'max 1 (mapcar 'org-string-width column)) lengths) + ;; Get the fraction of numbers, to decide about alignment of the column + (setq cnt 0 frac 0.0) + (loop for x in column do + (if (equal x "") + nil + (setq frac ( / (+ (* frac cnt) + (if (string-match org-table-number-regexp x) 1 0)) + (setq cnt (1+ cnt)))))) + (push (>= frac org-table-number-fraction) typenums)) + (setq lengths (nreverse lengths) typenums (nreverse typenums)) -(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, -like - *** TODO Write paper - *** DONE Call mom + ;; Store the alignment of this table, for later editing of single fields + (setq org-table-last-alignment typenums + org-table-last-column-widths lengths) -The different keywords are specified in the variable `org-todo-keywords'. -By default the available states are \"TODO\" and \"DONE\". -So for this example: when the item starts with TODO, it is changed to DONE. -When it starts with DONE, the DONE is removed. And when neither TODO nor -DONE are present, add TODO at the beginning of the heading. + ;; With invisible characters, `format' does not get the field width right + ;; So we need to make these fields wide by hand. + (when links + (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)) + (< (org-string-width (car c)) len)) + (setcar c (concat (car c) (make-string (- len (org-string-width (car c))) ?\ ))))))) -With prefix arg, use completion to determine the new state. With numeric -prefix arg, switch to that state." - (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)) - (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 - (if this - (nth (- (length org-todo-keywords) (length tail) 2) - org-todo-keywords) - org-done-string))) - (arg - ;; user requests a specific state - (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 " ") " "))) - (replace-match next t t) - (setq org-last-todo-state-is-todo - (not (equal state org-done-string))) - (when org-log-done - (if (equal state org-done-string) - (org-add-planning-info 'closed (org-current-time) 'scheduled) - (if (not this) - (org-add-planning-info nil nil 'closed)))) - ;; Fixup tag positioning - (and org-auto-align-tags (org-set-tags nil t)) - (run-hooks 'org-after-todo-state-change-hook))) - ;; 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)))) + ;; Compute the formats needed for output of the table + (setq rfmt (concat indent "|") hfmt (concat indent "|")) + (while (setq l (pop lengths)) + (setq ty (if (pop typenums) "" "-")) ; number types flushright + (setq rfmt (concat rfmt (format rfmt1 ty l)) + hfmt (concat hfmt (format hfmt1 (make-string l ?-))))) + (setq rfmt (concat rfmt "\n") + hfmt (concat (substring hfmt 0 -1) "|\n")) -(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 numeric prefix N, construct a sparse tree for the Nth element -of `org-todo-keywords'." - (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)) - (regexp-quote (nth (1- (prefix-numeric-value arg)) - org-todo-keywords))) - (t (error "Invalid prefix argument: %s" arg))))) - (message "%d TODO entries found" - (org-occur (concat "^" outline-regexp " +" kwd-re ))))) + (setq new (mapconcat + (lambda (l) + (if l (apply 'format rfmt + (append (pop fields) emptystrings)) + hfmt)) + lines "")) + ;; Replace the old one + (delete-region beg end) + (move-marker end nil) + (move-marker org-table-aligned-begin-marker (point)) + (insert new) + (move-marker org-table-aligned-end-marker (point)) + (when (and orgtbl-mode (not (org-mode-p))) + (goto-char org-table-aligned-begin-marker) + (while (org-hide-wide-columns org-table-aligned-end-marker))) + ;; Try to move to the old location + (goto-line winstartline) + (setq winstart (point-at-bol)) + (goto-line linepos) + (set-window-start (selected-window) winstart 'noforce) + (org-table-goto-column colpos) + (and org-table-overlay-coordinates (org-table-overlay-coordinates)) + (setq org-table-may-need-update nil) + )) -(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-string-width (s) + "Compute width of string, ignoring invisible characters. +This ignores character with invisibility property `org-link', and also +characters with property `org-cwidth', because these will become invisible +upon the next fontification round." + (let (b l) + (when (or (eq t buffer-invisibility-spec) + (assq 'org-link buffer-invisibility-spec)) + (while (setq b (text-property-any 0 (length s) + 'invisible 'org-link s)) + (setq s (concat (substring s 0 b) + (substring s (or (next-single-property-change + b 'invisible s) (length s))))))) + (while (setq b (text-property-any 0 (length s) 'org-cwidth t s)) + (setq s (concat (substring s 0 b) + (substring s (or (next-single-property-change + b 'org-cwidth s) (length s)))))) + (setq l (string-width s) b -1) + (while (setq b (text-property-any (1+ b) (length s) 'org-dwidth t s)) + (setq l (- l (get-text-property b 'org-dwidth-n s)))) + l)) -(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-table-begin (&optional table-type) + "Find the beginning of the table and return its position. +With argument TABLE-TYPE, go to the beginning of a table.el-type table." + (save-excursion + (if (not (re-search-backward + (if table-type org-table-any-border-regexp + org-table-border-regexp) + nil t)) + (progn (goto-char (point-min)) (point)) + (goto-char (match-beginning 0)) + (beginning-of-line 2) + (point)))) -(defun org-add-planning-info (what &optional time &rest remove) - "Insert new timestamp with keyword in the line directly after the headline. -WHAT indicates what kind of time stamp to add. TIME indicated the time to use. -If non is given, the user is prompted for a date. -REMOVE indicates what kind of entries to remove. An old WHAT entry will also -be removed." - (interactive) - (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) - (setq what nil)) +(defun org-table-end (&optional table-type) + "Find the end of the table and return its position. +With argument TABLE-TYPE, go to the end of a table.el-type table." (save-excursion - (save-restriction - (let (col list elt ts buffer-invisibility-spec) - (org-back-to-heading t) - (looking-at (concat outline-regexp "\\( *\\)[^\r\n]*")) - (goto-char (match-end 1)) - (setq col (current-column)) - (goto-char (1+ (match-end 0))) - (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") - (backward-char 1) - (narrow-to-region (point) (point)) - (indent-to-column col)) - ;; Check if we have to remove something. - (setq list (cons what remove)) - (while list - (setq elt (pop list)) - (goto-char (point-min)) - (when (or (and (eq elt 'scheduled) - (re-search-forward org-scheduled-time-regexp nil t)) - (and (eq elt 'deadline) - (re-search-forward org-deadline-time-regexp nil t)) - (and (eq elt 'closed) - (re-search-forward org-closed-time-regexp nil t))) - (replace-match "") - (if (looking-at " +") (replace-match "")))) + (if (not (re-search-forward + (if table-type org-table-any-border-regexp + org-table-border-regexp) + nil t)) (goto-char (point-max)) - (when what - (insert - (if (not (equal (char-before) ?\ )) " " "") - (cond ((eq what 'scheduled) org-scheduled-string) - ((eq what 'deadline) org-deadline-string) - ((eq what 'closed) org-closed-string)) - " ") - (org-insert-time-stamp time nil (eq what 'closed)) - (end-of-line 1) - (org-add-log-maybe 'done)) - (goto-char (point-min)) - (widen) - (if (looking-at "[ \t]+\r?\n") - (replace-match "")) - ts)))) - -(defvar org-log-note-marker (make-marker)) -(defvar org-log-note-purpose nil) -(defvar org-log-note-window-configuration nil) - -(defun org-add-log-maybe (&optional purpose) - (when (and (listp org-log-done) - (memq purpose org-log-done)) - (move-marker org-log-note-marker (point)) - (setq org-log-note-purpose purpose) - (add-hook 'post-command-hook 'org-add-log-note 'append))) + (goto-char (match-beginning 0))) + (point-marker))) -(defun org-add-log-note (&optional purpose) - "Pop up a window for taking a note, and add this note later at point." - (remove-hook 'post-command-hook 'org-add-log-note) - (setq org-log-note-window-configuration (current-window-configuration)) - (delete-other-windows) - (switch-to-buffer (marker-buffer org-log-note-marker)) - (goto-char org-log-note-marker) - (switch-to-buffer-other-window "*Org Note*") - (erase-buffer) - (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") - (t (error "This should not happen"))))) - (org-set-local 'org-finish-function 'org-store-log-note)) +(defun org-table-justify-field-maybe (&optional new) + "Justify the current field, text to left, number to right. +Optional argument NEW may specify text to replace the current field content." + (cond + ((and (not new) org-table-may-need-update)) ; Realignment will happen anyway + ((org-at-table-hline-p)) + ((and (not new) + (or (not (equal (marker-buffer org-table-aligned-begin-marker) + (current-buffer))) + (< (point) org-table-aligned-begin-marker) + (>= (point) org-table-aligned-end-marker))) + ;; This is not the same table, force a full re-align + (setq org-table-may-need-update t)) + (t ;; realign the current field, based on previous full realign + (let* ((pos (point)) s + (col (org-table-current-column)) + (num (if (> col 0) (nth (1- col) org-table-last-alignment))) + l f n o e) + (when (> col 0) + (skip-chars-backward "^|\n") + (if (looking-at " *\\([^|\n]*?\\) *\\(|\\|$\\)") + (progn + (setq s (match-string 1) + o (match-string 0) + l (max 1 (- (match-end 0) (match-beginning 0) 3)) + e (not (= (match-beginning 2) (match-end 2)))) + (setq f (format (if num " %%%ds %s" " %%-%ds %s") + l (if e "|" (setq org-table-may-need-update t) "")) + n (format f s)) + (if new + (if (<= (length new) l) ;; FIXME: length -> str-width? + (setq n (format f new)) + (setq n (concat new "|") org-table-may-need-update t))) + (or (equal n o) + (let (org-table-may-need-update) + (replace-match n)))) + (setq org-table-may-need-update t)) + (goto-char pos)))))) -(defun org-store-log-note () - "Finish taking a log note, and insert it to where it belongs." - (let ((txt (buffer-string)) - (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))) - (when (string-match "\\S-" txt) - (if (string-match "\\s-+\\'" txt) - (setq txt (replace-match "" t t txt))) - (setq lines (org-split-string txt "\n")) - (and note (string-match "\\S-" note) (push note lines)) - (save-excursion - (set-buffer (marker-buffer org-log-note-marker)) - (save-excursion - (goto-char org-log-note-marker) - (if (not (bolp)) (newline)) - (indent-relative t) - (setq ind (concat (buffer-substring (point-at-bol) (point)) " ")) - (insert " - " (pop lines)) - (while lines - (insert "\n" ind (pop lines)))))) - (set-window-configuration org-log-note-window-configuration))) +(defun org-table-next-field () + "Go to the next field in the current table, creating new lines as needed. +Before doing so, re-align the table if necessary." + (interactive) + (org-table-maybe-eval-formula) + (org-table-maybe-recalculate-line) + (if (and org-table-automatic-realign + org-table-may-need-update) + (org-table-align)) + (let ((end (org-table-end))) + (if (org-at-table-hline-p) + (end-of-line 1)) + (condition-case nil + (progn + (re-search-forward "|" end) + (if (looking-at "[ \t]*$") + (re-search-forward "|" end)) + (if (and (looking-at "-") + org-table-tab-jumps-over-hlines + (re-search-forward "^[ \t]*|\\([^-]\\)" end t)) + (goto-char (match-beginning 1))) + (if (looking-at "-") + (progn + (beginning-of-line 0) + (org-table-insert-row 'below)) + (if (looking-at " ") (forward-char 1)))) + (error + (org-table-insert-row 'below))))) -(defvar org-occur-highlights nil) -(make-variable-buffer-local 'org-occur-highlights) +(defun org-table-previous-field () + "Go to the previous field in the table. +Before doing so, re-align the table if necessary." + (interactive) + (org-table-justify-field-maybe) + (org-table-maybe-recalculate-line) + (if (and org-table-automatic-realign + org-table-may-need-update) + (org-table-align)) + (if (org-at-table-hline-p) + (end-of-line 1)) + (re-search-backward "|" (org-table-begin)) + (re-search-backward "|" (org-table-begin)) + (while (looking-at "|\\(-\\|[ \t]*$\\)") + (re-search-backward "|" (org-table-begin))) + (if (looking-at "| ?") + (goto-char (match-end 0)))) -(defun org-occur (regexp &optional keep-previous callback) - "Make a compact tree which shows all matches of REGEXP. -The tree will show the lines where the regexp matches, and all higher -headlines above the match. It will also show the heading after the match, -to make sure editing the matching entry is easy. -If KEEP-PREVIOUS is non-nil, highlighting and exposing done by a previous -call to `org-occur' will be kept, to allow stacking of calls to this -command. -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)) - (let ((cnt 0)) - (save-excursion - (goto-char (point-min)) - (if (or (not keep-previous) ; do not want to keep - (not org-occur-highlights)) ; no previous matches - ;; hide everything - (org-overview)) - (while (re-search-forward regexp nil t) - (when (or (not callback) - (save-match-data (funcall callback))) - (setq cnt (1+ cnt)) - (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 - nil 'local)) - (unless org-sparse-tree-open-archived-trees - (org-hide-archived-subtrees (point-min) (point-max))) - (run-hooks 'org-occur-hook) - (if (interactive-p) - (message "%d match(es) for regexp %s" cnt regexp)) - cnt)) - -(defun org-show-context (&optional key siblings) - "Make sure point and context and visible. -How much context is shown depends upon the variables -`org-show-hierarchy-above' and `org-show-following-heading'. -When SIBLINGS is non-nil, show all siblings on each hierarchy level." - (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))) - (catch 'exit - ;; Show heading or entry text - (if heading-p - (org-flag-heading nil) ; only show the heading - (and (or (org-invisible-p) (org-invisible-p2)) - (org-show-hidden-entry))) ; show entire entry - (when following-p - ;; Show next sibling, or heading below text - (save-excursion - (and (if heading-p (org-goto-sibling) (outline-next-heading)) - (org-flag-heading nil)))) - (when siblings (org-show-siblings)) - (when hierarchy-p - ;; show all higher headings, possibly with siblings - (save-excursion - (while (and (condition-case nil - (progn (org-up-heading-all 1) t) - (error nil)) - (not (bobp))) - (org-flag-heading nil) - (when siblings (org-show-siblings)))))))) - -(defun org-show-siblings () - "Show all siblings of the current headline." - (save-excursion - (while (org-goto-sibling) (org-flag-heading nil))) - (save-excursion - (while (org-goto-sibling 'previous) - (org-flag-heading nil)))) - -(defun org-reveal (&optional siblings) - "Show current entry, hierarchy above it, and the following headline. -This can be used to show a consistent set of context around locations -exposed with `org-show-hierarchy-above' or `org-show-following-heading' -not t for the search context. +(defun org-table-next-row () + "Go to the next row (same column) in the current table. +Before doing so, re-align the table if necessary." + (interactive) + (org-table-maybe-eval-formula) + (org-table-maybe-recalculate-line) + (if (or (looking-at "[ \t]*$") + (save-excursion (skip-chars-backward " \t") (bolp))) + (newline) + (if (and org-table-automatic-realign + org-table-may-need-update) + (org-table-align)) + (let ((col (org-table-current-column))) + (beginning-of-line 2) + (if (or (not (org-at-table-p)) + (org-at-table-hline-p)) + (progn + (beginning-of-line 0) + (org-table-insert-row 'below))) + (org-table-goto-column col) + (skip-chars-backward "^|\n\r") + (if (looking-at " ") (forward-char 1))))) -With optional argument SIBLINGS, on each level of the hierarchy all -siblings are shown. This repairs the tree structure so what it would -look like when opend with successive calls to `org-cycle'." - (interactive "P") - (let ((org-show-hierarchy-above t) - (org-show-following-heading t)) - (org-show-context nil siblings))) +(defun org-table-copy-down (n) + "Copy a field down in the current column. +If the field at the cursor is empty, copy into it the content of the nearest +non-empty field above. With argument N, use the Nth non-empty field. +If the current field is not empty, it is copied down to the next row, and +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." + (interactive "p") + (let* ((colpos (org-table-current-column)) + (field (org-table-get-field)) + (non-empty (string-match "[^ \t]" field)) + (beg (org-table-begin)) + txt) + (org-table-check-inside-data-field) + (if non-empty + (progn + (setq txt (org-trim field)) + (org-table-next-row) + (org-table-blank-field)) + (save-excursion + (setq txt + (catch 'exit + (while (progn (beginning-of-line 1) + (re-search-backward org-table-dataline-regexp + beg t)) + (org-table-goto-column colpos t) + (if (and (looking-at + "|[ \t]*\\([^| \t][^|]*?\\)[ \t]*|") + (= (setq n (1- n)) 0)) + (throw 'exit (match-string 1)))))))) + (if txt + (progn + (if (and org-table-copy-increment + (string-match "^[0-9]+$" txt)) + (setq txt (format "%d" (+ (string-to-number txt) 1)))) + (insert txt) + (org-table-maybe-recalculate-line) + (org-table-align)) + (error "No non-empty field found")))) -;; Overlay compatibility functions -(defun org-make-overlay (beg end &optional buffer) - (if (featurep 'xemacs) - (make-extent beg end buffer) - (make-overlay beg end buffer))) -(defun org-delete-overlay (ovl) - (if (featurep 'xemacs) (delete-extent ovl) (delete-overlay ovl))) -(defun org-detach-overlay (ovl) - (if (featurep 'xemacs) (detach-extent ovl) (delete-overlay ovl))) -(defun org-move-overlay (ovl beg end &optional buffer) - (if (featurep 'xemacs) - (set-extent-endpoints ovl beg end (or buffer (current-buffer))) - (move-overlay ovl beg end buffer))) -(defun org-overlay-put (ovl prop value) - (if (featurep 'xemacs) - (set-extent-property ovl prop value) - (overlay-put ovl prop value))) -(defun org-overlay-display (ovl text &optional face) - "Make overlay OVL display TEXT with face FACE." - (if (featurep 'xemacs) - (let ((gl (make-glyph text))) - (and face (set-glyph-face gl face)) - (set-extent-property ovl 'invisible t) - (set-extent-property ovl 'end-glyph gl)) - (overlay-put ovl 'display text) - (if face (overlay-put ovl 'face face)))) -(defun org-overlay-get (ovl prop) - (if (featurep 'xemacs) - (extent-property ovl prop) - (overlay-get ovl prop))) -(defun org-overlays-at (pos) - (if (featurep 'xemacs) (extents-at pos) (overlays-at pos))) -(defun org-overlays-in (&optional start end) - (if (featurep 'xemacs) - (extent-list nil start end) - (overlays-in start end))) -(defun org-overlay-start (o) - (if (featurep 'xemacs) (extent-start-position o) (overlay-start o))) -(defun org-overlay-end (o) - (if (featurep 'xemacs) (extent-end-position o) (overlay-end o))) +(defun org-table-check-inside-data-field () + "Is point inside a table data field? +I.e. not on a hline or before the first or after the last column? +This actually throws an error, so it aborts the current command." + (if (or (not (org-at-table-p)) + (= (org-table-current-column) 0) + (org-at-table-hline-p) + (looking-at "[ \t]*$")) + (error "Not in table data field"))) -(defun org-highlight-new-match (beg end) - "Highlight from BEG to END and mark the highlight is an occur headline." - (let ((ov (org-make-overlay beg end))) - (org-overlay-put ov 'face 'secondary-selection) - (push ov org-occur-highlights))) +(defvar org-table-clip nil + "Clipboard for table regions.") -(defvar org-inhibit-highlight-removal nil) -(defun org-remove-occur-highlights (&optional beg end noremove) - "Remove the occur highlights from the buffer. -BEG and END are ignored. If NOREMOVE is nil, remove this function -from the `before-change-functions' in the current buffer." +(defun org-table-blank-field () + "Blank the current table field or active region." (interactive) - (unless org-inhibit-highlight-removal - (mapc 'org-delete-overlay org-occur-highlights) - (setq org-occur-highlights nil) - (unless noremove - (remove-hook 'before-change-functions - 'org-remove-occur-highlights 'local)))) + (org-table-check-inside-data-field) + (if (and (interactive-p) (org-region-active-p)) + (let (org-table-clip) + (org-table-cut-region (region-beginning) (region-end))) + (skip-chars-backward "^|") + (backward-char 1) + (if (looking-at "|[^|\n]+") + (let* ((pos (match-beginning 0)) + (match (match-string 0)) + (len (org-string-width match))) + (replace-match (concat "|" (make-string (1- len) ?\ ))) + (goto-char (+ 2 pos)) + (substring match 1))))) -;;; Priorities +(defun org-table-get-field (&optional n replace) + "Return the value of the field in column N of current row. +N defaults to current field. +If REPLACE is a string, replace field with this value. The return value +is always the old value." + (and n (org-table-goto-column n)) + (skip-chars-backward "^|\n") + (backward-char 1) + (if (looking-at "|[^|\r\n]*") + (let* ((pos (match-beginning 0)) + (val (buffer-substring (1+ pos) (match-end 0)))) + (if replace + (replace-match (concat "|" replace))) + (goto-char (min (point-at-eol) (+ 2 pos))) + val) + (forward-char 1) "")) -(defvar org-priority-regexp ".*?\\(\\[#\\([A-Z]\\)\\] ?\\)" - "Regular expression matching the priority indicator.") -(defvar org-remove-priority-next-time nil) +(defun org-table-field-info (arg) + "Show info about the current field, and highlight any reference at point." + (interactive "P") + (org-table-get-specials) + (save-excursion + (let* ((pos (point)) + (col (org-table-current-column)) + (cname (car (rassoc (int-to-string col) org-table-column-names))) + (name (car (rassoc (list (org-current-line) col) + org-table-named-field-locations))) + (eql (org-table-get-stored-formulas)) + (dline (org-table-current-dline)) + (ref (format "@%d$%d" dline col)) + (fequation (or (assoc name eql) (assoc ref eql))) + (cequation (assoc (int-to-string col) eql))) + (goto-char pos) + (condition-case nil + (org-show-reference 'local) + (error nil)) + (message "line @%d, col $%s%s, ref @%d$%d%s%s" + dline col + (if cname (concat " or $" cname) "") + dline col + (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" "") + ""))))) -(defun org-priority-up () - "Increase the priority of the current item." +(defun org-table-current-column () + "Find out which column we are in. +When called interactively, column is also displayed in echo area." (interactive) - (org-priority 'up)) + (if (interactive-p) (org-table-check-inside-data-field)) + (save-excursion + (let ((cnt 0) (pos (point))) + (beginning-of-line 1) + (while (search-forward "|" pos t) + (setq cnt (1+ cnt))) + (if (interactive-p) (message "This is table column %d" cnt)) + cnt))) -(defun org-priority-down () - "Decrease the priority of the current item." +(defun org-table-current-dline () + "Find out what table data line we are in. +Only datalins count for this." (interactive) - (org-priority 'down)) - -(defun org-priority (&optional action) - "Change the priority of an item by ARG. -ACTION can be set, up, or down." - (interactive) - (setq action (or action 'set)) - (let (current new news have remove) - (save-excursion - (org-back-to-heading) - (if (looking-at org-priority-regexp) - (setq current (string-to-char (match-string 2)) - 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)) - (cond ((equal new ?\ ) (setq remove t)) - ((or (< (upcase new) ?A) (> (upcase new) org-lowest-priority)) - (error "Priority must be between `%c' and `%c'" - ?A org-lowest-priority)))) - ((eq action 'up) - (setq new (1- current))) - ((eq action 'down) - (setq new (1+ current))) - (t (error "Invalid action"))) - (setq new (min (max ?A (upcase new)) org-lowest-priority)) - (setq news (format "%c" new)) - (if have - (if remove - (replace-match "" t t nil 1) - (replace-match news t t nil 2)) - (if remove - (error "No priority cookie found in line") - (looking-at org-todo-line-regexp) - (if (match-end 2) - (progn - (goto-char (match-end 2)) - (insert " [#" news "]")) - (goto-char (match-beginning 3)) - (insert "[#" news "] "))))) - (if remove - (message "Priority removed") - (message "Priority of current item set to %s" news)))) + (if (interactive-p) (org-table-check-inside-data-field)) + (save-excursion + (let ((cnt 0) (pos (point))) + (goto-char (org-table-begin)) + (while (<= (point) pos) + (if (looking-at org-table-dataline-regexp) (setq cnt (1+ cnt))) + (beginning-of-line 2)) + (if (interactive-p) (message "This is table line %d" cnt)) + cnt))) +(defun org-table-goto-column (n &optional on-delim force) + "Move the cursor to the Nth column in the current table line. +With optional argument ON-DELIM, stop with point before the left delimiter +of the field. +If there are less than N fields, just go to after the last delimiter. +However, when FORCE is non-nil, create new columns if necessary." + (interactive "p") + (let ((pos (point-at-eol))) + (beginning-of-line 1) + (when (> n 0) + (while (and (> (setq n (1- n)) -1) + (or (search-forward "|" pos t) + (and force + (progn (end-of-line 1) + (skip-chars-backward "^|") + (insert " | ")))))) +; (backward-char 2) t))))) + (when (and force (not (looking-at ".*|"))) + (save-excursion (end-of-line 1) (insert " | "))) + (if on-delim + (backward-char 1) + (if (looking-at " ") (forward-char 1)))))) -(defun org-get-priority (s) - "Find priority cookie and return priority." - (save-match-data - (if (not (string-match org-priority-regexp s)) - (* 1000 (- org-lowest-priority org-default-priority)) - (* 1000 (- org-lowest-priority - (string-to-char (match-string 2 s))))))) +(defun org-at-table-p (&optional table-type) + "Return t if the cursor is inside an org-type table. +If TABLE-TYPE is non-nil, also check for table.el-type tables." + (if org-enable-table-editor + (save-excursion + (beginning-of-line 1) + (looking-at (if table-type org-table-any-line-regexp + org-table-line-regexp))) + nil)) -;;; Timestamps +(defun org-at-table.el-p () + "Return t if and only if we are at a table.el table." + (and (org-at-table-p 'any) + (save-excursion + (goto-char (org-table-begin 'any)) + (looking-at org-table1-hline-regexp)))) -(defvar org-last-changed-timestamp nil) +(defun org-table-recognize-table.el () + "If there is a table.el table nearby, recognize it and move into it." + (if org-table-tab-recognizes-table.el + (if (org-at-table.el-p) + (progn + (beginning-of-line 1) + (if (looking-at org-table-dataline-regexp) + nil + (if (looking-at org-table1-hline-regexp) + (progn + (beginning-of-line 2) + (if (looking-at org-table-any-border-regexp) + (beginning-of-line -1))))) + (if (re-search-forward "|" (org-table-end t) t) + (progn + (require 'table) + (if (table--at-cell-p (point)) + t + (message "recognizing table.el table...") + (table-recognize-table) + (message "recognizing table.el table...done"))) + (error "This should not happen...")) + t) + nil) + nil)) -(defun org-time-stamp (arg) - "Prompt for a date/time and insert a time stamp. -If the user specifies a time like HH:MM, or if this command is called -with a prefix argument, the time stamp will contain date and time. -Otherwise, only the date will be included. All parts of a date not -specified by the user will be filled in from the current date/time. -So if you press just return without typing anything, the time stamp -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) - (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-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))) - (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)))) - (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)))))) +(defun org-at-table-hline-p () + "Return t if the cursor is inside a hline in a table." + (if org-enable-table-editor + (save-excursion + (beginning-of-line 1) + (looking-at org-table-hline-regexp)) + nil)) -(defun org-time-stamp-inactive (&optional arg) - "Insert an inactive time stamp. -An inactive time stamp is enclosed in square brackets instead of angle -brackets. It is inactive in the sense that it does not trigger agenda entries, -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) - (setq time (org-read-date arg 'totime)) - (org-insert-time-stamp time (or org-time-was-given arg) 'inactive))) +(defun org-table-insert-column () + "Insert a new column into the table." + (interactive) + (if (not (org-at-table-p)) + (error "Not at a table")) + (org-table-find-dataline) + (let* ((col (max 1 (org-table-current-column))) + (beg (org-table-begin)) + (end (org-table-end)) + ;; Current cursor position + (linepos (org-current-line)) + (colpos col)) + (goto-char beg) + (while (< (point) end) + (if (org-at-table-hline-p) + nil + (org-table-goto-column col t) + (insert "| ")) + (beginning-of-line 2)) + (move-marker end nil) + (goto-line linepos) + (org-table-goto-column colpos) + (org-table-align) + (org-table-fix-formulas "$" nil (1- col) 1))) -(defvar org-date-ovl (org-make-overlay 1 1)) -(org-overlay-put org-date-ovl 'face 'org-warning) -(org-detach-overlay org-date-ovl) +(defun org-table-find-dataline () + "Find a dataline in the current table, which is needed for column commands." + (if (and (org-at-table-p) + (not (org-at-table-hline-p))) + t + (let ((col (current-column)) + (end (org-table-end))) + (move-to-column col) + (while (and (< (point) end) + (or (not (= (current-column) col)) + (org-at-table-hline-p))) + (beginning-of-line 2) + (move-to-column col)) + (if (and (org-at-table-p) + (not (org-at-table-hline-p))) + t + (error + "Please position cursor in a data line for column operations"))))) -(defun org-read-date (&optional with-time to-time from-string) - "Read a date 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, - 3-2-5 --> 2003-02-05 - feb 15 --> currentyear-02-15 - sep 12 9 --> 2009-09-12 - 12:45 --> today 12:45 - 22 sept 0:34 --> currentyear-09-22 0:34 - 12 --> currentyear-currentmonth-12 - Fri --> nearest Friday (today or later) - etc. -The function understands only English month and weekday abbreviations, -but this can be configured with the variables `parse-time-months' and -`parse-time-weekdays'. +(defun org-table-delete-column () + "Delete a column from the table." + (interactive) + (if (not (org-at-table-p)) + (error "Not at a table")) + (org-table-find-dataline) + (org-table-check-inside-data-field) + (let* ((col (org-table-current-column)) + (beg (org-table-begin)) + (end (org-table-end)) + ;; Current cursor position + (linepos (org-current-line)) + (colpos col)) + (goto-char beg) + (while (< (point) end) + (if (org-at-table-hline-p) + nil + (org-table-goto-column col t) + (and (looking-at "|[^|\n]+|") + (replace-match "|"))) + (beginning-of-line 2)) + (move-marker end nil) + (goto-line linepos) + (org-table-goto-column colpos) + (org-table-align) + (org-table-fix-formulas "$" (list (cons (number-to-string col) "INVALID")) + col -1 col))) -While prompting, a calendar is popped up - you can also select the -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) +(defun org-table-move-column-right () + "Move column to the right." + (interactive) + (org-table-move-column nil)) +(defun org-table-move-column-left () + "Move column to the left." + (interactive) + (org-table-move-column 'left)) -With optional argument TO-TIME, the date will immediately be converted -to an internal time. -With an optional argument WITH-TIME, the prompt will suggest to also -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." - (require 'parse-time) - (let* ((org-time-stamp-rounding-minutes - (if (equal with-time '(16)) 0 org-time-stamp-rounding-minutes)) - (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)) - (calendar-move-hook nil) - (view-diary-entries-initially nil) - (view-calendar-holidays-initially nil) - (timestr (format-time-string - (if with-time "%Y-%m-%d %H:%M" "%Y-%m-%d") default-time)) - (prompt (format "YYYY-MM-DD [%s]: " timestr)) - ans ans1 ans2 - second minute hour day month year tl wday wday1) +(defun org-table-move-column (&optional left) + "Move the current column to the right. With arg LEFT, move to the left." + (interactive "P") + (if (not (org-at-table-p)) + (error "Not at a table")) + (org-table-find-dataline) + (org-table-check-inside-data-field) + (let* ((col (org-table-current-column)) + (col1 (if left (1- col) col)) + (beg (org-table-begin)) + (end (org-table-end)) + ;; Current cursor position + (linepos (org-current-line)) + (colpos (if left (1- col) (1+ col)))) + (if (and left (= col 1)) + (error "Cannot move column further left")) + (if (and (not left) (looking-at "[^|\n]*|[^|\n]*$")) + (error "Cannot move column further right")) + (goto-char beg) + (while (< (point) end) + (if (org-at-table-hline-p) + nil + (org-table-goto-column col1 t) + (and (looking-at "|\\([^|\n]+\\)|\\([^|\n]+\\)|") + (replace-match "|\\2|\\1|"))) + (beginning-of-line 2)) + (move-marker end nil) + (goto-line linepos) + (org-table-goto-column colpos) + (org-table-align) + (org-table-fix-formulas + "$" (list (cons (number-to-string col) (number-to-string colpos)) + (cons (number-to-string colpos) (number-to-string col)))))) - (cond - (from-string (setq ans from-string)) - (org-popup-calendar-for-date-prompt - (save-excursion - (save-window-excursion - (calendar) - (calendar-forward-day (- (time-to-days default-time) - (calendar-absolute-from-gregorian - (calendar-current-date)))) - (org-eval-in-calendar nil) - (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-calendar-select-mouse) - (define-key map (if (featurep 'xemacs) [button2] [mouse-2]) - 'org-calendar-select-mouse) - (define-key minibuffer-local-map [(meta shift left)] - (lambda () (interactive) - (org-eval-in-calendar '(calendar-backward-month 1)))) - (define-key minibuffer-local-map [(meta shift right)] - (lambda () (interactive) - (org-eval-in-calendar '(calendar-forward-month 1)))) - (define-key minibuffer-local-map [(shift up)] - (lambda () (interactive) - (org-eval-in-calendar '(calendar-backward-week 1)))) - (define-key minibuffer-local-map [(shift down)] - (lambda () (interactive) - (org-eval-in-calendar '(calendar-forward-week 1)))) - (define-key minibuffer-local-map [(shift left)] - (lambda () (interactive) - (org-eval-in-calendar '(calendar-backward-day 1)))) - (define-key minibuffer-local-map [(shift right)] - (lambda () (interactive) - (org-eval-in-calendar '(calendar-forward-day 1)))) - (define-key minibuffer-local-map ">" - (lambda () (interactive) - (org-eval-in-calendar '(scroll-calendar-left 1)))) - (define-key minibuffer-local-map "<" - (lambda () (interactive) - (org-eval-in-calendar '(scroll-calendar-right 1)))) - (unwind-protect - (progn - (use-local-map map) - (setq ans (read-string prompt "" nil nil)) - (if (not (string-match "\\S-" ans)) (setq ans nil)) - (setq ans (or ans1 ans ans2))) - (use-local-map old-map)))))) - (t ; Naked prompt only - (setq ans (read-string prompt "" nil timestr)))) - (org-detach-overlay org-date-ovl) +(defun org-table-move-row-down () + "Move table row down." + (interactive) + (org-table-move-row nil)) +(defun org-table-move-row-up () + "Move table row up." + (interactive) + (org-table-move-row 'up)) - (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))) - second (or (nth 0 tl) 0) - wday (nth 6 tl)) - (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. - (setq wday1 (nth 6 (decode-time (encode-time 0 0 0 day month year)))) - (unless (equal wday wday1) - (setq day (+ day (% (- wday wday1 -7) 7))))) - (if (and (boundp 'org-time-was-given) - (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))))) +(defun org-table-move-row (&optional up) + "Move the current table line down. With arg UP, move it up." + (interactive "P") + (let* ((col (current-column)) + (pos (point)) + (hline1p (save-excursion (beginning-of-line 1) + (looking-at org-table-hline-regexp))) + (dline1 (org-table-current-dline)) + (dline2 (+ dline1 (if up -1 1))) + (tonew (if up 0 2)) + txt hline2p) + (beginning-of-line tonew) + (unless (org-at-table-p) + (goto-char pos) + (error "Cannot move row further")) + (setq hline2p (looking-at org-table-hline-regexp)) + (goto-char pos) + (beginning-of-line 1) + (setq pos (point)) + (setq txt (buffer-substring (point) (1+ (point-at-eol)))) + (delete-region (point) (1+ (point-at-eol))) + (beginning-of-line tonew) + (insert txt) + (beginning-of-line 0) + (move-to-column col) + (unless (or hline1p hline2p) + (org-table-fix-formulas + "@" (list (cons (number-to-string dline1) (number-to-string dline2)) + (cons (number-to-string dline2) (number-to-string dline1))))))) -(defun org-eval-in-calendar (form) - "Eval FORM in the calendar window and return to current window. -Also, store the cursor date in variable ans2." - (let ((sw (selected-window))) - (select-window (get-buffer-window "*Calendar*")) - (eval form) - (when (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 ans2 (format-time-string "%Y-%m-%d" time)))) - (org-move-overlay org-date-ovl (1- (point)) (1+ (point)) (current-buffer)) - (select-window sw))) +(defun org-table-insert-row (&optional arg) + "Insert a new row above the current line into the table. +With prefix ARG, insert below the current line." + (interactive "P") + (if (not (org-at-table-p)) + (error "Not at a table")) + (let* ((line (buffer-substring (point-at-bol) (point-at-eol))) + (new (org-table-clean-line line))) + ;; Fix the first field if necessary + (if (string-match "^[ \t]*| *[#$] *|" line) + (setq new (replace-match (match-string 0 line) t t new))) + (beginning-of-line (if arg 2 1)) + (let (org-table-may-need-update) (insert-before-markers new "\n")) + (beginning-of-line 0) + (re-search-forward "| ?" (point-at-eol) t) + (and (or org-table-may-need-update org-table-overlay-coordinates) + (org-table-align)) + (org-table-fix-formulas "@" nil (1- (org-table-current-dline)) 1))) -(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." - (interactive) - (when (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 ans1 (format-time-string "%Y-%m-%d" time))) - (if (active-minibuffer-window) (exit-minibuffer)))) +(defun org-table-insert-hline (&optional arg) + "Insert a horizontal-line below the current line into the table. +With prefix ARG, insert above the current line." + (interactive "P") + (if (not (org-at-table-p)) + (error "Not at a table")) + (let ((line (org-table-clean-line + (buffer-substring (point-at-bol) (point-at-eol)))) + (col (current-column))) + (while (string-match "|\\( +\\)|" line) + (setq line (replace-match + (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)) + (insert line "\n") + (beginning-of-line (if arg 1 -1)) + (move-to-column col) + (and org-table-overlay-coordinates (org-table-align)))) -(defun org-insert-time-stamp (time &optional with-hm inactive pre post) - "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 -stamp will not contribute to the agenda. -PRE and POST are optional strings to be inserted before and after the -stamp. -The command returns the inserted time stamp." - (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 "")) - stamp)) +(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." + (if (string-match "^[ \t]*|-" s) + ;; It's a hline, just map the characters + (setq s (mapconcat (lambda (x) (if (member x '(?| ?+)) "|" " ")) s "")) + (while (string-match "|\\([ \t]*?[^ \t\r\n|][^\r\n|]*\\)|" s) + (setq s (replace-match + (concat "|" (make-string (org-string-width (match-string 1 s)) + ?\ ) "|") + t t s))) + s)) -(defun org-toggle-time-stamp-overlays () - "Toggle the use of custom time stamp formats." +(defun org-table-kill-row () + "Delete the current row or horizontal line from the table." (interactive) - (setq org-display-custom-times (not org-display-custom-times)) - (unless org-display-custom-times - (let ((p (point-min)) (bmp (buffer-modified-p))) - (while (setq p (next-single-property-change p 'display)) - (if (and (get-text-property p 'display) - (eq (get-text-property p 'face) 'org-date)) - (remove-text-properties - p (setq p (next-single-property-change p 'display)) - '(display t)))) - (set-buffer-modified-p bmp))) - (if (featurep 'xemacs) - (remove-text-properties (point-min) (point-max) '(end-glyph t))) - (org-restart-font-lock) - (setq org-table-may-need-update t) - (if org-display-custom-times - (message "Time stamps are overlayed with custom format") - (message "Time stamp overlays removed"))) - -(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))) - (inactive (= (char-before (1- beg)) ?\[)) - (tf (funcall (if with-hm 'cdr 'car) org-time-stamp-custom-formats)) - (time (org-fix-decoded-time t1)) - (time (mapcar (lambda (x) (or x 0)) t1)) - (str (org-add-props - (format-time-string - (substring tf 1 -1) (apply 'encode-time time)) - 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)))) - (if (featurep 'xemacs) - (progn - (put-text-property beg end 'invisible t) - (put-text-property beg end 'end-glyph (make-glyph str))) - (put-text-property beg end 'display str)))) - -(defun org-fix-decoded-time (time) - "Set 0 instead of nil for the first 6 elements of time. -Don't touch the rest." - (let ((n 0)) - (mapcar (lambda (x) (if (< (setq n (1+ n)) 7) (or x 0) x)) time))) + (if (not (org-at-table-p)) + (error "Not at a table")) + (let ((col (current-column)) + (dline (org-table-current-dline))) + (kill-region (point-at-bol) (min (1+ (point-at-eol)) (point-max))) + (if (not (org-at-table-p)) (beginning-of-line 0)) + (move-to-column col) + (org-table-fix-formulas "@" (list (cons (number-to-string dline) "INVALID")) + dline -1 dline))) -(defun org-days-to-time (timestamp-string) - "Difference between TIMESTAMP-STRING and now in days." - (- (time-to-days (org-time-string-to-time timestamp-string)) - (time-to-days (current-time)))) -(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)) - (not (org-entry-is-done-p)))) +(defun org-table-sort-lines (with-case &optional sorting-type) + "Sort table lines according to the column at point. -(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." - (interactive "e") - (mouse-set-point ev) - (when (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 ans1 (format-time-string "%Y-%m-%d" time))) - (if (active-minibuffer-window) (exit-minibuffer)))) +The position of point indicates the column to be used for +sorting, and the range of lines is the range between the nearest +horizontal separator lines, or the entire table of no such lines +exist. If point is before the first column, you will be prompted +for the sorting column. If there is an active region, the mark +specifies the first line and the sorting column, while point +should be in the last line to be included into the sorting. -(defun org-check-deadlines (ndays) - "Check if there are any deadlines due or past due. -A deadline is considered due if it happens within `org-deadline-warning-days' -days from today's date. If the deadline appears in an entry marked DONE, -it is not shown. The prefix arg NDAYS can be used to test that many -days. If the prefix is a raw \\[universal-argument] prefix, all deadlines are shown." - (interactive "P") - (let* ((org-warn-days - (cond - ((equal ndays '(4)) 100000) - (ndays (prefix-numeric-value ndays)) - (t org-deadline-warning-days))) - (case-fold-search nil) - (regexp (concat "\\<" org-deadline-string " *<\\([^>]+\\)>")) - (callback - (lambda () (org-deadline-close (match-string 1) org-warn-days)))) +The command then prompts for the sorting type which can be +alphabetically, numerically, or by time (as given in a time stamp +in the field). Sorting in reverse order is also possible. - (message "%d deadlines past-due or due within %d days" - (org-occur regexp nil callback) - org-warn-days))) +With prefix argument WITH-CASE, alphabetic sorting will be case-sensitive. -(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 -TO-BUFFER, the result is inserted just after the date stamp into the buffer. -If the time range is actually in a table, the result is inserted into the -next column. -For time difference computation, a year is assumed to be exactly 365 -days in order to avoid rounding problems." +If SORTING-TYPE is specified when this function is called from a Lisp +program, no prompting will take place. SORTING-TYPE must be a character, +any of (?a ?A ?n ?N ?t ?T) where the capital letter indicate that sorting +should be done in reverse order." (interactive "P") - (or - (org-clock-update-time-maybe) - (save-excursion - (unless (org-at-date-range-p) - (goto-char (point-at-bol)) - (re-search-forward org-tr-regexp (point-at-eol) t)) - (if (not (org-at-date-range-p)) - (error "Not at a time-stamp range, and none found in current line"))) - (let* ((ts1 (match-string 1)) - (ts2 (match-string 2)) - (havetime (or (> (length ts1) 15) (> (length ts2) 15))) - (match-end (match-end 0)) - (time1 (org-time-string-to-time ts1)) - (time2 (org-time-string-to-time ts2)) - (t1 (time-to-seconds time1)) - (t2 (time-to-seconds time2)) - (diff (abs (- t2 t1))) - (negative (< (- t2 t1) 0)) - ;; (ys (floor (* 365 24 60 60))) - (ds (* 24 60 60)) - (hs (* 60 60)) - (fy "%dy %dd %02d:%02d") - (fy1 "%dy %dd") - (fd "%dd %02d:%02d") - (fd1 "%dd") - (fh "%02d:%02d") - y d h m align) - (if havetime - (setq ; y (floor (/ diff ys)) diff (mod diff ys) - y 0 - d (floor (/ diff ds)) diff (mod diff ds) - h (floor (/ diff hs)) diff (mod diff hs) - m (floor (/ diff 60))) - (setq ; y (floor (/ diff ys)) diff (mod diff ys) - y 0 - 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)))) - (if (looking-at - "\\( *-? *[0-9]+y\\)?\\( *[0-9]+d\\)? *[0-9][0-9]:[0-9][0-9]") - (replace-match "")) - (if negative (insert " -")) - (if (> y 0) (insert " " (format (if havetime fy fy1) y d h m)) - (if (> d 0) (insert " " (format (if havetime fd fd1) d h m)) - (insert " " (format fh h m)))) - (if align (org-table-align)) - (message "Time difference inserted"))))) + (let* ((thisline (org-current-line)) + (thiscol (org-table-current-column)) + beg end bcol ecol tend tbeg column lns pos) + (when (equal thiscol 0) + (if (interactive-p) + (setq thiscol + (string-to-number + (read-string "Use column N for sorting: "))) + (setq thiscol 1)) + (org-table-goto-column thiscol)) + (org-table-check-inside-data-field) + (if (org-region-active-p) + (progn + (setq beg (region-beginning) end (region-end)) + (goto-char beg) + (setq column (org-table-current-column) + beg (point-at-bol)) + (goto-char end) + (setq end (point-at-bol 2))) + (setq column (org-table-current-column) + pos (point) + tbeg (org-table-begin) + tend (org-table-end)) + (if (re-search-backward org-table-hline-regexp tbeg t) + (setq beg (point-at-bol 2)) + (goto-char tbeg) + (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)) + (goto-char tend) + (setq end (point-at-bol)))) + (setq beg (move-marker (make-marker) beg) + end (move-marker (make-marker) end)) + (untabify beg end) + (goto-char beg) + (org-table-goto-column column) + (skip-chars-backward "^|") + (setq bcol (current-column)) + (org-table-goto-column (1+ column)) + (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)) + (org-split-string (buffer-substring beg end) "\n"))) + (setq lns (org-do-sort lns "Table" with-case sorting-type)) + (delete-region beg end) + (move-marker beg nil) + (move-marker end nil) + (insert (mapconcat 'cdr lns "\n") "\n") + (goto-line thisline) + (org-table-goto-column thiscol) + (message "%d lines sorted, based on column %d" (length lns) column))) -(defun org-make-tdiff-string (y d h m) - (let ((fmt "") - (l nil)) - (if (> y 0) (setq fmt (concat fmt "%d year" (if (> y 1) "s" "") " ") - l (push y l))) - (if (> d 0) (setq fmt (concat fmt "%d day" (if (> d 1) "s" "") " ") - l (push d l))) - (if (> h 0) (setq fmt (concat fmt "%d hour" (if (> h 1) "s" "") " ") - l (push h l))) - (if (> m 0) (setq fmt (concat fmt "%d minute" (if (> m 1) "s" "") " ") - l (push m l))) - (apply 'format fmt (nreverse l)))) +(defun org-table-cut-region (beg end) + "Copy region in table to the clipboard and blank all relevant fields." + (interactive "r") + (org-table-copy-region beg end 'cut)) -(defun org-time-string-to-time (s) - (apply 'encode-time (org-parse-time-string s))) +(defun org-table-copy-region (beg end &optional cut) + "Copy rectangular region in table to clipboard. +A special clipboard is used which can only be accessed +with `org-table-paste-rectangle'." + (interactive "rP") + (let* (l01 c01 l02 c02 l1 c1 l2 c2 ic1 ic2 + region cols + (rpl (if cut " " nil))) + (goto-char beg) + (org-table-check-inside-data-field) + (setq l01 (org-current-line) + c01 (org-table-current-column)) + (goto-char end) + (org-table-check-inside-data-field) + (setq l02 (org-current-line) + c02 (org-table-current-column)) + (setq l1 (min l01 l02) l2 (max l01 l02) + c1 (min c01 c02) c2 (max c01 c02)) + (catch 'exit + (while t + (catch 'nextline + (if (> l1 l2) (throw 'exit t)) + (goto-line l1) + (if (org-at-table-hline-p) (throw 'nextline (setq l1 (1+ l1)))) + (setq cols nil ic1 c1 ic2 c2) + (while (< ic1 (1+ ic2)) + (push (org-table-get-field ic1 rpl) cols) + (setq ic1 (1+ ic1))) + (push (nreverse cols) region) + (setq l1 (1+ l1))))) + (setq org-table-clip (nreverse region)) + (if cut (org-table-align)) + org-table-clip)) -(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) - (list 0 - (if (or (match-beginning 8) (not nodefault)) - (string-to-number (or (match-string 8 s) "0"))) - (if (or (match-beginning 7) (not nodefault)) - (string-to-number (or (match-string 7 s) "0"))) - (string-to-number (match-string 4 s)) - (string-to-number (match-string 3 s)) - (string-to-number (match-string 2 s)) - nil nil nil) - (make-list 9 0))) +(defun org-table-paste-rectangle () + "Paste a rectangular region into a table. +The upper right corner ends up in the current field. All involved fields +will be overwritten. If the rectangle does not fit into the present table, +the table is enlarged as needed. The process ignores horizontal separator +lines." + (interactive) + (unless (and org-table-clip (listp org-table-clip)) + (error "First cut/copy a region to paste!")) + (org-table-check-inside-data-field) + (let* ((clip org-table-clip) + (line (org-current-line)) + (col (org-table-current-column)) + (org-enable-table-editor t) + (org-table-automatic-realign nil) + c cols field) + (while (setq cols (pop clip)) + (while (org-at-table-hline-p) (beginning-of-line 2)) + (if (not (org-at-table-p)) + (progn (end-of-line 0) (org-table-next-field))) + (setq c col) + (while (setq field (pop cols)) + (org-table-goto-column c nil 'force) + (org-table-get-field nil field) + (setq c (1+ c))) + (beginning-of-line 2)) + (goto-line line) + (org-table-goto-column col) + (org-table-align))) -(defun org-timestamp-up (&optional arg) - "Increase the date item at the cursor by one. -If the cursor is on the year, change the year. If it is on the month or -the day, change that. -With prefix ARG, change by that many units." - (interactive "p") - (org-timestamp-change (prefix-numeric-value arg))) - -(defun org-timestamp-down (&optional arg) - "Decrease the date item at the cursor by one. -If the cursor is on the year, change the year. If it is on the month or -the day, change that. -With prefix ARG, change by that many units." - (interactive "p") - (org-timestamp-change (- (prefix-numeric-value arg)))) - -(defun org-timestamp-up-day (&optional arg) - "Increase the date in the time stamp by one day. -With prefix ARG, change that many days." - (interactive "p") - (if (and (not (org-at-timestamp-p t)) - (org-on-heading-p)) - (org-todo 'up) - (org-timestamp-change (prefix-numeric-value arg) 'day))) - -(defun org-timestamp-down-day (&optional arg) - "Decrease the date in the time stamp by one day. -With prefix ARG, change that many days." - (interactive "p") - (if (and (not (org-at-timestamp-p t)) - (org-on-heading-p)) - (org-todo 'down) - (org-timestamp-change (- (prefix-numeric-value arg)) 'day))) - -(defsubst org-pos-in-match-range (pos n) - (and (match-beginning n) - (<= (match-beginning n) pos) - (>= (match-end n) pos))) - -(defun org-at-timestamp-p (&optional inactive-ok) - "Determine if the cursor is in or at a timestamp." +(defun org-table-convert () + "Convert from `org-mode' table to table.el and back. +Obviously, this only works within limits. When an Org-mode table is +converted to table.el, all horizontal separator lines get lost, because +table.el uses these as cell boundaries and has no notion of horizontal lines. +A table.el table can be converted to an Org-mode table only if it does not +do row or column spanning. Multiline cells will become multiple cells. +Beware, Org-mode does not test if the table can be successfully converted - it +blindly applies a recipe that works for simple tables." (interactive) - (let* ((tsr (if inactive-ok org-ts-regexp3 org-ts-regexp2)) - (pos (point)) - (ans (or (looking-at tsr) - (save-excursion - (skip-chars-backward "^[<\n\r\t") - (if (> (point) 1) (backward-char 1)) - (and (looking-at tsr) - (> (- (match-end 0) pos) -1)))))) - (and (boundp 'org-ts-what) - (setq org-ts-what - (cond - ((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) - (t 'day)))) - ans)) - -(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', -`year', `minute', `second'. If WHAT is not given, the cursor position -in the timestamp determines what will be changed." - (let ((pos (point)) - with-hm inactive - org-ts-what - 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))))) + (require 'table) + (if (org-at-table.el-p) + ;; convert to Org-mode table + (let ((beg (move-marker (make-marker) (org-table-begin t))) + (end (move-marker (make-marker) (org-table-end t)))) + (table-unrecognize-region beg end) + (goto-char beg) + (while (re-search-forward "^\\([ \t]*\\)\\+-.*\n" end t) + (replace-match "")) + (goto-char beg)) + (if (org-at-table-p) + ;; convert to table.el table + (let ((beg (move-marker (make-marker) (org-table-begin))) + (end (move-marker (make-marker) (org-table-end)))) + ;; first, get rid of all horizontal lines + (goto-char beg) + (while (re-search-forward "^\\([ \t]*\\)|-.*\n" end t) + (replace-match "")) + ;; insert a hline before first + (goto-char beg) + (org-table-insert-hline 'above) + (beginning-of-line -1) + ;; insert a hline after each line + (while (progn (beginning-of-line 3) (< (point) end)) + (org-table-insert-hline)) + (goto-char beg) + (setq end (move-marker end (org-table-end))) + ;; replace "+" at beginning and ending of hlines + (while (re-search-forward "^\\([ \t]*\\)|-" end t) + (replace-match "\\1+-")) + (goto-char beg) + (while (re-search-forward "-|[ \t]*$" end t) + (replace-match "-+")) + (goto-char beg))))) -(defun org-recenter-calendar (date) - "If the calendar is visible, recenter it to DATE." - (let* ((win (selected-window)) - (cwin (get-buffer-window "*Calendar*" t)) - (calendar-move-hook nil)) - (when cwin - (select-window cwin) - (calendar-goto-date (if (listp date) date - (calendar-gregorian-from-absolute date))) - (select-window win)))) +(defun org-table-wrap-region (arg) + "Wrap several fields in a column like a paragraph. +This is useful if you'd like to spread the contents of a field over several +lines, in order to keep the table compact. -(defun org-goto-calendar (&optional arg) - "Go to the Emacs calendar at the current date. -If there is a time stamp in the current line, go to that date. -A prefix ARG can be used to force the current date." - (interactive "P") - (let ((tsr org-ts-regexp) diff - (calendar-move-hook nil) - (view-calendar-holidays-initially nil) - (view-diary-entries-initially nil)) - (if (or (org-at-timestamp-p) - (save-excursion - (beginning-of-line 1) - (looking-at (concat ".*" tsr)))) - (let ((d1 (time-to-days (current-time))) - (d2 (time-to-days - (org-time-string-to-time (match-string 1))))) - (setq diff (- d2 d1)))) - (calendar) - (calendar-goto-today) - (if (and diff (not arg)) (calendar-forward-day diff)))) +If there is an active region, and both point and mark are in the same column, +the text in the column is wrapped to minimum width for the given number of +lines. Generally, this makes the table more compact. A prefix ARG may be +used to change the number of desired lines. For example, `C-2 \\[org-table-wrap]' +formats the selected text to two lines. If the region was longer than two +lines, the remaining lines remain empty. A negative prefix argument reduces +the current number of lines by that amount. The wrapped text is pasted back +into the table. If you formatted it to more lines than it was before, fields +further down in the table get overwritten - so you might need to make space in +the table first. -(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 there is no region, the current field is split at the cursor position and +the text fragment to the right of the cursor is prepended to the field one +line down. -;;; The clock for measuring work time. +If there is no region, but you specify a prefix ARG, the current field gets +blank, and the content is appended to the field above." + (interactive "P") + (org-table-check-inside-data-field) + (if (org-region-active-p) + ;; There is a region: fill as a paragraph + (let* ((beg (region-beginning)) + (cline (save-excursion (goto-char beg) (org-current-line))) + (ccol (save-excursion (goto-char beg) (org-table-current-column))) + nlines) + (org-table-cut-region (region-beginning) (region-end)) + (if (> (length (car org-table-clip)) 1) + (error "Region must be limited to single column")) + (setq nlines (if arg + (if (< arg 1) + (+ (length org-table-clip) arg) + arg) + (length org-table-clip))) + (setq org-table-clip + (mapcar 'list (org-wrap (mapconcat 'car org-table-clip " ") + nil nlines))) + (goto-line cline) + (org-table-goto-column ccol) + (org-table-paste-rectangle)) + ;; No region, split the current field at point + (if arg + ;; combine with field above + (let ((s (org-table-blank-field)) + (col (org-table-current-column))) + (beginning-of-line 0) + (while (org-at-table-hline-p) (beginning-of-line 0)) + (org-table-goto-column col) + (skip-chars-forward "^|") + (skip-chars-backward " ") + (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)))))) -(defvar org-clock-marker (make-marker) - "Marker recording the last clock-in.") +(defvar org-field-marker nil) -(defun org-clock-in () - "Start the clock on the current item. -If necessary, clock-out of the currently active clock." - (interactive) - (org-clock-out t) - (let (ts) - (save-excursion - (org-back-to-heading t) - (beginning-of-line 2) - (if (and (looking-at (concat "[ \t]*" org-keyword-time-regexp)) - (not (equal (match-string 1) org-clock-string))) - (beginning-of-line 1)) - (insert "\n") (backward-char 1) - (indent-relative) - (insert org-clock-string " ") - (setq ts (org-insert-time-stamp (current-time) 'with-hm 'inactive)) - (move-marker org-clock-marker (point)) - (message "Clock started at %s" ts)))) +(defun org-table-edit-field (arg) + "Edit table field in a different window. +This is mainly useful for fields that contain hidden parts. +When called with a \\[universal-argument] prefix, just make the full field visible so that +it can be edited in place." + (interactive "P") + (if arg + (let ((b (save-excursion (skip-chars-backward "^|") (point))) + (e (save-excursion (skip-chars-forward "^|\r\n") (point)))) + (remove-text-properties b e '(org-cwidth t invisible t + display t intangible t)) + (if (and (boundp 'font-lock-mode) font-lock-mode) + (font-lock-fontify-block))) + (let ((pos (move-marker (make-marker) (point))) + (field (org-table-get-field)) + (cw (current-window-configuration)) + p) + (switch-to-buffer-other-window "*Org tmp*") + (erase-buffer) + (insert "#\n# Edit field and finish with C-c C-c\n#\n") + (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-window-configuration cw) + (org-set-local 'org-field-marker pos) + (message "Edit and finish with C-c C-c")))) -(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." - (interactive) - (catch 'exit - (if (not (marker-buffer org-clock-marker)) - (if fail-quietly (throw 'exit t) (error "No active clock"))) - (let (ts te s h m) - (save-excursion - (set-buffer (marker-buffer org-clock-marker)) - (goto-char org-clock-marker) - (beginning-of-line 1) - (if (and (looking-at (concat "[ \t]*" org-keyword-time-regexp)) - (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) - (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))) - (time-to-seconds (apply 'encode-time (org-parse-time-string ts)))) - h (floor (/ s 3600)) - s (- s (* 3600 h)) - m (floor (/ s 60)) - s (- s (* 60 s))) - (insert " => " (format "%2d:%02d" h m)) - (move-marker org-clock-marker nil) - (org-add-log-maybe 'clock-out) - (message "Clock stopped at %s after HH:MM = %d:%02d" te h m))))) +(defun org-table-finish-edit-field () + "Finish editing a table data field. +Remove all newline characters, insert the result into the table, realign +the table and kill the editing buffer." + (let ((pos org-field-marker) + (cw org-window-configuration) + (cb (current-buffer)) + text) + (goto-char (point-min)) + (while (re-search-forward "^#.*\n?" nil t) (replace-match "")) + (while (re-search-forward "\\([ \t]*\n[ \t]*\\)+" nil t) + (replace-match " ")) + (setq text (org-trim (buffer-string))) + (set-window-configuration cw) + (kill-buffer cb) + (select-window (get-buffer-window (marker-buffer pos))) + (goto-char pos) + (move-marker pos nil) + (org-table-check-inside-data-field) + (org-table-get-field nil text) + (org-table-align) + (message "New field value inserted"))) -(defun org-clock-cancel () - "Cancel the running clock be removing the start timestamp." - (interactive) - (if (not (marker-buffer org-clock-marker)) - (error "No active clock")) - (save-excursion - (set-buffer (marker-buffer org-clock-marker)) - (goto-char org-clock-marker) - (delete-region (1- (point-at-bol)) (point-at-eol))) - (message "Clock canceled")) +(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))) + s) -(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) +(defun org-wrap (string &optional width lines) + "Wrap string to either a number of lines, or a width in characters. +If WIDTH is non-nil, the string is wrapped to that width, however many lines +that costs. If there is a word longer than WIDTH, the text is actually +wrapped to the length of that word. +IF WIDTH is nil and LINES is non-nil, the string is forced into at most that +many lines, whatever width that takes. +The return value is a list of lines, without newlines at the end." + (let* ((words (org-split-string string "[ \t\n]+")) + (maxword (apply 'max (mapcar 'org-string-width words))) + w ll) + (cond (width + (org-do-wrap words (max maxword width))) + (lines + (setq w maxword) + (setq ll (org-do-wrap words maxword)) + (if (<= (length ll) lines) + ll + (setq ll words) + (while (> (length ll) lines) + (setq w (1+ w)) + (setq ll (org-do-wrap words w))) + ll)) + (t (error "Cannot wrap this"))))) -(defun org-clock-sum (&optional tstart tend) - "Sum the times for each subtree. -Puts the resulting times in minutes as a text property on each headline." - (interactive) - (let* ((bmp (buffer-modified-p)) - (re (concat "^\\(\\*+\\)[ \t]\\|^[ \t]*" - org-clock-string - "[ \t]*\\(\\[.*?\\]\\)-+\\(\\[.*?\\]\\)")) - (lmax 30) - (ltimes (make-vector lmax 0)) - (t1 0) - (level 0) - ts te dt - time) - (remove-text-properties (point-min) (point-max) '(:org-clock-minutes t)) - (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 - (setq level (- (match-end 1) (match-beginning 1))) - (when (or (> t1 0) (> (aref ltimes level) 0)) - (loop for l from 0 to level do - (aset ltimes l (+ (aref ltimes l) t1))) - (setq t1 0 time (aref ltimes level)) - (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)))) - (setq org-clock-file-total-minutes (aref ltimes 0))) - (set-buffer-modified-p bmp))) -(defun org-clock-display (&optional total-only) - "Show subtree times in the entire buffer. -If TOTAL-ONLY is non-nil, only show the total time for the entire file -in the echo area." - (interactive) - (org-remove-clock-overlays) - (let (time h m p) - (org-clock-sum) - (unless total-only - (save-excursion - (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)) - (org-put-clock-overlay time (funcall outline-level)))) - (setq h (/ org-clock-file-total-minutes 60) - m (- org-clock-file-total-minutes (* 60 h))) - ;; Arrange to remove the overlays upon next change. - (when org-remove-highlights-with-change - (org-add-hook 'before-change-functions 'org-remove-clock-overlays - nil 'local)))) - (message "Total file time: %d:%02d (%d hours and %d minutes)" h m h m))) +(defun org-do-wrap (words width) + "Create lines of maximum width WIDTH (in characters) from word list WORDS." + (let (lines line) + (while words + (setq line (pop words)) + (while (and words (< (+ (length line) (length (car words))) width)) + (setq line (concat line " " (pop words)))) + (setq lines (push line lines))) + (nreverse lines))) -(defvar org-clock-overlays nil) -(make-variable-buffer-local 'org-clock-overlays) +(defun org-split-string (string &optional separators) + "Splits STRING into substrings at SEPARATORS. +No empty strings are returned if there are matches at the beginning +and end of string." + (let ((rexp (or separators "[ \f\t\n\r\v]+")) + (start 0) + notfirst + (list nil)) + (while (and (string-match rexp string + (if (and notfirst + (= start (match-beginning 0)) + (< start (length string))) + (1+ start) start)) + (< (match-beginning 0) (length string))) + (setq notfirst t) + (or (eq (match-beginning 0) 0) + (and (eq (match-beginning 0) (match-end 0)) + (eq (match-beginning 0) start)) + (setq list + (cons (substring string start (match-beginning 0)) + list))) + (setq start (match-end 0))) + (or (eq start (length string)) + (setq list + (cons (substring string start) + list))) + (nreverse list))) -(defun org-put-clock-overlay (time &optional level) - "Put an overlays on the current line, displaying TIME. -If LEVEL is given, prefix time with a corresponding number of stars. -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)) - (off 0) - ov tx) - (move-to-column c) - (unless (eolp) (skip-chars-backward "^ \t")) - (skip-chars-backward " \t") - (setq ov (org-make-overlay (1- (point)) (point-at-eol)) - tx (concat (buffer-substring (1- (point)) (point)) - (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) ?\ )) - '(face secondary-selection)) - "")) - (if (not (featurep 'xemacs)) - (org-overlay-put ov 'display tx) - (org-overlay-put ov 'invisible t) - (org-overlay-put ov 'end-glyph (make-glyph tx))) - (push ov org-clock-overlays))) +(defun org-table-map-tables (function) + "Apply FUNCTION to the start of all tables in the buffer." + (save-excursion + (save-restriction + (widen) + (goto-char (point-min)) + (while (re-search-forward org-table-any-line-regexp nil t) + (message "Mapping tables: %d%%" (/ (* 100.0 (point)) (buffer-size))) + (beginning-of-line 1) + (if (looking-at org-table-line-regexp) + (save-excursion (funcall function))) + (re-search-forward org-table-any-border-regexp nil 1)))) + (message "Mapping tables: done")) -(defun org-remove-clock-overlays (&optional beg end noremove) - "Remove the occur highlights from the buffer. -BEG and END are ignored. If NOREMOVE is nil, remove this function -from the `before-change-functions' in the current buffer." +(defvar org-timecnt) ; dynamically scoped parameter + +(defun org-table-sum (&optional beg end nlast) + "Sum numbers in region of current table column. +The result will be displayed in the echo area, and will be available +as kill to be inserted with \\[yank]. + +If there is an active region, it is interpreted as a rectangle and all +numbers in that rectangle will be summed. If there is no active +region and point is located in a table column, sum all numbers in that +column. + +If at least one number looks like a time HH:MM or HH:MM:SS, all other +numbers are assumed to be times as well (in decimal hours) and the +numbers are added as such. + +If NLAST is a number, only the NLAST fields will actually be summed." (interactive) - (unless org-inhibit-highlight-removal - (mapc 'org-delete-overlay org-clock-overlays) - (setq org-clock-overlays nil) - (unless noremove - (remove-hook 'before-change-functions - 'org-remove-clock-overlays 'local)))) + (save-excursion + (let (col (org-timecnt 0) diff h m s org-table-clip) + (cond + ((and beg end)) ; beg and end given explicitly + ((org-region-active-p) + (setq beg (region-beginning) end (region-end))) + (t + (setq col (org-table-current-column)) + (goto-char (org-table-begin)) + (unless (re-search-forward "^[ \t]*|[^-]" nil t) + (error "No table data")) + (org-table-goto-column col) + (setq beg (point)) + (goto-char (org-table-end)) + (unless (re-search-backward "^[ \t]*|[^-]" nil t) + (error "No table data")) + (org-table-goto-column col) + (setq end (point)))) + (let* ((items (apply 'append (org-table-copy-region beg end))) + (items1 (cond ((not nlast) items) + ((>= nlast (length items)) items) + (t (setq items (reverse items)) + (setcdr (nthcdr (1- nlast) items) nil) + (nreverse items)))) + (numbers (delq nil (mapcar 'org-table-get-number-for-summing + items1))) + (res (apply '+ numbers)) + (sres (if (= org-timecnt 0) + (format "%g" res) + (setq diff (* 3600 res) + h (floor (/ diff 3600)) diff (mod diff 3600) + m (floor (/ diff 60)) diff (mod diff 60) + s diff) + (format "%d:%02d:%02d" h m s)))) + (kill-new sres) + (if (interactive-p) + (message "%s" + (substitute-command-keys + (format "Sum of %d items: %-20s (\\[yank] will insert result into buffer)" + (length numbers) sres)))) + sres)))) -(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) - (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))) - (org-clock-out)))) +(defun org-table-get-number-for-summing (s) + (let (n) + (if (string-match "^ *|? *" s) + (setq s (replace-match "" nil nil s))) + (if (string-match " *|? *$" s) + (setq s (replace-match "" nil nil s))) + (setq n (string-to-number s)) + (cond + ((and (string-match "0" s) + (string-match "\\`[-+ \t0.edED]+\\'" s)) 0) + ((string-match "\\`[ \t]+\\'" s) nil) + ((string-match "\\`\\([0-9]+\\):\\([0-9]+\\)\\(:\\([0-9]+\\)\\)?\\'" s) + (let ((h (string-to-number (or (match-string 1 s) "0"))) + (m (string-to-number (or (match-string 2 s) "0"))) + (s (string-to-number (or (match-string 4 s) "0")))) + (if (boundp 'org-timecnt) (setq org-timecnt (1+ org-timecnt))) + (* 1.0 (+ h (/ m 60.0) (/ s 3600.0))))) + ((equal n 0) nil) + (t n)))) -(add-hook 'org-after-todo-state-change-hook - 'org-clock-out-if-current) +(defun org-table-current-field-formula () + "Return the formula active for the current field. +Assumes that specials are in place." + (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)) + (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))))) -(defun org-check-running-clock () - "Check if the current buffer contains the running clock. -If yes, offer to stop it and to save the buffer with the changes." - (when (and (equal (marker-buffer org-clock-marker) (current-buffer)) - (y-or-n-p (format "Clock-out in buffer %s before killing it? " - (buffer-name)))) - (org-clock-out) - (when (y-or-n-p "Save changed buffer?") - (save-buffer)))) +(defun org-table-get-formula (&optional equation named) + "Read a formula from the minibuffer, offer stored formula as default. +When NAMED is non-nil, look for a named equation." + (let* ((stored-list (org-table-get-stored-formulas)) + (name (car (rassoc (list (org-current-line) + (org-table-current-column)) + org-table-named-field-locations))) + (ref (format "@%d$%d" (org-table-current-dline) + (org-table-current-column))) + (refass (assoc ref stored-list)) + (scol (if named + (if name name ref) + (int-to-string (org-table-current-column)))) + (dummy (and (or name refass) (not named) + (not (y-or-n-p "Replace field formula with column formula? " )) + (error "Abort"))) + (name (or name ref)) + (org-table-may-need-update nil) + (stored (cdr (assoc scol stored-list))) + (eq (cond + ((and stored equation (string-match "^ *=? *$" equation)) + stored) + ((stringp equation) + equation) + (t (read-string + (format "%s formula $%s=" (if named "Field" "Column") scol) + (or stored "") 'org-table-formula-history + ;stored + )))) + mustsave) + (when (not (string-match "\\S-" eq)) + ;; remove formula + (setq stored-list (delq (assoc scol stored-list) stored-list)) + (org-table-store-formulas stored-list) + (error "Formula removed")) + (if (string-match "^ *=?" eq) (setq eq (replace-match "" t t eq))) + (if (string-match " *$" eq) (setq eq (replace-match "" t t eq))) + (if (and name (not named)) + ;; We set the column equation, delete the named one. + (setq stored-list (delq (assoc name stored-list) stored-list) + mustsave t)) + (if stored + (setcdr (assoc scol stored-list) eq) + (setq stored-list (cons (cons scol eq) stored-list))) + (if (or mustsave (not (equal stored eq))) + (org-table-store-formulas stored-list)) + eq)) -(defun org-clock-report () - "Create a table containing a report about clocked time. -If the buffer contains lines -#+BEGIN: clocktable :maxlevel 3 :emphasize nil +(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))))) + (save-excursion + (goto-char (org-table-end)) + (if (looking-at "\\([ \t]*\n\\)*#\\+TBLFM:\\(.*\n?\\)") + (progn + ;; don't overwrite TBLFM, we might use text properties to store stuff + (goto-char (match-beginning 2)) + (delete-region (match-beginning 2) (match-end 0))) + (insert "#+TBLFM:")) + (insert " " + (mapconcat (lambda (x) + (concat + (if (equal (string-to-char (car x)) ?@) "" "$") + (car x) "=" (cdr x))) + alist "::") + "\n"))) -#+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." +(defun org-table-get-stored-formulas () + "Return an alist with the stored formulas directly after current table." (interactive) - (org-remove-clock-overlays) - (unless (org-find-dblock "clocktable") - (org-create-dblock (list :name "clocktable" - :maxlevel 2 :emphasize nil))) - (org-update-dblock)) + (let (scol eq eq-alist strings string seen) + (save-excursion + (goto-char (org-table-end)) + (when (looking-at "\\([ \t]*\n\\)*#\\+TBLFM: *\\(.*\\)") + (setq strings (org-split-string (match-string 2) " *:: *")) + (while (setq string (pop strings)) + (when (string-match "\\(@[0-9]+\\$[0-9]+\\|\\$\\([a-zA-Z0-9]+\\)\\) *= *\\(.*[^ \t]\\)" string) + (setq scol (if (match-end 2) + (match-string 2 string) + (match-string 1 string)) + 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) + (push scol seen)))))) + (nreverse eq-alist))) -(defun org-clock-update-time-maybe () - "If this is a CLOCK line, update it and return t. -Otherwise, return nil." - (interactive) +(defun org-table-fix-formulas (key replace &optional limit delta remove) + "Modify the equations after the table structure has been edited. +KEY is \"@\" or \"$\". REPLACE is an alist of numbers to replace. +For all numbers larger than LIMIT, shift them by DELTA." (save-excursion - (beginning-of-line 1) - (skip-chars-forward " \t") - (when (looking-at org-clock-string) - (let ((re (concat "[ \t]*" org-clock-string - " *[[<]\\([^]>]+\\)[]>]-+[[<]\\([^]>]+\\)[]>]" - "\\([ \t]*=>.*\\)?")) - ts te h m s) - (if (not (looking-at re)) - nil - (and (match-end 3) (delete-region (match-beginning 3) (match-end 3))) - (end-of-line 1) - (setq ts (match-string 1) - te (match-string 2)) - (setq s (- (time-to-seconds - (apply 'encode-time (org-parse-time-string te))) - (time-to-seconds - (apply 'encode-time (org-parse-time-string ts)))) - h (floor (/ s 3600)) - s (- s (* 3600 h)) - m (floor (/ s 60)) - s (- s (* 60 s))) - (insert " => " (format "%2d:%02d" h m)) - t))))) + (goto-char (org-table-end)) + (when (looking-at "#\\+TBLFM:") + (let ((re (concat key "\\([0-9]+\\)")) + (re2 + (when remove + (if (equal key "$") + (format "\\(@[0-9]+\\)?\\$%d=.*?\\(::\\|$\\)" remove) + (format "@%d\\$[0-9]+=.*?\\(::\\|$\\)" remove)))) + s n a) + (when remove + (while (re-search-forward re2 (point-at-eol) t) + (replace-match ""))) + (while (re-search-forward re (point-at-eol) t) + (setq s (match-string 1) n (string-to-number s)) + (cond + ((setq a (assoc s replace)) + (replace-match (concat key (cdr a)) t t)) + ((and limit (> n limit)) + (replace-match (concat key (int-to-string (+ n delta))) t t)))))))) -(defun org-clock-special-range (key &optional time as-strings) - "Return two times bordering a special time range. -Key is a symbol specifying the range and can be one of `today', `yesterday', -`thisweek', `lastweek', `thismonth', `lastmonth', `thisyear', `lastyear'. -A week starts Monday 0:00 and ends Sunday 24:00. -The range is determined relative to TIME. TIME defaults to the current time. -The return value is a cons cell with two internal times like the ones -returned by `current time' or `encode-time'. if AS-STRINGS is non-nil, -the returned times will be formatted strings." - (let* ((tm (decode-time (or time (current-time)))) - (s 0) (m (nth 1 tm)) (h (nth 2 tm)) - (d (nth 3 tm)) (month (nth 4 tm)) (y (nth 5 tm)) - (dow (nth 6 tm)) - s1 m1 h1 d1 month1 y1 diff ts te fm) - (cond - ((eq key 'today) - (setq h 0 m 0 h1 24 m1 0)) - ((eq key 'yesterday) - (setq d (1- d) h 0 m 0 h1 24 m1 0)) - ((eq key 'thisweek) - (setq diff (if (= dow 0) 6 (1- dow)) - m 0 h 0 d (- d diff) d1 (+ 7 d))) - ((eq key 'lastweek) - (setq diff (+ 7 (if (= dow 0) 6 (1- dow))) - m 0 h 0 d (- d diff) d1 (+ 7 d))) - ((eq key 'thismonth) - (setq d 1 h 0 m 0 d1 1 month1 (1+ month) h1 0 m1 0)) - ((eq key 'lastmonth) - (setq d 1 h 0 m 0 d1 1 month (1- month) month1 (1+ month) h1 0 m1 0)) - ((eq key 'thisyear) - (setq m 0 h 0 d 1 month 1 y1 (1+ y))) - ((eq key 'lastyear) - (setq m 0 h 0 d 1 month 1 y (1- y) y1 (1+ y))) - (t (error "No such time block %s" key))) - (setq ts (encode-time s m h d month y) - te (encode-time (or s1 s) (or m1 m) (or h1 h) - (or d1 d) (or month1 month) (or y1 y))) - (setq fm (cdr org-time-stamp-formats)) - (if as-strings - (cons (format-time-string fm ts) (format-time-string fm te)) - (cons ts te)))) - -(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)) - (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)) - ;; FIXME: does not yet use org-insert-time-stamp - (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)) +(defun org-table-get-specials () + "Get the column names and local parameters for this table." + (save-excursion + (let ((beg (org-table-begin)) (end (org-table-end)) + names name fields fields1 field cnt + c v l line col types dlines hlines) + (setq org-table-column-names nil + org-table-local-parameters nil + org-table-named-field-locations nil + org-table-current-begin-line nil + org-table-current-line-types nil) + (goto-char beg) + (when (re-search-forward "^[ \t]*| *! *\\(|.*\\)" end t) + (setq names (org-split-string (match-string 1) " *| *") + cnt 1) + (while (setq name (pop names)) + (setq cnt (1+ cnt)) + (if (string-match "^[a-zA-Z][a-zA-Z0-9]*$" name) + (push (cons name (int-to-string cnt)) org-table-column-names)))) + (setq org-table-column-names (nreverse org-table-column-names)) + (setq org-table-column-name-regexp + (concat "\\$\\(" (mapconcat 'car org-table-column-names "\\|") "\\)\\>")) + (goto-char beg) + (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) + (push (cons (match-string 1 field) (match-string 2 field)) + org-table-local-parameters)))) + (goto-char beg) + (while (re-search-forward "^[ \t]*| *\\([_^]\\) *\\(|.*\\)" end t) + (setq c (match-string 1) + fields (org-split-string (match-string 2) " *| *")) (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))) - -(defun org-collect-clock-time-entries () - "Return an internal list with clocking information. -This list has one entry for each CLOCK interval. -FIXME: describe the elements." - (interactive) - (let ((re (concat "^[ \t]*" org-clock-string - " *\\[\\(.*?\\)\\]--\\[\\(.*?\\)\\]")) - rtn beg end next cont level title total closedp leafp - clockpos titlepos h m donep) - (save-excursion - (org-clock-sum) - (goto-char (point-min)) - (while (re-search-forward re nil t) - (setq clockpos (match-beginning 0) - beg (match-string 1) end (match-string 2) - cont (match-end 0)) - (setq beg (apply 'encode-time (org-parse-time-string beg)) - end (apply 'encode-time (org-parse-time-string end))) - (org-back-to-heading t) - (setq donep (org-entry-is-done-p)) - (setq titlepos (point) - total (or (get-text-property (1+ (point)) :org-clock-minutes) 0) - h (/ total 60) m (- total (* 60 h)) - total (cons h m)) - (looking-at "\\(\\*+\\) +\\(.*\\)") - (setq level (- (match-end 1) (match-beginning 1)) - title (org-match-string-no-properties 2)) - (save-excursion (outline-next-heading) (setq next (point))) - (setq closedp (re-search-forward org-closed-time-regexp next t)) - (goto-char next) - (setq leafp (and (looking-at "^\\*+ ") - (<= (- (match-end 0) (point)) level))) - (push (list beg end clockpos closedp donep - total title titlepos level leafp) - rtn) - (goto-char cont))) - (nreverse rtn))) - -;;; Agenda, and Diary Integration - -;;; Define the mode + (beginning-of-line (if (equal c "_") 2 0)) + (setq line (org-current-line) col 1) + (and (looking-at "^[ \t]*|[^|]*\\(|.*\\)") + (setq fields1 (org-split-string (match-string 1) " *| *")))) + (while (and fields1 (setq field (pop fields))) + (setq v (pop fields1) col (1+ col)) + (when (and (stringp field) (stringp v) + (string-match "^[a-zA-Z][a-zA-Z0-9]*$" field)) + (push (cons field v) org-table-local-parameters) + (push (list field line col) org-table-named-field-locations)))) + ;; Analyse the line types + (goto-char beg) + (setq org-table-current-begin-line (org-current-line) + l org-table-current-begin-line) + (while (looking-at "[ \t]*|\\(-\\)?") + (push (if (match-end 1) 'hline 'dline) types) + (if (match-end 1) (push l hlines) (push l dlines)) + (beginning-of-line 2) + (setq l (1+ l))) + (setq org-table-current-line-types (apply 'vector (nreverse types)) + org-table-dlines (apply 'vector (cons nil (nreverse dlines))) + org-table-hlines (apply 'vector (cons nil (nreverse hlines))))))) -(defvar org-agenda-mode-map (make-sparse-keymap) - "Keymap for `org-agenda-mode'.") +(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)))) -(defvar org-agenda-menu) ; defined later in this file. -(defvar org-agenda-follow-mode nil) -(defvar org-agenda-show-log nil) -(defvar org-agenda-redo-command nil) -(defvar org-agenda-mode-hook nil) -(defvar org-agenda-type nil) -(defvar org-agenda-force-single-file nil) +(defun org-table-maybe-eval-formula () + "Check if the current field starts with \"=\" or \":=\". +If yes, store the formula and apply it." + ;; We already know we are in a table. Get field will only return a formula + ;; when appropriate. It might return a separator line, but no problem. + (when org-table-formula-evaluate-inline + (let* ((field (org-trim (or (org-table-get-field) ""))) + named eq) + (when (string-match "^:?=\\(.*\\)" field) + (setq named (equal (string-to-char field) ?:) + 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) + (error "Calc does not seem to be installed, and is needed to evaluate the formula")))))) -(defun org-agenda-mode () - "Mode for time-sorted view on action items in Org-mode files. +(defvar org-recalc-commands nil + "List of commands triggering the recalculation of a line. +Will be filled automatically during use.") -The following commands are available: +(defvar org-recalc-marks + '((" " . "Unmarked: no special line, no automatic recalculation") + ("#" . "Automatically recalculate this line upon TAB, RET, and C-c C-c in the line") + ("*" . "Recalculate only when entire table is recalculated with `C-u C-c *'") + ("!" . "Column name definition line. Reference in formula as $name.") + ("$" . "Parameter definition line name=value. Reference in formula as $name.") + ("_" . "Names for values in row below this one.") + ("^" . "Names for values in row above this one."))) -\\{org-agenda-mode-map}" +(defun org-table-rotate-recalc-marks (&optional newchar) + "Rotate the recalculation mark in the first column. +If in any row, the first field is not consistent with a mark, +insert a new column for the markers. +When there is an active region, change all the lines in the region, +after prompting for the marking character. +After each change, a message will be displayed indicating the meaning +of the new mark." (interactive) - (kill-all-local-variables) - (setq major-mode 'org-agenda-mode) - (setq mode-name "Org-Agenda") - (use-local-map org-agenda-mode-map) - (easy-menu-add org-agenda-menu) - (if org-startup-truncated (setq truncate-lines t)) - (org-add-hook 'post-command-hook 'org-agenda-post-command-hook nil 'local) - (org-add-hook 'pre-command-hook 'org-unhighlight nil 'local) - (unless org-agenda-keep-modes - (setq org-agenda-follow-mode org-agenda-start-with-follow-mode - org-agenda-show-log nil)) - (easy-menu-change - '("Agenda") "Agenda Files" - (append - (list - (vector - (if (get 'org-agenda-files 'org-restrict) - "Restricted to single file" - "Edit File List") - '(org-edit-agenda-file-list) - (not (get 'org-agenda-files 'org-restrict))) - "--") - (mapcar 'org-file-menu-entry (org-agenda-files)))) - (org-agenda-set-mode-name) - (apply - (if (fboundp 'run-mode-hooks) 'run-mode-hooks 'run-hooks) - (list 'org-agenda-mode-hook))) - -(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 " " 'org-agenda-show) -(define-key org-agenda-mode-map "\C-c\C-t" 'org-agenda-todo) -(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) + (unless (org-at-table-p) (error "Not at a table")) + (let* ((marks (append (mapcar 'car org-recalc-marks) '(" "))) + (beg (org-table-begin)) + (end (org-table-end)) + (l (org-current-line)) + (l1 (if (org-region-active-p) (org-current-line (region-beginning)))) + (l2 (if (org-region-active-p) (org-current-line (region-end)))) + (have-col + (save-excursion + (goto-char beg) + (not (re-search-forward "^[ \t]*|[^-|][^|]*[^#!$*_^| \t][^|]*|" end t)))) + (col (org-table-current-column)) + (forcenew (car (assoc newchar org-recalc-marks))) + epos new) + (when l1 + (message "Change region to what mark? Type # * ! $ or SPC: ") + (setq newchar (char-to-string (read-char-exclusive)) + forcenew (car (assoc newchar org-recalc-marks)))) + (if (and newchar (not forcenew)) + (error "Invalid NEWCHAR `%s' in `org-table-rotate-recalc-marks'" + newchar)) + (if l1 (goto-line l1)) + (save-excursion + (beginning-of-line 1) + (unless (looking-at org-table-dataline-regexp) + (error "Not at a table data line"))) + (unless have-col + (org-table-goto-column 1) + (org-table-insert-column) + (org-table-goto-column (1+ col))) + (setq epos (point-at-eol)) + (save-excursion + (beginning-of-line 1) + (org-table-get-field + 1 (if (looking-at "^[ \t]*| *\\([#!$*^_ ]\\) *|") + (concat " " + (setq new (or forcenew + (cadr (member (match-string 1) marks)))) + " ") + " # "))) + (if (and l1 l2) + (progn + (goto-line l1) + (while (progn (beginning-of-line 2) (not (= (org-current-line) l2))) + (and (looking-at org-table-dataline-regexp) + (org-table-get-field 1 (concat " " new " ")))) + (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)))))) -(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) -(let ((l '(1 2 3 4 5 6 7 8 9 0))) - (while l (define-key org-agenda-mode-map - (int-to-string (pop l)) 'digit-argument))) +(defun org-table-maybe-recalculate-line () + "Recompute the current line if marked for it, and if we haven't just done it." + (interactive) + (and org-table-allow-automatic-line-recalculation + (not (and (memq last-command org-recalc-commands) + (equal org-last-recalc-line (org-current-line)))) + (save-excursion (beginning-of-line 1) + (looking-at org-table-auto-recalculate-regexp)) + (org-table-recalculate) t)) -(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) -(eval-after-load "calendar" - '(define-key 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-clock-out) -(define-key org-agenda-mode-map "X" 'org-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) -(defvar org-agenda-keymap (copy-keymap org-agenda-mode-map) - "Local keymap for agenda entries from Org-mode.") +(defvar org-table-formula-debug nil + "Non-nil means, debug table formulas. +When nil, simply write \"#ERROR\" in corrupted fields.") +(make-variable-buffer-local 'org-table-formula-debug) -(define-key org-agenda-keymap - (if (featurep 'xemacs) [(button2)] [(mouse-2)]) 'org-agenda-goto-mouse) -(define-key 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)) -(easy-menu-define org-agenda-menu org-agenda-mode-map "Agenda menu" - '("Agenda" - ("Agenda Files") - "--" - ["Show" org-agenda-show t] - ["Go To (other window)" org-agenda-goto t] - ["Go To (this window)" org-agenda-switch-to t] - ["Follow Mode" org-agenda-follow-mode - :style toggle :selected org-agenda-follow-mode :active t] - "--" - ["Cycle TODO" org-agenda-todo t] - ("Tags" - ["Show all Tags" org-agenda-show-tags t] - ["Set Tags" org-agenda-set-tags t]) - ("Schedule" - ["Schedule" org-agenda-schedule t] - ["Set Deadline" org-agenda-deadline t] - "--" - ["Reschedule +1 day" org-agenda-date-later (org-agenda-check-type nil 'agenda 'timeline)] - ["Reschedule -1 day" org-agenda-date-earlier (org-agenda-check-type nil 'agenda 'timeline)] - ["Reschedule to ..." org-agenda-date-prompt (org-agenda-check-type nil 'agenda 'timeline)]) - ("Priority" - ["Set Priority" org-agenda-priority t] - ["Increase Priority" org-agenda-priority-up t] - ["Decrease Priority" org-agenda-priority-down t] - ["Show Priority" org-agenda-show-priority t]) - "--" - ;; ["New agenda command" org-agenda t] - ["Rebuild buffer" org-agenda-redo t] - ["Save all Org-mode Buffers" org-save-all-org-buffers t] - "--" - ["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)] - "--" - ["Day View" org-agenda-day-view :active (org-agenda-check-type nil 'agenda) - :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)] - "--" - ["Show Logbook entries" org-agenda-log-mode - :style toggle :selected org-agenda-show-log :active (org-agenda-check-type nil 'agenda 'timeline)] - ["Include Diary" org-agenda-toggle-diary - :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)] - "--" - ["New Diary Entry" org-agenda-diary-entry (org-agenda-check-type nil 'agenda 'timeline)] - ("Calendar Commands" - ["Goto Calendar" org-agenda-goto-calendar (org-agenda-check-type nil 'agenda 'timeline)] - ["Phases of the Moon" org-agenda-phases-of-moon (org-agenda-check-type nil 'agenda 'timeline)] - ["Sunrise/Sunset" org-agenda-sunrise-sunset (org-agenda-check-type nil 'agenda 'timeline)] - ["Holidays" org-agenda-holidays (org-agenda-check-type nil 'agenda 'timeline)] - ["Convert" org-agenda-convert-date (org-agenda-check-type nil 'agenda 'timeline)]) - ["Create iCalendar file" org-export-icalendar-combine-agenda-files t] - "--" - ["Quit" org-agenda-quit t] - ["Exit and Release Buffers" org-agenda-exit t] - )) +(defvar modes) +(defsubst org-set-calc-mode (var &optional value) + (if (stringp var) + (setq var (assoc var '(("D" calc-angle-mode deg) + ("R" calc-angle-mode rad) + ("F" calc-prefer-frac t) + ("S" calc-symbolic-mode t))) + value (nth 2 var) var (nth 1 var))) + (if (memq var modes) + (setcar (cdr (memq var modes)) value) + (cons var (cons value modes))) + modes) -(defvar org-agenda-restrict nil) -(defvar org-agenda-restrict-begin (make-marker)) -(defvar org-agenda-restrict-end (make-marker)) -(defvar org-agenda-last-dispatch-buffer nil) +(defun org-table-eval-formula (&optional arg equation + suppress-align suppress-const + suppress-store suppress-analysis) + "Replace the table field value at the cursor by the result of a calculation. -;;;###autoload -(defun org-agenda (arg) - "Dispatch agenda commands to collect entries to the agenda buffer. -Prompts for a character to select a command. 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 - entries with a specific TODO keyword (the user gets a prompt). -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. +This function makes use of Dave Gillespie's Calc package, in my view the +most exciting program ever written for GNU Emacs. So you need to have Calc +installed in order to use this function. -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. +In a table, this command replaces the value in the current field with the +result of a formula. It also installs the formula as the \"current\" column +formula, by storing it in a special line below the table. When called +with a `C-u' prefix, the current field must ba a named field, and the +formula is installed as valid in only this specific field. -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." - (interactive "P") - (catch 'exit - (let* ((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) - ;; 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 - "Press key for an agenda command: --------------------------------- -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 C Configure custom agenda commands") - (while (setq entry (pop custom)) - (setq key (car entry) type (nth 1 entry) match (nth 2 entry)) - (insert (format "\n%-4s%-14s: %s" - key - (cond - ((stringp type) type) - ((eq type 'tags) "Tags query") - ((eq type 'todo) "TODO keyword") - ((eq type 'tags-tree) "Tags tree") - ((eq type 'todo-tree) "TODO kwd tree") - ((eq type 'occur-tree) "Occur tree") - (t "???")) - (if (stringp match) - (org-add-props match nil 'face 'org-warning) - (format "set of %d commands" (+ -2 (length entry))))))) - (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))) +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] +to check the referenced fields. - (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) - (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 ""))) - (require 'calendar) ; FIXME: can we avoid this for some commands? - ;; For example the todo list should not need it (but does...) - (cond - ((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 - (error "This is not an Org-mode file")) - (org-call-with-arg 'org-timeline arg)) - ((setq entry (assoc (char-to-string c) org-agenda-custom-commands)) - (if (symbolp (nth 1 entry)) - (progn - (setq type (nth 1 entry) match (nth 2 entry) lprops (nth 3 entry) - lprops (nth 3 entry)) - (cond - ((eq type 'tags) - (org-let lprops '(org-tags-view current-prefix-arg match))) - ((eq type 'tags-todo) - (org-let lprops '(org-tags-view '(4) match))) - ((eq type 'todo) - (org-let lprops '(org-todo-list match))) - ((eq type 'tags-tree) - (org-check-for-org-mode) - (org-let lprops '(org-tags-sparse-tree current-prefix-arg match))) - ((eq type 'todo-tree) - (org-check-for-org-mode) - (org-let lprops - '(org-occur (concat "^" outline-regexp "[ \t]*" - (regexp-quote match) "\\>")))) - ((eq type 'occur-tree) - (org-check-for-org-mode) - (org-let lprops '(org-occur match))) - (t (error "Invalid custom agenda command type %s" type)))) - (org-run-agenda-series (cddr entry)))) - (t (error "Invalid key")))))) +When called, the command first prompts for a formula, which is read in +the minibuffer. Previously entered formulas are available through the +history list, and the last used formula is offered as a default. +These stored formulas are adapted correctly when moving, inserting, or +deleting columns with the corresponding commands. -;; FIXME: what is the meaning of WINDOW????? -(defun org-run-agenda-series (series &optional window) - (org-prepare-agenda) - (let* ((org-agenda-multi t) - (redo (list 'org-run-agenda-series (list 'quote series))) - (org-select-agenda-window t) - (cmds (car series)) - (gprops (nth 1 series)) - match ;; The byte compiler incorrectly complains about this. Keep it! - cmd type lprops) - (while (setq cmd (pop cmds)) - (setq type (car cmd) match (nth 1 cmd) lprops (nth 2 cmd)) - (cond - ((eq type 'agenda) - (call-interactively 'org-agenda-list)) - ((eq type 'alltodo) - (call-interactively 'org-todo-list)) - ((eq type 'tags) - (org-let2 gprops lprops - '(org-tags-view current-prefix-arg match))) - ((eq type 'tags-todo) - (org-let2 gprops lprops - '(org-tags-view '(4) match))) - ((eq type 'todo) - (org-let2 gprops lprops - '(org-todo-list match))) - (t (error "Invalid type in command series")))) - (widen) - (setq org-agenda-redo-command redo) - (goto-char (point-min))) - (org-finalize-agenda)) +The formula can be any algebraic expression understood by the Calc package. +For details, see the Org-mode manual. -;;;###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'. -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)))) +This function can also be called from Lisp programs and offers +additional arguments: EQUATION can be the formula to apply. If this +argument is given, the user will not be prompted. SUPPRESS-ALIGN is +used to speed-up recursive calls by by-passing unnecessary aligns. +SUPPRESS-CONST suppresses the interpretation of constants in the +formula, assuming that this has been done already outside the function. +SUPPRESS-STORE means the formula should not be stored, either because +it is already stored, or because it is a modified equation that should +not overwrite the stored one." + (interactive "P") + (org-table-check-inside-data-field) + (or suppress-analysis (org-table-get-specials)) + (if (equal arg '(16)) + (let ((eq (org-table-current-field-formula))) + (or eq (error "No equation active for current field")) + (org-table-get-field nil eq) + (org-table-align) + (setq org-table-may-need-update t)) + (let* (fields + (ndown (if (integerp arg) arg 1)) + (org-table-automatic-realign nil) + (case-fold-search nil) + (down (> ndown 1)) + (formula (if (and equation suppress-store) + equation + (org-table-get-formula equation (equal arg '(4))))) + (n0 (org-table-current-column)) + (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) + ;; 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) + (let ((tmp (org-split-string formula ";"))) + (setq formula (car tmp) + fmt (concat (cdr (assoc "%" org-table-local-parameters)) + (nth 1 tmp))) + (while (string-match "\\([pnfse]\\)\\(-?[0-9]+\\)" fmt) + (setq c (string-to-char (match-string 1 fmt)) + n (string-to-number (match-string 2 fmt))) + (if (= c ?p) + (setq modes (org-set-calc-mode 'calc-internal-prec n)) + (setq modes (org-set-calc-mode + 'calc-float-format + (list (cdr (assoc c '((?n . float) (?f . fix) + (?s . sci) (?e . eng)))) + n)))) + (setq fmt (replace-match "" t t fmt))) + (if (string-match "[NT]" fmt) + (setq numbers (equal (match-string 0 fmt) "N") + fmt (replace-match "" t t fmt))) + (if (string-match "E" fmt) + (setq keep-empty t + fmt (replace-match "" t t fmt))) + (while (string-match "[DRFS]" fmt) + (setq modes (org-set-calc-mode (match-string 0 fmt))) + (setq fmt (replace-match "" t t fmt))) + (unless (string-match "\\S-" fmt) + (setq fmt nil)))) + (if (and (not suppress-const) org-table-formula-use-constants) + (setq formula (org-table-formula-substitute-names formula))) + (setq orig (or (get-text-property 1 :orig-formula formula) "?")) + (while (> ndown 0) + (setq fields (org-split-string + (org-no-properties + (buffer-substring (point-at-bol) (point-at-eol))) + " *| *")) + (if numbers + (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) "'("))) + ;; Check for old vertical references + (setq form (org-rewrite-old-row-references form)) + ;; Insert complex ranges + (while (string-match org-table-range-regexp form) + (setq form + (replace-match + (save-match-data + (org-table-make-reference + (org-table-get-range (match-string 0 form) nil n0) + keep-empty numbers lispp)) + t t form))) + ;; Insert simple ranges + (while (string-match "\\$\\([0-9]+\\)\\.\\.\\$\\([0-9]+\\)" form) + (setq form + (replace-match + (save-match-data + (org-table-make-reference + (org-sublist + fields (string-to-number (match-string 1 form)) + (string-to-number (match-string 2 form))) + keep-empty numbers lispp)) + 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)) + (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))) + (error "#ERROR")) + ev (if (numberp ev) (number-to-string ev) ev)) + (or (fboundp 'calc-eval) + (error "Calc does not seem to be installed, and is needed to evaluate the formula")) + (setq ev (calc-eval (cons form modes) + (if numbers 'num)))) + + (when org-table-formula-debug + (with-output-to-temp-buffer "*Substitution History*" + (princ (format "Substitution history of formula +Orig: %s +$xyz-> %s +@r$c-> %s +$1-> %s\n" orig formula form0 form)) + (if (listp ev) + (princ (format " %s^\nError: %s" + (make-string (car ev) ?\-) (nth 1 ev))) + (princ (format "Result: %s\nFormat: %s\nFinal: %s" + ev (or fmt "NONE") + (if fmt (format fmt (string-to-number ev)) ev))))) + (setq bw (get-buffer-window "*Substitution History*")) + (shrink-window-if-larger-than-buffer bw) + (unless (and (interactive-p) (not ndown)) + (unless (let (inhibit-redisplay) + (y-or-n-p "Debugging Formula. Continue to next? ")) + (org-table-align) + (error "Abort")) + (delete-window bw) + (message ""))) + (if (listp ev) (setq fmt nil ev "#ERROR")) + (org-table-justify-field-maybe + (if fmt (format fmt (string-to-number ev)) ev)) + (if (and down (> ndown 0) (looking-at ".*\n[ \t]*|[^-]")) + (call-interactively 'org-return) + (setq ndown 0))) + (and down (org-table-maybe-recalculate-line)) + (or suppress-align (and org-table-may-need-update + (org-table-align)))))) + +(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 +the current column, to avoid unnecessary parsing. +HIGHLIGHT means, just highlight the range." + (if (not (equal (string-to-char desc) ?@)) + (setq desc (concat "@" desc))) + (save-excursion + (or tbeg (setq tbeg (org-table-begin))) + (or col (setq col (org-table-current-column))) + (let ((thisline (org-current-line)) + beg end c1 c2 r1 r2 rangep tmp) + (unless (string-match org-table-range-regexp desc) + (error "Invalid table range specifier `%s'" desc)) + (setq rangep (match-end 3) + r1 (and (match-end 1) (match-string 1 desc)) + r2 (and (match-end 4) (match-string 4 desc)) + c1 (and (match-end 2) (substring (match-string 2 desc) 1)) + c2 (and (match-end 5) (substring (match-string 5 desc) 1))) + + (and c1 (setq c1 (+ (string-to-number c1) + (if (memq (string-to-char c1) '(?- ?+)) col 0)))) + (and c2 (setq c2 (+ (string-to-number c2) + (if (memq (string-to-char c2) '(?- ?+)) col 0)))) + (if (equal r1 "") (setq r1 nil)) + (if (equal r2 "") (setq r2 nil)) + (if r1 (setq r1 (org-table-get-descriptor-line r1))) + (if r2 (setq r2 (org-table-get-descriptor-line r2))) +; (setq r2 (or r2 r1) c2 (or c2 c1)) + (if (not r1) (setq r1 thisline)) + (if (not r2) (setq r2 thisline)) + (if (not c1) (setq c1 col)) + (if (not c2) (setq c2 col)) + (if (or (not rangep) (and (= r1 r2) (= c1 c2))) + ;; just one field + (progn + (goto-line r1) + (while (not (looking-at org-table-dataline-regexp)) + (beginning-of-line 2)) + (prog1 (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 + (if (< r2 r1) (setq tmp r1 r1 r2 r2 tmp)) + (if (< c2 c1) (setq tmp c1 c1 c2 c2 tmp)) + (goto-line r1) + (while (not (looking-at org-table-dataline-regexp)) + (beginning-of-line 2)) + (org-table-goto-column c1) + (setq beg (point)) + (goto-line r2) + (while (not (looking-at org-table-dataline-regexp)) + (beginning-of-line 0)) + (org-table-goto-column c2) + (setq end (point)) + (if highlight + (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)))))) + +(defun org-table-get-descriptor-line (desc &optional cline bline table) + "Analyze descriptor DESC and retrieve the corresponding line number. +The cursor is currently in line CLINE, the table begins in line BLINE, +and TABLE is a vector with line types." + (if (string-match "^[0-9]+$" desc) + (aref org-table-dlines (string-to-number desc)) + (setq cline (or cline (org-current-line)) + bline (or bline org-table-current-begin-line) + table (or table org-table-current-line-types)) + (if (or + (not (string-match "^\\(\\([-+]\\)?\\(I+\\)\\)?\\(\\([-+]\\)?\\([0-9]+\\)\\)?" desc)) + ;; 1 2 3 4 5 6 + (and (not (match-end 3)) (not (match-end 6))) + (and (match-end 3) (match-end 6) (not (match-end 5)))) + (error "invalid row descriptor `%s'" desc)) + (let* ((hdir (and (match-end 2) (match-string 2 desc))) + (hn (if (match-end 3) (- (match-end 3) (match-beginning 3)) nil)) + (odir (and (match-end 5) (match-string 5 desc))) + (on (if (match-end 6) (string-to-number (match-string 6 desc)))) + (i (- cline bline)) + (rel (and (match-end 6) + (or (and (match-end 1) (not (match-end 3))) + (match-end 5))))) + (if (and hn (not hdir)) + (progn + (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 + (if (and hn (> hn 0)) + (setq i (org-find-row-type table i 'hline (equal hdir "-") nil hn))) + (if on + (setq i (org-find-row-type table i 'dline (equal odir "-") rel on))) + (+ bline i))))) + +(defun org-find-row-type (table i type backwards relative n) + (let ((l (length table))) + (while (> n 0) + (while (and (setq i (+ i (if backwards -1 1))) + (>= i 0) (< i l) + (not (eq (aref table i) type)) + (if (and relative (eq (aref table i) 'hline)) + (progn (setq i (- i (if backwards -1 1)) n 1) nil) + t))) + (setq n (1- n))) + (if (or (< i 0) (>= i l)) + (error "Row descriptior leads outside table") + i))) + +(defun org-rewrite-old-row-references (s) + (if (string-match "&[-+0-9I]" s) + (error "Formula contains old &row reference, please rewrite using @-syntax") + s)) -(defmacro org-no-read-only (&rest body) - "Inhibit read-only for BODY." - `(let ((inhibit-read-only t)) ,@body)) +(defun org-table-make-reference (elements keep-empty numbers lispp) + "Convert list ELEMENTS to something appropriate to insert into formula. +KEEP-EMPTY indicated to keep empty fields, default is to skip them. +NUMBERS indicates that everything should be converted to numbers. +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 (equal elements "") (setq elements "0")) + (if numbers (number-to-string (string-to-number elements)) elements)) + (unless keep-empty + (setq elements + (delq nil + (mapcar (lambda (x) (if (string-match "\\S-" x) x nil)) + elements)))) + (setq elements (or elements '("0"))) + (if lispp + (mapconcat 'prin1-to-string + (if numbers (mapcar 'string-to-number elements) elements) + " ") + (concat "[" (mapconcat + (lambda (x) + (if numbers (number-to-string (string-to-number x)) x)) + elements + ",") "]")))) -(defun org-check-for-org-mode () - "Make sure current buffer is in org-mode. Error if not." - (or (org-mode-p) - (error "Cannot execute org-mode agenda command on buffer in %s." - major-mode))) +(defun org-table-recalculate (&optional all noalign) + "Recalculate the current table line by applying all stored formulas. +With prefix arg ALL, do this for all lines in the table." + (interactive "P") + (or (memq this-command org-recalc-commands) + (setq org-recalc-commands (cons this-command org-recalc-commands))) + (unless (org-at-table-p) (error "Not at a table")) + (if (equal all '(16)) + (org-table-iterate) + (org-table-get-specials) + (let* ((eqlist (sort (org-table-get-stored-formulas) + (lambda (a b) (string< (car a) (car b))))) + (inhibit-redisplay (not debug-on-error)) + (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) + ;; Insert constants in all formulas + (setq eqlist + (mapcar (lambda (x) + (setcdr x (org-table-formula-substitute-names (cdr x))) + x) + eqlist)) + ;; Split the equation list + (while (setq eq (pop eqlist)) + (if (<= (string-to-char (car eq)) ?9) + (push eq eqlnum) + (push eq eqlname))) + (setq eqlnum (nreverse eqlnum) eqlname (nreverse eqlname)) + (if all + (progn + (setq end (move-marker (make-marker) (1+ (org-table-end)))) + (goto-char (setq beg (org-table-begin))) + (if (re-search-forward org-table-calculate-mark-regexp end t) + ;; This is a table with marked lines, compute selected lines + (setq line-re org-table-recalculate-regexp) + ;; Move forward to the first non-header line + (if (and (re-search-forward org-table-dataline-regexp end t) + (re-search-forward org-table-hline-regexp end t) + (re-search-forward org-table-dataline-regexp end t)) + (setq beg (match-beginning 0)) + nil))) ;; just leave beg where it is + (setq beg (point-at-bol) + end (move-marker (make-marker) (1+ (point-at-eol))))) + (goto-char beg) + (and all (message "Re-applying formulas to full table...")) + (while (re-search-forward line-re end t) + (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)))) + (setq org-last-recalc-line (org-current-line)) + (setq eql eqlnum) + (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)))) + (goto-line thisline) + (org-table-goto-column thiscol) + (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) + (org-table-goto-column thiscol) + (or noalign (and org-table-may-need-update (org-table-align)) + (and all (message "Re-applying formulas...done")))))) + +(defun org-table-iterate (&optional arg) + "Recalculate the table until it does not change anymore." + (interactive "P") + (let ((imax (if arg (prefix-numeric-value arg) 10)) + (i 0) + (lasttbl (buffer-substring (org-table-begin) (org-table-end))) + thistbl) + (catch 'exit + (while (< i imax) + (setq i (1+ i)) + (org-table-recalculate 'all) + (setq thistbl (buffer-substring (org-table-begin) (org-table-end))) + (if (not (string= lasttbl thistbl)) + (setq lasttbl thistbl) + (if (> i 1) + (message "Convergence after %d iterations" i) + (message "Table was already stable")) + (throw 'exit t))) + (error "No convergence after %d iterations" i)))) -(defun org-fit-agenda-window () - "Fit the window to the buffer size." - (and org-fit-agenda-window - (memq org-agenda-window-setup '(reorganize-frame)) - (fboundp 'fit-window-to-buffer) - (fit-window-to-buffer nil (/ (* (frame-height) 3) 4) - (/ (frame-height) 2)))) +(defun org-table-formula-substitute-names (f) + "Replace $const with values in string F." + (let ((start 0) a (f1 f)) + ;; First, check for column names + (while (setq start (string-match org-table-column-name-regexp f start)) + (setq start (1+ start)) + (setq a (assoc (match-string 1 f) org-table-column-names)) + (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)) + (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)))) + (if org-table-formula-debug + (put-text-property 0 (length f) :orig-formula f1 f)) + f)) -(defun org-agenda-files (&optional unrestricted) - "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'")))) +(defun org-table-get-constant (const) + "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)) + (and (fboundp 'constants-get) (constants-get const)) + "#UNDEFINED_NAME")) -(defvar org-window-configuration) +(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) -(defun org-edit-agenda-file-list () - "Edit the list of agenda files. -Depending on setup, this either uses customize to edit the variable -`org-agenda-files', or it visits the file that is holding the list. In the -latter case, the buffer is set up in a way that saving it automatically kills -the buffer and restores the previous window configuration." - (interactive) - (if (stringp org-agenda-files) - (let ((cw (current-window-configuration))) - (find-file org-agenda-files) - (org-set-local 'org-window-configuration cw) - (org-add-hook 'after-save-hook - (lambda () - (set-window-configuration - (prog1 org-window-configuration - (kill-buffer (current-buffer)))) - (org-install-agenda-files-menu) - (message "New agenda file list installed")) - nil 'local) - (message (substitute-command-keys - "Edit list and finish with \\[save-buffer]"))) - (customize-variable 'org-agenda-files))) +(defvar org-pos) -(defun org-store-new-agenda-file-list (list) - "Set new value for the agenda file list and save it correcly." - (if (stringp org-agenda-files) - (let ((f org-agenda-files) b) - (while (setq b (find-buffer-visiting f)) (kill-buffer b)) - (with-temp-file f - (insert (mapconcat 'identity list "\n") "\n"))) - (let ((org-mode-hook nil) (default-major-mode 'fundamental-mode)) - (setq org-agenda-files list) - (customize-save-variable 'org-agenda-files org-agenda-files)))) +(defun org-table-edit-formulas () + "Edit the formulas of the current table in a separate buffer." + (interactive) + (unless (org-at-table-p) (error "Not at a table")) + (org-table-get-specials) + (let ((eql (org-table-get-stored-formulas)) + (pos (move-marker (make-marker) (point))) + (wc (current-window-configuration)) + entry s) + (switch-to-buffer-other-window "*Edit Formulas*") + (erase-buffer) + (fundamental-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") -(defun org-read-agenda-file-list () - "Read the list of agenda files from a file." - (when (stringp org-agenda-files) - (with-temp-buffer - (insert-file-contents org-agenda-files) - (org-split-string (buffer-string) "[ \t\r\n]*?[\r\n][ \t\r\n]*")))) + (put-text-property 0 (length s) 'face 'font-lock-comment-face s) + (insert s) + (while (setq entry (pop eql)) + (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'."))) -(defvar org-agenda-markers nil - "List of all currently active markers created by `org-agenda'.") -(defvar org-agenda-last-marker-time (time-to-seconds (current-time)) - "Creation time of the last agenda marker.") +(defun org-table-edit-formulas-post-command () + (when (not (memq this-command '(lisp-complete-symbol))) + (let ((win (selected-window))) + (save-excursion + (condition-case nil + (org-show-reference) + (error nil)) + (select-window win))))) -(defun org-agenda-new-marker (&optional pos) - "Return a new agenda marker. -Org-mode keeps a list of these markers and resets them when they are -no longer in use." - (let ((m (copy-marker (or pos (point))))) - (setq org-agenda-last-marker-time (time-to-seconds (current-time))) - (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)))) +(defun org-finish-edit-formulas (&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) + (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]+.*$\\)*\\)" + nil 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)) + (set-window-configuration org-window-configuration) + (select-window (get-buffer-window (marker-buffer pos))) + (goto-char pos) + (unless (org-at-table-p) + (error "Lost table position - cannot install formulae")) + (org-table-store-formulas eql) + (move-marker pos nil) + (kill-buffer "*Edit Formulas*") + (if arg + (org-table-recalculate 'all) + (message "New formulas installed - press C-u C-c C-c to apply.")))) -(defvar org-agenda-new-buffers nil - "Buffers created to visit agenda files.") +(defun org-abort-edit-formulas () + "Abort editing formulas, without installing the changes." + (interactive) + (org-table-remove-rectangle-highlight) + (let ((pos org-pos)) + (set-window-configuration org-window-configuration) + (select-window (get-buffer-window (marker-buffer pos))) + (goto-char pos) + (move-marker pos nil) + (message "Formula editing aborted without installing changes"))) -(defun org-get-agenda-file-buffer (file) - "Get a buffer visiting FILE. If the buffer needs to be created, add -it to the list of buffers which might be released later." - (let ((buf (find-buffer-visiting file))) - (if buf - buf ; just return it - ;; Make a new buffer and remember it - (setq buf (find-file-noselect file)) - (if buf (push buf org-agenda-new-buffers)) - buf))) +(defun org-edit-formula-lisp-indent () + "Pretty-print and re-indent Lisp expressions in the Formula Editor." + (interactive) + (let ((pos (point)) beg end ind) + (beginning-of-line 1) + (cond + ((looking-at "[ \t]") + (goto-char pos) + (call-interactively 'lisp-indent-line)) + ((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]+ *= *'(") + (goto-char (- (match-end 0) 2)) + (setq beg (point)) + (setq ind (make-string (current-column) ?\ )) + (condition-case nil (forward-sexp 1) + (error + (error "Cannot pretty-print Lisp expression: Unbalanced parenthesis"))) + (setq end (point)) + (save-restriction + (narrow-to-region beg end) + (if (eq last-command this-command) + (progn + (goto-char (point-min)) + (setq this-command nil) + (while (re-search-forward "[ \t]*\n[ \t]*" nil t) + (replace-match " "))) + (pp-buffer) + (untabify (point-min) (point-max)) + (goto-char (1+ (point-min))) + (while (re-search-forward "^." nil t) + (beginning-of-line 1) + (insert ind)) + (goto-char (point-max)) + (backward-delete-char 1))) + (goto-char beg)) + (t nil)))) -(defun org-release-buffers (blist) - "Release all buffers in list, asking the user for confirmation when needed. -When a buffer is unmodified, it is just killed. When modified, it is saved -\(if the user agrees) and then killed." - (let (buf file) - (while (setq buf (pop blist)) - (setq file (buffer-file-name buf)) - (when (and (buffer-modified-p buf) - file - (y-or-n-p (format "Save file %s? " file))) - (with-current-buffer buf (save-buffer))) - (kill-buffer buf)))) +(defvar org-show-positions nil) -(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 -\\[universal-argument] prefix, all unfinished TODO items will also be shown, -under the current date. -If the buffer contains an active region, only check the region for -dates." - (interactive "P") - (require 'calendar) - (org-compile-prefix-format 'timeline) - (org-set-sorting-strategy 'timeline) - (let* ((dopast t) - (dotodo include-all) - (doclosed org-agenda-show-log) - (entry buffer-file-name) - (date (calendar-current-date)) - (win (selected-window)) - (pos1 (point)) - (beg (if (org-region-active-p) (region-beginning) (point-min))) - (end (if (org-region-active-p) (region-end) (point-max))) - (day-numbers (org-get-all-dates beg end 'no-ranges - t doclosed ; always include today - org-timeline-show-empty-dates)) - (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-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) - (if doclosed (push :closed args)) - (push :timestamp 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)) - (if (listp d) (setq d (car d) emptyp t) (setq emptyp nil)) - (if (and (>= d today) - dopast - past) +(defun org-show-reference (&optional local) + "Show the location/value of the $ expression at point." + (interactive) + (org-table-remove-rectangle-highlight) + (catch 'exit + (let ((pos (if local (point) org-pos)) + (face2 'highlight) + (org-inhibit-highlight-removal t) + (win (selected-window)) + (org-show-positions nil) + var name e what match dest) + (if local (org-table-get-specials)) + (setq what (cond + ((org-at-regexp-p org-table-range-regexp2) '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))) + (when (and match (not (equal (match-beginning 0) (point-at-bol)))) + (org-table-add-rectangle-overlay (match-beginning 0) (match-end 0) + 'secondary-selection)) + (org-add-hook 'before-change-functions + 'org-table-remove-rectangle-highlight) + (if (eq what 'name) (setq var (substring match 1))) + (when (eq what 'range) + (or (equal (string-to-char match) ?@) (setq match (concat "@" match))) + (setq match (org-table-formula-substitute-names match))) + (unless local + (save-excursion + (beginning-of-line 1) + (when (looking-at "\\(\\$[0-9a-zA-Z]+\\|@[0-9]+\\$[0-9]+\\)=") + (setq dest (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 + (marker-buffer pos))))) + (goto-char pos) + (org-table-force-dataline) + (when dest + (setq name (substring dest 1)) + (cond + ((string-match "^\\$[a-zA-Z][a-zA-Z0-9]*" dest) + (setq e (assoc name org-table-named-field-locations)) + (goto-line (nth 1 e)) + (org-table-goto-column (nth 2 e))) + ((string-match "^@\\([0-9]+\\)\\$\\([0-9]+\\)" dest) + (let ((l (string-to-number (match-string 1 dest))) + (c (string-to-number (match-string 2 dest)))) + (goto-line (aref org-table-dlines l)) + (org-table-goto-column c))) + (t (org-table-goto-column (string-to-number name)))) + (move-marker pos (point)) + (org-table-highlight-rectangle nil nil face2)) + (cond + ((equal dest match)) + ((not match)) + ((eq what 'range) + (condition-case nil + (save-excursion + (org-table-get-range match nil nil 'highlight)) + (error nil))) + ((setq e (assoc var org-table-named-field-locations)) + (goto-line (nth 1 e)) + (org-table-goto-column (nth 2 e)) + (org-table-highlight-rectangle (point) (point)) + (message "Named field, column %d of line %d" (nth 2 e) (nth 1 e))) + ((setq e (assoc var org-table-column-names)) + (org-table-goto-column (string-to-number (cdr e))) + (org-table-highlight-rectangle (point) (point)) + (goto-char (org-table-begin)) + (if (re-search-forward (concat "^[ \t]*| *! *.*?| *\\(" var "\\) *|") + (org-table-end) t) (progn - (setq past nil) - (insert (make-string 79 ?-) "\n"))) - (setq date (calendar-gregorian-from-absolute d)) - (setq s (point)) - (setq rtn (and (not emptyp) - (apply 'org-agenda-get-day-entries - entry date args))) - (if (or rtn (equal d today) org-timeline-show-empty-dates) + (goto-char (match-beginning 1)) + (org-table-highlight-rectangle) + (message "Named column (column %s)" (cdr e))) + (error "Column name not found"))) + ((eq what 'column) + ;; column number + (org-table-goto-column (string-to-number (substring match 1))) + (org-table-highlight-rectangle (point) (point)) + (message "Column %s" (substring match 1))) + ((setq e (assoc var org-table-local-parameters)) + (goto-char (org-table-begin)) + (if (re-search-forward (concat "^[ \t]*| *\\$ *.*?| *\\(" var "=\\)") nil t) (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") - (put-text-property s (1- (point)) 'face - 'org-level-3) - (if (equal d today) - (put-text-property s (1- (point)) 'org-today t)) - (and rtn (insert (org-finalize-agenda-entries rtn) "\n")) - (put-text-property s (1- (point)) 'day d))))) - (goto-char (point-min)) - (goto-char (or (text-property-any (point-min) (point-max) 'org-today t) - (point-min))) - (add-text-properties (point-min) (point-max) '(org-agenda-type timeline)) - (org-finalize-agenda) - (setq buffer-read-only t) - (when (not org-select-agenda-window) - (select-window win) - (goto-char pos1)))) + (goto-char (match-beginning 1)) + (org-table-highlight-rectangle) + (message "Local parameter.")) + (error "Parameter not found"))) + (t + (cond + ((not var) (error "No reference at point")) + ((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)) + (t (error "Undefined name $%s" var))))) + (goto-char pos) + (when org-show-positions + (push 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)))) + (select-window win)))) -(defvar org-agenda-overriding-arguments nil) ; dynamically scoped parameter -(defvar org-agenda-last-arguments nil - "The arguments of the previous call to org-agenda") +(defun org-table-force-dataline () + "Make sure the cursor is in a dataline in a table." + (unless (save-excursion + (beginning-of-line 1) + (looking-at org-table-dataline-regexp)) + (let* ((re org-table-dataline-regexp) + (p1 (save-excursion (re-search-forward re nil 'move))) + (p2 (save-excursion (re-search-backward re nil 'move)))) + (cond ((and p1 p2) + (goto-char (if (< (abs (- p1 (point))) (abs (- p2 (point)))) + p1 p2))) + ((or p1 p2) (goto-char (or p1 p2))) + (t (error "No table dataline around here")))))) + +(defun org-table-edit-line-up () + "Move cursor one line up in the window showing the table." + (interactive) + (org-table-edit-move 'previous-line)) + +(defun org-table-edit-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)) + +(defun org-table-edit-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) + (pos org-pos) (win (selected-window)) p) + (select-window (get-buffer-window (marker-buffer org-pos))) + (setq p (point)) + (call-interactively command) + (while (and (org-at-table-p) + (org-at-table-hline-p)) + (call-interactively command)) + (or (org-at-table-p) (goto-char p)) + (move-marker pos (point)) + (select-window win))) + +(defun org-table-edit-scroll (N) + (interactive "p") + (let ((other-window-scroll-buffer (marker-buffer org-pos))) + (scroll-other-window N))) + +(defun org-table-edit-scroll-down (N) + (interactive "p") + (org-table-edit-scroll (- N))) + +(defvar org-table-rectangle-overlays nil) + +(defun org-table-add-rectangle-overlay (beg end &optional face) + "Add a new overlay." + (let ((ov (org-make-overlay beg end))) + (org-overlay-put ov 'face (or face 'secondary-selection)) + (push ov org-table-rectangle-overlays))) + +(defun org-table-highlight-rectangle (&optional beg end face) + "Highlight rectangular region in a table." + (setq beg (or beg (point)) end (or end (point))) + (let ((b (min beg end)) + (e (max beg end)) + l1 c1 l2 c2 tmp) + (and (boundp 'org-show-positions) + (setq org-show-positions (cons b (cons e org-show-positions)))) + (goto-char (min beg end)) + (setq l1 (org-current-line) + c1 (org-table-current-column)) + (goto-char (max beg end)) + (setq l2 (org-current-line) + c2 (org-table-current-column)) + (if (> c1 c2) (setq tmp c1 c1 c2 c2 tmp)) + (goto-line l1) + (beginning-of-line 1) + (loop for line from l1 to l2 do + (when (looking-at org-table-dataline-regexp) + (org-table-goto-column c1) + (skip-chars-backward "^|\n") (setq beg (point)) + (org-table-goto-column c2) + (skip-chars-forward "^|\n") (setq end (point)) + (org-table-add-rectangle-overlay beg end face)) + (beginning-of-line 2)) + (goto-char b)) + (add-hook 'before-change-functions 'org-table-remove-rectangle-highlight)) + +(defun org-table-remove-rectangle-highlight (&rest ignore) + "Remove the rectangle overlays." + (unless org-inhibit-highlight-removal + (remove-hook 'before-change-functions 'org-table-remove-rectangle-highlight) + (mapc 'org-delete-overlay org-table-rectangle-overlays) + (setq org-table-rectangle-overlays nil))) + +(defvar org-table-coordinate-overlays nil + "Collects the cooordinate grid overlays, so that they can be removed.") +(make-variable-buffer-local 'org-table-coordinate-overlays) + +(defun org-table-overlay-coordinates () + "Add overlays to the table at point, to show row/column coordinates." + (interactive) + (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) + (goto-char (org-table-begin)) + (while (org-at-table-p) + (setq eol (point-at-eol)) + (setq ov (org-make-overlay (point-at-bol) (1+ (point-at-bol)))) + (push ov org-table-coordinate-overlays) + (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) + (when hline + (setq ic 0) + (while (re-search-forward "[+|]-+" eol t) + (setq beg (1+ (match-beginning 0)) + str (concat "$" (int-to-string (setq ic (1+ ic))))) + (setq ov (org-make-overlay beg (+ beg (length str)))) + (push ov org-table-coordinate-overlays) + (org-overlay-display ov str 'org-formula 'evaporate))) + (beginning-of-line 2))))) + +(defun org-table-toggle-coordinate-overlays () + "Toggle the display of Row/Column numbers in tables." + (interactive) + (setq org-table-overlay-coordinates (not org-table-overlay-coordinates)) + (message "Row/Column number display turned %s" + (if org-table-overlay-coordinates "on" "off")) + (if (and (org-at-table-p) org-table-overlay-coordinates) + (org-table-align)) + (unless org-table-overlay-coordinates + (mapc 'org-delete-overlay org-table-coordinate-overlays) + (setq org-table-coordinate-overlays nil))) + +(defun org-table-toggle-formula-debugger () + "Toggle the formula debugger in tables." + (interactive) + (setq org-table-formula-debug (not org-table-formula-debug)) + (message "Formula debugging has been turned %s" + (if org-table-formula-debug "on" "off"))) + +;;; The orgtbl minor mode + +;; Define a minor mode which can be used in other modes in order to +;; integrate the org-mode table editor. + +;; This is really a hack, because the org-mode table editor uses several +;; keys which normally belong to the major mode, for example the TAB and +;; RET keys. Here is how it works: The minor mode defines all the keys +;; necessary to operate the table editor, but wraps the commands into a +;; function which tests if the cursor is currently inside a table. If that +;; is the case, the table editor command is executed. However, when any of +;; those keys is used outside a table, the 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 used by the table editor is +;; otherwise used as a prefix key. + +;; 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. + +;; The optimized version (see variable `orgtbl-optimized') takes over +;; all keys which are bound to `self-insert-command' in the *global map*. +;; Some modes bind other commands to simple characters, for example +;; AUCTeX binds the double quote to `Tex-insert-quote'. With orgtbl-mode +;; active, this binding is ignored inside tables and replaced with a +;; modified self-insert. + +(defvar orgtbl-mode nil + "Variable controlling `orgtbl-mode', a minor mode enabling the `org-mode' +table editor in arbitrary modes.") +(make-variable-buffer-local 'orgtbl-mode) + +(defvar orgtbl-mode-map (make-keymap) + "Keymap for `orgtbl-mode'.") ;;;###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. -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'." - (interactive "P") - (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))) - (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)) - (thefiles (org-agenda-files)) - (files thefiles) - (win (selected-window)) - (today (time-to-days (current-time))) - (sd (or start-day today)) - (start (if (or (null org-agenda-start-on-weekday) - (< org-agenda-ndays 7)) - sd - (let* ((nt (calendar-day-of-week - (calendar-gregorian-from-absolute sd))) - (n1 org-agenda-start-on-weekday) - (d (- nt n1))) - (- sd (+ (if (< d 0) 7 0) d))))) - (day-numbers (list start)) - (inhibit-redisplay t) - s e rtn rtnall file date d start-pos end-pos todayp nd) - (setq org-agenda-redo-command - (list 'org-agenda-list (list 'quote include-all) start-day ndays)) - ;; Make the list of days - (setq ndays (or ndays org-agenda-ndays) - nd ndays) - (while (> ndays 1) - (push (1+ (car day-numbers)) day-numbers) - (setq ndays (1- ndays))) - (setq day-numbers (nreverse day-numbers)) - (org-prepare-agenda) - (org-set-local 'starting-day (car day-numbers)) - (org-set-local 'include-all-loc include-all) - (when (and (or include-all org-agenda-include-all-todo) - (member today day-numbers)) - (setq files thefiles - rtnall nil) - (while (setq file (pop files)) - (catch 'nextfile - (org-check-agenda-file file) - (setq date (calendar-gregorian-from-absolute today) - rtn (org-agenda-get-day-entries - file date :todo)) - (setq rtnall (append rtnall rtn)))) - (when rtnall - (insert "ALL CURRENTLY OPEN TODO ITEMS:\n") - (add-text-properties (point-min) (1- (point)) - (list 'face 'org-level-3)) - (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)) - (while (setq d (pop day-numbers)) - (setq date (calendar-gregorian-from-absolute d) - s (point)) - (if (or (setq todayp (= d today)) - (and (not start-pos) (= d sd))) - (setq start-pos (point)) - (if (and start-pos (not end-pos)) - (setq end-pos (point)))) - (setq files thefiles - rtnall nil) - (while (setq file (pop files)) - (catch 'nextfile - (org-check-agenda-file file) - (if org-agenda-show-log - (setq rtn (org-agenda-get-day-entries - file date - :deadline :scheduled :timestamp :closed)) - (setq rtn (org-agenda-get-day-entries - file date - :deadline :scheduled :timestamp))) - (setq rtnall (append rtnall rtn)))) - (if org-agenda-include-diary - (progn - (require 'diary-lib) - (setq rtn (org-get-entries-from-diary date)) - (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))) - (put-text-property s (1- (point)) 'face - 'org-level-3) - (if todayp (put-text-property s (1- (point)) 'org-today t)) +(defun turn-on-orgtbl () + "Unconditionally turn on `orgtbl-mode'." + (orgtbl-mode 1)) - (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)))) - (goto-char (point-min)) - (org-fit-agenda-window) - (unless (and (pos-visible-in-window-p (point-min)) - (pos-visible-in-window-p (point-max))) - (goto-char (1- (point-max))) - (recenter -1) - (if (not (pos-visible-in-window-p (or start-pos 1))) - (progn - (goto-char (or start-pos 1)) - (recenter 1)))) - (goto-char (or start-pos 1)) - (add-text-properties (point-min) (point-max) '(org-agenda-type agenda)) - (org-finalize-agenda) - (setq buffer-read-only t) - (if (not org-select-agenda-window) (select-window win)) - (message ""))) +(defvar org-old-auto-fill-inhibit-regexp nil + "Local variable used by `orgtbl-mode'") -(defvar org-select-this-todo-keyword nil) +(defconst orgtbl-line-start-regexp "[ \t]*\\(|\\|#\\+\\(TBLFM\\|ORGTBL\\):\\)" + "Matches a line belonging to an orgtbl.") + +(defconst orgtbl-extra-font-lock-keywords + (list (list (concat "^" orgtbl-line-start-regexp ".*") + 0 (quote 'org-table) 'prepend)) + "Extra font-lock-keywords to be added when orgtbl-mode is active.") ;;;###autoload -(defun org-todo-list (arg) - "Show all TODO entries from all agenda file in a single list. -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'." - (interactive "P") - (require 'calendar) - (org-compile-prefix-format 'todo) - (org-set-sorting-strategy 'todo) - (let* ((today (time-to-days (current-time))) - (date (calendar-gregorian-from-absolute today)) - (win (selected-window)) - (kwds org-todo-keywords) - (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)))) - 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))) - (and (equal 0 arg) (setq org-select-this-todo-keyword nil)) - (org-prepare-agenda) - (org-set-local 'last-arg arg) - (org-set-local 'org-todo-keywords kwds) - (setq org-agenda-redo-command - '(org-todo-list (or current-prefix-arg last-arg))) - (setq files (org-agenda-files) - rtnall nil) - (while (setq file (pop files)) - (catch 'nextfile - (org-check-agenda-file file) - (setq rtn (org-agenda-get-day-entries file date :todo)) - (setq rtnall (append rtnall rtn)))) - (insert "Global list of TODO items of type: ") - (add-text-properties (point-min) (1- (point)) - (list 'face 'org-level-3)) - (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)) - (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 todo)) - (org-finalize-agenda) - (setq buffer-read-only t) - (if (not org-select-agenda-window) (select-window win)))) +(defun orgtbl-mode (&optional arg) + "The `org-mode' table editor as a minor mode for use in other modes." + (interactive) + (if (org-mode-p) + ;; Exit without error, in case some hook functions calls this + ;; by accident in org-mode. + (message "Orgtbl-mode is not useful in org-mode, command ignored") + (setq orgtbl-mode + (if arg (> (prefix-numeric-value arg) 0) (not orgtbl-mode))) + (if orgtbl-mode + (progn + (and (orgtbl-setup) (defun orgtbl-setup () nil)) + ;; Make sure we are first in minor-mode-map-alist + (let ((c (assq 'orgtbl-mode minor-mode-map-alist))) + (and c (setq minor-mode-map-alist + (cons c (delq c minor-mode-map-alist))))) + (org-set-local (quote org-table-may-need-update) t) + (org-add-hook 'before-change-functions 'org-before-change-function + nil 'local) + (org-set-local 'org-old-auto-fill-inhibit-regexp + auto-fill-inhibit-regexp) + (org-set-local 'auto-fill-inhibit-regexp + (if auto-fill-inhibit-regexp + (concat orgtbl-line-start-regexp "\\|" + auto-fill-inhibit-regexp) + orgtbl-line-start-regexp)) + (org-add-to-invisibility-spec '(org-cwidth)) + (when (fboundp 'font-lock-add-keywords) + (font-lock-add-keywords nil orgtbl-extra-font-lock-keywords) + (org-restart-font-lock)) + (easy-menu-add orgtbl-mode-menu) + (run-hooks 'orgtbl-mode-hook)) + (setq auto-fill-inhibit-regexp org-old-auto-fill-inhibit-regexp) + (org-cleanup-narrow-column-properties) + (org-remove-from-invisibility-spec '(org-cwidth)) + (remove-hook 'before-change-functions 'org-before-change-function t) + (when (fboundp 'font-lock-remove-keywords) + (font-lock-remove-keywords nil orgtbl-extra-font-lock-keywords) + (org-restart-font-lock)) + (easy-menu-remove orgtbl-mode-menu) + (force-mode-line-update 'all)))) -(defun org-check-agenda-file (file) - "Make sure FILE exists. If not, ask user what to do." - (when (not (file-exists-p file)) - (message "non-existent file %s. [R]emove from list or [A]bort?" - (abbreviate-file-name file)) - (let ((r (downcase (read-char-exclusive)))) - (cond - ((equal r ?r) - (org-remove-file file) - (throw 'nextfile t)) - (t (error "Abort")))))) +(defun org-cleanup-narrow-column-properties () + "Remove all properties related to narrow-column invisibility." + (let ((s 1)) + (while (setq s (text-property-any s (point-max) + 'display org-narrow-column-arrow)) + (remove-text-properties s (1+ s) '(display t))) + (setq s 1) + (while (setq s (text-property-any s (point-max) 'org-cwidth 1)) + (remove-text-properties s (1+ s) '(org-cwidth t))) + (setq s 1) + (while (setq s (text-property-any s (point-max) 'invisible 'org-cwidth)) + (remove-text-properties s (1+ s) '(invisible t))))) -(defun org-agenda-check-type (error &rest types) - "Check if agenda buffer is of allowed type. -If ERROR is non-nil, throw an error, otherwise just return nil." - (if (memq org-agenda-type types) - t - (if error - (error "Not allowed in %s-type agenda buffers" org-agenda-type) - nil))) +;; Install it as a minor mode. +(put 'orgtbl-mode :included t) +(put 'orgtbl-mode :menu-tag "Org Table Mode") +(add-minor-mode 'orgtbl-mode " OrgTbl" orgtbl-mode-map) -(defun org-agenda-quit () - "Exit agenda by removing the window or the buffer." - (interactive) - (let ((buf (current-buffer))) - (if (not (one-window-p)) (delete-window)) - (kill-buffer buf) - (org-agenda-maybe-reset-markers 'force)) - ;; Maybe restore the pre-agenda window configuration. - (and org-agenda-restore-windows-after-quit - (not (eq org-agenda-window-setup 'other-frame)) - org-pre-agenda-window-conf - (set-window-configuration org-pre-agenda-window-conf))) +(defun orgtbl-make-binding (fun n &rest keys) + "Create a function for binding in the table 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 "orgtbl-hijacker-command-" (int-to-string n))) + '(arg) + (concat "In tables, run `" (symbol-name fun) "'.\n" + "Outside of tables, run the binding of `" + (mapconcat (lambda (x) (format "%s" x)) keys "' or `") + "'.") + '(interactive "p") + (list 'if + '(org-at-table-p) + (list 'call-interactively (list 'quote fun)) + (list 'let '(orgtbl-mode) + (list 'call-interactively + (append '(or) + (mapcar (lambda (k) + (list 'key-binding k)) + keys) + '('orgtbl-error)))))))) -(defun org-agenda-exit () - "Exit agenda by removing the window or the buffer. -Also kill all Org-mode buffers which have been loaded by `org-agenda'. -Org-mode buffers visited directly by the user will not be touched." +(defun orgtbl-error () + "Error when there is no default binding for a table key." (interactive) - (org-release-buffers org-agenda-new-buffers) - (setq org-agenda-new-buffers nil) - (org-agenda-quit)) + (error "This key is has no function outside tables")) -(defun org-save-all-org-buffers () - "Save all Org-mode buffers without user confirmation." - (interactive) - (message "Saving all Org-mode buffers...") - (save-some-buffers t 'org-mode-p) - (message "Saving all Org-mode buffers... done")) +(defun orgtbl-setup () + "Setup orgtbl keymaps." + (let ((nfunc 0) + (bindings + (list + '([(meta shift left)] org-table-delete-column) + '([(meta left)] org-table-move-column-left) + '([(meta right)] org-table-move-column-right) + '([(meta shift right)] org-table-insert-column) + '([(meta shift up)] org-table-kill-row) + '([(meta shift down)] org-table-insert-row) + '([(meta up)] org-table-move-row-up) + '([(meta down)] org-table-move-row-down) + '("\C-c\C-w" org-table-cut-region) + '("\C-c\M-w" org-table-copy-region) + '("\C-c\C-y" org-table-paste-rectangle) + '("\C-c-" org-table-insert-hline) + '("\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) + '("\C-c\C-q" org-table-wrap-region) + '("\C-c?" org-table-field-info) + '("\C-c " org-table-blank-field) + '("\C-c+" org-table-sum) + '("\C-c=" org-table-eval-formula) + '("\C-c'" org-table-edit-formulas) + '("\C-c`" org-table-edit-field) + '("\C-c*" org-table-recalculate) + '("\C-c|" org-table-create-or-convert-from-region) + '("\C-c^" org-table-sort-lines) + '([(control ?#)] org-table-rotate-recalc-marks))) + elt key fun cmd) + (while (setq elt (pop bindings)) + (setq nfunc (1+ nfunc)) + (setq key (car elt) + fun (nth 1 elt) + cmd (orgtbl-make-binding fun nfunc key)) + (define-key orgtbl-mode-map key cmd)) -(defun org-agenda-redo () - "Rebuild Agenda. -When this is the global TODO list, a prefix argument will be interpreted." - (interactive) - (let* ((org-agenda-keep-modes t) - (line (org-current-line)) - (window-line (- line (org-current-line (window-start))))) - (message "Rebuilding agenda buffer...") - (eval org-agenda-redo-command) - (message "Rebuilding agenda buffer...done") - (goto-line line) - (recenter window-line))) + ;; Special treatment needed for TAB and RET + (define-key orgtbl-mode-map [(return)] + (orgtbl-make-binding 'orgtbl-ret 100 [(return)] "\C-m")) + (define-key orgtbl-mode-map "\C-m" + (orgtbl-make-binding 'orgtbl-ret 101 "\C-m" [(return)])) -(defun org-agenda-goto-today () - "Go to today." - (interactive) - (org-agenda-check-type t 'timeline 'agenda) - (let ((tdpos (text-property-any (point-min) (point-max) 'org-today t))) - (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) - (org-agenda-redo) - (org-agenda-find-today-or-agenda))) - (t (error "Cannot find today"))))) + (define-key orgtbl-mode-map [(tab)] + (orgtbl-make-binding 'orgtbl-tab 102 [(tab)] "\C-i")) + (define-key orgtbl-mode-map "\C-i" + (orgtbl-make-binding 'orgtbl-tab 103 "\C-i" [(tab)])) -(defun org-agenda-find-today-or-agenda () - (goto-char - (or (text-property-any (point-min) (point-max) 'org-today t) - (text-property-any (point-min) (point-max) 'org-agenda-type 'agenda) - (point-min)))) + (define-key orgtbl-mode-map [(shift tab)] + (orgtbl-make-binding 'org-table-previous-field 104 + [(shift tab)] [(tab)] "\C-i")) -(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'." - (interactive "p") - (org-agenda-check-type t 'agenda) - (let ((org-agenda-overriding-arguments - (list (car org-agenda-last-arguments) - (+ starting-day (* arg org-agenda-ndays)) - nil t))) - (org-agenda-redo) - (org-agenda-find-today-or-agenda))) + (define-key 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)] + (orgtbl-make-binding 'org-table-wrap-region 106 + [(meta return)] "\M-\C-m")) -(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'." - (interactive "p") - (org-agenda-check-type t 'agenda) - (let ((org-agenda-overriding-arguments - (list (car org-agenda-last-arguments) - (- starting-day (* arg org-agenda-ndays)) - nil t))) - (org-agenda-redo) - (org-agenda-find-today-or-agenda))) + (define-key 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 + (org-remap orgtbl-mode-map + '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)) + (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"] + ["Next Field" org-cycle :active (org-at-table-p) :keys "TAB"] + ["Previous Field" org-shifttab :active (org-at-table-p) :keys "S-TAB"] + ["Next Row" org-return :active (org-at-table-p) :keys "RET"] + "--" + ["Blank Field" org-table-blank-field :active (org-at-table-p) :keys "C-c SPC"] + ["Edit Field" org-table-edit-field :active (org-at-table-p) :keys "C-c ` "] + ["Copy Field from Above" + org-table-copy-down :active (org-at-table-p) :keys "S-RET"] + "--" + ("Column" + ["Move Column Left" org-metaleft :active (org-at-table-p) :keys "M-"] + ["Move Column Right" org-metaright :active (org-at-table-p) :keys "M-"] + ["Delete Column" org-shiftmetaleft :active (org-at-table-p) :keys "M-S-"] + ["Insert Column" org-shiftmetaright :active (org-at-table-p) :keys "M-S-"]) + ("Row" + ["Move Row Up" org-metaup :active (org-at-table-p) :keys "M-"] + ["Move Row Down" org-metadown :active (org-at-table-p) :keys "M-"] + ["Delete Row" org-shiftmetaup :active (org-at-table-p) :keys "M-S-"] + ["Insert Row" org-shiftmetadown :active (org-at-table-p) :keys "M-S-"] + ["Sort lines in region" org-table-sort-lines (org-at-table-p) :keys "C-c ^"] + "--" + ["Insert Hline" org-table-insert-hline :active (org-at-table-p) :keys "C-c -"]) + ("Rectangle" + ["Copy Rectangle" org-copy-special :active (org-at-table-p)] + ["Cut Rectangle" org-cut-special :active (org-at-table-p)] + ["Paste Rectangle" org-paste-special :active (org-at-table-p)] + ["Fill Rectangle" org-table-wrap-region :active (org-at-table-p)]) + "--" + ("Radio tables" + ["Insert table template" orgtbl-insert-radio-table + (assq major-mode orgtbl-radio-table-templates)] + ["Comment/uncomment table" orgtbl-toggle-comment t]) + "--" + ["Set Column Formula" org-table-eval-formula :active (org-at-table-p) :keys "C-c ="] + ["Set Field Formula" (org-table-eval-formula '(4)) :active (org-at-table-p) :keys "C-u C-c ="] + ["Edit Formulas" org-table-edit-formulas :active (org-at-table-p) :keys "C-c '"] + ["Recalculate line" org-table-recalculate :active (org-at-table-p) :keys "C-c *"] + ["Recalculate all" (org-table-recalculate '(4)) :active (org-at-table-p) :keys "C-u C-c *"] + ["Iterate all" (org-table-recalculate '(16)) :active (org-at-table-p) :keys "C-u C-u C-c *"] + ["Toggle Recalculate Mark" org-table-rotate-recalc-marks :active (org-at-table-p) :keys "C-c #"] + ["Sum Column/Rectangle" org-table-sum + :active (or (org-at-table-p) (org-region-active-p)) :keys "C-c +"] + ["Which Column?" org-table-current-column :active (org-at-table-p) :keys "C-c ?"] + ["Debug Formulas" + org-table-toggle-formula-debugger :active (org-at-table-p) + :keys "C-c {" + :style toggle :selected org-table-formula-debug] + ["Show Col/Row Numbers" + org-table-toggle-coordinate-overlays :active (org-at-table-p) + :keys "C-c }" + :style toggle :selected org-table-overlay-coordinates] + )) + t)) -(defun org-agenda-week-view () - "Switch to weekly 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) - starting-day) - nil t))) - (org-agenda-redo) - (org-agenda-find-today-or-agenda)) - (org-agenda-set-mode-name) - (message "Switched to week view")) +(defun orgtbl-ctrl-c-ctrl-c (arg) + "If the cursor is inside a table, realign the table. +It it is a table to be sent away to a receiver, do it. +With prefix arg, also recompute table." + (interactive "P") + (let ((pos (point)) action) + (save-excursion + (beginning-of-line 1) + (setq action (cond ((looking-at "#\\+ORGTBL:.*\n[ \t]*|") (match-end 0)) + ((looking-at "[ \t]*|") pos) + ((looking-at "#\\+TBLFM:") 'recalc)))) + (cond + ((integerp action) + (goto-char action) + (org-table-maybe-eval-formula) + (if arg + (call-interactively 'org-table-recalculate) + (org-table-maybe-recalculate-line)) + (call-interactively 'org-table-align) + (orgtbl-send-table 'maybe)) + ((eq action 'recalc) + (save-excursion + (beginning-of-line 1) + (skip-chars-backward " \r\n\t") + (if (org-at-table-p) + (org-call-with-arg 'org-table-recalculate t)))) + (t (let (orgtbl-mode) + (call-interactively (key-binding "\C-c\C-c"))))))) -(defun org-agenda-day-view () - "Switch to daily view for agenda." +(defun orgtbl-tab (arg) + "Justification and field motion for `orgtbl-mode'." + (interactive "P") + (if arg (org-table-edit-field t) + (org-table-justify-field-maybe) + (org-table-next-field))) + +(defun orgtbl-ret () + "Justification and field motion for `orgtbl-mode'." (interactive) - (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) - starting-day) - nil t))) - (org-agenda-redo) - (org-agenda-find-today-or-agenda)) - (org-agenda-set-mode-name) - (message "Switched to day view")) + (org-table-justify-field-maybe) + (org-table-next-row)) -(defun org-agenda-next-date-line (&optional arg) - "Jump to the next line indicating a date in agenda buffer." +(defun orgtbl-self-insert-command (N) + "Like `self-insert-command', use overwrite-mode for whitespace in tables. +If the cursor is in a table looking at whitespace, the whitespace is +overwritten, and the table is not marked as requiring realignment." (interactive "p") - (org-agenda-check-type t 'agenda 'timeline) - (beginning-of-line 1) - (if (looking-at "^\\S-") (forward-char 1)) - (if (not (re-search-forward "^\\S-" nil t arg)) - (progn - (backward-char 1) - (error "No next date after this line in this buffer"))) - (goto-char (match-beginning 0))) + (if (and (org-at-table-p) + (or + (and org-table-auto-blank-field + (member last-command + '(orgtbl-hijacker-command-100 + orgtbl-hijacker-command-101 + orgtbl-hijacker-command-102 + orgtbl-hijacker-command-103 + orgtbl-hijacker-command-104 + orgtbl-hijacker-command-105)) + (org-table-blank-field)) + t) + (eq N 1) + (looking-at "[^|\n]* +|")) + (let (org-table-may-need-update) + (goto-char (1- (match-end 0))) + (delete-backward-char 1) + (goto-char (match-beginning 0)) + (self-insert-command N)) + (setq org-table-may-need-update t) + (let (orgtbl-mode) + (call-interactively (key-binding (vector last-input-event)))))) -(defun org-agenda-previous-date-line (&optional arg) - "Jump to the previous line indicating a date in agenda buffer." +(defun org-force-self-insert (N) + "Needed to enforce self-insert under remapping." (interactive "p") - (org-agenda-check-type t 'agenda 'timeline) - (beginning-of-line 1) - (if (not (re-search-backward "^\\S-" nil t arg)) - (error "No previous date before this line in this buffer"))) + (self-insert-command N)) -;; Initialize the highlight -(defvar org-hl (org-make-overlay 1 1)) -(org-overlay-put org-hl 'face 'highlight) +(defvar orgtbl-exp-regexp "^\\([-+]?[0-9][0-9.]*\\)[eE]\\([-+]?[0-9]+\\)$" + "Regula expression matching exponentials as produced by calc.") -(defun org-highlight (begin end &optional buffer) - "Highlight a region with overlay." - (funcall (if (featurep 'xemacs) 'set-extent-endpoints 'move-overlay) - org-hl begin end (or buffer (current-buffer)))) +(defvar org-table-clean-did-remove-column-1 nil) -(defun org-unhighlight () - "Detach overlay INDEX." - (funcall (if (featurep 'xemacs) 'detach-extent 'delete-overlay) org-hl)) - - -(defun org-agenda-follow-mode () - "Toggle follow mode in an agenda buffer." +(defun orgtbl-send-table (&optional maybe) + "Send a tranformed version of this table to the receiver position. +With argument MAYBE, fail quietly if no transformation is defined for +this table." (interactive) - (setq org-agenda-follow-mode (not org-agenda-follow-mode)) - (org-agenda-set-mode-name) - (message "Follow mode is %s" - (if org-agenda-follow-mode "on" "off"))) + (catch 'exit + (unless (org-at-table-p) (error "Not at a table")) + ;; when non-interactive, we assume align has just happened. + (when (interactive-p) (org-table-align)) + (save-excursion + (goto-char (org-table-begin)) + (beginning-of-line 0) + (unless (looking-at "#\\+ORGTBL: *SEND +\\([a-zA-Z0-9_]+\\) +\\([^ \t\r\n]+\\)\\( +.*\\)?") + (if maybe + (throw 'exit nil) + (error "Don't know how to transform this table.")))) + (let* ((name (match-string 1)) + beg + (transform (intern (match-string 2))) + (params (if (match-end 3) (read (concat "(" (match-string 3) ")")))) + (skip (plist-get params :skip)) + (skipcols (plist-get params :skipcols)) + (txt (buffer-substring-no-properties + (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)) + (table (mapcar + (lambda (x) + (if (string-match org-table-hline-regexp x) + 'hline + (org-remove-by-index + (org-split-string (org-trim x) "\\s-*|\\s-*") + skipcols i0))) + lines)) + (fun (if (= i0 2) 'cdr 'identity)) + (org-table-last-alignment + (org-remove-by-index (funcall fun org-table-last-alignment) + skipcols i0)) + (org-table-last-column-widths + (org-remove-by-index (funcall fun org-table-last-column-widths) + skipcols i0))) + + (unless (fboundp transform) + (error "No such transformation function %s" transform)) + (setq txt (funcall transform table params)) + ;; Find the insertion place + (save-excursion + (goto-char (point-min)) + (unless (re-search-forward + (concat "BEGIN RECEIVE ORGTBL +" name "\\([ \t]\\|$\\)") nil t) + (error "Don't know where to insert translated table")) + (goto-char (match-beginning 0)) + (beginning-of-line 2) + (setq beg (point)) + (unless (re-search-forward (concat "END RECEIVE ORGTBL +" name) nil t) + (error "Cannot find end of insertion region")) + (beginning-of-line 1) + (delete-region beg (point)) + (goto-char beg) + (insert txt "\n")) + (message "Table converted and installed at receiver location")))) -(defun org-agenda-log-mode () - "Toggle log mode in an agenda buffer." +(defun org-remove-by-index (list indices &optional i0) + "Remove the elements in LIST with indices in INDICES. +First element has index 0, or I0 if given." + (if (not indices) + list + (if (integerp indices) (setq indices (list indices))) + (setq i0 (1- (or i0 0))) + (delq :rm (mapcar (lambda (x) + (setq i0 (1+ i0)) + (if (memq i0 indices) :rm x)) + list)))) + +(defun orgtbl-toggle-comment () + "Comment or uncomment the orgtbl at point." (interactive) - (org-agenda-check-type t 'agenda 'timeline) - (setq org-agenda-show-log (not org-agenda-show-log)) - (org-agenda-set-mode-name) - (org-agenda-redo) - (message "Log mode is %s" - (if org-agenda-show-log "on" "off"))) + (let* ((re1 (concat "^" (regexp-quote comment-start) orgtbl-line-start-regexp)) + (re2 (concat "^" orgtbl-line-start-regexp)) + (commented (save-excursion (beginning-of-line 1) + (cond ((looking-at re1) t) + ((looking-at re2) nil) + (t (error "Not at an org table"))))) + (re (if commented re1 re2)) + beg end) + (save-excursion + (beginning-of-line 1) + (while (looking-at re) (beginning-of-line 0)) + (beginning-of-line 2) + (setq beg (point)) + (while (looking-at re) (beginning-of-line 2)) + (setq end (point))) + (comment-region beg end (if commented '(4) nil)))) -(defun org-agenda-toggle-diary () - "Toggle diary inclusion in an agenda buffer." +(defun orgtbl-insert-radio-table () + "Insert a radio table template appropriate for this major mode." (interactive) - (org-agenda-check-type t 'agenda) - (setq org-agenda-include-diary (not org-agenda-include-diary)) - (org-agenda-redo) - (org-agenda-set-mode-name) - (message "Diary inclusion turned %s" - (if org-agenda-include-diary "on" "off"))) + (let* ((e (assq major-mode orgtbl-radio-table-templates)) + (txt (nth 1 e)) + name pos) + (unless e (error "No radio table setup defined for %s" major-mode)) + (setq name (read-string "Table name: ")) + (while (string-match "%n" txt) + (setq txt (replace-match name t t txt))) + (or (bolp) (insert "\n")) + (setq pos (point)) + (insert txt) + (goto-char pos))) -(defun org-agenda-toggle-time-grid () - "Toggle time grid in an agenda buffer." +(defun org-get-param (params header i sym &optional hsym) + "Get parameter value for symbol SYM. +If this is a header line, actually get the value for the symbol with an +additional \"h\" inserted after the colon. +If the value is a protperty list, get the element for the current column. +Assumes variables VAL, PARAMS, HEAD and I to be scoped into the function." + (let ((val (plist-get params sym))) + (and hsym header (setq val (or (plist-get params hsym) val))) + (if (consp val) (plist-get val i) val))) + +(defun orgtbl-to-generic (table params) + "Convert the orgtbl-mode TABLE to some other format. +This generic routine can be used for many standard cases. +TABLE is a list, each entry either the symbol `hline' for a horizontal +separator line, or a list of fields for that line. +PARAMS is a property list of parameters that can influence the conversion. +For the generic converter, some parameters are obligatory: You need to +specify either :lfmt, or all of (:lstart :lend :sep). If you do not use +:splice, you must have :tstart and :tend. + +Valid parameters are + +:tstart String to start the table. Ignored when :splice is t. +:tend String to end the table. Ignored when :splice is t. + +:splice When set to t, return only table body lines, don't wrap + them into :tstart and :tend. Default is nil. + +:hline String to be inserted on horizontal separation lines. + May be nil to ignore hlines. + +:lstart String to start a new table line. +:lend String to end a table line +:sep Separator between two fields +:lfmt Format for entire line, with enough %s to capture all fields. + If this is present, :lstart, :lend, and :sep are ignored. +: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, you could use :fmt \"$%s$\". + This may also be a property list with column numbers and + formats. for example :fmt (2 \"$%s$\" 4 \"%s%%\") + +:hlstart :hlend :hlsep :hlfmt :hfmt + Same as above, specific for the header lines in the table. + All lines before the first hline are treated as header. + If any of these is not present, the data line value is used. + +:efmt Use this format to print numbers with exponentials. + The format should have %s twice for inserting mantissa + and exponent, for example \"%s\\\\times10^{%s}\". This + may also be a property list with column numbers and + formats. :fmt will still be applied after :efmt. + +In addition to this, the parameters :skip and :skipcols are always handled +directly by `orgtbl-send-table'. See manual." (interactive) - (org-agenda-check-type t 'agenda) - (setq org-agenda-use-time-grid (not org-agenda-use-time-grid)) - (org-agenda-redo) - (org-agenda-set-mode-name) - (message "Time-grid turned %s" - (if org-agenda-use-time-grid "on" "off"))) + (let* ((p params) + (splicep (plist-get p :splice)) + (hline (plist-get p :hline)) + rtn line i fm efm lfmt h) + + ;; Do we have a header? + (if (and (not splicep) (listp (car table)) (memq 'hline table)) + (setq h t)) + + ;; Put header + (unless splicep + (push (or (plist-get p :tstart) "ERROR: no :tstart") rtn)) + + ;; Now loop over all lines + (while (setq line (pop table)) + (if (eq line 'hline) + ;; A horizontal separator line + (progn (if hline (push hline rtn)) + (setq h nil)) ; no longer in header + ;; A normal line. Convert the fields, push line onto the result list + (setq i 0) + (setq line + (mapcar + (lambda (f) + (setq i (1+ i) + fm (org-get-param p h i :fmt :hfmt) + efm (org-get-param p h i :efmt)) + (if (and efm (string-match orgtbl-exp-regexp f)) + (setq f (format + efm (match-string 1 f) (match-string 2 f)))) + (if fm (setq f (format fm f))) + f) + line)) + (if (setq lfmt (org-get-param p h i :lfmt :hlfmt)) + (push (apply 'format lfmt line) rtn) + (push (concat + (org-get-param p h i :lstart :hlstart) + (mapconcat 'identity line (org-get-param p h i :sep :hsep)) + (org-get-param p h i :lend :hlend)) + rtn)))) + + (unless splicep + (push (or (plist-get p :tend) "ERROR: no :tend") rtn)) + + (mapconcat 'identity (nreverse rtn) "\n"))) + +(defun orgtbl-to-latex (table params) + "Convert the orgtbl-mode TABLE to LaTeX. +TABLE is a list, each entry either the symbol `hline' for a horizontal +separator line, or a list of fields for that line. +PARAMS is a property list of parameters that can influence the conversion. +Supports all parameters from `orgtbl-to-generic'. Most important for +LaTeX are: + +:splice When set to t, return only table body lines, don't wrap + them into a tabular environment. Default is nil. + +: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%%\") + +:efmt Format for transforming numbers with exponentials. The format + should have %s twice for inserting mantissa and exponent, for + example \"%s\\\\times10^{%s}\". LaTeX default is \"%s\\\\,(%s)\". + This may also be a property list with column numbers and formats. + +The general parameters :skip and :skipcols have already been applied when +this function is called." + (let* ((alignment (mapconcat (lambda (x) (if x "r" "l")) + org-table-last-alignment "")) + (params2 + (list + :tstart (concat "\\begin{tabular}{" alignment "}") + :tend "\\end{tabular}" + :lstart "" :lend " \\\\" :sep " & " + :efmt "%s\\,(%s)" :hline "\\hline"))) + (orgtbl-to-generic table (org-combine-plists params2 params)))) + +(defun orgtbl-to-html (table params) + "Convert the orgtbl-mode TABLE to LaTeX. +TABLE is a list, each entry either the symbol `hline' for a horizontal +separator line, or a list of fields for that line. +PARAMS is a property list of parameters that can influence the conversion. +Currently this function recognizes the following parameters: + +:splice When set to t, return only table body lines, don't wrap + them into a
environment. Default is nil. + +The general parameters :skip and :skipcols have already been applied when +this function is called. The function does *not* use `orgtbl-to-generic', +so you cannot specify parameters for it." + (let* ((splicep (plist-get params :splice)) + html) + ;; Just call the formatter we already have + ;; We need to make text lines for it, so put the fields back together. + (setq html (org-format-org-table-html + (mapcar + (lambda (x) + (if (eq x 'hline) + "|----+----|" + (concat "| " (mapconcat 'identity x " | ") " |"))) + table) + splicep)) + (if (string-match "\n+\\'" html) + (setq html (replace-match "" t t html))) + html)) -(defun org-agenda-set-mode-name () - "Set the mode name to indicate all the small mode settings." - (setq mode-name - (concat "Org-Agenda" - (if (equal org-agenda-ndays 1) " Day" "") - (if (equal org-agenda-ndays 7) " Week" "") - (if org-agenda-follow-mode " Follow" "") - (if org-agenda-include-diary " Diary" "") - (if org-agenda-use-time-grid " Grid" "") - (if org-agenda-show-log " Log" ""))) - (force-mode-line-update)) +(defun orgtbl-to-texinfo (table params) + "Convert the orgtbl-mode TABLE to TeXInfo. +TABLE is a list, each entry either the symbol `hline' for a horizontal +separator line, or a list of fields for that line. +PARAMS is a property list of parameters that can influence the conversion. +Supports all parameters from `orgtbl-to-generic'. Most important for +TeXInfo are: + +:splice nil/t When set to t, return only table body lines, don't wrap + them into a multitable environment. Default is nil. + +:fmt fmt A format to be used to wrap the field, should contain + %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}\"). + +:cf \"f1 f2..\" The column fractions for the table. Bye default these + are computed automatically from the width of the columns + under org-mode. + +The general parameters :skip and :skipcols have already been applied when +this function is called." + (let* ((total (float (apply '+ org-table-last-column-widths))) + (colfrac (or (plist-get params :cf) + (mapconcat + (lambda (x) (format "%.3f" (/ (float x) total))) + org-table-last-column-widths " "))) + (params2 + (list + :tstart (concat "@multitable @columnfractions " colfrac) + :tend "@end multitable" + :lstart "@item " :lend "" :sep " @tab " + :hlstart "@headitem "))) + (orgtbl-to-generic table (org-combine-plists params2 params)))) -(defun org-agenda-post-command-hook () - (and (eolp) (not (bolp)) (backward-char 1)) - (setq org-agenda-type (get-text-property (point) 'org-agenda-type)) - (if (and org-agenda-follow-mode - (get-text-property (point) 'org-marker)) - (org-agenda-show))) +;;;; Link Stuff -(defvar org-disable-agenda-to-diary nil) ;Dynamically-scoped param. +;;; Link abbreviations -(defun org-get-entries-from-diary (date) - "Get the (Emacs Calendar) diary entries for DATE." - (let* ((fancy-diary-buffer "*temporary-fancy-diary-buffer*") - (diary-display-hook '(fancy-diary-display)) - (list-diary-entries-hook - (cons 'org-diary-default-entry list-diary-entries-hook)) - (diary-file-name-prefix-function nil) ; turn this feature off - (diary-modify-entry-list-string-function 'org-modify-diary-entry-string) - entries - (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)) - (setq entries nil) - (with-current-buffer fancy-diary-buffer - (setq buffer-read-only nil) - (if (= (point-max) 1) - ;; 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) - (setq entries nil) - (setq entries (buffer-substring (point-min) (- (point-max) 1))))) - (set-buffer-modified-p nil) - (kill-buffer fancy-diary-buffer))) - (when entries - (setq entries (org-split-string entries "\n")) - (setq entries - (mapcar - (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))) - entries))))) +(defun org-link-expand-abbrev (link) + "Apply replacements as defined in `org-link-abbrev-alist." + (if (string-match "^\\([a-zA-Z]+\\)\\(::?\\(.*\\)\\)?$" link) + (let* ((key (match-string 1 link)) + (as (or (assoc key org-link-abbrev-alist-local) + (assoc key org-link-abbrev-alist))) + (tag (and (match-end 2) (match-string 3 link))) + rpl) + (if (not as) + link + (setq rpl (cdr as)) + (cond + ((symbolp rpl) (funcall rpl tag)) + ((string-match "%s" rpl) (replace-match (or tag "") t t rpl)) + (t (concat rpl tag))))) + link)) -(defun org-agenda-cleanup-fancy-diary () - "Remove unwanted stuff in buffer created by `fancy-diary-display'. -This gets rid of the date, the underline under the date, and -the dummy entry installed by `org-mode' to ensure non-empty diary for each -date. It also removes lines that contain only whitespace." - (goto-char (point-min)) - (if (looking-at ".*?:[ \t]*") - (progn - (replace-match "") - (re-search-forward "\n=+$" nil t) - (replace-match "") - (while (re-search-backward "^ +\n?" nil t) (replace-match ""))) - (re-search-forward "\n=+$" nil t) - (delete-region (point-min) (min (point-max) (1+ (match-end 0))))) - (goto-char (point-min)) - (while (re-search-forward "^ +\n" nil t) - (replace-match "")) - (goto-char (point-min)) - (if (re-search-forward "^Org-mode dummy\n?" nil t) - (replace-match ""))) +;;; Storing and inserting links -;; Make sure entries from the diary have the right text properties. -(eval-after-load "diary-lib" - '(if (boundp 'diary-modify-entry-list-string-function) - ;; We can rely on the hook, nothing to do - nil - ;; Hook not avaiable, must use advice to make this work - (defadvice add-to-diary-list (before org-mark-diary-entry activate) - "Make the position visible." - (if (and org-disable-agenda-to-diary ;; called from org-agenda - (stringp string) - buffer-file-name) - (setq string (org-modify-diary-entry-string string)))))) +(defvar org-insert-link-history nil + "Minibuffer history for links inserted with `org-insert-link'.") -(defun org-modify-diary-entry-string (string) - "Add text properties to string, allowing org-mode to act on it." - (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)) - 'org-agenda-diary-link t - 'org-marker (org-agenda-new-marker (point-at-bol)))) +(defvar org-stored-links nil + "Contains the links stored with `org-store-link'.") -(defun org-diary-default-entry () - "Add a dummy entry to the diary. -Needed to avoid empty dates which mess up holiday display." - ;; Catch the error if dealing with the new add-to-diary-alist - (when org-disable-agenda-to-diary - (condition-case nil - (add-to-diary-list original-date "Org-mode dummy" "") - (error - (add-to-diary-list original-date "Org-mode dummy" "" nil))))) +(defvar org-store-link-plist nil + "Plist with info about the most recently link created with `org-store-link'.") ;;;###autoload -(defun org-cycle-agenda-files () - "Cycle through the files in `org-agenda-files'. -If the current buffer visits an agenda file, find the next one in the list. -If the current buffer does not, find the first agenda file." - (interactive) - (let* ((fs (org-agenda-files t)) - (files (append fs (list (car fs)))) - (tcf (if buffer-file-name (file-truename buffer-file-name))) - file) - (unless files (error "No agenda files")) - (catch 'exit - (while (setq file (pop files)) - (if (equal (file-truename file) tcf) - (when (car files) - (find-file (car files)) - (throw 'exit t)))) - (find-file (car fs))))) - -(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." +(defun org-store-link (arg) + "\\Store an org-link to the current location. +This link 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") - (let ((file-alist (mapcar (lambda (x) - (cons (file-truename x) x)) - (org-agenda-files t))) - (ctf (file-truename buffer-file-name)) - x had) - (setq x (assoc ctf file-alist) had x) - - (if (not x) (setq x (cons ctf (abbreviate-file-name buffer-file-name)))) - (if to-end - (setq file-alist (append (delq x file-alist) (list x))) - (setq file-alist (cons x (delq x file-alist)))) - (org-store-new-agenda-file-list (mapcar 'cdr file-alist)) - (org-install-agenda-files-menu) - (message "File %s to %s of agenda file list" - (if had "moved" "added") (if to-end "end" "front")))) + (setq org-store-link-plist nil) ; reset + (let (link cpltxt desc description search txt) + (cond -(defun org-remove-file (&optional file) - "Remove current file from the list of files in variable `org-agenda-files'. -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)) - (true-file (file-truename file)) - (afile (abbreviate-file-name file)) - (files (delq nil (mapcar - (lambda (x) - (if (equal true-file - (file-truename x)) - nil x)) - (org-agenda-files t))))) - (if (not (= (length files) (length (org-agenda-files t)))) - (progn - (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)))) + ((eq major-mode 'bbdb-mode) + (let ((name (bbdb-record-name (bbdb-current-record))) + (company (bbdb-record-company (bbdb-current-record)))) + (setq cpltxt (concat "bbdb:" (or name company)) + link (org-make-link cpltxt)) + (org-store-link-props :type "bbdb" :name name :company company))) + + ((eq major-mode 'Info-mode) + (setq link (org-make-link "info:" + (file-name-nondirectory Info-current-file) + ":" Info-current-node)) + (setq cpltxt (concat (file-name-nondirectory Info-current-file) + ":" Info-current-node)) + (org-store-link-props :type "info" :file Info-current-file + :node Info-current-node)) -(defun org-file-menu-entry (file) - (vector file (list 'find-file file) t)) + ((eq major-mode 'calendar-mode) + (let ((cd (calendar-cursor-to-date))) + (setq link + (format-time-string + (car org-time-stamp-formats) + (apply 'encode-time + (list 0 0 0 (nth 1 cd) (nth 0 cd) (nth 2 cd) + nil nil nil)))) + (org-store-link-props :type "calendar" :date cd))) -(defun org-get-all-dates (beg end &optional no-ranges force-today inactive empty) - "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)) - dates dates1 date day day1 day2 ts1 ts2) - (if force-today - (setq dates (list (time-to-days (current-time))))) - (save-excursion - (goto-char beg) - (while (re-search-forward re end t) - (setq day (time-to-days (org-time-string-to-time - (substring (match-string 1) 0 10)))) - (or (memq day dates) (push day dates))) - (unless no-ranges - (goto-char beg) - (while (re-search-forward org-tr-regexp end t) - (setq ts1 (substring (match-string 1) 0 10) - ts2 (substring (match-string 2) 0 10) - day1 (time-to-days (org-time-string-to-time ts1)) - day2 (time-to-days (org-time-string-to-time ts2))) - (while (< (setq day1 (1+ day1)) day2) - (or (memq day1 dates) (push day1 dates))))) - (setq dates (sort dates '<)) - (when empty - (while (setq day (pop dates)) - (setq day2 (car dates)) - (push day dates1) - (when (and day2 empty) - (if (or (eq empty t) - (and (numberp empty) (<= (- day2 day) empty))) - (while (< (setq day (1+ day)) day2) - (push (list day) dates1)) - (push (cons :omitted (- day2 day)) dates1)))) - (setq dates (nreverse dates1))) - dates))) + ((or (eq major-mode 'vm-summary-mode) + (eq major-mode 'vm-presentation-mode)) + (and (eq major-mode 'vm-presentation-mode) (vm-summarize)) + (vm-follow-summary-cursor) + (save-excursion + (vm-select-folder-buffer) + (let* ((message (car vm-message-pointer)) + (folder buffer-file-name) + (subject (vm-su-subject message)) + (to (vm-get-header-contents message "To")) + (from (vm-get-header-contents message "From")) + (message-id (vm-su-message-id message))) + (org-store-link-props :type "vm" :from from :to to :subject subject + :message-id message-id) + (setq message-id (org-remove-angle-brackets message-id)) + (setq folder (abbreviate-file-name folder)) + (if (string-match (concat "^" (regexp-quote vm-folder-directory)) + folder) + (setq folder (replace-match "" t t folder))) + (setq cpltxt (org-email-link-description)) + (setq link (org-make-link "vm:" folder "#" message-id))))) -;;;###autoload -(defun org-diary (&rest args) - "Return diary information from org-files. -This function can be used in a \"sexp\" diary entry in the Emacs calendar. -It accesses org files and extracts information from those files to be -listed in the diary. The function accepts arguments specifying what -items should be listed. The following arguments are allowed: + ((eq major-mode 'wl-summary-mode) + (let* ((msgnum (wl-summary-message-number)) + (message-id (elmo-message-field wl-summary-buffer-elmo-folder + msgnum 'message-id)) + (wl-message-entity + (if (fboundp 'elmo-message-entity) + (elmo-message-entity + wl-summary-buffer-elmo-folder msgnum) + (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) + (wl-summary-line-subject)))) + (org-store-link-props :type "wl" :from from :to to + :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 "wl:" wl-summary-buffer-folder-name + "#" message-id)))) - :timestamp List the headlines of items containing a date stamp or - date range matching the selected date. Deadlines will - also be listed, on the expiration day. + ((or (equal major-mode 'mh-folder-mode) + (equal major-mode 'mh-show-mode)) + (let ((from (org-mhe-get-header "From:")) + (to (org-mhe-get-header "To:")) + (message-id (org-mhe-get-header "Message-Id:")) + (subject (org-mhe-get-header "Subject:"))) + (org-store-link-props :type "mh" :from from :to to + :subject subject :message-id message-id) + (setq cpltxt (org-email-link-description)) + (setq link (org-make-link "mhe:" (org-mhe-get-message-real-folder) "#" + (org-remove-angle-brackets message-id))))) - :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 - an entry is marked DONE, it is no longer listed. + ((eq major-mode 'rmail-mode) + (save-excursion + (save-restriction + (rmail-narrow-to-non-pruned-header) + (let ((folder buffer-file-name) + (message-id (mail-fetch-field "message-id")) + (from (mail-fetch-field "from")) + (to (mail-fetch-field "to")) + (subject (mail-fetch-field "subject"))) + (org-store-link-props + :type "rmail" :from from :to to + :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)))))) - :scheduled List all items which are scheduled for the given date. - The diary for *today* also contains items which were - scheduled earlier and are not yet marked DONE. + ((eq major-mode 'gnus-group-mode) + (let ((group (cond ((fboundp 'gnus-group-group-name) ; depending on Gnus + (gnus-group-group-name)) ; version + ((fboundp 'gnus-group-name) + (gnus-group-name)) + (t "???")))) + (unless group (error "Not on a group")) + (org-store-link-props :type "gnus" :group group) + (setq cpltxt (concat + (if (org-xor arg org-usenet-links-prefer-google) + "http://groups.google.com/groups?group=" + "gnus:") + group) + link (org-make-link cpltxt)))) - :todo List all TODO items from the org-file. This may be a - long list - so this is not turned on by default. - Like deadlines, these entries only show up in the - diary for *today*, not at any other date. + ((memq major-mode '(gnus-summary-mode gnus-article-mode)) + (and (eq major-mode 'gnus-article-mode) (gnus-article-show-summary)) + (let* ((group gnus-newsgroup-name) + (article (gnus-summary-article-number)) + (header (gnus-summary-article-header article)) + (from (mail-header-from header)) + (message-id (mail-header-id header)) + (date (mail-header-date header)) + (subject (gnus-summary-subject-string))) + (org-store-link-props :type "gnus" :from from :subject subject + :message-id message-id :group group) + (setq cpltxt (org-email-link-description)) + (if (org-xor arg org-usenet-links-prefer-google) + (setq link + (concat + cpltxt "\n " + (format "http://groups.google.com/groups?as_umsgid=%s" + (org-fixup-message-id-for-http message-id)))) + (setq link (org-make-link "gnus:" group + "#" (number-to-string article)))))) -The call in the diary file should look like this: + ((eq major-mode 'w3-mode) + (setq cpltxt (url-view-url t) + link (org-make-link cpltxt)) + (org-store-link-props :type "w3" :url (url-view-url t))) - &%%(org-diary) ~/path/to/some/orgfile.org + ((eq major-mode 'w3m-mode) + (setq cpltxt (or w3m-current-title w3m-current-url) + link (org-make-link w3m-current-url)) + (org-store-link-props :type "w3m" :url (url-view-url t))) -Use a separate line for each org file to check. Or, if you omit the file name, -all files listed in `org-agenda-files' will be checked automatically: + ((setq search (run-hook-with-args-until-success + 'org-create-file-search-functions)) + (setq link (concat "file:" (abbreviate-file-name buffer-file-name) + "::" search)) + (setq cpltxt (or description link))) - &%%(org-diary) + ((eq major-mode 'image-mode) + (setq cpltxt (concat "file:" + (abbreviate-file-name buffer-file-name)) + link (org-make-link cpltxt)) + (org-store-link-props :type "image" :file buffer-file-name)) -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 + ((eq major-mode 'dired-mode) + ;; link to the file in the current line + (setq cpltxt (concat "file:" + (abbreviate-file-name + (expand-file-name + (dired-get-filename nil t)))) + link (org-make-link cpltxt))) - &%%(org-diary :deadline :timestamp :scheduled) + ((and buffer-file-name (org-mode-p)) + ;; Just link to current headline + (setq cpltxt (concat "file:" + (abbreviate-file-name buffer-file-name))) + ;; Add a context search string + (when (org-xor org-context-in-file-links arg) + ;; Check if we are on a target + (if (org-in-regexp "<<\\(.*?\\)>>") + (setq cpltxt (concat cpltxt "::" (match-string 1))) + (setq txt (cond + ((org-on-heading-p) nil) + ((org-region-active-p) + (buffer-substring (region-beginning) (region-end))) + (t (buffer-substring (point-at-bol) (point-at-eol))))) + (when (or (null txt) (string-match "\\S-" txt)) + (setq cpltxt + (concat cpltxt "::" (org-make-org-heading-search-string txt)) + desc "NONE")))) + (if (string-match "::\\'" cpltxt) + (setq cpltxt (substring cpltxt 0 -2))) + (setq link (org-make-link cpltxt))) + + (buffer-file-name + ;; Just link to this file here. + (setq cpltxt (concat "file:" + (abbreviate-file-name buffer-file-name))) + ;; Add a context string + (when (org-xor org-context-in-file-links arg) + (setq txt (if (org-region-active-p) + (buffer-substring (region-beginning) (region-end)) + (buffer-substring (point-at-bol) (point-at-eol)))) + ;; Only use search option if there is some text. + (when (string-match "\\S-" txt) + (setq cpltxt + (concat cpltxt "::" (org-make-org-heading-search-string txt)) + desc "NONE"))) + (setq link (org-make-link cpltxt))) -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) - (org-compile-prefix-format 'agenda) - (org-set-sorting-strategy 'agenda) - (setq args (or args '(:deadline :scheduled :timestamp))) - (let* ((files (if (and entry (stringp entry) (string-match "\\S-" entry)) - (list entry) - (org-agenda-files t))) - file rtn results) - ;; 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)) - (while (setq file (pop files)) - (setq rtn (apply 'org-agenda-get-day-entries file date args)) - (setq results (append results rtn))) - (if results - (concat (org-finalize-agenda-entries results) "\n")))) -(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)))))) + ((interactive-p) + (error "Cannot link to a buffer which is not visiting a file")) -(defun org-agenda-get-day-entries (file date &rest args) - "Does the work for `org-diary' and `org-agenda'. -FILE is the path to a file to be checked for entries. DATE is date like -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))) - (let* ((org-startup-with-deadline-check nil) - (org-startup-folded nil) - (org-startup-align-all-tables nil) - (buffer (if (file-exists-p file) - (org-get-agenda-file-buffer file) - (error "No such file %s" file))) - arg results rtn) - (if (not buffer) - ;; If file does not exist, make sure an error message ends up in diary - (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)) - (setq org-category-table (org-get-category-table)) - (let ((case-fold-search nil)) - (save-excursion - (save-restriction - (if org-agenda-restrict - (narrow-to-region org-agenda-restrict-begin - org-agenda-restrict-end) - (widen)) - ;; The way we repeatedly append to `results' makes it O(n^2) :-( - (while (setq arg (pop args)) - (cond - ((and (eq arg :todo) - (equal date (calendar-current-date))) - (setq rtn (org-agenda-get-todos)) - (setq results (append results rtn))) - ((eq arg :timestamp) - (setq rtn (org-agenda-get-blocks)) - (setq results (append results rtn)) - (setq rtn (org-agenda-get-timestamps)) - (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))) - (setq rtn (org-agenda-get-deadlines)) - (setq results (append results rtn)))))))) - results)))) + (t (setq link nil))) -(defun org-entry-is-done-p () - "Is the current entry marked DONE?" - (save-excursion - (and (re-search-backward "[\r\n]\\*" nil t) - (looking-at org-nl-done-regexp)))) + (if (consp link) (setq cpltxt (car link) link (cdr link))) + (setq link (or link cpltxt) + desc (or desc cpltxt)) + (if (equal desc "NONE") (setq desc nil)) -(defun org-at-date-range-p (&optional inactive-ok) - "Is the cursor inside a date range?" + (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)))) + +(defun org-store-link-props (&rest plist) + "Store link properties, extract names and addresses." + (let (x adr) + (when (setq x (plist-get plist :from)) + (setq adr (mail-extract-address-components x)) + (plist-put plist :fromname (car adr)) + (plist-put plist :fromaddress (nth 1 adr))) + (when (setq x (plist-get plist :to)) + (setq adr (mail-extract-address-components x)) + (plist-put plist :toname (car adr)) + (plist-put plist :toaddress (nth 1 adr)))) + (let ((from (plist-get plist :from)) + (to (plist-get plist :to))) + (when (and from to org-from-is-user-regexp) + (plist-put plist :fromto + (if (string-match org-from-is-user-regexp from) + (concat "to %t") + (concat "from %f"))))) + (setq org-store-link-plist plist)) + +(defun org-email-link-description (&optional fmt) + "Return the description part of an email link. +This takes information from `org-store-link-plist' and formats it +according to FMT (default from `org-email-link-description-format')." + (setq fmt (or fmt org-email-link-description-format)) + (let* ((p org-store-link-plist) + (to (plist-get p :toaddress)) + (from (plist-get p :fromaddress)) + (table + (list + (cons "%c" (plist-get p :fromto)) + (cons "%F" (plist-get p :from)) + (cons "%f" (or (plist-get p :fromname) (plist-get p :fromaddress) "?")) + (cons "%T" (plist-get p :to)) + (cons "%t" (or (plist-get p :toname) (plist-get p :toaddress) "?")) + (cons "%s" (plist-get p :subject)) + (cons "%m" (plist-get p :message-id))))) + (when (string-match "%c" fmt) + ;; Check if the user wrote this message + (if (and org-from-is-user-regexp from to + (save-match-data (string-match org-from-is-user-regexp from))) + (setq fmt (replace-match "to %t" t t fmt)) + (setq fmt (replace-match "from %f" t t fmt)))) + (org-replace-escapes fmt table))) + +(defun org-make-org-heading-search-string (&optional string heading) + "Make search string for STRING or current headline." (interactive) - (save-excursion - (catch 'exit - (let ((pos (point))) - (skip-chars-backward "^[<\r\n") - (skip-chars-backward "<[") - (and (looking-at (if inactive-ok org-tr-regexp-both org-tr-regexp)) - (>= (match-end 0) pos) - (throw 'exit t)) - (skip-chars-backward "^<[\r\n") - (skip-chars-backward "<[") - (and (looking-at (if inactive-ok org-tr-regexp-both org-tr-regexp)) - (>= (match-end 0) pos) - (throw 'exit t))) - nil))) + (let ((s (or string (org-get-heading)))) + (unless (and string (not heading)) + ;; 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) + (setq s (replace-match "" t t s))) + (setq s (org-trim s)) + (if (string-match (concat "^\\(" org-quote-string "\\|" + org-comment-string "\\)") s) + (setq s (replace-match "" t t s))) + (while (string-match org-ts-regexp s) + (setq s (replace-match "" t t s)))) + (while (string-match "[^a-zA-Z_0-9 \t]+" s) + (setq s (replace-match " " t t s))) + (or string (setq s (concat "*" s))) ; Add * for headlines + (mapconcat 'identity (org-split-string s "[ \t]+") " "))) -(defun org-agenda-get-todos () - "Return the TODO information for agenda display." - (let* ((props (list 'face nil - 'done-face 'org-done - 'org-not-done-regexp org-not-done-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]\\*+ *\\(" - (if org-select-this-todo-keyword - (concat "\\<\\(" org-select-this-todo-keyword - "\\)\\>") - org-not-done-regexp) - "[^\n\r]*\\)")) - (deadline-re (concat ".*\\(\n[^*].*\\)?" org-deadline-time-regexp)) - (sched-re (concat ".*\\(\n[^*].*\\)?" org-scheduled-time-regexp)) -; FIXME why was this wrong? (sched-re (concat ".*\n?.*?" org-scheduled-time-regexp)) - marker priority category tags - ee txt) - (goto-char (point-min)) - (while (re-search-forward regexp nil t) - (catch :skip - (save-match-data - (beginning-of-line) - (when (or (and org-agenda-todo-ignore-scheduled - (looking-at sched-re)) - (and org-agenda-todo-ignore-deadlines - (looking-at deadline-re) - (org-deadline-close (match-string 2)))) +(defun org-make-link (&rest strings) + "Concatenate STRINGS, format resulting string with `org-link-format'." + (apply 'concat strings)) - ;; FIXME: the following test also happens below, but we need it here - (or org-agenda-todo-list-sublevels (org-end-of-subtree 'invisible)) - (throw :skip nil))) - (org-agenda-skip) - (goto-char (match-beginning 1)) - (setq marker (org-agenda-new-marker (1+ (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))) - (org-add-props txt props - 'org-marker marker 'org-hd-marker marker - 'priority priority 'org-category category) - (push txt ee) - (if org-agenda-todo-list-sublevels - (goto-char (match-end 1)) - (org-end-of-subtree 'invisible)))) - (nreverse ee))) +(defun org-make-link-string (link &optional description) + "Make a link with brackets, consisting of LINK and DESCRIPTION." + (when (stringp description) + ;; Remove brackets from the description, they are fatal. + (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)) + (when (and (not description) + (not (equal link (org-link-escape link)))) + (setq description link)) + (concat "[[" (org-link-escape link) "]" + (if description (concat "[" description "]") "") + "]")) -(defconst org-agenda-no-heading-message - "No heading for this item in buffer or region.") +(defconst org-link-escape-chars '(("[" . "%5B") ("]" . "%5D") (" " . "%20")) + "Association list of escapes for some characters problematic in links.") -(defun org-agenda-get-timestamps () - "Return the date stamp information for agenda display." - (let* ((props (list 'face nil - 'org-not-done-regexp org-not-done-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))) - marker hdmarker deadlinep scheduledp donep tmp priority category - ee txt timestr tags) - (goto-char (point-min)) - (while (re-search-forward regexp nil t) - (catch :skip - (and (save-match-data (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)) - 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)) - deadlinep (string-match org-deadline-regexp tmp) - scheduledp (string-match org-scheduled-regexp tmp) - donep (org-entry-is-done-p)) - (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) - (progn - (goto-char (match-end 1)) - (setq hdmarker (org-agenda-new-marker) - tags (org-get-tags-at)) - (looking-at "\\*+[ \t]*\\([^\r\n]+\\)") - (setq txt (org-format-agenda-item - (format "%s%s" - (if deadlinep "Deadline: " "") - (if scheduledp "Scheduled: " "")) - (match-string 1) category tags timestr))) - (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))) - (push txt ee)) - (outline-next-heading))) - (nreverse ee))) +(defun org-link-escape (text) + "Escape charaters in TEXT that are problematic for links." + (when text + (let ((re (mapconcat (lambda (x) (regexp-quote (car x))) + org-link-escape-chars "\\|"))) + (while (string-match re text) + (setq text + (replace-match + (cdr (assoc (match-string 0 text) org-link-escape-chars)) + t t text))) + text))) -(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 - 'keymap org-agenda-keymap - 'help-echo - (format "mouse-2 or RET jump to org file %s" - (abbreviate-file-name buffer-file-name)))) - (regexp (concat - "\\<\\(" org-closed-string "\\|" org-clock-string "\\) *\\[" - (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)))) - 1 11)))) - marker hdmarker priority category tags closedp - ee txt timestr) +(defun org-link-unescape (text) + "Reverse the action of `org-link-escape'." + (when text + (let ((re (mapconcat (lambda (x) (regexp-quote (cdr x))) + org-link-escape-chars "\\|"))) + (while (string-match re text) + (setq text + (replace-match + (car (rassoc (match-string 0 text) org-link-escape-chars)) + t t text))) + text))) + +(defun org-xor (a b) + "Exclusive or." + (if a (not b) b)) + +(defun org-get-header (header) + "Find a header field in the current buffer." + (save-excursion (goto-char (point-min)) - (while (re-search-forward regexp nil t) - (catch :skip - (org-agenda-skip) - (setq marker (org-agenda-new-marker (match-beginning 0)) - closedp (equal (match-string 1) org-closed-string) - category (org-get-category (match-beginning 0)) - timestr (buffer-substring (match-beginning 0) (point-at-eol)) - ;; donep (org-entry-is-done-p) - ) - (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) - (progn - (goto-char (match-end 1)) - (setq hdmarker (org-agenda-new-marker) - tags (org-get-tags-at)) - (looking-at "\\*+[ \t]*\\([^\r\n]+\\)") - (setq txt (org-format-agenda-item - (if closedp "Closed: " "Clocked: ") - (match-string 1) category tags timestr))) - (setq txt org-agenda-no-heading-message)) - (setq priority 100000) - (org-add-props txt props - 'org-marker marker 'org-hd-marker hdmarker 'face 'org-done - 'priority priority 'org-category category - 'undone-face 'org-warning 'done-face 'org-done) - (push txt ee)) - (outline-next-heading))) - (nreverse ee))) + (let ((case-fold-search t) s) + (cond + ((eq header 'from) + (if (re-search-forward "^From:\\s-+\\(.*\\)" nil t) + (setq s (match-string 1))) + (while (string-match "\"" s) + (setq s (replace-match "" t t s))) + (if (string-match "[<(].*" s) + (setq s (replace-match "" t t s)))) + ((eq header 'message-id) + (if (re-search-forward "^message-id:\\s-+\\(.*\\)" nil t) + (setq s (match-string 1)))) + ((eq header 'subject) + (if (re-search-forward "^subject:\\s-+\\(.*\\)" nil t) + (setq s (match-string 1))))) + (if (string-match "\\`[ \t\]+" s) (setq s (replace-match "" t t s))) + (if (string-match "[ \t\]+\\'" s) (setq s (replace-match "" t t s))) + s))) -(defun org-agenda-get-deadlines () - "Return the deadline information for agenda display." - (let* ((wdays org-deadline-warning-days) - (props (list 'mouse-face 'highlight - 'org-not-done-regexp org-not-done-regexp - 'keymap org-agenda-keymap - 'help-echo - (format "mouse-2 or RET jump to org file %s" - (abbreviate-file-name buffer-file-name)))) - (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) - (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)) - ;; 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))) - (save-excursion - (setq category (org-get-category)) - (if (re-search-backward "\\(^\\|\r\\)\\*+[ \t]*" nil t) - (progn - (goto-char (match-end 0)) - (setq pos1 (match-end 1)) - (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 txt nil) - (setq txt (org-format-agenda-item - (format "In %3d d.: " diff) head category tags)))) - (setq txt org-agenda-no-heading-message)) - (when txt - (setq face (cond ((<= diff 0) 'org-warning) - ((<= diff 5) 'org-upcoming-deadline) - (t nil))) - (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)) - 'org-category category - 'face face 'undone-face face 'done-face 'org-done) - (push txt ee)))))) - ee)) -(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 - 'done-face 'org-done - '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 org-scheduled-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) - (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)) - ;; When to show a scheduled item in the calendar: - ;; If it is on or past the date. - (if (and (< diff 0) todayp) - (save-excursion - (setq category (org-get-category)) - (if (re-search-backward "\\(^\\|\r\\)\\*+[ \t]*" nil t) - (progn - (goto-char (match-end 0)) - (setq pos1 (match-end 1)) - (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 txt nil) - (setq txt (org-format-agenda-item - (format "Sched.%2dx: " (- 1 diff)) head - category tags)))) - (setq txt org-agenda-no-heading-message)) - (when txt - (org-add-props txt props - 'org-marker (org-agenda-new-marker pos) - 'org-hd-marker (org-agenda-new-marker pos1) - 'priority (+ (- 5 diff) (org-get-priority txt)) - 'org-category category) - (push txt ee)))))) - ee)) +(defun org-fixup-message-id-for-http (s) + "Replace special characters in a message id, so it can be used in an http query." + (while (string-match "<" s) + (setq s (replace-match "%3C" t t s))) + (while (string-match ">" s) + (setq s (replace-match "%3E" t t s))) + (while (string-match "@" s) + (setq s (replace-match "%40" t t s))) + s) -(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 - '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 org-tr-regexp) - (d0 (calendar-absolute-from-gregorian date)) - marker hdmarker ee txt d1 d2 s1 s2 timestr category tags pos) - (goto-char (point-min)) - (while (re-search-forward regexp nil t) - (catch :skip - (org-agenda-skip) - (setq pos (point)) - (setq timestr (match-string 0) - s1 (match-string 1) - s2 (match-string 2) - d1 (time-to-days (org-time-string-to-time s1)) - d2 (time-to-days (org-time-string-to-time s2))) - (if (and (> (- d0 d1) -1) (> (- d2 d0) -1)) - ;; Only allow days between the limits, because the normal - ;; date stamps will catch the limits. - (save-excursion - (setq marker (org-agenda-new-marker (point))) - (setq category (org-get-category)) - (if (re-search-backward "\\(^\\|\r\\)\\*+" nil t) - (progn - (setq hdmarker (org-agenda-new-marker (match-end 1))) - (goto-char (match-end 1)) - (setq tags (org-get-tags-at)) - (looking-at "\\*+[ \t]*\\([^\r\n]+\\)") - (setq txt (org-format-agenda-item - (format (if (= d1 d2) "" "(%d/%d): ") - (1+ (- d0 d1)) (1+ (- d2 d1))) - (match-string 1) 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 - 'priority (org-get-priority txt) 'org-category category) - (push txt ee))) - (goto-char pos))) - ;; Sort the entries by expiration date. - (nreverse ee))) +(defun org-insert-link (&optional complete-file) + "Insert a link. At the prompt, enter the link. -(defconst org-plain-time-of-day-regexp - (concat - "\\(\\<[012]?[0-9]" - "\\(\\(:\\([0-5][0-9]\\([AaPp][Mm]\\)?\\)\\)\\|\\([AaPp][Mm]\\)\\)\\>\\)" - "\\(--?" - "\\(\\<[012]?[0-9]" - "\\(\\(:\\([0-5][0-9]\\([AaPp][Mm]\\)?\\)\\)\\|\\([AaPp][Mm]\\)\\)\\>\\)" - "\\)?") - "Regular expression to match a plain time or time range. -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.") +Completion can be used to select a link previously stored with +`org-store-link'. When the empty string is entered (i.e. if you just +press RET at the prompt), the link defaults to the most recently +stored link. As SPC triggers completion in the minibuffer, you need to +use M-SPC or C-q SPC to force the insertion of a space character. -(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]\\)>" - "\\(--?" - "<\\1\\([012][0-9]:[0-5][0-9]\\)>\\)?") - "Regular expression to match a timestamp time or time range. -After a match, the following groups carry important information: -0 the full match -1 date plus weekday, for backreferencing to make sure both times on same day -2 the first time, range or not -4 the second time, if it is a range.") +You will also be prompted for a description, and if one is given, it will +be displayed in the buffer instead of the link. -(defvar org-prefix-has-time nil - "A flag, set by `org-compile-prefix-format'. -The flag is set if the currently compiled format contains a `%t'.") -(defvar org-prefix-has-tag nil - "A flag, set by `org-compile-prefix-format'. -The flag is set if the currently compiled format contains a `%T'.") +If there is already a link at point, this command will allow you to edit link +and description parts. -(defun org-format-agenda-item (extra txt &optional category tags dotime - noprefix) - "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. -CATEGORY (string, symbol or nil) may be used to overrule the default -category taken from local variable or file name. It will replace the `%c' -specifier in the format. DOTIME, when non-nil, indicates that a -time-of-day should be extracted from TXT for sorting of this entry, and for -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." - (save-match-data - ;; Diary entries sometimes have extra whitespace at the beginning - (if (string-match "^ +" txt) (setq txt (replace-match "" nil nil txt))) - (let* ((category (or category - org-category - (if buffer-file-name - (file-name-sans-extension - (file-name-nondirectory buffer-file-name)) - ""))) - (tag (if tags (nth (1- (length tags)) tags) "")) - time ;; 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) - (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) - s1 (match-string (if plain 1 2) ts) - s2 (match-string (if plain 8 4) ts)) +With a \\[universal-argument] prefix, prompts for a file to link to. The file name can be +selected using completion. The path to the file will be relative to +the current directory if the file is in the current directory or a +subdirectory. Otherwise, the link will be the absolute path as +completed in the minibuffer (i.e. normally ~/path/to/file). - ;; 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) - (if (eq org-agenda-remove-times-when-in-prefix 'beg) - (= (match-beginning 0) 0) - t)) - (setq txt (replace-match "" nil nil txt)))) - ;; Normalize the time(s) to 24 hour - (if s1 (setq s1 (org-get-time-of-day s1 'string t))) - (if s2 (setq s2 (org-get-time-of-day s2 'string t)))) +With two \\[universal-argument] prefixes, enforce an absolute path even if the file +is in the current directory or below. +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) + (cond + ((org-in-regexp org-bracket-link-regexp 1) + ;; We do have a link at point, and we are going to edit it. + (setq remove (list (match-beginning 0) (match-end 0))) + (setq desc (if (match-end 3) (org-match-string-no-properties 3))) + (setq link (read-string "Link: " + (org-link-unescape + (org-match-string-no-properties 1))))) + ((or (org-in-regexp org-angle-link-re) + (org-in-regexp org-plain-link-re)) + ;; Convert to bracket link + (setq remove (list (match-beginning 0) (match-end 0)) + link (read-string "Link: " + (org-remove-angle-brackets (match-string 0))))) + ((equal complete-file '(4)) + ;; Completing read for file names. + (setq file (read-file-name "File: ")) + (let ((pwd (file-name-as-directory (expand-file-name "."))) + (pwd1 (file-name-as-directory (abbreviate-file-name + (expand-file-name "."))))) + (cond + ((equal complete-file '(16)) + (setq link (org-make-link + "file:" + (abbreviate-file-name (expand-file-name file))))) + ((string-match (concat "^" (regexp-quote pwd1) "\\(.+\\)") file) + (setq link (org-make-link "file:" (match-string 1 file)))) + ((string-match (concat "^" (regexp-quote pwd) "\\(.+\\)") + (expand-file-name file)) + (setq link (org-make-link + "file:" (match-string 1 (expand-file-name file))))) + (t (setq link (org-make-link "file:" file)))))) + (t + ;; Read link, with completion for stored links. + ;; Fake a link history + (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))))) + (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))))) - (when (string-match "\\([ \t]+\\)\\(:[a-zA-Z_@0-9:]+:\\)[ \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 - org-prefix-has-tag)) - (setq txt (replace-match "" t t txt)) - (setq txt (replace-match - (concat (make-string (max (- 50 (length txt)) 1) ?\ ) - (match-string 2 txt)) - t t txt)))) + (if (string-match org-plain-link-re link) + ;; URL-like link, normalize the use of angular brackets. + (setq link (org-make-link (org-remove-angle-brackets link)))) - ;; Create the final string - (if noprefix - (setq rtn txt) - ;; Prepare the variables needed in the eval of the compiled format - (setq time (cond (s2 (concat s1 "-" s2)) - (s1 (concat s1 "......")) - (t "")) - extra (or extra "") - category (if (symbolp category) (symbol-name category) category)) - ;; Evaluate the compiled format - (setq rtn (concat (eval org-prefix-format-compiled) txt))) + ;; Check if we are linking to the current file with a search option + ;; If yes, simplify the link by using only the search option. + (when (and buffer-file-name + (string-match "\\]+\\)" link)) + (let* ((path (match-string 1 link)) + (case-fold-search nil) + (search (match-string 2 link))) + (save-match-data + (if (equal (file-truename buffer-file-name) (file-truename path)) + ;; We are linking to this same file, with a search option + (setq link search))))) - ;; And finally add the text properties - (org-add-props rtn nil - 'org-category (downcase category) 'tags tags - 'prefix-length (- (length rtn) (length txt)) - 'time-of-day time-of-day - 'dotime dotime)))) + ;; Check if we can/should use a relative path. If yes, simplify the link + (when (string-match "\\]?\\)\\([cts]\\)" - s start) - (setq var (cdr (assoc (match-string 4 s) - '(("c" . category) ("t" . time) ("s" . extra) - ("T" . tag)))) - c (or (match-string 3 s) "") - opt (match-beginning 1) - start (1+ (match-beginning 0))) - (if (equal var 'time) (setq org-prefix-has-time t)) - (if (equal var 'tag) (setq org-prefix-has-tag t)) - (setq f (concat "%" (match-string 2 s) "s")) - (if opt - (setq varform - `(if (equal "" ,var) - "" - (format ,f (if (equal "" ,var) "" (concat ,var ,c))))) - (setq varform `(format ,f (if (equal ,var "") "" (concat ,var ,c))))) - (setq s (replace-match "%s" t nil s)) - (push varform vars)) - (setq vars (nreverse vars)) - (setq org-prefix-format-compiled `(format ,s ,@vars)))) +;;; Opening/following a link +(defvar org-link-search-failed nil) -(defun org-set-sorting-strategy (key) - (if (symbolp (car org-agenda-sorting-strategy)) - ;; the old format - (setq org-agenda-sorting-strategy-selected org-agenda-sorting-strategy) - (setq org-agenda-sorting-strategy-selected - (or (cdr (assq key org-agenda-sorting-strategy)) - (cdr (assq 'agenda org-agenda-sorting-strategy)) - '(time-up category-keep priority-down))))) +(defun org-next-link () + "Move forward to the next link. +If the link is in hidden text, expose it." + (interactive) + (when (and org-link-search-failed (eq this-command last-command)) + (goto-char (point-min)) + (message "Link search wrapped back to beginning of buffer")) + (setq org-link-search-failed nil) + (let* ((pos (point)) + (ct (org-context)) + (a (assoc :link ct))) + (if a (goto-char (nth 2 a))) + (if (re-search-forward org-any-link-re nil t) + (progn + (goto-char (match-beginning 0)) + (if (org-invisible-p) (org-show-context))) + (goto-char pos) + (setq org-link-search-failed t) + (error "No further link found")))) -(defun org-get-time-of-day (s &optional string mod24) - "Check string S for a time of day. -If found, return it as a military time number between 0 and 2400. -If not found, return nil. -The optional STRING argument forces conversion into a 5 character wide string -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)) - (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)))) - (am-p (equal ampm "am")) - (h1 (cond ((not ampm) h) - ((= h 12) (if am-p 0 12)) - (t (+ h (if am-p 0 12))))) - (h2 (if (and string mod24 (not (and (= m 0) (= h1 24)))) - (mod h1 24) h1)) - (t0 (+ (* 100 h2) m)) - (t1 (concat (if (>= h1 24) "+" " ") - (if (< t0 100) "0" "") - (if (< t0 10) "0" "") - (int-to-string t0)))) - (if string (concat (substring t1 -4 -2) ":" (substring t1 -2)) t0))))) +(defun org-previous-link () + "Move backward to the previous link. +If the link is in hidden text, expose it." + (interactive) + (when (and org-link-search-failed (eq this-command last-command)) + (goto-char (point-max)) + (message "Link search wrapped back to end of buffer")) + (setq org-link-search-failed nil) + (let* ((pos (point)) + (ct (org-context)) + (a (assoc :link ct))) + (if a (goto-char (nth 1 a))) + (if (re-search-backward org-any-link-re nil t) + (progn + (goto-char (match-beginning 0)) + (if (org-invisible-p) (org-show-context))) + (goto-char pos) + (setq org-link-search-failed t) + (error "No further link found")))) -(defun org-finalize-agenda-entries (list &optional nosort) - "Sort and concatenate the agenda items." - (setq list (mapcar 'org-agenda-highlight-todo list)) - (if nosort - list - (mapconcat 'identity (sort list 'org-entries-lessp) "\n"))) +(defun org-find-file-at-mouse (ev) + "Open file link or URL at mouse." + (interactive "e") + (mouse-set-point ev) + (org-open-at-point 'in-emacs)) -(defun org-agenda-highlight-todo (x) - (let (re pl) - (if (eq x 'line) - (save-excursion - (beginning-of-line 1) - (setq re (get-text-property (point) 'org-not-done-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)) - 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)) - x))) +(defun org-open-at-mouse (ev) + "Open file link or URL at mouse." + (interactive "e") + (mouse-set-point ev) + (org-open-at-point)) -(defsubst org-cmp-priority (a b) - "Compare the priorities of string A and B." - (let ((pa (or (get-text-property 1 'priority a) 0)) - (pb (or (get-text-property 1 'priority b) 0))) - (cond ((> pa pb) +1) - ((< pa pb) -1) - (t nil)))) +(defvar org-window-config-before-follow-link nil + "The window configuration before following a link. +This is saved in case the need arises to restore it.") -(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) ""))) - (cond ((string-lessp ca cb) -1) - ((string-lessp cb ca) +1) - (t nil)))) +(defvar org-open-link-marker (make-marker) + "Marker pointing to the location where `org-open-at-point; was called.") -(defsubst org-cmp-tag (a b) - "Compare the string values of categories of strings A and B." - (let ((ta (car (last (get-text-property 1 'tags a)))) - (tb (car (last (get-text-property 1 'tags b))))) - (cond ((not ta) +1) - ((not tb) -1) - ((string-lessp ta tb) -1) - ((string-lessp tb ta) +1) - (t nil)))) +(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 +the end of the current subtree. +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") + (move-marker org-open-link-marker (point)) + (setq org-window-config-before-follow-link (current-window-configuration)) + (org-remove-occur-highlights nil nil t) + (if (org-at-timestamp-p t) + (org-follow-timestamp-link) + (let (type path link line search (pos (point))) + (catch 'match + (save-excursion + (skip-chars-forward "^]\n\r") + (when (org-in-regexp org-bracket-link-regexp) + (setq link (org-link-unescape (org-match-string-no-properties 1))) + (while (string-match " *\n *" link) + (setq link (replace-match " " t t link))) + (setq link (org-link-expand-abbrev link)) + (if (string-match org-link-re-with-space2 link) + (setq type (match-string 1 link) path (match-string 2 link)) + (setq type "thisfile" path link)) + (throw 'match t))) -(defsubst org-cmp-time (a b) - "Compare the time-of-day values of strings A and B." - (let* ((def (if org-sort-agenda-notime-is-late 9901 -1)) - (ta (or (get-text-property 1 'time-of-day a) def)) - (tb (or (get-text-property 1 'time-of-day b) def))) - (cond ((< ta tb) -1) - ((< tb ta) +1) - (t nil)))) + (when (get-text-property (point) 'org-linked-text) + (setq type "thisfile" + pos (if (get-text-property (1+ (point)) 'org-linked-text) + (1+ (point)) (point)) + path (buffer-substring + (previous-single-property-change pos 'org-linked-text) + (next-single-property-change pos 'org-linked-text))) + (throw 'match t)) -(defun org-entries-lessp (a b) - "Predicate for sorting agenda entries." - ;; The following variables will be used when the form is evaluated. - (let* ((time-up (org-cmp-time a b)) - (time-down (if time-up (- time-up) nil)) - (priority-up (org-cmp-priority a b)) - (priority-down (if priority-up (- priority-up) nil)) - (category-up (org-cmp-category a b)) - (category-down (if category-up (- category-up) nil)) - (category-keep (if category-up +1 nil)) - (tag-up (org-cmp-tag a b)) - (tag-down (if tag-up (- tag-up) nil))) - (cdr (assoc - (eval (cons 'or org-agenda-sorting-strategy-selected)) - '((-1 . t) (1 . nil) (nil . nil)))))) + (save-excursion + (when (or (org-in-regexp org-angle-link-re) + (org-in-regexp org-plain-link-re)) + (setq type (match-string 1) path (match-string 2)) + (throw 'match t))) + (save-excursion + (when (org-in-regexp "\\(:[A-Za-z_@0-9:]+\\):[ \t\r\n]") + (setq type "tags" + path (match-string 1)) + (while (string-match ":" path) + (setq path (replace-match "+" t t path))) + (throw 'match t)))) + (unless path + (error "No link found")) + ;; Remove any trailing spaces in path + (if (string-match " +\\'" path) + (setq path (replace-match "" t t path))) -(defun org-agenda-show-priority () - "Show the priority of the current item. -This priority is composed of the main priority given with the [#A] cookies, -and by additional input from the age of a schedules or deadline entry." - (interactive) - (let* ((pri (get-text-property (point-at-bol) 'priority))) - (message "Priority is %d" (if pri pri -1000)))) + (cond -(defun org-agenda-show-tags () - "Show the tags applicable to the current item." - (interactive) - (let* ((tags (get-text-property (point-at-bol) 'tags))) - (if tags - (message "Tags are :%s:" - (org-no-properties (mapconcat 'identity tags ":"))) - (message "No tags associated with this line")))) + ((equal type "mailto") + (let ((cmd (car org-link-mailto-program)) + (args (cdr org-link-mailto-program)) args1 + (address path) (subject "") a) + (if (string-match "\\(.*\\)::\\(.*\\)" path) + (setq address (match-string 1 path) + subject (org-link-escape (match-string 2 path)))) + (while args + (cond + ((not (stringp (car args))) (push (pop args) args1)) + (t (setq a (pop args)) + (if (string-match "%a" a) + (setq a (replace-match address t t a))) + (if (string-match "%s" a) + (setq a (replace-match subject t t a))) + (push a args1)))) + (apply cmd (nreverse args1)))) -(defun org-agenda-goto (&optional highlight) - "Go to the Org-mode file which contains the item at point." - (interactive) - (let* ((marker (or (get-text-property (point) 'org-marker) - (org-agenda-error))) - (buffer (marker-buffer marker)) - (pos (marker-position marker))) - (switch-to-buffer-other-window buffer) - (widen) - (goto-char pos) - (when (org-mode-p) - (org-show-context 'agenda) - (save-excursion - (and (outline-next-heading) - (org-flag-heading nil)))) ; show the next heading - (and highlight (org-highlight (point-at-bol) (point-at-eol))))) + ((member type '("http" "https" "ftp" "news")) + (browse-url (concat type ":" path))) -(defun org-agenda-kill () - "Kill the entry or subtree belonging to the current agenda entry." - (interactive) - (let* ((marker (or (get-text-property (point) 'org-marker) - (org-agenda-error))) - (hdmarker (get-text-property (point) 'org-hd-marker)) - (buffer (marker-buffer marker)) - (pos (marker-position marker)) - dbeg dend txt n conf) - (with-current-buffer buffer - (save-excursion - (goto-char pos) - (if (org-mode-p) - (setq dbeg (progn (org-back-to-heading t) (point)) - dend (org-end-of-subtree t)) - (setq dbeg (point-at-bol) - dend (min (point-max) (1+ (point-at-eol))))) - (setq txt (buffer-substring dbeg dend)))) - (while (string-match "^[ \t]*\n" txt) (setq txt (replace-match "" t t txt))) - (setq n (length (split-string txt "\n")) - conf (or (eq t org-agenda-confirm-kill) - (and (numberp org-agenda-confirm-kill) - (> n org-agenda-confirm-kill)))) - (and conf - (not (y-or-n-p - (format "Delete entry with %d lines in buffer \"%s\"? " - n (buffer-name buffer)))) - (error "Abort")) - ;; FIXME: if we kill an entire subtree, should we not find all - ;; lines coming from the subtree? - (save-excursion (org-agenda-change-all-lines "" hdmarker)) - (with-current-buffer buffer (delete-region dbeg dend)) - (message "Agenda item and source killed"))) + ((string= type "tags") + (org-tags-view in-emacs path)) + ((string= type "thisfile") + (if in-emacs + (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)) -(defun org-agenda-switch-to (&optional delete-other-windows) - "Go to the Org-mode file which contains the item at point." - (interactive) - (let* ((marker (or (get-text-property (point) 'org-marker) - (org-agenda-error))) - (buffer (marker-buffer marker)) - (pos (marker-position marker))) - (switch-to-buffer buffer) - (and delete-other-windows (delete-other-windows)) - (widen) - (goto-char pos) - (when (org-mode-p) - (org-show-context 'agenda) - (save-excursion - (and (outline-next-heading) - (org-flag-heading nil)))))) ; show the next heading + ((string= type "file") + (if (string-match "::\\([0-9]+\\)\\'" path) + (setq line (string-to-number (match-string 1 path)) + path (substring path 0 (match-beginning 0))) + (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)) -(defun org-agenda-goto-mouse (ev) - "Go to the Org-mode file which contains the item at the mouse click." - (interactive "e") - (mouse-set-point ev) - (org-agenda-goto)) + ((string= type "news") + (org-follow-gnus-link path)) -(defun org-agenda-show () - "Display the Org-mode file which contains the item at point." - (interactive) - (let ((win (selected-window))) - (org-agenda-goto t) - (select-window win))) + ((string= type "bbdb") + (org-follow-bbdb-link path)) -(defun org-agenda-recenter (arg) - "Display the Org-mode file which contains the item at point and recenter." - (interactive "P") - (let ((win (selected-window))) - (org-agenda-goto t) - (recenter arg) - (select-window win))) + ((string= type "info") + (org-follow-info-link path)) -(defun org-agenda-show-mouse (ev) - "Display the Org-mode file which contains the item at the mouse click." - (interactive "e") - (mouse-set-point ev) - (org-agenda-show)) + ((string= type "gnus") + (let (group article) + (if (not (string-match "\\`\\([^#]+\\)\\(#\\(.*\\)\\)?" path)) + (error "Error in Gnus link")) + (setq group (match-string 1 path) + article (match-string 3 path)) + (org-follow-gnus-link group article))) -(defun org-agenda-check-no-diary () - "Check if the entry is a diary link and abort if yes." - (if (get-text-property (point) 'org-agenda-diary-link) - (org-agenda-error))) + ((string= type "vm") + (let (folder article) + (if (not (string-match "\\`\\([^#]+\\)\\(#\\(.*\\)\\)?" path)) + (error "Error in VM link")) + (setq folder (match-string 1 path) + article (match-string 3 path)) + ;; in-emacs is the prefix arg, will be interpreted as read-only + (org-follow-vm-link folder article in-emacs))) -(defun org-agenda-error () - (error "Command not allowed in this line")) + ((string= type "wl") + (let (folder article) + (if (not (string-match "\\`\\([^#]+\\)\\(#\\(.*\\)\\)?" path)) + (error "Error in Wanderlust link")) + (setq folder (match-string 1 path) + article (match-string 3 path)) + (org-follow-wl-link folder article))) -(defvar org-last-heading-marker (make-marker) - "Marker pointing to the headline that last changed its TODO state -by a remote command from the agenda.") + ((string= type "mhe") + (let (folder article) + (if (not (string-match "\\`\\([^#]+\\)\\(#\\(.*\\)\\)?" path)) + (error "Error in MHE link")) + (setq folder (match-string 1 path) + article (match-string 3 path)) + (org-follow-mhe-link folder article))) -(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 -the same tree node, and the headline of the tree node in the Org-mode file." - (interactive "P") - (org-agenda-check-no-diary) - (let* ((col (current-column)) - (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) - newhead) - (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 - (org-todo arg) - (and (bolp) (forward-char 1)) - (setq newhead (org-get-heading)) - (save-excursion - (org-back-to-heading) - (move-marker org-last-heading-marker (point)))) - (beginning-of-line 1) - (save-excursion - (org-agenda-change-all-lines newhead hdmarker 'fixface)) - (move-to-column col))) + ((string= type "rmail") + (let (folder article) + (if (not (string-match "\\`\\([^#]+\\)\\(#\\(.*\\)\\)?" path)) + (error "Error in RMAIL link")) + (setq folder (match-string 1 path) + article (match-string 3 path)) + (org-follow-rmail-link folder article))) -(defun org-agenda-change-all-lines (newhead hdmarker &optional fixface) - "Change all lines in the agenda buffer which match HDMARKER. -The new content of the line will be NEWHEAD (as modified by -`org-format-agenda-item'). HDMARKER is checked with -`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) - props m pl undone-face done-face finish new dotime cat tags) - (save-excursion - (goto-char (point-max)) - (beginning-of-line 1) - (while (not finish) - (setq finish (bobp)) - (when (and (setq m (get-text-property (point) 'org-hd-marker)) - (equal m hdmarker)) - (setq props (text-properties-at (point)) - dotime (get-text-property (point) 'dotime) - cat (get-text-property (point) 'org-category) - tags (get-text-property (point) 'tags) - new (org-format-agenda-item "x" newhead cat tags dotime 'noprefix) - pl (get-text-property (point) 'prefix-length) - undone-face (get-text-property (point) 'undone-face) - done-face (get-text-property (point) 'done-face)) - (move-to-column pl) - (cond - ((equal new "") - (beginning-of-line 1) - (and (looking-at ".*\n?") (replace-match ""))) - ((looking-at ".*") - (replace-match new t t) - (beginning-of-line 1) - (add-text-properties (point-at-bol) (point-at-eol) props) - (when fixface - (add-text-properties - (point-at-bol) (point-at-eol) - (list 'face - (if org-last-todo-state-is-todo - undone-face done-face)))) - (org-agenda-highlight-todo 'line) - (beginning-of-line 1)) - (t (error "Line update did not work")))) - (beginning-of-line 0))) - (org-finalize-agenda))) + ((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? " + (org-add-props cmd nil + 'face 'org-warning)))) + (progn + (message "Executing %s" cmd) + (shell-command cmd)) + (error "Abort")))) -(defun org-agenda-align-tags (&optional line) - "Align all tags in agenda items to `org-agenda-align-tags-to-column'." - (let ((buffer-read-only)) - (save-excursion - (goto-char (if line (point-at-bol) (point-min))) - (while (re-search-forward "\\([ \t]+\\):[a-zA-Z0-9_@:]+:[ \t]*$" - (if line (point-at-eol) nil) t) - (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))) ?\ ) - (text-properties-at (point)))))))) + ((string= type "elisp") + (let ((cmd path)) + (if (or (not org-confirm-elisp-link-function) + (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))) + (error "Abort")))) -(defun org-agenda-priority-up () - "Increase the priority of line at point, also in Org-mode file." - (interactive) - (org-agenda-priority 'up)) + (t + (browse-url-at-point))))) + (move-marker org-open-link-marker nil)) -(defun org-agenda-priority-down () - "Decrease the priority of line at point, also in Org-mode file." - (interactive) - (org-agenda-priority 'down)) -(defun org-agenda-priority (&optional force-direction) - "Set the priority of line at point, also in Org-mode file. -This changes the line at point, all other lines in the agenda referring to -the same tree node, and the headline of the tree node in the Org-mode file." - (interactive) - (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) - newhead) - (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 - (funcall 'org-priority force-direction) - (end-of-line 1) - (setq newhead (org-get-heading))) - (org-agenda-change-all-lines newhead hdmarker) - (beginning-of-line 1))) +;;; File search -(defun org-get-tags-at (&optional pos) - "Get a list of all headline tags applicable at POS. -POS defaults to point. If tags are inherited, the list contains -the targets in the same sequence as the headlines appear, i.e. -the tags of the current headline come last." - (interactive) - (let (tags) - (save-excursion - (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)) - (error nil)))) - tags)) +(defvar org-create-file-search-functions nil + "List of functions to construct the right search string for a file link. +These functions are called in turn with point at the location to +which the link should point. -;; FIXME: should fix the tags property of the agenda line. -(defun org-agenda-set-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) - (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))) +A function in the hook should first test if it would like to +handle this file type, for example by checking the major-mode or +the file extension. If it decides not to handle this file, it +should just return nil to give other functions a chance. If it +does handle the file, it must return the search string to be used +when following the link. The search string will be part of the +file link, given after a double colon, and `org-open-at-point' +will automatically search for it. If special measures must be +taken to make the search successful, another function should be +added to the companion hook `org-execute-file-search-functions', +which see. -(defun org-agenda-date-later (arg &optional what) - "Change the date of this item to one day later." - (interactive "p") - (org-agenda-check-type t 'agenda 'timeline) - (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))) - (with-current-buffer buffer - (widen) - (goto-char pos) - (if (not (org-at-timestamp-p)) - (error "Cannot find time stamp")) - (org-timestamp-change arg (or what 'day)) - (message "Time stamp changed to %s" org-last-changed-timestamp)))) +A function in this hook may also use `setq' to set the variable +`description' to provide a suggestion for the descriptive text to +be used for this link when it gets inserted into an Org-mode +buffer with \\[org-insert-link].") -(defun org-agenda-date-earlier (arg &optional what) - "Change the date of this item to one day earlier." - (interactive "p") - (org-agenda-date-later (- arg) what)) +(defvar org-execute-file-search-functions nil + "List of functions to execute a file search triggered by a link. -(defun org-agenda-date-prompt (arg) - "Change the date of this item. Date is prompted for, with default today. -The prefix ARG is passed to the `org-time-stamp' command and can therefore -be used to request time specification in the time stamp." - (interactive "P") - (org-agenda-check-type t 'agenda 'timeline) - (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))) - (with-current-buffer buffer - (widen) - (goto-char pos) - (if (not (org-at-timestamp-p)) - (error "Cannot find time stamp")) - (org-time-stamp arg) - (message "Time stamp changed to %s" org-last-changed-timestamp)))) +Functions added to this hook must accept a single argument, the +search string that was part of the file link, the part after the +double colon. The function must first check if it would like to +handle this search, for example by checking the major-mode or the +file extension. If it decides not to handle this search, it +should just return nil to give other functions a chance. If it +does handle the search, it must return a non-nil value to keep +other functions from trying. -(defun org-agenda-schedule (arg) - "Schedule the item at point." - (interactive "P") - (org-agenda-check-type t 'agenda 'timeline 'todo 'tags) - (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)) - (org-insert-labeled-timestamps-at-point nil) - ts) - (with-current-buffer buffer - (widen) - (goto-char pos) - (setq ts (org-schedule)) - (message "Item scheduled for %s" ts)))) +Each function can access the current prefix argument through the +variable `current-prefix-argument'. Note that a single prefix is +used to force opening a link in Emacs, so it may be good to only +use a numeric or double prefix to guide the search function. -(defun org-agenda-deadline (arg) - "Schedule the item at point." - (interactive "P") - (org-agenda-check-type t 'agenda 'timeline 'todo 'tags) - (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)) - (org-insert-labeled-timestamps-at-point nil) - ts) - (with-current-buffer buffer - (widen) - (goto-char pos) - (setq ts (org-deadline)) - (message "Deadline for this item set to %s" ts)))) +In case this is needed, a function in this hook can also restore +the window configuration before `org-open-at-point' was called using: -(defun org-get-heading () - "Return the heading of the current entry, without the stars." - (save-excursion - (and (memq (char-before) '(?\n ?\r)) (skip-chars-forward "^\n\r")) - (if (and (re-search-backward "[\r\n]\\*" nil t) - (looking-at "[\r\n]\\*+[ \t]+\\([^\r\n]*\\)")) - (match-string 1) - ""))) + (set-window-configuration org-window-config-before-follow-link)") -(defun org-agenda-clock-in (&optional arg) - "Start the clock on the currently selected item." - (interactive "P") - (org-agenda-check-no-diary) - (let* ((marker (or (get-text-property (point) 'org-marker) - (org-agenda-error))) - (pos (marker-position marker))) - (with-current-buffer (marker-buffer marker) - (widen) - (goto-char pos) - (org-clock-in)))) +(defun org-link-search (s &optional type avoid-pos) + "Search for a link search option. +If S is surrounded by forward slashes, it is interpreted as a +regular expression. In org-mode files, this will create an `org-occur' +sparse tree. In ordinary files, `occur' will be used to list matches. +If the current buffer is in `dired-mode', grep will be used to 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]+") " ")) + (pos (point)) + (pre "") (post "") + words re0 re1 re2 re3 re4 re5 re2a reall) + (cond + ;; First check if there are any special + ((run-hook-with-args-until-success 'org-execute-file-search-functions s)) + ;; Now try the builtin stuff + ((save-excursion + (goto-char (point-min)) + (and + (re-search-forward + (concat "<<" (regexp-quote s0) ">>") nil t) + (setq pos (match-beginning 0)))) + ;; There is an exact target for this + (goto-char pos)) + ((string-match "^/\\(.*\\)/$" s) + ;; A regular expression + (cond + ((org-mode-p) + (org-occur (match-string 1 s))) + ;;((eq major-mode 'dired-mode) + ;; (grep (concat "grep -n -e '" (match-string 1 s) "' *"))) + (t (org-do-occur (match-string 1 s))))) + (t + ;; A normal search string + (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]*\\)?$" + s (substring s 1))) + (remove-text-properties + 0 (length s) + '(face nil mouse-face nil keymap nil fontified nil) 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]") + 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) + re3 (concat pre re4 post) + re5 (concat pre ".*" re4) + re2 (concat pre re2) + re2a (concat pre re2a) + re4 (concat pre re4) + reall (concat "\\(" re0 "\\)\\|\\(" re1 "\\)\\|\\(" re2 + "\\)\\|\\(" re3 "\\)\\|\\(" re4 "\\)\\|\\(" + re5 "\\)" + )) + (cond + ((eq type 'org-occur) (org-occur reall)) + ((eq type 'occur) (org-do-occur (downcase reall) 'cleanup)) + (t (goto-char (point-min)) + (if (or (org-search-not-self 1 re0 nil t) + (org-search-not-self 1 re1 nil t) + (org-search-not-self 1 re2 nil t) + (org-search-not-self 1 re2a nil t) + (org-search-not-self 1 re3 nil t) + (org-search-not-self 1 re4 nil t) + (org-search-not-self 1 re5 nil t) + ) + (goto-char (match-beginning 1)) + (goto-char pos) + (error "No match"))))) + (t + ;; Normal string-search + (goto-char (point-min)) + (if (search-forward s nil t) + (goto-char (match-beginning 0)) + (error "No match")))) + (and (org-mode-p) (org-show-context 'link-search)))) -(defun org-agenda-diary-entry () - "Make a diary entry, like the `i' command from the calendar. -All the standard commands work: block, weekly etc." - (interactive) - (org-agenda-check-type t 'agenda 'timeline) - (require 'diary-lib) - (let* ((char (progn - (message "Diary entry: [d]ay [w]eekly [m]onthly [y]early [a]nniversary [b]lock [c]yclic") - (read-char-exclusive))) - (cmd (cdr (assoc char - '((?d . insert-diary-entry) - (?w . insert-weekly-diary-entry) - (?m . insert-monthly-diary-entry) - (?y . insert-yearly-diary-entry) - (?a . insert-anniversary-diary-entry) - (?b . insert-block-diary-entry) - (?c . insert-cyclic-diary-entry))))) - (oldf (symbol-function 'calendar-cursor-to-date)) - (point (point)) - (mark (or (mark t) (point)))) - (unless cmd - (error "No command associated with <%c>" char)) - (unless (and (get-text-property point 'day) - (or (not (equal ?b char)) - (get-text-property mark 'day))) - (error "Don't know which date to use for diary entry")) - ;; We implement this by hacking the `calendar-cursor-to-date' function - ;; and the `calendar-mark-ring' variable. Saves a lot of code. - (let ((calendar-mark-ring - (list (calendar-gregorian-from-absolute - (or (get-text-property mark 'day) - (get-text-property point 'day)))))) - (unwind-protect - (progn - (fset 'calendar-cursor-to-date - (lambda (&optional error) - (calendar-gregorian-from-absolute - (get-text-property point 'day)))) - (call-interactively cmd)) - (fset 'calendar-cursor-to-date oldf))))) +(defun org-search-not-self (group &rest args) + "Execute `re-search-forward', but only accept matches that do not +enclose the position of `org-open-link-marker'." + (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))))))) +(defun org-get-buffer-for-internal-link (buffer) + "Return a buffer to be used for displaying the link target of internal links." + (cond + ((not org-display-internal-link-with-indirect-buffer) + buffer) + ((string-match "(Clone)$" (buffer-name buffer)) + (message "Buffer is already a clone, not making another one") + ;; we also do not modify visibility in this case + buffer) + (t ; make a new indirect buffer for displaying the link + (let* ((bn (buffer-name buffer)) + (ibn (concat bn "(Clone)")) + (ib (or (get-buffer ibn) (make-indirect-buffer buffer ibn 'clone)))) + (with-current-buffer ib (org-overview)) + ib)))) -(defun org-agenda-execute-calendar-command (cmd) - "Execute a calendar command from the agenda, with the date associated to -the cursor position." - (org-agenda-check-type t 'agenda 'timeline) - (require 'diary-lib) - (unless (get-text-property (point) 'day) - (error "Don't know which date to use for calendar command")) - (let* ((oldf (symbol-function 'calendar-cursor-to-date)) - (point (point)) - (date (calendar-gregorian-from-absolute - (get-text-property point 'day))) - (displayed-day (extract-calendar-day date)) - (displayed-month (extract-calendar-month date)) - (displayed-year (extract-calendar-year date))) - (unwind-protect - (progn - (fset 'calendar-cursor-to-date - (lambda (&optional error) - (calendar-gregorian-from-absolute - (get-text-property point 'day)))) - (call-interactively cmd)) - (fset 'calendar-cursor-to-date oldf)))) +(defun org-do-occur (regexp &optional cleanup) + "Call the Emacs command `occur'. +If CLEANUP is non-nil, remove the printout of the regular expression +in the *Occur* buffer. This is useful if the regex is long and not useful +to read." + (occur regexp) + (when cleanup + (let ((cwin (selected-window)) win beg end) + (when (setq win (get-buffer-window "*Occur*")) + (select-window win)) + (goto-char (point-min)) + (when (re-search-forward "match[a-z]+" nil t) + (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))) + (goto-char (point-min)) + (select-window cwin)))) -(defun org-agenda-phases-of-moon () - "Display the phases of the moon for the 3 months around the cursor date." - (interactive) - (org-agenda-execute-calendar-command 'calendar-phases-of-moon)) +;;; The mark ring for links jumps -(defun org-agenda-holidays () - "Display the holidays for the 3 months around the cursor date." - (interactive) - (org-agenda-execute-calendar-command 'list-calendar-holidays)) +(defvar org-mark-ring nil + "Mark ring for positions before jumps in Org-mode.") +(defvar org-mark-ring-last-goto nil + "Last position in the mark ring used to go back.") +;; Fill and close the ring +(setq org-mark-ring nil org-mark-ring-last-goto nil) ;; in case file is reloaded +(loop for i from 1 to org-mark-ring-length do + (push (make-marker) org-mark-ring)) +(setcdr (nthcdr (1- org-mark-ring-length) org-mark-ring) + org-mark-ring) -(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") - (let ((calendar-longitude (if arg nil calendar-longitude)) - (calendar-latitude (if arg nil calendar-latitude)) - (calendar-location-name - (if arg "the given coordinates" calendar-location-name))) - (org-agenda-execute-calendar-command 'calendar-sunrise-sunset))) - -(defun org-agenda-goto-calendar () - "Open the Emacs calendar with the date at the cursor." +(defun org-mark-ring-push (&optional pos buffer) + "Put the current position or POS into the mark ring and rotate it." (interactive) - (org-agenda-check-type t 'agenda 'timeline) - (let* ((day (or (get-text-property (point) 'day) - (error "Don't know which date to open in calendar"))) - (date (calendar-gregorian-from-absolute day)) - (calendar-move-hook nil) - (view-calendar-holidays-initially nil) - (view-diary-entries-initially nil)) - (calendar) - (calendar-goto-date date))) + (setq pos (or pos (point))) + (setq org-mark-ring (nthcdr (1- org-mark-ring-length) org-mark-ring)) + (move-marker (car org-mark-ring) + (or pos (point)) + (or buffer (current-buffer))) + (message + (substitute-command-keys + "Position saved to mark ring, go back with \\[org-mark-ring-goto]."))) -(defun org-calendar-goto-agenda () - "Compute the Org-mode agenda for the calendar date displayed at the cursor. -This is a command that has to be installed in `calendar-mode-map'." - (interactive) - (org-agenda-list nil (calendar-absolute-from-gregorian - (calendar-cursor-to-date)) - nil)) +(defun org-mark-ring-goto (&optional n) + "Jump to the previous position in the mark ring. +With prefix arg N, jump back that many stored positions. When +called several times in succession, walk through the entire ring. +Org-mode commands jumping to a different position in the current file, +or to another Org-mode file, automatically push the old position +onto the ring." + (interactive "p") + (let (p m) + (if (eq last-command this-command) + (setq p (nthcdr n (or org-mark-ring-last-goto org-mark-ring))) + (setq p org-mark-ring)) + (setq org-mark-ring-last-goto p) + (setq m (car p)) + (switch-to-buffer (marker-buffer m)) + (goto-char m) + (if (or (org-invisible-p) (org-invisible-p2)) (org-show-context 'mark-goto)))) -(defun org-agenda-convert-date () - (interactive) - (org-agenda-check-type t 'agenda 'timeline) - (let ((day (get-text-property (point) 'day)) - date s) - (unless day - (error "Don't know which date to convert")) - (setq date (calendar-gregorian-from-absolute day)) - (setq s (concat - "Gregorian: " (calendar-date-string date) "\n" - "ISO: " (calendar-iso-date-string date) "\n" - "Day of Yr: " (calendar-day-of-year-string date) "\n" - "Julian: " (calendar-julian-date-string date) "\n" - "Astron. JD: " (calendar-astro-date-string date) - " (Julian date number at noon UTC)\n" - "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" - "Mayan: " (calendar-mayan-date-string date) "\n" - "Coptic: " (calendar-coptic-date-string date) "\n" - "Ethiopic: " (calendar-ethiopic-date-string date) "\n" - "Persian: " (calendar-persian-date-string date) "\n" - "Chinese: " (calendar-chinese-date-string date) "\n")) - (with-output-to-temp-buffer "*Dates*" - (princ s)) - (if (fboundp 'fit-window-to-buffer) - (fit-window-to-buffer (get-buffer-window "*Dates*"))))) +(defun org-remove-angle-brackets (s) + (if (equal (substring s 0 1) "<") (setq s (substring s 1))) + (if (equal (substring s -1) ">") (setq s (substring s 0 -1))) + s) +(defun org-add-angle-brackets (s) + (if (equal (substring s 0 1) "<") nil (setq s (concat "<" s))) + (if (equal (substring s -1) ">") nil (setq s (concat s ">"))) + s) -;;; Tags +;;; Following specific links -(defun org-scan-tags (action matcher &optional todo-only) - "Scan headline tags with inheritance and produce output ACTION. -ACTION can be `sparse-tree' or `agenda'. MATCHER is a Lisp form to be -evaluated, testing if a given set of tags qualifies a headline for -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]*$")) - (props (list 'face nil - 'done-face 'org-done - 'undone-face nil - 'mouse-face 'highlight - 'org-not-done-regexp org-not-done-regexp - 'keymap org-agenda-keymap - 'help-echo - (format "mouse-2 or RET jump to org file %s" - (abbreviate-file-name buffer-file-name)))) - (case-fold-search nil) - lspos - tags tags-list tags-alist (llast 0) rtn level category i txt - todo marker) - (save-excursion - (goto-char (point-min)) - (when (eq action 'sparse-tree) (org-overview)) - (while (re-search-forward re nil t) - (catch :skip - (and (eq action 'agenda) (org-agenda-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) - category (org-get-category)) - (setq i llast llast level) - ;; remove tag lists from same and sublevels - (while (>= i level) - (when (setq entry (assoc i tags-alist)) - (setq tags-alist (delete entry tags-alist))) - (setq i (1- i))) - ;; add the nex tags - (when tags - (setq tags (mapcar 'downcase (org-split-string tags ":")) - tags-alist - (cons (cons level tags) tags-alist))) - ;; compile tags for current headline - (setq tags-list - (if org-use-tag-inheritance - (apply 'append (mapcar 'cdr tags-alist)) - tags)) - (when (and (or (not todo-only) todo) - (eval matcher) - (or (not org-agenda-skip-archived-trees) - (not (member org-archive-tag tags-list)))) - ;; list this headline - (if (eq action 'sparse-tree) - (progn - (org-show-context 'tags-tree)) - (setq txt (org-format-agenda-item - "" - (concat - (if org-tags-match-list-sublevels - (make-string (1- level) ?.) "") - (org-get-heading)) - category tags-list)) - (goto-char lspos) - (setq marker (org-agenda-new-marker)) - (org-add-props txt props - 'org-marker marker 'org-hd-marker marker 'org-category category) - (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)))))) - (when (and (eq action 'sparse-tree) - (not org-sparse-tree-open-archived-trees)) - (org-hide-archived-subtrees (point-min) (point-max))) - (nreverse rtn))) +(defun org-follow-timestamp-link () + (cond + ((org-at-date-range-p t) + (let ((org-agenda-start-on-weekday) + (t1 (match-string 1)) + (t2 (match-string 2))) + (setq t1 (time-to-days (org-time-string-to-time t1)) + t2 (time-to-days (org-time-string-to-time t2))) + (org-agenda-list nil t1 (1+ (- t2 t1))))) + ((org-at-timestamp-p t) + (org-agenda-list nil (time-to-days (org-time-string-to-time + (substring (match-string 1) 0 10))) + 1)) + (t (error "This should not happen")))) -(defun org-tags-sparse-tree (&optional arg match) - "Create a sparse tree according to tags string MATCH. -MATCH can contain positive and negative selection of tags, like -\"+WORK+URGENT-WITHBOSS\"." - (interactive "P") - (org-scan-tags 'sparse-tree (cdr (org-make-tags-matcher match)))) -(defun org-make-tags-matcher (match) - "Create the TAGS//TODO matcher form for the selection string MATCH." - (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))) ; FIXME: SHould we have a separate history for this? +(defun org-follow-bbdb-link (name) + "Follow a BBDB link to NAME." + (require 'bbdb) + (let ((inhibit-redisplay (not debug-on-error)) + (bbdb-electric-p nil)) + (catch 'exit + ;; Exact match on name + (bbdb-name (concat "\\`" name "\\'") nil) + (if (< 0 (buffer-size (get-buffer "*BBDB*"))) (throw 'exit nil)) + ;; Exact match on name + (bbdb-company (concat "\\`" name "\\'") nil) + (if (< 0 (buffer-size (get-buffer "*BBDB*"))) (throw 'exit nil)) + ;; Partial match on name + (bbdb-name name nil) + (if (< 0 (buffer-size (get-buffer "*BBDB*"))) (throw 'exit nil)) + ;; Partial match on company + (bbdb-company name nil) + (if (< 0 (buffer-size (get-buffer "*BBDB*"))) (throw 'exit nil)) + ;; General match including network address and notes + (bbdb name nil) + (when (= 0 (buffer-size (get-buffer "*BBDB*"))) + (delete-window (get-buffer-window "*BBDB*")) + (error "No matching BBDB record"))))) - ;; Parse the string and create a lisp form - (let ((match0 match) minus tag mm - tagsmatch todomatch tagsmatcher todomatcher kwd matcher - orterms term orlist) - (if (string-match "/+" match) - ;; match contains also a todo-matching request - (setq tagsmatch (substring match 0 (match-beginning 0)) - todomatch (substring match (match-end 0))) - ;; only matching tags - (setq tagsmatch match todomatch nil)) +(defun org-follow-info-link (name) + "Follow an info file & node link to NAME." + (if (or (string-match "\\(.*\\)::?\\(.*\\)" name) + (string-match "\\(.*\\)" name)) + (progn + (require 'info) + (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)))) - ;; Make the tags matcher - (if (or (not tagsmatch) (not (string-match "\\S-" tagsmatch))) - (setq tagsmatcher t) - (setq orterms (org-split-string tagsmatch "|") orlist nil) - (while (setq term (pop orterms)) - (while (string-match "^&?\\([-+:]\\)?\\([A-Za-z_@0-9]+\\)" term) - (setq minus (and (match-end 1) - (equal (match-string 1 term) "-")) - tag (match-string 2 term) - term (substring term (match-end 0)) - mm (list 'member (downcase tag) 'tags-list) - mm (if minus (list 'not mm) mm)) - (push mm tagsmatcher)) - (push (if (> (length tagsmatcher) 1) - (cons 'and tagsmatcher) - (car tagsmatcher)) - orlist) - (setq tagsmatcher nil)) - (setq tagsmatcher (if (> (length orlist) 1) (cons 'or orlist) (car orlist)))) +(defun org-follow-gnus-link (&optional group article) + "Follow a Gnus link to GROUP and ARTICLE." + (require 'gnus) + (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-summary-goto-article (string-to-number article) nil t)) + (group (gnus-group-jump-to-group group)))) - ;; Make the todo matcher ;; FIXME: reduce syntax richness? - (if (or (not todomatch) (not (string-match "\\S-" todomatch))) - (setq todomatcher t) - (setq orterms (org-split-string todomatch "|") orlist nil) - (while (setq term (pop orterms)) - (while (string-match "^&?\\([-+:]\\)?\\([A-Za-z_@0-9]+\\)" term) - (setq minus (and (match-end 1) - (equal (match-string 1 term) "-")) - kwd (match-string 2 term) - term (substring term (match-end 0)) - mm (list 'equal 'todo kwd) - mm (if minus (list 'not mm) mm)) - (push mm todomatcher)) - (push (if (> (length todomatcher) 1) - (cons 'and todomatcher) - (car todomatcher)) - orlist) - (setq todomatcher nil)) - (setq todomatcher (if (> (length orlist) 1) - (cons 'or orlist) (car orlist)))) +(defun org-follow-vm-link (&optional folder article readonly) + "Follow a VM link to FOLDER and ARTICLE." + (require 'vm) + (setq article (org-add-angle-brackets article)) + (if (string-match "^//\\([a-zA-Z]+@\\)?\\([^:]+\\):\\(.*\\)" folder) + ;; ange-ftp or efs or tramp access + (let ((user (or (match-string 1 folder) (user-login-name))) + (host (match-string 2 folder)) + (file (match-string 3 folder))) + (cond + ((featurep 'tramp) + ;; use tramp to access the file + (if (featurep 'xemacs) + (setq folder (format "[%s@%s]%s" user host file)) + (setq folder (format "/%s@%s:%s" user host file)))) + (t + ;; use ange-ftp or efs + (require (if (featurep 'xemacs) 'efs 'ange-ftp)) + (setq folder (format "/%s@%s:%s" user host file)))))) + (when folder + (funcall (cdr (assq 'vm org-link-frame-setup)) folder readonly) + (sit-for 0.1) + (when article + (vm-select-folder-buffer) + (widen) + (let ((case-fold-search t)) + (goto-char (point-min)) + (if (not (re-search-forward + (concat "^" "message-id: *" (regexp-quote article)))) + (error "Could not find the specified message in this folder")) + (vm-isearch-update) + (vm-isearch-narrow) + (vm-beginning-of-message) + (vm-summarize))))) - ;; Return the string and lisp forms of the matcher - (setq matcher (if todomatcher - (list 'and tagsmatcher todomatcher) - tagsmatcher)) - (cons match0 matcher))) +(defun org-follow-wl-link (folder article) + "Follow a Wanderlust link to FOLDER and ARTICLE." + (if (and (string= folder "%") + article + (string-match "^\\([^#]+\\)\\(#\\(.*\\)\\)?" article)) + ;; XXX: imap-uw supports folders starting with '#' such as "#mh/inbox". + ;; Thus, we recompose folder and article ids. + (setq folder (format "%s#%s" folder (match-string 1 article)) + article (match-string 3 article))) + (if (not (elmo-folder-exists-p (wl-folder-get-elmo-folder folder))) + (error "No such folder: %s" folder)) + (wl-summary-goto-folder-subr folder 'no-sync t nil t nil nil) + (and article + (wl-summary-jump-to-msg-by-message-id (org-add-angle-brackets article)) + (wl-summary-redisplay))) -;;;###autoload -(defun org-tags-view (&optional todo-only match) - "Show all headlines for all `org-agenda-files' matching a TAGS criterion. -The prefix arg TODO-ONLY limits the search to TODO entries." - (interactive "P") - (org-compile-prefix-format 'tags) - (org-set-sorting-strategy 'tags) - (let* ((org-tags-match-list-sublevels - (if todo-only t org-tags-match-list-sublevels)) - (win (selected-window)) - (completion-ignore-case t) - rtn rtnall files file pos matcher - buffer) - (setq matcher (org-make-tags-matcher match) - match (car matcher) matcher (cdr matcher)) - (org-prepare-agenda) - (setq org-agenda-redo-command - (list 'org-tags-view (list 'quote todo-only) - (list 'if 'current-prefix-arg nil match))) - (setq files (org-agenda-files) - rtnall nil) - (while (setq file (pop files)) - (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, merror message to agenda - (setq rtn (list - (format "ORG-AGENDA-ERROR: No such org-file %s" file)) - rtnall (append rtnall rtn)) - (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 +(defun org-follow-rmail-link (folder article) + "Follow an RMAIL link to FOLDER and ARTICLE." + (setq article (org-add-angle-brackets article)) + (let (message-number) + (save-excursion + (save-window-excursion + (rmail (if (string= folder "RMAIL") rmail-file-name folder)) + (setq message-number (save-restriction - (if org-agenda-restrict - (narrow-to-region org-agenda-restrict-begin - org-agenda-restrict-end) - (widen)) - (setq rtn (org-scan-tags 'agenda matcher todo-only)) - (setq rtnall (append rtnall rtn)))))))) - (insert "Headlines with TAGS match: ") - (add-text-properties (point-min) (1- (point)) - (list 'face 'org-level-3)) - (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)) - (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 tags)) - (org-finalize-agenda) - (setq buffer-read-only t) - (if (not org-select-agenda-window) (select-window win)))) - -(defvar org-add-colon-after-tag-completion nil) ;; dynamically skoped param -(defvar org-tags-overlay (org-make-overlay 1 1)) -(org-detach-overlay org-tags-overlay) - -(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)) - 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 - (while (re-search-forward re nil t) - (org-set-tags nil t) - (end-of-line 1))) - (message "All tags realigned to column %d" org-tags-column)) - (if just-align - (setq tags current) - ;; Get a new set of tags from the user - (setq table (or org-tag-alist (org-get-buffer-tags)) - org-last-tags-completion-table table - current-tags (org-split-string current ":") - inherited-tags (nreverse - (nthcdr (length current-tags) - (nreverse (org-get-tags-at)))) - tags - (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) - (let ((org-add-colon-after-tag-completion t)) - (org-trim - (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 ":"))) - (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) - (and (not (featurep 'xemacs)) c0 (tabify p0 (point))) - tags) - (error "Tags alignment failed"))))) + (widen) + (goto-char (point-max)) + (if (re-search-backward + (concat "^Message-ID:\\s-+" (regexp-quote + (or article ""))) + nil t) + (rmail-what-message)))))) + (if message-number + (progn + (rmail (if (string= folder "RMAIL") rmail-file-name folder)) + (rmail-show-message message-number) + message-number) + (error "Message not found")))) -(defun org-tags-completion-function (string predicate &optional flag) - (let (s1 s2 rtn (ctable org-last-tags-completion-table) - (confirm (lambda (x) (stringp (car x))))) - (if (string-match "^\\(.*[-+:&|]\\)\\([^-+:&|]*\\)$" string) - (setq s1 (match-string 1 string) - s2 (match-string 2 string)) - (setq s1 "" s2 string)) - (cond - ((eq flag nil) - ;; 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)) - ":" ""))) - ) - ((eq flag t) - ;; all-completions - (all-completions s2 ctable confirm) - ) - ((eq flag 'lambda) - ;; exact match? - (assoc s2 ctable))) - )) +;;; mh-e integration based on planner-mode +(defun org-mhe-get-message-real-folder () + "Return the name of the current message real folder, so if you use +sequences, it will now work." + (save-excursion + (let* ((folder + (if (equal major-mode 'mh-folder-mode) + mh-current-folder + ;; Refer to the show buffer + mh-show-folder-buffer)) + (end-index + (if (boundp 'mh-index-folder) + (min (length mh-index-folder) (length folder)))) + ) + ;; a simple test on mh-index-data does not work, because + ;; mh-index-data is always nil in a show buffer. + (if (and (boundp 'mh-index-folder) + (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) + ) + )) + (org-mhe-get-message-folder-from-index) + ) + folder + ) + ))) -(defun org-fast-tag-insert (kwd tags face &optional end) - "Insert KDW, and the TAGS, the latter with face FACE. Also inser END." - (insert (format "%-12s" (concat kwd ":")) - (org-add-props (mapconcat 'identity tags " ") nil 'face face) - (or end ""))) +(defun org-mhe-get-message-folder-from-index () + "Returns the name of the message folder in a index folder buffer." + (save-excursion + (mh-index-previous-folder) + (re-search-forward "^\\(+.*\\)$" nil t) + (message (match-string 1)))) -(defun org-fast-tag-show-exit (flag) +(defun org-mhe-get-message-folder () + "Return the name of the current message folder. Be careful if you +use sequences." (save-excursion - (goto-line 3) - (if (re-search-forward "[ \t]+Next change exits" (point-at-eol) t) - (replace-match "")) - (when flag - (end-of-line 1) - (move-to-column (- (window-width) 19) t) - (insert (org-add-props " Next change exits" nil 'face 'org-warning))))) - -(defun org-set-current-tags-overlay (current prefix) - (let ((s (concat ":" (mapconcat 'identity current ":") ":"))) - (if (featurep 'xemacs) - (org-overlay-display org-tags-overlay (concat prefix s) - 'secondary-selection) - (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) - "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. -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 - (lambda (x) - (if (stringp (car x)) (string-width (car x)) 0)) - table))) - (buf (current-buffer)) - (buffer-tags nil) - (fwidth (+ maxlen 3 1 3)) - (ncol (/ (- (window-width) 4) fwidth)) - (i-face 'org-done) - (c-face 'org-tag) - 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) - groups ingroup) - (save-excursion - (beginning-of-line 1) - (if (looking-at ".*[ \t]\\(:[A-Za-z_@0-9:]+:\\)[ \t]*\\(\r\\|$\\)") - (setq ov-start (match-beginning 1) - ov-end (match-end 1) - ov-prefix "") - (setq ov-start (1- (point-at-eol)) - ov-end (1+ ov-start)) - (skip-chars-forward "^\n\r") - (setq ov-prefix - (concat - (buffer-substring (1- (point)) (point)) - (if (> (current-column) org-tags-column) - " " - (make-string (- org-tags-column (current-column)) ?\ )))))) - (org-move-overlay org-tags-overlay ov-start ov-end) - (save-window-excursion - ;; FIXME: would it be better to keep the other windows? - (delete-other-windows) - (split-window-vertically) - (switch-to-buffer-other-window (get-buffer-create " *Org tags*")) - (erase-buffer) - (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) - (while (setq e (pop tbl)) - (cond - ((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) c2 nil) - (if (cdr e) - (setq c (cdr e)) - ;; automatically assign a character. - (setq c1 (string-to-char - (downcase (substring - tg (if (= (string-to-char tg) ?@) 1 0))))) - (if (or (rassoc c1 ntable) (rassoc c1 table)) - (while (or (rassoc char ntable) (rassoc char table)) - (setq char (1+ char))) - (setq c2 c1)) - (setq c (or c2 char))) - (if ingroup (push tg (car groups))) - (setq tg (org-add-props tg nil 'face - (cond - ((member tg current) c-face) - ((member tg inherited) i-face) - (t nil)))) - (if (and (= cnt 0) (not ingroup)) (insert " ")) - (insert "[" c "] " tg (make-string - (- fwidth 4 (length tg)) ?\ )) - (push (cons tg c) ntable) - (when (= (setq cnt (1+ cnt)) ncol) - (insert "\n") - (if ingroup (insert " ")) - (setq cnt 0))))) - (setq ntable (nreverse ntable)) - (insert "\n") - (goto-char (point-min)) - (if (fboundp 'fit-window-to-buffer) (fit-window-to-buffer)) - (setq rtn - (catch 'exit - (while t - (message "[a-z..]:Toggle [SPC]:clear [RET]:accept [TAB]:free [C-c]: multi%s" - (if groups " [!] no groups" "")) - (setq c (let ((inhibit-quit t)) (read-char-exclusive))) - (cond - ((= c ?\r) (throw 'exit t)) - ((= c ?!) - (setq groups nil) - (goto-char (point-min)) - (while (re-search-forward "[{}]" nil t) (replace-match " "))) - ((= c ?\C-c) - (org-fast-tag-show-exit - (setq exit-after-next (not exit-after-next)))) - ((or (= c ?\C-g) - (and (= c ?q) (not (rassoc c ntable)))) - (org-detach-overlay org-tags-overlay) - (setq quit-flag t)) - ((= c ?\ ) - (setq current nil) - (if exit-after-next (setq exit-after-next 'now))) - ((= c ?\t) - (condition-case nil - (setq tg (completing-read - "Tag: " - (or buffer-tags - (with-current-buffer buf - (org-get-buffer-tags))))) - (quit (setq tg ""))) - (when (string-match "\\S-" tg) - (add-to-list 'buffer-tags (list tg)) - (if (member tg current) - (setq current (delete tg current)) - (push tg current))) - (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))) - (push tg current)) - (if exit-after-next (setq exit-after-next 'now)))) - - ;; Create a sorted list - (setq current - (sort current - (lambda (a b) - (assoc b (cdr (memq (assoc a ntable) ntable)))))) - (if (eq exit-after-next 'now) (throw 'exit t)) - (goto-char (point-min)) - (beginning-of-line 2) - (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) - (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))))) - (goto-char (point-min))))) - (org-detach-overlay org-tags-overlay) - (if rtn - (mapconcat 'identity current ":") - nil)))) + (if (equal major-mode 'mh-folder-mode) + mh-current-folder + ;; Refer to the show buffer + mh-show-folder-buffer))) -(defun org-get-tags () - "Get the TAGS string in the current headline." - (unless (org-on-heading-p t) - (error "Not on a heading")) +(defun org-mhe-get-message-num () + "Return the number of the current message. Be careful if you +use sequences." (save-excursion - (beginning-of-line 1) - (if (looking-at ".*[ \t]\\(:[A-Za-z_@0-9:]+:\\)[ \t]*\\(\r\\|$\\)") - (org-match-string-no-properties 1) - ""))) + (if (equal major-mode 'mh-folder-mode) + (mh-get-msg-num nil) + ;; Refer to the show buffer + (mh-show-buffer-message-number)))) -(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) ":")))) - (mapcar 'list tags))) +(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 +idea..." + (let* ((folder (org-mhe-get-message-folder)) + (num (org-mhe-get-message-num)) + (buffer (get-buffer-create (concat "show-" folder))) + (header-field)) + (with-current-buffer buffer + (mh-display-msg num folder) + (if (equal major-mode 'mh-folder-mode) + (mh-header-display) + (mh-show-header-display)) + (set-buffer buffer) + (setq header-field (mh-get-header-field header)) + (if (equal major-mode 'mh-folder-mode) + (mh-show) + (mh-show-show)) + header-field))) -;;; Link Stuff +(defun org-follow-mhe-link (folder article) + "Follow an MHE link to FOLDER and ARTICLE. +If ARTICLE is nil FOLDER is shown. If the configuration variable +`org-mhe-search-all-folders' is t and `mh-searcher' is pick, +ARTICLE is searched in all folders. Indexed searches (swish++, +namazu, and others supported by MH-E) will always search in all +folders." + (require 'mh-e) + (require 'mh-search) + (require 'mh-utils) + (mh-find-path) + (if (not article) + (mh-visit-folder (mh-normalize-folder-name folder)) + (setq article (org-add-angle-brackets article)) + (mh-search-choose) + (if (equal mh-searcher 'pick) + (progn + (mh-search folder (list "--message-id" article)) + (when (and org-mhe-search-all-folders + (not (org-mhe-get-message-real-folder))) + (kill-this-buffer) + (mh-search "+" (list "--message-id" article)))) + (mh-search "+" article)) + (if (org-mhe-get-message-real-folder) + (mh-show-msg 1) + (kill-this-buffer) + (error "Message not found")))) -(defvar org-create-file-search-functions nil - "List of functions to construct the right search string for a file link. -These functions are called in turn with point at the location to -which the link should point. +;;; BibTeX links -A function in the hook should first test if it would like to -handle this file type, for example by checking the major-mode or -the file extension. If it decides not to handle this file, it -should just return nil to give other functions a chance. If it -does handle the file, it must return the search string to be used -when following the link. The search string will be part of the -file link, given after a double colon, and `org-open-at-point' -will automatically search for it. If special measures must be -taken to make the search successful, another function should be -added to the companion hook `org-execute-file-search-functions', -which see. +;; Use the custom search meachnism to construct and use search strings for +;; file links to BibTeX database entries. -A function in this hook may also use `setq' to set the variable -`description' to provide a suggestion for the descriptive text to -be used for this link when it gets inserted into an Org-mode -buffer with \\[org-insert-link].") +(defun org-create-file-search-in-bibtex () + "Create the search string and description for a BibTeX database entry." + (when (eq major-mode 'bibtex-mode) + ;; yes, we want to construct this search string. + ;; Make a good description for this entry, using names, year and the title + ;; Put it into the `description' variable which is dynamically scoped. + (let ((bibtex-autokey-names 1) + (bibtex-autokey-names-stretch 1) + (bibtex-autokey-name-case-convert-function 'identity) + (bibtex-autokey-name-separator " & ") + (bibtex-autokey-additional-names " et al.") + (bibtex-autokey-year-length 4) + (bibtex-autokey-name-year-separator " ") + (bibtex-autokey-titlewords 3) + (bibtex-autokey-titleword-separator " ") + (bibtex-autokey-titleword-case-convert-function 'identity) + (bibtex-autokey-titleword-length 'infty) + (bibtex-autokey-year-title-separator ": ")) + (setq description (bibtex-generate-autokey))) + ;; Now parse the entry, get the key and return it. + (save-excursion + (bibtex-beginning-of-entry) + (cdr (assoc "=key=" (bibtex-parse-entry)))))) -(defvar org-execute-file-search-functions nil - "List of functions to execute a file search triggered by a link. +(defun org-execute-file-search-in-bibtex (s) + "Find the link search string S as a key for a database entry." + (when (eq major-mode 'bibtex-mode) + ;; Yes, we want to do the search in this file. + ;; We construct a regexp that searches for "@entrytype{" followed by the key + (goto-char (point-min)) + (and (re-search-forward (concat "@[a-zA-Z]+[ \t\n]*{[ \t\n]*" + (regexp-quote s) "[ \t\n]*,") nil t) + (goto-char (match-beginning 0))) + (if (and (match-beginning 0) (equal current-prefix-arg '(16))) + ;; Use double prefix to indicate that any web link should be browsed + (let ((b (current-buffer)) (p (point))) + ;; Restore the window configuration because we just use the web link + (set-window-configuration org-window-config-before-follow-link) + (save-excursion (set-buffer b) (goto-char p) + (bibtex-url))) + (recenter 0)) ; Move entry start to beginning of window + ;; return t to indicate that the search is done. + t)) -Functions added to this hook must accept a single argument, the -search string that was part of the file link, the part after the -double colon. The function must first check if it would like to -handle this search, for example by checking the major-mode or the -file extension. If it decides not to handle this search, it -should just return nil to give other functions a chance. If it -does handle the search, it must return a non-nil value to keep -other functions from trying. +;; Finally add the functions to the right hooks. +(add-hook 'org-create-file-search-functions 'org-create-file-search-in-bibtex) +(add-hook 'org-execute-file-search-functions 'org-execute-file-search-in-bibtex) -Each function can access the current prefix argument through the -variable `current-prefix-argument'. Note that a single prefix is -used to force opening a link in Emacs, so it may be good to only -use a numeric or double prefix to guide the search function. +;; end of Bibtex link setup -In case this is needed, a function in this hook can also restore -the window configuration before `org-open-at-point' was called using: +;;; Following file links - (set-window-configuration org-window-config-before-follow-link)") +(defun org-open-file (path &optional in-emacs line search) + "Open the file at PATH. +First, this expands any special file name abbreviations. Then the +configuration variable `org-file-apps' is checked if it contains an +entry for this file type, and if yes, the corresponding command is launched. +If no application is found, Emacs simply visits the file. +With optional argument IN-EMACS, Emacs will visit the file. +Optional LINE specifies a line to go to, optional SEARCH a string to +search for. If LINE or SEARCH is given, the file will always be +opened in Emacs. +If the file does not exist, an error is thrown." + (setq in-emacs (or in-emacs line search)) + (let* ((file (if (equal path "") + buffer-file-name + (substitute-in-file-name (expand-file-name path)))) + (apps (append org-file-apps (org-default-apps))) + (remp (and (assq 'remote apps) (org-file-remote-p file))) + (dirp (if remp nil (file-directory-p file))) + (dfile (downcase file)) + (old-buffer (current-buffer)) + (old-pos (point)) + (old-mode major-mode) + ext cmd) + (if (string-match "^.*\\.\\([a-zA-Z0-9]+\\.gz\\)$" dfile) + (setq ext (match-string 1 dfile)) + (if (string-match "^.*\\.\\([a-zA-Z0-9]+\\)$" dfile) + (setq ext (match-string 1 dfile)))) + (if in-emacs + (setq cmd 'emacs) + (setq cmd (or (and remp (cdr (assoc 'remote apps))) + (and dirp (cdr (assoc 'directory apps))) + (cdr (assoc ext apps)) + (cdr (assoc t apps))))) + (when (eq cmd 'mailcap) + (require 'mailcap) + (mailcap-parse-mailcaps) + (let* ((mime-type (mailcap-extension-to-mime (or ext ""))) + (command (mailcap-mime-info mime-type))) + (if (stringp command) + (setq cmd command) + (setq cmd 'emacs)))) + (if (and (not (eq cmd 'emacs)) ; Emacs has not 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))) + (save-window-excursion + (shell-command (concat cmd " &")))) + ((or (stringp cmd) + (eq cmd 'emacs)) + (funcall (cdr (assq 'file org-link-frame-setup)) file) + (if line (goto-line line) + (if search (org-link-search search)))) + ((consp cmd) + (eval cmd)) + (t (funcall (cdr (assq 'file org-link-frame-setup)) file))) + (and (org-mode-p) (eq old-mode 'org-mode) + (or (not (equal old-buffer (current-buffer))) + (not (equal old-pos (point)))) + (org-mark-ring-push old-pos old-buffer)))) -(defun org-find-file-at-mouse (ev) - "Open file link or URL at mouse." - (interactive "e") - (mouse-set-point ev) - (org-open-at-point 'in-emacs)) +(defun org-default-apps () + "Return the default applications for this operating system." + (cond + ((eq system-type 'darwin) + org-file-apps-defaults-macosx) + ((eq system-type 'windows-nt) + org-file-apps-defaults-windowsnt) + (t org-file-apps-defaults-gnu))) -(defun org-open-at-mouse (ev) - "Open file link or URL at mouse." - (interactive "e") - (mouse-set-point ev) - (org-open-at-point)) +(defun org-expand-file-name (path) + "Replace special path abbreviations and expand the file name." + (expand-file-name path)) -(defvar org-window-config-before-follow-link nil - "The window configuration before following a link. -This is saved in case the need arises to restore it.") +(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. +Return non-nil if the location is indeed remote. -;; FIXME: IN-EMACS is used for many purposes, maybe rename this argument??? -(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 -the end of the current subtree. -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") - (setq org-window-config-before-follow-link (current-window-configuration)) - (org-remove-occur-highlights nil nil t) - (if (org-at-timestamp-p t) - (org-follow-timestamp-link) - (let (type path link line search (pos (point))) - (catch 'match - (save-excursion - (skip-chars-forward "^]\n\r") - (when (and (re-search-backward "\\[\\[" nil t) - (looking-at org-bracket-link-regexp) - (<= (match-beginning 0) pos) - (>= (match-end 0) pos)) - (setq link (org-link-unescape (org-match-string-no-properties 1))) - (while (string-match " *\n *" link) - (setq link (replace-match " " t t link))) - (setq link (org-link-expand-abbrev link)) - (if (string-match org-link-re-with-space2 link) - (setq type (match-string 1 link) - path (match-string 2 link)) - (setq type "thisfile" - path link)) - (throw 'match t))) +For example, the filename \"/user@host:/foo\" specifies a location +on the system \"/user@host:\"." + (cond ((fboundp 'file-remote-p) + (file-remote-p file)) + ((fboundp 'tramp-handle-file-remote-p) + (tramp-handle-file-remote-p file)) + ((and (boundp 'ange-ftp-name-format) + (string-match (car ange-ftp-name-format) file)) + t) + (t nil))) - (when (get-text-property (point) 'org-linked-text) - (setq type "thisfile" - pos (if (get-text-property (1+ (point)) 'org-linked-text) - (1+ (point)) (point)) - path (buffer-substring - (previous-single-property-change pos 'org-linked-text) - (next-single-property-change pos 'org-linked-text))) - (throw 'match t)) - (save-excursion - (skip-chars-backward (concat "^[]" org-non-link-chars " ")) - (if (equal (char-before) ?<) (backward-char 1)) - (when (or (looking-at org-angle-link-re) - (looking-at org-plain-link-re) - (and (or (re-search-forward org-angle-link-re (point-at-eol) t) - (re-search-forward org-plain-link-re (point-at-eol) t)) - (<= (match-beginning 0) pos) - (>= (match-end 0) pos))) - (setq type (match-string 1) - path (match-string 2)) - (throw 'match t))) - (save-excursion - (skip-chars-backward "^ \t\n\r") - (when (looking-at "\\(:[A-Za-z_@0-9:]+\\):[ \t\r\n]") - (setq type "tags" - path (match-string 1)) - (while (string-match ":" path) - (setq path (replace-match "+" t t path))) - (throw 'match t))) - (save-excursion - (skip-chars-backward "a-zA-Z_") - (when (and (memq 'camel org-activate-links) - (looking-at org-camel-regexp)) - (setq type "camel" path (match-string 0)) - (if (equal (char-before) ?*) - (setq path (concat "*" path)))) - (throw 'match t))) - (unless path - (error "No link found")) - ;; Remove any trailing spaces in path - (if (string-match " +\\'" path) - (setq path (replace-match "" t t path))) +;;;; Hooks for remember.el - (cond +;;;###autoload +(defun org-remember-annotation () + "Return a link to the current location as an annotation for remember.el. +If you are using Org-mode files as target for data storage with +remember.el, then the annotations should include a link compatible with the +conventions in Org-mode. This function returns such a link." + (org-store-link nil)) - ((equal type "mailto") - (let ((cmd (car org-link-mailto-program)) - (args (cdr org-link-mailto-program)) args1 - (address path) (subject "") a) - (if (string-match "\\(.*\\)::\\(.*\\)" path) - (setq address (match-string 1 path) - subject (org-link-escape (match-string 2 path)))) - (while args - (cond - ((not (stringp (car args))) (push (pop args) args1)) - (t (setq a (pop args)) - (if (string-match "%a" a) - (setq a (replace-match address t t a))) - (if (string-match "%s" a) - (setq a (replace-match subject t t a))) - (push a args1)))) - (apply cmd (nreverse args1)))) +(defconst org-remember-help +"Select a destination location for the note. +UP/DOWN=headline TAB=cycle visibility [Q]uit RET//=Store +RET at beg-of-buf -> Append to file as level 2 headline +RET on headline -> Store as sublevel entry to current headline +/ -> before/after current headline, same headings level") - ((member type '("http" "https" "ftp" "news")) - (browse-url (concat type ":" path))) +;;;###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." + (if org-remember-templates - ((string= type "tags") - (org-tags-view in-emacs path)) - ((or (string= type "camel") - (string= type "thisfile")) - (if in-emacs - (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)))) + (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))) + (tpl (car entry)) + (plist-p (if org-store-link-plist t nil)) + (file (if (and (nth 1 entry) (stringp (nth 1 entry)) + (string-match "\\S-" (nth 1 entry))) + (nth 1 entry) + org-default-notes-file)) + (headline (nth 2 entry)) + (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 + (v-n user-full-name) + (org-startup-folded nil) + org-time-was-given x prompt char time) + (setq org-store-link-plist + (append (list :annotation v-a :initial v-i))) + (unless tpl (setq tpl "") (message "No template") (ding)) + (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" + (abbreviate-file-name (or file org-default-notes-file)) + (or headline "")))) + (insert tpl) (goto-char (point-min)) + ;; Simple %-escapes + (while (re-search-forward "%\\([tTuUai]\\)" nil t) + (when (and initial (equal (match-string 0) "%i")) + (save-match-data + (let* ((lead (buffer-substring + (point-at-bol) (match-beginning 0)))) + (setq v-i (mapconcat 'identity + (org-split-string initial "\n") + (concat "\n" lead)))))) + (replace-match + (or (eval (intern (concat "v-" (match-string 1)))) "") + t t)) + ;; 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)))) + (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) + (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) + (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"))))) + (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))) - ((string= type "file") - (if (string-match "::\\([0-9]+\\)\\'" path) - (setq line (string-to-number (match-string 1 path)) - path (substring path 0 (match-beginning 0))) - (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)) +;;;###autoload +(defun org-remember () + "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." + (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)))) - ((string= type "news") - (org-follow-gnus-link path)) +;;;###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. +Then the command offers the headings tree of the selected file in order to +file the text at a specific location. +You can either immediately press RET to get the note appended to the +file, or you can use vertical cursor motion and visibility cycling (TAB) to +find a better place. Then press RET or or in insert the note. - ((string= type "bbdb") - (org-follow-bbdb-link path)) +Key Cursor position Note gets inserted +----------------------------------------------------------------------------- +RET buffer-start as level 2 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. + on headline as same level, before current heading + on headline as same level, after current heading - ((string= type "info") - (org-follow-info-link path)) +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. - ((string= type "gnus") - (let (group article) - (if (not (string-match "\\`\\([^#]+\\)\\(#\\(.*\\)\\)?" path)) - (error "Error in Gnus link")) - (setq group (match-string 1 path) - article (match-string 3 path)) - (org-follow-gnus-link group article))) +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 +is constructed from the current date and some additional data. - ((string= type "vm") - (let (folder article) - (if (not (string-match "\\`\\([^#]+\\)\\(#\\(.*\\)\\)?" path)) - (error "Error in VM link")) - (setq folder (match-string 1 path) - article (match-string 3 path)) - ;; in-emacs is the prefix arg, will be interpreted as read-only - (org-follow-vm-link folder article in-emacs))) +If the variable `org-adapt-indentation' is non-nil, the entire text is +also indented so that it starts in the same column as the headline +\(i.e. after the stars). - ((string= type "wl") - (let (folder article) - (if (not (string-match "\\`\\([^#]+\\)\\(#\\(.*\\)\\)?" path)) - (error "Error in Wanderlust link")) - (setq folder (match-string 1 path) - article (match-string 3 path)) - (org-follow-wl-link folder article))) +See also the variable `org-reverse-note-order'." + (goto-char (point-min)) + (while (looking-at "^[ \t]*\n\\|^##.*\n") + (replace-match "")) + (catch 'quit + (let* ((txt (buffer-substring (point-min) (point-max))) + (fastp current-prefix-arg) + (file (if fastp org-default-notes-file (org-get-org-file))) + (heading org-remember-default-headline) + (visiting (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) + ;; 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) + ;; Is already a headline + (setq indent nil) + ;; We need to add a headline: Use time and first buffer line + (setq lines (cons first lines) + first (concat "* " (current-time-string) + " (" (remember-buffer-desc) ")") + indent " ")) + (if (and org-adapt-indentation indent) + (setq lines (mapcar (lambda (x) (concat indent x)) lines))) + (setq txt (concat first "\n" + (mapconcat 'identity lines "\n")))) + ;; 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)) + (save-excursion + (save-restriction + (widen) - ((string= type "mhe") - (let (folder article) - (if (not (string-match "\\`\\([^#]+\\)\\(#\\(.*\\)\\)?" path)) - (error "Error in MHE link")) - (setq folder (match-string 1 path) - article (match-string 3 path)) - (org-follow-mhe-link folder article))) + ;; 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]*$") + nil t) + (setq org-goto-start-pos (match-beginning 0)))) - ((string= type "rmail") - (let (folder article) - (if (not (string-match "\\`\\([^#]+\\)\\(#\\(.*\\)\\)?" path)) - (error "Error in RMAIL link")) - (setq folder (match-string 1 path) - article (match-string 3 path)) - (org-follow-rmail-link folder article))) + ;; Ask the User for a location + (setq spos (if fastp + org-goto-start-pos + (org-get-location (current-buffer) org-remember-help))) + (if (not spos) (throw 'quit nil)) ; return nil to show we did + ; not handle this note + (goto-char spos) + (cond ((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))) + ((and (bobp) reversed) + ;; Put it at the start, as level 1 + (save-restriction + (widen) + (goto-char (point-min)) + (re-search-forward "^\\*" nil t) + (beginning-of-line 1) + (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))) + (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. - ((string= type "shell") - (let ((cmd path)) - (while (string-match "@{" cmd) ; FIXME: not needed for [[]] links - (setq cmd (replace-match "<" t t cmd))) - (while (string-match "@}" cmd) ; FIXME: not needed for [[]] links - (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? " - (org-add-props cmd nil - 'face 'org-warning)))) - (progn - (message "Executing %s" cmd) - (shell-command cmd)) - (error "Abort")))) +(defun org-get-org-file () + "Read a filename, with default directory `org-directory'." + (let ((default (or org-default-notes-file remember-data-file))) + (read-file-name (format "File name [%s]: " default) + (file-name-as-directory org-directory) + default))) - ((string= type "elisp") - (let ((cmd path)) - (if (or (not org-confirm-elisp-link-function) - (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))) - (error "Abort")))) +(defun org-notes-order-reversed-p () + "Check if the current file should receive notes in reversed order." + (cond + ((not org-reverse-note-order) nil) + ((eq t org-reverse-note-order) t) + ((not (listp org-reverse-note-order)) nil) + (t (catch 'exit + (let ((all org-reverse-note-order) + entry) + (while (setq entry (pop all)) + (if (string-match (car entry) buffer-file-name) + (throw 'exit (cdr entry)))) + nil))))) - (t - (browse-url-at-point)))))) +;;;; Dynamic blocks -(defun org-link-expand-abbrev (link) - "Apply replacements as defined in `org-link-abbrev-alist." - (if (string-match "^\\([a-zA-Z]+\\)\\(::\\(.*\\)\\)?$" link) - (let* ((key (match-string 1 link)) - (as (or (assoc key org-link-abbrev-alist-local) - (assoc key org-link-abbrev-alist))) - (tag (and (match-end 2) (match-string 3 link))) - rpl) - (if (not as) - link - (setq rpl (cdr as)) - (cond - ((symbolp rpl) (funcall rpl tag)) - ((string-match "%s" rpl) (replace-match (or tag "") t t rpl)) - (t (concat rpl tag))))) - link)) +(defun org-find-dblock (name) + "Find the first dynamic block with name NAME in the buffer. +If not found, stay at current position and return nil." + (let (pos) + (save-excursion + (goto-char (point-min)) + (setq pos (and (re-search-forward (concat "^#\\+BEGIN:[ \t]+" name "\\>") + nil t) + (match-beginning 0)))) + (if pos (goto-char pos)) + pos)) -(defun org-link-search (s &optional type) - "Search for a link search option. -When S is a CamelCaseWord, search for a target, or for a sentence containing -the words. If S is surrounded by forward slashes, it is interpreted as a -regular expression. In org-mode files, this will create an `org-occur' -sparse tree. In ordinary files, `occur' will be used to list matches. -If the current buffer is in `dired-mode', grep will be used to search -in all files." - (let ((case-fold-search t) - (s0 (mapconcat 'identity (org-split-string s "[ \t\r\n]+") " ")) - (pos (point)) - (pre "") (post "") - words re0 re1 re2 re3 re4 re5 re2a reall camel) - (cond - ;; First check if there are any special - ((run-hook-with-args-until-success 'org-execute-file-search-functions s)) - ;; Now try the builtin stuff - ((save-excursion - (goto-char (point-min)) - (and - (re-search-forward - (concat "<<" (regexp-quote s0) ">>") nil t) - (setq pos (match-beginning 0)))) - ;; There is an exact target for this - (goto-char pos)) - ((string-match "^/\\(.*\\)/$" s) - ;; A regular expression - (cond - ((org-mode-p) - (org-occur (match-string 1 s))) - ;;((eq major-mode 'dired-mode) - ;; (grep (concat "grep -n -e '" (match-string 1 s) "' *"))) - (t (org-do-occur (match-string 1 s))))) - ((or (setq camel (string-match (concat "^" org-camel-regexp "$") s)) - t) - ;; A camel or a normal search string - (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]*\\)?$" - s (substring s 1))) - (remove-text-properties - 0 (length s) - '(face nil mouse-face nil keymap nil fontified nil) s) - ;; Make a series of regular expressions to find a match - (setq words - (if camel - (org-camel-to-words s) - (org-split-string s "[ \n\r\t]+")) - re0 (concat "\\(<<" (regexp-quote s0) ">>\\)") - re2 (concat "[ \t\r\n]\\(" (mapconcat 'downcase words "[ \t]+") "\\)[ \t\r\n]") - 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) - re3 (concat pre re4 post) - re5 (concat pre ".*" re4) - re2 (concat pre re2) - re2a (concat pre re2a) - re4 (concat pre re4) - reall (concat "\\(" re0 "\\)\\|\\(" re1 "\\)\\|\\(" re2 - "\\)\\|\\(" re3 "\\)\\|\\(" re4 "\\)\\|\\(" - re5 "\\)" - )) - (cond - ((eq type 'org-occur) (org-occur reall)) - ((eq type 'occur) (org-do-occur (downcase reall) 'cleanup)) - (t (goto-char (point-min)) - (if (or (org-search-not-link re0 nil t) - (org-search-not-link re1 nil t) - (org-search-not-link re2 nil t) - (org-search-not-link re2a nil t) - (org-search-not-link re3 nil t) - (org-search-not-link re4 nil t) - (org-search-not-link re5 nil t) - ) - (goto-char (match-beginning 1)) - (goto-char pos) - (error "No match"))))) - (t - ;; Normal string-search - (goto-char (point-min)) - (if (search-forward s nil t) - (goto-char (match-beginning 0)) - (error "No match")))) - (and (org-mode-p) (org-show-context 'link-search)))) +(defconst org-dblock-start-re + "^#\\+BEGIN:[ \t]+\\(\\S-+\\)\\([ \t]+\\(.*\\)\\)?" + "Matches the startline of a dynamic block, with parameters.") -(defun org-search-not-link (&rest args) - "Execute `re-search-forward', but only accept matches that are not a link." - (catch 'exit - (let (p1) - (while (apply 're-search-forward args) - (setq p1 (point)) - (if (not (save-match-data - (and (re-search-backward "\\[\\[" nil t) - (looking-at org-bracket-link-regexp) - (<= (match-beginning 0) p1) - (>= (match-end 0) p1)))) - (progn (goto-char (match-end 0)) - (throw 'exit (point))) - (goto-char (match-end 0))))))) +(defconst org-dblock-end-re "^#\\+END\\([: \t\r\n]\\|$\\)" + "Matches the end of a dyhamic block.") -(defun org-get-buffer-for-internal-link (buffer) - "Return a buffer to be used for displaying the link target of internal links." - (cond - ((not org-display-internal-link-with-indirect-buffer) - buffer) - ((string-match "(Clone)$" (buffer-name buffer)) - (message "Buffer is already a clone, not making another one") - ;; we also do not modify visibility in this case - buffer) - (t ; make a new indirect buffer for displaying the link - (let* ((bn (buffer-name buffer)) - (ibn (concat bn "(Clone)")) - (ib (or (get-buffer ibn) (make-indirect-buffer buffer ibn 'clone)))) - (with-current-buffer ib (org-overview)) - ib)))) +(defun org-create-dblock (plist) + "Create a dynamic block section, with parameters taken from PLIST. +PLIST must containe a :name entry which is used as name of the block." + (unless (bolp) (newline)) + (let ((name (plist-get plist :name))) + (insert "#+BEGIN: " name) + (while plist + (if (eq (car plist) :name) + (setq plist (cddr plist)) + (insert " " (prin1-to-string (pop plist))))) + (insert "\n\n#+END:\n") + (beginning-of-line -2))) -(defun org-do-occur (regexp &optional cleanup) - "Call the Emacs command `occur'. -If CLEANUP is non-nil, remove the printout of the regular expression -in the *Occur* buffer. This is useful if the regex is long and not useful -to read." - (occur regexp) - (when cleanup - (let ((cwin (selected-window)) win beg end) - (when (setq win (get-buffer-window "*Occur*")) - (select-window win)) - (goto-char (point-min)) - (when (re-search-forward "match[a-z]+" nil t) - (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))) - (goto-char (point-min)) - (select-window cwin)))) +(defun org-prepare-dblock () + "Prepare dynamic block for refresh. +This empties the block, puts the cursor at the insert position and returns +the property list including an extra property :name with the block name." + (unless (looking-at org-dblock-start-re) + (error "Not at a dynamic block")) + (let* ((begdel (1+ (match-end 0))) + (name (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")) + (delete-region begdel (match-beginning 0)) + (goto-char begdel) + (open-line 1) + params)) -(defvar org-mark-ring nil - "Mark ring for positions before jumps in Org-mode.") -(defvar org-mark-ring-last-goto nil - "Last position in the mark ring used to go back.") -;; Fill and close the ring -(setq org-mark-ring nil org-mark-ring-last-goto nil) ;; in case file is reloaded -(loop for i from 1 to org-mark-ring-length do - (push (make-marker) org-mark-ring)) -(setcdr (nthcdr (1- org-mark-ring-length) org-mark-ring) - org-mark-ring) +(defun org-map-dblocks (&optional command) + "Apply COMMAND to all dynamic blocks in the current buffer. +If COMMAND is not given, use `org-update-dblock'." + (let ((cmd (or command 'org-update-dblock)) + pos) + (save-excursion + (goto-char (point-min)) + (while (re-search-forward org-dblock-start-re nil t) + (goto-char (setq pos (match-beginning 0))) + (condition-case nil + (funcall cmd) + (error (message "Error during update of dynamic block"))) + (goto-char pos) + (unless (re-search-forward org-dblock-end-re nil t) + (error "Dynamic block not terminated")))))) -(defun org-mark-ring-push (&optional pos buffer) - "Put the current position or POS into the mark ring and rotate it." - (interactive) - (setq pos (or pos (point))) - (setq org-mark-ring (nthcdr (1- org-mark-ring-length) org-mark-ring)) - (move-marker (car org-mark-ring) - (or pos (point)) - (or buffer (current-buffer))) - (message - (substitute-command-keys - "Position saved to mark ring, go back with \\[org-mark-ring-goto]."))) +(defun org-dblock-update (&optional arg) + "User command for updating dynamic blocks. +Update the dynamic block at point. With prefix ARG, update all dynamic +blocks in the buffer." + (interactive "P") + (if arg + (org-update-all-dblocks) + (or (looking-at org-dblock-start-re) + (org-beginning-of-dblock)) + (org-update-dblock))) -(defun org-mark-ring-goto (&optional n) - "Jump to the previous position in the mark ring. -With prefix arg N, jump back that many stored positions. When -called several times in succession, walk through the entire ring. -Org-mode commands jumping to a different position in the current file, -or to another Org-mode file, automatically push the old position -onto the ring." - (interactive "p") - (let (p m) - (if (eq last-command this-command) - (setq p (nthcdr n (or org-mark-ring-last-goto org-mark-ring))) - (setq p org-mark-ring)) - (setq org-mark-ring-last-goto p) - (setq m (car p)) - (switch-to-buffer (marker-buffer m)) - (goto-char m) - (if (or (org-invisible-p) (org-invisible-p2)) (org-show-context 'mark-goto)))) +(defun org-update-dblock () + "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))) -(defun org-camel-to-words (s) - "Split \"CamelCaseWords\" to (\"Camel\" \"Case\" \"Words\")." - (let ((case-fold-search nil) - words) - (while (string-match "[a-z][A-Z]" s) - (push (substring s 0 (1+ (match-beginning 0))) words) - (setq s (substring s (1+ (match-beginning 0))))) - (nreverse (cons s words)))) +(defun org-beginning-of-dblock () + "Find the beginning of the dynamic block at point. +Error if there is no scuh block at point." + (let ((pos (point)) + beg) + (end-of-line 1) + (if (and (re-search-backward org-dblock-start-re nil t) + (setq beg (match-beginning 0)) + (re-search-forward org-dblock-end-re nil t) + (> (match-end 0) pos)) + (goto-char beg) + (goto-char pos) + (error "Not in a dynamic block")))) -(defun org-remove-angle-brackets (s) - (if (equal (substring s 0 1) "<") (setq s (substring s 1))) - (if (equal (substring s -1) ">") (setq s (substring s 0 -1))) - s) -(defun org-add-angle-brackets (s) - (if (equal (substring s 0 1) "<") nil (setq s (concat "<" s))) - (if (equal (substring s -1) ">") nil (setq s (concat s ">"))) - s) +(defun org-update-all-dblocks () + "Update all dynamic blocks in the buffer. +This function can be used in a hook." + (when (org-mode-p) + (org-map-dblocks 'org-update-dblock))) -(defun org-follow-timestamp-link () - (cond - ((org-at-date-range-p t) - (let ((org-agenda-start-on-weekday) - (t1 (match-string 1)) - (t2 (match-string 2))) - (setq t1 (time-to-days (org-time-string-to-time t1)) - t2 (time-to-days (org-time-string-to-time t2))) - (org-agenda-list nil t1 (1+ (- t2 t1))))) - ((org-at-timestamp-p t) - (org-agenda-list nil (time-to-days (org-time-string-to-time - (substring (match-string 1) 0 10))) - 1)) - (t (error "This should not happen")))) +;;;; Completion -(defun org-follow-bbdb-link (name) - "Follow a BBDB link to NAME." - (require 'bbdb) - (let ((inhibit-redisplay t) - (bbdb-electric-p nil)) - (catch 'exit - ;; Exact match on name - (bbdb-name (concat "\\`" name "\\'") nil) - (if (< 0 (buffer-size (get-buffer "*BBDB*"))) (throw 'exit nil)) - ;; Exact match on name - (bbdb-company (concat "\\`" name "\\'") nil) - (if (< 0 (buffer-size (get-buffer "*BBDB*"))) (throw 'exit nil)) - ;; Partial match on name - (bbdb-name name nil) - (if (< 0 (buffer-size (get-buffer "*BBDB*"))) (throw 'exit nil)) - ;; Partial match on company - (bbdb-company name nil) - (if (< 0 (buffer-size (get-buffer "*BBDB*"))) (throw 'exit nil)) - ;; General match including network address and notes - (bbdb name nil) - (when (= 0 (buffer-size (get-buffer "*BBDB*"))) - (delete-window (get-buffer-window "*BBDB*")) - (error "No matching BBDB record"))))) - - -(defun org-follow-info-link (name) - "Follow an info file & node link to NAME." - (if (or (string-match "\\(.*\\)::?\\(.*\\)" name) - (string-match "\\(.*\\)" name)) - (progn - (require 'info) - (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)))) - -(defun org-follow-gnus-link (&optional group article) - "Follow a Gnus link to GROUP and ARTICLE." - (require 'gnus) - (funcall (cdr (assq 'gnus org-link-frame-setup))) - (if gnus-other-frame-object (select-frame gnus-other-frame-object)) - (if group (gnus-fetch-group group)) - (if article - (or (gnus-summary-goto-article article nil 'force) - (if (fboundp 'gnus-summary-insert-cached-articles) - (progn - (gnus-summary-insert-cached-articles) - (gnus-summary-goto-article article nil 'force)) - (message "Message could not be found."))))) +(defun org-complete (&optional arg) + "Perform completion on word at point. +At the beginning of a headline, this completes TODO keywords as given in +`org-todo-keywords'. +If the current word is preceded by a backslash, completes the TeX symbols +that are supported for HTML support. +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'." + (interactive "P") + (catch 'exit + (let* ((end (point)) + (beg1 (save-excursion + (skip-chars-backward "a-zA-Z_@0-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")))))) -(defun org-follow-vm-link (&optional folder article readonly) - "Follow a VM link to FOLDER and ARTICLE." - (require 'vm) - (setq article (org-add-angle-brackets article)) - (if (string-match "^//\\([a-zA-Z]+@\\)?\\([^:]+\\):\\(.*\\)" folder) - ;; ange-ftp or efs or tramp access - (let ((user (or (match-string 1 folder) (user-login-name))) - (host (match-string 2 folder)) - (file (match-string 3 folder))) - (cond - ((featurep 'tramp) - ;; use tramp to access the file - (if (featurep 'xemacs) - (setq folder (format "[%s@%s]%s" user host file)) - (setq folder (format "/%s@%s:%s" user host file)))) - (t - ;; use ange-ftp or efs - (require (if (featurep 'xemacs) 'efs 'ange-ftp)) - (setq folder (format "/%s@%s:%s" user host file)))))) - (when folder - (funcall (cdr (assq 'vm org-link-frame-setup)) folder readonly) - (sit-for 0.1) - (when article - (vm-select-folder-buffer) - (widen) - (let ((case-fold-search t)) - (goto-char (point-min)) - (if (not (re-search-forward - (concat "^" "message-id: *" (regexp-quote article)))) - (error "Could not find the specified message in this folder")) - (vm-isearch-update) - (vm-isearch-narrow) - (vm-beginning-of-message) - (vm-summarize))))) +;;;; TODO, DEADLINE, Comments -(defun org-follow-wl-link (folder article) - "Follow a Wanderlust link to FOLDER and ARTICLE." - (setq article (org-add-angle-brackets article)) - (wl-summary-goto-folder-subr folder 'no-sync t nil t) - (if article (wl-summary-jump-to-msg-by-message-id article ">")) - (wl-summary-redisplay)) +(defun org-toggle-comment () + "Change the COMMENT state of an entry." + (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)))))) -(defun org-follow-rmail-link (folder article) - "Follow an RMAIL link to FOLDER and ARTICLE." - (setq article (org-add-angle-brackets article)) - (let (message-number) - (save-excursion - (save-window-excursion - (rmail (if (string= folder "RMAIL") rmail-file-name folder)) - (setq message-number - (save-restriction - (widen) - (goto-char (point-max)) - (if (re-search-backward - (concat "^Message-ID:\\s-+" (regexp-quote - (or article ""))) - nil t) - (rmail-what-message)))))) - (if message-number - (progn - (rmail (if (string= folder "RMAIL") rmail-file-name folder)) - (rmail-show-message message-number) - message-number) - (error "Message not found")))) +(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.") -;; mh-e integration based on planner-mode -(defun org-mhe-get-message-real-folder () - "Return the name of the current message real folder, so if you use -sequences, it will now work." - (save-excursion - (let* ((folder - (if (equal major-mode 'mh-folder-mode) - mh-current-folder - ;; Refer to the show buffer - mh-show-folder-buffer)) - (end-index - (if (boundp 'mh-index-folder) - (min (length mh-index-folder) (length folder)))) - ) - ;; a simple test on mh-index-data does not work, because - ;; mh-index-data is always nil in a show buffer. - (if (and (boundp 'mh-index-folder) - (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) - ) - )) - (org-mhe-get-message-folder-from-index) - ) - folder - ) - ))) +(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, +like + *** TODO Write paper + *** DONE Call mom -(defun org-mhe-get-message-folder-from-index () - "Returns the name of the message folder in a index folder buffer." - (save-excursion - (mh-index-previous-folder) - (re-search-forward "^\\(+.*\\)$" nil t) - (message (match-string 1)))) +The different keywords are specified in the variable `org-todo-keywords'. +By default the available states are \"TODO\" and \"DONE\". +So for this example: when the item starts with TODO, it is changed to DONE. +When it starts with DONE, the DONE is removed. And when neither TODO nor +DONE are present, add TODO at the beginning of the heading. -(defun org-mhe-get-message-folder () - "Return the name of the current message folder. Be careful if you -use sequences." - (save-excursion - (if (equal major-mode 'mh-folder-mode) - mh-current-folder - ;; Refer to the show buffer - mh-show-folder-buffer))) +With C-u prefix arg, use completion to determine the new state. +With numeric prefix arg, switch to that state. -(defun org-mhe-get-message-num () - "Return the number of the current message. Be careful if you -use sequences." +For calling through lisp, arg is also interpreted in the following way: +'none -> empty state +\"\"(empty string) -> switch to empty state +'done -> switch to DONE +\"WAITING\" -> switch to the specified keyword, but only if it + really is a member of `org-todo-keywords'." + (interactive "P") (save-excursion - (if (equal major-mode 'mh-folder-mode) - (mh-get-msg-num nil) - ;; Refer to the show buffer - (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 -idea..." - (let* ((folder (org-mhe-get-message-folder)) - (num (org-mhe-get-message-num)) - (buffer (get-buffer-create (concat "show-" folder))) - (header-field)) - (with-current-buffer buffer - (mh-display-msg num folder) - (if (equal major-mode 'mh-folder-mode) - (mh-header-display) - (mh-show-header-display)) - (set-buffer buffer) - (setq header-field (mh-get-header-field header)) - (if (equal major-mode 'mh-folder-mode) - (mh-show) - (mh-show-show)) - header-field))) + (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 + (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))) + (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)))) -(defun org-follow-mhe-link (folder article) - "Follow an MHE link to FOLDER and ARTICLE. -If ARTICLE is nil FOLDER is shown. If the configuration variable -`org-mhe-search-all-folders' is t and `mh-searcher' is pick, -ARTICLE is searched in all folders. Indexed searches (swish++, -namazu, and others supported by MH-E) will always search in all -folders." - (require 'mh-e) - (require 'mh-search) - (require 'mh-utils) - (mh-find-path) - (if (not article) - (mh-visit-folder (mh-normalize-folder-name folder)) - (setq article (org-add-angle-brackets article)) - (mh-search-choose) - (if (equal mh-searcher 'pick) - (progn - (mh-search folder (list "--message-id" article)) - (when (and org-mhe-search-all-folders - (not (org-mhe-get-message-real-folder))) - (kill-this-buffer) - (mh-search "+" (list "--message-id" article)))) - (mh-search "+" article)) - (if (org-mhe-get-message-real-folder) - (mh-show-msg 1) - (kill-this-buffer) - (error "Message not found")))) +(defun org-get-repeat () + "Return the REPEAT statement of this entry." + (save-match-data + (save-excursion + (org-back-to-heading t) + (if (re-search-forward + org-repeat-re (save-excursion (outline-next-heading) (point)) t) + (match-string 1))))) + +(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'." + ;; 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) + (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))) + (org-back-to-heading t) + (org-add-planning-info nil nil 'closed) + (setq re (concat "\\(" org-scheduled-time-regexp "\\)\\|\\(" + org-deadline-time-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)) + (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 " "))) + (setq org-log-post-message msg) + (message msg)))) -;; BibTeX links +(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 numeric prefix N, construct a sparse tree for the Nth element +of `org-todo-keywords'." + (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)) + (regexp-quote (nth (1- (prefix-numeric-value arg)) + org-todo-keywords))) + (t (error "Invalid prefix argument: %s" arg))))) + (message "%d TODO entries found" + (org-occur (concat "^" outline-regexp " +" kwd-re ))))) -;; Use the custom search meachnism to construct and use search strings for -;; file links to BibTeX database entries. +(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-create-file-search-in-bibtex () - "Create the search string and description for a BibTeX database entry." - (when (eq major-mode 'bibtex-mode) - ;; yes, we want to construct this search string. - ;; Make a good description for this entry, using names, year and the title - ;; Put it into the `description' variable which is dynamically scoped. - (let ((bibtex-autokey-names 1) - (bibtex-autokey-names-stretch 1) - (bibtex-autokey-name-case-convert-function 'identity) - (bibtex-autokey-name-separator " & ") - (bibtex-autokey-additional-names " et al.") - (bibtex-autokey-year-length 4) - (bibtex-autokey-name-year-separator " ") - (bibtex-autokey-titlewords 3) - (bibtex-autokey-titleword-separator " ") - (bibtex-autokey-titleword-case-convert-function 'identity) - (bibtex-autokey-titleword-length 'infty) - (bibtex-autokey-year-title-separator ": ")) - (setq description (bibtex-generate-autokey))) - ;; Now parse the entry, get the key and return it. +(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-add-planning-info (what &optional time &rest remove) + "Insert new timestamp with keyword in the line directly after the headline. +WHAT indicates what kind of time stamp to add. TIME indicated the time to use. +If non is given, the user is prompted for a date. +REMOVE indicates what kind of entries to remove. An old WHAT entry will also +be removed." + (interactive) + (let (org-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) + (setq what nil)) (save-excursion - (bibtex-beginning-of-entry) - (cdr (assoc "=key=" (bibtex-parse-entry)))))) + (save-restriction + (let (col list elt ts buffer-invisibility-spec) + (org-back-to-heading t) + (looking-at (concat outline-regexp "\\( *\\)[^\r\n]*")) + (goto-char (match-end 1)) + (setq col (current-column)) + (goto-char (1+ (match-end 0))) + (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") + (backward-char 1) + (narrow-to-region (point) (point)) + (indent-to-column col)) + ;; Check if we have to remove something. + (setq list (cons what remove)) + (while list + (setq elt (pop list)) + (goto-char (point-min)) + (when (or (and (eq elt 'scheduled) + (re-search-forward org-scheduled-time-regexp nil t)) + (and (eq elt 'deadline) + (re-search-forward org-deadline-time-regexp nil t)) + (and (eq elt 'closed) + (re-search-forward org-closed-time-regexp nil t))) + (replace-match "") + (if (looking-at "--+<[^>]+>") (replace-match "")) + (if (looking-at " +") (replace-match "")))) + (goto-char (point-max)) + (when what + (insert + (if (not (equal (char-before) ?\ )) " " "") + (cond ((eq what 'scheduled) org-scheduled-string) + ((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)) + (end-of-line 1)) + (goto-char (point-min)) + (widen) + (if (looking-at "[ \t]+\r?\n") + (replace-match "")) + ts))))) -(defun org-execute-file-search-in-bibtex (s) - "Find the link search string S as a key for a database entry." - (when (eq major-mode 'bibtex-mode) - ;; Yes, we want to do the search in this file. - ;; We construct a regexp that searches for "@entrytype{" followed by the key - (goto-char (point-min)) - (and (re-search-forward (concat "@[a-zA-Z]+[ \t\n]*{[ \t\n]*" - (regexp-quote s) "[ \t\n]*,") nil t) - (goto-char (match-beginning 0))) - (if (and (match-beginning 0) (equal current-prefix-arg '(16))) - ;; Use double prefix to indicate that any web link should be browsed - (let ((b (current-buffer)) (p (point))) - ;; Restore the window configuration because we just use the web link - (set-window-configuration org-window-config-before-follow-link) - (save-excursion (set-buffer b) (goto-char p) - (bibtex-url))) - (recenter 0)) ; Move entry start to beginning of window - ;; return t to indicate that the search is done. - t)) +(defvar org-log-note-marker (make-marker)) +(defvar org-log-note-purpose nil) +(defvar org-log-note-state 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.") -;; Finally add the functions to the right hooks. -(add-hook 'org-create-file-search-functions 'org-create-file-search-in-bibtex) -(add-hook 'org-execute-file-search-functions 'org-execute-file-search-in-bibtex) +(defun org-add-log-maybe (&optional purpose state findpos) + (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)))) -;; end of Bibtex link setup +(defun org-add-log-note (&optional purpose) + "Pop up a window for taking a note, and add this note later at point." + (remove-hook 'post-command-hook 'org-add-log-note) + (setq org-log-note-window-configuration (current-window-configuration)) + (delete-other-windows) + (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*") + (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") + (t (error "This should not happen"))))) + (org-set-local 'org-finish-function 'org-store-log-note)) -(defun org-upgrade-old-links (&optional query-description) - "Transfer old <...> style links to new [[...]] style links. -With arg query-description, ask at each match for a description text to use -for this link." - (interactive (list (y-or-n-p "Would you like to be queried for a description at each link?"))) - (save-excursion - (goto-char (point-min)) - (let ((re (concat "\\([^[]\\)<\\(" - "\\(" (mapconcat 'identity org-link-types "\\|") - "\\):" - "[^" org-non-link-chars "]+\\)>")) - l1 l2 (cnt 0)) - (while (re-search-forward re nil t) - (setq cnt (1+ cnt) - l1 (org-match-string-no-properties 2) - l2 (save-match-data (org-link-escape l1))) - (when query-description (setq l1 (read-string "Desc: " l1))) - (if (equal l1 l2) - (replace-match (concat (match-string 1) "[[" l1 "]]") t t) - (replace-match (concat (match-string 1) "[[" l2 "][" l1 "]]") t t))) - (message "%d matches have beed treated" cnt)))) +(defun org-store-log-note () + "Finish taking a log note, and insert it to where it belongs." + (let ((txt (buffer-string)) + (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))) + (if (string-match "\\s-+\\'" txt) + (setq txt (replace-match "" t t txt))) + (setq lines (org-split-string txt "\n")) + (when (and note (string-match "\\S-" note)) + (setq note + (org-replace-escapes + note + (list (cons "%u" (user-login-name)) + (cons "%U" user-full-name) + (cons "%t" (format-time-string + (org-time-stamp-format 'long 'inactive) + (current-time))) + (cons "%s" (if org-log-note-state + (concat "\"" org-log-note-state "\"") + ""))))) + (if lines (setq note (concat note " \\\\"))) + (push note lines)) + (save-excursion + (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)) (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-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))) -(defun org-open-file (path &optional in-emacs line search) - "Open the file at PATH. -First, this expands any special file name abbreviations. Then the -configuration variable `org-file-apps' is checked if it contains an -entry for this file type, and if yes, the corresponding command is launched. -If no application is found, Emacs simply visits the file. -With optional argument IN-EMACS, Emacs will visit the file. -Optional LINE specifies a line to go to, optional SEARCH a string to -search for. If LINE or SEARCH is given, the file will always be -opened in Emacs. -If the file does not exist, an error is thrown." - (setq in-emacs (or in-emacs line search)) - (let* ((file (if (equal path "") - buffer-file-name - (substitute-in-file-name (expand-file-name path)))) - (apps (append org-file-apps (org-default-apps))) - (remp (and (assq 'remote apps) (org-file-remote-p file))) - (dirp (if remp nil (file-directory-p file))) - (dfile (downcase file)) - (old-buffer (current-buffer)) - (old-pos (point)) - (old-mode major-mode) - ext cmd) - (if (string-match "^.*\\.\\([a-zA-Z0-9]+\\.gz\\)$" dfile) - (setq ext (match-string 1 dfile)) - (if (string-match "^.*\\.\\([a-zA-Z0-9]+\\)$" dfile) - (setq ext (match-string 1 dfile)))) - (if in-emacs - (setq cmd 'emacs) - (setq cmd (or (and remp (cdr (assoc 'remote apps))) - (and dirp (cdr (assoc 'directory apps))) - (cdr (assoc ext apps)) - (cdr (assoc t apps))))) - (when (eq cmd 'mailcap) - (require 'mailcap) - (mailcap-parse-mailcaps) - (let* ((mime-type (mailcap-extension-to-mime (or ext ""))) - (command (mailcap-mime-info mime-type))) - (if (stringp command) - (setq cmd command) - (setq cmd 'emacs)))) - (if (and (not (eq cmd 'emacs)) ; Emacs has not 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))) - (save-window-excursion - (shell-command (concat cmd " &")))) - ((or (stringp cmd) - (eq cmd 'emacs)) -; (unless (equal (file-truename file) (file-truename (or buffer-file-name ""))) -; (funcall (cdr (assq 'file org-link-frame-setup)) file)) - (funcall (cdr (assq 'file org-link-frame-setup)) file) - (if line (goto-line line) - (if search (org-link-search search)))) - ((consp cmd) - (eval cmd)) - (t (funcall (cdr (assq 'file org-link-frame-setup)) file))) - (and (org-mode-p) (eq old-mode 'org-mode) - (or (not (equal old-buffer (current-buffer))) - (not (equal old-pos (point)))) - (org-mark-ring-push old-pos old-buffer)))) +(defvar org-occur-highlights nil) +(make-variable-buffer-local 'org-occur-highlights) -(defun org-default-apps () - "Return the default applications for this operating system." - (cond - ((eq system-type 'darwin) - org-file-apps-defaults-macosx) - ((eq system-type 'windows-nt) - org-file-apps-defaults-windowsnt) - (t org-file-apps-defaults-gnu))) +(defun org-occur (regexp &optional keep-previous callback) + "Make a compact tree which shows all matches of REGEXP. +The tree will show the lines where the regexp matches, and all higher +headlines above the match. It will also show the heading after the match, +to make sure editing the matching entry is easy. +If KEEP-PREVIOUS is non-nil, highlighting and exposing done by a previous +call to `org-occur' will be kept, to allow stacking of calls to this +command. +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)) + (let ((cnt 0)) + (save-excursion + (goto-char (point-min)) + (if (or (not keep-previous) ; do not want to keep + (not org-occur-highlights)) ; no previous matches + ;; hide everything + (org-overview)) + (while (re-search-forward regexp nil t) + (when (or (not callback) + (save-match-data (funcall callback))) + (setq cnt (1+ cnt)) + (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 + nil 'local)) + (unless org-sparse-tree-open-archived-trees + (org-hide-archived-subtrees (point-min) (point-max))) + (run-hooks 'org-occur-hook) + (if (interactive-p) + (message "%d match(es) for regexp %s" cnt regexp)) + cnt)) -(defun org-expand-file-name (path) - "Replace special path abbreviations and expand the file name." - (expand-file-name path)) +(defun org-show-context (&optional key) + "Make sure point and context and visible. +How much context is shown depends upon the variables +`org-show-hierarchy-above', `org-show-following-heading'. and +`org-show-siblings'." + (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)) + (siblings-p (org-get-alist-option org-show-siblings key))) + (catch 'exit + ;; Show heading or entry text + (if heading-p + (org-flag-heading nil) ; only show the heading + (and (or (org-invisible-p) (org-invisible-p2)) + (org-show-hidden-entry))) ; show entire entry + (when following-p + ;; Show next sibling, or heading below text + (save-excursion + (and (if heading-p (org-goto-sibling) (outline-next-heading)) + (org-flag-heading nil)))) + (when siblings-p (org-show-siblings)) + (when hierarchy-p + ;; show all higher headings, possibly with siblings + (save-excursion + (while (and (condition-case nil + (progn (org-up-heading-all 1) t) + (error nil)) + (not (bobp))) + (org-flag-heading nil) + (when siblings-p (org-show-siblings)))))))) -(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. -Return non-nil if the location is indeed remote. +(defun org-reveal (&optional siblings) + "Show current entry, hierarchy above it, and the following headline. +This can be used to show a consistent set of context around locations +exposed with `org-show-hierarchy-above' or `org-show-following-heading' +not t for the search context. -For example, the filename \"/user@host:/foo\" specifies a location -on the system \"/user@host:\"." - (cond ((fboundp 'file-remote-p) - (file-remote-p file)) - ((fboundp 'tramp-handle-file-remote-p) - (tramp-handle-file-remote-p file)) - ((and (boundp 'ange-ftp-name-format) - (string-match (car ange-ftp-name-format) file)) - t) - (t nil))) +With optional argument SIBLINGS, on each level of the hierarchy all +siblings are shown. This repairs the tree structure to what it would +look like when opened with hierarchical calls to `org-cycle'." + (interactive "P") + (let ((org-show-hierarchy-above t) + (org-show-following-heading t) + (org-show-siblings (if siblings t org-show-siblings))) + (org-show-context nil))) -(defvar org-insert-link-history nil - "Minibuffer history for links inserted with `org-insert-link'.") +(defun org-highlight-new-match (beg end) + "Highlight from BEG to END and mark the highlight is an occur headline." + (let ((ov (org-make-overlay beg end))) + (org-overlay-put ov 'face 'secondary-selection) + (push ov org-occur-highlights))) -(defvar org-stored-links nil - "Contains the links stored with `org-store-link'.") +(defun org-remove-occur-highlights (&optional beg end noremove) + "Remove the occur highlights from the buffer. +BEG and END are ignored. If NOREMOVE is nil, remove this function +from the `before-change-functions' in the current buffer." + (interactive) + (unless org-inhibit-highlight-removal + (mapc 'org-delete-overlay org-occur-highlights) + (setq org-occur-highlights nil) + (unless noremove + (remove-hook 'before-change-functions + 'org-remove-occur-highlights 'local)))) -;;;###autoload -(defun org-store-link (arg) - "\\Store an org-link to the current location. -This link 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") - (let (link cpltxt desc description search txt (pos (point))) - (cond +;;;; Priorities - ((eq major-mode 'bbdb-mode) - (setq cpltxt (concat - "bbdb:" - (or (bbdb-record-name (bbdb-current-record)) - (bbdb-record-company (bbdb-current-record)))) - link (org-make-link cpltxt))) +(defvar org-priority-regexp ".*?\\(\\[#\\([A-Z]\\)\\] ?\\)" + "Regular expression matching the priority indicator.") - ((eq major-mode 'Info-mode) - (setq link (org-make-link "info:" - (file-name-nondirectory Info-current-file) - ":" Info-current-node)) - (setq cpltxt (concat (file-name-nondirectory Info-current-file) - ":" Info-current-node))) +(defvar org-remove-priority-next-time nil) - ((eq major-mode 'calendar-mode) - (let ((cd (calendar-cursor-to-date))) - (setq link - (format-time-string - (car org-time-stamp-formats) - (apply 'encode-time - (list 0 0 0 (nth 1 cd) (nth 0 cd) (nth 2 cd) - nil nil nil)))))) +(defun org-priority-up () + "Increase the priority of the current item." + (interactive) + (org-priority 'up)) - ((or (eq major-mode 'vm-summary-mode) - (eq major-mode 'vm-presentation-mode)) - (and (eq major-mode 'vm-presentation-mode) (vm-summarize)) - (vm-follow-summary-cursor) - (save-excursion - (vm-select-folder-buffer) - (let* ((message (car vm-message-pointer)) - (folder buffer-file-name) - (subject (vm-su-subject message)) - (author (vm-su-full-name message)) - (message-id (vm-su-message-id message))) - (setq message-id (org-remove-angle-brackets message-id)) - (setq folder (abbreviate-file-name folder)) - (if (string-match (concat "^" (regexp-quote vm-folder-directory)) - folder) - (setq folder (replace-match "" t t folder))) - (setq cpltxt (concat author " on: " subject)) - (setq link (org-make-link "vm:" folder "#" message-id))))) +(defun org-priority-down () + "Decrease the priority of the current item." + (interactive) + (org-priority 'down)) - ((eq major-mode 'wl-summary-mode) - (let* ((msgnum (wl-summary-message-number)) - (message-id (elmo-message-field wl-summary-buffer-elmo-folder - msgnum 'message-id)) - (wl-message-entity (elmo-msgdb-overview-get-entity - msgnum (wl-summary-buffer-msgdb))) - (author (wl-summary-line-from)) ; FIXME: correct? - (subject "???")) ; FIXME: - (setq message-id (org-remove-angle-brackets message-id)) - (setq cpltxt (concat author " on: " subject)) - (setq link (org-make-link "wl:" wl-summary-buffer-folder-name - "#" message-id)))) +(defun org-priority (&optional action) + "Change the priority of an item by ARG. +ACTION can be set, up, or down." + (interactive) + (setq action (or action 'set)) + (let (current new news have remove) + (save-excursion + (org-back-to-heading) + (if (looking-at org-priority-regexp) + (setq current (string-to-char (match-string 2)) + 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)) + (cond ((equal new ?\ ) (setq remove t)) + ((or (< (upcase new) ?A) (> (upcase new) org-lowest-priority)) + (error "Priority must be between `%c' and `%c'" + ?A org-lowest-priority)))) + ((eq action 'up) + (setq new (1- current))) + ((eq action 'down) + (setq new (1+ current))) + (t (error "Invalid action"))) + (setq new (min (max ?A (upcase new)) org-lowest-priority)) + (setq news (format "%c" new)) + (if have + (if remove + (replace-match "" t t nil 1) + (replace-match news t t nil 2)) + (if remove + (error "No priority cookie found in line") + (looking-at org-todo-line-regexp) + (if (match-end 2) + (progn + (goto-char (match-end 2)) + (insert " [#" news "]")) + (goto-char (match-beginning 3)) + (insert "[#" news "] "))))) + (if remove + (message "Priority removed") + (message "Priority of current item set to %s" news)))) - ((or (equal major-mode 'mh-folder-mode) - (equal major-mode 'mh-show-mode)) - (let ((from-header (org-mhe-get-header "From:")) - (to-header (org-mhe-get-header "To:")) - (subject (org-mhe-get-header "Subject:"))) - (setq cpltxt (concat from-header " on: " subject)) - (setq link (org-make-link "mhe:" (org-mhe-get-message-real-folder) "#" - (org-remove-angle-brackets - (org-mhe-get-header "Message-Id:")))))) - ((eq major-mode 'rmail-mode) - (save-excursion - (save-restriction - (rmail-narrow-to-non-pruned-header) - (let ((folder buffer-file-name) - (message-id (mail-fetch-field "message-id")) - (author (mail-fetch-field "from")) - (subject (mail-fetch-field "subject"))) - (setq message-id (org-remove-angle-brackets message-id)) - (setq cpltxt (concat author " on: " subject)) - (setq link (org-make-link "rmail:" folder "#" message-id)))))) - - ((eq major-mode 'gnus-group-mode) - (let ((group (cond ((fboundp 'gnus-group-group-name) ; depending on Gnus - (gnus-group-group-name)) ; version - ((fboundp 'gnus-group-name) - (gnus-group-name)) - (t "???")))) - (setq cpltxt (concat - (if (org-xor arg org-usenet-links-prefer-google) - "http://groups.google.com/groups?group=" - "gnus:") - group) - link (org-make-link cpltxt)))) +(defun org-get-priority (s) + "Find priority cookie and return priority." + (save-match-data + (if (not (string-match org-priority-regexp s)) + (* 1000 (- org-lowest-priority org-default-priority)) + (* 1000 (- org-lowest-priority + (string-to-char (match-string 2 s))))))) - ((memq major-mode '(gnus-summary-mode gnus-article-mode)) - (require 'gnus-sum) - (and (eq major-mode 'gnus-article-mode) (gnus-article-show-summary)) - (gnus-summary-beginning-of-article) - (let* ((group (car gnus-article-current)) - (article (cdr gnus-article-current)) - (header (gnus-summary-article-header article)) - (author (mail-header-from header)) - (message-id (mail-header-id header)) - (date (mail-header-date header)) - (subject (gnus-summary-subject-string))) - (setq cpltxt (concat author " on: " subject)) - (if (org-xor arg org-usenet-links-prefer-google) - (setq link - (concat - cpltxt "\n " - (format "http://groups.google.com/groups?as_umsgid=%s" - (org-fixup-message-id-for-http message-id)))) - (setq link (org-make-link "gnus:" group - "#" (number-to-string article)))))) +;;;; Tags - ((eq major-mode 'w3-mode) - (setq cpltxt (url-view-url t) - link (org-make-link cpltxt))) - ((eq major-mode 'w3m-mode) - (setq cpltxt (or w3m-current-title w3m-current-url) - link (org-make-link w3m-current-url))) +(defun org-scan-tags (action matcher &optional todo-only) + "Scan headline tags with inheritance and produce output ACTION. +ACTION can be `sparse-tree' or `agenda'. MATCHER is a Lisp form to be +evaluated, testing if a given set of tags qualifies a headline for +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]*$")) + (props (list 'face nil + 'done-face 'org-done + 'undone-face nil + 'mouse-face 'highlight + 'org-not-done-regexp org-not-done-regexp + 'keymap org-agenda-keymap + 'help-echo + (format "mouse-2 or RET jump to org file %s" + (abbreviate-file-name buffer-file-name)))) + (case-fold-search nil) + lspos + tags tags-list tags-alist (llast 0) rtn level category i txt + todo marker entry) + (save-excursion + (goto-char (point-min)) + (when (eq action 'sparse-tree) (org-overview)) + (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) + category (org-get-category)) + (setq i llast llast level) + ;; remove tag lists from same and sublevels + (while (>= i level) + (when (setq entry (assoc i tags-alist)) + (setq tags-alist (delete entry tags-alist))) + (setq i (1- i))) + ;; add the nex tags + (when tags + (setq tags (mapcar 'downcase (org-split-string tags ":")) + tags-alist + (cons (cons level tags) tags-alist))) + ;; compile tags for current headline + (setq tags-list + (if org-use-tag-inheritance + (apply 'append (mapcar 'cdr tags-alist)) + tags)) + (when (and (or (not todo-only) todo) + (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 + (org-show-context 'tags-tree)) + (setq txt (org-format-agenda-item + "" + (concat + (if org-tags-match-list-sublevels + (make-string (1- level) ?.) "") + (org-get-heading)) + category tags-list)) + (goto-char lspos) + (setq marker (org-agenda-new-marker)) + (org-add-props txt props + 'org-marker marker 'org-hd-marker marker 'org-category category) + (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)))))) + (when (and (eq action 'sparse-tree) + (not org-sparse-tree-open-archived-trees)) + (org-hide-archived-subtrees (point-min) (point-max))) + (nreverse rtn))) - ((setq search (run-hook-with-args-until-success - 'org-create-file-search-functions)) - (setq link (concat "file:" (abbreviate-file-name buffer-file-name) - "::" search)) - (setq cpltxt (or description link))) +(defvar todo-only) ;; dynamically scoped - ((eq major-mode 'image-mode) - (setq cpltxt (concat "file:" - (abbreviate-file-name buffer-file-name)) - link (org-make-link cpltxt))) +(defun org-tags-sparse-tree (&optional todo-only match) + "Create a sparse tree according to tags string MATCH. +MATCH can contain positive and negative selection of tags, like +\"+WORK+URGENT-WITHBOSS\". +If optional argument TODO_ONLY is non-nil, only select lines that are +also TODO lines." + (interactive "P") + (org-scan-tags 'sparse-tree (cdr (org-make-tags-matcher match)) todo-only)) - ((eq major-mode 'dired-mode) - ;; link to the file in the current line - (setq cpltxt (concat "file:" - (abbreviate-file-name - (expand-file-name - (dired-get-filename nil t)))) - link (org-make-link cpltxt))) +(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))) - ((and buffer-file-name (org-mode-p)) - ;; Just link to current headline - (setq cpltxt (concat "file:" - (abbreviate-file-name buffer-file-name))) - ;; Add a context search string - (when (org-xor org-context-in-file-links arg) - ;; Check if we are on a target - (if (save-excursion - (skip-chars-forward "^>\n\r") - (and (re-search-backward "<<" nil t) - (looking-at "<<\\(.*?\\)>>") - (<= (match-beginning 0) pos) - (>= (match-end 0) pos))) - (setq cpltxt (concat cpltxt "::" (match-string 1))) - (setq txt (cond - ((org-on-heading-p) nil) - ((org-region-active-p) - (buffer-substring (region-beginning) (region-end))) - (t (buffer-substring (point-at-bol) (point-at-eol))))) - (when (or (null txt) (string-match "\\S-" txt)) - (setq cpltxt - (concat cpltxt "::" - (if org-file-link-context-use-camel-case - (org-make-org-heading-camel txt) - (org-make-org-heading-search-string txt))) - desc "NONE")))) - (if (string-match "::\\'" cpltxt) - (setq cpltxt (substring cpltxt 0 -2))) - (setq link (org-make-link cpltxt))) + ;; Parse the string and create a lisp form + (let ((match0 match) + (re "^&?\\([-+:]\\)?\\({[^}]+}\\|LEVEL=\\([0-9]+\\)\\|[A-Za-z_@0-9]+\\)") + minus tag mm + tagsmatch todomatch tagsmatcher todomatcher kwd matcher + orterms term orlist re-p level-p) + (if (string-match "/+" match) + ;; match contains also a todo-matching request + (progn + (setq tagsmatch (substring match 0 (match-beginning 0)) + todomatch (substring match (match-end 0))) + (if (string-match "^!" todomatch) + (setq todo-only t todomatch (substring todomatch 1))) + (if (string-match "^\\s-*$" todomatch) + (setq todomatch nil))) + ;; only matching tags + (setq tagsmatch match todomatch nil)) - (buffer-file-name - ;; Just link to this file here. - (setq cpltxt (concat "file:" - (abbreviate-file-name buffer-file-name))) - ;; Add a context string - (when (org-xor org-context-in-file-links arg) - (setq txt (if (org-region-active-p) - (buffer-substring (region-beginning) (region-end)) - (buffer-substring (point-at-bol) (point-at-eol)))) - ;; Only use search option if there is some text. - (when (string-match "\\S-" txt) - (setq cpltxt - (concat cpltxt "::" - (if org-file-link-context-use-camel-case - (org-make-org-heading-camel txt) - (org-make-org-heading-search-string txt))) - desc "NONE"))) - (setq link (org-make-link cpltxt))) + ;; Make the tags matcher + (if (or (not tagsmatch) (not (string-match "\\S-" tagsmatch))) + (setq tagsmatcher t) + (setq orterms (org-split-string tagsmatch "|") orlist nil) + (while (setq term (pop orterms)) + (while (and (equal (substring term -1) "\\") orterms) + (setq term (concat term "|" (pop orterms)))) ; repair bad split + (while (string-match re term) + (setq minus (and (match-end 1) + (equal (match-string 1 term) "-")) + tag (match-string 2 term) + re-p (equal (string-to-char tag) ?{) + level-p (match-end 3) + mm (cond + (re-p `(org-match-any-p ,(substring tag 1 -1) tags-list)) + (level-p `(= level ,(string-to-number + (match-string 3 term)))) + (t `(member ,(downcase tag) tags-list))) + mm (if minus (list 'not mm) mm) + term (substring term (match-end 0))) + (push mm tagsmatcher)) + (push (if (> (length tagsmatcher) 1) + (cons 'and tagsmatcher) + (car tagsmatcher)) + orlist) + (setq tagsmatcher nil)) + (setq tagsmatcher (if (> (length orlist) 1) (cons 'or orlist) (car orlist)))) - ((interactive-p) - (error "Cannot link to a buffer which is not visiting a file")) + ;; Make the todo matcher + (if (or (not todomatch) (not (string-match "\\S-" todomatch))) + (setq todomatcher t) + (setq orterms (org-split-string todomatch "|") orlist nil) + (while (setq term (pop orterms)) + (while (string-match re term) + (setq minus (and (match-end 1) + (equal (match-string 1 term) "-")) + kwd (match-string 2 term) + re-p (equal (string-to-char kwd) ?{) + term (substring term (match-end 0)) + mm (if re-p + `(string-match ,(substring kwd 1 -1) todo) + (list 'equal 'todo kwd)) + mm (if minus (list 'not mm) mm)) + (push mm todomatcher)) + (push (if (> (length todomatcher) 1) + (cons 'and todomatcher) + (car todomatcher)) + orlist) + (setq todomatcher nil)) + (setq todomatcher (if (> (length orlist) 1) + (cons 'or orlist) (car orlist)))) - (t (setq link nil))) + ;; Return the string and lisp forms of the matcher + (setq matcher (if todomatcher + (list 'and tagsmatcher todomatcher) + tagsmatcher)) + (cons match0 matcher))) - (if (consp link) (setq cpltxt (car link) link (cdr link))) - (setq link (or link cpltxt) - desc (or desc cpltxt)) - (if (equal desc "NONE") (setq desc nil)) +(defun org-match-any-p (re list) + "Does re match any element of list?" + (setq list (mapcar (lambda (x) (string-match re x)) list)) + (delq nil list)) - (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)))) +(defvar org-add-colon-after-tag-completion nil) ;; dynamically skoped param +(defvar org-tags-overlay (org-make-overlay 1 1)) +(org-detach-overlay org-tags-overlay) -(defun org-make-org-heading-search-string (&optional string heading) - "Make search string for STRING or current headline." - (interactive) - (let ((s (or string (org-get-heading)))) - (unless (and string (not heading)) - ;; 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) - (setq s (replace-match "" t t s))) - (setq s (org-trim s)) - (if (string-match (concat "^\\(" org-quote-string "\\|" - org-comment-string "\\)") s) - (setq s (replace-match "" t t s))) - (while (string-match org-ts-regexp s) - (setq s (replace-match "" t t s)))) - (while (string-match "[^a-zA-Z_0-9 \t]+" s) - (setq s (replace-match " " t t s))) - (or string (setq s (concat "*" s))) ; Add * for headlines - (mapconcat 'identity (org-split-string s "[ \t]+") " "))) - -(defun org-make-org-heading-camel (&optional string heading) - "Make a CamelCase string for STRING or the current headline." - (interactive) - (let ((s (or string (org-get-heading)))) - (unless (and string (not heading)) - ;; 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) - (setq s (replace-match "" t t s))) - (setq s (org-trim s)) - (if (string-match (concat "^\\(" org-quote-string "\\|" - org-comment-string "\\)") s) - (setq s (replace-match "" t t s))) - (while (string-match org-ts-regexp s) - (setq s (replace-match "" t t s)))) - (while (string-match "[^a-zA-Z_ \t]+" s) - (setq s (replace-match " " t t s))) - (or string (setq s (concat "*" s))) ; Add * for headlines - (mapconcat 'capitalize (org-split-string s "[ \t]+") ""))) - -(defun org-make-link (&rest strings) - "Concatenate STRINGS, format resulting string with `org-link-format'." - (format org-link-format (apply 'concat strings))) - -(defun org-make-link-string (link &optional description) - "Make a link with brackets, consisting of LINK and DESCRIPTION." - (if (eq org-link-style 'plain) - (if (equal description link) - link - (concat description "\n" link)) - (when (stringp description) - ;; Remove brackets from the description, they are fatal. - (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)) - (when (and (not description) - (not (equal link (org-link-escape link)))) - (setq description link)) - (concat "[[" (org-link-escape link) "]" - (if description (concat "[" description "]") "") - "]"))) - -(defconst org-link-escape-chars '(("[" . "%5B") ("]" . "%5D") (" " . "%20")) - "Association list of escapes for some characters problematic in links.") +(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)) + 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 + (while (re-search-forward re nil t) + (org-set-tags nil t) + (end-of-line 1))) + (message "All tags realigned to column %d" org-tags-column)) + (if just-align + (setq tags current) + ;; Get a new set of tags from the user + (setq table (or org-tag-alist (org-get-buffer-tags)) + org-last-tags-completion-table table + current-tags (org-split-string current ":") + inherited-tags (nreverse + (nthcdr (length current-tags) + (nreverse (org-get-tags-at)))) + tags + (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) + (let ((org-add-colon-after-tag-completion t)) + (org-trim + (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 ":"))) + (unless (string-match "^:" tags) (setq tags (concat ":" tags)))) -(defun org-link-escape (text) - "Escape charaters in TEXT that are problematic for links." - (when text - (let ((re (mapconcat (lambda (x) (regexp-quote (car x))) - org-link-escape-chars "\\|"))) - (while (string-match re text) - (setq text - (replace-match - (cdr (assoc (match-string 0 text) org-link-escape-chars)) - t t text))) - text))) + ;; 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) + (and (not (featurep 'xemacs)) c0 (tabify p0 (point))) + tags) + (error "Tags alignment failed"))))) -(defun org-link-unescape (text) - "Reverse the action of `org-link-escape'." - (when text - (let ((re (mapconcat (lambda (x) (regexp-quote (cdr x))) - org-link-escape-chars "\\|"))) - (while (string-match re text) - (setq text - (replace-match - (car (rassoc (match-string 0 text) org-link-escape-chars)) - t t text))) - text))) +(defun org-tags-completion-function (string predicate &optional flag) + (let (s1 s2 rtn (ctable org-last-tags-completion-table) + (confirm (lambda (x) (stringp (car x))))) + (if (string-match "^\\(.*[-+:&|]\\)\\([^-+:&|]*\\)$" string) + (setq s1 (match-string 1 string) + s2 (match-string 2 string)) + (setq s1 "" s2 string)) + (cond + ((eq flag nil) + ;; 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)) + ":" ""))) + ) + ((eq flag t) + ;; all-completions + (all-completions s2 ctable confirm) + ) + ((eq flag 'lambda) + ;; exact match? + (assoc s2 ctable))) + )) -(defun org-xor (a b) - "Exclusive or." - (if a (not b) b)) +(defun org-fast-tag-insert (kwd tags face &optional end) + "Insert KDW, and the TAGS, the latter with face FACE. Also inser END." + (insert (format "%-12s" (concat kwd ":")) + (org-add-props (mapconcat 'identity tags " ") nil 'face face) + (or end ""))) -(defun org-get-header (header) - "Find a header field in the current buffer." +(defun org-fast-tag-show-exit (flag) (save-excursion - (goto-char (point-min)) - (let ((case-fold-search t) s) - (cond - ((eq header 'from) - (if (re-search-forward "^From:\\s-+\\(.*\\)" nil t) - (setq s (match-string 1))) - (while (string-match "\"" s) - (setq s (replace-match "" t t s))) - (if (string-match "[<(].*" s) - (setq s (replace-match "" t t s)))) - ((eq header 'message-id) - (if (re-search-forward "^message-id:\\s-+\\(.*\\)" nil t) - (setq s (match-string 1)))) - ((eq header 'subject) - (if (re-search-forward "^subject:\\s-+\\(.*\\)" nil t) - (setq s (match-string 1))))) - (if (string-match "\\`[ \t\]+" s) (setq s (replace-match "" t t s))) - (if (string-match "[ \t\]+\\'" s) (setq s (replace-match "" t t s))) - s))) - - -(defun org-fixup-message-id-for-http (s) - "Replace special characters in a message id, so it can be used in an http query." - (while (string-match "<" s) - (setq s (replace-match "%3C" t t s))) - (while (string-match ">" s) - (setq s (replace-match "%3E" t t s))) - (while (string-match "@" s) - (setq s (replace-match "%40" t t s))) - s) - -(defun org-insert-link (&optional complete-file) - "Insert a link. At the prompt, enter the link. - -Completion can be used to select a link previously stored with -`org-store-link'. When the empty string is entered (i.e. if you just -press RET at the prompt), the link defaults to the most recently -stored link. As SPC triggers completion in the minibuffer, you need to -use M-SPC or C-q SPC to force the insertion of a space character. - -You will also be prompted for a description, and if one is given, it will -be displayed in the buffer instead of the link. - -If there is already a link at point, this command will allow you to edit link -and description parts. - -With a \\[universal-argument] prefix, prompts for a file to link to. The file name can be -selected using completion. The path to the file will be relative to -the current directory if the file is in the current directory or a -subdirectory. Otherwise, the link will be the absolute path as -completed in the minibuffer (i.e. normally ~/path/to/file). + (goto-line 3) + (if (re-search-forward "[ \t]+Next change exits" (point-at-eol) t) + (replace-match "")) + (when flag + (end-of-line 1) + (move-to-column (- (window-width) 19) t) + (insert (org-add-props " Next change exits" nil 'face 'org-warning))))) -With two \\[universal-argument] prefixes, enforce an absolute path even if the file -is in the current directory or below. -With three \\[universal-argument] prefixes, negate the meaning of -`org-keep-stored-link-after-insertion'." - (interactive "P") - (let (link desc entry remove file (pos (point))) - (cond - ((save-excursion - (skip-chars-forward "^]\n\r") - (and (re-search-backward "\\[\\[" nil t) - (looking-at org-bracket-link-regexp) - (<= (match-beginning 0) pos) - (>= (match-end 0) pos))) - ;; We do have a link at point, and we are going to edit it. - (setq remove (list (match-beginning 0) (match-end 0))) - (setq desc (if (match-end 3) (org-match-string-no-properties 3))) - (setq link (read-string "Link: " - (org-link-unescape - (org-match-string-no-properties 1))))) - ((equal complete-file '(4)) - ;; Completing read for file names. - (setq file (read-file-name "File: ")) - (let ((pwd (file-name-as-directory (expand-file-name "."))) - (pwd1 (file-name-as-directory (abbreviate-file-name - (expand-file-name "."))))) - (cond - ((equal complete-file '(16)) - (setq link (org-make-link - "file:" - (abbreviate-file-name (expand-file-name file))))) - ((string-match (concat "^" (regexp-quote pwd1) "\\(.+\\)") file) - (setq link (org-make-link "file:" (match-string 1 file)))) - ((string-match (concat "^" (regexp-quote pwd) "\\(.+\\)") - (expand-file-name file)) - (setq link (org-make-link - "file:" (match-string 1 (expand-file-name file))))) - (t (setq link (org-make-link "file:" file)))))) - (t - ;; Read link, with completion for stored links. - (setq link (org-completing-read - "Link: " org-stored-links nil nil nil - org-insert-link-history - (or (car (car org-stored-links))))) - (setq entry (assoc link org-stored-links)) - (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 desc (nth 2 entry))))) +(defun org-set-current-tags-overlay (current prefix) + (let ((s (concat ":" (mapconcat 'identity current ":") ":"))) + (if (featurep 'xemacs) + (org-overlay-display org-tags-overlay (concat prefix s) + 'secondary-selection) + (put-text-property 0 (length s) 'face '(secondary-selection org-tag) s) + (org-overlay-display org-tags-overlay (concat prefix s))))) - (if (string-match org-plain-link-re link) - ;; URL-like link, normalize the use of angular brackets. - (setq link (org-make-link (org-remove-angle-brackets link)))) - - ;; Check if we are linking to the current file with a search option - ;; If yes, simplify the link by using only the search option. - (when (and buffer-file-name - (string-match "\\]+\\)" link)) - (let* ((path (match-string 1 link)) - (case-fold-search nil) - (search (match-string 2 link))) - (save-match-data - (if (equal (file-truename buffer-file-name) (file-truename path)) - ;; We are linking to this same file, with a search option - (setq link search))))) - - ;; Check if we can/should use a relative path. If yes, simplify the link - (when (string-match "\\ (current-column) org-tags-column) + " " + (make-string (- org-tags-column (current-column)) ?\ )))))) + (org-move-overlay org-tags-overlay ov-start ov-end) + (save-window-excursion + (if expert + (set-buffer (get-buffer-create " *Org tags*")) + (delete-other-windows) + (split-window-vertically) + (switch-to-buffer-other-window (get-buffer-create " *Org tags*"))) + (erase-buffer) + (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) + (while (setq e (pop tbl)) (cond - ((eq org-link-file-path-type 'absolute) - (setq path (abbreviate-file-name (expand-file-name path)))) - ((eq org-link-file-path-type 'noabbrev) - (setq path (expand-file-name path))) - ((eq org-link-file-path-type 'relative) - (setq path (file-relative-name path))) + ((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 - (save-match-data - (if (string-match (concat "^" (regexp-quote - (file-name-as-directory - (expand-file-name ".")))) - (expand-file-name path)) - ;; 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 desc (read-string "Description: " desc)) - (unless (string-match "\\S-" desc) (setq desc nil)) - (if remove (apply 'delete-region remove)) - (insert (org-make-link-string link desc)))) - -(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) - (apply 'completing-read args))) + (setq tg (car e) c2 nil) + (if (cdr e) + (setq c (cdr e)) + ;; automatically assign a character. + (setq c1 (string-to-char + (downcase (substring + tg (if (= (string-to-char tg) ?@) 1 0))))) + (if (or (rassoc c1 ntable) (rassoc c1 table)) + (while (or (rassoc char ntable) (rassoc char table)) + (setq char (1+ char))) + (setq c2 c1)) + (setq c (or c2 char))) + (if ingroup (push tg (car groups))) + (setq tg (org-add-props tg nil 'face + (cond + ((member tg current) c-face) + ((member tg inherited) i-face) + (t nil)))) + (if (and (= cnt 0) (not ingroup)) (insert " ")) + (insert "[" c "] " tg (make-string + (- fwidth 4 (length tg)) ?\ )) + (push (cons tg c) ntable) + (when (= (setq cnt (1+ cnt)) ncol) + (insert "\n") + (if ingroup (insert " ")) + (setq cnt 0))))) + (setq ntable (nreverse ntable)) + (insert "\n") + (goto-char (point-min)) + (if (and (not expert) (fboundp 'fit-window-to-buffer)) + (fit-window-to-buffer)) + (setq rtn + (catch 'exit + (while t + (message "[a-z..]:Toggle [SPC]:clear [RET]:accept [TAB]:free%s%s" + (if groups " [!] no groups" " [!]groups") + (if expert " [C-c]:window" (if exit-after-next " [C-c]:single" " [C-c]:multi"))) + (setq c (let ((inhibit-quit t)) (read-char-exclusive))) + (cond + ((= c ?\r) (throw 'exit t)) + ((= c ?!) + (setq groups (not groups)) + (goto-char (point-min)) + (while (re-search-forward "[{}]" nil t) (replace-match " "))) + ((= c ?\C-c) + (if (not expert) + (org-fast-tag-show-exit + (setq exit-after-next (not exit-after-next))) + (setq expert nil) + (delete-other-windows) + (split-window-vertically) + (switch-to-buffer-other-window " *Org tags*") + (and (fboundp 'fit-window-to-buffer) + (fit-window-to-buffer)))) + ((or (= c ?\C-g) + (and (= c ?q) (not (rassoc c ntable)))) + (org-detach-overlay org-tags-overlay) + (setq quit-flag t)) + ((= c ?\ ) + (setq current nil) + (if exit-after-next (setq exit-after-next 'now))) + ((= c ?\t) + (condition-case nil + (setq tg (completing-read + "Tag: " + (or buffer-tags + (with-current-buffer buf + (org-get-buffer-tags))))) + (quit (setq tg ""))) + (when (string-match "\\S-" tg) + (add-to-list 'buffer-tags (list tg)) + (if (member tg current) + (setq current (delete tg current)) + (push tg current))) + (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))) + (push tg current)) + (if exit-after-next (setq exit-after-next 'now)))) -;;; Hooks for remember.el + ;; Create a sorted list + (setq current + (sort current + (lambda (a b) + (assoc b (cdr (memq (assoc a ntable) ntable)))))) + (if (eq exit-after-next 'now) (throw 'exit t)) + (goto-char (point-min)) + (beginning-of-line 2) + (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) + (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))))) + (goto-char (point-min))))) + (org-detach-overlay org-tags-overlay) + (if rtn + (mapconcat 'identity current ":") + nil)))) -(defvar org-finish-function nil) +(defun org-get-tags () + "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\\|$\\)") + (org-match-string-no-properties 1) + ""))) -;;;###autoload -(defun org-remember-annotation () - "Return a link to the current location as an annotation for remember.el. -If you are using Org-mode files as target for data storage with -remember.el, then the annotations should include a link compatible with the -conventions in Org-mode. This function returns such a link." - (org-store-link nil)) +(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) ":")))) + (mapcar 'list tags))) -(defconst org-remember-help -"Select a destination location for the note. -UP/DOWN=headline TAB=cycle visibility [Q]uit RET//=Store -RET at beg-of-buf -> Append to file as level 2 headline -RET on headline -> Store as sublevel entry to current headline -/ -> before/after current headline, same headings level") +;;;; Timestamps -;;;###autoload -(defun org-remember-apply-template () - "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." - (if org-remember-templates +(defvar org-last-changed-timestamp nil) +(defvar org-time-was-given) ; dynamically scoped parameter +(defvar org-ts-what) ; dynamically scoped parameter - (let* ((entry (if (= (length org-remember-templates) 1) - (cdar org-remember-templates) - (message "Select template: %s" - (mapconcat - (lambda (x) (char-to-string (car x))) - org-remember-templates " ")) - (cdr (assoc (read-char-exclusive) org-remember-templates)))) - (tpl (car entry)) - (file (if (consp (cdr entry)) (nth 1 entry))) - (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-a annotation) ; defined in `remember-mode' - (v-i initial) ; defined in `remember-mode' - (v-n user-full-name) - ) - (unless tpl (setq tpl "") (message "No template") (ding)) - (insert tpl) (goto-char (point-min)) - (while (re-search-forward "%\\([tTuTai]\\)" nil t) - (when (and initial (equal (match-string 0) "%i")) - (save-match-data - (let* ((lead (buffer-substring - (point-at-bol) (match-beginning 0)))) - (setq v-i (mapconcat 'identity - (org-split-string initial "\n") - (concat "\n" lead)))))) - (replace-match - (or (eval (intern (concat "v-" (match-string 1)))) "") - t t)) - (let ((org-startup-folded nil) - (org-startup-with-deadline-check nil)) - (org-mode)) - (if (and file (string-match "\\S-" file) (not (file-directory-p file))) - (org-set-local 'org-default-notes-file file)) - (goto-char (point-min)) - (if (re-search-forward "%\\?" nil t) (replace-match ""))) - (let ((org-startup-folded nil) - (org-startup-with-deadline-check nil)) - (org-mode))) - (org-set-local 'org-finish-function 'remember-buffer)) - -;;;###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. -Then the command offers the headings tree of the selected file in order to -file the text at a specific location. -You can either immediately press RET to get the note appended to the -file, or you can use vertical cursor motion and visibility cycling (TAB) to -find a better place. Then press RET or or in insert the note. - -Key Cursor position Note gets inserted ------------------------------------------------------------------------------ -RET buffer-start as level 2 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. - on headline as same level, before current heading - on headline as same level, after current heading - -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. +(defun org-time-stamp (arg) + "Prompt for a date/time and insert a time stamp. +If the user specifies a time like HH:MM, or if this command is called +with a prefix argument, the time stamp will contain date and time. +Otherwise, only the date will be included. All parts of a date not +specified by the user will be filled in from the current date/time. +So if you press just return without typing anything, the time stamp +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) + (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-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))) + (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)))) + (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)))))) -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 -is constructed from the current date and some additional data. +(defun org-time-stamp-inactive (&optional arg) + "Insert an inactive time stamp. +An inactive time stamp is enclosed in square brackets instead of angle +brackets. It is inactive in the sense that it does not trigger agenda entries, +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) + (setq time (org-read-date arg 'totime)) + (org-insert-time-stamp time (or org-time-was-given arg) 'inactive))) -If the variable `org-adapt-indentation' is non-nil, the entire text is -also indented so that it starts in the same column as the headline -\(i.e. after the stars). +(defvar org-date-ovl (org-make-overlay 1 1)) +(org-overlay-put org-date-ovl 'face 'org-warning) +(org-detach-overlay org-date-ovl) -See also the variable `org-reverse-note-order'." - (catch 'quit - (let* ((txt (buffer-substring (point-min) (point-max))) - (fastp current-prefix-arg) - (file (if fastp org-default-notes-file (org-get-org-file))) - (visiting (find-buffer-visiting file)) - (org-startup-with-deadline-check nil) - (org-startup-folded nil) - (org-startup-align-all-tables nil) - spos level indent reversed) - ;; Modify text so that it becomes a nice subtree which can be inserted - ;; into an org tree. - (let* ((lines (split-string txt "\n")) - first) - ;; remove empty lines at the beginning - (while (and lines (string-match "^[ \t]*\n" (car lines))) - (setq lines (cdr lines))) - (setq first (car lines) lines (cdr lines)) - (if (string-match "^\\*+" first) - ;; Is already a headline - (setq indent nil) - ;; We need to add a headline: Use time and first buffer line - (setq lines (cons first lines) - first (concat "* " (current-time-string) - " (" (remember-buffer-desc) ")") - indent " ")) - (if (and org-adapt-indentation indent) - (setq lines (mapcar (lambda (x) (concat indent x)) lines))) - (setq txt (concat first "\n" - (mapconcat 'identity lines "\n")))) - ;; Find the file - (if (not visiting) - (find-file-noselect file)) - (with-current-buffer (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)) - (save-excursion - (save-restriction - (widen) - ;; Ask the User for a location - (setq spos (if fastp 1 (org-get-location - (current-buffer) - org-remember-help))) - (if (not spos) (throw 'quit nil)) ; return nil to show we did - ; not handle this note - (goto-char spos) - (cond ((bobp) - ;; Put it at the start or end, as level 2 - (save-restriction - (widen) - (goto-char (if reversed (point-min) (point-max))) - (if (not (bolp)) (newline)) - (org-paste-subtree 2 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) - (setq level (funcall outline-level)) - (if reversed - (outline-end-of-heading) - (outline-end-of-subtree)) - (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))) - (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. +(defvar org-ans1) ; dynamically scoped parameter +(defvar org-ans2) ; dynamically scoped parameter -(defun org-get-org-file () - "Read a filename, with default directory `org-directory'." - (let ((default (or org-default-notes-file remember-data-file))) - (read-file-name (format "File name [%s]: " default) - (file-name-as-directory org-directory) - default))) +(defun org-read-date (&optional with-time to-time from-string prompt) + "Read a date 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, + 3-2-5 --> 2003-02-05 + feb 15 --> currentyear-02-15 + sep 12 9 --> 2009-09-12 + 12:45 --> today 12:45 + 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. +The function understands only English month and weekday abbreviations, +but this can be configured with the variables `parse-time-months' and +`parse-time-weekdays'. -(defun org-notes-order-reversed-p () - "Check if the current file should receive notes in reversed order." - (cond - ((not org-reverse-note-order) nil) - ((eq t org-reverse-note-order) t) - ((not (listp org-reverse-note-order)) nil) - (t (catch 'exit - (let ((all org-reverse-note-order) - entry) - (while (setq entry (pop all)) - (if (string-match (car entry) buffer-file-name) - (throw 'exit (cdr entry)))) - nil))))) +While prompting, a calendar is popped up - you can also select the +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) -;;; Tables +With optional argument TO-TIME, the date will immediately be converted +to an internal time. +With an optional argument WITH-TIME, the prompt will suggest to also +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." + (require 'parse-time) + (let* ((org-time-stamp-rounding-minutes + (if (equal with-time '(16)) 0 org-time-stamp-rounding-minutes)) + (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)) + (calendar-move-hook nil) + (view-diary-entries-initially nil) + (view-calendar-holidays-initially nil) + (timestr (format-time-string + (if with-time "%Y-%m-%d %H:%M" "%Y-%m-%d") default-time)) + (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) -;; Watch out: Here we are talking about two different kind of tables. -;; Most of the code is for the tables created with the Org-mode table editor. -;; Sometimes, we talk about tables created and edited with the table.el -;; Emacs package. We call the former org-type tables, and the latter -;; table.el-type tables. + (cond + (from-string (setq ans from-string)) + (org-popup-calendar-for-date-prompt + (save-excursion + (save-window-excursion + (calendar) + (calendar-forward-day (- (time-to-days default-time) + (calendar-absolute-from-gregorian + (calendar-current-date)))) + (org-eval-in-calendar nil) + (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-calendar-select-mouse) + (define-key map (if (featurep 'xemacs) [button2] [mouse-2]) + 'org-calendar-select-mouse) + (define-key minibuffer-local-map [(meta shift left)] + (lambda () (interactive) + (org-eval-in-calendar '(calendar-backward-month 1)))) + (define-key minibuffer-local-map [(meta shift right)] + (lambda () (interactive) + (org-eval-in-calendar '(calendar-forward-month 1)))) + (define-key minibuffer-local-map [(shift up)] + (lambda () (interactive) + (org-eval-in-calendar '(calendar-backward-week 1)))) + (define-key minibuffer-local-map [(shift down)] + (lambda () (interactive) + (org-eval-in-calendar '(calendar-forward-week 1)))) + (define-key minibuffer-local-map [(shift left)] + (lambda () (interactive) + (org-eval-in-calendar '(calendar-backward-day 1)))) + (define-key minibuffer-local-map [(shift right)] + (lambda () (interactive) + (org-eval-in-calendar '(calendar-forward-day 1)))) + (define-key minibuffer-local-map ">" + (lambda () (interactive) + (org-eval-in-calendar '(scroll-calendar-left 1)))) + (define-key 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)) + ;; 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)))))) + (t ; Naked prompt only + (setq ans (read-string prompt "" nil timestr)))) + (org-detach-overlay org-date-ovl) + (if (string-match "^[ \t]*[-+][0-9]+[ \t]*$" org-ans0) + (setq deltadays (string-to-number ans) ans "")) -(defun org-before-change-function (beg end) - "Every change indicates that a table might need an update." - (setq org-table-may-need-update t)) + (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))) + second (or (nth 0 tl) 0) + wday (nth 6 tl)) + (setq day (+ day deltadays)) + (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. + (setq wday1 (nth 6 (decode-time (encode-time 0 0 0 day month year)))) + (unless (equal wday wday1) + (setq day (+ day (% (- wday wday1 -7) 7))))) + (if (and (boundp 'org-time-was-given) + (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))))) -(defconst org-table-line-regexp "^[ \t]*|" - "Detects an org-type table line.") -(defconst org-table-dataline-regexp "^[ \t]*|[^-]" - "Detects an org-type table line.") -(defconst org-table-auto-recalculate-regexp "^[ \t]*| *# *\\(|\\|$\\)" - "Detects a table line marked for automatic recalculation.") -(defconst org-table-recalculate-regexp "^[ \t]*| *[#*] *\\(|\\|$\\)" - "Detects a table line marked for automatic recalculation.") -(defconst org-table-calculate-mark-regexp "^[ \t]*| *[!$^_#*] *\\(|\\|$\\)" - "Detects a table line marked for automatic recalculation.") -(defconst org-table-hline-regexp "^[ \t]*|-" - "Detects an org-type table hline.") -(defconst org-table1-hline-regexp "^[ \t]*\\+-[-+]" - "Detects a table-type table hline.") -(defconst org-table-any-line-regexp "^[ \t]*\\(|\\|\\+-[-+]\\)" - "Detects an org-type or table-type table.") -(defconst org-table-border-regexp "^[ \t]*[^| \t]" - "Searching from within a table (any type) this finds the first line -outside the table.") -(defconst org-table-any-border-regexp "^[ \t]*[^|+ \t]" - "Searching from within a table (any type) this finds the first line -outside the table.") +(defun org-eval-in-calendar (form) + "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) + (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))) -(defun org-table-create-with-table.el () - "Use the table.el package to insert a new table. -If there is already a table at point, convert between Org-mode tables -and table.el tables." +(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." (interactive) - (require 'table) - (cond - ((org-at-table.el-p) - (if (y-or-n-p "Convert table to Org-mode table? ") - (org-table-convert))) - ((org-at-table-p) - (if (y-or-n-p "Convert table to table.el table? ") - (org-table-convert))) - (t (call-interactively 'table-insert)))) + (when (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-ans1 (format-time-string "%Y-%m-%d" time))) + (if (active-minibuffer-window) (exit-minibuffer)))) -(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." - (interactive "P") - (if (org-region-active-p) - (org-table-convert-region (region-beginning) (region-end) arg) - (org-table-create arg))) +(defun org-insert-time-stamp (time &optional with-hm inactive pre post) + "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 +stamp will not contribute to the agenda. +PRE and POST are optional strings to be inserted before and after the +stamp. +The command returns the inserted time stamp." + (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 "")) + stamp)) -(defun org-table-create (&optional size) - "Query for a size and insert a table skeleton. -SIZE is a string Columns x Rows like for example \"3x2\"." - (interactive "P") - (unless size - (setq size (read-string - (concat "Table size Columns x Rows [e.g. " - org-table-default-size "]: ") - "" nil org-table-default-size))) +(defun org-toggle-time-stamp-overlays () + "Toggle the use of custom time stamp formats." + (interactive) + (setq org-display-custom-times (not org-display-custom-times)) + (unless org-display-custom-times + (let ((p (point-min)) (bmp (buffer-modified-p))) + (while (setq p (next-single-property-change p 'display)) + (if (and (get-text-property p 'display) + (eq (get-text-property p 'face) 'org-date)) + (remove-text-properties + p (setq p (next-single-property-change p 'display)) + '(display t)))) + (set-buffer-modified-p bmp))) + (if (featurep 'xemacs) + (remove-text-properties (point-min) (point-max) '(end-glyph t))) + (org-restart-font-lock) + (setq org-table-may-need-update t) + (if org-display-custom-times + (message "Time stamps are overlayed with custom format") + (message "Time stamp overlays removed"))) - (let* ((pos (point)) - (indent (make-string (current-column) ?\ )) - (split (org-split-string size " *x *")) - (rows (string-to-number (nth 1 split))) - (columns (string-to-number (car split))) - (line (concat (apply 'concat indent "|" (make-list columns " |")) - "\n"))) - (if (string-match "^[ \t]*$" (buffer-substring-no-properties - (point-at-bol) (point))) - (beginning-of-line 1) - (newline)) - ;; (mapcar (lambda (x) (insert line)) (make-list rows t)) - (dotimes (i rows) (insert line)) - (goto-char pos) - (if (> rows 1) - ;; Insert a hline after the first row. +(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 + (format-time-string + (substring tf 1 -1) (apply 'encode-time time)) + 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)))) + (if (featurep 'xemacs) (progn - (end-of-line 1) - (insert "\n|-") - (goto-char pos))) - (org-table-align))) + (put-text-property beg end 'invisible t) + (put-text-property beg end 'end-glyph (make-glyph str))) + (put-text-property beg end 'display str)))) -(defun org-table-convert-region (beg0 end0 &optional nspace) - "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)." - (interactive "rP") - (let* ((beg (min beg0 end0)) - (end (max beg0 end0)) - (tabsep t) - re) - (goto-char beg) - (beginning-of-line 1) - (setq beg (move-marker (make-marker) (point))) - (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) - (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))))) - (goto-char beg) - (while (re-search-forward re end t) - (replace-match "| " t t)) - (goto-char beg) - (insert " ") - (org-table-align))) +(defun org-translate-time (string) + "Translate all timestamps in STRING to custom format. +But do this only if the variable `org-display-custom-times' is set." + (when org-display-custom-times + (save-match-data + (let* ((start 0) + (re org-ts-regexp-both) + t1 with-hm inactive tf time str beg end) + (while (setq start (string-match re string start)) + (setq beg (match-beginning 0) + end (match-end 0) + t1 (save-match-data + (org-parse-time-string (substring string beg end) t)) + with-hm (and (nth 1 t1) (nth 2 t1)) + inactive (equal (substring string beg (1+ beg)) "[") + tf (funcall (if with-hm 'cdr 'car) + org-time-stamp-custom-formats) + time (org-fix-decoded-time t1) + str (format-time-string + (concat + (if inactive "[" "<") (substring tf 1 -1) + (if inactive "]" ">")) + (apply 'encode-time time)) + string (replace-match str t t string) + start (+ start (length str))))))) + string) -(defun org-table-import (file arg) - "Import FILE as a table. -The file is assumed to be tab-separated. Such files can be produced by most -spreadsheet and database applications. If no tabs (at least one per line) -are found, lines will be split on whitespace into fields." - (interactive "f\nP") - (or (bolp) (newline)) - (let ((beg (point)) - (pm (point-max))) - (insert-file-contents file) - (org-table-convert-region beg (+ (point) (- (point-max) pm)) arg))) +(defun org-fix-decoded-time (time) + "Set 0 instead of nil for the first 6 elements of time. +Don't touch the rest." + (let ((n 0)) + (mapcar (lambda (x) (if (< (setq n (1+ n)) 7) (or x 0) x)) time))) -(defun org-table-export () - "Export table as a tab-separated file. -Such a file can be imported into a spreadsheet program like Excel." - (interactive) - (let* ((beg (org-table-begin)) - (end (org-table-end)) - (table (buffer-substring beg end)) - (file (read-file-name "Export table to: ")) - buf) - (unless (or (not (file-exists-p file)) - (y-or-n-p (format "Overwrite file %s? " file))) - (error "Abort")) - (with-current-buffer (find-file-noselect file) - (setq buf (current-buffer)) - (erase-buffer) - (fundamental-mode) - (insert table) - (goto-char (point-min)) - (while (re-search-forward "^[ \t]*|[ \t]*" nil t) - (replace-match "" t t) - (end-of-line 1)) - (goto-char (point-min)) - (while (re-search-forward "[ \t]*|[ \t]*$" nil t) - (replace-match "" t t) - (goto-char (min (1+ (point)) (point-max)))) - (goto-char (point-min)) - (while (re-search-forward "^-[-+]*$" nil t) - (replace-match "") - (if (looking-at "\n") - (delete-char 1))) - (goto-char (point-min)) - (while (re-search-forward "[ \t]*|[ \t]*" nil t) - (replace-match "\t" t t)) - (save-buffer)) - (kill-buffer buf))) - -(defvar org-table-aligned-begin-marker (make-marker) - "Marker at the beginning of the table last aligned. -Used to check if cursor still is in that table, to minimize realignment.") -(defvar org-table-aligned-end-marker (make-marker) - "Marker at the end of the table last aligned. -Used to check if cursor still is in that table, to minimize realignment.") -(defvar org-table-last-alignment nil - "List of flags for flushright alignment, from the last re-alignment. -This is being used to correctly align a single field after TAB or RET.") -(defvar org-table-last-column-widths nil - "List of max width of fields in each column. -This is being used to correctly align a single field after TAB or RET.") - -(defvar org-last-recalc-line nil) -(defconst org-narrow-column-arrow "=>" - "Used as display property in narrowed table columns.") +(defun org-days-to-time (timestamp-string) + "Difference between TIMESTAMP-STRING and now in days." + (- (time-to-days (org-time-string-to-time timestamp-string)) + (time-to-days (current-time)))) -(defun org-table-align () - "Align the table at point by aligning all vertical bars." - (interactive) - (let* ( - ;; Limits of table - (beg (org-table-begin)) - (end (org-table-end)) - ;; Current cursor position - (linepos (org-current-line)) - (colpos (org-table-current-column)) - (winstart (window-start)) - (winstartline (org-current-line (min winstart (1- (point-max))))) - lines (new "") lengths l typenums ty fields maxfields i - column - (indent "") cnt frac - rfmt hfmt - (spaces '(1 . 1)) - (sp1 (car spaces)) - (sp2 (cdr spaces)) - (rfmt1 (concat - (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) - (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 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))) +(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)) + (not (org-entry-is-done-p)))) - ;; Check if we are narrowing any columns - (goto-char beg) - (setq narrow (and org-format-transports-properties-p - (re-search-forward "<[0-9]+>" end t))) - ;; Get the rows - (setq lines (org-split-string - (buffer-substring beg end) "\n")) - ;; Store the indentation of the first line - (if (string-match "^ *" (car lines)) - (setq indent (make-string (- (match-end 0) (match-beginning 0)) ?\ ))) - ;; Mark the hlines by setting the corresponding element to nil - ;; At the same time, we remove trailing space. - (setq lines (mapcar (lambda (l) - (if (string-match "^ *|-" l) - nil - (if (string-match "[ \t]+$" l) - (substring l 0 (match-beginning 0)) - l))) - lines)) - ;; Get the data fields by splitting the lines. - (setq fields (mapcar - (lambda (l) - (org-split-string l " *| *")) - (delq nil (copy-sequence lines)))) - ;; How many fields in the longest line? - (condition-case nil - (setq maxfields (apply 'max (mapcar 'length fields))) - (error - (kill-region beg end) - (org-table-create org-table-default-size) - (error "Empty table - created default table"))) - ;; A list of empty strings to fill any short rows on output - (setq emptystrings (make-list maxfields "")) - ;; Check for special formatting. - (setq i -1) - (while (< (setq i (1+ i)) maxfields) ;; Loop over all columns - (setq column (mapcar (lambda (x) (or (nth i x) "")) fields)) - ;; Check if there is an explicit width specified - (when (and org-table-limit-column-width narrow) - (setq c column fmax nil) - (while c - (setq e (pop c)) - (if (and (stringp e) (string-match "^<\\([0-9]+\\)>$" e)) - (setq fmax (string-to-number (match-string 1 e)) c nil))) - ;; Find fields that are wider than fmax, and shorten them - (when fmax - (loop for xx in column do - (when (and (stringp xx) - (> (org-string-width xx) fmax)) - (org-add-props xx nil - 'help-echo - (concat "Clipped table field, use C-c ` to edit. Full value is:\n" (org-no-properties (copy-sequence xx)))) - (setq f1 (min fmax (or (string-match org-bracket-link-regexp xx) fmax))) - (unless (> f1 1) - (error "Cannot narrow field starting with wide link \"%s\"" - (match-string 0 xx))) - (add-text-properties f1 (length xx) (list 'org-cwidth t) xx) - (add-text-properties (- f1 2) f1 - (list 'display org-narrow-column-arrow) - xx))))) - ;; Get the maximum width for each column - (push (apply 'max 1 (mapcar 'org-string-width column)) lengths) - ;; Get the fraction of numbers, to decide about alignment of the column - (setq cnt 0 frac 0.0) - (loop for x in column do - (if (equal x "") - nil - (setq frac ( / (+ (* frac cnt) - (if (string-match org-table-number-regexp x) 1 0)) - (setq cnt (1+ cnt)))))) - (push (>= frac org-table-number-fraction) typenums)) - (setq lengths (nreverse lengths) typenums (nreverse typenums)) +(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." + (interactive "e") + (mouse-set-point ev) + (when (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-ans1 (format-time-string "%Y-%m-%d" time))) + (if (active-minibuffer-window) (exit-minibuffer)))) - ;; Store the alignment of this table, for later editing of single fields - (setq org-table-last-alignment typenums - org-table-last-column-widths lengths) +(defun org-check-deadlines (ndays) + "Check if there are any deadlines due or past due. +A deadline is considered due if it happens within `org-deadline-warning-days' +days from today's date. If the deadline appears in an entry marked DONE, +it is not shown. The prefix arg NDAYS can be used to test that many +days. If the prefix is a raw \\[universal-argument] prefix, all deadlines are shown." + (interactive "P") + (let* ((org-warn-days + (cond + ((equal ndays '(4)) 100000) + (ndays (prefix-numeric-value ndays)) + (t org-deadline-warning-days))) + (case-fold-search nil) + (regexp (concat "\\<" org-deadline-string " *<\\([^>]+\\)>")) + (callback + (lambda () (org-deadline-close (match-string 1) org-warn-days)))) - ;; With invisible characters, `format' does not get the field width right - ;; So we need to make these fields wide by hand. - (when links - (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)) - (< (org-string-width (car c)) len)) - (setcar c (concat (car c) (make-string (- len (org-string-width (car c))) ?\ ))))))) + (message "%d deadlines past-due or due within %d days" + (org-occur regexp nil callback) + org-warn-days))) - ;; Compute the formats needed for output of the table - (setq rfmt (concat indent "|") hfmt (concat indent "|")) - (while (setq l (pop lengths)) - (setq ty (if (pop typenums) "" "-")) ; number types flushright - (setq rfmt (concat rfmt (format rfmt1 ty l)) - hfmt (concat hfmt (format hfmt1 (make-string l ?-))))) - (setq rfmt (concat rfmt "\n") - hfmt (concat (substring hfmt 0 -1) "|\n")) +(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 +TO-BUFFER, the result is inserted just after the date stamp into the buffer. +If the time range is actually in a table, the result is inserted into the +next column. +For time difference computation, a year is assumed to be exactly 365 +days in order to avoid rounding problems." + (interactive "P") + (or + (org-clock-update-time-maybe) + (save-excursion + (unless (org-at-date-range-p) + (goto-char (point-at-bol)) + (re-search-forward org-tr-regexp (point-at-eol) t)) + (if (not (org-at-date-range-p)) + (error "Not at a time-stamp range, and none found in current line"))) + (let* ((ts1 (match-string 1)) + (ts2 (match-string 2)) + (havetime (or (> (length ts1) 15) (> (length ts2) 15))) + (match-end (match-end 0)) + (time1 (org-time-string-to-time ts1)) + (time2 (org-time-string-to-time ts2)) + (t1 (time-to-seconds time1)) + (t2 (time-to-seconds time2)) + (diff (abs (- t2 t1))) + (negative (< (- t2 t1) 0)) + ;; (ys (floor (* 365 24 60 60))) + (ds (* 24 60 60)) + (hs (* 60 60)) + (fy "%dy %dd %02d:%02d") + (fy1 "%dy %dd") + (fd "%dd %02d:%02d") + (fd1 "%dd") + (fh "%02d:%02d") + y d h m align) + (if havetime + (setq ; y (floor (/ diff ys)) diff (mod diff ys) + y 0 + d (floor (/ diff ds)) diff (mod diff ds) + h (floor (/ diff hs)) diff (mod diff hs) + m (floor (/ diff 60))) + (setq ; y (floor (/ diff ys)) diff (mod diff ys) + y 0 + 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)))) + (if (looking-at + "\\( *-? *[0-9]+y\\)?\\( *[0-9]+d\\)? *[0-9][0-9]:[0-9][0-9]") + (replace-match "")) + (if negative (insert " -")) + (if (> y 0) (insert " " (format (if havetime fy fy1) y d h m)) + (if (> d 0) (insert " " (format (if havetime fd fd1) d h m)) + (insert " " (format fh h m)))) + (if align (org-table-align)) + (message "Time difference inserted"))))) - (setq new (mapconcat - (lambda (l) - (if l (apply 'format rfmt - (append (pop fields) emptystrings)) - hfmt)) - lines "")) - ;; Replace the old one - (delete-region beg end) - (move-marker end nil) - (move-marker org-table-aligned-begin-marker (point)) - (insert new) - (move-marker org-table-aligned-end-marker (point)) - (when (and orgtbl-mode (not (org-mode-p))) - (goto-char org-table-aligned-begin-marker) - (while (org-hide-wide-columns org-table-aligned-end-marker))) - ;; Try to move to the old location - (goto-line winstartline) - (setq winstart (point-at-bol)) - (goto-line linepos) - (set-window-start (selected-window) winstart 'noforce) - (org-table-goto-column colpos) - (setq org-table-may-need-update nil) - )) +(defun org-make-tdiff-string (y d h m) + (let ((fmt "") + (l nil)) + (if (> y 0) (setq fmt (concat fmt "%d year" (if (> y 1) "s" "") " ") + l (push y l))) + (if (> d 0) (setq fmt (concat fmt "%d day" (if (> d 1) "s" "") " ") + l (push d l))) + (if (> h 0) (setq fmt (concat fmt "%d hour" (if (> h 1) "s" "") " ") + l (push h l))) + (if (> m 0) (setq fmt (concat fmt "%d minute" (if (> m 1) "s" "") " ") + l (push m l))) + (apply 'format fmt (nreverse l)))) -(defun org-string-width (s) - "Compute width of string, ignoring invisible characters. -This ignores character with invisibility property `org-link', and also -characters with property `org-cwidth', because these will become invisible -upon the next fontification round." - (let (b l) - (when (or (eq t buffer-invisibility-spec) - (assq 'org-link buffer-invisibility-spec)) - (while (setq b (text-property-any 0 (length s) - 'invisible 'org-link s)) - (setq s (concat (substring s 0 b) - (substring s (or (next-single-property-change - b 'invisible s) (length s))))))) - (while (setq b (text-property-any 0 (length s) 'org-cwidth t s)) - (setq s (concat (substring s 0 b) - (substring s (or (next-single-property-change - b 'org-cwidth s) (length s)))))) - (setq l (string-width s) b -1) - (while (setq b (text-property-any (1+ b) (length s) 'org-dwidth t s)) - (setq l (- l (get-text-property b 'org-dwidth-n s)))) - l)) +(defun org-time-string-to-time (s) + (apply 'encode-time (org-parse-time-string s))) -(defun org-table-begin (&optional table-type) - "Find the beginning of the table and return its position. -With argument TABLE-TYPE, go to the beginning of a table.el-type table." - (save-excursion - (if (not (re-search-backward - (if table-type org-table-any-border-regexp - org-table-border-regexp) - nil t)) - (progn (goto-char (point-min)) (point)) - (goto-char (match-beginning 0)) - (beginning-of-line 2) - (point)))) +(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) + (list 0 + (if (or (match-beginning 8) (not nodefault)) + (string-to-number (or (match-string 8 s) "0"))) + (if (or (match-beginning 7) (not nodefault)) + (string-to-number (or (match-string 7 s) "0"))) + (string-to-number (match-string 4 s)) + (string-to-number (match-string 3 s)) + (string-to-number (match-string 2 s)) + nil nil nil) + (make-list 9 0))) -(defun org-table-end (&optional table-type) - "Find the end of the table and return its position. -With argument TABLE-TYPE, go to the end of a table.el-type table." - (save-excursion - (if (not (re-search-forward - (if table-type org-table-any-border-regexp - org-table-border-regexp) - nil t)) - (goto-char (point-max)) - (goto-char (match-beginning 0))) - (point-marker))) +(defun org-timestamp-up (&optional arg) + "Increase the date item at the cursor by one. +If the cursor is on the year, change the year. If it is on the month or +the day, change that. +With prefix ARG, change by that many units." + (interactive "p") + (org-timestamp-change (prefix-numeric-value arg))) -(defun org-table-justify-field-maybe (&optional new) - "Justify the current field, text to left, number to right. -Optional argument NEW may specify text to replace the current field content." - (cond - ((and (not new) org-table-may-need-update)) ; Realignment will happen anyway - ((org-at-table-hline-p)) - ((and (not new) - (or (not (equal (marker-buffer org-table-aligned-begin-marker) - (current-buffer))) - (< (point) org-table-aligned-begin-marker) - (>= (point) org-table-aligned-end-marker))) - ;; This is not the same table, force a full re-align - (setq org-table-may-need-update t)) - (t ;; realign the current field, based on previous full realign - (let* ((pos (point)) s - (col (org-table-current-column)) - (num (if (> col 0) (nth (1- col) org-table-last-alignment))) - l f n o e) - (when (> col 0) - (skip-chars-backward "^|\n") - (if (looking-at " *\\([^|\n]*?\\) *\\(|\\|$\\)") - (progn - (setq s (match-string 1) - o (match-string 0) - l (max 1 (- (match-end 0) (match-beginning 0) 3)) - e (not (= (match-beginning 2) (match-end 2)))) - (setq f (format (if num " %%%ds %s" " %%-%ds %s") - l (if e "|" (setq org-table-may-need-update t) "")) - n (format f s)) - (if new - (if (<= (length new) l) ;; FIXME: length -> str-width? - (setq n (format f new)) - (setq n (concat new "|") org-table-may-need-update t))) - (or (equal n o) - (let (org-table-may-need-update) - (replace-match n)))) - (setq org-table-may-need-update t)) - (goto-char pos)))))) +(defun org-timestamp-down (&optional arg) + "Decrease the date item at the cursor by one. +If the cursor is on the year, change the year. If it is on the month or +the day, change that. +With prefix ARG, change by that many units." + (interactive "p") + (org-timestamp-change (- (prefix-numeric-value arg)))) -(defun org-table-next-field () - "Go to the next field in the current table, creating new lines as needed. -Before doing so, re-align the table if necessary." - (interactive) - (org-table-maybe-eval-formula) - (org-table-maybe-recalculate-line) - (if (and org-table-automatic-realign - org-table-may-need-update) - (org-table-align)) - (let ((end (org-table-end))) - (if (org-at-table-hline-p) - (end-of-line 1)) - (condition-case nil - (progn - (re-search-forward "|" end) - (if (looking-at "[ \t]*$") - (re-search-forward "|" end)) - (if (and (looking-at "-") - org-table-tab-jumps-over-hlines - (re-search-forward "^[ \t]*|\\([^-]\\)" end t)) - (goto-char (match-beginning 1))) - (if (looking-at "-") - (progn - (beginning-of-line 0) - (org-table-insert-row 'below)) - (if (looking-at " ") (forward-char 1)))) - (error - (org-table-insert-row 'below))))) +(defun org-timestamp-up-day (&optional arg) + "Increase the date in the time stamp by one day. +With prefix ARG, change that many days." + (interactive "p") + (if (and (not (org-at-timestamp-p t)) + (org-on-heading-p)) + (org-todo 'up) + (org-timestamp-change (prefix-numeric-value arg) 'day))) -(defun org-table-previous-field () - "Go to the previous field in the table. -Before doing so, re-align the table if necessary." - (interactive) - (org-table-justify-field-maybe) - (org-table-maybe-recalculate-line) - (if (and org-table-automatic-realign - org-table-may-need-update) - (org-table-align)) - (if (org-at-table-hline-p) - (end-of-line 1)) - (re-search-backward "|" (org-table-begin)) - (re-search-backward "|" (org-table-begin)) - (while (looking-at "|\\(-\\|[ \t]*$\\)") - (re-search-backward "|" (org-table-begin))) - (if (looking-at "| ?") - (goto-char (match-end 0)))) +(defun org-timestamp-down-day (&optional arg) + "Decrease the date in the time stamp by one day. +With prefix ARG, change that many days." + (interactive "p") + (if (and (not (org-at-timestamp-p t)) + (org-on-heading-p)) + (org-todo 'down) + (org-timestamp-change (- (prefix-numeric-value arg)) 'day))) -(defun org-table-next-row () - "Go to the next row (same column) in the current table. -Before doing so, re-align the table if necessary." +(defsubst org-pos-in-match-range (pos n) + (and (match-beginning n) + (<= (match-beginning n) pos) + (>= (match-end n) pos))) + +(defun org-at-timestamp-p (&optional inactive-ok) + "Determine if the cursor is in or at a timestamp." (interactive) - (org-table-maybe-eval-formula) - (org-table-maybe-recalculate-line) - (if (or (looking-at "[ \t]*$") - (save-excursion (skip-chars-backward " \t") (bolp))) - (newline) - (if (and org-table-automatic-realign - org-table-may-need-update) - (org-table-align)) - (let ((col (org-table-current-column))) - (beginning-of-line 2) - (if (or (not (org-at-table-p)) - (org-at-table-hline-p)) - (progn - (beginning-of-line 0) - (org-table-insert-row 'below))) - (org-table-goto-column col) - (skip-chars-backward "^|\n\r") - (if (looking-at " ") (forward-char 1))))) + (let* ((tsr (if inactive-ok org-ts-regexp3 org-ts-regexp2)) + (pos (point)) + (ans (or (looking-at tsr) + (save-excursion + (skip-chars-backward "^[<\n\r\t") + (if (> (point) 1) (backward-char 1)) + (and (looking-at tsr) + (> (- (match-end 0) pos) -1)))))) + (and (boundp 'org-ts-what) + (setq org-ts-what + (cond + ((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) + (t 'day)))) + ans)) -(defun org-table-copy-down (n) - "Copy a field down in the current column. -If the field at the cursor is empty, copy into it the content of the nearest -non-empty field above. With argument N, use the Nth non-empty field. -If the current field is not empty, it is copied down to the next row, and -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." - (interactive "p") - (let* ((colpos (org-table-current-column)) - (field (org-table-get-field)) - (non-empty (string-match "[^ \t]" field)) - (beg (org-table-begin)) - txt) - (org-table-check-inside-data-field) - (if non-empty - (progn - (setq txt (org-trim field)) - (org-table-next-row) - (org-table-blank-field)) - (save-excursion - (setq txt - (catch 'exit - (while (progn (beginning-of-line 1) - (re-search-backward org-table-dataline-regexp - beg t)) - (org-table-goto-column colpos t) - (if (and (looking-at - "|[ \t]*\\([^| \t][^|]*?\\)[ \t]*|") - (= (setq n (1- n)) 0)) - (throw 'exit (match-string 1)))))))) - (if txt - (progn - (if (and org-table-copy-increment - (string-match "^[0-9]+$" txt)) - (setq txt (format "%d" (+ (string-to-number txt) 1)))) - (insert txt) - (org-table-maybe-recalculate-line) - (org-table-align)) - (error "No non-empty field found")))) +(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', +`year', `minute', `second'. If WHAT is not given, the cursor position +in the timestamp determines what will be changed." + (let ((pos (point)) + with-hm inactive + org-ts-what + 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))))) -(defun org-table-check-inside-data-field () - "Is point inside a table data field? -I.e. not on a hline or before the first or after the last column? -This actually throws an error, so it aborts the current command." - (if (or (not (org-at-table-p)) - (= (org-table-current-column) 0) - (org-at-table-hline-p) - (looking-at "[ \t]*$")) - (error "Not in table data field"))) +(defun org-recenter-calendar (date) + "If the calendar is visible, recenter it to DATE." + (let* ((win (selected-window)) + (cwin (get-buffer-window "*Calendar*" t)) + (calendar-move-hook nil)) + (when cwin + (select-window cwin) + (calendar-goto-date (if (listp date) date + (calendar-gregorian-from-absolute date))) + (select-window win)))) -(defvar org-table-clip nil - "Clipboard for table regions.") +(defun org-goto-calendar (&optional arg) + "Go to the Emacs calendar at the current date. +If there is a time stamp in the current line, go to that date. +A prefix ARG can be used to force the current date." + (interactive "P") + (let ((tsr org-ts-regexp) diff + (calendar-move-hook nil) + (view-calendar-holidays-initially nil) + (view-diary-entries-initially nil)) + (if (or (org-at-timestamp-p) + (save-excursion + (beginning-of-line 1) + (looking-at (concat ".*" tsr)))) + (let ((d1 (time-to-days (current-time))) + (d2 (time-to-days + (org-time-string-to-time (match-string 1))))) + (setq diff (- d2 d1)))) + (calendar) + (calendar-goto-today) + (if (and diff (not arg)) (calendar-forward-day diff)))) -(defun org-table-blank-field () - "Blank the current table field or active region." +(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-table-check-inside-data-field) - (if (and (interactive-p) (org-region-active-p)) - (let (org-table-clip) - (org-table-cut-region (region-beginning) (region-end))) - (skip-chars-backward "^|") - (backward-char 1) - (if (looking-at "|[^|\n]+") - (let* ((pos (match-beginning 0)) - (match (match-string 0)) - (len (org-string-width match))) - (replace-match (concat "|" (make-string (1- len) ?\ ))) - (goto-char (+ 2 pos)) - (substring match 1))))) + (org-timestamp-change 0 'calendar)) -(defun org-table-get-field (&optional n replace) - "Return the value of the field in column N of current row. -N defaults to current field. -If REPLACE is a string, replace field with this value. The return value -is always the old value." - (and n (org-table-goto-column n)) - (skip-chars-backward "^|\n") - (backward-char 1) - (if (looking-at "|[^|\r\n]*") - (let* ((pos (match-beginning 0)) - (val (buffer-substring (1+ pos) (match-end 0)))) - (if replace - (replace-match (concat "|" replace))) - (goto-char (min (point-at-eol) (+ 2 pos))) - val) - (forward-char 1) "")) +;;; The clock for measuring work time. -(defun org-table-current-column () - "Find out which column we are in. -When called interactively, column is also displayed in echo area." +(defvar org-clock-marker (make-marker) + "Marker recording the last clock-in.") + +(defun org-clock-in () + "Start the clock on the current item. +If necessary, clock-out of the currently active clock." (interactive) - (if (interactive-p) (org-table-check-inside-data-field)) - (save-excursion - (let ((cnt 0) (pos (point))) - (beginning-of-line 1) - (while (search-forward "|" pos t) - (setq cnt (1+ cnt))) - (if (interactive-p) (message "This is table column %d" cnt)) - cnt))) + (org-clock-out t) + (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))) + (insert "\n") (backward-char 1) + (indent-relative) + (insert org-clock-string " ") + (setq ts (org-insert-time-stamp (current-time) 'with-hm 'inactive)) + (move-marker org-clock-marker (point) (buffer-base-buffer)) + (message "Clock started at %s" ts)))) -(defun org-table-goto-column (n &optional on-delim force) - "Move the cursor to the Nth column in the current table line. -With optional argument ON-DELIM, stop with point before the left delimiter -of the field. -If there are less than N fields, just go to after the last delimiter. -However, when FORCE is non-nil, create new columns if necessary." - (interactive "p") - (let ((pos (point-at-eol))) - (beginning-of-line 1) - (when (> n 0) - (while (and (> (setq n (1- n)) -1) - (or (search-forward "|" pos t) - (and force - (progn (end-of-line 1) - (skip-chars-backward "^|") - (insert " | ")))))) -; (backward-char 2) t))))) - (when (and force (not (looking-at ".*|"))) - (save-excursion (end-of-line 1) (insert " | "))) - (if on-delim - (backward-char 1) - (if (looking-at " ") (forward-char 1)))))) +(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." + (interactive) + (catch 'exit + (if (not (marker-buffer org-clock-marker)) + (if fail-quietly (throw 'exit t) (error "No active clock"))) + (let (ts te s h m) + (save-excursion + (set-buffer (marker-buffer org-clock-marker)) + (goto-char org-clock-marker) + (beginning-of-line 1) + (if (and (looking-at (concat "[ \t]*" org-keyword-time-regexp)) + (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) + (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))) + (time-to-seconds (apply 'encode-time (org-parse-time-string ts)))) + h (floor (/ s 3600)) + s (- s (* 3600 h)) + m (floor (/ s 60)) + s (- s (* 60 s))) + (insert " => " (format "%2d:%02d" h m)) + (move-marker org-clock-marker nil) + (org-add-log-maybe 'clock-out) + (message "Clock stopped at %s after HH:MM = %d:%02d" te h m))))) -(defun org-at-table-p (&optional table-type) - "Return t if the cursor is inside an org-type table. -If TABLE-TYPE is non-nil, also check for table.el-type tables." - (if org-enable-table-editor - (save-excursion - (beginning-of-line 1) - (looking-at (if table-type org-table-any-line-regexp - org-table-line-regexp))) - nil)) +(defun org-clock-cancel () + "Cancel the running clock be removing the start timestamp." + (interactive) + (if (not (marker-buffer org-clock-marker)) + (error "No active clock")) + (save-excursion + (set-buffer (marker-buffer org-clock-marker)) + (goto-char org-clock-marker) + (delete-region (1- (point-at-bol)) (point-at-eol))) + (message "Clock canceled")) -(defun org-at-table.el-p () - "Return t if and only if we are at a table.el table." - (and (org-at-table-p 'any) - (save-excursion - (goto-char (org-table-begin 'any)) - (looking-at org-table1-hline-regexp)))) +(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) -(defun org-table-recognize-table.el () - "If there is a table.el table nearby, recognize it and move into it." - (if org-table-tab-recognizes-table.el - (if (org-at-table.el-p) - (progn - (beginning-of-line 1) - (if (looking-at org-table-dataline-regexp) - nil - (if (looking-at org-table1-hline-regexp) - (progn - (beginning-of-line 2) - (if (looking-at org-table-any-border-regexp) - (beginning-of-line -1))))) - (if (re-search-forward "|" (org-table-end t) t) - (progn - (require 'table) - (if (table--at-cell-p (point)) - t - (message "recognizing table.el table...") - (table-recognize-table) - (message "recognizing table.el table...done"))) - (error "This should not happen...")) - t) - nil) - nil)) +(defun org-clock-sum (&optional tstart tend) + "Sum the times for each subtree. +Puts the resulting times in minutes as a text property on each headline." + (interactive) + (let* ((bmp (buffer-modified-p)) + (re (concat "^\\(\\*+\\)[ \t]\\|^[ \t]*" + org-clock-string + "[ \t]*\\(\\[.*?\\]\\)-+\\(\\[.*?\\]\\)")) + (lmax 30) + (ltimes (make-vector lmax 0)) + (t1 0) + (level 0) + ts te dt + time) + (remove-text-properties (point-min) (point-max) '(:org-clock-minutes t)) + (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 + (setq level (- (match-end 1) (match-beginning 1))) + (when (or (> t1 0) (> (aref ltimes level) 0)) + (loop for l from 0 to level do + (aset ltimes l (+ (aref ltimes l) t1))) + (setq t1 0 time (aref ltimes level)) + (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)))) + (setq org-clock-file-total-minutes (aref ltimes 0))) + (set-buffer-modified-p bmp))) -(defun org-at-table-hline-p () - "Return t if the cursor is inside a hline in a table." - (if org-enable-table-editor +(defun org-clock-display (&optional total-only) + "Show subtree times in the entire buffer. +If TOTAL-ONLY is non-nil, only show the total time for the entire file +in the echo area." + (interactive) + (org-remove-clock-overlays) + (let (time h m p) + (org-clock-sum) + (unless total-only (save-excursion - (beginning-of-line 1) - (looking-at org-table-hline-regexp)) - nil)) + (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)) + (org-put-clock-overlay time (funcall outline-level)))) + (setq h (/ org-clock-file-total-minutes 60) + m (- org-clock-file-total-minutes (* 60 h))) + ;; Arrange to remove the overlays upon next change. + (when org-remove-highlights-with-change + (org-add-hook 'before-change-functions 'org-remove-clock-overlays + nil 'local)))) + (message "Total file time: %d:%02d (%d hours and %d minutes)" h m h m))) -(defun org-table-insert-column () - "Insert a new column into the table." - (interactive) - (if (not (org-at-table-p)) - (error "Not at a table")) - (org-table-find-dataline) - (let* ((col (max 1 (org-table-current-column))) - (beg (org-table-begin)) - (end (org-table-end)) - ;; Current cursor position - (linepos (org-current-line)) - (colpos col)) - (goto-char beg) - (while (< (point) end) - (if (org-at-table-hline-p) - nil - (org-table-goto-column col t) - (insert "| ")) - (beginning-of-line 2)) - (move-marker end nil) - (goto-line linepos) - (org-table-goto-column colpos) - (org-table-align) - (org-table-modify-formulas 'insert col))) +(defvar org-clock-overlays nil) +(make-variable-buffer-local 'org-clock-overlays) -(defun org-table-find-dataline () - "Find a dataline in the current table, which is needed for column commands." - (if (and (org-at-table-p) - (not (org-at-table-hline-p))) - t - (let ((col (current-column)) - (end (org-table-end))) - (move-to-column col) - (while (and (< (point) end) - (or (not (= (current-column) col)) - (org-at-table-hline-p))) - (beginning-of-line 2) - (move-to-column col)) - (if (and (org-at-table-p) - (not (org-at-table-hline-p))) - t - (error - "Please position cursor in a data line for column operations"))))) +(defun org-put-clock-overlay (time &optional level) + "Put an overlays on the current line, displaying TIME. +If LEVEL is given, prefix time with a corresponding number of stars. +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)) + (off 0) + ov tx) + (move-to-column c) + (unless (eolp) (skip-chars-backward "^ \t")) + (skip-chars-backward " \t") + (setq ov (org-make-overlay (1- (point)) (point-at-eol)) + tx (concat (buffer-substring (1- (point)) (point)) + (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) ?\ )) + '(face secondary-selection)) + "")) + (if (not (featurep 'xemacs)) + (org-overlay-put ov 'display tx) + (org-overlay-put ov 'invisible t) + (org-overlay-put ov 'end-glyph (make-glyph tx))) + (push ov org-clock-overlays))) -(defun org-table-delete-column () - "Delete a column from the table." +(defun org-remove-clock-overlays (&optional beg end noremove) + "Remove the occur highlights from the buffer. +BEG and END are ignored. If NOREMOVE is nil, remove this function +from the `before-change-functions' in the current buffer." (interactive) - (if (not (org-at-table-p)) - (error "Not at a table")) - (org-table-find-dataline) - (org-table-check-inside-data-field) - (let* ((col (org-table-current-column)) - (beg (org-table-begin)) - (end (org-table-end)) - ;; Current cursor position - (linepos (org-current-line)) - (colpos col)) - (goto-char beg) - (while (< (point) end) - (if (org-at-table-hline-p) - nil - (org-table-goto-column col t) - (and (looking-at "|[^|\n]+|") - (replace-match "|"))) - (beginning-of-line 2)) - (move-marker end nil) - (goto-line linepos) - (org-table-goto-column colpos) - (org-table-align) - (org-table-modify-formulas 'remove col))) + (unless org-inhibit-highlight-removal + (mapc 'org-delete-overlay org-clock-overlays) + (setq org-clock-overlays nil) + (unless noremove + (remove-hook 'before-change-functions + 'org-remove-clock-overlays 'local)))) -(defun org-table-move-column-right () - "Move column to the right." - (interactive) - (org-table-move-column nil)) -(defun org-table-move-column-left () - "Move column to the left." - (interactive) - (org-table-move-column 'left)) +(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) + (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))) + (org-clock-out)))) -(defun org-table-move-column (&optional left) - "Move the current column to the right. With arg LEFT, move to the left." - (interactive "P") - (if (not (org-at-table-p)) - (error "Not at a table")) - (org-table-find-dataline) - (org-table-check-inside-data-field) - (let* ((col (org-table-current-column)) - (col1 (if left (1- col) col)) - (beg (org-table-begin)) - (end (org-table-end)) - ;; Current cursor position - (linepos (org-current-line)) - (colpos (if left (1- col) (1+ col)))) - (if (and left (= col 1)) - (error "Cannot move column further left")) - (if (and (not left) (looking-at "[^|\n]*|[^|\n]*$")) - (error "Cannot move column further right")) - (goto-char beg) - (while (< (point) end) - (if (org-at-table-hline-p) - nil - (org-table-goto-column col1 t) - (and (looking-at "|\\([^|\n]+\\)|\\([^|\n]+\\)|") - (replace-match "|\\2|\\1|"))) - (beginning-of-line 2)) - (move-marker end nil) - (goto-line linepos) - (org-table-goto-column colpos) - (org-table-align) - (org-table-modify-formulas 'swap col (if left (1- col) (1+ col))))) +(add-hook 'org-after-todo-state-change-hook + 'org-clock-out-if-current) -(defun org-table-move-row-down () - "Move table row down." - (interactive) - (org-table-move-row nil)) -(defun org-table-move-row-up () - "Move table row up." +(defun org-check-running-clock () + "Check if the current buffer contains the running clock. +If yes, offer to stop it and to save the buffer with the changes." + (when (and (equal (marker-buffer org-clock-marker) (current-buffer)) + (y-or-n-p (format "Clock-out in buffer %s before killing it? " + (buffer-name)))) + (org-clock-out) + (when (y-or-n-p "Save changed buffer?") + (save-buffer)))) + +(defun org-clock-report () + "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) - (org-table-move-row 'up)) + (org-remove-clock-overlays) + (unless (org-find-dblock "clocktable") + (org-create-dblock (list :name "clocktable" + :maxlevel 2 :emphasize nil))) + (org-update-dblock)) -(defun org-table-move-row (&optional up) - "Move the current table line down. With arg UP, move it up." - (interactive "P") - (let ((col (current-column)) - (pos (point)) - (tonew (if up 0 2)) - txt) - (beginning-of-line tonew) - (if (not (org-at-table-p)) - (progn - (goto-char pos) - (error "Cannot move row further"))) - (goto-char pos) +(defun org-clock-update-time-maybe () + "If this is a CLOCK line, update it and return t. +Otherwise, return nil." + (interactive) + (save-excursion (beginning-of-line 1) - (setq pos (point)) - (setq txt (buffer-substring (point) (1+ (point-at-eol)))) - (delete-region (point) (1+ (point-at-eol))) - (beginning-of-line tonew) - (insert txt) - (beginning-of-line 0) - (move-to-column col))) - -(defun org-table-insert-row (&optional arg) - "Insert a new row above the current line into the table. -With prefix ARG, insert below the current line." - (interactive "P") - (if (not (org-at-table-p)) - (error "Not at a table")) - (let* ((line (buffer-substring (point-at-bol) (point-at-eol))) - (new (org-table-clean-line line))) - ;; Fix the first field if necessary - (if (string-match "^[ \t]*| *[#$] *|" line) - (setq new (replace-match (match-string 0 line) t t new))) - (beginning-of-line (if arg 2 1)) - (let (org-table-may-need-update) (insert-before-markers new "\n")) - (beginning-of-line 0) - (re-search-forward "| ?" (point-at-eol) t) - (and org-table-may-need-update (org-table-align)))) + (skip-chars-forward " \t") + (when (looking-at org-clock-string) + (let ((re (concat "[ \t]*" org-clock-string + " *[[<]\\([^]>]+\\)[]>]-+[[<]\\([^]>]+\\)[]>]" + "\\([ \t]*=>.*\\)?")) + ts te h m s) + (if (not (looking-at re)) + nil + (and (match-end 3) (delete-region (match-beginning 3) (match-end 3))) + (end-of-line 1) + (setq ts (match-string 1) + te (match-string 2)) + (setq s (- (time-to-seconds + (apply 'encode-time (org-parse-time-string te))) + (time-to-seconds + (apply 'encode-time (org-parse-time-string ts)))) + h (floor (/ s 3600)) + s (- s (* 3600 h)) + m (floor (/ s 60)) + s (- s (* 60 s))) + (insert " => " (format "%2d:%02d" h m)) + t))))) -(defun org-table-insert-hline (&optional arg) - "Insert a horizontal-line below the current line into the table. -With prefix ARG, insert above the current line." - (interactive "P") - (if (not (org-at-table-p)) - (error "Not at a table")) - (let ((line (org-table-clean-line - (buffer-substring (point-at-bol) (point-at-eol)))) - (col (current-column))) - (while (string-match "|\\( +\\)|" line) - (setq line (replace-match - (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)) - (insert line "\n") - (beginning-of-line (if arg 1 -1)) - (move-to-column col))) +(defun org-clock-special-range (key &optional time as-strings) + "Return two times bordering a special time range. +Key is a symbol specifying the range and can be one of `today', `yesterday', +`thisweek', `lastweek', `thismonth', `lastmonth', `thisyear', `lastyear'. +A week starts Monday 0:00 and ends Sunday 24:00. +The range is determined relative to TIME. TIME defaults to the current time. +The return value is a cons cell with two internal times like the ones +returned by `current time' or `encode-time'. if AS-STRINGS is non-nil, +the returned times will be formatted strings." + (let* ((tm (decode-time (or time (current-time)))) + (s 0) (m (nth 1 tm)) (h (nth 2 tm)) + (d (nth 3 tm)) (month (nth 4 tm)) (y (nth 5 tm)) + (dow (nth 6 tm)) + s1 m1 h1 d1 month1 y1 diff ts te fm) + (cond + ((eq key 'today) + (setq h 0 m 0 h1 24 m1 0)) + ((eq key 'yesterday) + (setq d (1- d) h 0 m 0 h1 24 m1 0)) + ((eq key 'thisweek) + (setq diff (if (= dow 0) 6 (1- dow)) + m 0 h 0 d (- d diff) d1 (+ 7 d))) + ((eq key 'lastweek) + (setq diff (+ 7 (if (= dow 0) 6 (1- dow))) + m 0 h 0 d (- d diff) d1 (+ 7 d))) + ((eq key 'thismonth) + (setq d 1 h 0 m 0 d1 1 month1 (1+ month) h1 0 m1 0)) + ((eq key 'lastmonth) + (setq d 1 h 0 m 0 d1 1 month (1- month) month1 (1+ month) h1 0 m1 0)) + ((eq key 'thisyear) + (setq m 0 h 0 d 1 month 1 y1 (1+ y))) + ((eq key 'lastyear) + (setq m 0 h 0 d 1 month 1 y (1- y) y1 (1+ y))) + (t (error "No such time block %s" key))) + (setq ts (encode-time s m h d month y) + te (encode-time (or s1 s) (or m1 m) (or h1 h) + (or d1 d) (or month1 month) (or y1 y))) + (setq fm (cdr org-time-stamp-formats)) + (if as-strings + (cons (format-time-string fm ts) (format-time-string fm te)) + (cons ts te)))) -(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." - (if (string-match "^[ \t]*|-" s) - ;; It's a hline, just map the characters - (setq s (mapconcat (lambda (x) (if (member x '(?| ?+)) "|" " ")) s "")) - (while (string-match "|\\([ \t]*?[^ \t\r\n|][^\r\n|]*\\)|" s) - (setq s (replace-match - (concat "|" (make-string (org-string-width (match-string 1 s)) - ?\ ) "|") - t t s))) - s)) +(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)) + (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)) + (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))) -(defun org-table-kill-row () - "Delete the current row or horizontal line from the table." +;; FIXME: I don't think anybody uses this, ask David +(defun org-collect-clock-time-entries () + "Return an internal list with clocking information. +This list has one entry for each CLOCK interval. +FIXME: describe the elements." (interactive) - (if (not (org-at-table-p)) - (error "Not at a table")) - (let ((col (current-column))) - (kill-region (point-at-bol) (min (1+ (point-at-eol)) (point-max))) - (if (not (org-at-table-p)) (beginning-of-line 0)) - (move-to-column col))) + (let ((re (concat "^[ \t]*" org-clock-string + " *\\[\\(.*?\\)\\]--\\[\\(.*?\\)\\]")) + rtn beg end next cont level title total closedp leafp + clockpos titlepos h m donep) + (save-excursion + (org-clock-sum) + (goto-char (point-min)) + (while (re-search-forward re nil t) + (setq clockpos (match-beginning 0) + beg (match-string 1) end (match-string 2) + cont (match-end 0)) + (setq beg (apply 'encode-time (org-parse-time-string beg)) + end (apply 'encode-time (org-parse-time-string end))) + (org-back-to-heading t) + (setq donep (org-entry-is-done-p)) + (setq titlepos (point) + total (or (get-text-property (1+ (point)) :org-clock-minutes) 0) + h (/ total 60) m (- total (* 60 h)) + total (cons h m)) + (looking-at "\\(\\*+\\) +\\(.*\\)") + (setq level (- (match-end 1) (match-beginning 1)) + title (org-match-string-no-properties 2)) + (save-excursion (outline-next-heading) (setq next (point))) + (setq closedp (re-search-forward org-closed-time-regexp next t)) + (goto-char next) + (setq leafp (and (looking-at "^\\*+ ") + (<= (- (match-end 0) (point)) level))) + (push (list beg end clockpos closedp donep + total title titlepos level leafp) + rtn) + (goto-char cont))) + (nreverse rtn))) -(defun org-table-sort-lines (beg end numericp) - "Sort table lines in region. -Point and mark define the first and last line to include. Both point and -mark should be in the column that is used for sorting. For example, to -sort according to column 3, put the mark in the first line to sort, in -table column 3. Put point into the last line to be included in the sorting, -also in table column 3. The command will prompt for the sorting method -\(n for numerical, a for alphanumeric)." - (interactive "r\nsSorting method: [n]=numeric [a]=alpha: ") - (setq numericp (string-match "[nN]" numericp)) - (org-table-align) ;; Just to be safe - (let* (bcol ecol cmp column lns) - (goto-char beg) - (org-table-check-inside-data-field) - (setq column (org-table-current-column) - beg (move-marker (make-marker) (point-at-bol))) - (goto-char end) - (org-table-check-inside-data-field) - (setq end (move-marker (make-marker) (1+ (point-at-eol)))) - (untabify beg end) - (goto-char beg) - (org-table-goto-column column) - (skip-chars-backward "^|") - (setq bcol (current-column)) - (org-table-goto-column (1+ column)) - (skip-chars-backward "^|") - (setq ecol (1- (current-column))) - (setq cmp (if numericp - (lambda (a b) (< (car a) (car b))) - (lambda (a b) (string< (car a) (car b))))) - (setq lns (mapcar (lambda(x) (cons (org-trim (substring x bcol ecol)) x)) - (org-split-string (buffer-substring beg end) "\n"))) - (if numericp - (setq lns (mapcar (lambda(x) - (cons (string-to-number (car x)) (cdr x))) - lns))) - (delete-region beg end) - (move-marker beg nil) - (move-marker end nil) - (insert (mapconcat 'cdr (setq lns (sort lns cmp)) "\n") "\n") - (message "%d lines sorted %s based on column %d" - (length lns) - (if numericp "numerically" "alphabetically") column))) +;;;; Agenda, and Diary Integration -(defun org-table-cut-region (beg end) - "Copy region in table to the clipboard and blank all relevant fields." - (interactive "r") - (org-table-copy-region beg end 'cut)) +;;; Define the Org-agenda-mode -(defun org-table-copy-region (beg end &optional cut) - "Copy rectangular region in table to clipboard. -A special clipboard is used which can only be accessed -with `org-table-paste-rectangle'." - (interactive "rP") - (let* (l01 c01 l02 c02 l1 c1 l2 c2 ic1 ic2 - region cols - (rpl (if cut " " nil))) - (goto-char beg) - (org-table-check-inside-data-field) - (setq l01 (org-current-line) - c01 (org-table-current-column)) - (goto-char end) - (org-table-check-inside-data-field) - (setq l02 (org-current-line) - c02 (org-table-current-column)) - (setq l1 (min l01 l02) l2 (max l01 l02) - c1 (min c01 c02) c2 (max c01 c02)) - (catch 'exit - (while t - (catch 'nextline - (if (> l1 l2) (throw 'exit t)) - (goto-line l1) - (if (org-at-table-hline-p) (throw 'nextline (setq l1 (1+ l1)))) - (setq cols nil ic1 c1 ic2 c2) - (while (< ic1 (1+ ic2)) - (push (org-table-get-field ic1 rpl) cols) - (setq ic1 (1+ ic1))) - (push (nreverse cols) region) - (setq l1 (1+ l1))))) - (setq org-table-clip (nreverse region)) - (if cut (org-table-align)) - org-table-clip)) +(defvar org-agenda-mode-map (make-sparse-keymap) + "Keymap for `org-agenda-mode'.") -(defun org-table-paste-rectangle () - "Paste a rectangular region into a table. -The upper right corner ends up in the current field. All involved fields -will be overwritten. If the rectangle does not fit into the present table, -the table is enlarged as needed. The process ignores horizontal separator -lines." - (interactive) - (unless (and org-table-clip (listp org-table-clip)) - (error "First cut/copy a region to paste!")) - (org-table-check-inside-data-field) - (let* ((clip org-table-clip) - (line (org-current-line)) - (col (org-table-current-column)) - (org-enable-table-editor t) - (org-table-automatic-realign nil) - c cols field) - (while (setq cols (pop clip)) - (while (org-at-table-hline-p) (beginning-of-line 2)) - (if (not (org-at-table-p)) - (progn (end-of-line 0) (org-table-next-field))) - (setq c col) - (while (setq field (pop cols)) - (org-table-goto-column c nil 'force) - (org-table-get-field nil field) - (setq c (1+ c))) - (beginning-of-line 2)) - (goto-line line) - (org-table-goto-column col) - (org-table-align))) +(defvar org-agenda-menu) ; defined later in this file. +(defvar org-agenda-follow-mode nil) +(defvar org-agenda-show-log nil) +(defvar org-agenda-redo-command nil) +(defvar org-agenda-mode-hook nil) +(defvar org-agenda-type nil) +(defvar org-agenda-force-single-file nil) -(defun org-table-convert () - "Convert from `org-mode' table to table.el and back. -Obviously, this only works within limits. When an Org-mode table is -converted to table.el, all horizontal separator lines get lost, because -table.el uses these as cell boundaries and has no notion of horizontal lines. -A table.el table can be converted to an Org-mode table only if it does not -do row or column spanning. Multiline cells will become multiple cells. -Beware, Org-mode does not test if the table can be successfully converted - it -blindly applies a recipe that works for simple tables." - (interactive) - (require 'table) - (if (org-at-table.el-p) - ;; convert to Org-mode table - (let ((beg (move-marker (make-marker) (org-table-begin t))) - (end (move-marker (make-marker) (org-table-end t)))) - (table-unrecognize-region beg end) - (goto-char beg) - (while (re-search-forward "^\\([ \t]*\\)\\+-.*\n" end t) - (replace-match "")) - (goto-char beg)) - (if (org-at-table-p) - ;; convert to table.el table - (let ((beg (move-marker (make-marker) (org-table-begin))) - (end (move-marker (make-marker) (org-table-end)))) - ;; first, get rid of all horizontal lines - (goto-char beg) - (while (re-search-forward "^\\([ \t]*\\)|-.*\n" end t) - (replace-match "")) - ;; insert a hline before first - (goto-char beg) - (org-table-insert-hline 'above) - (beginning-of-line -1) - ;; insert a hline after each line - (while (progn (beginning-of-line 3) (< (point) end)) - (org-table-insert-hline)) - (goto-char beg) - (setq end (move-marker end (org-table-end))) - ;; replace "+" at beginning and ending of hlines - (while (re-search-forward "^\\([ \t]*\\)|-" end t) - (replace-match "\\1+-")) - (goto-char beg) - (while (re-search-forward "-|[ \t]*$" end t) - (replace-match "-+")) - (goto-char beg))))) +(defun org-agenda-mode () + "Mode for time-sorted view on action items in Org-mode files. -(defun org-table-wrap-region (arg) - "Wrap several fields in a column like a paragraph. -This is useful if you'd like to spread the contents of a field over several -lines, in order to keep the table compact. +The following commands are available: -If there is an active region, and both point and mark are in the same column, -the text in the column is wrapped to minimum width for the given number of -lines. Generally, this makes the table more compact. A prefix ARG may be -used to change the number of desired lines. For example, `C-2 \\[org-table-wrap]' -formats the selected text to two lines. If the region was longer than two -lines, the remaining lines remain empty. A negative prefix argument reduces -the current number of lines by that amount. The wrapped text is pasted back -into the table. If you formatted it to more lines than it was before, fields -further down in the table get overwritten - so you might need to make space in -the table first. +\\{org-agenda-mode-map}" + (interactive) + (kill-all-local-variables) + (setq org-agenda-undo-list nil + org-agenda-pending-undo-list nil) + (setq major-mode 'org-agenda-mode) + (setq mode-name "Org-Agenda") + (use-local-map org-agenda-mode-map) + (easy-menu-add org-agenda-menu) + (if org-startup-truncated (setq truncate-lines t)) + (org-add-hook 'post-command-hook 'org-agenda-post-command-hook nil 'local) + (org-add-hook 'pre-command-hook 'org-unhighlight nil 'local) + ;; Make sure properties are removed when copying text + (when (boundp 'buffer-substring-filters) + (org-set-local 'buffer-substring-filters + (cons (lambda (x) + (set-text-properties 0 (length x) nil x) x) + buffer-substring-filters))) + (unless org-agenda-keep-modes + (setq org-agenda-follow-mode org-agenda-start-with-follow-mode + org-agenda-show-log nil)) + (easy-menu-change + '("Agenda") "Agenda Files" + (append + (list + (vector + (if (get 'org-agenda-files 'org-restrict) + "Restricted to single file" + "Edit File List") + '(org-edit-agenda-file-list) + (not (get 'org-agenda-files 'org-restrict))) + "--") + (mapcar 'org-file-menu-entry (org-agenda-files)))) + (org-agenda-set-mode-name) + (apply + (if (fboundp 'run-mode-hooks) 'run-mode-hooks 'run-hooks) + (list 'org-agenda-mode-hook))) -If there is no region, the current field is split at the cursor position and -the text fragment to the right of the cursor is prepended to the field one -line down. +(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 "$" '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) -If there is no region, but you specify a prefix ARG, the current field gets -blank, and the content is appended to the field above." - (interactive "P") - (org-table-check-inside-data-field) - (if (org-region-active-p) - ;; There is a region: fill as a paragraph - (let ((beg (region-beginning)) - nlines) - (org-table-cut-region (region-beginning) (region-end)) - (if (> (length (car org-table-clip)) 1) - (error "Region must be limited to single column")) - (setq nlines (if arg - (if (< arg 1) - (+ (length org-table-clip) arg) - arg) - (length org-table-clip))) - (setq org-table-clip - (mapcar 'list (org-wrap (mapconcat 'car org-table-clip " ") - nil nlines))) - (goto-char beg) - (org-table-paste-rectangle)) - ;; No region, split the current field at point - (if arg - ;; combine with field above - (let ((s (org-table-blank-field)) - (col (org-table-current-column))) - (beginning-of-line 0) - (while (org-at-table-hline-p) (beginning-of-line 0)) - (org-table-goto-column col) - (skip-chars-forward "^|") - (skip-chars-backward " ") - (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)))))) +(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) +(let ((l '(1 2 3 4 5 6 7 8 9 0))) + (while l (define-key org-agenda-mode-map + (int-to-string (pop l)) 'digit-argument))) -(defvar org-field-marker nil) +(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) +(eval-after-load "calendar" + '(define-key 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) +(defvar org-agenda-keymap (copy-keymap org-agenda-mode-map) + "Local keymap for agenda entries from Org-mode.") -(defun org-table-edit-field (arg) - "Edit table field in a different window. -This is mainly useful for fields that contain hidden parts. -When called with a \\[universal-argument] prefix, just make the full field visible so that -it can be edited in place." - (interactive "P") - (if arg - (let ((b (save-excursion (skip-chars-backward "^|") (point))) - (e (save-excursion (skip-chars-forward "^|\r\n") (point)))) - (remove-text-properties b e '(org-cwidth t invisible t - display t intangible t)) - (if (and (boundp 'font-lock-mode) font-lock-mode) - (font-lock-fontify-block))) - (let ((pos (move-marker (make-marker) (point))) - (field (org-table-get-field)) - (cw (current-window-configuration)) - p) - (switch-to-buffer-other-window "*Org tmp*") - (erase-buffer) - (insert "#\n# Edit field and finish with C-c C-c\n#\n") - (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-window-configuration cw) - (org-set-local 'org-field-marker pos) - (message "Edit and finish with C-c C-c")))) +(define-key org-agenda-keymap + (if (featurep 'xemacs) [(button2)] [(mouse-2)]) 'org-agenda-goto-mouse) +(define-key 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)) +(easy-menu-define org-agenda-menu org-agenda-mode-map "Agenda menu" + '("Agenda" + ("Agenda Files") + "--" + ["Show" org-agenda-show t] + ["Go To (other window)" org-agenda-goto t] + ["Go To (this window)" org-agenda-switch-to t] + ["Follow Mode" org-agenda-follow-mode + :style toggle :selected org-agenda-follow-mode :active t] + ["Tree to indirect frame" org-agenda-tree-to-indirect-buffer t] + "--" + ["Cycle TODO" org-agenda-todo t] + ["Archive subtree" org-agenda-archive t] + ["Delete subtree" org-agenda-kill t] + "--" + ["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)] + "--" + ("Tags" + ["Show all Tags" org-agenda-show-tags t] + ["Set Tags" org-agenda-set-tags 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)]) + ("Priority" + ["Set Priority" org-agenda-priority t] + ["Increase Priority" org-agenda-priority-up t] + ["Decrease Priority" org-agenda-priority-down t] + ["Show Priority" org-agenda-show-priority t]) + ("Calendar/Diary" + ["New Diary Entry" org-agenda-diary-entry (org-agenda-check-type nil 'agenda 'timeline)] + ["Goto Calendar" org-agenda-goto-calendar (org-agenda-check-type nil 'agenda 'timeline)] + ["Phases of the Moon" org-agenda-phases-of-moon (org-agenda-check-type nil 'agenda 'timeline)] + ["Sunrise/Sunset" org-agenda-sunrise-sunset (org-agenda-check-type nil 'agenda 'timeline)] + ["Holidays" org-agenda-holidays (org-agenda-check-type nil 'agenda 'timeline)] + ["Convert" org-agenda-convert-date (org-agenda-check-type nil 'agenda 'timeline)] + "--" + ["Create iCalendar file" org-export-icalendar-combine-agenda-files t]) + "--" + ("View" + ["Day View" org-agenda-day-view :active (org-agenda-check-type nil 'agenda) + :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)] + "--" + ["Show Logbook entries" org-agenda-log-mode + :style toggle :selected org-agenda-show-log :active (org-agenda-check-type nil 'agenda 'timeline)] + ["Include Diary" org-agenda-toggle-diary + :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)]) + ["Rebuild buffer" org-agenda-redo t] + ["Save all Org-mode Buffers" org-save-all-org-buffers t] + "--" + ["Undo Remote Editing" org-agenda-undo org-agenda-undo-list] + "--" + ["Quit" org-agenda-quit t] + ["Exit and Release Buffers" org-agenda-exit t] + )) -(defun org-table-finish-edit-field () - "Finish editing a table data field. -Remove all newline characters, insert the result into the table, realign -the table and kill the editing buffer." - (let ((pos org-field-marker) - (cw org-window-configuration) - (cb (current-buffer)) - text) - (goto-char (point-min)) - (while (re-search-forward "^#.*\n?" nil t) (replace-match "")) - (while (re-search-forward "\\([ \t]*\n[ \t]*\\)+" nil t) - (replace-match " ")) - (setq text (org-trim (buffer-string))) - (set-window-configuration cw) - (kill-buffer cb) - (select-window (get-buffer-window (marker-buffer pos))) - (goto-char pos) - (move-marker pos nil) - (org-table-check-inside-data-field) - (org-table-get-field nil text) - (org-table-align) - (message "New field value inserted"))) +;;; Agenda undo + +(defvar org-agenda-allow-remote-undo t + "Non-nil means, allow remote undo from the agenda buffer.") +(defvar org-agenda-undo-list nil + "List of undoable operations in the agenda since last refresh.") +(defvar org-agenda-undo-has-started-in nil + "Buffers that have already seen `undo-start' in the current undo sequence.") +(defvar org-agenda-pending-undo-list nil + "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." + (declare (debug t)) + `(unless (get-text-property (point) 'org-protected) + ,@body)) + +(defmacro org-with-remote-undo (_buffer &rest _body) + "Execute BODY while recording undo information in two buffers." + (declare (indent 1) (debug t)) + `(let ((_cline (org-current-line)) + (_cmd this-command) + (_buf1 (current-buffer)) + (_buf2 ,_buffer) + (_undo1 buffer-undo-list) + (_undo2 (with-current-buffer ,_buffer buffer-undo-list)) + _c1 _c2) + ,@_body + (when org-agenda-allow-remote-undo + (setq _c1 (org-verify-change-for-undo + _undo1 (with-current-buffer _buf1 buffer-undo-list)) + _c2 (org-verify-change-for-undo + _undo2 (with-current-buffer _buf2 buffer-undo-list))) + (when (or _c1 _c2) + ;; make sure there are undo boundaries + (and _c1 (with-current-buffer _buf1 (undo-boundary))) + (and _c2 (with-current-buffer _buf2 (undo-boundary))) + ;; remember which buffer to undo + (push (list _cmd _cline _buf1 _c1 _buf2 _c2) + org-agenda-undo-list))))) + +(defun org-agenda-undo () + "Undo a remote editing step in the agenda. +This undoes changes both in the agenda buffer and in the remote buffer +that have been changed along." + (interactive) + (or org-agenda-allow-remote-undo + (error "Check the variable `org-agenda-allow-remote-undo' to activate remote undo.")) + (if (not (eq this-command last-command)) + (setq org-agenda-undo-has-started-in nil + org-agenda-pending-undo-list org-agenda-undo-list)) + (if (not org-agenda-pending-undo-list) + (error "No further undo information")) + (let* ((entry (pop org-agenda-pending-undo-list)) + buf line cmd rembuf) + (setq cmd (pop entry) line (pop entry)) + (setq rembuf (nth 2 entry)) + (org-with-remote-undo rembuf + (while (bufferp (setq buf (pop entry))) + (if (pop entry) + (with-current-buffer buf + (let ((last-undo-buffer buf) + buffer-read-only) + (unless (memq buf org-agenda-undo-has-started-in) + (push buf org-agenda-undo-has-started-in) + (make-local-variable 'pending-undo-list) + (undo-start)) + (while (and pending-undo-list + (listp pending-undo-list) + (not (car pending-undo-list))) + (pop pending-undo-list)) + (undo-more 1)))))) + (goto-line line) + (message "`%s' undone (buffer %s)" cmd (buffer-name rembuf)))) -(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))) - s) +(defun org-verify-change-for-undo (l1 l2) + "Verify that a real change occurred between the undo lists L1 and L2." + (while (and l1 (listp l1) (null (car l1))) (pop l1)) + (while (and l2 (listp l2) (null (car l2))) (pop l2)) + (not (eq l1 l2))) -(defun org-wrap (string &optional width lines) - "Wrap string to either a number of lines, or a width in characters. -If WIDTH is non-nil, the string is wrapped to that width, however many lines -that costs. If there is a word longer than WIDTH, the text is actually -wrapped to the length of that word. -IF WIDTH is nil and LINES is non-nil, the string is forced into at most that -many lines, whatever width that takes. -The return value is a list of lines, without newlines at the end." - (let* ((words (org-split-string string "[ \t\n]+")) - (maxword (apply 'max (mapcar 'org-string-width words))) - w ll) - (cond (width - (org-do-wrap words (max maxword width))) - (lines - (setq w maxword) - (setq ll (org-do-wrap words maxword)) - (if (<= (length ll) lines) - ll - (setq ll words) - (while (> (length ll) lines) - (setq w (1+ w)) - (setq ll (org-do-wrap words w))) - ll)) - (t (error "Cannot wrap this"))))) +;;; Agenda dispatch +(defvar org-agenda-restrict nil) +(defvar org-agenda-restrict-begin (make-marker)) +(defvar org-agenda-restrict-end (make-marker)) +(defvar org-agenda-last-dispatch-buffer nil) -(defun org-do-wrap (words width) - "Create lines of maximum width WIDTH (in characters) from word list WORDS." - (let (lines line) - (while words - (setq line (pop words)) - (while (and words (< (+ (length line) (length (car words))) width)) - (setq line (concat line " " (pop words)))) - (setq lines (push line lines))) - (nreverse lines))) +;;;###autoload +(defun org-agenda (arg) + "Dispatch agenda commands to collect entries to the agenda buffer. +Prompts for a character to select a command. 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 + entries with a specific TODO keyword (the user gets a prompt). +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. -(defun org-split-string (string &optional separators) - "Splits STRING into substrings at SEPARATORS. -No empty strings are returned if there are matches at the beginning -and end of string." - (let ((rexp (or separators "[ \f\t\n\r\v]+")) - (start 0) - notfirst - (list nil)) - (while (and (string-match rexp string - (if (and notfirst - (= start (match-beginning 0)) - (< start (length string))) - (1+ start) start)) - (< (match-beginning 0) (length string))) - (setq notfirst t) - (or (eq (match-beginning 0) 0) - (and (eq (match-beginning 0) (match-end 0)) - (eq (match-beginning 0) start)) - (setq list - (cons (substring string start (match-beginning 0)) - list))) - (setq start (match-end 0))) - (or (eq start (length string)) - (setq list - (cons (substring string start) - list))) - (nreverse list))) +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. -(defun org-table-map-tables (function) - "Apply FUNCTION to the start of all tables in the buffer." - (save-excursion - (save-restriction - (widen) - (goto-char (point-min)) - (while (re-search-forward org-table-any-line-regexp nil t) - (message "Mapping tables: %d%%" (/ (* 100.0 (point)) (buffer-size))) - (beginning-of-line 1) - (if (looking-at org-table-line-regexp) - (save-excursion (funcall function))) - (re-search-forward org-table-any-border-regexp nil 1)))) - (message "Mapping tables: done")) +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." + (interactive "P") + (catch 'exit + (let* ((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) + ;; 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) + (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 ""))) + (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)) + (progn + (setq type (nth 1 entry) match (nth 2 entry) lprops (nth 3 entry) + lprops (nth 3 entry)) + (cond + ((eq type 'tags) + (org-let lprops '(org-tags-view current-prefix-arg match))) + ((eq type 'tags-todo) + (org-let lprops '(org-tags-view '(4) match))) + ((eq type 'todo) + (org-let lprops '(org-todo-list match))) + ((eq type 'tags-tree) + (org-check-for-org-mode) + (org-let lprops '(org-tags-sparse-tree current-prefix-arg match))) + ((eq type 'todo-tree) + (org-check-for-org-mode) + (org-let lprops + '(org-occur (concat "^" outline-regexp "[ \t]*" + (regexp-quote match) "\\>")))) + ((eq type 'occur-tree) + (org-check-for-org-mode) + (org-let lprops '(org-occur 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 + (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-table-sum (&optional beg end nlast) - "Sum numbers in region of current table column. -The result will be displayed in the echo area, and will be available -as kill to be inserted with \\[yank]. +(defun org-run-agenda-series (series) + (org-prepare-agenda) + (let* ((org-agenda-multi t) + (redo (list 'org-run-agenda-series (list 'quote series))) + (cmds (car series)) + (gprops (nth 1 series)) + match ;; The byte compiler incorrectly complains about this. Keep it! + cmd type lprops) + (while (setq cmd (pop cmds)) + (setq type (car cmd) match (nth 1 cmd) lprops (nth 2 cmd)) + (cond + ((eq type 'agenda) + (call-interactively 'org-agenda-list)) + ((eq type 'alltodo) + (call-interactively 'org-todo-list)) + ((eq type 'stuck) + (call-interactively 'org-agenda-list-stuck-projects)) + ((eq type 'tags) + (org-let2 gprops lprops + '(org-tags-view current-prefix-arg match))) + ((eq type 'tags-todo) + (org-let2 gprops lprops + '(org-tags-view '(4) match))) + ((eq type 'todo) + (org-let2 gprops lprops + '(org-todo-list match))) + ((fboundp type) + (org-let2 gprops lprops + '(funcall type match))) + (t (error "Invalid type in command series")))) + (widen) + (setq org-agenda-redo-command redo) + (goto-char (point-min))) + (org-finalize-agenda)) -If there is an active region, it is interpreted as a rectangle and all -numbers in that rectangle will be summed. If there is no active -region and point is located in a table column, sum all numbers in that -column. +;;;###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'. +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 at least one number looks like a time HH:MM or HH:MM:SS, all other -numbers are assumed to be times as well (in decimal hours) and the -numbers are added as such. +(defmacro org-no-read-only (&rest body) + "Inhibit read-only for BODY." + `(let ((inhibit-read-only t)) ,@body)) -If NLAST is a number, only the NLAST fields will actually be summed." - (interactive) - (save-excursion - (let (col (timecnt 0) diff h m s org-table-clip) - (cond - ((and beg end)) ; beg and end given explicitly - ((org-region-active-p) - (setq beg (region-beginning) end (region-end))) - (t - (setq col (org-table-current-column)) - (goto-char (org-table-begin)) - (unless (re-search-forward "^[ \t]*|[^-]" nil t) - (error "No table data")) - (org-table-goto-column col) -;not needed? (skip-chars-backward "^|") - (setq beg (point)) - (goto-char (org-table-end)) - (unless (re-search-backward "^[ \t]*|[^-]" nil t) - (error "No table data")) - (org-table-goto-column col) -;not needed? (skip-chars-forward "^|") - (setq end (point)))) - (let* ((items (apply 'append (org-table-copy-region beg end))) - (items1 (cond ((not nlast) items) - ((>= nlast (length items)) items) - (t (setq items (reverse items)) - (setcdr (nthcdr (1- nlast) items) nil) - (nreverse items)))) - (numbers (delq nil (mapcar 'org-table-get-number-for-summing - items1))) - (res (apply '+ numbers)) - (sres (if (= timecnt 0) - (format "%g" res) - (setq diff (* 3600 res) - h (floor (/ diff 3600)) diff (mod diff 3600) - m (floor (/ diff 60)) diff (mod diff 60) - s diff) - (format "%d:%02d:%02d" h m s)))) - (kill-new sres) - (if (interactive-p) - (message "%s" - (substitute-command-keys - (format "Sum of %d items: %-20s (\\[yank] will insert result into buffer)" - (length numbers) sres)))) - sres)))) +(defun org-check-for-org-mode () + "Make sure current buffer is in org-mode. Error if not." + (or (org-mode-p) + (error "Cannot execute org-mode agenda command on buffer in %s." + major-mode))) -(defun org-table-get-number-for-summing (s) - (let (n) - (if (string-match "^ *|? *" s) - (setq s (replace-match "" nil nil s))) - (if (string-match " *|? *$" s) - (setq s (replace-match "" nil nil s))) - (setq n (string-to-number s)) - (cond - ((and (string-match "0" s) - (string-match "\\`[-+ \t0.edED]+\\'" s)) 0) - ((string-match "\\`[ \t]+\\'" s) nil) - ((string-match "\\`\\([0-9]+\\):\\([0-9]+\\)\\(:\\([0-9]+\\)\\)?\\'" s) - (let ((h (string-to-number (or (match-string 1 s) "0"))) - (m (string-to-number (or (match-string 2 s) "0"))) - (s (string-to-number (or (match-string 4 s) "0")))) - (if (boundp 'timecnt) (setq timecnt (1+ timecnt))) - (* 1.0 (+ h (/ m 60.0) (/ s 3600.0))))) - ((equal n 0) nil) - (t n)))) +(defun org-fit-agenda-window () + "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)))) -(defun org-table-get-vertical-vector (desc &optional tbeg col) - "Get a calc vector from a column, accorting to descriptor DESC. -Optional arguments TBEG and COL can give the beginning of the table and -the current column, to avoid unnecessary parsing." - (save-excursion - (or tbeg (setq tbeg (org-table-begin))) - (or col (setq col (org-table-current-column))) - (let (beg end nn n n1 n2 l (thisline (org-current-line)) hline-list) - (cond - ((string-match "\\(I+\\)\\(-\\(I+\\)\\)?" desc) - (setq n1 (- (match-end 1) (match-beginning 1))) - (if (match-beginning 3) - (setq n2 (- (match-end 2) (match-beginning 3)))) - (setq n (if n2 (max n1 n2) n1)) - (setq n1 (if n2 (min n1 n2))) - (setq nn n) - (while (and (> nn 0) - (re-search-backward org-table-hline-regexp tbeg t)) - (push (org-current-line) hline-list) - (setq nn (1- nn))) - (setq hline-list (nreverse hline-list)) - (goto-line (nth (1- n) hline-list)) - (when (re-search-forward org-table-dataline-regexp) - (org-table-goto-column col) - (setq beg (point))) - (goto-line (if n1 (nth (1- n1) hline-list) thisline)) - (when (re-search-backward org-table-dataline-regexp) - (org-table-goto-column col) - (setq end (point))) - (setq l (apply 'append (org-table-copy-region beg end))) - (concat "[" (mapconcat (lambda (x) (setq x (org-trim x)) - (if (equal x "") "0" x)) - l ",") "]")) - ((string-match "\\([0-9]+\\)-\\([0-9]+\\)" desc) - (setq n1 (string-to-number (match-string 1 desc)) - n2 (string-to-number (match-string 2 desc))) - (beginning-of-line 1) - (save-excursion - (when (re-search-backward org-table-dataline-regexp tbeg t n1) - (org-table-goto-column col) - (setq beg (point)))) - (when (re-search-backward org-table-dataline-regexp tbeg t n2) - (org-table-goto-column col) - (setq end (point))) - (setq l (apply 'append (org-table-copy-region beg end))) - (concat "[" (mapconcat - (lambda (x) (setq x (org-trim x)) - (if (equal x "") "0" x)) - l ",") "]")) - ((string-match "\\([0-9]+\\)" desc) - (beginning-of-line 1) - (when (re-search-backward org-table-dataline-regexp tbeg t - (string-to-number (match-string 0 desc))) - (org-table-goto-column col) - (org-trim (org-table-get-field)))))))) +;;; Agenda file list -(defvar org-table-formula-history nil) +(defun org-agenda-files (&optional unrestricted) + "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'")))) -(defvar org-table-column-names nil - "Alist with column names, derived from the `!' line.") -(defvar org-table-column-name-regexp nil - "Regular expression matching the current column names.") -(defvar org-table-local-parameters nil - "Alist with parameter names, derived from the `$' line.") -(defvar org-table-named-field-locations nil - "Alist with locations of named fields.") +(defun org-edit-agenda-file-list () + "Edit the list of agenda files. +Depending on setup, this either uses customize to edit the variable +`org-agenda-files', or it visits the file that is holding the list. In the +latter case, the buffer is set up in a way that saving it automatically kills +the buffer and restores the previous window configuration." + (interactive) + (if (stringp org-agenda-files) + (let ((cw (current-window-configuration))) + (find-file org-agenda-files) + (org-set-local 'org-window-configuration cw) + (org-add-hook 'after-save-hook + (lambda () + (set-window-configuration + (prog1 org-window-configuration + (kill-buffer (current-buffer)))) + (org-install-agenda-files-menu) + (message "New agenda file list installed")) + nil 'local) + (message (substitute-command-keys + "Edit list and finish with \\[save-buffer]"))) + (customize-variable 'org-agenda-files))) -(defun org-table-get-formula (&optional equation named) - "Read a formula from the minibuffer, offer stored formula as default." - (let* ((name (car (rassoc (list (org-current-line) - (org-table-current-column)) - org-table-named-field-locations))) - (scol (if named - (if name name - (error "Not in a named field")) - (int-to-string (org-table-current-column)))) - (dummy (and name (not named) - (not (y-or-n-p "Replace named-field formula with column equation? " )) - (error "Abort"))) - (org-table-may-need-update nil) - (stored-list (org-table-get-stored-formulas)) - (stored (cdr (assoc scol stored-list))) - (eq (cond - ((and stored equation (string-match "^ *=? *$" equation)) - stored) - ((stringp equation) - equation) - (t (read-string - (format "%s formula $%s=" (if named "Field" "Column") scol) - (or stored "") 'org-table-formula-history - ;stored - )))) - mustsave) - (when (not (string-match "\\S-" eq)) - ;; remove formula - (setq stored-list (delq (assoc scol stored-list) stored-list)) - (org-table-store-formulas stored-list) - (error "Formula removed")) - (if (string-match "^ *=?" eq) (setq eq (replace-match "" t t eq))) - (if (string-match " *$" eq) (setq eq (replace-match "" t t eq))) - (if (and name (not named)) - ;; We set the column equation, delete the named one. - (setq stored-list (delq (assoc name stored-list) stored-list) - mustsave t)) - (if stored - (setcdr (assoc scol stored-list) eq) - (setq stored-list (cons (cons scol eq) stored-list))) - (if (or mustsave (not (equal stored eq))) - (org-table-store-formulas stored-list)) - eq)) +(defun org-store-new-agenda-file-list (list) + "Set new value for the agenda file list and save it correcly." + (if (stringp org-agenda-files) + (let ((f org-agenda-files) b) + (while (setq b (find-buffer-visiting f)) (kill-buffer b)) + (with-temp-file f + (insert (mapconcat 'identity list "\n") "\n"))) + (let ((org-mode-hook nil) (default-major-mode 'fundamental-mode)) + (setq org-agenda-files list) + (customize-save-variable 'org-agenda-files org-agenda-files)))) -(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))))) - (save-excursion - (goto-char (org-table-end)) - (if (looking-at "\\([ \t]*\n\\)*#\\+TBLFM:.*\n?") - (delete-region (point) (match-end 0))) - (insert "#+TBLFM: " - (mapconcat (lambda (x) - (concat "$" (car x) "=" (cdr x))) - alist "::") - "\n"))) +(defun org-read-agenda-file-list () + "Read the list of agenda files from a file." + (when (stringp org-agenda-files) + (with-temp-buffer + (insert-file-contents org-agenda-files) + (org-split-string (buffer-string) "[ \t\r\n]*?[\r\n][ \t\r\n]*")))) -(defun org-table-get-stored-formulas () - "Return an alist with the stored formulas directly after current table." - (interactive) - (let (scol eq eq-alist strings string seen) - (save-excursion - (goto-char (org-table-end)) - (when (looking-at "\\([ \t]*\n\\)*#\\+TBLFM: *\\(.*\\)") - (setq strings (org-split-string (match-string 2) " *:: *")) - (while (setq string (pop strings)) - (when (string-match "\\$\\([a-zA-Z0-9]+\\) *= *\\(.*[^ \t]\\)" string) - (setq scol (match-string 1 string) - eq (match-string 2 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) - (push scol seen)))))) - (nreverse eq-alist))) -(defun org-table-modify-formulas (action &rest columns) - "Modify the formulas stored below the current table. -ACTION can be `remove', `insert', `swap'. For `swap', two column numbers are -expected, for the other actions only a single column number is needed." - (let ((list (org-table-get-stored-formulas)) - (nmax (length (org-split-string - (buffer-substring (point-at-bol) (point-at-eol)) - "|"))) - col col1 col2 scol si sc1 sc2) - (cond - ((null list)) ; No action needed if there are no stored formulas - ((eq action 'remove) - (setq col (car columns) - scol (int-to-string col)) - (org-table-replace-in-formulas list scol "INVALID") - (if (assoc scol list) (setq list (delq (assoc scol list) list))) - (loop for i from (1+ col) upto nmax by 1 do - (setq si (int-to-string i)) - (org-table-replace-in-formulas list si (int-to-string (1- i))) - (if (assoc si list) (setcar (assoc si list) - (int-to-string (1- i)))))) - ((eq action 'insert) - (setq col (car columns)) - (loop for i from nmax downto col by 1 do - (setq si (int-to-string i)) - (org-table-replace-in-formulas list si (int-to-string (1+ i))) - (if (assoc si list) (setcar (assoc si list) - (int-to-string (1+ i)))))) - ((eq action 'swap) - (setq col1 (car columns) col2 (nth 1 columns) - sc1 (int-to-string col1) sc2 (int-to-string col2)) - ;; Hopefully, ZqZtZ will never be a name in a table - (org-table-replace-in-formulas list sc1 "ZqZtZ") - (org-table-replace-in-formulas list sc2 sc1) - (org-table-replace-in-formulas list "ZqZtZ" sc2) - (if (assoc sc1 list) (setcar (assoc sc1 list) "ZqZtZ")) - (if (assoc sc2 list) (setcar (assoc sc2 list) sc1)) - (if (assoc "ZqZtZ" list) (setcar (assoc "ZqZtZ" list) sc2))) - (t (error "Invalid action in `org-table-modify-formulas'"))) - (if list (org-table-store-formulas list)))) - -(defun org-table-replace-in-formulas (list s1 s2) - (let (elt re s) - (setq s1 (concat "$" (if (integerp s1) (int-to-string s1) s1)) - s2 (concat "$" (if (integerp s2) (int-to-string s2) s2)) - re (concat (regexp-quote s1) "\\>")) - (while (setq elt (pop list)) - (setq s (cdr elt)) - (while (string-match re s) - (setq s (replace-match s2 t t s))) - (setcdr elt s)))) +;;;###autoload +(defun org-cycle-agenda-files () + "Cycle through the files in `org-agenda-files'. +If the current buffer visits an agenda file, find the next one in the list. +If the current buffer does not, find the first agenda file." + (interactive) + (let* ((fs (org-agenda-files t)) + (files (append fs (list (car fs)))) + (tcf (if buffer-file-name (file-truename buffer-file-name))) + file) + (unless files (error "No agenda files")) + (catch 'exit + (while (setq file (pop files)) + (if (equal (file-truename file) tcf) + (when (car files) + (find-file (car files)) + (throw 'exit t)))) + (find-file (car fs))) + (if (buffer-base-buffer) (switch-to-buffer (buffer-base-buffer))))) -(defun org-table-get-specials () - "Get the column names and local parameters for this table." - (save-excursion - (let ((beg (org-table-begin)) (end (org-table-end)) - names name fields fields1 field cnt c v line col) - (setq org-table-column-names nil - org-table-local-parameters nil - org-table-named-field-locations nil) - (goto-char beg) - (when (re-search-forward "^[ \t]*| *! *\\(|.*\\)" end t) - (setq names (org-split-string (match-string 1) " *| *") - cnt 1) - (while (setq name (pop names)) - (setq cnt (1+ cnt)) - (if (string-match "^[a-zA-Z][a-zA-Z0-9]*$" name) - (push (cons name (int-to-string cnt)) org-table-column-names)))) - (setq org-table-column-names (nreverse org-table-column-names)) - (setq org-table-column-name-regexp - (concat "\\$\\(" (mapconcat 'car org-table-column-names "\\|") "\\)\\>")) - (goto-char beg) - (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) - (push (cons (match-string 1 field) (match-string 2 field)) - org-table-local-parameters)))) - (goto-char beg) - (while (re-search-forward "^[ \t]*| *\\([_^]\\) *\\(|.*\\)" end t) - (setq c (match-string 1) - fields (org-split-string (match-string 2) " *| *")) - (save-excursion - (beginning-of-line (if (equal c "_") 2 0)) - (setq line (org-current-line) col 1) - (and (looking-at "^[ \t]*|[^|]*\\(|.*\\)") - (setq fields1 (org-split-string (match-string 1) " *| *")))) - (while (and fields1 (setq field (pop fields))) - (setq v (pop fields1) col (1+ col)) - (when (and (stringp field) (stringp v) - (string-match "^[a-zA-Z][a-zA-Z0-9]*$" field)) - (push (cons field v) org-table-local-parameters) - (push (list field line col) org-table-named-field-locations))))))) +(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-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-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) + (cons (file-truename x) x)) + (org-agenda-files t))) + (ctf (file-truename buffer-file-name)) + x had) + (setq x (assoc ctf file-alist) had x) -(defun org-table-maybe-eval-formula () - "Check if the current field starts with \"=\" or \":=\". -If yes, store the formula and apply it." - ;; We already know we are in a table. Get field will only return a formula - ;; when appropriate. It might return a separator line, but no problem. - (when org-table-formula-evaluate-inline - (let* ((field (org-trim (or (org-table-get-field) ""))) - named eq) - (when (string-match "^:?=\\(.*\\)" field) - (setq named (equal (string-to-char field) ?:) - eq (match-string 1 field)) - (if (fboundp 'calc-eval) - (org-table-eval-formula (if named '(4) nil) eq)))))) + (if (not x) (setq x (cons ctf (abbreviate-file-name buffer-file-name)))) + (if to-end + (setq file-alist (append (delq x file-alist) (list x))) + (setq file-alist (cons x (delq x file-alist)))) + (org-store-new-agenda-file-list (mapcar 'cdr file-alist)) + (org-install-agenda-files-menu) + (message "File %s to %s of agenda file list" + (if had "moved" "added") (if to-end "end" "front")))) -(defvar org-recalc-commands nil - "List of commands triggering the recalculation of a line. -Will be filled automatically during use.") +(defun org-remove-file (&optional file) + "Remove current file from the list of files in variable `org-agenda-files'. +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)) + (true-file (file-truename file)) + (afile (abbreviate-file-name file)) + (files (delq nil (mapcar + (lambda (x) + (if (equal true-file + (file-truename x)) + nil x)) + (org-agenda-files t))))) + (if (not (= (length files) (length (org-agenda-files t)))) + (progn + (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)))) -(defvar org-recalc-marks - '((" " . "Unmarked: no special line, no automatic recalculation") - ("#" . "Automatically recalculate this line upon TAB, RET, and C-c C-c in the line") - ("*" . "Recalculate only when entire table is recalculated with `C-u C-c *'") - ("!" . "Column name definition line. Reference in formula as $name.") - ("$" . "Parameter definition line name=value. Reference in formula as $name.") - ("_" . "Names for values in row below this one.") - ("^" . "Names for values in row above this one."))) +(defun org-file-menu-entry (file) + (vector file (list 'find-file file) t)) -(defun org-table-rotate-recalc-marks (&optional newchar) - "Rotate the recalculation mark in the first column. -If in any row, the first field is not consistent with a mark, -insert a new column for the markers. -When there is an active region, change all the lines in the region, -after prompting for the marking character. -After each change, a message will be displayed indicating the meaning -of the new mark." - (interactive) - (unless (org-at-table-p) (error "Not at a table")) - (let* ((marks (append (mapcar 'car org-recalc-marks) '(" "))) - (beg (org-table-begin)) - (end (org-table-end)) - (l (org-current-line)) - (l1 (if (org-region-active-p) (org-current-line (region-beginning)))) - (l2 (if (org-region-active-p) (org-current-line (region-end)))) - (have-col - (save-excursion - (goto-char beg) - (not (re-search-forward "^[ \t]*|[^-|][^|]*[^#!$*_^| \t][^|]*|" end t)))) - (col (org-table-current-column)) - (forcenew (car (assoc newchar org-recalc-marks))) - epos new) - (when l1 - (message "Change region to what mark? Type # * ! $ or SPC: ") - (setq newchar (char-to-string (read-char-exclusive)) - forcenew (car (assoc newchar org-recalc-marks)))) - (if (and newchar (not forcenew)) - (error "Invalid NEWCHAR `%s' in `org-table-rotate-recalc-marks'" - newchar)) - (if l1 (goto-line l1)) - (save-excursion - (beginning-of-line 1) - (unless (looking-at org-table-dataline-regexp) - (error "Not at a table data line"))) - (unless have-col - (org-table-goto-column 1) - (org-table-insert-column) - (org-table-goto-column (1+ col))) - (setq epos (point-at-eol)) - (save-excursion - (beginning-of-line 1) - (org-table-get-field - 1 (if (looking-at "^[ \t]*| *\\([#!$*^_ ]\\) *|") - (concat " " - (setq new (or forcenew - (cadr (member (match-string 1) marks)))) - " ") - " # "))) - (if (and l1 l2) - (progn - (goto-line l1) - (while (progn (beginning-of-line 2) (not (= (org-current-line) l2))) - (and (looking-at org-table-dataline-regexp) - (org-table-get-field 1 (concat " " new " ")))) - (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)))))) +(defun org-check-agenda-file (file) + "Make sure FILE exists. If not, ask user what to do." + (when (not (file-exists-p file)) + (message "non-existent file %s. [R]emove from list or [A]bort?" + (abbreviate-file-name file)) + (let ((r (downcase (read-char-exclusive)))) + (cond + ((equal r ?r) + (org-remove-file file) + (throw 'nextfile t)) + (t (error "Abort")))))) -(defun org-table-maybe-recalculate-line () - "Recompute the current line if marked for it, and if we haven't just done it." - (interactive) - (and org-table-allow-automatic-line-recalculation - (not (and (memq last-command org-recalc-commands) - (equal org-last-recalc-line (org-current-line)))) - (save-excursion (beginning-of-line 1) - (looking-at org-table-auto-recalculate-regexp)) - (fboundp 'calc-eval) - (org-table-recalculate) t)) +;;; Agenda prepare and finalize -(defvar org-table-formula-debug nil - "Non-nil means, debug table formulas. -When nil, simply write \"#ERROR\" in corrupted fields.") +(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 () + (if org-agenda-multi + (progn + (setq buffer-read-only nil) + (goto-char (point-max)) + (unless (= (point) 1) + (insert "\n" (make-string (window-width) ?=) "\n")) + (narrow-to-region (point) (point-max))) + (org-agenda-maybe-reset-markers 'force) + (org-prepare-agenda-buffers (org-agenda-files)) + (let* ((abuf (get-buffer-create org-agenda-buffer-name)) + (awin (get-buffer-window abuf))) + (cond + ((equal (current-buffer) abuf) nil) + (awin (select-window awin)) + ((not (setq org-pre-agenda-window-conf (current-window-configuration)))) + ((equal org-agenda-window-setup 'current-window) + (switch-to-buffer abuf)) + ((equal org-agenda-window-setup 'other-window) + (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)))) + (setq buffer-read-only nil) + (erase-buffer) + (org-agenda-mode)) + (setq buffer-read-only nil)) -(defvar modes) -(defsubst org-set-calc-mode (var &optional value) - (if (stringp var) - (setq var (assoc var '(("D" calc-angle-mode deg) - ("R" calc-angle-mode rad) - ("F" calc-prefer-frac t) - ("S" calc-symbolic-mode t))) - value (nth 2 var) var (nth 1 var))) - (if (memq var modes) - (setcar (cdr (memq var modes)) value) - (cons var (cons value modes))) - modes) +(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)) + (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)))) -(defun org-table-eval-formula (&optional arg equation - suppress-align suppress-const - suppress-store) - "Replace the table field value at the cursor by the result of a calculation. +(defun org-prepare-agenda-buffers (files) + "Create buffers for all agenda files, protect archived trees and comments." + (interactive) + (let ((pa '(:org-archived t)) + (pc '(:org-comment t)) + (pall '(:org-archived t :org-comment 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)) + (widen) + (setq bmp (buffer-modified-p)) + (save-excursion + (remove-text-properties (point-min) (point-max) pall) + (when org-agenda-skip-archived-trees + (goto-char (point-min)) + (while (re-search-forward rea nil t) + (if (org-on-heading-p) + (add-text-properties (point-at-bol) (org-end-of-subtree t) pa)))) + (goto-char (point-min)) + (setq re (concat "^\\*+ +" org-comment-string "\\>")) + (while (re-search-forward re nil t) + (add-text-properties + (match-beginning 0) (org-end-of-subtree t) pc))) + (set-buffer-modified-p bmp)))))) + +(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. +Otherwise, the function must return a position from where the search +should be continued. +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.") -This function makes use of Dave Gillespie's Calc package, in my view the -most exciting program ever written for GNU Emacs. So you need to have Calc -installed in order to use this function. +(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) + (and org-agenda-skip-archived-trees + (get-text-property p :org-archived) + (org-end-of-subtree t) + (throw :skip t)) + (and (get-text-property p :org-comment) + (org-end-of-subtree t) + (throw :skip t)) + (if (equal (char-after p) ?#) (throw :skip t)) + (when (and (functionp org-agenda-skip-function) + (setq to (save-excursion + (save-match-data + (funcall org-agenda-skip-function))))) + (goto-char to) + (throw :skip t)))) -In a table, this command replaces the value in the current field with the -result of a formula. It also installs the formula as the \"current\" column -formula, by storing it in a special line below the table. When called -with a `C-u' prefix, the current field must ba a named field, and the -formula is installed as valid in only this specific field. +(defvar org-agenda-markers nil + "List of all currently active markers created by `org-agenda'.") +(defvar org-agenda-last-marker-time (time-to-seconds (current-time)) + "Creation time of the last agenda marker.") -When called, the command first prompts for a formula, which is read in -the minibuffer. Previously entered formulas are available through the -history list, and the last used formula is offered as a default. -These stored formulas are adapted correctly when moving, inserting, or -deleting columns with the corresponding commands. +(defun org-agenda-new-marker (&optional pos) + "Return a new agenda marker. +Org-mode keeps a list of these markers and resets them when they are +no longer in use." + (let ((m (copy-marker (or pos (point))))) + (setq org-agenda-last-marker-time (time-to-seconds (current-time))) + (push m org-agenda-markers) + m)) -The formula can be any algebraic expression understood by the Calc package. -For details, see the Org-mode manual. +(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)))) -This function can also be called from Lisp programs and offers -additional arguments: EQUATION can be the formula to apply. If this -argument is given, the user will not be prompted. SUPPRESS-ALIGN is -used to speed-up recursive calls by by-passing unnecessary aligns. -SUPPRESS-CONST suppresses the interpretation of constants in the -formula, assuming that this has been done already outside the function. -SUPPRESS-STORE means the formula should not be stored, either because -it is already stored, or because it is a modified equation that should -not overwrite the stored one." - (interactive "P") - (require 'calc) - (org-table-check-inside-data-field) - (org-table-get-specials) - (let* (fields - (ndown (if (integerp arg) arg 1)) - (org-table-automatic-realign nil) - (case-fold-search nil) - (down (> ndown 1)) - (formula (if (and equation suppress-store) - equation - (org-table-get-formula equation (equal arg '(4))))) - (n0 (org-table-current-column)) - (modes (copy-sequence org-calc-default-modes)) - n form fmt x ev orig c lispp) - ;; 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) - (let ((tmp (org-split-string formula ";"))) - (setq formula (car tmp) - fmt (concat (cdr (assoc "%" org-table-local-parameters)) - (nth 1 tmp))) - (while (string-match "\\([pnfse]\\)\\(-?[0-9]+\\)" fmt) - (setq c (string-to-char (match-string 1 fmt)) - n (string-to-number (match-string 2 fmt))) - (if (= c ?p) - (setq modes (org-set-calc-mode 'calc-internal-prec n)) - (setq modes (org-set-calc-mode - 'calc-float-format - (list (cdr (assoc c '((?n . float) (?f . fix) - (?s . sci) (?e . eng)))) - n)))) - (setq fmt (replace-match "" t t fmt))) - (while (string-match "[DRFS]" fmt) - (setq modes (org-set-calc-mode (match-string 0 fmt))) - (setq fmt (replace-match "" t t fmt))) - (unless (string-match "\\S-" fmt) - (setq fmt nil)))) - (if (and (not suppress-const) org-table-formula-use-constants) - (setq formula (org-table-formula-substitute-names formula))) - (setq orig (or (get-text-property 1 :orig-formula formula) "?")) - (while (> ndown 0) - (setq fields (org-split-string - (buffer-substring - (point-at-bol) (point-at-eol)) " *| *")) - (if org-table-formula-numbers-only - (setq fields (mapcar - (lambda (x) (number-to-string (string-to-number x))) - fields))) - (setq ndown (1- ndown)) - (setq form (copy-sequence formula) - lispp (equal (substring form 0 2) "'(")) - ;; 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)) - (unless x (error "Invalid field specifier \"%s\"" - (match-string 0 form))) - (if (equal x "") (setq x "0")) - (setq form (replace-match - (if lispp x (concat "(" x ")")) - t t form))) - ;; Insert ranges in current column - (while (string-match "\\&[-I0-9]+" form) - (setq form (replace-match - (save-match-data - (org-table-get-vertical-vector (match-string 0 form) - nil n0)) - t t form))) - (if lispp - (setq ev (eval (eval (read form))) - ev (if (numberp ev) (number-to-string ev) ev)) - (setq ev (calc-eval (cons form modes) - (if org-table-formula-numbers-only 'num)))) +(defvar org-agenda-new-buffers nil + "Buffers created to visit agenda files.") - (when org-table-formula-debug - (with-output-to-temp-buffer "*Help*" - (princ (format "Substitution history of formula -Orig: %s -$xyz-> %s -$1-> %s\n" orig formula form)) - (if (listp ev) - (princ (format " %s^\nError: %s" - (make-string (car ev) ?\-) (nth 1 ev))) - (princ (format "Result: %s\nFormat: %s\nFinal: %s" - ev (or fmt "NONE") - (if fmt (format fmt (string-to-number ev)) ev))))) - (shrink-window-if-larger-than-buffer (get-buffer-window "*Help*")) - (unless (and (interactive-p) (not ndown)) - (unless (let (inhibit-redisplay) - (y-or-n-p "Debugging Formula. Continue to next? ")) - (org-table-align) - (error "Abort")) - (delete-window (get-buffer-window "*Help*")) - (message ""))) - (if (listp ev) (setq fmt nil ev "#ERROR")) - (org-table-justify-field-maybe - (if fmt (format fmt (string-to-number ev)) ev)) - (if (and down (> ndown 0) (looking-at ".*\n[ \t]*|[^-]")) - (call-interactively 'org-return) - (setq ndown 0))) - (and down (org-table-maybe-recalculate-line)) - (or suppress-align (and org-table-may-need-update - (org-table-align))))) +(defun org-get-agenda-file-buffer (file) + "Get a buffer visiting FILE. If the buffer needs to be created, add +it to the list of buffers which might be released later." + (let ((buf (org-find-base-buffer-visiting file))) + (if buf + buf ; just return it + ;; Make a new buffer and remember it + (setq buf (find-file-noselect file)) + (if buf (push buf org-agenda-new-buffers)) + buf))) -(defun org-table-recalculate (&optional all noalign) - "Recalculate the current table line by applying all stored formulas. -With prefix arg ALL, do this for all lines in the table." - (interactive "P") - (or (memq this-command org-recalc-commands) - (setq org-recalc-commands (cons this-command org-recalc-commands))) - (unless (org-at-table-p) (error "Not at a table")) - (org-table-get-specials) - (let* ((eqlist (sort (org-table-get-stored-formulas) - (lambda (a b) (string< (car a) (car b))))) - (inhibit-redisplay t) - (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) - ;; Insert constants in all formulas - (setq eqlist - (mapcar (lambda (x) - (setcdr x (org-table-formula-substitute-names (cdr x))) - x) - eqlist)) - ;; Split the equation list - (while (setq eq (pop eqlist)) - (if (<= (string-to-char (car eq)) ?9) - (push eq eqlnum) - (push eq eqlname))) - (setq eqlnum (nreverse eqlnum) eqlname (nreverse eqlname)) - (if all - (progn - (setq end (move-marker (make-marker) (1+ (org-table-end)))) - (goto-char (setq beg (org-table-begin))) - (if (re-search-forward org-table-calculate-mark-regexp end t) - ;; This is a table with marked lines, only compute selected lines - (setq line-re org-table-recalculate-regexp) - ;; Move forward to the first non-header line - (if (and (re-search-forward org-table-dataline-regexp end t) - (re-search-forward org-table-hline-regexp end t) - (re-search-forward org-table-dataline-regexp end t)) - (setq beg (match-beginning 0)) - nil))) ;; just leave beg where it is - (setq beg (point-at-bol) - end (move-marker (make-marker) (1+ (point-at-eol))))) - (goto-char beg) - (and all (message "Re-applying formulas to full table...")) - (while (re-search-forward line-re end t) - (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)))) - (setq org-last-recalc-line (org-current-line)) - (setq eql eqlnum) - (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)))) - (goto-line thisline) - (org-table-goto-column thiscol) - (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 names fields - (while (setq eq (pop eqlname)) - (setq name (car eq) - a (assoc name org-table-named-field-locations)) - (when a - (message "Re-applying formula to named 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))) - ;; back to initial position - (goto-line thisline) - (org-table-goto-column thiscol) - (or noalign (and org-table-may-need-update (org-table-align)) - (and all (message "Re-applying formulas...done"))))) +(defun org-release-buffers (blist) + "Release all buffers in list, asking the user for confirmation when needed. +When a buffer is unmodified, it is just killed. When modified, it is saved +\(if the user agrees) and then killed." + (let (buf file) + (while (setq buf (pop blist)) + (setq file (buffer-file-name buf)) + (when (and (buffer-modified-p buf) + file + (y-or-n-p (format "Save file %s? " file))) + (with-current-buffer buf (save-buffer))) + (kill-buffer buf)))) -(defun org-table-formula-substitute-names (f) - "Replace $const with values in string F." - (let ((start 0) a n1 n2 nn1 nn2 s (f1 f)) - ;; First, check for column names - (while (setq start (string-match org-table-column-name-regexp f start)) - (setq start (1+ start)) - (setq a (assoc (match-string 1 f) org-table-column-names)) - (setq f (replace-match (concat "$" (cdr a)) t t f))) - ;; Expand ranges to vectors - (while (string-match "\\$\\([0-9]+\\)\\.\\.\\.?\\$\\([0-9]+\\)" f) - (setq n1 (string-to-number (match-string 1 f)) - n2 (string-to-number (match-string 2 f)) - nn1 (1+ (min n1 n2)) nn2 (max n1 n2) - s (concat "[($" (number-to-string (1- nn1)) ")")) - (loop for i from nn1 upto nn2 do - (setq s (concat s ",($" (int-to-string i) ")"))) - (setq s (concat s "]")) - (if (< n2 n1) (setq s (concat "rev(" s ")"))) - (setq f (replace-match s t t f))) - ;; Parameters and constants - (setq start 0) - (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)))) - (if org-table-formula-debug - (put-text-property 0 (length f) :orig-formula f1 f)) - f)) - -(defun org-table-get-constant (const) - "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)) - (and (fboundp 'constants-get) (constants-get const)) - "#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-variable) - -(defvar org-pos) - -(defun org-table-edit-formulas () - "Edit the formulas of the current table in a separate buffer." - (interactive) - (unless (org-at-table-p) - (error "Not at a table")) - (org-table-get-specials) - (let ((eql (org-table-get-stored-formulas)) - (pos (move-marker (make-marker) (point))) - (wc (current-window-configuration)) - entry loc s) - (switch-to-buffer-other-window "*Edit Formulas*") - (erase-buffer) - (fundamental-mode) - (org-set-local 'org-pos pos) - (org-set-local 'org-window-configuration wc) - (use-local-map org-edit-formulas-map) - (setq s "# Edit formulas and finish with `C-c C-c'. -# Use `C-u C-c C-c' to also appy them immediately to the entire table. -# Use `C-c ?' to get information about $name at point. -# To cancel editing, press `C-c C-q'.\n") - (put-text-property 0 (length s) 'face 'font-lock-comment-face s) - (insert s) - (while (setq entry (pop eql)) - (when (setq loc (assoc (car entry) org-table-named-field-locations)) - (setq s (format "# Named formula, referring to column %d in line %d\n" - (nth 2 loc) (nth 1 loc))) - (put-text-property 0 (length s) 'face 'font-lock-comment-face s) - (insert s)) - (setq s (concat "$" (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'."))) - -(defun org-show-variable () - "Show the location/value of the $ expression at point." - (interactive) - (let (var (pos org-pos) (win (selected-window)) e) +(defvar org-category-table nil) +(defun org-get-category-table () + "Get the table of categories and positions in current buffer." + (let (tbl) (save-excursion - (or (looking-at "\\$") (skip-chars-backward "$a-zA-Z0-9")) - (if (looking-at "\\$\\([a-zA-Z0-9]+\\)") - (setq var (match-string 1)) - (error "No variable at point"))) - (cond - ((setq e (assoc var org-table-named-field-locations)) - (switch-to-buffer-other-window (marker-buffer pos)) - (goto-line (nth 1 e)) - (org-table-goto-column (nth 2 e)) - (select-window win) - (message "Named field, column %d of line %d" (nth 2 e) (nth 1 e))) - ((setq e (assoc var org-table-column-names)) - (switch-to-buffer-other-window (marker-buffer pos)) - (goto-char pos) - (goto-char (org-table-begin)) - (if (re-search-forward (concat "^[ \t]*| *! *.*?| *\\(" var "\\) *|") - (org-table-end) t) - (progn - (goto-char (match-beginning 1)) - (message "Named column (column %s)" (cdr e))) - (error "Column name not found")) - (select-window win)) - ((string-match "^[0-9]$" var) - ;; column number - (switch-to-buffer-other-window (marker-buffer pos)) - (goto-char pos) - (goto-char (org-table-begin)) - (recenter 1) - (if (re-search-forward org-table-dataline-regexp - (org-table-end) t) - (progn - (goto-char (match-beginning 0)) - (org-table-goto-column (string-to-number var)) - (message "Column %s" var)) - (error "Column name not found")) - (select-window win)) - ((setq e (assoc var org-table-local-parameters)) - (switch-to-buffer-other-window (marker-buffer pos)) - (goto-char pos) - (goto-char (org-table-begin)) - (if (re-search-forward (concat "^[ \t]*| *\\$ *.*?| *\\(" var "=\\)") nil t) - (progn - (goto-char (match-beginning 1)) - (message "Local parameter.")) - (error "Parameter not found")) - (select-window win)) - (t + (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 - ((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)) - (t (error "Undefined name $%s" var))))))) + ((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)))))) +;;; Agenda timeline -(defun org-finish-edit-formulas (&optional arg) - "Parse the buffer for formula definitions and install them. -With prefix ARG, apply the new formulas to the table." +(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 +\\[universal-argument] prefix, all unfinished TODO items will also be shown, +under the current date. +If the buffer contains an active region, only check the region for +dates." (interactive "P") - (let ((pos org-pos) eql) + (require 'calendar) + (org-compile-prefix-format 'timeline) + (org-set-sorting-strategy 'timeline) + (let* ((dopast t) + (dotodo include-all) + (doclosed org-agenda-show-log) + (entry buffer-file-name) + (date (calendar-current-date)) + (beg (if (org-region-active-p) (region-beginning) (point-min))) + (end (if (org-region-active-p) (region-end) (point-max))) + (day-numbers (org-get-all-dates beg end 'no-ranges + t doclosed ; always include today + org-timeline-show-empty-dates)) + (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-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) + (if doclosed (push :closed args)) + (push :timestamp 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)) + (if (listp d) (setq d (car d) emptyp t) (setq emptyp nil)) + (if (and (>= d today) + dopast + past) + (progn + (setq past nil) + (insert (make-string 79 ?-) "\n"))) + (setq date (calendar-gregorian-from-absolute d)) + (setq s (point)) + (setq rtn (and (not emptyp) + (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) + (put-text-property s (1- (point)) 'org-date-line t) + (if (equal d today) + (put-text-property s (1- (point)) 'org-today t)) + (and rtn (insert (org-finalize-agenda-entries rtn) "\n")) + (put-text-property s (1- (point)) 'day d))))) (goto-char (point-min)) - (while (re-search-forward "^\\$\\([a-zA-Z0-9]+\\) *= *\\(.*?\\) *$" nil t) - (push (cons (match-string 1) (match-string 2)) eql)) - (set-window-configuration org-window-configuration) - (select-window (get-buffer-window (marker-buffer pos))) - (goto-char pos) - (unless (org-at-table-p) - (error "Lost table position - cannot install formulae")) - (org-table-store-formulas eql) - (move-marker pos nil) - (kill-buffer "*Edit Formulas*") - (if arg - (org-table-recalculate 'all) - (message "New formulas installed - press C-u C-c C-c to apply.")))) - -(defun org-abort-edit-formulas () - "Abort editing formulas, without installing the changes." - (interactive) - (let ((pos org-pos)) - (set-window-configuration org-window-configuration) - (select-window (get-buffer-window (marker-buffer pos))) - (goto-char pos) - (message "Formula editing aborted without installing changes"))) - -;;; The orgtbl minor mode - -;; Define a minor mode which can be used in other modes in order to -;; integrate the org-mode table editor. - -;; This is really a hack, because the org-mode table editor uses several -;; keys which normally belong to the major mode, for example the TAB and -;; RET keys. Here is how it works: The minor mode defines all the keys -;; necessary to operate the table editor, but wraps the commands into a -;; function which tests if the cursor is currently inside a table. If that -;; is the case, the table editor command is executed. However, when any of -;; those keys is used outside a table, the 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 used by the table editor is -;; otherwise used as a prefix key. + (goto-char (or (text-property-any (point-min) (point-max) 'org-today t) + (point-min))) + (add-text-properties (point-min) (point-max) '(org-agenda-type timeline)) + (org-finalize-agenda) + (setq buffer-read-only t))) -;; 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-get-all-dates (beg end &optional no-ranges force-today inactive empty) + "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)) + dates dates1 date day day1 day2 ts1 ts2) + (if force-today + (setq dates (list (time-to-days (current-time))))) + (save-excursion + (goto-char beg) + (while (re-search-forward re end t) + (setq day (time-to-days (org-time-string-to-time + (substring (match-string 1) 0 10)))) + (or (memq day dates) (push day dates))) + (unless no-ranges + (goto-char beg) + (while (re-search-forward org-tr-regexp end t) + (setq ts1 (substring (match-string 1) 0 10) + ts2 (substring (match-string 2) 0 10) + day1 (time-to-days (org-time-string-to-time ts1)) + day2 (time-to-days (org-time-string-to-time ts2))) + (while (< (setq day1 (1+ day1)) day2) + (or (memq day1 dates) (push day1 dates))))) + (setq dates (sort dates '<)) + (when empty + (while (setq day (pop dates)) + (setq day2 (car dates)) + (push day dates1) + (when (and day2 empty) + (if (or (eq empty t) + (and (numberp empty) (<= (- day2 day) empty))) + (while (< (setq day (1+ day)) day2) + (push (list day) dates1)) + (push (cons :omitted (- day2 day)) dates1)))) + (setq dates (nreverse dates1))) + dates))) -;; The optimized version (see variable `orgtbl-optimized') takes over -;; all keys which are bound to `self-insert-command' in the *global map*. -;; Some modes bind other commands to simple characters, for example -;; AUCTeX binds the double quote to `Tex-insert-quote'. With orgtbl-mode -;; active, this binding is ignored inside tables and replaced with a -;; modified self-insert. +;;; Agenda Daily/Weekly -(defvar orgtbl-mode nil - "Variable controlling `orgtbl-mode', a minor mode enabling the `org-mode' -table editor in arbitrary modes.") -(make-variable-buffer-local 'orgtbl-mode) +(defvar org-agenda-overriding-arguments 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-include-all-loc nil) ; local variable -(defvar orgtbl-mode-map (make-keymap) - "Keymap for `orgtbl-mode'.") ;;;###autoload -(defun turn-on-orgtbl () - "Unconditionally turn on `orgtbl-mode'." - (orgtbl-mode 1)) +(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. +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'." + (interactive "P") + (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))) + (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)) + (thefiles (org-agenda-files)) + (files thefiles) + (today (time-to-days (current-time))) + (sd (or start-day today)) + (start (if (or (null org-agenda-start-on-weekday) + (< org-agenda-ndays 7)) + sd + (let* ((nt (calendar-day-of-week + (calendar-gregorian-from-absolute sd))) + (n1 org-agenda-start-on-weekday) + (d (- nt n1))) + (- sd (+ (if (< d 0) 7 0) d))))) + (day-numbers (list start)) + (inhibit-redisplay (not debug-on-error)) + s e rtn rtnall file date d start-pos end-pos todayp nd) + (setq org-agenda-redo-command + (list 'org-agenda-list (list 'quote include-all) start-day ndays)) + ;; Make the list of days + (setq ndays (or ndays org-agenda-ndays) + nd ndays) + (while (> ndays 1) + (push (1+ (car day-numbers)) day-numbers) + (setq ndays (1- ndays))) + (setq day-numbers (nreverse day-numbers)) + (org-prepare-agenda) + (org-set-local 'org-starting-day (car day-numbers)) + (org-set-local 'org-include-all-loc include-all) + (when (and (or include-all org-agenda-include-all-todo) + (member today day-numbers)) + (setq files thefiles + rtnall nil) + (while (setq file (pop files)) + (catch 'nextfile + (org-check-agenda-file file) + (setq date (calendar-gregorian-from-absolute today) + rtn (org-agenda-get-day-entries + file date :todo)) + (setq rtnall (append rtnall rtn)))) + (when rtnall + (insert "ALL CURRENTLY OPEN TODO ITEMS:\n") + (add-text-properties (point-min) (1- (point)) + (list 'face 'org-level-3)) + (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)) + (while (setq d (pop day-numbers)) + (setq date (calendar-gregorian-from-absolute d) + s (point)) + (if (or (setq todayp (= d today)) + (and (not start-pos) (= d sd))) + (setq start-pos (point)) + (if (and start-pos (not end-pos)) + (setq end-pos (point)))) + (setq files thefiles + rtnall nil) + (while (setq file (pop files)) + (catch 'nextfile + (org-check-agenda-file file) + (if org-agenda-show-log + (setq rtn (org-agenda-get-day-entries + file date + :deadline :scheduled :timestamp :closed)) + (setq rtn (org-agenda-get-day-entries + file date + :deadline :scheduled :timestamp))) + (setq rtnall (append rtnall rtn)))) + (if org-agenda-include-diary + (progn + (require 'diary-lib) + (setq rtn (org-get-entries-from-diary date)) + (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) + (put-text-property s (1- (point)) 'org-date-line t) + (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)))) + (goto-char (point-min)) + (org-fit-agenda-window) + (unless (and (pos-visible-in-window-p (point-min)) + (pos-visible-in-window-p (point-max))) + (goto-char (1- (point-max))) + (recenter -1) + (if (not (pos-visible-in-window-p (or start-pos 1))) + (progn + (goto-char (or start-pos 1)) + (recenter 1)))) + (goto-char (or start-pos 1)) + (add-text-properties (point-min) (point-max) '(org-agenda-type agenda)) + (org-finalize-agenda) + (setq buffer-read-only t) + (message ""))) + +;;; Agenda TODO list + +(defvar org-select-this-todo-keyword nil) +(defvar org-last-arg nil) ;;;###autoload -(defun orgtbl-mode (&optional arg) - "The `org-mode' table editor as a minor mode for use in other modes." +(defun org-todo-list (arg) + "Show all TODO entries from all agenda file in a single list. +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'." + (interactive "P") + (require 'calendar) + (org-compile-prefix-format 'todo) + (org-set-sorting-strategy 'todo) + (let* ((today (time-to-days (current-time))) + (date (calendar-gregorian-from-absolute today)) + (kwds org-todo-keywords) + (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)))) + 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))) + (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) + rtnall nil) + (while (setq file (pop files)) + (catch 'nextfile + (org-check-agenda-file file) + (setq rtn (org-agenda-get-day-entries file date :todo)) + (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") + (insert "Global list of TODO items of type: ") + (add-text-properties (point-min) (1- (point)) + (list 'face 'org-level-3)) + (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))) + (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 todo)) + (org-finalize-agenda) + (setq buffer-read-only t))) + +;;; Agenda tags match + +;;;###autoload +(defun org-tags-view (&optional todo-only match) + "Show all headlines for all `org-agenda-files' matching a TAGS criterion. +The prefix arg TODO-ONLY limits the search to TODO entries." + (interactive "P") + (org-compile-prefix-format 'tags) + (org-set-sorting-strategy 'tags) + (let* ((org-tags-match-list-sublevels + (if todo-only t org-tags-match-list-sublevels)) + (completion-ignore-case t) + rtn rtnall files file pos matcher + buffer) + (setq matcher (org-make-tags-matcher match) + match (car matcher) matcher (cdr matcher)) + (org-prepare-agenda) + (setq org-agenda-redo-command + (list 'org-tags-view (list 'quote todo-only) + (list 'if 'current-prefix-arg nil match))) + (setq files (org-agenda-files) + rtnall nil) + (while (setq file (pop files)) + (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, merror message to agenda + (setq rtn (list + (format "ORG-AGENDA-ERROR: No such org-file %s" file)) + rtnall (append rtnall rtn)) + (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 + (narrow-to-region org-agenda-restrict-begin + org-agenda-restrict-end) + (widen)) + (setq rtn (org-scan-tags 'agenda matcher todo-only)) + (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") + (insert "Headlines with TAGS match: ") + (add-text-properties (point-min) (1- (point)) + (list 'face 'org-level-3)) + (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))) + (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 tags)) + (org-finalize-agenda) + (setq buffer-read-only t))) + +;;; Agenda Finding stuck projects + +(defvar org-agenda-skip-regexp nil + "Regular expression used in skipping subtrees for the agenda. +This is basically a temporary global variable that can be set and then +used by user-defined selections using `org-agenda-skip-function'.") + +(defvar org-agenda-overriding-header nil + "When this is set during todo and tags searches, will replace header.") + +(defun org-agenda-skip-subtree-when-regexp-matches () + "Checks if the current subtree contains match for `org-agenda-skip-regexp'. +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)))) + +(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 +of what a project is and how to check if it stuck, customize the variable +`org-stuck-projects'. +MATCH is being ignored." (interactive) - (if (org-mode-p) - ;; Exit without error, in case some hook functions calls this - ;; by accident in org-mode. - (message "Orgtbl-mode is not useful in org-mode, command ignored") - (setq orgtbl-mode - (if arg (> (prefix-numeric-value arg) 0) (not orgtbl-mode))) - (if orgtbl-mode - (progn - (and (orgtbl-setup) (defun orgtbl-setup () nil)) - ;; Make sure we are first in minor-mode-map-alist - (let ((c (assq 'orgtbl-mode minor-mode-map-alist))) - (and c (setq minor-mode-map-alist - (cons c (delq c minor-mode-map-alist))))) - (org-set-local (quote org-table-may-need-update) t) - (org-add-hook 'before-change-functions 'org-before-change-function - nil 'local) - (org-set-local 'org-old-auto-fill-inhibit-regexp - auto-fill-inhibit-regexp) - (org-set-local 'auto-fill-inhibit-regexp - (if auto-fill-inhibit-regexp - (concat "\\([ \t]*|\\|" auto-fill-inhibit-regexp) - "[ \t]*|")) - (org-add-to-invisibility-spec '(org-cwidth)) - (easy-menu-add orgtbl-mode-menu) - (run-hooks 'orgtbl-mode-hook)) - (setq auto-fill-inhibit-regexp org-old-auto-fill-inhibit-regexp) - (org-cleanup-narrow-column-properties) - (org-remove-from-invisibility-spec '(org-cwidth)) - (remove-hook 'before-change-functions 'org-before-change-function t) - (easy-menu-remove orgtbl-mode-menu) - (force-mode-line-update 'all)))) + (let* ((org-agenda-skip-function 'org-agenda-skip-subtree-when-regexp-matches) + (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-re (concat "^\\*+[ \t]+\\(" + (mapconcat 'identity todo "\\|") + "\\)\\>")) + (tags-re (concat "^\\*+.*:\\(" + (mapconcat 'identity tags "\\|") + "\\):[a-zA-Z0-9_@:]*[ \t]*$"))) + + (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")))) + (org-tags-view nil matcher) + (with-current-buffer org-agenda-buffer-name + (setq org-agenda-redo-command + '(org-agenda-list-stuck-projects + (or current-prefix-arg org-last-arg)))))) + +;;; Diary integration + +(defvar org-disable-agenda-to-diary nil) ;Dynamically-scoped param. + +(defun org-get-entries-from-diary (date) + "Get the (Emacs Calendar) diary entries for DATE." + (let* ((fancy-diary-buffer "*temporary-fancy-diary-buffer*") + (diary-display-hook '(fancy-diary-display)) + (list-diary-entries-hook + (cons 'org-diary-default-entry list-diary-entries-hook)) + (diary-file-name-prefix-function nil) ; turn this feature off + (diary-modify-entry-list-string-function 'org-modify-diary-entry-string) + entries + (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)) + (setq entries nil) + (with-current-buffer fancy-diary-buffer + (setq buffer-read-only nil) + (if (= (point-max) 1) + ;; 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) + (setq entries nil) + (setq entries (buffer-substring (point-min) (- (point-max) 1))))) + (set-buffer-modified-p nil) + (kill-buffer fancy-diary-buffer))) + (when entries + (setq entries (org-split-string entries "\n")) + (setq entries + (mapcar + (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))) + entries))))) + +(defun org-agenda-cleanup-fancy-diary () + "Remove unwanted stuff in buffer created by `fancy-diary-display'. +This gets rid of the date, the underline under the date, and +the dummy entry installed by `org-mode' to ensure non-empty diary for each +date. It also removes lines that contain only whitespace." + (goto-char (point-min)) + (if (looking-at ".*?:[ \t]*") + (progn + (replace-match "") + (re-search-forward "\n=+$" nil t) + (replace-match "") + (while (re-search-backward "^ +\n?" nil t) (replace-match ""))) + (re-search-forward "\n=+$" nil t) + (delete-region (point-min) (min (point-max) (1+ (match-end 0))))) + (goto-char (point-min)) + (while (re-search-forward "^ +\n" nil t) + (replace-match "")) + (goto-char (point-min)) + (if (re-search-forward "^Org-mode dummy\n?" nil t) + (replace-match ""))) + +;; Make sure entries from the diary have the right text properties. +(eval-after-load "diary-lib" + '(if (boundp 'diary-modify-entry-list-string-function) + ;; We can rely on the hook, nothing to do + nil + ;; Hook not avaiable, must use advice to make this work + (defadvice add-to-diary-list (before org-mark-diary-entry activate) + "Make the position visible." + (if (and org-disable-agenda-to-diary ;; called from org-agenda + (stringp string) + buffer-file-name) + (setq string (org-modify-diary-entry-string string)))))) + +(defun org-modify-diary-entry-string (string) + "Add text properties to string, allowing org-mode to act on it." + (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)) + 'org-agenda-diary-link t + 'org-marker (org-agenda-new-marker (point-at-bol)))) + +(defun org-diary-default-entry () + "Add a dummy entry to the diary. +Needed to avoid empty dates which mess up holiday display." + ;; Catch the error if dealing with the new add-to-diary-alist + (when org-disable-agenda-to-diary + (condition-case nil + (add-to-diary-list original-date "Org-mode dummy" "") + (error + (add-to-diary-list original-date "Org-mode dummy" "" nil))))) + +;;;###autoload +(defun org-diary (&rest args) + "Return diary information from org-files. +This function can be used in a \"sexp\" diary entry in the Emacs calendar. +It accesses org files and extracts information from those files to be +listed in the diary. The function accepts arguments specifying what +items should be listed. The following arguments are allowed: + + :timestamp List the headlines of items containing a date stamp or + date range matching the selected date. Deadlines will + also be listed, on the expiration day. + + :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 + an entry is marked DONE, it is no longer listed. + + :scheduled List all items which are scheduled for the given date. + The diary for *today* also contains items which were + scheduled earlier and are not yet marked DONE. + + :todo List all TODO items from the org-file. This may be a + long list - so this is not turned on by default. + Like deadlines, these entries only show up in the + diary for *today*, not at any other date. + +The call in the diary file should look like this: + + &%%(org-diary) ~/path/to/some/orgfile.org + +Use a separate line for each org file to check. Or, if you omit the file name, +all files listed in `org-agenda-files' will be checked automatically: + + &%%(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 + + &%%(org-diary :deadline :timestamp :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) + (org-compile-prefix-format 'agenda) + (org-set-sorting-strategy 'agenda) + (setq args (or args '(:deadline :scheduled :timestamp))) + (let* ((files (if (and entry (stringp entry) (string-match "\\S-" entry)) + (list entry) + (org-agenda-files t))) + file rtn results) + ;; 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)) + (while (setq file (pop files)) + (setq rtn (apply 'org-agenda-get-day-entries file date args)) + (setq results (append results rtn))) + (if results + (concat (org-finalize-agenda-entries results) "\n")))) + +;;; Agenda entry finders + +(defun org-agenda-get-day-entries (file date &rest args) + "Does the work for `org-diary' and `org-agenda'. +FILE is the path to a file to be checked for entries. DATE is date like +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))) + (let* ((org-startup-folded nil) + (org-startup-align-all-tables nil) + (buffer (if (file-exists-p file) + (org-get-agenda-file-buffer file) + (error "No such file %s" file))) + arg results rtn) + (if (not buffer) + ;; If file does not exist, make sure an error message ends up in diary + (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)) + (setq org-category-table (org-get-category-table)) + (let ((case-fold-search nil)) + (save-excursion + (save-restriction + (if org-agenda-restrict + (narrow-to-region org-agenda-restrict-begin + org-agenda-restrict-end) + (widen)) + ;; The way we repeatedly append to `results' makes it O(n^2) :-( + (while (setq arg (pop args)) + (cond + ((and (eq arg :todo) + (equal date (calendar-current-date))) + (setq rtn (org-agenda-get-todos)) + (setq results (append results rtn))) + ((eq arg :timestamp) + (setq rtn (org-agenda-get-blocks)) + (setq results (append results rtn)) + (setq rtn (org-agenda-get-timestamps)) + (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))) + (setq rtn (org-agenda-get-deadlines)) + (setq results (append results rtn)))))))) + results)))) + +(defun org-entry-is-done-p () + "Is the current entry marked DONE?" + (save-excursion + (and (re-search-backward "[\r\n]\\*" nil t) + (looking-at org-nl-done-regexp)))) + +(defun org-at-date-range-p (&optional inactive-ok) + "Is the cursor inside a date range?" + (interactive) + (save-excursion + (catch 'exit + (let ((pos (point))) + (skip-chars-backward "^[<\r\n") + (skip-chars-backward "<[") + (and (looking-at (if inactive-ok org-tr-regexp-both org-tr-regexp)) + (>= (match-end 0) pos) + (throw 'exit t)) + (skip-chars-backward "^<[\r\n") + (skip-chars-backward "<[") + (and (looking-at (if inactive-ok org-tr-regexp-both org-tr-regexp)) + (>= (match-end 0) pos) + (throw 'exit t))) + nil))) + +(defun org-agenda-get-todos () + "Return the TODO information for agenda display." + (let* ((props (list 'face nil + 'done-face 'org-done + 'org-not-done-regexp org-not-done-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]\\*+ *\\(" + (if org-select-this-todo-keyword + (concat "\\<\\(" org-select-this-todo-keyword + "\\)\\>") + org-not-done-regexp) + "[^\n\r]*\\)")) + marker priority category tags + ee txt beg end) + (goto-char (point-min)) + (while (re-search-forward regexp nil t) + (catch :skip + (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) + (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) + (or org-agenda-todo-list-sublevels (org-end-of-subtree 'invisible)) + (throw :skip nil))) + (org-agenda-skip) + (goto-char (match-beginning 1)) + (setq marker (org-agenda-new-marker (1+ (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))) + (org-add-props txt props + 'org-marker marker 'org-hd-marker marker + 'priority priority 'org-category category) + (push txt ee) + (if org-agenda-todo-list-sublevels + (goto-char (match-end 1)) + (org-end-of-subtree 'invisible)))) + (nreverse ee))) + +(defconst org-agenda-no-heading-message + "No heading for this item in buffer or region.") + +(defun org-agenda-get-timestamps () + "Return the date stamp information for agenda display." + (let* ((props (list 'face nil + 'org-not-done-regexp org-not-done-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))) + marker hdmarker deadlinep scheduledp donep tmp priority category + ee txt timestr tags) + (goto-char (point-min)) + (while (re-search-forward regexp nil t) + (catch :skip + (and (save-match-data (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)) + 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)) + 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 (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) + (progn + (goto-char (match-end 1)) + (setq hdmarker (org-agenda-new-marker) + tags (org-get-tags-at)) + (looking-at "\\*+[ \t]*\\([^\r\n]+\\)") + (setq txt (org-format-agenda-item + (format "%s%s" + (if deadlinep "Deadline: " "") + (if scheduledp "Scheduled: " "")) + (match-string 1) category tags timestr))) + (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))) + (push txt ee)) + (outline-next-heading))) + (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 + 'keymap org-agenda-keymap + 'help-echo + (format "mouse-2 or RET jump to org file %s" + (abbreviate-file-name buffer-file-name)))) + (regexp (concat + "\\<\\(" org-closed-string "\\|" org-clock-string "\\) *\\[" + (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)))) + 1 11)))) + marker hdmarker priority category tags closedp + ee txt timestr) + (goto-char (point-min)) + (while (re-search-forward regexp nil t) + (catch :skip + (org-agenda-skip) + (setq marker (org-agenda-new-marker (match-beginning 0)) + closedp (equal (match-string 1) org-closed-string) + category (org-get-category (match-beginning 0)) + timestr (buffer-substring (match-beginning 0) (point-at-eol)) + ;; donep (org-entry-is-done-p) + ) + (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) + (progn + (goto-char (match-end 1)) + (setq hdmarker (org-agenda-new-marker) + tags (org-get-tags-at)) + (looking-at "\\*+[ \t]*\\([^\r\n]+\\)") + (setq txt (org-format-agenda-item + (if closedp "Closed: " "Clocked: ") + (match-string 1) category tags timestr))) + (setq txt org-agenda-no-heading-message)) + (setq priority 100000) + (org-add-props txt props + 'org-marker marker 'org-hd-marker hdmarker 'face 'org-done + 'priority priority 'org-category category + 'undone-face 'org-warning 'done-face 'org-done) + (push txt ee)) + (outline-next-heading))) + (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 + 'org-not-done-regexp org-not-done-regexp + 'keymap org-agenda-keymap + 'help-echo + (format "mouse-2 or RET jump to org file %s" + (abbreviate-file-name buffer-file-name)))) + (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) + (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)) + ;; 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))) + (save-excursion + (setq category (org-get-category)) + (if (re-search-backward "\\(^\\|\r\\)\\*+[ \t]*" nil t) + (progn + (goto-char (match-end 0)) + (setq pos1 (match-end 1)) + (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 txt nil) + (setq txt (org-format-agenda-item + (format "In %3d d.: " diff) head category tags)))) + (setq txt org-agenda-no-heading-message)) + (when txt + (setq face (cond ((<= diff 0) 'org-warning) + ((<= diff 5) 'org-upcoming-deadline) + (t nil))) + (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)) + 'org-category category + 'face face 'undone-face face 'done-face 'org-done) + (push txt ee)))))) + ee)) + +(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 + 'done-face 'org-done + '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 org-scheduled-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) + (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)) + ;; When to show a scheduled item in the calendar: + ;; If it is on or past the date. + (if (and (< diff 0) todayp) + (save-excursion + (setq category (org-get-category)) + (if (re-search-backward "\\(^\\|\r\\)\\*+[ \t]*" nil t) + (progn + (goto-char (match-end 0)) + (setq pos1 (match-end 1)) + (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 txt nil) + (setq txt (org-format-agenda-item + (format "Sched.%2dx: " (- 1 diff)) head + category tags)))) + (setq txt org-agenda-no-heading-message)) + (when txt + (org-add-props txt props + 'org-marker (org-agenda-new-marker pos) + 'org-hd-marker (org-agenda-new-marker pos1) + 'priority (+ (- 5 diff) (org-get-priority txt)) + 'org-category category) + (push txt ee)))))) + 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 + '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 org-tr-regexp) + (d0 (calendar-absolute-from-gregorian date)) + marker hdmarker ee txt d1 d2 s1 s2 timestr category tags pos) + (goto-char (point-min)) + (while (re-search-forward regexp nil t) + (catch :skip + (org-agenda-skip) + (setq pos (point)) + (setq timestr (match-string 0) + s1 (match-string 1) + s2 (match-string 2) + d1 (time-to-days (org-time-string-to-time s1)) + d2 (time-to-days (org-time-string-to-time s2))) + (if (and (> (- d0 d1) -1) (> (- d2 d0) -1)) + ;; Only allow days between the limits, because the normal + ;; date stamps will catch the limits. + (save-excursion + (setq marker (org-agenda-new-marker (point))) + (setq category (org-get-category)) + (if (re-search-backward "\\(^\\|\r\\)\\*+" nil t) + (progn + (setq hdmarker (org-agenda-new-marker (match-end 1))) + (goto-char (match-end 1)) + (setq tags (org-get-tags-at)) + (looking-at "\\*+[ \t]*\\([^\r\n]+\\)") + (setq txt (org-format-agenda-item + (format (if (= d1 d2) "" "(%d/%d): ") + (1+ (- d0 d1)) (1+ (- d2 d1))) + (match-string 1) 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 + 'priority (org-get-priority txt) 'org-category category) + (push txt ee))) + (goto-char pos))) + ;; Sort the entries by expiration date. + (nreverse ee))) + +;;; Agenda presentation and sorting + +;; FIXME: should I allow spaces around the dash? +(defconst org-plain-time-of-day-regexp + (concat + "\\(\\<[012]?[0-9]" + "\\(\\(:\\([0-5][0-9]\\([AaPp][Mm]\\)?\\)\\)\\|\\([AaPp][Mm]\\)\\)\\>\\)" + "\\(--?" + "\\(\\<[012]?[0-9]" + "\\(\\(:\\([0-5][0-9]\\([AaPp][Mm]\\)?\\)\\)\\|\\([AaPp][Mm]\\)\\)\\>\\)" + "\\)?") + "Regular expression to match a plain time or time range. +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.") + +(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]\\)>" + "\\(--?" + "<\\1\\([012][0-9]:[0-5][0-9]\\)>\\)?") + "Regular expression to match a timestamp time or time range. +After a match, the following groups carry important information: +0 the full match +1 date plus weekday, for backreferencing to make sure both times on same day +2 the first time, range or not +4 the second time, if it is a range.") + +(defvar org-prefix-has-time nil + "A flag, set by `org-compile-prefix-format'. +The flag is set if the currently compiled format contains a `%t'.") +(defvar org-prefix-has-tag nil + "A flag, set by `org-compile-prefix-format'. +The flag is set if the currently compiled format contains a `%T'.") + +(defun org-format-agenda-item (extra txt &optional category tags dotime + noprefix) + "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. +CATEGORY (string, symbol or nil) may be used to overrule the default +category taken from local variable or file name. It will replace the `%c' +specifier in the format. DOTIME, when non-nil, indicates that a +time-of-day should be extracted from TXT for sorting of this entry, and for +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." + (save-match-data + ;; Diary entries sometimes have extra whitespace at the beginning + (if (string-match "^ +" txt) (setq txt (replace-match "" nil nil txt))) + (let* ((category (or category + org-category + (if buffer-file-name + (file-name-sans-extension + (file-name-nondirectory buffer-file-name)) + ""))) + (tag (if tags (nth (1- (length tags)) tags) "")) + 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) + (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) + s1 (match-string (if plain 1 2) ts) + s2 (match-string (if plain 8 4) 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) + (if (eq org-agenda-remove-times-when-in-prefix 'beg) + (= (match-beginning 0) 0) + t)) + (setq txt (replace-match "" nil nil txt)))) + ;; Normalize the time(s) to 24 hour + (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) + ;; Tags are in the string + (if (or (eq org-agenda-remove-tags-when-in-prefix t) + (and org-agenda-remove-tags-when-in-prefix + org-prefix-has-tag)) + (setq txt (replace-match "" t t txt)) + (setq txt (replace-match + (concat (make-string (max (- 50 (length txt)) 1) ?\ ) + (match-string 2 txt)) + t t txt)))) + + ;; Create the final string + (if noprefix + (setq rtn txt) + ;; Prepare the variables needed in the eval of the compiled format + (setq time (cond (s2 (concat s1 "-" s2)) + (s1 (concat s1 "......")) + (t "")) + extra (or extra "") + category (if (symbolp category) (symbol-name category) category)) + ;; Evaluate the compiled format + (setq rtn (concat (eval org-prefix-format-compiled) txt))) + + ;; And finally add the text properties + (org-add-props rtn nil + 'org-category (downcase category) 'tags tags + 'prefix-length (- (length rtn) (length txt)) + 'time-of-day time-of-day + 'dotime dotime)))) + +(defvar org-agenda-sorting-strategy) +(defvar org-agenda-sorting-strategy-selected nil) + +(defun org-agenda-add-time-grid-maybe (list ndays todayp) + (catch 'exit + (cond ((not org-agenda-use-time-grid) (throw 'exit list)) + ((and todayp (member 'today (car org-agenda-time-grid)))) + ((and (= ndays 1) (member 'daily (car org-agenda-time-grid)))) + ((member 'weekly (car org-agenda-time-grid))) + (t (throw 'exit list))) + (let* ((have (delq nil (mapcar + (lambda (x) (get-text-property 1 'time-of-day x)) + list))) + (string (nth 1 org-agenda-time-grid)) + (gridtimes (nth 2 org-agenda-time-grid)) + (req (car org-agenda-time-grid)) + (remove (member 'remove-match req)) + new time) + (if (and (member 'require-timed req) (not have)) + ;; don't show empty grid + (throw 'exit list)) + (while (setq time (pop gridtimes)) + (unless (and remove (member time have)) + (setq time (int-to-string time)) + (push (org-format-agenda-item + nil string "" nil + (concat (substring time 0 -2) ":" (substring time -2))) + new) + (put-text-property + 1 (length (car new)) 'face 'org-time-grid (car new)))) + (if (member 'time-up org-agenda-sorting-strategy-selected) + (append new list) + (append list new))))) + +(defun org-compile-prefix-format (key) + "Compile the prefix format into a Lisp form that can be evaluated. +The resulting form is returned and stored in the variable +`org-prefix-format-compiled'." + (setq org-prefix-has-time nil org-prefix-has-tag nil) + (let ((s (cond + ((stringp org-agenda-prefix-format) + org-agenda-prefix-format) + ((assq key org-agenda-prefix-format) + (cdr (assq key org-agenda-prefix-format))) + (t " %-12:c%?-12t% s"))) + (start 0) + varform vars var e c f opt) + (while (string-match "%\\(\\?\\)?\\([-+]?[0-9.]*\\)\\([ .;,:!?=|/<>]?\\)\\([cts]\\)" + s start) + (setq var (cdr (assoc (match-string 4 s) + '(("c" . category) ("t" . time) ("s" . extra) + ("T" . tag)))) + c (or (match-string 3 s) "") + opt (match-beginning 1) + start (1+ (match-beginning 0))) + (if (equal var 'time) (setq org-prefix-has-time t)) + (if (equal var 'tag) (setq org-prefix-has-tag t)) + (setq f (concat "%" (match-string 2 s) "s")) + (if opt + (setq varform + `(if (equal "" ,var) + "" + (format ,f (if (equal "" ,var) "" (concat ,var ,c))))) + (setq varform `(format ,f (if (equal ,var "") "" (concat ,var ,c))))) + (setq s (replace-match "%s" t nil s)) + (push varform vars)) + (setq vars (nreverse vars)) + (setq org-prefix-format-compiled `(format ,s ,@vars)))) + +(defun org-set-sorting-strategy (key) + (if (symbolp (car org-agenda-sorting-strategy)) + ;; the old format + (setq org-agenda-sorting-strategy-selected org-agenda-sorting-strategy) + (setq org-agenda-sorting-strategy-selected + (or (cdr (assq key org-agenda-sorting-strategy)) + (cdr (assq 'agenda org-agenda-sorting-strategy)) + '(time-up category-keep priority-down))))) + +(defun org-get-time-of-day (s &optional string mod24) + "Check string S for a time of day. +If found, return it as a military time number between 0 and 2400. +If not found, return nil. +The optional STRING argument forces conversion into a 5 character wide string +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)) + (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)))) + (am-p (equal ampm "am")) + (h1 (cond ((not ampm) h) + ((= h 12) (if am-p 0 12)) + (t (+ h (if am-p 0 12))))) + (h2 (if (and string mod24 (not (and (= m 0) (= h1 24)))) + (mod h1 24) h1)) + (t0 (+ (* 100 h2) m)) + (t1 (concat (if (>= h1 24) "+" " ") + (if (< t0 100) "0" "") + (if (< t0 10) "0" "") + (int-to-string t0)))) + (if string (concat (substring t1 -4 -2) ":" (substring t1 -2)) t0))))) + +(defun org-finalize-agenda-entries (list &optional nosort) + "Sort and concatenate the agenda items." + (setq list (mapcar 'org-agenda-highlight-todo list)) + (if nosort + list + (mapconcat 'identity (sort list 'org-entries-lessp) "\n"))) + +(defun org-agenda-highlight-todo (x) + (let (re pl) + (if (eq x 'line) + (save-excursion + (beginning-of-line 1) + (setq re (get-text-property (point) 'org-not-done-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)) + 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)) + x))) + +(defsubst org-cmp-priority (a b) + "Compare the priorities of string A and B." + (let ((pa (or (get-text-property 1 'priority a) 0)) + (pb (or (get-text-property 1 'priority b) 0))) + (cond ((> pa pb) +1) + ((< pa pb) -1) + (t nil)))) + +(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) ""))) + (cond ((string-lessp ca cb) -1) + ((string-lessp cb ca) +1) + (t nil)))) + +(defsubst org-cmp-tag (a b) + "Compare the string values of categories of strings A and B." + (let ((ta (car (last (get-text-property 1 'tags a)))) + (tb (car (last (get-text-property 1 'tags b))))) + (cond ((not ta) +1) + ((not tb) -1) + ((string-lessp ta tb) -1) + ((string-lessp tb ta) +1) + (t nil)))) + +(defsubst org-cmp-time (a b) + "Compare the time-of-day values of strings A and B." + (let* ((def (if org-sort-agenda-notime-is-late 9901 -1)) + (ta (or (get-text-property 1 'time-of-day a) def)) + (tb (or (get-text-property 1 'time-of-day b) def))) + (cond ((< ta tb) -1) + ((< tb ta) +1) + (t nil)))) + +(defun org-entries-lessp (a b) + "Predicate for sorting agenda entries." + ;; The following variables will be used when the form is evaluated. + ;; So even though the compiler complains, keep them. + (let* ((time-up (org-cmp-time a b)) + (time-down (if time-up (- time-up) nil)) + (priority-up (org-cmp-priority a b)) + (priority-down (if priority-up (- priority-up) nil)) + (category-up (org-cmp-category a b)) + (category-down (if category-up (- category-up) nil)) + (category-keep (if category-up +1 nil)) + (tag-up (org-cmp-tag a b)) + (tag-down (if tag-up (- tag-up) nil))) + (cdr (assoc + (eval (cons 'or org-agenda-sorting-strategy-selected)) + '((-1 . t) (1 . nil) (nil . nil)))))) + +;;; Agenda commands + +(defun org-agenda-check-type (error &rest types) + "Check if agenda buffer is of allowed type. +If ERROR is non-nil, throw an error, otherwise just return nil." + (if (memq org-agenda-type types) + t + (if error + (error "Not allowed in %s-type agenda buffers" org-agenda-type) + nil))) + +(defun org-agenda-quit () + "Exit agenda by removing the window or the buffer." + (interactive) + (let ((buf (current-buffer))) + (if (not (one-window-p)) (delete-window)) + (kill-buffer buf) + (org-agenda-maybe-reset-markers 'force)) + ;; Maybe restore the pre-agenda window configuration. + (and org-agenda-restore-windows-after-quit + (not (eq org-agenda-window-setup 'other-frame)) + org-pre-agenda-window-conf + (set-window-configuration org-pre-agenda-window-conf))) + +(defun org-agenda-exit () + "Exit agenda by removing the window or the buffer. +Also kill all Org-mode buffers which have been loaded by `org-agenda'. +Org-mode buffers visited directly by the user will not be touched." + (interactive) + (org-release-buffers org-agenda-new-buffers) + (setq org-agenda-new-buffers nil) + (org-agenda-quit)) + +(defun org-save-all-org-buffers () + "Save all Org-mode buffers without user confirmation." + (interactive) + (message "Saving all Org-mode buffers...") + (save-some-buffers t 'org-mode-p) + (message "Saving all Org-mode buffers... done")) + +(defun org-agenda-redo () + "Rebuild Agenda. +When this is the global TODO list, a prefix argument will be interpreted." + (interactive) + (let* ((org-agenda-keep-modes t) + (line (org-current-line)) + (window-line (- line (org-current-line (window-start))))) + (message "Rebuilding agenda buffer...") + (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-goto-today () + "Go to today." + (interactive) + (org-agenda-check-type t 'timeline 'agenda) + (let ((tdpos (text-property-any (point-min) (point-max) 'org-today t))) + (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) + (org-agenda-redo) + (org-agenda-find-today-or-agenda))) + (t (error "Cannot find today"))))) + +(defun org-agenda-find-today-or-agenda () + (goto-char + (or (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'." + (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))) + +(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'." + (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))) + +(defun org-agenda-week-view () + "Switch to weekly 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 () + "Switch to daily view for agenda." + (interactive) + (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))) + (org-agenda-redo) + (org-agenda-find-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 +(defun org-agenda-next-date-line (&optional arg) + "Jump to the next line indicating a date in agenda buffer." + (interactive "p") + (org-agenda-check-type t 'agenda 'timeline) + (beginning-of-line 1) + (if (looking-at "^\\S-") (forward-char 1)) + (if (not (re-search-forward "^\\S-" nil t arg)) + (progn + (backward-char 1) + (error "No next date after this line in this buffer"))) + (goto-char (match-beginning 0))) + +(defun org-agenda-previous-date-line (&optional arg) + "Jump to the previous line indicating a date in agenda buffer." + (interactive "p") + (org-agenda-check-type t 'agenda 'timeline) + (beginning-of-line 1) + (if (not (re-search-backward "^\\S-" nil t arg)) + (error "No previous date before this line in this buffer"))) + +;; Initialize the highlight +(defvar org-hl (org-make-overlay 1 1)) +(org-overlay-put org-hl 'face 'highlight) + +(defun org-highlight (begin end &optional buffer) + "Highlight a region with overlay." + (funcall (if (featurep 'xemacs) 'set-extent-endpoints 'move-overlay) + org-hl begin end (or buffer (current-buffer)))) + +(defun org-unhighlight () + "Detach overlay INDEX." + (funcall (if (featurep 'xemacs) 'detach-extent 'delete-overlay) org-hl)) + +(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)) + +(defun org-agenda-follow-mode () + "Toggle follow mode in an agenda buffer." + (interactive) + (setq org-agenda-follow-mode (not org-agenda-follow-mode)) + (org-agenda-set-mode-name) + (message "Follow mode is %s" + (if org-agenda-follow-mode "on" "off"))) + +(defun org-agenda-log-mode () + "Toggle log mode in an agenda buffer." + (interactive) + (org-agenda-check-type t 'agenda 'timeline) + (setq org-agenda-show-log (not org-agenda-show-log)) + (org-agenda-set-mode-name) + (org-agenda-redo) + (message "Log mode is %s" + (if org-agenda-show-log "on" "off"))) + +(defun org-agenda-toggle-diary () + "Toggle diary inclusion in an agenda buffer." + (interactive) + (org-agenda-check-type t 'agenda) + (setq org-agenda-include-diary (not org-agenda-include-diary)) + (org-agenda-redo) + (org-agenda-set-mode-name) + (message "Diary inclusion turned %s" + (if org-agenda-include-diary "on" "off"))) + +(defun org-agenda-toggle-time-grid () + "Toggle time grid in an agenda buffer." + (interactive) + (org-agenda-check-type t 'agenda) + (setq org-agenda-use-time-grid (not org-agenda-use-time-grid)) + (org-agenda-redo) + (org-agenda-set-mode-name) + (message "Time-grid turned %s" + (if org-agenda-use-time-grid "on" "off"))) + +(defun org-agenda-set-mode-name () + "Set the mode name to indicate all the small mode settings." + (setq mode-name + (concat "Org-Agenda" + (if (equal org-agenda-ndays 1) " Day" "") + (if (equal org-agenda-ndays 7) " Week" "") + (if org-agenda-follow-mode " Follow" "") + (if org-agenda-include-diary " Diary" "") + (if org-agenda-use-time-grid " Grid" "") + (if org-agenda-show-log " Log" ""))) + (force-mode-line-update)) + +(defun org-agenda-post-command-hook () + (and (eolp) (not (bolp)) (backward-char 1)) + (setq org-agenda-type (get-text-property (point) 'org-agenda-type)) + (if (and org-agenda-follow-mode + (get-text-property (point) 'org-marker)) + (org-agenda-show))) + +(defun org-agenda-show-priority () + "Show the priority of the current item. +This priority is composed of the main priority given with the [#A] cookies, +and by additional input from the age of a schedules or deadline entry." + (interactive) + (let* ((pri (get-text-property (point-at-bol) 'priority))) + (message "Priority is %d" (if pri pri -1000)))) + +(defun org-agenda-show-tags () + "Show the tags applicable to the current item." + (interactive) + (let* ((tags (get-text-property (point-at-bol) 'tags))) + (if tags + (message "Tags are :%s:" + (org-no-properties (mapconcat 'identity tags ":"))) + (message "No tags associated with this line")))) + +(defun org-agenda-goto (&optional highlight) + "Go to the Org-mode file which contains the item at point." + (interactive) + (let* ((marker (or (get-text-property (point) 'org-marker) + (org-agenda-error))) + (buffer (marker-buffer marker)) + (pos (marker-position marker))) + (switch-to-buffer-other-window buffer) + (widen) + (goto-char pos) + (when (org-mode-p) + (org-show-context 'agenda) + (save-excursion + (and (outline-next-heading) + (org-flag-heading nil)))) ; show the next heading + (and highlight (org-highlight (point-at-bol) (point-at-eol))))) + +(defun org-agenda-kill () + "Kill the entry or subtree belonging to the current agenda entry." + (interactive) + (or (eq major-mode 'org-agenda-mode) (error "Not in agenda")) + (let* ((marker (or (get-text-property (point) 'org-marker) + (org-agenda-error))) + (buffer (marker-buffer marker)) + (pos (marker-position marker)) + dbeg dend (n 0) conf) + (org-with-remote-undo buffer + (with-current-buffer buffer + (save-excursion + (goto-char pos) + (if (org-mode-p) + (setq dbeg (progn (org-back-to-heading t) (point)) + dend (org-end-of-subtree t)) + (setq dbeg (point-at-bol) + dend (min (point-max) (1+ (point-at-eol))))) + (goto-char dbeg) + (while (re-search-forward "^[ \t]*\\S-" dend t) (setq n (1+ n))))) + (setq conf (or (eq t org-agenda-confirm-kill) + (and (numberp org-agenda-confirm-kill) + (> n org-agenda-confirm-kill)))) + (and conf + (not (y-or-n-p + (format "Delete entry with %d lines in buffer \"%s\"? " + n (buffer-name buffer)))) + (error "Abort")) + (org-remove-subtree-entries-from-agenda buffer dbeg dend) + (with-current-buffer buffer (delete-region dbeg dend)) + (message "Agenda item and source killed")))) + +(defun org-agenda-archive () + "Kill the entry or subtree belonging to the current agenda entry." + (interactive) + (or (eq major-mode 'org-agenda-mode) (error "Not in agenda")) + (let* ((marker (or (get-text-property (point) 'org-marker) + (org-agenda-error))) + (buffer (marker-buffer marker)) + (pos (marker-position marker))) + (org-with-remote-undo buffer + (with-current-buffer buffer + (if (org-mode-p) + (save-excursion + (goto-char pos) + (org-remove-subtree-entries-from-agenda) + (org-back-to-heading t) + (org-archive-subtree)) + (error "Archiving works only in Org-mode files")))))) + +(defun org-remove-subtree-entries-from-agenda (&optional buf beg end) + "Remove all lines in the agenda that correspond to a given subtree. +The subtree is the one in buffer BUF, starting at BEG and ending at END. +If this information is not given, the function uses the tree at point." + (let ((buf (or buf (current-buffer))) m p) + (save-excursion + (unless (and beg end) + (org-back-to-heading t) + (setq beg (point)) + (org-end-of-subtree t) + (setq end (point))) + (set-buffer (get-buffer org-agenda-buffer-name)) + (save-excursion + (goto-char (point-max)) + (beginning-of-line 1) + (while (not (bobp)) + (when (and (setq m (get-text-property (point) 'org-marker)) + (equal buf (marker-buffer m)) + (setq p (marker-position m)) + (>= p beg) + (<= p end)) + (let (buffer-read-only) + (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"))))) + +(defun org-agenda-switch-to (&optional delete-other-windows) + "Go to the Org-mode file which contains the item at point." + (interactive) + (let* ((marker (or (get-text-property (point) 'org-marker) + (org-agenda-error))) + (buffer (marker-buffer marker)) + (pos (marker-position marker))) + (switch-to-buffer buffer) + (and delete-other-windows (delete-other-windows)) + (widen) + (goto-char pos) + (when (org-mode-p) + (org-show-context 'agenda) + (save-excursion + (and (outline-next-heading) + (org-flag-heading nil)))))) ; show the next heading + +(defun org-agenda-goto-mouse (ev) + "Go to the Org-mode file which contains the item at the mouse click." + (interactive "e") + (mouse-set-point ev) + (org-agenda-goto)) + +(defun org-agenda-show () + "Display the Org-mode file which contains the item at point." + (interactive) + (let ((win (selected-window))) + (org-agenda-goto t) + (select-window win))) + +(defun org-agenda-recenter (arg) + "Display the Org-mode file which contains the item at point and recenter." + (interactive "P") + (let ((win (selected-window))) + (org-agenda-goto t) + (recenter arg) + (select-window win))) + +(defun org-agenda-show-mouse (ev) + "Display the Org-mode file which contains the item at the mouse click." + (interactive "e") + (mouse-set-point ev) + (org-agenda-show)) + +(defun org-agenda-check-no-diary () + "Check if the entry is a diary link and abort if yes." + (if (get-text-property (point) 'org-agenda-diary-link) + (org-agenda-error))) + +(defun org-agenda-error () + (error "Command not allowed in this line")) + +(defun org-agenda-tree-to-indirect-buffer () + "Show the subtree corresponding to the current entry in an indirect buffer. +This calls the command `org-tree-to-indirect-buffer' from the original +Org-mode buffer. +With numerical prefix arg ARG, go up to this level and then take that tree. +With a C-u prefix, make a separate frame for this tree (i.e. don't use the +dedicated frame)." + (interactive) + (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))) + (with-current-buffer buffer + (save-excursion + (goto-char pos) + (call-interactively 'org-tree-to-indirect-buffer))))) + +(defvar org-last-heading-marker (make-marker) + "Marker pointing to the headline that last changed its TODO state +by a remote command from the agenda.") + +(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 +the same tree node, and the headline of the tree node in the Org-mode file." + (interactive "P") + (org-agenda-check-no-diary) + (let* ((col (current-column)) + (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) + 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 + (org-todo arg) + (and (bolp) (forward-char 1)) + (setq newhead (org-get-heading)) + (save-excursion + (org-back-to-heading) + (move-marker org-last-heading-marker (point)))) + (beginning-of-line 1) + (save-excursion + (org-agenda-change-all-lines newhead hdmarker 'fixface)) + (move-to-column col)))) + +(defun org-agenda-change-all-lines (newhead hdmarker &optional fixface) + "Change all lines in the agenda buffer which match HDMARKER. +The new content of the line will be NEWHEAD (as modified by +`org-format-agenda-item'). HDMARKER is checked with +`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) + props m pl undone-face done-face finish new dotime cat tags) + (save-excursion + (goto-char (point-max)) + (beginning-of-line 1) + (while (not finish) + (setq finish (bobp)) + (when (and (setq m (get-text-property (point) 'org-hd-marker)) + (equal m hdmarker)) + (setq props (text-properties-at (point)) + dotime (get-text-property (point) 'dotime) + cat (get-text-property (point) 'org-category) + tags (get-text-property (point) 'tags) + new (org-format-agenda-item "x" newhead cat tags dotime 'noprefix) + pl (get-text-property (point) 'prefix-length) + undone-face (get-text-property (point) 'undone-face) + done-face (get-text-property (point) 'done-face)) + (move-to-column pl) + (cond + ((equal new "") + (beginning-of-line 1) + (and (looking-at ".*\n?") (replace-match ""))) + ((looking-at ".*") + (replace-match new t t) + (beginning-of-line 1) + (add-text-properties (point-at-bol) (point-at-eol) props) + (when fixface + (add-text-properties + (point-at-bol) (point-at-eol) + (list 'face + (if org-last-todo-state-is-todo + undone-face done-face)))) + (org-agenda-highlight-todo 'line) + (beginning-of-line 1)) + (t (error "Line update did not work")))) + (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)) + (save-excursion + (goto-char (if line (point-at-bol) (point-min))) + (while (re-search-forward "\\([ \t]+\\):[a-zA-Z0-9_@:]+:[ \t]*$" + (if line (point-at-eol) nil) t) + (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))) ?\ ) + (text-properties-at (point)))))))) + +(defun org-agenda-priority-up () + "Increase the priority of line at point, also in Org-mode file." + (interactive) + (org-agenda-priority 'up)) + +(defun org-agenda-priority-down () + "Decrease the priority of line at point, also in Org-mode file." + (interactive) + (org-agenda-priority 'down)) + +(defun org-agenda-priority (&optional force-direction) + "Set the priority of line at point, also in Org-mode file. +This changes the line at point, all other lines in the agenda referring to +the same tree node, and the headline of the tree node in the Org-mode file." + (interactive) + (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) + 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 + (funcall 'org-priority force-direction) + (end-of-line 1) + (setq newhead (org-get-heading))) + (org-agenda-change-all-lines newhead hdmarker) + (beginning-of-line 1)))) + +(defun org-get-tags-at (&optional pos) + "Get a list of all headline tags applicable at POS. +POS defaults to point. If tags are inherited, the list contains +the targets in the same sequence as the headlines appear, i.e. +the tags of the current headline come last." + (interactive) + (let (tags) + (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)) + (error nil)))) + tags))) + +;; FIXME: should fix the tags property of the agenda line. +(defun org-agenda-set-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)))) + +(defun org-agenda-toggle-archive-tag () + "Toggle the archive tag for the current entry." + (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-toggle-archive-tag) + (end-of-line 1) + (setq newhead (org-get-heading))) + (org-agenda-change-all-lines newhead hdmarker) + (beginning-of-line 1)))) + +(defun org-agenda-date-later (arg &optional what) + "Change the date of this item to one day later." + (interactive "p") + (org-agenda-check-type t 'agenda 'timeline) + (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))) + (org-with-remote-undo buffer + (with-current-buffer buffer + (widen) + (goto-char pos) + (if (not (org-at-timestamp-p)) + (error "Cannot find time stamp")) + (org-timestamp-change arg (or what 'day))) + (org-agenda-show-new-time marker org-last-changed-timestamp)) + (message "Time stamp changed to %s" org-last-changed-timestamp))) + +(defun org-agenda-date-earlier (arg &optional what) + "Change the date of this item to one day earlier." + (interactive "p") + (org-agenda-date-later (- arg) what)) + +(defun org-agenda-show-new-time (marker stamp) + "Show new date stamp via text properties." + ;; We use text properties to make this undoable + (let ((buffer-read-only nil)) + (setq stamp (concat " => " stamp)) + (save-excursion + (goto-char (point-max)) + (while (not (bobp)) + (when (equal marker (get-text-property (point) 'org-marker)) + (move-to-column (- (window-width) (length stamp)) t) + (if (featurep 'xemacs) + ;; Use `duplicable' property to trigger undo recording + (let ((ex (make-extent nil nil)) + (gl (make-glyph stamp))) + (set-glyph-face gl 'secondary-selection) + (set-extent-properties + ex (list 'invisible t 'end-glyph gl 'duplicable t)) + (insert-extent ex (1- (point)) (point-at-eol))) + (add-text-properties + (1- (point)) (point-at-eol) + (list 'display (org-add-props stamp nil + 'face 'secondary-selection)))) + (beginning-of-line 1)) + (beginning-of-line 0))))) + +(defun org-agenda-date-prompt (arg) + "Change the date of this item. Date is prompted for, with default today. +The prefix ARG is passed to the `org-time-stamp' command and can therefore +be used to request time specification in the time stamp." + (interactive "P") + (org-agenda-check-type t 'agenda 'timeline) + (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))) + (org-with-remote-undo buffer + (with-current-buffer buffer + (widen) + (goto-char pos) + (if (not (org-at-timestamp-p)) + (error "Cannot find time stamp")) + (org-time-stamp arg) + (message "Time stamp changed to %s" org-last-changed-timestamp))))) + +(defun org-agenda-schedule (arg) + "Schedule the item at point." + (interactive "P") + (org-agenda-check-type t 'agenda 'timeline 'todo 'tags) + (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)) + (org-insert-labeled-timestamps-at-point nil) + ts) + (org-with-remote-undo buffer + (with-current-buffer buffer + (widen) + (goto-char pos) + (setq ts (org-schedule)) + (message "Item scheduled for %s" ts))))) + +(defun org-agenda-deadline (arg) + "Schedule the item at point." + (interactive "P") + (org-agenda-check-type t 'agenda 'timeline 'todo 'tags) + (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)) + (org-insert-labeled-timestamps-at-point nil) + ts) + (org-with-remote-undo buffer + (with-current-buffer buffer + (widen) + (goto-char pos) + (setq ts (org-deadline)) + (message "Deadline for this item set to %s" ts))))) + +(defun org-get-heading () + "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) ""))) + +(defun org-agenda-clock-in (&optional arg) + "Start the clock on the currently selected item." + (interactive "P") + (org-agenda-check-no-diary) + (let* ((marker (or (get-text-property (point) 'org-marker) + (org-agenda-error))) + (pos (marker-position marker))) + (org-with-remote-undo (marker-buffer marker) + (with-current-buffer (marker-buffer marker) + (widen) + (goto-char pos) + (org-clock-in))))) + +(defun org-agenda-clock-out (&optional arg) + "Stop the currently running clock." + (interactive "P") + (unless (marker-buffer org-clock-marker) + (error "No running clock")) + (org-with-remote-undo (marker-buffer org-clock-marker) + (org-clock-out))) + +(defun org-agenda-clock-cancel (&optional arg) + "Cancel the currently running clock." + (interactive "P") + (unless (marker-buffer org-clock-marker) + (error "No running clock")) + (org-with-remote-undo (marker-buffer org-clock-marker) + (org-clock-cancel))) + +(defun org-agenda-diary-entry () + "Make a diary entry, like the `i' command from the calendar. +All the standard commands work: block, weekly etc." + (interactive) + (org-agenda-check-type t 'agenda 'timeline) + (require 'diary-lib) + (let* ((char (progn + (message "Diary entry: [d]ay [w]eekly [m]onthly [y]early [a]nniversary [b]lock [c]yclic") + (read-char-exclusive))) + (cmd (cdr (assoc char + '((?d . insert-diary-entry) + (?w . insert-weekly-diary-entry) + (?m . insert-monthly-diary-entry) + (?y . insert-yearly-diary-entry) + (?a . insert-anniversary-diary-entry) + (?b . insert-block-diary-entry) + (?c . insert-cyclic-diary-entry))))) + (oldf (symbol-function 'calendar-cursor-to-date)) +; (buf (get-file-buffer (substitute-in-file-name diary-file))) + (point (point)) + (mark (or (mark t) (point)))) + (unless cmd + (error "No command associated with <%c>" char)) + (unless (and (get-text-property point 'day) + (or (not (equal ?b char)) + (get-text-property mark 'day))) + (error "Don't know which date to use for diary entry")) + ;; We implement this by hacking the `calendar-cursor-to-date' function + ;; and the `calendar-mark-ring' variable. Saves a lot of code. + (let ((calendar-mark-ring + (list (calendar-gregorian-from-absolute + (or (get-text-property mark 'day) + (get-text-property point 'day)))))) + (unwind-protect + (progn + (fset 'calendar-cursor-to-date + (lambda (&optional error) + (calendar-gregorian-from-absolute + (get-text-property point 'day)))) + (call-interactively cmd)) + (fset 'calendar-cursor-to-date oldf))))) + + +(defun org-agenda-execute-calendar-command (cmd) + "Execute a calendar command from the agenda, with the date associated to +the cursor position." + (org-agenda-check-type t 'agenda 'timeline) + (require 'diary-lib) + (unless (get-text-property (point) 'day) + (error "Don't know which date to use for calendar command")) + (let* ((oldf (symbol-function 'calendar-cursor-to-date)) + (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))) + (unwind-protect + (progn + (fset 'calendar-cursor-to-date + (lambda (&optional error) + (calendar-gregorian-from-absolute + (get-text-property point 'day)))) + (call-interactively cmd)) + (fset 'calendar-cursor-to-date oldf)))) + +(defun org-agenda-phases-of-moon () + "Display the phases of the moon for the 3 months around the cursor date." + (interactive) + (org-agenda-execute-calendar-command 'calendar-phases-of-moon)) + +(defun org-agenda-holidays () + "Display the holidays for the 3 months around the cursor date." + (interactive) + (org-agenda-execute-calendar-command 'list-calendar-holidays)) + +(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") + (let ((calendar-longitude (if arg nil calendar-longitude)) + (calendar-latitude (if arg nil calendar-latitude)) + (calendar-location-name + (if arg "the given coordinates" calendar-location-name))) + (org-agenda-execute-calendar-command 'calendar-sunrise-sunset))) + +(defun org-agenda-goto-calendar () + "Open the Emacs calendar with the date at the cursor." + (interactive) + (org-agenda-check-type t 'agenda 'timeline) + (let* ((day (or (get-text-property (point) 'day) + (error "Don't know which date to open in calendar"))) + (date (calendar-gregorian-from-absolute day)) + (calendar-move-hook nil) + (view-calendar-holidays-initially nil) + (view-diary-entries-initially nil)) + (calendar) + (calendar-goto-date date))) + +(defun org-calendar-goto-agenda () + "Compute the Org-mode agenda for the calendar date displayed at the cursor. +This is a command that has to be installed in `calendar-mode-map'." + (interactive) + (org-agenda-list nil (calendar-absolute-from-gregorian + (calendar-cursor-to-date)) + nil)) + +(defun org-agenda-convert-date () + (interactive) + (org-agenda-check-type t 'agenda 'timeline) + (let ((day (get-text-property (point) 'day)) + date s) + (unless day + (error "Don't know which date to convert")) + (setq date (calendar-gregorian-from-absolute day)) + (setq s (concat + "Gregorian: " (calendar-date-string date) "\n" + "ISO: " (calendar-iso-date-string date) "\n" + "Day of Yr: " (calendar-day-of-year-string date) "\n" + "Julian: " (calendar-julian-date-string date) "\n" + "Astron. JD: " (calendar-astro-date-string date) + " (Julian date number at noon UTC)\n" + "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" + "Mayan: " (calendar-mayan-date-string date) "\n" + "Coptic: " (calendar-coptic-date-string date) "\n" + "Ethiopic: " (calendar-ethiopic-date-string date) "\n" + "Persian: " (calendar-persian-date-string date) "\n" + "Chinese: " (calendar-chinese-date-string date) "\n")) + (with-output-to-temp-buffer "*Dates*" + (princ s)) + (if (fboundp 'fit-window-to-buffer) + (fit-window-to-buffer (get-buffer-window "*Dates*"))))) -(defun org-cleanup-narrow-column-properties () - "Remove all properties related to narrow-column invisibility." - (let ((s 1)) - (while (setq s (text-property-any s (point-max) - 'display org-narrow-column-arrow)) - (remove-text-properties s (1+ s) '(display t))) - (setq s 1) - (while (setq s (text-property-any s (point-max) 'org-cwidth 1)) - (remove-text-properties s (1+ s) '(org-cwidth t))) - (setq s 1) - (while (setq s (text-property-any s (point-max) 'invisible 'org-cwidth)) - (remove-text-properties s (1+ s) '(invisible t))))) -;; Install it as a minor mode. -(put 'orgtbl-mode :included t) -(put 'orgtbl-mode :menu-tag "Org Table Mode") -(add-minor-mode 'orgtbl-mode " OrgTbl" orgtbl-mode-map) +;;;; Embedded LaTeX -(defun orgtbl-make-binding (fun n &rest keys) - "Create a function for binding in the table 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 "orgtbl-hijacker-command-" (int-to-string n))) - '(arg) - (concat "In tables, run `" (symbol-name fun) "'.\n" - "Outside of tables, run the binding of `" - (mapconcat (lambda (x) (format "%s" x)) keys "' or `") - "'.") - '(interactive "p") - (list 'if - '(org-at-table-p) - (list 'call-interactively (list 'quote fun)) - (list 'let '(orgtbl-mode) - (list 'call-interactively - (append '(or) - (mapcar (lambda (k) - (list 'key-binding k)) - keys) - '('orgtbl-error)))))))) +(defvar org-cdlatex-mode-map (make-sparse-keymap) + "Keymap for the minor `org-cdlatex-mode'.") -(defun orgtbl-error () - "Error when there is no default binding for a table key." - (interactive) - (error "This key is has no function outside tables")) +(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) -(defun orgtbl-setup () - "Setup orgtbl keymaps." - (let ((nfunc 0) - (bindings - (list - '([(meta shift left)] org-table-delete-column) - '([(meta left)] org-table-move-column-left) - '([(meta right)] org-table-move-column-right) - '([(meta shift right)] org-table-insert-column) - '([(meta shift up)] org-table-kill-row) - '([(meta shift down)] org-table-insert-row) - '([(meta up)] org-table-move-row-up) - '([(meta down)] org-table-move-row-down) - '("\C-c\C-w" org-table-cut-region) - '("\C-c\M-w" org-table-copy-region) - '("\C-c\C-y" org-table-paste-rectangle) - '("\C-c-" org-table-insert-hline) -; '([(shift tab)] org-table-previous-field) - '("\C-m" org-table-next-row) - (list (org-key 'S-return) 'org-table-copy-down) - '([(meta return)] org-table-wrap-region) - '("\C-c\C-q" org-table-wrap-region) - '("\C-c?" org-table-current-column) - '("\C-c " org-table-blank-field) - '("\C-c+" org-table-sum) - '("\C-c=" org-table-eval-formula) - '("\C-c'" org-table-edit-formulas) - '("\C-c`" org-table-edit-field) - '("\C-c*" org-table-recalculate) - '("\C-c|" org-table-create-or-convert-from-region) - '("\C-c^" org-table-sort-lines) - '([(control ?#)] org-table-rotate-recalc-marks))) - elt key fun cmd) - (while (setq elt (pop bindings)) - (setq nfunc (1+ nfunc)) - (setq key (car elt) - fun (nth 1 elt) - cmd (orgtbl-make-binding fun nfunc key)) - (define-key orgtbl-mode-map key cmd)) - ;; Special treatment needed for TAB and RET - (define-key orgtbl-mode-map [(return)] - (orgtbl-make-binding 'orgtbl-ret 100 [(return)] "\C-m")) - (define-key orgtbl-mode-map "\C-m" - (orgtbl-make-binding 'orgtbl-ret 101 "\C-m" [(return)])) - (define-key orgtbl-mode-map [(tab)] - (orgtbl-make-binding 'orgtbl-tab 102 [(tab)] "\C-i")) - (define-key orgtbl-mode-map "\C-i" - (orgtbl-make-binding 'orgtbl-tab 103 "\C-i" [(tab)]))) - (define-key orgtbl-mode-map "\C-i" - (orgtbl-make-binding 'orgtbl-tab 104 [(shift tab)])) - (define-key orgtbl-mode-map "\C-c\C-c" - (orgtbl-make-binding 'org-ctrl-c-ctrl-c 105 "\C-c\C-c")) - (when orgtbl-optimized - ;; If the user wants maximum table support, we need to hijack - ;; some standard editing functions - (org-remap orgtbl-mode-map - '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)) - (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"] - ["Next Field" org-cycle :active (org-at-table-p) :keys "TAB"] - ["Previous Field" org-shifttab :active (org-at-table-p) :keys "S-TAB"] - ["Next Row" org-return :active (org-at-table-p) :keys "RET"] - "--" - ["Blank Field" org-table-blank-field :active (org-at-table-p) :keys "C-c SPC"] - ["Edit Field" org-table-edit-field :active (org-at-table-p) :keys "C-c ` "] - ["Copy Field from Above" - org-table-copy-down :active (org-at-table-p) :keys "S-RET"] - "--" - ("Column" - ["Move Column Left" org-metaleft :active (org-at-table-p) :keys "M-"] - ["Move Column Right" org-metaright :active (org-at-table-p) :keys "M-"] - ["Delete Column" org-shiftmetaleft :active (org-at-table-p) :keys "M-S-"] - ["Insert Column" org-shiftmetaright :active (org-at-table-p) :keys "M-S-"] - "--" - ["Enable Narrowing" (setq org-table-limit-column-width (not org-table-limit-column-width)) :active (org-at-table-p) :selected org-table-limit-column-width :style toggle]) - ("Row" - ["Move Row Up" org-metaup :active (org-at-table-p) :keys "M-"] - ["Move Row Down" org-metadown :active (org-at-table-p) :keys "M-"] - ["Delete Row" org-shiftmetaup :active (org-at-table-p) :keys "M-S-"] - ["Insert Row" org-shiftmetadown :active (org-at-table-p) :keys "M-S-"] - ["Sort lines in region" org-table-sort-lines (org-at-table-p) :keys "C-c ^"] - "--" - ["Insert Hline" org-table-insert-hline :active (org-at-table-p) :keys "C-c -"]) - ("Rectangle" - ["Copy Rectangle" org-copy-special :active (org-at-table-p)] - ["Cut Rectangle" org-cut-special :active (org-at-table-p)] - ["Paste Rectangle" org-paste-special :active (org-at-table-p)] - ["Fill Rectangle" org-table-wrap-region :active (org-at-table-p)]) - "--" - ["Set Column Formula" org-table-eval-formula :active (org-at-table-p) :keys "C-c ="] - ["Set Named Field Formula" (org-table-eval-formula '(4)) :active (org-at-table-p) :keys "C-u C-c ="] - ["Edit Formulas" org-table-edit-formulas :active (org-at-table-p) :keys "C-c '"] - ["Recalculate line" org-table-recalculate :active (org-at-table-p) :keys "C-c *"] - ["Recalculate all" (org-table-recalculate '(4)) :active (org-at-table-p) :keys "C-u C-c *"] - ["Toggle Recalculate Mark" org-table-rotate-recalc-marks :active (org-at-table-p) :keys "C-c #"] - ["Sum Column/Rectangle" org-table-sum - :active (or (org-at-table-p) (org-region-active-p)) :keys "C-c +"] - ["Which Column?" org-table-current-column :active (org-at-table-p) :keys "C-c ?"] - ["Debug Formulas" - (setq org-table-formula-debug (not org-table-formula-debug)) - :style toggle :selected org-table-formula-debug] - )) - t) +(defvar org-cdlatex-texmathp-advice-is-done nil + "Flag remembering if we have applied the advice to texmathp already.") + +(define-minor-mode org-cdlatex-mode + "Toggle the minor `org-cdlatex-mode'. +This mode supports entering LaTeX environment and math in LaTeX fragments +in Org-mode. +\\{org-cdlatex-mode-map}" + nil " OCDL" nil + (when org-cdlatex-mode (require 'cdlatex)) + (unless org-cdlatex-texmathp-advice-is-done + (setq org-cdlatex-texmathp-advice-is-done t) + (defadvice texmathp (around org-math-always-on activate) + "Always return t in org-mode buffers. +This is because we want to insert math symbols without dollars even outside +the LaTeX math segments. If Orgmode thinks that point is actually inside +en embedded LaTeX fragement, let texmathp do its job. +\\[org-cdlatex-mode-map]" + (interactive) + (let (p) + (cond + ((not (org-mode-p)) ad-do-it) + ((eq this-command 'cdlatex-math-symbol) + (setq ad-return-value t + texmathp-why '("cdlatex-math-symbol in org-mode" . 0))) + (t + (let ((p (org-inside-LaTeX-fragment-p))) + (if (and p (member (car p) (plist-get org-format-latex-options :matchers))) + (setq ad-return-value t + texmathp-why '("Org-mode embedded math" . 0)) + (if p ad-do-it))))))))) + +(defun turn-on-org-cdlatex () + "Unconditionally turn on `org-cdlatex-mode'." + (org-cdlatex-mode 1)) + +(defun org-inside-LaTeX-fragment-p () + "Test if point is inside a LaTeX fragment. +I.e. after a \\begin, \\(, \\[, $, or $$, without the corresponding closing +sequence appearing also before point. +Even though the matchers for math are configurable, this function assumes +that \\begin, \\(, \\[, and $$ are always used. Only the single dollar +delimiters are skipped when they have been removed by customization. +The return value is nil, or a cons cell with the delimiter and +and the position of this delimiter. + +This function does a reasonably good job, but can locally be fooled by +for example currency specifications. For example it will assume being in +inline math after \"$22.34\". The LaTeX fragment formatter will only format +fragments that are properly closed, but during editing, we have to live +with the uncertainty caused by missing closing delimiters. This function +looks only before point, not after." + (catch 'exit + (let ((pos (point)) + (dodollar (member "$" (plist-get org-format-latex-options :matchers))) + (lim (progn + (re-search-backward (concat "^\\(" paragraph-start "\\)") nil t) + (point))) + dd-on str (start 0) m re) + (goto-char pos) + (when dodollar + (setq str (concat (buffer-substring lim (point)) "\000 X$.") + re (nth 1 (assoc "$" org-latex-regexps))) + (while (string-match re str start) + (cond + ((= (match-end 0) (length str)) + (throw 'exit (cons "$" (+ lim (match-beginning 0))))) + ((= (match-end 0) (- (length str) 5)) + (throw 'exit nil)) + (t (setq start (match-end 0)))))) + (when (setq m (re-search-backward "\\(\\\\begin{[^}]*}\\|\\\\(\\|\\\\\\[\\)\\|\\(\\\\end{[^}]*}\\|\\\\)\\|\\\\\\]\\)\\|\\(\\$\\$\\)" lim t)) + (goto-char pos) + (and (match-beginning 1) (throw 'exit (cons (match-string 1) m))) + (and (match-beginning 2) (throw 'exit nil)) + ;; count $$ + (while (re-search-backward "\\$\\$" lim t) + (setq dd-on (not dd-on))) + (goto-char pos) + (if dd-on (cons "$$" m)))))) + + +(defun org-try-cdlatex-tab () + "Check if it makes sense to execute `cdlatex-tab', and do it if yes. +It makes sense to do so if `org-cdlatex-mode' is active and if the cursor is + - inside a LaTeX fragment, or + - after the first word in a line, where an abbreviation expansion could + insert a LaTeX environment." + (when org-cdlatex-mode + (cond + ((save-excursion + (skip-chars-backward "a-zA-Z0-9*") + (skip-chars-backward " \t") + (bolp)) + (cdlatex-tab) t) + ((org-inside-LaTeX-fragment-p) + (cdlatex-tab) t) + (t nil)))) -(defun orgtbl-tab (arg) - "Justification and field motion for `orgtbl-mode'." +(defun org-cdlatex-underscore-caret (&optional arg) + "Execute `cdlatex-sub-superscript' in LaTeX fragments. +Revert to the normal definition outside of these fragments." (interactive "P") - (if arg (org-table-edit-field t) - (org-table-justify-field-maybe) - (org-table-next-field))) - -(defun orgtbl-ret () - "Justification and field motion for `orgtbl-mode'." - (interactive) - (org-table-justify-field-maybe) - (org-table-next-row)) + (if (org-inside-LaTeX-fragment-p) + (call-interactively 'cdlatex-sub-superscript) + (let (org-cdlatex-mode) + (call-interactively (key-binding (vector last-input-event)))))) -(defun orgtbl-self-insert-command (N) - "Like `self-insert-command', use overwrite-mode for whitespace in tables. -If the cursor is in a table looking at whitespace, the whitespace is -overwritten, and the table is not marked as requiring realignment." - (interactive "p") - (if (and (org-at-table-p) - (or - (and org-table-auto-blank-field - (member last-command - '(orgtbl-hijacker-command-100 - orgtbl-hijacker-command-101 - orgtbl-hijacker-command-102 - orgtbl-hijacker-command-103 - orgtbl-hijacker-command-104 - orgtbl-hijacker-command-105)) - (org-table-blank-field)) - t) - (eq N 1) - (looking-at "[^|\n]* +|")) - (let (org-table-may-need-update) - (goto-char (1- (match-end 0))) - (delete-backward-char 1) - (goto-char (match-beginning 0)) - (self-insert-command N)) - (setq org-table-may-need-update t) - (let (orgtbl-mode) +(defun org-cdlatex-math-modify (&optional arg) + "Execute `cdlatex-math-modify' in LaTeX fragments. +Revert to the normal definition outside of these fragments." + (interactive "P") + (if (org-inside-LaTeX-fragment-p) + (call-interactively 'cdlatex-math-modify) + (let (org-cdlatex-mode) (call-interactively (key-binding (vector last-input-event)))))) -(defun org-force-self-insert (N) - "Needed to enforce self-insert under remapping." - (interactive "p") - (self-insert-command N)) +(defvar org-latex-fragment-image-overlays nil + "List of overlays carrying the images of latex fragments.") +(make-variable-buffer-local 'org-latex-fragment-image-overlays) + +(defun org-remove-latex-fragment-image-overlays () + "Remove all overlays with LaTeX fragment images in current buffer." + (mapc 'org-delete-overlay org-latex-fragment-image-overlays) + (setq org-latex-fragment-image-overlays nil)) + +(defun org-preview-latex-fragment (&optional subtree) + "Preview the LaTeX fragment at point, or all locally or globally. +If the cursor is in a LaTeX fragment, create the image and overlay +it over the source code. If there is no fragment at point, display +all fragments in the current text, from one headline to the next. With +prefix SUBTREE, display all fragments in the current subtree. With a +double prefix `C-u C-u', or when the cursor is before the first headline, +display all fragments in the buffer. +The images can be removed again with \\[org-ctrl-c-ctrl-c]." + (interactive "P") + (org-remove-latex-fragment-image-overlays) + (save-excursion + (save-restriction + (let (beg end at msg) + (cond + ((or (equal subtree '(16)) + (not (save-excursion + (re-search-backward (concat "^" outline-regexp) nil t)))) + (setq beg (point-min) end (point-max) + msg "Creating images for buffer...%s")) + ((equal subtree '(4)) + (org-back-to-heading) + (setq beg (point) end (org-end-of-subtree t) + msg "Creating images for subtree...%s")) + (t + (if (setq at (org-inside-LaTeX-fragment-p)) + (goto-char (max (point-min) (- (cdr at) 2))) + (org-back-to-heading)) + (setq beg (point) end (progn (outline-next-heading) (point)) + msg (if at "Creating image...%s" + "Creating images for entry...%s")))) + (message msg "") + (narrow-to-region beg end) + (org-format-latex + (concat "ltxpng/" (file-name-sans-extension + (file-name-nondirectory + buffer-file-name))) + default-directory 'overlays msg at) + (message msg "done. Use `C-c C-c' to remove images."))))) + +(defvar org-latex-regexps + '(("begin" "^[ \t]*\\(\\\\begin{\\([a-zA-Z0-9\\*]+\\)[^\000]+?\\\\end{\\2}\\)" 1 t) + ;; ("$" "\\([ (]\\|^\\)\\(\\(\\([$]\\)\\([^ \r\n,.$].*?\\(\n.*?\\)\\{0,5\\}[^ \r\n,.$]\\)\\4\\)\\)\\([ .,?;:'\")]\\|$\\)" 2 nil) + ;; \000 in the following regex is needed for org-inside-LaTeX-fragment-p + ("$" "\\([^$]\\)\\(\\(\\$\\([^ \r\n,;.$][^$\n\r]*?\\(\n[^$\n\r]*?\\)\\{0,2\\}[^ \r\n,.$]\\)\\$\\)\\)\\([ .,?;:'\")\000]\\|$\\)" 2 nil) + ("\\(" "\\\\([^\000]*?\\\\)" 0 nil) + ("\\[" "\\\\\\[[^\000]*?\\\\\\]" 0 t) + ("$$" "\\$\\$[^\000]*?\\$\\$" 0 t)) + "Regular expressions for matching embedded LaTeX.") + +(defun org-format-latex (prefix &optional dir overlays msg at) + "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)) + (absprefix (expand-file-name prefix dir)) + (todir (file-name-directory absprefix)) + (opt org-format-latex-options) + (matchers (plist-get opt :matchers)) + (re-list org-latex-regexps) + (cnt 0) txt link beg end re e checkdir + m n block linkfile movefile ov) + ;; Check if there are old images files with this prefix, and remove them + (when (file-directory-p todir) + (mapc 'delete-file + (directory-files + todir 'full + (concat (regexp-quote prefixnodir) "_[0-9]+\\.png$")))) + ;; Check the different regular expressions + (while (setq e (pop re-list)) + (setq m (car e) re (nth 1 e) n (nth 2 e) + block (if (nth 3 e) "\n\n" "")) + (when (member m matchers) + (goto-char (point-min)) + (while (re-search-forward re nil t) + (when (or (not at) (equal (cdr at) (match-beginning n))) + (setq txt (match-string n) + beg (match-beginning n) end (match-end n) + cnt (1+ cnt) + linkfile (format "%s_%04d.png" prefix cnt) + movefile (format "%s_%04d.png" absprefix cnt) + link (concat block "[[file:" linkfile "]]" block)) + (if msg (message msg cnt)) + (goto-char beg) + (unless checkdir ; make sure the directory exists + (setq checkdir t) + (or (file-directory-p todir) (make-directory todir))) + (org-create-formula-image + txt movefile opt) + (if overlays + (progn + (setq ov (org-make-overlay beg end)) + (if (featurep 'xemacs) + (progn + (org-overlay-put ov 'invisible t) + (org-overlay-put + ov 'end-glyph + (make-glyph (vector 'png :file movefile)))) + (org-overlay-put + ov 'display + (list 'image :type 'png :file movefile :ascent 'center))) + (push ov org-latex-fragment-image-overlays) + (goto-char end)) + (delete-region beg end) + (insert link)))))))) + +;; This function borrows from Ganesh Swami's latex2png.el +(defun org-create-formula-image (string tofile options) + (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"))) + (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")) + (let ((dir default-directory)) + (condition-case nil + (progn + (cd tmpdir) + (call-process "latex" nil nil nil texfile)) + (error nil)) + (cd dir)) + (if (not (file-exists-p dvifile)) + (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" + "-o" pngfile + dvifile) + (if (not (file-exists-p pngfile)) + (progn (message "Failed to create png file from %s" texfile) nil) + ;; Use the requested file name and clean up + (copy-file pngfile tofile 'replace) + (loop for e in '(".dvi" ".tex" ".aux" ".log" ".png") do + (delete-file (concat texfilebase e))) + pngfile)))) + +;;;; Exporting -;;; Exporting +;;; Variables, constants, and parameter plists (defconst org-level-max 20) @@ -13795,9 +16280,13 @@ overwritten, and the table is not marked as requiring realignment." "Should default preamble be inserted? Set by publishing functions.") (defvar org-export-html-auto-postamble t "Should default postamble be inserted? Set by publishing functions.") +(defvar org-current-export-file nil) ; dynamically scoped parameter +(defvar org-current-export-dir nil) ; dynamically scoped parameter + (defconst org-export-plist-vars '((:language . org-export-default-language) + (:customtime . org-display-custom-times) (:headline-levels . org-export-headline-levels) (:section-numbers . org-export-with-section-numbers) (:table-of-contents . org-export-with-toc) @@ -13871,20 +16360,6 @@ overwritten, and the table is not marked as requiring realignment." (match-string 1 options))))))))) p))) -(defun org-combine-plists (&rest plists) - "Create a single property list from all plists in PLISTS. -The process starts by copying the last list, and then setting properties -from the other lists. Settings in the first list are the most significant -ones and overrule settings in the other lists." - (let ((rtn (copy-sequence (pop plists))) - p v ls) - (while plists - (setq ls (pop plists)) - (while ls - (setq p (pop ls) v (pop ls)) - (setq rtn (plist-put rtn p v)))) - rtn)) - (defun org-export-directory (type plist) (let* ((val (plist-get plist :publishing-directory)) (dir (if (listp val) @@ -13972,8 +16447,6 @@ ones and overrule settings in the other lists." (call-interactively (cdr ass)) (error "No command associated with key %c" r1)))) -;; ASCII - (defconst org-html-entities '(("nbsp") ("iexcl") @@ -14272,6 +16745,8 @@ The list contains HTML entities for Latin-1, Greek and other symbols. It is supplemented by a number of commonly used TeX macros with appropriate translations. There is currently no way for users to extend this.") +;;; 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." (interactive) @@ -14280,12 +16755,16 @@ translations. There is currently no way for users to extend this.") (re-plain-link (concat "\\([^[<]\\)" org-plain-link-re)) (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")) (erase-buffer) (insert string) (let ((org-inhibit-startup t)) (org-mode)) + (untabify (point-min) (point-max)) ;; Get rid of archived trees (when (not (eq org-export-with-archived-trees t)) @@ -14298,6 +16777,32 @@ translations. There is currently no way for users to extend this.") (if org-export-with-archived-trees (1+ (point-at-eol)) (point)) (org-end-of-subtree t))))) + ;; Protect stuff from HTML processing + (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 + (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)))) + (goto-char (point-min)) + (while (re-search-forward re-quote nil t) + (goto-char (match-beginning 0)) + (end-of-line 1) + (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 (goto-char (point-min)) @@ -14313,13 +16818,15 @@ translations. There is currently no way for users to extend this.") (goto-char (point-min)) (when re-radio (while (re-search-forward re-radio nil t) - (replace-match "\\1[[\\2]]"))) + (org-if-unprotected + (replace-match "\\1[[\\2]]")))) ;; Find all links that contain a newline and put them into a single line (goto-char (point-min)) (while (re-search-forward "\\(\\(\\[\\|\\]\\)\\[[^]]*?\\)[ \t]*\n[ \t]*\\([^]]*\\]\\(\\[\\|\\]\\)\\)" nil t) - (replace-match "\\1 \\3") - (goto-char (match-beginning 0))) + (org-if-unprotected + (replace-match "\\1 \\3") + (goto-char (match-beginning 0)))) ;; Convert LaTeX fragments to images (when (memq :LaTeX-fragments parameters) @@ -14334,91 +16841,103 @@ translations. There is currently no way for users to extend this.") ;; Expand link abbreviations (goto-char (point-min)) (while (re-search-forward re-plain-link nil t) - (replace-match - (concat - (match-string 1) "[[" (match-string 2) ":" (match-string 3) "]]") - t t)) + (org-if-unprotected + (replace-match + (concat + (match-string 1) "[[" (match-string 2) ":" (match-string 3) "]]") + t t))) (goto-char (point-min)) (while (re-search-forward re-angle-link nil t) - (replace-match - (concat - (match-string 1) "[[" (match-string 2) ":" (match-string 3) "]]") - t t)) + (org-if-unprotected + (replace-match + (concat + (match-string 1) "[[" (match-string 2) ":" (match-string 3) "]]") + t t))) (goto-char (point-min)) (while (re-search-forward org-bracket-link-regexp nil t) - (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)) + (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))) ;; Find multiline emphasis and put them into single line (when (memq :emph-multiline parameters) (goto-char (point-min)) (while (re-search-forward org-emph-re nil t) - (subst-char-in-region (match-beginning 0) (match-end 0) ?\n ?\ t) - (goto-char (1- (match-end 0))))) + (org-if-unprotected + (subst-char-in-region (match-beginning 0) (match-end 0) ?\n ?\ t) + (goto-char (1- (match-end 0)))))) (setq rtn (buffer-string))) (kill-buffer " org-mode-tmp") rtn)) (defun org-solidify-link-text (s &optional alist) - "Take link text and make a safe target out of it." - (save-match-data - (let* ((rtn - (mapconcat - 'identity - (org-split-string s "[ \t\r\n]+") "--")) - (a (assoc rtn alist))) - (or (cdr a) rtn)))) - -(defun org-convert-to-odd-levels () - "Convert an org-mode file with all levels allowed to one with odd levels. -This will leave level 1 alone, convert level 2 to level 3, level 3 to -level 5 etc." - (interactive) - (when (yes-or-no-p "Are you sure you want to globally change levels to odd? ") - (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 (>= (setq n (1- n)) 0) - (org-demote)) - (end-of-line 1)))))) + "Take link text and make a safe target out of it." + (save-match-data + (let* ((rtn + (mapconcat + 'identity + (org-split-string s "[ \t\r\n]+") "--")) + (a (assoc rtn alist))) + (or (cdr a) rtn)))) +;; Variable holding the vector with section numbers +(defvar org-section-numbers (make-vector org-level-max 0)) -(defun org-convert-to-oddeven-levels () - "Convert an org-mode file with only odd levels to one with odd and even levels. -This promotes level 3 to level 2, level 5 to level 3 etc. If the file contains a -section with an even level, conversion would destroy the structure of the file. An error -is signaled in this case." - (interactive) - (goto-char (point-min)) - ;; First check if there are no even levels - (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 (>= (setq n (1- n)) 0) - (org-promote)) - (end-of-line 1)))))) +(defun org-init-section-numbers () + "Initialize the vector for the section numbers." + (let* ((level -1) + (numbers (nreverse (org-split-string "" "\\."))) + (depth (1- (length org-section-numbers))) + (i depth) number-string) + (while (>= i 0) + (if (> i level) + (aset org-section-numbers i 0) + (setq number-string (or (car numbers) "0")) + (if (string-match "\\`[A-Z]\\'" number-string) + (aset org-section-numbers i + (- (string-to-char number-string) ?A -1)) + (aset org-section-numbers i (string-to-number number-string))) + (pop numbers)) + (setq i (1- i))))) -(defun org-tr-level (n) - "Make N odd if required." - (if org-odd-levels-only (1+ (/ n 2)) n)) +(defun org-section-number (&optional level) + "Return a string with the current section number. +When LEVEL is non-nil, increase section numbers on that level." + (let* ((depth (1- (length org-section-numbers))) idx n (string "")) + (when level + (when (> level -1) + (aset org-section-numbers + level (1+ (aref org-section-numbers level)))) + (setq idx (1+ level)) + (while (<= idx depth) + (if (not (= idx 1)) + (aset org-section-numbers idx 0)) + (setq idx (1+ idx)))) + (setq idx 0) + (while (<= idx depth) + (setq n (aref org-section-numbers idx)) + (setq string (concat string (if (not (string= string "")) "." "") + (int-to-string n))) + (setq idx (1+ idx))) + (save-match-data + (if (string-match "\\`\\([@0]\\.\\)+" string) + (setq string (replace-match "" t nil string))) + (if (string-match "\\(\\.0\\)+\\'" string) + (setq string (replace-match "" t nil string)))) + string)) + +;;; ASCII export (defvar org-last-level nil) ; dynamically scoped variable +(defvar org-levels-open nil) ; dynamically scoped parameter (defvar org-ascii-current-indentation nil) ; For communication (defun org-export-as-ascii (arg) @@ -14434,15 +16953,16 @@ underlined headlines. The default is 3." (buffer-substring (if (org-region-active-p) (region-beginning) (point-min)) (if (org-region-active-p) (region-end) (point-max)))) + (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)) - (org-startup-with-deadline-check nil) (level 0) line txt (umax nil) + (umax-toc nil) (case-fold-search nil) (filename (concat (file-name-as-directory (org-export-directory :ascii opt-plist)) @@ -14450,7 +16970,7 @@ underlined headlines. The default is 3." (file-name-nondirectory buffer-file-name)) ".txt")) (buffer (find-file-noselect filename)) - (levels-open (make-vector org-level-max nil)) + (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))) @@ -14461,7 +16981,7 @@ underlined headlines. The default is 3." (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 "\\>\\)")) +; (quote-re (concat "^\\(\\*+\\)\\([ \t]*" org-quote-string "\\>\\)")) (text nil) (todo nil) (lang-words nil)) @@ -14473,9 +16993,7 @@ underlined headlines. The default is 3." (setq lang-words (or (assoc language org-export-language-setup) (assoc "en" org-export-language-setup))) - (if org-export-ascii-show-new-buffer - (switch-to-buffer-other-window buffer) - (set-buffer buffer)) + (switch-to-buffer-other-window buffer) (erase-buffer) (fundamental-mode) ;; create local variables for all options, to make sure all called @@ -14487,6 +17005,9 @@ underlined headlines. The default is 3." (org-set-local 'org-odd-levels-only odd) (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 (if title (org-insert-centered title ?=)) @@ -14520,7 +17041,7 @@ underlined headlines. The default is 3." org-done-string))) ; TODO, not DONE (and org-export-mark-todo-in-toc - (= level umax) + (= level umax-toc) (org-search-todo-below line lines level)))) (setq txt (org-html-expand-for-ascii txt)) @@ -14534,7 +17055,7 @@ underlined headlines. The default is 3." (if org-export-with-section-numbers (setq txt (concat (org-section-number level) " " txt))) - (if (<= level umax) + (if (<= level umax-toc) (progn (insert (make-string (* (1- level) 4) ?\ ) @@ -14555,6 +17076,8 @@ underlined headlines. The default is 3." (setq line (replace-match (if (match-end 3) "[\\3]" "[\\1]") t nil line))) + (when custom-times + (setq line (org-translate-time line))) (cond ((string-match "^\\(\\*+\\)[ \t]*\\(.*\\)" line) ;; a Headline @@ -14709,7 +17232,7 @@ command." (not (get-char-property s 'invisible)))) s)) -;; HTML +;;; HTML export (defun org-get-current-options () "Return a string with current options as keyword options. @@ -14724,7 +17247,7 @@ Does include HTML export options as well as TODO and CATEGORY stuff." #+CATEGORY: %s #+SEQ_TODO: %s #+TYP_TODO: %s -#+STARTUP: %s %s %s %s %s %s +#+STARTUP: %s %s %s %s %s #+TAGS: %s #+ARCHIVE: %s #+LINK: %s @@ -14750,11 +17273,14 @@ Does include HTML export options as well as TODO and CATEGORY stuff." "Me Jason Marie DONE") (cdr (assoc org-startup-folded '((nil . "showall") (t . "overview") (content . "content")))) - (if org-startup-with-deadline-check "dlcheck" "nodlcheck") (if org-odd-levels-only "odd" "oddeven") (if org-hide-leading-stars "hidestars" "showstars") (if org-startup-align-all-tables "align" "noalign") - (if org-log-done "logging" "nologging") + (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 " "))) (or (mapconcat (lambda (x) (cond ((equal '(:startgroup) x) "{") @@ -14849,6 +17375,7 @@ org-mode's default settings, but still inferior to file-local settings." (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-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))) @@ -14869,13 +17396,14 @@ org-mode's default settings, but still inferior to file-local settings." (all_lines (org-skip-comments (org-split-string (org-cleaned-string-for-export - region :emph-multiline + 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 @@ -14883,7 +17411,7 @@ org-mode's default settings, but still inferior to file-local settings." ".html")) (current-dir (file-name-directory buffer-file-name)) (buffer (find-file-noselect filename)) - (levels-open (make-vector org-level-max nil)) + (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))) (author (plist-get opt-plist :author)) @@ -14927,7 +17455,7 @@ org-mode's default settings, but still inferior to file-local settings." (assoc "en" org-export-language-setup))) ;; Switch to the output buffer - (if (or hidden (not org-export-html-show-new-buffer)) + (if (or hidden t) (set-buffer buffer) (switch-to-buffer-other-window buffer)) (erase-buffer) @@ -14942,6 +17470,9 @@ org-mode's default settings, but still inferior to file-local settings." 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 @@ -14994,7 +17525,7 @@ lang=\"%s\" xml:lang=\"%s\"> org-done-string))) ; TODO, not DONE (and org-export-mark-todo-in-toc - (= level umax) + (= level umax-toc) (org-search-todo-below line lines level)))) (if (and (memq org-export-with-tags '(not-in-toc nil)) @@ -15005,7 +17536,7 @@ lang=\"%s\" xml:lang=\"%s\"> (if org-export-with-section-numbers (setq txt (concat (org-section-number level) " " txt))) - (if (<= level umax) + (if (<= level umax-toc) (progn (setq head-count (+ head-count 1)) (if (> level org-last-level) @@ -15075,6 +17606,15 @@ lang=\"%s\" xml:lang=\"%s\"> (insert "\n")) (throw 'nextline nil)) + ;; Protected HTML + (when (get-text-property 0 'org-protected line) + (insert line "\n") + (throw 'nextline nil)) + + ;; Horizontal line + (when (string-match "^[ \t]*-\\{5,\\}[ \t]*$" line) + (insert "\n
\n") + (throw 'nextline nil)) ;; make targets to anchors (while (string-match "<<]*\\)>>>?\\((INVISIBLE)\\)?[ \t]*\n?" line) @@ -15114,6 +17654,12 @@ lang=\"%s\" xml:lang=\"%s\"> desc2 (if (match-end 2) (concat type ":" path) path) descp (and desc1 (not (equal desc1 desc2))) desc (or desc1 desc2)) + ;; Make an image out of the description if that is so wanted + (when (and descp (org-file-image-p desc)) + (save-match-data + (if (string-match "^file:" desc) + (setq desc (substring desc (match-end 0))))) + (setq desc (concat ""))) ;; FIXME: do we need to unescape here somewhere? (cond ((equal type "internal") @@ -15122,7 +17668,15 @@ lang=\"%s\" xml:lang=\"%s\"> "" desc ""))) - ((member type '("http" "https" "ftp" "mailto" "news")) + ((member type '("http" "https")) ; FIXME: need to test this. + ;; 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))) + (org-file-image-p path)) + (setq rpl (concat "")) + (setq link (concat type ":" path)) + (setq rpl (concat "" desc "")))) + ((member type '("ftp" "mailto" "news")) ;; standard URL (setq link (concat type ":" path)) (setq rpl (concat "" desc ""))) @@ -15139,8 +17693,7 @@ lang=\"%s\" xml:lang=\"%s\"> (if (functionp link-validate) (funcall link-validate filename current-dir) t)) - (setq file-is-image-p - (string-match (org-image-file-name-regexp) filename)) + (setq file-is-image-p (org-file-image-p filename)) (setq thefile (if abs-p (expand-file-name filename) filename)) (when (and org-export-html-link-org-files-as-html (string-match "\\.org$" thefile)) @@ -15351,8 +17904,9 @@ lang=\"%s\" xml:lang=\"%s\"> ;; Need to use the code generator in table.el, with the original text. (org-format-table-table-html-using-table-generate-source olines))))) -(defun org-format-org-table-html (lines) +(defun org-format-org-table-html (lines &optional splice) "Format a table into HTML." + ;; 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))) @@ -15360,52 +17914,79 @@ lang=\"%s\" xml:lang=\"%s\"> (when org-export-table-remove-special-lines ;; Check if the table has a marking column. If yes remove the ;; column and the special lines - (let* ((special - (not - (memq nil - (mapcar - (lambda (x) - (or (string-match "^[ \t]*|-" x) - (string-match "^[ \t]*| *\\([#!$*_^ ]\\) *|" x))) - lines))))) - (if special - (setq lines - (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)))) - lines)))))) + (setq lines (org-table-clean-before-export lines))) (let ((head (and org-export-highlight-first-table-line (delq nil (mapcar (lambda (x) (string-match "^[ \t]*|-" x)) (cdr lines))))) - line fields html) - (setq html (concat org-export-html-table-tag "\n")) + (nlines 0) fnum i + tbopen line fields html) + (if splice (setq head nil)) + (unless splice (push (if head "" "") html)) + (setq tbopen t) (while (setq line (pop lines)) (catch 'next-line (if (string-match "^[ \t]*|-" line) (progn + (unless splice + (push (if head "" "") html) + (if lines (push "" html) (setq tbopen nil))) (setq head nil) ;; head ends here, first time around ;; ignore this line (throw 'next-line t))) ;; Break the line into fields (setq fields (org-split-string line "[ \t]*|[ \t]*")) - (setq html (concat - html - "" - (mapconcat (lambda (x) - (if head - (concat "") - (concat ""))) - fields "") - "\n")))) - (setq html (concat html "
" x "" x "
\n")) - html)) + (unless fnum (setq fnum (make-vector (length fields) 0))) + (setq nlines (1+ nlines) i -1) + (push (concat "" + (mapconcat + (lambda (x) + (setq i (1+ i)) + (if (and (< i nlines) + (string-match org-table-number-regexp x)) + (incf (aref fnum i))) + (if head + (concat "" x "") + (concat "" x ""))) + fields "") + "") + html))) + (unless splice (if tbopen (push "" html))) + (unless splice (push "\n" html)) + (setq html (nreverse html)) + (unless splice + ;; Put in COL tags with the alignment (unfortuntely often ignored...) + (push (mapconcat + (lambda (x) + (format "" + (if (> (/ (float x) nlines) org-table-number-fraction) + "right" "left"))) + fnum "") + html) + (push org-export-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." + (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) + (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)))) + lines)))) (defun org-fake-empty-table-line (line) "Replace everything except \"|\" with spaces." @@ -15494,7 +18075,8 @@ But it has the disadvantage, that Org-mode's HTML conversions cannot be used." (format "@%s @" (match-string 1 s))) (format " @%s@" - (substring (match-string 3 s) 1 -1))) + (substring + (org-translate-time (match-string 3 s)) 1 -1))) s (substring s (match-end 0))))) ;; Line break if line started and ended with time stamp stuff (if (not r) @@ -15623,198 +18205,70 @@ stacked delimiters is N. Escaping delimiters is not possible." (defun org-close-li () "Close
  • if necessary." (org-close-par-maybe) - (insert "
    • \n")) -; (when (save-excursion -; (re-search-backward "" nil t)) -; (if (member (match-string 0) '("" "" "
  • ")) -; (insert "
    • ")))) - -(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) - (if (aref levels-open (1- l)) - (progn - (org-html-level-close l) - (aset levels-open (1- l) nil))) - (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) - (setq title (replace-match - (if org-export-with-tags - (save-match-data - (concat - "   " - (mapconcat 'identity (org-split-string - (match-string 1 title) ":") - " ") - "")) - "") - t t title))) - (if (> level umax) - (progn - (if (aref levels-open (1- level)) - (progn - (org-close-li) - (insert "
  • " title "
    \n")) - (aset levels-open (1- level) t) - (org-close-par-maybe) - (insert "
      \n
    • " title "
      \n"))) - (if org-export-with-section-numbers - (setq title (concat (org-section-number level) " " title))) - (setq level (+ level org-export-html-toplevel-hlevel -1)) - (if with-toc - (insert (format "\n%s\n" - level head-count title level)) - (insert (format "\n%s\n" level title level))) - (org-open-par))))) - -(defun org-html-level-close (&rest args) - "Terminate one level in HTML export." - (org-close-li) - (insert "
    ")) - -;; Variable holding the vector with section numbers -(defvar org-section-numbers (make-vector org-level-max 0)) - -(defun org-init-section-numbers () - "Initialize the vector for the section numbers." - (let* ((level -1) - (numbers (nreverse (org-split-string "" "\\."))) - (depth (1- (length org-section-numbers))) - (i depth) number-string) - (while (>= i 0) - (if (> i level) - (aset org-section-numbers i 0) - (setq number-string (or (car numbers) "0")) - (if (string-match "\\`[A-Z]\\'" number-string) - (aset org-section-numbers i - (- (string-to-char number-string) ?A -1)) - (aset org-section-numbers i (string-to-number number-string))) - (pop numbers)) - (setq i (1- i))))) - -(defun org-section-number (&optional level) - "Return a string with the current section number. -When LEVEL is non-nil, increase section numbers on that level." - (let* ((depth (1- (length org-section-numbers))) idx n (string "")) - (when level - (when (> level -1) - (aset org-section-numbers - level (1+ (aref org-section-numbers level)))) - (setq idx (1+ level)) - (while (<= idx depth) - (if (not (= idx 1)) - (aset org-section-numbers idx 0)) - (setq idx (1+ idx)))) - (setq idx 0) - (while (<= idx depth) - (setq n (aref org-section-numbers idx)) - (setq string (concat string (if (not (string= string "")) "." "") - (int-to-string n))) - (setq idx (1+ idx))) - (save-match-data - (if (string-match "\\`\\([@0]\\.\\)+" string) - (setq string (replace-match "" t nil string))) - (if (string-match "\\(\\.0\\)+\\'" string) - (setq string (replace-match "" t nil string)))) - string)) - - -;;;###autoload -(defun org-export-icalendar-this-file () - "Export current file as an iCalendar file. -The iCalendar file will be located in the same directory as the Org-mode -file, but with extension `.ics'." - (interactive) - (org-export-icalendar nil buffer-file-name)) - -(defun org-export-as-xoxo-insert-into (buffer &rest output) - (with-current-buffer buffer - (apply 'insert output))) -(put 'org-export-as-xoxo-insert-into 'lisp-indent-function 1) - -(defun org-export-as-xoxo (&optional buffer) - "Export the org buffer as XOXO. -The XOXO buffer is named *xoxo-*" - (interactive (list (current-buffer))) - ;; A quickie abstraction - - ;; 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) - (org-infile-export-plist))) - (filename (concat (file-name-as-directory - (org-export-directory :xoxo opt-plist)) - (file-name-sans-extension - (file-name-nondirectory buffer-file-name)) - ".html")) - (out (find-file-noselect filename)) - (last-level 1) - (hanging-li nil)) - ;; Check the output buffer is empty. - (with-current-buffer out (erase-buffer)) - ;; Kick off the output - (org-export-as-xoxo-insert-into out "
      \n") - (while (re-search-forward "^\\(\\*+\\) \\(.+\\)" (point-max) 't) - (let* ((hd (match-string-no-properties 1)) - (level (length hd)) - (text (concat - (match-string-no-properties 2) - (save-excursion - (goto-char (match-end 0)) - (let ((str "")) - (catch 'loop - (while 't - (forward-line) - (if (looking-at "^[ \t]\\(.*\\)") - (setq str (concat str (match-string-no-properties 1))) - (throw 'loop str))))))))) - - ;; Handle level rendering - (cond - ((> level last-level) - (org-export-as-xoxo-insert-into out "\n
        \n")) - - ((< level last-level) - (dotimes (- (- last-level level) 1) - (if hanging-li - (org-export-as-xoxo-insert-into out "\n")) - (org-export-as-xoxo-insert-into out "
      \n")) - (when hanging-li - (org-export-as-xoxo-insert-into out "\n") - (setq hanging-li nil))) - - ((equal level last-level) - (if hanging-li - (org-export-as-xoxo-insert-into out "\n"))) - ) + (insert "\n")) +; (when (save-excursion +; (re-search-backward "" nil t)) +; (if (member (match-string 0) '("" "
    " "
  • ")) +; (insert "
    • ")))) - (setq last-level level) +(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) + (if (aref org-levels-open (1- l)) + (progn + (org-html-level-close l) + (aset org-levels-open (1- l) nil))) + (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) + (setq title (replace-match + (if org-export-with-tags + (save-match-data + (concat + "   " + (mapconcat 'identity (org-split-string + (match-string 1 title) ":") + " ") + "")) + "") + t t title))) + (if (> level umax) + (progn + (if (aref org-levels-open (1- level)) + (progn + (org-close-li) + (insert "
  • " title "
    \n")) + (aset org-levels-open (1- level) t) + (org-close-par-maybe) + (insert "
      \n
    • " title "
      \n"))) + (if org-export-with-section-numbers + (setq title (concat (org-section-number level) " " title))) + (setq level (+ level org-export-html-toplevel-hlevel -1)) + (if with-toc + (insert (format "\n%s\n" + level head-count title level)) + (insert (format "\n%s\n" level title level))) + (org-open-par))))) - ;; And output the new li - (setq hanging-li 't) - (if (equal ?+ (elt text 0)) - (org-export-as-xoxo-insert-into out "
    • ") - (org-export-as-xoxo-insert-into out "
    • " text)))) +(defun org-html-level-close (&rest args) + "Terminate one level in HTML export." + (org-close-li) + (insert "
    ")) - ;; Finally finish off the ol - (dotimes (- last-level 1) - (if hanging-li - (org-export-as-xoxo-insert-into out "
    • \n")) - (org-export-as-xoxo-insert-into out "\n")) +;;; iCalendar export - ;; Finish the buffer off and clean it up. - (switch-to-buffer-other-window out) - (indent-region (point-min) (point-max) nil) - (save-buffer) - (goto-char (point-min)) - ))) +;;;###autoload +(defun org-export-icalendar-this-file () + "Export current file as an iCalendar file. +The iCalendar file will be located in the same directory as the Org-mode +file, but with extension `.ics'." + (interactive) + (org-export-icalendar nil buffer-file-name)) ;;;###autoload (defun org-export-icalendar-all-agenda-files () @@ -15868,7 +18322,7 @@ file and store it under the name `org-combined-agenda-icalendar-file'." (and (not started) (setq started t) (org-start-icalendar-file org-icalendar-combined-name)) (org-start-icalendar-file category)) - (org-print-icalendar-entries combine category) + (org-print-icalendar-entries combine) (when (or (and combine (not files)) (not combine)) (org-finish-icalendar-file) (set-buffer ical-buffer) @@ -15882,21 +18336,24 @@ The iCalendar buffer is still current when this hook is run. A good way to use this is to tell a desktop calenndar application to re-read the iCalendar file.") -(defun org-print-icalendar-entries (&optional combine category) +(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)) (dts (org-ical-ts-to-string (format-time-string (cdr org-time-stamp-formats) (current-time)) "DTSTART")) - hd ts ts2 state (inc t) pos scheduledp deadlinep tmp pri) + hd ts ts2 state status (inc t) pos + scheduledp deadlinep tmp pri category) (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)) + hd (org-get-heading) + category (org-get-category)) (if (looking-at re2) (progn (goto-char (match-end 0)) @@ -15912,28 +18369,35 @@ When COMBINE is non nil, add the category to each line." (if (or (string-match org-tr-regexp hd) (string-match org-ts-regexp hd)) (setq hd (replace-match "" t t hd))) - (if combine - (setq hd (concat hd " (category " category ")"))) - (if deadlinep (setq hd (concat "DL: " hd " This is a deadline"))) - (if scheduledp (setq hd (concat "S: " hd " Scheduled for this date"))) + (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 %s %s SUMMARY:%s +CATEGORIES:%s END:VEVENT\n" (org-ical-ts-to-string ts "DTSTART") (org-ical-ts-to-string ts2 "DTEND" inc) - hd))) + hd category))) (when org-icalendar-include-todo (goto-char (point-min)) (while (re-search-forward org-todo-line-regexp nil t) - (setq state (match-string 1)) - (unless (equal state org-done-string) + (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))))) + (substring hd (match-end 1)))) (setq pri org-default-priority)) (setq pri (floor (1+ (* 8. (/ (float (- org-lowest-priority pri)) (- org-lowest-priority ?A)))))) @@ -15941,10 +18405,12 @@ END:VEVENT\n" (princ (format "BEGIN:VTODO %s SUMMARY:%s +CATEGORIES:%s SEQUENCE:1 PRIORITY:%d +STATUS:%s END:VTODO\n" - dts hd pri)))))))) + dts hd category pri status)))))))) (defun org-start-icalendar-file (name) "Start an iCalendar file by inserting the header." @@ -15981,294 +18447,93 @@ a time), or the day by one (if it does not contain a time)." (setq fmt (if have-time ":%Y%m%dT%H%M%S" ";VALUE=DATE:%Y%m%d")) (concat keyword (format-time-string fmt time)))) -;;; LaTeX stuff - -(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) - -(defvar org-cdlatex-texmathp-advice-is-done nil - "Flag remembering if we have applied the advice to texmathp already.") - -(define-minor-mode org-cdlatex-mode - "Toggle the minor `org-cdlatex-mode'. -This mode supports entering LaTeX environment and math in LaTeX fragments -in Org-mode. -\\{org-cdlatex-mode-map}" - nil " OCDL" nil - (when org-cdlatex-mode (require 'cdlatex)) - (unless org-cdlatex-texmathp-advice-is-done - (setq org-cdlatex-texmathp-advice-is-done t) - (defadvice texmathp (around org-math-always-on activate) - "Always return t in org-mode buffers. -This is because we want to insert math symbols without dollars even outside -the LaTeX math segments. If Orgmode thinks that point is actually inside -en embedded LaTeX fragement, let texmathp do its job. -\\[org-cdlatex-mode-map]" - (interactive) - (let (p) - (cond - ((not (org-mode-p)) ad-do-it) - ((eq this-command 'cdlatex-math-symbol) - (setq ad-return-value t - texmathp-why '("cdlatex-math-symbol in org-mode" . 0))) - (t - (let ((p (org-inside-LaTeX-fragment-p))) - (if (and p (member (car p) (plist-get org-format-latex-options :matchers))) - (setq ad-return-value t - texmathp-why '("Org-mode embedded math" . 0)) - (if p ad-do-it))))))))) - -(defun turn-on-org-cdlatex () - "Unconditionally turn on `org-cdlatex-mode'." - (org-cdlatex-mode 1)) - -(defun org-inside-LaTeX-fragment-p () - "Test if point is inside a LaTeX fragment. -I.e. after a \\begin, \\(, \\[, $, or $$, without the corresponding closing -sequence appearing also before point. -Even though the matchers for math are configurable, this function assumes -that \\begin, \\(, \\[, and $$ are always used. Only the single dollar -delimiters are skipped when they have been removed by customization. -The return value is nil, or a cons cell with the delimiter and -and the position of this delimiter. - -This function does a reasonably good job, but can locally be fooled by -for example currency specifications. For example it will assume being in -inline math after \"$22.34\". The LaTeX fragment formatter will only format -fragments that are properly closed, but during editing, we have to live -with the uncertainty caused by missing closing delimiters. This function -looks only before point, not after." - (catch 'exit - (let ((pos (point)) - (dodollar (member "$" (plist-get org-format-latex-options :matchers))) - (lim (progn - (re-search-backward (concat "^\\(" paragraph-start "\\)") nil t) - (point))) - dd-on str (start 0) m re) - (goto-char pos) - (when dodollar - (setq str (concat (buffer-substring lim (point)) "\000 X$.") - re (nth 1 (assoc "$" org-latex-regexps))) - (while (string-match re str start) - (cond - ((= (match-end 0) (length str)) - (throw 'exit (cons "$" (+ lim (match-beginning 0))))) - ((= (match-end 0) (- (length str) 5)) - (throw 'exit nil)) - (t (setq start (match-end 0)))))) - (when (setq m (re-search-backward "\\(\\\\begin{[^}]*}\\|\\\\(\\|\\\\\\[\\)\\|\\(\\\\end{[^}]*}\\|\\\\)\\|\\\\\\]\\)\\|\\(\\$\\$\\)" lim t)) - (goto-char pos) - (and (match-beginning 1) (throw 'exit (cons (match-string 1) m))) - (and (match-beginning 2) (throw 'exit nil)) - ;; count $$ - (while (re-search-backward "\\$\\$" lim t) - (setq dd-on (not dd-on))) - (goto-char pos) - (if dd-on (cons "$$" m)))))) +;;; XOXO export +(defun org-export-as-xoxo-insert-into (buffer &rest output) + (with-current-buffer buffer + (apply 'insert output))) +(put 'org-export-as-xoxo-insert-into 'lisp-indent-function 1) -(defun org-try-cdlatex-tab () - "Check if it makes sense to execute `cdlatex-tab', and do it if yes. -It makes sense to do so if `org-cdlatex-mode' is active and if the cursor is - - inside a LaTeX fragment, or - - after the first word in a line, where an abbreviation expansion could - insert a LaTeX environment." - (when org-cdlatex-mode - (cond - ((save-excursion - (skip-chars-backward "a-zA-Z0-9*") - (skip-chars-backward " \t") - (bolp)) - (cdlatex-tab) t) - ((org-inside-LaTeX-fragment-p) - (cdlatex-tab) t) - (t nil)))) +(defun org-export-as-xoxo (&optional buffer) + "Export the org buffer as XOXO. +The XOXO buffer is named *xoxo-*" + (interactive (list (current-buffer))) + ;; A quickie abstraction -(defun org-cdlatex-underscore-caret (&optional arg) - "Execute `cdlatex-sub-superscript' in LaTeX fragments. -Revert to the normal definition outside of these fragments." - (interactive "P") - (if (org-inside-LaTeX-fragment-p) - (call-interactively 'cdlatex-sub-superscript) - (let (org-cdlatex-mode) - (call-interactively (key-binding (vector last-input-event)))))) + ;; 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) + (org-infile-export-plist))) + (filename (concat (file-name-as-directory + (org-export-directory :xoxo opt-plist)) + (file-name-sans-extension + (file-name-nondirectory buffer-file-name)) + ".html")) + (out (find-file-noselect filename)) + (last-level 1) + (hanging-li nil)) + ;; Check the output buffer is empty. + (with-current-buffer out (erase-buffer)) + ;; Kick off the output + (org-export-as-xoxo-insert-into out "
      \n") + (while (re-search-forward "^\\(\\*+\\) \\(.+\\)" (point-max) 't) + (let* ((hd (match-string-no-properties 1)) + (level (length hd)) + (text (concat + (match-string-no-properties 2) + (save-excursion + (goto-char (match-end 0)) + (let ((str "")) + (catch 'loop + (while 't + (forward-line) + (if (looking-at "^[ \t]\\(.*\\)") + (setq str (concat str (match-string-no-properties 1))) + (throw 'loop str))))))))) -(defun org-cdlatex-math-modify (&optional arg) - "Execute `cdlatex-math-modify' in LaTeX fragments. -Revert to the normal definition outside of these fragments." - (interactive "P") - (if (org-inside-LaTeX-fragment-p) - (call-interactively 'cdlatex-math-modify) - (let (org-cdlatex-mode) - (call-interactively (key-binding (vector last-input-event)))))) + ;; Handle level rendering + (cond + ((> level last-level) + (org-export-as-xoxo-insert-into out "\n
        \n")) -(defvar org-latex-fragment-image-overlays nil - "List of overlays carrying the images of latex fragments.") -(make-variable-buffer-local 'org-latex-fragment-image-overlays) + ((< level last-level) + (dotimes (- (- last-level level) 1) + (if hanging-li + (org-export-as-xoxo-insert-into out "\n")) + (org-export-as-xoxo-insert-into out "
      \n")) + (when hanging-li + (org-export-as-xoxo-insert-into out "\n") + (setq hanging-li nil))) -(defun org-remove-latex-fragment-image-overlays () - "Remove all overlays with LaTeX fragment images in current buffer." - (mapc 'org-delete-overlay org-latex-fragment-image-overlays) - (setq org-latex-fragment-image-overlays nil)) + ((equal level last-level) + (if hanging-li + (org-export-as-xoxo-insert-into out "\n"))) + ) -(defun org-preview-latex-fragment (&optional subtree) - "Preview the LaTeX fragment at point, or all locally or globally. -If the cursor is in a LaTeX fragment, create the image and overlay -it over the source code. If there is no fragment at point, display -all fragments in the current text, from one headline to the next. With -prefix SUBTREE, display all fragments in the current subtree. With a -double prefix `C-u C-u', or when the cursor is before the first headline, -display all fragments in the buffer. -The images can be removed again with \\[org-ctrl-c-ctrl-c]." - (interactive "P") - (org-remove-latex-fragment-image-overlays) - (save-excursion - (save-restriction - (let (beg end at msg) - (cond - ((or (equal subtree '(16)) - (not (save-excursion - (re-search-backward (concat "^" outline-regexp) nil t)))) - (setq beg (point-min) end (point-max) - msg "Creating images for buffer...%s")) - ((equal subtree '(4)) - (org-back-to-heading) - (setq beg (point) end (org-end-of-subtree t) - msg "Creating images for subtree...%s")) - (t - (if (setq at (org-inside-LaTeX-fragment-p)) - (goto-char (max (point-min) (- (cdr at) 2))) - (org-back-to-heading)) - (setq beg (point) end (progn (outline-next-heading) (point)) - msg (if at "Creating image...%s" - "Creating images for entry...%s")))) - (message msg "") - (narrow-to-region beg end) - (org-format-latex - (concat "ltxpng/" (file-name-sans-extension - (file-name-nondirectory - buffer-file-name))) - default-directory 'overlays msg at) - (message msg "done. Use `C-c C-c' to remove images."))))) + (setq last-level level) -(defvar org-latex-regexps - '(("begin" "^[ \t]*\\(\\\\begin{\\([a-zA-Z0-9\\*]+\\)[^\000]+?\\\\end{\\2}\\)" 1 t) - ;; ("$" "\\([ (]\\|^\\)\\(\\(\\([$]\\)\\([^ \r\n,.$].*?\\(\n.*?\\)\\{0,5\\}[^ \r\n,.$]\\)\\4\\)\\)\\([ .,?;:'\")]\\|$\\)" 2 nil) - ;; \000 in the following regex is needed for org-inside-LaTeX-fragment-p - ("$" "\\([^$]\\)\\(\\(\\$\\([^ \r\n,;.$][^$\n\r]*?\\(\n[^$\n\r]*?\\)\\{0,2\\}[^ \r\n,.$]\\)\\$\\)\\)\\([ .,?;:'\")\000]\\|$\\)" 2 nil) - ("\\(" "\\\\([^\000]*?\\\\)" 0 nil) - ("\\[" "\\\\\\[[^\000]*?\\\\\\]" 0 t) - ("$$" "\\$\\$[^\000]*?\\$\\$" 0 t)) - "Regular expressions for matching embedded LaTeX.") + ;; And output the new li + (setq hanging-li 't) + (if (equal ?+ (elt text 0)) + (org-export-as-xoxo-insert-into out "
    1. ") + (org-export-as-xoxo-insert-into out "
    2. " text)))) -(defun org-format-latex (prefix &optional dir overlays msg at) - "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)) - (absprefix (expand-file-name prefix dir)) - (todir (file-name-directory absprefix)) - (opt org-format-latex-options) - (matchers (plist-get opt :matchers)) - (re-list org-latex-regexps) - (cnt 0) txt link beg end re e oldfiles - m n block linkfile movefile ov) - ;; Make sure the directory exists - (or (file-directory-p todir) (make-directory todir)) - ;; Check if there are old images files with this prefix, and remove them - (setq oldfiles (directory-files - todir 'full - (concat (regexp-quote prefixnodir) "_[0-9]+\\.png$"))) - (while oldfiles (delete-file (pop oldfiles))) - ;; Check the different regular expressions - (while (setq e (pop re-list)) - (setq m (car e) re (nth 1 e) n (nth 2 e) - block (if (nth 3 e) "\n\n" "")) - (when (member m matchers) - (goto-char (point-min)) - (while (re-search-forward re nil t) - (when (or (not at) (equal (cdr at) (match-beginning n))) - (setq txt (match-string n) - beg (match-beginning n) end (match-end n) - cnt (1+ cnt) - linkfile (format "%s_%04d.png" prefix cnt) - movefile (format "%s_%04d.png" absprefix cnt) - link (concat block "[[file:" linkfile "]]" block)) - (if msg (message msg cnt)) - (goto-char beg) - (org-create-formula-image - txt movefile opt) - (if overlays - (progn - (setq ov (org-make-overlay beg end)) - (if (featurep 'xemacs) - (progn - (org-overlay-put ov 'invisible t) - (org-overlay-put - ov 'end-glyph - (make-glyph (vector 'png :file movefile)))) - (org-overlay-put - ov 'display - (list 'image :type 'png :file movefile :ascent 'center))) - (push ov org-latex-fragment-image-overlays) - (goto-char end)) - (delete-region beg end) - (insert link)))))))) + ;; Finally finish off the ol + (dotimes (- last-level 1) + (if hanging-li + (org-export-as-xoxo-insert-into out "
      3. \n")) + (org-export-as-xoxo-insert-into out "
    \n")) -;; This function borrows from Ganesh Swami's latex2png.el -(defun org-create-formula-image (string tofile options) - (let* ((tmpdir (if (featurep 'xemacs) - (temp-directory) - temporary-file-directory)) - (texfilebase (make-temp-name - (expand-file-name "orgtex" tmpdir))) + ;; Finish the buffer off and clean it up. + (switch-to-buffer-other-window out) + (indent-region (point-min) (point-max) nil) + (save-buffer) + (goto-char (point-min)) + ))) -;(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"))) - (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")) - (let ((dir default-directory)) - (condition-case nil - (progn - (cd tmpdir) - (call-process "latex" nil nil nil texfile)) - (error nil)) - (cd dir)) - (if (not (file-exists-p dvifile)) - (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" - "-o" pngfile - dvifile) - (if (not (file-exists-p pngfile)) - (progn (message "Failed to create png file from %s" texfile) nil) - ;; Use the requested file name and clean up - (copy-file pngfile tofile 'replace) - (loop for e in '(".dvi" ".tex" ".aux" ".log" ".png") do - (delete-file (concat texfilebase e))) - pngfile)))) -;;; Key bindings +;;;; Key bindings ;; - Bindings in Org-mode map are currently ;; 0123456789abcdefghijklmnopqrstuvwxyz!?@#$%^&-+*/=()_{}[]:;"|,.<>~`'\t the alphabet @@ -16286,6 +18551,7 @@ The images can be removed again with \\[org-ctrl-c-ctrl-c]." (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) ;; The following line is necessary under Suse GNU/Linux (unless (featurep 'xemacs) (define-key org-mode-map [S-iso-lefttab] 'org-shifttab)) @@ -16311,12 +18577,12 @@ The images can be removed again with \\[org-ctrl-c-ctrl-c]." (define-key org-mode-map (org-key 'S-left) 'org-shiftleft) (define-key org-mode-map (org-key 'S-right) 'org-shiftright) -;; Extra keys for tty access. We only set them when really needed -;; because otherwise the menus don't show the simple keys +;;; Extra keys for tty access. +;; We only set them when really needed because otherwise the +;; menus don't show the simple keys (when (or (featurep 'xemacs) ;; because XEmacs supports multi-device stuff (not window-system)) - (define-key org-mode-map "\M-\C-i" 'org-complete) (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) @@ -16337,14 +18603,16 @@ The images can be removed again with \\[org-ctrl-c-ctrl-c]." (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)) - + ;; 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) @@ -16356,6 +18624,8 @@ The images can be removed again with \\[org-ctrl-c-ctrl-c]." (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) @@ -16368,31 +18638,34 @@ The images can be removed again with \\[org-ctrl-c-ctrl-c]." (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-table-sort-lines) -(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-current-column) -(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\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-" '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) @@ -16524,6 +18797,9 @@ See the individual commands for more information." (interactive "P") (cond ((org-at-table-p) (call-interactively 'org-table-previous-field)) + (arg (message "Content view to level: ") + (org-content (prefix-numeric-value arg)) + (setq org-cycle-global-status 'overview)) (t (call-interactively 'org-global-cycle)))) (defun org-shiftmetaleft () @@ -16803,9 +19079,7 @@ See the individual commands for more information." ["Move Column Left" org-metaleft (org-at-table-p)] ["Move Column Right" org-metaright (org-at-table-p)] ["Delete Column" org-shiftmetaleft (org-at-table-p)] - ["Insert Column" org-shiftmetaright (org-at-table-p)] - "--" - ["Enable Narrowing" (setq org-table-limit-column-width (not org-table-limit-column-width)) :active (org-at-table-p) :selected org-table-limit-column-width :style toggle]) + ["Insert Column" org-shiftmetaright (org-at-table-p)]) ("Row" ["Move Row Up" org-metaup (org-at-table-p)] ["Move Row Down" org-metadown (org-at-table-p)] @@ -16822,19 +19096,24 @@ See the individual commands for more information." "--" ("Calculate" ["Set Column Formula" org-table-eval-formula (org-at-table-p)] - ["Set Named Field Formula" (org-table-eval-formula '(4)) :active (org-at-table-p) :keys "C-u C-c ="] + ["Set Field Formula" (org-table-eval-formula '(4)) :active (org-at-table-p) :keys "C-u C-c ="] ["Edit Formulas" org-table-edit-formulas (org-at-table-p)] "--" ["Recalculate line" org-table-recalculate (org-at-table-p)] ["Recalculate all" (lambda () (interactive) (org-table-recalculate '(4))) :active (org-at-table-p) :keys "C-u C-c *"] + ["Iterate all" (lambda () (interactive) (org-table-recalculate '(16))) :active (org-at-table-p) :keys "C-u C-u C-c *"] + "--" ["Toggle Recalculate Mark" org-table-rotate-recalc-marks (org-at-table-p)] "--" ["Sum Column/Rectangle" org-table-sum (or (org-at-table-p) (org-region-active-p))] ["Which Column?" org-table-current-column (org-at-table-p)]) ["Debug Formulas" - (setq org-table-formula-debug (not org-table-formula-debug)) + org-table-toggle-formula-debugger :style toggle :selected org-table-formula-debug] + ["Show Col/Row Numbers" + org-table-toggle-coordinate-overlays + :style toggle :selected org-table-overlay-coordinates] "--" ["Create" org-table-create (and (not (org-at-table-p)) org-enable-table-editor)] @@ -16851,7 +19130,9 @@ See the individual commands for more information." ["Cycle Global Visibility" org-shifttab (not (org-at-table-p))] ["Sparse Tree" org-occur t] ["Reveal Context" org-reveal t] - ["Show All" show-all t]) + ["Show All" show-all t] + "--" + ["Subtree to indirect buffer" org-tree-to-indirect-buffer t]) "--" ["New Heading" org-insert-heading t] ("Navigate Headings" @@ -16875,12 +19156,14 @@ See the individual commands for more information." ["Demote Heading" org-metaright (not (org-at-table-p))] ["Demote Subtree" org-shiftmetaright (not (org-at-table-p))] "--" + ["Sort Region/Children" org-sort (not (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]) ("Archive" ["Toggle ARCHIVE tag" org-toggle-archive-tag t] - ["Check and Tag Children" (org-toggle-archive-tag (4)) - :active t :keys "C-u C-c C-x C-a"] +; ["Check and Tag Children" (org-toggle-archive-tag (4)) +; :active t :keys "C-u C-c C-x C-a"] ["Sparse trees open ARCHIVE trees" (setq org-sparse-tree-open-archived-trees (not org-sparse-tree-open-archived-trees)) @@ -16892,9 +19175,10 @@ See the individual commands for more information." (setq org-agenda-skip-archived-trees (not org-agenda-skip-archived-trees)) :style toggle :selected (not org-agenda-skip-archived-trees)] "--" - ["Move Subtree to Archive" org-archive-subtree t] - ["Check and Move Children" (org-archive-subtree '(4)) - :active t :keys "C-u C-c $"]) + ["Move Subtree to Archive" org-advertized-archive-subtree t] + ; ["Check and Move Children" (org-archive-subtree '(4)) + ; :active t :keys "C-u C-c C-x C-s"] + ) "--" ("TODO Lists" ["TODO/DONE/-" org-todo t] @@ -16961,17 +19245,16 @@ See the individual commands for more information." ["Insert Link" org-insert-link t] ["Follow Link" org-open-at-point t] "--" + ["Next link" org-next-link t] + ["Previous link" org-previous-link t] + "--" ["Descriptive Links" (progn (org-add-to-invisibility-spec '(org-link)) (org-restart-font-lock)) :style radio :selected (member '(org-link) buffer-invisibility-spec)] ["Literal Links" (progn (org-remove-from-invisibility-spec '(org-link)) (org-restart-font-lock)) - :style radio :selected (not (member '(org-link) buffer-invisibility-spec))] - "--" - ["Upgrade all to [[link][desc]]" org-upgrade-old-links - (save-excursion (goto-char (point-min)) - (re-search-forward "<[a-z]+:" nil t))]) + :style radio :selected (not (member '(org-link) buffer-invisibility-spec))]) "--" ["Export/Publish..." org-export t] ("LaTeX" @@ -16997,6 +19280,15 @@ See the individual commands for more information." ["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." @@ -17022,7 +19314,7 @@ With optional NODE, go directly to that node." "--") (mapcar 'org-file-menu-entry (org-agenda-files t)))))))) -;;; Documentation +;;;; Documentation (defun org-customize () "Call the customize function with org as argument." @@ -17047,7 +19339,10 @@ With optional NODE, go directly to that node." (message "\"Org\"-menu now contains full customization menu")) (error "Cannot expand menu (outdated version of cus-edit.el)"))) -;;; Miscellaneous stuff +;;;; Miscellaneous stuff + + +;;; Generally useful functions (defun org-context () "Return a list of contexts of the current cursor position. @@ -17067,7 +19362,7 @@ contexts are: :table in an org-mode table :table-special on a special filed in a table :table-table in a table.el table -:link on a hyperline +:link on a hyperlink :keyword on a keyword: SCHEDULED, DEADLINE, CLOSE,COMMENT, QUOTE. :target on a <> :radio-target on a <<>> @@ -17147,6 +19442,23 @@ and :keyword." (setq clist (nreverse (delq nil clist))) clist)) +(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 +lines both before and after point into the search. +If VISUALLY is set, require that the cursor is not after the match but +really on, so that the block visually is on the match." + (catch 'exit + (let ((pos (point)) + (eol (point-at-eol (+ 1 (or nlines 0)))) + (inc (if visually 1 0))) + (save-excursion + (beginning-of-line (- 1 (or nlines 0))) + (while (re-search-forward re eol t) + (if (and (<= (match-beginning 0) pos) + (>= (+ inc (match-end 0)) pos)) + (throw 'exit (cons (match-beginning 0) (match-end 0))))))))) + (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 @@ -17159,6 +19471,20 @@ return nil." (list context (match-beginning group) (match-end group)) t))) +(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 +from the other lists. Settings in the last list are the most significant +ones and overrule settings in the other lists." + (let ((rtn (copy-sequence (pop plists))) + p v ls) + (while plists + (setq ls (pop plists)) + (while ls + (setq p (pop ls) v (pop ls)) + (setq rtn (plist-put rtn p v)))) + rtn)) + (defun org-move-line-down (arg) "Move the current line down. With prefix argument, move it past ARG lines." (interactive "p") @@ -17185,8 +19511,54 @@ return nil." (goto-char pos) (move-to-column col))) -;; Paragraph filling stuff. +(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. +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." + (let ((case-fold-search nil) + e re rpl) + (while (setq e (pop table)) + (setq re (concat "%-?[0-9.]*" (substring (car e) 1))) + (while (string-match re string) + (setq rpl (format (concat (substring (match-string 0 string) 0 -1) "s") + (cdr e))) + (setq string (replace-match rpl t t string)))) + string)) + + +(defun org-sublist (list start end) + "Return a section of LIST, from START to END. +Counting starts at 1." + (let (rtn (c start)) + (setq list (nthcdr (1- start) list)) + (while (and list (<= c end)) + (push (pop list) rtn) + (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" + (let ((buf (find-buffer-visiting file))) + (or (buffer-base-buffer buf) buf))) + +;;; Paragraph filling stuff. ;; We want this to be just right, so use the full arsenal. +;; FIXME: configure filladapt for XEmacs (defun org-set-autofill-regexps () (interactive) @@ -17202,7 +19574,7 @@ return nil." ;; 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 @@ -17236,52 +19608,12 @@ return nil." "Return a fill prefix for org-mode files. In particular, this makes sure hanging paragraphs for hand-formatted lists work correctly." - (if (looking-at " *\\([-*+] \\|[0-9]+[.)] \\)?") - (make-string (- (match-end 0) (match-beginning 0)) ?\ ))) - -;; Functions needed for Emacs/XEmacs region compatibility - -(defun org-add-hook (hook function &optional append local) - "Add-hook, compatible with both Emacsen." - (if (and local (featurep 'xemacs)) - (add-local-hook hook function append) - (add-hook hook function append local))) - -(defun org-region-active-p () - "Is `transient-mark-mode' on and the region active? -Works on both Emacs and XEmacs." - (if org-ignore-region - nil - (if (featurep 'xemacs) - (and zmacs-regions (region-active-p)) - (and transient-mark-mode mark-active)))) - -(defun org-add-to-invisibility-spec (arg) - "Add elements to `buffer-invisibility-spec'. -See documentation for `buffer-invisibility-spec' for the kind of elements -that can be added." - (cond - ((fboundp 'add-to-invisibility-spec) - (add-to-invisibility-spec arg)) - ((or (null buffer-invisibility-spec) (eq buffer-invisibility-spec t)) - (setq buffer-invisibility-spec (list arg))) - (t - (setq buffer-invisibility-spec - (cons arg buffer-invisibility-spec))))) - -(defun org-remove-from-invisibility-spec (arg) - "Remove elements from `buffer-invisibility-spec'." - (if (fboundp 'remove-from-invisibility-spec) - (remove-from-invisibility-spec arg) - (if (consp buffer-invisibility-spec) - (setq buffer-invisibility-spec - (delete arg buffer-invisibility-spec))))) + (cond ((looking-at "#[ \t]+") + (match-string 0)) + ((looking-at " *\\([-*+] \\|[0-9]+[.)] \\)?") + (make-string (- (match-end 0) (match-beginning 0)) ?\ )) + (t nil))) -(defun org-in-invisibility-spec-p (arg) - "Is ARG a member of `buffer-invisibility-spec'?" - (if (consp buffer-invisibility-spec) - (member arg buffer-invisibility-spec) - nil)) (defun org-image-file-name-regexp () "Return regexp matching the file names of images." @@ -17297,7 +19629,12 @@ that can be added." t) "\\'")))) -;; Functions extending outline functionality +(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? @@ -17337,14 +19674,8 @@ to a visible line beginning. This makes the function of C-a more intuitive." (defalias 'org-on-heading-p 'outline-on-heading-p) (defun org-on-target-p () - (let ((pos (point))) - (save-excursion - (skip-chars-forward "<") - (and (re-search-backward "<<" nil t) - (or (looking-at org-radio-target-regexp) - (looking-at org-target-regexp)) - (<= (match-beginning 0) pos) - (>= (1+ (match-end 0)) pos))))) + (or (org-in-regexp org-radio-target-regexp) + (org-in-regexp org-target-regexp))) (defun org-up-heading-all (arg) "Move to the heading line of which the present line is a subheading. @@ -17374,6 +19705,14 @@ move point." (goto-char pos) nil))) +(defun org-show-siblings () + "Show all siblings of the current headline." + (save-excursion + (while (org-goto-sibling) (org-flag-heading nil))) + (save-excursion + (while (org-goto-sibling 'previous) + (org-flag-heading nil)))) + (defun org-show-hidden-entry () "Show an entry where even the heading is hidden." (save-excursion @@ -17446,6 +19785,30 @@ Show the heading too, if it is currently invisible." "\\):[ \t]*" "\\(.+\\)")) +;; Make isearch reveal the necessary context +(defun org-isearch-end () + "Reveal context after isearch exits." + (when isearch-success ; only if search was successful + (if (featurep 'xemacs) + ;; Under XEmacs, the hook is run in the correct place, + ;; we directly show the context. + (org-show-context 'isearch) + ;; In Emacs the hook runs *before* restoring the overlays. + ;; So we have to use a one-time post-command-hook to do this. + ;; (Emacs 22 has a special variable, see function `org-mode') + (unless (and (boundp 'isearch-mode-end-hook-quit) + isearch-mode-end-hook-quit) + ;; Only when the isearch was not quitted. + (org-add-hook 'post-command-hook 'org-isearch-post-command + 'append 'local))))) + +(defun org-isearch-post-command () + "Remove self from hook, and show context." + (remove-hook 'post-command-hook 'org-isearch-post-command 'local) + (org-show-context 'isearch)) + +;;;; Repair problems with some other packages + ;; Make `bookmark-jump' show the jump location if it was hidden. (eval-after-load "bookmark" '(if (boundp 'bookmark-after-jump-hook) @@ -17468,9 +19831,10 @@ Show the heading too, if it is currently invisible." (eval-after-load "session" '(add-to-list 'session-globals-exclude 'org-mark-ring)) -;;; Experimental code +;;;; Experimental code -;;; Finish up + +;;;; Finish up (provide 'org) @@ -17478,3 +19842,4 @@ Show the heading too, if it is currently invisible." ;; arch-tag: e77da1a7-acc7-4336-b19e-efa25af3f9fd ;;; org.el ends here + -- cgit v1.2.1 From f252c2ad23cc2a516124bdb312515828185f4df7 Mon Sep 17 00:00:00 2001 From: Carsten Dominik Date: Sun, 25 Feb 2007 06:43:10 +0000 Subject: *** empty log message *** --- lisp/ChangeLog | 131 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 131 insertions(+) (limited to 'lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 76da575db39..6180d2d7415 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,134 @@ +2007-02-25 Carsten Dominik + + * textmodes/org.el (org-table-overlay-coordinates) + (org-table-toggle-coordinate-overlays): New functions. + (org-table-overlay-coordinates, org-table-coordinate-overlays): + New variables. + (org-startup-with-deadline-check): Option removed. + (org-mode): Remove deadline check on startup. + (org-table-limit-column-width): Option removed. + (org-table-formula-numbers-only): Option removed. + (org-link-style, org-link-format): Options removed. + (org-select-agenda-window, org-fit-agenda-window): Options + removed. + (org-export-ascii-show-new-buffer) + (org-export-html-show-new-buffer): Options removed. + (org-activate-links): Camel option removed. + (org-file-link-context-use-camel-case): Option removed. + (org-camel-regexp): Veriable removed. + (org-activate-camels): Function removed. + (org-store-link): Removed Camel stuff. + (org-make-org-heading-camel): Function removed. + (org-open-at-point): Removed camel stuff. + (org-link-search): Removed camel stuff. + (org-camel-to-words): Function removed. + (org-get-agenda-file-buffer): Make sure we prepare the base + buffers, not any indirect buffers. + (org-sort-entries): Sort top-level when not on a headline, and no + active region. + (org-in-regexp): New function. + (org-search-not-self): Renamed from `org-search-not-link'. + (org-open-link-marker): New variable. + (org-open-at-point): Set `org-open-link-marker'. + (org-print-icalendar-entries): Fixed bug with excluding DONE + entries from the exported list. + (org-edit-formula-lisp-indent): New command. + (orgtbl-to-texinfo, orgtbl-to-html): New functions. + (orgtbl-to-latex, orgtbl-insert-radio-table) + (orgtbl-toggle-comment, orgtbl-send-table): New functions. + (orgtbl-radio-table-templates): New option. + (org-store-link-props): + (org-remember-templates): More possibilities to insert info into + templates. + (org-remember-apply-template): Make use of the extended template + capabilities. + (org-remember-redo-template): New command. + (org-upgrade-old-links) + (org-table-modify-formulas, org-table-replace-in-formulas) + (org-table-find-dataline) + (org-table-get-vertical-vector): Functions removed. + (org-table-remove-rectangle-highlight) + (org-time-stamp-format, org-toggle-log-option) + (org-table-highlight-rectangle) + (org-table-iterate, org-table-make-reference): + (org-translate-time, org-tree-to-indirect-buffer) + (org-table-field-info, org-table-fix-formulas) + (org-table-force-dataline, org-table-get-descriptor-line) + (org-table-get-range) + (org-skip-comments, org-sort) + (org-sort-entries, org-sublist, org-table-add-rectangle-overlay) + (org-table-current-dline, org-table-current-field-formula) + (org-table-edit-backward-field) + (org-table-edit-formulas-post-command) + (org-table-edit-line-down, org-table-edit-line-up) + (org-agenda-archive) + (org-agenda-clock-cancel) + (org-agenda-clock-out, org-agenda-list-stuck-projects) + (org-agenda-open-link, org-agenda-show-new-time) + (org-agenda-skip-subtree-when-regexp-matches) + (org-agenda-tree-to-indirect-buffer, org-agenda-undo) + (org-at-regexp-p, org-auto-repeat-maybe, org-check-log-option) + (org-do-sort, org-file-image-p, org-find-overlays) + (org-find-row-type, org-get-indirect-buffer, org-get-repeat) + (org-highlight-until-next-command, org-isearch-end) + (org-match-any-p, org-next-link, org-previous-link): + (org-remove-subtree-entries-from-agenda, org-replace-escapes) + (org-rewrite-old-row-references) + (org-isearch-post-command) + (org-table-edit-move, org-table-edit-next-field) + (org-table-edit-scroll, org-table-edit-scroll-down) + (org-set-frame-title, org-show-reference) + (org-unhighlight-once, org-verify-change-for-undo): New functions. + (org-show-variable): Command removed. + (org-add-log-maybe): New arguments STATE, FINDPOS + (org-table-sort-lines): Rewritten from scratch. + (org-link-search): New argument AVOID-POS. + (org-print-icalendar-entries): Argument CATEGORY removed. + (org-run-agenda-series): Argument WONDOW removed. + (org-next-link, org-previous-link): New commands. + (org-agenda-date-format): New option. + (org-table-iterate): New command. + (org-table-modify-formulas) + (org-table-replace-in-formulas): Functions removed. + (org-table-fix-formulas): New function. + (org-table-insert-column, org-table-delete-column) + (org-table-move-column): Use `org-table-fix-formulas'. + (org-follow-gnus-link): Patch from Bastien/Leo. + (org-table-current-field-formula): New function. + (org-file-image-p): New function. + (org-agenda-show-new-time): New function. + (org-agenda-date-later): Call `org-agenda-show-new-time'. + (org-with-remote-undo): New macro. + (org-agenda-undo): New command. + (org-verify-change-for-undo): New function. + (org-time-stamp-format): New function. + (org-agenda-get-timestamps): Skip scheduled if DONE and requested + by user. + (org-match-any-p): New function. + (org-make-tags-matcher): Handle regular expressions for tag and + todo matches. + (org-read-date): Accept "+N" as input for a date relative to the + current date. + (org-remove-subtree-entries-from-agenda): New function. + (org-agenda-archive, org-agenda-kill): Use + `org-remove-subtree-entries-from-agenda'. + (org-do-sort, org-sort-entries): New functions. + (org-sort): New command. + (org-table-sort-lines): Use `org-do-sort'. + (org-fix-decoded-time): New function. + (org-table-number-regexp): Require 0x... to identify as number in + tables. + (org-startup-options): New keywords for note taking. + (org-upgrade-old-links): Function removed. + (org-get-repeat): New function. + (org-show-context): Also show siblings on current level. + (org-show-siblings): New function. + (org-isearch-end, org-isearch-post-command): New functions. + (org-show-siblings): New option. + (org-show-context): Use `org-show-siblings'. + (org-table-maybe-recalculate-line): No longer require `calc-eval' + to be bound, because user may just use elisp. + 2007-02-24 Kim F. Storm * emulation/cua-base.el (cua-paste): Handle x-clipboard-yank. -- cgit v1.2.1 From f215a02f44f5dd04f597e6db5a02af74ead095be Mon Sep 17 00:00:00 2001 From: Andreas Schwab Date: Sun, 25 Feb 2007 09:24:29 +0000 Subject: =?UTF-8?q?(hack-one-local-variable-eval-safep):=20Correct=20handl?= =?UTF-8?q?ing=20of=20edebug-form-spec=20property=20value.=20=20Reported?= =?UTF-8?q?=20by=20Johan=20Bockg=C3=A5rd=20.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- lisp/ChangeLog | 6 ++++++ lisp/files.el | 3 ++- 2 files changed, 8 insertions(+), 1 deletion(-) (limited to 'lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 6180d2d7415..6cc6088f170 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,9 @@ +2007-02-25 Andreas Schwab + + * files.el (hack-one-local-variable-eval-safep): Correct handling + of edebug-form-spec property value. Reported by Johan Bockg,Ae(Brd + . + 2007-02-25 Carsten Dominik * textmodes/org.el (org-table-overlay-coordinates) diff --git a/lisp/files.el b/lisp/files.el index 6d5b101d3c1..adec33ef77b 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -2787,7 +2787,8 @@ It is dangerous if either of these conditions are met: ;; During bootstrapping, edebug-basic-spec might not be ;; defined yet. (and (fboundp 'edebug-basic-spec) - (edebug-basic-spec val)))))) + (hack-one-local-variable-quotep val) + (edebug-basic-spec (nth 1 val))))))) ;; Allow expressions that the user requested. (member exp safe-local-eval-forms) ;; Certain functions can be allowed with safe arguments -- cgit v1.2.1 From 3b61abfe71dc16e0d3ee271788f8f96daef9d22a Mon Sep 17 00:00:00 2001 From: Eli Zaretskii Date: Sun, 25 Feb 2007 21:16:11 +0000 Subject: Add comment explaining why we look for simple.el on startup. --- lisp/startup.el | 2 ++ 1 file changed, 2 insertions(+) (limited to 'lisp') diff --git a/lisp/startup.el b/lisp/startup.el index 3e26aa17409..10fadfbfd77 100644 --- a/lisp/startup.el +++ b/lisp/startup.el @@ -647,6 +647,8 @@ or `CVS', and any subdirectory that contains a file named `.nosearch'." ;; Convert preloaded file names in load-history to absolute. (let ((simple-file-name + ;; Look for simple.el or simple.elc and use their directory + ;; as the place where all Lisp files live. (locate-file "simple" load-path (get-load-suffixes))) lisp-dir) ;; Don't abort if simple.el cannot be found, but print a warning. -- cgit v1.2.1 From 4b547e5acf67ec3de0a9e106ea69a34121de4215 Mon Sep 17 00:00:00 2001 From: "Kim F. Storm" Date: Sun, 25 Feb 2007 22:00:58 +0000 Subject: *** empty log message *** --- lisp/ChangeLog | 4 ++++ 1 file changed, 4 insertions(+) (limited to 'lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 6cc6088f170..55a70ad8e15 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,7 @@ +2007-02-25 Kim F. Storm + + * emacs-lisp/map-ynp.el (map-y-or-n-p): Apply minibuffer-prompt-properties. + 2007-02-25 Andreas Schwab * files.el (hack-one-local-variable-eval-safep): Correct handling -- cgit v1.2.1 From f7f2cc5da8b6c5d4b2eb294522217ed6f643dd04 Mon Sep 17 00:00:00 2001 From: "Kim F. Storm" Date: Sun, 25 Feb 2007 22:01:08 +0000 Subject: (map-y-or-n-p): Apply minibuffer-prompt-properties. --- lisp/emacs-lisp/map-ynp.el | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'lisp') diff --git a/lisp/emacs-lisp/map-ynp.el b/lisp/emacs-lisp/map-ynp.el index c40f1cf9b3a..d14394b97a0 100644 --- a/lisp/emacs-lisp/map-ynp.el +++ b/lisp/emacs-lisp/map-ynp.el @@ -149,7 +149,8 @@ Returns the number of actions taken." ;; Prompt in the echo area. (let ((cursor-in-echo-area (not no-cursor-in-echo-area)) (message-log-max nil)) - (message "%s(y, n, !, ., q, %sor %s) " + (message (apply 'propertize "%s(y, n, !, ., q, %sor %s) " + minibuffer-prompt-properties) prompt user-keys (key-description (vector help-char))) (if minibuffer-auto-raise -- cgit v1.2.1 From 7c9fe7ee5930294edf0013ac87ecb4693b30c275 Mon Sep 17 00:00:00 2001 From: "Kim F. Storm" Date: Sun, 25 Feb 2007 23:48:44 +0000 Subject: *** empty log message *** --- lisp/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) (limited to 'lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 55a70ad8e15..74f5389f3fb 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,5 +1,10 @@ 2007-02-25 Kim F. Storm + * ido.el (ido-buffer-internal): Set this-command to fallback command. + Add selected buffer to buffer-name-history. + (ido-file-internal): Set this-command to fallback command. + Add file names to to file-name-history. + * emacs-lisp/map-ynp.el (map-y-or-n-p): Apply minibuffer-prompt-properties. 2007-02-25 Andreas Schwab -- cgit v1.2.1 From 16f462c5f9eb3b6b88004cb65cc8ec886bde78c0 Mon Sep 17 00:00:00 2001 From: "Kim F. Storm" Date: Sun, 25 Feb 2007 23:48:54 +0000 Subject: (ido-buffer-internal): Set this-command to fallback command. Add selected buffer to buffer-name-history. (ido-file-internal): Set this-command to fallback command. Add file names to to file-name-history. --- lisp/ido.el | 22 ++++++++++++++-------- 1 file changed, 14 insertions(+), 8 deletions(-) (limited to 'lisp') diff --git a/lisp/ido.el b/lisp/ido.el index ad3f4329e6b..27abe9c9a8f 100644 --- a/lisp/ido.el +++ b/lisp/ido.el @@ -2163,9 +2163,9 @@ If cursor is not at the end of the user input, move to end of input." ((eq ido-exit 'fallback) (let ((read-buffer-function nil)) - (run-hook-with-args 'ido-before-fallback-functions - (or fallback 'switch-to-buffer)) - (call-interactively (or fallback 'switch-to-buffer)))) + (setq this-command (or fallback 'switch-to-buffer)) + (run-hook-with-args 'ido-before-fallback-functions this-command) + (call-interactively this-command))) ;; Check buf is non-nil. ((not buf) nil) @@ -2173,6 +2173,7 @@ If cursor is not at the end of the user input, move to end of input." ;; View buffer if it exists ((get-buffer buf) + (add-to-history 'buffer-name-history buf) (if (eq method 'insert) (progn (ido-record-command 'insert-buffer buf) @@ -2192,6 +2193,7 @@ If cursor is not at the end of the user input, move to end of input." ;; create a new buffer (t + (add-to-history 'buffer-name-history buf) (setq buf (get-buffer-create buf)) (if (fboundp 'set-buffer-major-mode) (set-buffer-major-mode buf)) @@ -2304,9 +2306,9 @@ If cursor is not at the end of the user input, move to end of input." ;; we don't want to change directory of current buffer. (let ((default-directory ido-current-directory) (read-file-name-function nil)) - (run-hook-with-args 'ido-before-fallback-functions - (or fallback 'find-file)) - (call-interactively (or fallback 'find-file)))) + (setq this-command (or fallback 'find-file)) + (run-hook-with-args 'ido-before-fallback-functions this-command) + (call-interactively this-command))) ((eq ido-exit 'switch-to-buffer) (ido-buffer-internal ido-default-buffer-method nil nil nil ido-text)) @@ -2363,9 +2365,11 @@ If cursor is not at the end of the user input, move to end of input." ((eq method 'write) (ido-record-work-file filename) (setq default-directory ido-current-directory) - (ido-record-command 'write-file (concat ido-current-directory filename)) + (setq filename (concat ido-current-directory filename)) + (ido-record-command 'write-file filename) + (add-to-history 'file-name-history filename) (ido-record-work-directory) - (write-file (concat ido-current-directory filename))) + (write-file filename)) ((eq method 'read-only) (ido-record-work-file filename) @@ -2381,6 +2385,7 @@ If cursor is not at the end of the user input, move to end of input." (ido-record-command (if ido-find-literal 'insert-file-literally 'insert-file) filename) + (add-to-history 'file-name-history filename) (ido-record-work-directory) (insert-file-1 filename (if ido-find-literal @@ -2391,6 +2396,7 @@ If cursor is not at the end of the user input, move to end of input." (ido-record-work-file filename) (setq filename (concat ido-current-directory filename)) (ido-record-command 'find-file filename) + (add-to-history 'file-name-history filename) (ido-record-work-directory) (ido-visit-buffer (find-file-noselect filename nil ido-find-literal) method)))))) -- cgit v1.2.1 From 7af1dacf7d47b5fd4c80f25115603c375abe5cd6 Mon Sep 17 00:00:00 2001 From: Juanma Barranquero Date: Mon, 26 Feb 2007 09:40:04 +0000 Subject: (font-lock-mode): Doc fix. --- lisp/ChangeLog | 24 ++++++++++++++---------- lisp/font-core.el | 4 ---- 2 files changed, 14 insertions(+), 14 deletions(-) (limited to 'lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 74f5389f3fb..1b23188a41b 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,11 +1,16 @@ +2007-02-26 Johan Bockg,Ae(Brd + + * font-core.el (font-lock-mode): Doc fix. + 2007-02-25 Kim F. Storm * ido.el (ido-buffer-internal): Set this-command to fallback command. Add selected buffer to buffer-name-history. (ido-file-internal): Set this-command to fallback command. - Add file names to to file-name-history. + Add file names to file-name-history. - * emacs-lisp/map-ynp.el (map-y-or-n-p): Apply minibuffer-prompt-properties. + * emacs-lisp/map-ynp.el (map-y-or-n-p): + Apply minibuffer-prompt-properties. 2007-02-25 Andreas Schwab @@ -24,8 +29,7 @@ (org-table-limit-column-width): Option removed. (org-table-formula-numbers-only): Option removed. (org-link-style, org-link-format): Options removed. - (org-select-agenda-window, org-fit-agenda-window): Options - removed. + (org-select-agenda-window, org-fit-agenda-window): Options removed. (org-export-ascii-show-new-buffer) (org-export-html-show-new-buffer): Options removed. (org-activate-links): Camel option removed. @@ -53,10 +57,10 @@ (orgtbl-toggle-comment, orgtbl-send-table): New functions. (orgtbl-radio-table-templates): New option. (org-store-link-props): - (org-remember-templates): More possibilities to insert info into - templates. - (org-remember-apply-template): Make use of the extended template - capabilities. + (org-remember-templates): More possibilities to insert info + into templates. + (org-remember-apply-template): Make use of the extended + template capabilities. (org-remember-redo-template): New command. (org-upgrade-old-links) (org-table-modify-formulas, org-table-replace-in-formulas) @@ -131,8 +135,8 @@ (org-sort): New command. (org-table-sort-lines): Use `org-do-sort'. (org-fix-decoded-time): New function. - (org-table-number-regexp): Require 0x... to identify as number in - tables. + (org-table-number-regexp): Require 0x... to identify as number + in tables. (org-startup-options): New keywords for note taking. (org-upgrade-old-links): Function removed. (org-get-repeat): New function. diff --git a/lisp/font-core.el b/lisp/font-core.el index da355b8b6aa..3edf2140393 100644 --- a/lisp/font-core.el +++ b/lisp/font-core.el @@ -124,10 +124,6 @@ generally prefer. When you turn Font Lock mode on/off the buffer is fontified/defontified, though fontification occurs only if the buffer is less than `font-lock-maximum-size'. -For example, to use maximum levels of fontification, put in your ~/.emacs: - - (setq font-lock-maximum-decoration t) - To add your own highlighting for some major mode, and modify the highlighting selected automatically via the variable `font-lock-maximum-decoration', you can use `font-lock-add-keywords'. -- cgit v1.2.1 From 864129b6f7f2c2b1fc81964796ced9915e570a7f Mon Sep 17 00:00:00 2001 From: "Kim F. Storm" Date: Mon, 26 Feb 2007 10:11:22 +0000 Subject: *** empty log message *** --- lisp/ChangeLog | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) (limited to 'lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 1b23188a41b..d563bbb5e51 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,8 @@ +2007-02-26 Kim F. Storm + + * mouse.el (mouse-show-mark): Run hooks and perform command + remapping for mouse-region-delete-keys. + 2007-02-26 Johan Bockg,Ae(Brd * font-core.el (font-lock-mode): Doc fix. @@ -15,8 +20,7 @@ 2007-02-25 Andreas Schwab * files.el (hack-one-local-variable-eval-safep): Correct handling - of edebug-form-spec property value. Reported by Johan Bockg,Ae(Brd - . + of edebug-form-spec property value. Reported by Johan Bockg,Ae(Brd. 2007-02-25 Carsten Dominik -- cgit v1.2.1 From 760a2050ca3b597fddd830f9676e427d97ecf9ff Mon Sep 17 00:00:00 2001 From: "Kim F. Storm" Date: Mon, 26 Feb 2007 10:11:34 +0000 Subject: (mouse-show-mark): Run hooks and perform command remapping for mouse-region-delete-keys. --- lisp/mouse.el | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) (limited to 'lisp') diff --git a/lisp/mouse.el b/lisp/mouse.el index dae098ec117..ef0784d8973 100644 --- a/lisp/mouse.el +++ b/lisp/mouse.el @@ -1276,7 +1276,17 @@ If MODE is 2 then do the same for lines." (unless ignore ;; For certain special keys, delete the region. (if (member key mouse-region-delete-keys) - (delete-region (mark t) (point)) + (progn + ;; Since notionally this is a separate command, + ;; run all the hooks that would be run if it were + ;; executed separately. + (run-hooks 'post-command-hook) + (setq last-command this-command) + (setq this-original-command 'delete-region) + (setq this-command (or (command-remapping this-original-command) + this-original-command)) + (run-hooks 'pre-command-hook) + (call-interactively this-command)) ;; Otherwise, unread the key so it gets executed normally. (setq unread-command-events (nconc events unread-command-events)))) -- cgit v1.2.1 From da888ddfaf1dbe7b0235c54e94b3ae0a0f0fece8 Mon Sep 17 00:00:00 2001 From: Romain Francoise Date: Mon, 26 Feb 2007 17:43:11 +0000 Subject: (whois-server-tld): Update server for .org. (whois-server-list): Add whois.publicinterestregistry.net. (whois-guess-server): Fix formatting in docstring. --- lisp/ChangeLog | 6 ++++++ lisp/net/net-utils.el | 8 ++++++-- 2 files changed, 12 insertions(+), 2 deletions(-) (limited to 'lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index d563bbb5e51..7fd5382e6dc 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,9 @@ +2007-02-26 Romain Francoise + + * net/net-utils.el (whois-server-tld): Update server for .org. + (whois-server-list): Add whois.publicinterestregistry.net. + (whois-guess-server): Fix formatting in docstring. + 2007-02-26 Kim F. Storm * mouse.el (mouse-show-mark): Run hooks and perform command diff --git a/lisp/net/net-utils.el b/lisp/net/net-utils.el index 86bab7b20c5..6a1c1bca8c0 100644 --- a/lisp/net/net-utils.el +++ b/lisp/net/net-utils.el @@ -674,6 +674,7 @@ queries of the form USER@HOST, and wants a query containing USER only." (defcustom whois-server-list '(("whois.arin.net") ; Networks, ASN's, and related POC's (numbers) ("rs.internic.net") ; domain related info + ("whois.publicinterestregistry.net") ("whois.abuse.net") ("whois.apnic.net") ("nic.ddn.mil") @@ -684,9 +685,12 @@ queries of the form USER@HOST, and wants a query containing USER only." :group 'net-utils :type '(repeat (list string))) +;; FIXME: modern whois clients include a much better tld <-> whois server +;; list, Emacs should probably avoid specifying the server as the client +;; will DTRT anyway... -rfr (defcustom whois-server-tld '(("rs.internic.net" . "com") - ("rs.internic.net" . "org") + ("whois.publicinterestregistry.net" . "org") ("whois.ripe.net" . "be") ("whois.ripe.net" . "de") ("whois.ripe.net" . "dk") @@ -707,7 +711,7 @@ queries of the form USER@HOST, and wants a query containing USER only." (defcustom whois-guess-server t "If non-nil then whois will try to deduce the appropriate whois server from the query. If the query doesn't look like a domain or hostname -then the server named by whois-server-name is used." +then the server named by `whois-server-name' is used." :group 'net-utils :type 'boolean) -- cgit v1.2.1 From 2b84c0d2d3e80a8b61bdb8970856e53dde9b42d3 Mon Sep 17 00:00:00 2001 From: Nick Roberts Date: Mon, 26 Feb 2007 20:47:39 +0000 Subject: *** empty log message *** --- lisp/ChangeLog | 10 ++++++++++ 1 file changed, 10 insertions(+) (limited to 'lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 7fd5382e6dc..32b85284bf0 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,13 @@ +2007-02-26 Nick Roberts + + * progmodes/gud.el (gud, gud-menu-map): Remove references to bash/bashdb. + (gud-bashdb-history, gud-bashdb-marker-filter) + (gud-bashdb-command-name, bashdb): Remove. + +2007-02-26 Andrey Zhdanov + + (gud-pdb-marker-regexp): Add optional keyword for Python 2.5. + 2007-02-26 Romain Francoise * net/net-utils.el (whois-server-tld): Update server for .org. -- cgit v1.2.1 From 063b72899020265f19b424aa7975d12dd96d44e1 Mon Sep 17 00:00:00 2001 From: Nick Roberts Date: Mon, 26 Feb 2007 21:01:26 +0000 Subject: *** empty log message *** --- lisp/ChangeLog | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'lisp') diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 32b85284bf0..21f1332e856 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -4,7 +4,7 @@ (gud-bashdb-history, gud-bashdb-marker-filter) (gud-bashdb-command-name, bashdb): Remove. -2007-02-26 Andrey Zhdanov +2007-02-26 Andrey Zhdanov (tiny change) (gud-pdb-marker-regexp): Add optional keyword for Python 2.5. -- cgit v1.2.1 From f6f3d0b9133d06b29523c7bc744130cddc5c8d6b Mon Sep 17 00:00:00 2001 From: Nick Roberts Date: Mon, 26 Feb 2007 21:10:38 +0000 Subject: (gud, gud-menu-map): Remove references to bash/bashdb. (gud-bashdb-history, gud-bashdb-marker-filter) (gud-bashdb-command-name, bashdb): Remove. (gud-pdb-marker-regexp): Add optional keyword for Python 2.5. --- lisp/progmodes/gud.el | 133 +++----------------------------------------------- 1 file changed, 6 insertions(+), 127 deletions(-) (limited to 'lisp') diff --git a/lisp/progmodes/gud.el b/lisp/progmodes/gud.el index 312b7187225..1662af1c924 100644 --- a/lisp/progmodes/gud.el +++ b/lisp/progmodes/gud.el @@ -58,7 +58,7 @@ (defgroup gud nil "Grand Unified Debugger mode for gdb and other debuggers under Emacs. -Supported debuggers include gdb, sdb, dbx, xdb, perldb, pdb (Python), jdb, and bash." +Supported debuggers include gdb, sdb, dbx, xdb, perldb, pdb (Python), jdb." :group 'unix :group 'tools) @@ -166,18 +166,18 @@ Used to grey out relevant toolbar icons.") ([tbreak] menu-item "Temporary Breakpoint" gud-tbreak :enable (not gud-running) :visible (memq gud-minor-mode - '(gdbmi gdba gdb sdb xdb bashdb))) + '(gdbmi gdba gdb sdb xdb))) ([break] menu-item "Set Breakpoint" gud-break :enable (not gud-running) :visible (gud-tool-bar-item-visible-no-fringe)) ([up] menu-item "Up Stack" gud-up :enable (not gud-running) :visible (memq gud-minor-mode - '(gdbmi gdba gdb dbx xdb jdb pdb bashdb))) + '(gdbmi gdba gdb dbx xdb jdb pdb))) ([down] menu-item "Down Stack" gud-down :enable (not gud-running) :visible (memq gud-minor-mode - '(gdbmi gdba gdb dbx xdb jdb pdb bashdb))) + '(gdbmi gdba gdb dbx xdb jdb pdb))) ([pp] menu-item "Print S-expression" gud-pp :enable (and (not gud-running) gdb-active-process) @@ -196,7 +196,7 @@ Used to grey out relevant toolbar icons.") ([finish] menu-item "Finish Function" gud-finish :enable (not gud-running) :visible (memq gud-minor-mode - '(gdbmi gdba gdb xdb jdb pdb bashdb))) + '(gdbmi gdba gdb xdb jdb pdb))) ([stepi] menu-item "Step Instruction" gud-stepi :enable (not gud-running) :visible (memq gud-minor-mode '(gdbmi gdba gdb dbx))) @@ -1520,7 +1520,7 @@ and source-file directory for your debugger." ;; Last group is for return value, e.g. "> test.py(2)foo()->None" ;; Either file or function name may be omitted: "> (0)?()" (defvar gud-pdb-marker-regexp - "^> \\([-a-zA-Z0-9_/.:\\]*\\|\\)(\\([0-9]+\\))\\([a-zA-Z0-9_]*\\|\\?\\)()\\(->[^\n]*\\)?\n") + "^> \\([-a-zA-Z0-9_/.:\\]*\\|\\)(\\([0-9]+\\))\\([a-zA-Z0-9_]*\\|\\?\\|\\)()\\(->[^\n]*\\)?\n") (defvar gud-pdb-marker-regexp-file-group 1) (defvar gud-pdb-marker-regexp-line-group 2) (defvar gud-pdb-marker-regexp-fnname-group 3) @@ -2286,127 +2286,6 @@ gud, see `gud-mode'." (gud-jdb-build-source-files-list gud-jdb-directories "\\.java$")))) (fset 'gud-jdb-find-source 'gud-jdb-find-source-file))) - - -;; ====================================================================== -;; -;; BASHDB support. See http://bashdb.sourceforge.net -;; -;; AUTHOR: Rocky Bernstein -;; -;; CREATED: Sun Nov 10 10:46:38 2002 Rocky Bernstein. -;; -;; INVOCATION NOTES: -;; -;; You invoke bashdb-mode with: -;; -;; M-x bashdb -;; -;; It responds with: -;; -;; Run bashdb (like this): bash -;; - -;; History of argument lists passed to bashdb. -(defvar gud-bashdb-history nil) - -;; Convert a command line as would be typed normally to run a script -;; into one that invokes an Emacs-enabled debugging session. -;; "--debugger" in inserted as the first switch. - -;; There's no guarantee that Emacs will hand the filter the entire -;; marker at once; it could be broken up across several strings. We -;; might even receive a big chunk with several markers in it. If we -;; receive a chunk of text which looks like it might contain the -;; beginning of a marker, we save it here between calls to the -;; filter. -(defun gud-bashdb-marker-filter (string) - (setq gud-marker-acc (concat gud-marker-acc string)) - (let ((output "")) - - ;; Process all the complete markers in this chunk. - ;; Format of line looks like this: - ;; (/etc/init.d/ntp.init:16): - ;; but we also allow DOS drive letters - ;; (d:/etc/init.d/ntp.init:16): - (while (string-match "\\(^\\|\n\\)(\\(\\([a-zA-Z]:\\)?[^:\n]*\\):\\([0-9]*\\)):.*\n" - gud-marker-acc) - (setq - - ;; Extract the frame position from the marker. - gud-last-frame - (cons (match-string 2 gud-marker-acc) - (string-to-number (match-string 4 gud-marker-acc))) - - ;; Append any text before the marker to the output we're going - ;; to return - we don't include the marker in this text. - output (concat output - (substring gud-marker-acc 0 (match-beginning 0))) - - ;; Set the accumulator to the remaining text. - gud-marker-acc (substring gud-marker-acc (match-end 0)))) - - ;; Does the remaining text look like it might end with the - ;; beginning of another marker? If it does, then keep it in - ;; gud-marker-acc until we receive the rest of it. Since we - ;; know the full marker regexp above failed, it's pretty simple to - ;; test for marker starts. - (if (string-match "\032.*\\'" gud-marker-acc) - (progn - ;; Everything before the potential marker start can be output. - (setq output (concat output (substring gud-marker-acc - 0 (match-beginning 0)))) - - ;; Everything after, we save, to combine with later input. - (setq gud-marker-acc - (substring gud-marker-acc (match-beginning 0)))) - - (setq output (concat output gud-marker-acc) - gud-marker-acc "")) - - output)) - -(defcustom gud-bashdb-command-name "bash --debugger" - "File name for executing bash debugger." - :type 'string - :group 'gud) - -;;;###autoload -(defun bashdb (command-line) - "Run bashdb on program FILE in buffer *gud-FILE*. -The directory containing FILE becomes the initial working directory -and source-file directory for your debugger." - (interactive - (list (read-from-minibuffer "Run bashdb (like this): " - (if (consp gud-bashdb-history) - (car gud-bashdb-history) - (concat gud-bashdb-command-name - " ")) - gud-minibuffer-local-map nil - '(gud-bashdb-history . 1)))) - - (gud-common-init command-line nil 'gud-bashdb-marker-filter) - - (set (make-local-variable 'gud-minor-mode) 'bashdb) - - (gud-def gud-break "break %l" "\C-b" "Set breakpoint at current line.") - (gud-def gud-tbreak "tbreak %l" "\C-t" "Set temporary breakpoint at current line.") - (gud-def gud-remove "clear %l" "\C-d" "Remove breakpoint at current line") - (gud-def gud-step "step" "\C-s" "Step one source line with display.") - (gud-def gud-next "next" "\C-n" "Step one line (skip functions).") - (gud-def gud-cont "continue" "\C-r" "Continue with display.") - (gud-def gud-finish "finish" "\C-f" "Finish executing current function.") - (gud-def gud-up "up %p" "<" "Up N stack frames (numeric arg).") - (gud-def gud-down "down %p" ">" "Down N stack frames (numeric arg).") - (gud-def gud-print "x %e" "\C-p" "Evaluate BASH expression at point.") - - ;; Is this right? - (gud-def gud-statement "eval %e" "\C-e" "Execute BASH statement at point.") - - (setq comint-prompt-regexp "^bashdb<+(*[0-9]+)*>+ ") - (setq paragraph-start comint-prompt-regexp) - (run-hooks 'bashdb-mode-hook) - ) ;; ;; End of debugger-specific information -- cgit v1.2.1