diff options
Diffstat (limited to 'lisp/textmodes')
| -rw-r--r-- | lisp/textmodes/bibtex.el | 1525 | ||||
| -rw-r--r-- | lisp/textmodes/conf-mode.el | 106 | ||||
| -rw-r--r-- | lisp/textmodes/fill.el | 5 | ||||
| -rw-r--r-- | lisp/textmodes/flyspell.el | 1009 | ||||
| -rw-r--r-- | lisp/textmodes/ispell.el | 162 | ||||
| -rw-r--r-- | lisp/textmodes/nroff-mode.el | 1 | ||||
| -rw-r--r-- | lisp/textmodes/org.el | 3317 | ||||
| -rw-r--r-- | lisp/textmodes/paragraphs.el | 10 | ||||
| -rw-r--r-- | lisp/textmodes/picture.el | 99 | ||||
| -rw-r--r-- | lisp/textmodes/reftex-vars.el | 1 | ||||
| -rw-r--r-- | lisp/textmodes/reftex.el | 2 | ||||
| -rw-r--r-- | lisp/textmodes/sgml-mode.el | 1 | ||||
| -rw-r--r-- | lisp/textmodes/texinfmt.el | 4 | ||||
| -rw-r--r-- | lisp/textmodes/texinfo.el | 7 | ||||
| -rw-r--r-- | lisp/textmodes/tildify.el | 4 |
15 files changed, 4036 insertions, 2217 deletions
diff --git a/lisp/textmodes/bibtex.el b/lisp/textmodes/bibtex.el index 7b736708268..6bb3c0d642c 100644 --- a/lisp/textmodes/bibtex.el +++ b/lisp/textmodes/bibtex.el @@ -551,6 +551,12 @@ See `bibtex-generate-autokey' for details." :group 'bibtex-autokey :type 'string) +(defcustom bibtex-autokey-expand-strings nil + "If non-nil, expand strings when extracting the content of a BibTeX field. +See `bibtex-generate-autokey' for details." + :group 'bibtex-autokey + :type 'boolean) + (defvar bibtex-autokey-transcriptions '(;; language specific characters ("\\\\aa" . "a") ; \aa -> a @@ -809,6 +815,8 @@ submatch), or a function called with the field's text as argument and with the `match-data' properly set. Case is always ignored. Always remove the field delimiters. +If `bibtex-expand-strings' is non-nil, BibTeX strings are expanded +for generating the URL. The following is a complex example, see http://link.aps.org/linkfaq.html. @@ -840,12 +848,17 @@ The following is a complex example, see http://link.aps.org/linkfaq.html. (integer :tag "Sub-match") (function :tag "Filter")))))))) -;; bibtex-font-lock-keywords is a user option as well, but since the +(defcustom bibtex-expand-strings nil + "If non-nil, expand strings when extracting the content of a BibTeX field." + :group 'bibtex + :type 'boolean) + +;; `bibtex-font-lock-keywords' is a user option, too. But since the ;; patterns used to define this variable are defined in a later ;; section of this file, it is defined later. -;; Syntax Table, Keybindings and BibTeX Entry List +;; Syntax Table and Keybindings (defvar bibtex-mode-syntax-table (let ((st (make-syntax-table))) (modify-syntax-entry ?\" "\"" st) @@ -1031,13 +1044,15 @@ At most `bibtex-entry-kill-ring-max' items are kept here.") (defvar bibtex-strings (lazy-completion-table bibtex-strings - bibtex-parse-strings (bibtex-string-files-init)) + (lambda () + (bibtex-parse-strings (bibtex-string-files-init)))) "Completion table for BibTeX string keys. Initialized from `bibtex-predefined-strings' and `bibtex-string-files'.") (make-variable-buffer-local 'bibtex-strings) (defvar bibtex-reference-keys - (lazy-completion-table bibtex-reference-keys bibtex-parse-keys nil t) + (lazy-completion-table bibtex-reference-keys + (lambda () (bibtex-parse-keys nil t))) "Completion table for BibTeX reference keys. The CDRs of the elements are t for header keys and nil for crossref keys.") (make-variable-buffer-local 'bibtex-reference-keys) @@ -1073,10 +1088,11 @@ The CDRs of the elements are t for header keys and nil for crossref keys.") "Last reformat reference keys option given.") (defconst bibtex-field-name "[^\"#%'(),={} \t\n0-9][^\"#%'(),={} \t\n]*" - "Regexp matching the name part of a BibTeX field.") + "Regexp matching the name of a BibTeX field.") -(defconst bibtex-entry-type (concat "@" bibtex-field-name) - "Regexp matching the type part of a BibTeX entry.") +(defconst bibtex-name-part + (concat ",[ \t\n]*\\(" bibtex-field-name "\\)") + "Regexp matching the name part of a BibTeX field.") (defconst bibtex-reference-key "[][[:alnum:].:;?!`'/*@+|()<>&_^$-]+" "Regexp matching the reference key part of a BibTeX entry.") @@ -1084,54 +1100,50 @@ The CDRs of the elements are t for header keys and nil for crossref keys.") (defconst bibtex-field-const "[][[:alnum:].:;?!`'/*@+=|<>&_^$-]+" "Regexp matching a BibTeX field constant.") -(defconst bibtex-entry-head +(defvar bibtex-entry-type + (concat "@[ \t]*\\(?:" + (regexp-opt (mapcar 'car bibtex-entry-field-alist)) "\\)") + "Regexp matching the name of a BibTeX entry.") + +(defvar bibtex-entry-head (concat "^[ \t]*\\(" bibtex-entry-type "\\)[ \t]*[({][ \t\n]*\\(" bibtex-reference-key "\\)") - "Regexp matching the header line of a BibTeX entry.") + "Regexp matching the header line of a BibTeX entry (including key).") -(defconst bibtex-entry-maybe-empty-head +(defvar bibtex-entry-maybe-empty-head (concat bibtex-entry-head "?") "Regexp matching the header line of a BibTeX entry (possibly without key).") +(defconst bibtex-any-entry-maybe-empty-head + (concat "^[ \t]*\\(@[ \t]*" bibtex-field-name "\\)[ \t]*[({][ \t\n]*\\(" + bibtex-reference-key "\\)?") + "Regexp matching the header line of any BibTeX entry (possibly without key).") + +(defvar bibtex-any-valid-entry-type + (concat "^[ \t]*@[ \t]*\\(?:" + (regexp-opt (append '("String" "Preamble") + (mapcar 'car bibtex-entry-field-alist))) "\\)") + "Regexp matching any valid BibTeX entry (including String and Preamble).") + (defconst bibtex-type-in-head 1 "Regexp subexpression number of the type part in `bibtex-entry-head'.") (defconst bibtex-key-in-head 2 "Regexp subexpression number of the key part in `bibtex-entry-head'.") +(defconst bibtex-string-type "^[ \t]*\\(@[ \t]*String\\)[ \t]*[({][ \t\n]*" + "Regexp matching the name of a BibTeX String entry.") + (defconst bibtex-string-maybe-empty-head - (concat "^[ \t]*\\(@String\\)[ \t]*[({]\\(" - bibtex-reference-key - "\\)?") + (concat bibtex-string-type "\\(" bibtex-reference-key "\\)?") "Regexp matching the header line of a BibTeX String entry.") -(defconst bibtex-entry-postfix "[ \t\n]*,?[ \t\n]*[})]" - "Regexp matching the postfix of a BibTeX entry.") - -(defvar bibtex-known-entry-type-re - (regexp-opt (mapcar 'car bibtex-entry-field-alist)) - "Regexp matching the name of a BibTeX entry.") - -(defvar bibtex-valid-entry-re - (concat "@[ \t]*\\(" bibtex-known-entry-type-re "\\)") - "Regexp matching the name of a valid BibTeX entry.") - -(defvar bibtex-valid-entry-whitespace-re - (concat "[ \t]*\\(" bibtex-valid-entry-re "\\)") - "Regexp matching the name of a valid BibTeX entry preceded by whitespace.") - -(defvar bibtex-any-valid-entry-re - (concat "@[ \t]*" - (regexp-opt (append '("String") - (mapcar 'car bibtex-entry-field-alist)) - t)) - "Regexp matching the name of any valid BibTeX entry (including string).") - -(defconst bibtex-empty-field-re "\\`\\(\"\"\\|{}\\)\\'" - "Regexp matching the text part (as a string) of an empty field.") +(defconst bibtex-preamble-prefix + "[ \t]*\\(@[ \t]*Preamble\\)[ \t]*[({][ \t\n]*" + "Regexp matching the prefix part of a BibTeX Preamble entry.") (defconst bibtex-font-lock-syntactic-keywords `((,(concat "^[ \t]*\\(" (substring bibtex-comment-start 0 1) "\\)" @@ -1140,7 +1152,7 @@ The CDRs of the elements are t for header keys and nil for crossref keys.") (defvar bibtex-font-lock-keywords ;; entry type and reference key - `((,bibtex-entry-maybe-empty-head + `((,bibtex-any-entry-maybe-empty-head (,bibtex-type-in-head font-lock-function-name-face) (,bibtex-key-in-head font-lock-constant-face nil t)) ;; optional field names (treated as comments) @@ -1160,9 +1172,8 @@ The CDRs of the elements are t for header keys and nil for crossref keys.") "[ \t]*=[ \t]*") "Regexp for `bibtex-font-lock-url'.") -(defvar bibtex-field-name-for-parsing nil - "Regexp of field name to be parsed by function `bibtex-parse-field-name'. -Passed by dynamic scoping.") +(defvar bibtex-string-empty-key nil + "If non-nil, `bibtex-parse-string' accepts empty key.") (defvar bibtex-sort-entry-class-alist (let ((i -1) alist) @@ -1193,8 +1204,8 @@ ARG is ignored." "Parse a string of the format <left-hand-side = right-hand-side>. The functions PARSE-LHS and PARSE-RHS are used to parse the corresponding substrings. These functions are expected to return nil if parsing is not -successful. If both functions return non-nil, a pair containing the returned -values of the functions PARSE-LHS and PARSE-RHS is returned." +successful. If the returned values of both functions are non-nil, +return a cons pair of these values. Do not move point." (save-match-data (save-excursion (let ((left (funcall parse-lhs)) @@ -1206,23 +1217,24 @@ values of the functions PARSE-LHS and PARSE-RHS is returned." (cons left right)))))) (defun bibtex-parse-field-name () - "Parse the field name stored in `bibtex-field-name-for-parsing'. + "Parse the name part of a BibTeX field. If the field name is found, return a triple consisting of the position of the very first character of the match, the actual starting position of the name part and end position of the match. Move point to end of field name. If `bibtex-autoadd-commas' is non-nil add missing comma at end of preceding BibTeX field as necessary." - (cond ((looking-at ",[ \t\n]*") - (let ((start (point))) - (goto-char (match-end 0)) - (when (looking-at bibtex-field-name-for-parsing) - (goto-char (match-end 0)) - (list start (match-beginning 0) (match-end 0))))) + (cond ((looking-at bibtex-name-part) + (goto-char (match-end 0)) + (list (match-beginning 0) (match-beginning 1) (match-end 0))) ;; Maybe add a missing comma. ((and bibtex-autoadd-commas - (looking-at (concat "[ \t\n]*\\(?:" bibtex-field-name-for-parsing + (looking-at (concat "[ \t\n]*\\(?:" bibtex-field-name "\\)[ \t\n]*="))) (skip-chars-backward " \t\n") + ;; It can be confusing if non-editing commands try to + ;; modify the buffer. + (if buffer-read-only + (error "Comma missing at buffer position %s" (point))) (insert ",") (forward-char -1) ;; Now try again. @@ -1251,7 +1263,8 @@ BibTeX field as necessary." (defun bibtex-parse-field-string () "Parse a BibTeX field string enclosed by braces or quotes. If a syntactically correct string is found, a pair containing the start and -end position of the field string is returned, nil otherwise." +end position of the field string is returned, nil otherwise. +Do not move point." (let ((end-point (or (and (eq (following-char) ?\") (save-excursion @@ -1283,68 +1296,17 @@ returned, nil otherwise. Move point to end of field text." (if (looking-at "[ \t\n]*#[ \t\n]*") (goto-char (match-end 0)) (setq end-point (point)))) + (skip-chars-forward " \t\n") (if (and (not failure) end-point) - (cons starting-point end-point)))) - -(defun bibtex-parse-field (name) - "Parse a BibTeX field of regexp NAME. -If a syntactically correct field is found, a pair containing the boundaries of -the name and text parts of the field is returned." - (let ((bibtex-field-name-for-parsing name)) - (bibtex-parse-association 'bibtex-parse-field-name - 'bibtex-parse-field-text))) - -(defun bibtex-search-forward-field (name &optional bound) - "Search forward to find a BibTeX field of name NAME. -If a syntactically correct field is found, a pair containing the boundaries of -the name and text parts of the field is returned. The search is limited by -optional arg BOUND. If BOUND is t the search is limited by the end of the -current entry. Do not move point." - (save-match-data - (save-excursion - (unless (integer-or-marker-p bound) - (setq bound (if bound - (save-excursion (bibtex-end-of-entry)) - (point-max)))) - (let ((case-fold-search t) - (bibtex-field-name-for-parsing name) - boundaries temp-boundaries) - (while (and (not boundaries) - (< (point) bound) - (search-forward "," bound t)) - (goto-char (match-beginning 0)) - (if (and (setq temp-boundaries - (bibtex-parse-association 'bibtex-parse-field-name - 'bibtex-parse-field-text)) - (<= (cddr temp-boundaries) bound)) - (setq boundaries temp-boundaries) - (forward-char 1))) - boundaries)))) + (list starting-point end-point (point))))) -(defun bibtex-search-backward-field (name &optional bound) - "Search backward to find a BibTeX field of name NAME. -If a syntactically correct field is found, a pair containing the boundaries of -the name and text parts of the field is returned. The search is limited by -optional arg BOUND. If BOUND is t the search is limited by the beginning of the -current entry. Do not move point." - (save-match-data - (save-excursion - (unless (integer-or-marker-p bound) - (setq bound (if bound - (save-excursion (bibtex-beginning-of-entry)) - (point-min)))) - (let ((case-fold-search t) - (bibtex-field-name-for-parsing name) - boundaries temp-boundaries) - (while (and (not boundaries) - (>= (point) bound) - (search-backward "," bound t)) - (if (setq temp-boundaries - (bibtex-parse-association 'bibtex-parse-field-name - 'bibtex-parse-field-text)) - (setq boundaries temp-boundaries))) - boundaries)))) +(defun bibtex-parse-field () + "Parse the BibTeX field beginning at the position of point. +If a syntactically correct field is found, return a cons pair containing +the boundaries of the name and text parts of the field. Do not move point." + (bibtex-parse-association 'bibtex-parse-field-name + 'bibtex-parse-field-text)) (defsubst bibtex-start-of-field (bounds) (nth 0 (car bounds))) @@ -1352,51 +1314,134 @@ current entry. Do not move point." (nth 1 (car bounds))) (defsubst bibtex-end-of-name-in-field (bounds) (nth 2 (car bounds))) -(defsubst bibtex-end-of-field (bounds) - (cddr bounds)) (defsubst bibtex-start-of-text-in-field (bounds) - (cadr bounds)) + (nth 1 bounds)) (defsubst bibtex-end-of-text-in-field (bounds) - (cddr bounds)) + (nth 2 bounds)) +(defsubst bibtex-end-of-field (bounds) + (nth 3 bounds)) + +(defun bibtex-search-forward-field (name &optional bound) + "Search forward to find a BibTeX field of name NAME. +If a syntactically correct field is found, return a pair containing +the boundaries of the name and text parts of the field. The search +is limited by optional arg BOUND. If BOUND is t the search is limited +by the end of the current entry. Do not move point." + (save-match-data + (save-excursion + (if (eq bound t) + (let ((regexp (concat bibtex-name-part "[ \t\n]*=\\|" + bibtex-any-entry-maybe-empty-head)) + (case-fold-search t) bounds) + (catch 'done + (if (looking-at "[ \t]*@") (goto-char (match-end 0))) + (while (and (not bounds) + (re-search-forward regexp nil t)) + (if (match-beginning 2) + ;; We found a new entry + (throw 'done nil) + ;; We found a field + (goto-char (match-beginning 0)) + (setq bounds (bibtex-parse-field)))) + ;; Step through all fields so that we cannot overshoot. + (while bounds + (goto-char (bibtex-start-of-name-in-field bounds)) + (if (looking-at name) (throw 'done bounds)) + (goto-char (bibtex-end-of-field bounds)) + (setq bounds (bibtex-parse-field))))) + ;; Bounded search or bound is nil (i.e. we cannot overshoot). + ;; Indeed, the search is bounded when `bibtex-search-forward-field' + ;; is called many times. So we optimize this part of this function. + (let ((name-part (concat ",[ \t\n]*\\(" name "\\)[ \t\n]*=[ \t\n]*")) + (case-fold-search t) left right) + (while (and (not right) + (re-search-forward name-part bound t)) + (setq left (list (match-beginning 0) (match-beginning 1) + (match-end 1)) + ;; Don't worry that the field text could be past bound. + right (bibtex-parse-field-text))) + (if right (cons left right))))))) + +(defun bibtex-search-backward-field (name &optional bound) + "Search backward to find a BibTeX field of name NAME. +If a syntactically correct field is found, return a pair containing +the boundaries of the name and text parts of the field. The search +is limited by the optional arg BOUND. If BOUND is t the search is +limited by the beginning of the current entry. Do not move point." + (save-match-data + (if (eq bound t) + (setq bound (save-excursion (bibtex-beginning-of-entry)))) + (let ((name-part (concat ",[ \t\n]*\\(" name "\\)[ \t\n]*=[ \t\n]*")) + (case-fold-search t) left right) + (save-excursion + ;; the parsing functions are not designed for parsing backwards :-( + (when (search-backward "," bound t) + (or (save-excursion + (when (looking-at name-part) + (setq left (list (match-beginning 0) (match-beginning 1) + (match-end 1))) + (goto-char (match-end 0)) + (setq right (bibtex-parse-field-text)))) + (while (and (not right) + (re-search-backward name-part bound t)) + (setq left (list (match-beginning 0) (match-beginning 1) + (match-end 1))) + (save-excursion + (goto-char (match-end 0)) + (setq right (bibtex-parse-field-text))))) + (if right (cons left right))))))) (defun bibtex-name-in-field (bounds &optional remove-opt-alt) "Get content of name in BibTeX field defined via BOUNDS. If optional arg REMOVE-OPT-ALT is non-nil remove \"OPT\" and \"ALT\"." - (let ((name (buffer-substring-no-properties (nth 1 (car bounds)) - (nth 2 (car bounds))))) + (let ((name (buffer-substring-no-properties + (bibtex-start-of-name-in-field bounds) + (bibtex-end-of-name-in-field bounds)))) (if (and remove-opt-alt (string-match "\\`\\(OPT\\|ALT\\)" name)) (substring name 3) name))) -(defun bibtex-text-in-field-bounds (bounds &optional remove-delim) - "Get content of text in BibTeX field defined via BOUNDS. -If optional arg REMOVE-DELIM is non-nil remove enclosing field delimiters -if present." - (let ((content (buffer-substring-no-properties (cadr bounds) - (cddr bounds)))) - (if remove-delim - (bibtex-remove-delimiters-string content) - content))) +(defun bibtex-text-in-field-bounds (bounds &optional content) + "Get text in BibTeX field defined via BOUNDS. +If optional arg CONTENT is non-nil extract content of field +by removing field delimiters and concatenating the resulting string. +If `bibtex-expand-strings' is non-nil, also expand BibTeX strings." + (if content + (save-excursion + (goto-char (bibtex-start-of-text-in-field bounds)) + (let ((epoint (bibtex-end-of-text-in-field bounds)) + content opoint) + (while (< (setq opoint (point)) epoint) + (if (looking-at bibtex-field-const) + (let ((mtch (match-string-no-properties 0))) + (push (or (if bibtex-expand-strings + (cdr (assoc-string mtch (bibtex-strings) t))) + mtch) content) + (goto-char (match-end 0))) + (let ((bounds (bibtex-parse-field-string))) + (push (buffer-substring-no-properties + (1+ (car bounds)) (1- (cdr bounds))) content) + (goto-char (cdr bounds)))) + (re-search-forward "\\=[ \t\n]*#[ \t\n]*" nil t)) + (apply 'concat (nreverse content)))) + (buffer-substring-no-properties (bibtex-start-of-text-in-field bounds) + (bibtex-end-of-text-in-field bounds)))) (defun bibtex-text-in-field (field &optional follow-crossref) "Get content of field FIELD of current BibTeX entry. Return nil if not found. If optional arg FOLLOW-CROSSREF is non-nil, follow crossref." (save-excursion - (save-restriction - ;; We want to jump back and forth while searching FIELD - (bibtex-narrow-to-entry) - (goto-char (point-min)) - (let ((bounds (bibtex-search-forward-field field)) - crossref-field) - (cond (bounds (bibtex-text-in-field-bounds bounds t)) - ((and follow-crossref - (progn (goto-char (point-min)) - (setq bounds (bibtex-search-forward-field - "\\(OPT\\)?crossref")))) - (setq crossref-field (bibtex-text-in-field-bounds bounds t)) - (widen) + (let* ((end (if follow-crossref (bibtex-end-of-entry) t)) + (beg (bibtex-beginning-of-entry)) ; move point + (bounds (bibtex-search-forward-field field end))) + (cond (bounds (bibtex-text-in-field-bounds bounds t)) + ((and follow-crossref + (progn (goto-char beg) + (setq bounds (bibtex-search-forward-field + "\\(OPT\\)?crossref" end)))) + (let ((crossref-field (bibtex-text-in-field-bounds bounds t))) (if (bibtex-find-crossref crossref-field) ;; Do not pass FOLLOW-CROSSREF because we want ;; to follow crossrefs only one level of recursion. @@ -1406,16 +1451,21 @@ If optional arg FOLLOW-CROSSREF is non-nil, follow crossref." "Parse the prefix part of a BibTeX string entry, including reference key. If the string prefix is found, return a triple consisting of the position of the very first character of the match, the actual starting position of the -reference key and the end position of the match." +reference key and the end position of the match. +If `bibtex-string-empty-key' is non-nil accept empty string key." (let ((case-fold-search t)) - (if (looking-at "^[ \t]*@string[ \t\n]*[({][ \t\n]*") + (if (looking-at bibtex-string-type) (let ((start (point))) (goto-char (match-end 0)) - (when (looking-at bibtex-reference-key) - (goto-char (match-end 0)) - (list start - (match-beginning 0) - (match-end 0))))))) + (cond ((looking-at bibtex-reference-key) + (goto-char (match-end 0)) + (list start + (match-beginning 0) + (match-end 0))) + ((and bibtex-string-empty-key + (looking-at "=")) + (skip-chars-backward " \t\n") + (list start (point) (point)))))))) (defun bibtex-parse-string-postfix () "Parse the postfix part of a BibTeX string entry, including the text. @@ -1425,65 +1475,47 @@ character of the string entry. Move point past BibTeX string entry." (let* ((case-fold-search t) (bounds (bibtex-parse-field-text))) (when bounds - (goto-char (cdr bounds)) + (goto-char (nth 1 bounds)) (when (looking-at "[ \t\n]*[})]") (goto-char (match-end 0)) (list (car bounds) - (cdr bounds) + (nth 1 bounds) (match-end 0)))))) -(defun bibtex-parse-string () - "Parse a BibTeX string entry. -If a syntactically correct entry is found, a pair containing the boundaries of -the reference key and text parts of the entry is returned. -Move point past BibTeX string entry." - (bibtex-parse-association 'bibtex-parse-string-prefix - 'bibtex-parse-string-postfix)) +(defun bibtex-parse-string (&optional empty-key) + "Parse a BibTeX string entry beginning at the position of point. +If a syntactically correct entry is found, return a cons pair containing +the boundaries of the reference key and text parts of the entry. +If EMPTY-KEY is non-nil, key may be empty. Do not move point." + (let ((bibtex-string-empty-key empty-key)) + (bibtex-parse-association 'bibtex-parse-string-prefix + 'bibtex-parse-string-postfix))) -(defun bibtex-search-forward-string () +(defun bibtex-search-forward-string (&optional empty-key) "Search forward to find a BibTeX string entry. If a syntactically correct entry is found, a pair containing the boundaries of -the reference key and text parts of the string is returned. Do not move point." - (save-excursion - (save-match-data - (let ((case-fold-search t) - boundaries) - (while (and (not boundaries) - (search-forward-regexp - "^[ \t]*@string[ \t\n]*[({][ \t\n]*" nil t)) - (goto-char (match-beginning 0)) - (unless (setq boundaries (bibtex-parse-string)) - (forward-char 1))) - boundaries)))) - -(defun bibtex-search-backward-string () - "Search backward to find a BibTeX string entry. -If a syntactically correct entry is found, a pair containing the boundaries of -the reference key and text parts of the field is returned. Do not move point." +the reference key and text parts of the string is returned. +If EMPTY-KEY is non-nil, key may be empty. Do not move point." (save-excursion (save-match-data - (let ((case-fold-search t) - boundaries) - (while (and (not boundaries) - (search-backward-regexp - "^[ \t]*@string[ \t\n]*[({][ \t\n]*" nil t)) - (goto-char (match-beginning 0)) - (setq boundaries (bibtex-parse-string))) - boundaries)))) + (let ((case-fold-search t) bounds) + (while (and (not bounds) + (search-forward-regexp bibtex-string-type nil t)) + (save-excursion (goto-char (match-beginning 0)) + (setq bounds (bibtex-parse-string empty-key)))) + bounds)))) (defun bibtex-reference-key-in-string (bounds) + "Return the key part of a BibTeX string defined via BOUNDS" (buffer-substring-no-properties (nth 1 (car bounds)) (nth 2 (car bounds)))) -(defun bibtex-text-in-string (bounds &optional remove-delim) - "Get content of text in BibTeX string field defined via BOUNDS. -If optional arg REMOVE-DELIM is non-nil remove enclosing field -delimiters if present." - (let ((content (buffer-substring-no-properties (nth 0 (cdr bounds)) - (nth 1 (cdr bounds))))) - (if remove-delim - (bibtex-remove-delimiters-string content) - content))) +(defun bibtex-text-in-string (bounds &optional content) + "Get text in BibTeX string field defined via BOUNDS. +If optional arg CONTENT is non-nil extract content +by removing field delimiters and concatenating the resulting string. +If `bibtex-expand-strings' is non-nil, also expand BibTeX strings." + (bibtex-text-in-field-bounds bounds content)) (defsubst bibtex-start-of-text-in-string (bounds) (nth 0 (cdr bounds))) @@ -1503,14 +1535,17 @@ delimiters if present." (or (match-string-no-properties bibtex-key-in-head) empty)) -;; Helper Functions +(defun bibtex-parse-preamble () + "Parse BibTeX preamble. +Point must be at beginning of preamble. Do not move point." + (let ((case-fold-search t)) + (when (looking-at bibtex-preamble-prefix) + (let ((start (match-beginning 0)) (pref-start (match-beginning 1)) + (bounds (save-excursion (goto-char (match-end 0)) + (bibtex-parse-string-postfix)))) + (if bounds (cons (list start pref-start) bounds)))))) -(defun bibtex-remove-delimiters-string (str) - "Remove delimiters of string STR." - (if (and (memq (aref str 0) '(?\{ ?\")) - (memq (aref str (1- (length str))) '(?\} ?\"))) - (substring str 1 -1) - str)) +;; Helper Functions (defsubst bibtex-string= (str1 str2) "Return t if STR1 and STR2 are equal, ignoring case." @@ -1526,6 +1561,35 @@ delimiters if present." (+ (count-lines 1 (point)) (if (bolp) 1 0))) +(defun bibtex-valid-entry (&optional empty-key) + "Parse a valid BibTeX entry (maybe without key if EMPTY-KEY is t). +A valid entry is a syntactical correct one with type contained in +`bibtex-entry-field-alist'. Ignore @String and @Preamble entries. +Return a cons pair with buffer positions of beginning and end of entry +if a valid entry is found, nil otherwise. Do not move point. +After a call to this function `match-data' corresponds to the header +of the entry, see regexp `bibtex-entry-head'." + (let ((case-fold-search t) end) + (if (looking-at (if empty-key bibtex-entry-maybe-empty-head + bibtex-entry-head)) + (save-excursion + (save-match-data + (goto-char (match-end 0)) + (let ((entry-closer + (if (save-excursion + (goto-char (match-end bibtex-type-in-head)) + (looking-at "[ \t]*(")) + ",?[ \t\n]*)" ;; entry opened with `(' + ",?[ \t\n]*}")) ;; entry opened with `{' + bounds) + (skip-chars-forward " \t\n") + ;; loop over all BibTeX fields + (while (setq bounds (bibtex-parse-field)) + (goto-char (bibtex-end-of-field bounds))) + ;; This matches the infix* part. + (if (looking-at entry-closer) (setq end (match-end 0))))) + (if end (cons (match-beginning 0) end)))))) + (defun bibtex-skip-to-valid-entry (&optional backward) "Move point to beginning of the next valid BibTeX entry. Do not move if we are already at beginning of a valid BibTeX entry. @@ -1533,49 +1597,39 @@ With optional argument BACKWARD non-nil, move backward to beginning of previous valid one. A valid entry is a syntactical correct one with type contained in `bibtex-entry-field-alist' or, if `bibtex-sort-ignore-string-entries' is nil, a syntactical correct string -entry. Return buffer position of beginning and ending of entry if a valid +entry. Return buffer position of beginning and end of entry if a valid entry is found, nil otherwise." (interactive "P") (let ((case-fold-search t) - found) + found bounds) + (beginning-of-line) + ;; Loop till we look at a valid entry. (while (not (or found (if backward (bobp) (eobp)))) - (let ((pnt (point)) - bounds) - (cond ((or (and (looking-at bibtex-valid-entry-re) - (setq found (bibtex-search-entry nil nil t)) - (equal (match-beginning 0) pnt)) - (and (not bibtex-sort-ignore-string-entries) - (setq bounds (bibtex-parse-string)) - (setq found (cons (bibtex-start-of-field bounds) - (bibtex-end-of-string bounds))))) - (goto-char pnt)) - (backward - (if (re-search-backward "^[ \t]*\\(@\\)" nil 'move) - (goto-char (match-beginning 1)))) - (t (if (re-search-forward "\n[ \t]*@" nil 'move) - (forward-char -1)))))) + (cond ((setq found (or (bibtex-valid-entry) + (and (not bibtex-sort-ignore-string-entries) + (setq bounds (bibtex-parse-string)) + (cons (bibtex-start-of-field bounds) + (bibtex-end-of-string bounds)))))) + (backward (re-search-backward "^[ \t]*@" nil 'move)) + (t (if (re-search-forward "\n\\([ \t]*@\\)" nil 'move) + (goto-char (match-beginning 1)))))) found)) (defun bibtex-map-entries (fun) "Call FUN for each BibTeX entry in buffer (possibly narrowed). FUN is called with three arguments, the key of the entry and the buffer -positions (marker) of beginning and end of entry. Point is inside the entry. -If `bibtex-sort-ignore-string-entries' is non-nil, FUN is not called for -@String entries." - (let ((case-fold-search t)) +positions of beginning and end of entry. Also, point is at beginning of +entry and `match-data' corresponds to the header of the entry, +see regexp `bibtex-entry-head'. If `bibtex-sort-ignore-string-entries' +is non-nil, FUN is not called for @String entries." + (let ((case-fold-search t) + found) (save-excursion (goto-char (point-min)) - (while (re-search-forward bibtex-entry-head nil t) - (let ((entry-type (bibtex-type-in-head)) - (key (bibtex-key-in-head "")) - (beg (copy-marker (match-beginning 0))) - (end (copy-marker (save-excursion (bibtex-end-of-entry))))) - (save-excursion - (if (or (and (not bibtex-sort-ignore-string-entries) - (bibtex-string= entry-type "string")) - (assoc-string entry-type bibtex-entry-field-alist t)) - (funcall fun key beg end))) - (goto-char end)))))) + (while (setq found (bibtex-skip-to-valid-entry)) + (looking-at bibtex-any-entry-maybe-empty-head) + (funcall fun (bibtex-key-in-head "") (car found) (cdr found)) + (goto-char (cdr found)))))) (defun bibtex-progress-message (&optional flag interval) "Echo a message about progress of current buffer. @@ -1625,89 +1679,19 @@ If FLAG is nil, a message is echoed if point was incremented at least "}" ")")) -(defun bibtex-search-entry (empty-head &optional bound noerror backward) - "Search for a BibTeX entry (maybe without reference key if EMPTY-HEAD is t). -BOUND and NOERROR are exactly as in `re-search-forward'. If BACKWARD -is non-nil, search in reverse direction. Move point past the closing -delimiter (at the beginning of entry if BACKWARD is non-nil). -Return a cons pair with buffer positions of beginning and end of entry. -After call to this function MATCH-BEGINNING and MATCH-END functions -are defined, but only for the head part of the entry -\(especially (match-end 0) just gives the end of the head part)." - (let ((pnt (point)) - (entry-head-re (if empty-head - bibtex-entry-maybe-empty-head - bibtex-entry-head))) - (if backward - (let (found) - (while (and (not found) - (re-search-backward entry-head-re bound noerror)) - (setq found (bibtex-search-entry empty-head pnt t))) - (if found - (progn (goto-char (match-beginning 0)) - found) - (cond ((not noerror) - ;; yell - (error "Backward search of BibTeX entry failed")) - ((eq noerror t) - ;; don't move - (goto-char pnt))) - nil)) - (let (found) - (unless bound (setq bound (point-max))) - (while (and (not found) - (re-search-forward entry-head-re bound noerror)) - (save-match-data - (let ((entry-closer - (if (save-excursion - (goto-char (match-end bibtex-type-in-head)) - (looking-at "[ \t]*(")) - ;; entry opened with parenthesis - ?\) - ?\})) - (infix-start (point)) - finished bounds) - (while (not finished) - (skip-chars-forward " \t\n" bound) - (if (and (setq bounds (bibtex-parse-field bibtex-field-name)) - (<= (bibtex-end-of-field bounds) bound)) - (setq infix-start (bibtex-end-of-field bounds)) - (setq finished t)) - (goto-char infix-start)) - ;; This matches the infix* part. The AND construction assures - ;; that BOUND is respected. - (when (and (looking-at bibtex-entry-postfix) - (eq (char-before (match-end 0)) entry-closer) - (<= (match-end 0) bound)) - (goto-char (match-end 0)) - (setq found t))))) - (if found - (cons (match-beginning 0) (point)) - (cond ((not noerror) - ;; yell - (error "Search of BibTeX entry failed")) - ((eq noerror t) - ;; don't move - (goto-char pnt))) - nil))))) - -(defun bibtex-flash-head () +(defun bibtex-flash-head (prompt) "Flash at BibTeX entry head before point, if exists." (let ((case-fold-search t) - flash) - (cond ((re-search-backward bibtex-entry-head nil t) - (goto-char (match-beginning bibtex-type-in-head)) - (setq flash (match-end bibtex-key-in-head))) - (t - (end-of-line) - (skip-chars-backward " \t") - (setq flash (point)) - (beginning-of-line) - (skip-chars-forward " \t"))) - (if (pos-visible-in-window-p (point)) - (sit-for 1) - (message "From: %s" - (buffer-substring (point) flash))))) + (pnt (point))) + (save-excursion + (bibtex-beginning-of-entry) + (when (and (looking-at bibtex-any-entry-maybe-empty-head) + (< (point) pnt)) + (goto-char (match-beginning bibtex-type-in-head)) + (if (pos-visible-in-window-p (point)) + (sit-for 1) + (message "%s%s" prompt (buffer-substring-no-properties + (point) (match-end bibtex-key-in-head)))))))) (defun bibtex-make-optional-field (field) "Make an optional field named FIELD in current BibTeX entry." @@ -1731,79 +1715,62 @@ are defined, but only for the head part of the entry (skip-chars-forward " \t\n"))) (defun bibtex-beginning-of-first-entry () - "Go to the beginning of the first BibTeX entry in buffer. Return point." + "Go to beginning of line of first BibTeX entry in buffer. +If `bibtex-sort-ignore-string-entries' is non-nil, @String entries +are ignored. Return point" (goto-char (point-min)) - (if (re-search-forward "^[ \t]*@" nil 'move) - (beginning-of-line)) + (bibtex-skip-to-valid-entry) (point)) -(defun bibtex-beginning-of-last-entry () - "Go to the beginning of the last BibTeX entry in buffer." - (goto-char (point-max)) - (if (re-search-backward "^[ \t]*@" nil 'move) - (beginning-of-line)) - (point)) - -(defun bibtex-inside-field () - "Try to avoid point being at end of a BibTeX field." - (end-of-line) - (skip-chars-backward " \t") - (if (= (preceding-char) ?,) - (forward-char -2)) - (if (or (= (preceding-char) ?}) - (= (preceding-char) ?\")) - (forward-char -1))) - -(defun bibtex-enclosing-field (&optional noerr) +(defun bibtex-enclosing-field (&optional comma noerr) "Search for BibTeX field enclosing point. +For `bibtex-mode''s internal algorithms, a field begins at the comma +following the preceding field. Usually, this is not what the user expects. +Thus if COMMA is non-nil, the \"current field\" includes the terminating comma. Unless NOERR is non-nil, signal an error if no enclosing field is found. On success return bounds, nil otherwise. Do not move point." - (let ((bounds (bibtex-search-backward-field bibtex-field-name t))) - (if (and bounds - (<= (bibtex-start-of-field bounds) (point)) - (>= (bibtex-end-of-field bounds) (point))) - bounds - (unless noerr - (error "Can't find enclosing BibTeX field"))))) - -(defun bibtex-enclosing-entry-maybe-empty-head () - "Search for BibTeX entry enclosing point. Move point to end of entry. -Beginning (but not end) of entry is given by (`match-beginning' 0)." - (let ((case-fold-search t) - (old-point (point))) - (unless (re-search-backward bibtex-entry-maybe-empty-head nil t) - (goto-char old-point) - (error "Can't find beginning of enclosing BibTeX entry")) - (goto-char (match-beginning bibtex-type-in-head)) - (unless (bibtex-search-entry t nil t) - (goto-char old-point) - (error "Can't find end of enclosing BibTeX entry")))) - -(defun bibtex-insert-kill (n) - "Reinsert the Nth stretch of killed BibTeX text." - (if (not bibtex-last-kill-command) - (error "BibTeX kill ring is empty") - (let* ((kr (if (eq bibtex-last-kill-command 'field) - 'bibtex-field-kill-ring - 'bibtex-entry-kill-ring)) - (kryp (if (eq bibtex-last-kill-command 'field) - 'bibtex-field-kill-ring-yank-pointer - 'bibtex-entry-kill-ring-yank-pointer)) - (current (car (set kryp (nthcdr (mod (- n (length (eval kryp))) - (length (eval kr))) - (eval kr)))))) - (if (eq bibtex-last-kill-command 'field) - (let (bibtex-help-message) - (bibtex-find-text) - (if (looking-at "[}\"]") - (forward-char)) - (set-mark (point)) - (message "Mark set") - (bibtex-make-field current t)) - (unless (eobp) (bibtex-beginning-of-entry)) - (set-mark (point)) - (message "Mark set") - (insert current))))) + (save-excursion + (when comma + (end-of-line) + (skip-chars-backward " \t") + (if (= (preceding-char) ?,) (forward-char -1))) + + (let ((bounds (bibtex-search-backward-field bibtex-field-name t))) + (cond ((and bounds + (<= (bibtex-start-of-field bounds) (point)) + (>= (bibtex-end-of-field bounds) (point))) + bounds) + ((not noerr) + (error "Can't find enclosing BibTeX field")))))) + +(defun bibtex-beginning-first-field (&optional beg) + "Move point to beginning of first field. +Optional arg BEG is beginning of entry." + (if beg (goto-char beg) (bibtex-beginning-of-entry)) + (looking-at bibtex-any-entry-maybe-empty-head) + (goto-char (match-end 0))) + +(defun bibtex-insert-kill (n &optional comma) + "Reinsert the Nth stretch of killed BibTeX text (field or entry). +Optional arg COMMA is as in `bibtex-enclosing-field'." + (unless bibtex-last-kill-command (error "BibTeX kill ring is empty")) + (let ((fun (lambda (kryp kr) ;; adapted from `current-kill' + (car (set kryp (nthcdr (mod (- n (length (eval kryp))) + (length kr)) kr)))))) + (if (eq bibtex-last-kill-command 'field) + (progn + ;; insert past the current field + (goto-char (bibtex-end-of-field (bibtex-enclosing-field comma))) + (set-mark (point)) + (message "Mark set") + (bibtex-make-field (funcall fun 'bibtex-field-kill-ring-yank-pointer + bibtex-field-kill-ring) t)) + ;; insert past the current entry + (bibtex-skip-to-valid-entry) + (set-mark (point)) + (message "Mark set") + (insert (funcall fun 'bibtex-entry-kill-ring-yank-pointer + bibtex-entry-kill-ring))))) (defun bibtex-format-entry () "Helper function for `bibtex-clean-entry'. @@ -1846,12 +1813,11 @@ Formats current entry according to variable `bibtex-entry-format'." ;; determine if entry has crossref field and if at least ;; one alternative is non-empty (goto-char (point-min)) - (let* ((fields-alist (bibtex-parse-entry)) + (let* ((fields-alist (bibtex-parse-entry t)) (field (assoc-string "crossref" fields-alist t))) (setq crossref-key (and field - (not (string-match bibtex-empty-field-re - (cdr field))) - (bibtex-remove-delimiters-string (cdr field))) + (not (equal "" (cdr field))) + (cdr field)) req-field-list (if crossref-key (nth 0 (nth 2 entry-list)) ; crossref part (nth 0 (nth 1 entry-list)))) ; required part @@ -1861,8 +1827,7 @@ Formats current entry according to variable `bibtex-entry-format'." (setq alternatives-there t field (assoc-string (car rfield) fields-alist t)) (if (and field - (not (string-match bibtex-empty-field-re - (cdr field)))) + (not (equal "" (cdr field)))) (cond ((not non-empty-alternative) (setq non-empty-alternative t)) ((memq 'required-fields format) @@ -1874,8 +1839,8 @@ Formats current entry according to variable `bibtex-entry-format'." (error "All alternatives are empty")) ;; process all fields - (goto-char (point-min)) - (while (setq bounds (bibtex-search-forward-field bibtex-field-name)) + (bibtex-beginning-first-field (point-min)) + (while (setq bounds (bibtex-parse-field)) (let* ((beg-field (copy-marker (bibtex-start-of-field bounds))) (end-field (copy-marker (bibtex-end-of-field bounds) t)) (beg-name (copy-marker (bibtex-start-of-name-in-field bounds))) @@ -1887,9 +1852,7 @@ Formats current entry according to variable `bibtex-entry-format'." beg-name (+ beg-name 3)))) (field-name (buffer-substring-no-properties (if opt-alt (+ beg-name 3) beg-name) end-name)) - (empty-field (string-match bibtex-empty-field-re - (buffer-substring-no-properties - beg-text end-text))) + (empty-field (equal "" (bibtex-text-in-field-bounds bounds t))) deleted) ;; We have more elegant high-level functions for several @@ -2015,10 +1978,6 @@ Formats current entry according to variable `bibtex-entry-format'." (error "Alternative fields `%s' are defined %s times" altlist found)))))) - ;; update point - (if (looking-at (bibtex-field-right-delimiter)) - (forward-char)) - ;; update comma after last field (if (memq 'last-comma format) (cond ((and bibtex-comma-after-last-field @@ -2065,7 +2024,8 @@ is returned unchanged." Optional arg CHANGE-LIST is a list of substitution patterns that is applied to the content of FIELD. It is an alist with pairs \(OLD-REGEXP . NEW-STRING\)." - (let ((content (bibtex-text-in-field field bibtex-autokey-use-crossref)) + (let* ((bibtex-expand-strings bibtex-autokey-expand-strings) + (content (bibtex-text-in-field field bibtex-autokey-use-crossref)) case-fold-search) (unless content (setq content "")) (dolist (pattern change-list content) @@ -2195,6 +2155,7 @@ The algorithm works as follows. The name part: 1. Use the author or editor field to generate the name part of the key. + Expand BibTeX strings if `bibtex-autokey-expand-strings' is non-nil. 2. Change the content of the name field according to `bibtex-autokey-name-change-strings' (see there for further detail). 3. Use the first `bibtex-autokey-names' names in the name field. If there @@ -2299,7 +2260,9 @@ If optional arg GLOBAL is non-nil, completion is based on the keys in "Set `bibtex-reference-keys' to the keys used in the whole buffer. Find both entry keys and crossref entries. If ABORTABLE is non-nil abort on user input. If VERBOSE is non-nil give messages about progress. -Return alist of keys if parsing was completed, `aborted' otherwise." +Return alist of keys if parsing was completed, `aborted' otherwise. +If `bibtex-parse-keys-fast' is non-nil, use fast but simplified algorithm +for parsing BibTeX keys. If parsing fails, try to set this variable to nil." (let (ref-keys crossref-keys) (save-excursion (save-match-data @@ -2387,6 +2350,11 @@ Return alist of strings if parsing was completed, `aborted' otherwise." ;; successful operation --> return `bibtex-strings' (setq bibtex-strings strings)))))) +(defun bibtex-strings () + "Return `bibtex-strings'. Initialize this variable if necessary." + (if (listp bibtex-strings) bibtex-strings + (bibtex-parse-strings (bibtex-string-files-init)))) + (defun bibtex-string-files-init () "Return initialization for `bibtex-strings'. Use `bibtex-predefined-strings' and BibTeX files `bibtex-string-files'." @@ -2502,6 +2470,7 @@ already set." "Complete word fragment before point to longest prefix of COMPLETIONS. COMPLETIONS is an alist of strings. If point is not after the part of a word, all strings are listed. Return completion." + ;; Return value is used by cleanup functions. (let* ((case-fold-search t) (beg (save-excursion (re-search-backward "[ \t{\"]") @@ -2521,29 +2490,21 @@ of a word, all strings are listed. Return completion." (t (message "Making completion list...") (with-output-to-temp-buffer "*Completions*" - (display-completion-list (all-completions part-of-word - completions) + (display-completion-list (all-completions part-of-word completions) part-of-word)) (message "Making completion list...done") - ;; return value is handled by choose-completion-string-functions nil)))) (defun bibtex-complete-string-cleanup (str compl) "Cleanup after inserting string STR. Remove enclosing field delimiters for STR. Display message with expansion of STR using expansion list COMPL." + ;; point is at position inside field where completion was requested (save-excursion - (bibtex-inside-field) - (let ((bounds (bibtex-enclosing-field)) - (abbr (cdr (if (stringp str) + (let ((abbr (cdr (if (stringp str) (assoc-string str compl t))))) (if abbr (message "Abbreviation for `%s'" abbr)) - (goto-char (bibtex-start-of-text-in-field bounds)) - (let ((boundaries (bibtex-parse-field-string))) - (if (and boundaries - (equal (cdr boundaries) - (bibtex-end-of-text-in-field bounds))) - (bibtex-remove-delimiters)))))) + (bibtex-remove-delimiters)))) (defun bibtex-complete-crossref-cleanup (key) "Display summary message on entry KEY after completion of a crossref key. @@ -2598,52 +2559,52 @@ Used as default value of `bibtex-summary-function'." (defun bibtex-pop (arg direction) "Fill current field from the ARGth same field's text in DIRECTION. Generic function used by `bibtex-pop-previous' and `bibtex-pop-next'." - (let (bibtex-help-message) - (bibtex-find-text)) - (save-excursion - ;; parse current field - (bibtex-inside-field) - (let* ((case-fold-search t) - (bounds (bibtex-enclosing-field)) - (start-old-text (bibtex-start-of-text-in-field bounds)) - (stop-old-text (bibtex-end-of-text-in-field bounds)) - (field-name (bibtex-name-in-field bounds t))) + ;; parse current field + (let* ((bounds (bibtex-enclosing-field t)) + (start-old-field (bibtex-start-of-field bounds)) + (start-old-text (bibtex-start-of-text-in-field bounds)) + (end-old-text (bibtex-end-of-text-in-field bounds)) + (field-name (bibtex-name-in-field bounds t)) + failure) + (save-excursion ;; if executed several times in a row, start each search where ;; the last one was finished - (unless (eq last-command 'bibtex-pop) - (bibtex-enclosing-entry-maybe-empty-head) - (setq bibtex-pop-previous-search-point (match-beginning 0) - bibtex-pop-next-search-point (point))) - (if (eq direction 'previous) - (goto-char bibtex-pop-previous-search-point) - (goto-char bibtex-pop-next-search-point)) - ;; Now search for arg'th previous/next similar field - (let (bounds failure new-text) - (while (and (not failure) - (> arg 0)) - (cond ((eq direction 'previous) - (if (setq bounds (bibtex-search-backward-field field-name)) - (goto-char (bibtex-start-of-field bounds)) - (setq failure t))) - ((eq direction 'next) - (if (setq bounds (bibtex-search-forward-field field-name)) - (goto-char (bibtex-end-of-field bounds)) - (setq failure t)))) - (setq arg (- arg 1))) - (if failure - (error "No %s matching BibTeX field" - (if (eq direction 'previous) "previous" "next")) - ;; Found a matching field. Remember boundaries. - (setq bibtex-pop-previous-search-point (bibtex-start-of-field bounds) - bibtex-pop-next-search-point (bibtex-end-of-field bounds) - new-text (bibtex-text-in-field-bounds bounds)) - (bibtex-flash-head) + (cond ((eq last-command 'bibtex-pop) + (goto-char (if (eq direction 'previous) + bibtex-pop-previous-search-point + bibtex-pop-next-search-point))) + ((eq direction 'previous) + (bibtex-beginning-of-entry)) + (t (bibtex-end-of-entry))) + ;; Search for arg'th previous/next similar field + (while (and (not failure) + (>= (setq arg (1- arg)) 0)) + ;; The search of BibTeX fields is not bounded by entry boundaries + (if (eq direction 'previous) + (if (setq bounds (bibtex-search-backward-field field-name)) + (goto-char (bibtex-start-of-field bounds)) + (setq failure t)) + (if (setq bounds (bibtex-search-forward-field field-name)) + (goto-char (bibtex-end-of-field bounds)) + (setq failure t)))) + (if failure + (error "No %s matching BibTeX field" + (if (eq direction 'previous) "previous" "next")) + ;; Found a matching field. Remember boundaries. + (let ((new-text (bibtex-text-in-field-bounds bounds)) + (nbeg (copy-marker (bibtex-start-of-field bounds))) + (nend (copy-marker (bibtex-end-of-field bounds)))) + (bibtex-flash-head "From: ") ;; Go back to where we started, delete old text, and pop new. - (goto-char stop-old-text) - (delete-region start-old-text stop-old-text) - (insert new-text))))) - (let (bibtex-help-message) - (bibtex-find-text)) + (goto-char end-old-text) + (delete-region start-old-text end-old-text) + (if (= nbeg start-old-field) + (insert (bibtex-field-left-delimiter) + (bibtex-field-right-delimiter)) + (insert new-text)) + (setq bibtex-pop-previous-search-point (marker-position nbeg) + bibtex-pop-next-search-point (marker-position nend)))))) + (bibtex-find-text nil nil nil t) (setq this-command 'bibtex-pop)) (defun bibtex-beginning-of-field () @@ -2667,7 +2628,7 @@ begins at the beginning of a line. We use this function for font-locking." (setq field (match-string-no-properties 1))) (setq bounds (bibtex-parse-field-text)) (progn - (setq start (car bounds) end (cdr bounds)) + (setq start (car bounds) end (nth 1 bounds)) ;; Always ignore field delimiters (if (memq (char-before end) '(?\} ?\")) (setq end (1- end))) @@ -2822,6 +2783,7 @@ if that value is non-nil. (list (list nil bibtex-entry-head bibtex-key-in-head)) imenu-case-fold-search t) (make-local-variable 'choose-completion-string-functions) + (make-local-variable 'completion-ignore-case) ;; XEmacs needs easy-menu-add, Emacs does not care (easy-menu-add bibtex-edit-menu) (easy-menu-add bibtex-entry-menu) @@ -2837,7 +2799,7 @@ and `bibtex-user-optional-fields'." (let ((e (assoc-string entry-type bibtex-entry-field-alist t)) required optional) (unless e - (error "BibTeX entry type %s not defined" entry-type)) + (error "Fields for BibTeX entry type %s not defined" entry-type)) (if (and (member-ignore-case entry-type bibtex-include-OPTcrossref) (nth 2 e)) (setq required (nth 0 (nth 2 e)) @@ -2894,10 +2856,11 @@ according to `bibtex-field-list', but are not yet present." (save-excursion (bibtex-beginning-of-entry) ;; For inserting new fields, we use the fact that - ;; bibtex-parse-entry moves point to the end of the last field. + ;; `bibtex-parse-entry' moves point to the end of the last field. (let* ((fields-alist (bibtex-parse-entry)) (field-list (bibtex-field-list (cdr (assoc "=type=" fields-alist))))) + (skip-chars-backward " \t\n") (dolist (field (car field-list)) (unless (assoc-string (car field) fields-alist t) (bibtex-make-field field))) @@ -2905,20 +2868,21 @@ according to `bibtex-field-list', but are not yet present." (unless (assoc-string (car field) fields-alist t) (bibtex-make-optional-field field)))))) -(defun bibtex-parse-entry () +(defun bibtex-parse-entry (&optional content) "Parse entry at point, return an alist. The alist elements have the form (FIELD . TEXT), where FIELD can also be the special strings \"=type=\" and \"=key=\". For the FIELD \"=key=\" TEXT may be nil. Remove \"OPT\" and \"ALT\" from FIELD. -Move point to the end of the last field." +Move point to the end of the last field. +If optional arg CONTENT is non-nil extract content of text fields." (let (alist bounds) (when (looking-at bibtex-entry-maybe-empty-head) (push (cons "=type=" (bibtex-type-in-head)) alist) (push (cons "=key=" (bibtex-key-in-head)) alist) (goto-char (match-end 0)) - (while (setq bounds (bibtex-parse-field bibtex-field-name)) + (while (setq bounds (bibtex-parse-field)) (push (cons (bibtex-name-in-field bounds t) - (bibtex-text-in-field-bounds bounds)) + (bibtex-text-in-field-bounds bounds content)) alist) (goto-char (bibtex-end-of-field bounds)))) alist)) @@ -2939,6 +2903,7 @@ entry (for example, the year parts of the keys)." (key (bibtex-key-in-head)) (key-end (match-end bibtex-key-in-head)) (case-fold-search t) + (bibtex-sort-ignore-string-entries t) tmp other-key other bounds) ;; The fields we want to change start right after the key. (goto-char key-end) @@ -2970,14 +2935,11 @@ entry (for example, the year parts of the keys)." (when other (setq other (save-excursion (goto-char other) (bibtex-parse-entry))) (setq key-end (point)) ;In case parse-entry changed the buffer. - (while (setq bounds (bibtex-parse-field bibtex-field-name)) + (while (setq bounds (bibtex-parse-field)) (let ((text (assoc-string (bibtex-name-in-field bounds t) other t))) (if (not (and text - (string-match bibtex-empty-field-re - (buffer-substring-no-properties - (bibtex-start-of-text-in-field bounds) - (bibtex-end-of-text-in-field bounds))))) + (equal "" (bibtex-text-in-field-bounds bounds t)))) (goto-char (bibtex-end-of-field bounds)) (goto-char (bibtex-start-of-text-in-field bounds)) (delete-region (point) (bibtex-end-of-text-in-field bounds)) @@ -2994,21 +2956,27 @@ entry (for example, the year parts of the keys)." (while (re-search-backward (regexp-quote other-suffix) key-end 'move) (replace-match suffix))))))) -(defun bibtex-print-help-message () - "Print helpful information about current field in current BibTeX entry." - (interactive) - (save-excursion +(defun bibtex-print-help-message (&optional field comma) + "Print helpful information about current FIELD in current BibTeX entry. +Optional arg COMMA is as in `bibtex-enclosing-field'. It is t for +interactive calls." + (interactive (list nil t)) + (unless field (setq field (car (bibtex-find-text-internal nil nil comma)))) + (if (string-match "@" field) + (cond ((bibtex-string= field "@string") + (message "String definition")) + ((bibtex-string= field "@preamble") + (message "Preamble definition")) + (t (message "Entry key"))) (let* ((case-fold-search t) - (field-name (bibtex-name-in-field (bibtex-enclosing-field) t)) - (field-list (bibtex-field-list (progn (re-search-backward - bibtex-entry-maybe-empty-head nil t) - (bibtex-type-in-head)))) - (comment (assoc-string field-name - (append (car field-list) - (cdr field-list)) - t))) - (if comment - (message "%s" (nth 1 comment)) + (type (save-excursion + (bibtex-beginning-of-entry) + (looking-at bibtex-entry-maybe-empty-head) + (bibtex-type-in-head))) + (field-list (bibtex-field-list type)) + (comment (assoc-string field (append (car field-list) + (cdr field-list)) t))) + (if comment (message "%s" (nth 1 comment)) (message "No comment available"))))) (defun bibtex-make-field (field &optional move interactive) @@ -3024,7 +2992,8 @@ MOVE and INTERACTIVE are t when called interactively." (list (let ((completion-ignore-case t) (field-list (bibtex-field-list (save-excursion - (bibtex-enclosing-entry-maybe-empty-head) + (bibtex-beginning-of-entry) + (looking-at bibtex-any-entry-maybe-empty-head) (bibtex-type-in-head))))) (completing-read "BibTeX field name: " (append (car field-list) (cdr field-list)) @@ -3032,11 +3001,10 @@ MOVE and INTERACTIVE are t when called interactively." t t)) (unless (consp field) (setq field (list field))) - (if move - (let (bibtex-help-message) - (bibtex-find-text) - (if (looking-at "[}\"]") - (forward-char)))) + (when move + (bibtex-find-text) + (if (looking-at "[}\"]") + (forward-char))) (insert ",\n") (indent-to-column (+ bibtex-entry-offset bibtex-field-indentation)) (if (nth 3 field) (insert "ALT")) @@ -3054,8 +3022,9 @@ MOVE and INTERACTIVE are t when called interactively." (t (concat (bibtex-field-left-delimiter) (bibtex-field-right-delimiter)))))) (when interactive - (forward-char -1) - (bibtex-print-help-message))) + ;; (bibtex-find-text nil nil bibtex-help-message) + (if (memq (preceding-char) '(?} ?\")) (forward-char -1)) + (if bibtex-help-message (bibtex-print-help-message (car field))))) (defun bibtex-beginning-of-entry () "Move to beginning of BibTeX entry (beginning of line). @@ -3076,28 +3045,19 @@ of the previous entry. Do not move if ahead of first entry. Return the new location of point." (interactive) (let ((case-fold-search t) - (org (point)) - (pnt (bibtex-beginning-of-entry)) - err bounds) - (cond ((looking-at bibtex-valid-entry-whitespace-re) - (bibtex-search-entry t nil t) - (unless (equal (match-beginning 0) pnt) - (setq err t))) - ((setq bounds (bibtex-parse-string)) + (pnt (point)) + (_ (bibtex-beginning-of-entry)) + (bounds (bibtex-valid-entry t))) + (cond (bounds (goto-char (cdr bounds))) ; regular entry + ;; @String or @Preamble + ((setq bounds (or (bibtex-parse-string t) (bibtex-parse-preamble))) (goto-char (bibtex-end-of-string bounds))) - ((looking-at "[ \t]*@[ \t]*preamble[ \t\n]*") - (goto-char (match-end 0)) - (if (looking-at "[({]") - (forward-sexp 1) - (setq err t))) - (t - (if (interactive-p) - (message "Not on a known BibTeX entry.")) - (goto-char org))) - (when err - (goto-char pnt) - (error "Syntactically incorrect BibTeX entry starts here"))) - (point)) + ((looking-at bibtex-any-valid-entry-type) + ;; Parsing of entry failed + (error "Syntactically incorrect BibTeX entry starts here.")) + (t (if (interactive-p) (message "Not on a known BibTeX entry.")) + (goto-char pnt))) + (point))) (defun bibtex-goto-line (arg) "Goto line ARG, counting from beginning of (narrowed) buffer." @@ -3142,15 +3102,10 @@ otherwise count all entries except @String entries. If mark is active count entries in region, if not in whole buffer." (interactive "P") (let ((number 0) - (bibtex-sort-ignore-string-entries - (not count-string-entries))) - (save-excursion - (save-restriction - (narrow-to-region (if mark-active (region-beginning) - (bibtex-beginning-of-first-entry)) - (if mark-active (region-end) (point-max))) - (bibtex-map-entries (lambda (key beg end) - (setq number (1+ number)))))) + (bibtex-sort-ignore-string-entries (not count-string-entries))) + (save-restriction + (if mark-active (narrow-to-region (region-beginning) (region-end))) + (bibtex-map-entries (lambda (key beg end) (setq number (1+ number))))) (message "%s contains %d entries." (if mark-active "Region" "Buffer") number))) @@ -3237,17 +3192,13 @@ If its value is nil use plain sorting. Text outside of BibTeX entries is not affected. If `bibtex-sort-ignore-string-entries' is non-nil, @String entries are ignored." (interactive) - (save-restriction - (narrow-to-region (bibtex-beginning-of-first-entry) - (save-excursion (goto-char (point-max)) - (bibtex-end-of-entry))) - (bibtex-skip-to-valid-entry) + (bibtex-beginning-of-first-entry) ;; needed by `sort-subr' (sort-subr nil 'bibtex-skip-to-valid-entry ; NEXTREC function 'bibtex-end-of-entry ; ENDREC function 'bibtex-entry-index ; STARTKEY function nil ; ENDKEY function - 'bibtex-lessp))) ; PREDICATE + 'bibtex-lessp)) ; PREDICATE (defun bibtex-find-crossref (crossref-key &optional pnt split) "Move point to the beginning of BibTeX entry CROSSREF-KEY. @@ -3361,11 +3312,10 @@ Return t if preparation was successful or nil if entry KEY already exists." (key-exist) (t ; bibtex-maintain-sorted-entries is non-nil (let* ((case-fold-search t) - (left (save-excursion (bibtex-beginning-of-first-entry) - (bibtex-skip-to-valid-entry) - (point))) - (right (save-excursion (bibtex-beginning-of-last-entry) - (bibtex-end-of-entry))) + (left (save-excursion (bibtex-beginning-of-first-entry))) + (bounds (save-excursion (goto-char (point-max)) + (bibtex-skip-to-valid-entry t))) + (right (if bounds (cdr bounds) (point-min))) (found (if (>= left right) left)) actual-index new) (save-excursion @@ -3412,41 +3362,38 @@ Return t if test was successful, nil otherwise." error-list syntax-error) (save-excursion (save-restriction - (narrow-to-region (if mark-active (region-beginning) - (bibtex-beginning-of-first-entry)) - (if mark-active (region-end) (point-max))) + (if mark-active (narrow-to-region (region-beginning) (region-end))) - ;; looking if entries fit syntactical structure + ;; Check syntactical structure of entries (goto-char (point-min)) (bibtex-progress-message "Checking syntactical structure") - (let (bibtex-sort-ignore-string-entries) - (while (re-search-forward "^[ \t]*@" nil t) + (let (bounds end) + (while (setq end (re-search-forward "^[ \t]*@" nil t)) (bibtex-progress-message) - (forward-char -1) - (let ((pnt (point))) - (if (not (looking-at bibtex-any-valid-entry-re)) - (forward-char) - (bibtex-skip-to-valid-entry) - (if (equal (point) pnt) - (forward-char) - (goto-char pnt) - (push (cons (bibtex-current-line) - "Syntax error (check esp. commas, braces, and quotes)") - error-list) - (forward-char)))))) + (goto-char (match-beginning 0)) + (cond ((setq bounds (bibtex-valid-entry)) + (goto-char (cdr bounds))) + ((setq bounds (or (bibtex-parse-string) + (bibtex-parse-preamble))) + (goto-char (bibtex-end-of-string bounds))) + ((looking-at bibtex-any-valid-entry-type) + (push (cons (bibtex-current-line) + "Syntax error (check esp. commas, braces, and quotes)") + error-list) + (goto-char (match-end 0))) + (t (goto-char end))))) (bibtex-progress-message 'done) (if error-list - ;; proceed only if there were no syntax errors. + ;; Continue only if there were no syntax errors. (setq syntax-error t) - ;; looking for duplicate keys and correct sort order + ;; Check for duplicate keys and correct sort order (let (previous current key-list) (bibtex-progress-message "Checking for duplicate keys") (bibtex-map-entries (lambda (key beg end) (bibtex-progress-message) - (goto-char beg) (setq current (bibtex-entry-index)) (cond ((not previous)) ((member key key-list) @@ -3482,18 +3429,13 @@ Return t if test was successful, nil otherwise." (bibtex-map-entries (lambda (key beg end) (bibtex-progress-message) - (let* ((entry-list (progn - (goto-char beg) - (bibtex-search-entry nil end) - (assoc-string (bibtex-type-in-head) - bibtex-entry-field-alist t))) + (let* ((entry-list (assoc-string (bibtex-type-in-head) + bibtex-entry-field-alist t)) (req (copy-sequence (elt (elt entry-list 1) 0))) (creq (copy-sequence (elt (elt entry-list 2) 0))) crossref-there bounds alt-there field) - (goto-char beg) - (while (setq bounds (bibtex-search-forward-field - bibtex-field-name end)) - (goto-char (bibtex-start-of-text-in-field bounds)) + (bibtex-beginning-first-field beg) + (while (setq bounds (bibtex-parse-field)) (let ((field-name (bibtex-name-in-field bounds))) (if (and (bibtex-string= field-name "month") ;; Check only abbreviated month fields. @@ -3505,18 +3447,19 @@ Return t if test was successful, nil otherwise." (push (cons (bibtex-current-line) "Questionable month field") error-list)) - (setq field (assoc-string field-name req t)) + (setq field (assoc-string field-name req t) + req (delete field req) + creq (delete (assoc-string field-name creq t) creq)) (if (nth 3 field) - (if alt-there (push (cons (bibtex-current-line) - "More than one non-empty alternative") - error-list) + (if alt-there + (push (cons (bibtex-current-line) + "More than one non-empty alternative") + error-list) (setq alt-there t))) - (setq req (delete field req) - creq (delete (assoc-string field-name creq t) creq)) (if (bibtex-string= field-name "crossref") - (setq crossref-there t)))) - (if crossref-there - (setq req creq)) + (setq crossref-there t))) + (goto-char (bibtex-end-of-field bounds))) + (if crossref-there (setq req creq)) (let (alt) (dolist (field req) (if (nth 3 field) @@ -3557,11 +3500,10 @@ Return t if test was successful, nil otherwise." (toggle-read-only 1) (goto-line 3)) ; first error message (display-buffer err-buf) - ;; return nil - nil) + nil) ; return `nil' (i.e., buffer is invalid) (message "%s is syntactically correct" (if mark-active "Region" "Buffer")) - t))) + t))) ; return `t' (i.e., buffer is valid) (defun bibtex-validate-globally (&optional strings) "Check for duplicate keys in `bibtex-files'. @@ -3597,7 +3539,7 @@ Return t if test was successful, nil otherwise." (dolist (key (cdr (assq buffer buffer-key-list))) (when (assoc-string key current-keys) (bibtex-find-entry key) - (push (format "%s:%d: Duplicat key `%s' in %s\n" + (push (format "%s:%d: Duplicate key `%s' in %s\n" (buffer-file-name) (bibtex-current-line) key (abbreviate-file-name (buffer-file-name buffer))) error-list)))))) @@ -3615,67 +3557,131 @@ Return t if test was successful, nil otherwise." (toggle-read-only 1) (goto-line 3)) ; first error message (display-buffer err-buf) - ;; return nil - nil) + nil) ; return `nil' (i.e., buffer is invalid) (message "No duplicate keys.") - t))) - -(defun bibtex-next-field (begin) - "Move point to end of text of next BibTeX field. -With prefix BEGIN non-nil, move point to its beginning." - (interactive "P") - (bibtex-inside-field) - (let ((start (point))) - (condition-case () - (let ((bounds (bibtex-enclosing-field))) - (goto-char (bibtex-end-of-field bounds)) - (forward-char 2)) - (error - (goto-char start) - (end-of-line) - (forward-char)))) - (bibtex-find-text begin)) - -(defun bibtex-find-text (&optional begin noerror) - "Move point to end of text of current BibTeX field. + t))) ; return `t' (i.e., buffer is valid) + +(defun bibtex-next-field (begin &optional comma) + "Move point to end of text of next BibTeX field or entry head. +With prefix BEGIN non-nil, move point to its beginning. Optional arg COMMA +is as in `bibtex-enclosing-field'. It is t for interactive calls." + (interactive (list current-prefix-arg t)) + (let ((bounds (bibtex-find-text-internal t nil comma)) + end-of-entry) + (if (not bounds) + (setq end-of-entry t) + (goto-char (nth 3 bounds)) + (if (assoc-string (car bounds) '("@String" "@Preamble") t) + (setq end-of-entry t) + ;; BibTeX key or field + (if (looking-at ",[ \t\n]*") (goto-char (match-end 0))) + ;; end of entry + (if (looking-at "[)}][ \t\n]*") (setq end-of-entry t)))) + (if (and end-of-entry + (re-search-forward bibtex-any-entry-maybe-empty-head nil t)) + (goto-char (match-beginning 0))) + (bibtex-find-text begin nil bibtex-help-message))) + +(defun bibtex-find-text (&optional begin noerror help comma) + "Move point to end of text of current BibTeX field or entry head. With optional prefix BEGIN non-nil, move point to its beginning. Unless NOERROR is non-nil, an error is signaled if point is not -on a BibTeX field." - (interactive "P") - (let* ((pnt (point)) - (_ (bibtex-inside-field)) - (bounds (bibtex-enclosing-field t))) - (beginning-of-line) +on a BibTeX field. If optional arg HELP is non-nil print help message. +When called interactively, the value of HELP is `bibtex-help-message'. +Optional arg COMMA is as in `bibtex-enclosing-field'. It is t for +interactive calls." + (interactive (list current-prefix-arg nil bibtex-help-message t)) + (let ((bounds (bibtex-find-text-internal t nil comma))) (cond (bounds (if begin - (progn (goto-char (bibtex-start-of-text-in-field bounds)) + (progn (goto-char (nth 1 bounds)) (if (looking-at "[{\"]") (forward-char))) - (goto-char (bibtex-end-of-text-in-field bounds)) - (if (or (= (preceding-char) ?}) - (= (preceding-char) ?\")) + (goto-char (nth 2 bounds)) + (if (memq (preceding-char) '(?} ?\")) (forward-char -1))) - (if bibtex-help-message - (bibtex-print-help-message))) - ((setq bounds (bibtex-parse-string)) - (goto-char (if begin - (1+ (bibtex-start-of-text-in-string bounds)) - (1- (bibtex-end-of-text-in-string bounds))))) - ((looking-at bibtex-entry-maybe-empty-head) - (goto-char (if begin - (match-beginning bibtex-key-in-head) - (match-end 0)))) - (t - (goto-char pnt) - (unless noerror (error "Not on BibTeX field")))))) - -(defun bibtex-remove-OPT-or-ALT () + (if help (bibtex-print-help-message (car bounds)))) + ((not noerror) (error "Not on BibTeX field"))))) + +(defun bibtex-find-text-internal (&optional noerror subfield comma) + "Find text part of current BibTeX field or entry head. +Return list (NAME START-TEXT END-TEXT END) with field or entry name, +start and end of text and end of field or entry head, or nil if not found. +If optional arg NOERROR is non-nil, an error message is suppressed if text +is not found. If optional arg SUBFIELD is non-nil START-TEXT and END-TEXT +correspond to the current subfield delimited by #. +Optional arg COMMA is as in `bibtex-enclosing-field'." + (save-excursion + (let ((pnt (point)) + (bounds (bibtex-enclosing-field comma t)) + (case-fold-search t) + name start-text end-text end failure done no-sub) + (bibtex-beginning-of-entry) + (cond (bounds + (setq name (bibtex-name-in-field bounds t) + start-text (bibtex-start-of-text-in-field bounds) + end-text (bibtex-end-of-text-in-field bounds) + end (bibtex-end-of-field bounds))) + ;; @String + ((setq bounds (bibtex-parse-string t)) + (if (<= pnt (bibtex-end-of-string bounds)) + (setq name "@String" ;; not a field name! + start-text (bibtex-start-of-text-in-string bounds) + end-text (bibtex-end-of-text-in-string bounds) + end (bibtex-end-of-string bounds)) + (setq failure t))) + ;; @Preamble + ((setq bounds (bibtex-parse-preamble)) + (if (<= pnt (bibtex-end-of-string bounds)) + (setq name "@Preamble" ;; not a field name! + start-text (bibtex-start-of-text-in-string bounds) + end-text (bibtex-end-of-text-in-string bounds) + end (bibtex-end-of-string bounds)) + (setq failure t))) + ;; BibTeX head + ((looking-at bibtex-entry-maybe-empty-head) + (goto-char (match-end 0)) + (if comma (save-match-data + (re-search-forward "\\=[ \t\n]*," nil t))) + (if (<= pnt (point)) + (setq name (match-string-no-properties bibtex-type-in-head) + start-text (or (match-beginning bibtex-key-in-head) + (match-end 0)) + end-text (or (match-end bibtex-key-in-head) + (match-end 0)) + end end-text + no-sub t) ;; subfields do not make sense + (setq failure t))) + (t (setq failure t))) + (when (and subfield (not failure)) + (setq failure no-sub) + (unless failure + (goto-char start-text) + (while (not done) + (if (or (prog1 (looking-at bibtex-field-const) + (setq end-text (match-end 0))) + (prog1 (setq bounds (bibtex-parse-field-string)) + (setq end-text (cdr bounds)))) + (progn + (if (and (<= start-text pnt) (<= pnt end-text)) + (setq done t) + (goto-char end-text)) + (if (looking-at "[ \t\n]*#[ \t\n]*") + (setq start-text (goto-char (match-end 0))))) + (setq done t failure t))))) + (cond ((not failure) + (list name start-text end-text end)) + ((and no-sub (not noerror)) + (error "Not on text part of BibTeX field")) + ((not noerror) (error "Not on BibTeX field")))))) + +(defun bibtex-remove-OPT-or-ALT (&optional comma) "Remove the string starting optional/alternative fields. -Align text and go thereafter to end of text." - (interactive) - (bibtex-inside-field) +Align text and go thereafter to end of text. Optional arg COMMA +is as in `bibtex-enclosing-field'. It is t for interactive calls." + (interactive (list t)) (let ((case-fold-search t) - (bounds (bibtex-enclosing-field))) + (bounds (bibtex-enclosing-field comma))) (save-excursion (goto-char (bibtex-start-of-name-in-field bounds)) (when (looking-at "OPT\\|ALT") @@ -3691,35 +3697,34 @@ Align text and go thereafter to end of text." (delete-horizontal-space) (if bibtex-align-at-equal-sign (insert " ") - (indent-to-column bibtex-text-indentation)))) - (bibtex-inside-field))) - -(defun bibtex-remove-delimiters () - "Remove \"\" or {} around string." - (interactive) - (save-excursion - (bibtex-inside-field) - (let* ((bounds (bibtex-enclosing-field)) - (end (bibtex-end-of-text-in-field bounds)) - (start (bibtex-start-of-text-in-field bounds))) - (if (memq (char-before end) '(?\} ?\")) - (delete-region (1- end) end)) - (if (memq (char-after start) '(?\{ ?\")) - (delete-region start (1+ start)))))) - -(defun bibtex-kill-field (&optional copy-only) + (indent-to-column bibtex-text-indentation)))))) + +(defun bibtex-remove-delimiters (&optional comma) + "Remove \"\" or {} around current BibTeX field text. +Optional arg COMMA is as in `bibtex-enclosing-field'. It is t for +interactive calls." + (interactive (list t)) + (let* ((bounds (bibtex-find-text-internal nil t comma)) + (start (nth 1 bounds)) + (end (nth 2 bounds))) + (if (memq (char-before end) '(?\} ?\")) + (delete-region (1- end) end)) + (if (memq (char-after start) '(?\{ ?\")) + (delete-region start (1+ start))))) + +(defun bibtex-kill-field (&optional copy-only comma) "Kill the entire enclosing BibTeX field. With prefix arg COPY-ONLY, copy the current field to `bibtex-field-kill-ring', -but do not actually kill it." - (interactive "P") +but do not actually kill it. Optional arg COMMA is as in +`bibtex-enclosing-field'. It is t for interactive calls." + (interactive (list current-prefix-arg t)) (save-excursion - (bibtex-inside-field) (let* ((case-fold-search t) - (bounds (bibtex-enclosing-field)) + (bounds (bibtex-enclosing-field comma)) (end (bibtex-end-of-field bounds)) (beg (bibtex-start-of-field bounds))) (goto-char end) - (skip-chars-forward " \t\n,") + (skip-chars-forward ",") (push (list (bibtex-name-in-field bounds) nil (bibtex-text-in-field-bounds bounds)) bibtex-field-kill-ring) @@ -3732,10 +3737,12 @@ but do not actually kill it." (delete-region beg end)))) (setq bibtex-last-kill-command 'field)) -(defun bibtex-copy-field-as-kill () - "Copy the BibTeX field at point to the kill ring." - (interactive) - (bibtex-kill-field t)) +(defun bibtex-copy-field-as-kill (&optional comma) + "Copy the BibTeX field at point to the kill ring. +Optional arg COMMA is as in `bibtex-enclosing-field'. It is t for +interactive calls." + (interactive (list t)) + (bibtex-kill-field t comma)) (defun bibtex-kill-entry (&optional copy-only) "Kill the entire enclosing BibTeX entry. @@ -3747,7 +3754,7 @@ but do not actually kill it." (beg (bibtex-beginning-of-entry)) (end (progn (bibtex-end-of-entry) (if (re-search-forward - bibtex-entry-maybe-empty-head nil 'move) + bibtex-any-entry-maybe-empty-head nil 'move) (goto-char (match-beginning 0))) (point)))) (push (buffer-substring-no-properties beg end) @@ -3772,13 +3779,13 @@ More precisely, reinsert the field or entry killed or yanked most recently. With argument N, reinsert the Nth most recently killed BibTeX item. See also the command \\[bibtex-yank-pop]." (interactive "*p") - (bibtex-insert-kill (1- n)) + (bibtex-insert-kill (1- n) t) (setq this-command 'bibtex-yank)) (defun bibtex-yank-pop (n) "Replace just-yanked killed BibTeX item with a different item. This command is allowed only immediately after a `bibtex-yank' or a -`bibtex-yank-pop'. At such a time, the region contains a reinserted +`bibtex-yank-pop'. In this case, the region contains a reinserted previously killed BibTeX item. `bibtex-yank-pop' deletes that item and inserts in its place a different killed BibTeX item. @@ -3794,18 +3801,19 @@ comes the newest one." (setq this-command 'bibtex-yank) (let ((inhibit-read-only t)) (delete-region (point) (mark t)) - (bibtex-insert-kill n))) - -(defun bibtex-empty-field () - "Delete the text part of the current field, replace with empty text." - (interactive) - (bibtex-inside-field) - (let ((bounds (bibtex-enclosing-field))) + (bibtex-insert-kill n t))) + +(defun bibtex-empty-field (&optional comma) + "Delete the text part of the current field, replace with empty text. +Optional arg COMMA is as in `bibtex-enclosing-field'. It is t for +interactive calls." + (interactive (list t)) + (let ((bounds (bibtex-enclosing-field comma))) (goto-char (bibtex-start-of-text-in-field bounds)) (delete-region (point) (bibtex-end-of-text-in-field bounds)) - (insert (concat (bibtex-field-left-delimiter) - (bibtex-field-right-delimiter)) ) - (bibtex-find-text t))) + (insert (bibtex-field-left-delimiter) + (bibtex-field-right-delimiter)) + (bibtex-find-text t nil bibtex-help-message))) (defun bibtex-pop-previous (arg) "Replace text of current field with the similar field in previous entry. @@ -3837,7 +3845,7 @@ At end of the cleaning process, the functions in (interactive "P") (let ((case-fold-search t) (start (bibtex-beginning-of-entry)) - (_ (looking-at bibtex-entry-maybe-empty-head)) + (_ (looking-at bibtex-any-entry-maybe-empty-head)) (entry-type (bibtex-type-in-head)) (key (bibtex-key-in-head))) ;; formatting @@ -3901,7 +3909,7 @@ At end of the cleaning process, the functions in (if (and (listp bibtex-strings) (not (assoc key bibtex-strings))) (push (cons key (bibtex-text-in-string - (save-excursion (bibtex-parse-string)) t)) + (bibtex-parse-string) t)) bibtex-strings))) ;; We have a normal entry. ((listp bibtex-reference-keys) @@ -3929,28 +3937,27 @@ At end of the cleaning process, the functions in If JUSTIFY is non-nil justify as well. If optional arg MOVE is non-nil move point to end of field." (let ((end-field (copy-marker (bibtex-end-of-field bounds)))) - (goto-char (bibtex-start-of-field bounds)) - (if justify - (progn - (forward-char) - (bibtex-delete-whitespace) - (open-line 1) - (forward-char) - (indent-to-column (+ bibtex-entry-offset - bibtex-field-indentation)) - (re-search-forward "[ \t\n]*=" end-field) - (replace-match "=") - (forward-char -1) - (if bibtex-align-at-equal-sign - (indent-to-column - (+ bibtex-entry-offset (- bibtex-text-indentation 2))) - (insert " ")) - (forward-char) - (bibtex-delete-whitespace) - (if bibtex-align-at-equal-sign - (insert " ") - (indent-to-column bibtex-text-indentation))) - (re-search-forward "[ \t\n]*=[ \t\n]*" end-field)) + (if (not justify) + (goto-char (bibtex-start-of-text-in-field bounds)) + (goto-char (bibtex-start-of-field bounds)) + (forward-char) ;; leading comma + (bibtex-delete-whitespace) + (open-line 1) + (forward-char) + (indent-to-column (+ bibtex-entry-offset + bibtex-field-indentation)) + (re-search-forward "[ \t\n]*=" end-field) + (replace-match "=") + (forward-char -1) + (if bibtex-align-at-equal-sign + (indent-to-column + (+ bibtex-entry-offset (- bibtex-text-indentation 2))) + (insert " ")) + (forward-char) + (bibtex-delete-whitespace) + (if bibtex-align-at-equal-sign + (insert " ") + (indent-to-column bibtex-text-indentation))) ;; Paragraphs within fields are not preserved. Bother? (fill-region-as-paragraph (line-beginning-position) end-field default-justification nil (point)) @@ -3958,14 +3965,13 @@ If optional arg MOVE is non-nil move point to end of field." (defun bibtex-fill-field (&optional justify) "Like \\[fill-paragraph], but fill current BibTeX field. -Optional prefix arg JUSTIFY non-nil means justify as well. +If optional prefix JUSTIFY is non-nil justify as well. In BibTeX mode this function is bound to `fill-paragraph-function'." (interactive "*P") (let ((pnt (copy-marker (point))) - (bounds (bibtex-enclosing-field))) - (when bounds - (bibtex-fill-field-bounds bounds justify) - (goto-char pnt)))) + (bounds (bibtex-enclosing-field t))) + (bibtex-fill-field-bounds bounds justify) + (goto-char pnt))) (defun bibtex-fill-entry () "Fill current BibTeX entry. @@ -3976,14 +3982,16 @@ If `bibtex-align-at-equal-sign' is non-nil, align equal signs, too." (interactive "*") (let ((pnt (copy-marker (point))) (end (copy-marker (bibtex-end-of-entry))) + (beg (bibtex-beginning-of-entry)) ; move point bounds) - (bibtex-beginning-of-entry) (bibtex-delete-whitespace) (indent-to-column bibtex-entry-offset) - (while (setq bounds (bibtex-search-forward-field bibtex-field-name end)) + (bibtex-beginning-first-field beg) + (while (setq bounds (bibtex-parse-field)) (bibtex-fill-field-bounds bounds t t)) (if (looking-at ",") (forward-char)) + (skip-chars-backward " \t\n") (bibtex-delete-whitespace) (open-line 1) (forward-char) @@ -3994,18 +4002,18 @@ If `bibtex-align-at-equal-sign' is non-nil, align equal signs, too." "Realign BibTeX entries such that they are separated by one blank line." (goto-char (point-min)) (let ((case-fold-search t) - (valid-entry (concat "[ \t\n]*\\(" bibtex-valid-entry-re "\\)"))) - ;; No blank lines prior to the first valid entry if there no + (entry-type (concat "[ \t\n]*\\(" bibtex-entry-type "\\)"))) + ;; No blank lines prior to the first entry if there no ;; non-white characters in front of it. - (when (looking-at valid-entry) + (when (looking-at entry-type) (replace-match "\\1")) - ;; Valid entries are separated by one blank line. - (while (re-search-forward valid-entry nil t) + ;; Entries are separated by one blank line. + (while (re-search-forward entry-type nil t) (replace-match "\n\n\\1")) - ;; One blank line past the last valid entry if it is followed by + ;; One blank line past the last entry if it is followed by ;; non-white characters, no blank line otherwise. (beginning-of-line) - (when (re-search-forward bibtex-valid-entry-re nil t) + (when (re-search-forward bibtex-entry-type nil t) (bibtex-end-of-entry) (bibtex-delete-whitespace) (open-line (if (eobp) 1 2))))) @@ -4056,8 +4064,7 @@ If mark is active reformat entries in region, if not in whole buffer." bibtex-autokey-edit-before-use) (save-restriction - (narrow-to-region (if mark-active (region-beginning) (point-min)) - (if mark-active (region-end) (point-max))) + (if mark-active (narrow-to-region (region-beginning) (region-end))) (if (memq 'realign bibtex-entry-format) (bibtex-realign)) (bibtex-progress-message "Formatting" 1) @@ -4084,12 +4091,10 @@ entries from minibuffer." (message "Starting to validate buffer...") (sit-for 1 nil t) (bibtex-realign) - (message - "If errors occur, correct them and call `bibtex-convert-alien' again") - (sit-for 5 nil t) (deactivate-mark) ; So bibtex-validate works on the whole buffer. - (when (let (bibtex-maintain-sorted-entries) - (bibtex-validate)) + (if (not (let (bibtex-maintain-sorted-entries) + (bibtex-validate))) + (message "Correct errors and call `bibtex-convert-alien' again") (message "Starting to reformat entries...") (sit-for 2 nil t) (bibtex-reformat read-options) @@ -4101,14 +4106,15 @@ entries from minibuffer." If point is inside key or crossref field perform key completion based on `bibtex-reference-keys'. Inside a month field perform key completion based on `bibtex-predefined-month-strings'. Inside any other field -perform string completion based on `bibtex-strings'. An error is -signaled if point is outside key or BibTeX field." +\(including a String or Preamble definition) perform string completion +based on `bibtex-strings'. +An error is signaled if point is outside key or BibTeX field." (interactive) (let ((pnt (point)) (case-fold-search t) bounds name compl) (save-excursion - (if (and (setq bounds (bibtex-enclosing-field t)) + (if (and (setq bounds (bibtex-enclosing-field nil t)) (>= pnt (bibtex-start-of-text-in-field bounds)) (<= pnt (bibtex-end-of-text-in-field bounds))) (setq name (bibtex-name-in-field bounds t) @@ -4119,22 +4125,22 @@ signaled if point is outside key or BibTeX field." ;; point is in month field bibtex-predefined-month-strings) ;; point is in other field - (t (if (listp bibtex-strings) - bibtex-strings - ;; so that bibtex-complete-string-cleanup - ;; can do its job - (bibtex-parse-strings - (bibtex-string-files-init)))))) + (t (bibtex-strings)))) (bibtex-beginning-of-entry) - (cond ((and (looking-at bibtex-string-maybe-empty-head) - ;; point is inside a string key - (or (and (match-beginning bibtex-key-in-head) - (>= pnt (match-beginning bibtex-key-in-head)) - (<= pnt (match-end bibtex-key-in-head))) - ;; or point is on empty string key - (and (not (match-beginning bibtex-key-in-head)) - (= pnt (match-end 0))))) - (setq compl 'string)) + (cond ((setq bounds (bibtex-parse-string t)) + ;; point is inside a @String key + (cond ((and (>= pnt (nth 1 (car bounds))) + (<= pnt (nth 2 (car bounds)))) + (setq compl 'string)) + ;; point is inside a @String field + ((and (>= pnt (bibtex-start-of-text-in-string bounds)) + (<= pnt (bibtex-end-of-text-in-string bounds))) + (setq compl (bibtex-strings))))) + ;; point is inside a @Preamble field + ((setq bounds (bibtex-parse-preamble)) + (if (and (>= pnt (bibtex-start-of-text-in-string bounds)) + (<= pnt (bibtex-end-of-text-in-string bounds))) + (setq compl (bibtex-strings)))) ((and (looking-at bibtex-entry-maybe-empty-head) ;; point is inside a key (or (and (match-beginning bibtex-key-in-head) @@ -4147,41 +4153,53 @@ signaled if point is outside key or BibTeX field." (cond ((eq compl 'key) ;; key completion: no cleanup needed - (let (completion-ignore-case) - (bibtex-complete-internal (bibtex-global-key-alist)))) + (setq choose-completion-string-functions nil + completion-ignore-case nil) + (bibtex-complete-internal (bibtex-global-key-alist))) ((eq compl 'crossref-key) ;; crossref key completion - (let (completion-ignore-case) - (setq choose-completion-string-functions - (lambda (choice buffer mini-p base-size) - (let ((choose-completion-string-functions nil)) - (choose-completion-string choice buffer base-size)) - (bibtex-complete-crossref-cleanup choice) - ;; return t (needed by choose-completion-string-functions) - t)) - (bibtex-complete-crossref-cleanup (bibtex-complete-internal - (bibtex-global-key-alist))))) + ;; + ;; If we quit the *Completions* buffer without requesting + ;; a completion, `choose-completion-string-functions' is still + ;; non-nil. Therefore, `choose-completion-string-functions' is + ;; always set (either to non-nil or nil) when a new completion + ;; is requested. + ;; Also, `choose-completion-delete-max-match' requires + ;; that we set `completion-ignore-case' (i.e., binding via `let' + ;; is not sufficient). + (setq completion-ignore-case nil + choose-completion-string-functions + (lambda (choice buffer mini-p base-size) + (setq choose-completion-string-functions nil) + (choose-completion-string choice buffer base-size) + (bibtex-complete-crossref-cleanup choice) + t)) ; needed by choose-completion-string-functions + + (bibtex-complete-crossref-cleanup (bibtex-complete-internal + (bibtex-global-key-alist)))) ((eq compl 'string) ;; string key completion: no cleanup needed - (let ((completion-ignore-case t)) - (bibtex-complete-internal bibtex-strings))) + (setq choose-completion-string-functions nil + completion-ignore-case t) + (bibtex-complete-internal bibtex-strings)) (compl ;; string completion - (let ((completion-ignore-case t)) - (setq choose-completion-string-functions - `(lambda (choice buffer mini-p base-size) - (let ((choose-completion-string-functions nil)) - (choose-completion-string choice buffer base-size)) - (bibtex-complete-string-cleanup choice ',compl) - ;; return t (needed by choose-completion-string-functions) - t)) - (bibtex-complete-string-cleanup (bibtex-complete-internal compl) - compl))) - - (t (error "Point outside key or BibTeX field"))))) + (setq completion-ignore-case t + choose-completion-string-functions + `(lambda (choice buffer mini-p base-size) + (setq choose-completion-string-functions nil) + (choose-completion-string choice buffer base-size) + (bibtex-complete-string-cleanup choice ',compl) + t)) ; needed by choose-completion-string-functions + (bibtex-complete-string-cleanup (bibtex-complete-internal compl) + compl)) + + (t (setq choose-completion-string-functions nil + completion-ignore-case nil) ; default + (error "Point outside key or BibTeX field"))))) (defun bibtex-Article () "Insert a new BibTeX @Article entry; see also `bibtex-entry'." @@ -4282,8 +4300,8 @@ signaled if point is outside key or BibTeX field." (bibtex-entry-left-delimiter) (bibtex-field-left-delimiter)) (let ((endpos (point))) - (insert (bibtex-entry-right-delimiter) - (bibtex-field-right-delimiter) + (insert (bibtex-field-right-delimiter) + (bibtex-entry-right-delimiter) "\n") (goto-char endpos))) @@ -4296,7 +4314,8 @@ The URL is generated using the schemes defined in `bibtex-generate-url-list' (save-excursion (if pos (goto-char pos)) (bibtex-beginning-of-entry) - (let ((fields-alist (bibtex-parse-entry)) + ;; Always remove field delimiters + (let ((fields-alist (bibtex-parse-entry t)) ;; Always ignore case, (case-fold-search t) (lst bibtex-generate-url-list) @@ -4304,18 +4323,14 @@ The URL is generated using the schemes defined in `bibtex-generate-url-list' (while (setq scheme (pop lst)) (when (and (setq field (cdr (assoc-string (caar scheme) fields-alist t))) - ;; Always remove field delimiters - (progn (setq field (bibtex-remove-delimiters-string field)) - (string-match (cdar scheme) field))) + (string-match (cdar scheme) field)) (setq lst nil scheme (cdr scheme) url (if (null scheme) (match-string 0 field) (if (stringp (car scheme)) (setq fmt (pop scheme))) (dolist (step scheme) - ;; Always remove field delimiters - (setq field (bibtex-remove-delimiters-string - (cdr (assoc-string (car step) fields-alist t)))) + (setq field (cdr (assoc-string (car step) fields-alist t))) (if (string-match (nth 1 step) field) (setq field (cond ((functionp (nth 2 step)) (funcall (nth 2 step) field)) diff --git a/lisp/textmodes/conf-mode.el b/lisp/textmodes/conf-mode.el index 2c895eb517e..764c831d1b3 100644 --- a/lisp/textmodes/conf-mode.el +++ b/lisp/textmodes/conf-mode.el @@ -201,11 +201,11 @@ This variable is best set in the file local variables, or through "Keywords to hilight in Conf Colon mode.") (defvar conf-assignment-sign ?= - "What sign is used for assignments.") + "Sign used for assignments (char or string).") (defvar conf-assignment-regexp ".+?\\([ \t]*=[ \t]*\\)" "Regexp to recognize assignments. -It is anchored after the first sexp on a line. There must a +It is anchored after the first sexp on a line. There must be a grouping for the assignment sign, including leading and trailing whitespace.") @@ -279,7 +279,7 @@ unbalanced, but hey...)" ;;;###autoload -(defun conf-mode (&optional comment syntax-table name) +(defun conf-mode () "Mode for Unix and Windows Conf files and Java properties. Most conf files know only three kinds of constructs: parameter assignments optionally grouped into sections and comments. Yet @@ -311,7 +311,13 @@ See also `conf-space-mode', `conf-colon-mode', `conf-javaprop-mode', \\{conf-mode-map}" (interactive) - (if (not comment) + ;; `conf-mode' plays two roles: it's the parent of several sub-modes + ;; but it's also the function that chooses between those submodes. + ;; To tell the difference between those two cases where the function + ;; might be called, we check `delay-mode-hooks'. + ;; (adopted from tex-mode.el) + (if (not delay-mode-hooks) + ;; try to guess sub-mode of conf-mode based on buffer content (let ((unix 0) (win 0) (equal 0) (colon 0) (space 0) (jp 0)) (save-excursion (goto-char (point-min)) @@ -338,17 +344,14 @@ See also `conf-space-mode', `conf-colon-mode', `conf-javaprop-mode', ((or (> win unix) (and (= win unix) (eq system-type 'windows-nt))) (conf-windows-mode)) (t (conf-unix-mode)))) + (kill-all-local-variables) (use-local-map conf-mode-map) - (setq major-mode 'conf-mode - mode-name name) + mode-name "Conf[?]") (set (make-local-variable 'font-lock-defaults) '(conf-font-lock-keywords nil t nil nil)) - (set (make-local-variable 'comment-start) comment) - (set (make-local-variable 'comment-start-skip) - (concat (regexp-quote comment-start) "+\\s *")) - ;; Let newcomment.el decide this for himself. + ;; Let newcomment.el decide this for itself. ;; (set (make-local-variable 'comment-use-syntax) t) (set (make-local-variable 'parse-sexp-ignore-comments) t) (set (make-local-variable 'outline-regexp) @@ -357,18 +360,28 @@ See also `conf-space-mode', `conf-colon-mode', `conf-javaprop-mode', "[\n}]") (set (make-local-variable 'outline-level) 'conf-outline-level) - (set-syntax-table syntax-table) + (set-syntax-table conf-mode-syntax-table) (setq imenu-generic-expression '(("Parameters" "^[ \t]*\\(.+?\\)[ \t]*=" 1) ;; [section] (nil "^[ \t]*\\[[ \t]*\\(.+\\)[ \t]*\\]" 1) ;; section { ... } (nil "^[ \t]*\\([^=:{} \t\n][^=:{}\n]+\\)[ \t\n]*{" 1))) - (run-mode-hooks 'conf-mode-hook))) +(defun conf-mode-initialize (comment &optional font-lock) + "Intitializations for sub-modes of conf-mode. +COMMENT initializes `comment-start' and `comment-start-skip'. +The optional arg FONT-LOCK is the value for FONT-LOCK-KEYWORDS." + (set (make-local-variable 'comment-start) comment) + (set (make-local-variable 'comment-start-skip) + (concat (regexp-quote comment-start) "+\\s *")) + (if font-lock + (set (make-local-variable 'font-lock-defaults) + `(,font-lock nil t nil nil)))) + ;;;###autoload -(defun conf-unix-mode () +(define-derived-mode conf-unix-mode conf-mode "Conf[Unix]" "Conf Mode starter for Unix style Conf files. Comments start with `#'. For details see `conf-mode'. Example: @@ -380,11 +393,10 @@ For details see `conf-mode'. Example: Name=The GIMP Name[ca]=El GIMP Name[cs]=GIMP" - (interactive) - (conf-mode "#" conf-unix-mode-syntax-table "Conf[Unix]")) + (conf-mode-initialize "#")) ;;;###autoload -(defun conf-windows-mode () +(define-derived-mode conf-windows-mode conf-mode "Conf[WinIni]" "Conf Mode starter for Windows style Conf files. Comments start with `;'. For details see `conf-mode'. Example: @@ -397,8 +409,7 @@ Default={5984FFE0-28D4-11CF-AE66-08002B2E1262} \[{5984FFE0-28D4-11CF-AE66-08002B2E1262}] PersistMoniker=file://Folder.htt" - (interactive) - (conf-mode ";" conf-mode-syntax-table "Conf[WinIni]")) + (conf-mode-initialize ";")) ;; Here are a few more or less widespread styles. There are others, so ;; obscure, they are not covered. E.g. RFC 2614 allows both Unix and Windows @@ -406,7 +417,7 @@ PersistMoniker=file://Folder.htt" ;; if you need it. ;;;###autoload -(defun conf-javaprop-mode () +(define-derived-mode conf-javaprop-mode conf-mode "Conf[JavaProp]" "Conf Mode starter for Java properties files. Comments start with `#' but are also recognized with `//' or between `/*' and `*/'. @@ -422,27 +433,23 @@ name value x.1 = x.2.y.1.z.1 = x.2.y.1.z.2.zz =" - (interactive) - (conf-mode "#" conf-javaprop-mode-syntax-table "Conf[JavaProp]") + (conf-mode-initialize "#" 'conf-javaprop-font-lock-keywords) (set (make-local-variable 'conf-assignment-column) conf-javaprop-assignment-column) (set (make-local-variable 'conf-assignment-regexp) ".+?\\([ \t]*[=: \t][ \t]*\\|$\\)") - (set (make-local-variable 'conf-font-lock-keywords) - conf-javaprop-font-lock-keywords) (setq comment-start-skip "\\(?:#+\\|/[/*]+\\)\\s *") (setq imenu-generic-expression '(("Parameters" "^[ \t]*\\(.+?\\)[=: \t]" 1)))) ;;;###autoload -(defun conf-space-mode (&optional keywords) +(define-derived-mode conf-space-mode conf-unix-mode "Conf[Space]" "Conf Mode starter for space separated conf files. \"Assignments\" are with ` '. Keywords before the parameters are recognized according to `conf-space-keywords'. Interactively with a prefix ARG of `0' no keywords will be recognized. With any other prefix arg you will be prompted for a regexp to match -the keywords. Programmatically you can pass such a regexp as -KEYWORDS, or any non-nil non-string for no keywords. +the keywords. For details see `conf-mode'. Example: @@ -457,30 +464,23 @@ class desktop # Standard multimedia devices add /dev/audio desktop add /dev/mixer desktop" - (interactive - (list (if current-prefix-arg - (if (> (prefix-numeric-value current-prefix-arg) 0) - (read-string "Regexp to match keywords: ") - t)))) - (conf-unix-mode) - (setq mode-name "Conf[Space]") + (conf-mode-initialize "#" 'conf-space-font-lock-keywords) (set (make-local-variable 'conf-assignment-sign) nil) - (set (make-local-variable 'conf-font-lock-keywords) - conf-space-font-lock-keywords) ;; This doesn't seem right, but the next two depend on conf-space-keywords ;; being set, while after-change-major-mode-hook might set up imenu, needing ;; the following result: (hack-local-variables-prop-line) (hack-local-variables) - (if keywords - (set (make-local-variable 'conf-space-keywords) - (if (stringp keywords) keywords)) - (or conf-space-keywords - (not buffer-file-name) - (set (make-local-variable 'conf-space-keywords) - (assoc-default buffer-file-name conf-space-keywords-alist - 'string-match)))) + (cond (current-prefix-arg + (set (make-local-variable 'conf-space-keywords) + (if (> (prefix-numeric-value current-prefix-arg) 0) + (read-string "Regexp to match keywords: ")))) + (conf-space-keywords) + (buffer-file-name + (set (make-local-variable 'conf-space-keywords) + (assoc-default buffer-file-name conf-space-keywords-alist + 'string-match)))) (set (make-local-variable 'conf-assignment-regexp) (if conf-space-keywords (concat "\\(?:" conf-space-keywords "\\)[ \t]+.+?\\([ \t]+\\|$\\)") @@ -495,7 +495,7 @@ add /dev/mixer desktop" 1)))) ;;;###autoload -(defun conf-colon-mode (&optional comment syntax-table name) +(define-derived-mode conf-colon-mode conf-unix-mode "Conf[Colon]" "Conf Mode starter for Colon files. \"Assignments\" are with `:'. For details see `conf-mode'. Example: @@ -504,11 +504,7 @@ For details see `conf-mode'. Example: <Multi_key> <exclam> <exclam> : \"\\241\" exclamdown <Multi_key> <c> <slash> : \"\\242\" cent" - (interactive) - (if comment - (conf-mode comment syntax-table name) - (conf-unix-mode) - (setq mode-name "Conf[Colon]")) + (conf-mode-initialize "#" 'conf-colon-font-lock-keywords) (set (make-local-variable 'conf-assignment-space) conf-colon-assignment-space) (set (make-local-variable 'conf-assignment-column) @@ -517,14 +513,12 @@ For details see `conf-mode'. Example: ?:) (set (make-local-variable 'conf-assignment-regexp) ".+?\\([ \t]*:[ \t]*\\)") - (set (make-local-variable 'conf-font-lock-keywords) - conf-colon-font-lock-keywords) (setq imenu-generic-expression `(("Parameters" "^[ \t]*\\(.+?\\)[ \t]*:" 1) ,@(cdr imenu-generic-expression)))) ;;;###autoload -(defun conf-ppd-mode () +(define-derived-mode conf-ppd-mode conf-colon-mode "Conf[PPD]" "Conf Mode starter for Adobe/CUPS PPD files. Comments start with `*%' and \"assignments\" are with `:'. For details see `conf-mode'. Example: @@ -533,13 +527,12 @@ For details see `conf-mode'. Example: *DefaultTransfer: Null *Transfer Null.Inverse: \"{ 1 exch sub }\"" - (interactive) - (conf-colon-mode "*%" conf-ppd-mode-syntax-table "Conf[PPD]") + (conf-mode-initialize "*%") ;; no sections, they match within PostScript code (setq imenu-generic-expression (list (car imenu-generic-expression)))) ;;;###autoload -(defun conf-xdefaults-mode () +(define-derived-mode conf-xdefaults-mode conf-colon-mode "Conf[Xdefaults]" "Conf Mode starter for Xdefaults files. Comments start with `!' and \"assignments\" are with `:'. For details see `conf-mode'. Example: @@ -548,8 +541,7 @@ For details see `conf-mode'. Example: *background: gray99 *foreground: black" - (interactive) - (conf-colon-mode "!" conf-xdefaults-mode-syntax-table "Conf[Xdefaults]")) + (conf-mode-initialize "!")) (provide 'conf-mode) diff --git a/lisp/textmodes/fill.el b/lisp/textmodes/fill.el index ce95c6f026f..48defb7d786 100644 --- a/lisp/textmodes/fill.el +++ b/lisp/textmodes/fill.el @@ -291,12 +291,13 @@ act as a paragraph-separator." (defun fill-single-word-nobreak-p () "Don't break a line after the first or before the last word of a sentence." - (or (looking-at "[ \t]*\\sw+[ \t]*[.?!:][ \t]*$") + (or (looking-at (concat "[ \t]*\\sw+" "\\(?:" (sentence-end) "\\)")) (save-excursion (skip-chars-backward " \t") (and (/= (skip-syntax-backward "w") 0) (/= (skip-chars-backward " \t") 0) - (/= (skip-chars-backward ".?!:") 0))))) + (/= (skip-chars-backward ".?!:") 0) + (looking-at (sentence-end)))))) (defun fill-french-nobreak-p () "Return nil if French style allows breaking the line at point. diff --git a/lisp/textmodes/flyspell.el b/lisp/textmodes/flyspell.el index 74c7cbc5762..a6e3734b42c 100644 --- a/lisp/textmodes/flyspell.el +++ b/lisp/textmodes/flyspell.el @@ -1,7 +1,7 @@ ;;; flyspell.el --- on-the-fly spell checker ;; Copyright (C) 1998, 2000, 2002, 2003, 2004, -;; 2005 Free Software Foundation, Inc. +;; 2005, 2006 Free Software Foundation, Inc. ;; Author: Manuel Serrano <Manuel.Serrano@sophia.inria.fr> ;; Maintainer: FSF @@ -46,9 +46,9 @@ (require 'ispell) -;*---------------------------------------------------------------------*/ -;* Group ... */ -;*---------------------------------------------------------------------*/ +;;*---------------------------------------------------------------------*/ +;;* Group ... */ +;;*---------------------------------------------------------------------*/ (defgroup flyspell nil "Spell checking on the fly." :tag "FlySpell" @@ -56,41 +56,30 @@ :group 'ispell :group 'processes) -;*---------------------------------------------------------------------*/ -;* Which emacs are we currently running */ -;*---------------------------------------------------------------------*/ -(defvar flyspell-emacs - (cond - ((string-match "XEmacs" emacs-version) - 'xemacs) - (t - 'emacs)) - "The type of Emacs we are currently running.") - -;*---------------------------------------------------------------------*/ -;* User configuration ... */ -;*---------------------------------------------------------------------*/ +;;*---------------------------------------------------------------------*/ +;;* User configuration ... */ +;;*---------------------------------------------------------------------*/ (defcustom flyspell-highlight-flag t - "*How Flyspell should indicate misspelled words. + "How Flyspell should indicate misspelled words. Non-nil means use highlight, nil means use minibuffer messages." :group 'flyspell :type 'boolean) (defcustom flyspell-mark-duplications-flag t - "*Non-nil means Flyspell reports a repeated word as an error. + "Non-nil means Flyspell reports a repeated word as an error. Detection of repeated words is not implemented in \"large\" regions; see `flyspell-large-region'." :group 'flyspell :type 'boolean) (defcustom flyspell-sort-corrections nil - "*Non-nil means, sort the corrections alphabetically before popping them." + "Non-nil means, sort the corrections alphabetically before popping them." :group 'flyspell :version "21.1" :type 'boolean) (defcustom flyspell-duplicate-distance -1 - "*The maximum distance for finding duplicates of unrecognized words. + "The maximum distance for finding duplicates of unrecognized words. This applies to the feature that when a word is not found in the dictionary, if the same spelling occurs elsewhere in the buffer, Flyspell uses a different face (`flyspell-duplicate') to highlight it. @@ -102,19 +91,19 @@ This variable specifies how far to search to find such a duplicate. :type 'number) (defcustom flyspell-delay 3 - "*The number of seconds to wait before checking, after a \"delayed\" command." + "The number of seconds to wait before checking, after a \"delayed\" command." :group 'flyspell :type 'number) (defcustom flyspell-persistent-highlight t - "*Non-nil means misspelled words remain highlighted until corrected. + "Non-nil means misspelled words remain highlighted until corrected. If this variable is nil, only the most recently detected misspelled word is highlighted." :group 'flyspell :type 'boolean) (defcustom flyspell-highlight-properties t - "*Non-nil means highlight incorrect words even if a property exists for this word." + "Non-nil means highlight incorrect words even if a property exists for this word." :group 'flyspell :type 'boolean) @@ -158,17 +147,17 @@ command was not the very same command." :type '(repeat (symbol))) (defcustom flyspell-issue-welcome-flag t - "*Non-nil means that Flyspell should display a welcome message when started." + "Non-nil means that Flyspell should display a welcome message when started." :group 'flyspell :type 'boolean) (defcustom flyspell-issue-message-flag t - "*Non-nil means that Flyspell emits messages when checking words." + "Non-nil means that Flyspell emits messages when checking words." :group 'flyspell :type 'boolean) (defcustom flyspell-incorrect-hook nil - "*List of functions to be called when incorrect words are encountered. + "List of functions to be called when incorrect words are encountered. Each function is given three arguments. The first two arguments are the beginning and the end of the incorrect region. The third is either the symbol `doublon' or the list @@ -200,7 +189,7 @@ Ispell's ultimate default dictionary." :type 'string) (defcustom flyspell-check-tex-math-command nil - "*Non nil means check even inside TeX math environment. + "Non nil means check even inside TeX math environment. TeX math environments are discovered by the TEXMATHP that implemented inside the texmathp.el Emacs package. That package may be found at: http://strw.leidenuniv.nl/~dominik/Tools" @@ -216,26 +205,26 @@ http://strw.leidenuniv.nl/~dominik/Tools" (defcustom flyspell-abbrev-p nil - "*If non-nil, add correction to abbreviation table." + "If non-nil, add correction to abbreviation table." :group 'flyspell :version "21.1" :type 'boolean) (defcustom flyspell-use-global-abbrev-table-p nil - "*If non-nil, prefer global abbrev table to local abbrev table." + "If non-nil, prefer global abbrev table to local abbrev table." :group 'flyspell :version "21.1" :type 'boolean) (defcustom flyspell-mode-line-string " Fly" - "*String displayed on the modeline when flyspell is active. + "String displayed on the modeline when flyspell is active. Set this to nil if you don't want a modeline indicator." :group 'flyspell :type '(choice string (const :tag "None" nil))) (defcustom flyspell-large-region 1000 - "*The threshold that determines if a region is small. + "The threshold that determines if a region is small. If the region is smaller than this number of characters, `flyspell-region' checks the words sequentially using regular flyspell methods. Else, if the region is large, a new Ispell process is @@ -250,7 +239,7 @@ If `flyspell-large-region' is nil, all regions are treated as small." :type '(choice number (const :tag "All small" nil))) (defcustom flyspell-insert-function (function insert) - "*Function for inserting word by flyspell upon correction." + "Function for inserting word by flyspell upon correction." :group 'flyspell :type 'function) @@ -265,7 +254,7 @@ If `flyspell-large-region' is nil, all regions are treated as small." :type '(choice string (const nil))) (defcustom flyspell-use-meta-tab t - "*Non-nil means that flyspell uses META-TAB to correct word." + "Non-nil means that flyspell uses M-TAB to correct word." :group 'flyspell :type 'boolean) @@ -274,17 +263,17 @@ If `flyspell-large-region' is nil, all regions are treated as small." "The key binding for flyspell auto correction." :group 'flyspell) -;*---------------------------------------------------------------------*/ -;* Mode specific options */ -;* ------------------------------------------------------------- */ -;* Mode specific options enable users to disable flyspell on */ -;* certain word depending of the emacs mode. For instance, when */ -;* using flyspell with mail-mode add the following expression */ -;* in your .emacs file: */ -;* (add-hook 'mail-mode */ -;* '(lambda () (setq flyspell-generic-check-word-p */ -;* 'mail-mode-flyspell-verify))) */ -;*---------------------------------------------------------------------*/ +;;*---------------------------------------------------------------------*/ +;;* Mode specific options */ +;;* ------------------------------------------------------------- */ +;;* Mode specific options enable users to disable flyspell on */ +;;* certain word depending of the emacs mode. For instance, when */ +;;* using flyspell with mail-mode add the following expression */ +;;* in your .emacs file: */ +;;* (add-hook 'mail-mode */ +;;* '(lambda () (setq flyspell-generic-check-word-p */ +;;* 'mail-mode-flyspell-verify))) */ +;;*---------------------------------------------------------------------*/ (defvar flyspell-generic-check-word-p nil "Function providing per-mode customization over which words are flyspelled. Returns t to continue checking, nil otherwise. @@ -292,7 +281,7 @@ Flyspell mode sets this variable to whatever is the `flyspell-mode-predicate' property of the major mode name.") (make-variable-buffer-local 'flyspell-generic-check-word-p) -;*--- mail mode -------------------------------------------------------*/ +;;*--- mail mode -------------------------------------------------------*/ (put 'mail-mode 'flyspell-mode-predicate 'mail-mode-flyspell-verify) (put 'message-mode 'flyspell-mode-predicate 'mail-mode-flyspell-verify) (defun mail-mode-flyspell-verify () @@ -321,7 +310,7 @@ property of the major mode name.") (beginning-of-line) (not (looking-at "[>}|]\\|To:"))))))) -;*--- texinfo mode ----------------------------------------------------*/ +;;*--- texinfo mode ----------------------------------------------------*/ (put 'texinfo-mode 'flyspell-mode-predicate 'texinfo-mode-flyspell-verify) (defun texinfo-mode-flyspell-verify () "This function is used for `flyspell-generic-check-word-p' in Texinfo mode." @@ -329,13 +318,13 @@ property of the major mode name.") (forward-word -1) (not (looking-at "@")))) -;*--- tex mode --------------------------------------------------------*/ +;;*--- tex mode --------------------------------------------------------*/ (put 'tex-mode 'flyspell-mode-predicate 'tex-mode-flyspell-verify) (defun tex-mode-flyspell-verify () "This function is used for `flyspell-generic-check-word-p' in LaTeX mode." (and (not (save-excursion - (re-search-backward "^[ \t]*%%%[ \t]+Local" (point-min) t))) + (re-search-backward "^[ \t]*%%%[ \t]+Local" nil t))) (not (save-excursion (let ((this (point-marker)) (e (progn (end-of-line) (point-marker)))) @@ -344,7 +333,7 @@ property of the major mode name.") (and (>= this (match-beginning 0)) (<= this (match-end 0)) ))))))) -;*--- sgml mode -------------------------------------------------------*/ +;;*--- sgml mode -------------------------------------------------------*/ (put 'sgml-mode 'flyspell-mode-predicate 'sgml-mode-flyspell-verify) (put 'html-mode 'flyspell-mode-predicate 'sgml-mode-flyspell-verify) @@ -371,9 +360,9 @@ property of the major mode name.") (and (re-search-backward "&[^;]*" s t) (= (match-end 0) this))))))))) -;*---------------------------------------------------------------------*/ -;* Programming mode */ -;*---------------------------------------------------------------------*/ +;;*---------------------------------------------------------------------*/ +;;* Programming mode */ +;;*---------------------------------------------------------------------*/ (defvar flyspell-prog-text-faces '(font-lock-string-face font-lock-comment-face font-lock-doc-face) "Faces corresponding to text in programming-mode buffers.") @@ -391,9 +380,9 @@ property of the major mode name.") (flyspell-mode 1) (run-hooks 'flyspell-prog-mode-hook)) -;*---------------------------------------------------------------------*/ -;* Overlay compatibility */ -;*---------------------------------------------------------------------*/ +;;*---------------------------------------------------------------------*/ +;;* Overlay compatibility */ +;;*---------------------------------------------------------------------*/ (autoload 'make-overlay "overlay" "Overlay compatibility kit." t) (autoload 'overlayp "overlay" "Overlay compatibility kit." t) (autoload 'overlays-in "overlay" "Overlay compatibility kit." t) @@ -403,9 +392,9 @@ property of the major mode name.") (autoload 'overlay-get "overlay" "Overlay compatibility kit." t) (autoload 'previous-overlay-change "overlay" "Overlay compatibility kit." t) -;*---------------------------------------------------------------------*/ -;* The minor mode declaration. */ -;*---------------------------------------------------------------------*/ +;;*---------------------------------------------------------------------*/ +;;* The minor mode declaration. */ +;;*---------------------------------------------------------------------*/ (defvar flyspell-mouse-map (let ((map (make-sparse-keymap))) (define-key map (if (featurep 'xemacs) [button2] [down-mouse-2]) @@ -432,9 +421,9 @@ property of the major mode name.") (defvar flyspell-dash-local-dictionary nil) (make-variable-buffer-local 'flyspell-dash-local-dictionary) -;*---------------------------------------------------------------------*/ -;* Highlighting */ -;*---------------------------------------------------------------------*/ +;;*---------------------------------------------------------------------*/ +;;* Highlighting */ +;;*---------------------------------------------------------------------*/ (defface flyspell-incorrect '((((class color)) (:foreground "OrangeRed" :bold t :underline t)) (t (:bold t))) @@ -454,9 +443,9 @@ See also `flyspell-duplicate-distance'." (defvar flyspell-overlay nil) -;*---------------------------------------------------------------------*/ -;* flyspell-mode ... */ -;*---------------------------------------------------------------------*/ +;;*---------------------------------------------------------------------*/ +;;* flyspell-mode ... */ +;;*---------------------------------------------------------------------*/ ;;;###autoload(defvar flyspell-mode nil) ;;;###autoload (define-minor-mode flyspell-mode @@ -494,46 +483,57 @@ in your .emacs file. (flyspell-mode-on) (flyspell-mode-off))) -;*---------------------------------------------------------------------*/ -;* flyspell-buffers ... */ -;* ------------------------------------------------------------- */ -;* For remembering buffers running flyspell */ -;*---------------------------------------------------------------------*/ +;;*---------------------------------------------------------------------*/ +;;* flyspell-buffers ... */ +;;* ------------------------------------------------------------- */ +;;* For remembering buffers running flyspell */ +;;*---------------------------------------------------------------------*/ (defvar flyspell-buffers nil) -;*---------------------------------------------------------------------*/ -;* flyspell-minibuffer-p ... */ -;*---------------------------------------------------------------------*/ +;;*---------------------------------------------------------------------*/ +;;* flyspell-minibuffer-p ... */ +;;*---------------------------------------------------------------------*/ (defun flyspell-minibuffer-p (buffer) "Is BUFFER a minibuffer?" (let ((ws (get-buffer-window-list buffer t))) (and (consp ws) (window-minibuffer-p (car ws))))) -;*---------------------------------------------------------------------*/ -;* flyspell-accept-buffer-local-defs ... */ -;*---------------------------------------------------------------------*/ -(defun flyspell-accept-buffer-local-defs () - ;; strange problem. If buffer in current window has font-lock turned on, - ;; but SET-BUFFER was called to point to an invisible buffer, this ispell - ;; call will reset the buffer to the buffer in the current window. However, - ;; it only happens at startup (fix by Albert L. Ting). - (let ((buf (current-buffer))) - (ispell-accept-buffer-local-defs) - (set-buffer buf)) - (if (not (and (eq flyspell-dash-dictionary ispell-dictionary) - (eq flyspell-dash-local-dictionary ispell-local-dictionary))) +;;*---------------------------------------------------------------------*/ +;;* flyspell-accept-buffer-local-defs ... */ +;;*---------------------------------------------------------------------*/ +(defvar flyspell-last-buffer nil + "The buffer in which the last flyspell operation took place.") + +(defun flyspell-accept-buffer-local-defs (&optional force) + ;; When flyspell-word is used inside a loop (e.g. when processing + ;; flyspell-changes), the calls to `ispell-accept-buffer-local-defs' end + ;; up dwarfing everything else, so only do it when the buffer has changed. + (when (or force (not (eq flyspell-last-buffer (current-buffer)))) + (setq flyspell-last-buffer (current-buffer)) + ;; Strange problem: If buffer in current window has font-lock turned on, + ;; but SET-BUFFER was called to point to an invisible buffer, this ispell + ;; call will reset the buffer to the buffer in the current window. + ;; However, it only happens at startup (fix by Albert L. Ting). + (save-current-buffer + (ispell-accept-buffer-local-defs)) + (unless (and (eq flyspell-dash-dictionary ispell-dictionary) + (eq flyspell-dash-local-dictionary ispell-local-dictionary)) ;; The dictionary has changed - (progn - (setq flyspell-dash-dictionary ispell-dictionary) - (setq flyspell-dash-local-dictionary ispell-local-dictionary) - (if (member (or ispell-local-dictionary ispell-dictionary) - flyspell-dictionaries-that-consider-dash-as-word-delimiter) - (setq flyspell-consider-dash-as-word-delimiter-flag t) - (setq flyspell-consider-dash-as-word-delimiter-flag nil))))) - -;*---------------------------------------------------------------------*/ -;* flyspell-mode-on ... */ -;*---------------------------------------------------------------------*/ + (setq flyspell-dash-dictionary ispell-dictionary) + (setq flyspell-dash-local-dictionary ispell-local-dictionary) + (setq flyspell-consider-dash-as-word-delimiter-flag + (member (or ispell-local-dictionary ispell-dictionary) + flyspell-dictionaries-that-consider-dash-as-word-delimiter))))) + +(defun flyspell-kill-ispell-hook () + (setq flyspell-last-buffer nil) + (dolist (buf (buffer-list)) + (with-current-buffer buf + (kill-local-variable 'flyspell-word-cache-word)))) + +;;*---------------------------------------------------------------------*/ +;;* flyspell-mode-on ... */ +;;*---------------------------------------------------------------------*/ (defun flyspell-mode-on () "Turn Flyspell mode on. Do not use this; use `flyspell-mode' instead." (ispell-maybe-find-aspell-dictionaries) @@ -542,10 +542,14 @@ in your .emacs file. (or ispell-local-dictionary ispell-dictionary (if flyspell-default-dictionary (ispell-change-dictionary flyspell-default-dictionary))) + ;; Make sure we flush our caches when needed. + (add-hook 'ispell-kill-ispell-hook 'flyspell-kill-ispell-hook) ;; we have to force ispell to accept the local definition or ;; otherwise it could be too late, the local dictionary may ;; be forgotten! - (flyspell-accept-buffer-local-defs) + ;; Pass the `force' argument for the case where flyspell was active already + ;; but the buffer's local-defs have been edited. + (flyspell-accept-buffer-local-defs 'force) ;; we put the `flyspell-delayed' property on some commands (flyspell-delay-commands) ;; we put the `flyspell-deplacement' property on some commands @@ -555,9 +559,7 @@ in your .emacs file. ;; we bound flyspell action to pre-command hook (add-hook 'pre-command-hook (function flyspell-pre-command-hook) t t) ;; we bound flyspell action to after-change hook - (make-local-variable 'after-change-functions) - (setq after-change-functions - (cons 'flyspell-after-change-function after-change-functions)) + (add-hook 'after-change-functions 'flyspell-after-change-function nil t) ;; set flyspell-generic-check-word-p based on the major mode (let ((mode-predicate (get major-mode 'flyspell-mode-predicate))) (if mode-predicate @@ -576,17 +578,17 @@ in your .emacs file. ;; we end with the flyspell hooks (run-hooks 'flyspell-mode-hook)) -;*---------------------------------------------------------------------*/ -;* flyspell-delay-commands ... */ -;*---------------------------------------------------------------------*/ +;;*---------------------------------------------------------------------*/ +;;* flyspell-delay-commands ... */ +;;*---------------------------------------------------------------------*/ (defun flyspell-delay-commands () "Install the standard set of Flyspell delayed commands." (mapcar 'flyspell-delay-command flyspell-default-delayed-commands) (mapcar 'flyspell-delay-command flyspell-delayed-commands)) -;*---------------------------------------------------------------------*/ -;* flyspell-delay-command ... */ -;*---------------------------------------------------------------------*/ +;;*---------------------------------------------------------------------*/ +;;* flyspell-delay-command ... */ +;;*---------------------------------------------------------------------*/ (defun flyspell-delay-command (command) "Set COMMAND to be delayed, for Flyspell. When flyspell `post-command-hook' is invoked because a delayed command @@ -595,17 +597,17 @@ It will be checked only after `flyspell-delay' seconds." (interactive "SDelay Flyspell after Command: ") (put command 'flyspell-delayed t)) -;*---------------------------------------------------------------------*/ -;* flyspell-deplacement-commands ... */ -;*---------------------------------------------------------------------*/ +;;*---------------------------------------------------------------------*/ +;;* flyspell-deplacement-commands ... */ +;;*---------------------------------------------------------------------*/ (defun flyspell-deplacement-commands () "Install the standard set of Flyspell deplacement commands." (mapcar 'flyspell-deplacement-command flyspell-default-deplacement-commands) (mapcar 'flyspell-deplacement-command flyspell-deplacement-commands)) -;*---------------------------------------------------------------------*/ -;* flyspell-deplacement-command ... */ -;*---------------------------------------------------------------------*/ +;;*---------------------------------------------------------------------*/ +;;* flyspell-deplacement-command ... */ +;;*---------------------------------------------------------------------*/ (defun flyspell-deplacement-command (command) "Set COMMAND that implement cursor movements, for Flyspell. When flyspell `post-command-hook' is invoked because of a deplacement command @@ -614,9 +616,9 @@ not the very same deplacement command." (interactive "SDeplacement Flyspell after Command: ") (put command 'flyspell-deplacement t)) -;*---------------------------------------------------------------------*/ -;* flyspell-word-cache ... */ -;*---------------------------------------------------------------------*/ +;;*---------------------------------------------------------------------*/ +;;* flyspell-word-cache ... */ +;;*---------------------------------------------------------------------*/ (defvar flyspell-word-cache-start nil) (defvar flyspell-word-cache-end nil) (defvar flyspell-word-cache-word nil) @@ -626,26 +628,26 @@ not the very same deplacement command." (make-variable-buffer-local 'flyspell-word-cache-word) (make-variable-buffer-local 'flyspell-word-cache-result) -;*---------------------------------------------------------------------*/ -;* The flyspell pre-hook, store the current position. In the */ -;* post command hook, we will check, if the word at this position */ -;* has to be spell checked. */ -;*---------------------------------------------------------------------*/ +;;*---------------------------------------------------------------------*/ +;;* The flyspell pre-hook, store the current position. In the */ +;;* post command hook, we will check, if the word at this position */ +;;* has to be spell checked. */ +;;*---------------------------------------------------------------------*/ (defvar flyspell-pre-buffer nil) (defvar flyspell-pre-point nil) (defvar flyspell-pre-column nil) (defvar flyspell-pre-pre-buffer nil) (defvar flyspell-pre-pre-point nil) -;*---------------------------------------------------------------------*/ -;* flyspell-previous-command ... */ -;*---------------------------------------------------------------------*/ +;;*---------------------------------------------------------------------*/ +;;* flyspell-previous-command ... */ +;;*---------------------------------------------------------------------*/ (defvar flyspell-previous-command nil "The last interactive command checked by Flyspell.") -;*---------------------------------------------------------------------*/ -;* flyspell-pre-command-hook ... */ -;*---------------------------------------------------------------------*/ +;;*---------------------------------------------------------------------*/ +;;* flyspell-pre-command-hook ... */ +;;*---------------------------------------------------------------------*/ (defun flyspell-pre-command-hook () "Save the current buffer and point for Flyspell's post-command hook." (interactive) @@ -653,17 +655,16 @@ not the very same deplacement command." (setq flyspell-pre-point (point)) (setq flyspell-pre-column (current-column))) -;*---------------------------------------------------------------------*/ -;* flyspell-mode-off ... */ -;*---------------------------------------------------------------------*/ +;;*---------------------------------------------------------------------*/ +;;* flyspell-mode-off ... */ +;;*---------------------------------------------------------------------*/ ;;;###autoload (defun flyspell-mode-off () "Turn Flyspell mode off." ;; we remove the hooks (remove-hook 'post-command-hook (function flyspell-post-command-hook) t) (remove-hook 'pre-command-hook (function flyspell-pre-command-hook) t) - (setq after-change-functions (delq 'flyspell-after-change-function - after-change-functions)) + (remove-hook 'after-change-functions 'flyspell-after-change-function t) ;; we remove all the flyspell hilightings (flyspell-delete-all-overlays) ;; we have to erase pre cache variables @@ -672,9 +673,9 @@ not the very same deplacement command." ;; we mark the mode as killed (setq flyspell-mode nil)) -;*---------------------------------------------------------------------*/ -;* flyspell-check-pre-word-p ... */ -;*---------------------------------------------------------------------*/ +;;*---------------------------------------------------------------------*/ +;;* flyspell-check-pre-word-p ... */ +;;*---------------------------------------------------------------------*/ (defun flyspell-check-pre-word-p () "Return non-nil if we should check the word before point. More precisely, it applies to the word that was before point @@ -710,24 +711,24 @@ before the current command." (or (< flyspell-pre-point flyspell-word-cache-start) (> flyspell-pre-point flyspell-word-cache-end))))) -;*---------------------------------------------------------------------*/ -;* The flyspell after-change-hook, store the change position. In */ -;* the post command hook, we will check, if the word at this */ -;* position has to be spell checked. */ -;*---------------------------------------------------------------------*/ +;;*---------------------------------------------------------------------*/ +;;* The flyspell after-change-hook, store the change position. In */ +;;* the post command hook, we will check, if the word at this */ +;;* position has to be spell checked. */ +;;*---------------------------------------------------------------------*/ (defvar flyspell-changes nil) +(make-variable-buffer-local 'flyspell-changes) -;*---------------------------------------------------------------------*/ -;* flyspell-after-change-function ... */ -;*---------------------------------------------------------------------*/ +;;*---------------------------------------------------------------------*/ +;;* flyspell-after-change-function ... */ +;;*---------------------------------------------------------------------*/ (defun flyspell-after-change-function (start stop len) "Save the current buffer and point for Flyspell's post-command hook." - (interactive) - (setq flyspell-changes (cons (cons start stop) flyspell-changes))) + (push (cons start stop) flyspell-changes)) -;*---------------------------------------------------------------------*/ -;* flyspell-check-changed-word-p ... */ -;*---------------------------------------------------------------------*/ +;;*---------------------------------------------------------------------*/ +;;* flyspell-check-changed-word-p ... */ +;;*---------------------------------------------------------------------*/ (defun flyspell-check-changed-word-p (start stop) "Return t when the changed word has to be checked. The answer depends of several criteria. @@ -745,9 +746,9 @@ Mostly we check word delimiters." (t t))) -;*---------------------------------------------------------------------*/ -;* flyspell-check-word-p ... */ -;*---------------------------------------------------------------------*/ +;;*---------------------------------------------------------------------*/ +;;* flyspell-check-word-p ... */ +;;*---------------------------------------------------------------------*/ (defun flyspell-check-word-p () "Return t when the word at `point' has to be checked. The answer depends of several criteria. @@ -762,7 +763,7 @@ Mostly we check word delimiters." (backward-char 1) (and (looking-at (flyspell-get-not-casechars)) (or flyspell-consider-dash-as-word-delimiter-flag - (not (looking-at "\\-")))))) + (not (looking-at "-")))))) ;; yes because we have reached or typed a word delimiter. t) ((symbolp this-command) @@ -777,67 +778,57 @@ Mostly we check word delimiters." (t t))) (t t))) -;*---------------------------------------------------------------------*/ -;* flyspell-debug-signal-no-check ... */ -;*---------------------------------------------------------------------*/ +;;*---------------------------------------------------------------------*/ +;;* flyspell-debug-signal-no-check ... */ +;;*---------------------------------------------------------------------*/ (defun flyspell-debug-signal-no-check (msg obj) (setq debug-on-error t) - (save-excursion - (let ((buffer (get-buffer-create "*flyspell-debug*"))) - (set-buffer buffer) - (erase-buffer) - (insert "NO-CHECK:\n") - (insert (format " %S : %S\n" msg obj))))) - -;*---------------------------------------------------------------------*/ -;* flyspell-debug-signal-pre-word-checked ... */ -;*---------------------------------------------------------------------*/ + (with-current-buffer (get-buffer-create "*flyspell-debug*") + (erase-buffer) + (insert "NO-CHECK:\n") + (insert (format " %S : %S\n" msg obj)))) + +;;*---------------------------------------------------------------------*/ +;;* flyspell-debug-signal-pre-word-checked ... */ +;;*---------------------------------------------------------------------*/ (defun flyspell-debug-signal-pre-word-checked () (setq debug-on-error t) - (save-excursion - (let ((buffer (get-buffer-create "*flyspell-debug*"))) - (set-buffer buffer) - (insert "PRE-WORD:\n") - (insert (format " pre-point : %S\n" flyspell-pre-point)) - (insert (format " pre-buffer : %S\n" flyspell-pre-buffer)) - (insert (format " cache-start: %S\n" flyspell-word-cache-start)) - (insert (format " cache-end : %S\n" flyspell-word-cache-end)) - (goto-char (point-max))))) - -;*---------------------------------------------------------------------*/ -;* flyspell-debug-signal-word-checked ... */ -;*---------------------------------------------------------------------*/ + (with-current-buffer (get-buffer-create "*flyspell-debug*") + (insert "PRE-WORD:\n") + (insert (format " pre-point : %S\n" flyspell-pre-point)) + (insert (format " pre-buffer : %S\n" flyspell-pre-buffer)) + (insert (format " cache-start: %S\n" flyspell-word-cache-start)) + (insert (format " cache-end : %S\n" flyspell-word-cache-end)) + (goto-char (point-max)))) + +;;*---------------------------------------------------------------------*/ +;;* flyspell-debug-signal-word-checked ... */ +;;*---------------------------------------------------------------------*/ (defun flyspell-debug-signal-word-checked () (setq debug-on-error t) - (save-excursion - (let ((oldbuf (current-buffer)) - (buffer (get-buffer-create "*flyspell-debug*")) - (point (point))) - (set-buffer buffer) + (let ((oldbuf (current-buffer)) + (point (point))) + (with-current-buffer (get-buffer-create "*flyspell-debug*") (insert "WORD:\n") (insert (format " this-cmd : %S\n" this-command)) (insert (format " delayed : %S\n" (and (symbolp this-command) (get this-command 'flyspell-delayed)))) (insert (format " point : %S\n" point)) (insert (format " prev-char : [%c] %S\n" - (progn - (set-buffer oldbuf) + (with-current-buffer oldbuf (let ((c (if (> (point) (point-min)) (save-excursion (backward-char 1) (char-after (point))) ? ))) - (set-buffer buffer) c)) - (progn - (set-buffer oldbuf) + (with-current-buffer oldbuf (let ((c (if (> (point) (point-min)) (save-excursion (backward-char 1) (and (and (looking-at (flyspell-get-not-casechars)) 1) (and (or flyspell-consider-dash-as-word-delimiter-flag (not (looking-at "\\-"))) 2)))))) - (set-buffer buffer) c)))) (insert (format " because : %S\n" (cond @@ -846,15 +837,13 @@ Mostly we check word delimiters." ;; the current command is not delayed, that ;; is that we must check the word now 'not-delayed) - ((progn - (set-buffer oldbuf) + ((with-current-buffer oldbuf (let ((c (if (> (point) (point-min)) (save-excursion (backward-char 1) (and (looking-at (flyspell-get-not-casechars)) (or flyspell-consider-dash-as-word-delimiter-flag (not (looking-at "\\-")))))))) - (set-buffer buffer) c)) ;; yes because we have reached or typed a word delimiter. 'separator) @@ -865,41 +854,40 @@ Mostly we check word delimiters." 'sit-for)))) (goto-char (point-max))))) -;*---------------------------------------------------------------------*/ -;* flyspell-debug-signal-changed-checked ... */ -;*---------------------------------------------------------------------*/ +;;*---------------------------------------------------------------------*/ +;;* flyspell-debug-signal-changed-checked ... */ +;;*---------------------------------------------------------------------*/ (defun flyspell-debug-signal-changed-checked () (setq debug-on-error t) - (save-excursion - (let ((buffer (get-buffer-create "*flyspell-debug*")) - (point (point))) - (set-buffer buffer) + (let ((point (point))) + (with-current-buffer (get-buffer-create "*flyspell-debug*") (insert "CHANGED WORD:\n") (insert (format " point : %S\n" point)) (goto-char (point-max))))) -;*---------------------------------------------------------------------*/ -;* flyspell-post-command-hook ... */ -;* ------------------------------------------------------------- */ -;* It is possible that we check several words: */ -;* 1- the current word is checked if the predicate */ -;* FLYSPELL-CHECK-WORD-P is true */ -;* 2- the word that used to be the current word before the */ -;* THIS-COMMAND is checked if: */ -;* a- the previous word is different from the current word */ -;* b- the previous word as not just been checked by the */ -;* previous FLYSPELL-POST-COMMAND-HOOK */ -;* 3- the words changed by the THIS-COMMAND that are neither the */ -;* previous word nor the current word */ -;*---------------------------------------------------------------------*/ +;;*---------------------------------------------------------------------*/ +;;* flyspell-post-command-hook ... */ +;;* ------------------------------------------------------------- */ +;;* It is possible that we check several words: */ +;;* 1- the current word is checked if the predicate */ +;;* FLYSPELL-CHECK-WORD-P is true */ +;;* 2- the word that used to be the current word before the */ +;;* THIS-COMMAND is checked if: */ +;;* a- the previous word is different from the current word */ +;;* b- the previous word as not just been checked by the */ +;;* previous FLYSPELL-POST-COMMAND-HOOK */ +;;* 3- the words changed by the THIS-COMMAND that are neither the */ +;;* previous word nor the current word */ +;;*---------------------------------------------------------------------*/ (defun flyspell-post-command-hook () "The `post-command-hook' used by flyspell to check a word in-the-fly." (interactive) - (let ((command this-command)) + (let ((command this-command) + ;; Prevent anything we do from affecting the mark. + deactivate-mark) (if (flyspell-check-pre-word-p) - (save-excursion + (with-current-buffer flyspell-pre-buffer '(flyspell-debug-signal-pre-word-checked) - (set-buffer flyspell-pre-buffer) (save-excursion (goto-char flyspell-pre-point) (flyspell-word)))) @@ -924,7 +912,7 @@ Mostly we check word delimiters." (progn (setq flyspell-word-cache-end -1) (setq flyspell-word-cache-result '_))))) - (while (consp flyspell-changes) + (while (and (not (input-pending-p)) (consp flyspell-changes)) (let ((start (car (car flyspell-changes))) (stop (cdr (car flyspell-changes)))) (if (flyspell-check-changed-word-p start stop) @@ -935,21 +923,21 @@ Mostly we check word delimiters." (setq flyspell-changes (cdr flyspell-changes)))) (setq flyspell-previous-command command))) -;*---------------------------------------------------------------------*/ -;* flyspell-notify-misspell ... */ -;*---------------------------------------------------------------------*/ -(defun flyspell-notify-misspell (start end word poss) +;;*---------------------------------------------------------------------*/ +;;* flyspell-notify-misspell ... */ +;;*---------------------------------------------------------------------*/ +(defun flyspell-notify-misspell (word poss) (let ((replacements (if (stringp poss) poss (if flyspell-sort-corrections (sort (car (cdr (cdr poss))) 'string<) (car (cdr (cdr poss))))))) (if flyspell-issue-message-flag - (message "mispelling `%s' %S" word replacements)))) + (message "misspelling `%s' %S" word replacements)))) -;*---------------------------------------------------------------------*/ -;* flyspell-word-search-backward ... */ -;*---------------------------------------------------------------------*/ +;;*---------------------------------------------------------------------*/ +;;* flyspell-word-search-backward ... */ +;;*---------------------------------------------------------------------*/ (defun flyspell-word-search-backward (word bound) (save-excursion (let ((r '()) @@ -961,9 +949,9 @@ Mostly we check word delimiters." (goto-char p)))) r))) -;*---------------------------------------------------------------------*/ -;* flyspell-word-search-forward ... */ -;*---------------------------------------------------------------------*/ +;;*---------------------------------------------------------------------*/ +;;* flyspell-word-search-forward ... */ +;;*---------------------------------------------------------------------*/ (defun flyspell-word-search-forward (word bound) (save-excursion (let ((r '()) @@ -975,9 +963,9 @@ Mostly we check word delimiters." (goto-char (1+ p))))) r))) -;*---------------------------------------------------------------------*/ -;* flyspell-word ... */ -;*---------------------------------------------------------------------*/ +;;*---------------------------------------------------------------------*/ +;;* flyspell-word ... */ +;;*---------------------------------------------------------------------*/ (defun flyspell-word (&optional following) "Spell check a word." (interactive (list ispell-following-word)) @@ -985,8 +973,8 @@ Mostly we check word delimiters." ;; use the correct dictionary (flyspell-accept-buffer-local-defs) (let* ((cursor-location (point)) - (flyspell-word (flyspell-get-word following)) - start end poss word) + (flyspell-word (flyspell-get-word following)) + start end poss word) (if (or (eq flyspell-word nil) (and (fboundp flyspell-generic-check-word-p) (not (funcall flyspell-generic-check-word-p)))) @@ -1029,18 +1017,20 @@ Mostly we check word delimiters." (setq flyspell-word-cache-end end) (setq flyspell-word-cache-word word) ;; now check spelling of word. - (process-send-string ispell-process "%\n") + (ispell-send-string "%\n") ;; put in verbose mode - (process-send-string ispell-process - (concat "^" word "\n")) + (ispell-send-string (concat "^" word "\n")) ;; we mark the ispell process so it can be killed ;; when emacs is exited without query (set-process-query-on-exit-flag ispell-process nil) - ;; wait until ispell has processed word - (while (progn - (accept-process-output ispell-process) - (not (string= "" (car ispell-filter))))) - ;; (process-send-string ispell-process "!\n") + ;; Wait until ispell has processed word. Since this code is often + ;; executed from post-command-hook but the ispell process may not + ;; be responsive, it's important to make sure we re-enable C-g. + (with-local-quit + (while (progn + (accept-process-output ispell-process) + (not (string= "" (car ispell-filter)))))) + ;; (ispell-send-string "!\n") ;; back to terse mode. (setq ispell-filter (cdr ispell-filter)) (if (consp ispell-filter) @@ -1103,27 +1093,27 @@ Mostly we check word delimiters." (if flyspell-highlight-flag (flyspell-highlight-incorrect-region start end poss) - (flyspell-notify-misspell start end word poss)) + (flyspell-notify-misspell word poss)) nil)))) ;; return to original location (goto-char cursor-location) (if ispell-quit (setq ispell-quit nil)) res)))))))) -;*---------------------------------------------------------------------*/ -;* flyspell-tex-math-initialized ... */ -;*---------------------------------------------------------------------*/ +;;*---------------------------------------------------------------------*/ +;;* flyspell-tex-math-initialized ... */ +;;*---------------------------------------------------------------------*/ (defvar flyspell-tex-math-initialized nil) -;*---------------------------------------------------------------------*/ -;* flyspell-math-tex-command-p ... */ -;* ------------------------------------------------------------- */ -;* This function uses the texmathp package to check if (point) */ -;* is within a tex command. In order to avoid using */ -;* condition-case each time we use the variable */ -;* flyspell-tex-math-initialized to make a special case the first */ -;* time that function is called. */ -;*---------------------------------------------------------------------*/ +;;*---------------------------------------------------------------------*/ +;;* flyspell-math-tex-command-p ... */ +;;* ------------------------------------------------------------- */ +;;* This function uses the texmathp package to check if (point) */ +;;* is within a tex command. In order to avoid using */ +;;* condition-case each time we use the variable */ +;;* flyspell-tex-math-initialized to make a special case the first */ +;;* time that function is called. */ +;;*---------------------------------------------------------------------*/ (defun flyspell-math-tex-command-p () (when (fboundp 'texmathp) (cond @@ -1141,9 +1131,9 @@ Mostly we check word delimiters." (setq flyspell-tex-math-initialized 'error) nil))))))) -;*---------------------------------------------------------------------*/ -;* flyspell-tex-command-p ... */ -;*---------------------------------------------------------------------*/ +;;*---------------------------------------------------------------------*/ +;;* flyspell-tex-command-p ... */ +;;*---------------------------------------------------------------------*/ (defun flyspell-tex-command-p (word) "Return t if WORD is a TeX command." (or (save-excursion @@ -1155,17 +1145,17 @@ Mostly we check word delimiters." (>= (match-end 0) b)))))) (flyspell-math-tex-command-p))) -;*---------------------------------------------------------------------*/ -;* flyspell-casechars-cache ... */ -;*---------------------------------------------------------------------*/ +;;*---------------------------------------------------------------------*/ +;;* flyspell-casechars-cache ... */ +;;*---------------------------------------------------------------------*/ (defvar flyspell-casechars-cache nil) (defvar flyspell-ispell-casechars-cache nil) (make-variable-buffer-local 'flyspell-casechars-cache) (make-variable-buffer-local 'flyspell-ispell-casechars-cache) -;*---------------------------------------------------------------------*/ -;* flyspell-get-casechars ... */ -;*---------------------------------------------------------------------*/ +;;*---------------------------------------------------------------------*/ +;;* flyspell-get-casechars ... */ +;;*---------------------------------------------------------------------*/ (defun flyspell-get-casechars () "This function builds a string that is the regexp of word chars. In order to avoid one useless string construction, @@ -1185,17 +1175,17 @@ this function changes the last char of the `ispell-casechars' string." (setq flyspell-casechars-cache ispell-casechars) flyspell-casechars-cache)))) -;*---------------------------------------------------------------------*/ -;* flyspell-get-not-casechars-cache ... */ -;*---------------------------------------------------------------------*/ +;;*---------------------------------------------------------------------*/ +;;* flyspell-get-not-casechars-cache ... */ +;;*---------------------------------------------------------------------*/ (defvar flyspell-not-casechars-cache nil) (defvar flyspell-ispell-not-casechars-cache nil) (make-variable-buffer-local 'flyspell-not-casechars-cache) (make-variable-buffer-local 'flyspell-ispell-not-casechars-cache) -;*---------------------------------------------------------------------*/ -;* flyspell-get-not-casechars ... */ -;*---------------------------------------------------------------------*/ +;;*---------------------------------------------------------------------*/ +;;* flyspell-get-not-casechars ... */ +;;*---------------------------------------------------------------------*/ (defun flyspell-get-not-casechars () "This function builds a string that is the regexp of non-word chars." (let ((ispell-not-casechars (ispell-get-not-casechars))) @@ -1213,9 +1203,9 @@ this function changes the last char of the `ispell-casechars' string." (setq flyspell-not-casechars-cache ispell-not-casechars) flyspell-not-casechars-cache)))) -;*---------------------------------------------------------------------*/ -;* flyspell-get-word ... */ -;*---------------------------------------------------------------------*/ +;;*---------------------------------------------------------------------*/ +;;* flyspell-get-word ... */ +;;*---------------------------------------------------------------------*/ (defun flyspell-get-word (following &optional extra-otherchars) "Return the word for spell-checking according to Ispell syntax. If optional argument FOLLOWING is non-nil or if `flyspell-following-word' @@ -1245,10 +1235,10 @@ Word syntax described by `flyspell-dictionary-alist' (which see)." ;; find the word (if (not (looking-at flyspell-casechars)) (if following - (re-search-forward flyspell-casechars (point-max) t) - (re-search-backward flyspell-casechars (point-min) t))) + (re-search-forward flyspell-casechars nil t) + (re-search-backward flyspell-casechars nil t))) ;; move to front of word - (re-search-backward flyspell-not-casechars (point-min) 'start) + (re-search-backward flyspell-not-casechars nil 'start) (while (and (or (and (not (string= "" ispell-otherchars)) (looking-at ispell-otherchars)) (and extra-otherchars (looking-at extra-otherchars))) @@ -1260,15 +1250,15 @@ Word syntax described by `flyspell-dictionary-alist' (which see)." (progn (backward-char 1) (if (looking-at flyspell-casechars) - (re-search-backward flyspell-not-casechars (point-min) 'move))) + (re-search-backward flyspell-not-casechars nil 'move))) (setq did-it-once t prevpt (point)) (backward-char 1) (if (looking-at flyspell-casechars) - (re-search-backward flyspell-not-casechars (point-min) 'move) + (re-search-backward flyspell-not-casechars nil 'move) (backward-char -1)))) ;; Now mark the word and save to string. - (if (not (re-search-forward word-regexp (point-max) t)) + (if (not (re-search-forward word-regexp nil t)) nil (progn (setq start (match-beginning 0) @@ -1276,9 +1266,9 @@ Word syntax described by `flyspell-dictionary-alist' (which see)." word (buffer-substring-no-properties start end)) (list word start end))))) -;*---------------------------------------------------------------------*/ -;* flyspell-small-region ... */ -;*---------------------------------------------------------------------*/ +;;*---------------------------------------------------------------------*/ +;;* flyspell-small-region ... */ +;;*---------------------------------------------------------------------*/ (defun flyspell-small-region (beg end) "Flyspell text between BEG and END." (save-excursion @@ -1305,65 +1295,150 @@ Word syntax described by `flyspell-dictionary-alist' (which see)." (if flyspell-issue-message-flag (message "Spell Checking completed.")) (flyspell-word))) -;*---------------------------------------------------------------------*/ -;* flyspell-external-ispell-process ... */ -;*---------------------------------------------------------------------*/ +;;*---------------------------------------------------------------------*/ +;;* flyspell-external-ispell-process ... */ +;;*---------------------------------------------------------------------*/ (defvar flyspell-external-ispell-process '() "The external Flyspell Ispell process.") -;*---------------------------------------------------------------------*/ -;* flyspell-external-ispell-buffer ... */ -;*---------------------------------------------------------------------*/ +;;*---------------------------------------------------------------------*/ +;;* flyspell-external-ispell-buffer ... */ +;;*---------------------------------------------------------------------*/ (defvar flyspell-external-ispell-buffer '()) (defvar flyspell-large-region-buffer '()) (defvar flyspell-large-region-beg (point-min)) (defvar flyspell-large-region-end (point-max)) -;*---------------------------------------------------------------------*/ -;* flyspell-external-point-words ... */ -;*---------------------------------------------------------------------*/ +;;*---------------------------------------------------------------------*/ +;;* flyspell-external-point-words ... */ +;;*---------------------------------------------------------------------*/ (defun flyspell-external-point-words () "Mark words from a buffer listing incorrect words in order of appearance. The list of incorrect words should be in `flyspell-external-ispell-buffer'. \(We finish by killing that buffer and setting the variable to nil.) The buffer to mark them in is `flyspell-large-region-buffer'." - - (with-current-buffer flyspell-external-ispell-buffer - (goto-char (point-min)) - ;; Loop over incorrect words. - (while (re-search-forward "\\([^\n]+\\)\n" (point-max) t) - ;; Bind WORD to the next one. - (let ((word (match-string 1))) - ;; Here there used to be code to see if WORD is the same - ;; as the previous iteration, and count the number of consecutive - ;; identical words, and the loop below would search for that many. - ;; That code seemed to be incorrect, and on principle, should - ;; be unnecessary too. -- rms. - (if flyspell-issue-message-flag - (message "Spell Checking...%d%% [%s]" - (* 100 (/ (float (point)) (point-max))) - word)) - ;; Search the other buffer for occurrences of this word, - ;; and check them. Stop when we find one that reports "incorrect". - ;; (I don't understand the reason for that logic, - ;; but I didn't want to change it. -- rms.) - (with-current-buffer flyspell-large-region-buffer - (goto-char flyspell-large-region-beg) - (let ((keep t)) - (while (and keep - (search-forward word flyspell-large-region-end t)) - (goto-char (- (point) 1)) - (setq keep (flyspell-word))) - (setq flyspell-large-region-beg (point)))))) - ;; we are done - (if flyspell-issue-message-flag (message "Spell Checking completed."))) - ;; Kill and forget the buffer with the list of incorrect words. - (kill-buffer flyspell-external-ispell-buffer) - (setq flyspell-external-ispell-buffer nil)) - -;*---------------------------------------------------------------------*/ -;* flyspell-large-region ... */ -;*---------------------------------------------------------------------*/ + (let (words-not-found + (ispell-otherchars (ispell-get-otherchars)) + (buffer-scan-pos flyspell-large-region-beg)) + (with-current-buffer flyspell-external-ispell-buffer + (goto-char (point-min)) + ;; Loop over incorrect words, in the order they were reported, + ;; which is also the order they appear in the buffer being checked. + (while (re-search-forward "\\([^\n]+\\)\n" nil t) + ;; Bind WORD to the next one. + (let ((word (match-string 1)) (wordpos (point))) + ;; Here there used to be code to see if WORD is the same + ;; as the previous iteration, and count the number of consecutive + ;; identical words, and the loop below would search for that many. + ;; That code seemed to be incorrect, and on principle, should + ;; be unnecessary too. -- rms. + (if flyspell-issue-message-flag + (message "Spell Checking...%d%% [%s]" + (* 100 (/ (float (point)) (point-max))) + word)) + (with-current-buffer flyspell-large-region-buffer + (goto-char buffer-scan-pos) + (let ((keep t)) + ;; Iterate on string search until string is found as word, + ;; not as substring + (while keep + (if (search-forward word + flyspell-large-region-end t) + (let* ((found-list + (save-excursion + ;; Move back into the match + ;; so flyspell-get-word will find it. + (forward-char -1) + (flyspell-get-word nil))) + (found (car found-list)) + (found-length (length found)) + (misspell-length (length word))) + (when (or + ;; Size matches, we really found it. + (= found-length misspell-length) + ;; Matches as part of a boundary-char separated word + (member word + (split-string found ispell-otherchars)) + ;; Misspelling has higher length than + ;; what flyspell considers the + ;; word. Caused by boundary-chars + ;; mismatch. Validating seems safe. + (< found-length misspell-length) + ;; ispell treats beginning of some TeX + ;; commands as nroff control sequences + ;; and strips them in the list of + ;; misspelled words thus giving a + ;; non-existent word. Skip if ispell + ;; is used, string is a TeX command + ;; (char before beginning of word is + ;; backslash) and none of the previous + ;; contitions match + (and (not ispell-really-aspell) + (save-excursion + (goto-char (- (nth 1 found-list) 1)) + (if (looking-at "[\\]" ) + t + nil)))) + (setq keep nil) + (flyspell-word) + ;; Search for next misspelled word will begin from + ;; end of last validated match. + (setq buffer-scan-pos (point)))) + ;; Record if misspelling is not found and try new one + (add-to-list 'words-not-found + (concat " -> " word " - " + (int-to-string wordpos))) + (setq keep nil))))))) + ;; we are done + (if flyspell-issue-message-flag (message "Spell Checking completed."))) + ;; Warn about not found misspellings + (dolist (word words-not-found) + (message "%s: word not found" word)) + ;; Kill and forget the buffer with the list of incorrect words. + (kill-buffer flyspell-external-ispell-buffer) + (setq flyspell-external-ispell-buffer nil))) + +;;*---------------------------------------------------------------------*/ +;;* flyspell-process-localwords ... */ +;;* ------------------------------------------------------------- */ +;;* This function is used to prevent marking of words explicitly */ +;;* declared correct. */ +;;*---------------------------------------------------------------------*/ +(defun flyspell-process-localwords (misspellings-buffer) + (let (localwords + (ispell-casechars (ispell-get-casechars))) + ;; Get localwords from the original buffer + (save-excursion + (goto-char (point-min)) + ;; Localwords parsing copied from ispell.el. + (while (search-forward ispell-words-keyword nil t) + (let ((end (save-excursion (end-of-line) (point))) + string) + ;; buffer-local words separated by a space, and can contain + ;; any character other than a space. Not rigorous enough. + (while (re-search-forward " *\\([^ ]+\\)" end t) + (setq string (buffer-substring-no-properties (match-beginning 1) + (match-end 1))) + ;; This can fail when string contains a word with invalid chars. + ;; Error handling needs to be added between Ispell and Emacs. + (if (and (< 1 (length string)) + (equal 0 (string-match ispell-casechars string))) + (push string localwords)))))) + ;; Remove localwords matches from misspellings-buffer. + ;; The usual mechanism of communicating the local words to ispell + ;; does not affect the special ispell process used by + ;; flyspell-large-region. + (with-current-buffer misspellings-buffer + (save-excursion + (dolist (word localwords) + (goto-char (point-min)) + (let ((regexp (concat "^" word "\n"))) + (while (re-search-forward regexp nil t) + (delete-region (match-beginning 0) (match-end 0))))))))) + +;;*---------------------------------------------------------------------*/ +;;* flyspell-large-region ... */ +;;*---------------------------------------------------------------------*/ (defun flyspell-large-region (beg end) (let* ((curbuf (current-buffer)) (buffer (get-buffer-create "*flyspell-region*"))) @@ -1371,11 +1446,13 @@ The buffer to mark them in is `flyspell-large-region-buffer'." (setq flyspell-large-region-buffer curbuf) (setq flyspell-large-region-beg beg) (setq flyspell-large-region-end end) + (flyspell-accept-buffer-local-defs) (set-buffer buffer) (erase-buffer) ;; this is done, we can start checking... (if flyspell-issue-message-flag (message "Checking region...")) (set-buffer curbuf) + (ispell-check-version) (let ((c (apply 'call-process-region beg end ispell-program-name @@ -1400,18 +1477,22 @@ The buffer to mark them in is `flyspell-large-region-buffer'." (setq args (append args ispell-extra-args)) args)))) (if (eq c 0) - (flyspell-external-point-words) + (progn + (flyspell-process-localwords buffer) + (with-current-buffer curbuf + (flyspell-delete-region-overlays beg end)) + (flyspell-external-point-words)) (error "Can't check region..."))))) -;*---------------------------------------------------------------------*/ -;* flyspell-region ... */ -;* ------------------------------------------------------------- */ -;* Because `ispell -a' is too slow, it is not possible to use */ -;* it on large region. Then, when ispell is invoked on a large */ -;* text region, a new `ispell -l' process is spawned. The */ -;* pointed out words are then searched in the region a checked with */ -;* regular flyspell means. */ -;*---------------------------------------------------------------------*/ +;;*---------------------------------------------------------------------*/ +;;* flyspell-region ... */ +;;* ------------------------------------------------------------- */ +;;* Because `ispell -a' is too slow, it is not possible to use */ +;;* it on large region. Then, when ispell is invoked on a large */ +;;* text region, a new `ispell -l' process is spawned. The */ +;;* pointed out words are then searched in the region a checked with */ +;;* regular flyspell means. */ +;;*---------------------------------------------------------------------*/ ;;;###autoload (defun flyspell-region (beg end) "Flyspell text between BEG and END." @@ -1427,24 +1508,24 @@ The buffer to mark them in is `flyspell-large-region-buffer'." (flyspell-large-region beg end) (flyspell-small-region beg end))))) -;*---------------------------------------------------------------------*/ -;* flyspell-buffer ... */ -;*---------------------------------------------------------------------*/ +;;*---------------------------------------------------------------------*/ +;;* flyspell-buffer ... */ +;;*---------------------------------------------------------------------*/ ;;;###autoload (defun flyspell-buffer () "Flyspell whole buffer." (interactive) (flyspell-region (point-min) (point-max))) -;*---------------------------------------------------------------------*/ -;* old next error position ... */ -;*---------------------------------------------------------------------*/ +;;*---------------------------------------------------------------------*/ +;;* old next error position ... */ +;;*---------------------------------------------------------------------*/ (defvar flyspell-old-buffer-error nil) (defvar flyspell-old-pos-error nil) -;*---------------------------------------------------------------------*/ -;* flyspell-goto-next-error ... */ -;*---------------------------------------------------------------------*/ +;;*---------------------------------------------------------------------*/ +;;* flyspell-goto-next-error ... */ +;;*---------------------------------------------------------------------*/ (defun flyspell-goto-next-error () "Go to the next previously detected error. In general FLYSPELL-GOTO-NEXT-ERROR must be used after @@ -1479,30 +1560,30 @@ FLYSPELL-BUFFER." (if (= pos max) (message "No more miss-spelled word!")))) -;*---------------------------------------------------------------------*/ -;* flyspell-overlay-p ... */ -;*---------------------------------------------------------------------*/ +;;*---------------------------------------------------------------------*/ +;;* flyspell-overlay-p ... */ +;;*---------------------------------------------------------------------*/ (defun flyspell-overlay-p (o) "A predicate that return true iff O is an overlay used by flyspell." (and (overlayp o) (overlay-get o 'flyspell-overlay))) -;*---------------------------------------------------------------------*/ -;* flyspell-delete-all-overlays ... */ -;* ------------------------------------------------------------- */ -;* Remove all the overlays introduced by flyspell. */ -;*---------------------------------------------------------------------*/ +;;*---------------------------------------------------------------------*/ +;;* flyspell-delete-region-overlays, flyspell-delete-all-overlays */ +;;* ------------------------------------------------------------- */ +;;* Remove overlays introduced by flyspell. */ +;;*---------------------------------------------------------------------*/ +(defun flyspell-delete-region-overlays (beg end) + "Delete overlays used by flyspell in a given region." + (remove-overlays beg end 'flyspell-overlay t)) + + (defun flyspell-delete-all-overlays () "Delete all the overlays used by flyspell." - (let ((l (overlays-in (point-min) (point-max)))) - (while (consp l) - (progn - (if (flyspell-overlay-p (car l)) - (delete-overlay (car l))) - (setq l (cdr l)))))) + (remove-overlays (point-min) (point-max) 'flyspell-overlay t)) -;*---------------------------------------------------------------------*/ -;* flyspell-unhighlight-at ... */ -;*---------------------------------------------------------------------*/ +;;*---------------------------------------------------------------------*/ +;;* flyspell-unhighlight-at ... */ +;;*---------------------------------------------------------------------*/ (defun flyspell-unhighlight-at (pos) "Remove the flyspell overlay that are located at POS." (if flyspell-persistent-highlight @@ -1512,13 +1593,13 @@ FLYSPELL-BUFFER." (delete-overlay (car overlays))) (setq overlays (cdr overlays)))) (if (flyspell-overlay-p flyspell-overlay) - (delete-overlay flyspell-overlay)))) + (delete-overlay flyspell-overlay)))) -;*---------------------------------------------------------------------*/ -;* flyspell-properties-at-p ... */ -;* ------------------------------------------------------------- */ -;* Is there an highlight properties at position pos? */ -;*---------------------------------------------------------------------*/ +;;*---------------------------------------------------------------------*/ +;;* flyspell-properties-at-p ... */ +;;* ------------------------------------------------------------- */ +;;* Is there an highlight properties at position pos? */ +;;*---------------------------------------------------------------------*/ (defun flyspell-properties-at-p (pos) "Return t if there is a text property at POS, not counting `local-map'. If variable `flyspell-highlight-properties' is set to nil, @@ -1532,33 +1613,33 @@ if the character at POS has any other property." (setq keep nil))) (consp prop))) -;*---------------------------------------------------------------------*/ -;* make-flyspell-overlay ... */ -;*---------------------------------------------------------------------*/ +;;*---------------------------------------------------------------------*/ +;;* make-flyspell-overlay ... */ +;;*---------------------------------------------------------------------*/ (defun make-flyspell-overlay (beg end face mouse-face) "Allocate an overlay to highlight an incorrect word. BEG and END specify the range in the buffer of that word. FACE and MOUSE-FACE specify the `face' and `mouse-face' properties for the overlay." - (let ((flyspell-overlay (make-overlay beg end nil t nil))) - (overlay-put flyspell-overlay 'face face) - (overlay-put flyspell-overlay 'mouse-face mouse-face) - (overlay-put flyspell-overlay 'flyspell-overlay t) - (overlay-put flyspell-overlay 'evaporate t) - (overlay-put flyspell-overlay 'help-echo "mouse-2: correct word at point") - (overlay-put flyspell-overlay 'keymap flyspell-mouse-map) + (let ((overlay (make-overlay beg end nil t nil))) + (overlay-put overlay 'face face) + (overlay-put overlay 'mouse-face mouse-face) + (overlay-put overlay 'flyspell-overlay t) + (overlay-put overlay 'evaporate t) + (overlay-put overlay 'help-echo "mouse-2: correct word at point") + (overlay-put overlay 'keymap flyspell-mouse-map) (when (eq face 'flyspell-incorrect) (and (stringp flyspell-before-incorrect-word-string) - (overlay-put flyspell-overlay 'before-string + (overlay-put overlay 'before-string flyspell-before-incorrect-word-string)) (and (stringp flyspell-after-incorrect-word-string) - (overlay-put flyspell-overlay 'after-string + (overlay-put overlay 'after-string flyspell-after-incorrect-word-string))) - flyspell-overlay)) + overlay)) -;*---------------------------------------------------------------------*/ -;* flyspell-highlight-incorrect-region ... */ -;*---------------------------------------------------------------------*/ +;;*---------------------------------------------------------------------*/ +;;* flyspell-highlight-incorrect-region ... */ +;;*---------------------------------------------------------------------*/ (defun flyspell-highlight-incorrect-region (beg end poss) "Set up an overlay on a misspelled word, in the buffer from BEG to END. POSS is usually a list of possible spelling/correction lists, @@ -1580,22 +1661,15 @@ is itself incorrect, but suspiciously repeated." (delete-overlay (car os))) (setq os (cdr os))))) ;; we cleanup current overlay at the same position - (if (and (not flyspell-persistent-highlight) - (overlayp flyspell-overlay)) - (delete-overlay flyspell-overlay) - (let ((os (overlays-at beg))) - (while (consp os) - (if (flyspell-overlay-p (car os)) - (delete-overlay (car os))) - (setq os (cdr os))))) + (flyspell-unhighlight-at beg) ;; now we can use a new overlay (setq flyspell-overlay (make-flyspell-overlay beg end 'flyspell-incorrect 'highlight))))))) -;*---------------------------------------------------------------------*/ -;* flyspell-highlight-duplicate-region ... */ -;*---------------------------------------------------------------------*/ +;;*---------------------------------------------------------------------*/ +;;* flyspell-highlight-duplicate-region ... */ +;;*---------------------------------------------------------------------*/ (defun flyspell-highlight-duplicate-region (beg end poss) "Set up an overlay on a duplicate misspelled word, in the buffer from BEG to END. POSS is a list of possible spelling/correction lists, @@ -1607,23 +1681,16 @@ as returned by `ispell-parse-output'." (not (flyspell-properties-at-p beg))) (progn ;; we cleanup current overlay at the same position - (if (and (not flyspell-persistent-highlight) - (overlayp flyspell-overlay)) - (delete-overlay flyspell-overlay) - (let ((overlays (overlays-at beg))) - (while (consp overlays) - (if (flyspell-overlay-p (car overlays)) - (delete-overlay (car overlays))) - (setq overlays (cdr overlays))))) + (flyspell-unhighlight-at beg) ;; now we can use a new overlay (setq flyspell-overlay (make-flyspell-overlay beg end 'flyspell-duplicate 'highlight))))))) -;*---------------------------------------------------------------------*/ -;* flyspell-auto-correct-cache ... */ -;*---------------------------------------------------------------------*/ +;;*---------------------------------------------------------------------*/ +;;* flyspell-auto-correct-cache ... */ +;;*---------------------------------------------------------------------*/ (defvar flyspell-auto-correct-pos nil) (defvar flyspell-auto-correct-region nil) (defvar flyspell-auto-correct-ring nil) @@ -1633,9 +1700,9 @@ as returned by `ispell-parse-output'." (make-variable-buffer-local 'flyspell-auto-correct-ring) (make-variable-buffer-local 'flyspell-auto-correct-word) -;*---------------------------------------------------------------------*/ -;* flyspell-check-previous-highlighted-word ... */ -;*---------------------------------------------------------------------*/ +;;*---------------------------------------------------------------------*/ +;;* flyspell-check-previous-highlighted-word ... */ +;;*---------------------------------------------------------------------*/ (defun flyspell-check-previous-highlighted-word (&optional arg) "Correct the closer misspelled word. This function scans a mis-spelled word before the cursor. If it finds one @@ -1656,7 +1723,7 @@ misspelled words backwards." (while (consp ovs) (setq ov (car ovs)) (setq ovs (cdr ovs)) - (if (and (overlay-get ov 'flyspell-overlay) + (if (and (flyspell-overlay-p ov) (= 0 (setq arg (1- arg)))) (throw 'exit t))))))) (save-excursion @@ -1664,9 +1731,9 @@ misspelled words backwards." (ispell-word)) (error "No word to correct before point")))) -;*---------------------------------------------------------------------*/ -;* flyspell-display-next-corrections ... */ -;*---------------------------------------------------------------------*/ +;;*---------------------------------------------------------------------*/ +;;* flyspell-display-next-corrections ... */ +;;*---------------------------------------------------------------------*/ (defun flyspell-display-next-corrections (corrections) (let ((string "Corrections:") (l corrections) @@ -1687,25 +1754,25 @@ misspelled words backwards." (display-message 'no-log string) (message "%s" string)))) -;*---------------------------------------------------------------------*/ -;* flyspell-abbrev-table ... */ -;*---------------------------------------------------------------------*/ +;;*---------------------------------------------------------------------*/ +;;* flyspell-abbrev-table ... */ +;;*---------------------------------------------------------------------*/ (defun flyspell-abbrev-table () (if flyspell-use-global-abbrev-table-p global-abbrev-table (or local-abbrev-table global-abbrev-table))) -;*---------------------------------------------------------------------*/ -;* flyspell-define-abbrev ... */ -;*---------------------------------------------------------------------*/ +;;*---------------------------------------------------------------------*/ +;;* flyspell-define-abbrev ... */ +;;*---------------------------------------------------------------------*/ (defun flyspell-define-abbrev (name expansion) (let ((table (flyspell-abbrev-table))) (when table (define-abbrev table name expansion)))) -;*---------------------------------------------------------------------*/ -;* flyspell-auto-correct-word ... */ -;*---------------------------------------------------------------------*/ +;;*---------------------------------------------------------------------*/ +;;* flyspell-auto-correct-word ... */ +;;*---------------------------------------------------------------------*/ (defun flyspell-auto-correct-word () "Correct the current word. This command proposes various successive corrections for the current word." @@ -1747,12 +1814,12 @@ This command proposes various successive corrections for the current word." poss) (setq flyspell-auto-correct-word word) ;; now check spelling of word. - (process-send-string ispell-process "%\n") ;put in verbose mode - (process-send-string ispell-process (concat "^" word "\n")) - ;; wait until ispell has processed word - (while (progn - (accept-process-output ispell-process) - (not (string= "" (car ispell-filter))))) + (ispell-send-string "%\n") ;put in verbose mode + (ispell-send-string (concat "^" word "\n")) + ;; wait until ispell has processed word. + (while (progn + (accept-process-output ispell-process) + (not (string= "" (car ispell-filter))))) (setq ispell-filter (cdr ispell-filter)) (if (consp ispell-filter) (setq poss (ispell-parse-output (car ispell-filter)))) @@ -1805,15 +1872,15 @@ This command proposes various successive corrections for the current word." (setq flyspell-auto-correct-pos (point)) (ispell-pdict-save t))))))) -;*---------------------------------------------------------------------*/ -;* flyspell-auto-correct-previous-pos ... */ -;*---------------------------------------------------------------------*/ +;;*---------------------------------------------------------------------*/ +;;* flyspell-auto-correct-previous-pos ... */ +;;*---------------------------------------------------------------------*/ (defvar flyspell-auto-correct-previous-pos nil "Holds the start of the first incorrect word before point.") -;*---------------------------------------------------------------------*/ -;* flyspell-auto-correct-previous-hook ... */ -;*---------------------------------------------------------------------*/ +;;*---------------------------------------------------------------------*/ +;;* flyspell-auto-correct-previous-hook ... */ +;;*---------------------------------------------------------------------*/ (defun flyspell-auto-correct-previous-hook () "Hook to track successive calls to `flyspell-auto-correct-previous-word'. Sets `flyspell-auto-correct-previous-pos' to nil" @@ -1822,11 +1889,11 @@ Sets `flyspell-auto-correct-previous-pos' to nil" (unless (eq this-command (function flyspell-auto-correct-previous-word)) (setq flyspell-auto-correct-previous-pos nil))) -;*---------------------------------------------------------------------*/ -;* flyspell-auto-correct-previous-word ... */ -;*---------------------------------------------------------------------*/ +;;*---------------------------------------------------------------------*/ +;;* flyspell-auto-correct-previous-word ... */ +;;*---------------------------------------------------------------------*/ (defun flyspell-auto-correct-previous-word (position) - "*Auto correct the first mispelled word that occurs before point. + "Auto correct the first mispelled word that occurs before point. But don't look beyond what's visible on the screen." (interactive "d") @@ -1876,9 +1943,9 @@ But don't look beyond what's visible on the screen." ;; the point may have moved so reset this (setq flyspell-auto-correct-previous-pos (point)))))))) -;*---------------------------------------------------------------------*/ -;* flyspell-correct-word ... */ -;*---------------------------------------------------------------------*/ +;;*---------------------------------------------------------------------*/ +;;* flyspell-correct-word ... */ +;;*---------------------------------------------------------------------*/ (defun flyspell-correct-word (event) "Pop up a menu of possible corrections for a misspelled word. The word checked is the word at the mouse position." @@ -1896,12 +1963,12 @@ The word checked is the word at the mouse position." (word (car word)) poss) ;; now check spelling of word. - (process-send-string ispell-process "%\n") ;put in verbose mode - (process-send-string ispell-process (concat "^" word "\n")) + (ispell-send-string "%\n") ;put in verbose mode + (ispell-send-string (concat "^" word "\n")) ;; wait until ispell has processed word - (while (progn - (accept-process-output ispell-process) - (not (string= "" (car ispell-filter))))) + (while (progn + (accept-process-output ispell-process) + (not (string= "" (car ispell-filter))))) (setq ispell-filter (cdr ispell-filter)) (if (consp ispell-filter) (setq poss (ispell-parse-output (car ispell-filter)))) @@ -1914,16 +1981,16 @@ The word checked is the word at the mouse position." (error "Ispell: error in Ispell process")) ((featurep 'xemacs) (flyspell-xemacs-popup - event poss word cursor-location start end save)) + poss word cursor-location start end save)) (t ;; The word is incorrect, we have to propose a replacement. (flyspell-do-correct (flyspell-emacs-popup event poss word) poss word cursor-location start end save))) (ispell-pdict-save t)))))) -;*---------------------------------------------------------------------*/ -;* flyspell-do-correct ... */ -;*---------------------------------------------------------------------*/ +;;*---------------------------------------------------------------------*/ +;;* flyspell-do-correct ... */ +;;*---------------------------------------------------------------------*/ (defun flyspell-do-correct (replace poss word cursor-location start end save) "The popup menu callback." ;; Originally, the XEmacs code didn't do the (goto-char save) here and did @@ -1972,9 +2039,9 @@ The word checked is the word at the mouse position." (goto-char save) nil))) -;*---------------------------------------------------------------------*/ -;* flyspell-ajust-cursor-point ... */ -;*---------------------------------------------------------------------*/ +;;*---------------------------------------------------------------------*/ +;;* flyspell-ajust-cursor-point ... */ +;;*---------------------------------------------------------------------*/ (defun flyspell-ajust-cursor-point (save cursor-location old-max) (if (>= save cursor-location) (let ((new-pos (+ save (- (point-max) old-max)))) @@ -1986,9 +2053,9 @@ The word checked is the word at the mouse position." (t new-pos)))) (goto-char save))) -;*---------------------------------------------------------------------*/ -;* flyspell-emacs-popup ... */ -;*---------------------------------------------------------------------*/ +;;*---------------------------------------------------------------------*/ +;;* flyspell-emacs-popup ... */ +;;*---------------------------------------------------------------------*/ (defun flyspell-emacs-popup (event poss word) "The Emacs popup menu." (if (not event) @@ -2028,10 +2095,10 @@ The word checked is the word at the mouse position." ispell-dictionary)) menu))))) -;*---------------------------------------------------------------------*/ -;* flyspell-xemacs-popup ... */ -;*---------------------------------------------------------------------*/ -(defun flyspell-xemacs-popup (event poss word cursor-location start end save) +;;*---------------------------------------------------------------------*/ +;;* flyspell-xemacs-popup ... */ +;;*---------------------------------------------------------------------*/ +(defun flyspell-xemacs-popup (poss word cursor-location start end save) "The XEmacs popup menu." (let* ((corrects (if flyspell-sort-corrections (sort (car (cdr (cdr poss))) 'string<) @@ -2101,9 +2168,9 @@ The word checked is the word at the mouse position." ispell-dictionary)) menu)))) -;*---------------------------------------------------------------------*/ -;* Some example functions for real autocorrecting */ -;*---------------------------------------------------------------------*/ +;;*---------------------------------------------------------------------*/ +;;* Some example functions for real autocorrecting */ +;;*---------------------------------------------------------------------*/ (defun flyspell-maybe-correct-transposition (beg end poss) "Check replacements for transposed characters. @@ -2160,16 +2227,16 @@ This function is meant to be added to `flyspell-incorrect-hook'." (setq i (1+ i)))) nil))) -;*---------------------------------------------------------------------*/ -;* flyspell-already-abbrevp ... */ -;*---------------------------------------------------------------------*/ +;;*---------------------------------------------------------------------*/ +;;* flyspell-already-abbrevp ... */ +;;*---------------------------------------------------------------------*/ (defun flyspell-already-abbrevp (table word) (let ((sym (abbrev-symbol word table))) (and sym (symbolp sym)))) -;*---------------------------------------------------------------------*/ -;* flyspell-change-abbrev ... */ -;*---------------------------------------------------------------------*/ +;;*---------------------------------------------------------------------*/ +;;* flyspell-change-abbrev ... */ +;;*---------------------------------------------------------------------*/ (defun flyspell-change-abbrev (table old new) (set (abbrev-symbol old table) new)) diff --git a/lisp/textmodes/ispell.el b/lisp/textmodes/ispell.el index deeb09543ac..c84d7b9bb12 100644 --- a/lisp/textmodes/ispell.el +++ b/lisp/textmodes/ispell.el @@ -1,7 +1,7 @@ ;;; ispell.el --- interface to International Ispell Versions 3.1 and 3.2 ;; Copyright (C) 1994, 1995, 1997, 1998, 1999, 2000, 2001, 2002, 2003, -;; 2004, 2005 Free Software Foundation, Inc. +;; 2004, 2005, 2006 Free Software Foundation, Inc. ;; Author: Ken Stevens <k.stevens@ieee.org> ;; Maintainer: Ken Stevens <k.stevens@ieee.org> @@ -445,7 +445,7 @@ where DICTNAME is the name of your default dictionary." (defvar ispell-local-dictionary-overridden nil "Non-nil means the user has explicitly set this buffer's Ispell dictionary.") -(make-variable-buffer-local 'ispell-local-dictionary) +(make-variable-buffer-local 'ispell-local-dictionary-overridden) (defcustom ispell-local-dictionary nil "If non-nil, the dictionary to be used for Ispell commands in this buffer. @@ -579,11 +579,11 @@ re-start emacs." ("francais" ; Francais.aff "[A-Za-z\300\302\306\307\310\311\312\313\316\317\324\331\333\334\340\342\347\350\351\352\353\356\357\364\371\373\374]" "[^A-Za-z\300\302\306\307\310\311\312\313\316\317\324\331\333\334\340\342\347\350\351\352\353\356\357\364\371\373\374]" - "[-']" t nil "~list" iso-8859-1) + "[-'.@]" t nil "~list" iso-8859-1) ("francais-tex" ; Francais.aff "[A-Za-z\300\302\306\307\310\311\312\313\316\317\324\331\333\334\340\342\347\350\351\352\353\356\357\364\371\373\374\\]" "[^A-Za-z\300\302\306\307\310\311\312\313\316\317\324\331\333\334\340\342\347\350\351\352\353\356\357\364\371\373\374\\]" - "[-'^`\"]" t nil "~tex" iso-8859-1))) + "[-'^`\".@]" t nil "~tex" iso-8859-1))) ;;; Fourth part of dictionary, shortened for loaddefs.el @@ -599,7 +599,7 @@ re-start emacs." ("italiano" ; Italian.aff "[A-Z\300\301\310\311\314\315\322\323\331\332a-z\340\341\350\351\354\355\363\371\372]" "[^A-Z\300\301\310\311\314\315\322\323\331\332a-z\340\341\350\351\354\355\363\371\372]" - "[-]" nil ("-B" "-d" "italian") "~tex" iso-8859-1) + "[-.]" nil ("-B" "-d" "italian") "~tex" iso-8859-1) ("nederlands" ; Nederlands.aff "[A-Za-z\300\301\302\303\304\305\307\310\311\312\313\314\315\316\317\322\323\324\325\326\331\332\333\334\340\341\342\343\344\345\347\350\351\352\353\354\355\356\357\361\362\363\364\365\366\371\372\373\374]" "[^A-Za-z\300\301\302\303\304\305\307\310\311\312\313\314\315\316\317\322\323\324\325\326\331\332\333\334\340\341\342\343\344\345\347\350\351\352\353\354\355\356\357\361\362\363\364\365\366\371\372\373\374]" @@ -624,7 +624,7 @@ re-start emacs." ("polish" ; Polish mode "[A-Za-z\241\243\246\254\257\261\263\266\274\277\306\312\321\323\346\352\361\363]" "[^A-Za-z\241\243\246\254\257\261\263\266\274\277\306\312\321\323\346\352\361\363]" - "" nil nil nil iso-8859-2) + "." nil nil nil iso-8859-2) ("portugues" ; Portuguese mode "[a-zA-Z\301\302\311\323\340\341\342\351\352\355\363\343\372]" "[^a-zA-Z\301\302\311\323\340\341\342\351\352\355\363\343\372]" @@ -721,7 +721,7 @@ LANGUAGE.aff file \(e.g., english.aff\).") (defvar ispell-aspell-supports-utf8 nil "Non-nil means to try to automatically find aspell dictionaries. -This is set to t in ispell-check-version for aspell >= 0.60. +This is set to t in `ispell-check-version' for aspell >= 0.60. Earlier aspell versions do not consistently support UTF-8. Handling this would require some extra guessing in `ispell-aspell-find-dictionary'.") @@ -894,13 +894,22 @@ and added as a submenu of the \"Edit\" menu.") "Find Aspell's dictionaries, and record in `ispell-dictionary-alist'." (unless ispell-really-aspell (error "This function only works with aspell")) - (let ((dictionaries - (split-string - (with-temp-buffer - (call-process ispell-program-name nil t nil "dicts") - (buffer-string))))) - (setq ispell-dictionary-alist - (mapcar #'ispell-aspell-find-dictionary dictionaries)) + (let* ((dictionaries + (split-string + (with-temp-buffer + (call-process ispell-program-name nil t nil "dicts") + (buffer-string)))) + ;; Search for the named dictionaries. + (found + (delq nil + (mapcar #'ispell-aspell-find-dictionary dictionaries)))) + ;; Merge into FOUND any elements from the standard ispell-dictionary-alist + ;; which have no element in FOUND at all. + (dolist (dict ispell-dictionary-alist) + (unless (assoc (car dict) found) + (setq found (nconc found (list dict))))) + (setq ispell-dictionary-alist found) + (ispell-aspell-add-aliases) ;; Add a default entry (let* ((english-dict (assoc "en" ispell-dictionary-alist)) @@ -922,6 +931,9 @@ Assumes that value contains no whitespace." (car (split-string (buffer-string))))) (defun ispell-aspell-find-dictionary (dict-name) + ;; This returns nil if the data file does not exist. + ;; Can someone please explain the return value format when the + ;; file does exist -- rms? (let* ((lang ;; Strip out region, variant, etc. (and (string-match "^[[:alpha:]]+" dict-name) (match-string 0 dict-name))) @@ -931,35 +943,37 @@ Assumes that value contains no whitespace." (ispell-get-aspell-config-value "data-dir"))) "/" lang ".dat")) otherchars) - ;; This file really should exist; there is no sensible recovery. - (with-temp-buffer - (insert-file-contents data-file) - ;; There is zero or one line with special characters declarations. - (when (search-forward-regexp "^special" nil t) - (let ((specials (split-string - (buffer-substring (point) - (progn (end-of-line) (point)))))) - ;; The line looks like: special ' -** - -** . -** : -*- - ;; -** means that this character - ;; - doesn't appear at word start - ;; * may appear in the middle of a word - ;; * may appear at word end - ;; `otherchars' is about the middle case. - (while specials - (when (eq (aref (cadr specials) 1) ?*) - (push (car specials) otherchars)) - (setq specials (cddr specials)))))) - (list dict-name - "[[:alpha:]]" - "[^[:alpha:]]" - (regexp-opt otherchars) - t ; We can't tell, so set this to t - (list "-d" dict-name "--encoding=utf-8") - nil ; aspell doesn't support this - ;; Here we specify the encoding to use while communicating with - ;; aspell. This doesn't apply to command line arguments, so - ;; just don't pass words to spellcheck as arguments... - 'utf-8))) + (condition-case () + (with-temp-buffer + (insert-file-contents data-file) + ;; There is zero or one line with special characters declarations. + (when (search-forward-regexp "^special" nil t) + (let ((specials (split-string + (buffer-substring (point) + (progn (end-of-line) (point)))))) + ;; The line looks like: special ' -** - -** . -** : -*- + ;; -** means that this character + ;; - doesn't appear at word start + ;; * may appear in the middle of a word + ;; * may appear at word end + ;; `otherchars' is about the middle case. + (while specials + (when (eq (aref (cadr specials) 1) ?*) + (push (car specials) otherchars)) + (setq specials (cddr specials))))) + (list dict-name + "[[:alpha:]]" + "[^[:alpha:]]" + (regexp-opt otherchars) + t ; We can't tell, so set this to t + (list "-d" dict-name "--encoding=utf-8") + nil ; aspell doesn't support this + ;; Here we specify the encoding to use while communicating with + ;; aspell. This doesn't apply to command line arguments, so + ;; just don't pass words to spellcheck as arguments... + 'utf-8)) + (file-error + nil)))) (defun ispell-aspell-add-aliases () "Find aspell's dictionary aliases and add them to `ispell-dictionary-alist'." @@ -1147,6 +1161,10 @@ The variable `ispell-library-directory' defines the library location." This is passed to the ispell process using the `-d' switch and is used as key in `ispell-local-dictionary-alist' and `ispell-dictionary-alist'.") +(defvar ispell-current-personal-dictionary nil + "The name of the current personal dictionary, or nil for the default. +This is passed to the ispell process using the `-p' switch.") + (defvar ispell-dictionary nil "Default dictionary to use if `ispell-local-dictionary' is nil.") @@ -1295,7 +1313,7 @@ Valid forms include: (KEY . REGEXP) - skip to the end of REGEXP. REGEXP may be string or symbol. (KEY REGEXP) - skip to end of REGEXP. REGEXP must be a string. (KEY FUNCTION ARGS) - FUNCTION called with ARGS returns end of region.") - +(put 'ispell-skip-region-alist 'risky-local-variable t) ;;;###autoload @@ -1325,6 +1343,7 @@ Second list has key placed inside \\begin{}. Delete or add any regions you want to be automatically selected for skipping in latex mode.") +(put 'ispell-tex-skip-alist 'risky-local-variable t) ;;;###autoload @@ -1341,7 +1360,7 @@ for skipping in latex mode.") Same format as `ispell-skip-region-alist' Note - substrings of other matches must come last (e.g. \"<[tT][tT]/\" and \"<[^ \\t\\n>]\").") - +(put 'ispell-html-skip-alists 'risky-local-variable t) (defvar ispell-local-pdict ispell-personal-dictionary "A buffer local variable containing the current personal dictionary. @@ -1754,8 +1773,7 @@ Global `ispell-quit' set to start location to continue spell session." (setq line (1+ line)))) (insert (car guess) " ") (setq guess (cdr guess))) - (insert "\nUse option `i' if this is a correct composition" - " from the derivative root.\n") + (insert "\nUse option `i' to accept this spelling and put it in your private dictionary.") (setq line (+ line (if choices 3 2))))) (while (and choices (< (if (> (+ 7 (current-column) (length (car choices)) @@ -2264,11 +2282,13 @@ otherwise it is displayed normally. The variable `ispell-highlight-face' selects the face to use for highlighting." (if highlight - (progn + (if ispell-overlay + (move-overlay ispell-overlay start end (current-buffer)) (setq ispell-overlay (make-overlay start end)) - (overlay-put ispell-overlay 'priority 1) ;higher than lazy overlays + (overlay-put ispell-overlay 'priority 1001) ;higher than lazy overlays (overlay-put ispell-overlay 'face ispell-highlight-face)) - (delete-overlay ispell-overlay)) + (if ispell-overlay + (delete-overlay ispell-overlay))) (if (and ispell-lazy-highlight (boundp 'lazy-highlight-cleanup)) (if highlight (let ((isearch-string @@ -2411,18 +2431,23 @@ Keeps argument list for future ispell invocations for no async support." ;; Local dictionary becomes the global dictionary in use. (setq ispell-current-dictionary (or ispell-local-dictionary ispell-dictionary)) + (setq ispell-current-personal-dictionary + (or ispell-local-pdict ispell-personal-dictionary)) (setq args (ispell-get-ispell-args)) (if (and ispell-current-dictionary ; use specified dictionary (not (member "-d" args))) ; only define if not overridden (setq args (append (list "-d" ispell-current-dictionary) args))) - (if ispell-personal-dictionary ; use specified pers dict + (if ispell-current-personal-dictionary ; use specified pers dict (setq args (append args (list "-p" - (expand-file-name ispell-personal-dictionary))))) + (expand-file-name ispell-current-personal-dictionary))))) (setq args (append args ispell-extra-args)) + ;; Initially we don't know any buffer's local words. + (setq ispell-buffer-local-name nil) + (if ispell-async-processp (let ((process-connection-type ispell-use-ptys-p)) (apply 'start-process @@ -2449,7 +2474,8 @@ Keeps argument list for future ispell invocations for no async support." (setq ispell-filter nil ispell-filter-continue nil) ;; may need to restart to select new personal dictionary. (ispell-kill-ispell t) - (message "Starting new Ispell process...") + (message "Starting new Ispell process [%s] ..." + (or ispell-local-dictionary ispell-dictionary "default")) (sit-for 0) (setq ispell-library-directory (ispell-check-version) ispell-process-directory default-directory @@ -2501,6 +2527,9 @@ Keeps argument list for future ispell invocations for no async support." "Kill current Ispell process (so that you may start a fresh one). With NO-ERROR, just return non-nil if there was no Ispell running." (interactive) + ;; This hook is typically used by flyspell to flush some variables used + ;; to optimize the common cases. + (run-hooks 'ispell-kill-ispell-hook) (if (not (and ispell-process (eq (ispell-process-status) 'run))) (or no-error @@ -2564,6 +2593,7 @@ By just answering RET you can find out what the current dictionary is." (setq ispell-local-dictionary dict) (setq ispell-local-dictionary-overridden t)) (error "Undefined dictionary: %s" dict)) + (ispell-internal-change-dictionary) (message "%s Ispell dictionary set to %s" (if arg "Global" "Local") dict)))) @@ -2574,9 +2604,8 @@ This may kill the Ispell process; if so, a new one will be started when needed." (let ((dict (or ispell-local-dictionary ispell-dictionary))) (unless (equal ispell-current-dictionary dict) - (setq ispell-current-dictionary dict) - (ispell-kill-ispell t)))) - + (ispell-kill-ispell t) + (setq ispell-current-dictionary dict)))) ;;; Spelling of comments are checked when ispell-check-comments is non-nil. @@ -2909,9 +2938,8 @@ Point is placed at end of skipped region." coding))))) ;;; Avoid error messages when compiling for these dynamic variables. -(eval-when-compile - (defvar start) - (defvar end)) +(defvar start) +(defvar end) (defun ispell-process-line (string shift) "Sends a LINE of text to ispell and processes the result. @@ -3633,22 +3661,22 @@ Both should not be used to define a buffer-local dictionary." (setq ispell-local-pdict (match-string-no-properties 1))))))) ;; Reload if new personal dictionary defined. - (if (and ispell-local-pdict - (not (equal ispell-local-pdict ispell-personal-dictionary))) - (progn - (ispell-kill-ispell t) - (setq ispell-personal-dictionary ispell-local-pdict))) + (if (not (equal ispell-current-personal-dictionary + (or ispell-local-pdict ispell-personal-dictionary))) + (ispell-kill-ispell t)) ;; Reload if new dictionary defined. (ispell-internal-change-dictionary)) (defun ispell-buffer-local-words () "Loads the buffer-local dictionary in the current buffer." + ;; If there's an existing ispell process that's wrong for this use, + ;; kill it. (if (and ispell-buffer-local-name (not (equal ispell-buffer-local-name (buffer-name)))) - (progn - (ispell-kill-ispell t) - (setq ispell-buffer-local-name nil))) + (ispell-kill-ispell t)) + ;; Actually start a new ispell process, because we need + ;; to send commands now to specify the local words to it. (ispell-init-process) (save-excursion (goto-char (point-min)) diff --git a/lisp/textmodes/nroff-mode.el b/lisp/textmodes/nroff-mode.el index 05a740ee390..7fd2db1deb6 100644 --- a/lisp/textmodes/nroff-mode.el +++ b/lisp/textmodes/nroff-mode.el @@ -38,6 +38,7 @@ (defgroup nroff nil "Nroff mode." + :link '(custom-group-link :tag "Font Lock Faces group" font-lock-faces) :group 'wp :prefix "nroff-") diff --git a/lisp/textmodes/org.el b/lisp/textmodes/org.el index a84f2be28ae..92854893b25 100644 --- a/lisp/textmodes/org.el +++ b/lisp/textmodes/org.el @@ -1,11 +1,11 @@ -;;; org.el --- Outline-based notes management and organizer +;;; org.el --- Outline-based notes management and organize ;; Carstens outline-mode for keeping track of everything. -;; Copyright (c) 2004, 2005 Free Software Foundation +;; Copyright (c) 2004, 2005, 2006 Free Software Foundation ;; ;; Author: Carsten Dominik <dominik at science dot uva dot nl> -;; Keywords: outlines, hypermedia, calendar +;; Keywords: outlines, hypermedia, calendar, wp ;; Homepage: http://www.astro.uva.nl/~dominik/Tools/org/ -;; Version: 3.18 +;; Version: 4.03 ;; ;; This file is part of GNU Emacs. ;; @@ -76,134 +76,28 @@ ;; The documentation of Org-mode can be found in the TeXInfo file. The ;; distribution also contains a PDF version of it. At the homepage of ;; Org-mode, you can read the same text online as HTML. There is also an -;; excellent reference card made by Philip Rooke. +;; excellent reference card made by Philip Rooke. This card can be found +;; in the etc/ directory of Emacs 22. ;; -;; Changes: -;; ------- -;; Version 3.18 -;; - Export of calendar information in the standard iCalendar format. -;; - Some bug fixes. +;; Changes since version 4.00: +;; --------------------------- +;; Version 4.03 +;; - Table alignment fixed for use with wide characters. +;; - `C-c -' leaves cursor in current table line. +;; - The current TAG can be incorporated into the agenda prefix. +;; See option `org-agenda-prefix-format' for details. ;; -;; Version 3.17 -;; - HTML export specifies character set depending on coding-system. +;; Version 4.02 +;; - Minor bug fixes and improvements around tag searches. +;; - XEmacs compatibility fixes. ;; -;; Version 3.16 -;; - In tables, directly after the field motion commands like TAB and RET, -;; typing a character will blank the field. Can be turned off with -;; variable `org-table-auto-blank-field'. -;; - Inactive timestamps with `C-c !'. These do not trigger the agenda -;; and are not linked to the calendar. -;; - Additional key bindings to allow Org-mode to function on a tty emacs. -;; - `C-c C-h' prefix key replaced by `C-c C-x', and `C-c C-x C-h' replaced -;; by `C-c C-x b' (b=Browser). This was necessary to recover the -;; standard meaning of C-h after a prefix key (show prefix bindings). +;; Version 4.01 +;; - Tags can also be set remotely from agenda buffer. +;; - Boolean logic for tag searches. +;; - Additional agenda commands can be configured through the variable +;; `org-agenda-custom-commands'. +;; - Minor bug fixes. ;; -;; Version 3.15 -;; - QUOTE keyword at the beginning of an entry causes fixed-width export -;; of unmodified entry text. `C-c :' toggles this keyword. -;; - New face `org-special-keyword' which is used for COMMENT, QUOTE, -;; DEADLINE and SCHEDULED, and priority cookies. Default is only a weak -;; color, to reduce the amount of aggressive color in the buffer. -;; -;; Version 3.14 -;; - Formulas for individual fields in table. -;; - Automatic recalculation in calculating tables. -;; - Named fields and columns in tables. -;; - Fixed bug with calling `org-archive' several times in a row. -;; -;; Version 3.13 -;; - Efficiency improvements: Fewer table re-alignments needed. -;; - New special lines in tables, for defining names for individual cells. -;; -;; Version 3.12 -;; - Tables can store formulas (one per column) and compute fields. -;; Not quite like a full spreadsheet, but very powerful. -;; - table.el keybinding is now `C-c ~'. -;; - Numeric argument to org-cycle does `show-subtree' above on level ARG. -;; - Small changes to keys in agenda buffer. Affected keys: -;; [w] weekly view; [d] daily view; [D] toggle diary inclusion. -;; - Bug fixes. -;; -;; Version 3.11 -;; - Links inserted with C-c C-l are now by default enclosed in angle -;; brackets. See the new variable `org-link-format'. -;; - ">" terminates a link, this is a way to have several links in a line. -;; Both "<" and ">" are no longer allowed as characters in a link. -;; - Archiving of finished tasks. -;; - C-<up>/<down> bindings removed, to allow access to paragraph commands. -;; - Compatibility with CUA-mode (see variable `org-CUA-compatible'). -;; - Compatibility problems with viper-mode fixed. -;; - Improved html export of tables. -;; - Various clean-up changes. -;; -;; Version 3.10 -;; - Using `define-derived-mode' to derive `org-mode' from `outline-mode'. -;; -;; Version 3.09 -;; - Time-of-day specifications in agenda are extracted and placed -;; into the prefix. Timed entries can be placed into a time grid for -;; day. -;; -;; Version 3.08 -;; - "|" no longer allowed as part of a link, to allow links in tables. -;; - The prefix of items in the agenda buffer can be configured. -;; - Cleanup. -;; -;; Version 3.07 -;; - Some folding incinsistencies removed. -;; - BBDB links to company-only entries. -;; - Bug fixes and global cleanup. -;; -;; Version 3.06 -;; - M-S-RET inserts a new TODO heading. -;; - New startup option `content'. -;; - Better visual response when TODO items in agenda change status. -;; - Window positioning after visibility state changes optimized and made -;; configurable. See `org-cycle-hook' and `org-occur-hook'. -;; -;; Version 3.05 -;; - Agenda entries from the diary are linked to the diary file, so -;; adding and editing diary entries can be done directly from the agenda. -;; - Many calendar/diary commands available directly from agenda. -;; - Field copying in tables with S-RET does increment. -;; - C-c C-x C-v extracts the visible part of the buffer for printing. -;; - Moving subtrees up and down preserves the whitespace at the tree end. -;; -;; Version 3.04 -;; - Table editor optimized to need fewer realignments, and to keep -;; table shape when typing in fields. -;; - A new minor mode, orgtbl-mode, introduces the Org-mode table editor -;; into arbitrary major modes. -;; - Fixed bug with realignment in XEmacs. -;; - Startup options can be set with special #+STARTUP line. -;; - Heading following a match in org-occur can be suppressed. -;; -;; Version 3.03 -;; - Copyright transfer to the FSF. -;; - Effect of C-u and C-u C-u in org-timeline swapped. -;; - Timeline now always contains today, and `.' jumps to it. -;; - Table editor: -;; - cut and paste of rectangular regions in tables -;; - command to convert org-mode table to table.el table and back -;; - command to treat several cells like a paragraph and fill it -;; - command to convert a buffer region to a table -;; - import/export tables as tab-separated files (exchange with Excel) -;; - Agenda: -;; - Sorting mechanism for agenda items rewritten from scratch. -;; - Sorting fully configurable. -;; - Entries specifying a time are sorted together. -;; - Completion also covers option keywords after `#-'. -;; - Bug fixes. -;; -;; Version 3.01 -;; - New reference card, thanks to Philip Rooke for creating it. -;; - Single file agenda renamed to "Timeline". It no longer shows -;; warnings about upcoming deadlines/overdue scheduled items. -;; That functionality is now limited to the (multifile) agenda. -;; - When reading a date, the calendar can be manipulated with keys. -;; - Link support for RMAIL and Wanderlust (from planner.el, untested). -;; - Minor bug fixes and documentation improvements. - ;;; Code: (eval-when-compile (require 'cl) (require 'calendar)) @@ -217,7 +111,7 @@ ;;; Customization variables -(defvar org-version "3.18" +(defvar org-version "4.03" "The version number of the file org.el.") (defun org-version () (interactive) @@ -408,6 +302,11 @@ Changes become only effective after restarting Emacs." :group 'org-keywords :type 'string) +(defcustom org-closed-string "CLOSED:" + "String ued as the prefix for timestamps logging closing a TODO entry." + :group 'org-keywords + :type 'string) + (defcustom org-comment-string "COMMENT" "Entries starting with this keyword will never be exported. An entry can be toggled between COMMENT and normal with @@ -488,6 +387,7 @@ or contain a special line If the file does not specify a category, then file's base name is used instead.") +(make-variable-buffer-local 'org-category) (defgroup org-time nil "Options concerning time stamps and deadlines in Org-mode." @@ -520,6 +420,13 @@ moved to the new date." :group 'org-time :type 'boolean) +(defcustom org-log-done nil + "When set, insert a (non-active) time stamp when TODO entry is marked DONE. +When the state of an entry is changed from nothing to TODO, remove a previous +closing date." + :group 'org-time + :type 'boolean) + (defgroup org-agenda nil "Options concerning agenda display Org-mode." :tag "Org Agenda" @@ -527,11 +434,38 @@ moved to the new date." (defcustom org-agenda-files nil "A list of org files for agenda/diary display. -Entries are added to this list with \\[org-add-file] and removed with +Entries are added to this list with \\[org-agenda-file-to-front] and removed with \\[org-remove-file]. You can also use customize to edit the list." :group 'org-agenda :type '(repeat file)) +(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 of 3 items: + +key The key (a single char as a string) to be associated with the command. +type The command type, any of the following symbols: + todo Entries with a specific TODO keyword, in all agenda files. + tags Tags match in all agenda files. + todo-tree Sparse tree of specific TODO keyword in *current* file. + tags-tree Sparse tree with all tags matches in *current* file. + occur-tree Occur sparse tree for current file. +match What to search for: + - a single keyword for TODO keyword searches + - a tags match expression for tags searches + - a regular expression for occur searches" + :group 'org-agenda + :type '(repeat + (list (string :tag "Key") + (choice :tag "Type" + (const :tag "Tags search in all agenda files" tags) + (const :tag "TODO keyword search in all agenda files" todo) + (const :tag "Tags sparse tree in current buffer" tags-tree) + (const :tag "TODO keyword tree in current buffer" todo-tree) + (const :tag "Occur tree in current buffer" occur-tree)) + (string :tag "Match")))) + (defcustom org-select-timeline-window t "Non-nil means, after creating a timeline, move cursor into Timeline window. When nil, cursor will remain in the current window." @@ -637,6 +571,7 @@ This format works similar to a printf format, with the following meaning: %c the category of the item, \"Diary\" for entries from the diary, or as given by the CATEGORY keyword or derived from the file name. + %T the first tag of the item. %t the time-of-day specification if one applies to the entry, in the format HH:MM %s Scheduling/Deadline information, a short string @@ -761,6 +696,27 @@ agenda entries." :tag "Org Structure" :group 'org) +(defcustom org-cycle-include-plain-lists nil + "Non-nil means, include plain lists into visibility cycling. +This means that during cycling, plain list items will *temporarily* be +interpreted as outline headlines with a level given by 1000+i where i is the +indentation of the bullet. In all other operations, plain list items are +not seen as headlines. For example, you cannot assign a TODO keyword to +such an item." + :group 'org-structure + :type 'boolean) + +(defcustom org-cycle-emulate-tab t + "Where should `org-cycle' emulate TAB. +nil Never +white Only in completely white lines +t Everywhere except in headlines" + :group 'org-structure + :type '(choice (const :tag "Never" nil) + (const :tag "Only in completely white lines" white) + (const :tag "Everywhere except in headlines" t) + )) + (defcustom org-cycle-hook '(org-optimize-window-after-visibility-change) "Hook that is run after `org-cycle' has changed the buffer visibility. The function(s) in this hook must accept a single argument which indicates @@ -771,6 +727,29 @@ the values `folded', `children', or `subtree'." :group 'org-structure :type 'hook) +(defcustom org-highlight-sparse-tree-matches t + "Non-nil means, highlight all matches that define a sparse tree. +The highlights will automatically disappear the next time the buffer is +changed by an edit command." + :group 'org-structure + :type 'boolean) + +(defcustom org-show-hierarchy-above t + "Non-nil means, show full hierarchy when showing a spot in the tree. +Turning this off makes sparse trees more compact, but also less clear." + :group 'org-structure + :type 'boolean) + +(defcustom org-show-following-heading t + "Non-nil means, show heading following match in `org-occur'. +When doing an `org-occur' it is useful to show the headline which +follows the match, even if they do not match the regexp. This makes it +easier to edit directly inside the sparse tree. However, if you use +org-occur mainly as an overview, the following headlines are +unnecessary clutter." + :group 'org-structure + :type 'boolean) + (defcustom org-occur-hook '(org-first-headline-recenter) "Hook that is run after `org-occur' has constructed a sparse tree. This can be used to recenter the window to show as much of the structure @@ -781,7 +760,7 @@ as possible." (defcustom org-level-color-stars-only nil "Non-nil means fontify only the stars in each headline. When nil, the entire headline is fontified. -After changing this, requires restart of Emacs to become effective." +After changin this, requires restart of Emacs to become effective." :group 'org-structure :type 'boolean) @@ -794,6 +773,25 @@ body starts at column 0, indentation is not changed at all." :group 'org-structure :type 'boolean) +(defcustom org-plain-list-ordered-item-terminator t + "The character that makes a line with leading number an ordered list item. +Valid values are ?. and ?\). To get both terminators, use t. While +?. may look nicer, it creates the danger that a line with leading +number may be incorrectly interpreted as an item. ?\) therefore is +the safe choice." + :group 'org-structure + :type '(choice (const :tag "dot like in \"2.\"" ?.) + (const :tag "paren like in \"2)\"" ?\)) + (const :tab "both" t))) + +(defcustom org-auto-renumber-ordered-lists t + "Non-nil means, automatically renumber ordered plain lists. +Renumbering happens when the sequence have been changed with +\\[org-shiftmetaup] or \\[org-shiftmetadown]. After other editing commands, +use \\[org-ctrl-c-ctrl-c] to trigger renumbering." + :group 'org-structure + :type 'boolean) + (defcustom org-enable-fixed-width-editor t "Non-nil means, lines starting with \":\" are treated as fixed-width. This currently only means, they are never auto-wrapped. @@ -802,27 +800,6 @@ See also the QUOTE keyword." :group 'org-structure :type 'boolean) -(defcustom org-cycle-emulate-tab t - "Where should `org-cycle' emulate TAB. -nil Never -white Only in completely white lines -t Everywhere except in headlines" - :group 'org-structure - :type '(choice (const :tag "Never" nil) - (const :tag "Only in completely white lines" white) - (const :tag "Everywhere except in headlines" t) - )) - -(defcustom org-show-following-heading t - "Non-nil means, show heading following match in `org-occur'. -When doing an `org-occur' it is useful to show the headline which -follows the match, even if they do not match the regexp. This makes it -easier to edit directly inside the sparse tree. However, if you use -org-occur mainly as an overview, the following headlines are -unnecessary clutter." - :group 'org-structure - :type 'boolean) - (defcustom org-archive-location "%s_archive::" "The location where subtrees should be archived. This string consists of two parts, separated by a double-colon. @@ -872,11 +849,72 @@ first line, so it is probably best to use this in combinations with :group 'org-structure :type 'boolean) +(defgroup org-tags nil + "Options concerning startup of Org-mode." + :tag "Org Tags" + :group 'org) + +(defcustom org-tags-column 48 + "The column to which tags should be indented in a headline. +If this number is positive, it specified the column. If it is negative, +it means that the tags should be flushright to that column. For example, +-79 works well for a normal 80 character screen." + :group 'org-tags + :type 'integer) + +(defcustom org-auto-align-tags t + "Non-nil means, realign tags after pro/demotion of TODO state change. +These operations change the length of a headline and therefore shift +the tags around. With this options turned on, after each such operation +the tags are again aligned to `org-tags-column'." + :group 'org-tags + :type 'boolean) + +(defcustom org-use-tag-inheritance t + "Non-nil means, tags in levels apply also for sublevels. +When nil, only the tags directly give in a specific line apply there. +If you turn off this option, you very likely want to turn on the +companion option `org-tags-match-list-sublevels'." + :group 'org-tags + :type 'boolean) + +(defcustom org-tags-match-list-sublevels nil + "Non-nil means list also sublevels of headlines matching tag search. +Because of tag inheritance (see variable `org-use-tag-inheritance'), +the sublevels of a headline matching a tag search often also match +the same search. Listing all of them can create very long lists. +Setting this variable to nil causes subtrees to be skipped. +This option is off by default, because inheritance in on. If you turn +inheritance off, you very likely want to turn this option on. + +As a special case, if the tag search is restricted to TODO items, the +value of this variable is ignored and sublevels are always checked, to +make sure all corresponding TODO items find their way into the list." + :group 'org-tags + :type 'boolean) + +(defvar org-tags-history nil + "History of minibuffer reads for tags.") +(defvar org-last-tags-completion-table nil + "The last used completion table for tags.") + (defgroup org-link nil "Options concerning links in Org-mode." :tag "Org Link" :group 'org) +(defcustom org-tab-follows-link nil + "Non-nil means, on links TAB will follow the link. +Needs to be set before org.el is loaded." + :group 'org-link + :type 'boolean) + +(defcustom org-return-follows-link nil + "Non-nil means, on links RET will follow the link. +Needs to be set before org.el is loaded." + :group 'org-link + :type 'boolean) + (defcustom org-link-format "<%s>" "Default format for linkes in the buffer. This is a format string for printf, %s will be replaced by the link text. @@ -899,10 +937,11 @@ Changing this varable requires a re-launch of Emacs of become effective." :group 'org-link :type 'boolean) -(defcustom org-line-numbers-in-file-links t - "Non-nil means, file links from `org-store-link' contain line numbers. -The line number will be added to the file name with :NNN and interpreted -by the command `org-open-at-point'. +(defcustom org-context-in-file-links t + "Non-nil means, file links from `org-store-link' contain context. +The line number will be added to the file name with :: as separator and +used to find the context when the link is activated by the command +`org-open-at-point'. Using a prefix arg to the command \\[org-store-link] (`org-store-link') negates this setting for the duration of the command." :group 'org-link @@ -980,29 +1019,7 @@ The default is true, to keep new users from shooting into their own foot." :type 'boolean) (defconst org-file-apps-defaults-gnu - '((t . emacs) - ("jpg" . "xv %s") - ("gif" . "xv %s") - ("ppm" . "xv %s") - ("pgm" . "xv %s") - ("pbm" . "xv %s") - ("tif" . "xv %s") - ("png" . "xv %s") - ("ps" . "gv %s") - ("ps.gz" . "gv %s") - ("eps" . "gv %s") - ("eps.gz" . "gv %s") - ("dvi" . "xdvi %s") - ("mpeg" . "plaympeg %s") - ("mp3" . "plaympeg %s") - ("fig" . "xfig %s") - ("pdf" . "acroread %s") - ("doc" . "soffice %s") - ("ppt" . "soffice %s") - ("pps" . "soffice %s") - ("html" . "netscape -remote openURL(%s,new-window)") - ("htm" . "netscape -remote openURL(%s,new-window)") - ("xs" . "soffice %s")) + '((t . mailcap)) "Default file applications on a UNIX/LINUX system. See `org-file-apps'.") @@ -1125,6 +1142,17 @@ See also the variable `org-table-auto-blank-field'." (const :tag "on" t) (const :tag "on, optimized" optimized))) +;; FIXME: We could have a third option which makes it jump only over the first +;; hline in a table. +(defcustom org-table-tab-jumps-over-hlines t + "Non-nil means, tab in the last column of a table with jump over a hline. +If a horizontal separator line is following the current line, +`org-table-next-field' can either create a new row before that line, or jump +over the line. When this option is nil, a new line will be created before +this line." + :group 'org-table + :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 @@ -1310,7 +1338,52 @@ or use the +OPTION lines for a per-file setting." (defcustom org-export-default-language "en" "The default language of HTML export, as a string. -This should have an association in `org-export-language-setup'" +This should have an association in `org-export-language-setup'." + :group 'org-export + :type 'string) + +(defcustom org-export-html-style +"<style type=\"text/css\"> + html { + font-family: Times, serif; + font-size: 12pt; + } + .title { text-align: center; } + .todo, .deadline { color: red; } + .done { color: green; } + pre { + border: 1pt solid #AEBDCC; + background-color: #F3F5F7; + padding: 5pt; + font-family: courier, monospace; + } + table { border-collapse: collapse; } + td, th { + vertical-align: top; + border: 1pt solid #ADB9CC; + } +</style>" + "The default style specification for exported HTML files. +Since there are different ways of setting style information, this variable +needs to contain the full HTML structure to provide a style, including the +surrounding HTML tags. The style specifications should include definiitons +for new classes todo, done, title, and deadline. For example, legal values +would be. + + <style type=\"text/css\"> + p {font-weight: normal; color: gray; } + h1 {color: black; } + .title { text-align: center; } + .todo, .deadline { color: red; } + .done { color: green; } + </style> + +or, if you want to keep the style in a file, + + <link rel=\"stylesheet\" type=\"text/css\" href=\"mystyles.css\"> + +As the value of this option simply gets inserted into the HTML <head> header, +you can \"misuse\" it to add arbitrary text to the header." :group 'org-export :type 'string) @@ -1344,6 +1417,28 @@ This option can also be set with the +OPTIONS line, e.g. \"toc:nil\"." :group 'org-export :type 'boolean) +(defcustom org-export-plain-list-max-depth 20 + "Maximum depth of hand-formatted lists in HTML export. + +Org-mode parses hand-formatted enumeration and bullet lists and +transforms them to HTML open export. Different indentation of the +bullet or number indicates different list nesting levels. To avoid +confusion, only a single level is allowed by default. When this is +larger than 1, deeper indentation leads to deeper list nesting. For +example, the default value of 3 allows the following list to be +formatted correctly in HTML: + + * Fruit + - Apple + - Banana + 1. from Africa + 2. from South America + - Pineapple + * Bread + * Dairy products" + :group 'org-export + :type 'integer) + (defcustom org-export-preserve-breaks nil "Non-nil means, preserve all line breaks when exporting. Normally, in HTML output paragraphs will be reformatted. In ASCII @@ -1505,7 +1600,6 @@ This file is created with the command \\[org-export-icalendar-all-agenda-files]. :group 'org-export :type 'boolean) -;; FIXME: not yet used. (defcustom org-icalendar-combined-name "OrgMode" "Calendar name for the combined iCalendar representing all agenda files." :group 'org-export @@ -1837,6 +1931,7 @@ This variable is set by `org-before-change-function'. `org-table-align' sets it back to nil.") (defvar org-mode-hook nil) (defvar org-inhibit-startup nil) ; Dynamically-scoped param. +(defvar org-agenda-keep-modes nil) ; Dynamically-scoped param. ;;;###autoload @@ -1862,6 +1957,8 @@ The following commands are available: (easy-menu-add org-tbl-menu) (org-install-agenda-files-menu) (setq outline-regexp "\\*+") +; (setq outline-regexp "\\(?:\\*+\\|[ \t]*\\(?:[-+*]\\|[0-9]+[.)]\\) \\)") + (setq outline-level 'org-outline-level) (if org-startup-truncated (setq truncate-lines t)) (org-set-regexps-and-options) (set (make-local-variable 'font-lock-unfontify-region-function) @@ -1871,19 +1968,14 @@ The following commands are available: (make-local-hook 'before-change-functions) ;; needed for XEmacs (add-hook 'before-change-functions 'org-before-change-function nil 'local) - ;; Paragraph regular expressions - (set (make-local-variable 'paragraph-separate) "\f\\|[ ]*$\\|\\([*\f]+\\)") - (set (make-local-variable 'paragraph-start) "\f\\|[ ]*$\\|\\([*\f]+\\)") - ;; Inhibit auto-fill for headers, tables and fixed-width lines. - (set (make-local-variable 'auto-fill-inhibit-regexp) - (concat "\\*\\|#" - (if (or org-enable-table-editor org-enable-fixed-width-editor) - (concat - "\\|[ \t]*[" - (if org-enable-table-editor "|" "") - (if org-enable-fixed-width-editor ":" "") - "]")))) - (set (make-local-variable 'fill-paragraph-function) 'org-fill-paragraph) + ;; FIXME: The following does not work because isearch-mode-end-hook + ;; is called *before* the visibility overlays as removed. + ;; There should be another hook then for me to be used. +;; (make-local-hook 'isearch-mode-end-hook) ;; needed for XEmacs +;; (add-hook 'isearch-mode-end-hook 'org-show-hierarchy-above nil +;; 'local) + ;; Paragraphs and auto-filling + (org-set-autofill-regexps) ;; Settings for Calc embedded mode (set (make-local-variable 'calc-embedded-open-formula) "|\\|\n") (set (make-local-variable 'calc-embedded-close-formula) "|\\|\n") @@ -1915,15 +2007,16 @@ The following commands are available: (let ((this-command 'org-cycle) (last-command 'org-cycle)) (org-cycle '(4)) (org-cycle '(4)))))))) -(defun org-fill-paragraph (&optional justify) - "Re-align a table, pass through to fill-paragraph if no table." - (save-excursion - (beginning-of-line 1) - (looking-at "\\s-*\\(|\\|\\+-+\\)"))) - (defsubst org-current-line (&optional pos) (+ (if (bolp) 1 0) (count-lines (point-min) (or pos (point))))) + +;; FIXME: Do we need to copy? +(defun org-string-props (string &rest properties) + "Add PROPERTIES to string." + (add-text-properties 0 (length string) properties string) + string) + ;;; Font-Lock stuff (defvar org-mouse-map (make-sparse-keymap)) @@ -1931,6 +2024,12 @@ The following commands are available: (if org-xemacs-p [button2] [mouse-2]) 'org-open-at-mouse) (define-key org-mouse-map (if org-xemacs-p [button3] [mouse-3]) 'org-find-file-at-mouse) +(when org-tab-follows-link + (define-key org-mouse-map [(tab)] 'org-open-at-point) + (define-key org-mouse-map "\C-i" 'org-open-at-point)) +(when org-return-follows-link + (define-key org-mouse-map [(return)] 'org-open-at-point) + (define-key org-mouse-map "\C-m" 'org-open-at-point)) (require 'font-lock) @@ -1954,7 +2053,9 @@ The following commands are available: (cons (length (format-time-string (car org-time-stamp-formats))) (length (format-time-string (cdr org-time-stamp-formats)))) "This holds the lengths of the two different time formats.") -(defconst org-ts-regexp "<\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\}[^\r\n>]*\\)>" +(defconst org-ts-regexp "<\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\}[^\r\n>]*?\\)>" + "Regular expression for fast time stamp matching.") +(defconst org-ts-regexp-both "[[<]\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\}[^\r\n>]*?\\)[]>]" "Regular expression for fast time stamp matching.") (defconst org-ts-regexp1 "\\(\\([0-9]\\{4\\}\\)-\\([0-9]\\{2\\}\\)-\\([0-9]\\{2\\}\\)\\([^0-9>\r\n]*\\)\\(\\([0-9]\\{2\\}\\):\\([0-9]\\{2\\}\\)\\)?\\)" "Regular expression matching time strings for analysis.") @@ -1984,25 +2085,52 @@ The following commands are available: 'keymap org-mouse-map)) t))) +(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 + 'keymap org-mouse-map)) + t))) + +(defun org-activate-tags (limit) + (if (re-search-forward "[ \t]\\(:[A-Za-z_:]+:\\)[ \r\n]" limit t) + (progn + (add-text-properties (match-beginning 1) (match-end 1) + (list 'mouse-face 'highlight + 'keymap org-mouse-map)) + t))) + (defun org-font-lock-level () (save-excursion (org-back-to-heading t) (- (match-end 0) (match-beginning 0)))) +(defun org-outline-level () + (save-excursion + (looking-at outline-regexp) + (if (match-beginning 1) + (+ (org-get-string-indentation (match-string 1)) 1000) + (- (match-end 0) (match-beginning 0))))) + (defvar org-font-lock-keywords nil) (defun org-set-font-lock-defaults () (let ((org-font-lock-extra-keywords (list - '(org-activate-links (0 'org-link)) - '(org-activate-dates (0 'org-link)) + '(org-activate-links (0 'org-link t)) + '(org-activate-dates (0 'org-link t)) + '(org-activate-camels (0 'org-link t)) + '(org-activate-tags (1 'org-link t)) (list (concat "^\\*+[ \t]*" org-not-done-regexp) '(1 'org-warning t)) (list (concat "\\[#[A-Z]\\]") '(0 'org-special-keyword t)) -; (list (concat "\\<" org-deadline-string) '(0 'org-warning t)) -; (list (concat "\\<" org-scheduled-string) '(0 'org-warning 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)) ;; '("\\(\\s-\\|^\\)\\(\\*\\([a-zA-Z]+\\)\\*\\)\\([^a-zA-Z*]\\|$\\)" ;; (3 'bold)) ;; '("\\(\\s-\\|^\\)\\(/\\([a-zA-Z]+\\)/\\)\\([^a-zA-Z*]\\|$\\)" @@ -2032,7 +2160,7 @@ The following commands are available: ; on XEmacs if noutline is ever ported `((eval . (list "^\\(\\*+\\).*" ,(if org-level-color-stars-only 1 0) - '(nth ;; FIXME: 1<->0 ???? + '(nth (% (- (match-end 1) (match-beginning 1) 1) org-n-levels) org-level-faces) @@ -2095,120 +2223,125 @@ The following commands are available: ;; special case: use global cycling (setq arg t)) - (cond + (let ((outline-regexp + (if org-cycle-include-plain-lists + "\\*+\\|\\([ \t]*\\)\\([-+*]\\|[0-9]+[.)]\\) " + outline-regexp))) - ((org-at-table-p 'any) - ;; Enter the table or move to the next field in the table - (or (org-table-recognize-table.el) - (progn - (org-table-justify-field-maybe) - (org-table-next-field)))) + (cond - ((eq arg t) ;; Global cycling + ((org-at-table-p 'any) + ;; Enter the table or move to the next field in the table + (or (org-table-recognize-table.el) + (progn + (org-table-justify-field-maybe) + (org-table-next-field)))) - (cond - ((and (eq last-command this-command) - (eq org-cycle-global-status 'overview)) - ;; We just created the overview - now do table of contents - ;; This can be slow in very large buffers, so indicate action - (message "CONTENTS...") - (save-excursion - ;; Visit all headings and show their offspring - (goto-char (point-max)) - (catch 'exit - (while (and (progn (condition-case nil - (outline-previous-visible-heading 1) - (error (goto-char (point-min)))) - t) - (looking-at outline-regexp)) - (show-branches) - (if (bobp) (throw 'exit nil)))) - (message "CONTENTS...done")) - (setq org-cycle-global-status 'contents) - (run-hook-with-args 'org-cycle-hook 'contents)) - - ((and (eq last-command this-command) - (eq org-cycle-global-status 'contents)) - ;; We just showed the table of contents - now show everything - (show-all) - (message "SHOW ALL") - (setq org-cycle-global-status 'all) - (run-hook-with-args 'org-cycle-hook 'all)) + ((eq arg t) ;; Global cycling - (t - ;; Default action: go to overview - (hide-sublevels 1) - (message "OVERVIEW") - (setq org-cycle-global-status 'overview) - (run-hook-with-args 'org-cycle-hook 'overview)))) + (cond + ((and (eq last-command this-command) + (eq org-cycle-global-status 'overview)) + ;; We just created the overview - now do table of contents + ;; This can be slow in very large buffers, so indicate action + (message "CONTENTS...") + (save-excursion + ;; Visit all headings and show their offspring + (goto-char (point-max)) + (catch 'exit + (while (and (progn (condition-case nil + (outline-previous-visible-heading 1) + (error (goto-char (point-min)))) + t) + (looking-at outline-regexp)) + (show-branches) + (if (bobp) (throw 'exit nil)))) + (message "CONTENTS...done")) + (setq org-cycle-global-status 'contents) + (run-hook-with-args 'org-cycle-hook 'contents)) - ((integerp arg) - ;; Show-subtree, ARG levels up from here. - (save-excursion - (org-back-to-heading) - (outline-up-heading (if (< arg 0) (- arg) - (- (outline-level) arg))) - (org-show-subtree))) + ((and (eq last-command this-command) + (eq org-cycle-global-status 'contents)) + ;; We just showed the table of contents - now show everything + (show-all) + (message "SHOW ALL") + (setq org-cycle-global-status 'all) + (run-hook-with-args 'org-cycle-hook 'all)) - ((save-excursion (beginning-of-line 1) (looking-at outline-regexp)) - ;; At a heading: rotate between three different views - (org-back-to-heading) - (let ((goal-column 0) eoh eol eos) - ;; First, some boundaries + (t + ;; Default action: go to overview + (hide-sublevels 1) + (message "OVERVIEW") + (setq org-cycle-global-status 'overview) + (run-hook-with-args 'org-cycle-hook 'overview)))) + + ((integerp arg) + ;; Show-subtree, ARG levels up from here. (save-excursion (org-back-to-heading) + (outline-up-heading (if (< arg 0) (- arg) + (- (outline-level) arg))) + (org-show-subtree))) + + ((save-excursion (beginning-of-line 1) (looking-at outline-regexp)) + ;; At a heading: rotate between three different views + (org-back-to-heading) + (let ((goal-column 0) eoh eol eos) + ;; First, some boundaries (save-excursion - (beginning-of-line 2) - (while (and (not (eobp)) ;; this is like `next-line' - (get-char-property (1- (point)) 'invisible)) - (beginning-of-line 2)) (setq eol (point))) - (outline-end-of-heading) (setq eoh (point)) - (outline-end-of-subtree) (setq eos (point)) - (outline-next-heading)) - ;; Find out what to do next and set `this-command' - (cond - ((= eos eoh) - ;; Nothing is hidden behind this heading - (message "EMPTY ENTRY") - (setq org-cycle-subtree-status nil)) - ((>= eol eos) - ;; Entire subtree is hidden in one line: open it - (org-show-entry) - (show-children) - (message "CHILDREN") - (setq org-cycle-subtree-status 'children) - (run-hook-with-args 'org-cycle-hook 'children)) - ((and (eq last-command this-command) - (eq org-cycle-subtree-status 'children)) - ;; We just showed the children, now show everything. - (org-show-subtree) - (message "SUBTREE") - (setq org-cycle-subtree-status 'subtree) - (run-hook-with-args 'org-cycle-hook 'subtree)) - (t - ;; Default action: hide the subtree. - (hide-subtree) - (message "FOLDED") - (setq org-cycle-subtree-status 'folded) - (run-hook-with-args 'org-cycle-hook 'folded))))) - - ;; TAB emulation - (buffer-read-only (org-back-to-heading)) - ((if (and (eq org-cycle-emulate-tab 'white) - (save-excursion (beginning-of-line 1) (looking-at "[ \t]+$"))) - t - (eq org-cycle-emulate-tab t)) - (if (and (looking-at "[ \n\r\t]") - (string-match "^[ \t]*$" (buffer-substring - (point-at-bol) (point)))) - (progn - (beginning-of-line 1) - (and (looking-at "[ \t]+") (replace-match "")))) - (indent-relative)) + (org-back-to-heading) + (save-excursion + (beginning-of-line 2) + (while (and (not (eobp)) ;; this is like `next-line' + (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)) + ;; Find out what to do next and set `this-command' + (cond + ((= eos eoh) + ;; Nothing is hidden behind this heading + (message "EMPTY ENTRY") + (setq org-cycle-subtree-status nil)) + ((>= eol eos) + ;; Entire subtree is hidden in one line: open it + (org-show-entry) + (show-children) + (message "CHILDREN") + (setq org-cycle-subtree-status 'children) + (run-hook-with-args 'org-cycle-hook 'children)) + ((and (eq last-command this-command) + (eq org-cycle-subtree-status 'children)) + ;; We just showed the children, now show everything. + (org-show-subtree) + (message "SUBTREE") + (setq org-cycle-subtree-status 'subtree) + (run-hook-with-args 'org-cycle-hook 'subtree)) + (t + ;; Default action: hide the subtree. + (hide-subtree) + (message "FOLDED") + (setq org-cycle-subtree-status 'folded) + (run-hook-with-args 'org-cycle-hook 'folded))))) + + ;; TAB emulation + (buffer-read-only (org-back-to-heading)) + ((if (and (eq org-cycle-emulate-tab 'white) + (save-excursion (beginning-of-line 1) (looking-at "[ \t]+$"))) + t + (eq org-cycle-emulate-tab t)) + (if (and (looking-at "[ \n\r\t]") + (string-match "^[ \t]*$" (buffer-substring + (point-at-bol) (point)))) + (progn + (beginning-of-line 1) + (and (looking-at "[ \t]+") (replace-match "")))) + (indent-relative)) - (t (save-excursion - (org-back-to-heading) - (org-cycle))))) + (t (save-excursion + (org-back-to-heading) + (org-cycle)))))) (defun org-optimize-window-after-visibility-change (state) "Adjust the window after a change in outline visibility. @@ -2224,7 +2357,7 @@ This function is the default value of the hook `org-cycle-hook'." (defun org-subtree-end-visible-p () "Is the end of the current subtree visible?" (pos-visible-in-window-p - (save-excursion (outline-end-of-subtree) (point)))) + (save-excursion (org-end-of-subtree t) (point)))) (defun org-first-headline-recenter (&optional N) "Move cursor to the first headline and recenter the headline. @@ -2367,22 +2500,39 @@ or nil." (defvar org-ignore-region nil "To temporarily disable the active region.") -(defun org-insert-heading () - "Insert a new heading with same depth at point." - (interactive) - (let* ((head (save-excursion - (condition-case nil - (org-back-to-heading) - (error (outline-next-heading))) - (prog1 (match-string 0) - (funcall outline-level))))) +(defun org-insert-heading (&optional force-heading) + "Insert a new heading or item with same depth at point. +If ARG is non-nil" + (interactive "P") + (when (or force-heading (not (org-insert-item))) + (let* ((head (save-excursion + (condition-case nil + (org-back-to-heading) + (error (outline-next-heading))) + (prog1 (match-string 0) + (funcall outline-level))))) + (unless (bolp) (newline)) + (insert head) + (unless (eolp) + (save-excursion (newline-and-indent))) + (unless (equal (char-before) ?\ ) + (insert " ")) + (run-hooks 'org-insert-heading-hook)))) + +(defun org-insert-item () + "Insert a new item at the current level. +Return t when tings worked, nil when we are not in an item." + (when (save-excursion + (condition-case nil + (progn + (org-beginning-of-item) + (org-at-item-p) + t) + (error nil))) (unless (bolp) (newline)) - (insert head) - (unless (eolp) - (save-excursion (newline-and-indent))) - (unless (equal (char-before) ?\ ) - (insert " ")) - (run-hooks 'org-insert-heading-hook))) + (insert (match-string 0)) + (org-maybe-renumber-ordered-list) + t)) (defun org-insert-todo-heading (arg) "Insert a new heading with the same level and TODO state as current heading. @@ -2451,6 +2601,8 @@ in the region." (up-head (make-string (1- level) ?*))) (if (= level 1) (error "Cannot promote to level 0. UNDO to recover")) (replace-match up-head nil t) + ;; Fixup tag positioning + (and org-auto-align-tags (org-set-tags nil t)) (if org-adapt-indentation (org-fixup-indentation "^ " "" "^ ?\\S-")))) @@ -2462,6 +2614,8 @@ in the region." (let* ((level (save-match-data (funcall outline-level))) (down-head (make-string (1+ level) ?*))) (replace-match down-head nil t) + ;; Fixup tag positioning + (and org-auto-align-tags (org-set-tags nil t)) (if org-adapt-indentation (org-fixup-indentation "^ " " " "^\\S-")))) @@ -2701,6 +2855,234 @@ If optional TXT is given, check this string instead of the current kill." (throw 'exit nil))) t)))) +;;; Plain list items + +(defun org-at-item-p () + "Is point in a line starting a hand-formatted item?" + (let ((llt org-plain-list-ordered-item-terminator)) + (save-excursion + (goto-char (point-at-bol)) + (looking-at + (cond + ((eq llt t) "\\([ \t]*\\([-+]\\|\\([0-9]+[.)]\\)\\)\\|[ \t]+\\*\\)\\( \\|$\\)") + ((= llt ?.) "\\([ \t]*\\([-+]\\|\\([0-9]+\\.\\)\\)\\|[ \t]+\\*\\)\\( \\|$\\)") + ((= llt ?\)) "\\([ \t]*\\([-+]\\|\\([0-9]+)\\)\\)\\|[ \t]+\\*\\)\\( \\|$\\)") + (t (error "Invalid value of `org-plain-list-ordered-item-terminator'"))))))) + +(defun org-get-indentation () + "Get the indentation of the current line, ionterpreting tabs." + (save-excursion + (beginning-of-line 1) + (skip-chars-forward " \t") + (current-column))) + +(defun org-beginning-of-item () + "Go to the beginning of the current hand-formatted item. +If the cursor is not in an item, throw an error." + (let ((pos (point)) + (limit (save-excursion (org-back-to-heading) + (beginning-of-line 2) (point))) + ind ind1) + (if (org-at-item-p) + (beginning-of-line 1) + (beginning-of-line 1) + (skip-chars-forward " \t") + (setq ind (current-column)) + (if (catch 'exit + (while t + (beginning-of-line 0) + (if (< (point) limit) (throw 'exit nil)) + (unless (looking-at " \t]*$") + (skip-chars-forward " \t") + (setq ind1 (current-column)) + (if (< ind1 ind) + (throw 'exit (org-at-item-p)))))) + nil + (goto-char pos) + (error "Not in an item"))))) + +(defun org-end-of-item () + "Go to the beginning of the current hand-formatted item. +If the cursor is not in an item, throw an error." + (let ((pos (point)) + (limit (save-excursion (outline-next-heading) (point))) + (ind (save-excursion + (org-beginning-of-item) + (skip-chars-forward " \t") + (current-column))) + ind1) + (if (catch 'exit + (while t + (beginning-of-line 2) + (if (>= (point) limit) (throw 'exit t)) + (unless (looking-at "[ \t]*$") + (skip-chars-forward " \t") + (setq ind1 (current-column)) + (if (<= ind1 ind) (throw 'exit t))))) + (beginning-of-line 1) + (goto-char pos) + (error "Not in an item")))) + +(defun org-move-item-down (arg) + "Move the plain list item at point down, i.e. swap with following item. +Subitems (items with larger indentation are considered part of the item, +so this really moves item trees." + (interactive "p") + (let (beg end ind ind1 (pos (point)) txt) + (org-beginning-of-item) + (setq beg (point)) + (setq ind (org-get-indentation)) + (org-end-of-item) + (setq end (point)) + (setq ind1 (org-get-indentation)) + (if (and (org-at-item-p) (= ind ind1)) + (progn + (org-end-of-item) + (setq txt (buffer-substring beg end)) + (save-excursion + (delete-region beg end)) + (setq pos (point)) + (insert txt) + (goto-char pos) + (org-maybe-renumber-ordered-list)) + (goto-char pos) + (error "Cannot move this item further down")))) + +(defun org-move-item-up (arg) + "Move the plain list item at point up, i.e. swap with previous item. +Subitems (items with larger indentation are considered part of the item, +so this really moves item trees." + (interactive "p") + (let (beg end ind ind1 (pos (point)) txt) + (org-beginning-of-item) + (setq beg (point)) + (setq ind (org-get-indentation)) + (org-end-of-item) + (setq end (point)) + (goto-char beg) + (catch 'exit + (while t + (beginning-of-line 0) + (if (looking-at "[ \t]*$") + nil + (if (<= (setq ind1 (org-get-indentation)) ind) + (throw 'exit t))))) + (condition-case nil + (org-beginning-of-item) + (error (goto-char beg) + (error "Cannot move this item further up"))) + (setq ind1 (org-get-indentation)) + (if (and (org-at-item-p) (= ind ind1)) + (progn + (setq txt (buffer-substring beg end)) + (save-excursion + (delete-region beg end)) + (setq pos (point)) + (insert txt) + (goto-char pos) + (org-maybe-renumber-ordered-list)) + (goto-char pos) + (error "Cannot move this item further up")))) + +(defun org-maybe-renumber-ordered-list () + "Renumber the ordered list at point if setup allows it. +This tests the user option `org-auto-renumber-ordered-lists' before +doing the renumbering." + (and org-auto-renumber-ordered-lists + (org-at-item-p) + (match-beginning 3) + (org-renumber-ordered-list 1))) + +(defun org-get-string-indentation (s) + "What indentation has S due to SPACE and TAB at the beginning of the string?" + (let ((n -1) (i 0) (w tab-width) c) + (catch 'exit + (while (< (setq n (1+ n)) (length s)) + (setq c (aref s n)) + (cond ((= c ?\ ) (setq i (1+ i))) + ((= c ?\t) (setq i (* (/ (+ w i) w) w))) + (t (throw 'exit t))))) + i)) + +(defun org-renumber-ordered-list (arg) + "Renumber an ordered plain list. +Cursor neext to be in the first line of an item, the line that starts +with something like \"1.\" or \"2)\"." + (interactive "p") + (unless (and (org-at-item-p) + (match-beginning 3)) + (error "This is not an ordered list")) + (let ((line (org-current-line)) + (col (current-column)) + (ind (org-get-string-indentation + (buffer-substring (point-at-bol) (match-beginning 3)))) + ;; (term (substring (match-string 3) -1)) + ind1 (n (1- arg))) + ;; find where this list begins + (catch 'exit + (while t + (catch 'next + (beginning-of-line 0) + (if (looking-at "[ \t]*$") (throw 'next t)) + (skip-chars-forward " \t") (setq ind1 (current-column)) + (if (or (< ind1 ind) + (and (= ind1 ind) + (not (org-at-item-p)))) + (throw 'exit t))))) + ;; Walk forward and replace these numbers + (catch 'exit + (while t + (catch 'next + (beginning-of-line 2) + (if (eobp) (throw 'exit nil)) + (if (looking-at "[ \t]*$") (throw 'next nil)) + (skip-chars-forward " \t") (setq ind1 (current-column)) + (if (> ind1 ind) (throw 'next t)) + (if (< ind1 ind) (throw 'exit t)) + (if (not (org-at-item-p)) (throw 'exit nil)) + (if (not (match-beginning 3)) + (error "unordered bullet in ordered list. Press \\[undo] to recover")) + (delete-region (match-beginning 3) (1- (match-end 3))) + (goto-char (match-beginning 3)) + (insert (format "%d" (setq n (1+ n))))))) + (goto-line line) + (move-to-column col))) + +(defvar org-last-indent-begin-marker (make-marker)) +(defvar org-last-indent-end-marker (make-marker)) + + +(defun org-outdent-item (arg) + "Outdent a local list item." + (interactive "p") + (org-indent-item (- arg))) + +(defun org-indent-item (arg) + "Indent a local list item." + (interactive "p") + (unless (org-at-item-p) + (error "Not on an item")) + (let (beg end ind ind1) + (if (memq last-command '(org-shiftmetaright org-shiftmetaleft)) + (setq beg org-last-indent-begin-marker + end org-last-indent-end-marker) + (org-beginning-of-item) + (setq beg (move-marker org-last-indent-begin-marker (point))) + (org-end-of-item) + (setq end (move-marker org-last-indent-end-marker (point)))) + (goto-char beg) + (skip-chars-forward " \t") (setq ind (current-column)) + (if (< (+ arg ind) 0) (error "Cannot outdent beyond margin")) + (while (< (point) end) + (beginning-of-line 1) + (skip-chars-forward " \t") (setq ind1 (current-column)) + (delete-region (point-at-bol) (point)) + (indent-to-column (+ ind1 arg)) + (beginning-of-line 2)) + (goto-char beg))) + +;;; Archiving + (defun org-archive-subtree () "Move the current subtree to the archive. The archive can be a certain top-level heading in the current file, or in @@ -2814,17 +3196,23 @@ At all other locations, this simply calls `ispell-complete-word'." (interactive "P") (catch 'exit (let* ((end (point)) + (beg1 (save-excursion + (if (equal (char-before (point)) ?\ ) (backward-char 1)) + (skip-chars-backward "a-zA-Z_") + (point))) (beg (save-excursion (if (equal (char-before (point)) ?\ ) (backward-char 1)) (skip-chars-backward "a-zA-Z0-9_:$") (point))) + (camel (equal (char-before beg) ?*)) + (tag (equal (char-before beg1) ?:)) (texp (equal (char-before beg) ?\\)) (opt (equal (buffer-substring (max (point-at-bol) (- beg 2)) beg) "#+")) - (pattern (buffer-substring-no-properties beg end)) (completion-ignore-case opt) (type nil) + (tbl nil) (table (cond (opt (setq type :opt) @@ -2839,7 +3227,18 @@ At all other locations, this simply calls `ispell-complete-word'." (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 (org-make-org-heading-camel (match-string 3))) + tbl))) + tbl) + (tag (setq type :tag beg beg1) + (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))) (cond ((eq completion t) (if (equal type :opt) @@ -2855,9 +3254,9 @@ At all other locations, this simply calls `ispell-complete-word'." (insert completion) (if (get-buffer-window "*Completions*") (delete-window (get-buffer-window "*Completions*"))) - (if (and (eq type :todo) - (assoc completion table)) - (insert " ")) + (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")))) @@ -2865,7 +3264,7 @@ At all other locations, this simply calls `ispell-complete-word'." (message "Making completion list...") (let ((list (sort (all-completions pattern table) 'string<))) (with-output-to-temp-buffer "*Completions*" - (display-completion-list list pattern))) + (display-completion-list list))) (message "Making completion list...%s" "done")))))) ;;; Comments, TODO and DEADLINE @@ -2919,6 +3318,17 @@ prefix arg, switch to that state." (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)) @@ -2936,6 +3346,13 @@ prefix arg, switch to that 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-log-done) + (if (not this) + (org-log-done t)))) + ;; 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) @@ -2947,13 +3364,54 @@ prefix arg, switch to that state." (goto-char (or (match-end 2) (match-end 1))) (just-one-space)))) +(defun org-log-done (&optional undone) + "Add a time stamp logging that a TODO entry has been closed. +When UNDONE is non-nil, remove such a time stamg again." + (interactive) + (let (beg end col) + (save-excursion + (org-back-to-heading t) + (setq beg (point)) + (looking-at (concat outline-regexp " *")) + (goto-char (match-end 0)) + (setq col (current-column)) + (outline-next-heading) + (setq end (point)) + (goto-char beg) + (when (re-search-forward (concat + "[\r\n]\\([ \t]*" + (regexp-quote org-closed-string) + " *\\[.*?\\][^\n\r]*[\n\r]?\\)") end t) + (delete-region (match-beginning 1) (match-end 1))) + (unless undone + (org-back-to-heading t) + (skip-chars-forward "^\n\r") + (goto-char (min (1+ (point)) (point-max))) + (when (not (member (char-before) '(?\r ?\n))) + (insert "\n")) + (indent-to col) + (insert org-closed-string " " + (format-time-string + (concat "[" (substring (cdr org-time-stamp-formats) 1 -1) "]") + (current-time)) + "\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." +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 (if arg org-todo-regexp org-not-done-regexp))) + (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 ))))) @@ -2990,6 +3448,7 @@ to make sure editing the matching entry is easy. if CALLBACK is non-nil, it is a function which is called to confirm that the match should indeed be shown." (interactive "sRegexp: ") + (org-remove-occur-highlights nil nil t) (setq regexp (org-check-occur-regexp regexp)) (let ((cnt 0)) (save-excursion @@ -2997,9 +3456,13 @@ that the match should indeed be shown." (hide-sublevels 1) (while (re-search-forward regexp nil t) (when (or (not callback) - (funcall callback)) + (save-match-data (funcall callback))) (setq cnt (1+ cnt)) + (org-highlight-new-match (match-beginning 0) (match-end 0)) (org-show-hierarchy-above)))) + (make-local-hook 'before-change-functions) ; needed for XEmacs + (add-hook 'before-change-functions 'org-remove-occur-highlights + nil 'local) (run-hooks 'org-occur-hook) (if (interactive-p) (message "%d match(es) for regexp %s" cnt regexp)) @@ -3007,19 +3470,56 @@ that the match should indeed be shown." (defun org-show-hierarchy-above () "Make sure point and the headings hierarchy above is visible." - (if (org-on-heading-p t) - (org-flag-heading nil) ; only show the heading - (org-show-hidden-entry)) ; show entire entry - (save-excursion - (and org-show-following-heading - (outline-next-heading) - (org-flag-heading nil))) ; show the next heading - (save-excursion ; show all higher headings - (while (condition-case nil - (progn (org-up-heading-all 1) t) - (error nil)) - (org-flag-heading nil)))) - + (catch 'exit + (if (org-on-heading-p t) + (org-flag-heading nil) ; only show the heading + (and (org-invisible-p) (org-show-hidden-entry))) ; show entire entry + (save-excursion + (and org-show-following-heading + (outline-next-heading) + (org-flag-heading nil))) ; show the next heading + (when org-show-hierarchy-above + (save-excursion ; show all higher headings + (while (and (condition-case nil + (progn (org-up-heading-all 1) t) + (error nil)) + (not (bobp))) + (org-flag-heading nil)))))) + +;; Overlay compatibility functions +(defun org-make-overlay (beg end &optional buffer) + (if org-xemacs-p (make-extent beg end buffer) (make-overlay beg end buffer))) +(defun org-delete-overlay (ovl) + (if org-xemacs-p (delete-extent ovl) (delete-overlay ovl))) +(defun org-detatch-overlay (ovl) + (if org-xemacs-p (detach-extent ovl) (delete-overlay ovl))) +(defun org-move-overlay (ovl beg end &optional buffer) + (if org-xemacs-p + (set-extent-endpoints ovl beg end buffer) + (move-overlay ovl beg end buffer))) +(defun org-overlay-put (ovl prop value) + (if org-xemacs-p + (set-extent-property ovl prop value) + (overlay-put ovl prop value))) + +(defvar org-occur-highlights nil) +(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))) + +(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) + (mapc 'org-delete-overlay org-occur-highlights) + (setq org-occur-highlights nil) + (unless noremove + (remove-hook 'before-change-functions + 'org-remove-occur-highlights 'local))) + ;;; Priorities (defvar org-priority-regexp ".*?\\(\\[#\\([A-Z]\\)\\] ?\\)" @@ -3135,7 +3635,9 @@ at the cursor, it will be modified." "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." +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." + ;; FIXME: Would it be better not to ask for a date/time here? (interactive "P") (let ((fmt (if arg (cdr org-time-stamp-formats) (car org-time-stamp-formats))) @@ -3146,7 +3648,12 @@ does not link to the calendar and cannot be changed with the S-cursor keys." (setq fmt (concat "[" (substring fmt 1 -1) "]")) (insert (format-time-string fmt time)))) +(defvar org-date-ovl (org-make-overlay 1 1)) +(org-overlay-put org-date-ovl 'face 'org-warning) +(org-detatch-overlay org-date-ovl) + ;;; FIXME: Make the function take "Fri" as "next friday" +;;; because these are mostly being used to record the current time. (defun org-read-date (&optional with-time to-time) "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 @@ -3189,6 +3696,8 @@ used to insert the time stamp into the buffer to include the time." (mapcar (lambda(x) (or x 0)) ;; FIXME: Problem with timezone? (parse-time-string (match-string 1)))) (current-time))) + (calendar-move-hook nil) + (view-diary-entries-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)) @@ -3200,17 +3709,19 @@ used to insert the time stamp into the buffer to include the time." ;; Copied (with modifications) from planner.el by John Wiegley (save-excursion (save-window-excursion - (let ((view-diary-entries-initially nil)) - (calendar)) + (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 org-xemacs-p [button1] [mouse-1]) - 'org-calendar-select) + 'org-calendar-select-mouse) + (define-key map (if org-xemacs-p [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)))) @@ -3243,6 +3754,7 @@ used to insert the time stamp into the buffer to include the time." (use-local-map old-map))))) ;; Naked prompt only (setq ans (read-string prompt "" nil timestr))) + (org-detatch-overlay org-date-ovl) (if (string-match "^ *\\(\\([0-9]+\\)-\\)?\\([0-1]?[0-9]\\)-\\([0-3]?[0-9]\\)\\([^-0-9]\\|$\\)" ans) @@ -3282,6 +3794,7 @@ Also, store the cursor date in variable ans2." (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-calendar-select () @@ -3294,6 +3807,17 @@ This is used by `org-read-date' in a temporary keymap for the calendar buffer." (setq ans1 (format-time-string "%Y-%m-%d" time))) (if (active-minibuffer-window) (exit-minibuffer)))) +(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)))) + (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' @@ -3434,13 +3958,19 @@ With prefix ARG, change by that many units." "Increase the date in the time stamp by one day. With prefix ARG, change that many days." (interactive "p") - (org-timestamp-change (prefix-numeric-value arg) 'day)) + (if (and (not (org-at-timestamp-p)) + (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") - (org-timestamp-change (- (prefix-numeric-value arg)) 'day)) + (if (and (not (org-at-timestamp-p)) + (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) @@ -3448,7 +3978,7 @@ With prefix ARG, change that many days." (>= (match-end n) pos))) (defun org-at-timestamp-p () - "Determine if the cursor is or at a timestamp." + "Determine if the cursor is in or at a timestamp." (interactive) (let* ((tsr org-ts-regexp2) (pos (point)) @@ -3524,7 +4054,8 @@ in the timestamp determines what will be changed." (defun org-recenter-calendar (date) "If the calendar is visible, recenter it to DATE." (let* ((win (selected-window)) - (cwin (get-buffer-window "*Calendar*" t))) + (cwin (get-buffer-window "*Calendar*" t)) + (calendar-move-hook nil)) (when cwin (select-window cwin) (calendar-goto-date (if (listp date) date @@ -3536,7 +4067,9 @@ in the timestamp determines what will be changed." If there is a time stamp in the current line, go to that date. A prefix ARG can be used force the current date." (interactive "P") - (let ((tsr org-ts-regexp) diff) + (let ((tsr org-ts-regexp) diff + (calendar-move-hook nil) + (view-diary-entries-initially nil)) (if (or (org-at-timestamp-p) (save-excursion (beginning-of-line 1) @@ -3545,8 +4078,7 @@ A prefix ARG can be used force the current date." (d2 (time-to-days (org-time-string-to-time (match-string 1))))) (setq diff (- d2 d1)))) - (let ((view-diary-entries-initially nil)) - (calendar)) + (calendar) (calendar-goto-today) (if (and diff (not arg)) (calendar-forward-day diff)))) @@ -3565,9 +4097,12 @@ If there is already a time stamp at the cursor position, update it." (defvar org-agenda-menu) (defvar org-agenda-follow-mode nil) +(defvar org-agenda-show-log nil) (defvar org-agenda-buffer-name "*Org Agenda*") (defvar org-agenda-redo-command nil) (defvar org-agenda-mode-hook nil) +(defvar org-agenda-type nil) +(defvar org-agenda-force-single-file nil) ;;;###autoload (defun org-agenda-mode () @@ -3583,28 +4118,38 @@ The following commands are available: (use-local-map org-agenda-mode-map) (easy-menu-add org-agenda-menu) (if org-startup-truncated (setq truncate-lines t)) + (make-local-hook 'post-command-hook) ; Needed for XEmacs (add-hook 'post-command-hook 'org-agenda-post-command-hook nil 'local) + (make-local-hook 'pre-command-hook) ; Needed for XEmacs (add-hook 'pre-command-hook 'org-unhighlight nil 'local) - (setq org-agenda-follow-mode nil) + (unless org-agenda-keep-modes + (setq org-agenda-follow-mode nil + org-agenda-show-log nil)) (easy-menu-change '("Agenda") "Agenda Files" (append (list - ["Edit File List" (customize-variable 'org-agenda-files) t] + (vector + (if (get 'org-agenda-files 'org-restrict) + "Restricted to single file" + "Edit File List") + '(customize-variable 'org-agenda-files) + (not (get 'org-agenda-files 'org-restrict))) "--") - (mapcar 'org-file-menu-entry org-agenda-files))) + (mapcar 'org-file-menu-entry (org-agenda-files)))) (org-agenda-set-mode-name) (apply (if (fboundp 'run-mode-hooks) 'run-mode-hooks 'run-hooks) - org-agenda-mode-hook)) + (list 'org-agenda-mode-hook))) (define-key org-agenda-mode-map "\C-i" 'org-agenda-goto) (define-key org-agenda-mode-map "\C-m" 'org-agenda-switch-to) (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 "L" 'org-agenda-recenter) (define-key org-agenda-mode-map "t" 'org-agenda-todo) +(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) @@ -3619,12 +4164,14 @@ The following commands are available: (int-to-string (pop l)) 'digit-argument))) (define-key org-agenda-mode-map "f" 'org-agenda-follow-mode) +(define-key org-agenda-mode-map "l" 'org-agenda-log-mode) (define-key org-agenda-mode-map "D" 'org-agenda-toggle-diary) (define-key org-agenda-mode-map "g" 'org-agenda-toggle-time-grid) (define-key org-agenda-mode-map "r" 'org-agenda-redo) (define-key org-agenda-mode-map "q" 'org-agenda-quit) (define-key org-agenda-mode-map "x" 'org-agenda-exit) (define-key org-agenda-mode-map "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) @@ -3671,45 +4218,167 @@ The following commands are available: :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]) ("Reschedule" - ["Reschedule +1 day" org-agenda-date-later t] - ["Reschedule -1 day" org-agenda-date-earlier 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 t]) + ["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] - ["Goto Today" org-agenda-goto-today t] - ["Next Dates" org-agenda-later (local-variable-p 'starting-day)] - ["Previous Dates" org-agenda-earlier (local-variable-p 'starting-day)] "--" - ["Day View" org-agenda-day-view :active (local-variable-p 'starting-day) + ["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 (local-variable-p 'starting-day) + ["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 t] + :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 t] + :style toggle :selected org-agenda-use-time-grid :active (org-agenda-check-type nil 'agenda)] "--" - ["New Diary Entry" org-agenda-diary-entry t] + ["New Diary Entry" org-agenda-diary-entry (org-agenda-check-type nil 'agenda 'timeline)] ("Calendar Commands" - ["Goto Calendar" org-agenda-goto-calendar t] - ["Phases of the Moon" org-agenda-phases-of-moon t] - ["Sunrise/Sunset" org-agenda-sunrise-sunset t] - ["Holidays" org-agenda-holidays t] - ["Convert" org-agenda-convert-date t]) + ["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] )) +;;;###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: + +a Call `org-agenda' to display the agenda for the 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 get 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. + +More commands can be added by configuring the variable +`org-agenda-custom-commands'. In particular, specific tags and TODO keyword +searches can be pre-defined in this way. + +If the current buffer is in Org-mode and visiting a file, you can also +first press `1' to indicate that the agenda should be temporarily (until the +next use of \\[org-agenda]) restricted to the current file." + (interactive "P") + (catch 'exit + (let ((restrict-ok (and (buffer-file-name) (eq major-mode 'org-mode))) + (custom org-agenda-custom-commands) + c entry key type string) + (put 'org-agenda-files 'org-restrict nil) + (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. +C Configure your own agenda commands") + (while (setq entry (pop custom)) + (setq key (car entry) type (nth 1 entry) string (nth 2 entry)) + (insert (format "\n%-4s%-14s: %s" + key + (cond + ((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 "???")) + (org-string-props string 'face 'org-link)))) + (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] to restrict to current file" "")) + (setq c (read-char-exclusive)) + (message "") + (when (equal c ?1) + (if restrict-ok + (put 'org-agenda-files 'org-restrict (list (buffer-file-name))) + (error "Cannot restrict agenda to current buffer")) + (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) + (setq current-prefix-arg (or arg '(4))) + (call-interactively 'org-todo-list)) + ((equal c ?m) (call-interactively 'org-tags-view)) + ((equal c ?M) + (setq current-prefix-arg (or arg '(4))) + (call-interactively 'org-tags-view)) + ((setq entry (assoc (char-to-string c) org-agenda-custom-commands)) + (setq type (nth 1 entry) string (nth 2 entry)) + (cond + ((eq type 'tags) + (org-tags-view current-prefix-arg string)) + ((eq type 'todo) + (org-todo-list string)) + ((eq type 'tags-tree) + (org-check-for-org-mode) + (org-tags-sparse-tree current-prefix-arg string)) + ((eq type 'todo-tree) + (org-check-for-org-mode) + (org-occur (concat "^" outline-regexp "[ \t]*" + (regexp-quote string) "\\>"))) + ((eq type 'occur-tree) + (org-check-for-org-mode) + (org-occur string)) + (t (error "Invalid custom agenda command type %s" type)))) + (t (error "Invalid key")))))) + +(defun org-check-for-org-mode () + "Make sure current buffer is in org-mode. Error if not." + (or (eq major-mode 'org-mode) + (error "Cannot execute org-mode agenda command on buffer in %s." + major-mode))) + +(defun org-fit-agenda-window () + "Fit the window to the buffer size." + (and org-fit-agenda-window + (fboundp 'fit-window-to-buffer) + (fit-window-to-buffer nil (/ (* (frame-height) 3) 4) + (/ (frame-height) 2)))) + +(defun org-agenda-files () + "Get the list of agenda files." + (or (get 'org-agenda-files 'org-restrict) + org-agenda-files)) + (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)) @@ -3762,11 +4431,10 @@ When a buffer is unmodified, it is just killed. When modified, it is saved (defvar org-respect-restriction nil) ; Dynamically-scoped param. -(defun org-timeline (&optional include-all) +(defun org-timeline (&optional include-all keep-modes) "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 -one \\[universal-argument] prefix argument, past entries will also be listed. -With two \\[universal-argument] prefixes, all unfinished TODO items will also be shown, +\\[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." @@ -3774,8 +4442,10 @@ dates." (require 'calendar) (org-agenda-maybe-reset-markers 'force) (org-compile-prefix-format org-timeline-prefix-format) - (let* ((dopast include-all) - (dotodo (equal include-all '(16))) + (let* ((dopast t) + (dotodo include-all) + (doclosed org-agenda-show-log) + (org-agenda-keep-modes keep-modes) (entry (buffer-file-name)) (org-agenda-files (list (buffer-file-name))) (date (calendar-current-date)) @@ -3784,15 +4454,16 @@ dates." (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)) ; always include today + t doclosed)) ; always include today (today (time-to-days (current-time))) (org-respect-restriction t) (past t) + args s e rtn d) (setq org-agenda-redo-command (list 'progn (list 'switch-to-buffer-other-window (current-buffer)) - (list 'org-timeline (list 'quote include-all)))) + (list 'org-timeline (list 'quote include-all) t))) (if (not dopast) ;; Remove past dates from the list of dates. (setq day-numbers (delq nil (mapcar (lambda(x) @@ -3803,6 +4474,10 @@ dates." (setq buffer-read-only nil) (erase-buffer) (org-agenda-mode) (setq buffer-read-only nil) + (set (make-local-variable 'org-agenda-type) 'timeline) + (if doclosed (push :closed args)) + (push :timestamp args) + (if dotodo (push :todo args)) (while (setq d (pop day-numbers)) (if (and (>= d today) dopast @@ -3812,10 +4487,8 @@ dates." (insert (make-string 79 ?-) "\n"))) (setq date (calendar-gregorian-from-absolute d)) (setq s (point)) - (if dotodo - (setq rtn (org-agenda-get-day-entries - entry date :todo :timestamp)) - (setq rtn (org-agenda-get-day-entries entry date :timestamp))) + (setq rtn (apply 'org-agenda-get-day-entries + entry date args)) (if (or rtn (equal d today)) (progn (insert (calendar-day-name date) " " @@ -3837,12 +4510,15 @@ dates." (goto-char pos1)))) ;;;###autoload -(defun org-agenda (&optional include-all start-day ndays) +(defun org-agenda-list (&optional include-all start-day ndays keep-modes) "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'." @@ -3854,7 +4530,8 @@ NDAYS defaults to `org-agenda-ndays'." (if (or (equal ndays 1) (and (null ndays) (equal 1 org-agenda-ndays))) nil org-agenda-start-on-weekday)) - (files (copy-sequence org-agenda-files)) + (org-agenda-keep-modes keep-modes) + (files (copy-sequence (org-agenda-files))) (win (selected-window)) (today (time-to-days (current-time))) (sd (or start-day today)) @@ -3870,7 +4547,7 @@ NDAYS defaults to `org-agenda-ndays'." (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 'quote include-all) start-day ndays)) + (list 'org-agenda-list (list 'quote include-all) start-day ndays t)) ;; Make the list of days (setq ndays (or ndays org-agenda-ndays) nd ndays) @@ -3886,11 +4563,12 @@ NDAYS defaults to `org-agenda-ndays'." (setq buffer-read-only nil) (erase-buffer) (org-agenda-mode) (setq buffer-read-only nil) + (set (make-local-variable 'org-agenda-type) 'agenda) (set (make-local-variable 'starting-day) (car day-numbers)) (set (make-local-variable 'include-all-loc) include-all) (when (and (or include-all org-agenda-include-all-todo) (member today day-numbers)) - (setq files org-agenda-files + (setq files (org-agenda-files) rtnall nil) (while (setq file (pop files)) (catch 'nextfile @@ -3912,12 +4590,18 @@ NDAYS defaults to `org-agenda-ndays'." (setq start-pos (point)) (if (and start-pos (not end-pos)) (setq end-pos (point)))) - (setq files org-agenda-files + (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)) + (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 @@ -3934,16 +4618,14 @@ NDAYS defaults to `org-agenda-ndays'." (put-text-property s (1- (point)) 'face 'org-link) (if rtnall (insert - (org-finalize-agenda-entries ;; FIXME: condition needed + (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)) (setq buffer-read-only t) - (if org-fit-agenda-window - (fit-window-to-buffer nil (/ (* (frame-height) 3) 4) - (/ (frame-height) 2))) + (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))) @@ -3956,10 +4638,80 @@ NDAYS defaults to `org-agenda-ndays'." (if (not org-select-agenda-window) (select-window win)) (message ""))) +(defvar org-select-this-todo-keyword nil) + +;;;###autoload +(defun org-todo-list (arg &optional keep-modes) + "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") + (org-agenda-maybe-reset-markers 'force) + (org-compile-prefix-format org-agenda-prefix-format) + (let* ((org-agenda-keep-modes keep-modes) + (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) (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)) + (if (not (equal (current-buffer) (get-buffer org-agenda-buffer-name))) + (progn + (delete-other-windows) + (switch-to-buffer-other-window + (get-buffer-create org-agenda-buffer-name)))) + (setq buffer-read-only nil) + (erase-buffer) + (org-agenda-mode) (setq buffer-read-only nil) + (set (make-local-variable 'org-agenda-type) 'todo) + (set (make-local-variable 'last-arg) arg) + (set (make-local-variable 'org-todo-keywords) kwds) + (set (make-local-variable 'org-agenda-redo-command) + '(org-todo-list (or current-prefix-arg last-arg) t)) + (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-link)) + (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)) + (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-link)) + (when rtnall + (insert (org-finalize-agenda-entries rtnall) "\n")) + (goto-char (point-min)) + (setq buffer-read-only t) + (org-fit-agenda-window) + (if (not org-select-agenda-window) (select-window win)))) + (defun org-check-agenda-file (file) "Make sure FILE exists. If not, ask user what to do." ;; FIXME: this does not correctly change the menus - ;; Could probably be fixed by explicitly going to the buffer. + ;; Could probably be fixed by explicitly going to the buffer where + ;; the call originated. (when (not (file-exists-p file)) (message "non-existent file %s. [R]emove from agenda-files or [A]bort?" file) @@ -3970,6 +4722,15 @@ NDAYS defaults to `org-agenda-ndays'." (throw 'nextfile t)) (t (error "Abort")))))) +(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 "Now allowed in %s-type agenda buffers" org-agenda-type) + nil))) + (defun org-agenda-quit () "Exit agenda by removing the window or the buffer." (interactive) @@ -3988,18 +4749,23 @@ Org-mode buffers visited directly by the user will not be touched." (org-agenda-quit)) (defun org-agenda-redo () - "Rebuild Agenda." + "Rebuild Agenda. +When this is the global TODO list, a prefix argument will be interpreted." (interactive) - (eval org-agenda-redo-command)) + (message "Rebuilding agenda buffer...") + (eval org-agenda-redo-command) + (message "Rebuilding agenda buffer...done")) (defun org-agenda-goto-today () "Go to today." (interactive) + (org-agenda-check-type t 'timeline 'agenda) (if (boundp 'starting-day) (let ((cmd (car org-agenda-redo-command)) (iall (nth 1 org-agenda-redo-command)) - (nday (nth 3 org-agenda-redo-command))) - (eval (list cmd iall nil nday))) + (nday (nth 3 org-agenda-redo-command)) + (keep (nth 4 org-agenda-redo-command))) + (eval (list cmd iall nil nday keep))) (goto-char (or (text-property-any (point-min) (point-max) 'org-today t) (point-min))))) @@ -4007,47 +4773,46 @@ Org-mode buffers visited directly by the user will not be touched." "Go forward in time by `org-agenda-ndays' days. With prefix ARG, go forward that many times `org-agenda-ndays'." (interactive "p") - (unless (boundp 'starting-day) - (error "Not allowed")) - (org-agenda (if (boundp 'include-all-loc) include-all-loc nil) - (+ starting-day (* arg org-agenda-ndays)))) + (org-agenda-check-type t 'agenda) + (org-agenda-list (if (boundp 'include-all-loc) include-all-loc nil) + (+ starting-day (* arg org-agenda-ndays)) nil t)) (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") - (unless (boundp 'starting-day) - (error "Not allowed")) - (org-agenda (if (boundp 'include-all-loc) include-all-loc nil) - (- starting-day (* arg org-agenda-ndays)))) + (org-agenda-check-type t 'agenda) + (org-agenda-list (if (boundp 'include-all-loc) include-all-loc nil) + (- starting-day (* arg org-agenda-ndays)) nil t)) (defun org-agenda-week-view () "Switch to weekly view for agenda." (interactive) - (unless (boundp 'starting-day) - (error "Not allowed")) + (org-agenda-check-type t 'agenda) (setq org-agenda-ndays 7) - (org-agenda include-all-loc - (or (get-text-property (point) 'day) - starting-day)) + (org-agenda-list include-all-loc + (or (get-text-property (point) 'day) + starting-day) + nil t) (org-agenda-set-mode-name) (message "Switched to week view")) (defun org-agenda-day-view () "Switch to weekly view for agenda." (interactive) - (unless (boundp 'starting-day) - (error "Not allowed")) + (org-agenda-check-type t 'agenda) (setq org-agenda-ndays 1) - (org-agenda include-all-loc - (or (get-text-property (point) 'day) - starting-day)) + (org-agenda-list include-all-loc + (or (get-text-property (point) 'day) + starting-day) + nil t) (org-agenda-set-mode-name) (message "Switched to day view")) (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)) @@ -4059,14 +4824,14 @@ With prefix ARG, go back that many times `org-agenda-ndays'." (defun org-agenda-previous-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 (not (re-search-backward "^\\S-" nil t arg)) (error "No previous date before this line in this buffer"))) ;; Initialize the highlight -(defvar org-hl (funcall (if org-xemacs-p 'make-extent 'make-overlay) 1 1)) -(funcall (if org-xemacs-p 'set-extent-property 'overlay-put) org-hl - 'face '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." @@ -4086,9 +4851,20 @@ With prefix ARG, go back that many times `org-agenda-ndays'." (message "Follow mode is %s" (if org-agenda-follow-mode "on" "off"))) +(defun org-agenda-log-mode () + "Toggle follow 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 follow mode 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) @@ -4098,6 +4874,7 @@ With prefix ARG, go back that many times `org-agenda-ndays'." (defun org-agenda-toggle-time-grid () "Toggle follow mode 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) @@ -4112,7 +4889,8 @@ With prefix ARG, go back that many times `org-agenda-ndays'." (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-use-time-grid " Grid" "") + (if org-agenda-show-log " Log" ""))) (force-mode-line-update)) (defun org-agenda-post-command-hook () @@ -4156,7 +4934,7 @@ With prefix ARG, go back that many times `org-agenda-ndays'." (setq entries (mapcar (lambda (x) - (setq x (org-format-agenda-item "" x "Diary" 'time)) + (setq x (org-format-agenda-item "" x "Diary" nil 'time)) ;; Extend the text properties to the beginning of the line (add-text-properties 0 (length x) @@ -4224,34 +5002,53 @@ Needed to avoid empty dates which mess up holiday display." (error (add-to-diary-list original-date "Org-mode dummy" "" nil))))) -(defun org-add-file (&optional file) - "Add current file to 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. -It is possible (but not recommended) to add this function to the -`org-mode-hook'." +(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) - (catch 'exit - (let* ((file (or file (buffer-file-name) - (if (interactive-p) - (error "Buffer is not visiting a file") - (throw 'exit nil)))) - (true-file (file-truename file)) - (afile (abbreviate-file-name file)) - (present (delq nil (mapcar - (lambda (x) - (equal true-file (file-truename x))) - org-agenda-files)))) - (if (not present) - (progn - (setq org-agenda-files - (cons afile org-agenda-files)) - ;; Make sure custom.el does not end up with Org-mode - (let ((org-mode-hook nil) (default-major-mode 'fundamental-mode)) - (customize-save-variable 'org-agenda-files org-agenda-files)) - (org-install-agenda-files-menu) - (message "Added file: %s" afile)) - (message "File was already in list: %s" afile))))) + (let ((files (append org-agenda-files (list (car org-agenda-files)))) + (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 org-agenda-files))))) + +(defun org-agenda-file-to-end (&optional file) + "Move/add the current file to the end of the agenda fiole list. +I the file is not present in the list, it is appended ot the list. If it is +present, it is moved there." + (interactive) + (org-agenda-file-to-front 'to-end file)) + +(defun org-agenda-file-to-front (&optional to-end file) + "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)) + (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)))) + (setq org-agenda-files (mapcar 'cdr file-alist)) + (let ((org-mode-hook nil) (default-major-mode 'fundamental-mode)) + (customize-save-variable 'org-agenda-files org-agenda-files)) + (org-install-agenda-files-menu) + (message "File %s to %s of agenda file list" + (if had "moved" "added") (if to-end "end" "front")))) (defun org-remove-file (&optional file) "Remove current file from the list of files in variable `org-agenda-files'. @@ -4277,21 +5074,23 @@ Optional argument FILE means, use this file instead of the current." (defun org-file-menu-entry (file) (vector file (list 'find-file file) t)) -;; FIXME: Maybe removed a buffer visited through the menu from +;; FIXME: Maybe we removed a buffer visited through the menu from ;; org-agenda-new-buffers, so that the buffer will not be removed ;; when exiting the agenda???? -(defun org-get-all-dates (beg end &optional no-ranges force-today) +(defun org-get-all-dates (beg end &optional no-ranges force-today inactive) "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." - (let (dates date day day1 day2 ts1 ts2) +sure that TODAY is included in the list. If INACTIVE is non-nil, also +inactive time stamps (those in square brackets) are included." + (let ((re (if inactive org-ts-regexp-both org-ts-regexp)) + dates 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 org-ts-regexp end t) + (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))) @@ -4365,6 +5164,33 @@ function from a program - use `org-agenda-get-day-entries' instead." (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)))))) (defun org-agenda-get-day-entries (file date &rest args) "Does the work for `org-diary' and `org-agenda'. @@ -4385,6 +5211,7 @@ the documentation of `org-diary'." (with-current-buffer buffer (unless (eq major-mode 'org-mode) (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 @@ -4410,6 +5237,9 @@ the documentation of `org-diary'." ((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)) @@ -4449,25 +5279,31 @@ the documentation of `org-diary'." 'help-echo (format "mouse-2 or RET jump to org file %s" (abbreviate-file-name (buffer-file-name))))) - (regexp (concat "[\n\r]\\*+ *\\(" org-not-done-regexp + (regexp (concat "[\n\r]\\*+ *\\(" + (if org-select-this-todo-keyword + (concat "\\<\\(" org-select-this-todo-keyword + "\\)\\>") + org-not-done-regexp) "[^\n\r]*\\)")) - marker priority + marker priority category tags ee txt) (goto-char (point-min)) (while (re-search-forward regexp nil t) (goto-char (match-beginning 1)) - (setq marker (org-agenda-new-marker (point-at-bol)) - txt (org-format-agenda-item "" (match-string 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-todo-kwd-max-priority -2 + (length + (member (match-string 2) org-todo-keywords))) + 1))) (add-text-properties 0 (length txt) (append (list 'org-marker marker 'org-hd-marker marker - 'priority priority) + 'priority priority 'category category) props) txt) (push txt ee) @@ -4492,13 +5328,14 @@ the documentation of `org-diary'." (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 - ee txt timestr) + marker hdmarker deadlinep scheduledp donep tmp priority category + ee txt timestr tags) (goto-char (point-min)) (while (re-search-forward regexp nil t) (if (not (save-match-data (org-at-date-range-p))) (progn (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)) @@ -4514,13 +5351,14 @@ the documentation of `org-diary'." (if (re-search-backward "\\(^\\|\r\\)\\*+" nil t) (progn (goto-char (match-end 1)) - (setq hdmarker (org-agenda-new-marker)) + (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) nil timestr))) + (match-string 1) category tags timestr))) (setq txt org-agenda-no-heading-message)) (setq priority (org-get-priority txt)) (add-text-properties @@ -4534,6 +5372,7 @@ the documentation of `org-diary'." (if donep 'org-done 'org-warning) 'undone-face 'org-warning 'done-face 'org-done + 'category category 'priority (+ 100 priority)) txt) (if scheduledp @@ -4542,11 +5381,67 @@ the documentation of `org-diary'." (list 'face 'org-scheduled-today 'undone-face 'org-scheduled-today 'done-face 'org-done + 'category category priority (+ 99 priority)) txt) (add-text-properties 0 (length txt) - (list 'priority priority) txt))) + (list 'priority priority 'category category) txt))) + (push txt ee)) + (outline-next-heading)))) + (nreverse ee))) + +(defun org-agenda-get-closed () + "Return the loggedd TODO entries for agenda display." + (let* ((props (list '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 + "\\<" org-closed-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 + ee txt timestr) + (goto-char (point-min)) + (while (re-search-forward regexp nil t) + (if (not (save-match-data (org-at-date-range-p))) + (progn + (setq marker (org-agenda-new-marker (match-beginning 0)) + 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 + "Closed: " + (match-string 1) category tags timestr))) + (setq txt org-agenda-no-heading-message)) + (setq priority 100000) + (add-text-properties + 0 (length txt) (append (list 'org-marker marker + 'org-hd-marker hdmarker + 'face 'org-done + 'priority priority + 'category category + 'undone-face 'org-warning + 'done-face 'org-done) props) + txt) (push txt ee)) (outline-next-heading)))) (nreverse ee))) @@ -4562,7 +5457,7 @@ the documentation of `org-diary'." (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 + d2 diff pos pos1 category tags ee txt head) (goto-char (point-min)) (while (re-search-forward regexp nil t) @@ -4575,10 +5470,12 @@ the documentation of `org-diary'." ;; 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") @@ -4586,7 +5483,7 @@ the documentation of `org-diary'." (if (string-match org-looking-at-done-regexp head) (setq txt nil) (setq txt (org-format-agenda-item - (format "In %3d d.: " diff) head)))) + (format "In %3d d.: " diff) head category tags)))) (setq txt org-agenda-no-heading-message)) (when txt (add-text-properties @@ -4595,6 +5492,7 @@ the documentation of `org-diary'." (list 'org-marker (org-agenda-new-marker pos) 'org-hd-marker (org-agenda-new-marker pos1) 'priority (+ (- 10 diff) (org-get-priority txt)) + 'category category 'face (cond ((<= diff 0) 'org-warning) ((<= diff 5) 'org-scheduled-previously) (t nil)) @@ -4621,7 +5519,7 @@ the documentation of `org-diary'." (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 + d2 diff pos pos1 category tags ee txt head) (goto-char (point-min)) (while (re-search-forward regexp nil t) @@ -4633,24 +5531,28 @@ the documentation of `org-diary'." ;; 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)))) + (format "Sched.%2dx: " (- 1 diff)) head + category tags)))) (setq txt org-agenda-no-heading-message)) (when txt (add-text-properties 0 (length txt) (append (list 'org-marker (org-agenda-new-marker pos) 'org-hd-marker (org-agenda-new-marker pos1) - 'priority (+ (- 5 diff) (org-get-priority txt))) + 'priority (+ (- 5 diff) (org-get-priority txt)) + 'category category) props) txt) (push txt ee))))) ee)) @@ -4665,7 +5567,7 @@ the documentation of `org-diary'." (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) + marker hdmarker ee txt d1 d2 s1 s2 timestr category tags) (goto-char (point-min)) (while (re-search-forward regexp nil t) (setq timestr (match-string 0) @@ -4678,20 +5580,24 @@ the documentation of `org-diary'." ;; 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) nil (if (= d0 d1) timestr)))) + (match-string 1) category tags + (if (= d0 d1) timestr)))) (setq txt org-agenda-no-heading-message)) (add-text-properties 0 (length txt) (append (list 'org-marker marker 'org-hd-marker hdmarker - 'priority (org-get-priority txt)) + 'priority (org-get-priority txt) + 'category category) props) txt) (push txt ee))) @@ -4699,8 +5605,6 @@ the documentation of `org-diary'." ;; Sort the entries by expiration date. (nreverse ee))) - - (defconst org-plain-time-of-day-regexp (concat "\\(\\<[012]?[0-9]" @@ -4733,7 +5637,7 @@ After a match, the following groups carry important information: "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 dotime noprefix) +(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. @@ -4744,7 +5648,7 @@ 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'." +`org-agenda-change-all-lines'. TAG can be the tag 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))) @@ -4754,6 +5658,7 @@ only the correctly processes TXT should be returned - this is used by (file-name-sans-extension (file-name-nondirectory (buffer-file-name))) ""))) + (tag (or (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))) @@ -4794,6 +5699,7 @@ only the correctly processes TXT should be returned - this is used by ;; And finally add the text properties (add-text-properties 0 (length rtn) (list 'category (downcase category) + 'tags tags 'prefix-length (- (length rtn) (length txt)) 'time-of-day time-of-day 'dotime dotime) @@ -4822,7 +5728,7 @@ only the correctly processes TXT should be returned - this is used by (unless (and remove (member time have)) (setq time (int-to-string time)) (push (org-format-agenda-item - nil string "" ;; FIXME: put a category? + nil string "" nil ;; FIXME: put a category for the grid? (concat (substring time 0 -2) ":" (substring time -2))) new) (put-text-property @@ -4836,11 +5742,12 @@ only the correctly processes TXT should be returned - this is used by The resulting form is returned and stored in the variable `org-prefix-format-compiled'." (setq org-prefix-has-time nil) - (let ((start 0) varform vars var (s format) c f opt) + (let ((start 0) varform vars var (s format)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)))) + '(("c" . category) ("t" . time) ("s" . extra) + ("T" . tag)))) c (or (match-string 3 s) "") opt (match-beginning 1) start (1+ (match-beginning 0))) @@ -4878,7 +5785,9 @@ HH:MM." (if (match-beginning 3) (string-to-number (match-string 3 s)) 0))) - (t1 (concat " " (int-to-string t0)))) + (t1 (concat " " + (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) @@ -4932,6 +5841,14 @@ and by additional input from the age of a schedules or deadline entry." (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:" (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) @@ -5005,11 +5922,11 @@ and by additional input from the age of a schedules or deadline entry." "Marker pointing to the headline that last changed its TODO state by a remote command from the agenda.") -(defun org-agenda-todo () +(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) + (interactive "P") (org-agenda-check-no-diary) (let* ((col (current-column)) (marker (or (get-text-property (point) 'org-marker) @@ -5026,7 +5943,7 @@ the same tree node, and the headline of the tree node in the Org-mode file." (save-excursion (and (outline-next-heading) (org-flag-heading nil))) ; show the next heading - (org-todo) + (org-todo arg) (forward-char 1) (setq newhead (org-get-heading)) (save-excursion @@ -5044,7 +5961,7 @@ The new content of the line will be NEWHEAD (as modified by `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* (props m pl undone-face done-face finish new dotime) + (let* (props m pl undone-face done-face finish new dotime cat tags) ; (setq newhead (org-format-agenda-item "x" newhead "x" nil 'noprefix)) (save-excursion (goto-char (point-max)) @@ -5055,7 +5972,9 @@ the new TODO state." (equal m hdmarker)) (setq props (text-properties-at (point)) dotime (get-text-property (point) 'dotime) - new (org-format-agenda-item "x" newhead "x" dotime 'noprefix) + cat (get-text-property (point) '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)) @@ -5111,9 +6030,34 @@ the same tree node, and the headline of the tree node in the Org-mode file." (org-agenda-change-all-lines newhead hdmarker) (beginning-of-line 1))) +(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-hidden-entry) + (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-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))) @@ -5137,6 +6081,7 @@ the same tree node, and the headline of the tree node in the Org-mode file." 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))) @@ -5153,8 +6098,10 @@ be used to request time specification in the time stamp." (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")) +;;FIXME???????? (and (bolp) (end-of-line 1)) (if (and (re-search-backward "[\r\n]\\*" nil t) - (looking-at "[\r\n]\\*+[ \t]+\\(.*\\)")) + (looking-at "[\r\n]\\*+[ \t]+\\([^\r\n]*\\)")) (match-string 1) ""))) @@ -5162,6 +6109,7 @@ be used to request time specification in the time stamp." "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") @@ -5202,6 +6150,7 @@ All the standard commands work: block, weekly etc" (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")) @@ -5246,22 +6195,26 @@ argument, latitude and longitude will be prompted for." (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))) - (let ((view-diary-entries-initially nil)) - (calendar)) + (date (calendar-gregorian-from-absolute day)) + (calendar-move-hook 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 nil (calendar-absolute-from-gregorian - (calendar-cursor-to-date)))) + (org-agenda-list nil (calendar-absolute-from-gregorian + (calendar-cursor-to-date)) + nil t)) (defun org-agenda-convert-date () (interactive) + (org-agenda-check-type t 'agenda 'timeline) (let ((day (get-text-property (point) 'day)) date s) (unless day @@ -5284,7 +6237,287 @@ This is a command that has to be installed in `calendar-mode-map'." "Chinese: " (calendar-chinese-date-string date) "\n")) (with-output-to-temp-buffer "*Dates*" (princ s)) - (fit-window-to-buffer (get-buffer-window "*Dates*")))) + (if (fboundp 'fit-window-to-buffer) + (fit-window-to-buffer (get-buffer-window "*Dates*"))))) + +;;; Tags + +(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 TDOD keyword +d are included in the output." + (let* ((re (concat "[\n\r]" outline-regexp " *\\(\\<\\(" + (mapconcat 'regexp-quote + (nreverse (cdr (reverse org-todo-keywords))) + "\\|") + "\\>\\)\\)? *\\(.*?\\)\\(:[A-Za-z_:]+:\\)?[ \t]*[\n\r]")) + (props (list 'face nil + 'done-face 'org-done + 'undone-face nil + 'mouse-face 'highlight + 'keymap org-agenda-keymap + 'help-echo + (format "mouse-2 or RET jump to org file %s" + (abbreviate-file-name (buffer-file-name))))) + 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) (hide-sublevels 1)) + (while (re-search-forward re nil t) + (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 (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)) + ;; list this headline + (if (eq action 'sparse-tree) + (progn + (org-show-hierarchy-above)) + (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)) + (add-text-properties + 0 (length txt) + (append (list 'org-marker marker 'org-hd-marker marker + 'category category) + props) + txt) + (push txt rtn)) + ;; if we are to skip sublevels, jump to end of subtree + (point) + (or org-tags-match-list-sublevels (org-end-of-subtree))))) + (nreverse rtn))) + +(defun org-tags-sparse-tree (&optional arg match) + "Create a sparse tree according to tags search string MATCH. +MATCH can contain positive and negative selection of tags, like +\"+WORK+URGENT-WITHBOSS\"." + (interactive "P") + (let ((org-show-following-heading nil) + (org-show-hierarchy-above nil)) + (org-scan-tags 'sparse-tree (cdr (org-make-tags-matcher match))))) + +(defun org-make-tags-matcher (match) + "Create the TAGS matcher form for the tags-selecting string MATCH." + (unless match + ;; Get a new match request, with completion + (setq org-last-tags-completion-table + (or (org-get-buffer-tags) + org-last-tags-completion-table)) + (setq match (completing-read + "Tags: " 'org-tags-completion-function nil nil nil + 'org-tags-history))) + ;; parse the string and create a lisp form + (let ((match0 match) minus tag mm matcher orterms term orlist) + (setq orterms (org-split-string match "|")) + (while (setq term (pop orterms)) + (while (string-match "^&?\\([-+:]\\)?\\([A-Za-z_]+\\)" 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 matcher)) + (push (if (> (length matcher) 1) (cons 'and matcher) (car matcher)) + orlist) + (setq matcher nil)) + (setq matcher (if (> (length orlist) 1) (cons 'or orlist) (car orlist))) + ;; Return the string and lisp forms of the matcher + (cons match0 matcher))) + +;;;###autoload +(defun org-tags-view (&optional todo-only match keep-modes) + "Show all headlines for all `org-agenda-files' matching a TAGS criterions. +The prefix arg TODO-ONLY limits the search to TODO entries." + (interactive "P") + (org-agenda-maybe-reset-markers 'force) + (org-compile-prefix-format org-agenda-prefix-format) + (let* ((org-agenda-keep-modes keep-modes) + (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)) + (if (not (equal (current-buffer) (get-buffer org-agenda-buffer-name))) + (progn + (delete-other-windows) + (switch-to-buffer-other-window + (get-buffer-create org-agenda-buffer-name)))) + (setq buffer-read-only nil) + (erase-buffer) + (org-agenda-mode) (setq buffer-read-only nil) + (set (make-local-variable 'org-agenda-type) 'tags) + (set (make-local-variable 'org-agenda-redo-command) + (list 'org-tags-view (list 'quote todo-only) + (list 'if 'current-prefix-arg nil match) t)) + (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 (eq major-mode 'org-mode) + (error "Agenda file %s is not in `org-mode'" file)) + (save-excursion + (save-restriction + (if org-respect-restriction + (if (org-region-active-p) + ;; Respect a region to restrict search + (narrow-to-region (region-beginning) (region-end))) + ;; If we work for the calendar or many files, + ;; get rid of any restriction + (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-link)) + (setq pos (point)) + (insert match "\n") + (add-text-properties pos (1- (point)) (list 'face 'org-warning)) + (setq pos (point)) + (insert "Press `C-u r' to search again with new search string\n") + (add-text-properties pos (1- (point)) (list 'face 'org-link)) + (when rtnall + (insert (mapconcat 'identity rtnall "\n"))) + (goto-char (point-min)) + (setq buffer-read-only t) + (org-fit-agenda-window) + (if (not org-select-agenda-window) (select-window win)))) + +(defvar org-add-colon-after-tag-completion nil) ;; dynamically skoped param +(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) + (let* (;(inherit (org-get-inherited-tags)) + (re (concat "^" outline-regexp)) + (col (current-column)) + (current (org-get-tags)) + tags hd empty) + (if arg + (save-excursion + (goto-char (point-min)) + (while (re-search-forward re nil t) + (org-set-tags nil t)) + (message "All tags realigned to column %d" org-tags-column)) + (if just-align + (setq tags current) + (setq org-last-tags-completion-table + (or (org-get-buffer-tags) + org-last-tags-completion-table)) + (setq tags + (let ((org-add-colon-after-tag-completion t)) + (completing-read "Tags: " 'org-tags-completion-function + nil nil current 'org-tags-history))) + (while (string-match "[-+&]+" tags) + (setq tags (replace-match ":" t t tags))) + (unless (setq empty (string-match "\\`[\t ]*\\'" tags)) + (unless (string-match ":$" tags) (setq tags (concat tags ":"))) + (unless (string-match "^:" tags) (setq tags (concat ":" tags))))) + (if (equal current "") + (progn + (end-of-line 1) + (or empty (insert " "))) + (beginning-of-line 1) + (looking-at (concat "\\(.*\\)\\(" (regexp-quote current) "\\)[ \t]*")) + (setq hd (match-string 1)) + (delete-region (match-beginning 0) (match-end 0)) + (insert (org-trim hd) (if empty "" " "))) + (unless (equal tags "") + (move-to-column (max (current-column) + (if (> org-tags-column 0) + org-tags-column + (- (- org-tags-column) (length tags)))) + t) + (insert tags)) + (move-to-column col)))) + +(defun org-tags-completion-function (string predicate &optional flag) + (let (s1 s2 rtn (ctable org-last-tags-completion-table)) + (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)) + (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) + ) + ((eq flag 'lambda) + ;; exact match? + (assoc s2 ctable))) + )) + +(defun org-get-tags () + "Get the TAGS string in the current headline." + (unless (org-on-heading-p) + (error "Not on a heading")) + (save-excursion + (beginning-of-line 1) + (if (looking-at ".*[ \t]\\(:[A-Za-z_:]+:\\)[ \t]*\\(\r\\|$\\)") + (match-string 1) + ""))) + +(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_:]+\\):[ \t\r\n]" nil t) + (mapc (lambda (x) (add-to-list 'tags x)) + (org-split-string (match-string 1) ":")))) + (mapcar 'list tags))) ;;; Link Stuff @@ -5307,90 +6540,216 @@ 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") + (org-remove-occur-highlights nil nil t) (if (org-at-timestamp-p) - (org-agenda nil (time-to-days (org-time-string-to-time - (substring (match-string 1) 0 10))) - 1) - (let (type path line (pos (point))) - (save-excursion - (skip-chars-backward - (concat (if org-allow-space-in-links "^" "^ ") - org-non-link-chars)) - (if (re-search-forward - org-link-regexp - (save-excursion - (condition-case nil - (progn (outline-end-of-subtree) (max pos (point))) - (error (end-of-line 1) (point)))) - t) + (org-agenda-list nil (time-to-days (org-time-string-to-time + (substring (match-string 1) 0 10))) + 1) + (let (type path line search (pos (point))) + (catch 'match + (save-excursion + (skip-chars-backward + (concat (if org-allow-space-in-links "^" "^ ") + org-non-link-chars)) + (when (looking-at org-link-regexp) (setq type (match-string 1) - path (match-string 2))) - (unless path - (error "No link found")) - ;; Remove any trailing spaces in path - (if (string-match " +\\'" path) - (setq path (replace-match "" t t path))) - - (cond - - ((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)))) - (org-open-file path in-emacs line)) - - ((string= type "news") - (org-follow-gnus-link path)) - - ((string= type "bbdb") - (org-follow-bbdb-link path)) - - ((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))) - - ((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))) - - ((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))) - - ((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))) - - ((string= type "shell") - (let ((cmd path)) - (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-links) - (yes-or-no-p (format "Execute \"%s\" in the shell? " cmd))) - (shell-command cmd) - (error "Abort")))) + path (match-string 2)) + (throw 'match t))) + (save-excursion + (skip-chars-backward "^ \t\n\r") + (when (looking-at "\\(:[A-Za-z_:]+\\):[ \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 (looking-at org-camel-regexp) + (setq type "camel" path (match-string 0)) + (if (equal (char-before) ?*) + (setq path (concat "*" path)))) + (throw 'match t)) + (save-excursion + (when (re-search-forward + org-link-regexp + (save-excursion + (condition-case nil + (progn (outline-end-of-subtree) (max pos (point))) + (error (end-of-line 1) (point)))) + t) + (setq type (match-string 1) + path (match-string 2))))) + (unless path + (error "No link found")) + ;; Remove any trailing spaces in path + (if (string-match " +\\'" path) + (setq path (replace-match "" t t path))) + + (cond + + ((string= type "tags") + (org-tags-view path in-emacs)) + ((string= type "camel") + (org-link-search + path + (cond ((equal in-emacs '(4)) 'occur) + ((equal in-emacs '(16)) 'org-occur) + (t nil)))) + + ((string= type "file") + (if (string-match "::?\\([0-9]+\\)\\'" path) ;; second : optional + (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)) + + ((string= type "news") + (org-follow-gnus-link path)) + + ((string= type "bbdb") + (org-follow-bbdb-link path)) + + ((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))) + + ((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))) + + ((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))) + + ((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))) + + ((string= type "shell") + (let ((cmd path)) + (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-links) + (yes-or-no-p (format "Execute \"%s\" in the shell? " cmd))) + (shell-command cmd) + (error "Abort")))) + + (t + (browse-url-at-point)))))) + +(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 matched. +If the current buffer is in `dired-mode', grep will be used to search +in all files." + (let ((case-fold-search t) + (s0 s) + (pos (point)) + (pre "") (post "") + words re0 re1 re2 re3 re4 re5 reall) + (cond ((string-match "^/\\(.*\\)/$" s) + ;; A regular expression + (cond + ((eq major-mode 'org-mode) + (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))))) + ((string-match (concat "^" org-camel-regexp) s) + ;; A camel + (if (equal (string-to-char s) ?*) + (setq pre "^\\*+[ \t]*\\(\\sw+\\)?[ \t]*" + post "[ \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-camel-to-words s) + re0 (concat "<<" (regexp-quote s0) ">>") + re2 (concat "\\<" (mapconcat 'downcase words "[ \t]+") "\\>") + re4 (concat "\\<" (mapconcat 'downcase words "[^a-zA-Z_\r\n]+") "\\>") + re1 (concat pre re2 post) + re3 (concat pre re4 post) + re5 (concat pre ".*" re4) + re2 (concat pre re2) + 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 (re-search-forward re0 nil t) + (re-search-forward re1 nil t) + (re-search-forward re2 nil t) + (re-search-forward re3 nil t) + (re-search-forward re4 nil t) + (re-search-forward re5 nil t)) + (goto-char (match-beginning 0)) + (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")))))) + +(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)))) - (t - (browse-url-at-point))))))) +(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-follow-bbdb-link (name) "Follow a BBDB link to NAME." @@ -5490,15 +6849,21 @@ optional argument IN-EMACS is non-nil, Emacs will visit the file." message-number) (error "Message not found")))) -(defun org-open-file (path &optional in-emacs line) +(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 +openen in emacs. If the file does not exist, an error is thrown." - (let* ((file (convert-standard-filename (org-expand-file-name path))) + (setq in-emacs (or in-emacs line search)) + (let* ((file (if (equal path "") + (buffer-file-name) + (convert-standard-filename (org-expand-file-name path)))) (dfile (downcase file)) ext cmd apps) (if (and (not (file-exists-p file)) @@ -5513,15 +6878,25 @@ If the file does not exist, an error is thrown." (setq cmd 'emacs) (setq cmd (or (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)))) (cond ((and (stringp cmd) (not (string-match "^\\s-*$" cmd))) (setq cmd (format cmd (concat "\"" file "\""))) (save-window-excursion - (shell-command (concat cmd " & &")))) + (shell-command (concat cmd " &")))) ((or (stringp cmd) (eq cmd 'emacs)) - (funcall (cdr (assq 'file org-link-frame-setup)) file) - (if line (goto-line line))) + (unless (equal (file-truename file) (file-truename (buffer-file-name))) + (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))))) @@ -5553,7 +6928,7 @@ 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-line-numbers-in-file-links'." +For file links, arg negates `org-context-in-file-links'." (interactive "P") (let (link cpltxt) (cond @@ -5663,17 +7038,39 @@ For file links, arg negates `org-line-numbers-in-file-links'." (setq cpltxt w3m-current-url link (org-make-link cpltxt))) + ((eq major-mode 'org-mode) + ;; 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) + (if (save-excursion + (skip-chars-backward "a-zA-Z<") + (looking-at (concat "<<\\(" org-camel-regexp "\\)>>"))) + (setq cpltxt (concat cpltxt "::" (match-string 1))) + (setq cpltxt + (concat cpltxt "::" + (org-make-org-heading-camel + (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)))) + ))))) + (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 the line number? - (if (org-xor org-line-numbers-in-file-links arg) - (setq cpltxt - (concat cpltxt - ":" (int-to-string - (+ (if (bolp) 1 0) (count-lines - (point-min) (point))))))) + ;; Add a context string + (when (org-xor org-context-in-file-links arg) + (setq cpltxt + (concat cpltxt "::" + (org-make-org-heading-camel + (if (org-region-active-p) + (buffer-substring (region-beginning) (region-end)) + (buffer-substring (point-at-bol) (point-at-eol))))))) (setq link (org-make-link cpltxt))) ((interactive-p) @@ -5688,6 +7085,25 @@ For file links, arg negates `org-line-numbers-in-file-links'." (message "Stored: %s" (or cpltxt link))) link))) +(defun org-make-org-heading-camel (&optional string) + "Make a CamelCase string for S or the current headline." + (interactive) + (let ((s (or string (org-get-heading)))) + (unless string + ;; We are using a headline, clean up garbage in there. + (if (string-match org-todo-regexp 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))) @@ -5775,9 +7191,23 @@ is in the current directory or below." (setq org-stored-links (delq (assoc link org-stored-links) org-stored-links))) (if (not linktxt) (setq link (org-make-link link))) - (let ((lines (org-split-string (or linktxt link) "\n"))) + (setq link (or linktxt link)) + (when (string-match "<\\<file:\\(.+?\\)::\\([^>]+\\)>" link) + (let* ((path (match-string 1 link)) + (case-fold-search nil) + (search (match-string 2 link))) + (when (save-match-data + (equal (file-truename (buffer-file-name)) + (file-truename path))) + (if (save-match-data + (string-match (concat "^" org-camel-regexp "$") search)) + (setq link (replace-match search t t link) + matched t) + (setq link (replace-match (concat "<file:::" search ">") + t t link)))))) + (let ((lines (org-split-string link "\n"))) (insert (car lines)) - (setq matched (string-match org-link-regexp (car lines))) + (setq matched (or matched (string-match org-link-regexp (car lines)))) (setq lines (cdr lines)) (while lines (insert "\n") @@ -6173,7 +7603,7 @@ This is being used to correctly align a single field after TAB or RET.") (while (< (setq i (1+ i)) maxfields) ;; Loop over all columns (setq column (mapcar (lambda (x) (or (nth i x) "")) fields)) ;; maximum length - (push (apply 'max 1 (mapcar 'length column)) lengths) + (push (apply 'max 1 (mapcar 'string-width column)) lengths) ;; compute the fraction stepwise, ignoring empty fields (setq cnt 0 frac 0.0) (mapcar @@ -6293,7 +7723,7 @@ Optional argument NEW may specify text to replace the current field content." (goto-char pos)))))) (defun org-table-next-field () - "Go to the next field in the current table. + "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) @@ -6301,20 +7731,25 @@ Before doing so, re-align the table if necessary." (if (and org-table-automatic-realign org-table-may-need-update) (org-table-align)) - (if (org-at-table-hline-p) - (end-of-line 1)) - (condition-case nil - (progn - (re-search-forward "|" (org-table-end)) - (if (looking-at "[ \t]*$") - (re-search-forward "|" (org-table-end))) - (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)))) + (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-table-previous-field () "Go to the previous field in the table. @@ -6424,7 +7859,7 @@ This actually throws an error, so it aborts the current command." (if (looking-at "|[^|\n]+") (let* ((pos (match-beginning 0)) (match (match-string 0)) - (len (length match))) + (len (string-width match))) (replace-match (concat "|" (make-string (1- len) ?\ ))) (goto-char (+ 2 pos)) (substring match 1))))) @@ -6465,6 +7900,7 @@ 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) @@ -6483,7 +7919,7 @@ However, when FORCE is non-nil, create new columns if necessary." (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 chack for table.el-type tables." +If TABLE-TYPE is non-nil, also check for table.el-type tables." (if org-enable-table-editor (save-excursion (beginning-of-line 1) @@ -6491,6 +7927,13 @@ If TABLE-TYPE is non-nil, also chack for table.el-type tables." org-table-line-regexp))) nil)) +(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)))) + (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 @@ -6517,15 +7960,6 @@ If TABLE-TYPE is non-nil, also chack for table.el-type tables." nil) nil)) -(defun org-at-table.el-p () - "Return t if the cursor is inside a table.el-type table." - (save-excursion - (if (org-at-table-p 'any) - (progn - (goto-char (org-table-begin 'any)) - (looking-at org-table1-hline-regexp)) - nil))) - (defun org-at-table-hline-p () "Return t if the cursor is inside a hline in a table." (if org-enable-table-editor @@ -6683,7 +8117,9 @@ 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-no-properties (point-at-bol) (point-at-eol))) + (let* ((line + (org-expand-wide-chars + (buffer-substring-no-properties (point-at-bol) (point-at-eol)))) new) (if (string-match "^[ \t]*|-" line) (setq new (mapcar (lambda (x) (if (member x '(?| ?+)) ?| ?\ )) line)) @@ -6706,7 +8142,9 @@ With prefix ARG, insert above the current line." (interactive "P") (if (not (org-at-table-p)) (error "Not at a table")) - (let ((line (buffer-substring-no-properties (point-at-bol) (point-at-eol))) + (let ((line + (org-expand-wide-chars + (buffer-substring-no-properties (point-at-bol) (point-at-eol)))) (col (current-column)) start) (if (string-match "^[ \t]*|-" line) @@ -6725,9 +8163,19 @@ With prefix ARG, insert above the current line." (if (equal (char-before (point)) ?+) (progn (backward-delete-char 1) (insert "|"))) (insert "\n") - (beginning-of-line 0) + (beginning-of-line (if arg 1 -1)) (move-to-column col))) +(defun org-expand-wide-chars (s) + "Expand wide characters to spaces." + (let (w a) + (mapconcat + (lambda (x) + (if (> (setq w (string-width (setq a (char-to-string x)))) 1) + (make-string w ?\ ) + a)) + s ""))) + (defun org-table-kill-row () "Delete the current row or horizontal line from the table." (interactive) @@ -6738,6 +8186,49 @@ With prefix ARG, insert above the current line." (if (not (org-at-table-p)) (beginning-of-line 0)) (move-to-column col))) +(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)) + (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))) (defun org-table-cut-region (beg end) "Copy region in table to the clipboard and blank all relevant fields." @@ -6839,8 +8330,9 @@ blindly applies a recipe that works for simple tables." ;; 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 2) (< (point) end)) + (while (progn (beginning-of-line 3) (< (point) end)) (org-table-insert-hline)) (goto-char beg) (setq end (move-marker end (org-table-end))) @@ -6929,7 +8421,7 @@ 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 'length words))) + (maxword (apply 'max (mapcar 'string-width words))) w ll) (cond (width (org-do-wrap words (max maxword width))) @@ -8006,6 +9498,7 @@ to execute outside of tables." '("\C-c=" org-table-eval-formula) '("\C-c'" org-table-edit-formulas) '("\C-c*" org-table-recalculate) + '("\C-c^" org-table-sort-lines) '([(control ?#)] org-table-rotate-recalc-marks))) elt key fun cmd) (while (setq elt (pop bindings)) @@ -8056,6 +9549,7 @@ to execute outside of tables." ["Move Row Down" org-metadown :active (org-at-table-p) :keys "M-<down>"] ["Delete Row" org-shiftmetaup :active (org-at-table-p) :keys "M-S-<up>"] ["Insert Row" org-shiftmetadown :active (org-at-table-p) :keys "M-S-<down>"] + ["Sort lines in region" org-table-sort-lines (org-at-table-p) :keys "C-c ^"] "--" ["Insert Hline" org-table-insert-hline :active (org-at-table-p) :keys "C-c -"]) ("Rectangle" @@ -8831,7 +10325,8 @@ headlines. The default is 3. Lower levels will become bulleted lists." (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) - (let* ((region-p (org-region-active-p)) + (let* ((style org-export-html-style) + (region-p (org-region-active-p)) (region (buffer-substring (if region-p (region-beginning) (point-min)) @@ -8852,6 +10347,11 @@ headlines. The default is 3. Lower levels will become bulleted lists." (options nil) (quote-re (concat "^\\*+[ \t]*" org-quote-string "\\>")) (inquote nil) + (infixed nil) + (in-local-list nil) + (local-list-num nil) + (local-list-indent nil) + (llt org-plain-list-ordered-item-terminator) (email user-mail-address) (language org-export-default-language) (text nil) @@ -8868,6 +10368,7 @@ headlines. The default is 3. Lower levels will become bulleted lists." (coding-system-get coding-system 'mime-charset))) table-open type table-buffer table-orig-buffer + ind start-is-num starter ) (message "Exporting...") @@ -8892,17 +10393,20 @@ headlines. The default is 3. Lower levels will become bulleted lists." ;; File header (insert (format - "<html lang=\"%s\"><head> + "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.0 Transitional//EN\" + \"http://www.w3.org/TR/REC-html40/loose.dtd\"> +<html lang=\"%s\"><head> <title>%s</title> <meta http-equiv=\"Content-Type\" content=\"text/html;charset=%s\"> <meta name=generator content=\"Org-mode\"> <meta name=generated content=\"%s %s\"> <meta name=author content=\"%s\"> +%s </head><body> " language (org-html-expand title) (or charset "iso-8859-1") - date time author)) - (if title (insert (concat "<H1 align=\"center\">" + date time author style)) + (if title (insert (concat "<H1 class=\"title\">" (org-html-expand title) "</H1>\n"))) (if author (insert (concat (nth 1 lang-words) ": " author "\n"))) (if email (insert (concat "<a href=\"mailto:" email "\"><" @@ -8952,8 +10456,8 @@ headlines. The default is 3. Lower levels will become bulleted lists." (insert (format (if todo - "<li><a href=\"#sec-%d\"><span style='color:red'>%s</span></a></li>\n" - "<li><a href=\"#sec-%d\">%s</a></li>\n") + "<li><a href=\"#sec-%d\"><span class=\"todo\">%s</span></a>\n" + "<li><a href=\"#sec-%d\">%s</a>\n") head-count txt)) (setq org-last-level level)) )))) @@ -8966,15 +10470,30 @@ headlines. The default is 3. Lower levels will become bulleted lists." (org-init-section-numbers) (while (setq line (pop lines) origline line) - ;; end of quote? - (when (and inquote (string-match "^\\*+" line)) - (insert "</pre>\n") - (setq inquote nil)) - ;; inquote - (if inquote - (progn - (insert line "\n") - (setq line (org-html-expand line))) ;;????? FIXME: not needed? + (catch 'nextline + + ;; end of quote section? + (when (and inquote (string-match "^\\*+" line)) + (insert "</pre>\n") + (setq inquote nil)) + ;; inside a quote section? + (when inquote + (insert (org-html-protect line) "\n") + (throw 'nextline nil)) + + ;; verbatim lines + (when (and org-export-with-fixed-width + (string-match "^[ \t]*:\\(.*\\)" line)) + (when (not infixed) + (setq infixed t) + (insert "<pre>\n")) + (insert (org-html-protect (match-string 1 line)) "\n") + (when (and lines + (not (string-match "^[ \t]*\\(:.*\\)" + (car lines)))) + (setq infixed nil) + (insert "</pre>\n")) + (throw 'nextline nil)) ;; Protect the links (setq start 0) @@ -8984,122 +10503,150 @@ headlines. The default is 3. Lower levels will become bulleted lists." (concat "\000" (match-string 1 line) "\000") t t line))) - ;; replace "<" and ">" by "<" and ">" + ;; replace "&" by "&", "<" and ">" by "<" and ">" ;; handle @<..> HTML tags (replace "@>..<" by "<..>") (setq line (org-html-expand line)) - ;; Verbatim lines - (if (and org-export-with-fixed-width - (string-match "^[ \t]*:\\(.*\\)" line)) - (progn - (let ((l (match-string 1 line))) - (while (string-match " " l) - (setq l (replace-match " " t t l))) - (insert "\n<span style='font-family:Courier'>" - l "</span>" - (if (and lines - (not (string-match "^[ \t]+\\(:.*\\)" - (car lines)))) - "<br>\n" "\n")))) - - (setq start 0) - (while (string-match org-protected-link-regexp line start) - (setq start (- (match-end 0) 2)) - (setq type (match-string 1 line)) - (cond - ((member type '("http" "https" "ftp" "mailto" "news")) - ;; standard URL - (setq line (replace-match + ;; Format the links + (setq start 0) + (while (string-match org-protected-link-regexp line start) + (setq start (- (match-end 0) 2)) + (setq type (match-string 1 line)) + (cond + ((member type '("http" "https" "ftp" "mailto" "news")) + ;; standard URL + (setq line (replace-match ; "<a href=\"\\1:\\2\"><\\1:\\2></a>" - "<a href=\"\\1:\\2\">\\1:\\2</a>" - nil nil line))) - ((string= type "file") - ;; FILE link - (let* ((filename (match-string 2 line)) - (abs-p (file-name-absolute-p filename)) - (thefile (if abs-p (expand-file-name filename) filename)) - (thefile (save-match-data - (if (string-match ":[0-9]+$" thefile) - (replace-match "" t t thefile) - thefile))) - (file-is-image-p - (save-match-data - (string-match (org-image-file-name-regexp) thefile)))) - (setq line (replace-match - (if (and org-export-html-inline-images - file-is-image-p) - (concat "<img src=\"" thefile "\"/>") - (concat "<a href=\"" thefile "\">\\1:\\2</a>")) - nil nil line)))) - - ((member type '("bbdb" "vm" "wl" "rmail" "gnus" "shell")) + "<a href=\"\\1:\\2\">\\1:\\2</a>" + nil nil line))) + ((string= type "file") + ;; FILE link + (let* ((filename (match-string 2 line)) + (abs-p (file-name-absolute-p filename)) + (thefile (if abs-p (expand-file-name filename) filename)) + (thefile (save-match-data + (if (string-match ":[0-9]+$" thefile) + (replace-match "" t t thefile) + thefile))) + (file-is-image-p + (save-match-data + (string-match (org-image-file-name-regexp) thefile)))) (setq line (replace-match - "<i><\\1:\\2></i>" nil nil line))))) - - ;; TODO items - (if (and (string-match org-todo-line-regexp line) - (match-beginning 2)) - (if (equal (match-string 2 line) org-done-string) - (setq line (replace-match - "<span style='color:green'>\\2</span>" - nil nil line 2)) - (setq line (replace-match "<span style='color:red'>\\2</span>" - nil nil line 2)))) - - ;; DEADLINES - (if (string-match org-deadline-line-regexp line) - (progn - (if (save-match-data - (string-match "<a href" - (substring line 0 (match-beginning 0)))) - nil ; Don't do the replacement - it is inside a link - (setq line (replace-match "<span style='color:red'>\\&</span>" - nil nil line 1))))) - + (if (and org-export-html-inline-images + file-is-image-p) + (concat "<img src=\"" thefile "\"/>") + (concat "<a href=\"" thefile "\">\\1:\\2</a>")) + nil nil line)))) + + ((member type '("bbdb" "vm" "wl" "rmail" "gnus" "shell")) + (setq line (replace-match + "<i><\\1:\\2></i>" nil nil line))))) + + ;; TODO items + (if (and (string-match org-todo-line-regexp line) + (match-beginning 2)) + (if (equal (match-string 2 line) org-done-string) + (setq line (replace-match + "<span class=\"done\">\\2</span>" + nil nil line 2)) + (setq line (replace-match "<span class=\"todo\">\\2</span>" + nil nil line 2)))) - (cond - ((string-match "^\\(\\*+\\)[ \t]*\\(.*\\)" line) - ;; This is a headline - (setq level (- (match-end 1) (match-beginning 1)) - txt (match-string 2 line)) - (if (<= level umax) (setq head-count (+ head-count 1))) - (org-html-level-start level txt umax - (and org-export-with-toc (<= level umax)) - head-count) - ;; QUOTES - (when (string-match quote-re line) - (insert "<pre>") - (setq inquote t))) - - ((and org-export-with-tables - (string-match "^\\([ \t]*\\)\\(|\\|\\+-+\\+\\)" line)) - (if (not table-open) - ;; New table starts - (setq table-open t table-buffer nil table-orig-buffer nil)) - ;; Accumulate lines - (setq table-buffer (cons line table-buffer) - table-orig-buffer (cons origline table-orig-buffer)) - (when (or (not lines) - (not (string-match "^\\([ \t]*\\)\\(|\\|\\+-+\\+\\)" - (car lines)))) - (setq table-open nil - table-buffer (nreverse table-buffer) - table-orig-buffer (nreverse table-orig-buffer)) - (insert (org-format-table-html table-buffer table-orig-buffer)))) - (t - ;; Normal lines - ;; Lines starting with "-", and empty lines make new paragraph. - ;; FIXME: Should we add + and *? - (if (string-match "^ *-\\|^[ \t]*$" line) (insert "<p>")) - (insert line (if org-export-preserve-breaks "<br>\n" "\n")))) - ))) - (if org-export-html-with-timestamp - (insert org-export-html-html-helper-timestamp)) - (insert "</body>\n</html>\n") - (debug) - (normal-mode) - (save-buffer) - (goto-char (point-min))))) + ;; DEADLINES + (if (string-match org-deadline-line-regexp line) + (progn + (if (save-match-data + (string-match "<a href" + (substring line 0 (match-beginning 0)))) + nil ; Don't do the replacement - it is inside a link + (setq line (replace-match "<span class=\"deadline\">\\&</span>" + nil nil line 1))))) + (cond + ((string-match "^\\(\\*+\\)[ \t]*\\(.*\\)" line) + ;; This is a headline + (setq level (- (match-end 1) (match-beginning 1)) + txt (match-string 2 line)) + (if (<= level umax) (setq head-count (+ head-count 1))) + (when in-local-list + ;; Close any local lists before inserting a new header line + (while local-list-num + (insert (if (car local-list-num) "</ol>\n" "</ul>")) + (pop local-list-num)) + (setq local-list-indent nil + in-local-list nil)) + (org-html-level-start level txt umax + (and org-export-with-toc (<= level umax)) + head-count) + ;; QUOTES + (when (string-match quote-re line) + (insert "<pre>") + (setq inquote t))) + + ((and org-export-with-tables + (string-match "^\\([ \t]*\\)\\(|\\|\\+-+\\+\\)" line)) + (if (not table-open) + ;; New table starts + (setq table-open t table-buffer nil table-orig-buffer nil)) + ;; Accumulate lines + (setq table-buffer (cons line table-buffer) + table-orig-buffer (cons origline table-orig-buffer)) + (when (or (not lines) + (not (string-match "^\\([ \t]*\\)\\(|\\|\\+-+\\+\\)" + (car lines)))) + (setq table-open nil + table-buffer (nreverse table-buffer) + table-orig-buffer (nreverse table-orig-buffer)) + (insert (org-format-table-html table-buffer table-orig-buffer)))) + (t + ;; Normal lines + (when (and (> org-export-plain-list-max-depth 0) + (string-match + (cond + ((eq llt t) "^\\([ \t]*\\)\\(\\([-+*]\\)\\|\\([0-9]+[.)]\\)\\)?\\( +[^ \t\n\r]\\|[ \t]*$\\)") + ((= llt ?.) "^\\([ \t]*\\)\\(\\([-+*]\\)\\|\\([0-9]+\\.\\)\\)?\\( +[^ \t\n\r]\\|[ \t]*$\\)") + ((= llt ?\)) "^\\( \t]*\\)\\(\\([-+*]\\)\\|\\([0-9]+)\\)\\)?\\( +[^ \t\n\r]\\|[ \t]*$\\)") + (t (error "Invalid value of `org-plain-list-ordered-item-terminator'"))) + line)) + (setq ind (org-get-string-indentation line) + start-is-num (match-beginning 4) + starter (if (match-beginning 2) (match-string 2 line)) + line (substring line (match-beginning 5))) + (unless (string-match "[^ \t]" line) + ;; empty line. Pretend indentation is large. + (setq ind (1+ (or (car local-list-indent) 1)))) + (while (and in-local-list + (or (and (= ind (car local-list-indent)) + (not starter)) + (< ind (car local-list-indent)))) + (insert (if (car local-list-num) "</ol>\n" "</ul>")) + (pop local-list-num) (pop local-list-indent) + (setq in-local-list local-list-indent)) + (cond + ((and starter + (or (not in-local-list) + (> ind (car local-list-indent))) + (< (length local-list-indent) + org-export-plain-list-max-depth)) + ;; Start new (level of ) list + (insert (if start-is-num "<ol>\n<li>\n" "<ul>\n<li>\n")) + (push start-is-num local-list-num) + (push ind local-list-indent) + (setq in-local-list t)) + (starter + ;; continue current list + (insert "<li>\n")))) + ;; Empty lines start a new paragraph. If hand-formatted lists + ;; are not fully interpreted, lines starting with "-", "+", "*" + ;; also start a new paragraph. + (if (string-match "^ [-+*]-\\|^[ \t]*$" line) (insert "<p>")) + (insert line (if org-export-preserve-breaks "<br>\n" "\n")))) + )) + (if org-export-html-with-timestamp + (insert org-export-html-html-helper-timestamp)) + (insert "</body>\n</html>\n") + (normal-mode) + (save-buffer) + (goto-char (point-min))))) (defun org-format-table-html (lines olines) "Find out which HTML converter to use and return the HTML code." @@ -9152,7 +10699,7 @@ headlines. The default is 3. Lower levels will become bulleted lists." (mapconcat (lambda (x) (if head (concat "<th>" x "</th>") - (concat "<td valign=\"top\">" x "</td>"))) + (concat "<td>" x "</td>"))) fields "") "</tr>\n")))) (setq html (concat html "</table>\n")) @@ -9191,10 +10738,8 @@ But it has the disadvantage, that no cell- or row-spanning is allowed." (lambda (x) (if (equal x "") (setq x empty)) (if head - (concat "<th valign=\"top\">" x - "</th>\n") - (concat "<td valign=\"top\">" x - "</td>\n"))) + (concat "<th>" x "</th>\n") + (concat "<td>" x "</td>\n"))) field-buffer "\n") "</tr>\n")) (setq head nil) @@ -9229,18 +10774,28 @@ But it has the disadvantage, that Org-mode's HTML conversions cannot be used." (set-buffer " org-tmp2 ") (buffer-substring (point-min) (point-max)))) +(defun org-html-protect (s) + ;; convert & to &, < to < and > to > + (let ((start 0)) + (while (string-match "&" s start) + (setq s (replace-match "&" t t s) + start (1+ (match-beginning 0)))) + (while (string-match "<" s) + (setq s (replace-match "<" t t s))) + (while (string-match ">" s) + (setq s (replace-match ">" t t s)))) + s) + (defun org-html-expand (string) "Prepare STRING for HTML export. Applies all active conversions." ;; First check if there is a link in the line - if yes, apply conversions ;; only before the start of the link. + ;; FIXME: This is no longer correct, because links now have an end. (let* ((m (string-match org-link-regexp string)) (s (if m (substring string 0 m) string)) (r (if m (substring string m) ""))) - ;; convert < to < and > to > - (while (string-match "<" s) - (setq s (replace-match "<" t t s))) - (while (string-match ">" s) - (setq s (replace-match ">" t t s))) + ;; convert & to &, < to < and > to > + (setq s (org-html-protect s)) (if org-export-html-expand (while (string-match "@<\\([^&]*\\)>" s) (setq s (replace-match "<\\1>" nil nil s)))) @@ -9392,7 +10947,6 @@ stacked delimiters is N. Escaping delimiters is not possible." "Terminate one level in HTML export." (insert "</ul>")) - ;; Variable holding the vector with section numbers (defvar org-section-numbers (make-vector org-level-max 0)) @@ -9440,9 +10994,6 @@ When LEVEL is non-nil, increase section numbers on that level." string)) - - - (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 @@ -9490,7 +11041,7 @@ file and store it under the name `org-combined-agenda-icalendar-file'." (let ((standard-output ical-buffer)) (if combine (and (not started) (setq started t) - (org-start-icalendar-file "OrgMode")) + (org-start-icalendar-file org-icalendar-combined-name)) (org-start-icalendar-file category)) (org-print-icalendar-entries combine category) (when (or (and combine (not files)) (not combine)) @@ -9513,7 +11064,7 @@ When COMBINE is non nil, add the category to each line." (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 donep tmp pri) + hd ts ts2 state (inc t) pos scheduledp deadlinep tmp pri) (save-excursion (goto-char (point-min)) (while (re-search-forward org-ts-regexp nil t) @@ -9531,10 +11082,11 @@ When COMBINE is non nil, add the category to each line." pos) deadlinep (string-match org-deadline-regexp tmp) scheduledp (string-match org-scheduled-regexp tmp) - donep (org-entry-is-done-p))) + ;; donep (org-entry-is-done-p) + )) (if (or (string-match org-tr-regexp hd) (string-match org-ts-regexp hd)) - (setq hd (replace-match "" t t hd))) + (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"))) @@ -9572,15 +11124,14 @@ END:VTODO\n" (defun org-start-icalendar-file (name) "Start an iCalendar file by inserting the header." (let ((user user-full-name) - (calname "something") (name (or name "unknown")) - (timezone "FIXME")) + (timezone (cadr (current-time-zone)))) (princ (format "BEGIN:VCALENDAR VERSION:2.0 X-WR-CALNAME:%s PRODID:-//%s//Emacs with Org-mode//EN -X-WR-TIMEZONE:Europe/Amsterdam +X-WR-TIMEZONE:%s CALSCALE:GREGORIAN\n" name user timezone)))) (defun org-finish-icalendar-file () @@ -9610,10 +11161,10 @@ a time), or the day by one (if it does not contain a time)." ;; - Bindings in Org-mode map are currently ;; 0123456789abcdefghijklmnopqrstuvwxyz!?@#$%^&-+*/=()_{}[]:;"|,.<>~`'\t the alphabet -;; abcd fgh j lmnopqrstuvwxyz ? #$ -+*/= [] ; |,.<>~ \t necessary bindings +;; abcd fgh j lmnopqrstuvwxyz!? #$ -+*/= [] ; |,.<>~ \t necessary bindings ;; e (?) useful from outline-mode ;; i k @ expendable from outline-mode -;; 0123456789 ! %^& ()_{} " `' free +;; 0123456789 %^& ()_{} " `' free ;; Make `C-c C-x' a prefix key (define-key org-mode-map "\C-c\C-x" (make-sparse-keymap)) @@ -9661,10 +11212,10 @@ a time), or the day by one (if it does not contain a time)." (define-key org-mode-map [?\C-c ?\C-x (up)] 'org-shiftup) (define-key org-mode-map (org-key 'S-down) 'org-shiftdown) (define-key org-mode-map [?\C-c ?\C-x (down)] 'org-shiftdown) -(define-key org-mode-map (org-key 'S-left) 'org-timestamp-down-day) -(define-key org-mode-map [?\C-c ?\C-x (left)] 'org-timestamp-down-day) -(define-key org-mode-map (org-key 'S-right) 'org-timestamp-up-day) -(define-key org-mode-map [?\C-c ?\C-x (right)] 'org-timestamp-up-day) +(define-key org-mode-map (org-key 'S-left) 'org-shiftleft) +(define-key org-mode-map [?\C-c ?\C-x (left)] 'org-shiftleft) +(define-key org-mode-map (org-key 'S-right) 'org-shiftright) +(define-key org-mode-map [?\C-c ?\C-x (right)] 'org-shiftright) ;; All the other keys (define-key org-mode-map "\C-c$" 'org-archive-subtree) @@ -9676,6 +11227,7 @@ a time), or the day by one (if it does not contain a time)." (define-key org-mode-map "\C-c\C-v" 'org-show-todo-tree) (define-key org-mode-map "\C-c\C-w" 'org-check-deadlines) (define-key org-mode-map "\C-c/" 'org-occur) ; Minor-mode reserved +(define-key org-mode-map "\C-c\\" 'org-tags-sparse-tree) ; Minor-mode res. (define-key org-mode-map "\C-c\C-m" 'org-insert-heading) (define-key org-mode-map "\M-\C-m" 'org-insert-heading) (define-key org-mode-map "\C-c\C-l" 'org-insert-link) @@ -9687,10 +11239,12 @@ a time), or the day by one (if it does not contain a time)." (define-key org-mode-map "\C-c\C-y" 'org-evaluate-time-range) (define-key org-mode-map "\C-c>" 'org-goto-calendar) (define-key org-mode-map "\C-c<" 'org-date-from-calendar) -(define-key org-mode-map "\C-c[" 'org-add-file) +(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\C-r" 'org-timeline) (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-m" 'org-return) (define-key org-mode-map "\C-c?" 'org-table-current-column) @@ -9801,7 +11355,7 @@ COMMANDS is a list of alternating OLDDEF NEWDEF command names." (if (fboundp 'command-remapping) (define-key map (vector 'remap old) new) (substitute-key-definition old new map global-map))))) - + (when (eq org-enable-table-editor 'optimized) ;; If the user wants maximum table support, we need to hijack ;; some standard editing functions @@ -9813,7 +11367,7 @@ COMMANDS is a list of alternating OLDDEF NEWDEF command names." (defun org-shiftcursor-error () "Throw an error because Shift-Cursor command was applied in wrong context." - (error "This command is only active in tables and on headlines")) + (error "This command is active in special context like tables, headlines or timestamps")) (defun org-shifttab () "Global visibility cycling or move to previous table field. @@ -9832,6 +11386,7 @@ See the individual commands for more information." (cond ((org-at-table-p) (org-table-delete-column)) ((org-on-heading-p) (org-promote-subtree)) + ((org-at-item-p) (call-interactively 'org-outdent-item)) (t (org-shiftcursor-error)))) (defun org-shiftmetaright () @@ -9842,30 +11397,36 @@ See the individual commands for more information." (cond ((org-at-table-p) (org-table-insert-column)) ((org-on-heading-p) (org-demote-subtree)) + ((org-at-item-p) (call-interactively 'org-indent-item)) (t (org-shiftcursor-error)))) (defun org-shiftmetaup (&optional arg) "Move subtree up or kill table row. -Calls `org-move-subtree-up' or `org-table-kill-row', depending on context. -See the individual commands for more information." +Calls `org-move-subtree-up' or `org-table-kill-row' or +`org-move-item-up' depending on context. See the individual commands +for more information." (interactive "P") (cond ((org-at-table-p) (org-table-kill-row)) ((org-on-heading-p) (org-move-subtree-up arg)) + ((org-at-item-p) (org-move-item-up arg)) (t (org-shiftcursor-error)))) (defun org-shiftmetadown (&optional arg) "Move subtree down or insert table row. -Calls `org-move-subtree-down' or `org-table-insert-row', depending on context. -See the individual commands for more information." +Calls `org-move-subtree-down' or `org-table-insert-row' or +`org-move-item-down', depending on context. See the individual +commands for more information." (interactive "P") (cond ((org-at-table-p) (org-table-insert-row arg)) ((org-on-heading-p) (org-move-subtree-down arg)) + ((org-at-item-p) (org-move-item-down arg)) (t (org-shiftcursor-error)))) (defun org-metaleft (&optional arg) "Promote heading or move table column to left. Calls `org-do-promote' or `org-table-move-column', depending on context. +With no specific context, calls the Emacs default `backward-word'. See the individual commands for more information." (interactive "P") (cond @@ -9876,6 +11437,7 @@ See the individual commands for more information." (defun org-metaright (&optional arg) "Demote subtree or move table column to right. Calls `org-do-demote' or `org-table-move-column', depending on context. +With no specific context, calls the Emacs default `forward-word'. See the individual commands for more information." (interactive "P") (cond @@ -9885,22 +11447,26 @@ See the individual commands for more information." (defun org-metaup (&optional arg) "Move subtree up or move table row up. -Calls `org-move-subtree-up' or `org-table-move-row', depending on context. -See the individual commands for more information." +Calls `org-move-subtree-up' or `org-table-move-row' or +`org-move-item-up', depending on context. See the individual commands +for more information." (interactive "P") (cond ((org-at-table-p) (org-table-move-row 'up)) ((org-on-heading-p) (org-move-subtree-up arg)) + ((org-at-item-p) (org-move-item-up arg)) (t (org-shiftcursor-error)))) (defun org-metadown (&optional arg) "Move subtree down or move table row down. -Calls `org-move-subtree-down' or `org-table-move-row', depending on context. -See the individual commands for more information." +Calls `org-move-subtree-down' or `org-table-move-row' or +`org-move-item-down', depending on context. See the individual +commands for more information." (interactive "P") (cond ((org-at-table-p) (org-table-move-row nil)) ((org-on-heading-p) (org-move-subtree-down arg)) + ((org-at-item-p) (org-move-item-down arg)) (t (org-shiftcursor-error)))) (defun org-shiftup (&optional arg) @@ -9921,6 +11487,22 @@ See the individual commands for more information." ((org-at-timestamp-p) (org-timestamp-down arg)) (t (org-priority-down)))) +(defun org-shiftright () + "Next TODO keyword or timestamp one day later, depending on context." + (interactive) + (cond + ((org-at-timestamp-p) (org-timestamp-up-day)) + ((org-on-heading-p) (org-todo 'right)) + (t (org-shiftcursor-error)))) + +(defun org-shiftleft () + "Previous TODO keyword or timestamp one day earlier, depending on context." + (interactive) + (cond + ((org-at-timestamp-p) (org-timestamp-down-day)) + ((org-on-heading-p) (org-todo 'left)) + (t (org-shiftcursor-error)))) + (defun org-copy-special () "Copy region in table or copy current subtree. Calls `org-table-copy' or `org-copy-subtree', depending on context. @@ -9952,12 +11534,18 @@ When the cursor is inside a table created by the table.el package, activate that table. Otherwise, if the cursor is at a normal table created with org.el, re-align that table. This command works even if the automatic table editor has been turned off. + +If the cursor is in a headline, prompt for tags and insert them into +the current line, aligned to `org-tags-column'. When in a headline and +called with prefix arg, realign all tags in the current buffer. + If the cursor is in one of the special #+KEYWORD lines, this triggers scanning the buffer for these lines and updating the information. If the cursor is on a #+TBLFM line, re-apply the formulae to the table." (interactive "P") (let ((org-enable-table-editor t)) (cond + ((org-on-heading-p) (org-set-tags arg)) ((org-at-table.el-p) (require 'table) (beginning-of-line 1) @@ -9969,6 +11557,8 @@ If the cursor is on a #+TBLFM line, re-apply the formulae to the table." (org-table-recalculate t) (org-table-maybe-recalculate-line)) (org-table-align)) + ((org-at-item-p) + (org-renumber-ordered-list (prefix-numeric-value arg))) ((save-excursion (beginning-of-line 1) (looking-at "#\\+\\([A-Z]+\\)")) (cond ((equal (match-string 1) "TBLFM") @@ -9981,11 +11571,13 @@ If the cursor is on a #+TBLFM line, re-apply the formulae to the table." (org-mode-restart)))) ((org-region-active-p) (org-table-convert-region (region-beginning) (region-end) arg)) - ((and (region-beginning) (region-end)) + ((condition-case nil + (and (region-beginning) (region-end)) + (error nil)) (if (y-or-n-p "Convert inactive region to table? ") (org-table-convert-region (region-beginning) (region-end) arg) (error "Abort"))) - (t (error "No table at point, and no region to make one"))))) + (t (error "C-c C-c can do nothing useful at this location."))))) (defun org-mode-restart () "Restart Org-mode, to scan again for special lines. @@ -10013,7 +11605,7 @@ See the individual commands for more information." (cond ((org-at-table-p) (org-table-wrap-region arg)) - (t (org-insert-heading)))) + (t (org-insert-heading arg)))) ;;; Menu entries @@ -10038,6 +11630,7 @@ See the individual commands for more information." ["Move Row Down" org-metadown (org-at-table-p)] ["Delete Row" org-shiftmetaup (org-at-table-p)] ["Insert Row" org-shiftmetadown (org-at-table-p)] + ["Sort lines in region" org-table-sort-lines (org-at-table-p)] "--" ["Insert Hline" org-table-insert-hline (org-at-table-p)]) ("Rectangle" @@ -10107,6 +11700,7 @@ See the individual commands for more information." ("TODO Lists" ["TODO/DONE/-" org-todo t] ["Show TODO Tree" org-show-todo-tree t] + ["Global TODO list" org-todo-list t] "--" ["Set Priority" org-priority t] ["Priority Up" org-shiftup t] @@ -10126,13 +11720,13 @@ See the individual commands for more information." ["Goto Calendar" org-goto-calendar t] ["Date from Calendar" org-date-from-calendar t]) "--" - ("Timeline/Agenda" - ["Show TODO Tree this File" org-show-todo-tree t] - ["Check Deadlines this File" org-check-deadlines t] - ["Timeline Current File" org-timeline t] - "--" - ["Agenda" org-agenda t]) + ["Agenda Command" org-agenda t] ("File List for Agenda") + ("Special views current file" + ["TODO Tree" org-show-todo-tree t] + ["Check Deadlines" org-check-deadlines t] + ["Timeline" org-timeline t] + ["Tags Tree" org-tags-sparse-tree t]) "--" ("Hyperlinks" ["Store Link (Global)" org-store-link t] @@ -10179,8 +11773,9 @@ With optional NODE, go directly to that node." (append (list ["Edit File List" (customize-variable 'org-agenda-files) t] - ["Add Current File to List" org-add-file t] + ["Add/Move Current File to Front of List" org-agenda-file-to-front t] ["Remove Current File from List" org-remove-file t] + ["Cycle through agenda files" org-cycle-agenda-files t] "--") (mapcar 'org-file-menu-entry org-agenda-files)))) @@ -10237,6 +11832,58 @@ With optional NODE, go directly to that node." (goto-char pos) (move-to-column col))) +;; Paragraph filling stuff. +;; We want this to be just right, so use the full arsenal. +;; FIXME: This very likely does not work correctly for XEmacs, because the +;; filladapt package works slightly differently. + +(defun org-set-autofill-regexps () + (interactive) + ;; In the paragraph separator we include headlines, because filling + ;; text in a line directly attached to a headline would otherwise + ;; fill the headline as well. + (set (make-local-variable 'paragraph-separate) "\f\\|\\*\\|[ ]*$\\|[ \t]*[:|]") + ;; The paragraph starter includes hand-formatted lists. + (set (make-local-variable 'paragraph-start) + "\f\\|[ ]*$\\|\\([*\f]+\\)\\|[ \t]*\\([-+*]\\|[0-9]+[.)][ \t]+\\)\\|[ \t]*[:|]") + ;; Inhibit auto-fill for headers, tables and fixed-width lines. + ;; But only if the user has not turned off tables or fixed-width regions + (set (make-local-variable 'auto-fill-inhibit-regexp) + (concat "\\*\\|#" + (if (or org-enable-table-editor org-enable-fixed-width-editor) + (concat + "\\|[ \t]*[" + (if org-enable-table-editor "|" "") + (if org-enable-fixed-width-editor ":" "") + "]")))) + ;; We use our own fill-paragraph function, to make sure that tables + ;; and fixed-width regions are not wrapped. That function will pass + ;; through to `fill-paragraph' when appropriate. + (set (make-local-variable 'fill-paragraph-function) 'org-fill-paragraph) + ;; Adaptive filling: To get full control, first make sure that + ;; `adaptive-fill-regexp' never matches. Then install our won matcher. + (setq adaptive-fill-regexp "\000") + (setq adaptive-fill-function 'org-adaptive-fill-function)) + +(defun org-fill-paragraph (&optional justify) + "Re-align a table, pass through to fill-paragraph if no table." + (let ((table-p (org-at-table-p)) + (table.el-p (org-at-table.el-p))) + (cond ((equal (char-after (point-at-bol)) ?*) t) ; skip headlines + (table.el-p t) ; skip table.el tables + (table-p (org-table-align) t) ; align org-mode tables + (t nil)))) ; call paragraph-fill + +;; For reference, this is the default value of adaptive-fill-regexp +;; "[ \t]*\\([-|#;>*]+[ \t]*\\|(?[0-9]+[.)][ \t]*\\)*" + +(defun org-adaptive-fill-function () + "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-region-active-p () @@ -10289,12 +11936,18 @@ that can be added." t) "\\'")))) -;; Functions needed for compatibility with old outline.el +;; Functions needed for compatibility with old outline.el. + +;; Programming for the old outline.el (that uses selective display +;; instead of `invisible' text properties) is a nightmare, mostly +;; because regular expressions can no longer be anchored at +;; beginning/end of line. Therefore a number of function need special +;; treatment when the old outline.el is being used. ;; The following functions capture almost the entire compatibility code -;; between the different versions of outline-mode. The only other place -;; where this is important are the font-lock-keywords. Search for -;; `org-noutline-p' to find it. +;; between the different versions of outline-mode. The only other +;; places where this is important are the font-lock-keywords, and in +;; `org-export-copy-visible'. Search for `org-noutline-p' to find them. ;; 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? @@ -10311,8 +11964,11 @@ to a visible line beginning. This makes the function of C-a more intuitive." (backward-char 1) (beginning-of-line 1)) (forward-char 1)))) + (when org-noutline-p (define-key org-mode-map "\C-a" 'org-beginning-of-line)) +;; FIXME: should I use substitute-key-definition to reach other bindings +;; of beginning-of-line? (defun org-invisible-p () "Check if point is at a character currently not visible." @@ -10330,7 +11986,8 @@ to a visible line beginning. This makes the function of C-a more intuitive." Only visible heading lines are considered, unless INVISIBLE-OK is non-nil." (if org-noutline-p (outline-back-to-heading invisible-ok) - (if (looking-at outline-regexp) + (if (and (memq (char-before) '(?\n ?\r)) + (looking-at outline-regexp)) t (if (re-search-backward (concat (if invisible-ok "\\([\r\n]\\|^\\)" "^") outline-regexp) @@ -10411,6 +12068,27 @@ When ENTRY is non-nil, show the entire entry." flag (if flag ?\r ?\n)))))) +(defun org-end-of-subtree (&optional invisible-OK) + ;; This is an exact copy of the original function, but it uses + ;; `org-back-to-heading', to make it work also in invisible + ;; trees. And is uses an invisible-OK argument. + ;; Under Emacs this is not needed, but the old outline.el needs this fix. + (org-back-to-heading invisible-OK) + (let ((opoint (point)) + (first t) + (level (funcall outline-level))) + (while (and (not (eobp)) + (or first (> (funcall outline-level) level))) + (setq first nil) + (outline-next-heading)) + (if (memq (preceding-char) '(?\n ?\^M)) + (progn + ;; Go to end of line before heading + (forward-char -1) + (if (memq (preceding-char) '(?\n ?\^M)) + ;; leave blank line before heading + (forward-char -1)))))) + (defun org-show-subtree () "Show everything after this heading at deeper levels." (outline-flag-region @@ -10468,3 +12146,26 @@ Show the heading too, if it is currently invisible." ;; arch-tag: e77da1a7-acc7-4336-b19e-efa25af3f9fd ;;; org.el ends here + + +(defun org-get-tags-at (&optional pos) + "Get a list of all headline targs 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_:]+\\):[ \t]*\\([\n\r]\\|\\'\\)") + (setq tags (append (org-split-string (match-string 1) ":") tags))) + (or org-use-tag-inheritance (error "")) + (org-up-heading-all 1)) + (error nil)))) + (message "%s" tags) + tags)) + diff --git a/lisp/textmodes/paragraphs.el b/lisp/textmodes/paragraphs.el index 1ed43279c3d..b196001c799 100644 --- a/lisp/textmodes/paragraphs.el +++ b/lisp/textmodes/paragraphs.el @@ -159,7 +159,7 @@ to obtain the value of this variable." :group 'paragraphs :type '(choice regexp (const :tag "Use default value" nil))) -(defcustom sentence-end-base "[.?!][]\"'\xd0c9\x5397d)}]*" +(defcustom sentence-end-base "[.?!][]\"'$B!I$,1r}(B)}]*" "*Regexp matching the basic end of a sentence, not including following space." :group 'paragraphs :type 'string @@ -502,9 +502,9 @@ ones already marked." (interactive "*p") (transpose-subr 'forward-sentence arg)) -;;; Local Variables: -;;; coding: iso-2022-7bit -;;; End: +;; Local Variables: +;; coding: iso-2022-7bit +;; End: -;;; arch-tag: e727eb1a-527a-4464-b9d7-9d3ec0d1a575 +;; arch-tag: e727eb1a-527a-4464-b9d7-9d3ec0d1a575 ;;; paragraphs.el ends here diff --git a/lisp/textmodes/picture.el b/lisp/textmodes/picture.el index 5d528dec109..78741065100 100644 --- a/lisp/textmodes/picture.el +++ b/lisp/textmodes/picture.el @@ -661,60 +661,69 @@ Picture mode is invoked by the command \\[picture-mode]." ;;;###autoload (defun picture-mode () "Switch to Picture mode, in which a quarter-plane screen model is used. +\\<picture-mode-map> Printing characters replace instead of inserting themselves with motion afterwards settable by these commands: - C-c < Move left after insertion. - C-c > Move right after insertion. - C-c ^ Move up after insertion. - C-c . Move down after insertion. - C-c ` Move northwest (nw) after insertion. - C-c ' Move northeast (ne) after insertion. - C-c / Move southwest (sw) after insertion. - C-c \\ Move southeast (se) after insertion. - C-u C-c ` Move westnorthwest (wnw) after insertion. - C-u C-c ' Move eastnortheast (ene) after insertion. - C-u C-c / Move westsouthwest (wsw) after insertion. - C-u C-c \\ Move eastsoutheast (ese) after insertion. + + Move left after insertion: \\[picture-movement-left] + Move right after insertion: \\[picture-movement-right] + Move up after insertion: \\[picture-movement-up] + Move down after insertion: \\[picture-movement-down] + + Move northwest (nw) after insertion: \\[picture-movement-nw] + Move northeast (ne) after insertion: \\[picture-movement-ne] + Move southwest (sw) after insertion: \\[picture-movement-sw] + Move southeast (se) after insertion: \\[picture-movement-se] + + Move westnorthwest (wnw) after insertion: C-u \\[picture-movement-nw] + Move eastnortheast (ene) after insertion: C-u \\[picture-movement-ne] + Move westsouthwest (wsw) after insertion: C-u \\[picture-movement-sw] + Move eastsoutheast (ese) after insertion: C-u \\[picture-movement-se] + The current direction is displayed in the mode line. The initial direction is right. Whitespace is inserted and tabs are changed to spaces when required by movement. You can move around in the buffer with these commands: - \\[picture-move-down] Move vertically to SAME column in previous line. - \\[picture-move-up] Move vertically to SAME column in next line. - \\[picture-end-of-line] Move to column following last non-whitespace character. - \\[picture-forward-column] Move right inserting spaces if required. - \\[picture-backward-column] Move left changing tabs to spaces if required. - C-c C-f Move in direction of current picture motion. - C-c C-b Move in opposite direction of current picture motion. - Return Move to beginning of next line. + + Move vertically to SAME column in previous line: \\[picture-move-down] + Move vertically to SAME column in next line: \\[picture-move-up] + Move to column following last + non-whitespace character: \\[picture-end-of-line] + Move right, inserting spaces if required: \\[picture-forward-column] + Move left changing tabs to spaces if required: \\[picture-backward-column] + Move in direction of current picture motion: \\[picture-motion] + Move opposite to current picture motion: \\[picture-motion-reverse] + Move to beginning of next line: \\[next-line] + You can edit tabular text with these commands: - M-Tab Move to column beneath (or at) next interesting character. - `Indents' relative to a previous line. - Tab Move to next stop in tab stop list. - C-c Tab Set tab stops according to context of this line. - With ARG resets tab stops to default (global) value. - See also documentation of variable picture-tab-chars - which defines \"interesting character\". You can manually - change the tab stop list with command \\[edit-tab-stops]. + + Move to column beneath (or at) next interesting + character (see variable `picture-tab-chars'): \\[picture-tab-search] + Move to next stop in tab stop list: \\[picture-tab] + Set tab stops according to context of this line: \\[picture-set-tab-stops] + (With ARG, resets tab stops to default value.) + Change the tab stop list: \\[edit-tab-stops] + You can manipulate text with these commands: - C-d Clear (replace) ARG columns after point without moving. - C-c C-d Delete char at point - the command normally assigned to C-d. - \\[picture-backward-clear-column] Clear (replace) ARG columns before point, moving back over them. - \\[picture-clear-line] Clear ARG lines, advancing over them. The cleared - text is saved in the kill ring. - \\[picture-open-line] Open blank line(s) beneath current line. + Clear ARG columns after point without moving: \\[picture-clear-column] + Delete char at point: \\[delete-char] + Clear ARG columns backward: \\[picture-backward-clear-column] + Clear ARG lines, advancing over them: \\[picture-clear-line] + (the cleared text is saved in the kill ring) + Open blank line(s) beneath current line: \\[picture-open-line] + You can manipulate rectangles with these commands: - C-c C-k Clear (or kill) a rectangle and save it. - C-c C-w Like C-c C-k except rectangle is saved in named register. - C-c C-y Overlay (or insert) currently saved rectangle at point. - C-c C-x Like C-c C-y except rectangle is taken from named register. - C-c C-r Draw a rectangular box around mark and point. - \\[copy-rectangle-to-register] Copies a rectangle to a register. - \\[advertised-undo] Can undo effects of rectangle overlay commands - if invoked soon enough. -You can return to the previous mode with: - C-c C-c Which also strips trailing whitespace from every line. - Stripping is suppressed by supplying an argument. + Clear a rectangle and save it: \\[picture-clear-rectangle] + Clear a rectangle, saving in a named register: \\[picture-clear-rectangle-to-register] + Insert currently saved rectangle at point: \\[picture-yank-rectangle] + Insert rectangle from named register: \\[picture-yank-rectangle-from-register] + Draw a rectangular box around mark and point: \\[picture-draw-rectangle] + Copies a rectangle to a register: \\[copy-rectangle-to-register] + Undo effects of rectangle overlay commands: \\[advertised-undo] + +You can return to the previous mode with \\[picture-mode-exit], which +also strips trailing whitespace from every line. Stripping is suppressed +by supplying an argument. Entry to this mode calls the value of `picture-mode-hook' if non-nil. diff --git a/lisp/textmodes/reftex-vars.el b/lisp/textmodes/reftex-vars.el index 703f5b8dd2a..01e8a1b4ddf 100644 --- a/lisp/textmodes/reftex-vars.el +++ b/lisp/textmodes/reftex-vars.el @@ -1704,6 +1704,7 @@ The value of this variable will only have any effect when (defgroup reftex-fontification-configurations nil "Options concerning the faces used in RefTeX." + :link '(custom-group-link :tag "Font Lock Faces group" font-lock-faces) :group 'reftex) (defcustom reftex-use-fonts t diff --git a/lisp/textmodes/reftex.el b/lisp/textmodes/reftex.el index 8d0aa4bf80d..386f19f1797 100644 --- a/lisp/textmodes/reftex.el +++ b/lisp/textmodes/reftex.el @@ -2262,7 +2262,7 @@ IGNORE-WORDS List of words which should be removed from the string." (defun reftex-use-fonts () ;; Return t if we can and want to use fonts. - (and window-system + (and ; window-system reftex-use-fonts (featurep 'font-lock))) diff --git a/lisp/textmodes/sgml-mode.el b/lisp/textmodes/sgml-mode.el index 49bdd5a1cce..2a482109a6c 100644 --- a/lisp/textmodes/sgml-mode.el +++ b/lisp/textmodes/sgml-mode.el @@ -41,6 +41,7 @@ (defgroup sgml nil "SGML editing mode." + :link '(custom-group-link :tag "Font Lock Faces group" font-lock-faces) :group 'languages) (defcustom sgml-basic-offset 2 diff --git a/lisp/textmodes/texinfmt.el b/lisp/textmodes/texinfmt.el index d46d2f81fd4..15a15eb37fb 100644 --- a/lisp/textmodes/texinfmt.el +++ b/lisp/textmodes/texinfmt.el @@ -212,6 +212,8 @@ converted to Info is stored in a temporary buffer." ;;; Find a buffer to use. (switch-to-buffer (get-buffer-create texinfo-region-buffer-name)) + (setq buffer-read-only t) + (let ((inhibit-read-only t)) (erase-buffer) ;; Insert the header into the buffer. (insert header-text) @@ -313,7 +315,7 @@ converted to Info is stored in a temporary buffer." (goto-char (point-min)) (Info-tagify input-buffer) (goto-char (point-min)) - (message "Done."))) + (message "Done.")))) ;;;###autoload (defun texi2info (&optional nosplit) diff --git a/lisp/textmodes/texinfo.el b/lisp/textmodes/texinfo.el index 3507f6e57cf..8392e56dc00 100644 --- a/lisp/textmodes/texinfo.el +++ b/lisp/textmodes/texinfo.el @@ -1,4 +1,4 @@ -;;; texinfo.el --- major mode for editing Texinfo files +;;; texinfo.el --- major mode for editing Texinfo files -*- coding: iso-2022-7bit -*- ;; Copyright (C) 1985, 1988, 1989, 1990, 1991, 1992, 1993, 1996, 1997, ;; 2000, 2001, 2002, 2003, 2004, 2005 Free Software Foundation, Inc. @@ -46,6 +46,7 @@ (defgroup texinfo nil "Texinfo Mode." + :link '(custom-group-link :tag "Font Lock Faces group" font-lock-faces) :group 'docs) ;;;###autoload @@ -595,7 +596,7 @@ value of `texinfo-mode-hook'." (setq paragraph-start (concat "\b\\|@[a-zA-Z]*[ \n]\\|" paragraph-start)) (make-local-variable 'sentence-end-base) (setq sentence-end-base - "\\(@\\(end\\)?dots{}\\|[.?!]\\)[]\"'\xd0c9\x5397d)}]*") + "\\(@\\(end\\)?dots{}\\|[.?!]\\)[]\"'$B!I$,1r}(B)}]*") (make-local-variable 'adaptive-fill-mode) (setq adaptive-fill-mode nil) (make-local-variable 'fill-column) @@ -1059,5 +1060,5 @@ You are prompted for the job number (use a number shown by a previous (provide 'texinfo) -;;; arch-tag: 005d7c38-43b9-4b7d-aa1d-aea69bae73e1 +;; arch-tag: 005d7c38-43b9-4b7d-aa1d-aea69bae73e1 ;;; texinfo.el ends here diff --git a/lisp/textmodes/tildify.el b/lisp/textmodes/tildify.el index d3be75a7cb8..1810e41cbca 100644 --- a/lisp/textmodes/tildify.el +++ b/lisp/textmodes/tildify.el @@ -29,7 +29,7 @@ ;; This package can be typically used for adding forgotten tildes in TeX ;; sources or adding ` ' sequences in SGML (e.g. HTML) texts. ;; -;; For example, the Czech ortography requires avoiding one letter +;; For example, the Czech orthography requires avoiding one letter ;; prepositions at line endings. So they should be connected with the ;; following words by a tilde. Some users forget to do this all the ;; time. The purpose of this program is to check the text and suggest @@ -43,7 +43,7 @@ ;; The default variable settings are suited for Czech, so do not try to ;; understand them if you are not familiar with Czech grammar and spelling. ;; -;; The algorithm was inspired by Petr Ol¹įk's program `vlna'. Abbilities of +;; The algorithm was inspired by Petr Ol¹įk's program `vlna'. Abilities of ;; `tildify.el' are a little limited; if you have improvement suggestions, let ;; me know. |