diff options
Diffstat (limited to '.emacs.d/org-7.4/lisp')
194 files changed, 81846 insertions, 0 deletions
diff --git a/.emacs.d/org-7.4/lisp/ob-C.el b/.emacs.d/org-7.4/lisp/ob-C.el new file mode 100644 index 0000000..da0e768 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-C.el @@ -0,0 +1,194 @@ +;;; ob-C.el --- org-babel functions for C and similar languages + +;; Copyright (C) 2010 Free Software Foundation, Inc. + +;; Author: Eric Schulte +;; Keywords: literate programming, reproducible research +;; Homepage: http://orgmode.org +;; Version: 7.4 + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Org-Babel support for evaluating C code. +;; +;; very limited implementation: +;; - currently only support :results output +;; - not much in the way of error feedback + +;;; Code: +(require 'ob) +(require 'ob-eval) +(require 'cc-mode) + +(declare-function org-entry-get "org" + (pom property &optional inherit literal-nil)) + +(add-to-list 'org-babel-tangle-lang-exts '("c++" . "cpp")) + +(defvar org-babel-default-header-args:C '()) + +(defvar org-babel-C-compiler "gcc" + "Command used to compile a C source code file into an + executable.") + +(defvar org-babel-c++-compiler "g++" + "Command used to compile a c++ source code file into an + executable.") + +(defvar org-babel-c-variant nil + "Internal variable used to hold which type of C (e.g. C or C++) +is currently being evaluated.") + +(defun org-babel-execute:cpp (body params) + "Execute BODY according to PARAMS. This function calls +`org-babel-execute:C'." + (org-babel-execute:C body params)) + +(defun org-babel-execute:c++ (body params) + "Execute a block of C++ code with org-babel. This function is +called by `org-babel-execute-src-block'." + (let ((org-babel-c-variant 'cpp)) (org-babel-C-execute body params))) + +(defun org-babel-expand-body:c++ (body params) + "Expand a block of C++ code with org-babel according to it's +header arguments (calls `org-babel-C-expand')." + (let ((org-babel-c-variant 'cpp)) (org-babel-C-expand body params))) + +(defun org-babel-execute:C (body params) + "Execute a block of C code with org-babel. This function is +called by `org-babel-execute-src-block'." + (let ((org-babel-c-variant 'c)) (org-babel-C-execute body params))) + +(defun org-babel-expand-body:c (body params) + "Expand a block of C code with org-babel according to it's +header arguments (calls `org-babel-C-expand')." + (let ((org-babel-c-variant 'c)) (org-babel-C-expand body params))) + +(defun org-babel-C-execute (body params) + "This function should only be called by `org-babel-execute:C' +or `org-babel-execute:c++'." + (let* ((tmp-src-file (org-babel-temp-file + "C-src-" + (cond + ((equal org-babel-c-variant 'c) ".c") + ((equal org-babel-c-variant 'cpp) ".cpp")))) + (tmp-bin-file (org-babel-temp-file "C-bin-")) + (cmdline (cdr (assoc :cmdline params))) + (flags (cdr (assoc :flags params))) + (full-body (org-babel-C-expand body params)) + (compile + (progn + (with-temp-file tmp-src-file (insert full-body)) + (org-babel-eval + (format "%s -o %s %s %s" + (cond + ((equal org-babel-c-variant 'c) org-babel-C-compiler) + ((equal org-babel-c-variant 'cpp) org-babel-c++-compiler)) + (org-babel-process-file-name tmp-bin-file) + (mapconcat 'identity + (if (listp flags) flags (list flags)) " ") + (org-babel-process-file-name tmp-src-file)) "")))) + ((lambda (results) + (org-babel-reassemble-table + (if (member "vector" (cdr (assoc :result-params params))) + (let ((tmp-file (org-babel-temp-file "c-"))) + (with-temp-file tmp-file (insert results)) + (org-babel-import-elisp-from-file tmp-file)) + (org-babel-read results)) + (org-babel-pick-name + (cdr (assoc :colname-names params)) (cdr (assoc :colnames params))) + (org-babel-pick-name + (cdr (assoc :rowname-names params)) (cdr (assoc :rownames params))))) + (org-babel-trim + (org-babel-eval + (concat tmp-bin-file (if cmdline (concat " " cmdline) "")) ""))))) + +(defun org-babel-C-expand (body params) + "Expand a block of C or C++ code with org-babel according to +it's header arguments." + (let ((vars (mapcar #'cdr (org-babel-get-header params :var))) + (main-p (not (string= (cdr (assoc :main params)) "no"))) + (includes (or (cdr (assoc :includes params)) + (org-babel-read (org-entry-get nil "includes" t)))) + (defines (org-babel-read + (or (cdr (assoc :defines params)) + (org-babel-read (org-entry-get nil "defines" t)))))) + (mapconcat 'identity + (list + ;; includes + (mapconcat + (lambda (inc) (format "#include %s" inc)) + (if (listp includes) includes (list includes)) "\n") + ;; defines + (mapconcat + (lambda (inc) (format "#define %s" inc)) + (if (listp defines) defines (list defines)) "\n") + ;; variables + (mapconcat 'org-babel-C-var-to-C vars "\n") + ;; body + (if main-p + (org-babel-C-ensure-main-wrap body) + body) "\n") "\n"))) + +(defun org-babel-C-ensure-main-wrap (body) + "Wrap body in a \"main\" function call if none exists." + (if (string-match "^[ \t]*[intvod]+[ \t\n\r]*main[ \t]*(.*)" body) + body + (format "int main() {\n%s\n}\n" body))) + +(defun org-babel-prep-session:C (session params) + "This function does nothing as C is a compiled language with no +support for sessions" + (error "C is a compiled languages -- no support for sessions")) + +(defun org-babel-load-session:C (session body params) + "This function does nothing as C is a compiled language with no +support for sessions" + (error "C is a compiled languages -- no support for sessions")) + +;; helper functions + +(defun org-babel-C-var-to-C (pair) + "Convert an elisp val into a string of C code specifying a var +of the same value." + ;; TODO list support + (let ((var (car pair)) + (val (cdr pair))) + (when (symbolp val) + (setq val (symbol-name val)) + (when (= (length val) 1) + (setq val (string-to-char val)))) + (cond + ((integerp val) + (format "int %S = %S;" var val)) + ((floatp val) + (format "double %S = %S;" var val)) + ((or (characterp val)) + (format "char %S = '%S';" var val)) + ((stringp val) + (format "char %S[%d] = \"%s\";" + var (+ 1 (length val)) val)) + (t + (format "u32 %S = %S;" var val))))) + + +(provide 'ob-C) + +;; arch-tag: 8f49e462-54e3-417b-9a8d-423864893b37 + +;;; ob-C.el ends here diff --git a/.emacs.d/org-7.4/lisp/ob-C.elc b/.emacs.d/org-7.4/lisp/ob-C.elc Binary files differnew file mode 100644 index 0000000..e6dd9ff --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-C.elc diff --git a/.emacs.d/org-7.4/lisp/ob-R.el b/.emacs.d/org-7.4/lisp/ob-R.el new file mode 100644 index 0000000..1f4fd87 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-R.el @@ -0,0 +1,303 @@ +;;; ob-R.el --- org-babel functions for R code evaluation + +;; Copyright (C) 2009, 2010 Free Software Foundation, Inc. + +;; Author: Eric Schulte, Dan Davison +;; Keywords: literate programming, reproducible research, R, statistics +;; Homepage: http://orgmode.org +;; Version: 7.4 + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Org-Babel support for evaluating R code + +;;; Code: +(require 'ob) +(require 'ob-ref) +(require 'ob-comint) +(require 'ob-eval) +(eval-when-compile (require 'cl)) + +(declare-function orgtbl-to-tsv "org-table" (table params)) +(declare-function R "ext:essd-r" (&optional start-args)) +(declare-function inferior-ess-send-input "ext:ess-inf" ()) +(declare-function ess-make-buffer-current "ext:ess-inf" ()) +(declare-function ess-eval-buffer "ext:ess-inf" (vis)) +(declare-function org-number-sequence "org-compat" (from &optional to inc)) + +(defconst org-babel-header-arg-names:R + '(width height bg units pointsize antialias quality compression + res type family title fonts version paper encoding + pagecentre colormodel useDingbats horizontal) + "R-specific header arguments.") + +(defvar org-babel-default-header-args:R '()) + +(defvar org-babel-R-command "R --slave --no-save" + "Name of command to use for executing R code.") + +(defun org-babel-expand-body:R (body params) + "Expand BODY according to PARAMS, return the expanded body." + (let ((out-file (cdr (assoc :file params)))) + (mapconcat + #'identity + ((lambda (inside) + (if out-file + (append + (list (org-babel-R-construct-graphics-device-call out-file params)) + inside + (list "dev.off()")) + inside)) + (append (org-babel-variable-assignments:R params) + (list body))) "\n"))) + +(defun org-babel-execute:R (body params) + "Execute a block of R code. +This function is called by `org-babel-execute-src-block'." + (save-excursion + (let* ((result-type (cdr (assoc :result-type params))) + (session (org-babel-R-initiate-session + (cdr (assoc :session params)) params)) + (colnames-p (cdr (assoc :colnames params))) + (rownames-p (cdr (assoc :rownames params))) + (out-file (cdr (assoc :file params))) + (full-body (org-babel-expand-body:R body params)) + (result + (org-babel-R-evaluate + session full-body result-type + (or (equal "yes" colnames-p) + (org-babel-pick-name + (cdr (assoc :colname-names params)) colnames-p)) + (or (equal "yes" rownames-p) + (org-babel-pick-name + (cdr (assoc :rowname-names params)) rownames-p))))) + (message "result is %S" result) + (or out-file result)))) + +(defun org-babel-prep-session:R (session params) + "Prepare SESSION according to the header arguments specified in PARAMS." + (let* ((session (org-babel-R-initiate-session session params)) + (var-lines (org-babel-variable-assignments:R params))) + (org-babel-comint-in-buffer session + (mapc (lambda (var) + (end-of-line 1) (insert var) (comint-send-input nil t) + (org-babel-comint-wait-for-output session)) var-lines)) + session)) + +(defun org-babel-load-session:R (session body params) + "Load BODY into SESSION." + (save-window-excursion + (let ((buffer (org-babel-prep-session:R session params))) + (with-current-buffer buffer + (goto-char (process-mark (get-buffer-process (current-buffer)))) + (insert (org-babel-chomp body))) + buffer))) + +;; helper functions + +(defun org-babel-variable-assignments:R (params) + "Return list of R statements assigning the block's variables" + (let ((vars (mapcar #'cdr (org-babel-get-header params :var)))) + (mapcar + (lambda (pair) + (org-babel-R-assign-elisp + (car pair) (cdr pair) + (equal "yes" (cdr (assoc :colnames params))) + (equal "yes" (cdr (assoc :rownames params))))) + (mapcar + (lambda (i) + (cons (car (nth i vars)) + (org-babel-reassemble-table + (cdr (nth i vars)) + (cdr (nth i (cdr (assoc :colname-names params)))) + (cdr (nth i (cdr (assoc :rowname-names params))))))) + (org-number-sequence 0 (1- (length vars))))))) + +(defun org-babel-R-quote-tsv-field (s) + "Quote field S for export to R." + (if (stringp s) + (concat "\"" (mapconcat 'identity (split-string s "\"") "\"\"") "\"") + (format "%S" s))) + +(defun org-babel-R-assign-elisp (name value colnames-p rownames-p) + "Construct R code assigning the elisp VALUE to a variable named NAME." + (if (listp value) + (let ((transition-file (org-babel-temp-file "R-import-"))) + ;; ensure VALUE has an orgtbl structure (depth of at least 2) + (unless (listp (car value)) (setq value (list value))) + (with-temp-file transition-file + (insert (orgtbl-to-tsv value '(:fmt org-babel-R-quote-tsv-field))) + (insert "\n")) + (format "%s <- read.table(\"%s\", header=%s, row.names=%s, sep=\"\\t\", as.is=TRUE)" + name (org-babel-process-file-name transition-file 'noquote) + (if (or (eq (nth 1 value) 'hline) colnames-p) "TRUE" "FALSE") + (if rownames-p "1" "NULL"))) + (format "%s <- %s" name (org-babel-R-quote-tsv-field value)))) + +(defvar ess-ask-for-ess-directory nil) +(defun org-babel-R-initiate-session (session params) + "If there is not a current R process then create one." + (unless (string= session "none") + (let ((session (or session "*R*")) + (ess-ask-for-ess-directory + (and ess-ask-for-ess-directory (not (cdr (assoc :dir params)))))) + (if (org-babel-comint-buffer-livep session) + session + (save-window-excursion + (require 'ess) (R) + (rename-buffer + (if (bufferp session) + (buffer-name session) + (if (stringp session) + session + (buffer-name)))) + (current-buffer)))))) + +(defvar ess-local-process-name nil) +(defun org-babel-R-associate-session (session) + "Associate R code buffer with an R session. +Make SESSION be the inferior ESS process associated with the +current code buffer." + (setq ess-local-process-name + (process-name (get-buffer-process session))) + (ess-make-buffer-current)) + +(defun org-babel-R-construct-graphics-device-call (out-file params) + "Construct the call to the graphics device." + (let ((devices + '((:bmp . "bmp") + (:jpg . "jpeg") + (:jpeg . "jpeg") + (:tiff . "tiff") + (:png . "png") + (:svg . "svg") + (:pdf . "pdf") + (:ps . "postscript") + (:postscript . "postscript"))) + (allowed-args '(:width :height :bg :units :pointsize + :antialias :quality :compression :res + :type :family :title :fonts :version + :paper :encoding :pagecentre :colormodel + :useDingbats :horizontal)) + (device (and (string-match ".+\\.\\([^.]+\\)" out-file) + (match-string 1 out-file))) + (extra-args (cdr (assq :R-dev-args params))) filearg args) + (setq device (or (and device (cdr (assq (intern (concat ":" device)) + devices))) "png")) + (setq filearg + (if (member device '("pdf" "postscript" "svg")) "file" "filename")) + (setq args (mapconcat + (lambda (pair) + (if (member (car pair) allowed-args) + (format ",%s=%s" + (substring (symbol-name (car pair)) 1) + (cdr pair)) "")) + params "")) + (format "%s(%s=\"%s\"%s%s%s)" + device filearg out-file args + (if extra-args "," "") (or extra-args "")))) + +(defvar org-babel-R-eoe-indicator "'org_babel_R_eoe'") +(defvar org-babel-R-eoe-output "[1] \"org_babel_R_eoe\"") +(defvar org-babel-R-write-object-command "{function(object, transfer.file) {invisible(if(inherits(try(write.table(object, file=transfer.file, sep=\"\\t\", na=\"nil\",row.names=%s, col.names=%s, quote=FALSE), silent=TRUE),\"try-error\")) {if(!file.exists(transfer.file)) file.create(transfer.file)})}}(object=%s, transfer.file=\"%s\")") + +(defun org-babel-R-evaluate + (session body result-type column-names-p row-names-p) + "Evaluate R code in BODY." + (if session + (org-babel-R-evaluate-session + session body result-type column-names-p row-names-p) + (org-babel-R-evaluate-external-process + body result-type column-names-p row-names-p))) + +(defun org-babel-R-evaluate-external-process + (body result-type column-names-p row-names-p) + "Evaluate BODY in external R process. +If RESULT-TYPE equals 'output then return standard output as a +string. If RESULT-TYPE equals 'value then return the value of the +last statement in BODY, as elisp." + (case result-type + (value + (let ((tmp-file (org-babel-temp-file "R-"))) + (org-babel-eval org-babel-R-command + (format org-babel-R-write-object-command + (if row-names-p "TRUE" "FALSE") + (if column-names-p + (if row-names-p "NA" "TRUE") + "FALSE") + (format "{function ()\n{\n%s\n}}()" body) + (org-babel-process-file-name tmp-file 'noquote))) + (org-babel-R-process-value-result + (org-babel-import-elisp-from-file tmp-file '(16)) column-names-p))) + (output (org-babel-eval org-babel-R-command body)))) + +(defun org-babel-R-evaluate-session + (session body result-type column-names-p row-names-p) + "Evaluate BODY in SESSION. +If RESULT-TYPE equals 'output then return standard output as a +string. If RESULT-TYPE equals 'value then return the value of the +last statement in BODY, as elisp." + (case result-type + (value + (with-temp-buffer + (insert (org-babel-chomp body)) + (let ((ess-local-process-name + (process-name (get-buffer-process session)))) + (ess-eval-buffer nil))) + (let ((tmp-file (org-babel-temp-file "R-"))) + (org-babel-comint-eval-invisibly-and-wait-for-file + session tmp-file + (format org-babel-R-write-object-command + (if row-names-p "TRUE" "FALSE") + (if column-names-p + (if row-names-p "NA" "TRUE") + "FALSE") + ".Last.value" (org-babel-process-file-name tmp-file 'noquote))) + (org-babel-R-process-value-result + (org-babel-import-elisp-from-file tmp-file '(16)) column-names-p))) + (output + (mapconcat + #'org-babel-chomp + (butlast + (delq nil + (mapcar + (lambda (line) (when (> (length line) 0) line)) + (mapcar + (lambda (line) ;; cleanup extra prompts left in output + (if (string-match + "^\\([ ]*[>+][ ]?\\)+\\([[0-9]+\\|[ ]\\)" line) + (substring line (match-end 1)) + line)) + (org-babel-comint-with-output (session org-babel-R-eoe-output) + (insert (mapconcat #'org-babel-chomp + (list body org-babel-R-eoe-indicator) + "\n")) + (inferior-ess-send-input)))))) "\n")))) + +(defun org-babel-R-process-value-result (result column-names-p) + "R-specific processing of return value. +Insert hline if column names in output have been requested." + (if column-names-p + (cons (car result) (cons 'hline (cdr result))) + result)) + +(provide 'ob-R) + +;; arch-tag: cd4c7298-503b-450f-a3c2-f3e74b630237 + +;;; ob-R.el ends here diff --git a/.emacs.d/org-7.4/lisp/ob-R.elc b/.emacs.d/org-7.4/lisp/ob-R.elc Binary files differnew file mode 100644 index 0000000..26ea781 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-R.elc diff --git a/.emacs.d/org-7.4/lisp/ob-asymptote.el b/.emacs.d/org-7.4/lisp/ob-asymptote.el new file mode 100644 index 0000000..ab2abda --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-asymptote.el @@ -0,0 +1,164 @@ +;;; ob-asymptote.el --- org-babel functions for asymptote evaluation + +;; Copyright (C) 2009, 2010 Free Software Foundation, Inc. + +;; Author: Eric Schulte +;; Keywords: literate programming, reproducible research +;; Homepage: http://orgmode.org +;; Version: 7.4 + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Org-Babel support for evaluating asymptote source code. +;; +;; This differs from most standard languages in that +;; +;; 1) there is no such thing as a "session" in asymptote +;; +;; 2) we are generally only going to return results of type "file" +;; +;; 3) we are adding the "file" and "cmdline" header arguments, if file +;; is omitted then the -V option is passed to the asy command for +;; interactive viewing + +;;; Requirements: + +;; - The asymptote program :: http://asymptote.sourceforge.net/ +;; +;; - asy-mode :: Major mode for editing asymptote files + +;;; Code: +(require 'ob) +(eval-when-compile (require 'cl)) + +(declare-function orgtbl-to-generic "org-table" (table params)) +(declare-function org-combine-plists "org" (&rest plists)) + +(add-to-list 'org-babel-tangle-lang-exts '("asymptote" . "asy")) + +(defvar org-babel-default-header-args:asymptote + '((:results . "file") (:exports . "results")) + "Default arguments when evaluating an Asymptote source block.") + +(defun org-babel-execute:asymptote (body params) + "Execute a block of Asymptote code. +This function is called by `org-babel-execute-src-block'." + (let* ((result-params (split-string (or (cdr (assoc :results params)) ""))) + (out-file (cdr (assoc :file params))) + (format (or (and out-file + (string-match ".+\\.\\(.+\\)" out-file) + (match-string 1 out-file)) + "pdf")) + (cmdline (cdr (assoc :cmdline params))) + (in-file (org-babel-temp-file "asymptote-")) + (cmd + (concat "asy " + (if out-file + (concat + "-globalwrite -f " format + " -o " (org-babel-process-file-name out-file)) + "-V") + " " cmdline + " " (org-babel-process-file-name in-file)))) + (with-temp-file in-file + (insert (org-babel-expand-body:generic + body params + (org-babel-variable-assignments:asymptote params)))) + (message cmd) (shell-command cmd) + out-file)) + +(defun org-babel-prep-session:asymptote (session params) + "Return an error if the :session header argument is set. +Asymptote does not support sessions" + (error "Asymptote does not support sessions")) + +(defun org-babel-variable-assignments:asymptote (params) + "Return list of asymptote statements assigning the block's variables" + (mapcar #'org-babel-asymptote-var-to-asymptote + (mapcar #'cdr (org-babel-get-header params :var)))) + +(defun org-babel-asymptote-var-to-asymptote (pair) + "Convert an elisp value into an Asymptote variable. +The elisp value PAIR is converted into Asymptote code specifying +a variable of the same value." + (let ((var (car pair)) + (val (if (symbolp (cdr pair)) + (symbol-name (cdr pair)) + (cdr pair)))) + (cond + ((integerp val) + (format "int %S=%S;" var val)) + ((floatp val) + (format "real %S=%S;" var val)) + ((stringp val) + (format "string %S=\"%s\";" var val)) + ((listp val) + (let* ((dimension-2-p (not (null (cdr val)))) + (dim (if dimension-2-p "[][]" "[]")) + (type (org-babel-asymptote-define-type val)) + (array (org-babel-asymptote-table-to-array + val + (if dimension-2-p '(:lstart "{" :lend "}," :llend "}"))))) + (format "%S%s %S=%s;" type dim var array)))))) + +(defun org-babel-asymptote-table-to-array (table params) + "Convert values of an elisp table into a string of an asymptote array. +Empty cells are ignored." + (labels ((atom-to-string (table) + (cond + ((null table) '()) + ((not (listp (car table))) + (cons (if (and (stringp (car table)) + (not (string= (car table) ""))) + (format "\"%s\"" (car table)) + (format "%s" (car table))) + (atom-to-string (cdr table)))) + (t + (cons (atom-to-string (car table)) + (atom-to-string (cdr table)))))) + ;; Remove any empty row + (fix-empty-lines (table) + (delq nil (mapcar (lambda (l) (delq "" l)) table)))) + (orgtbl-to-generic + (fix-empty-lines (atom-to-string table)) + (org-combine-plists '(:hline nil :sep "," :tstart "{" :tend "}") params)))) + +(defun org-babel-asymptote-define-type (data) + "Determine type of DATA. +DATA is a list. Type symbol is returned as 'symbol. The type is +usually the type of the first atom encountered, except for arrays +of int, where every cell must be of int type." + (labels ((anything-but-int (el) + (cond + ((null el) nil) + ((not (listp (car el))) + (cond + ((floatp (car el)) 'real) + ((stringp (car el)) 'string) + (t + (anything-but-int (cdr el))))) + (t + (or (anything-but-int (car el)) + (anything-but-int (cdr el))))))) + (or (anything-but-int data) 'int))) + +(provide 'ob-asymptote) + +;; arch-tag: f2f5bd0d-78e8-412b-8e6c-6dadc94cc06b + +;;; ob-asymptote.el ends here diff --git a/.emacs.d/org-7.4/lisp/ob-asymptote.elc b/.emacs.d/org-7.4/lisp/ob-asymptote.elc Binary files differnew file mode 100644 index 0000000..530f6c4 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-asymptote.elc diff --git a/.emacs.d/org-7.4/lisp/ob-calc.el b/.emacs.d/org-7.4/lisp/ob-calc.el new file mode 100644 index 0000000..287bad3 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-calc.el @@ -0,0 +1,97 @@ +;;; ob-calc.el --- org-babel functions for calc code evaluation + +;; Copyright (C) 2010 Free Software Foundation, Inc + +;; Author: Eric Schulte +;; Keywords: literate programming, reproducible research +;; Homepage: http://orgmode.org +;; Version: 7.4 + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Org-Babel support for evaluating calc code + +;;; Code: +(require 'ob) +(require 'calc) +(require 'calc-trail) +(eval-when-compile (require 'ob-comint)) + +(defvar org-babel-default-header-args:calc nil + "Default arguments for evaluating an calc source block.") + +(defun org-babel-expand-body:calc (body params) + "Expand BODY according to PARAMS, return the expanded body." body) + +(defun org-babel-execute:calc (body params) + "Execute a block of calc code with Babel." + (unless (get-buffer "*Calculator*") + (save-window-excursion (calc) (calc-quit))) + (let* ((vars (mapcar #'cdr (org-babel-get-header params :var))) + (var-syms (mapcar #'car vars)) + (var-names (mapcar #'symbol-name var-syms))) + (mapc + (lambda (pair) + (calc-push-list (list (cdr pair))) + (calc-store-into (car pair))) + vars) + (mapc + (lambda (line) + (when (> (length line) 0) + (cond + ;; simple variable name + ((member line var-names) (calc-recall (intern line))) + ;; stack operation + ((string= "'" (substring line 0 1)) + (funcall (lookup-key calc-mode-map (substring line 1)) nil)) + ;; complex expression + (t + (calc-push-list + (list ((lambda (res) + (cond + ((numberp res) res) + ((math-read-number res) (math-read-number res)) + ((listp res) (error "calc error \"%s\" on input \"%s\"" + (cadr res) line)) + (t (calc-eval + (math-evaluate-expr + ;; resolve user variables, calc built in + ;; variables are handled automatically + ;; upstream by calc + (mapcar (lambda (el) + (if (and (consp el) (equal 'var (car el)) + (member (cadr el) var-syms)) + (progn + (calc-recall (cadr el)) + (prog1 (calc-top 1) + (calc-pop 1))) + el)) + ;; parse line into calc objects + (car (math-read-exprs line)))))))) + (calc-eval line)))))))) + (mapcar #'org-babel-trim + (split-string (org-babel-expand-body:calc body params) "[\n\r]")))) + (save-excursion + (with-current-buffer (get-buffer "*Calculator*") + (calc-eval (calc-top 1))))) + +(provide 'ob-calc) + +;; arch-tag: 5c57a3b7-5818-4c6c-acda-7a94831a6449 + +;;; ob-calc.el ends here diff --git a/.emacs.d/org-7.4/lisp/ob-calc.elc b/.emacs.d/org-7.4/lisp/ob-calc.elc Binary files differnew file mode 100644 index 0000000..0a006b2 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-calc.elc diff --git a/.emacs.d/org-7.4/lisp/ob-clojure.el b/.emacs.d/org-7.4/lisp/ob-clojure.el new file mode 100644 index 0000000..d88c54b --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-clojure.el @@ -0,0 +1,88 @@ +;;; ob-clojure.el --- org-babel functions for clojure evaluation + +;; Copyright (C) 2009, 2010 Free Software Foundation, Inc. + +;; Author: Joel Boehland, Eric Schulte +;; Keywords: literate programming, reproducible research +;; Homepage: http://orgmode.org +;; Version: 7.4 + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;;; support for evaluating clojure code, relies on slime for all eval + +;;; Requirements: + +;;; - clojure (at least 1.2.0) +;;; - clojure-mode +;;; - slime +;;; - swank-clojure + +;;; By far, the best way to install these components is by following +;;; the directions as set out by Phil Hagelberg (Technomancy) on the +;;; web page: http://technomancy.us/126 + +;;; Code: +(require 'ob) + +(declare-function slime-eval "ext:slime" (sexp &optional package)) + +(add-to-list 'org-babel-tangle-lang-exts '("clojure" . "clj")) + +(defvar org-babel-default-header-args:clojure '()) +(defvar org-babel-header-arg-names:clojure '(package)) + +(defun org-babel-expand-body:clojure (body params) + "Expand BODY according to PARAMS, return the expanded body." + (let* ((vars (mapcar #'cdr (org-babel-get-header params :var))) + (result-params (cdr (assoc :result-params params))) + (print-level nil) (print-length nil) + (body (org-babel-trim + (if (> (length vars) 0) + (concat "(let [" + (mapconcat + (lambda (var) + (format "%S (quote %S)" (car var) (cdr var))) + vars "\n ") + "]\n" body ")") + body)))) + (if (or (member "code" result-params) + (member "pp" result-params)) + (format (concat "(let [org-mode-print-catcher (java.io.StringWriter.)]" + "(clojure.pprint/with-pprint-dispatch %s-dispatch" + "(clojure.pprint/pprint %s org-mode-print-catcher)" + "(str org-mode-print-catcher)))") + (if (member "code" result-params) "code" "simple") body) + body))) + +(defun org-babel-execute:clojure (body params) + "Execute a block of Clojure code with Babel." + (require 'slime) (require 'swank-clojure) + (with-temp-buffer + (insert (org-babel-expand-body:clojure body params)) + (read + (slime-eval + `(swank:interactive-eval-region + ,(buffer-substring-no-properties (point-min) (point-max))) + (cdr (assoc :package params)))))) + +(provide 'ob-clojure) + +;; arch-tag: a43b33f2-653e-46b1-ac56-2805cf05b7d1 + +;;; ob-clojure.el ends here diff --git a/.emacs.d/org-7.4/lisp/ob-clojure.elc b/.emacs.d/org-7.4/lisp/ob-clojure.elc Binary files differnew file mode 100644 index 0000000..b71f04a --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-clojure.elc diff --git a/.emacs.d/org-7.4/lisp/ob-comint.el b/.emacs.d/org-7.4/lisp/ob-comint.el new file mode 100644 index 0000000..064aad5 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-comint.el @@ -0,0 +1,163 @@ +;;; ob-comint.el --- org-babel functions for interaction with comint buffers + +;; Copyright (C) 2009, 2010 Free Software Foundation, Inc. + +;; Author: Eric Schulte +;; Keywords: literate programming, reproducible research, comint +;; Homepage: http://orgmode.org +;; Version: 7.4 + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; These functions build on comint to ease the sending and receiving +;; of commands and results from comint buffers. + +;; Note that the buffers in this file are analogous to sessions in +;; org-babel at large. + +;;; Code: +(require 'ob) +(require 'comint) +(eval-when-compile (require 'cl)) +(declare-function with-parsed-tramp-file-name "tramp" (filename var &rest body)) +(declare-function tramp-flush-directory-property "tramp" (vec directory)) + +(defun org-babel-comint-buffer-livep (buffer) + "Check if BUFFER is a comint buffer with a live process." + (let ((buffer (if buffer (get-buffer buffer)))) + (and buffer (buffer-live-p buffer) (get-buffer-process buffer) buffer))) + +(defmacro org-babel-comint-in-buffer (buffer &rest body) + "Check BUFFER and execute BODY. +BUFFER is checked with `org-babel-comint-buffer-livep'. BODY is +executed inside the protection of `save-excursion' and +`save-match-data'." + (declare (indent 1)) + `(save-excursion + (save-match-data + (unless (org-babel-comint-buffer-livep ,buffer) + (error "buffer %s doesn't exist or has no process" ,buffer)) + (set-buffer ,buffer) + ,@body))) + +(defmacro org-babel-comint-with-output (meta &rest body) + "Evaluate BODY in BUFFER and return process output. +Will wait until EOE-INDICATOR appears in the output, then return +all process output. If REMOVE-ECHO and FULL-BODY are present and +non-nil, then strip echo'd body from the returned output. META +should be a list containing the following where the last two +elements are optional. + + (BUFFER EOE-INDICATOR REMOVE-ECHO FULL-BODY) + +This macro ensures that the filter is removed in case of an error +or user `keyboard-quit' during execution of body." + (declare (indent 1)) + (let ((buffer (car meta)) + (eoe-indicator (cadr meta)) + (remove-echo (cadr (cdr meta))) + (full-body (cadr (cdr (cdr meta))))) + `(org-babel-comint-in-buffer ,buffer + (let ((string-buffer "") dangling-text raw) + (flet ((my-filt (text) + (setq string-buffer (concat string-buffer text)))) + ;; setup filter + (add-hook 'comint-output-filter-functions 'my-filt) + (unwind-protect + (progn + ;; got located, and save dangling text + (goto-char (process-mark (get-buffer-process (current-buffer)))) + (let ((start (point)) + (end (point-max))) + (setq dangling-text (buffer-substring start end)) + (delete-region start end)) + ;; pass FULL-BODY to process + ,@body + ;; wait for end-of-evaluation indicator + (while (progn + (goto-char comint-last-input-end) + (not (save-excursion + (and (re-search-forward + comint-prompt-regexp nil t) + (re-search-forward + (regexp-quote ,eoe-indicator) nil t))))) + (accept-process-output (get-buffer-process (current-buffer))) + ;; thought the following this would allow async + ;; background running, but I was wrong... + ;; (run-with-timer .5 .5 'accept-process-output + ;; (get-buffer-process (current-buffer))) + ) + ;; replace cut dangling text + (goto-char (process-mark (get-buffer-process (current-buffer)))) + (insert dangling-text)) + ;; remove filter + (remove-hook 'comint-output-filter-functions 'my-filt))) + ;; remove echo'd FULL-BODY from input + (if (and ,remove-echo ,full-body + (string-match + (replace-regexp-in-string + "\n" "[\r\n]+" (regexp-quote (or ,full-body ""))) + string-buffer)) + (setq raw (substring string-buffer (match-end 0)))) + (split-string string-buffer comint-prompt-regexp))))) + +(defun org-babel-comint-input-command (buffer cmd) + "Pass CMD to BUFFER. +The input will not be echoed." + (org-babel-comint-in-buffer buffer + (goto-char (process-mark (get-buffer-process buffer))) + (insert cmd) + (comint-send-input) + (org-babel-comint-wait-for-output buffer))) + +(defun org-babel-comint-wait-for-output (buffer) + "Wait until output arrives from BUFFER. +Note: this is only safe when waiting for the result of a single +statement (not large blocks of code)." + (org-babel-comint-in-buffer buffer + (while (progn + (goto-char comint-last-input-end) + (not (and (re-search-forward comint-prompt-regexp nil t) + (goto-char (match-beginning 0)) + (string= (face-name (face-at-point)) + "comint-highlight-prompt")))) + (accept-process-output (get-buffer-process buffer))))) + +(defun org-babel-comint-eval-invisibly-and-wait-for-file + (buffer file string &optional period) + "Evaluate STRING in BUFFER invisibly. +Don't return until FILE exists. Code in STRING must ensure that +FILE exists at end of evaluation." + (unless (org-babel-comint-buffer-livep buffer) + (error "buffer %s doesn't exist or has no process" buffer)) + (if (file-exists-p file) (delete-file file)) + (process-send-string + (get-buffer-process buffer) + (if (string-match "\n$" string) string (concat string "\n"))) + ;; From Tramp 2.1.19 the following cache flush is not necessary + (if (file-remote-p default-directory) + (let (v) + (with-parsed-tramp-file-name default-directory nil + (tramp-flush-directory-property v "")))) + (while (not (file-exists-p file)) (sit-for (or period 0.25)))) + +(provide 'ob-comint) + +;; arch-tag: 9adddce6-0864-4be3-b0b5-6c5157dc7889 + +;;; ob-comint.el ends here diff --git a/.emacs.d/org-7.4/lisp/ob-comint.elc b/.emacs.d/org-7.4/lisp/ob-comint.elc Binary files differnew file mode 100644 index 0000000..fa239de --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-comint.elc diff --git a/.emacs.d/org-7.4/lisp/ob-css.el b/.emacs.d/org-7.4/lisp/ob-css.el new file mode 100644 index 0000000..48ea9e3 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-css.el @@ -0,0 +1,49 @@ +;;; ob-css.el --- org-babel functions for css evaluation + +;; Copyright (C) 2009, 2010 Free Software Foundation, Inc. + +;; Author: Eric Schulte +;; Keywords: literate programming, reproducible research +;; Homepage: http://orgmode.org +;; Version: 7.4 + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Since CSS can't be executed, this file exists solely for tangling +;; CSS from org-mode files. + +;;; Code: +(require 'ob) + +(defvar org-babel-default-header-args:css '()) + +(defun org-babel-execute:css (body params) + "Execute a block of CSS code. +This function is called by `org-babel-execute-src-block'." + body) + +(defun org-babel-prep-session:css (session params) + "Return an error if the :session header argument is set. +CSS does not support sessions." + (error "CSS sessions are nonsensical")) + +(provide 'ob-css) + +;; arch-tag: f4447e8c-50ab-41f9-b322-b7b9574d9fbe + +;;; ob-css.el ends here diff --git a/.emacs.d/org-7.4/lisp/ob-css.elc b/.emacs.d/org-7.4/lisp/ob-css.elc Binary files differnew file mode 100644 index 0000000..6cc9da2 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-css.elc diff --git a/.emacs.d/org-7.4/lisp/ob-ditaa.el b/.emacs.d/org-7.4/lisp/ob-ditaa.el new file mode 100644 index 0000000..097f938 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-ditaa.el @@ -0,0 +1,74 @@ +;;; ob-ditaa.el --- org-babel functions for ditaa evaluation + +;; Copyright (C) 2009, 2010 Free Software Foundation, Inc. + +;; Author: Eric Schulte +;; Keywords: literate programming, reproducible research +;; Homepage: http://orgmode.org +;; Version: 7.4 + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Org-Babel support for evaluating ditaa source code. +;; +;; This differs from most standard languages in that +;; +;; 1) there is no such thing as a "session" in ditaa +;; +;; 2) we are generally only going to return results of type "file" +;; +;; 3) we are adding the "file" and "cmdline" header arguments +;; +;; 4) there are no variables (at least for now) + +;;; Code: +(require 'ob) + +(defvar org-babel-default-header-args:ditaa + '((:results . "file") (:exports . "results")) + "Default arguments for evaluating a ditaa source block.") + +(defvar org-ditaa-jar-path) +(defun org-babel-execute:ditaa (body params) + "Execute a block of Ditaa code with org-babel. +This function is called by `org-babel-execute-src-block'." + (let* ((result-params (split-string (or (cdr (assoc :results params)) ""))) + (out-file (cdr (assoc :file params))) + (cmdline (cdr (assoc :cmdline params))) + (in-file (org-babel-temp-file "ditaa-")) + (cmd (concat "java -jar " + (shell-quote-argument + (expand-file-name org-ditaa-jar-path)) + " " cmdline + " " (org-babel-process-file-name in-file) + " " (org-babel-process-file-name out-file)))) + (unless (file-exists-p org-ditaa-jar-path) + (error "Could not find ditaa.jar at %s" org-ditaa-jar-path)) + (with-temp-file in-file (insert body)) + (message cmd) (shell-command cmd) + out-file)) + +(defun org-babel-prep-session:ditaa (session params) + "Return an error because ditaa does not support sessions." + (error "Ditaa does not support sessions")) + +(provide 'ob-ditaa) + +;; arch-tag: 492cd006-07d9-4fac-bef6-5bb60b48842e + +;;; ob-ditaa.el ends here diff --git a/.emacs.d/org-7.4/lisp/ob-ditaa.elc b/.emacs.d/org-7.4/lisp/ob-ditaa.elc Binary files differnew file mode 100644 index 0000000..dee1f5c --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-ditaa.elc diff --git a/.emacs.d/org-7.4/lisp/ob-dot.el b/.emacs.d/org-7.4/lisp/ob-dot.el new file mode 100644 index 0000000..36baddb --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-dot.el @@ -0,0 +1,90 @@ +;;; ob-dot.el --- org-babel functions for dot evaluation + +;; Copyright (C) 2009, 2010 Free Software Foundation, Inc. + +;; Author: Eric Schulte +;; Keywords: literate programming, reproducible research +;; Homepage: http://orgmode.org +;; Version: 7.4 + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Org-Babel support for evaluating dot source code. +;; +;; For information on dot see http://www.graphviz.org/ +;; +;; This differs from most standard languages in that +;; +;; 1) there is no such thing as a "session" in dot +;; +;; 2) we are generally only going to return results of type "file" +;; +;; 3) we are adding the "file" and "cmdline" header arguments +;; +;; 4) there are no variables (at least for now) + +;;; Code: +(require 'ob) +(require 'ob-eval) + +(defvar org-babel-default-header-args:dot + '((:results . "file") (:exports . "results")) + "Default arguments to use when evaluating a dot source block.") + +(defun org-babel-expand-body:dot (body params) + "Expand BODY according to PARAMS, return the expanded body." + (let ((vars (mapcar #'cdr (org-babel-get-header params :var)))) + (mapc + (lambda (pair) + (let ((name (symbol-name (car pair))) + (value (cdr pair))) + (setq body + (replace-regexp-in-string + (concat "\$" (regexp-quote name)) + (if (stringp value) value (format "%S" value)) + body)))) + vars) + body)) + +(defun org-babel-execute:dot (body params) + "Execute a block of Dot code with org-babel. +This function is called by `org-babel-execute-src-block'." + (let* ((result-params (cdr (assoc :result-params params))) + (out-file (cdr (assoc :file params))) + (cmdline (or (cdr (assoc :cmdline params)) + (format "-T%s" (file-name-extension out-file)))) + (cmd (or (cdr (assoc :cmd params)) "dot")) + (in-file (org-babel-temp-file "dot-"))) + (with-temp-file in-file + (insert (org-babel-expand-body:dot body params))) + (org-babel-eval + (concat cmd + " " (org-babel-process-file-name in-file) + " " cmdline + " -o " (org-babel-process-file-name out-file)) "") + out-file)) + +(defun org-babel-prep-session:dot (session params) + "Return an error because Dot does not support sessions." + (error "Dot does not support sessions")) + +(provide 'ob-dot) + +;; arch-tag: 817d0516-7b47-4f77-a8b2-2aadd8e4d0e2 + +;;; ob-dot.el ends here diff --git a/.emacs.d/org-7.4/lisp/ob-dot.elc b/.emacs.d/org-7.4/lisp/ob-dot.elc Binary files differnew file mode 100644 index 0000000..96c5588 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-dot.elc diff --git a/.emacs.d/org-7.4/lisp/ob-emacs-lisp.el b/.emacs.d/org-7.4/lisp/ob-emacs-lisp.el new file mode 100644 index 0000000..df6f505 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-emacs-lisp.el @@ -0,0 +1,71 @@ +;;; ob-emacs-lisp.el --- org-babel functions for emacs-lisp code evaluation + +;; Copyright (C) 2009, 2010 Free Software Foundation, Inc + +;; Author: Eric Schulte +;; Keywords: literate programming, reproducible research +;; Homepage: http://orgmode.org +;; Version: 7.4 + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Org-Babel support for evaluating emacs-lisp code + +;;; Code: +(require 'ob) +(eval-when-compile (require 'ob-comint)) + +(defvar org-babel-default-header-args:emacs-lisp + '((:hlines . "yes") (:colnames . "no")) + "Default arguments for evaluating an emacs-lisp source block.") + +(declare-function orgtbl-to-generic "org-table" (table params)) + +(defun org-babel-expand-body:emacs-lisp (body params) + "Expand BODY according to PARAMS, return the expanded body." + (let* ((vars (mapcar #'cdr (org-babel-get-header params :var))) + (result-params (cdr (assoc :result-params params))) + (print-level nil) (print-length nil) + (body (if (> (length vars) 0) + (concat "(let (" + (mapconcat + (lambda (var) + (format "%S" (print `(,(car var) ',(cdr var))))) + vars "\n ") + ")\n" body ")") + body))) + (if (or (member "code" result-params) + (member "pp" result-params)) + (concat "(pp " body ")") body))) + +(defun org-babel-execute:emacs-lisp (body params) + "Execute a block of emacs-lisp code with Babel." + (save-window-excursion + (org-babel-reassemble-table + (eval (read (format "(progn %s)" + (org-babel-expand-body:emacs-lisp body params)))) + (org-babel-pick-name (cdr (assoc :colname-names params)) + (cdr (assoc :colnames params))) + (org-babel-pick-name (cdr (assoc :rowname-names params)) + (cdr (assoc :rownames params)))))) + +(provide 'ob-emacs-lisp) + +;; arch-tag: e9a3acca-dc84-472a-9f5a-23c35befbcd6 + +;;; ob-emacs-lisp.el ends here diff --git a/.emacs.d/org-7.4/lisp/ob-emacs-lisp.elc b/.emacs.d/org-7.4/lisp/ob-emacs-lisp.elc Binary files differnew file mode 100644 index 0000000..09b4298 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-emacs-lisp.elc diff --git a/.emacs.d/org-7.4/lisp/ob-eval.el b/.emacs.d/org-7.4/lisp/ob-eval.el new file mode 100644 index 0000000..a71cb0d --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-eval.el @@ -0,0 +1,262 @@ +;;; ob-eval.el --- org-babel functions for external code evaluation + +;; Copyright (C) 2009, 2010 Free Software Foundation, Inc. + +;; Author: Eric Schulte +;; Keywords: literate programming, reproducible research, comint +;; Homepage: http://orgmode.org +;; Version: 7.4 + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; These functions build existing Emacs support for executing external +;; shell commands. + +;;; Code: +(eval-when-compile (require 'cl)) + +(defvar org-babel-error-buffer-name "*Org-Babel Error Output*") + +(defun org-babel-eval-error-notify (exit-code stderr) + "Open a buffer to display STDERR and a message with the value of EXIT-CODE." + (let ((buf (get-buffer-create org-babel-error-buffer-name))) + (with-current-buffer buf + (goto-char (point-max)) + (save-excursion (insert stderr))) + (display-buffer buf)) + (message "Babel evaluation exited with code %S" exit-code)) + +(defun org-babel-eval (cmd body) + "Run CMD on BODY. +If CMD succeeds then return its results, otherwise display +STDERR with `org-babel-eval-error-notify'." + (let ((err-buff (get-buffer-create " *Org-Babel Error*")) exit-code) + (with-current-buffer err-buff (erase-buffer)) + (with-temp-buffer + (insert body) + (setq exit-code + (org-babel-shell-command-on-region + (point-min) (point-max) cmd t 'replace err-buff)) + (if (or (not (numberp exit-code)) (> exit-code 0)) + (progn + (with-current-buffer err-buff + (org-babel-eval-error-notify exit-code (buffer-string))) + nil) + (buffer-string))))) + +(defun org-babel-eval-read-file (file) + "Return the contents of FILE as a string." + (with-temp-buffer (insert-file-contents file) + (buffer-string))) + +(defun org-babel-shell-command-on-region (start end command + &optional output-buffer replace + error-buffer display-error-buffer) + "Execute COMMAND in an inferior shell with region as input. + +Fixes bugs in the emacs 23.1.1 version of `shell-command-on-region' + +Normally display output (if any) in temp buffer `*Shell Command Output*'; +Prefix arg means replace the region with it. Return the exit code of +COMMAND. + +To specify a coding system for converting non-ASCII characters in +the input and output to the shell command, use +\\[universal-coding-system-argument] before this command. By +default, the input (from the current buffer) is encoded in the +same coding system that will be used to save the file, +`buffer-file-coding-system'. If the output is going to replace +the region, then it is decoded from that same coding system. + +The noninteractive arguments are START, END, COMMAND, +OUTPUT-BUFFER, REPLACE, ERROR-BUFFER, and DISPLAY-ERROR-BUFFER. +Noninteractive callers can specify coding systems by binding +`coding-system-for-read' and `coding-system-for-write'. + +If the command generates output, the output may be displayed +in the echo area or in a buffer. +If the output is short enough to display in the echo area +\(determined by the variable `max-mini-window-height' if +`resize-mini-windows' is non-nil), it is shown there. Otherwise +it is displayed in the buffer `*Shell Command Output*'. The output +is available in that buffer in both cases. + +If there is output and an error, a message about the error +appears at the end of the output. + +If there is no output, or if output is inserted in the current buffer, +then `*Shell Command Output*' is deleted. + +If the optional fourth argument OUTPUT-BUFFER is non-nil, +that says to put the output in some other buffer. +If OUTPUT-BUFFER is a buffer or buffer name, put the output there. +If OUTPUT-BUFFER is not a buffer and not nil, +insert output in the current buffer. +In either case, the output is inserted after point (leaving mark after it). + +If REPLACE, the optional fifth argument, is non-nil, that means insert +the output in place of text from START to END, putting point and mark +around it. + +If optional sixth argument ERROR-BUFFER is non-nil, it is a buffer +or buffer name to which to direct the command's standard error output. +If it is nil, error output is mingled with regular output. +If DISPLAY-ERROR-BUFFER is non-nil, display the error buffer if there +were any errors. (This is always t, interactively.) +In an interactive call, the variable `shell-command-default-error-buffer' +specifies the value of ERROR-BUFFER." + (interactive (let (string) + (unless (mark) + (error "The mark is not set now, so there is no region")) + ;; Do this before calling region-beginning + ;; and region-end, in case subprocess output + ;; relocates them while we are in the minibuffer. + (setq string (read-shell-command "Shell command on region: ")) + ;; call-interactively recognizes region-beginning and + ;; region-end specially, leaving them in the history. + (list (region-beginning) (region-end) + string + current-prefix-arg + current-prefix-arg + shell-command-default-error-buffer + t))) + (let ((error-file + (if error-buffer + (make-temp-file + (expand-file-name "scor" + (if (featurep 'xemacs) + (temp-directory) + temporary-file-directory))) + nil)) + exit-status) + (if (or replace + (and output-buffer + (not (or (bufferp output-buffer) (stringp output-buffer))))) + ;; Replace specified region with output from command. + (let ((swap (and replace (< start end)))) + ;; Don't muck with mark unless REPLACE says we should. + (goto-char start) + (and replace (push-mark (point) 'nomsg)) + (setq exit-status + (call-process-region start end shell-file-name t + (if error-file + (list output-buffer error-file) + t) + nil shell-command-switch command)) + ;; It is rude to delete a buffer which the command is not using. + ;; (let ((shell-buffer (get-buffer "*Shell Command Output*"))) + ;; (and shell-buffer (not (eq shell-buffer (current-buffer))) + ;; (kill-buffer shell-buffer))) + ;; Don't muck with mark unless REPLACE says we should. + (and replace swap (exchange-point-and-mark))) + ;; No prefix argument: put the output in a temp buffer, + ;; replacing its entire contents. + (let ((buffer (get-buffer-create + (or output-buffer "*Shell Command Output*")))) + (unwind-protect + (if (eq buffer (current-buffer)) + ;; If the input is the same buffer as the output, + ;; delete everything but the specified region, + ;; then replace that region with the output. + (progn (setq buffer-read-only nil) + (delete-region (max start end) (point-max)) + (delete-region (point-min) (min start end)) + (setq exit-status + (call-process-region (point-min) (point-max) + shell-file-name t + (if error-file + (list t error-file) + t) + nil shell-command-switch + command))) + ;; Clear the output buffer, then run the command with + ;; output there. + (let ((directory default-directory)) + (with-current-buffer buffer + (setq buffer-read-only nil) + (if (not output-buffer) + (setq default-directory directory)) + (erase-buffer))) + (setq exit-status + (call-process-region start end shell-file-name nil + (if error-file + (list buffer error-file) + buffer) + nil shell-command-switch command))) + ;; Report the output. + (with-current-buffer buffer + (setq mode-line-process + (cond ((null exit-status) + " - Error") + ((stringp exit-status) + (format " - Signal [%s]" exit-status)) + ((not (equal 0 exit-status)) + (format " - Exit [%d]" exit-status))))) + (if (with-current-buffer buffer (> (point-max) (point-min))) + ;; There's some output, display it + (display-message-or-buffer buffer) + ;; No output; error? + (let ((output + (if (and error-file + (< 0 (nth 7 (file-attributes error-file)))) + "some error output" + "no output"))) + (cond ((null exit-status) + (message "(Shell command failed with error)")) + ((equal 0 exit-status) + (message "(Shell command succeeded with %s)" + output)) + ((stringp exit-status) + (message "(Shell command killed by signal %s)" + exit-status)) + (t + (message "(Shell command failed with code %d and %s)" + exit-status output)))) + ;; Don't kill: there might be useful info in the undo-log. + ;; (kill-buffer buffer) + )))) + + (when (and error-file (file-exists-p error-file)) + (if (< 0 (nth 7 (file-attributes error-file))) + (with-current-buffer (get-buffer-create error-buffer) + (let ((pos-from-end (- (point-max) (point)))) + (or (bobp) + (insert "\f\n")) + ;; Do no formatting while reading error file, + ;; because that can run a shell command, and we + ;; don't want that to cause an infinite recursion. + (format-insert-file error-file nil) + ;; Put point after the inserted errors. + (goto-char (- (point-max) pos-from-end))) + (and display-error-buffer + (display-buffer (current-buffer))))) + (delete-file error-file)) + exit-status)) + +(defun org-babel-eval-wipe-error-buffer () + "Delete the contents of the Org code block error buffer. +This buffer is named by `org-babel-error-buffer-name'." + (when (get-buffer org-babel-error-buffer-name) + (with-current-buffer org-babel-error-buffer-name + (delete-region (point-min) (point-max))))) + +(provide 'ob-eval) + +;; arch-tag: 5328b17f-957d-42d9-94da-a2952682d04d + +;;; ob-eval.el ends here diff --git a/.emacs.d/org-7.4/lisp/ob-eval.elc b/.emacs.d/org-7.4/lisp/ob-eval.elc Binary files differnew file mode 100644 index 0000000..ecd4637 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-eval.elc diff --git a/.emacs.d/org-7.4/lisp/ob-exp.el b/.emacs.d/org-7.4/lisp/ob-exp.el new file mode 100644 index 0000000..8b6914c --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-exp.el @@ -0,0 +1,328 @@ +;;; ob-exp.el --- Exportation of org-babel source blocks + +;; Copyright (C) 2009, 2010 Free Software Foundation, Inc. + +;; Author: Eric Schulte, Dan Davison +;; Keywords: literate programming, reproducible research +;; Homepage: http://orgmode.org +;; Version: 7.4 + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; See the online documentation for more information +;; +;; http://orgmode.org/worg/org-contrib/babel/ + +;;; Code: +(require 'ob) +(require 'org-exp-blocks) +(eval-when-compile + (require 'cl)) + +(defvar obe-marker nil) +(defvar org-current-export-file) +(defvar org-babel-lob-one-liner-regexp) +(defvar org-babel-ref-split-regexp) +(declare-function org-babel-lob-get-info "ob-lob" ()) +(declare-function org-babel-eval-wipe-error-buffer "ob-eval" ()) +(add-to-list 'org-export-interblocks '(src org-babel-exp-inline-src-blocks)) +(add-to-list 'org-export-interblocks '(lob org-babel-exp-lob-one-liners)) +(add-hook 'org-export-blocks-postblock-hook 'org-exp-res/src-name-cleanup) + +(org-export-blocks-add-block '(src org-babel-exp-src-blocks nil)) + +(defcustom org-export-babel-evaluate t + "Switch controlling code evaluation during export. +When set to nil no code will be evaluated as part of the export +process." + :group 'org-babel + :type 'boolean) +(put 'org-export-babel-evaluate 'safe-local-variable (lambda (x) (eq x nil))) + +(defvar org-babel-function-def-export-keyword "function" + "The keyword to substitute for the source name line on export. +When exporting a source block function, this keyword will +appear in the exported version in the place of source name +line. A source block is considered to be a source block function +if the source name is present and is followed by a parenthesized +argument list. The parentheses may be empty or contain +whitespace. An example is the following which generates n random +\(uniform) numbers. + +#+source: rand(n) +#+begin_src R + runif(n) +#+end_src") + +(defvar org-babel-function-def-export-indent 4 + "Number of characters to indent a source block on export. +When exporting a source block function, the block contents will +be indented by this many characters. See +`org-babel-function-def-export-name' for the definition of a +source block function.") + +(defmacro org-babel-exp-in-export-file (&rest body) + `(let* ((lang-headers (intern (concat "org-babel-default-header-args:" lang))) + (heading (nth 4 (ignore-errors (org-heading-components)))) + (link (when org-current-export-file + (org-make-link-string + (if heading + (concat org-current-export-file "::" heading) + org-current-export-file)))) + (export-buffer (current-buffer)) results) + (when link + ;; resolve parameters in the original file so that + ;; headline and file-wide parameters are included, attempt + ;; to go to the same heading in the original file + (set-buffer (get-file-buffer org-current-export-file)) + (save-restriction + (condition-case nil + (org-open-link-from-string link) + (error (when heading + (goto-char (point-min)) + (re-search-forward (regexp-quote heading) nil t)))) + (setq results ,@body)) + (set-buffer export-buffer) + results))) + +(defun org-babel-exp-src-blocks (body &rest headers) + "Process source block for export. +Depending on the 'export' headers argument in replace the source +code block with... + +both ---- display the code and the results + +code ---- the default, display the code inside the block but do + not process + +results - just like none only the block is run on export ensuring + that it's results are present in the org-mode buffer + +none ----- do not display either code or results upon export" + (interactive) + (message "org-babel-exp processing...") + (save-excursion + (goto-char (match-beginning 0)) + (let* ((info (org-babel-get-src-block-info 'light)) + (lang (nth 0 info)) + (raw-params (nth 2 info))) + ;; bail if we couldn't get any info from the block + (when info + (org-babel-exp-in-export-file + (setf (nth 2 info) + (org-babel-merge-params + org-babel-default-header-args + (org-babel-params-from-buffer) + (org-babel-params-from-properties lang) + (if (boundp lang-headers) (eval lang-headers) nil) + raw-params))) + ;; expand noweb references in the original file + (setf (nth 1 info) + (if (and (cdr (assoc :noweb (nth 2 info))) + (string= "yes" (cdr (assoc :noweb (nth 2 info))))) + (org-babel-expand-noweb-references + info (get-file-buffer org-current-export-file)) + (nth 1 info))) + (org-babel-exp-do-export info 'block))))) + +(defun org-babel-exp-inline-src-blocks (start end) + "Process inline source blocks between START and END for export. +See `org-babel-exp-src-blocks' for export options, currently the +options and are taken from `org-babel-default-inline-header-args'." + (interactive) + (save-excursion + (goto-char start) + (while (and (< (point) end) + (re-search-forward org-babel-inline-src-block-regexp end t)) + (let* ((info (save-match-data (org-babel-parse-inline-src-block-match))) + (params (nth 2 info)) + (replacement + (save-match-data + (if (org-babel-in-example-or-verbatim) + (buffer-substring (match-beginning 0) (match-end 0)) + ;; expand noweb references in the original file + (setf (nth 1 info) + (if (and (cdr (assoc :noweb params)) + (string= "yes" (cdr (assoc :noweb params)))) + (org-babel-expand-noweb-references + info (get-file-buffer org-current-export-file)) + (nth 1 info))) + (org-babel-exp-do-export info 'inline))))) + (setq end (+ end (- (length replacement) (length (match-string 1))))) + (replace-match replacement t t nil 1))))) + +(defun org-exp-res/src-name-cleanup () + "Clean up #+results and #+srcname lines for export. +This function should only be called after all block processing +has taken place." + (interactive) + (save-excursion + (goto-char (point-min)) + (while (org-re-search-forward-unprotected + (concat + "\\("org-babel-src-name-regexp"\\|"org-babel-result-regexp"\\)") + nil t) + (delete-region + (progn (beginning-of-line) (point)) + (progn (end-of-line) (+ 1 (point))))))) + +(defun org-babel-in-example-or-verbatim () + "Return true if point is in example or verbatim code. +Example and verbatim code include escaped portions of +an org-mode buffer code that should be treated as normal +org-mode text." + (or (org-in-indented-comment-line) + (save-excursion + (save-match-data + (goto-char (point-at-bol)) + (looking-at "[ \t]*:[ \t]"))) + (org-in-regexps-block-p "^[ \t]*#\\+begin_src" "^[ \t]*#\\+end_src"))) + +(defun org-babel-exp-lob-one-liners (start end) + "Process Library of Babel calls between START and END for export. +See `org-babel-exp-src-blocks' for export options. Currently the +options are taken from `org-babel-default-header-args'." + (interactive) + (let (replacement) + (save-excursion + (goto-char start) + (while (and (< (point) end) + (re-search-forward org-babel-lob-one-liner-regexp nil t)) + (setq replacement + (let ((lob-info (org-babel-lob-get-info))) + (save-match-data + (org-babel-exp-do-export + (list "emacs-lisp" "results" + (org-babel-merge-params + org-babel-default-header-args + (org-babel-params-from-buffer) + (org-babel-params-from-properties) + (org-babel-parse-header-arguments + (org-babel-clean-text-properties + (concat ":var results=" + (mapconcat #'identity + (butlast lob-info) " "))))) + (car (last lob-info))) + 'lob)))) + (setq end (+ end (- (length replacement) (length (match-string 0))))) + (replace-match replacement t t))))) + +(defun org-babel-exp-do-export (info type) + "Return a string with the exported content of a code block. +The function respects the value of the :exports header argument." + (flet ((silently () (let ((session (cdr (assoc :session (nth 2 info))))) + (when (and session + (not (equal "none" session))) + (org-babel-exp-results info type 'silent)))) + (clean () (org-babel-remove-result info))) + (case (intern (or (cdr (assoc :exports (nth 2 info))) "code")) + ('none (silently) (clean) "") + ('code (silently) (clean) (org-babel-exp-code info type)) + ('results (org-babel-exp-results info type)) + ('both (concat (org-babel-exp-code info type) + "\n\n" + (org-babel-exp-results info type)))))) + +(defvar backend) +(defun org-babel-exp-code (info type) + "Prepare and return code in the current code block for export. +Code is prepared in a manner suitable for export by +org-mode. This function is called by `org-babel-exp-do-export'. +The code block is not evaluated." + (let ((lang (nth 0 info)) + (body (nth 1 info)) + (switches (nth 3 info)) + (name (nth 4 info)) + (args (mapcar #'cdr (org-babel-get-header (nth 2 info) :var)))) + (case type + ('inline (format "=%s=" body)) + ('block + (let ((str + (format "#+BEGIN_SRC %s %s\n%s%s#+END_SRC\n" lang switches body + (if (and body (string-match "\n$" body)) + "" "\n")))) + (when name + (add-text-properties + 0 (length str) + (list 'org-caption + (format "%s(%s)" + name + (mapconcat #'identity args ", "))) + str)) + str)) + ('lob + (let ((call-line (and (string-match "results=" (car args)) + (substring (car args) (match-end 0))))) + (cond + ((eq backend 'html) + (format "\n#+HTML: <label class=\"org-src-name\">%s</label>\n" + call-line)) + ((format ": %s\n" call-line)))))))) + +(defun org-babel-exp-results (info type &optional silent) + "Evaluate and return the results of the current code block for export. +Results are prepared in a manner suitable for export by org-mode. +This function is called by `org-babel-exp-do-export'. The code +block will be evaluated. Optional argument SILENT can be used to +inhibit insertion of results into the buffer." + (or + (when org-export-babel-evaluate + (let ((lang (nth 0 info)) + (body (nth 1 info))) + (setf (nth 2 info) (org-babel-exp-in-export-file + (org-babel-process-params (nth 2 info)))) + ;; skip code blocks which we can't evaluate + (when (fboundp (intern (concat "org-babel-execute:" lang))) + (org-babel-eval-wipe-error-buffer) + (if (equal type 'inline) + (let ((raw (org-babel-execute-src-block + nil info '((:results . "silent")))) + (result-params (split-string + (cdr (assoc :results (nth 2 info)))))) + (unless silent + (cond ;; respect the value of the :results header argument + ((member "file" result-params) + (org-babel-result-to-file raw)) + ((or (member "raw" result-params) + (member "org" result-params)) + (format "%s" raw)) + ((member "code" result-params) + (format "src_%s{%s}" lang raw)) + (t + (if (stringp raw) + (if (= 0 (length raw)) "=(no results)=" + (format "%s" raw)) + (format "%S" raw)))))) + (prog1 nil + (setf (nth 2 info) + (org-babel-merge-params + (nth 2 info) + `((:results . ,(if silent "silent" "replace"))))) + (cond + ((equal type 'block) (org-babel-execute-src-block nil info)) + ((equal type 'lob) + (save-excursion + (re-search-backward org-babel-lob-one-liner-regexp nil t) + (org-babel-execute-src-block nil info))))))))) + "")) + +(provide 'ob-exp) + +;; arch-tag: 523abf4c-76d1-44ed-9f27-e3bddf34bf0f + +;;; ob-exp.el ends here diff --git a/.emacs.d/org-7.4/lisp/ob-exp.elc b/.emacs.d/org-7.4/lisp/ob-exp.elc Binary files differnew file mode 100644 index 0000000..731f574 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-exp.elc diff --git a/.emacs.d/org-7.4/lisp/ob-gnuplot.el b/.emacs.d/org-7.4/lisp/ob-gnuplot.el new file mode 100644 index 0000000..423e47e --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-gnuplot.el @@ -0,0 +1,235 @@ +;;; ob-gnuplot.el --- org-babel functions for gnuplot evaluation + +;; Copyright (C) 2009, 2010 Free Software Foundation, Inc. + +;; Author: Eric Schulte +;; Keywords: literate programming, reproducible research +;; Homepage: http://orgmode.org +;; Version: 7.4 + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Org-Babel support for evaluating gnuplot source code. +;; +;; This differs from most standard languages in that +;; +;; 1) we are generally only going to return results of type "file" +;; +;; 2) we are adding the "file" and "cmdline" header arguments + +;;; Requirements: + +;; - gnuplot :: http://www.gnuplot.info/ +;; +;; - gnuplot-mode :: http://cars9.uchicago.edu/~ravel/software/gnuplot-mode.html + +;;; Code: +(require 'ob) +(require 'ob-ref) +(require 'ob-comint) +(eval-when-compile (require 'cl)) + +(declare-function org-time-string-to-time "org" (s)) +(declare-function org-combine-plists "org" (&rest plists)) +(declare-function orgtbl-to-generic "org-table" (table params)) +(declare-function gnuplot-mode "ext:gnuplot-mode" ()) +(declare-function gnuplot-send-string-to-gnuplot "ext:gnuplot-mode" (str txt)) +(declare-function gnuplot-send-buffer-to-gnuplot "ext:gnuplot-mode" ()) + +(defvar org-babel-default-header-args:gnuplot + '((:results . "file") (:exports . "results") (:session . nil)) + "Default arguments to use when evaluating a gnuplot source block.") + +(defvar org-babel-gnuplot-timestamp-fmt nil) + +(defun org-babel-gnuplot-process-vars (params) + "Extract variables from PARAMS and process the variables. +Dumps all vectors into files and returns an association list +of variable names and the related value to be used in the gnuplot +code." + (mapcar + (lambda (pair) + (cons + (car pair) ;; variable name + (if (listp (cdr pair)) ;; variable value + (org-babel-gnuplot-table-to-data + (cdr pair) (org-babel-temp-file "gnuplot-") params) + (cdr pair)))) + (mapcar #'cdr (org-babel-get-header params :var)))) + +(defun org-babel-expand-body:gnuplot (body params) + "Expand BODY according to PARAMS, return the expanded body." + (save-window-excursion + (let* ((vars (org-babel-gnuplot-process-vars params)) + (out-file (cdr (assoc :file params))) + (term (or (cdr (assoc :term params)) + (when out-file (file-name-extension out-file)))) + (cmdline (cdr (assoc :cmdline params))) + (title (plist-get params :title)) + (lines (plist-get params :line)) + (sets (plist-get params :set)) + (x-labels (plist-get params :xlabels)) + (y-labels (plist-get params :ylabels)) + (timefmt (plist-get params :timefmt)) + (time-ind (or (plist-get params :timeind) + (when timefmt 1))) + output) + (flet ((add-to-body (text) + (setq body (concat text "\n" body)))) + ;; append header argument settings to body + (when title (add-to-body (format "set title '%s'" title))) ;; title + (when lines (mapc (lambda (el) (add-to-body el)) lines)) ;; line + (when sets + (mapc (lambda (el) (add-to-body (format "set %s" el))) sets)) + (when x-labels + (add-to-body + (format "set xtics (%s)" + (mapconcat (lambda (pair) + (format "\"%s\" %d" (cdr pair) (car pair))) + x-labels ", ")))) + (when y-labels + (add-to-body + (format "set ytics (%s)" + (mapconcat (lambda (pair) + (format "\"%s\" %d" (cdr pair) (car pair))) + y-labels ", ")))) + (when time-ind + (add-to-body "set xdata time") + (add-to-body (concat "set timefmt \"" + (or timefmt + "%Y-%m-%d-%H:%M:%S") "\""))) + (when out-file (add-to-body (format "set output \"%s\"" out-file))) + (when term (add-to-body (format "set term %s" term))) + ;; insert variables into code body: this should happen last + ;; placing the variables at the *top* of the code in case their + ;; values are used later + (add-to-body (mapconcat #'identity + (org-babel-variable-assignments:gnuplot params) + "\n")) + ;; replace any variable names preceded by '$' with the actual + ;; value of the variable + (mapc (lambda (pair) + (setq body (replace-regexp-in-string + (format "\\$%s" (car pair)) (cdr pair) body))) + vars)) + body))) + +(defun org-babel-execute:gnuplot (body params) + "Execute a block of Gnuplot code. +This function is called by `org-babel-execute-src-block'." + (require 'gnuplot) + (let ((session (cdr (assoc :session params))) + (result-type (cdr (assoc :results params))) + (out-file (cdr (assoc :file params))) + (body (org-babel-expand-body:gnuplot body params)) + output) + (save-window-excursion + ;; evaluate the code body with gnuplot + (if (string= session "none") + (let ((script-file (org-babel-temp-file "gnuplot-script-"))) + (with-temp-file script-file + (insert (concat body "\n"))) + (message "gnuplot \"%s\"" script-file) + (setq output + (shell-command-to-string + (format + "gnuplot \"%s\"" + (org-babel-process-file-name script-file)))) + (message output)) + (with-temp-buffer + (insert (concat body "\n")) + (gnuplot-mode) + (gnuplot-send-buffer-to-gnuplot))) + (if (member "output" (split-string result-type)) + output + out-file)))) + +(defun org-babel-prep-session:gnuplot (session params) + "Prepare SESSION according to the header arguments in PARAMS." + (let* ((session (org-babel-gnuplot-initiate-session session)) + (var-lines (org-babel-variable-assignments:gnuplot params))) + (message "%S" session) + (org-babel-comint-in-buffer session + (mapc (lambda (var-line) + (insert var-line) (comint-send-input nil t) + (org-babel-comint-wait-for-output session) + (sit-for .1) (goto-char (point-max))) var-lines)) + session)) + +(defun org-babel-load-session:gnuplot (session body params) + "Load BODY into SESSION." + (save-window-excursion + (let ((buffer (org-babel-prep-session:gnuplot session params))) + (with-current-buffer buffer + (goto-char (process-mark (get-buffer-process (current-buffer)))) + (insert (org-babel-chomp body))) + buffer))) + +(defun org-babel-variable-assignments:gnuplot (params) + "Return list of gnuplot statements assigning the block's variables" + (mapcar + (lambda (pair) (format "%s = \"%s\"" (car pair) (cdr pair))) + (org-babel-gnuplot-process-vars params))) + +(defvar gnuplot-buffer) +(defun org-babel-gnuplot-initiate-session (&optional session params) + "Initiate a gnuplot session. +If there is not a current inferior-process-buffer in SESSION +then create one. Return the initialized session. The current +`gnuplot-mode' doesn't provide support for multiple sessions." + (require 'gnuplot) + (unless (string= session "none") + (save-window-excursion + (gnuplot-send-string-to-gnuplot "" "line") + gnuplot-buffer))) + +(defun org-babel-gnuplot-quote-timestamp-field (s) + "Convert S from timestamp to Unix time and export to gnuplot." + (format-time-string org-babel-gnuplot-timestamp-fmt (org-time-string-to-time s))) + +(defvar org-table-number-regexp) +(defvar org-ts-regexp3) +(defun org-babel-gnuplot-quote-tsv-field (s) + "Quote S for export to gnuplot." + (unless (stringp s) + (setq s (format "%s" s))) + (if (string-match org-table-number-regexp s) s + (if (string-match org-ts-regexp3 s) + (org-babel-gnuplot-quote-timestamp-field s) + (concat "\"" (mapconcat 'identity (split-string s "\"") "\"\"") "\"")))) + +(defun org-babel-gnuplot-table-to-data (table data-file params) + "Export TABLE to DATA-FILE in a format readable by gnuplot. +Pass PARAMS through to `orgtbl-to-generic' when exporting TABLE." + (with-temp-file data-file + (make-local-variable 'org-babel-gnuplot-timestamp-fmt) + (setq org-babel-gnuplot-timestamp-fmt (or + (plist-get params :timefmt) + "%Y-%m-%d-%H:%M:%S")) + (insert (orgtbl-to-generic + table + (org-combine-plists + '(:sep "\t" :fmt org-babel-gnuplot-quote-tsv-field) + params)))) + data-file) + +(provide 'ob-gnuplot) + +;; arch-tag: 50490ace-a9e1-4b29-a6e5-0db9f16c610b + +;;; ob-gnuplot.el ends here diff --git a/.emacs.d/org-7.4/lisp/ob-gnuplot.elc b/.emacs.d/org-7.4/lisp/ob-gnuplot.elc Binary files differnew file mode 100644 index 0000000..99d4f3c --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-gnuplot.elc diff --git a/.emacs.d/org-7.4/lisp/ob-haskell.el b/.emacs.d/org-7.4/lisp/ob-haskell.el new file mode 100644 index 0000000..734e1f6 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-haskell.el @@ -0,0 +1,217 @@ +;;; ob-haskell.el --- org-babel functions for haskell evaluation + +;; Copyright (C) 2009, 2010 Free Software Foundation, Inc. + +;; Author: Eric Schulte +;; Keywords: literate programming, reproducible research +;; Homepage: http://orgmode.org +;; Version: 7.4 + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Org-Babel support for evaluating haskell source code. This one will +;; be sort of tricky because haskell programs must be compiled before +;; they can be run, but haskell code can also be run through an +;; interactive interpreter. +;; +;; For now lets only allow evaluation using the haskell interpreter. + +;;; Requirements: + +;; - haskell-mode :: http://www.iro.umontreal.ca/~monnier/elisp/#haskell-mode +;; +;; - inf-haskell :: http://www.iro.umontreal.ca/~monnier/elisp/#haskell-mode +;; +;; - (optionally) lhs2tex :: http://people.cs.uu.nl/andres/lhs2tex/ + +;;; Code: +(require 'ob) +(require 'ob-comint) +(require 'comint) +(eval-when-compile (require 'cl)) + +(declare-function org-remove-indentation "org" (code &optional n)) +(declare-function haskell-mode "ext:haskell-mode" ()) +(declare-function run-haskell "ext:inf-haskell" (&optional arg)) +(declare-function inferior-haskell-load-file + "ext:inf-haskell" (&optional reload)) + +(add-to-list 'org-babel-tangle-lang-exts '("haskell" . "hs")) + +(defvar org-babel-default-header-args:haskell '()) + +(defvar org-babel-haskell-lhs2tex-command "lhs2tex") + +(defvar org-babel-haskell-eoe "\"org-babel-haskell-eoe\"") + +(defun org-babel-execute:haskell (body params) + "Execute a block of Haskell code." + (let* ((session (cdr (assoc :session params))) + (vars (mapcar #'cdr (org-babel-get-header params :var))) + (result-type (cdr (assoc :result-type params))) + (full-body (org-babel-expand-body:generic + body params + (org-babel-variable-assignments:haskell params))) + (session (org-babel-haskell-initiate-session session params)) + (raw (org-babel-comint-with-output + (session org-babel-haskell-eoe t full-body) + (insert (org-babel-trim full-body)) + (comint-send-input nil t) + (insert org-babel-haskell-eoe) + (comint-send-input nil t))) + (results (mapcar + #'org-babel-haskell-read-string + (cdr (member org-babel-haskell-eoe + (reverse (mapcar #'org-babel-trim raw))))))) + (org-babel-reassemble-table + (cond + ((equal result-type 'output) + (mapconcat #'identity (reverse (cdr results)) "\n")) + ((equal result-type 'value) + (org-babel-haskell-table-or-string (car results)))) + (org-babel-pick-name (cdr (assoc :colname-names params)) + (cdr (assoc :colname-names params))) + (org-babel-pick-name (cdr (assoc :rowname-names params)) + (cdr (assoc :rowname-names params)))))) + +(defun org-babel-haskell-read-string (string) + "Strip \\\"s from around a haskell string." + (if (string-match "^\"\\([^\000]+\\)\"$" string) + (match-string 1 string) + string)) + +(defun org-babel-haskell-initiate-session (&optional session params) + "Initiate a haskell session. +If there is not a current inferior-process-buffer in SESSION +then create one. Return the initialized session." + (require 'inf-haskell) + (or (get-buffer "*haskell*") + (save-window-excursion (run-haskell) (sleep-for 0.25) (current-buffer)))) + +(defun org-babel-load-session:haskell (session body params) + "Load BODY into SESSION." + (save-window-excursion + (let* ((buffer (org-babel-prep-session:haskell session params)) + (load-file (concat (org-babel-temp-file "haskell-load-") ".hs"))) + (with-temp-buffer + (insert body) (write-file load-file) + (haskell-mode) (inferior-haskell-load-file)) + buffer))) + +(defun org-babel-prep-session:haskell (session params) + "Prepare SESSION according to the header arguments in PARAMS." + (save-window-excursion + (let ((buffer (org-babel-haskell-initiate-session session))) + (org-babel-comint-in-buffer buffer + (mapc (lambda (line) + (insert line) + (comint-send-input nil t)) + (org-babel-variable-assignments:haskell params))) + (current-buffer)))) + +(defun org-babel-variable-assignments:haskell (params) + "Return list of haskell statements assigning the block's variables" + (mapcar (lambda (pair) + (format "let %s = %s" + (car pair) + (org-babel-haskell-var-to-haskell (cdr pair)))) + (mapcar #'cdr (org-babel-get-header params :var)))) + +(defun org-babel-haskell-table-or-string (results) + "Convert RESULTS to an Emacs-lisp table or string. +If RESULTS look like a table, then convert them into an +Emacs-lisp table, otherwise return the results as a string." + (org-babel-script-escape results)) + +(defun org-babel-haskell-var-to-haskell (var) + "Convert an elisp value VAR into a haskell variable. +The elisp VAR is converted to a string of haskell source code +specifying a variable of the same value." + (if (listp var) + (concat "[" (mapconcat #'org-babel-haskell-var-to-haskell var ", ") "]") + (format "%S" var))) + +(defvar org-src-preserve-indentation) +(defun org-babel-haskell-export-to-lhs (&optional arg) + "Export to a .lhs file with all haskell code blocks escaped. +When called with a prefix argument the resulting +.lhs file will be exported to a .tex file. This function will +create two new files, base-name.lhs and base-name.tex where +base-name is the name of the current org-mode file. + +Note that all standard Babel literate programming +constructs (header arguments, no-web syntax etc...) are ignored." + (interactive "P") + (let* ((contents (buffer-string)) + (haskell-regexp + (concat "^\\([ \t]*\\)#\\+begin_src[ \t]haskell*\\(.*\\)?[\r\n]" + "\\([^\000]*?\\)[\r\n][ \t]*#\\+end_src.*")) + (base-name (file-name-sans-extension (buffer-file-name))) + (tmp-file (org-babel-temp-file "haskell-")) + (tmp-org-file (concat tmp-file ".org")) + (tmp-tex-file (concat tmp-file ".tex")) + (lhs-file (concat base-name ".lhs")) + (tex-file (concat base-name ".tex")) + (command (concat org-babel-haskell-lhs2tex-command + " " (org-babel-process-file-name lhs-file) + " > " (org-babel-process-file-name tex-file))) + (preserve-indentp org-src-preserve-indentation) + indentation) + ;; escape haskell source-code blocks + (with-temp-file tmp-org-file + (insert contents) + (goto-char (point-min)) + (while (re-search-forward haskell-regexp nil t) + (save-match-data (setq indentation (length (match-string 1)))) + (replace-match (save-match-data + (concat + "#+begin_latex\n\\begin{code}\n" + (if (or preserve-indentp + (string-match "-i" (match-string 2))) + (match-string 3) + (org-remove-indentation (match-string 3))) + "\n\\end{code}\n#+end_latex\n")) + t t) + (indent-code-rigidly (match-beginning 0) (match-end 0) indentation))) + (save-excursion + ;; export to latex w/org and save as .lhs + (find-file tmp-org-file) (funcall 'org-export-as-latex nil) + (kill-buffer) + (delete-file tmp-org-file) + (find-file tmp-tex-file) + (goto-char (point-min)) (forward-line 2) + (insert "%include polycode.fmt\n") + ;; ensure all \begin/end{code} statements start at the first column + (while (re-search-forward "^[ \t]+\\\\begin{code}[^\000]+\\\\end{code}" nil t) + (replace-match (save-match-data (org-remove-indentation (match-string 0))) + t t)) + (setq contents (buffer-string)) + (save-buffer) (kill-buffer)) + (delete-file tmp-tex-file) + ;; save org exported latex to a .lhs file + (with-temp-file lhs-file (insert contents)) + (if (not arg) + (find-file lhs-file) + ;; process .lhs file with lhs2tex + (message "running %s" command) (shell-command command) (find-file tex-file)))) + +(provide 'ob-haskell) + +;; arch-tag: b53f75f3-ba1a-4b05-82d9-a2a0d4e70804 + +;;; ob-haskell.el ends here diff --git a/.emacs.d/org-7.4/lisp/ob-haskell.elc b/.emacs.d/org-7.4/lisp/ob-haskell.elc Binary files differnew file mode 100644 index 0000000..3dbdc46 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-haskell.elc diff --git a/.emacs.d/org-7.4/lisp/ob-js.el b/.emacs.d/org-7.4/lisp/ob-js.el new file mode 100644 index 0000000..05f8ea4 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-js.el @@ -0,0 +1,165 @@ +;;; ob-js.el --- org-babel functions for Javascript + +;; Copyright (C) 2010 Free Software Foundation + +;; Author: Eric Schulte +;; Keywords: literate programming, reproducible research, js +;; Homepage: http://orgmode.org +;; Version: 7.4 + +;;; License: + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; Now working with SBCL for both session and external evaluation. +;; +;; This certainly isn't optimally robust, but it seems to be working +;; for the basic use cases. + +;;; Requirements: + +;; - a non-browser javascript engine such as node.js http://nodejs.org/ +;; or mozrepl http://wiki.github.com/bard/mozrepl/ +;; +;; - for session based evaluation mozrepl and moz.el are required see +;; http://wiki.github.com/bard/mozrepl/emacs-integration for +;; configuration instructions + +;;; Code: +(require 'ob) +(require 'ob-ref) +(require 'ob-comint) +(require 'ob-eval) +(eval-when-compile (require 'cl)) + +(declare-function run-mozilla "ext:moz" (arg)) + +(defvar org-babel-default-header-args:js '() + "Default header arguments for js code blocks.") + +(defvar org-babel-js-eoe "org-babel-js-eoe" + "String to indicate that evaluation has completed.") + +(defcustom org-babel-js-cmd "node" + "Name of command used to evaluate js blocks." + :group 'org-babel + :type 'string) + +(defvar org-babel-js-function-wrapper + "require('sys').print(require('sys').inspect(function(){%s}()));" + "Javascript code to print value of body.") + +(defun org-babel-execute:js (body params) + "Execute a block of Javascript code with org-babel. +This function is called by `org-babel-execute-src-block'" + (let* ((org-babel-js-cmd (or (cdr (assoc :cmd params)) org-babel-js-cmd)) + (result-type (cdr (assoc :result-type params))) + (full-body (org-babel-expand-body:generic + body params (org-babel-variable-assignments:js params)))) + (org-babel-js-read + (if (not (string= (cdr (assoc :session params)) "none")) + ;; session evaluation + (let ((session (org-babel-prep-session:js + (cdr (assoc :session params)) params))) + (nth 1 + (org-babel-comint-with-output + (session (format "%S" org-babel-js-eoe) t body) + (mapc + (lambda (line) + (insert (org-babel-chomp line)) (comint-send-input nil t)) + (list body (format "%S" org-babel-js-eoe)))))) + ;; external evaluation + (let ((script-file (org-babel-temp-file "js-script-"))) + (with-temp-file script-file + (insert + ;; return the value or the output + (if (string= result-type "value") + (format org-babel-js-function-wrapper full-body) + full-body))) + (org-babel-eval + (format "%s %s" org-babel-js-cmd + (org-babel-process-file-name script-file)) "")))))) + +(defun org-babel-js-read (results) + "Convert RESULTS into an appropriate elisp value. +If RESULTS look like a table, then convert them into an +Emacs-lisp table, otherwise return the results as a string." + (org-babel-read + (if (and (stringp results) (string-match "^\\[.+\\]$" results)) + (org-babel-read + (concat "'" + (replace-regexp-in-string + "\\[" "(" (replace-regexp-in-string + "\\]" ")" (replace-regexp-in-string + ", " " " (replace-regexp-in-string + "'" "\"" results)))))) + results))) + +(defun org-babel-js-var-to-js (var) + "Convert VAR into a js variable. +Convert an elisp value into a string of js source code +specifying a variable of the same value." + (if (listp var) + (concat "[" (mapconcat #'org-babel-js-var-to-js var ", ") "]") + (format "%S" var))) + +(defun org-babel-prep-session:js (session params) + "Prepare SESSION according to the header arguments specified in PARAMS." + (let* ((session (org-babel-js-initiate-session session)) + (var-lines (org-babel-variable-assignments:js params))) + (when session + (org-babel-comint-in-buffer session + (sit-for .5) (goto-char (point-max)) + (mapc (lambda (var) + (insert var) (comint-send-input nil t) + (org-babel-comint-wait-for-output session) + (sit-for .1) (goto-char (point-max))) var-lines))) + session)) + +(defun org-babel-variable-assignments:js (params) + "Return list of Javascript statements assigning the block's variables" + (mapcar + (lambda (pair) (format "var %s=%s;" + (car pair) (org-babel-js-var-to-js (cdr pair)))) + (mapcar #'cdr (org-babel-get-header params :var)))) + +(defun org-babel-js-initiate-session (&optional session) + "If there is not a current inferior-process-buffer in SESSION +then create. Return the initialized session." + (unless (string= session "none") + (cond + ((string= "mozrepl" org-babel-js-cmd) + (require 'moz) + (let ((session-buffer (save-window-excursion + (run-mozilla nil) + (rename-buffer session) + (current-buffer)))) + (if (org-babel-comint-buffer-livep session-buffer) + (progn (sit-for .25) session-buffer) + (sit-for .5) + (org-babel-js-initiate-session session)))) + ((string= "node" org-babel-js-cmd ) + (error "session evaluation with node.js is not supported")) + (t + (error "sessions are only supported with mozrepl add \":cmd mozrepl\""))))) + +(provide 'ob-js) + +;; arch-tag: 84401fb3-b8d9-4bb6-9a90-cbe2d103d494 + +;;; ob-js.el ends here diff --git a/.emacs.d/org-7.4/lisp/ob-js.elc b/.emacs.d/org-7.4/lisp/ob-js.elc Binary files differnew file mode 100644 index 0000000..f4e26d3 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-js.elc diff --git a/.emacs.d/org-7.4/lisp/ob-keys.el b/.emacs.d/org-7.4/lisp/ob-keys.el new file mode 100644 index 0000000..af81906 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-keys.el @@ -0,0 +1,98 @@ +;;; ob-keys.el --- key bindings for org-babel + +;; Copyright (C) 2009, 2010 Free Software Foundation, Inc. + +;; Author: Eric Schulte +;; Keywords: literate programming, reproducible research +;; Homepage: http://orgmode.org +;; Version: 7.4 + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Add org-babel keybindings to the org-mode keymap for exposing +;; org-babel functions. These will all share a common prefix. See +;; the value of `org-babel-key-bindings' for a list of interactive +;; functions and their associated keys. + +;;; Code: +(require 'ob) + +(defvar org-babel-key-prefix "\C-c\C-v" + "The key prefix for Babel interactive key-bindings. +See `org-babel-key-bindings' for the list of interactive babel +functions which are assigned key bindings, and see +`org-babel-map' for the actual babel keymap.") + +(defvar org-babel-map (make-sparse-keymap) + "The keymap for interactive Babel functions.") + +;;;###autoload +(defun org-babel-describe-bindings () + "Describe all keybindings behind `org-babel-key-prefix'." + (interactive) + (describe-bindings org-babel-key-prefix)) + +(defvar org-babel-key-bindings + '(("p" . org-babel-previous-src-block) + ("\C-p" . org-babel-previous-src-block) + ("n" . org-babel-next-src-block) + ("\C-n" . org-babel-next-src-block) + ("e" . org-babel-execute-maybe) + ("\C-e" . org-babel-execute-maybe) + ("o" . org-babel-open-src-block-result) + ("\C-o" . org-babel-open-src-block-result) + ("\C-v" . org-babel-expand-src-block) + ("v" . org-babel-expand-src-block) + ("u" . org-babel-goto-src-block-head) + ("\C-u" . org-babel-goto-src-block-head) + ("g" . org-babel-goto-named-src-block) + ("r" . org-babel-goto-named-result) + ("\C-r" . org-babel-goto-named-result) + ("\C-b" . org-babel-execute-buffer) + ("b" . org-babel-execute-buffer) + ("\C-s" . org-babel-execute-subtree) + ("s" . org-babel-execute-subtree) + ("\C-d" . org-babel-demarcate-block) + ("d" . org-babel-demarcate-block) + ("\C-t" . org-babel-tangle) + ("t" . org-babel-tangle) + ("\C-f" . org-babel-tangle-file) + ("f" . org-babel-tangle-file) + ("\C-l" . org-babel-load-in-session) + ("l" . org-babel-load-in-session) + ("\C-i" . org-babel-lob-ingest) + ("i" . org-babel-lob-ingest) + ("\C-z" . org-babel-switch-to-session) + ("z" . org-babel-switch-to-session-with-code) + ("\C-a" . org-babel-sha1-hash) + ("a" . org-babel-sha1-hash) + ("h" . org-babel-describe-bindings) + ("\C-x" . org-babel-do-key-sequence-in-edit-buffer) + ("x" . org-babel-do-key-sequence-in-edit-buffer) + ("\C-\M-h" . org-babel-mark-block)) + "Alist of key bindings and interactive Babel functions. +This list associates interactive Babel functions +with keys. Each element of this list will add an entry to the +`org-babel-map' using the letter key which is the `car' of the +a-list placed behind the generic `org-babel-key-prefix'.") + +(provide 'ob-keys) + +;; arch-tag: 01e348ee-4906-46fa-839a-6b7b6f989048 + +;;; ob-keys.el ends here diff --git a/.emacs.d/org-7.4/lisp/ob-keys.elc b/.emacs.d/org-7.4/lisp/ob-keys.elc Binary files differnew file mode 100644 index 0000000..b0d06d8 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-keys.elc diff --git a/.emacs.d/org-7.4/lisp/ob-latex.el b/.emacs.d/org-7.4/lisp/ob-latex.el new file mode 100644 index 0000000..96afbcd --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-latex.el @@ -0,0 +1,180 @@ +;;; ob-latex.el --- org-babel functions for latex "evaluation" + +;; Copyright (C) 2009, 2010 Free Software Foundation, Inc. + +;; Author: Eric Schulte +;; Keywords: literate programming, reproducible research +;; Homepage: http://orgmode.org +;; Version: 7.4 + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Org-Babel support for evaluating LaTeX source code. +;; +;; Currently on evaluation this returns raw LaTeX code, unless a :file +;; header argument is given in which case small png or pdf files will +;; be created directly form the latex source code. + +;;; Code: +(require 'ob) + +(declare-function org-create-formula-image "org" (string tofile options buffer)) +(declare-function org-splice-latex-header "org" + (tpl def-pkg pkg snippets-p &optional extra)) +(declare-function org-export-latex-fix-inputenc "org-latex" ()) +(add-to-list 'org-babel-tangle-lang-exts '("latex" . "tex")) + +(defvar org-format-latex-header) +(defvar org-format-latex-header-extra) +(defvar org-export-latex-packages-alist) +(defvar org-export-latex-default-packages-alist) +(defvar org-export-pdf-logfiles) +(defvar org-latex-to-pdf-process) +(defvar org-export-pdf-remove-logfiles) +(defvar org-format-latex-options) +(defvar org-export-latex-packages-alist) + +(defvar org-babel-default-header-args:latex + '((:results . "latex") (:exports . "results")) + "Default arguments to use when evaluating a LaTeX source block.") + +(defun org-babel-expand-body:latex (body params) + "Expand BODY according to PARAMS, return the expanded body." + (mapc (lambda (pair) ;; replace variables + (setq body + (replace-regexp-in-string + (regexp-quote (format "%S" (car pair))) + (if (stringp (cdr pair)) + (cdr pair) (format "%S" (cdr pair))) + body))) (mapcar #'cdr (org-babel-get-header params :var))) + (org-babel-trim body)) + +(defun org-babel-execute:latex (body params) + "Execute a block of Latex code with Babel. +This function is called by `org-babel-execute-src-block'." + (setq body (org-babel-expand-body:latex body params)) + (if (cdr (assoc :file params)) + (let* ((out-file (cdr (assoc :file params))) + (tex-file (org-babel-temp-file "latex-" ".tex")) + (border (cdr (assoc :border params))) + (fit (or (cdr (assoc :fit params)) border)) + (height (and fit (cdr (assoc :pdfheight params)))) + (width (and fit (cdr (assoc :pdfwidth params)))) + (headers (cdr (assoc :headers params))) + (in-buffer (not (string= "no" (cdr (assoc :buffer params))))) + (org-export-latex-packages-alist + (append (cdr (assoc :packages params)) + org-export-latex-packages-alist))) + (cond + ((string-match "\\.png$" out-file) + (org-create-formula-image + body out-file org-format-latex-options in-buffer)) + ((string-match "\\.pdf$" out-file) + (require 'org-latex) + (with-temp-file tex-file + (insert + (org-splice-latex-header + org-format-latex-header + (delq + nil + (mapcar + (lambda (el) + (unless (and (listp el) (string= "hyperref" (cadr el))) + el)) + org-export-latex-default-packages-alist)) + org-export-latex-packages-alist + org-format-latex-header-extra) + (if fit "\n\\usepackage[active, tightpage]{preview}\n" "") + (if border (format "\\setlength{\\PreviewBorder}{%s}" border) "") + (if height (concat "\n" (format "\\pdfpageheight %s" height)) "") + (if width (concat "\n" (format "\\pdfpagewidth %s" width)) "") + (if headers + (concat "\n" + (if (listp headers) + (mapconcat #'identity headers "\n") + headers) "\n") + "") + (if org-format-latex-header-extra + (concat "\n" org-format-latex-header-extra) + "") + (if fit + (concat "\n\\begin{document}\n\\begin{preview}\n" body + "\n\\end{preview}\n\\end{document}\n") + (concat "\n\\begin{document}\n" body "\n\\end{document}\n"))) + (org-export-latex-fix-inputenc)) + (when (file-exists-p out-file) (delete-file out-file)) + (rename-file (org-babel-latex-tex-to-pdf tex-file) out-file)) + ((string-match "\\.\\([^\\.]+\\)$" out-file) + (error "can not create %s files, please specify a .png or .pdf file" + (match-string 1 out-file)))) + out-file) + body)) + +(defun org-babel-latex-tex-to-pdf (file) + "Generate a pdf file according to the contents FILE. +Extracted from `org-export-as-pdf' in org-latex.el." + (let* ((wconfig (current-window-configuration)) + (default-directory (file-name-directory file)) + (base (file-name-sans-extension file)) + (pdffile (concat base ".pdf")) + (cmds org-latex-to-pdf-process) + (outbuf (get-buffer-create "*Org PDF LaTeX Output*")) + output-dir cmd) + (with-current-buffer outbuf (erase-buffer)) + (message (concat "Processing LaTeX file " file "...")) + (setq output-dir (file-name-directory file)) + (if (and cmds (symbolp cmds)) + (funcall cmds (shell-quote-argument file)) + (while cmds + (setq cmd (pop cmds)) + (while (string-match "%b" cmd) + (setq cmd (replace-match + (save-match-data + (shell-quote-argument base)) + t t cmd))) + (while (string-match "%f" cmd) + (setq cmd (replace-match + (save-match-data + (shell-quote-argument file)) + t t cmd))) + (while (string-match "%o" cmd) + (setq cmd (replace-match + (save-match-data + (shell-quote-argument output-dir)) + t t cmd))) + (shell-command cmd outbuf))) + (message (concat "Processing LaTeX file " file "...done")) + (if (not (file-exists-p pdffile)) + (error (concat "PDF file " pdffile " was not produced")) + (set-window-configuration wconfig) + (when org-export-pdf-remove-logfiles + (dolist (ext org-export-pdf-logfiles) + (setq file (concat base "." ext)) + (and (file-exists-p file) (delete-file file)))) + (message "Exporting to PDF...done") + pdffile))) + +(defun org-babel-prep-session:latex (session params) + "Return an error because LaTeX doesn't support sesstions." + (error "LaTeX does not support sessions")) + +(provide 'ob-latex) + +;; arch-tag: 1f13f7e2-26de-4c24-9274-9f331d4c6ff3 + +;;; ob-latex.el ends here diff --git a/.emacs.d/org-7.4/lisp/ob-latex.elc b/.emacs.d/org-7.4/lisp/ob-latex.elc Binary files differnew file mode 100644 index 0000000..5f7f6db --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-latex.elc diff --git a/.emacs.d/org-7.4/lisp/ob-ledger.el b/.emacs.d/org-7.4/lisp/ob-ledger.el new file mode 100644 index 0000000..a02eb6f --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-ledger.el @@ -0,0 +1,72 @@ +;;; ob-ledger.el --- org-babel functions for ledger evaluation + +;; Copyright (C) 2010 Free Software Foundation, Inc. + +;; Author: Eric S Fraga +;; Keywords: literate programming, reproducible research, accounting +;; Homepage: http://orgmode.org +;; Version: 7.4 + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Org-Babel support for evaluating ledger entries. +;; +;; This differs from most standard languages in that +;; +;; 1) there is no such thing as a "session" in ledger +;; +;; 2) we are generally only going to return output from the leger program +;; +;; 3) we are adding the "cmdline" header argument +;; +;; 4) there are no variables + +;;; Code: +(require 'ob) + +(defvar org-babel-default-header-args:ledger + '((:results . "output") (:cmdline . "bal")) + "Default arguments to use when evaluating a ledger source block.") + +(defun org-babel-execute:ledger (body params) + "Execute a block of Ledger entries with org-babel. This function is +called by `org-babel-execute-src-block'." + (message "executing Ledger source code block") + (let ((result-params (split-string (or (cdr (assoc :results params)) ""))) + (cmdline (cdr (assoc :cmdline params))) + (in-file (org-babel-temp-file "ledger-")) + (out-file (org-babel-temp-file "ledger-output-"))) + (with-temp-file in-file (insert body)) + (message (concat "ledger" + " -f " (org-babel-process-file-name in-file) + " " cmdline)) + (with-output-to-string + (shell-command (concat "ledger" + " -f " (org-babel-process-file-name in-file) + " " cmdline + " > " (org-babel-process-file-name out-file)))) + (with-temp-buffer (insert-file-contents out-file) (buffer-string)))) + +(defun org-babel-prep-session:ledger (session params) + (error "Ledger does not support sessions")) + +(provide 'ob-ledger) + +;; arch-tag: 7bbb529e-95a1-4236-9d29-b0000b918c7c + +;;; ob-ledger.el ends here diff --git a/.emacs.d/org-7.4/lisp/ob-ledger.elc b/.emacs.d/org-7.4/lisp/ob-ledger.elc Binary files differnew file mode 100644 index 0000000..4b8710c --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-ledger.elc diff --git a/.emacs.d/org-7.4/lisp/ob-lob.el b/.emacs.d/org-7.4/lisp/ob-lob.el new file mode 100644 index 0000000..137a6bc --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-lob.el @@ -0,0 +1,124 @@ +;;; ob-lob.el --- functions supporting the Library of Babel + +;; Copyright (C) 2009, 2010 Free Software Foundation, Inc. + +;; Author: Eric Schulte, Dan Davison +;; Keywords: literate programming, reproducible research +;; Homepage: http://orgmode.org +;; Version: 7.4 + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; See the online documentation for more information +;; +;; http://orgmode.org/worg/org-contrib/babel/ + +;;; Code: +(require 'ob) +(require 'ob-table) + +(defvar org-babel-library-of-babel nil + "Library of source-code blocks. +This is an association list. Populate the library by adding +files to `org-babel-lob-files'.") + +(defcustom org-babel-lob-files '() + "Files used to populate the `org-babel-library-of-babel'. +To add files to this list use the `org-babel-lob-ingest' command." + :group 'org-babel + :type 'list) + +;;;###autoload +(defun org-babel-lob-ingest (&optional file) + "Add all named source-blocks defined in FILE to +`org-babel-library-of-babel'." + (interactive "f") + (let ((lob-ingest-count 0)) + (org-babel-map-src-blocks file + (let* ((info (org-babel-get-src-block-info 'light)) + (source-name (nth 4 info))) + (when source-name + (setq source-name (intern source-name) + org-babel-library-of-babel + (cons (cons source-name info) + (assq-delete-all source-name org-babel-library-of-babel)) + lob-ingest-count (1+ lob-ingest-count))))) + (message "%d src block%s added to Library of Babel" + lob-ingest-count (if (> lob-ingest-count 1) "s" "")) + lob-ingest-count)) + +(defconst org-babel-lob-call-aliases '("lob" "call") + "Aliases to call a source block function. +If you change the value of this variable then your files may + become unusable by other org-babel users, and vice versa.") + +(defconst org-babel-lob-one-liner-regexp + (concat + "^\\([ \t]*\\)#\\+\\(?:" + (mapconcat #'regexp-quote org-babel-lob-call-aliases "\\|") + "\\):[ \t]+\\([^\(\)\n]+?\\)\\(\\[\\(.*\\)\\]\\|\\(\\)\\)" + "\(\\([^\n]*\\)\)\\(\\[.+\\]\\|\\)[ \t]*\\([^\n]*\\)") + "Regexp to match calls to predefined source block functions.") + +;; functions for executing lob one-liners +;;;###autoload +(defun org-babel-lob-execute-maybe () + "Execute a Library of Babel source block, if appropriate. +Detect if this is context for a Library Of Babel source block and +if so then run the appropriate source block from the Library." + (interactive) + (let ((info (org-babel-lob-get-info))) + (if (nth 0 info) (progn (org-babel-lob-execute info) t) nil))) + +;;;###autoload +(defun org-babel-lob-get-info () + "Return a Library of Babel function call as a string." + (let ((case-fold-search t)) + (save-excursion + (beginning-of-line 1) + (if (looking-at org-babel-lob-one-liner-regexp) + (append + (mapcar #'org-babel-clean-text-properties + (list + (format "%s%s(%s)%s" + (match-string 2) + (if (match-string 4) + (concat "[" (match-string 4) "]") "") + (or (match-string 6) "") (match-string 7)) + (match-string 8))) + (list (length (match-string 1)))))))) + +(defun org-babel-lob-execute (info) + "Execute the lob call specified by INFO." + (let ((params (org-babel-process-params + (org-babel-merge-params + org-babel-default-header-args + (org-babel-params-from-buffer) + (org-babel-params-from-properties) + (org-babel-parse-header-arguments + (org-babel-clean-text-properties + (concat ":var results=" + (mapconcat #'identity (butlast info) " ")))))))) + (org-babel-execute-src-block + nil (list "emacs-lisp" "results" params nil nil (nth 2 info))))) + +(provide 'ob-lob) + +;; arch-tag: ce0712c9-2147-4019-ba3f-42341b8b474b + +;;; ob-lob.el ends here diff --git a/.emacs.d/org-7.4/lisp/ob-lob.elc b/.emacs.d/org-7.4/lisp/ob-lob.elc Binary files differnew file mode 100644 index 0000000..3430f2c --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-lob.elc diff --git a/.emacs.d/org-7.4/lisp/ob-matlab.el b/.emacs.d/org-7.4/lisp/ob-matlab.el new file mode 100644 index 0000000..192c73d --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-matlab.el @@ -0,0 +1,48 @@ +;;; ob-matlab.el --- org-babel support for matlab evaluation + +;; Copyright (C) 2010 Free Software Foundation, Inc. + +;; Author: Dan Davison +;; Keywords: literate programming, reproducible research +;; Homepage: http://orgmode.org +;; Version: 7.4 + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Functions that are common to org-babel support for matlab and +;; octave are in org-babel-octave.el + +;;; Requirements: + +;; Matlab + +;; matlab.el required for interactive emacs sessions and matlab-mode +;; major mode for source code editing buffer +;; http://matlab-emacs.sourceforge.net/ + +;;; Code: +(require 'ob) +(require 'ob-octave) + +;; see ob-octave for matlab implementation + +(provide 'ob-matlab) + +;; arch-tag: 6b234299-c1f7-4eb1-ace8-7b93344065ac + +;;; ob-matlab.el ends here diff --git a/.emacs.d/org-7.4/lisp/ob-matlab.elc b/.emacs.d/org-7.4/lisp/ob-matlab.elc Binary files differnew file mode 100644 index 0000000..195d105 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-matlab.elc diff --git a/.emacs.d/org-7.4/lisp/ob-mscgen.el b/.emacs.d/org-7.4/lisp/ob-mscgen.el new file mode 100644 index 0000000..98230da --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-mscgen.el @@ -0,0 +1,86 @@ +;;; ob-msc.el --- org-babel functions for mscgen evaluation + +;; Copyright (C) 2010 Free Software Foundation, Inc. + +;; Author: Juan Pechiar +;; Keywords: literate programming, reproducible research +;; Homepage: http://orgmode.org +;; Version: 7.4 + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; This software provides EMACS org-babel export support for message +;; sequence charts. The mscgen utility is used for processing the +;; sequence definition, and must therefore be installed in the system. +;; +;; Mscgen is available and documented at +;; http://www.mcternan.me.uk/mscgen/index.html +;; +;; This code is directly inspired by Eric Schulte's ob-dot.el +;; +;; Example: +;; +;; #+begin_src mscgen :file example.png +;; msc { +;; A,B; +;; A -> B [ label = "send message" ]; +;; A <- B [ label = "get answer" ]; +;; } +;; #+end_src +;; +;; Header for alternative file type: +;; +;; #+begin_src mscgen :file ex2.svg :filetype svg + +;; This differs from most standard languages in that +;; +;; 1) there is no such thing as a "session" in mscgen +;; 2) we are generally only going to return results of type "file" +;; 3) we are adding the "file" and "filetype" header arguments +;; 4) there are no variables + +;;; Code: +(require 'ob) +(require 'ob-eval) + +(defvar org-babel-default-header-args:mscgen + '((:results . "file") (:exports . "results")) + "Default arguments to use when evaluating a mscgen source block.") + +(defun org-babel-execute:mscgen (body params) + "Execute a block of Mscgen code with Babel. +This function is called by `org-babel-execute-src-block'. +Default filetype is png. Modify by setting :filetype parameter to +mscgen supported formats." + (let* ((out-file (or (cdr (assoc :file params)) "output.png" )) + (filetype (or (cdr (assoc :filetype params)) "png" ))) + (unless (cdr (assoc :file params)) + (error " +ERROR: no output file specified. Add \":file name.png\" to the src header")) + (org-babel-eval (concat "mscgen -T " filetype " -o " out-file) body) + out-file)) + +(defun org-babel-prep-session:mscgen (session params) + "Raise an error because Mscgen doesn't support sessions." + (error "Mscgen does not support sessions")) + +(provide 'ob-mscgen) + +;; arch-tag: 74695b1e-715f-4b5a-a3a9-d78ee39ba5c8 + +;;; ob-msc.el ends here diff --git a/.emacs.d/org-7.4/lisp/ob-mscgen.elc b/.emacs.d/org-7.4/lisp/ob-mscgen.elc Binary files differnew file mode 100644 index 0000000..f29f295 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-mscgen.elc diff --git a/.emacs.d/org-7.4/lisp/ob-ocaml.el b/.emacs.d/org-7.4/lisp/ob-ocaml.el new file mode 100644 index 0000000..459dcf3 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-ocaml.el @@ -0,0 +1,157 @@ +;;; ob-ocaml.el --- org-babel functions for ocaml evaluation + +;; Copyright (C) 2009, 2010 Free Software Foundation, Inc. + +;; Author: Eric Schulte +;; Keywords: literate programming, reproducible research +;; Homepage: http://orgmode.org +;; Version: 7.4 + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Org-Babel support for evaluating ocaml source code. This one will +;; be sort of tricky because ocaml programs must be compiled before +;; they can be run, but ocaml code can also be run through an +;; interactive interpreter. +;; +;; For now lets only allow evaluation using the ocaml interpreter. + +;;; Requirements: + +;; - tuareg-mode :: http://www-rocq.inria.fr/~acohen/tuareg/ + +;;; Code: +(require 'ob) +(require 'ob-comint) +(require 'comint) +(eval-when-compile (require 'cl)) + +(declare-function tuareg-run-caml "ext:tuareg" ()) +(declare-function tuareg-interactive-send-input "ext:tuareg" ()) + +(add-to-list 'org-babel-tangle-lang-exts '("ocaml" . "ml")) + +(defvar org-babel-default-header-args:ocaml '()) + +(defvar org-babel-ocaml-eoe-indicator "\"org-babel-ocaml-eoe\";;") +(defvar org-babel-ocaml-eoe-output "org-babel-ocaml-eoe") + +(defun org-babel-execute:ocaml (body params) + "Execute a block of Ocaml code with Babel." + (let* ((vars (mapcar #'cdr (org-babel-get-header params :var))) + (full-body (org-babel-expand-body:generic + body params + (org-babel-variable-assignments:ocaml params))) + (session (org-babel-prep-session:ocaml + (cdr (assoc :session params)) params)) + (raw (org-babel-comint-with-output + (session org-babel-ocaml-eoe-output t full-body) + (insert + (concat + (org-babel-chomp full-body)"\n"org-babel-ocaml-eoe-indicator)) + (tuareg-interactive-send-input))) + (clean + (car (let ((re (regexp-quote org-babel-ocaml-eoe-output)) out) + (delq nil (mapcar (lambda (line) + (if out + (progn (setq out nil) line) + (when (string-match re line) + (progn (setq out t) nil)))) + (mapcar #'org-babel-trim (reverse raw)))))))) + (org-babel-reassemble-table + (org-babel-ocaml-parse-output (org-babel-trim clean)) + (org-babel-pick-name + (cdr (assoc :colname-names params)) (cdr (assoc :colnames params))) + (org-babel-pick-name + (cdr (assoc :rowname-names params)) (cdr (assoc :rownames params)))))) + +(defvar tuareg-interactive-buffer-name) +(defun org-babel-prep-session:ocaml (session params) + "Prepare SESSION according to the header arguments in PARAMS." + (require 'tuareg) + (let ((tuareg-interactive-buffer-name (if (and (not (string= session "none")) + (not (string= session "default")) + (stringp session)) + session + tuareg-interactive-buffer-name))) + (save-window-excursion (tuareg-run-caml) + (get-buffer tuareg-interactive-buffer-name)))) + +(defun org-babel-variable-assignments:ocaml (params) + "Return list of ocaml statements assigning the block's variables" + (mapcar + (lambda (pair) (format "let %s = %s;;" (car pair) + (org-babel-ocaml-elisp-to-ocaml (cdr pair)))) + (mapcar #'cdr (org-babel-get-header params :var)))) + +(defun org-babel-ocaml-elisp-to-ocaml (val) + "Return a string of ocaml code which evaluates to VAL." + (if (listp val) + (concat "[|" (mapconcat #'org-babel-ocaml-elisp-to-ocaml val "; ") "|]") + (format "%S" val))) + +(defun org-babel-ocaml-parse-output (output) + "Parse OUTPUT. +OUTPUT is string output from an ocaml process." + (let ((regexp "%s = \\(.+\\)$")) + (cond + ((string-match (format regexp "string") output) + (org-babel-read (match-string 1 output))) + ((or (string-match (format regexp "int") output) + (string-match (format regexp "float") output)) + (string-to-number (match-string 1 output))) + ((string-match (format regexp "list") output) + (org-babel-ocaml-read-list (match-string 1 output))) + ((string-match (format regexp "array") output) + (org-babel-ocaml-read-array (match-string 1 output))) + (t (message "don't recognize type of %s" output) output)))) + +(defun org-babel-ocaml-read-list (results) + "Convert RESULTS into an elisp table or string. +If the results look like a table, then convert them into an +Emacs-lisp table, otherwise return the results as a string." + (org-babel-read + (if (and (stringp results) (string-match "^\\[.+\\]$" results)) + (org-babel-read + (replace-regexp-in-string + "\\[" "(" (replace-regexp-in-string + "\\]" ")" (replace-regexp-in-string + "; " " " (replace-regexp-in-string + "'" "\"" results))))) + results))) + +(defun org-babel-ocaml-read-array (results) + "Convert RESULTS into an elisp table or string. +If the results look like a table, then convert them into an +Emacs-lisp table, otherwise return the results as a string." + (org-babel-read + (if (and (stringp results) (string-match "^\\[.+\\]$" results)) + (org-babel-read + (concat + "'" (replace-regexp-in-string + "\\[|" "(" (replace-regexp-in-string + "|\\]" ")" (replace-regexp-in-string + "; " " " (replace-regexp-in-string + "'" "\"" results)))))) + results))) + +(provide 'ob-ocaml) + +;; arch-tag: 2e815f4d-365e-4d69-b1df-dd17fdd7b7b7 + +;;; ob-ocaml.el ends here diff --git a/.emacs.d/org-7.4/lisp/ob-ocaml.elc b/.emacs.d/org-7.4/lisp/ob-ocaml.elc Binary files differnew file mode 100644 index 0000000..e59b9c7 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-ocaml.elc diff --git a/.emacs.d/org-7.4/lisp/ob-octave.el b/.emacs.d/org-7.4/lisp/ob-octave.el new file mode 100644 index 0000000..9fcd825 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-octave.el @@ -0,0 +1,264 @@ +;;; ob-octave.el --- org-babel functions for octave and matlab evaluation + +;; Copyright (C) 2010 Free Software Foundation, Inc. + +;; Author: Dan Davison +;; Keywords: literate programming, reproducible research +;; Homepage: http://orgmode.org +;; Version: 7.4 + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;;; Requirements: + +;; octave +;; octave-mode.el and octave-inf.el come with GNU emacs + +;;; Code: +(require 'ob) +(require 'ob-ref) +(require 'ob-comint) +(require 'ob-eval) +(eval-when-compile (require 'cl)) + +(declare-function matlab-shell "ext:matlab-mode") +(declare-function matlab-shell-run-region "ext:matlab-mode") + +(defvar org-babel-default-header-args:matlab '()) +(defvar org-babel-default-header-args:octave '()) + +(defvar org-babel-matlab-shell-command "matlab -nosplash" + "Shell command to run matlab as an external process.") +(defvar org-babel-octave-shell-command "octave -q" + "Shell command to run octave as an external process.") + +(defvar org-babel-matlab-with-emacs-link nil + "If non-nil use matlab-shell-run-region for session evaluation. + This will use EmacsLink if (matlab-with-emacs-link) evaluates + to a non-nil value.") + +(defvar org-babel-matlab-emacs-link-wrapper-method + "%s +if ischar(ans), fid = fopen('%s', 'w'); fprintf(fid, '%%s\\n', ans); fclose(fid); +else, save -ascii %s ans +end +delete('%s') +") +(defvar org-babel-octave-wrapper-method + "%s +if ischar(ans), fid = fopen('%s', 'w'); fprintf(fid, '%%s\\n', ans); fclose(fid); +else, dlmwrite('%s', ans, '\\t') +end") + +(defvar org-babel-octave-eoe-indicator "\'org_babel_eoe\'") + +(defvar org-babel-octave-eoe-output "ans = org_babel_eoe") + +(defun org-babel-execute:matlab (body params) + "Execute a block of matlab code with Babel." + (org-babel-execute:octave body params 'matlab)) + +(defun org-babel-execute:octave (body params &optional matlabp) + "Execute a block of octave code with Babel." + (let* ((session + (funcall (intern (format "org-babel-%s-initiate-session" + (if matlabp "matlab" "octave"))) + (cdr (assoc :session params)) params)) + (vars (mapcar #'cdr (org-babel-get-header params :var))) + (result-params (cdr (assoc :result-params params))) + (result-type (cdr (assoc :result-type params))) + (out-file (cdr (assoc :file params))) + (full-body + (org-babel-expand-body:generic + body params (org-babel-variable-assignments:octave params))) + (result (org-babel-octave-evaluate + session full-body result-type matlabp))) + (or out-file + (org-babel-reassemble-table + result + (org-babel-pick-name + (cdr (assoc :colname-names params)) (cdr (assoc :colnames params))) + (org-babel-pick-name + (cdr (assoc :rowname-names params)) (cdr (assoc :rownames params))))))) + +(defun org-babel-prep-session:matlab (session params) + "Prepare SESSION according to PARAMS." + (org-babel-prep-session:octave session params 'matlab)) + +(defun org-babel-variable-assignments:octave (params) + "Return list of octave statements assigning the block's variables" + (mapcar + (lambda (pair) + (format "%s=%s" + (car pair) + (org-babel-octave-var-to-octave (cdr pair)))) + (mapcar #'cdr (org-babel-get-header params :var)))) + +(defalias 'org-babel-variable-assignments:matlab + 'org-babel-variable-assignments:octave) + +(defun org-babel-octave-var-to-octave (var) + "Convert an emacs-lisp value into an octave variable. +Converts an emacs-lisp variable into a string of octave code +specifying a variable of the same value." + (if (listp var) + (concat "[" (mapconcat #'org-babel-octave-var-to-octave var + (if (listp (car var)) "; " ",")) "]") + (format "%s" (or var "nil")))) + +(defun org-babel-prep-session:octave (session params &optional matlabp) + "Prepare SESSION according to the header arguments specified in PARAMS." + (let* ((session (org-babel-octave-initiate-session session params matlabp)) + (var-lines (org-babel-variable-assignments:octave params))) + (org-babel-comint-in-buffer session + (mapc (lambda (var) + (end-of-line 1) (insert var) (comint-send-input nil t) + (org-babel-comint-wait-for-output session)) var-lines)) + session)) + +(defun org-babel-matlab-initiate-session (&optional session params) + "Create a matlab inferior process buffer. +If there is not a current inferior-process-buffer in SESSION then +create. Return the initialized session." + (org-babel-octave-initiate-session session params 'matlab)) + +(defun org-babel-octave-initiate-session (&optional session params matlabp) + "Create an octave inferior process buffer. +If there is not a current inferior-process-buffer in SESSION then +create. Return the initialized session." + (if matlabp (require 'matlab) (require 'octave-inf)) + (unless (string= session "none") + (let ((session (or session + (if matlabp "*Inferior Matlab*" "*Inferior Octave*")))) + (if (org-babel-comint-buffer-livep session) session + (save-window-excursion + (if matlabp (unless org-babel-matlab-with-emacs-link (matlab-shell)) + (run-octave)) + (rename-buffer (if (bufferp session) (buffer-name session) + (if (stringp session) session (buffer-name)))) + (current-buffer)))))) + +(defun org-babel-octave-evaluate + (session body result-type &optional matlabp) + "Pass BODY to the octave process in SESSION. +If RESULT-TYPE equals 'output then return the outputs of the +statements in BODY, if RESULT-TYPE equals 'value then return the +value of the last statement in BODY, as elisp." + (if session + (org-babel-octave-evaluate-session session body result-type matlabp) + (org-babel-octave-evaluate-external-process body result-type matlabp))) + +(defun org-babel-octave-evaluate-external-process (body result-type matlabp) + "Evaluate BODY in an external octave process." + (let ((cmd (if matlabp + org-babel-matlab-shell-command + org-babel-octave-shell-command))) + (case result-type + (output (org-babel-eval cmd body)) + (value (let ((tmp-file (org-babel-temp-file "octave-"))) + (org-babel-eval + cmd + (format org-babel-octave-wrapper-method body + (org-babel-process-file-name tmp-file 'noquote) + (org-babel-process-file-name tmp-file 'noquote))) + (org-babel-octave-import-elisp-from-file tmp-file)))))) + +(defun org-babel-octave-evaluate-session + (session body result-type &optional matlabp) + "Evaluate BODY in SESSION." + (let* ((tmp-file (org-babel-temp-file (if matlabp "matlab-" "octave-"))) + (wait-file (org-babel-temp-file "matlab-emacs-link-wait-signal-")) + (full-body + (case result-type + (output + (mapconcat + #'org-babel-chomp + (list body org-babel-octave-eoe-indicator) "\n")) + (value + (if (and matlabp org-babel-matlab-with-emacs-link) + (concat + (format org-babel-matlab-emacs-link-wrapper-method + body + (org-babel-process-file-name tmp-file 'noquote) + (org-babel-process-file-name tmp-file 'noquote) wait-file) "\n") + (mapconcat + #'org-babel-chomp + (list (format org-babel-octave-wrapper-method + body + (org-babel-process-file-name tmp-file 'noquote) + (org-babel-process-file-name tmp-file 'noquote)) + org-babel-octave-eoe-indicator) "\n"))))) + (raw (if (and matlabp org-babel-matlab-with-emacs-link) + (save-window-excursion + (with-temp-buffer + (insert full-body) + (write-region "" 'ignored wait-file nil nil nil 'excl) + (matlab-shell-run-region (point-min) (point-max)) + (message "Waiting for Matlab Emacs Link") + (while (file-exists-p wait-file) (sit-for 0.01)) + "")) ;; matlab-shell-run-region doesn't seem to + ;; make *matlab* buffer contents easily + ;; available, so :results output currently + ;; won't work + (org-babel-comint-with-output + (session + (if matlabp + org-babel-octave-eoe-indicator + org-babel-octave-eoe-output) + t full-body) + (insert full-body) (comint-send-input nil t)))) results) + (case result-type + (value + (org-babel-octave-import-elisp-from-file tmp-file)) + (output + (progn + (setq results + (if matlabp + (cdr (reverse (delq "" (mapcar + #'org-babel-octave-read-string + (mapcar #'org-babel-trim raw))))) + (cdr (member org-babel-octave-eoe-output + (reverse (mapcar + #'org-babel-octave-read-string + (mapcar #'org-babel-trim raw))))))) + (mapconcat #'identity (reverse results) "\n")))))) + +(defun org-babel-octave-import-elisp-from-file (file-name) + "Import data from FILE-NAME. +This removes initial blank and comment lines and then calls +`org-babel-import-elisp-from-file'." + (let ((temp-file (org-babel-temp-file "octave-matlab-")) beg end) + (with-temp-file temp-file + (insert-file-contents file-name) + (re-search-forward "^[ \t]*[^# \t]" nil t) + (if (< (setq beg (point-min)) + (setq end (point-at-bol))) + (delete-region beg end))) + (org-babel-import-elisp-from-file temp-file '(16)))) + +(defun org-babel-octave-read-string (string) + "Strip \\\"s from around octave string" + (if (string-match "^\"\\([^\000]+\\)\"$" string) + (match-string 1 string) + string)) + +(provide 'ob-octave) + +;; arch-tag: d8e5f68b-ba13-440a-a495-b653e989e704 + +;;; ob-octave.el ends here diff --git a/.emacs.d/org-7.4/lisp/ob-octave.elc b/.emacs.d/org-7.4/lisp/ob-octave.elc Binary files differnew file mode 100644 index 0000000..f72a620 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-octave.elc diff --git a/.emacs.d/org-7.4/lisp/ob-org.el b/.emacs.d/org-7.4/lisp/ob-org.el new file mode 100644 index 0000000..c03fa07 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-org.el @@ -0,0 +1,62 @@ +;;; ob-org.el --- org-babel functions for org code block evaluation + +;; Copyright (C) 2010 Free Software Foundation, Inc. + +;; Author: Eric Schulte +;; Keywords: literate programming, reproducible research +;; Homepage: http://orgmode.org +;; Version: 7.4 + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This is the simplest of code blocks, where upon evaluation the +;; contents of the code block are returned in a raw result. + +;;; Code: +(require 'ob) + +(declare-function org-export-string "org-exp" (string fmt &optional dir)) + +(defvar org-babel-default-header-args:org + '((:results . "raw silent") (:exports . "results")) + "Default arguments for evaluating a org source block.") + +(defvar org-babel-org-default-header + "#+TITLE: default empty header\n" + "Default header inserted during export of org blocks.") + +(defun org-babel-execute:org (body params) + "Execute a block of Org code with. +This function is called by `org-babel-execute-src-block'." + (let ((result-params (split-string (or (cdr (assoc :results params)) ""))) + (body (replace-regexp-in-string "^," "" body))) + (cond + ((member "latex" result-params) (org-export-string body "latex")) + ((member "html" result-params) (org-export-string body "html")) + ((member "ascii" result-params) (org-export-string body "ascii")) + (t body)))) + +(defun org-babel-prep-session:org (session params) + "Return an error because org does not support sessions." + (error "Org does not support sessions")) + +(provide 'ob-org) + +;; arch-tag: 130af5fe-cc56-46bd-9508-fa0ebd94cb1f + +;;; ob-org.el ends here diff --git a/.emacs.d/org-7.4/lisp/ob-org.elc b/.emacs.d/org-7.4/lisp/ob-org.elc Binary files differnew file mode 100644 index 0000000..b991626 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-org.elc diff --git a/.emacs.d/org-7.4/lisp/ob-perl.el b/.emacs.d/org-7.4/lisp/ob-perl.el new file mode 100644 index 0000000..1e0cecb --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-perl.el @@ -0,0 +1,117 @@ +;;; ob-perl.el --- org-babel functions for perl evaluation + +;; Copyright (C) 2009, 2010 Free Software Foundation + +;; Author: Dan Davison, Eric Schulte +;; Keywords: literate programming, reproducible research +;; Homepage: http://orgmode.org +;; Version: 7.4 + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Org-Babel support for evaluating perl source code. + +;;; Code: +(require 'ob) +(require 'ob-eval) +(eval-when-compile (require 'cl)) + +(add-to-list 'org-babel-tangle-lang-exts '("perl" . "pl")) + +(defvar org-babel-default-header-args:perl '()) + +(defvar org-babel-perl-command "perl" + "Name of command to use for executing perl code.") + +(defun org-babel-execute:perl (body params) + "Execute a block of Perl code with Babel. +This function is called by `org-babel-execute-src-block'." + (let* ((session (cdr (assoc :session params))) + (result-params (cdr (assoc :result-params params))) + (result-type (cdr (assoc :result-type params))) + (full-body (org-babel-expand-body:generic + body params (org-babel-variable-assignments:perl params))) + (session (org-babel-perl-initiate-session session))) + (org-babel-reassemble-table + (org-babel-perl-evaluate session full-body result-type) + (org-babel-pick-name + (cdr (assoc :colname-names params)) (cdr (assoc :colnames params))) + (org-babel-pick-name + (cdr (assoc :rowname-names params)) (cdr (assoc :rownames params)))))) + +(defun org-babel-prep-session:perl (session params) + "Prepare SESSION according to the header arguments in PARAMS." + (error "Sessions are not supported for Perl.")) + +(defun org-babel-variable-assignments:perl (params) + "Return list of perl statements assigning the block's variables" + (mapcar + (lambda (pair) + (format "$%s=%s;" + (car pair) + (org-babel-perl-var-to-perl (cdr pair)))) + (mapcar #'cdr (org-babel-get-header params :var)))) + +;; helper functions + +(defun org-babel-perl-var-to-perl (var) + "Convert an elisp value to a perl variable. +The elisp value, VAR, is converted to a string of perl source code +specifying a var of the same value." + (if (listp var) + (concat "[" (mapconcat #'org-babel-perl-var-to-perl var ", ") "]") + (format "%S" var))) + +(defvar org-babel-perl-buffers '(:default . nil)) + +(defun org-babel-perl-initiate-session (&optional session params) + "Return nil because sessions are not supported by perl" +nil) + +(defvar org-babel-perl-wrapper-method + " +sub main { +%s +} +@r = main; +open(o, \">%s\"); +print o join(\"\\n\", @r), \"\\n\"") + +(defvar org-babel-perl-pp-wrapper-method + nil) + +(defun org-babel-perl-evaluate (session body &optional result-type) + "Pass BODY to the Perl process in SESSION. +If RESULT-TYPE equals 'output then return a list of the outputs +of the statements in BODY, if RESULT-TYPE equals 'value then +return the value of the last statement in BODY, as elisp." + (when session (error "Sessions are not supported for Perl.")) + (case result-type + (output (org-babel-eval org-babel-perl-command body)) + (value (let ((tmp-file (org-babel-temp-file "perl-"))) + (org-babel-eval + org-babel-perl-command + (format org-babel-perl-wrapper-method body + (org-babel-process-file-name tmp-file 'noquote))) + (org-babel-eval-read-file tmp-file))))) + +(provide 'ob-perl) + +;; arch-tag: 88ef9396-d857-4dc3-8946-5a72bdfa2337 + +;;; ob-perl.el ends here diff --git a/.emacs.d/org-7.4/lisp/ob-perl.elc b/.emacs.d/org-7.4/lisp/ob-perl.elc Binary files differnew file mode 100644 index 0000000..a6d3d5b --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-perl.elc diff --git a/.emacs.d/org-7.4/lisp/ob-plantuml.el b/.emacs.d/org-7.4/lisp/ob-plantuml.el new file mode 100644 index 0000000..fb81dc8 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-plantuml.el @@ -0,0 +1,83 @@ +;;; ob-plantuml.el --- org-babel functions for plantuml evaluation + +;; Copyright (C) 2010 Free Software Foundation, Inc. + +;; Author: Zhang Weize +;; Keywords: literate programming, reproducible research +;; Homepage: http://orgmode.org +;; Version: 7.4 + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Org-Babel support for evaluating plantuml script. +;; +;; Inspired by Ian Yang's org-export-blocks-format-plantuml +;; http://www.emacswiki.org/emacs/org-export-blocks-format-plantuml.el + +;;; Requirements: + +;; plantuml | http://plantuml.sourceforge.net/ +;; plantuml.jar | `org-plantuml-jar-path' should point to the jar file + +;;; Code: +(require 'ob) +(require 'ob-eval) + +(defvar org-babel-default-header-args:plantuml + '((:results . "file") (:exports . "results")) + "Default arguments for evaluating a plantuml source block.") + +(defcustom org-plantuml-jar-path nil + "Path to the plantuml.jar file." + :group 'org-babel + :type 'string) + +(defun org-babel-execute:plantuml (body params) + "Execute a block of plantuml code with org-babel. +This function is called by `org-babel-execute-src-block'." + (let* ((result-params (split-string (or (cdr (assoc :results params)) ""))) + (out-file (or (cdr (assoc :file params)) + (error "plantuml requires a \":file\" header argument"))) + (cmdline (cdr (assoc :cmdline params))) + (in-file (org-babel-temp-file "plantuml-")) + (cmd (if (not org-plantuml-jar-path) + (error "`org-plantuml-jar-path' is not set") + (concat "java -jar " + (shell-quote-argument + (expand-file-name org-plantuml-jar-path)) + (if (string= (file-name-extension out-file) "svg") + " -tsvg" "") + " -p " cmdline " < " + (org-babel-process-file-name in-file) + " > " + (org-babel-process-file-name out-file))))) + (unless (file-exists-p org-plantuml-jar-path) + (error "Could not find plantuml.jar at %s" org-plantuml-jar-path)) + (with-temp-file in-file (insert (concat "@startuml\n" body "\n@enduml"))) + (message "%s" cmd) (org-babel-eval cmd "") + out-file)) + +(defun org-babel-prep-session:plantuml (session params) + "Return an error because plantuml does not support sessions." + (error "Plantuml does not support sessions")) + +(provide 'ob-plantuml) + +;; arch-tag: 451f50c5-e779-407e-ad64-70e0e8f161d1 + +;;; ob-plantuml.el ends here diff --git a/.emacs.d/org-7.4/lisp/ob-plantuml.elc b/.emacs.d/org-7.4/lisp/ob-plantuml.elc Binary files differnew file mode 100644 index 0000000..28cf32e --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-plantuml.elc diff --git a/.emacs.d/org-7.4/lisp/ob-python.el b/.emacs.d/org-7.4/lisp/ob-python.el new file mode 100644 index 0000000..27b69bf --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-python.el @@ -0,0 +1,282 @@ +;;; ob-python.el --- org-babel functions for python evaluation + +;; Copyright (C) 2009, 2010 Free Software Foundation + +;; Author: Eric Schulte, Dan Davison +;; Keywords: literate programming, reproducible research +;; Homepage: http://orgmode.org +;; Version: 7.4 + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Org-Babel support for evaluating python source code. + +;;; Code: +(require 'ob) +(require 'ob-ref) +(require 'ob-comint) +(require 'ob-eval) +(eval-when-compile (require 'cl)) + +(declare-function org-remove-indentation "org" ) +(declare-function py-shell "ext:python-mode" (&optional argprompt)) +(declare-function run-python "ext:python" (&optional cmd noshow new)) + +(add-to-list 'org-babel-tangle-lang-exts '("python" . "py")) + +(defvar org-babel-default-header-args:python '()) + +(defvar org-babel-python-command "python" + "Name of command for executing python code.") + +(defvar org-babel-python-mode (if (featurep 'xemacs) 'python-mode 'python) + "Preferred python mode for use in running python interactively.") + +(defvar org-src-preserve-indentation) + +(defun org-babel-execute:python (body params) + "Execute a block of Python code with Babel. +This function is called by `org-babel-execute-src-block'." + (let* ((session (org-babel-python-initiate-session + (cdr (assoc :session params)))) + (result-params (cdr (assoc :result-params params))) + (result-type (cdr (assoc :result-type params))) + (return-val (when (and (eq result-type 'value) (not session)) + (cdr (assoc :return params)))) + (preamble (cdr (assoc :preamble params))) + (full-body + (org-babel-expand-body:generic + (concat body (if return-val (format "return %s" return-val) "")) + params (org-babel-variable-assignments:python params))) + (result (org-babel-python-evaluate + session full-body result-type result-params preamble))) + (or (cdr (assoc :file params)) + (org-babel-reassemble-table + result + (org-babel-pick-name (cdr (assoc :colname-names params)) + (cdr (assoc :colnames params))) + (org-babel-pick-name (cdr (assoc :rowname-names params)) + (cdr (assoc :rownames params))))))) + +(defun org-babel-prep-session:python (session params) + "Prepare SESSION according to the header arguments in PARAMS. +VARS contains resolved variable references" + (let* ((session (org-babel-python-initiate-session session)) + (var-lines + (org-babel-variable-assignments:python params))) + (org-babel-comint-in-buffer session + (mapc (lambda (var) + (end-of-line 1) (insert var) (comint-send-input) + (org-babel-comint-wait-for-output session)) var-lines)) + session)) + +(defun org-babel-load-session:python (session body params) + "Load BODY into SESSION." + (save-window-excursion + (let ((buffer (org-babel-prep-session:python session params))) + (with-current-buffer buffer + (goto-char (process-mark (get-buffer-process (current-buffer)))) + (insert (org-babel-chomp body))) + buffer))) + +;; helper functions + +(defun org-babel-variable-assignments:python (params) + "Return list of python statements assigning the block's variables" + (mapcar + (lambda (pair) + (format "%s=%s" + (car pair) + (org-babel-python-var-to-python (cdr pair)))) + (mapcar #'cdr (org-babel-get-header params :var)))) + +(defun org-babel-python-var-to-python (var) + "Convert an elisp value to a python variable. +Convert an elisp value, VAR, into a string of python source code +specifying a variable of the same value." + (if (listp var) + (concat "[" (mapconcat #'org-babel-python-var-to-python var ", ") "]") + (if (equal var 'hline) + "None" + (format + (if (and (stringp var) (string-match "[\n\r]" var)) "\"\"%S\"\"" "%S") + var)))) + +(defun org-babel-python-table-or-string (results) + "Convert RESULTS into an appropriate elisp value. +If the results look like a list or tuple, then convert them into an +Emacs-lisp table, otherwise return the results as a string." + (org-babel-script-escape results)) + +(defvar org-babel-python-buffers '((:default . nil))) + +(defun org-babel-python-session-buffer (session) + "Return the buffer associated with SESSION." + (cdr (assoc session org-babel-python-buffers))) + +(defun org-babel-python-initiate-session-by-key (&optional session) + "Initiate a python session. +If there is not a current inferior-process-buffer in SESSION +then create. Return the initialized session." + (require org-babel-python-mode) + (save-window-excursion + (let* ((session (if session (intern session) :default)) + (python-buffer (org-babel-python-session-buffer session))) + (cond + ((and (eq 'python org-babel-python-mode) + (fboundp 'run-python)) ; python.el + (run-python)) + ((and (eq 'python-mode org-babel-python-mode) + (fboundp 'py-shell)) ; python-mode.el + ;; `py-shell' creates a buffer whose name is the value of + ;; `py-which-bufname' with '*'s at the beginning and end + (let* ((bufname (if python-buffer + (replace-regexp-in-string ;; zap surrounding * + "^\\*\\([^*]+\\)\\*$" "\\1" python-buffer) + (concat "Python-" (symbol-name session)))) + (py-which-bufname bufname)) + (py-shell) + (setq python-buffer (concat "*" bufname "*")))) + (t + (error "No function available for running an inferior python."))) + (setq org-babel-python-buffers + (cons (cons session python-buffer) + (assq-delete-all session org-babel-python-buffers))) + session))) + +(defun org-babel-python-initiate-session (&optional session params) + "Create a session named SESSION according to PARAMS." + (unless (string= session "none") + (org-babel-python-session-buffer + (org-babel-python-initiate-session-by-key session)))) + +(defvar org-babel-python-eoe-indicator "'org_babel_python_eoe'" + "A string to indicate that evaluation has completed.") +(defvar org-babel-python-wrapper-method + " +def main(): +%s + +open('%s', 'w').write( str(main()) )") +(defvar org-babel-python-pp-wrapper-method + " +import pprint +def main(): +%s + +open('%s', 'w').write( pprint.pformat(main()) )") + +(defun org-babel-python-evaluate + (session body &optional result-type result-params preamble) + "Evaluate BODY as python code." + (if session + (org-babel-python-evaluate-session + session body result-type result-params) + (org-babel-python-evaluate-external-process + body result-type result-params preamble))) + +(defun org-babel-python-evaluate-external-process + (body &optional result-type result-params preamble) + "Evaluate BODY in external python process. +If RESULT-TYPE equals 'output then return standard output as a +string. If RESULT-TYPE equals 'value then return the value of the +last statement in BODY, as elisp." + (case result-type + (output (org-babel-eval org-babel-python-command + (concat (if preamble (concat preamble "\n") "") body))) + (value (let ((tmp-file (org-babel-temp-file "python-"))) + (org-babel-eval org-babel-python-command + (concat + (if preamble (concat preamble "\n") "") + (format + (if (member "pp" result-params) + org-babel-python-pp-wrapper-method + org-babel-python-wrapper-method) + (mapconcat + (lambda (line) (format "\t%s" line)) + (split-string + (org-remove-indentation + (org-babel-trim body)) + "[\r\n]") "\n") + (org-babel-process-file-name tmp-file 'noquote)))) + ((lambda (raw) + (if (or (member "code" result-params) + (member "pp" result-params)) + raw + (org-babel-python-table-or-string raw))) + (org-babel-eval-read-file tmp-file)))))) + +(defun org-babel-python-evaluate-session + (session body &optional result-type result-params) + "Pass BODY to the Python process in SESSION. +If RESULT-TYPE equals 'output then return standard output as a +string. If RESULT-TYPE equals 'value then return the value of the +last statement in BODY, as elisp." + (flet ((dump-last-value + (tmp-file pp) + (mapc + (lambda (statement) (insert statement) (comint-send-input)) + (if pp + (list + "import pprint" + (format "open('%s', 'w').write(pprint.pformat(_))" + (org-babel-process-file-name tmp-file 'noquote))) + (list (format "open('%s', 'w').write(str(_))" + (org-babel-process-file-name tmp-file 'noquote)))))) + (input-body (body) + (mapc (lambda (statement) (insert statement) (comint-send-input)) + (split-string (org-babel-trim body) "[\r\n]+")) + (comint-send-input) (comint-send-input))) + (case result-type + (output + (mapconcat + #'org-babel-trim + (butlast + (org-babel-comint-with-output + (session org-babel-python-eoe-indicator t body) + (let ((comint-process-echoes nil)) + (input-body body) + (insert org-babel-python-eoe-indicator) + (comint-send-input))) 2) "\n")) + (value + ((lambda (results) + (if (or (member "code" result-params) (member "pp" result-params)) + results + (org-babel-python-table-or-string results))) + (let ((tmp-file (org-babel-temp-file "python-"))) + (org-babel-comint-with-output + (session org-babel-python-eoe-indicator t body) + (let ((comint-process-echoes nil)) + (input-body body) + (dump-last-value tmp-file (member "pp" result-params)) + (comint-send-input) (comint-send-input) + (insert org-babel-python-eoe-indicator) + (comint-send-input))) + (org-babel-eval-read-file tmp-file))))))) + +(defun org-babel-python-read-string (string) + "Strip 's from around python string" + (if (string-match "^'\\([^\000]+\\)'$" string) + (match-string 1 string) + string)) + +(provide 'ob-python) + +;; arch-tag: f19b6c3d-dfcb-4a1a-9ce0-45ade1ebc212 + +;;; ob-python.el ends here diff --git a/.emacs.d/org-7.4/lisp/ob-python.elc b/.emacs.d/org-7.4/lisp/ob-python.elc Binary files differnew file mode 100644 index 0000000..55cd4a7 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-python.elc diff --git a/.emacs.d/org-7.4/lisp/ob-ref.el b/.emacs.d/org-7.4/lisp/ob-ref.el new file mode 100644 index 0000000..2ca99ca --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-ref.el @@ -0,0 +1,229 @@ +;;; ob-ref.el --- org-babel functions for referencing external data + +;; Copyright (C) 2009, 2010 Free Software Foundation, Inc. + +;; Author: Eric Schulte, Dan Davison +;; Keywords: literate programming, reproducible research +;; Homepage: http://orgmode.org +;; Version: 7.4 + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Functions for referencing data from the header arguments of a +;; org-babel block. The syntax of such a reference should be + +;; #+VAR: variable-name=file:resource-id + +;; - variable-name :: the name of the variable to which the value +;; will be assigned + +;; - file :: path to the file containing the resource, or omitted if +;; resource is in the current file + +;; - resource-id :: the id or name of the resource + +;; So an example of a simple src block referencing table data in the +;; same file would be + +;; #+TBLNAME: sandbox +;; | 1 | 2 | 3 | +;; | 4 | org-babel | 6 | +;; +;; #+begin_src emacs-lisp :var table=sandbox +;; (message table) +;; #+end_src + +;;; Code: +(require 'ob) +(eval-when-compile + (require 'org-list) + (require 'cl)) + +(declare-function org-remove-if-not "org" (predicate seq)) +(declare-function org-at-table-p "org" (&optional table-type)) +(declare-function org-count "org" (CL-ITEM CL-SEQ)) +(declare-function org-in-item-p "org-list" ()) + +(defvar org-babel-ref-split-regexp + "[ \f\t\n\r\v]*\\(.+?\\)[ \f\t\n\r\v]*=[ \f\t\n\r\v]*\\(.+\\)[ \f\t\n\r\v]*") + +(defun org-babel-ref-parse (assignment) + "Parse a variable ASSIGNMENT in a header argument. +If the right hand side of the assignment has a literal value +return that value, otherwise interpret as a reference to an +external resource and find it's value using +`org-babel-ref-resolve'. Return a list with two elements. The +first element of the list will be the name of the variable, and +the second will be an emacs-lisp representation of the value of +the variable." + (when (string-match org-babel-ref-split-regexp assignment) + (let ((var (match-string 1 assignment)) + (ref (match-string 2 assignment))) + (cons (intern var) + (let ((out (org-babel-read ref))) + (if (equal out ref) + (if (string-match "^\".+\"$" ref) + (read ref) + (org-babel-ref-resolve ref)) + out)))))) + +(defvar org-babel-library-of-babel) +(defun org-babel-ref-resolve (ref) + "Resolve the reference REF and return its value." + (save-excursion + (let ((case-fold-search t) + type args new-refere new-header-args new-referent result + lob-info split-file split-ref index index-row index-col) + ;; if ref is indexed grab the indices -- beware nested indices + (when (and (string-match "\\[\\([^\\[]+\\)\\]$" ref) + (let ((str (substring ref 0 (match-beginning 0)))) + (= (org-count ?( str) (org-count ?) str)))) + (setq index (match-string 1 ref)) + (setq ref (substring ref 0 (match-beginning 0)))) + ;; assign any arguments to pass to source block + (when (string-match + "^\\(.+?\\)\\(\\[\\(.*\\)\\]\\|\\(\\)\\)\(\\(.*\\)\)$" ref) + (setq new-refere (match-string 1 ref)) + (setq new-header-args (match-string 3 ref)) + (setq new-referent (match-string 5 ref)) + (when (> (length new-refere) 0) + (when (> (length new-referent) 0) + (setq args (mapcar (lambda (ref) (cons :var ref)) + (org-babel-ref-split-args new-referent)))) + (when (> (length new-header-args) 0) + (setq args (append (org-babel-parse-header-arguments new-header-args) + args))) + (setq ref new-refere))) + (when (string-match "^\\(.+\\):\\(.+\\)$" ref) + (setq split-file (match-string 1 ref)) + (setq split-ref (match-string 2 ref)) + (find-file split-file) (setq ref split-ref)) + (save-restriction + (widen) + (goto-char (point-min)) + (if (let ((result_regexp (concat "^[ \t]*#\\+\\(TBLNAME\\|RESNAME" + "\\|RESULTS\\):[ \t]*" + (regexp-quote ref) "[ \t]*$")) + (regexp (concat org-babel-src-name-regexp + (regexp-quote ref) "\\(\(.*\)\\)?" "[ \t]*$"))) + ;; goto ref in the current buffer + (or (and (not args) + (or (re-search-forward result_regexp nil t) + (re-search-backward result_regexp nil t))) + (re-search-forward regexp nil t) + (re-search-backward regexp nil t) + ;; check the Library of Babel + (setq lob-info (cdr (assoc (intern ref) + org-babel-library-of-babel))))) + (unless lob-info (goto-char (match-beginning 0))) + ;; ;; TODO: allow searching for names in other buffers + ;; (setq id-loc (org-id-find ref 'marker) + ;; buffer (marker-buffer id-loc) + ;; loc (marker-position id-loc)) + ;; (move-marker id-loc nil) + (error "reference '%s' not found in this buffer" ref)) + (if lob-info + (setq type 'lob) + (while (not (setq type (org-babel-ref-at-ref-p))) + (forward-line 1) + (beginning-of-line) + (if (or (= (point) (point-min)) (= (point) (point-max))) + (error "reference not found")))) + (let ((params (append args '((:results . "silent"))))) + (setq result + (case type + ('results-line (org-babel-read-result)) + ('table (org-babel-read-table)) + ('list (org-babel-read-list)) + ('file (org-babel-read-link)) + ('source-block (org-babel-execute-src-block nil nil params)) + ('lob (org-babel-execute-src-block nil lob-info params))))) + (if (symbolp result) + (format "%S" result) + (if (and index (listp result)) + (org-babel-ref-index-list index result) + result)))))) + +(defun org-babel-ref-index-list (index lis) + "Return the subset of LIS indexed by INDEX. + +Indices are 0 based and negative indices count from the end of +LIS, so 0 references the first element of LIS and -1 references +the last. If INDEX is separated by \",\"s then each \"portion\" +is assumed to index into the next deepest nesting or dimension. + +A valid \"portion\" can consist of either an integer index, two +integers separated by a \":\" in which case the entire range is +returned, or an empty string or \"*\" both of which are +interpreted to mean the entire range and as such are equivalent +to \"0:-1\"." + (if (and (> (length index) 0) (string-match "^\\([^,]*\\),?" index)) + (let ((ind-re "\\(\\([-[:digit:]]+\\):\\([-[:digit:]]+\\)\\|\*\\)") + (length (length lis)) + (portion (match-string 1 index)) + (remainder (substring index (match-end 0)))) + (flet ((wrap (num) (if (< num 0) (+ length num) num)) + (open (ls) (if (and (listp ls) (= (length ls) 1)) (car ls) ls))) + (open + (mapcar + (lambda (sub-lis) (org-babel-ref-index-list remainder sub-lis)) + (if (or (= 0 (length portion)) (string-match ind-re portion)) + (mapcar + (lambda (n) (nth n lis)) + (apply 'org-number-sequence + (if (and (> (length portion) 0) (match-string 2 portion)) + (list + (wrap (string-to-number (match-string 2 portion))) + (wrap (string-to-number (match-string 3 portion)))) + (list (wrap 0) (wrap -1))))) + (list (nth (wrap (string-to-number portion)) lis))))))) + lis)) + +(defun org-babel-ref-split-args (arg-string) + "Split ARG-STRING into top-level arguments of balanced parenthesis." + (let ((index 0) (depth 0) (buffer "") holder return) + ;; crawl along string, splitting at any ","s which are on the top level + (while (< index (length arg-string)) + (setq holder (substring arg-string index (+ 1 index))) + (setq buffer (concat buffer holder)) + (setq index (+ 1 index)) + (cond + ((string= holder ",") + (when (= depth 0) + (setq return (reverse (cons (substring buffer 0 -1) return))) + (setq buffer ""))) + ((or (string= holder "(") (string= holder "[")) (setq depth (+ depth 1))) + ((or (string= holder ")") (string= holder "]")) (setq depth (- depth 1))))) + (mapcar #'org-babel-trim (reverse (cons buffer return))))) + +(defvar org-bracket-link-regexp) +(defun org-babel-ref-at-ref-p () + "Return the type of reference located at point. +Return nil if none of the supported reference types are found. +Supported reference types are tables and source blocks." + (cond ((org-at-table-p) 'table) + ((org-in-item-p) 'list) + ((looking-at "^[ \t]*#\\+BEGIN_SRC") 'source-block) + ((looking-at org-bracket-link-regexp) 'file) + ((looking-at org-babel-result-regexp) 'results-line))) + +(provide 'ob-ref) + +;; arch-tag: ace4a4f4-ea38-4dac-8fe6-6f52fcc43b6d + +;;; ob-ref.el ends here diff --git a/.emacs.d/org-7.4/lisp/ob-ref.elc b/.emacs.d/org-7.4/lisp/ob-ref.elc Binary files differnew file mode 100644 index 0000000..b172193 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-ref.elc diff --git a/.emacs.d/org-7.4/lisp/ob-ruby.el b/.emacs.d/org-7.4/lisp/ob-ruby.el new file mode 100644 index 0000000..3f2af39 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-ruby.el @@ -0,0 +1,239 @@ +;;; ob-ruby.el --- org-babel functions for ruby evaluation + +;; Copyright (C) 2009, 2010 Free Software Foundation + +;; Author: Eric Schulte +;; Keywords: literate programming, reproducible research +;; Homepage: http://orgmode.org +;; Version: 7.4 + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Org-Babel support for evaluating ruby source code. + +;;; Requirements: + +;; - ruby and irb executables :: http://www.ruby-lang.org/ +;; +;; - ruby-mode :: Can be installed through ELPA, or from +;; http://github.com/eschulte/rinari/raw/master/util/ruby-mode.el +;; +;; - inf-ruby mode :: Can be installed through ELPA, or from +;; http://github.com/eschulte/rinari/raw/master/util/inf-ruby.el + +;;; Code: +(require 'ob) +(require 'ob-ref) +(require 'ob-comint) +(require 'ob-eval) +(eval-when-compile (require 'cl)) + +(declare-function run-ruby "ext:inf-ruby" (&optional command name)) + +(add-to-list 'org-babel-tangle-lang-exts '("ruby" . "rb")) + +(defvar org-babel-default-header-args:ruby '()) + +(defvar org-babel-ruby-command "ruby" + "Name of command to use for executing ruby code.") + +(defun org-babel-execute:ruby (body params) + "Execute a block of Ruby code with Babel. +This function is called by `org-babel-execute-src-block'." + (let* ((session (org-babel-ruby-initiate-session + (cdr (assoc :session params)))) + (result-params (cdr (assoc :result-params params))) + (result-type (cdr (assoc :result-type params))) + (full-body (org-babel-expand-body:generic + body params (org-babel-variable-assignments:ruby params))) + (result (org-babel-ruby-evaluate + session full-body result-type result-params))) + (or (cdr (assoc :file params)) + (org-babel-reassemble-table + result + (org-babel-pick-name (cdr (assoc :colname-names params)) + (cdr (assoc :colnames params))) + (org-babel-pick-name (cdr (assoc :rowname-names params)) + (cdr (assoc :rownames params))))))) + +(defun org-babel-prep-session:ruby (session params) + "Prepare SESSION according to the header arguments specified in PARAMS." + ;; (message "params=%S" params) ;; debugging + (let* ((session (org-babel-ruby-initiate-session session)) + (var-lines (org-babel-variable-assignments:ruby params))) + (org-babel-comint-in-buffer session + (sit-for .5) (goto-char (point-max)) + (mapc (lambda (var) + (insert var) (comint-send-input nil t) + (org-babel-comint-wait-for-output session) + (sit-for .1) (goto-char (point-max))) var-lines)) + session)) + +(defun org-babel-load-session:ruby (session body params) + "Load BODY into SESSION." + (save-window-excursion + (let ((buffer (org-babel-prep-session:ruby session params))) + (with-current-buffer buffer + (goto-char (process-mark (get-buffer-process (current-buffer)))) + (insert (org-babel-chomp body))) + buffer))) + +;; helper functions + +(defun org-babel-variable-assignments:ruby (params) + "Return list of ruby statements assigning the block's variables" + (mapcar + (lambda (pair) + (format "%s=%s" + (car pair) + (org-babel-ruby-var-to-ruby (cdr pair)))) + (mapcar #'cdr (org-babel-get-header params :var)))) + +(defun org-babel-ruby-var-to-ruby (var) + "Convert VAR into a ruby variable. +Convert an elisp value into a string of ruby source code +specifying a variable of the same value." + (if (listp var) + (concat "[" (mapconcat #'org-babel-ruby-var-to-ruby var ", ") "]") + (format "%S" var))) + +(defun org-babel-ruby-table-or-string (results) + "Convert RESULTS into an appropriate elisp value. +If RESULTS look like a table, then convert them into an +Emacs-lisp table, otherwise return the results as a string." + (org-babel-script-escape results)) + +(defun org-babel-ruby-initiate-session (&optional session params) + "Initiate a ruby session. +If there is not a current inferior-process-buffer in SESSION +then create one. Return the initialized session." + (require 'inf-ruby) + (unless (string= session "none") + (let ((session-buffer (save-window-excursion + (run-ruby nil session) (current-buffer)))) + (if (org-babel-comint-buffer-livep session-buffer) + (progn (sit-for .25) session-buffer) + (sit-for .5) + (org-babel-ruby-initiate-session session))))) + +(defvar org-babel-ruby-eoe-indicator ":org_babel_ruby_eoe" + "String to indicate that evaluation has completed.") +(defvar org-babel-ruby-f-write + "File.open('%s','w'){|f| f.write((_.class == String) ? _ : _.inspect)}") +(defvar org-babel-ruby-pp-f-write + "File.open('%s','w'){|f| $stdout = f; pp(results); $stdout = orig_out}") +(defvar org-babel-ruby-wrapper-method + " +def main() +%s +end +results = main() +File.open('%s', 'w'){ |f| f.write((results.class == String) ? results : results.inspect) } +") +(defvar org-babel-ruby-pp-wrapper-method + " +require 'pp' +def main() +%s +end +results = main() +File.open('%s', 'w') do |f| + $stdout = f + pp results +end +") + +(defun org-babel-ruby-evaluate + (buffer body &optional result-type result-params) + "Pass BODY to the Ruby process in BUFFER. +If RESULT-TYPE equals 'output then return a list of the outputs +of the statements in BODY, if RESULT-TYPE equals 'value then +return the value of the last statement in BODY, as elisp." + (if (not buffer) + ;; external process evaluation + (case result-type + (output (org-babel-eval org-babel-ruby-command body)) + (value (let ((tmp-file (org-babel-temp-file "ruby-"))) + (org-babel-eval + org-babel-ruby-command + (format (if (member "pp" result-params) + org-babel-ruby-pp-wrapper-method + org-babel-ruby-wrapper-method) + body (org-babel-process-file-name tmp-file 'noquote))) + ((lambda (raw) + (if (or (member "code" result-params) + (member "pp" result-params)) + raw + (org-babel-ruby-table-or-string raw))) + (org-babel-eval-read-file tmp-file))))) + ;; comint session evaluation + (case result-type + (output + (mapconcat + #'identity + (butlast + (split-string + (mapconcat + #'org-babel-trim + (butlast + (org-babel-comint-with-output + (buffer org-babel-ruby-eoe-indicator t body) + (mapc + (lambda (line) + (insert (org-babel-chomp line)) (comint-send-input nil t)) + (list body org-babel-ruby-eoe-indicator)) + (comint-send-input nil t)) 2) + "\n") "[\r\n]")) "\n")) + (value + ((lambda (results) + (if (or (member "code" result-params) (member "pp" result-params)) + results + (org-babel-ruby-table-or-string results))) + (let* ((tmp-file (org-babel-temp-file "ruby-")) + (ppp (or (member "code" result-params) + (member "pp" result-params)))) + (org-babel-comint-with-output + (buffer org-babel-ruby-eoe-indicator t body) + (when ppp (insert "require 'pp';") (comint-send-input nil t)) + (mapc + (lambda (line) + (insert (org-babel-chomp line)) (comint-send-input nil t)) + (append + (list body) + (if (not ppp) + (list (format org-babel-ruby-f-write + (org-babel-process-file-name tmp-file 'noquote))) + (list + "results=_" "require 'pp'" "orig_out = $stdout" + (format org-babel-ruby-pp-f-write + (org-babel-process-file-name tmp-file 'noquote)))) + (list org-babel-ruby-eoe-indicator))) + (comint-send-input nil t)) + (org-babel-eval-read-file tmp-file))))))) + +(defun org-babel-ruby-read-string (string) + "Strip \\\"s from around a ruby string." + (if (string-match "^\"\\([^\000]+\\)\"$" string) + (match-string 1 string) + string)) + +(provide 'ob-ruby) + +;; arch-tag: 3e9726db-4520-49e2-b263-e8f571ac88f5 + +;;; ob-ruby.el ends here diff --git a/.emacs.d/org-7.4/lisp/ob-ruby.elc b/.emacs.d/org-7.4/lisp/ob-ruby.elc Binary files differnew file mode 100644 index 0000000..32a1e65 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-ruby.elc diff --git a/.emacs.d/org-7.4/lisp/ob-sass.el b/.emacs.d/org-7.4/lisp/ob-sass.el new file mode 100644 index 0000000..b3acc8b --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-sass.el @@ -0,0 +1,69 @@ +;;; ob-sass.el --- org-babel functions for the sass css generation language + +;; Copyright (C) 2009, 2010 Free Software Foundation, Inc. + +;; Author: Eric Schulte +;; Keywords: literate programming, reproducible research +;; Homepage: http://orgmode.org +;; Version: 7.4 + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; For more information on sass see http://sass-lang.com/ +;; +;; This accepts a 'file' header argument which is the target of the +;; compiled sass. The default output type for sass evaluation is +;; either file (if a 'file' header argument was given) or scalar if no +;; such header argument was supplied. +;; +;; A 'cmdline' header argument can be supplied to pass arguments to +;; the sass command line. + +;;; Requirements: + +;; - sass-mode :: http://github.com/nex3/haml/blob/master/extra/sass-mode.el + +;;; Code: +(require 'ob) + +(defvar org-babel-default-header-args:sass '()) + +(defun org-babel-execute:sass (body params) + "Execute a block of Sass code with Babel. +This function is called by `org-babel-execute-src-block'." + (let* ((result-params (split-string (or (cdr (assoc :results params)) ""))) + (file (cdr (assoc :file params))) + (out-file (or file (org-babel-temp-file "sass-out-"))) + (cmdline (cdr (assoc :cmdline params))) + (in-file (org-babel-temp-file "sass-in-")) + (cmd (concat "sass " (or cmdline "") + " " (org-babel-process-file-name in-file) + " " (org-babel-process-file-name out-file)))) + (with-temp-file in-file + (insert (org-babel-expand-body:generic body params))) (shell-command cmd) + (or file (with-temp-buffer (insert-file-contents out-file) (buffer-string))))) + +(defun org-babel-prep-session:sass (session params) + "Raise an error because sass does not support sessions." + (error "Sass does not support sessions")) + +(provide 'ob-sass) + +;; arch-tag: 2954b169-eef4-45ce-a8e5-3e619f0f07ac + +;;; ob-sass.el ends here diff --git a/.emacs.d/org-7.4/lisp/ob-sass.elc b/.emacs.d/org-7.4/lisp/ob-sass.elc Binary files differnew file mode 100644 index 0000000..06ed6fc --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-sass.elc diff --git a/.emacs.d/org-7.4/lisp/ob-scheme.el b/.emacs.d/org-7.4/lisp/ob-scheme.el new file mode 100644 index 0000000..b2b9fa6 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-scheme.el @@ -0,0 +1,139 @@ +;;; ob-scheme.el --- org-babel functions for Scheme + +;; Copyright (C) 2010 Free Software Foundation + +;; Author: Eric Schulte +;; Keywords: literate programming, reproducible research, scheme +;; Homepage: http://orgmode.org +;; Version: 7.4 + +;;; License: + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; Now working with SBCL for both session and external evaluation. +;; +;; This certainly isn't optimally robust, but it seems to be working +;; for the basic use cases. + +;;; Requirements: + +;; - a working scheme implementation +;; (e.g. guile http://www.gnu.org/software/guile/guile.html) +;; +;; - for session based evaluation cmuscheme.el is required which is +;; included in Emacs + +;;; Code: +(require 'ob) +(require 'ob-ref) +(require 'ob-comint) +(require 'ob-eval) +(eval-when-compile (require 'cl)) + +(declare-function run-scheme "ext:cmuscheme" (cmd)) + +(defvar org-babel-default-header-args:scheme '() + "Default header arguments for scheme code blocks.") + +(defvar org-babel-scheme-eoe "org-babel-scheme-eoe" + "String to indicate that evaluation has completed.") + +(defcustom org-babel-scheme-cmd "guile" + "Name of command used to evaluate scheme blocks." + :group 'org-babel + :type 'string) + +(defun org-babel-expand-body:scheme (body params) + "Expand BODY according to PARAMS, return the expanded body." + (let ((vars (mapcar #'cdr (org-babel-get-header params :var)))) + (if (> (length vars) 0) + (concat "(let (" + (mapconcat + (lambda (var) (format "%S" (print `(,(car var) ',(cdr var))))) + vars "\n ") + ")\n" body ")") + body))) + +(defvar scheme-program-name) +(defun org-babel-execute:scheme (body params) + "Execute a block of Scheme code with org-babel. +This function is called by `org-babel-execute-src-block'" + (let* ((result-type (cdr (assoc :result-type params))) + (org-babel-scheme-cmd (or (cdr (assoc :scheme params)) + org-babel-scheme-cmd)) + (full-body (org-babel-expand-body:scheme body params))) + (read + (if (not (string= (cdr (assoc :session params)) "none")) + ;; session evaluation + (let ((session (org-babel-prep-session:scheme + (cdr (assoc :session params)) params))) + (org-babel-comint-with-output + (session (format "%S" org-babel-scheme-eoe) t body) + (mapc + (lambda (line) + (insert (org-babel-chomp line)) (comint-send-input nil t)) + (list body (format "%S" org-babel-scheme-eoe))))) + ;; external evaluation + (let ((script-file (org-babel-temp-file "scheme-script-"))) + (with-temp-file script-file + (insert + ;; return the value or the output + (if (string= result-type "value") + (format "(display %s)" full-body) + full-body))) + (org-babel-eval + (format "%s %s" org-babel-scheme-cmd + (org-babel-process-file-name script-file)) "")))))) + +(defun org-babel-prep-session:scheme (session params) + "Prepare SESSION according to the header arguments specified in PARAMS." + (let* ((session (org-babel-scheme-initiate-session session)) + (vars (mapcar #'cdr (org-babel-get-header params :var))) + (var-lines + (mapcar + (lambda (var) (format "%S" (print `(define ,(car var) ',(cdr var))))) + vars))) + (when session + (org-babel-comint-in-buffer session + (sit-for .5) (goto-char (point-max)) + (mapc (lambda (var) + (insert var) (comint-send-input nil t) + (org-babel-comint-wait-for-output session) + (sit-for .1) (goto-char (point-max))) var-lines))) + session)) + +(defun org-babel-scheme-initiate-session (&optional session) + "If there is not a current inferior-process-buffer in SESSION +then create. Return the initialized session." + (require 'cmuscheme) + (unless (string= session "none") + (let ((session-buffer (save-window-excursion + (run-scheme org-babel-scheme-cmd) + (rename-buffer session) + (current-buffer)))) + (if (org-babel-comint-buffer-livep session-buffer) + (progn (sit-for .25) session-buffer) + (sit-for .5) + (org-babel-scheme-initiate-session session))))) + +(provide 'ob-scheme) + +;; arch-tag: 6b2fe76f-4b25-4e87-ad1c-225b2f282a71 + +;;; ob-scheme.el ends here diff --git a/.emacs.d/org-7.4/lisp/ob-scheme.elc b/.emacs.d/org-7.4/lisp/ob-scheme.elc Binary files differnew file mode 100644 index 0000000..960d7f9 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-scheme.elc diff --git a/.emacs.d/org-7.4/lisp/ob-screen.el b/.emacs.d/org-7.4/lisp/ob-screen.el new file mode 100644 index 0000000..7f4af79 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-screen.el @@ -0,0 +1,147 @@ +;;; ob-screen.el --- org-babel support for interactive terminal + +;; Copyright (C) 2009, 2010 Free Software Foundation + +;; Author: Benjamin Andresen +;; Keywords: literate programming, interactive shell +;; Homepage: http://orgmode.org +;; Version: 7.4 + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Org-Babel support for interactive terminals. Mostly shell scripts. +;; Heavily inspired by 'eev' from Eduardo Ochs +;; +;; Adding :cmd and :terminal as header arguments +;; :terminal must support the -T (title) and -e (command) parameter +;; +;; You can test the default setup. (xterm + sh) with +;; M-x org-babel-screen-test RET + +;;; Code: +(require 'ob) +(require 'ob-ref) + +(defvar org-babel-screen-location "screen" + "The command location for screen. +In case you want to use a different screen than one selected by your $PATH") + +(defvar org-babel-default-header-args:screen + '((:results . "silent") (:session . "default") (:cmd . "sh") (:terminal . "xterm")) + "Default arguments to use when running screen source blocks.") + +(defun org-babel-execute:screen (body params) + "Send a block of code via screen to a terminal using Babel. +\"default\" session is used when none is specified." + (message "Sending source code block to interactive terminal session...") + (save-window-excursion + (let* ((session (cdr (assoc :session params))) + (socket (org-babel-screen-session-socketname session))) + (unless socket (org-babel-prep-session:screen session params)) + (org-babel-screen-session-execute-string + session (org-babel-expand-body:generic body params))))) + +(defun org-babel-prep-session:screen (session params) + "Prepare SESSION according to the header arguments specified in PARAMS." + (let* ((session (cdr (assoc :session params))) + (socket (org-babel-screen-session-socketname session)) + (cmd (cdr (assoc :cmd params))) + (terminal (cdr (assoc :terminal params))) + (process-name (concat "org-babel: terminal (" session ")"))) + (apply 'start-process process-name "*Messages*" + terminal `("-T" ,(concat "org-babel: " session) "-e" ,org-babel-screen-location + "-c" "/dev/null" "-mS" ,(concat "org-babel-session-" session) + ,cmd)) + ;; XXX: Is there a better way than the following? + (while (not (org-babel-screen-session-socketname session)) + ;; wait until screen session is available before returning + ))) + +;; helper functions + +(defun org-babel-screen-session-execute-string (session body) + "If SESSION exists, send BODY to it." + (let ((socket (org-babel-screen-session-socketname session))) + (when socket + (let ((tmpfile (org-babel-screen-session-write-temp-file session body))) + (apply 'start-process (concat "org-babel: screen (" session ")") "*Messages*" + org-babel-screen-location + `("-S" ,socket "-X" "eval" "msgwait 0" + ,(concat "readreg z " tmpfile) + "paste z")))))) + +(defun org-babel-screen-session-socketname (session) + "Check if SESSION exists by parsing output of \"screen -ls\"." + (let* ((screen-ls (shell-command-to-string "screen -ls")) + (sockets (delq + nil + (mapcar + (lambda (x) + (when (string-match (rx (or "(Attached)" "(Detached)")) x) + x)) + (split-string screen-ls "\n")))) + (match-socket (car + (delq + nil + (mapcar + (lambda (x) + (when (string-match + (concat "org-babel-session-" session) x) + x)) + sockets))))) + (when match-socket (car (split-string match-socket))))) + +(defun org-babel-screen-session-write-temp-file (session body) + "Save BODY in a temp file that is named after SESSION." + (let ((tmpfile (concat "/tmp/screen.org-babel-session-" session))) + (with-temp-file tmpfile + (insert body) + + ;; org-babel has superflous spaces + (goto-char (point-min)) + (delete-matching-lines "^ +$")) + tmpfile)) + +(defun org-babel-screen-test () + "Test if the default setup works. +The terminal should shortly flicker." + (interactive) + (let* ((session "org-babel-testing") + (random-string (format "%s" (random 99999))) + (tmpfile "/tmp/org-babel-screen.test") + (body (concat "echo '" random-string "' > " tmpfile "\nexit\n")) + process tmp-string) + (org-babel-execute:screen body org-babel-default-header-args:screen) + ;; XXX: need to find a better way to do the following + (while (not (file-readable-p tmpfile)) + ;; do something, otherwise this will be optimized away + (format "org-babel-screen: File not readable yet.")) + (setq tmp-string (with-temp-buffer + (insert-file-contents-literally tmpfile) + (buffer-substring (point-min) (point-max)))) + (delete-file tmpfile) + (message (concat "org-babel-screen: Setup " + (if (string-match random-string tmp-string) + "WORKS." + "DOESN'T work."))))) + +(provide 'ob-screen) + +;; arch-tag: 908e5afe-89a0-4f27-b982-23f1f2e3bac9 + +;;; ob-screen.el ends here diff --git a/.emacs.d/org-7.4/lisp/ob-screen.elc b/.emacs.d/org-7.4/lisp/ob-screen.elc Binary files differnew file mode 100644 index 0000000..57735aa --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-screen.elc diff --git a/.emacs.d/org-7.4/lisp/ob-sh.el b/.emacs.d/org-7.4/lisp/ob-sh.el new file mode 100644 index 0000000..e153d68 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-sh.el @@ -0,0 +1,171 @@ +;;; ob-sh.el --- org-babel functions for shell evaluation + +;; Copyright (C) 2009, 2010 Free Software Foundation, Inc. + +;; Author: Eric Schulte +;; Keywords: literate programming, reproducible research +;; Homepage: http://orgmode.org +;; Version: 7.4 + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Org-Babel support for evaluating shell source code. + +;;; Code: +(require 'ob) +(require 'ob-comint) +(require 'ob-eval) +(require 'shell) +(eval-when-compile (require 'cl)) + +(declare-function org-babel-comint-in-buffer "ob-comint" (buffer &rest body)) +(declare-function org-babel-comint-wait-for-output "ob-comint" (buffer)) +(declare-function org-babel-comint-buffer-livep "ob-comint" (buffer)) +(declare-function org-babel-comint-with-output "ob-comint" (meta &rest body)) +(declare-function orgtbl-to-generic "org-table" (table params)) + +(defvar org-babel-default-header-args:sh '()) + +(defvar org-babel-sh-command "sh" + "Command used to invoke a shell. +This will be passed to `shell-command-on-region'") + +(defun org-babel-execute:sh (body params) + "Execute a block of Shell commands with Babel. +This function is called by `org-babel-execute-src-block'." + (let* ((session (org-babel-sh-initiate-session + (cdr (assoc :session params)))) + (result-params (cdr (assoc :result-params params))) + (full-body (org-babel-expand-body:generic + body params (org-babel-variable-assignments:sh params)))) + (org-babel-reassemble-table + (org-babel-sh-evaluate session full-body result-params) + (org-babel-pick-name + (cdr (assoc :colname-names params)) (cdr (assoc :colnames params))) + (org-babel-pick-name + (cdr (assoc :rowname-names params)) (cdr (assoc :rownames params)))))) + +(defun org-babel-prep-session:sh (session params) + "Prepare SESSION according to the header arguments specified in PARAMS." + (let* ((session (org-babel-sh-initiate-session session)) + (var-lines (org-babel-variable-assignments:sh params))) + (org-babel-comint-in-buffer session + (mapc (lambda (var) + (insert var) (comint-send-input nil t) + (org-babel-comint-wait-for-output session)) var-lines)) + session)) + +(defun org-babel-load-session:sh (session body params) + "Load BODY into SESSION." + (save-window-excursion + (let ((buffer (org-babel-prep-session:sh session params))) + (with-current-buffer buffer + (goto-char (process-mark (get-buffer-process (current-buffer)))) + (insert (org-babel-chomp body))) + buffer))) + +;; helper functions + +(defun org-babel-variable-assignments:sh (params) + "Return list of shell statements assigning the block's variables" + (let ((sep (cdr (assoc :separator params)))) + (mapcar + (lambda (pair) + (format "%s=%s" + (car pair) + (org-babel-sh-var-to-sh (cdr pair) sep))) + (mapcar #'cdr (org-babel-get-header params :var))))) + +(defun org-babel-sh-var-to-sh (var &optional sep) + "Convert an elisp value to a shell variable. +Convert an elisp var into a string of shell commands specifying a +var of the same value." + (if (listp var) + (flet ((deep-string (el) + (if (listp el) + (mapcar #'deep-string el) + (org-babel-sh-var-to-sh el sep)))) + (format "$(cat <<'BABEL_TABLE'\n%s\nBABEL_TABLE\n)" + (orgtbl-to-generic + (deep-string (if (listp (car var)) var (list var))) + (list :sep (or sep "\t"))))) + (if (stringp var) + (if (string-match "[\n\r]" var) + (format "$(cat <<BABEL_STRING\n%s\nBABEL_STRING\n)" var) + (format "%s" var)) + (format "%S" var)))) + +(defun org-babel-sh-table-or-results (results) + "Convert RESULTS to an appropriate elisp value. +If the results look like a table, then convert them into an +Emacs-lisp table, otherwise return the results as a string." + (org-babel-script-escape results)) + +(defun org-babel-sh-initiate-session (&optional session params) + "Initiate a session named SESSION according to PARAMS." + (when (and session (not (string= session "none"))) + (save-window-excursion + (or (org-babel-comint-buffer-livep session) + (progn (shell session) (get-buffer (current-buffer))))))) + +(defvar org-babel-sh-eoe-indicator "echo 'org_babel_sh_eoe'" + "String to indicate that evaluation has completed.") +(defvar org-babel-sh-eoe-output "org_babel_sh_eoe" + "String to indicate that evaluation has completed.") + +(defun org-babel-sh-evaluate (session body &optional result-params) + "Pass BODY to the Shell process in BUFFER. +If RESULT-TYPE equals 'output then return a list of the outputs +of the statements in BODY, if RESULT-TYPE equals 'value then +return the value of the last statement in BODY." + ((lambda (results) + (when results + (if (or (member "scalar" result-params) + (member "output" result-params)) + results + (let ((tmp-file (org-babel-temp-file "sh-"))) + (with-temp-file tmp-file (insert results)) + (org-babel-import-elisp-from-file tmp-file))))) + (if (not session) + (org-babel-eval org-babel-sh-command (org-babel-trim body)) + (mapconcat + #'org-babel-sh-strip-weird-long-prompt + (mapcar + #'org-babel-trim + (butlast + (org-babel-comint-with-output + (session org-babel-sh-eoe-output t body) + (mapc + (lambda (line) + (insert line) (comint-send-input nil t) (sleep-for 0.25)) + (append + (split-string (org-babel-trim body) "\n") + (list org-babel-sh-eoe-indicator)))) + 2)) "\n")))) + +(defun org-babel-sh-strip-weird-long-prompt (string) + "Remove prompt cruft from a string of shell output." + (while (string-match "^% +[\r\n$]+ *" string) + (setq string (substring string (match-end 0)))) + string) + +(provide 'ob-sh) + +;; arch-tag: 416dd531-c230-4b0a-a5bf-8d948f990f2d + +;;; ob-sh.el ends here diff --git a/.emacs.d/org-7.4/lisp/ob-sh.elc b/.emacs.d/org-7.4/lisp/ob-sh.elc Binary files differnew file mode 100644 index 0000000..9a98a42 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-sh.elc diff --git a/.emacs.d/org-7.4/lisp/ob-sql.el b/.emacs.d/org-7.4/lisp/ob-sql.el new file mode 100644 index 0000000..5bb123d --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-sql.el @@ -0,0 +1,126 @@ +;;; ob-sql.el --- org-babel functions for sql evaluation + +;; Copyright (C) 2009, 2010 Free Software Foundation, Inc. + +;; Author: Eric Schulte +;; Keywords: literate programming, reproducible research +;; Homepage: http://orgmode.org +;; Version: 7.4 + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Org-Babel support for evaluating sql source code. +;; +;; SQL is somewhat unique in that there are many different engines for +;; the evaluation of sql (Mysql, PostgreSQL, etc...), so much of this +;; file will have to be implemented engine by engine. +;; +;; Also SQL evaluation generally takes place inside of a database. +;; +;; For now lets just allow a generic ':cmdline' header argument. +;; +;; TODO: +;; +;; - support for sessions +;; - add more useful header arguments (user, passwd, database, etc...) +;; - support for more engines (currently only supports mysql) +;; - what's a reasonable way to drop table data into SQL? +;; + +;;; Code: +(require 'ob) +(eval-when-compile (require 'cl)) + +(declare-function org-table-import "org-table" (file arg)) +(declare-function orgtbl-to-csv "org-table" (TABLE PARAMS)) + +(defvar org-babel-default-header-args:sql '()) + +(defun org-babel-expand-body:sql (body params) + "Expand BODY according to the values of PARAMS." + (org-babel-sql-expand-vars + body (mapcar #'cdr (org-babel-get-header params :var)))) + +(defun org-babel-execute:sql (body params) + "Execute a block of Sql code with Babel. +This function is called by `org-babel-execute-src-block'." + (let* ((result-params (cdr (assoc :result-params params))) + (cmdline (cdr (assoc :cmdline params))) + (engine (cdr (assoc :engine params))) + (in-file (org-babel-temp-file "sql-in-")) + (out-file (or (cdr (assoc :out-file params)) + (org-babel-temp-file "sql-out-"))) + (command (case (intern engine) + ('msosql (format "osql %s -s \"\t\" -i %s -o %s" + (or cmdline "") + (org-babel-process-file-name in-file) + (org-babel-process-file-name out-file))) + ('mysql (format "mysql %s -e \"source %s\" > %s" + (or cmdline "") + (org-babel-process-file-name in-file) + (org-babel-process-file-name out-file))) + ('postgresql (format "psql -A -P footer=off -F \"\t\" -f %s -o %s %s" + (org-babel-process-file-name in-file) + (org-babel-process-file-name out-file) + (or cmdline ""))) + (t (error "no support for the %s sql engine" engine))))) + (with-temp-file in-file + (insert (org-babel-expand-body:sql body params))) + (message command) + (shell-command command) + (with-temp-buffer + (org-table-import out-file '(16)) + (org-babel-reassemble-table + (org-table-to-lisp) + (org-babel-pick-name (cdr (assoc :colname-names params)) + (cdr (assoc :colnames params))) + (org-babel-pick-name (cdr (assoc :rowname-names params)) + (cdr (assoc :rownames params))))))) + +(defun org-babel-sql-expand-vars (body vars) + "Expand the variables held in VARS in BODY." + (mapc + (lambda (pair) + (setq body + (replace-regexp-in-string + (format "\$%s" (car pair)) + ((lambda (val) + (if (listp val) + ((lambda (data-file) + (with-temp-file data-file + (insert (orgtbl-to-csv + val '(:fmt (lambda (el) (if (stringp el) + el + (format "%S" el))))))) + data-file) + (org-babel-temp-file "sql-data-")) + (if (stringp val) val (format "%S" val)))) + (cdr pair)) + body))) + vars) + body) + +(defun org-babel-prep-session:sql (session params) + "Raise an error because Sql sessions aren't implemented." + (error "sql sessions not yet implemented")) + +(provide 'ob-sql) + +;; arch-tag: a43ff944-6de1-4566-a83c-626814e3dad2 + +;;; ob-sql.el ends here diff --git a/.emacs.d/org-7.4/lisp/ob-sql.elc b/.emacs.d/org-7.4/lisp/ob-sql.elc Binary files differnew file mode 100644 index 0000000..8a57e86 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-sql.elc diff --git a/.emacs.d/org-7.4/lisp/ob-sqlite.el b/.emacs.d/org-7.4/lisp/ob-sqlite.el new file mode 100644 index 0000000..65e8091 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-sqlite.el @@ -0,0 +1,149 @@ +;;; ob-sqlite.el --- org-babel functions for sqlite database interaction + +;; Copyright (C) 2010 Free Software Foundation + +;; Author: Eric Schulte +;; Keywords: literate programming, reproducible research +;; Homepage: http://orgmode.org +;; Version: 7.4 + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Org-Babel support for evaluating sqlite source code. + +;;; Code: +(require 'ob) +(require 'ob-eval) +(require 'ob-ref) + +(declare-function org-fill-template "org" (template alist)) +(declare-function org-table-convert-region "org-table" + (beg0 end0 &optional separator)) +(declare-function orgtbl-to-csv "org-table" (TABLE PARAMS)) + +(defvar org-babel-default-header-args:sqlite '()) + +(defvar org-babel-header-arg-names:sqlite + '(db header echo bail csv column html line list separator nullvalue) + "Sqlite specific header args.") + +(defun org-babel-expand-body:sqlite (body params) + "Expand BODY according to the values of PARAMS." + (org-babel-sqlite-expand-vars + body (mapcar #'cdr (org-babel-get-header params :var)))) + +(defvar org-babel-sqlite3-command "sqlite3") + +(defun org-babel-execute:sqlite (body params) + "Execute a block of Sqlite code with Babel. +This function is called by `org-babel-execute-src-block'." + (let ((result-params (split-string (or (cdr (assoc :results params)) ""))) + (db (cdr (assoc :db params))) + (separator (cdr (assoc :separator params))) + (nullvalue (cdr (assoc :nullvalue params))) + (headers-p (equal "yes" (cdr (assoc :colnames params)))) + (others (delq nil (mapcar + (lambda (arg) (car (assoc arg params))) + (list :header :echo :bail :column + :csv :html :line :list)))) + exit-code) + (unless db (error "ob-sqlite: can't evaluate without a database.")) + (with-temp-buffer + (insert + (org-babel-eval + (org-fill-template + "%cmd %header %separator %nullvalue %others %csv %db " + (list + (cons "cmd" org-babel-sqlite3-command) + (cons "header" (if headers-p "-header" "-noheader")) + (cons "separator" + (if separator (format "-separator %s" separator) "")) + (cons "nullvalue" + (if nullvalue (format "-nullvalue %s" nullvalue) "")) + (cons "others" + (mapconcat + (lambda (arg) (format "-%s" (substring (symbol-name arg) 1))) + others " ")) + ;; for easy table parsing, default header type should be -csv + (cons "csv" (if (or (member :csv others) (member :column others) + (member :line others) (member :list others) + (member :html others) separator) + "" + "-csv")) + (cons "db " db))) + ;; body of the code block + (org-babel-expand-body:sqlite body params))) + (if (or (member "scalar" result-params) + (member "html" result-params) + (member "code" result-params) + (equal (point-min) (point-max))) + (buffer-string) + (org-table-convert-region (point-min) (point-max)) + (org-babel-sqlite-table-or-scalar + (org-babel-sqlite-offset-colnames + (org-table-to-lisp) headers-p)))))) + +(defun org-babel-sqlite-expand-vars (body vars) + "Expand the variables held in VARS in BODY." + (mapc + (lambda (pair) + (setq body + (replace-regexp-in-string + (format "\$%s" (car pair)) + ((lambda (val) + (if (listp val) + ((lambda (data-file) + (with-temp-file data-file + (insert (orgtbl-to-csv + val '(:fmt (lambda (el) (if (stringp el) + el + (format "%S" el))))))) + data-file) + (org-babel-temp-file "sqlite-data-")) + (if (stringp val) val (format "%S" val)))) + (cdr pair)) + body))) + vars) + body) + +(defun org-babel-sqlite-table-or-scalar (result) + "If RESULT looks like a trivial table, then unwrap it." + (if (and (equal 1 (length result)) + (equal 1 (length (car result)))) + (org-babel-read (caar result)) + (mapcar (lambda (row) + (if (equal 'hline row) + 'hline + (mapcar #'org-babel-read row))) result))) + +(defun org-babel-sqlite-offset-colnames (table headers-p) + "If HEADERS-P is non-nil then offset the first row as column names." + (if headers-p + (cons (car table) (cons 'hline (cdr table))) + table)) + +(defun org-babel-prep-session:sqlite (session params) + "Raise an error because support for sqlite sessions isn't implemented. +Prepare SESSION according to the header arguments specified in PARAMS." + (error "sqlite sessions not yet implemented")) + +(provide 'ob-sqlite) + +;; arch-tag: 5c03d7f2-0f72-48b8-bbd1-35aafea248ac + +;;; ob-sqlite.el ends here diff --git a/.emacs.d/org-7.4/lisp/ob-sqlite.elc b/.emacs.d/org-7.4/lisp/ob-sqlite.elc Binary files differnew file mode 100644 index 0000000..6e66482 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-sqlite.elc diff --git a/.emacs.d/org-7.4/lisp/ob-table.el b/.emacs.d/org-7.4/lisp/ob-table.el new file mode 100644 index 0000000..b7f9673 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-table.el @@ -0,0 +1,125 @@ +;;; ob-table.el --- support for calling org-babel functions from tables + +;; Copyright (C) 2009, 2010 Free Software Foundation, Inc. + +;; Author: Eric Schulte +;; Keywords: literate programming, reproducible research +;; Homepage: http://orgmode.org +;; Version: 7.4 + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Should allow calling functions from org-mode tables using the +;; function `sbe' as so... + +;; #+begin_src emacs-lisp :results silent +;; (defun fibbd (n) (if (< n 2) 1 (+ (fibbd (- n 1)) (fibbd (- n 2))))) +;; #+end_src + +;; #+srcname: fibbd +;; #+begin_src emacs-lisp :var n=2 :results silent +;; (fibbd n) +;; #+end_src + +;; | original | fibbd | +;; |----------+--------| +;; | 0 | | +;; | 1 | | +;; | 2 | | +;; | 3 | | +;; | 4 | | +;; | 5 | | +;; | 6 | | +;; | 7 | | +;; | 8 | | +;; | 9 | | +;; #+TBLFM: $2='(sbe 'fibbd (n $1)) + +;;; Code: +(require 'ob) + +(defun org-babel-table-truncate-at-newline (string) + "Replace newline character with ellipses. +If STRING ends in a newline character, then remove the newline +character and replace it with ellipses." + (if (and (stringp string) (string-match "[\n\r]\\(.\\)?" string)) + (concat (substring string 0 (match-beginning 0)) + (if (match-string 1 string) "...")) string)) + +(defmacro sbe (source-block &rest variables) + "Return the results of calling SOURCE-BLOCK with VARIABLES. +Each element of VARIABLES should be a two +element list, whose first element is the name of the variable and +second element is a string of its value. The following call to +`sbe' would be equivalent to the following source code block. + + (sbe 'source-block (n $2) (m 3)) + +#+begin_src emacs-lisp :var results=source-block(n=val_at_col_2, m=3) :results silent +results +#+end_src + +NOTE: by default string variable names are interpreted as +references to source-code blocks, to force interpretation of a +cell's value as a string, prefix the identifier with two \"$\"s +rather than a single \"$\" (i.e. \"$$2\" instead of \"$2\" in the +example above." + (let* (quote + (variables + (mapcar + (lambda (var) + ;; ensure that all cells prefixed with $'s are strings + (cons (car var) + (delq nil (mapcar + (lambda (el) + (if (eq '$ el) + (setq quote t) + (prog1 (if quote + (format "\"%s\"" el) + (org-babel-clean-text-properties el)) + (setq quote nil)))) + (cdr var))))) + variables))) + (unless (stringp source-block) + (setq source-block (symbol-name source-block))) + (org-babel-table-truncate-at-newline ;; org-table cells can't be multi-line + (if (and source-block (> (length source-block) 0)) + (let ((params + (eval `(org-babel-parse-header-arguments + (concat ":var results=" + ,source-block + "(" + (mapconcat + (lambda (var-spec) + (if (> (length (cdr var-spec)) 1) + (format "%S='%S" + (car var-spec) + (mapcar #'read (cdr var-spec))) + (format "%S=%s" + (car var-spec) (cadr var-spec)))) + ',variables ", ") + ")"))))) + (org-babel-execute-src-block + nil (list "emacs-lisp" "results" params) '((:results . "silent")))) + "")))) + +(provide 'ob-table) + +;; arch-tag: 4234cc7c-4fc8-4e92-abb0-2892de1a493b + +;;; ob-table.el ends here diff --git a/.emacs.d/org-7.4/lisp/ob-table.elc b/.emacs.d/org-7.4/lisp/ob-table.elc Binary files differnew file mode 100644 index 0000000..1fc8b46 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-table.elc diff --git a/.emacs.d/org-7.4/lisp/ob-tangle.el b/.emacs.d/org-7.4/lisp/ob-tangle.el new file mode 100644 index 0000000..c5ef2a1 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-tangle.el @@ -0,0 +1,454 @@ +;;; ob-tangle.el --- extract source code from org-mode files + +;; Copyright (C) 2009, 2010 Free Software Foundation, Inc. + +;; Author: Eric Schulte +;; Keywords: literate programming, reproducible research +;; Homepage: http://orgmode.org +;; Version: 7.4 + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Extract the code from source blocks out into raw source-code files. + +;;; Code: +(require 'ob) +(require 'org-src) +(eval-when-compile + (require 'cl)) + +(declare-function org-link-escape "org" (text &optional table)) +(declare-function org-heading-components "org" ()) +(declare-function org-back-to-heading "org" (invisible-ok)) +(declare-function org-fill-template "org" (template alist)) +(declare-function org-babel-update-block-body "org" (new-body)) + +;;;###autoload +(defcustom org-babel-tangle-lang-exts + '(("emacs-lisp" . "el")) + "Alist mapping languages to their file extensions. +The key is the language name, the value is the string that should +be inserted as the extension commonly used to identify files +written in this language. If no entry is found in this list, +then the name of the language is used." + :group 'org-babel-tangle + :type '(repeat + (cons + (string "Language name") + (string "File Extension")))) + +(defcustom org-babel-post-tangle-hook nil + "Hook run in code files tangled by `org-babel-tangle'." + :group 'org-babel + :type 'hook) + +(defcustom org-babel-pre-tangle-hook '(save-buffer) + "Hook run at the beginning of `org-babel-tangle'." + :group 'org-babel + :type 'hook) + +(defcustom org-babel-tangle-pad-newline t + "Switch indicating whether to pad tangled code with newlines." + :group 'org-babel + :type 'boolean) + +(defcustom org-babel-tangle-comment-format-beg "[[%link][%source-name]]" + "Format of inserted comments in tangled code files. +The following format strings can be used to insert special +information into the output using `org-fill-template'. +%start-line --- the line number at the start of the code block +%file --------- the file from which the code block was tangled +%link --------- Org-mode style link to the code block +%source-name -- name of the code block + +Whether or not comments are inserted during tangling is +controlled by the :comments header argument." + :group 'org-babel + :type 'string) + +(defcustom org-babel-tangle-comment-format-end "%source-name ends here" + "Format of inserted comments in tangled code files. +The following format strings can be used to insert special +information into the output using `org-fill-template'. +%start-line --- the line number at the start of the code block +%file --------- the file from which the code block was tangled +%link --------- Org-mode style link to the code block +%source-name -- name of the code block + +Whether or not comments are inserted during tangling is +controlled by the :comments header argument." + :group 'org-babel + :type 'string) + +(defun org-babel-find-file-noselect-refresh (file) + "Find file ensuring that the latest changes on disk are +represented in the file." + (find-file-noselect file) + (with-current-buffer (get-file-buffer file) + (revert-buffer t t t))) + +(defmacro org-babel-with-temp-filebuffer (file &rest body) + "Open FILE into a temporary buffer execute BODY there like +`progn', then kill the FILE buffer returning the result of +evaluating BODY." + (declare (indent 1)) + (let ((temp-result (make-symbol "temp-result")) + (temp-file (make-symbol "temp-file")) + (visited-p (make-symbol "visited-p"))) + `(let (,temp-result ,temp-file + (,visited-p (get-file-buffer ,file))) + (org-babel-find-file-noselect-refresh ,file) + (setf ,temp-file (get-file-buffer ,file)) + (with-current-buffer ,temp-file + (setf ,temp-result (progn ,@body))) + (unless ,visited-p (kill-buffer ,temp-file)) + ,temp-result))) + +;;;###autoload +(defun org-babel-load-file (file) + "Load Emacs Lisp source code blocks in the Org-mode FILE. +This function exports the source code using +`org-babel-tangle' and then loads the resulting file using +`load-file'." + (interactive "fFile to load: ") + (flet ((age (file) + (float-time + (time-subtract (current-time) + (nth 5 (or (file-attributes (file-truename file)) + (file-attributes file))))))) + (let* ((base-name (file-name-sans-extension file)) + (exported-file (concat base-name ".el"))) + ;; tangle if the org-mode file is newer than the elisp file + (unless (and (file-exists-p exported-file) + (> (age file) (age exported-file))) + (org-babel-tangle-file file exported-file "emacs-lisp")) + (load-file exported-file) + (message "loaded %s" exported-file)))) + +;;;###autoload +(defun org-babel-tangle-file (file &optional target-file lang) + "Extract the bodies of source code blocks in FILE. +Source code blocks are extracted with `org-babel-tangle'. +Optional argument TARGET-FILE can be used to specify a default +export file for all source blocks. Optional argument LANG can be +used to limit the exported source code blocks by language." + (interactive "fFile to tangle: \nP") + (let ((visited-p (get-file-buffer (expand-file-name file))) + to-be-removed) + (save-window-excursion + (find-file file) + (setq to-be-removed (current-buffer)) + (org-babel-tangle target-file lang)) + (unless visited-p + (kill-buffer to-be-removed)))) + +(defun org-babel-tangle-publish (_ filename pub-dir) + "Tangle FILENAME and place the results in PUB-DIR." + (mapc (lambda (el) (copy-file el pub-dir t)) (org-babel-tangle-file filename))) + +;;;###autoload +(defun org-babel-tangle (&optional target-file lang) + "Write code blocks to source-specific files. +Extract the bodies of all source code blocks from the current +file into their own source-specific files. Optional argument +TARGET-FILE can be used to specify a default export file for all +source blocks. Optional argument LANG can be used to limit the +exported source code blocks by language." + (interactive) + (run-hooks 'org-babel-pre-tangle-hook) + (save-excursion + (let ((block-counter 0) + (org-babel-default-header-args + (if target-file + (org-babel-merge-params org-babel-default-header-args + (list (cons :tangle target-file))) + org-babel-default-header-args)) + path-collector) + (mapc ;; map over all languages + (lambda (by-lang) + (let* ((lang (car by-lang)) + (specs (cdr by-lang)) + (ext (or (cdr (assoc lang org-babel-tangle-lang-exts)) lang)) + (lang-f (intern + (concat + (or (and (cdr (assoc lang org-src-lang-modes)) + (symbol-name + (cdr (assoc lang org-src-lang-modes)))) + lang) + "-mode"))) + she-banged) + (mapc + (lambda (spec) + (flet ((get-spec (name) + (cdr (assoc name (nth 4 spec))))) + (let* ((tangle (get-spec :tangle)) + (she-bang ((lambda (sheb) (when (> (length sheb) 0) sheb)) + (get-spec :shebang))) + (base-name (cond + ((string= "yes" tangle) + (file-name-sans-extension + (buffer-file-name))) + ((string= "no" tangle) nil) + ((> (length tangle) 0) tangle))) + (file-name (when base-name + ;; decide if we want to add ext to base-name + (if (and ext (string= "yes" tangle)) + (concat base-name "." ext) base-name)))) + (when file-name + ;; delete any old versions of file + (when (and (file-exists-p file-name) + (not (member file-name path-collector))) + (delete-file file-name)) + ;; drop source-block to file + (with-temp-buffer + (when (fboundp lang-f) (funcall lang-f)) + (when (and she-bang (not (member file-name she-banged))) + (insert (concat she-bang "\n")) + (setq she-banged (cons file-name she-banged))) + (org-babel-spec-to-string spec) + ;; We avoid append-to-file as it does not work with tramp. + (let ((content (buffer-string))) + (with-temp-buffer + (if (file-exists-p file-name) + (insert-file-contents file-name)) + (goto-char (point-max)) + (insert content) + (write-region nil nil file-name)))) + ;; if files contain she-bangs, then make the executable + (when she-bang (set-file-modes file-name #o755)) + ;; update counter + (setq block-counter (+ 1 block-counter)) + (add-to-list 'path-collector file-name))))) + specs))) + (org-babel-tangle-collect-blocks lang)) + (message "tangled %d code block%s from %s" block-counter + (if (= block-counter 1) "" "s") + (file-name-nondirectory (buffer-file-name (current-buffer)))) + ;; run `org-babel-post-tangle-hook' in all tangled files + (when org-babel-post-tangle-hook + (mapc + (lambda (file) + (org-babel-with-temp-filebuffer file + (run-hooks 'org-babel-post-tangle-hook))) + path-collector)) + path-collector))) + +(defun org-babel-tangle-clean () + "Remove comments inserted by `org-babel-tangle'. +Call this function inside of a source-code file generated by +`org-babel-tangle' to remove all comments inserted automatically +by `org-babel-tangle'. Warning, this comment removes any lines +containing constructs which resemble org-mode file links or noweb +references." + (interactive) + (goto-char (point-min)) + (while (or (re-search-forward "\\[\\[file:.*\\]\\[.*\\]\\]" nil t) + (re-search-forward "<<[^[:space:]]*>>" nil t)) + (delete-region (save-excursion (beginning-of-line 1) (point)) + (save-excursion (end-of-line 1) (forward-char 1) (point))))) + +(defvar org-stored-links) +(defun org-babel-tangle-collect-blocks (&optional language) + "Collect source blocks in the current Org-mode file. +Return an association list of source-code block specifications of +the form used by `org-babel-spec-to-string' grouped by language. +Optional argument LANG can be used to limit the collected source +code blocks by language." + (let ((block-counter 1) (current-heading "") blocks) + (org-babel-map-src-blocks (buffer-file-name) + ((lambda (new-heading) + (if (not (string= new-heading current-heading)) + (progn + (setq block-counter 1) + (setq current-heading new-heading)) + (setq block-counter (+ 1 block-counter)))) + (replace-regexp-in-string "[ \t]" "-" + (condition-case nil + (nth 4 (org-heading-components)) + (error (buffer-file-name))))) + (let* ((start-line (save-restriction (widen) + (+ 1 (line-number-at-pos (point))))) + (file (buffer-file-name)) + (info (org-babel-get-src-block-info 'light)) + (src-lang (nth 0 info))) + (unless (string= (cdr (assoc :tangle (nth 2 info))) "no") + (unless (and language (not (string= language src-lang))) + (let* ((info (org-babel-get-src-block-info)) + (params (nth 2 info)) + (link (progn (call-interactively 'org-store-link) + (org-babel-clean-text-properties + (car (pop org-stored-links))))) + (source-name + (intern (or (nth 4 info) + (format "%s:%d" + current-heading block-counter)))) + (expand-cmd + (intern (concat "org-babel-expand-body:" src-lang))) + (assignments-cmd + (intern (concat "org-babel-variable-assignments:" src-lang))) + (body + ((lambda (body) + (if (assoc :no-expand params) + body + (if (fboundp expand-cmd) + (funcall expand-cmd body params) + (org-babel-expand-body:generic + body params + (and (fboundp assignments-cmd) + (funcall assignments-cmd params)))))) + (if (and (cdr (assoc :noweb params)) + (let ((nowebs (split-string + (cdr (assoc :noweb params))))) + (or (member "yes" nowebs) + (member "tangle" nowebs)))) + (org-babel-expand-noweb-references info) + (nth 1 info)))) + (comment + (when (or (string= "both" (cdr (assoc :comments params))) + (string= "org" (cdr (assoc :comments params)))) + ;; from the previous heading or code-block end + (buffer-substring + (max (condition-case nil + (save-excursion + (org-back-to-heading t) (point)) + (error 0)) + (save-excursion + (re-search-backward + org-babel-src-block-regexp nil t) + (match-end 0))) + (point)))) + by-lang) + ;; add the spec for this block to blocks under it's language + (setq by-lang (cdr (assoc src-lang blocks))) + (setq blocks (delq (assoc src-lang blocks) blocks)) + (setq blocks (cons + (cons src-lang + (cons (list start-line file link + source-name params body comment) + by-lang)) blocks))))))) + ;; ensure blocks in the correct order + (setq blocks + (mapcar + (lambda (by-lang) (cons (car by-lang) (reverse (cdr by-lang)))) + blocks)) + blocks)) + +(defun org-babel-spec-to-string (spec) + "Insert SPEC into the current file. +Insert the source-code specified by SPEC into the current +source code file. This function uses `comment-region' which +assumes that the appropriate major-mode is set. SPEC has the +form + + (start-line file link source-name params body comment)" + (let* ((start-line (nth 0 spec)) + (file (nth 1 spec)) + (link (org-link-escape (nth 2 spec))) + (source-name (nth 3 spec)) + (body (nth 5 spec)) + (comment (nth 6 spec)) + (comments (cdr (assoc :comments (nth 4 spec)))) + (link-p (or (string= comments "both") (string= comments "link") + (string= comments "yes"))) + (link-data (mapcar (lambda (el) + (cons (symbol-name el) + ((lambda (le) + (if (stringp le) le (format "%S" le))) + (eval el)))) + '(start-line file link source-name)))) + (flet ((insert-comment (text) + (let ((text (org-babel-trim text))) + (when (and comments (not (string= comments "no")) + (> (length text) 0)) + (when org-babel-tangle-pad-newline (insert "\n")) + (comment-region (point) (progn (insert text) (point))) + (end-of-line nil) (insert "\n"))))) + (when comment (insert-comment comment)) + (when link-p + (insert-comment + (org-fill-template org-babel-tangle-comment-format-beg link-data))) + (when org-babel-tangle-pad-newline (insert "\n")) + (insert + (format + "%s\n" + (replace-regexp-in-string + "^," "" + (org-babel-trim body (if org-src-preserve-indentation "[\f\n\r\v]"))))) + (when link-p + (insert-comment + (org-fill-template org-babel-tangle-comment-format-end link-data)))))) + +;; detangling functions +(defvar org-bracket-link-analytic-regexp) +(defun org-babel-detangle (&optional source-code-file) + "Propagate changes in source file back original to Org-mode file. +This requires that code blocks were tangled with link comments +which enable the original code blocks to be found." + (interactive) + (save-excursion + (when source-code-file (find-file source-code-file)) + (goto-char (point-min)) + (let ((counter 0) new-body end) + (while (re-search-forward org-bracket-link-analytic-regexp nil t) + (when (re-search-forward + (concat " " (regexp-quote (match-string 5)) " ends here")) + (setq end (match-end 0)) + (forward-line -1) + (save-excursion + (when (setq new-body (org-babel-tangle-jump-to-org)) + (org-babel-update-block-body new-body))) + (setq counter (+ 1 counter))) + (goto-char end)) + (prog1 counter (message "detangled %d code blocks" counter))))) + +(defun org-babel-tangle-jump-to-org () + "Jump from a tangled code file to the related Org-mode file." + (interactive) + (let ((mid (point)) + target-buffer target-char + start end link path block-name body) + (save-window-excursion + (save-excursion + (unless (and (re-search-backward org-bracket-link-analytic-regexp nil t) + (setq start (point-at-eol)) + (setq link (match-string 0)) + (setq path (match-string 3)) + (setq block-name (match-string 5)) + (re-search-forward + (concat " " (regexp-quote block-name) " ends here") nil t) + (setq end (point-at-bol)) + (< start mid) (< mid end)) + (error "not in tangled code")) + (setq body (org-babel-trim (buffer-substring start end)))) + (when (string-match "::" path) + (setq path (substring path 0 (match-beginning 0)))) + (find-file path) (setq target-buffer (current-buffer)) + (goto-char start) (org-open-link-from-string link) + (if (string-match "[^ \t\n\r]:\\([[:digit:]]+\\)" block-name) + (org-babel-next-src-block + (string-to-number (match-string 1 block-name))) + (org-babel-goto-named-src-block block-name)) + (setq target-char (point))) + (pop-to-buffer target-buffer) + (prog1 body (goto-char target-char)))) + +(provide 'ob-tangle) + +;; arch-tag: 413ced93-48f5-4216-86e4-3fc5df8c8f24 + +;;; ob-tangle.el ends here diff --git a/.emacs.d/org-7.4/lisp/ob-tangle.elc b/.emacs.d/org-7.4/lisp/ob-tangle.elc Binary files differnew file mode 100644 index 0000000..faaf080 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob-tangle.elc diff --git a/.emacs.d/org-7.4/lisp/ob.el b/.emacs.d/org-7.4/lisp/ob.el new file mode 100644 index 0000000..1c9f9fd --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob.el @@ -0,0 +1,1968 @@ +;;; ob.el --- working with code blocks in org-mode + +;; Copyright (C) 2009, 2010 Free Software Foundation, Inc. + +;; Author: Eric Schulte, Dan Davison +;; Keywords: literate programming, reproducible research +;; Homepage: http://orgmode.org +;; Version: 7.4 + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; See the online documentation for more information +;; +;; http://orgmode.org/worg/org-contrib/babel/ + +;;; Code: +(eval-when-compile + (require 'org-list) + (require 'cl)) +(require 'ob-eval) +(require 'org-macs) + +(defvar org-babel-call-process-region-original) +(declare-function show-all "outline" ()) +(declare-function tramp-compat-make-temp-file "tramp-compat" + (filename &optional dir-flag)) +(declare-function tramp-dissect-file-name "tramp" (name &optional nodefault)) +(declare-function tramp-file-name-user "tramp" (vec)) +(declare-function tramp-file-name-host "tramp" (vec)) +(declare-function with-parsed-tramp-file-name "tramp" (filename var &rest body)) +(declare-function org-icompleting-read "org" (&rest args)) +(declare-function org-edit-src-code "org-src" + (&optional context code edit-buffer-name quietp)) +(declare-function org-edit-src-exit "org-src" (&optional context)) +(declare-function org-open-at-point "org" (&optional in-emacs reference-buffer)) +(declare-function org-save-outline-visibility "org" (use-markers &rest body)) +(declare-function org-outline-overlay-data "org" (&optional use-markers)) +(declare-function org-set-outline-overlay-data "org" (data)) +(declare-function org-narrow-to-subtree "org" ()) +(declare-function org-entry-get "org" + (pom property &optional inherit literal-nil)) +(declare-function org-make-options-regexp "org" (kwds &optional extra)) +(declare-function org-do-remove-indentation "org" (&optional n)) +(declare-function org-show-context "org" (&optional key)) +(declare-function org-at-table-p "org" (&optional table-type)) +(declare-function org-cycle "org" (&optional arg)) +(declare-function org-uniquify "org" (list)) +(declare-function org-current-level "org" ()) +(declare-function org-table-import "org-table" (file arg)) +(declare-function org-add-hook "org-compat" + (hook function &optional append local)) +(declare-function org-table-align "org-table" ()) +(declare-function org-table-end "org-table" (&optional table-type)) +(declare-function orgtbl-to-generic "org-table" (table params)) +(declare-function orgtbl-to-orgtbl "org-table" (table params)) +(declare-function org-babel-lob-get-info "ob-lob" nil) +(declare-function org-babel-ref-split-args "ob-ref" (arg-string)) +(declare-function org-babel-ref-parse "ob-ref" (assignment)) +(declare-function org-babel-ref-resolve "ob-ref" (ref)) +(declare-function org-babel-lob-execute-maybe "ob-lob" ()) +(declare-function org-number-sequence "org-compat" (from &optional to inc)) +(declare-function org-in-item-p "org-list" ()) +(declare-function org-list-parse-list "org-list" (&optional delete)) +(declare-function org-list-to-generic "org-list" (LIST PARAMS)) +(declare-function org-list-bottom-point "org-list" ()) + +(defgroup org-babel nil + "Code block evaluation and management in `org-mode' documents." + :tag "Babel" + :group 'org) + +(defcustom org-confirm-babel-evaluate t + "Confirm before evaluation. +Require confirmation before interactively evaluating code +blocks in Org-mode buffers. The default value of this variable +is t, meaning confirmation is required for any code block +evaluation. This variable can be set to nil to inhibit any +future confirmation requests. This variable can also be set to a +function which takes two arguments the language of the code block +and the body of the code block. Such a function should then +return a non-nil value if the user should be prompted for +execution or nil if no prompt is required. + +Warning: Disabling confirmation may result in accidental +evaluation of potentially harmful code. It may be advisable +remove code block execution from C-c C-c as further protection +against accidental code block evaluation. The +`org-babel-no-eval-on-ctrl-c-ctrl-c' variable can be used to +remove code block execution from the C-c C-c keybinding." + :group 'org-babel + :type '(choice boolean function)) +;; don't allow this variable to be changed through file settings +(put 'org-confirm-babel-evaluate 'safe-local-variable (lambda (x) (eq x t))) + +(defcustom org-babel-no-eval-on-ctrl-c-ctrl-c nil + "Remove code block evaluation from the C-c C-c key binding." + :group 'org-babel + :type 'boolean) + +(defvar org-babel-src-name-regexp + "^[ \t]*#\\+\\(srcname\\|source\\|function\\):[ \t]*" + "Regular expression used to match a source name line.") + +(defvar org-babel-multi-line-header-regexp + "^[ \t]*#\\+headers?:[ \t]*\\([^\n]*\\)$" + "Regular expression used to match multi-line header arguments.") + +(defvar org-babel-src-name-w-name-regexp + (concat org-babel-src-name-regexp + "\\(" + org-babel-multi-line-header-regexp + "\\)*" + "\\([^ ()\f\t\n\r\v]+\\)\\(\(\\(.*\\)\)\\|\\)") + "Regular expression matching source name lines with a name.") + +(defvar org-babel-src-block-regexp + (concat + ;; (1) indentation (2) lang + "^\\([ \t]*\\)#\\+begin_src[ \t]+\\([^ \f\t\n\r\v]+\\)[ \t]*" + ;; (3) switches + "\\([^\":\n]*\"[^\"\n*]*\"[^\":\n]*\\|[^\":\n]*\\)" + ;; (4) header arguments + "\\([^\n]*\\)\n" + ;; (5) body + "\\([^\000]+?\n\\)[ \t]*#\\+end_src") + "Regexp used to identify code blocks.") + +(defvar org-babel-inline-src-block-regexp + (concat + ;; (1) replacement target (2) lang + "[ \f\t\n\r\v]\\(src_\\([^ \f\t\n\r\v]+\\)" + ;; (3,4) (unused, headers) + "\\(\\|\\[\\(.*?\\)\\]\\)" + ;; (5) body + "{\\([^\f\n\r\v]+?\\)}\\)") + "Regexp used to identify inline src-blocks.") + +(defun org-babel-get-header (params key &optional others) + "Select only header argument of type KEY from a list. +Optional argument OTHERS indicates that only the header that do +not match KEY should be returned." + (delq nil + (mapcar + (lambda (p) (when (funcall (if others #'not #'identity) (eq (car p) key)) p)) + params))) + +(defun org-babel-get-src-block-info (&optional light) + "Get information on the current source block. + +Optional argument LIGHT does not resolve remote variable +references; a process which could likely result in the execution +of other code blocks. + +Returns a list + (language body header-arguments-alist switches name indent)." + (let ((case-fold-search t) head info name indent) + ;; full code block + (if (setq head (org-babel-where-is-src-block-head)) + (save-excursion + (goto-char head) + (setq info (org-babel-parse-src-block-match)) + (setq indent (car (last info))) + (setq info (butlast info)) + (while (and (forward-line -1) + (looking-at org-babel-multi-line-header-regexp)) + (setf (nth 2 info) + (org-babel-merge-params + (org-babel-parse-header-arguments (match-string 1)) + (nth 2 info)))) + (when (looking-at org-babel-src-name-w-name-regexp) + (setq name (org-babel-clean-text-properties (match-string 4))) + (when (match-string 6) + (setf (nth 2 info) ;; merge functional-syntax vars and header-args + (org-babel-merge-params + (mapcar (lambda (ref) (cons :var ref)) + (org-babel-ref-split-args (match-string 6))) + (nth 2 info)))))) + ;; inline source block + (when (save-excursion (re-search-backward "[ \f\t\n\r\v]" nil t) + (looking-at org-babel-inline-src-block-regexp)) + (setq info (org-babel-parse-inline-src-block-match)))) + ;; resolve variable references and add summary parameters + (when (and info (not light)) + (setf (nth 2 info) (org-babel-process-params (nth 2 info)))) + (when info (append info (list name indent))))) + +(defun org-babel-confirm-evaluate (info) + "Confirm evaluation of the code block INFO. +This behavior can be suppressed by setting the value of +`org-confirm-babel-evaluate' to nil, in which case all future +interactive code block evaluations will proceed without any +confirmation from the user. + +Note disabling confirmation may result in accidental evaluation +of potentially harmful code." + (let* ((eval (or (cdr (assoc :eval (nth 2 info))) + (when (assoc :noeval (nth 2 info)) "no"))) + (query (or (equal eval "query") + (if (functionp org-confirm-babel-evaluate) + (funcall org-confirm-babel-evaluate + (nth 0 info) (nth 1 info)) + org-confirm-babel-evaluate)))) + (if (or (equal eval "never") (equal eval "no") + (and query + (not (yes-or-no-p + (format "Evaluate this%scode block%son your system? " + (if info (format " %s " (nth 0 info)) " ") + (if (nth 4 info) + (format " (%s) " (nth 4 info)) " ")))))) + (prog1 nil (message "Evaluation %s" + (if (or (equal eval "never") (equal eval "no")) + "Disabled" "Aborted"))) + t))) + +;;;###autoload +(defun org-babel-execute-safely-maybe () + (unless org-babel-no-eval-on-ctrl-c-ctrl-c + (org-babel-execute-maybe))) + +(add-hook 'org-ctrl-c-ctrl-c-hook 'org-babel-execute-safely-maybe) + +;;;###autoload +(defun org-babel-execute-maybe () + (interactive) + (or (org-babel-execute-src-block-maybe) + (org-babel-lob-execute-maybe))) + +(defun org-babel-execute-src-block-maybe () + "Conditionally execute a source block. +Detect if this is context for a Babel src-block and if so +then run `org-babel-execute-src-block'." + (interactive) + (let ((info (org-babel-get-src-block-info))) + (if info + (progn (org-babel-eval-wipe-error-buffer) + (org-babel-execute-src-block current-prefix-arg info) t) nil))) + +;;;###autoload +(defun org-babel-expand-src-block-maybe () + "Conditionally expand a source block. +Detect if this is context for a org-babel src-block and if so +then run `org-babel-expand-src-block'." + (interactive) + (let ((info (org-babel-get-src-block-info))) + (if info + (progn (org-babel-expand-src-block current-prefix-arg info) t) + nil))) + +;;;###autoload +(defun org-babel-load-in-session-maybe () + "Conditionally load a source block in a session. +Detect if this is context for a org-babel src-block and if so +then run `org-babel-load-in-session'." + (interactive) + (let ((info (org-babel-get-src-block-info))) + (if info + (progn (org-babel-load-in-session current-prefix-arg info) t) + nil))) + +(add-hook 'org-metaup-hook 'org-babel-load-in-session-maybe) + +;;;###autoload +(defun org-babel-pop-to-session-maybe () + "Conditionally pop to a session. +Detect if this is context for a org-babel src-block and if so +then run `org-babel-pop-to-session'." + (interactive) + (let ((info (org-babel-get-src-block-info))) + (if info (progn (org-babel-pop-to-session current-prefix-arg info) t) nil))) + +(add-hook 'org-metadown-hook 'org-babel-pop-to-session-maybe) + +(defconst org-babel-header-arg-names + '(cache cmdline colnames dir exports file noweb results + session tangle var eval noeval comments) + "Common header arguments used by org-babel. +Note that individual languages may define their own language +specific header arguments as well.") + +(defvar org-babel-default-header-args + '((:session . "none") (:results . "replace") (:exports . "code") + (:cache . "no") (:noweb . "no") (:hlines . "no") (:tangle . "no")) + "Default arguments to use when evaluating a source block.") + +(defvar org-babel-default-inline-header-args + '((:session . "none") (:results . "silent") (:exports . "results")) + "Default arguments to use when evaluating an inline source block.") + +(defvar org-babel-current-buffer-properties nil + "Local cache for buffer properties.") +(make-variable-buffer-local 'org-babel-current-buffer-properties) + +(defvar org-babel-result-regexp + "^[ \t]*#\\+res\\(ults\\|name\\)\\(\\[\\([[:alnum:]]+\\)\\]\\)?\\:[ \t]*" + "Regular expression used to match result lines. +If the results are associated with a hash key then the hash will +be saved in the second match data.") + +(defvar org-babel-result-w-name-regexp + (concat org-babel-result-regexp + "\\([^ ()\f\t\n\r\v]+\\)\\(\(\\(.*\\)\)\\|\\)")) + +(defvar org-babel-min-lines-for-block-output 10 + "The minimum number of lines for block output. +If number of lines of output is equal to or exceeds this +value, the output is placed in a #+begin_example...#+end_example +block. Otherwise the output is marked as literal by inserting +colons at the starts of the lines. This variable only takes +effect if the :results output option is in effect.") + +(defvar org-babel-noweb-error-langs nil + "Languages for which Babel will raise literate programming errors. +List of languages for which errors should be raised when the +source code block satisfying a noweb reference in this language +can not be resolved.") + +(defvar org-babel-hash-show 4 + "Number of initial characters to show of a hidden results hash.") + +(defvar org-babel-after-execute-hook nil + "Hook for functions to be called after `org-babel-execute-src-block'") +(defun org-babel-named-src-block-regexp-for-name (name) + "This generates a regexp used to match a src block named NAME." + (concat org-babel-src-name-regexp (regexp-quote name) "[ \t\n]*" + (substring org-babel-src-block-regexp 1))) + +;;; functions +(defvar call-process-region) +;;;###autoload + +(defun org-babel-execute-src-block (&optional arg info params) + "Execute the current source code block. +Insert the results of execution into the buffer. Source code +execution and the collection and formatting of results can be +controlled through a variety of header arguments. + +With prefix argument ARG, force re-execution even if a an +existing result cached in the buffer would otherwise have been +returned. + +Optionally supply a value for INFO in the form returned by +`org-babel-get-src-block-info'. + +Optionally supply a value for PARAMS which will be merged with +the header arguments specified at the front of the source code +block." + (interactive) + (let ((info (or info (org-babel-get-src-block-info)))) + (when (org-babel-confirm-evaluate info) + (let* ((lang (nth 0 info)) + (params (if params + (org-babel-process-params + (org-babel-merge-params (nth 2 info) params)) + (nth 2 info))) + (cache? (and (not arg) (cdr (assoc :cache params)) + (string= "yes" (cdr (assoc :cache params))))) + (result-params (cdr (assoc :result-params params))) + (new-hash (when cache? (org-babel-sha1-hash info))) + (old-hash (when cache? (org-babel-result-hash info))) + (body (setf (nth 1 info) + (let ((noweb (cdr (assoc :noweb params)))) + (if (and noweb + (or (string= "yes" noweb) + (string= "tangle" noweb))) + (org-babel-expand-noweb-references info) + (nth 1 info))))) + (cmd (intern (concat "org-babel-execute:" lang))) + (dir (cdr (assoc :dir params))) + (default-directory + (or (and dir (file-name-as-directory dir)) default-directory)) + (org-babel-call-process-region-original + (if (boundp 'org-babel-call-process-region-original) + org-babel-call-process-region-original + (symbol-function 'call-process-region))) + (indent (car (last info))) + result) + (unwind-protect + (flet ((call-process-region (&rest args) + (apply 'org-babel-tramp-handle-call-process-region args))) + (unless (fboundp cmd) + (error "No org-babel-execute function for %s!" lang)) + (if (and (not arg) new-hash (equal new-hash old-hash)) + (save-excursion ;; return cached result + (goto-char (org-babel-where-is-src-block-result nil info)) + (end-of-line 1) (forward-char 1) + (setq result (org-babel-read-result)) + (message (replace-regexp-in-string + "%" "%%" (format "%S" result))) result) + (message "executing %s code block%s..." + (capitalize lang) + (if (nth 4 info) (format " (%s)" (nth 4 info)) "")) + (setq result + ((lambda (result) + (cond + ((member "file" result-params) + (cdr (assoc :file params))) + ((and (eq (cdr (assoc :result-type params)) 'value) + (or (member "vector" result-params) + (member "table" result-params)) + (not (listp result))) + (list (list result))) + (t result))) + (funcall cmd body params))) + (org-babel-insert-result + result result-params info new-hash indent lang) + (run-hooks 'org-babel-after-execute-hook) + result)) + (setq call-process-region 'org-babel-call-process-region-original)))))) + +(defun org-babel-expand-body:generic (body params &optional var-lines) + "Expand BODY with PARAMS. +Expand a block of code with org-babel according to it's header +arguments. This generic implementation of body expansion is +called for languages which have not defined their own specific +org-babel-expand-body:lang function." + (mapconcat #'identity (append var-lines (list body)) "\n")) + +;;;###autoload +(defun org-babel-expand-src-block (&optional arg info params) + "Expand the current source code block. +Expand according to the source code block's header +arguments and pop open the results in a preview buffer." + (interactive) + (let* ((info (or info (org-babel-get-src-block-info))) + (lang (nth 0 info)) + (params (setf (nth 2 info) + (sort (org-babel-merge-params (nth 2 info) params) + (lambda (el1 el2) (string< (symbol-name (car el1)) + (symbol-name (car el2))))))) + (body (setf (nth 1 info) + (if (and (cdr (assoc :noweb params)) + (string= "yes" (cdr (assoc :noweb params)))) + (org-babel-expand-noweb-references info) (nth 1 info)))) + (expand-cmd (intern (concat "org-babel-expand-body:" lang))) + (assignments-cmd (intern (concat "org-babel-variable-assignments:" lang))) + (expanded + (if (fboundp expand-cmd) (funcall expand-cmd body params) + (org-babel-expand-body:generic + body params (and (fboundp assignments-cmd) (funcall assignments-cmd params)))))) + (org-edit-src-code + nil expanded (concat "*Org-Babel Preview " (buffer-name) "[ " lang " ]*")))) + +;;;###autoload +(defun org-babel-load-in-session (&optional arg info) + "Load the body of the current source-code block. +Evaluate the header arguments for the source block before +entering the session. After loading the body this pops open the +session." + (interactive) + (let* ((info (or info (org-babel-get-src-block-info))) + (lang (nth 0 info)) + (params (nth 2 info)) + (body (setf (nth 1 info) + (if (and (cdr (assoc :noweb params)) + (string= "yes" (cdr (assoc :noweb params)))) + (org-babel-expand-noweb-references info) + (nth 1 info)))) + (session (cdr (assoc :session params))) + (dir (cdr (assoc :dir params))) + (default-directory + (or (and dir (file-name-as-directory dir)) default-directory)) + (cmd (intern (concat "org-babel-load-session:" lang)))) + (unless (fboundp cmd) + (error "No org-babel-load-session function for %s!" lang)) + (pop-to-buffer (funcall cmd session body params)) + (end-of-line 1))) + +;;;###autoload +(defun org-babel-initiate-session (&optional arg info) + "Initiate session for current code block. +If called with a prefix argument then resolve any variable +references in the header arguments and assign these variables in +the session. Copy the body of the code block to the kill ring." + (interactive "P") + (let* ((info (or info (org-babel-get-src-block-info (not arg)))) + (lang (nth 0 info)) + (body (nth 1 info)) + (params (nth 2 info)) + (session (cdr (assoc :session params))) + (dir (cdr (assoc :dir params))) + (default-directory + (or (and dir (file-name-as-directory dir)) default-directory)) + (init-cmd (intern (format "org-babel-%s-initiate-session" lang))) + (prep-cmd (intern (concat "org-babel-prep-session:" lang)))) + (if (and (stringp session) (string= session "none")) + (error "This block is not using a session!")) + (unless (fboundp init-cmd) + (error "No org-babel-initiate-session function for %s!" lang)) + (with-temp-buffer (insert (org-babel-trim body)) + (copy-region-as-kill (point-min) (point-max))) + (when arg + (unless (fboundp prep-cmd) + (error "No org-babel-prep-session function for %s!" lang)) + (funcall prep-cmd session params)) + (funcall init-cmd session params))) + +;;;###autoload +(defun org-babel-switch-to-session (&optional arg info) + "Switch to the session of the current code block. +Uses `org-babel-initiate-session' to start the session. If called +with a prefix argument then this is passed on to +`org-babel-initiate-session'." + (interactive "P") + (pop-to-buffer (org-babel-initiate-session arg info)) + (end-of-line 1)) + +(defalias 'org-babel-pop-to-session 'org-babel-switch-to-session) + +;;;###autoload +(defun org-babel-switch-to-session-with-code (&optional arg info) + "Switch to code buffer and display session." + (interactive "P") + (flet ((swap-windows + () + (let ((other-window-buffer (window-buffer (next-window)))) + (set-window-buffer (next-window) (current-buffer)) + (set-window-buffer (selected-window) other-window-buffer)) + (other-window 1))) + (let ((info (org-babel-get-src-block-info)) + (org-src-window-setup 'reorganize-frame)) + (save-excursion + (org-babel-switch-to-session arg info)) + (org-edit-src-code)) + (swap-windows))) + +(defmacro org-babel-do-in-edit-buffer (&rest body) + "Evaluate BODY in edit buffer if there is a code block at point. +Return t if a code block was found at point, nil otherwise." + `(let ((org-src-window-setup 'switch-invisibly)) + (when (and (org-babel-where-is-src-block-head) + (org-edit-src-code nil nil nil 'quietly)) + (unwind-protect (progn ,@body) + (if (org-bound-and-true-p org-edit-src-from-org-mode) + (org-edit-src-exit))) + t))) + +(defun org-babel-do-key-sequence-in-edit-buffer (key) + "Read key sequence and execute the command in edit buffer. +Enter a key sequence to be executed in the language major-mode +edit buffer. For example, TAB will alter the contents of the +Org-mode code block according to the effect of TAB in the +language major-mode buffer. For languages that support +interactive sessions, this can be used to send code from the Org +buffer to the session for evaluation using the native major-mode +evaluation mechanisms." + (interactive "kEnter key-sequence to execute in edit buffer: ") + (org-babel-do-in-edit-buffer + (call-interactively + (key-binding (or key (read-key-sequence nil)))))) + +(defvar org-bracket-link-regexp) +;;;###autoload +(defun org-babel-open-src-block-result (&optional re-run) + "If `point' is on a src block then open the results of the +source code block, otherwise return nil. With optional prefix +argument RE-RUN the source-code block is evaluated even if +results already exist." + (interactive "P") + (when (org-babel-get-src-block-info) + (save-excursion + ;; go to the results, if there aren't any then run the block + (goto-char (or (and (not re-run) (org-babel-where-is-src-block-result)) + (progn (org-babel-execute-src-block) + (org-babel-where-is-src-block-result)))) + (end-of-line 1) + (while (looking-at "[\n\r\t\f ]") (forward-char 1)) + ;; open the results + (if (looking-at org-bracket-link-regexp) + ;; file results + (org-open-at-point) + (let ((results (org-babel-read-result))) + (flet ((echo-res (result) + (if (stringp result) result (format "%S" result)))) + (pop-to-buffer (get-buffer-create "org-babel-results")) + (delete-region (point-min) (point-max)) + (if (listp results) + ;; table result + (insert (orgtbl-to-generic results '(:sep "\t" :fmt echo-res))) + ;; scalar result + (insert (echo-res results)))))) + t))) + +;;;###autoload +(defmacro org-babel-map-src-blocks (file &rest body) + "Evaluate BODY forms on each source-block in FILE. +If FILE is nil evaluate BODY forms on source blocks in current +buffer. During evaluation of BODY the following local variables +are set relative to the currently matched code block. + +full-block ------- string holding the entirety of the code block +beg-block -------- point at the beginning of the code block +end-block -------- point at the end of the matched code block +lang ------------- string holding the language of the code block +beg-lang --------- point at the beginning of the lang +end-lang --------- point at the end of the lang +switches --------- string holding the switches +beg-switches ----- point at the beginning of the switches +end-switches ----- point at the end of the switches +header-args ------ string holding the header-args +beg-header-args -- point at the beginning of the header-args +end-header-args -- point at the end of the header-args +body ------------- string holding the body of the code block +beg-body --------- point at the beginning of the body +end-body --------- point at the end of the body" + (declare (indent 1)) + (let ((tempvar (make-symbol "file"))) + `(let* ((,tempvar ,file) + (visited-p (or (null ,tempvar) + (get-file-buffer (expand-file-name ,tempvar)))) + (point (point)) to-be-removed) + (save-window-excursion + (when ,tempvar (find-file ,tempvar)) + (setq to-be-removed (current-buffer)) + (goto-char (point-min)) + (while (re-search-forward org-babel-src-block-regexp nil t) + (goto-char (match-beginning 0)) + (let ((full-block (match-string 0)) + (beg-block (match-beginning 0)) + (end-block (match-end 0)) + (lang (match-string 2)) + (beg-lang (match-beginning 2)) + (end-lang (match-end 2)) + (switches (match-string 3)) + (beg-switches (match-beginning 3)) + (end-switches (match-end 3)) + (header-args (match-string 4)) + (beg-header-args (match-beginning 4)) + (end-header-args (match-end 4)) + (body (match-string 5)) + (beg-body (match-beginning 5)) + (end-body (match-end 5))) + ,@body + (goto-char end-block)))) + (unless visited-p (kill-buffer to-be-removed)) + (goto-char point)))) + +;;;###autoload +(defun org-babel-execute-buffer (&optional arg) + "Execute source code blocks in a buffer. +Call `org-babel-execute-src-block' on every source block in +the current buffer." + (interactive "P") + (org-save-outline-visibility t + (org-babel-map-src-blocks nil + (org-babel-execute-src-block arg)))) + +;;;###autoload +(defun org-babel-execute-subtree (&optional arg) + "Execute source code blocks in a subtree. +Call `org-babel-execute-src-block' on every source block in +the current subtree." + (interactive "P") + (save-restriction + (save-excursion + (org-narrow-to-subtree) + (org-babel-execute-buffer arg) + (widen)))) + +;;;###autoload +(defun org-babel-sha1-hash (&optional info) + "Generate an sha1 hash based on the value of info." + (interactive) + (let ((print-level nil) + (info (or info (org-babel-get-src-block-info)))) + (setf (nth 2 info) + (sort (copy-sequence (nth 2 info)) + (lambda (a b) (string< (car a) (car b))))) + (let ((hash (sha1 + (format "%s-%s" + (mapconcat + #'identity + (delq nil + (mapcar + (lambda (arg) + (let ((v (cdr arg))) + (when (and v (not (and (sequencep v) + (not (consp v)) + (= (length v) 0)))) + (format "%S" v)))) + (nth 2 info))) ":") + (nth 1 info))))) + (when (interactive-p) (message hash)) + hash))) + +(defun org-babel-result-hash (&optional info) + "Return the in-buffer hash associated with INFO." + (org-babel-where-is-src-block-result nil info) + (org-babel-clean-text-properties (match-string 3))) + +(defun org-babel-hide-hash () + "Hide the hash in the current results line. +Only the initial `org-babel-hash-show' characters of the hash +will remain visible." + (add-to-invisibility-spec '(org-babel-hide-hash . t)) + (save-excursion + (when (and (re-search-forward org-babel-result-regexp nil t) + (match-string 3)) + (let* ((start (match-beginning 3)) + (hide-start (+ org-babel-hash-show start)) + (end (match-end 3)) + (hash (match-string 3)) + ov1 ov2) + (setq ov1 (make-overlay start hide-start)) + (setq ov2 (make-overlay hide-start end)) + (overlay-put ov2 'invisible 'org-babel-hide-hash) + (overlay-put ov1 'babel-hash hash))))) + +(defun org-babel-hide-all-hashes () + "Hide the hash in the current buffer. +Only the initial `org-babel-hash-show' characters of each hash +will remain visible. This function should be called as part of +the `org-mode-hook'." + (save-excursion + (while (re-search-forward org-babel-result-regexp nil t) + (goto-char (match-beginning 0)) + (org-babel-hide-hash) + (goto-char (match-end 0))))) +(add-hook 'org-mode-hook 'org-babel-hide-all-hashes) + +(defun org-babel-hash-at-point (&optional point) + "Return the value of the hash at POINT. +The hash is also added as the last element of the kill ring. +This can be called with C-c C-c." + (interactive) + (let ((hash (car (delq nil (mapcar + (lambda (ol) (overlay-get ol 'babel-hash)) + (overlays-at (or point (point)))))))) + (when hash (kill-new hash) (message hash)))) +(add-hook 'org-ctrl-c-ctrl-c-hook 'org-babel-hash-at-point) + +(defun org-babel-result-hide-spec () + "Hide portions of results lines. +Add `org-babel-hide-result' as an invisibility spec for hiding +portions of results lines." + (add-to-invisibility-spec '(org-babel-hide-result . t))) +(add-hook 'org-mode-hook 'org-babel-result-hide-spec) + +(defvar org-babel-hide-result-overlays nil + "Overlays hiding results.") + +(defun org-babel-result-hide-all () + "Fold all results in the current buffer." + (interactive) + (org-babel-show-result-all) + (save-excursion + (while (re-search-forward org-babel-result-regexp nil t) + (save-excursion (goto-char (match-beginning 0)) + (org-babel-hide-result-toggle-maybe))))) + +(defun org-babel-show-result-all () + "Unfold all results in the current buffer." + (mapc 'delete-overlay org-babel-hide-result-overlays) + (setq org-babel-hide-result-overlays nil)) + +;;;###autoload +(defun org-babel-hide-result-toggle-maybe () + "Toggle visibility of result at point." + (interactive) + (let ((case-fold-search t)) + (if (save-excursion + (beginning-of-line 1) + (looking-at org-babel-result-regexp)) + (progn (org-babel-hide-result-toggle) + t) ;; to signal that we took action + nil))) ;; to signal that we did not + +(defun org-babel-hide-result-toggle (&optional force) + "Toggle the visibility of the current result." + (interactive) + (save-excursion + (beginning-of-line) + (if (re-search-forward org-babel-result-regexp nil t) + (let ((start (progn (beginning-of-line 2) (- (point) 1))) + (end (progn (goto-char (- (org-babel-result-end) 1)) (point))) + ov) + (if (memq t (mapcar (lambda (overlay) + (eq (overlay-get overlay 'invisible) + 'org-babel-hide-result)) + (overlays-at start))) + (if (or (not force) (eq force 'off)) + (mapc (lambda (ov) + (when (member ov org-babel-hide-result-overlays) + (setq org-babel-hide-result-overlays + (delq ov org-babel-hide-result-overlays))) + (when (eq (overlay-get ov 'invisible) + 'org-babel-hide-result) + (delete-overlay ov))) + (overlays-at start))) + (setq ov (make-overlay start end)) + (overlay-put ov 'invisible 'org-babel-hide-result) + ;; make the block accessible to isearch + (overlay-put + ov 'isearch-open-invisible + (lambda (ov) + (when (member ov org-babel-hide-result-overlays) + (setq org-babel-hide-result-overlays + (delq ov org-babel-hide-result-overlays))) + (when (eq (overlay-get ov 'invisible) + 'org-babel-hide-result) + (delete-overlay ov)))) + (push ov org-babel-hide-result-overlays))) + (error "Not looking at a result line")))) + +;; org-tab-after-check-for-cycling-hook +(add-hook 'org-tab-first-hook 'org-babel-hide-result-toggle-maybe) +;; Remove overlays when changing major mode +(add-hook 'org-mode-hook + (lambda () (org-add-hook 'change-major-mode-hook + 'org-babel-show-result-all 'append 'local))) + +(defvar org-file-properties) +(defun org-babel-params-from-properties (&optional lang) + "Retrieve parameters specified as properties. +Return an association list of any source block params which +may be specified in the properties of the current outline entry." + (save-match-data + (let (val sym) + (delq nil + (mapcar + (lambda (header-arg) + (and (setq val + (or (condition-case nil + (org-entry-get (point) header-arg t) + (error nil)) + (cdr (assoc header-arg org-file-properties)))) + (cons (intern (concat ":" header-arg)) + (org-babel-read val)))) + (mapcar + 'symbol-name + (append + org-babel-header-arg-names + (progn + (setq sym (intern (concat "org-babel-header-arg-names:" lang))) + (and (boundp sym) (eval sym)))))))))) + +(defun org-babel-params-from-buffer () + "Retrieve per-buffer parameters. + Return an association list of any source block params which +may be specified at the top of the current buffer." + (or org-babel-current-buffer-properties + (setq org-babel-current-buffer-properties + (save-match-data + (save-excursion + (save-restriction + (widen) + (goto-char (point-min)) + (when (re-search-forward + (org-make-options-regexp (list "BABEL")) nil t) + (org-babel-parse-header-arguments + (org-match-string-no-properties 2))))))))) + +(defvar org-src-preserve-indentation) +(defun org-babel-parse-src-block-match () + "Parse the results from a match of the `org-babel-src-block-regexp'." + (let* ((block-indentation (length (match-string 1))) + (lang (org-babel-clean-text-properties (match-string 2))) + (lang-headers (intern (concat "org-babel-default-header-args:" lang))) + (switches (match-string 3)) + (body (org-babel-clean-text-properties (match-string 5))) + (preserve-indentation (or org-src-preserve-indentation + (string-match "-i\\>" switches)))) + (list lang + ;; get block body less properties, protective commas, and indentation + (with-temp-buffer + (save-match-data + (insert (org-babel-strip-protective-commas body)) + (unless preserve-indentation (org-do-remove-indentation)) + (buffer-string))) + (org-babel-merge-params + org-babel-default-header-args + (org-babel-params-from-buffer) + (org-babel-params-from-properties lang) + (if (boundp lang-headers) (eval lang-headers) nil) + (org-babel-parse-header-arguments + (org-babel-clean-text-properties (or (match-string 4) "")))) + switches + block-indentation))) + +(defun org-babel-parse-inline-src-block-match () + "Parse the results from a match of the `org-babel-inline-src-block-regexp'." + (let* ((lang (org-babel-clean-text-properties (match-string 2))) + (lang-headers (intern (concat "org-babel-default-header-args:" lang)))) + (list lang + (org-babel-strip-protective-commas + (org-babel-clean-text-properties (match-string 5))) + (org-babel-merge-params + org-babel-default-inline-header-args + (org-babel-params-from-buffer) + (org-babel-params-from-properties lang) + (if (boundp lang-headers) (eval lang-headers) nil) + (org-babel-parse-header-arguments + (org-babel-clean-text-properties (or (match-string 4) ""))))))) + +(defun org-babel-parse-header-arguments (arg-string) + "Parse a string of header arguments returning an alist." + (when (> (length arg-string) 0) + (delq nil + (mapcar + (lambda (arg) + (if (string-match + "\\([^ \f\t\n\r\v]+\\)[ \f\t\n\r\v]+\\([^ \f\t\n\r\v]+.*\\)" + arg) + (cons (intern (match-string 1 arg)) + (org-babel-read (org-babel-chomp (match-string 2 arg)))) + (cons (intern (org-babel-chomp arg)) nil))) + (let ((balance 0) (partial nil) (lst nil) (last 0)) + (mapc (lambda (ch) ; split on [] balanced instances of [ \t]: + (setq balance (+ balance + (cond ((equal 91 ch) 1) + ((equal 93 ch) -1) + (t 0)))) + (setq partial (cons ch partial)) + (when (and (= ch 58) (= balance 0) + (or (= last 32) (= last 9))) + (setq lst (cons (apply #'string (nreverse (cddr partial))) + lst)) + (setq partial (list ch))) + (setq last ch)) + (string-to-list arg-string)) + (nreverse (cons (apply #'string (nreverse partial)) lst))))))) + +(defun org-babel-process-params (params) + "Expand variables in PARAMS and add summary parameters." + (let* ((vars-and-names (org-babel-disassemble-tables + (mapcar (lambda (el) + (if (consp (cdr el)) + (cdr el) (org-babel-ref-parse (cdr el)))) + (org-babel-get-header params :var)) + (cdr (assoc :hlines params)) + (cdr (assoc :colnames params)) + (cdr (assoc :rownames params)))) + (result-params (append + (split-string (or (cdr (assoc :results params)) "")) + (cdr (assoc :result-params params))))) + (append + (mapcar (lambda (var) (cons :var var)) (car vars-and-names)) + (list + (cons :colname-names (cadr vars-and-names)) + (cons :rowname-names (caddr vars-and-names)) + (cons :result-params result-params) + (cons :result-type (cond ((member "output" result-params) 'output) + ((member "value" result-params) 'value) + (t 'value)))) + (org-babel-get-header params :var 'other)))) + +;; row and column names +(defun org-babel-del-hlines (table) + "Remove all 'hlines from TABLE." + (remove 'hline table)) + +(defun org-babel-get-colnames (table) + "Return the column names of TABLE. +Return a cons cell, the `car' of which contains the TABLE less +colnames, and the `cdr' of which contains a list of the column +names." + (if (equal 'hline (nth 1 table)) + (cons (cddr table) (car table)) + (cons (cdr table) (car table)))) + +(defun org-babel-get-rownames (table) + "Return the row names of TABLE. +Return a cons cell, the `car' of which contains the TABLE less +colnames, and the `cdr' of which contains a list of the column +names. Note: this function removes any hlines in TABLE." + (flet ((trans (table) (apply #'mapcar* #'list table))) + (let* ((width (apply 'max + (mapcar (lambda (el) (if (listp el) (length el) 0)) table))) + (table (trans (mapcar (lambda (row) + (if (not (equal row 'hline)) + row + (setq row '()) + (dotimes (n width) + (setq row (cons 'hline row))) + row)) + table)))) + (cons (mapcar (lambda (row) (if (equal (car row) 'hline) 'hline row)) + (trans (cdr table))) + (remove 'hline (car table)))))) + +(defun org-babel-put-colnames (table colnames) + "Add COLNAMES to TABLE if they exist." + (if colnames (apply 'list colnames 'hline table) table)) + +(defun org-babel-put-rownames (table rownames) + "Add ROWNAMES to TABLE if they exist." + (if rownames + (mapcar (lambda (row) + (if (listp row) + (cons (or (pop rownames) "") row) + row)) table) + table)) + +(defun org-babel-pick-name (names selector) + "Select one out of an alist of row or column names. +SELECTOR can be either a list of names in which case those names +will be returned directly, or an index into the list NAMES in +which case the indexed names will be return." + (if (listp selector) + selector + (when names + (if (and selector (symbolp selector) (not (equal t selector))) + (cdr (assoc selector names)) + (if (integerp selector) + (nth (- selector 1) names) + (cdr (car (last names)))))))) + +(defun org-babel-disassemble-tables (vars hlines colnames rownames) + "Parse tables for further processing. +Process the variables in VARS according to the HLINES, +ROWNAMES and COLNAMES header arguments. Return a list consisting +of the vars, cnames and rnames." + (let (cnames rnames) + (list + (mapcar + (lambda (var) + (when (listp (cdr var)) + (when (and (not (equal colnames "no")) + (or colnames (and (equal (nth 1 (cdr var)) 'hline) + (not (member 'hline (cddr (cdr var))))))) + (let ((both (org-babel-get-colnames (cdr var)))) + (setq cnames (cons (cons (car var) (cdr both)) + cnames)) + (setq var (cons (car var) (car both))))) + (when (and rownames (not (equal rownames "no"))) + (let ((both (org-babel-get-rownames (cdr var)))) + (setq rnames (cons (cons (car var) (cdr both)) + rnames)) + (setq var (cons (car var) (car both))))) + (when (and hlines (not (equal hlines "yes"))) + (setq var (cons (car var) (org-babel-del-hlines (cdr var)))))) + var) + vars) + cnames rnames))) + +(defun org-babel-reassemble-table (table colnames rownames) + "Add column and row names to a table. +Given a TABLE and set of COLNAMES and ROWNAMES add the names +to the table for reinsertion to org-mode." + (if (listp table) + ((lambda (table) + (if (and colnames (listp (car table)) (= (length (car table)) + (length colnames))) + (org-babel-put-colnames table colnames) table)) + (if (and rownames (= (length table) (length rownames))) + (org-babel-put-rownames table rownames) table)) + table)) + +(defun org-babel-where-is-src-block-head () + "Find where the current source block begins. +Return the point at the beginning of the current source +block. Specifically at the beginning of the #+BEGIN_SRC line. +If the point is not on a source block then return nil." + (let ((initial (point)) top bottom) + (or + (save-excursion ;; on a source name line + (beginning-of-line 1) + (and (looking-at org-babel-src-name-regexp) (forward-line 1) + (looking-at org-babel-src-block-regexp) + (point))) + (save-excursion ;; on a #+begin_src line + (beginning-of-line 1) + (and (looking-at org-babel-src-block-regexp) + (point))) + (save-excursion ;; inside a src block + (and + (re-search-backward "^[ \t]*#\\+begin_src" nil t) (setq top (point)) + (re-search-forward "^[ \t]*#\\+end_src" nil t) (setq bottom (point)) + (< top initial) (< initial bottom) + (progn (goto-char top) (beginning-of-line 1) + (looking-at org-babel-src-block-regexp)) + (point)))))) + +;;;###autoload +(defun org-babel-goto-src-block-head () + "Go to the beginning of the current code block." + (interactive) + ((lambda (head) + (if head (goto-char head) (error "not currently in a code block"))) + (org-babel-where-is-src-block-head))) + +;;;###autoload +(defun org-babel-goto-named-src-block (name) + "Go to a named source-code block." + (interactive + (let ((completion-ignore-case t)) + (list (org-icompleting-read "source-block name: " + (org-babel-src-block-names) nil t)))) + (let ((point (org-babel-find-named-block name))) + (if point + ;; taken from `org-open-at-point' + (progn (goto-char point) (org-show-context)) + (message "source-code block '%s' not found in this buffer" name)))) + +(defun org-babel-find-named-block (name) + "Find a named source-code block. +Return the location of the source block identified by source +NAME, or nil if no such block exists. Set match data according to +org-babel-named-src-block-regexp." + (save-excursion + (let ((case-fold-search t) + (regexp (org-babel-named-src-block-regexp-for-name name)) msg) + (goto-char (point-min)) + (when (or (re-search-forward regexp nil t) + (re-search-backward regexp nil t)) + (match-beginning 0))))) + +(defun org-babel-src-block-names (&optional file) + "Returns the names of source blocks in FILE or the current buffer." + (save-excursion + (when file (find-file file)) (goto-char (point-min)) + (let (names) + (while (re-search-forward org-babel-src-name-w-name-regexp nil t) + (setq names (cons (org-babel-clean-text-properties (match-string 3)) + names))) + names))) + +;;;###autoload +(defun org-babel-goto-named-result (name) + "Go to a named result." + (interactive + (let ((completion-ignore-case t)) + (list (org-icompleting-read "source-block name: " + (org-babel-result-names) nil t)))) + (let ((point (org-babel-find-named-result name))) + (if point + ;; taken from `org-open-at-point' + (progn (goto-char point) (org-show-context)) + (message "result '%s' not found in this buffer" name)))) + +(defun org-babel-find-named-result (name) + "Find a named result. +Return the location of the result named NAME in the current +buffer or nil if no such result exists." + (save-excursion + (goto-char (point-min)) + (when (re-search-forward + (concat org-babel-result-regexp + "[ \t]" (regexp-quote name) "[ \t\n\f\v\r]") nil t) + (beginning-of-line 0) (point)))) + +(defun org-babel-result-names (&optional file) + "Returns the names of results in FILE or the current buffer." + (save-excursion + (when file (find-file file)) (goto-char (point-min)) + (let (names) + (while (re-search-forward org-babel-result-w-name-regexp nil t) + (setq names (cons (org-babel-clean-text-properties (match-string 4)) + names))) + names))) + +;;;###autoload +(defun org-babel-next-src-block (&optional arg) + "Jump to the next source block. +With optional prefix argument ARG, jump forward ARG many source blocks." + (interactive "P") + (when (looking-at org-babel-src-block-regexp) (forward-char 1)) + (condition-case nil + (re-search-forward org-babel-src-block-regexp nil nil (or arg 1)) + (error (error "No further code blocks"))) + (goto-char (match-beginning 0)) (org-show-context)) + +;;;###autoload +(defun org-babel-previous-src-block (&optional arg) + "Jump to the previous source block. +With optional prefix argument ARG, jump backward ARG many source blocks." + (interactive "P") + (condition-case nil + (re-search-backward org-babel-src-block-regexp nil nil (or arg 1)) + (error (error "No previous code blocks"))) + (goto-char (match-beginning 0)) (org-show-context)) + +(defvar org-babel-load-languages) + +;;;###autoload +(defun org-babel-mark-block () + "Mark current src block" + (interactive) + ((lambda (head) + (when head + (save-excursion + (goto-char head) + (looking-at org-babel-src-block-regexp)) + (push-mark (match-end 5) nil t) + (goto-char (match-beginning 5)))) + (org-babel-where-is-src-block-head))) + +(defun org-babel-demarcate-block (&optional arg) + "Wrap or split the code in the region or on the point. +When called from inside of a code block the current block is +split. When called from outside of a code block a new code block +is created. In both cases if the region is demarcated and if the +region is not active then the point is demarcated." + (interactive "P") + (let ((info (org-babel-get-src-block-info 'light)) + (stars (concat (make-string (or (org-current-level) 1) ?*) " "))) + (if info + (mapc + (lambda (place) + (save-excursion + (goto-char place) + (let ((lang (nth 0 info)) + (indent (make-string (nth 5 info) ? ))) + (when (string-match "^[[:space:]]*$" + (buffer-substring (point-at-bol) + (point-at-eol))) + (delete-region (point-at-bol) (point-at-eol))) + (insert (concat (if (looking-at "^") "" "\n") + indent "#+end_src\n" + (if arg stars indent) "\n" + indent "#+begin_src " lang + (if (looking-at "[\n\r]") "" "\n"))))) + (move-end-of-line 2)) + (sort (if (region-active-p) (list (mark) (point)) (list (point))) #'>)) + (let ((start (point)) + (lang (org-icompleting-read "Lang: " + (mapcar (lambda (el) (symbol-name (car el))) + org-babel-load-languages))) + (body (delete-and-extract-region + (if (region-active-p) (mark) (point)) (point)))) + (insert (concat (if (looking-at "^") "" "\n") + (if arg (concat stars "\n") "") + "#+begin_src " lang "\n" + body + (if (or (= (length body) 0) + (string-match "[\r\n]$" body)) "" "\n") + "#+end_src\n")) + (goto-char start) (move-end-of-line 1))))) + +(defvar org-babel-lob-one-liner-regexp) +(defun org-babel-where-is-src-block-result (&optional insert info hash indent) + "Find where the current source block results begin. +Return the point at the beginning of the result of the current +source block. Specifically at the beginning of the results line. +If no result exists for this block then create a results line +following the source block." + (save-excursion + (let* ((on-lob-line (progn (beginning-of-line 1) + (looking-at org-babel-lob-one-liner-regexp))) + (name (if on-lob-line + (nth 0 (org-babel-lob-get-info)) + (nth 4 (or info (org-babel-get-src-block-info))))) + (head (unless on-lob-line (org-babel-where-is-src-block-head))) + found beg end) + (when head (goto-char head)) + (setq + found ;; was there a result (before we potentially insert one) + (or + (and + ;; named results: + ;; - return t if it is found, else return nil + ;; - if it does not need to be rebuilt, then don't set end + ;; - if it does need to be rebuilt then do set end + name (setq beg (org-babel-find-named-result name)) + (prog1 beg + (when (and hash (not (string= hash (match-string 3)))) + (goto-char beg) (setq end beg) ;; beginning of result + (forward-line 1) + (delete-region end (org-babel-result-end)) nil))) + (and + ;; unnamed results: + ;; - return t if it is found, else return nil + ;; - if it is found, and the hash doesn't match, delete and set end + (or on-lob-line (re-search-forward "^[ \t]*#\\+end_src" nil t)) + (progn (end-of-line 1) + (if (eobp) (insert "\n") (forward-char 1)) + (setq end (point)) + (or (and (not name) + (progn ;; unnamed results line already exists + (re-search-forward "[^ \f\t\n\r\v]" nil t) + (beginning-of-line 1) + (looking-at + (concat org-babel-result-regexp "\n"))) + (prog1 (point) + ;; must remove and rebuild if hash!=old-hash + (if (and hash (not (string= hash (match-string 3)))) + (prog1 nil + (forward-line 1) + (delete-region + end (org-babel-result-end))) + (setq end nil))))))))) + (if (and insert end) + (progn + (goto-char end) + (unless beg + (if (looking-at "[\n\r]") (forward-char 1) (insert "\n"))) + (insert (concat + (if indent + (mapconcat + (lambda (el) " ") + (org-number-sequence 1 indent) "") + "") + "#+results" + (when hash (concat "["hash"]")) + ":" + (when name (concat " " name)) "\n")) + (unless beg (insert "\n") (backward-char)) + (beginning-of-line 0) + (if hash (org-babel-hide-hash)) + (point)) + found)))) + +(defvar org-block-regexp) +(defun org-babel-read-result () + "Read the result at `point' into emacs-lisp." + (let ((case-fold-search t) result-string) + (cond + ((org-at-table-p) (org-babel-read-table)) + ((org-in-item-p) (org-babel-read-list)) + ((looking-at org-bracket-link-regexp) (org-babel-read-link)) + ((looking-at org-block-regexp) (org-babel-trim (match-string 4))) + ((looking-at "^[ \t]*: ") + (setq result-string + (org-babel-trim + (mapconcat (lambda (line) + (if (and (> (length line) 1) + (string-match "^[ \t]*: \\(.+\\)" line)) + (match-string 1 line) + line)) + (split-string + (buffer-substring + (point) (org-babel-result-end)) "[\r\n]+") + "\n"))) + (or (org-babel-number-p result-string) result-string)) + ((looking-at org-babel-result-regexp) + (save-excursion (forward-line 1) (org-babel-read-result)))))) + +(defun org-babel-read-table () + "Read the table at `point' into emacs-lisp." + (mapcar (lambda (row) + (if (and (symbolp row) (equal row 'hline)) row + (mapcar #'org-babel-read row))) + (org-table-to-lisp))) + +(defun org-babel-read-list () + "Read the list at `point' into emacs-lisp." + (mapcar #'org-babel-read (cdr (org-list-parse-list)))) + +(defvar org-link-types-re) +(defun org-babel-read-link () + "Read the link at `point' into emacs-lisp. +If the path of the link is a file path it is expanded using +`expand-file-name'." + (let* ((case-fold-search t) + (raw (and (looking-at org-bracket-link-regexp) + (org-babel-clean-text-properties (match-string 1)))) + (type (and (string-match org-link-types-re raw) + (match-string 1 raw)))) + (cond + ((not type) (expand-file-name raw)) + ((string= type "file") + (and (string-match "file\\(.*\\):\\(.+\\)" raw) + (expand-file-name (match-string 2 raw)))) + (t raw)))) + +(defun org-babel-insert-result + (result &optional result-params info hash indent lang) + "Insert RESULT into the current buffer. +By default RESULT is inserted after the end of the +current source block. With optional argument RESULT-PARAMS +controls insertion of results in the org-mode file. +RESULT-PARAMS can take the following values... + +replace - (default option) insert results after the source block + replacing any previously inserted results + +silent -- no results are inserted + +file ---- the results are interpreted as a file path, and are + inserted into the buffer using the Org-mode file syntax + +list ---- the results are interpreted as an Org-mode list. + +raw ----- results are added directly to the Org-mode file. This + is a good option if you code block will output org-mode + formatted text. + +org ----- similar in effect to raw, only the results are wrapped + in an org code block. Similar to the raw option, on + export the results will be interpreted as org-formatted + text, however by wrapping the results in an org code + block they can be replaced upon re-execution of the + code block. + +html ---- results are added inside of a #+BEGIN_HTML block. This + is a good option if you code block will output html + formatted text. + +latex --- results are added inside of a #+BEGIN_LATEX block. + This is a good option if you code block will output + latex formatted text. + +code ---- the results are extracted in the syntax of the source + code of the language being evaluated and are added + inside of a #+BEGIN_SRC block with the source-code + language set appropriately. Note this relies on the + optional LANG argument." + (if (stringp result) + (progn + (setq result (org-babel-clean-text-properties result)) + (when (member "file" result-params) + (setq result (org-babel-result-to-file result)))) + (unless (listp result) (setq result (format "%S" result)))) + (if (and result-params (member "silent" result-params)) + (progn + (message (replace-regexp-in-string "%" "%%" (format "%S" result))) + result) + (when (and (stringp result) ;; ensure results end in a newline + (> (length result) 0) + (not (or (string-equal (substring result -1) "\n") + (string-equal (substring result -1) "\r")))) + (setq result (concat result "\n"))) + (save-excursion + (let ((existing-result (org-babel-where-is-src-block-result + t info hash indent)) + (results-switches + (cdr (assoc :results_switches (nth 2 info)))) + beg end) + (if (not existing-result) + (setq beg (point)) + (goto-char existing-result) + (save-excursion + (re-search-forward "#" nil t) + (setq indent (- (current-column) 1))) + (forward-line 1) + (setq beg (point)) + (cond + ((member "replace" result-params) + (delete-region (point) (org-babel-result-end))) + ((member "append" result-params) + (goto-char (org-babel-result-end)) (setq beg (point-marker))) + ((member "prepend" result-params)))) ; already there + (setq results-switches + (if results-switches (concat " " results-switches) "")) + ;; insert results based on type + (cond + ;; do nothing for an empty result + ((= (length result) 0)) + ;; insert a list if preferred + ((member "list" result-params) + (insert + (org-babel-trim + (org-list-to-generic (cons 'unordered + (if (listp result) result (list result))) + '(:splicep nil :istart "- " :iend "\n"))))) + ;; assume the result is a table if it's not a string + ((not (stringp result)) + (goto-char beg) + (insert (concat (orgtbl-to-orgtbl + (if (or (eq 'hline (car result)) + (and (listp (car result)) + (listp (cdr (car result))))) + result (list result)) + '(:fmt (lambda (cell) (format "%s" cell)))) "\n")) + (goto-char beg) (when (org-at-table-p) (org-table-align))) + ((member "file" result-params) + (insert result)) + (t (goto-char beg) (insert result))) + (when (listp result) (goto-char (org-table-end))) + (setq end (point-marker)) + ;; possibly wrap result + (flet ((wrap (start finish) + (goto-char beg) (insert start) + (goto-char end) (insert finish) + (setq end (point-marker)))) + (cond + ((member "html" result-params) + (wrap "#+BEGIN_HTML\n" "#+END_HTML")) + ((member "latex" result-params) + (wrap "#+BEGIN_LaTeX\n" "#+END_LaTeX")) + ((member "code" result-params) + (wrap (format "#+BEGIN_SRC %s%s\n" (or lang "none") results-switches) + "#+END_SRC")) + ((member "org" result-params) + (wrap "#+BEGIN_ORG\n" "#+END_ORG")) + ((member "raw" result-params) + (goto-char beg) (if (org-at-table-p) (org-cycle))) + ((member "wrap" result-params) + (when (and (stringp result) (not (member "file" result-params))) + (org-babel-examplize-region beg end results-switches)) + (wrap "#+BEGIN_RESULT\n" "#+END_RESULT")) + ((and (stringp result) (not (member "file" result-params))) + (org-babel-examplize-region beg end results-switches) + (setq end (point))))) + ;; possibly indent the results to match the #+results line + (when (and indent (> indent 0) + ;; in this case `table-align' does the work for us + (not (and (listp result) + (member "append" result-params)))) + (indent-rigidly beg end indent)))) + (if (= (length result) 0) + (if (member "value" result-params) + (message "Code block returned no value.") + (message "Code block produced no output.")) + (message "Code block evaluation complete.")))) + +(defun org-babel-remove-result (&optional info) + "Remove the result of the current source block." + (interactive) + (let ((location (org-babel-where-is-src-block-result nil info)) start) + (when location + (save-excursion + (goto-char location) (setq start (point)) (forward-line 1) + (delete-region start (org-babel-result-end)))))) + +(defun org-babel-result-end () + "Return the point at the end of the current set of results" + (save-excursion + (cond + ((org-at-table-p) (progn (goto-char (org-table-end)) (point))) + ((org-in-item-p) (- (org-list-bottom-point) 1)) + (t + (let ((case-fold-search t) + (blocks-re (regexp-opt + (list "latex" "html" "example" "src" "result")))) + (if (looking-at (concat "[ \t]*#\\+begin_" blocks-re)) + (re-search-forward (concat "[ \t]*#\\+end_" blocks-re) nil t) + (while (looking-at "[ \t]*\\(: \\|\\[\\[\\)") + (forward-line 1)))) + (point))))) + +(defun org-babel-result-to-file (result) + "Convert RESULT into an `org-mode' link. +If the `default-directory' is different from the containing +file's directory then expand relative links." + (format + "[[file:%s]]" + (if (and default-directory + buffer-file-name + (not (string= (expand-file-name default-directory) + (expand-file-name + (file-name-directory buffer-file-name))))) + (expand-file-name result default-directory) + result))) + +(defun org-babel-examplize-region (beg end &optional results-switches) + "Comment out region using the ': ' org example quote." + (interactive "*r") + (let ((size (count-lines beg end))) + (save-excursion + (cond ((= size 0)) ; do nothing for an empty result + ((< size org-babel-min-lines-for-block-output) + (goto-char beg) + (dotimes (n size) + (beginning-of-line 1) (insert ": ") (forward-line 1))) + (t + (goto-char beg) + (insert (if results-switches + (format "#+begin_example%s\n" results-switches) + "#+begin_example\n")) + (if (markerp end) (goto-char end) (forward-char (- end beg))) + (insert "#+end_example\n")))))) + +(defun org-babel-update-block-body (new-body) + "Update the body of the current code block to NEW-BODY." + (if (not (org-babel-where-is-src-block-head)) + (error "not in source block") + (save-match-data + (replace-match (concat (org-babel-trim new-body) "\n") nil nil nil 5)) + (indent-rigidly (match-beginning 5) (match-end 5) 2))) + +(defun org-babel-merge-params (&rest plists) + "Combine all parameter association lists in PLISTS. +Later elements of PLISTS override the values of previous element. +This takes into account some special considerations for certain +parameters when merging lists." + (let ((results-exclusive-groups + '(("file" "list" "vector" "table" "scalar" "raw" "org" + "html" "latex" "code" "pp" "wrap") + ("replace" "silent" "append" "prepend") + ("output" "value"))) + (exports-exclusive-groups + '(("code" "results" "both" "none"))) + params results exports tangle noweb cache vars shebang comments) + (flet ((e-merge (exclusive-groups &rest result-params) + ;; maintain exclusivity of mutually exclusive parameters + (let (output) + (mapc (lambda (new-params) + (mapc (lambda (new-param) + (mapc (lambda (exclusive-group) + (when (member new-param exclusive-group) + (mapcar (lambda (excluded-param) + (setq output + (delete + excluded-param + output))) + exclusive-group))) + exclusive-groups) + (setq output (org-uniquify + (cons new-param output)))) + new-params)) + result-params) + output))) + (mapc + (lambda (plist) + (mapc + (lambda (pair) + (case (car pair) + (:var + (let ((name (if (listp (cdr pair)) + (cadr pair) + (and (string-match "^\\([^= \f\t\n\r\v]+\\)[ \t]*=" + (cdr pair)) + (intern (match-string 1 (cdr pair))))))) + (when name + (setq vars + (cons (cons name pair) + (if (member name (mapcar #'car vars)) + (delq nil + (mapcar + (lambda (p) (unless (equal (car p) name) p)) + vars)) + vars)))))) + (:results + (setq results (e-merge results-exclusive-groups + results (split-string (cdr pair))))) + (:file + (when (cdr pair) + (setq results (e-merge results-exclusive-groups + results '("file"))) + (unless (or (member "both" exports) + (member "none" exports) + (member "code" exports)) + (setq exports (e-merge exports-exclusive-groups + exports '("results")))) + (setq params (cons pair (assq-delete-all (car pair) params))))) + (:exports + (setq exports (e-merge exports-exclusive-groups + exports (split-string (cdr pair))))) + (:tangle ;; take the latest -- always overwrite + (setq tangle (or (list (cdr pair)) tangle))) + (:noweb + (setq noweb (e-merge '(("yes" "no" "tangle")) noweb + (split-string (or (cdr pair) ""))))) + (:cache + (setq cache (e-merge '(("yes" "no")) cache + (split-string (or (cdr pair) ""))))) + (:shebang ;; take the latest -- always overwrite + (setq shebang (or (list (cdr pair)) shebang))) + (:comments + (setq comments (e-merge '(("yes" "no")) comments + (split-string (or (cdr pair) ""))))) + (t ;; replace: this covers e.g. :session + (setq params (cons pair (assq-delete-all (car pair) params)))))) + plist)) + plists)) + (while vars (setq params (cons (cons :var (cddr (pop vars))) params))) + (cons (cons :comments (mapconcat 'identity comments " ")) + (cons (cons :shebang (mapconcat 'identity shebang " ")) + (cons (cons :cache (mapconcat 'identity cache " ")) + (cons (cons :noweb (mapconcat 'identity noweb " ")) + (cons (cons :tangle (mapconcat 'identity tangle " ")) + (cons (cons :exports + (mapconcat 'identity exports " ")) + (cons + (cons :results + (mapconcat 'identity results " ")) + params))))))))) + +(defun org-babel-expand-noweb-references (&optional info parent-buffer) + "Expand Noweb references in the body of the current source code block. + +For example the following reference would be replaced with the +body of the source-code block named 'example-block'. + +<<example-block>> + +Note that any text preceding the <<foo>> construct on a line will +be interposed between the lines of the replacement text. So for +example if <<foo>> is placed behind a comment, then the entire +replacement text will also be commented. + +This function must be called from inside of the buffer containing +the source-code block which holds BODY. + +In addition the following syntax can be used to insert the +results of evaluating the source-code block named 'example-block'. + +<<example-block()>> + +Any optional arguments can be passed to example-block by placing +the arguments inside the parenthesis following the convention +defined by `org-babel-lob'. For example + +<<example-block(a=9)>> + +would set the value of argument \"a\" equal to \"9\". Note that +these arguments are not evaluated in the current source-code +block but are passed literally to the \"example-block\"." + (let* ((parent-buffer (or parent-buffer (current-buffer))) + (info (or info (org-babel-get-src-block-info))) + (lang (nth 0 info)) + (body (nth 1 info)) + (new-body "") index source-name evaluate prefix) + (flet ((nb-add (text) + (setq new-body (concat new-body text)))) + (with-temp-buffer + (insert body) (goto-char (point-min)) + (setq index (point)) + (while (and (re-search-forward "<<\\(.+?\\)>>" nil t)) + (save-match-data (setf source-name (match-string 1))) + (save-match-data (setq evaluate (string-match "\(.*\)" source-name))) + (save-match-data + (setq prefix + (buffer-substring (match-beginning 0) + (save-excursion + (beginning-of-line 1) (point))))) + ;; add interval to new-body (removing noweb reference) + (goto-char (match-beginning 0)) + (nb-add (buffer-substring index (point))) + (goto-char (match-end 0)) + (setq index (point)) + (nb-add (with-current-buffer parent-buffer + (mapconcat ;; interpose PREFIX between every line + #'identity + (split-string + (if evaluate + (let ((raw (org-babel-ref-resolve source-name))) + (if (stringp raw) raw (format "%S" raw))) + (save-restriction + (widen) + (let ((point (org-babel-find-named-block + source-name))) + (if point + (save-excursion + (goto-char point) + (org-babel-trim + (org-babel-expand-noweb-references + (org-babel-get-src-block-info)))) + ;; optionally raise an error if named + ;; source-block doesn't exist + (if (member lang org-babel-noweb-error-langs) + (error "%s" + (concat + "<<" source-name ">> " + "could not be resolved (see " + "`org-babel-noweb-error-langs')")) + ""))))) + "[\n\r]") (concat "\n" prefix))))) + (nb-add (buffer-substring index (point-max))))) + new-body)) + +(defun org-babel-clean-text-properties (text) + "Strip all properties from text return." + (when text + (set-text-properties 0 (length text) nil text) text)) + +(defun org-babel-strip-protective-commas (body) + "Strip protective commas from bodies of source blocks." + (replace-regexp-in-string "^,#" "#" body)) + +(defun org-babel-script-escape (str) + "Safely convert tables into elisp lists." + (let (in-single in-double out) + (org-babel-read + (if (and (stringp str) (string-match "^\\[.+\\]$" str)) + (org-babel-read + (concat + "'" + (progn + (mapc + (lambda (ch) + (setq + out + (case ch + (91 (if (or in-double in-single) ; [ + (cons 91 out) + (cons 40 out))) + (93 (if (or in-double in-single) ; ] + (cons 93 out) + (cons 41 out))) + (44 (if (or in-double in-single) (cons 44 out) out)) ; , + (39 (if in-double ; ' + (cons 39 out) + (setq in-single (not in-single)) (cons 34 out))) + (34 (if in-single ; " + (append (list 34 32) out) + (setq in-double (not in-double)) (cons 34 out))) + (t (cons ch out))))) + (string-to-list str)) + (apply #'string (reverse out))))) + str)))) + +(defun org-babel-read (cell) + "Convert the string value of CELL to a number if appropriate. +Otherwise if cell looks like lisp (meaning it starts with a +\"(\" or a \"'\") then read it as lisp, otherwise return it +unmodified as a string. + +This is taken almost directly from `org-read-prop'." + (if (and (stringp cell) (not (equal cell ""))) + (or (org-babel-number-p cell) + (if (or (equal "(" (substring cell 0 1)) + (equal "'" (substring cell 0 1)) + (equal "`" (substring cell 0 1))) + (eval (read cell)) + (progn (set-text-properties 0 (length cell) nil cell) cell))) + cell)) + +(defun org-babel-number-p (string) + "If STRING represents a number return it's value." + (if (and (string-match "^-?[0-9]*\\.?[0-9]*$" string) + (= (length (substring string (match-beginning 0) + (match-end 0))) + (length string))) + (string-to-number string))) + +(defun org-babel-import-elisp-from-file (file-name &optional separator) + "Read the results located at FILE-NAME into an elisp table. +If the table is trivial, then return it as a scalar." + (let (result) + (save-window-excursion + (with-temp-buffer + (condition-case nil + (progn + (org-table-import file-name separator) + (delete-file file-name) + (setq result (mapcar (lambda (row) + (mapcar #'org-babel-string-read row)) + (org-table-to-lisp)))) + (error nil))) + (if (null (cdr result)) ;; if result is trivial vector, then scalarize it + (if (consp (car result)) + (if (null (cdr (car result))) + (caar result) + result) + (car result)) + result)))) + +(defun org-babel-string-read (cell) + "Strip nested \"s from around strings." + (org-babel-read (or (and (stringp cell) + (string-match "\\\"\\(.+\\)\\\"" cell) + (match-string 1 cell)) + cell))) + +(defun org-babel-reverse-string (string) + "Return the reverse of STRING." + (apply 'string (reverse (string-to-list string)))) + +(defun org-babel-chomp (string &optional regexp) + "Strip trailing spaces and carriage returns from STRING. +Default regexp used is \"[ \f\t\n\r\v]\" but can be +overwritten by specifying a regexp as a second argument." + (let ((regexp (or regexp "[ \f\t\n\r\v]"))) + (while (and (> (length string) 0) + (string-match regexp (substring string -1))) + (setq string (substring string 0 -1))) + string)) + +(defun org-babel-trim (string &optional regexp) + "Strip leading and trailing spaces and carriage returns from STRING. +Like `org-babel-chomp' only it runs on both the front and back +of the string." + (org-babel-chomp (org-babel-reverse-string + (org-babel-chomp (org-babel-reverse-string string) regexp)) + regexp)) + +(defvar org-babel-org-babel-call-process-region-original nil) +(defun org-babel-tramp-handle-call-process-region + (start end program &optional delete buffer display &rest args) + "Use tramp to handle call-process-region. +Fixes a bug in `tramp-handle-call-process-region'." + (if (and (featurep 'tramp) (file-remote-p default-directory)) + (let ((tmpfile (tramp-compat-make-temp-file ""))) + (write-region start end tmpfile) + (when delete (delete-region start end)) + (unwind-protect + ;; (apply 'call-process program tmpfile buffer display args) + ;; bug in tramp + (apply 'process-file program tmpfile buffer display args) + (delete-file tmpfile))) + ;; org-babel-call-process-region-original is the original emacs + ;; definition. It is in scope from the let binding in + ;; org-babel-execute-src-block + (apply org-babel-call-process-region-original + start end program delete buffer display args))) + +(defun org-babel-local-file-name (file) + "Return the local name component of FILE." + (if (file-remote-p file) + (let (localname) + (with-parsed-tramp-file-name file nil + localname)) + file)) + +(defun org-babel-process-file-name (name &optional no-quote-p) + "Prepare NAME to be used in an external process. +If NAME specifies a remote location, the remote portion of the +name is removed, since in that case the process will be executing +remotely. The file name is then processed by +`expand-file-name'. Unless second argument NO-QUOTE-P is non-nil, +the file name is additionally processed by +`shell-quote-argument'" + ((lambda (f) (if no-quote-p f (shell-quote-argument f))) + (expand-file-name (org-babel-local-file-name name)))) + +(defvar org-babel-temporary-directory) +(unless (or noninteractive (boundp 'org-babel-temporary-directory)) + (defvar org-babel-temporary-directory + (or (and (boundp 'org-babel-temporary-directory) + (file-exists-p org-babel-temporary-directory) + org-babel-temporary-directory) + (make-temp-file "babel-" t)) + "Directory to hold temporary files created to execute code blocks. +Used by `org-babel-temp-file'. This directory will be removed on +Emacs shutdown.")) + +(defun org-babel-temp-file (prefix &optional suffix) + "Create a temporary file in the `org-babel-temporary-directory'. +Passes PREFIX and SUFFIX directly to `make-temp-file' with the +value of `temporary-file-directory' temporarily set to the value +of `org-babel-temporary-directory'." + (if (file-remote-p default-directory) + (make-temp-file + (concat (file-remote-p default-directory) + (expand-file-name + prefix temporary-file-directory) + nil suffix)) + (let ((temporary-file-directory + (or (and (file-exists-p org-babel-temporary-directory) + org-babel-temporary-directory) + temporary-file-directory))) + (make-temp-file prefix nil suffix)))) + +(defun org-babel-remove-temporary-directory () + "Remove `org-babel-temporary-directory' on Emacs shutdown." + (when (and (boundp 'org-babel-temporary-directory) + (file-exists-p org-babel-temporary-directory)) + ;; taken from `delete-directory' in files.el + (condition-case nil + (progn + (mapc (lambda (file) + ;; This test is equivalent to + ;; (and (file-directory-p fn) (not (file-symlink-p fn))) + ;; but more efficient + (if (eq t (car (file-attributes file))) + (delete-directory file) + (delete-file file))) + ;; We do not want to delete "." and "..". + (directory-files org-babel-temporary-directory 'full + "^\\([^.]\\|\\.\\([^.]\\|\\..\\)\\).*")) + (delete-directory org-babel-temporary-directory)) + (error + (message "Failed to remove temporary Org-babel directory %s" + org-babel-temporary-directory))))) + +(add-hook 'kill-emacs-hook 'org-babel-remove-temporary-directory) + +(provide 'ob) + +;; arch-tag: 01a7ebee-06c5-4ee4-a709-e660d28c0af1 + +;;; ob.el ends here diff --git a/.emacs.d/org-7.4/lisp/ob.elc b/.emacs.d/org-7.4/lisp/ob.elc Binary files differnew file mode 100644 index 0000000..3a62e26 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/ob.elc diff --git a/.emacs.d/org-7.4/lisp/org-agenda.el b/.emacs.d/org-7.4/lisp/org-agenda.el new file mode 100644 index 0000000..6bcbf62 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-agenda.el @@ -0,0 +1,8063 @@ +;;; org-agenda.el --- Dynamic task and appointment lists for Org + +;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010 +;; Free Software Foundation, Inc. + +;; Author: Carsten Dominik <carsten at orgmode dot org> +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; Version: 7.4 +;; +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: + +;; This file contains the code for creating and using the Agenda for Org-mode. + +;;; Code: + +(require 'org) +(eval-when-compile + (require 'cl)) + +(declare-function diary-add-to-list "diary-lib" + (date string specifier &optional marker globcolor literal)) +(declare-function calendar-absolute-from-iso "cal-iso" (date)) +(declare-function calendar-astro-date-string "cal-julian" (&optional date)) +(declare-function calendar-bahai-date-string "cal-bahai" (&optional date)) +(declare-function calendar-chinese-date-string "cal-china" (&optional date)) +(declare-function calendar-coptic-date-string "cal-coptic" (&optional date)) +(declare-function calendar-ethiopic-date-string "cal-coptic" (&optional date)) +(declare-function calendar-french-date-string "cal-french" (&optional date)) +(declare-function calendar-goto-date "cal-move" (date)) +(declare-function calendar-hebrew-date-string "cal-hebrew" (&optional date)) +(declare-function calendar-islamic-date-string "cal-islam" (&optional date)) +(declare-function calendar-iso-date-string "cal-iso" (&optional date)) +(declare-function calendar-iso-from-absolute "cal-iso" (date)) +(declare-function calendar-julian-date-string "cal-julian" (&optional date)) +(declare-function calendar-mayan-date-string "cal-mayan" (&optional date)) +(declare-function calendar-persian-date-string "cal-persia" (&optional date)) +(declare-function org-datetree-find-date-create "org-datetree" + (date &optional keep-restriction)) +(declare-function org-columns-quit "org-colview" ()) +(declare-function diary-date-display-form "diary-lib" (&optional type)) +(declare-function org-mobile-write-agenda-for-mobile "org-mobile" (file)) +(declare-function org-habit-insert-consistency-graphs + "org-habit" (&optional line)) +(declare-function org-is-habit-p "org-habit" (&optional pom)) +(declare-function org-habit-parse-todo "org-habit" (&optional pom)) +(declare-function org-habit-get-priority "org-habit" (habit &optional moment)) +(defvar calendar-mode-map) +(defvar org-clock-current-task) ; defined in org-clock.el +(defvar org-mobile-force-id-on-agenda-items) ; defined in org-mobile.el +(defvar org-habit-show-habits) +(defvar org-habit-show-habits-only-for-today) + +;; Defined somewhere in this file, but used before definition. +(defvar org-agenda-buffer-name) +(defvar org-agenda-overriding-header) +(defvar org-agenda-title-append nil) +(defvar entry) +(defvar date) +(defvar org-agenda-undo-list) +(defvar org-agenda-pending-undo-list) +(defvar original-date) ; dynamically scoped, calendar.el does scope this + +(defcustom org-agenda-confirm-kill 1 + "When set, remote killing from the agenda buffer needs confirmation. +When t, a confirmation is always needed. When a number N, confirmation is +only needed when the text to be killed contains more than N non-white lines." + :group 'org-agenda + :type '(choice + (const :tag "Never" nil) + (const :tag "Always" t) + (integer :tag "When more than N lines"))) + +(defcustom org-agenda-compact-blocks nil + "Non-nil means make the block agenda more compact. +This is done by leaving out unnecessary lines." + :group 'org-agenda + :type 'boolean) + +(defcustom org-agenda-block-separator ?= + "The separator between blocks in the agenda. +If this is a string, it will be used as the separator, with a newline added. +If it is a character, it will be repeated to fill the window width." + :group 'org-agenda + :type '(choice + (character) + (string))) + +(defgroup org-agenda-export nil + "Options concerning exporting agenda views in Org-mode." + :tag "Org Agenda Export" + :group 'org-agenda) + +(defcustom org-agenda-with-colors t + "Non-nil means use colors in agenda views." + :group 'org-agenda-export + :type 'boolean) + +(defcustom org-agenda-exporter-settings nil + "Alist of variable/value pairs that should be active during agenda export. +This is a good place to set options for ps-print and for htmlize. +Note that the way this is implemented, the values will be evaluated +before assigned to the variables. So make sure to quote values you do +*not* want evaluated, for example + + (setq org-agenda-exporter-settings + '((ps-print-color-p 'black-white)))" + :group 'org-agenda-export + :type '(repeat + (list + (variable) + (sexp :tag "Value")))) + +(defcustom org-agenda-before-write-hook '(org-agenda-add-entry-text) + "Hook run in temporary buffer before writing it to an export file. +A useful function is `org-agenda-add-entry-text'." + :group 'org-agenda-export + :type 'hook + :options '(org-agenda-add-entry-text)) + +(defcustom org-agenda-add-entry-text-maxlines 0 + "Maximum number of entry text lines to be added to agenda. +This is only relevant when `org-agenda-add-entry-text' is part of +`org-agenda-before-write-hook', which it is by default. +When this is 0, nothing will happen. When it is greater than 0, it +specifies the maximum number of lines that will be added for each entry +that is listed in the agenda view. + +Note that this variable is not used during display, only when exporting +the agenda. For agenda display, see the variables `org-agenda-entry-text-mode' +and `org-agenda-entry-text-maxlines'." + :group 'org-agenda + :type 'integer) + +(defcustom org-agenda-add-entry-text-descriptive-links t + "Non-nil means export org-links as descriptive links in agenda added text. +This variable applies to the text added to the agenda when +`org-agenda-add-entry-text-maxlines' is larger than 0. +When this variable nil, the URL will (also) be shown." + :group 'org-agenda + :type 'boolean) + +(defcustom org-agenda-export-html-style "" + "The style specification for exported HTML Agenda files. +If this variable contains a string, it will replace the default <style> +section as produced by `htmlize'. +Since there are different ways of setting style information, this variable +needs to contain the full HTML structure to provide a style, including the +surrounding HTML tags. The style specifications should include definitions +the fonts used by the agenda, here is an example: + + <style type=\"text/css\"> + p { font-weight: normal; color: gray; } + .org-agenda-structure { + font-size: 110%; + color: #003399; + font-weight: 600; + } + .org-todo { + color: #cc6666; + font-weight: bold; + } + .org-agenda-done { + color: #339933; + } + .org-done { + color: #339933; + } + .title { text-align: center; } + .todo, .deadline { color: red; } + .done { color: green; } + </style> + +or, if you want to keep the style in a file, + + <link rel=\"stylesheet\" type=\"text/css\" href=\"mystyles.css\"> + +As the value of this option simply gets inserted into the HTML <head> header, +you can \"misuse\" it to also add other text to the header. However, +<style>...</style> is required, if not present the variable will be ignored." + :group 'org-agenda-export + :group 'org-export-html + :type 'string) + +(defcustom org-agenda-persistent-filter nil + "When set, keep filters from one agenda view to the next." + :group 'org-agenda + :type 'boolean) + +(defgroup org-agenda-custom-commands nil + "Options concerning agenda views in Org-mode." + :tag "Org Agenda Custom Commands" + :group 'org-agenda) + +(defconst org-sorting-choice + '(choice + (const time-up) (const time-down) + (const category-keep) (const category-up) (const category-down) + (const tag-down) (const tag-up) + (const priority-up) (const priority-down) + (const todo-state-up) (const todo-state-down) + (const effort-up) (const effort-down) + (const habit-up) (const habit-down) + (const alpha-up) (const alpha-down) + (const user-defined-up) (const user-defined-down)) + "Sorting choices.") + +(defconst org-agenda-custom-commands-local-options + `(repeat :tag "Local settings for this command. Remember to quote values" + (choice :tag "Setting" + (list :tag "Heading for this block" + (const org-agenda-overriding-header) + (string :tag "Headline")) + (list :tag "Files to be searched" + (const org-agenda-files) + (list + (const :format "" quote) + (repeat (file)))) + (list :tag "Sorting strategy" + (const org-agenda-sorting-strategy) + (list + (const :format "" quote) + (repeat + ,org-sorting-choice))) + (list :tag "Prefix format" + (const org-agenda-prefix-format :value " %-12:c%?-12t% s") + (string)) + (list :tag "Number of days in agenda" + (const org-agenda-span) + (choice (const :tag "Day" 'day) + (const :tag "Week" 'week) + (const :tag "Month" 'month) + (const :tag "Year" 'year) + (integer :tag "Custom"))) + (list :tag "Fixed starting date" + (const org-agenda-start-day) + (string :value "2007-11-01")) + (list :tag "Start on day of week" + (const org-agenda-start-on-weekday) + (choice :value 1 + (const :tag "Today" nil) + (integer :tag "Weekday No."))) + (list :tag "Include data from diary" + (const org-agenda-include-diary) + (boolean)) + (list :tag "Deadline Warning days" + (const org-deadline-warning-days) + (integer :value 1)) + (list :tag "Tags filter preset" + (const org-agenda-filter-preset) + (list + (const :format "" quote) + (repeat + (string :tag "+tag or -tag")))) + (list :tag "Set daily/weekly entry types" + (const org-agenda-entry-types) + (set :greedy t :value (:deadline :scheduled :timestamp :sexp) + (const :deadline) + (const :scheduled) + (const :timestamp) + (const :sexp))) + (list :tag "Standard skipping condition" + :value (org-agenda-skip-function '(org-agenda-skip-entry-if)) + (const org-agenda-skip-function) + (list + (const :format "" quote) + (list + (choice + :tag "Skipping range" + (const :tag "Skip entry" org-agenda-skip-entry-if) + (const :tag "Skip subtree" org-agenda-skip-subtree-if)) + (repeat :inline t :tag "Conditions for skipping" + (choice + :tag "Condition type" + (list :tag "Regexp matches" :inline t (const :format "" 'regexp) (regexp)) + (list :tag "Regexp does not match" :inline t (const :format "" 'notregexp) (regexp)) + (list :tag "TODO state is" :inline t + (const 'todo) + (choice + (const :tag "any not-done state" 'todo) + (const :tag "any done state" 'done) + (const :tag "any state" 'any) + (list :tag "Keyword list" + (const :format "" quote) + (repeat (string :tag "Keyword"))))) + (list :tag "TODO state is not" :inline t + (const 'nottodo) + (choice + (const :tag "any not-done state" 'todo) + (const :tag "any done state" 'done) + (const :tag "any state" 'any) + (list :tag "Keyword list" + (const :format "" quote) + (repeat (string :tag "Keyword"))))) + (const :tag "scheduled" 'scheduled) + (const :tag "not scheduled" 'notscheduled) + (const :tag "deadline" 'deadline) + (const :tag "no deadline" 'notdeadline) + (const :tag "timestamp" 'timestamp) + (const :tag "no timestamp" 'nottimestamp)))))) + (list :tag "Non-standard skipping condition" + :value (org-agenda-skip-function) + (const org-agenda-skip-function) + (sexp :tag "Function or form (quoted!)")) + (list :tag "Any variable" + (variable :tag "Variable") + (sexp :tag "Value (sexp)")))) + "Selection of examples for agenda command settings. +This will be spliced into the custom type of +`org-agenda-custom-commands'.") + + +(defcustom org-agenda-custom-commands nil + "Custom commands for the agenda. +These commands will be offered on the splash screen displayed by the +agenda dispatcher \\[org-agenda]. Each entry is a list like this: + + (key desc type match settings files) + +key The key (one or more characters as a string) to be associated + with the command. +desc A description of the command, when omitted or nil, a default + description is built using MATCH. +type The command type, any of the following symbols: + agenda The daily/weekly agenda. + todo Entries with a specific TODO keyword, in all agenda files. + search Entries containing search words entry or headline. + tags Tags/Property/TODO match in all agenda files. + tags-todo Tags/P/T match in all agenda files, TODO entries only. + todo-tree Sparse tree of specific TODO keyword in *current* file. + tags-tree Sparse tree with all tags matches in *current* file. + occur-tree Occur sparse tree for *current* file. + ... A user-defined function. +match What to search for: + - a single keyword for TODO keyword searches + - a tags match expression for tags searches + - a word search expression for text searches. + - a regular expression for occur searches + For all other commands, this should be the empty string. +settings A list of option settings, similar to that in a let form, so like + this: ((opt1 val1) (opt2 val2) ...). The values will be + evaluated at the moment of execution, so quote them when needed. +files A list of files file to write the produced agenda buffer to + with the command `org-store-agenda-views'. + If a file name ends in \".html\", an HTML version of the buffer + is written out. If it ends in \".ps\", a postscript version is + produced. Otherwise, only the plain text is written to the file. + +You can also define a set of commands, to create a composite agenda buffer. +In this case, an entry looks like this: + + (key desc (cmd1 cmd2 ...) general-settings-for-whole-set files) + +where + +desc A description string to be displayed in the dispatcher menu. +cmd An agenda command, similar to the above. However, tree commands + are no allowed, but instead you can get agenda and global todo list. + So valid commands for a set are: + (agenda \"\" settings) + (alltodo \"\" settings) + (stuck \"\" settings) + (todo \"match\" settings files) + (search \"match\" settings files) + (tags \"match\" settings files) + (tags-todo \"match\" settings files) + +Each command can carry a list of options, and another set of options can be +given for the whole set of commands. Individual command options take +precedence over the general options. + +When using several characters as key to a command, the first characters +are prefix commands. For the dispatcher to display useful information, you +should provide a description for the prefix, like + + (setq org-agenda-custom-commands + '((\"h\" . \"HOME + Name tag searches\") ; describe prefix \"h\" + (\"hl\" tags \"+HOME+Lisa\") + (\"hp\" tags \"+HOME+Peter\") + (\"hk\" tags \"+HOME+Kim\")))" + :group 'org-agenda-custom-commands + :type `(repeat + (choice :value ("x" "Describe command here" tags "" nil) + (list :tag "Single command" + (string :tag "Access Key(s) ") + (option (string :tag "Description")) + (choice + (const :tag "Agenda" agenda) + (const :tag "TODO list" alltodo) + (const :tag "Search words" search) + (const :tag "Stuck projects" stuck) + (const :tag "Tags/Property match (all agenda files)" tags) + (const :tag "Tags/Property match of TODO entries (all agenda files)" tags-todo) + (const :tag "TODO keyword search (all agenda files)" todo) + (const :tag "Tags sparse tree (current buffer)" tags-tree) + (const :tag "TODO keyword tree (current buffer)" todo-tree) + (const :tag "Occur tree (current buffer)" occur-tree) + (sexp :tag "Other, user-defined function")) + (string :tag "Match (only for some commands)") + ,org-agenda-custom-commands-local-options + (option (repeat :tag "Export" (file :tag "Export to")))) + (list :tag "Command series, all agenda files" + (string :tag "Access Key(s)") + (string :tag "Description ") + (repeat :tag "Component" + (choice + (list :tag "Agenda" + (const :format "" agenda) + (const :tag "" :format "" "") + ,org-agenda-custom-commands-local-options) + (list :tag "TODO list (all keywords)" + (const :format "" alltodo) + (const :tag "" :format "" "") + ,org-agenda-custom-commands-local-options) + (list :tag "Search words" + (const :format "" search) + (string :tag "Match") + ,org-agenda-custom-commands-local-options) + (list :tag "Stuck projects" + (const :format "" stuck) + (const :tag "" :format "" "") + ,org-agenda-custom-commands-local-options) + (list :tag "Tags search" + (const :format "" tags) + (string :tag "Match") + ,org-agenda-custom-commands-local-options) + (list :tag "Tags search, TODO entries only" + (const :format "" tags-todo) + (string :tag "Match") + ,org-agenda-custom-commands-local-options) + (list :tag "TODO keyword search" + (const :format "" todo) + (string :tag "Match") + ,org-agenda-custom-commands-local-options) + (list :tag "Other, user-defined function" + (symbol :tag "function") + (string :tag "Match") + ,org-agenda-custom-commands-local-options))) + + (repeat :tag "Settings for entire command set" + (list (variable :tag "Any variable") + (sexp :tag "Value"))) + (option (repeat :tag "Export" (file :tag "Export to")))) + (cons :tag "Prefix key documentation" + (string :tag "Access Key(s)") + (string :tag "Description "))))) + +(defcustom org-agenda-query-register ?o + "The register holding the current query string. +The purpose of this is that if you construct a query string interactively, +you can then use it to define a custom command." + :group 'org-agenda-custom-commands + :type 'character) + +(defcustom org-stuck-projects + '("+LEVEL=2/-DONE" ("TODO" "NEXT" "NEXTACTION") nil "") + "How to identify stuck projects. +This is a list of four items: +1. A tags/todo/property matcher string that is used to identify a project. + See the manual for a description of tag and property searches. + The entire tree below a headline matched by this is considered one project. +2. A list of TODO keywords identifying non-stuck projects. + If the project subtree contains any headline with one of these todo + keywords, the project is considered to be not stuck. If you specify + \"*\" as a keyword, any TODO keyword will mark the project unstuck. +3. A list of tags identifying non-stuck projects. + If the project subtree contains any headline with one of these tags, + the project is considered to be not stuck. If you specify \"*\" as + a tag, any tag will mark the project unstuck. Note that this is about + the explicit presence of a tag somewhere in the subtree, inherited + tags to not count here. If inherited tags make a project not stuck, + use \"-TAG\" in the tags part of the matcher under (1.) above. +4. An arbitrary regular expression matching non-stuck projects. + +If the project turns out to be not stuck, search continues also in the +subtree to see if any of the subtasks have project status. + +See also the variable `org-tags-match-list-sublevels' which applies +to projects matched by this search as well. + +After defining this variable, you may use \\[org-agenda-list-stuck-projects] +or `C-c a #' to produce the list." + :group 'org-agenda-custom-commands + :type '(list + (string :tag "Tags/TODO match to identify a project") + (repeat :tag "Projects are *not* stuck if they have an entry with TODO keyword any of" (string)) + (repeat :tag "Projects are *not* stuck if they have an entry with TAG being any of" (string)) + (regexp :tag "Projects are *not* stuck if this regexp matches inside the subtree"))) + +(defcustom org-agenda-filter-effort-default-operator "<" + "The default operator for effort estimate filtering. +If you select an effort estimate limit without first pressing an operator, +this one will be used." + :group 'org-agenda-custom-commands + :type '(choice (const :tag "less or equal" "<") + (const :tag "greater or equal"">") + (const :tag "equal" "="))) + +(defgroup org-agenda-skip nil + "Options concerning skipping parts of agenda files." + :tag "Org Agenda Skip" + :group 'org-agenda) +(defgroup org-agenda-daily/weekly nil + "Options concerning the daily/weekly agenda." + :tag "Org Agenda Daily/Weekly" + :group 'org-agenda) +(defgroup org-agenda-todo-list nil + "Options concerning the global todo list agenda view." + :tag "Org Agenda Todo List" + :group 'org-agenda) +(defgroup org-agenda-match-view nil + "Options concerning the general tags/property/todo match agenda view." + :tag "Org Agenda Match View" + :group 'org-agenda) +(defgroup org-agenda-search-view nil + "Options concerning the general tags/property/todo match agenda view." + :tag "Org Agenda Match View" + :group 'org-agenda) + +(defvar org-agenda-archives-mode nil + "Non-nil means the agenda will include archived items. +If this is the symbol `trees', trees in the selected agenda scope +that are marked with the ARCHIVE tag will be included anyway. When this is +t, also all archive files associated with the current selection of agenda +files will be included.") + +(defcustom org-agenda-skip-comment-trees t + "Non-nil means skip trees that start with the COMMENT keyword. +When nil, these trees are also scanned by agenda commands." + :group 'org-agenda-skip + :type 'boolean) + +(defcustom org-agenda-todo-list-sublevels t + "Non-nil means check also the sublevels of a TODO entry for TODO entries. +When nil, the sublevels of a TODO entry are not checked, resulting in +potentially much shorter TODO lists." + :group 'org-agenda-skip + :group 'org-agenda-todo-list + :type 'boolean) + +(defcustom org-agenda-todo-ignore-with-date nil + "Non-nil means don't show entries with a date in the global todo list. +You can use this if you prefer to mark mere appointments with a TODO keyword, +but don't want them to show up in the TODO list. +When this is set, it also covers deadlines and scheduled items, the settings +of `org-agenda-todo-ignore-scheduled' and `org-agenda-todo-ignore-deadlines' +will be ignored. +See also the variable `org-agenda-tags-todo-honor-ignore-options'." + :group 'org-agenda-skip + :group 'org-agenda-todo-list + :type 'boolean) + +(defcustom org-agenda-todo-ignore-timestamp nil + "Non-nil means don't show entries with a timestamp. +This applies when creating the global todo list. +Valid values are: + +past Don't show entries for today or in the past. + +future Don't show entries with a timestamp in the future. + The idea behind this is that if it has a future + timestamp, you don't want to think about it until the + date. + +all Don't show any entries with a timestamp in the global todo list. + The idea behind this is that by setting a timestamp, you + have already \"taken care\" of this item. + +See also `org-agenda-todo-ignore-with-date'. +See also the variable `org-agenda-tags-todo-honor-ignore-options' if you want +to make his option also apply to the tags-todo list." + :group 'org-agenda-skip + :group 'org-agenda-todo-list + :type '(choice + (const :tag "Ignore future timestamp todos" future) + (const :tag "Ignore past or present timestamp todos" past) + (const :tag "Ignore all timestamp todos" all) + (const :tag "Show timestamp todos" nil))) + +(defcustom org-agenda-todo-ignore-scheduled nil + "Non-nil means, ignore some scheduled TODO items when making TODO list. +This applies when creating the global todo list. +Valid values are: + +past Don't show entries scheduled today or in the past. + +future Don't show entries scheduled in the future. + The idea behind this is that by scheduling it, you don't want to + think about it until the scheduled date. + +all Don't show any scheduled entries in the global todo list. + The idea behind this is that by scheduling it, you have already + \"taken care\" of this item. + +t Same as `all', for backward compatibility. + +See also `org-agenda-todo-ignore-with-date'. +See also the variable `org-agenda-tags-todo-honor-ignore-options' if you want +to make his option also apply to the tags-todo list." + :group 'org-agenda-skip + :group 'org-agenda-todo-list + :type '(choice + (const :tag "Ignore future-scheduled todos" future) + (const :tag "Ignore past- or present-scheduled todos" past) + (const :tag "Ignore all scheduled todos" all) + (const :tag "Ignore all scheduled todos (compatibility)" t) + (const :tag "Show scheduled todos" nil))) + +(defcustom org-agenda-todo-ignore-deadlines nil + "Non-nil means ignore some deadlined TODO items when making TODO list. +There are different motivations for using different values, please think +carefully when configuring this variable. + +This applies when creating the global todo list. +Valid values are: + +near Don't show near deadline entries. A deadline is near when it is + closer than `org-deadline-warning-days' days. The idea behind this + is that such items will appear in the agenda anyway. + +far Don't show TODO entries where a deadline has been defined, but + the deadline is not near. This is useful if you don't want to + use the todo list to figure out what to do now. + +past Don't show entries with a deadline timestamp for today or in the past. + +future Don't show entries with a deadline timestamp in the future, not even + when they become `near' ones. Use it with caution. + +all Ignore all TODO entries that do have a deadline. + +t Same as `near', for backward compatibility. + +See also `org-agenda-todo-ignore-with-date'. +See also the variable `org-agenda-tags-todo-honor-ignore-options' if you want +to make his option also apply to the tags-todo list." + :group 'org-agenda-skip + :group 'org-agenda-todo-list + :type '(choice + (const :tag "Ignore near deadlines" near) + (const :tag "Ignore near deadlines (compatibility)" t) + (const :tag "Ignore far deadlines" far) + (const :tag "Ignore all TODOs with a deadlines" all) + (const :tag "Show all TODOs, even if they have a deadline" nil))) + +(defcustom org-agenda-tags-todo-honor-ignore-options nil + "Non-nil means honor todo-list ...ignore options also in tags-todo search. +The variables + `org-agenda-todo-ignore-with-date', + `org-agenda-todo-ignore-timestamp', + `org-agenda-todo-ignore-scheduled', + `org-agenda-todo-ignore-deadlines' +make the global TODO list skip entries that have time stamps of certain +kinds. If this option is set, the same options will also apply for the +tags-todo search, which is the general tags/property matcher +restricted to unfinished TODO entries only." + :group 'org-agenda-skip + :group 'org-agenda-todo-list + :group 'org-agenda-match-view + :type 'boolean) + +(defcustom org-agenda-skip-scheduled-if-done nil + "Non-nil means don't show scheduled items in agenda when they are done. +This is relevant for the daily/weekly agenda, not for the TODO list. And +it applies only to the actual date of the scheduling. Warnings about +an item with a past scheduling dates are always turned off when the item +is DONE." + :group 'org-agenda-skip + :group 'org-agenda-daily/weekly + :type 'boolean) + +(defcustom org-agenda-skip-scheduled-if-deadline-is-shown nil + "Non-nil means skip scheduling line if same entry shows because of deadline. +In the agenda of today, an entry can show up multiple times because +it is both scheduled and has a nearby deadline, and maybe a plain time +stamp as well. +When this variable is t, then only the deadline is shown and the fact that +the entry is scheduled today or was scheduled previously is not shown. +When this variable is nil, the entry will be shown several times. When +the variable is the symbol `not-today', then skip scheduled previously, +but not scheduled today." + :group 'org-agenda-skip + :group 'org-agenda-daily/weekly + :type '(choice + (const :tag "Never" nil) + (const :tag "Always" t) + (const :tag "Not when scheduled today" not-today))) + +(defcustom org-agenda-skip-deadline-if-done nil + "Non-nil means don't show deadlines when the corresponding item is done. +When nil, the deadline is still shown and should give you a happy feeling. +This is relevant for the daily/weekly agenda. And it applied only to the +actually date of the deadline. Warnings about approaching and past-due +deadlines are always turned off when the item is DONE." + :group 'org-agenda-skip + :group 'org-agenda-daily/weekly + :type 'boolean) + +(defcustom org-agenda-skip-deadline-prewarning-if-scheduled nil + "Non-nil means skip deadline prewarning when entry is also scheduled. +This will apply on all days where a prewarning for the deadline would +be shown, but not at the day when the entry is actually due. On that day, +the deadline will be shown anyway. +This variable may be set to nil, t, or a number which will then give +the number of days before the actual deadline when the prewarnings +should resume. +This can be used in a workflow where the first showing of the deadline will +trigger you to schedule it, and then you don't want to be reminded of it +because you will take care of it on the day when scheduled." + :group 'org-agenda-skip + :group 'org-agenda-daily/weekly + :type '(choice + (const :tag "Alwas show prewarning" nil) + (const :tag "Remove prewarning if entry is scheduled" t) + (integer :tag "Restart prewarning N days before deadline"))) + +(defcustom org-agenda-skip-additional-timestamps-same-entry t + "When nil, multiple same-day timestamps in entry make multiple agenda lines. +When non-nil, after the search for timestamps has matched once in an +entry, the rest of the entry will not be searched." + :group 'org-agenda-skip + :type 'boolean) + +(defcustom org-agenda-skip-timestamp-if-done nil + "Non-nil means don't select item by timestamp or -range if it is DONE." + :group 'org-agenda-skip + :group 'org-agenda-daily/weekly + :type 'boolean) + +(defcustom org-agenda-dim-blocked-tasks t + "Non-nil means dim blocked tasks in the agenda display. +This causes some overhead during agenda construction, but if you +have turned on `org-enforce-todo-dependencies', +`org-enforce-todo-checkbox-dependencies', or any other blocking +mechanism, this will create useful feedback in the agenda. + +Instead of t, this variable can also have the value `invisible'. +Then blocked tasks will be invisible and only become visible when +they become unblocked. An exemption to this behavior is when a task is +blocked because of unchecked checkboxes below it. Since checkboxes do +not show up in the agenda views, making this task invisible you remove any +trace from agenda views that there is something to do. Therefore, a task +that is blocked because of checkboxes will never be made invisible, it +will only be dimmed." + :group 'org-agenda-daily/weekly + :group 'org-agenda-todo-list + :type '(choice + (const :tag "Do not dim" nil) + (const :tag "Dim to a grey face" t) + (const :tag "Make invisible" invisible))) + +(defcustom org-timeline-show-empty-dates 3 + "Non-nil means `org-timeline' also shows dates without an entry. +When nil, only the days which actually have entries are shown. +When t, all days between the first and the last date are shown. +When an integer, show also empty dates, but if there is a gap of more than +N days, just insert a special line indicating the size of the gap." + :group 'org-agenda-skip + :type '(choice + (const :tag "None" nil) + (const :tag "All" t) + (integer :tag "at most"))) + +(defgroup org-agenda-startup nil + "Options concerning initial settings in the Agenda in Org Mode." + :tag "Org Agenda Startup" + :group 'org-agenda) + +(defcustom org-agenda-menu-show-matcher t + "Non-nil menas show the match string in the agenda dispatcher menu. +When nil, the matcher string is not shown, but is put into the help-echo +property so than moving the mouse over the command shows it. +Setting it to nil is good if matcher strings are very long and/or if +you wnat to use two-column display (see `org-agenda-menu-two-column')." + :group 'org-agenda + :type 'boolean) + +(defcustom org-agenda-menu-two-column nil + "Non-nil means, use two columns to show custom commands in the dispatcher. +If you use this, you probably want to set `org-agenda-menu-show-matcher' +to nil." + :group 'org-agenda + :type 'boolean) + +(defcustom org-finalize-agenda-hook nil + "Hook run just before displaying an agenda buffer." + :group 'org-agenda-startup + :type 'hook) + +(defcustom org-agenda-mouse-1-follows-link nil + "Non-nil means mouse-1 on a link will follow the link in the agenda. +A longer mouse click will still set point. Does not work on XEmacs. +Needs to be set before org.el is loaded." + :group 'org-agenda-startup + :type 'boolean) + +(defcustom org-agenda-start-with-follow-mode nil + "The initial value of follow mode in a newly created agenda window." + :group 'org-agenda-startup + :type 'boolean) + +(defcustom org-agenda-show-outline-path t + "Non-nil means show outline path in echo area after line motion." + :group 'org-agenda-startup + :type 'boolean) + +(defcustom org-agenda-start-with-entry-text-mode nil + "The initial value of entry-text-mode in a newly created agenda window." + :group 'org-agenda-startup + :type 'boolean) + +(defcustom org-agenda-entry-text-maxlines 5 + "Number of text lines to be added when `E' is pressed in the agenda. + +Note that this variable only used during agenda display. Add add entry text +when exporting the agenda, configure the variable +`org-agenda-add-entry-ext-maxlines'." + :group 'org-agenda + :type 'integer) + +(defcustom org-agenda-entry-text-exclude-regexps nil + "List of regular expressions to clean up entry text. +The complete matches of all regular expressions in this list will be +removed from entry text before it is shown in the agenda." + :group 'org-agenda + :type '(repeat (regexp))) + +(defvar org-agenda-entry-text-cleanup-hook nil + "Hook that is run after basic cleanup of entry text to be shown in agenda. +This cleanup is done in a temporary buffer, so the function may inspect and +change the entire buffer. +Some default stuff like drawers and scheduling/deadline dates will already +have been removed when this is called, as will any matches for regular +expressions listed in `org-agenda-entry-text-exclude-regexps'.") + +(defvar org-agenda-include-inactive-timestamps nil + "Non-nil means include inactive time stamps in agenda and timeline.") + +(defgroup org-agenda-windows nil + "Options concerning the windows used by the Agenda in Org Mode." + :tag "Org Agenda Windows" + :group 'org-agenda) + +(defcustom org-agenda-window-setup 'reorganize-frame + "How the agenda buffer should be displayed. +Possible values for this option are: + +current-window Show agenda in the current window, keeping all other windows. +other-window Use `switch-to-buffer-other-window' to display agenda. +reorganize-frame Show only two windows on the current frame, the current + window and the agenda. +other-frame Use `switch-to-buffer-other-frame' to display agenda. + Also, when exiting the agenda, kill that frame. +See also the variable `org-agenda-restore-windows-after-quit'." + :group 'org-agenda-windows + :type '(choice + (const current-window) + (const other-frame) + (const other-window) + (const reorganize-frame))) + +(defcustom org-agenda-window-frame-fractions '(0.5 . 0.75) + "The min and max height of the agenda window as a fraction of frame height. +The value of the variable is a cons cell with two numbers between 0 and 1. +It only matters if `org-agenda-window-setup' is `reorganize-frame'." + :group 'org-agenda-windows + :type '(cons (number :tag "Minimum") (number :tag "Maximum"))) + +(defcustom org-agenda-restore-windows-after-quit nil + "Non-nil means restore window configuration open exiting agenda. +Before the window configuration is changed for displaying the agenda, +the current status is recorded. When the agenda is exited with +`q' or `x' and this option is set, the old state is restored. If +`org-agenda-window-setup' is `other-frame', the value of this +option will be ignored." + :group 'org-agenda-windows + :type 'boolean) + +(defcustom org-agenda-ndays nil + "Number of days to include in overview display. +Should be 1 or 7. +Obsolete, see `org-agenda-span'." + :group 'org-agenda-daily/weekly + :type 'integer) + +(make-obsolete-variable 'org-agenda-ndays 'org-agenda-span "24.1") + +(defcustom org-agenda-span 'week + "Number of days to include in overview display. +Can be day, week, month, year, or any number of days. +Custom commands can set this variable in the options section." + :group 'org-agenda-daily/weekly + :type '(choice (const :tag "Day" day) + (const :tag "Week" week) + (const :tag "Month" month) + (const :tag "Year" year) + (integer :tag "Custom"))) + +(defcustom org-agenda-start-on-weekday 1 + "Non-nil means start the overview always on the specified weekday. +0 denotes Sunday, 1 denotes Monday etc. +When nil, always start on the current day. +Custom commands can set this variable in the options section." + :group 'org-agenda-daily/weekly + :type '(choice (const :tag "Today" nil) + (integer :tag "Weekday No."))) + +(defcustom org-agenda-show-all-dates t + "Non-nil means `org-agenda' shows every day in the selected range. +When nil, only the days which actually have entries are shown." + :group 'org-agenda-daily/weekly + :type 'boolean) + +(defcustom org-agenda-format-date 'org-agenda-format-date-aligned + "Format string for displaying dates in the agenda. +Used by the daily/weekly agenda and by the timeline. This should be +a format string understood by `format-time-string', or a function returning +the formatted date as a string. The function must take a single argument, +a calendar-style date list like (month day year)." + :group 'org-agenda-daily/weekly + :type '(choice + (string :tag "Format string") + (function :tag "Function"))) + +(defun org-agenda-format-date-aligned (date) + "Format a date string for display in the daily/weekly agenda, or timeline. +This function makes sure that dates are aligned for easy reading." + (require 'cal-iso) + (let* ((dayname (calendar-day-name date)) + (day (cadr date)) + (day-of-week (calendar-day-of-week date)) + (month (car date)) + (monthname (calendar-month-name month)) + (year (nth 2 date)) + (iso-week (org-days-to-iso-week + (calendar-absolute-from-gregorian date))) + (weekyear (cond ((and (= month 1) (>= iso-week 52)) + (1- year)) + ((and (= month 12) (<= iso-week 1)) + (1+ year)) + (t year))) + (weekstring (if (= day-of-week 1) + (format " W%02d" iso-week) + ""))) + (format "%-10s %2d %s %4d%s" + dayname day monthname year weekstring))) + +(defcustom org-agenda-time-leading-zero nil + "Non-nil means use leading zero for military times in agenda. +For example, 9:30am would become 09:30 rather than 9:30." + :group 'org-agenda-daily/weekly + :type 'boolean) + +(defcustom org-agenda-timegrid-use-ampm nil + "When set, show AM/PM style timestamps on the timegrid." + :group 'org-agenda + :type 'boolean) + +(defun org-agenda-time-of-day-to-ampm (time) + "Convert TIME of a string like '13:45' to an AM/PM style time string." + (let* ((hour-number (string-to-number (substring time 0 -3))) + (minute (substring time -2)) + (ampm "am")) + (cond + ((equal hour-number 12) + (setq ampm "pm")) + ((> hour-number 12) + (setq ampm "pm") + (setq hour-number (- hour-number 12)))) + (concat + (if org-agenda-time-leading-zero + (format "%02d" hour-number) + (format "%02s" (number-to-string hour-number))) + ":" minute ampm))) + +(defun org-agenda-time-of-day-to-ampm-maybe (time) + "Conditionally convert TIME to AM/PM format +based on `org-agenda-timegrid-use-ampm'" + (if org-agenda-timegrid-use-ampm + (org-agenda-time-of-day-to-ampm time) + time)) + +(defcustom org-agenda-weekend-days '(6 0) + "Which days are weekend? +These days get the special face `org-agenda-date-weekend' in the agenda +and timeline buffers." + :group 'org-agenda-daily/weekly + :type '(set :greedy t + (const :tag "Monday" 1) + (const :tag "Tuesday" 2) + (const :tag "Wednesday" 3) + (const :tag "Thursday" 4) + (const :tag "Friday" 5) + (const :tag "Saturday" 6) + (const :tag "Sunday" 0))) + +(defcustom org-agenda-include-diary nil + "If non-nil, include in the agenda entries from the Emacs Calendar's diary. +Custom commands can set this variable in the options section." + :group 'org-agenda-daily/weekly + :type 'boolean) + +(defcustom org-agenda-include-deadlines t + "If non-nil, include entries within their deadline warning period. +Custom commands can set this variable in the options section." + :group 'org-agenda-daily/weekly + :type 'boolean) + +(defcustom org-agenda-include-all-todo nil + "Set means weekly/daily agenda will always contain all TODO entries. +The TODO entries will be listed at the top of the agenda, before +the entries for specific days. +This option is deprecated, it is better to define a block agenda instead." + :group 'org-agenda-daily/weekly + :type 'boolean) + +(defcustom org-agenda-repeating-timestamp-show-all t + "Non-nil means show all occurrences of a repeating stamp in the agenda. +When nil, only one occurrence is shown, either today or the +nearest into the future." + :group 'org-agenda-daily/weekly + :type 'boolean) + +(defcustom org-scheduled-past-days 10000 + "No. of days to continue listing scheduled items that are not marked DONE. +When an item is scheduled on a date, it shows up in the agenda on this +day and will be listed until it is marked done for the number of days +given here." + :group 'org-agenda-daily/weekly + :type 'integer) + +(defcustom org-agenda-log-mode-items '(closed clock) + "List of items that should be shown in agenda log mode. +This list may contain the following symbols: + + closed Show entries that have been closed on that day. + clock Show entries that have received clocked time on that day. + state Show all logged state changes. +Note that instead of changing this variable, you can also press `C-u l' in +the agenda to display all available LOG items temporarily." + :group 'org-agenda-daily/weekly + :type '(set :greedy t (const closed) (const clock) (const state))) + +(defcustom org-agenda-log-mode-add-notes t + "Non-nil means add first line of notes to log entries in agenda views. +If a log item like a state change or a clock entry is associated with +notes, the first line of these notes will be added to the entry in the +agenda display." + :group 'org-agenda-daily/weekly + :type 'boolean) + +(defcustom org-agenda-start-with-log-mode nil + "The initial value of log-mode in a newly created agenda window." + :group 'org-agenda-startup + :group 'org-agenda-daily/weekly + :type 'boolean) + +(defcustom org-agenda-start-with-clockreport-mode nil + "The initial value of clockreport-mode in a newly created agenda window." + :group 'org-agenda-startup + :group 'org-agenda-daily/weekly + :type 'boolean) + +(defcustom org-agenda-clockreport-parameter-plist '(:link t :maxlevel 2) + "Property list with parameters for the clocktable in clockreport mode. +This is the display mode that shows a clock table in the daily/weekly +agenda, the properties for this dynamic block can be set here. +The usual clocktable parameters are allowed here, but you cannot set +the properties :name, :tstart, :tend, :block, and :scope - these will +be overwritten to make sure the content accurately reflects the +current display in the agenda." + :group 'org-agenda-daily/weekly + :type 'plist) + +(defcustom org-agenda-search-view-always-boolean nil + "Non-nil means the search string is interpreted as individual parts. + +The search string for search view can either be interpreted as a phrase, +or as a list of snippets that define a boolean search for a number of +strings. + +When this is non-nil, the string will be split on whitespace, and each +snippet will be searched individually, and all must match in order to +select an entry. A snippet is then a single string of non-white +characters, or a string in double quotes, or a regexp in {} braces. +If a snippet is preceded by \"-\", the snippet must *not* match. +\"+\" is syntactic sugar for positive selection. Each snippet may +be found as a full word or a partial word, but see the variable +`org-agenda-search-view-force-full-words'. + +When this is nil, search will look for the entire search phrase as one, +with each space character matching any amount of whitespace, including +line breaks. + +Even when this is nil, you can still switch to Boolean search dynamically +by preceding the first snippet with \"+\" or \"-\". If the first snippet +is a regexp marked with braces like \"{abc}\", this will also switch to +boolean search." + :group 'org-agenda-search-view + :type 'boolean) + +(if (fboundp 'defvaralias) + (defvaralias 'org-agenda-search-view-search-words-only + 'org-agenda-search-view-always-boolean)) + +(defcustom org-agenda-search-view-force-full-words nil + "Non-nil means, search words must be matches as complete words. +When nil, they may also match part of a word." + :group 'org-agenda-search-view + :type 'boolean) + +(defgroup org-agenda-time-grid nil + "Options concerning the time grid in the Org-mode Agenda." + :tag "Org Agenda Time Grid" + :group 'org-agenda) + +(defcustom org-agenda-search-headline-for-time t + "Non-nil means search headline for a time-of-day. +If the headline contains a time-of-day in one format or another, it will +be used to sort the entry into the time sequence of items for a day. +Some people have time stamps in the headline that refer to the creation +time or so, and then this produces an unwanted side effect. If this is +the case for your, use this variable to turn off searching the headline +for a time." + :group 'org-agenda-time-grid + :type 'boolean) + +(defcustom org-agenda-use-time-grid t + "Non-nil means show a time grid in the agenda schedule. +A time grid is a set of lines for specific times (like every two hours between +8:00 and 20:00). The items scheduled for a day at specific times are +sorted in between these lines. +For details about when the grid will be shown, and what it will look like, see +the variable `org-agenda-time-grid'." + :group 'org-agenda-time-grid + :type 'boolean) + +(defcustom org-agenda-time-grid + '((daily today require-timed) + "----------------" + (800 1000 1200 1400 1600 1800 2000)) + + "The settings for time grid for agenda display. +This is a list of three items. The first item is again a list. It contains +symbols specifying conditions when the grid should be displayed: + + daily if the agenda shows a single day + weekly if the agenda shows an entire week + today show grid on current date, independent of daily/weekly display + require-timed show grid only if at least one item has a time specification + +The second item is a string which will be placed behind the grid time. + +The third item is a list of integers, indicating the times that should have +a grid line." + :group 'org-agenda-time-grid + :type + '(list + (set :greedy t :tag "Grid Display Options" + (const :tag "Show grid in single day agenda display" daily) + (const :tag "Show grid in weekly agenda display" weekly) + (const :tag "Always show grid for today" today) + (const :tag "Show grid only if any timed entries are present" + require-timed) + (const :tag "Skip grid times already present in an entry" + remove-match)) + (string :tag "Grid String") + (repeat :tag "Grid Times" (integer :tag "Time")))) + +(defgroup org-agenda-sorting nil + "Options concerning sorting in the Org-mode Agenda." + :tag "Org Agenda Sorting" + :group 'org-agenda) + +(defcustom org-agenda-sorting-strategy + '((agenda habit-down time-up priority-down category-keep) + (todo priority-down category-keep) + (tags priority-down category-keep) + (search category-keep)) + "Sorting structure for the agenda items of a single day. +This is a list of symbols which will be used in sequence to determine +if an entry should be listed before another entry. The following +symbols are recognized: + +time-up Put entries with time-of-day indications first, early first +time-down Put entries with time-of-day indications first, late first +category-keep Keep the default order of categories, corresponding to the + sequence in `org-agenda-files'. +category-up Sort alphabetically by category, A-Z. +category-down Sort alphabetically by category, Z-A. +tag-up Sort alphabetically by last tag, A-Z. +tag-down Sort alphabetically by last tag, Z-A. +priority-up Sort numerically by priority, high priority last. +priority-down Sort numerically by priority, high priority first. +todo-state-up Sort by todo state, tasks that are done last. +todo-state-down Sort by todo state, tasks that are done first. +effort-up Sort numerically by estimated effort, high effort last. +effort-down Sort numerically by estimated effort, high effort first. +user-defined-up Sort according to `org-agenda-cmp-user-defined', high last. +user-defined-down Sort according to `org-agenda-cmp-user-defined', high first. +habit-up Put entries that are habits first +habit-down Put entries that are habits last +alpha-up Sort headlines alphabetically +alpha-down Sort headlines alphabetically, reversed + +The different possibilities will be tried in sequence, and testing stops +if one comparison returns a \"not-equal\". For example, the default + '(time-up category-keep priority-down) +means: Pull out all entries having a specified time of day and sort them, +in order to make a time schedule for the current day the first thing in the +agenda listing for the day. Of the entries without a time indication, keep +the grouped in categories, don't sort the categories, but keep them in +the sequence given in `org-agenda-files'. Within each category sort by +priority. + +Leaving out `category-keep' would mean that items will be sorted across +categories by priority. + +Instead of a single list, this can also be a set of list for specific +contents, with a context symbol in the car of the list, any of +`agenda', `todo', `tags', `search' for the corresponding agenda views. + +Custom commands can bind this variable in the options section." + :group 'org-agenda-sorting + :type `(choice + (repeat :tag "General" ,org-sorting-choice) + (list :tag "Individually" + (cons (const :tag "Strategy for Weekly/Daily agenda" agenda) + (repeat ,org-sorting-choice)) + (cons (const :tag "Strategy for TODO lists" todo) + (repeat ,org-sorting-choice)) + (cons (const :tag "Strategy for Tags matches" tags) + (repeat ,org-sorting-choice)) + (cons (const :tag "Strategy for search matches" search) + (repeat ,org-sorting-choice))))) + +(defcustom org-agenda-cmp-user-defined nil + "A function to define the comparison `user-defined'. +This function must receive two arguments, agenda entry a and b. +If a>b, return +1. If a<b, return -1. If they are equal as seen by +the user comparison, return nil. +When this is defined, you can make `user-defined-up' and `user-defined-down' +part of an agenda sorting strategy." + :group 'org-agenda-sorting + :type 'symbol) + +(defcustom org-sort-agenda-notime-is-late t + "Non-nil means items without time are considered late. +This is only relevant for sorting. When t, items which have no explicit +time like 15:30 will be considered as 99:01, i.e. later than any items which +do have a time. When nil, the default time is before 0:00. You can use this +option to decide if the schedule for today should come before or after timeless +agenda entries." + :group 'org-agenda-sorting + :type 'boolean) + +(defcustom org-sort-agenda-noeffort-is-high t + "Non-nil means items without effort estimate are sorted as high effort. +This also applies when filtering an agenda view with respect to the +< or > effort operator. Then, tasks with no effort defined will be treated +as tasks with high effort. +When nil, such items are sorted as 0 minutes effort." + :group 'org-agenda-sorting + :type 'boolean) + +(defgroup org-agenda-line-format nil + "Options concerning the entry prefix in the Org-mode agenda display." + :tag "Org Agenda Line Format" + :group 'org-agenda) + +(defcustom org-agenda-prefix-format + '((agenda . " %i %-12:c%?-12t% s") + (timeline . " % s") + (todo . " %i %-12:c") + (tags . " %i %-12:c") + (search . " %i %-12:c")) + "Format specifications for the prefix of items in the agenda views. +An alist with four entries, for the different agenda types. The keys to the +sublists are `agenda', `timeline', `todo', and `tags'. The values +are format strings. +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. + %i the icon category of the item, as give in + `org-agenda-category-icon-alist'. + %T the *last* tag of the item. Last because inherited tags come + first in the list. + %t the time-of-day specification if one applies to the entry, in the + format HH:MM + %s Scheduling/Deadline information, a short string + +All specifiers work basically like the standard `%s' of printf, but may +contain two additional characters: A question mark just after the `%' and +a whitespace/punctuation character just before the final letter. + +If the first character after `%' is a question mark, the entire field +will only be included if the corresponding value applies to the +current entry. This is useful for fields which should have fixed +width when present, but zero width when absent. For example, +\"%?-12t\" will result in a 12 character time field if a time of the +day is specified, but will completely disappear in entries which do +not contain a time. + +If there is punctuation or whitespace character just before the final +format letter, this character will be appended to the field value if +the value is not empty. For example, the format \"%-12:c\" leads to +\"Diary: \" if the category is \"Diary\". If the category were be +empty, no additional colon would be inserted. + +The default value of this option is \" %-12:c%?-12t% s\", meaning: +- Indent the line with two space characters +- Give the category in a 12 chars wide field, padded with whitespace on + the right (because of `-'). Append a colon if there is a category + (because of `:'). +- If there is a time-of-day, put it into a 12 chars wide field. If no + time, don't put in an empty field, just skip it (because of '?'). +- Finally, put the scheduling information and append a whitespace. + +As another example, if you don't want the time-of-day of entries in +the prefix, you could use: + + (setq org-agenda-prefix-format \" %-11:c% s\") + +See also the variables `org-agenda-remove-times-when-in-prefix' and +`org-agenda-remove-tags'. + +Custom commands can set this variable in the options section." + :type '(choice + (string :tag "General format") + (list :greedy t :tag "View dependent" + (cons (const agenda) (string :tag "Format")) + (cons (const timeline) (string :tag "Format")) + (cons (const todo) (string :tag "Format")) + (cons (const tags) (string :tag "Format")) + (cons (const search) (string :tag "Format")))) + :group 'org-agenda-line-format) + +(defvar org-prefix-format-compiled nil + "The compiled version of the most recently used prefix format. +See the variable `org-agenda-prefix-format'.") + +(defcustom org-agenda-todo-keyword-format "%-1s" + "Format for the TODO keyword in agenda lines. +Set this to something like \"%-12s\" if you want all TODO keywords +to occupy a fixed space in the agenda display." + :group 'org-agenda-line-format + :type 'string) + +(defcustom org-agenda-timerange-leaders '("" "(%d/%d): ") + "Text preceding timerange entries in the agenda view. +This is a list with two strings. The first applies when the range +is entirely on one day. The second applies if the range spans several days. +The strings may have two \"%d\" format specifiers which will be filled +with the sequence number of the days, and the total number of days in the +range, respectively." + :group 'org-agenda-line-format + :type '(list + (string :tag "Deadline today ") + (choice :tag "Deadline relative" + (string :tag "Format string") + (function)))) + +(defcustom org-agenda-scheduled-leaders '("Scheduled: " "Sched.%2dx: ") + "Text preceding scheduled items in the agenda view. +This is a list with two strings. The first applies when the item is +scheduled on the current day. The second applies when it has been scheduled +previously, it may contain a %d indicating that this is the nth time that +this item is scheduled, due to automatic rescheduling of unfinished items +for the following day. So this number is one larger than the number of days +that passed since this item was scheduled first." + :group 'org-agenda-line-format + :type '(list + (string :tag "Scheduled today ") + (string :tag "Scheduled previously"))) + +(defcustom org-agenda-inactive-leader "[" + "Text preceding item pulled into the agenda by inactive time stamps. +These entries are added to the agenda when pressing \"[\"." + :group 'org-agenda-line-format + :type '(list + (string :tag "Scheduled today ") + (string :tag "Scheduled previously"))) + +(defcustom org-agenda-deadline-leaders '("Deadline: " "In %3d d.: ") + "Text preceding deadline items in the agenda view. +This is a list with two strings. The first applies when the item has its +deadline on the current day. The second applies when it is in the past or +in the future, it may contain %d to capture how many days away the deadline +is (was)." + :group 'org-agenda-line-format + :type '(list + (string :tag "Deadline today ") + (choice :tag "Deadline relative" + (string :tag "Format string") + (function)))) + +(defcustom org-agenda-remove-times-when-in-prefix t + "Non-nil means remove duplicate time specifications in agenda items. +When the format `org-agenda-prefix-format' contains a `%t' specifier, a +time-of-day specification in a headline or diary entry is extracted and +placed into the prefix. If this option is non-nil, the original specification +\(a timestamp or -range, or just a plain time(range) specification like +11:30-4pm) will be removed for agenda display. This makes the agenda less +cluttered. +The option can be t or nil. It may also be the symbol `beg', indicating +that the time should only be removed when it is located at the beginning of +the headline/diary entry." + :group 'org-agenda-line-format + :type '(choice + (const :tag "Always" t) + (const :tag "Never" nil) + (const :tag "When at beginning of entry" beg))) + +(defcustom org-agenda-remove-timeranges-from-blocks nil + "Non-nil means remove time ranges specifications in agenda +items that span on several days." + :group 'org-agenda-line-format + :type 'boolean) + +(defcustom org-agenda-default-appointment-duration nil + "Default duration for appointments that only have a starting time. +When nil, no duration is specified in such cases. +When non-nil, this must be the number of minutes, e.g. 60 for one hour." + :group 'org-agenda-line-format + :type '(choice + (integer :tag "Minutes") + (const :tag "No default duration"))) + +(defcustom org-agenda-show-inherited-tags t + "Non-nil means show inherited tags in each agenda line." + :group 'org-agenda-line-format + :type 'boolean) + +(defcustom org-agenda-hide-tags-regexp nil + "Regular expression used to filter away specific tags in agenda views. +This means that these tags will be present, but not be shown in the agenda +line. Secondary filtering will still work on the hidden tags. +Nil means don't hide any tags." + :group 'org-agenda-line-format + :type '(choice + (const :tag "Hide none" nil) + (string :tag "Regexp "))) + +(defcustom org-agenda-remove-tags nil + "Non-nil means remove the tags from the headline copy in the agenda. +When this is the symbol `prefix', only remove tags when +`org-agenda-prefix-format' contains a `%T' specifier." + :group 'org-agenda-line-format + :type '(choice + (const :tag "Always" t) + (const :tag "Never" nil) + (const :tag "When prefix format contains %T" prefix))) + +(if (fboundp 'defvaralias) + (defvaralias 'org-agenda-remove-tags-when-in-prefix + 'org-agenda-remove-tags)) + +(defcustom org-agenda-tags-column (if (featurep 'xemacs) -79 -80) + "Shift tags in agenda items to this column. +If this number is positive, it specifies the column. If it is negative, +it means that the tags should be flushright to that column. For example, +-80 works well for a normal 80 character screen." + :group 'org-agenda-line-format + :type 'integer) + +(if (fboundp 'defvaralias) + (defvaralias 'org-agenda-align-tags-to-column 'org-agenda-tags-column)) + +(defcustom org-agenda-fontify-priorities 'cookies + "Non-nil means highlight low and high priorities in agenda. +When t, the highest priority entries are bold, lowest priority italic. +However, settings in `org-priority-faces' will overrule these faces. +When this variable is the symbol `cookies', only fontify the +cookies, not the entire task. +This may also be an association list of priority faces, whose +keys are the character values of `org-highest-priority', +`org-default-priority', and `org-lowest-priority' (the default values +are ?A, ?B, and ?C, respectively). The face may be a named face, a +color as a string, or a list like `(:background \"Red\")'. +If it is a color, the variable `org-faces-easy-properties' +determines if it is a foreground or a background color." + :group 'org-agenda-line-format + :type '(choice + (const :tag "Never" nil) + (const :tag "Defaults" t) + (const :tag "Cookies only" cookies) + (repeat :tag "Specify" + (list (character :tag "Priority" :value ?A) + (choice :tag "Face " + (string :tag "Color") + (sexp :tag "Face")))))) + +(defcustom org-agenda-day-face-function nil + "Function called to determine what face should be used to display a day. +The only argument passed to that function is the day. It should +returns a face, or nil if does not want to specify a face and let +the normal rules apply." + :group 'org-agenda-line-format + :type 'function) + +(defcustom org-agenda-category-icon-alist nil + "Alist of category icon to be displayed in agenda views. + +Each entry should have the following format: + + (CATEGORY-REGEXP FILE-OR-DATA TYPE DATA-P PROPS) + +Where CATEGORY-REGEXP is a regexp matching the categories where +the icon should be displayed. +FILE-OR-DATA either a file path or a string containing image data. + +The other fields can be ommited safely if not needed: +TYPE indicates the image type. +DATA-P is a boolean indicating whether the FILE-OR-DATA string is +image data. +PROPS are additional image attributes to assign to the image, +like, e.g. `:ascent center'. + + (\"Org\" \"/path/to/icon.png\" nil nil :ascent center) + +If you want to set the display properties yourself, just put a +list as second element: + + (CATEGORY-REGEXP (MY PROPERTY LIST)) + +For example, to display a 16px horizontal space for Emacs +category, you can use: + + (\"Emacs\" '(space . (:width (16))))" + :group 'org-agenda-line-format + :type '(alist :key-type (string :tag "Regexp matching category") + :value-type (choice (list :tag "Icon" + (string :tag "File or data") + (symbol :tag "Type") + (boolean :tag "Data?") + (repeat :tag "Extra image properties" :inline t symbol)) + (list :tag "Display properties" sexp)))) + +(defgroup org-agenda-column-view nil + "Options concerning column view in the agenda." + :tag "Org Agenda Column View" + :group 'org-agenda) + +(defcustom org-agenda-columns-show-summaries t + "Non-nil means show summaries for columns displayed in the agenda view." + :group 'org-agenda-column-view + :type 'boolean) + +(defcustom org-agenda-columns-remove-prefix-from-item t + "Non-nil means remove the prefix from a headline for agenda column view. +The special ITEM field in the columns format contains the current line, with +all information shown in other columns (like the TODO state or a tag). +When this variable is non-nil, also the agenda prefix will be removed from +the content of the ITEM field, to make sure as much as possible of the +headline can be shown in the limited width of the field." + :group 'org-agenda + :type 'boolean) + +(defcustom org-agenda-columns-compute-summary-properties t + "Non-nil means recompute all summary properties before column view. +When column view in the agenda is listing properties that have a summary +operator, it can go to all relevant buffers and recompute the summaries +there. This can mean overhead for the agenda column view, but is necessary +to have thing up to date. +As a special case, a CLOCKSUM property also makes sure that the clock +computations are current." + :group 'org-agenda-column-view + :type 'boolean) + +(defcustom org-agenda-columns-add-appointments-to-effort-sum nil + "Non-nil means the duration of an appointment will add to day effort. +The property to which appointment durations will be added is the one given +in the option `org-effort-property'. If an appointment does not have +an end time, `org-agenda-default-appointment-duration' will be used. If that +is not set, an appointment without end time will not contribute to the time +estimate." + :group 'org-agenda-column-view + :type 'boolean) + +(defcustom org-agenda-auto-exclude-function nil + "A function called with a tag to decide if it is filtered on '/ RET'. +The sole argument to the function, which is called once for each +possible tag, is a string giving the name of the tag. The +function should return either nil if the tag should be included +as normal, or \"-<TAG>\" to exclude the tag. +Note that for the purpose of tag filtering, only the lower-case version of +all tags will be considered, so that this function will only ever see +the lower-case version of all tags." + :group 'org-agenda + :type 'function) + +(eval-when-compile + (require 'cl)) +(require 'org) + +(defmacro org-agenda-with-point-at-orig-entry (string &rest body) + "Execute BODY with point at location given by `org-hd-marker' property. +If STRING is non-nil, the text property will be fetched from position 0 +in that string. If STRING is nil, it will be fetched from the beginning +of the current line." + `(let ((marker (get-text-property (if string 0 (point-at-bol)) + 'org-hd-marker string))) + (with-current-buffer (marker-buffer marker) + (save-excursion + (goto-char marker) + ,@body)))) + +(defun org-add-agenda-custom-command (entry) + "Replace or add a command in `org-agenda-custom-commands'. +This is mostly for hacking and trying a new command - once the command +works you probably want to add it to `org-agenda-custom-commands' for good." + (let ((ass (assoc (car entry) org-agenda-custom-commands))) + (if ass + (setcdr ass (cdr entry)) + (push entry org-agenda-custom-commands)))) + +;;; Define the Org-agenda-mode + +(defvar org-agenda-mode-map (make-sparse-keymap) + "Keymap for `org-agenda-mode'.") +(if (fboundp 'defvaralias) + (defvaralias 'org-agenda-keymap 'org-agenda-mode-map)) + +(defvar org-agenda-menu) ; defined later in this file. +(defvar org-agenda-restrict) ; defined later in this file. +(defvar org-agenda-follow-mode nil) +(defvar org-agenda-entry-text-mode nil) +(defvar org-agenda-clockreport-mode nil) +(defvar org-agenda-show-log nil) +(defvar org-agenda-redo-command nil) +(defvar org-agenda-query-string nil) +(defvar org-agenda-mode-hook nil + "Hook for `org-agenda-mode', run after the mode is turned on.") +(defvar org-agenda-type nil) +(defvar org-agenda-force-single-file nil) +(defvar org-agenda-bulk-marked-entries) ;; Defined further down in this file + +(defun org-agenda-mode () + "Mode for time-sorted view on action items in Org-mode files. + +The following commands are available: + +\\{org-agenda-mode-map}" + (interactive) + (kill-all-local-variables) + (setq org-agenda-undo-list nil + org-agenda-pending-undo-list nil + org-agenda-bulk-marked-entries nil) + (setq major-mode 'org-agenda-mode) + ;; Keep global-font-lock-mode from turning on font-lock-mode + (org-set-local 'font-lock-global-modes (list 'not major-mode)) + (setq mode-name "Org-Agenda") + (use-local-map org-agenda-mode-map) + (easy-menu-add org-agenda-menu) + (if org-startup-truncated (setq truncate-lines t)) + (org-set-local 'line-move-visual nil) + (org-add-hook 'post-command-hook 'org-agenda-post-command-hook nil 'local) + (org-add-hook 'pre-command-hook 'org-unhighlight nil 'local) + ;; Make sure properties are removed when copying text + (when (boundp 'buffer-substring-filters) + (org-set-local 'buffer-substring-filters + (cons (lambda (x) + (set-text-properties 0 (length x) nil x) x) + buffer-substring-filters))) + (unless org-agenda-keep-modes + (setq org-agenda-follow-mode org-agenda-start-with-follow-mode + org-agenda-entry-text-mode org-agenda-start-with-entry-text-mode + org-agenda-clockreport-mode org-agenda-start-with-clockreport-mode + org-agenda-show-log org-agenda-start-with-log-mode)) + + (easy-menu-change + '("Agenda") "Agenda Files" + (append + (list + (vector + (if (get 'org-agenda-files 'org-restrict) + "Restricted to single file" + "Edit File List") + '(org-edit-agenda-file-list) + (not (get 'org-agenda-files 'org-restrict))) + "--") + (mapcar 'org-file-menu-entry (org-agenda-files)))) + (org-agenda-set-mode-name) + (apply + (if (fboundp 'run-mode-hooks) 'run-mode-hooks 'run-hooks) + (list 'org-agenda-mode-hook))) + +(substitute-key-definition 'undo 'org-agenda-undo + org-agenda-mode-map global-map) +(org-defkey org-agenda-mode-map "\C-i" 'org-agenda-goto) +(org-defkey org-agenda-mode-map [(tab)] 'org-agenda-goto) +(org-defkey org-agenda-mode-map "\C-m" 'org-agenda-switch-to) +(org-defkey org-agenda-mode-map "\C-k" 'org-agenda-kill) +(org-defkey org-agenda-mode-map "\C-c\C-w" 'org-agenda-refile) +(org-defkey org-agenda-mode-map "m" 'org-agenda-bulk-mark) +(org-defkey org-agenda-mode-map "u" 'org-agenda-bulk-unmark) +(org-defkey org-agenda-mode-map "U" 'org-agenda-bulk-remove-all-marks) +(org-defkey org-agenda-mode-map "B" 'org-agenda-bulk-action) +(org-defkey org-agenda-mode-map "\C-c\C-x!" 'org-reload) +(org-defkey org-agenda-mode-map "\C-c\C-x\C-a" 'org-agenda-archive-default) +(org-defkey org-agenda-mode-map "\C-c\C-xa" 'org-agenda-toggle-archive-tag) +(org-defkey org-agenda-mode-map "\C-c\C-xA" 'org-agenda-archive-to-archive-sibling) +(org-defkey org-agenda-mode-map "\C-c\C-x\C-s" 'org-agenda-archive) +(org-defkey org-agenda-mode-map "\C-c$" 'org-agenda-archive) +(org-defkey org-agenda-mode-map "$" 'org-agenda-archive) +(org-defkey org-agenda-mode-map "\C-c\C-o" 'org-agenda-open-link) +(org-defkey org-agenda-mode-map " " 'org-agenda-show-and-scroll-up) +(org-defkey org-agenda-mode-map [backspace] 'org-agenda-show-scroll-down) +(org-defkey org-agenda-mode-map "\d" 'org-agenda-show-scroll-down) +(org-defkey org-agenda-mode-map [(control shift right)] 'org-agenda-todo-nextset) +(org-defkey org-agenda-mode-map [(control shift left)] 'org-agenda-todo-previousset) +(org-defkey org-agenda-mode-map "\C-c\C-xb" 'org-agenda-tree-to-indirect-buffer) +(org-defkey org-agenda-mode-map "o" 'delete-other-windows) +(org-defkey org-agenda-mode-map "L" 'org-agenda-recenter) +(org-defkey org-agenda-mode-map "\C-c\C-t" 'org-agenda-todo) +(org-defkey org-agenda-mode-map "t" 'org-agenda-todo) +(org-defkey org-agenda-mode-map "a" 'org-agenda-archive-default-with-confirmation) +(org-defkey org-agenda-mode-map ":" 'org-agenda-set-tags) +(org-defkey org-agenda-mode-map "\C-c\C-q" 'org-agenda-set-tags) +(org-defkey org-agenda-mode-map "." 'org-agenda-goto-today) +(org-defkey org-agenda-mode-map "j" 'org-agenda-goto-date) +(org-defkey org-agenda-mode-map "d" 'org-agenda-day-view) +(org-defkey org-agenda-mode-map "w" 'org-agenda-week-view) +(org-defkey org-agenda-mode-map "y" 'org-agenda-year-view) +(org-defkey org-agenda-mode-map "\C-c\C-z" 'org-agenda-add-note) +(org-defkey org-agenda-mode-map "z" 'org-agenda-add-note) +(org-defkey org-agenda-mode-map "k" 'org-agenda-action) +(org-defkey org-agenda-mode-map "\C-c\C-x\C-k" 'org-agenda-action) +(org-defkey org-agenda-mode-map [(shift right)] 'org-agenda-do-date-later) +(org-defkey org-agenda-mode-map [(shift left)] 'org-agenda-do-date-earlier) +(org-defkey org-agenda-mode-map [?\C-c ?\C-x (right)] 'org-agenda-do-date-later) +(org-defkey org-agenda-mode-map [?\C-c ?\C-x (left)] 'org-agenda-do-date-earlier) + +(org-defkey org-agenda-mode-map ">" 'org-agenda-date-prompt) +(org-defkey org-agenda-mode-map "\C-c\C-s" 'org-agenda-schedule) +(org-defkey org-agenda-mode-map "\C-c\C-d" 'org-agenda-deadline) +(let ((l '(1 2 3 4 5 6 7 8 9 0))) + (while l (org-defkey org-agenda-mode-map + (int-to-string (pop l)) 'digit-argument))) + +(org-defkey org-agenda-mode-map "F" 'org-agenda-follow-mode) +(org-defkey org-agenda-mode-map "R" 'org-agenda-clockreport-mode) +(org-defkey org-agenda-mode-map "E" 'org-agenda-entry-text-mode) +(org-defkey org-agenda-mode-map "l" 'org-agenda-log-mode) +(org-defkey org-agenda-mode-map "v" 'org-agenda-view-mode-dispatch) +(org-defkey org-agenda-mode-map "D" 'org-agenda-toggle-diary) +(org-defkey org-agenda-mode-map "!" 'org-agenda-toggle-deadlines) +(org-defkey org-agenda-mode-map "G" 'org-agenda-toggle-time-grid) +(org-defkey org-agenda-mode-map "r" 'org-agenda-redo) +(org-defkey org-agenda-mode-map "g" 'org-agenda-redo) +(org-defkey org-agenda-mode-map "e" 'org-agenda-set-effort) +(org-defkey org-agenda-mode-map "\C-c\C-xe" 'org-agenda-set-effort) +(org-defkey org-agenda-mode-map "\C-c\C-x\C-e" + 'org-clock-modify-effort-estimate) +(org-defkey org-agenda-mode-map "\C-c\C-xp" 'org-agenda-set-property) +(org-defkey org-agenda-mode-map "q" 'org-agenda-quit) +(org-defkey org-agenda-mode-map "x" 'org-agenda-exit) +(org-defkey org-agenda-mode-map "\C-x\C-w" 'org-write-agenda) +(org-defkey org-agenda-mode-map "\C-x\C-s" 'org-save-all-org-buffers) +(org-defkey org-agenda-mode-map "s" 'org-save-all-org-buffers) +(org-defkey org-agenda-mode-map "P" 'org-agenda-show-priority) +(org-defkey org-agenda-mode-map "T" 'org-agenda-show-tags) +(org-defkey org-agenda-mode-map "n" 'org-agenda-next-line) +(org-defkey org-agenda-mode-map "p" 'org-agenda-previous-line) +(substitute-key-definition 'next-line 'org-agenda-next-line + org-agenda-mode-map global-map) +(substitute-key-definition 'previous-line 'org-agenda-previous-line + org-agenda-mode-map global-map) +(org-defkey org-agenda-mode-map "\C-c\C-a" 'org-attach) +(org-defkey org-agenda-mode-map "\C-c\C-n" 'org-agenda-next-date-line) +(org-defkey org-agenda-mode-map "\C-c\C-p" 'org-agenda-previous-date-line) +(org-defkey org-agenda-mode-map "," 'org-agenda-priority) +(org-defkey org-agenda-mode-map "\C-c," 'org-agenda-priority) +(org-defkey org-agenda-mode-map "i" 'org-agenda-diary-entry) +(org-defkey org-agenda-mode-map "c" 'org-agenda-goto-calendar) +(org-defkey org-agenda-mode-map "C" 'org-agenda-convert-date) +(org-defkey org-agenda-mode-map "M" 'org-agenda-phases-of-moon) +(org-defkey org-agenda-mode-map "S" 'org-agenda-sunrise-sunset) +(org-defkey org-agenda-mode-map "h" 'org-agenda-holidays) +(org-defkey org-agenda-mode-map "H" 'org-agenda-holidays) +(org-defkey org-agenda-mode-map "\C-c\C-x\C-i" 'org-agenda-clock-in) +(org-defkey org-agenda-mode-map "I" 'org-agenda-clock-in) +(org-defkey org-agenda-mode-map "\C-c\C-x\C-o" 'org-agenda-clock-out) +(org-defkey org-agenda-mode-map "O" 'org-agenda-clock-out) +(org-defkey org-agenda-mode-map "\C-c\C-x\C-x" 'org-agenda-clock-cancel) +(org-defkey org-agenda-mode-map "X" 'org-agenda-clock-cancel) +(org-defkey org-agenda-mode-map "\C-c\C-x\C-j" 'org-clock-goto) +(org-defkey org-agenda-mode-map "J" 'org-agenda-clock-goto) +(org-defkey org-agenda-mode-map "+" 'org-agenda-priority-up) +(org-defkey org-agenda-mode-map "-" 'org-agenda-priority-down) +(org-defkey org-agenda-mode-map [(shift up)] 'org-agenda-priority-up) +(org-defkey org-agenda-mode-map [(shift down)] 'org-agenda-priority-down) +(org-defkey org-agenda-mode-map [?\C-c ?\C-x (up)] 'org-agenda-priority-up) +(org-defkey org-agenda-mode-map [?\C-c ?\C-x (down)] 'org-agenda-priority-down) +(org-defkey org-agenda-mode-map "f" 'org-agenda-later) +(org-defkey org-agenda-mode-map "b" 'org-agenda-earlier) +(org-defkey org-agenda-mode-map "\C-c\C-x\C-c" 'org-agenda-columns) +(org-defkey org-agenda-mode-map "\C-c\C-x>" 'org-agenda-remove-restriction-lock) + +(org-defkey org-agenda-mode-map "[" 'org-agenda-manipulate-query-add) +(org-defkey org-agenda-mode-map "]" 'org-agenda-manipulate-query-subtract) +(org-defkey org-agenda-mode-map "{" 'org-agenda-manipulate-query-add-re) +(org-defkey org-agenda-mode-map "}" 'org-agenda-manipulate-query-subtract-re) +(org-defkey org-agenda-mode-map "/" 'org-agenda-filter-by-tag) +(org-defkey org-agenda-mode-map "\\" 'org-agenda-filter-by-tag-refine) +(org-defkey org-agenda-mode-map ";" 'org-timer-set-timer) +(define-key org-agenda-mode-map "?" 'org-agenda-show-the-flagging-note) +(org-defkey org-agenda-mode-map "\C-c\C-x\C-mg" 'org-mobile-pull) +(org-defkey org-agenda-mode-map "\C-c\C-x\C-mp" 'org-mobile-push) + +(org-defkey org-agenda-mode-map [mouse-2] 'org-agenda-goto-mouse) +(org-defkey org-agenda-mode-map [mouse-3] 'org-agenda-show-mouse) +(when org-agenda-mouse-1-follows-link + (org-defkey org-agenda-mode-map [follow-link] 'mouse-face)) +(easy-menu-define org-agenda-menu org-agenda-mode-map "Agenda menu" + '("Agenda" + ("Agenda Files") + "--" + ("Agenda Dates" + ["Goto Today" org-agenda-goto-today (org-agenda-check-type nil 'agenda 'timeline)] + ["Next Dates" org-agenda-later (org-agenda-check-type nil 'agenda)] + ["Previous Dates" org-agenda-earlier (org-agenda-check-type nil 'agenda)] + ["Jump to date" org-agenda-goto-date (org-agenda-check-type nil 'agenda)]) + "--" + ("View" + ["Day View" org-agenda-day-view + :active (org-agenda-check-type nil 'agenda) + :style radio :selected (eq org-agenda-current-span 'day) + :keys "v d (or just d)"] + ["Week View" org-agenda-week-view + :active (org-agenda-check-type nil 'agenda) + :style radio :selected (eq org-agenda-current-span 'week) + :keys "v w (or just w)"] + ["Month View" org-agenda-month-view + :active (org-agenda-check-type nil 'agenda) + :style radio :selected (eq org-agenda-current-span 'month) + :keys "v m"] + ["Year View" org-agenda-year-view + :active (org-agenda-check-type nil 'agenda) + :style radio :selected (eq org-agenda-current-span 'year) + :keys "v y"] + "--" + ["Include Diary" org-agenda-toggle-diary + :style toggle :selected org-agenda-include-diary + :active (org-agenda-check-type nil 'agenda)] + ["Include Deadlines" org-agenda-toggle-deadlines + :style toggle :selected org-agenda-include-deadlines + :active (org-agenda-check-type nil 'agenda)] + ["Use Time Grid" org-agenda-toggle-time-grid + :style toggle :selected org-agenda-use-time-grid + :active (org-agenda-check-type nil 'agenda)] + "--" + ["Show clock report" org-agenda-clockreport-mode + :style toggle :selected org-agenda-clockreport-mode + :active (org-agenda-check-type nil 'agenda)] + ["Show some entry text" org-agenda-entry-text-mode + :style toggle :selected org-agenda-entry-text-mode + :active t] + "--" + ["Show Logbook entries" org-agenda-log-mode + :style toggle :selected org-agenda-show-log + :active (org-agenda-check-type nil 'agenda 'timeline) + :keys "v l (or just l)"] + ["Include archived trees" org-agenda-archives-mode + :style toggle :selected org-agenda-archives-mode :active t + :keys "v a"] + ["Include archive files" (org-agenda-archives-mode t) + :style toggle :selected (eq org-agenda-archives-mode t) :active t + :keys "v A"] + "--" + ["Remove Restriction" org-agenda-remove-restriction-lock org-agenda-restrict]) + ["Write view to file" org-write-agenda t] + ["Rebuild buffer" org-agenda-redo t] + ["Save all Org-mode Buffers" org-save-all-org-buffers t] + "--" + ["Show original entry" org-agenda-show t] + ["Go To (other window)" org-agenda-goto t] + ["Go To (this window)" org-agenda-switch-to t] + ["Follow Mode" org-agenda-follow-mode + :style toggle :selected org-agenda-follow-mode :active t] +; ["Tree to indirect frame" org-agenda-tree-to-indirect-buffer t] + "--" + ("TODO" + ["Cycle TODO" org-agenda-todo t] + ["Next TODO set" org-agenda-todo-nextset t] + ["Previous TODO set" org-agenda-todo-previousset t] + ["Add note" org-agenda-add-note t]) + ("Archive/Refile/Delete" + ["Archive default" org-agenda-archive-default t] + ["Archive default" org-agenda-archive-default-with-confirmation t] + ["Toggle ARCHIVE tag" org-agenda-toggle-archive-tag t] + ["Move to archive sibling" org-agenda-archive-to-archive-sibling t] + ["Archive subtree" org-agenda-archive t] + "--" + ["Refile" org-agenda-refile t] + "--" + ["Delete subtree" org-agenda-kill t]) + ("Bulk action" + ["Mark entry" org-agenda-bulk-mark t] + ["Unmark entry" org-agenda-bulk-unmark t] + ["Act on all marked" org-agenda-bulk-action t] + ["Unmark all entries" org-agenda-bulk-remove-all-marks :active t :keys "C-u s"]) + "--" + ("Tags and Properties" + ["Show all Tags" org-agenda-show-tags t] + ["Set Tags current line" org-agenda-set-tags (not (org-region-active-p))] + ["Change tag in region" org-agenda-set-tags (org-region-active-p)] + "--" + ["Column View" org-columns t]) + ("Deadline/Schedule" + ["Schedule" org-agenda-schedule t] + ["Set Deadline" org-agenda-deadline t] + "--" + ["Mark item" org-agenda-action :active t :keys "k m"] + ["Show mark item" org-agenda-action :active t :keys "k v"] + ["Schedule marked item" org-agenda-action :active t :keys "k s"] + ["Set Deadline for marked item" org-agenda-action :active t :keys "k d"] + "--" + ["Change Date +1 day" org-agenda-date-later (org-agenda-check-type nil 'agenda 'timeline)] + ["Change Date -1 day" org-agenda-date-earlier (org-agenda-check-type nil 'agenda 'timeline)] + ["Change Time +1 hour" org-agenda-do-date-later :active (org-agenda-check-type nil 'agenda 'timeline) :keys "C-u S-right"] + ["Change Time -1 hour" org-agenda-do-date-earlier :active (org-agenda-check-type nil 'agenda 'timeline) :keys "C-u S-left"] + ["Change Time + min" org-agenda-date-later :active (org-agenda-check-type nil 'agenda 'timeline) :keys "C-u C-u S-right"] + ["Change Time - min" org-agenda-date-earlier :active (org-agenda-check-type nil 'agenda 'timeline) :keys "C-u C-u S-left"] + ["Change Date to ..." org-agenda-date-prompt (org-agenda-check-type nil 'agenda 'timeline)]) + ("Clock and Effort" + ["Clock in" org-agenda-clock-in t] + ["Clock out" org-agenda-clock-out t] + ["Clock cancel" org-agenda-clock-cancel t] + ["Goto running clock" org-clock-goto t] + "--" + ["Set Effort" org-agenda-set-effort t] + ["Change clocked effort" org-clock-modify-effort-estimate + (org-clock-is-active)]) + ("Priority" + ["Set Priority" org-agenda-priority t] + ["Increase Priority" org-agenda-priority-up t] + ["Decrease Priority" org-agenda-priority-down t] + ["Show Priority" org-agenda-show-priority t]) + ("Calendar/Diary" + ["New Diary Entry" org-agenda-diary-entry (org-agenda-check-type nil 'agenda 'timeline)] + ["Goto Calendar" org-agenda-goto-calendar (org-agenda-check-type nil 'agenda 'timeline)] + ["Phases of the Moon" org-agenda-phases-of-moon (org-agenda-check-type nil 'agenda 'timeline)] + ["Sunrise/Sunset" org-agenda-sunrise-sunset (org-agenda-check-type nil 'agenda 'timeline)] + ["Holidays" org-agenda-holidays (org-agenda-check-type nil 'agenda 'timeline)] + ["Convert" org-agenda-convert-date (org-agenda-check-type nil 'agenda 'timeline)] + "--" + ["Create iCalendar File" org-export-icalendar-combine-agenda-files t]) + "--" + ["Undo Remote Editing" org-agenda-undo org-agenda-undo-list] + "--" + ("MobileOrg" + ["Push Files and Views" org-mobile-push t] + ["Get Captured and Flagged" org-mobile-pull t] + ["Find FLAGGED Tasks" (org-agenda nil "?") :active t :keys "C-c a ?"] + ["Show note / unflag" org-agenda-show-the-flagging-note t] + "--" + ["Setup" (progn (require 'org-mobile) (customize-group 'org-mobile)) t]) + "--" + ["Quit" org-agenda-quit t] + ["Exit and Release Buffers" org-agenda-exit t] + )) + +;;; Agenda undo + +(defvar org-agenda-allow-remote-undo t + "Non-nil means allow remote undo from the agenda buffer.") +(defvar org-agenda-undo-list nil + "List of undoable operations in the agenda since last refresh.") +(defvar org-agenda-undo-has-started-in nil + "Buffers that have already seen `undo-start' in the current undo sequence.") +(defvar org-agenda-pending-undo-list nil + "In a series of undo commands, this is the list of remaining undo items.") + + +(defun org-agenda-undo () + "Undo a remote editing step in the agenda. +This undoes changes both in the agenda buffer and in the remote buffer +that have been changed along." + (interactive) + (or org-agenda-allow-remote-undo + (error "Check the variable `org-agenda-allow-remote-undo' to activate remote undo")) + (if (not (eq this-command last-command)) + (setq org-agenda-undo-has-started-in nil + org-agenda-pending-undo-list org-agenda-undo-list)) + (if (not org-agenda-pending-undo-list) + (error "No further undo information")) + (let* ((entry (pop org-agenda-pending-undo-list)) + buf line cmd rembuf) + (setq cmd (pop entry) line (pop entry)) + (setq rembuf (nth 2 entry)) + (org-with-remote-undo rembuf + (while (bufferp (setq buf (pop entry))) + (if (pop entry) + (with-current-buffer buf + (let ((last-undo-buffer buf) + (inhibit-read-only t)) + (unless (memq buf org-agenda-undo-has-started-in) + (push buf org-agenda-undo-has-started-in) + (make-local-variable 'pending-undo-list) + (undo-start)) + (while (and pending-undo-list + (listp pending-undo-list) + (not (car pending-undo-list))) + (pop pending-undo-list)) + (undo-more 1)))))) + (org-goto-line line) + (message "`%s' undone (buffer %s)" cmd (buffer-name rembuf)))) + +(defun org-verify-change-for-undo (l1 l2) + "Verify that a real change occurred between the undo lists L1 and L2." + (while (and l1 (listp l1) (null (car l1))) (pop l1)) + (while (and l2 (listp l2) (null (car l2))) (pop l2)) + (not (eq l1 l2))) + +;;; Agenda dispatch + +(defvar org-agenda-restrict nil) +(defvar org-agenda-restrict-begin (make-marker)) +(defvar org-agenda-restrict-end (make-marker)) +(defvar org-agenda-last-dispatch-buffer nil) +(defvar org-agenda-overriding-restriction nil) + +;;;###autoload +(defun org-agenda (&optional arg keys restriction) + "Dispatch agenda commands to collect entries to the agenda buffer. +Prompts for a command to execute. Any prefix arg will be passed +on to the selected command. The default selections are: + +a Call `org-agenda-list' to display the agenda for current day or week. +t Call `org-todo-list' to display the global todo list. +T Call `org-todo-list' to display the global todo list, select only + entries with a specific TODO keyword (the user gets a prompt). +m Call `org-tags-view' to display headlines with tags matching + a condition (the user is prompted for the condition). +M Like `m', but select only TODO entries, no ordinary headlines. +L Create a timeline for the current buffer. +e Export views to associated files. +s Search entries for keywords. +/ Multi occur across all agenda files and also files listed + in `org-agenda-text-search-extra-files'. +< Restrict agenda commands to buffer, subtree, or region. + Press several times to get the desired effect. +> Remove a previous restriction. +# List \"stuck\" projects. +! Configure what \"stuck\" means. +C Configure custom agenda commands. + +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 `<' once to indicate that the agenda should be temporarily +\(until the next use of \\[org-agenda]) restricted to the current file. +Pressing `<' twice means to restrict to the current subtree or region +\(if active)." + (interactive "P") + (catch 'exit + (let* ((prefix-descriptions nil) + (org-agenda-window-setup (if (equal (buffer-name) + org-agenda-buffer-name) + 'current-window + org-agenda-window-setup)) + (org-agenda-custom-commands-orig org-agenda-custom-commands) + (org-agenda-custom-commands + ;; normalize different versions + (delq nil + (mapcar + (lambda (x) + (cond ((stringp (cdr x)) + (push x prefix-descriptions) + nil) + ((stringp (nth 1 x)) x) + ((not (nth 1 x)) (cons (car x) (cons "" (cddr x)))) + (t (cons (car x) (cons "" (cdr x)))))) + org-agenda-custom-commands))) + (buf (current-buffer)) + (bfn (buffer-file-name (buffer-base-buffer))) + entry key type match lprops ans) + ;; Turn off restriction unless there is an overriding one, + (unless org-agenda-overriding-restriction + (unless (org-bound-and-true-p org-agenda-keep-restricted-file-list) + ;; There is a request to keep the file list in place + (put 'org-agenda-files 'org-restrict nil)) + (setq org-agenda-restrict nil) + (move-marker org-agenda-restrict-begin nil) + (move-marker org-agenda-restrict-end nil)) + ;; Delete old local properties + (put 'org-agenda-redo-command 'org-lprops nil) + ;; Remember where this call originated + (setq org-agenda-last-dispatch-buffer (current-buffer)) + (unless keys + (setq ans (org-agenda-get-restriction-and-command prefix-descriptions) + keys (car ans) + restriction (cdr ans))) + ;; Establish the restriction, if any + (when (and (not org-agenda-overriding-restriction) restriction) + (put 'org-agenda-files 'org-restrict (list bfn)) + (cond + ((eq restriction 'region) + (setq org-agenda-restrict t) + (move-marker org-agenda-restrict-begin (region-beginning)) + (move-marker org-agenda-restrict-end (region-end))) + ((eq restriction 'subtree) + (save-excursion + (setq org-agenda-restrict t) + (org-back-to-heading t) + (move-marker org-agenda-restrict-begin (point)) + (move-marker org-agenda-restrict-end + (progn (org-end-of-subtree t))))))) + + ;; For example the todo list should not need it (but does...) + (cond + ((setq entry (assoc keys org-agenda-custom-commands)) + (if (or (symbolp (nth 2 entry)) (functionp (nth 2 entry))) + (progn + (setq type (nth 2 entry) match (eval (nth 3 entry)) + lprops (nth 4 entry)) + (put 'org-agenda-redo-command 'org-lprops lprops) + (cond + ((eq type 'agenda) + (org-let lprops '(org-agenda-list current-prefix-arg))) + ((eq type 'alltodo) + (org-let lprops '(org-todo-list current-prefix-arg))) + ((eq type 'search) + (org-let lprops '(org-search-view current-prefix-arg match nil))) + ((eq type 'stuck) + (org-let lprops '(org-agenda-list-stuck-projects + current-prefix-arg))) + ((eq type 'tags) + (org-let lprops '(org-tags-view current-prefix-arg match))) + ((eq type 'tags-todo) + (org-let lprops '(org-tags-view '(4) match))) + ((eq type 'todo) + (org-let lprops '(org-todo-list match))) + ((eq type 'tags-tree) + (org-check-for-org-mode) + (org-let lprops '(org-match-sparse-tree current-prefix-arg match))) + ((eq type 'todo-tree) + (org-check-for-org-mode) + (org-let lprops + '(org-occur (concat "^" outline-regexp "[ \t]*" + (regexp-quote match) "\\>")))) + ((eq type 'occur-tree) + (org-check-for-org-mode) + (org-let lprops '(org-occur match))) + ((functionp type) + (org-let lprops '(funcall type match))) + ((fboundp type) + (org-let lprops '(funcall type match))) + (t (error "Invalid custom agenda command type %s" type)))) + (org-run-agenda-series (nth 1 entry) (cddr entry)))) + ((equal keys "C") + (setq org-agenda-custom-commands org-agenda-custom-commands-orig) + (customize-variable 'org-agenda-custom-commands)) + ((equal keys "a") (call-interactively 'org-agenda-list)) + ((equal keys "s") (call-interactively 'org-search-view)) + ((equal keys "t") (call-interactively 'org-todo-list)) + ((equal keys "T") (org-call-with-arg 'org-todo-list (or arg '(4)))) + ((equal keys "m") (call-interactively 'org-tags-view)) + ((equal keys "M") (org-call-with-arg 'org-tags-view (or arg '(4)))) + ((equal keys "e") (call-interactively 'org-store-agenda-views)) + ((equal keys "?") (org-tags-view nil "+FLAGGED") + (org-add-hook + 'post-command-hook + (lambda () + (unless (current-message) + (let* ((m (org-agenda-get-any-marker)) + (note (and m (org-entry-get m "THEFLAGGINGNOTE")))) + (when note + (message (concat + "FLAGGING-NOTE ([?] for more info): " + (org-add-props + (replace-regexp-in-string + "\\\\n" "//" + (copy-sequence note)) + nil 'face 'org-warning))))))) + t t)) + ((equal keys "L") + (unless (org-mode-p) + (error "This is not an Org-mode file")) + (unless restriction + (put 'org-agenda-files 'org-restrict (list bfn)) + (org-call-with-arg 'org-timeline arg))) + ((equal keys "#") (call-interactively 'org-agenda-list-stuck-projects)) + ((equal keys "/") (call-interactively 'org-occur-in-agenda-files)) + ((equal keys "!") (customize-variable 'org-stuck-projects)) + (t (error "Invalid agenda key")))))) + +(defun org-agenda-normalize-custom-commands (cmds) + (delq nil + (mapcar + (lambda (x) + (cond ((stringp (cdr x)) nil) + ((stringp (nth 1 x)) x) + ((not (nth 1 x)) (cons (car x) (cons "" (cddr x)))) + (t (cons (car x) (cons "" (cdr x)))))) + cmds))) + +(defun org-agenda-get-restriction-and-command (prefix-descriptions) + "The user interface for selecting an agenda command." + (catch 'exit + (let* ((bfn (buffer-file-name (buffer-base-buffer))) + (restrict-ok (and bfn (org-mode-p))) + (region-p (org-region-active-p)) + (custom org-agenda-custom-commands) + (selstring "") + restriction second-time + c entry key type match prefixes rmheader header-end custom1 desc + line lines left right n n1) + (save-window-excursion + (delete-other-windows) + (org-switch-to-buffer-other-window " *Agenda Commands*") + (erase-buffer) + (insert (eval-when-compile + (let ((header +" +Press key for an agenda command: < Buffer, subtree/region restriction +-------------------------------- > Remove restriction +a Agenda for current week or day e Export agenda views +t List of all TODO entries T Entries with special TODO kwd +m Match a TAGS/PROP/TODO query M Like m, but only TODO entries +L Timeline for current buffer # List stuck projects (!=configure) +s Search for keywords C Configure custom agenda commands +/ Multi-occur ? Find :FLAGGED: entries +") + (start 0)) + (while (string-match + "\\(^\\| \\|(\\)\\(\\S-\\)\\( \\|=\\)" + header start) + (setq start (match-end 0)) + (add-text-properties (match-beginning 2) (match-end 2) + '(face bold) header)) + header))) + (setq header-end (move-marker (make-marker) (point))) + (while t + (setq custom1 custom) + (when (eq rmheader t) + (org-goto-line 1) + (re-search-forward ":" nil t) + (delete-region (match-end 0) (point-at-eol)) + (forward-char 1) + (looking-at "-+") + (delete-region (match-end 0) (point-at-eol)) + (move-marker header-end (match-end 0))) + (goto-char header-end) + (delete-region (point) (point-max)) + + ;; Produce all the lines that describe custom commands and prefixes + (setq lines nil) + (while (setq entry (pop custom1)) + (setq key (car entry) desc (nth 1 entry) + type (nth 2 entry) + match (nth 3 entry)) + (if (> (length key) 1) + (add-to-list 'prefixes (string-to-char key)) + (setq line + (format + "%-4s%-14s" + (org-add-props (copy-sequence key) + '(face bold)) + (cond + ((string-match "\\S-" desc) desc) + ((eq type 'agenda) "Agenda for current week or day") + ((eq type 'alltodo) "List of all TODO entries") + ((eq type 'search) "Word search") + ((eq type 'stuck) "List of stuck projects") + ((eq type 'todo) "TODO keyword") + ((eq type 'tags) "Tags query") + ((eq type 'tags-todo) "Tags (TODO)") + ((eq type 'tags-tree) "Tags tree") + ((eq type 'todo-tree) "TODO kwd tree") + ((eq type 'occur-tree) "Occur tree") + ((functionp type) (if (symbolp type) + (symbol-name type) + "Lambda expression")) + (t "???")))) + (if org-agenda-menu-show-matcher + (setq line + (concat line ": " + (cond + ((stringp match) + (setq match (copy-sequence match)) + (org-add-props match nil 'face 'org-warning)) + (match + (format "set of %d commands" (length match))) + (t "")))) + (if (org-string-nw-p match) + (add-text-properties + 0 (length line) (list 'help-echo + (concat "Matcher: "match)) line))) + (push line lines))) + (setq lines (nreverse lines)) + (when prefixes + (mapc (lambda (x) + (push + (format "%s %s" + (org-add-props (char-to-string x) + nil 'face 'bold) + (or (cdr (assoc (concat selstring + (char-to-string x)) + prefix-descriptions)) + "Prefix key")) + lines)) + prefixes)) + + ;; Check if we should display in two columns + (if org-agenda-menu-two-column + (progn + (setq n (length lines) + n1 (+ (/ n 2) (mod n 2)) + right (nthcdr n1 lines) + left (copy-sequence lines)) + (setcdr (nthcdr (1- n1) left) nil)) + (setq left lines right nil)) + (while left + (insert "\n" (pop left)) + (when right + (if (< (current-column) 40) + (move-to-column 40 t) + (insert " ")) + (insert (pop right)))) + + ;; Make the window the right size + (goto-char (point-min)) + (if second-time + (if (not (pos-visible-in-window-p (point-max))) + (org-fit-window-to-buffer)) + (setq second-time t) + (org-fit-window-to-buffer)) + + ;; Ask for selection + (message "Press key for agenda command%s:" + (if (or restrict-ok org-agenda-overriding-restriction) + (if org-agenda-overriding-restriction + " (restriction lock active)" + (if restriction + (format " (restricted to %s)" restriction) + " (unrestricted)")) + "")) + (setq c (read-char-exclusive)) + (message "") + (cond + ((assoc (char-to-string c) custom) + (setq selstring (concat selstring (char-to-string c))) + (throw 'exit (cons selstring restriction))) + ((memq c prefixes) + (setq selstring (concat selstring (char-to-string c)) + prefixes nil + rmheader (or rmheader t) + custom (delq nil (mapcar + (lambda (x) + (if (or (= (length (car x)) 1) + (/= (string-to-char (car x)) c)) + nil + (cons (substring (car x) 1) (cdr x)))) + custom)))) + ((and (not restrict-ok) (memq c '(?1 ?0 ?<))) + (message "Restriction is only possible in Org-mode buffers") + (ding) (sit-for 1)) + ((eq c ?1) + (org-agenda-remove-restriction-lock 'noupdate) + (setq restriction 'buffer)) + ((eq c ?0) + (org-agenda-remove-restriction-lock 'noupdate) + (setq restriction (if region-p 'region 'subtree))) + ((eq c ?<) + (org-agenda-remove-restriction-lock 'noupdate) + (setq restriction + (cond + ((eq restriction 'buffer) + (if region-p 'region 'subtree)) + ((memq restriction '(subtree region)) + nil) + (t 'buffer)))) + ((eq c ?>) + (org-agenda-remove-restriction-lock 'noupdate) + (setq restriction nil)) + ((and (equal selstring "") (memq c '(?s ?a ?t ?m ?L ?C ?e ?T ?M ?# ?! ?/ ??))) + (throw 'exit (cons (setq selstring (char-to-string c)) restriction))) + ((and (> (length selstring) 0) (eq c ?\d)) + (delete-window) + (org-agenda-get-restriction-and-command prefix-descriptions)) + + ((equal c ?q) (error "Abort")) + (t (error "Invalid key %c" c)))))))) + +(defun org-run-agenda-series (name series) + (org-let (nth 1 series) '(org-prepare-agenda name)) + (let* ((org-agenda-multi t) + (redo (list 'org-run-agenda-series name (list 'quote series))) + (cmds (car series)) + (gprops (nth 1 series)) + match ;; The byte compiler incorrectly complains about this. Keep it! + cmd type lprops) + (while (setq cmd (pop cmds)) + (setq type (car cmd) match (eval (nth 1 cmd)) lprops (nth 2 cmd)) + (cond + ((eq type 'agenda) + (org-let2 gprops lprops + '(call-interactively 'org-agenda-list))) + ((eq type 'alltodo) + (org-let2 gprops lprops + '(call-interactively 'org-todo-list))) + ((eq type 'search) + (org-let2 gprops lprops + '(org-search-view current-prefix-arg match nil))) + ((eq type 'stuck) + (org-let2 gprops lprops + '(call-interactively 'org-agenda-list-stuck-projects))) + ((eq type 'tags) + (org-let2 gprops lprops + '(org-tags-view current-prefix-arg match))) + ((eq type 'tags-todo) + (org-let2 gprops lprops + '(org-tags-view '(4) match))) + ((eq type 'todo) + (org-let2 gprops lprops + '(org-todo-list match))) + ((fboundp type) + (org-let2 gprops lprops + '(funcall type match))) + (t (error "Invalid type in command series")))) + (widen) + (setq org-agenda-redo-command redo) + (goto-char (point-min))) + (org-fit-agenda-window) + (org-let (nth 1 series) '(org-finalize-agenda))) + +;;;###autoload +(defmacro org-batch-agenda (cmd-key &rest parameters) + "Run an agenda command in batch mode and send the result to STDOUT. +If CMD-KEY is a string of length 1, it is used as a key in +`org-agenda-custom-commands' and triggers this command. If it is a +longer string it is used as a tags/todo match string. +Parameters are alternating variable names and values that will be bound +before running the agenda command." + (let (pars) + (while parameters + (push (list (pop parameters) (if parameters (pop parameters))) pars)) + (if (> (length cmd-key) 2) + (eval (list 'let (nreverse pars) + (list 'org-tags-view nil cmd-key))) + (eval (list 'let (nreverse pars) (list 'org-agenda nil cmd-key)))) + (set-buffer org-agenda-buffer-name) + (princ (org-encode-for-stdout (buffer-string))))) + +;(defun org-encode-for-stdout (string) +; (if (fboundp 'encode-coding-string) +; (encode-coding-string string buffer-file-coding-system) +; string)) + +(defun org-encode-for-stdout (string) + string) + +(defvar org-agenda-info nil) + +;;;###autoload +(defmacro org-batch-agenda-csv (cmd-key &rest parameters) + "Run an agenda command in batch mode and send the result to STDOUT. +If CMD-KEY is a string of length 1, it is used as a key in +`org-agenda-custom-commands' and triggers this command. If it is a +longer string it is used as a tags/todo match string. +Parameters are alternating variable names and values that will be bound +before running the agenda command. + +The output gives a line for each selected agenda item. Each +item is a list of comma-separated values, like this: + +category,head,type,todo,tags,date,time,extra,priority-l,priority-n + +category The category of the item +head The headline, without TODO kwd, TAGS and PRIORITY +type The type of the agenda entry, can be + todo selected in TODO match + tagsmatch selected in tags match + diary imported from diary + deadline a deadline on given date + scheduled scheduled on given date + timestamp entry has timestamp on given date + closed entry was closed on given date + upcoming-deadline warning about deadline + past-scheduled forwarded scheduled item + block entry has date block including g. date +todo The todo keyword, if any +tags All tags including inherited ones, separated by colons +date The relevant date, like 2007-2-14 +time The time, like 15:00-16:50 +extra Sting with extra planning info +priority-l The priority letter if any was given +priority-n The computed numerical priority +agenda-day The day in the agenda where this is listed" + + (let (pars) + (while parameters + (push (list (pop parameters) (if parameters (pop parameters))) pars)) + (push (list 'org-agenda-remove-tags t) pars) + (if (> (length cmd-key) 2) + (eval (list 'let (nreverse pars) + (list 'org-tags-view nil cmd-key))) + (eval (list 'let (nreverse pars) (list 'org-agenda nil cmd-key)))) + (set-buffer org-agenda-buffer-name) + (let* ((lines (org-split-string (buffer-string) "\n")) + line) + (while (setq line (pop lines)) + (catch 'next + (if (not (get-text-property 0 'org-category line)) (throw 'next nil)) + (setq org-agenda-info + (org-fix-agenda-info (text-properties-at 0 line))) + (princ + (org-encode-for-stdout + (mapconcat 'org-agenda-export-csv-mapper + '(org-category txt type todo tags date time extra + priority-letter priority agenda-day) + ","))) + (princ "\n")))))) + +(defun org-fix-agenda-info (props) + "Make sure all properties on an agenda item have a canonical form. +This ensures the export commands can easily use it." + (let (tmp re) + (when (setq tmp (plist-get props 'tags)) + (setq props (plist-put props 'tags (mapconcat 'identity tmp ":")))) + (when (setq tmp (plist-get props 'date)) + (if (integerp tmp) (setq tmp (calendar-gregorian-from-absolute tmp))) + (let ((calendar-date-display-form '(year "-" month "-" day))) + '((format "%4d, %9s %2s, %4s" dayname monthname day year)) + + (setq tmp (calendar-date-string tmp))) + (setq props (plist-put props 'date tmp))) + (when (setq tmp (plist-get props 'day)) + (if (integerp tmp) (setq tmp (calendar-gregorian-from-absolute tmp))) + (let ((calendar-date-display-form '(year "-" month "-" day))) + (setq tmp (calendar-date-string tmp))) + (setq props (plist-put props 'day tmp)) + (setq props (plist-put props 'agenda-day tmp))) + (when (setq tmp (plist-get props 'txt)) + (when (string-match "\\[#\\([A-Z0-9]\\)\\] ?" tmp) + (plist-put props 'priority-letter (match-string 1 tmp)) + (setq tmp (replace-match "" t t tmp))) + (when (and (setq re (plist-get props 'org-todo-regexp)) + (setq re (concat "\\`\\.*" re " ?")) + (string-match re tmp)) + (plist-put props 'todo (match-string 1 tmp)) + (setq tmp (replace-match "" t t tmp))) + (plist-put props 'txt tmp))) + props) + +(defun org-agenda-export-csv-mapper (prop) + (let ((res (plist-get org-agenda-info prop))) + (setq res + (cond + ((not res) "") + ((stringp res) res) + (t (prin1-to-string res)))) + (while (string-match "," res) + (setq res (replace-match ";" t t res))) + (org-trim res))) + + +;;;###autoload +(defun org-store-agenda-views (&rest parameters) + (interactive) + (eval (list 'org-batch-store-agenda-views))) + +;; FIXME, why is this a macro????? +;;;###autoload +(defmacro org-batch-store-agenda-views (&rest parameters) + "Run all custom agenda commands that have a file argument." + (let ((cmds (org-agenda-normalize-custom-commands org-agenda-custom-commands)) + (pop-up-frames nil) + (dir default-directory) + pars cmd thiscmdkey files opts cmd-or-set) + (while parameters + (push (list (pop parameters) (if parameters (pop parameters))) pars)) + (setq pars (reverse pars)) + (save-window-excursion + (while cmds + (setq cmd (pop cmds) + thiscmdkey (car cmd) + cmd-or-set (nth 2 cmd) + opts (nth (if (listp cmd-or-set) 3 4) cmd) + files (nth (if (listp cmd-or-set) 4 5) cmd)) + (if (stringp files) (setq files (list files))) + (when files + (eval (list 'let (append org-agenda-exporter-settings opts pars) + (list 'org-agenda nil thiscmdkey))) + (set-buffer org-agenda-buffer-name) + (while files + (eval (list 'let (append org-agenda-exporter-settings opts pars) + (list 'org-write-agenda + (expand-file-name (pop files) dir) nil t)))) + (and (get-buffer org-agenda-buffer-name) + (kill-buffer org-agenda-buffer-name))))))) + +(defun org-agenda-mark-header-line (pos) + "Mark the line at POS as an agenda structure header." + (save-excursion + (goto-char pos) + (put-text-property (point-at-bol) (point-at-eol) + 'org-agenda-structural-header t) + (when org-agenda-title-append + (put-text-property (point-at-bol) (point-at-eol) + 'org-agenda-title-append org-agenda-title-append)))) + +(defvar org-mobile-creating-agendas) +(defun org-write-agenda (file &optional open nosettings) + "Write the current buffer (an agenda view) as a file. +Depending on the extension of the file name, plain text (.txt), +HTML (.html or .htm) or Postscript (.ps) is produced. +If the extension is .ics, run icalendar export over all files used +to construct the agenda and limit the export to entries listed in the +agenda now. +With prefix argument OPEN, open the new file immediately. +If NOSETTINGS is given, do not scope the settings of +`org-agenda-exporter-settings' into the export commands. This is used when +the settings have already been scoped and we do not wish to overrule other, +higher priority settings." + (interactive "FWrite agenda to file: \nP") + (if (not (file-writable-p file)) + (error "Cannot write agenda to file %s" file)) + (org-let (if nosettings nil org-agenda-exporter-settings) + '(save-excursion + (save-window-excursion + (org-agenda-mark-filtered-text) + (let ((bs (copy-sequence (buffer-string))) beg) + (org-agenda-unmark-filtered-text) + (with-temp-buffer + (rename-buffer "Agenda View" t) + (set-buffer-modified-p nil) + (insert bs) + (org-agenda-remove-marked-text 'org-filtered) + (while (setq beg (text-property-any (point-min) (point-max) + 'org-filtered t)) + (delete-region + beg (or (next-single-property-change beg 'org-filtered) + (point-max)))) + (run-hooks 'org-agenda-before-write-hook) + (cond + ((org-bound-and-true-p org-mobile-creating-agendas) + (org-mobile-write-agenda-for-mobile file)) + ((string-match "\\.html?\\'" file) + (require 'htmlize) + (set-buffer (htmlize-buffer (current-buffer))) + + (when (and org-agenda-export-html-style + (string-match "<style>" org-agenda-export-html-style)) + ;; replace <style> section with org-agenda-export-html-style + (goto-char (point-min)) + (kill-region (- (search-forward "<style") 6) + (search-forward "</style>")) + (insert org-agenda-export-html-style)) + (write-file file) + (kill-buffer (current-buffer)) + (message "HTML written to %s" file)) + ((string-match "\\.ps\\'" file) + (require 'ps-print) + (ps-print-buffer-with-faces file) + (message "Postscript written to %s" file)) + ((string-match "\\.pdf\\'" file) + (require 'ps-print) + (ps-print-buffer-with-faces + (concat (file-name-sans-extension file) ".ps")) + (call-process "ps2pdf" nil nil nil + (expand-file-name + (concat (file-name-sans-extension file) ".ps")) + (expand-file-name file)) + (delete-file (concat (file-name-sans-extension file) ".ps")) + (message "PDF written to %s" file)) + ((string-match "\\.ics\\'" file) + (require 'org-icalendar) + (let ((org-agenda-marker-table + (org-create-marker-find-array + (org-agenda-collect-markers))) + (org-icalendar-verify-function 'org-check-agenda-marker-table) + (org-combined-agenda-icalendar-file file)) + (apply 'org-export-icalendar 'combine + (org-agenda-files nil 'ifmode)))) + (t + (let ((bs (buffer-string))) + (find-file file) + (erase-buffer) + (insert bs) + (save-buffer 0) + (kill-buffer (current-buffer)) + (message "Plain text written to %s" file)))))))) + (set-buffer org-agenda-buffer-name)) + (when open (org-open-file file))) + +(defvar org-agenda-filter-overlays nil) + +(defun org-agenda-mark-filtered-text () + "Mark all text hidden by filtering with a text property." + (let ((inhibit-read-only t)) + (mapc + (lambda (o) + (when (equal (overlay-buffer o) (current-buffer)) + (put-text-property + (overlay-start o) (overlay-end o) + 'org-filtered t))) + org-agenda-filter-overlays))) + +(defun org-agenda-unmark-filtered-text () + "Remove the filtering text property." + (let ((inhibit-read-only t)) + (remove-text-properties (point-min) (point-max) '(org-filtered t)))) + +(defun org-agenda-remove-marked-text (property &optional value) + "Delete all text marked with VALUE of PROPERTY. +VALUE defaults to t." + (let (beg) + (setq value (or value t)) + (while (setq beg (text-property-any (point-min) (point-max) + property value)) + (delete-region + beg (or (next-single-property-change beg 'org-filtered) + (point-max)))))) + +(defun org-agenda-add-entry-text () + "Add entry text to agenda lines. +This will add a maximum of `org-agenda-add-entry-text-maxlines' lines of the +entry text following headings shown in the agenda. +Drawers will be excluded, also the line with scheduling/deadline info." + (when (and (> org-agenda-add-entry-text-maxlines 0) + (not (org-bound-and-true-p org-mobile-creating-agendas))) + (let (m txt) + (goto-char (point-min)) + (while (not (eobp)) + (if (not (setq m (org-get-at-bol 'org-hd-marker))) + (beginning-of-line 2) + (setq txt (org-agenda-get-some-entry-text + m org-agenda-add-entry-text-maxlines " > ")) + (end-of-line 1) + (if (string-match "\\S-" txt) + (insert "\n" txt) + (or (eobp) (forward-char 1)))))))) + +(defun org-agenda-get-some-entry-text (marker n-lines &optional indent + &rest keep) + "Extract entry text from MARKER, at most N-LINES lines. +This will ignore drawers etc, just get the text. +If INDENT is given, prefix every line with this string. If KEEP is +given, it is a list of symbols, defining stuff that should not be +removed from the entry content. Currently only `planning' is allowed here." + (let (txt drawer-re kwd-time-re ind) + (save-excursion + (with-current-buffer (marker-buffer marker) + (if (not (org-mode-p)) + (setq txt "") + (save-excursion + (save-restriction + (widen) + (goto-char marker) + (end-of-line 1) + (setq txt (buffer-substring + (min (1+ (point)) (point-max)) + (progn (outline-next-heading) (point))) + drawer-re org-drawer-regexp + kwd-time-re (concat "^[ \t]*" org-keyword-time-regexp + ".*\n?")) + (with-temp-buffer + (insert txt) + (when org-agenda-add-entry-text-descriptive-links + (goto-char (point-min)) + (while (org-activate-bracket-links (point-max)) + (add-text-properties (match-beginning 0) (match-end 0) + '(face org-link)))) + (goto-char (point-min)) + (while (re-search-forward org-bracket-link-regexp (point-max) t) + (set-text-properties (match-beginning 0) (match-end 0) + nil)) + (goto-char (point-min)) + (while (re-search-forward drawer-re nil t) + (delete-region + (match-beginning 0) + (progn (re-search-forward + "^[ \t]*:END:.*\n?" nil 'move) + (point)))) + (unless (member 'planning keep) + (goto-char (point-min)) + (while (re-search-forward kwd-time-re nil t) + (replace-match ""))) + (goto-char (point-min)) + (when org-agenda-entry-text-exclude-regexps + (let ((re-list org-agenda-entry-text-exclude-regexps) re) + (while (setq re (pop re-list)) + (goto-char (point-min)) + (while (re-search-forward re nil t) + (replace-match ""))))) + (goto-char (point-max)) + (skip-chars-backward " \t\n") + (if (looking-at "[ \t\n]+\\'") (replace-match "")) + + ;; find and remove min common indentation + (goto-char (point-min)) + (untabify (point-min) (point-max)) + (setq ind (org-get-indentation)) + (while (not (eobp)) + (unless (looking-at "[ \t]*$") + (setq ind (min ind (org-get-indentation)))) + (beginning-of-line 2)) + (goto-char (point-min)) + (while (not (eobp)) + (unless (looking-at "[ \t]*$") + (move-to-column ind) + (delete-region (point-at-bol) (point))) + (beginning-of-line 2)) + + (run-hooks 'org-agenda-entry-text-cleanup-hook) + + (goto-char (point-min)) + (when indent + (while (and (not (eobp)) (re-search-forward "^" nil t)) + (replace-match indent t t))) + (goto-char (point-min)) + (while (looking-at "[ \t]*\n") (replace-match "")) + (goto-char (point-max)) + (when (> (org-current-line) + n-lines) + (org-goto-line (1+ n-lines)) + (backward-char 1)) + (setq txt (buffer-substring (point-min) (point))))))))) + txt)) + +(defun org-agenda-collect-markers () + "Collect the markers pointing to entries in the agenda buffer." + (let (m markers) + (save-excursion + (goto-char (point-min)) + (while (not (eobp)) + (when (setq m (or (org-get-at-bol 'org-hd-marker) + (org-get-at-bol 'org-marker))) + (push m markers)) + (beginning-of-line 2))) + (nreverse markers))) + +(defun org-create-marker-find-array (marker-list) + "Create a alist of files names with all marker positions in that file." + (let (f tbl m a p) + (while (setq m (pop marker-list)) + (setq p (marker-position m) + f (buffer-file-name (or (buffer-base-buffer + (marker-buffer m)) + (marker-buffer m)))) + (if (setq a (assoc f tbl)) + (push (marker-position m) (cdr a)) + (push (list f p) tbl))) + (mapcar (lambda (x) (setcdr x (sort (copy-sequence (cdr x)) '<)) x) + tbl))) + +(defvar org-agenda-marker-table nil) ; dynamically scoped parameter +(defun org-check-agenda-marker-table () + "Check of the current entry is on the marker list." + (let ((file (buffer-file-name (or (buffer-base-buffer) (current-buffer)))) + a) + (and (setq a (assoc file org-agenda-marker-table)) + (save-match-data + (save-excursion + (org-back-to-heading t) + (member (point) (cdr a))))))) + +(defun org-check-for-org-mode () + "Make sure current buffer is in org-mode. Error if not." + (or (org-mode-p) + (error "Cannot execute org-mode agenda command on buffer in %s" + major-mode))) + +(defun org-fit-agenda-window () + "Fit the window to the buffer size." + (and (memq org-agenda-window-setup '(reorganize-frame)) + (fboundp 'fit-window-to-buffer) + (org-fit-window-to-buffer + nil + (floor (* (frame-height) (cdr org-agenda-window-frame-fractions))) + (floor (* (frame-height) (car org-agenda-window-frame-fractions)))))) + +;;; Agenda prepare and finalize + +(defvar org-agenda-multi nil) ; dynamically scoped +(defvar org-agenda-buffer-name "*Org Agenda*") +(defvar org-pre-agenda-window-conf nil) +(defvar org-agenda-columns-active nil) +(defvar org-agenda-name nil) +(defvar org-agenda-filter nil) +(defvar org-agenda-filter-while-redo nil) +(defvar org-agenda-filter-preset nil + "A preset of the tags filter used for secondary agenda filtering. +This must be a list of strings, each string must be a single tag preceded +by \"+\" or \"-\". +This variable should not be set directly, but agenda custom commands can +bind it in the options section. The preset filter is a global property of +the entire agenda view. In a block agenda, it will not work reliably to +define a filter for one of the individual blocks. You need to set it in +the global options and expect it to be applied to the entire view.") + +(defun org-prepare-agenda (&optional name) + (setq org-todo-keywords-for-agenda nil) + (setq org-done-keywords-for-agenda nil) + (setq org-drawers-for-agenda nil) + (unless org-agenda-persistent-filter + (setq org-agenda-filter nil)) + (put 'org-agenda-filter :preset-filter org-agenda-filter-preset) + (if org-agenda-multi + (progn + (setq buffer-read-only nil) + (goto-char (point-max)) + (unless (or (bobp) org-agenda-compact-blocks) + (insert "\n" + (if (stringp org-agenda-block-separator) + org-agenda-block-separator + (make-string (window-width) org-agenda-block-separator)) + "\n")) + (narrow-to-region (point) (point-max))) + (org-agenda-reset-markers) + (setq org-agenda-contributing-files nil) + (setq org-agenda-columns-active nil) + (org-prepare-agenda-buffers (org-agenda-files nil 'ifmode)) + (setq org-todo-keywords-for-agenda + (org-uniquify org-todo-keywords-for-agenda)) + (setq org-done-keywords-for-agenda + (org-uniquify org-done-keywords-for-agenda)) + (setq org-drawers-for-agenda (org-uniquify org-drawers-for-agenda)) + (let* ((abuf (get-buffer-create org-agenda-buffer-name)) + (awin (get-buffer-window abuf))) + (cond + ((equal (current-buffer) abuf) nil) + (awin (select-window awin)) + ((not (setq org-pre-agenda-window-conf (current-window-configuration)))) + ((equal org-agenda-window-setup 'current-window) + (switch-to-buffer abuf)) + ((equal org-agenda-window-setup 'other-window) + (org-switch-to-buffer-other-window abuf)) + ((equal org-agenda-window-setup 'other-frame) + (switch-to-buffer-other-frame abuf)) + ((equal org-agenda-window-setup 'reorganize-frame) + (delete-other-windows) + (org-switch-to-buffer-other-window abuf))) + ;; additional test in case agenda is invoked from within agenda + ;; buffer via elisp link + (unless (equal (current-buffer) abuf) + (switch-to-buffer abuf))) + (setq buffer-read-only nil) + (let ((inhibit-read-only t)) (erase-buffer)) + (org-agenda-mode) + (and name (not org-agenda-name) + (org-set-local 'org-agenda-name name))) + (setq buffer-read-only nil)) + +(defun org-finalize-agenda () + "Finishing touch for the agenda buffer, called just before displaying it." + (unless org-agenda-multi + (save-excursion + (let ((inhibit-read-only t)) + (goto-char (point-min)) + (while (org-activate-bracket-links (point-max)) + (add-text-properties (match-beginning 0) (match-end 0) + '(face org-link))) + (org-agenda-align-tags) + (unless org-agenda-with-colors + (remove-text-properties (point-min) (point-max) '(face nil)))) + (if (and (boundp 'org-agenda-overriding-columns-format) + org-agenda-overriding-columns-format) + (org-set-local 'org-agenda-overriding-columns-format + org-agenda-overriding-columns-format)) + (if (and (boundp 'org-agenda-view-columns-initially) + org-agenda-view-columns-initially) + (org-agenda-columns)) + (when org-agenda-fontify-priorities + (org-agenda-fontify-priorities)) + (when (and org-agenda-dim-blocked-tasks org-blocker-hook) + (org-agenda-dim-blocked-tasks)) + (org-agenda-mark-clocking-task) + (when org-agenda-entry-text-mode + (org-agenda-entry-text-hide) + (org-agenda-entry-text-show)) + (if (functionp 'org-habit-insert-consistency-graphs) + (org-habit-insert-consistency-graphs)) + (run-hooks 'org-finalize-agenda-hook) + (setq org-agenda-type (org-get-at-bol 'org-agenda-type)) + (when (or org-agenda-filter (get 'org-agenda-filter :preset-filter)) + (org-agenda-filter-apply org-agenda-filter)) + ))) + +(defun org-agenda-mark-clocking-task () + "Mark the current clock entry in the agenda if it is present." + (mapc (lambda (o) + (if (eq (overlay-get o 'type) 'org-agenda-clocking) + (delete-overlay o))) + (overlays-in (point-min) (point-max))) + (when (marker-buffer org-clock-hd-marker) + (save-excursion + (goto-char (point-min)) + (let (s ov) + (while (setq s (next-single-property-change (point) 'org-hd-marker)) + (goto-char s) + (when (equal (org-get-at-bol 'org-hd-marker) + org-clock-hd-marker) + (setq ov (make-overlay (point-at-bol) (1+ (point-at-eol)))) + (overlay-put ov 'type 'org-agenda-clocking) + (overlay-put ov 'face 'org-agenda-clocking) + (overlay-put ov 'help-echo + "The clock is running in this item"))))))) + +(defun org-agenda-fontify-priorities () + "Make highest priority lines bold, and lowest italic." + (interactive) + (mapc (lambda (o) (if (eq (overlay-get o 'org-type) 'org-priority) + (delete-overlay o))) + (overlays-in (point-min) (point-max))) + (save-excursion + (let ((inhibit-read-only t) + b e p ov h l) + (goto-char (point-min)) + (while (re-search-forward "\\[#\\(.\\)\\]" nil t) + (setq h (or (get-char-property (point) 'org-highest-priority) + org-highest-priority) + l (or (get-char-property (point) 'org-lowest-priority) + org-lowest-priority) + p (string-to-char (match-string 1)) + b (match-beginning 0) + e (if (eq org-agenda-fontify-priorities 'cookies) + (match-end 0) + (point-at-eol)) + ov (make-overlay b e)) + (overlay-put + ov 'face + (cond ((org-face-from-face-or-color + 'priority nil + (cdr (assoc p org-priority-faces)))) + ((and (listp org-agenda-fontify-priorities) + (org-face-from-face-or-color + 'priority nil + (cdr (assoc p org-agenda-fontify-priorities))))) + ((equal p l) 'italic) + ((equal p h) 'bold))) + (overlay-put ov 'org-type 'org-priority))))) + +(defun org-agenda-dim-blocked-tasks () + "Dim currently blocked TODO's in the agenda display." + (mapc (lambda (o) (if (eq (overlay-get o 'org-type) 'org-blocked-todo) + (delete-overlay o))) + (overlays-in (point-min) (point-max))) + (save-excursion + (let ((inhibit-read-only t) + (org-depend-tag-blocked nil) + (invis (eq org-agenda-dim-blocked-tasks 'invisible)) + org-blocked-by-checkboxes + invis1 b e p ov h l) + (goto-char (point-min)) + (while (let ((pos (next-single-property-change (point) 'todo-state))) + (and pos (goto-char (1+ pos)))) + (setq org-blocked-by-checkboxes nil invis1 invis) + (let ((marker (org-get-at-bol 'org-hd-marker))) + (when (and marker + (not (with-current-buffer (marker-buffer marker) + (save-excursion + (goto-char marker) + (if (org-entry-get nil "NOBLOCKING") + t ;; Never block this entry + (run-hook-with-args-until-failure + 'org-blocker-hook + (list :type 'todo-state-change + :position marker + :from 'todo + :to 'done))))))) + (if org-blocked-by-checkboxes (setq invis1 nil)) + (setq b (if invis1 + (max (point-min) (1- (point-at-bol))) + (point-at-bol)) + e (point-at-eol) + ov (make-overlay b e)) + (if invis1 + (overlay-put ov 'invisible t) + (overlay-put ov 'face 'org-agenda-dimmed-todo-face)) + (overlay-put ov 'org-type 'org-blocked-todo))))))) + +(defvar org-agenda-skip-function nil + "Function to be called at each match during agenda construction. +If this function returns nil, the current match should not be skipped. +Otherwise, the function must return a position from where the search +should be continued. +This may also be a Lisp form, it will be evaluated. +Never set this variable using `setq' or so, because then it will apply +to all future agenda commands. Instead, bind it with `let' to scope +it dynamically into the agenda-constructing command. A good way to set +it is through options in `org-agenda-custom-commands'.") + +(defun org-agenda-skip () + "Throw to `:skip' in places that should be skipped. +Also moves point to the end of the skipped region, so that search can +continue from there." + (let ((p (point-at-bol)) to fp) + (and org-agenda-skip-archived-trees (not org-agenda-archives-mode) + (get-text-property p :org-archived) + (org-end-of-subtree t) + (throw :skip t)) + (and org-agenda-skip-comment-trees + (get-text-property p :org-comment) + (org-end-of-subtree t) + (throw :skip t)) + (if (equal (char-after p) ?#) (throw :skip t)) + (when (and (or (setq fp (functionp org-agenda-skip-function)) + (consp org-agenda-skip-function)) + (setq to (save-excursion + (save-match-data + (if fp + (funcall org-agenda-skip-function) + (eval org-agenda-skip-function)))))) + (goto-char to) + (throw :skip t)))) + +(defvar org-agenda-markers nil + "List of all currently active markers created by `org-agenda'.") +(defvar org-agenda-last-marker-time (org-float-time) + "Creation time of the last agenda marker.") + +(defun org-agenda-new-marker (&optional pos) + "Return a new agenda marker. +Org-mode keeps a list of these markers and resets them when they are +no longer in use." + (let ((m (copy-marker (or pos (point))))) + (setq org-agenda-last-marker-time (org-float-time)) + (push m org-agenda-markers) + m)) + +(defun org-agenda-reset-markers () + "Reset markers created by `org-agenda'." + (while org-agenda-markers + (move-marker (pop org-agenda-markers) nil))) + +(defun org-agenda-save-markers-for-cut-and-paste (beg end) + "Save relative positions of markers in region." + (mapc (lambda (m) (org-check-and-save-marker m beg end)) + org-agenda-markers)) + +;;; Entry text mode + +(defun org-agenda-entry-text-show-here () + "Add some text from the entry as context to the current line." + (let (m txt o) + (setq m (org-get-at-bol 'org-hd-marker)) + (unless (marker-buffer m) + (error "No marker points to an entry here")) + (setq txt (concat "\n" (org-no-properties + (org-agenda-get-some-entry-text + m org-agenda-entry-text-maxlines " > ")))) + (when (string-match "\\S-" txt) + (setq o (make-overlay (point-at-bol) (point-at-eol))) + (overlay-put o 'evaporate t) + (overlay-put o 'org-overlay-type 'agenda-entry-content) + (overlay-put o 'after-string txt)))) + +(defun org-agenda-entry-text-show () + "Add entry context for all agenda lines." + (interactive) + (save-excursion + (goto-char (point-max)) + (beginning-of-line 1) + (while (not (bobp)) + (when (org-get-at-bol 'org-hd-marker) + (org-agenda-entry-text-show-here)) + (beginning-of-line 0)))) + +(defun org-agenda-entry-text-hide () + "Remove any shown entry context." + (delq nil + (mapcar (lambda (o) + (if (eq (overlay-get o 'org-overlay-type) + 'agenda-entry-content) + (progn (delete-overlay o) t))) + (overlays-in (point-min) (point-max))))) + +(defun org-agenda-get-day-face (date) + "Return the face DATE should be displayed with." + (or (and (functionp org-agenda-day-face-function) + (funcall org-agenda-day-face-function date)) + (cond ((org-agenda-todayp date) + 'org-agenda-date-today) + ((member (calendar-day-of-week date) org-agenda-weekend-days) + 'org-agenda-date-weekend) + (t 'org-agenda-date)))) + +;;; Agenda timeline + +(defvar org-agenda-only-exact-dates nil) ; dynamically scoped + +(defun org-timeline (&optional include-all) + "Show a time-sorted view of the entries in the current org file. +Only entries with a time stamp of today or later will be listed. With +\\[universal-argument] prefix, all unfinished TODO items will also be shown, +under the current date. +If the buffer contains an active region, only check the region for +dates." + (interactive "P") + (org-compile-prefix-format 'timeline) + (org-set-sorting-strategy 'timeline) + (let* ((dopast t) + (dotodo include-all) + (doclosed org-agenda-show-log) + (entry (buffer-file-name (or (buffer-base-buffer (current-buffer)) + (current-buffer)))) + (date (calendar-current-date)) + (beg (if (org-region-active-p) (region-beginning) (point-min))) + (end (if (org-region-active-p) (region-end) (point-max))) + (day-numbers (org-get-all-dates beg end 'no-ranges + t doclosed ; always include today + org-timeline-show-empty-dates)) + (org-deadline-warning-days 0) + (org-agenda-only-exact-dates t) + (today (org-today)) + (past t) + args + s e rtn d emptyp) + (setq org-agenda-redo-command + (list 'progn + (list 'org-switch-to-buffer-other-window (current-buffer)) + (list 'org-timeline (list 'quote include-all)))) + (if (not dopast) + ;; Remove past dates from the list of dates. + (setq day-numbers (delq nil (mapcar (lambda(x) + (if (>= x today) x nil)) + day-numbers)))) + (org-prepare-agenda (concat "Timeline " (file-name-nondirectory entry))) + (if doclosed (push :closed args)) + (push :timestamp args) + (push :deadline args) + (push :scheduled args) + (push :sexp args) + (if dotodo (push :todo args)) + (insert "Timeline of file " entry "\n") + (add-text-properties (point-min) (point) + (list 'face 'org-agenda-structure)) + (org-agenda-mark-header-line (point-min)) + (while (setq d (pop day-numbers)) + (if (and (listp d) (eq (car d) :omitted)) + (progn + (setq s (point)) + (insert (format "\n[... %d empty days omitted]\n\n" (cdr d))) + (put-text-property s (1- (point)) 'face 'org-agenda-structure)) + (if (listp d) (setq d (car d) emptyp t) (setq emptyp nil)) + (if (and (>= d today) + dopast + past) + (progn + (setq past nil) + (insert (make-string 79 ?-) "\n"))) + (setq date (calendar-gregorian-from-absolute d)) + (setq s (point)) + (setq rtn (and (not emptyp) + (apply 'org-agenda-get-day-entries entry + date args))) + (if (or rtn (equal d today) org-timeline-show-empty-dates) + (progn + (insert + (if (stringp org-agenda-format-date) + (format-time-string org-agenda-format-date + (org-time-from-absolute date)) + (funcall org-agenda-format-date date)) + "\n") + (put-text-property s (1- (point)) 'face + (org-agenda-get-day-face date)) + (put-text-property s (1- (point)) 'org-date-line t) + (put-text-property s (1- (point)) 'org-agenda-date-header t) + (if (equal d today) + (put-text-property s (1- (point)) 'org-today t)) + (and rtn (insert (org-finalize-agenda-entries rtn) "\n")) + (put-text-property s (1- (point)) 'day d))))) + (goto-char (point-min)) + (goto-char (or (text-property-any (point-min) (point-max) 'org-today t) + (point-min))) + (add-text-properties (point-min) (point-max) '(org-agenda-type timeline)) + (org-finalize-agenda) + (setq buffer-read-only t))) + +(defun org-get-all-dates (beg end &optional no-ranges force-today inactive empty pre-re) + "Return a list of all relevant day numbers from BEG to END buffer positions. +If NO-RANGES is non-nil, include only the start and end dates of a range, +not every single day in the range. If FORCE-TODAY is non-nil, make +sure that TODAY is included in the list. If INACTIVE is non-nil, also +inactive time stamps (those in square brackets) are included. +When EMPTY is non-nil, also include days without any entries." + (let ((re (concat + (if pre-re pre-re "") + (if inactive org-ts-regexp-both org-ts-regexp))) + dates dates1 date day day1 day2 ts1 ts2) + (if force-today + (setq dates (list (org-today)))) + (save-excursion + (goto-char beg) + (while (re-search-forward re end t) + (setq day (time-to-days (org-time-string-to-time + (substring (match-string 1) 0 10)))) + (or (memq day dates) (push day dates))) + (unless no-ranges + (goto-char beg) + (while (re-search-forward org-tr-regexp end t) + (setq ts1 (substring (match-string 1) 0 10) + ts2 (substring (match-string 2) 0 10) + day1 (time-to-days (org-time-string-to-time ts1)) + day2 (time-to-days (org-time-string-to-time ts2))) + (while (< (setq day1 (1+ day1)) day2) + (or (memq day1 dates) (push day1 dates))))) + (setq dates (sort dates '<)) + (when empty + (while (setq day (pop dates)) + (setq day2 (car dates)) + (push day dates1) + (when (and day2 empty) + (if (or (eq empty t) + (and (numberp empty) (<= (- day2 day) empty))) + (while (< (setq day (1+ day)) day2) + (push (list day) dates1)) + (push (cons :omitted (- day2 day)) dates1)))) + (setq dates (nreverse dates1))) + dates))) + +;;; Agenda Daily/Weekly + +(defvar org-agenda-overriding-arguments nil) ; dynamically scoped parameter +(defvar org-agenda-start-day nil ; dynamically scoped parameter +"Custom commands can set this variable in the options section.") +(defvar org-agenda-last-arguments nil + "The arguments of the previous call to `org-agenda'.") +(defvar org-starting-day nil) ; local variable in the agenda buffer +(defvar org-agenda-current-span nil + "The current span used in the agenda view.") ; local variable in the agenda buffer +(defvar org-include-all-loc nil) ; local variable + +(defvar org-agenda-entry-types '(:deadline :scheduled :timestamp :sexp) + "List of types searched for when creating the daily/weekly agenda. +This variable is a list of symbols that controls the types of +items that appear in the daily/weekly agenda. Allowed symbols in this +list are are + + :timestamp List items containing a date stamp or date range matching + the selected date. This includes sexp entries in + angular brackets. + + :sexp List entries resulting from plain diary-like sexps. + + :deadline List deadline due on that date. When the date is today, + also list any deadlines past due, or due within + `org-deadline-warning-days'. `:deadline' must appear before + `:scheduled' if the setting of + `org-agenda-skip-scheduled-if-deadline-is-shown' is to have + any effect. + + :scheduled List all items which are scheduled for the given date. + The diary for *today* also contains items which were + scheduled earlier and are not yet marked DONE. + +By default, all four types are turned on. + +Never set this variable globally using `setq', because then it +will apply to all future agenda commands. Instead, bind it with +`let' to scope it dynamically into the the agenda-constructing +command. A good way to set it is through options in +`org-agenda-custom-commands'. For a more flexible (though +somewhat less efficient) way of determining what is included in +the daily/weekly agenda, see `org-agenda-skip-function'.") + +;;;###autoload +(defun org-agenda-list (&optional include-all start-day span) + "Produce a daily/weekly view from all files in variable `org-agenda-files'. +The view will be for the current day or week, but from the overview buffer +you will be able to go to other days/weeks. + +With one \\[universal-argument] prefix argument INCLUDE-ALL, +all unfinished TODO items will also be shown, before the agenda. +This feature is considered obsolete, please use the TODO list or a block +agenda instead. + +With a numeric prefix argument in an interactive call, the agenda will +span INCLUDE-ALL days. Lisp programs should instead specify SPAN to change +the number of days. SPAN defaults to `org-agenda-span'. + +START-DAY defaults to TODAY, or to the most recent match for the weekday +given in `org-agenda-start-on-weekday'." + (interactive "P") + (if (and (integerp include-all) (> include-all 0)) + (setq span include-all include-all nil)) + (setq start-day (or start-day org-agenda-start-day)) + (if org-agenda-overriding-arguments + (setq include-all (car org-agenda-overriding-arguments) + start-day (nth 1 org-agenda-overriding-arguments) + span (nth 2 org-agenda-overriding-arguments))) + (if (stringp start-day) + ;; Convert to an absolute day number + (setq start-day (time-to-days (org-read-date nil t start-day)))) + (setq org-agenda-last-arguments (list include-all start-day span)) + (org-compile-prefix-format 'agenda) + (org-set-sorting-strategy 'agenda) + (let* ((span (org-agenda-ndays-to-span (or span org-agenda-ndays org-agenda-span))) + (today (org-today)) + (sd (or start-day today)) + (ndays (org-agenda-span-to-ndays span sd)) + (org-agenda-start-on-weekday + (if (eq ndays 7) + org-agenda-start-on-weekday)) + (thefiles (org-agenda-files nil 'ifmode)) + (files thefiles) + (start (if (or (null org-agenda-start-on-weekday) + (< ndays 7)) + sd + (let* ((nt (calendar-day-of-week + (calendar-gregorian-from-absolute sd))) + (n1 org-agenda-start-on-weekday) + (d (- nt n1))) + (- sd (+ (if (< d 0) 7 0) d))))) + (day-numbers (list start)) + (day-cnt 0) + (inhibit-redisplay (not debug-on-error)) + s e rtn rtnall file date d start-pos end-pos todayp + clocktable-start clocktable-end filter) + (setq org-agenda-redo-command + (list 'org-agenda-list (list 'quote include-all) start-day (list 'quote span))) + (dotimes (n (1- ndays)) + (push (1+ (car day-numbers)) day-numbers)) + (setq day-numbers (nreverse day-numbers)) + (setq clocktable-start (car day-numbers) + clocktable-end (1+ (or (org-last day-numbers) 0))) + (org-prepare-agenda "Day/Week") + (org-set-local 'org-starting-day (car day-numbers)) + (org-set-local 'org-include-all-loc include-all) + (org-set-local 'org-agenda-current-span (org-agenda-ndays-to-span span)) + (when (and (or include-all org-agenda-include-all-todo) + (member today day-numbers)) + (setq files thefiles + rtnall nil) + (while (setq file (pop files)) + (catch 'nextfile + (org-check-agenda-file file) + (setq date (calendar-gregorian-from-absolute today) + rtn (org-agenda-get-day-entries + file date :todo)) + (setq rtnall (append rtnall rtn)))) + (when rtnall + (insert "All currently open TODO items:\n") + (add-text-properties (point-min) (1- (point)) + (list 'face 'org-agenda-structure + 'short-heading "All TODO items")) + (org-agenda-mark-header-line (point-min)) + (insert (org-finalize-agenda-entries rtnall) "\n"))) + (unless org-agenda-compact-blocks + (let* ((d1 (car day-numbers)) + (d2 (org-last day-numbers)) + (w1 (org-days-to-iso-week d1)) + (w2 (org-days-to-iso-week d2))) + (setq s (point)) + (if org-agenda-overriding-header + (insert (org-add-props (copy-sequence org-agenda-overriding-header) + nil 'face 'org-agenda-structure) "\n") + (insert (org-agenda-span-name span) + "-agenda" + (if (< (- d2 d1) 350) + (if (= w1 w2) + (format " (W%02d)" w1) + (format " (W%02d-W%02d)" w1 w2)) + "") + ":\n"))) + (add-text-properties s (1- (point)) (list 'face 'org-agenda-structure + 'org-date-line t)) + (org-agenda-mark-header-line s)) + (while (setq d (pop day-numbers)) + (setq date (calendar-gregorian-from-absolute d) + s (point)) + (if (or (setq todayp (= d today)) + (and (not start-pos) (= d sd))) + (setq start-pos (point)) + (if (and start-pos (not end-pos)) + (setq end-pos (point)))) + (setq files thefiles + rtnall nil) + (while (setq file (pop files)) + (catch 'nextfile + (org-check-agenda-file file) + (let ((org-agenda-entry-types org-agenda-entry-types)) + (unless org-agenda-include-deadlines + (setq org-agenda-entry-types + (delq :deadline org-agenda-entry-types))) + (cond + ((eq org-agenda-show-log 'only) + (setq rtn (org-agenda-get-day-entries + file date :closed))) + (org-agenda-show-log + (setq rtn (apply 'org-agenda-get-day-entries + file date + (append '(:closed) org-agenda-entry-types)))) + (t + (setq rtn (apply 'org-agenda-get-day-entries + file date + org-agenda-entry-types))))) + (setq rtnall (append rtnall rtn)))) + (if org-agenda-include-diary + (let ((org-agenda-search-headline-for-time t)) + (require 'diary-lib) + (setq rtn (org-get-entries-from-diary date)) + (setq rtnall (append rtnall rtn)))) + (if (or rtnall org-agenda-show-all-dates) + (progn + (setq day-cnt (1+ day-cnt)) + (insert + (if (stringp org-agenda-format-date) + (format-time-string org-agenda-format-date + (org-time-from-absolute date)) + (funcall org-agenda-format-date date)) + "\n") + (put-text-property s (1- (point)) 'face + (org-agenda-get-day-face date)) + (put-text-property s (1- (point)) 'org-date-line t) + (put-text-property s (1- (point)) 'org-agenda-date-header t) + (put-text-property s (1- (point)) 'org-day-cnt day-cnt) + (when todayp + (put-text-property s (1- (point)) 'org-today t)) + (if rtnall (insert + (org-finalize-agenda-entries + (org-agenda-add-time-grid-maybe + rtnall ndays todayp)) + "\n")) + (put-text-property s (1- (point)) 'day d) + (put-text-property s (1- (point)) 'org-day-cnt day-cnt)))) + (when (and org-agenda-clockreport-mode clocktable-start) + (let ((org-agenda-files (org-agenda-files nil 'ifmode)) + ;; the above line is to ensure the restricted range! + (p org-agenda-clockreport-parameter-plist) + tbl) + (setq p (org-plist-delete p :block)) + (setq p (plist-put p :tstart clocktable-start)) + (setq p (plist-put p :tend clocktable-end)) + (setq p (plist-put p :scope 'agenda)) + (when (and (eq org-agenda-clockreport-mode 'with-filter) + (setq filter (or org-agenda-filter-while-redo + (get 'org-agenda-filter :preset-filter)))) + (setq p (plist-put p :tags (mapconcat (lambda (x) + (if (string-match "[<>=]" x) + "" + x)) + filter "")))) + (message "%s" (plist-get p :tags)) (sit-for 2) + (setq tbl (apply 'org-get-clocktable p)) + (insert tbl))) + (goto-char (point-min)) + (or org-agenda-multi (org-fit-agenda-window)) + (unless (and (pos-visible-in-window-p (point-min)) + (pos-visible-in-window-p (point-max))) + (goto-char (1- (point-max))) + (recenter -1) + (if (not (pos-visible-in-window-p (or start-pos 1))) + (progn + (goto-char (or start-pos 1)) + (recenter 1)))) + (goto-char (or start-pos 1)) + (add-text-properties (point-min) (point-max) '(org-agenda-type agenda)) + (org-finalize-agenda) + (setq buffer-read-only t) + (message ""))) + +(defun org-agenda-ndays-to-span (n) + "Return a span symbol for a span of N days, or N if none matches." + (cond ((symbolp n) n) + ((= n 1) 'day) + ((= n 7) 'week) + (t n))) + +(defun org-agenda-span-to-ndays (span start-day) + "Return ndays from SPAN starting at START-DAY." + (cond ((numberp span) span) + ((eq span 'day) 1) + ((eq span 'week) 7) + ((eq span 'month) + (let ((date (calendar-gregorian-from-absolute start-day))) + (calendar-last-day-of-month (car date) (caddr date)))) + ((eq span 'year) + (let ((date (calendar-gregorian-from-absolute start-day))) + (if (calendar-leap-year-p (caddr date)) 366 365))))) + +(defun org-agenda-span-name (span) + "Return a SPAN name." + (if (null span) + "" + (if (symbolp span) + (capitalize (symbol-name span)) + (format "%d days" span)))) + +;;; Agenda word search + +(defvar org-agenda-search-history nil) +(defvar org-todo-only nil) + +(defvar org-search-syntax-table nil + "Special syntax table for org-mode search. +In this table, we have single quotes not as word constituents, to +that when \"+Ameli\" is searched as a work, it will also match \"Ameli's\"") + +(defun org-search-syntax-table () + (unless org-search-syntax-table + (setq org-search-syntax-table (copy-syntax-table org-mode-syntax-table)) + (modify-syntax-entry ?' "." org-search-syntax-table) + (modify-syntax-entry ?` "." org-search-syntax-table)) + org-search-syntax-table) + +(defvar org-agenda-last-search-view-search-was-boolean nil) + +;;;###autoload +(defun org-search-view (&optional todo-only string edit-at) + "Show all entries that contain a phrase or words or regular expressions. + +With optional prefix argument TODO-ONLY, only consider entries that are +TODO entries. The argument STRING can be used to pass a default search +string into this function. If EDIT-AT is non-nil, it means that the +user should get a chance to edit this string, with cursor at position +EDIT-AT. + +The search string can be viewed either as a phrase that should be found as +is, or it can be broken into a number of snippets, each of which must match +in a Boolean way to select an entry. The default depends on the variable +`org-agenda-search-view-always-boolean'. +Even if this is turned off (the default) you can always switch to +Boolean search dynamically by preceding the first word with \"+\" or \"-\". + +The default is a direct search of the whole phrase, where each space in +the search string can expand to an arbitrary amount of whitespace, +including newlines. + +If using a Boolean search, the search string is split on whitespace and +each snippet is searched separately, with logical AND to select an entry. +Words prefixed with a minus must *not* occur in the entry. Words without +a prefix or prefixed with a plus must occur in the entry. Matching is +case-insensitive. Words are enclosed by word delimiters (i.e. they must +match whole words, not parts of a word) if +`org-agenda-search-view-force-full-words' is set (default is nil). + +Boolean search snippets enclosed by curly braces are interpreted as +regular expressions that must or (when preceded with \"-\") must not +match in the entry. Snippets enclosed into double quotes will be taken +as a whole, to include whitespace. + +- If the search string starts with an asterisk, search only in headlines. +- If (possibly after the leading star) the search string starts with an + exclamation mark, this also means to look at TODO entries only, an effect + that can also be achieved with a prefix argument. +- If (possibly after star and exclamation mark) the search string starts + with a colon, this will mean that the (non-regexp) snippets of the + Boolean search must match as full words. + +This command searches the agenda files, and in addition the files listed +in `org-agenda-text-search-extra-files'." + (interactive "P") + (org-compile-prefix-format 'search) + (org-set-sorting-strategy 'search) + (org-prepare-agenda "SEARCH") + (let* ((props (list 'face nil + 'done-face 'org-agenda-done + 'org-not-done-regexp org-not-done-regexp + 'org-todo-regexp org-todo-regexp + 'org-complex-heading-regexp org-complex-heading-regexp + 'mouse-face 'highlight + 'help-echo (format "mouse-2 or RET jump to location"))) + (full-words org-agenda-search-view-force-full-words) + (org-agenda-text-search-extra-files org-agenda-text-search-extra-files) + regexp rtn rtnall files file pos + marker category tags c neg re boolean + ee txt beg end words regexps+ regexps- hdl-only buffer beg1 str) + (unless (and (not edit-at) + (stringp string) + (string-match "\\S-" string)) + (setq string (read-string + (if org-agenda-search-view-always-boolean + "[+-]Word/{Regexp} ...: " + "Phrase, or [+-]Word/{Regexp} ...: ") + (cond + ((integerp edit-at) (cons string edit-at)) + (edit-at string)) + 'org-agenda-search-history))) + (org-set-local 'org-todo-only todo-only) + (setq org-agenda-redo-command + (list 'org-search-view (if todo-only t nil) string + '(if current-prefix-arg 1 nil))) + (setq org-agenda-query-string string) + + (if (equal (string-to-char string) ?*) + (setq hdl-only t + words (substring string 1)) + (setq words string)) + (when (equal (string-to-char words) ?!) + (setq todo-only t + words (substring words 1))) + (when (equal (string-to-char words) ?:) + (setq full-words t + words (substring words 1))) + (if (or org-agenda-search-view-always-boolean + (member (string-to-char words) '(?- ?+ ?\{))) + (setq boolean t)) + (setq words (org-split-string words)) + (let (www w) + (while (setq w (pop words)) + (while (and (string-match "\\\\\\'" w) words) + (setq w (concat (substring w 0 -1) " " (pop words)))) + (push w www)) + (setq words (nreverse www) www nil) + (while (setq w (pop words)) + (when (and (string-match "\\`[-+]?{" w) + (not (string-match "}\\'" w))) + (while (and words (not (string-match "}\\'" (car words)))) + (setq w (concat w " " (pop words)))) + (setq w (concat w " " (pop words)))) + (push w www)) + (setq words (nreverse www))) + (setq org-agenda-last-search-view-search-was-boolean boolean) + (when boolean + (let (wds w) + (while (setq w (pop words)) + (if (or (equal (substring w 0 1) "\"") + (and (> (length w) 1) + (member (substring w 0 1) '("+" "-")) + (equal (substring w 1 2) "\""))) + (while (and words (not (equal (substring w -1) "\""))) + (setq w (concat w " " (pop words))))) + (and (string-match "\\`\\([-+]?\\)\"" w) + (setq w (replace-match "\\1" nil nil w))) + (and (equal (substring w -1) "\"") (setq w (substring w 0 -1))) + (push w wds)) + (setq words (nreverse wds)))) + (if boolean + (mapc (lambda (w) + (setq c (string-to-char w)) + (if (equal c ?-) + (setq neg t w (substring w 1)) + (if (equal c ?+) + (setq neg nil w (substring w 1)) + (setq neg nil))) + (if (string-match "\\`{.*}\\'" w) + (setq re (substring w 1 -1)) + (if full-words + (setq re (concat "\\<" (regexp-quote (downcase w)) "\\>")) + (setq re (regexp-quote (downcase w))))) + (if neg (push re regexps-) (push re regexps+))) + words) + (push (mapconcat (lambda (w) (regexp-quote w)) words "\\s-+") + regexps+)) + (setq regexps+ (sort regexps+ (lambda (a b) (> (length a) (length b))))) + (if (not regexps+) + (setq regexp (concat "^" org-outline-regexp)) + (setq regexp (pop regexps+)) + (if hdl-only (setq regexp (concat "^" org-outline-regexp ".*?" + regexp)))) + (setq files (org-agenda-files nil 'ifmode)) + (when (eq (car org-agenda-text-search-extra-files) 'agenda-archives) + (pop org-agenda-text-search-extra-files) + (setq files (org-add-archive-files files))) + (setq files (append files org-agenda-text-search-extra-files) + rtnall nil) + (while (setq file (pop files)) + (setq ee nil) + (catch 'nextfile + (org-check-agenda-file file) + (setq buffer (if (file-exists-p file) + (org-get-agenda-file-buffer file) + (error "No such file %s" file))) + (if (not buffer) + ;; If file does not exist, make sure an error message is sent + (setq rtn (list (format "ORG-AGENDA-ERROR: No such org-file %s" + file)))) + (with-current-buffer buffer + (with-syntax-table (org-search-syntax-table) + (unless (org-mode-p) + (error "Agenda file %s is not in `org-mode'" file)) + (let ((case-fold-search t)) + (save-excursion + (save-restriction + (if org-agenda-restrict + (narrow-to-region org-agenda-restrict-begin + org-agenda-restrict-end) + (widen)) + (goto-char (point-min)) + (unless (or (org-on-heading-p) + (outline-next-heading)) + (throw 'nextfile t)) + (goto-char (max (point-min) (1- (point)))) + (while (re-search-forward regexp nil t) + (org-back-to-heading t) + (skip-chars-forward "* ") + (setq beg (point-at-bol) + beg1 (point) + end (progn (outline-next-heading) (point))) + (catch :skip + (goto-char beg) + (org-agenda-skip) + (setq str (buffer-substring-no-properties + (point-at-bol) + (if hdl-only (point-at-eol) end))) + (mapc (lambda (wr) (when (string-match wr str) + (goto-char (1- end)) + (throw :skip t))) + regexps-) + (mapc (lambda (wr) (unless (string-match wr str) + (goto-char (1- end)) + (throw :skip t))) + (if todo-only + (cons (concat "^\*+[ \t]+" org-not-done-regexp) + regexps+) + regexps+)) + (goto-char beg) + (setq marker (org-agenda-new-marker (point)) + category (org-get-category) + tags (org-get-tags-at (point)) + txt (org-format-agenda-item + "" + (buffer-substring-no-properties + beg1 (point-at-eol)) + category tags)) + (org-add-props txt props + 'org-marker marker 'org-hd-marker marker + 'org-todo-regexp org-todo-regexp + 'org-complex-heading-regexp org-complex-heading-regexp + 'priority 1000 'org-category category + 'type "search") + (push txt ee) + (goto-char (1- end)))))))))) + (setq rtn (nreverse ee)) + (setq rtnall (append rtnall rtn))) + (if org-agenda-overriding-header + (insert (org-add-props (copy-sequence org-agenda-overriding-header) + nil 'face 'org-agenda-structure) "\n") + (insert "Search words: ") + (add-text-properties (point-min) (1- (point)) + (list 'face 'org-agenda-structure)) + (setq pos (point)) + (insert string "\n") + (add-text-properties pos (1- (point)) (list 'face 'org-warning)) + (setq pos (point)) + (unless org-agenda-multi + (insert "Press `[', `]' to add/sub word, `{', `}' to add/sub regexp, `C-u r' to edit\n") + (add-text-properties pos (1- (point)) + (list 'face 'org-agenda-structure)))) + (org-agenda-mark-header-line (point-min)) + (when rtnall + (insert (org-finalize-agenda-entries rtnall) "\n")) + (goto-char (point-min)) + (or org-agenda-multi (org-fit-agenda-window)) + (add-text-properties (point-min) (point-max) '(org-agenda-type search)) + (org-finalize-agenda) + (setq buffer-read-only t))) + +;;; Agenda TODO list + +(defvar org-select-this-todo-keyword nil) +(defvar org-last-arg nil) + +;;;###autoload +(defun org-todo-list (arg) + "Show all (not done) 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-1'." + (interactive "P") + (org-compile-prefix-format 'todo) + (org-set-sorting-strategy 'todo) + (org-prepare-agenda "TODO") + (if (and (stringp arg) (not (string-match "\\S-" arg))) (setq arg nil)) + (let* ((today (org-today)) + (date (calendar-gregorian-from-absolute today)) + (kwds org-todo-keywords-for-agenda) + (completion-ignore-case t) + (org-select-this-todo-keyword + (if (stringp arg) arg + (and arg (integerp arg) (> arg 0) + (nth (1- arg) kwds)))) + rtn rtnall files file pos) + (when (equal arg '(4)) + (setq org-select-this-todo-keyword + (org-icompleting-read "Keyword (or KWD1|K2D2|...): " + (mapcar 'list kwds) nil nil))) + (and (equal 0 arg) (setq org-select-this-todo-keyword nil)) + (org-set-local 'org-last-arg arg) + (setq org-agenda-redo-command + '(org-todo-list (or current-prefix-arg org-last-arg))) + (setq files (org-agenda-files nil 'ifmode) + rtnall nil) + (while (setq file (pop files)) + (catch 'nextfile + (org-check-agenda-file file) + (setq rtn (org-agenda-get-day-entries file date :todo)) + (setq rtnall (append rtnall rtn)))) + (if org-agenda-overriding-header + (insert (org-add-props (copy-sequence org-agenda-overriding-header) + nil 'face 'org-agenda-structure) "\n") + (insert "Global list of TODO items of type: ") + (add-text-properties (point-min) (1- (point)) + (list 'face 'org-agenda-structure + 'short-heading + (concat "ToDo: " + (or org-select-this-todo-keyword "ALL")))) + (org-agenda-mark-header-line (point-min)) + (setq pos (point)) + (insert (or org-select-this-todo-keyword "ALL") "\n") + (add-text-properties pos (1- (point)) (list 'face 'org-warning)) + (setq pos (point)) + (unless org-agenda-multi + (insert "Available with `N r': (0)ALL") + (let ((n 0) s) + (mapc (lambda (x) + (setq s (format "(%d)%s" (setq n (1+ n)) x)) + (if (> (+ (current-column) (string-width s) 1) (frame-width)) + (insert "\n ")) + (insert " " s)) + kwds)) + (insert "\n")) + (add-text-properties pos (1- (point)) (list 'face 'org-agenda-structure))) + (org-agenda-mark-header-line (point-min)) + (when rtnall + (insert (org-finalize-agenda-entries rtnall) "\n")) + (goto-char (point-min)) + (or org-agenda-multi (org-fit-agenda-window)) + (add-text-properties (point-min) (point-max) '(org-agenda-type todo)) + (org-finalize-agenda) + (setq buffer-read-only t))) + +;;; Agenda tags match + +;;;###autoload +(defun org-tags-view (&optional todo-only match) + "Show all headlines for all `org-agenda-files' matching a TAGS criterion. +The prefix arg TODO-ONLY limits the search to TODO entries." + (interactive "P") + (org-compile-prefix-format 'tags) + (org-set-sorting-strategy 'tags) + (let* ((org-tags-match-list-sublevels + org-tags-match-list-sublevels) + (completion-ignore-case t) + rtn rtnall files file pos matcher + buffer) + (when (and (stringp match) (not (string-match "\\S-" match))) + (setq match nil)) + (setq matcher (org-make-tags-matcher match) + match (car matcher) matcher (cdr matcher)) + (org-prepare-agenda (concat "TAGS " match)) + (setq org-agenda-query-string match) + (setq org-agenda-redo-command + (list 'org-tags-view (list 'quote todo-only) + (list 'if 'current-prefix-arg nil 'org-agenda-query-string))) + (setq files (org-agenda-files nil 'ifmode) + 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, error message to agenda + (setq rtn (list + (format "ORG-AGENDA-ERROR: No such org-file %s" file)) + rtnall (append rtnall rtn)) + (with-current-buffer buffer + (unless (org-mode-p) + (error "Agenda file %s is not in `org-mode'" file)) + (save-excursion + (save-restriction + (if org-agenda-restrict + (narrow-to-region org-agenda-restrict-begin + org-agenda-restrict-end) + (widen)) + (setq rtn (org-scan-tags 'agenda matcher todo-only)) + (setq rtnall (append rtnall rtn)))))))) + (if org-agenda-overriding-header + (insert (org-add-props (copy-sequence org-agenda-overriding-header) + nil 'face 'org-agenda-structure) "\n") + (insert "Headlines with TAGS match: ") + (add-text-properties (point-min) (1- (point)) + (list 'face 'org-agenda-structure + 'short-heading + (concat "Match: " match))) + (setq pos (point)) + (insert match "\n") + (add-text-properties pos (1- (point)) (list 'face 'org-warning)) + (setq pos (point)) + (unless org-agenda-multi + (insert "Press `C-u r' to search again with new search string\n")) + (add-text-properties pos (1- (point)) (list 'face 'org-agenda-structure))) + (org-agenda-mark-header-line (point-min)) + (when rtnall + (insert (org-finalize-agenda-entries rtnall) "\n")) + (goto-char (point-min)) + (or org-agenda-multi (org-fit-agenda-window)) + (add-text-properties (point-min) (point-max) '(org-agenda-type tags)) + (org-finalize-agenda) + (setq buffer-read-only t))) + +;;; Agenda Finding stuck projects + +(defvar org-agenda-skip-regexp nil + "Regular expression used in skipping subtrees for the agenda. +This is basically a temporary global variable that can be set and then +used by user-defined selections using `org-agenda-skip-function'.") + +(defvar org-agenda-overriding-header nil + "When this is set during todo and tags searches, will replace header. +This variable should not be set directly, but custom commands can bind it +in the options section.") + +(defun org-agenda-skip-entry-when-regexp-matches () + "Check if the current entry contains match for `org-agenda-skip-regexp'. +If yes, it returns the end position of this entry, causing agenda commands +to skip the entry but continuing the search in the subtree. This is a +function that can be put into `org-agenda-skip-function' for the duration +of a command." + (let ((end (save-excursion (org-end-of-subtree t))) + skip) + (save-excursion + (setq skip (re-search-forward org-agenda-skip-regexp end t))) + (and skip end))) + +(defun org-agenda-skip-subtree-when-regexp-matches () + "Check if the current subtree contains match for `org-agenda-skip-regexp'. +If yes, it returns the end position of this tree, causing agenda commands +to skip this subtree. This is a function that can be put into +`org-agenda-skip-function' for the duration of a command." + (let ((end (save-excursion (org-end-of-subtree t))) + skip) + (save-excursion + (setq skip (re-search-forward org-agenda-skip-regexp end t))) + (and skip end))) + +(defun org-agenda-skip-entry-when-regexp-matches-in-subtree () + "Check if the current subtree contains match for `org-agenda-skip-regexp'. +If yes, it returns the end position of the current entry (NOT the tree), +causing agenda commands to skip the entry but continuing the search in +the subtree. This is a function that can be put into +`org-agenda-skip-function' for the duration of a command. An important +use of this function is for the stuck project list." + (let ((end (save-excursion (org-end-of-subtree t))) + (entry-end (save-excursion (outline-next-heading) (1- (point)))) + skip) + (save-excursion + (setq skip (re-search-forward org-agenda-skip-regexp end t))) + (and skip entry-end))) + +(defun org-agenda-skip-entry-if (&rest conditions) + "Skip entry if any of CONDITIONS is true. +See `org-agenda-skip-if' for details." + (org-agenda-skip-if nil conditions)) + +(defun org-agenda-skip-subtree-if (&rest conditions) + "Skip entry if any of CONDITIONS is true. +See `org-agenda-skip-if' for details." + (org-agenda-skip-if t conditions)) + +(defun org-agenda-skip-if (subtree conditions) + "Checks current entity for CONDITIONS. +If SUBTREE is non-nil, the entire subtree is checked. Otherwise, only +the entry, i.e. the text before the next heading is checked. + +CONDITIONS is a list of symbols, boolean OR is used to combine the results +from different tests. Valid conditions are: + +scheduled Check if there is a scheduled cookie +notscheduled Check if there is no scheduled cookie +deadline Check if there is a deadline +notdeadline Check if there is no deadline +timestamp Check if there is a timestamp (also deadline or scheduled) +nottimestamp Check if there is no timestamp (also deadline or scheduled) +regexp Check if regexp matches +notregexp Check if regexp does not match. +todo Check if TODO keyword matches +nottodo Check if TODO keyword does not match + +The regexp is taken from the conditions list, it must come right after +the `regexp' or `notregexp' element. + +`todo' and `nottodo' accept as an argument a list of todo +keywords, which may include \"*\" to match any todo keyword. + + (org-agenda-skip-entry-if 'todo '(\"TODO\" \"WAITING\")) + +would skip all entries with \"TODO\" or \"WAITING\" keywords. + +Instead of a list a keyword class may be given + + (org-agenda-skip-entry-if 'nottodo 'done) + +would skip entries that haven't been marked with any of \"DONE\" +keywords. Possible classes are: `todo', `done', `any'. + +If any of these conditions is met, this function returns the end point of +the entity, causing the search to continue from there. This is a function +that can be put into `org-agenda-skip-function' for the duration of a command." + (let (beg end m) + (org-back-to-heading t) + (setq beg (point) + end (if subtree + (progn (org-end-of-subtree t) (point)) + (progn (outline-next-heading) (1- (point))))) + (goto-char beg) + (and + (or + (and (memq 'scheduled conditions) + (re-search-forward org-scheduled-time-regexp end t)) + (and (memq 'notscheduled conditions) + (not (re-search-forward org-scheduled-time-regexp end t))) + (and (memq 'deadline conditions) + (re-search-forward org-deadline-time-regexp end t)) + (and (memq 'notdeadline conditions) + (not (re-search-forward org-deadline-time-regexp end t))) + (and (memq 'timestamp conditions) + (re-search-forward org-ts-regexp end t)) + (and (memq 'nottimestamp conditions) + (not (re-search-forward org-ts-regexp end t))) + (and (setq m (memq 'regexp conditions)) + (stringp (nth 1 m)) + (re-search-forward (nth 1 m) end t)) + (and (setq m (memq 'notregexp conditions)) + (stringp (nth 1 m)) + (not (re-search-forward (nth 1 m) end t))) + (and (or + (setq m (memq 'todo conditions)) + (setq m (memq 'nottodo conditions))) + (org-agenda-skip-if-todo m end))) + end))) + +(defun org-agenda-skip-if-todo (args end) + "Helper function for `org-agenda-skip-if', do not use it directly. +ARGS is a list with first element either `todo' or `nottodo'. +The remainder is either a list of TODO keywords, or a state symbol +`todo' or `done' or `any'." + (let ((kw (car args)) + (arg (cadr args)) + todo-wds todo-re) + (setq todo-wds + (org-uniquify + (cond + ((listp arg) ;; list of keywords + (if (member "*" arg) + (mapcar 'substring-no-properties org-todo-keywords-1) + arg)) + ((symbolp arg) ;; keyword class name + (cond + ((eq arg 'todo) + (org-delete-all org-done-keywords + (mapcar 'substring-no-properties + org-todo-keywords-1))) + ((eq arg 'done) org-done-keywords) + ((eq arg 'any) + (mapcar 'substring-no-properties org-todo-keywords-1))))))) + (setq todo-re + (concat "^\\*+[ \t]+\\<\\(" + (mapconcat 'identity todo-wds "\\|") + "\\)\\>")) + (if (eq kw 'todo) + (re-search-forward todo-re end t) + (not (re-search-forward todo-re end t))))) + +;;;###autoload +(defun org-agenda-list-stuck-projects (&rest ignore) + "Create agenda view for projects that are stuck. +Stuck projects are project that have no next actions. For the definitions +of what a project is and how to check if it stuck, customize the variable +`org-stuck-projects'." + (interactive) + (let* ((org-agenda-skip-function + 'org-agenda-skip-entry-when-regexp-matches-in-subtree) + ;; We could have used org-agenda-skip-if here. + (org-agenda-overriding-header + (or org-agenda-overriding-header "List of stuck projects: ")) + (matcher (nth 0 org-stuck-projects)) + (todo (nth 1 org-stuck-projects)) + (todo-wds (if (member "*" todo) + (progn + (org-prepare-agenda-buffers (org-agenda-files + nil 'ifmode)) + (org-delete-all + org-done-keywords-for-agenda + (copy-sequence org-todo-keywords-for-agenda))) + todo)) + (todo-re (concat "^\\*+[ \t]+\\(" + (mapconcat 'identity todo-wds "\\|") + "\\)\\>")) + (tags (nth 2 org-stuck-projects)) + (tags-re (if (member "*" tags) + (org-re "^\\*+ .*:[[:alnum:]_@#%]+:[ \t]*$") + (if tags + (concat "^\\*+ .*:\\(" + (mapconcat 'identity tags "\\|") + (org-re "\\):[[:alnum:]_@#%:]*[ \t]*$"))))) + (gen-re (nth 3 org-stuck-projects)) + (re-list + (delq nil + (list + (if todo todo-re) + (if tags tags-re) + (and gen-re (stringp gen-re) (string-match "\\S-" gen-re) + gen-re))))) + (setq org-agenda-skip-regexp + (if re-list + (mapconcat 'identity re-list "\\|") + (error "No information how to identify unstuck projects"))) + (org-tags-view nil matcher) + (with-current-buffer org-agenda-buffer-name + (setq org-agenda-redo-command + '(org-agenda-list-stuck-projects + (or current-prefix-arg org-last-arg)))))) + +;;; Diary integration + +(defvar org-disable-agenda-to-diary nil) ;Dynamically-scoped param. +(defvar list-diary-entries-hook) + +(defun org-get-entries-from-diary (date) + "Get the (Emacs Calendar) diary entries for DATE." + (require 'diary-lib) + (let* ((diary-fancy-buffer "*temporary-fancy-diary-buffer*") + (diary-display-hook '(fancy-diary-display)) + (diary-display-function 'fancy-diary-display) + (pop-up-frames nil) + (list-diary-entries-hook + (cons 'org-diary-default-entry list-diary-entries-hook)) + (diary-file-name-prefix-function nil) ; turn this feature off + (diary-modify-entry-list-string-function 'org-modify-diary-entry-string) + entries + (org-disable-agenda-to-diary t)) + (save-excursion + (save-window-excursion + (funcall (if (fboundp 'diary-list-entries) + 'diary-list-entries 'list-diary-entries) + date 1))) + (if (not (get-buffer diary-fancy-buffer)) + (setq entries nil) + (with-current-buffer diary-fancy-buffer + (setq buffer-read-only nil) + (if (zerop (buffer-size)) + ;; No entries + (setq entries nil) + ;; Omit the date and other unnecessary stuff + (org-agenda-cleanup-fancy-diary) + ;; Add prefix to each line and extend the text properties + (if (zerop (buffer-size)) + (setq entries nil) + (setq entries (buffer-substring (point-min) (- (point-max) 1))))) + (set-buffer-modified-p nil) + (kill-buffer diary-fancy-buffer))) + (when entries + (setq entries (org-split-string entries "\n")) + (setq entries + (mapcar + (lambda (x) + (setq x (org-format-agenda-item "" x "Diary" nil 'time)) + ;; Extend the text properties to the beginning of the line + (org-add-props x (text-properties-at (1- (length x)) x) + 'type "diary" 'date date 'face 'org-agenda-diary)) + entries))))) + +(defvar org-agenda-cleanup-fancy-diary-hook nil + "Hook run when the fancy diary buffer is cleaned up.") + +(defun org-agenda-cleanup-fancy-diary () + "Remove unwanted stuff in buffer created by `fancy-diary-display'. +This gets rid of the date, the underline under the date, and +the dummy entry installed by `org-mode' to ensure non-empty diary for each +date. It also removes lines that contain only whitespace." + (goto-char (point-min)) + (if (looking-at ".*?:[ \t]*") + (progn + (replace-match "") + (re-search-forward "\n=+$" nil t) + (replace-match "") + (while (re-search-backward "^ +\n?" nil t) (replace-match ""))) + (re-search-forward "\n=+$" nil t) + (delete-region (point-min) (min (point-max) (1+ (match-end 0))))) + (goto-char (point-min)) + (while (re-search-forward "^ +\n" nil t) + (replace-match "")) + (goto-char (point-min)) + (if (re-search-forward "^Org-mode dummy\n?" nil t) + (replace-match "")) + (run-hooks 'org-agenda-cleanup-fancy-diary-hook)) + +;; Make sure entries from the diary have the right text properties. +(eval-after-load "diary-lib" + '(if (boundp 'diary-modify-entry-list-string-function) + ;; We can rely on the hook, nothing to do + nil + ;; Hook not available, must use advice to make this work + (defadvice add-to-diary-list (before org-mark-diary-entry activate) + "Make the position visible." + (if (and org-disable-agenda-to-diary ;; called from org-agenda + (stringp string) + buffer-file-name) + (setq string (org-modify-diary-entry-string string)))))) + +(defun org-modify-diary-entry-string (string) + "Add text properties to string, allowing org-mode to act on it." + (org-add-props string nil + 'mouse-face 'highlight + 'help-echo (if buffer-file-name + (format "mouse-2 or RET jump to diary file %s" + (abbreviate-file-name buffer-file-name)) + "") + 'org-agenda-diary-link t + 'org-marker (org-agenda-new-marker (point-at-bol)))) + +(defun org-diary-default-entry () + "Add a dummy entry to the diary. +Needed to avoid empty dates which mess up holiday display." + ;; Catch the error if dealing with the new add-to-diary-alist + (when org-disable-agenda-to-diary + (condition-case nil + (org-add-to-diary-list original-date "Org-mode dummy" "") + (error + (org-add-to-diary-list original-date "Org-mode dummy" "" nil))))) + +(defun org-add-to-diary-list (&rest args) + (if (fboundp 'diary-add-to-list) + (apply 'diary-add-to-list args) + (apply 'add-to-diary-list args))) + +(defvar org-diary-last-run-time nil) + +;;;###autoload +(defun org-diary (&rest args) + "Return diary information from org-files. +This function can be used in a \"sexp\" diary entry in the Emacs calendar. +It accesses org files and extracts information from those files to be +listed in the diary. The function accepts arguments specifying what +items should be listed. For a list of arguments allowed here, see the +variable `org-agenda-entry-types'. + +The call in the diary file should look like this: + + &%%(org-diary) ~/path/to/some/orgfile.org + +Use a separate line for each org file to check. Or, if you omit the file name, +all files listed in `org-agenda-files' will be checked automatically: + + &%%(org-diary) + +If you don't give any arguments (as in the example above), the default +arguments (:deadline :scheduled :timestamp :sexp) are used. +So the example above may also be written as + + &%%(org-diary :deadline :timestamp :sexp :scheduled) + +The function expects the lisp variables `entry' and `date' to be provided +by the caller, because this is how the calendar works. Don't use this +function from a program - use `org-agenda-get-day-entries' instead." + (when (> (- (org-float-time) + org-agenda-last-marker-time) + 5) + (org-agenda-reset-markers)) + (org-compile-prefix-format 'agenda) + (org-set-sorting-strategy 'agenda) + (setq args (or args '(:deadline :scheduled :timestamp :sexp))) + (let* ((files (if (and entry (stringp entry) (string-match "\\S-" entry)) + (list entry) + (org-agenda-files t))) + (time (org-float-time)) + file rtn results) + (when (or (not org-diary-last-run-time) + (> (- time + org-diary-last-run-time) + 3)) + (org-prepare-agenda-buffers files)) + (setq org-diary-last-run-time time) + ;; If this is called during org-agenda, don't return any entries to + ;; the calendar. Org Agenda will list these entries itself. + (if org-disable-agenda-to-diary (setq files nil)) + (while (setq file (pop files)) + (setq rtn (apply 'org-agenda-get-day-entries file date args)) + (setq results (append results rtn))) + (if results + (concat (org-finalize-agenda-entries results) "\n")))) + +;;; Agenda entry finders + +(defun org-agenda-get-day-entries (file date &rest args) + "Does the work for `org-diary' and `org-agenda'. +FILE is the path to a file to be checked for entries. DATE is date like +the one returned by `calendar-current-date'. ARGS are symbols indicating +which kind of entries should be extracted. For details about these, see +the documentation of `org-diary'." + (setq args (or args '(:deadline :scheduled :timestamp :sexp))) + (let* ((org-startup-folded nil) + (org-startup-align-all-tables nil) + (buffer (if (file-exists-p file) + (org-get-agenda-file-buffer file) + (error "No such file %s" file))) + arg results rtn deadline-results) + (if (not buffer) + ;; If file does not exist, make sure an error message ends up in diary + (list (format "ORG-AGENDA-ERROR: No such org-file %s" file)) + (with-current-buffer buffer + (unless (org-mode-p) + (error "Agenda file %s is not in `org-mode'" file)) + (let ((case-fold-search nil)) + (save-excursion + (save-restriction + (if org-agenda-restrict + (narrow-to-region org-agenda-restrict-begin + org-agenda-restrict-end) + (widen)) + ;; The way we repeatedly append to `results' makes it O(n^2) :-( + (while (setq arg (pop args)) + (cond + ((and (eq arg :todo) + (equal date (calendar-current-date))) + (setq rtn (org-agenda-get-todos)) + (setq results (append results rtn))) + ((eq arg :timestamp) + (setq rtn (org-agenda-get-blocks)) + (setq results (append results rtn)) + (setq rtn (org-agenda-get-timestamps)) + (setq results (append results rtn))) + ((eq arg :sexp) + (setq rtn (org-agenda-get-sexps)) + (setq results (append results rtn))) + ((eq arg :scheduled) + (setq rtn (org-agenda-get-scheduled deadline-results)) + (setq results (append results rtn))) + ((eq arg :closed) + (setq rtn (org-agenda-get-progress)) + (setq results (append results rtn))) + ((eq arg :deadline) + (setq rtn (org-agenda-get-deadlines)) + (setq deadline-results (copy-sequence rtn)) + (setq results (append results rtn)))))))) + results)))) + +(defun org-agenda-get-todos () + "Return the TODO information for agenda display." + (let* ((props (list 'face nil + 'done-face 'org-agenda-done + 'org-not-done-regexp org-not-done-regexp + 'org-todo-regexp org-todo-regexp + 'org-complex-heading-regexp org-complex-heading-regexp + 'mouse-face 'highlight + 'help-echo + (format "mouse-2 or RET jump to org file %s" + (abbreviate-file-name buffer-file-name)))) + (regexp (concat "^\\*+[ \t]+\\(" + (if org-select-this-todo-keyword + (if (equal org-select-this-todo-keyword "*") + org-todo-regexp + (concat "\\<\\(" + (mapconcat 'identity (org-split-string org-select-this-todo-keyword "|") "\\|") + "\\)\\>")) + org-not-done-regexp) + "[^\n\r]*\\)")) + marker priority category tags todo-state + ee txt beg end) + (goto-char (point-min)) + (while (re-search-forward regexp nil t) + (catch :skip + (save-match-data + (beginning-of-line) + (setq beg (point) end (save-excursion (outline-next-heading) (point))) + (when (org-agenda-check-for-timestamp-as-reason-to-ignore-todo-item end) + (goto-char (1+ beg)) + (or org-agenda-todo-list-sublevels (org-end-of-subtree 'invisible)) + (throw :skip nil))) + (goto-char beg) + (org-agenda-skip) + (goto-char (match-beginning 1)) + (setq marker (org-agenda-new-marker (match-beginning 0)) + category (org-get-category) + txt (match-string 1) + tags (org-get-tags-at (point)) + txt (org-format-agenda-item "" txt category tags) + priority (1+ (org-get-priority txt)) + todo-state (org-get-todo-state)) + (org-add-props txt props + 'org-marker marker 'org-hd-marker marker + 'priority priority 'org-category category + 'type "todo" 'todo-state todo-state) + (push txt ee) + (if org-agenda-todo-list-sublevels + (goto-char (match-end 1)) + (org-end-of-subtree 'invisible)))) + (nreverse ee))) + +;;;###autoload +(defun org-agenda-check-for-timestamp-as-reason-to-ignore-todo-item + (&optional end) + "Do we have a reason to ignore this TODO entry because it has a time stamp?" + (when (or org-agenda-todo-ignore-with-date + org-agenda-todo-ignore-scheduled + org-agenda-todo-ignore-deadlines + org-agenda-todo-ignore-timestamp) + (setq end (or end (save-excursion (outline-next-heading) (point)))) + (save-excursion + (or (and org-agenda-todo-ignore-with-date + (re-search-forward org-ts-regexp end t)) + (and org-agenda-todo-ignore-scheduled + (re-search-forward org-scheduled-time-regexp end t) + (cond + ((eq org-agenda-todo-ignore-scheduled 'future) + (> (org-days-to-time (match-string 1)) 0)) + ((eq org-agenda-todo-ignore-scheduled 'past) + (<= (org-days-to-time (match-string 1)) 0)) + (t))) + (and org-agenda-todo-ignore-deadlines + (re-search-forward org-deadline-time-regexp end t) + (cond + ((memq org-agenda-todo-ignore-deadlines '(t all)) t) + ((eq org-agenda-todo-ignore-deadlines 'far) + (not (org-deadline-close (match-string 1)))) + ((eq org-agenda-todo-ignore-deadlines 'future) + (> (org-days-to-time (match-string 1)) 0)) + ((eq org-agenda-todo-ignore-deadlines 'past) + (<= (org-days-to-time (match-string 1)) 0)) + (t (org-deadline-close (match-string 1))))) + (and org-agenda-todo-ignore-timestamp + (let ((buffer (current-buffer)) + (regexp + (concat + org-scheduled-time-regexp "\\|" org-deadline-time-regexp)) + (start (point))) + ;; Copy current buffer into a temporary one + (with-temp-buffer + (insert-buffer-substring buffer start end) + (goto-char (point-min)) + ;; Delete SCHEDULED and DEADLINE items + (while (re-search-forward regexp end t) + (delete-region (match-beginning 0) (match-end 0))) + (goto-char (point-min)) + ;; No search for timestamp left + (when (re-search-forward org-ts-regexp nil t) + (cond + ((eq org-agenda-todo-ignore-timestamp 'future) + (> (org-days-to-time (match-string 1)) 0)) + ((eq org-agenda-todo-ignore-timestamp 'past) + (<= (org-days-to-time (match-string 1)) 0)) + (t)))))))))) + +(defconst org-agenda-no-heading-message + "No heading for this item in buffer or region.") + +(defun org-agenda-get-timestamps () + "Return the date stamp information for agenda display." + (let* ((props (list 'face nil + 'org-not-done-regexp org-not-done-regexp + 'org-todo-regexp org-todo-regexp + 'org-complex-heading-regexp org-complex-heading-regexp + 'mouse-face 'highlight + 'help-echo + (format "mouse-2 or RET jump to org file %s" + (abbreviate-file-name buffer-file-name)))) + (d1 (calendar-absolute-from-gregorian date)) + (remove-re + (concat + (regexp-quote + (format-time-string + "<%Y-%m-%d" + (encode-time 0 0 0 (nth 1 date) (nth 0 date) (nth 2 date)))) + ".*?>")) + (regexp + (concat + (if org-agenda-include-inactive-timestamps "[[<]" "<") + (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)) + "\\|\\(<[0-9]+-[0-9]+-[0-9]+[^>\n]+?\\+[0-9]+[dwmy]>\\)" + "\\|\\(<%%\\(([^>\n]+)\\)>\\)")) + marker hdmarker deadlinep scheduledp clockp closedp inactivep + donep tmp priority category ee txt timestr tags b0 b3 e3 head + todo-state end-of-match) + (goto-char (point-min)) + (while (setq end-of-match (re-search-forward regexp nil t)) + (setq b0 (match-beginning 0) + b3 (match-beginning 3) e3 (match-end 3)) + (catch :skip + (and (org-at-date-range-p) (throw :skip nil)) + (org-agenda-skip) + (if (and (match-end 1) + (not (= d1 (org-time-string-to-absolute + (match-string 1) d1 nil + org-agenda-repeating-timestamp-show-all)))) + (throw :skip nil)) + (if (and e3 + (not (org-diary-sexp-entry (buffer-substring b3 e3) "" date))) + (throw :skip nil)) + (setq tmp (buffer-substring (max (point-min) + (- b0 org-ds-keyword-length)) + b0) + timestr (if b3 "" (buffer-substring b0 (point-at-eol))) + inactivep (= (char-after b0) ?\[) + deadlinep (string-match org-deadline-regexp tmp) + scheduledp (string-match org-scheduled-regexp tmp) + closedp (and org-agenda-include-inactive-timestamps + (string-match org-closed-string tmp)) + clockp (and org-agenda-include-inactive-timestamps + (or (string-match org-clock-string tmp) + (string-match "]-+\\'" tmp))) + todo-state (ignore-errors (org-get-todo-state)) + donep (member todo-state org-done-keywords)) + (if (or scheduledp deadlinep closedp clockp + (and donep org-agenda-skip-timestamp-if-done)) + (throw :skip t)) + (if (string-match ">" timestr) + ;; substring should only run to end of time stamp + (setq timestr (substring timestr 0 (match-end 0)))) + (setq marker (org-agenda-new-marker b0) + category (org-get-category b0)) + (save-excursion + (if (not (re-search-backward "^\\*+ " nil t)) + (setq txt org-agenda-no-heading-message) + (goto-char (match-beginning 0)) + (setq hdmarker (org-agenda-new-marker) + tags (org-get-tags-at)) + (looking-at "\\*+[ \t]+\\([^\r\n]+\\)") + (setq head (match-string 1)) + (setq txt (org-format-agenda-item + (if inactivep org-agenda-inactive-leader nil) + head category tags timestr nil + remove-re))) + (setq priority (org-get-priority txt)) + (org-add-props txt props + 'org-marker marker 'org-hd-marker hdmarker) + (org-add-props txt nil 'priority priority + 'org-category category 'date date + 'todo-state todo-state + 'type "timestamp") + (push txt ee)) + (if org-agenda-skip-additional-timestamps-same-entry + (outline-next-heading) + (goto-char end-of-match)))) + (nreverse ee))) + +(defun org-agenda-get-sexps () + "Return the sexp information for agenda display." + (require 'diary-lib) + (let* ((props (list 'face nil + 'mouse-face 'highlight + 'help-echo + (format "mouse-2 or RET jump to org file %s" + (abbreviate-file-name buffer-file-name)))) + (regexp "^&?%%(") + marker category ee txt tags entry result beg b sexp sexp-entry + todo-state) + (goto-char (point-min)) + (while (re-search-forward regexp nil t) + (catch :skip + (org-agenda-skip) + (setq beg (match-beginning 0)) + (goto-char (1- (match-end 0))) + (setq b (point)) + (forward-sexp 1) + (setq sexp (buffer-substring b (point))) + (setq sexp-entry (if (looking-at "[ \t]*\\(\\S-.*\\)") + (org-trim (match-string 1)) + "")) + (setq result (org-diary-sexp-entry sexp sexp-entry date)) + (when result + (setq marker (org-agenda-new-marker beg) + category (org-get-category beg) + todo-state (org-get-todo-state)) + + (dolist (r (if (stringp result) + (list result) + result)) ;; we expect a list here + (if (string-match "\\S-" r) + (setq txt r) + (setq txt "SEXP entry returned empty string")) + + (setq txt (org-format-agenda-item + "" txt category tags 'time)) + (org-add-props txt props 'org-marker marker) + (org-add-props txt nil + 'org-category category 'date date 'todo-state todo-state + 'type "sexp") + (push txt ee))))) + (nreverse ee))) + +(defun org-diary-class (m1 d1 y1 m2 d2 y2 dayname &rest skip-weeks) + "Entry applies if date is between dates on DAYNAME, but skips SKIP-WEEKS. +The order of the first 2 times 3 arguments depends on the variable +`calendar-date-style' or, if that is not defined, on `european-calendar-style'. +So for American calendars, give this as MONTH DAY YEAR, for European as +DAY MONTH YEAR, and for ISO as YEAR MONTH DAY. +DAYNAME is a number between 0 (Sunday) and 6 (Saturday). SKIP-WEEKS +is any number of ISO weeks in the block period for which the item should +be skipped." + (let* ((date1 (calendar-absolute-from-gregorian + (org-order-calendar-date-args m1 d1 y1))) + (date2 (calendar-absolute-from-gregorian + (org-order-calendar-date-args m2 d2 y2))) + (d (calendar-absolute-from-gregorian date))) + (and + (<= date1 d) + (<= d date2) + (= (calendar-day-of-week date) dayname) + (or (not skip-weeks) + (progn + (require 'cal-iso) + (not (member (car (calendar-iso-from-absolute d)) skip-weeks)))) + entry))) + +(defalias 'org-get-closed 'org-agenda-get-progress) +(defun org-agenda-get-progress () + "Return the logged TODO entries for agenda display." + (let* ((props (list 'mouse-face 'highlight + 'org-not-done-regexp org-not-done-regexp + 'org-todo-regexp org-todo-regexp + 'org-complex-heading-regexp org-complex-heading-regexp + 'help-echo + (format "mouse-2 or RET jump to org file %s" + (abbreviate-file-name buffer-file-name)))) + (items (if (consp org-agenda-show-log) + org-agenda-show-log + org-agenda-log-mode-items)) + (parts + (delq nil + (list + (if (memq 'closed items) (concat "\\<" org-closed-string)) + (if (memq 'clock items) (concat "\\<" org-clock-string)) + (if (memq 'state items) "- State \"\\([a-zA-Z0-9]+\\)\".*?")))) + (parts-re (if parts (mapconcat 'identity parts "\\|") + (error "`org-agenda-log-mode-items' is empty"))) + (regexp (concat + "\\(" parts-re "\\)" + " *\\[" + (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)))) + (org-agenda-search-headline-for-time nil) + marker hdmarker priority category tags closedp statep clockp state + ee txt extra timestr rest clocked) + (goto-char (point-min)) + (while (re-search-forward regexp nil t) + (catch :skip + (org-agenda-skip) + (setq marker (org-agenda-new-marker (match-beginning 0)) + closedp (equal (match-string 1) org-closed-string) + statep (equal (string-to-char (match-string 1)) ?-) + clockp (not (or closedp statep)) + state (and statep (match-string 2)) + category (org-get-category (match-beginning 0)) + timestr (buffer-substring (match-beginning 0) (point-at-eol)) + ) + (when (string-match "\\]" timestr) + ;; substring should only run to end of time stamp + (setq rest (substring timestr (match-end 0)) + timestr (substring timestr 0 (match-end 0))) + (if (and (not closedp) (not statep) + (string-match "\\([0-9]\\{1,2\\}:[0-9]\\{2\\}\\)\\].*?\\([0-9]\\{1,2\\}:[0-9]\\{2\\}\\)" rest)) + (progn (setq timestr (concat (substring timestr 0 -1) + "-" (match-string 1 rest) "]")) + (setq clocked (match-string 2 rest))) + (setq clocked "-"))) + (save-excursion + (setq extra nil) + (cond + ((not org-agenda-log-mode-add-notes)) + (statep + (and (looking-at ".*\n[ \t]*\\([^-\n \t].*?\\)[ \t]*$") + (setq extra (match-string 1)))) + (clockp + (and (looking-at ".*\n[ \t]*-[ \t]+\\([^-\n \t].*?\\)[ \t]*$") + (setq extra (match-string 1))))) + (if (not (re-search-backward "^\\*+ " nil t)) + (setq txt org-agenda-no-heading-message) + (goto-char (match-beginning 0)) + (setq hdmarker (org-agenda-new-marker) + tags (org-get-tags-at)) + (looking-at "\\*+[ \t]+\\([^\r\n]+\\)") + (setq txt (match-string 1)) + (when extra + (if (string-match "\\([ \t]+\\)\\(:[^ \n\t]*?:\\)[ \t]*$" txt) + (setq txt (concat (substring txt 0 (match-beginning 1)) + " - " extra " " (match-string 2 txt))) + (setq txt (concat txt " - " extra)))) + (setq txt (org-format-agenda-item + (cond + (closedp "Closed: ") + (statep (concat "State: (" state ")")) + (t (concat "Clocked: (" clocked ")"))) + txt category tags timestr))) + (setq priority 100000) + (org-add-props txt props + 'org-marker marker 'org-hd-marker hdmarker 'face 'org-agenda-done + 'priority priority 'org-category category + 'type "closed" 'date date + 'undone-face 'org-warning 'done-face 'org-agenda-done) + (push txt ee)) + (goto-char (point-at-eol)))) + (nreverse ee))) + +(defun org-agenda-get-deadlines () + "Return the deadline information for agenda display." + (let* ((props (list 'mouse-face 'highlight + 'org-not-done-regexp org-not-done-regexp + 'org-todo-regexp org-todo-regexp + 'org-complex-heading-regexp org-complex-heading-regexp + 'help-echo + (format "mouse-2 or RET jump to org file %s" + (abbreviate-file-name buffer-file-name)))) + (regexp org-deadline-time-regexp) + (todayp (org-agenda-todayp date)) ; DATE bound by calendar + (d1 (calendar-absolute-from-gregorian date)) ; DATE bound by calendar + d2 diff dfrac wdays pos pos1 category tags + suppress-prewarning + ee txt head face s todo-state upcomingp donep timestr) + (goto-char (point-min)) + (while (re-search-forward regexp nil t) + (setq suppress-prewarning nil) + (catch :skip + (org-agenda-skip) + (when (and org-agenda-skip-deadline-prewarning-if-scheduled + (save-match-data + (string-match org-scheduled-time-regexp + (buffer-substring (point-at-bol) + (point-at-eol))))) + (setq suppress-prewarning + (if (integerp org-agenda-skip-deadline-prewarning-if-scheduled) + org-agenda-skip-deadline-prewarning-if-scheduled + 0))) + (setq s (match-string 1) + txt nil + pos (1- (match-beginning 1)) + d2 (org-time-string-to-absolute + (match-string 1) d1 'past + org-agenda-repeating-timestamp-show-all) + diff (- d2 d1) + wdays (if suppress-prewarning + (let ((org-deadline-warning-days suppress-prewarning)) + (org-get-wdays s)) + (org-get-wdays s)) + dfrac (/ (* 1.0 (- wdays diff)) (max wdays 1)) + upcomingp (and todayp (> diff 0))) + ;; When to show a deadline in the calendar: + ;; If the expiration is within wdays warning time. + ;; Past-due deadlines are only shown on the current date + (if (and (or (and (<= diff wdays) + (and todayp (not org-agenda-only-exact-dates))) + (= diff 0))) + (save-excursion + (setq todo-state (org-get-todo-state)) + (setq donep (member todo-state org-done-keywords)) + (if (and donep + (or org-agenda-skip-deadline-if-done + (not (= diff 0)))) + (setq txt nil) + (setq category (org-get-category)) + (if (not (re-search-backward "^\\*+[ \t]+" nil t)) + (setq txt org-agenda-no-heading-message) + (goto-char (match-end 0)) + (setq pos1 (match-beginning 0)) + (setq tags (org-get-tags-at pos1)) + (setq head (buffer-substring-no-properties + (point) + (progn (skip-chars-forward "^\r\n") + (point)))) + (if (string-match " \\([012]?[0-9]:[0-9][0-9]\\)" s) + (setq timestr + (concat (substring s (match-beginning 1)) " ")) + (setq timestr 'time)) + (setq txt (org-format-agenda-item + (if (= diff 0) + (car org-agenda-deadline-leaders) + (if (functionp + (nth 1 org-agenda-deadline-leaders)) + (funcall + (nth 1 org-agenda-deadline-leaders) + diff date) + (format (nth 1 org-agenda-deadline-leaders) + diff))) + head category tags + (if (not (= diff 0)) nil timestr))))) + (when txt + (setq face (org-agenda-deadline-face dfrac wdays)) + (org-add-props txt props + 'org-marker (org-agenda-new-marker pos) + 'org-hd-marker (org-agenda-new-marker pos1) + 'priority (+ (- diff) + (org-get-priority txt)) + 'org-category category + 'todo-state todo-state + 'type (if upcomingp "upcoming-deadline" "deadline") + 'date (if upcomingp date d2) + 'face (if donep 'org-agenda-done face) + 'undone-face face 'done-face 'org-agenda-done) + (push txt ee)))))) + (nreverse ee))) + +(defun org-agenda-deadline-face (fraction &optional wdays) + "Return the face to displaying a deadline item. +FRACTION is what fraction of the head-warning time has passed." + (if (equal wdays 0) (setq fraction 1.)) + (let ((faces org-agenda-deadline-faces) f) + (catch 'exit + (while (setq f (pop faces)) + (if (>= fraction (car f)) (throw 'exit (cdr f))))))) + +(defun org-agenda-get-scheduled (&optional deadline-results) + "Return the scheduled information for agenda display." + (let* ((props (list 'org-not-done-regexp org-not-done-regexp + 'org-todo-regexp org-todo-regexp + 'org-complex-heading-regexp org-complex-heading-regexp + 'done-face 'org-agenda-done + 'mouse-face 'highlight + 'help-echo + (format "mouse-2 or RET jump to org file %s" + (abbreviate-file-name buffer-file-name)))) + (regexp org-scheduled-time-regexp) + (todayp (org-agenda-todayp date)) ; DATE bound by calendar + (d1 (calendar-absolute-from-gregorian date)) ; DATE bound by calendar + mm + (deadline-position-alist + (mapcar (lambda (a) (and (setq mm (get-text-property + 0 'org-hd-marker a)) + (cons (marker-position mm) a))) + deadline-results)) + d2 diff pos pos1 category tags donep + ee txt head pastschedp todo-state face timestr s habitp) + (goto-char (point-min)) + (while (re-search-forward regexp nil t) + (catch :skip + (org-agenda-skip) + (setq s (match-string 1) + txt nil + pos (1- (match-beginning 1)) + d2 (org-time-string-to-absolute + (match-string 1) d1 'past + org-agenda-repeating-timestamp-show-all) + diff (- d2 d1)) + (setq pastschedp (and todayp (< diff 0))) + ;; When to show a scheduled item in the calendar: + ;; If it is on or past the date. + (when (or (and (< diff 0) + (< (abs diff) org-scheduled-past-days) + (and todayp (not org-agenda-only-exact-dates))) + (= diff 0)) + (save-excursion + (setq todo-state (org-get-todo-state)) + (setq donep (member todo-state org-done-keywords)) + (setq habitp (and (functionp 'org-is-habit-p) + (org-is-habit-p))) + (if (and donep + (or habitp org-agenda-skip-scheduled-if-done + (not (= diff 0)))) + (setq txt nil) + (setq category (org-get-category)) + (if (not (re-search-backward "^\\*+[ \t]+" nil t)) + (setq txt org-agenda-no-heading-message) + (goto-char (match-end 0)) + (setq pos1 (match-beginning 0)) + (if habitp + (if (or (not org-habit-show-habits) + (and (not todayp) + org-habit-show-habits-only-for-today)) + (throw :skip nil)) + (if (and + (or (eq t org-agenda-skip-scheduled-if-deadline-is-shown) + (and org-agenda-skip-scheduled-if-deadline-is-shown + pastschedp)) + (setq mm (assoc pos1 deadline-position-alist))) + (throw :skip nil))) + (setq tags (org-get-tags-at)) + (setq head (buffer-substring-no-properties + (point) + (progn (skip-chars-forward "^\r\n") (point)))) + (if (string-match " \\([012]?[0-9]:[0-9][0-9]\\)" s) + (setq timestr + (concat (substring s (match-beginning 1)) " ")) + (setq timestr 'time)) + (setq txt (org-format-agenda-item + (if (= diff 0) + (car org-agenda-scheduled-leaders) + (format (nth 1 org-agenda-scheduled-leaders) + (- 1 diff))) + head category tags + (if (not (= diff 0)) nil timestr) + nil nil habitp)))) + (when txt + (setq face + (cond + ((and (not habitp) pastschedp) + 'org-scheduled-previously) + (todayp 'org-scheduled-today) + (t 'org-scheduled)) + habitp (and habitp (org-habit-parse-todo))) + (org-add-props txt props + 'undone-face face + 'face (if donep 'org-agenda-done face) + 'org-marker (org-agenda-new-marker pos) + 'org-hd-marker (org-agenda-new-marker pos1) + 'type (if pastschedp "past-scheduled" "scheduled") + 'date (if pastschedp d2 date) + 'priority (if habitp + (org-habit-get-priority habitp) + (+ 94 (- 5 diff) (org-get-priority txt))) + 'org-category category + 'org-habit-p habitp + 'todo-state todo-state) + (push txt ee)))))) + (nreverse ee))) + +(defun org-agenda-get-blocks () + "Return the date-range information for agenda display." + (let* ((props (list 'face nil + 'org-not-done-regexp org-not-done-regexp + 'org-todo-regexp org-todo-regexp + 'org-complex-heading-regexp org-complex-heading-regexp + 'mouse-face 'highlight + 'help-echo + (format "mouse-2 or RET jump to org file %s" + (abbreviate-file-name buffer-file-name)))) + (regexp org-tr-regexp) + (d0 (calendar-absolute-from-gregorian date)) + marker hdmarker ee txt d1 d2 s1 s2 timestr category todo-state tags pos + head donep) + (goto-char (point-min)) + (while (re-search-forward regexp nil t) + (catch :skip + (org-agenda-skip) + (setq pos (point)) + (setq timestr (match-string 0) + s1 (match-string 1) + s2 (match-string 2) + d1 (time-to-days (org-time-string-to-time s1)) + d2 (time-to-days (org-time-string-to-time s2))) + (if (and (> (- d0 d1) -1) (> (- d2 d0) -1)) + ;; Only allow days between the limits, because the normal + ;; date stamps will catch the limits. + (save-excursion + (setq todo-state (org-get-todo-state)) + (setq donep (member todo-state org-done-keywords)) + (if (and donep org-agenda-skip-timestamp-if-done) + (throw :skip t)) + (setq marker (org-agenda-new-marker (point))) + (setq category (org-get-category)) + (if (not (re-search-backward "^\\*+ " nil t)) + (setq txt org-agenda-no-heading-message) + (goto-char (match-beginning 0)) + (setq hdmarker (org-agenda-new-marker (point))) + (setq tags (org-get-tags-at)) + (looking-at "\\*+[ \t]+\\([^\r\n]+\\)") + (setq head (match-string 1)) + (let ((remove-re + (if org-agenda-remove-timeranges-from-blocks + (concat + "<" (regexp-quote s1) ".*?>" + "--" + "<" (regexp-quote s2) ".*?>") + nil))) + (setq txt (org-format-agenda-item + (format + (nth (if (= d1 d2) 0 1) + org-agenda-timerange-leaders) + (1+ (- d0 d1)) (1+ (- d2 d1))) + head category tags + timestr nil remove-re)))) + (org-add-props txt props + 'org-marker marker 'org-hd-marker hdmarker + 'type "block" 'date date + 'todo-state todo-state + 'priority (org-get-priority txt) 'org-category category) + (push txt ee))) + (goto-char pos))) + ;; Sort the entries by expiration date. + (nreverse ee))) + +;;; Agenda presentation and sorting + +(defvar org-prefix-has-time nil + "A flag, set by `org-compile-prefix-format'. +The flag is set if the currently compiled format contains a `%t'.") +(defvar org-prefix-has-tag nil + "A flag, set by `org-compile-prefix-format'. +The flag is set if the currently compiled format contains a `%T'.") +(defvar org-prefix-has-effort nil + "A flag, set by `org-compile-prefix-format'. +The flag is set if the currently compiled format contains a `%e'.") +(defvar org-prefix-category-length nil + "Used by `org-compile-prefix-format' to remember the category field width.") +(defvar org-prefix-category-max-length nil + "Used by `org-compile-prefix-format' to remember the category field width.") + +(defun org-agenda-get-category-icon (category) + "Return an image for CATEGORY according to `org-agenda-category-icon-alist'." + (dolist (entry org-agenda-category-icon-alist) + (when (org-string-match-p (car entry) category) + (if (listp (cadr entry)) + (return (cadr entry)) + (return (apply 'create-image (cdr entry))))))) + +(defun org-format-agenda-item (extra txt &optional category tags dotime + noprefix remove-re habitp) + "Format TXT to be inserted into the agenda buffer. +In particular, it adds the prefix and corresponding text properties. EXTRA +must be a string and replaces the `%s' specifier in the prefix format. +CATEGORY (string, symbol or nil) may be used to overrule the default +category taken from local variable or file name. It will replace the `%c' +specifier in the format. DOTIME, when non-nil, indicates that a +time-of-day should be extracted from TXT for sorting of this entry, and for +the `%t' specifier in the format. When DOTIME is a string, this string is +searched for a time before TXT is. NOPREFIX is a flag and indicates that +only the correctly processes TXT should be returned - this is used by +`org-agenda-change-all-lines'. TAGS can be the tags of the headline. +Any match of REMOVE-RE will be removed from TXT." + (save-match-data + ;; Diary entries sometimes have extra whitespace at the beginning + (if (string-match "^ +" txt) (setq txt (replace-match "" nil nil txt))) + + ;; Fix the tags part in txt + (setq txt (org-agenda-fix-displayed-tags + txt tags + org-agenda-show-inherited-tags + org-agenda-hide-tags-regexp)) + (let* ((category (or category + (if (stringp org-category) + org-category + (and org-category (symbol-name org-category))) + (if buffer-file-name + (file-name-sans-extension + (file-name-nondirectory buffer-file-name)) + ""))) + (category-icon (org-agenda-get-category-icon category)) + (category-icon (if category-icon + (propertize " " 'display category-icon) + "")) + ;; time, tag, effort are needed for the eval of the prefix format + (tag (if tags (nth (1- (length tags)) tags) "")) + time effort neffort + (ts (if dotime (concat + (if (stringp dotime) dotime "") + (and org-agenda-search-headline-for-time txt)))) + (time-of-day (and dotime (org-get-time-of-day ts))) + stamp plain s0 s1 s2 t1 t2 rtn srp l + duration thecategory) + (and (org-mode-p) buffer-file-name + (add-to-list 'org-agenda-contributing-files buffer-file-name)) + (when (and dotime time-of-day) + ;; Extract starting and ending time and move them to prefix + (when (or (setq stamp (string-match org-stamp-time-of-day-regexp ts)) + (setq plain (string-match org-plain-time-of-day-regexp ts))) + (setq s0 (match-string 0 ts) + srp (and stamp (match-end 3)) + s1 (match-string (if plain 1 2) ts) + s2 (match-string (if plain 8 (if srp 4 6)) ts)) + + ;; If the times are in TXT (not in DOTIMES), and the prefix will list + ;; them, we might want to remove them there to avoid duplication. + ;; The user can turn this off with a variable. + (if (and org-prefix-has-time + org-agenda-remove-times-when-in-prefix (or stamp plain) + (string-match (concat (regexp-quote s0) " *") txt) + (not (equal ?\] (string-to-char (substring txt (match-end 0))))) + (if (eq org-agenda-remove-times-when-in-prefix 'beg) + (= (match-beginning 0) 0) + t)) + (setq txt (replace-match "" nil nil txt)))) + ;; Normalize the time(s) to 24 hour + (if s1 (setq s1 (org-get-time-of-day s1 'string t))) + (if s2 (setq s2 (org-get-time-of-day s2 'string t))) + ;; Compute the duration + (when s1 + (setq t1 (+ (* 60 (string-to-number (substring s1 0 2))) + (string-to-number (substring s1 3))) + t2 (cond + (s2 (+ (* 60 (string-to-number (substring s2 0 2))) + (string-to-number (substring s2 3)))) + (org-agenda-default-appointment-duration + (+ t1 org-agenda-default-appointment-duration)) + (t nil))) + (setq duration (if t2 (- t2 t1))))) + + (when (and s1 (not s2) org-agenda-default-appointment-duration + (string-match "\\([0-9]+\\):\\([0-9]+\\)" s1)) + (let ((m (+ (string-to-number (match-string 2 s1)) + (* 60 (string-to-number (match-string 1 s1))) + org-agenda-default-appointment-duration)) + h) + (setq h (/ m 60) m (- m (* h 60))) + (setq s2 (format "%02d:%02d" h m)))) + + (when (string-match (org-re "\\([ \t]+\\)\\(:[[:alnum:]_@#%:]+:\\)[ \t]*$") + txt) + ;; Tags are in the string + (if (or (eq org-agenda-remove-tags t) + (and org-agenda-remove-tags + org-prefix-has-tag)) + (setq txt (replace-match "" t t txt)) + (setq txt (replace-match + (concat (make-string (max (- 50 (length txt)) 1) ?\ ) + (match-string 2 txt)) + t t txt)))) + (when (org-mode-p) + (setq effort + (condition-case nil + (org-get-effort + (or (get-text-property 0 'org-hd-marker txt) + (get-text-property 0 'org-marker txt))) + (error nil))) + (when effort + (setq neffort (org-hh:mm-string-to-minutes effort) + effort (setq effort (concat "[" effort "]" ))))) + + (when remove-re + (while (string-match remove-re txt) + (setq txt (replace-match "" t t txt)))) + + ;; Create the final string + (if noprefix + (setq rtn txt) + ;; Prepare the variables needed in the eval of the compiled format + (setq time (cond (s2 (concat + (org-agenda-time-of-day-to-ampm-maybe s1) + "-" (org-agenda-time-of-day-to-ampm-maybe s2) + (if org-agenda-timegrid-use-ampm " "))) + (s1 (concat + (org-agenda-time-of-day-to-ampm-maybe s1) + (if org-agenda-timegrid-use-ampm + "........ " + "......"))) + (t "")) + extra (or (and (not habitp) extra) "") + category (if (symbolp category) (symbol-name category) category) + thecategory (copy-sequence category)) + (if (string-match org-bracket-link-regexp category) + (progn + (setq l (if (match-end 3) + (- (match-end 3) (match-beginning 3)) + (- (match-end 1) (match-beginning 1)))) + (when (< l (or org-prefix-category-length 0)) + (setq category (copy-sequence category)) + (org-add-props category nil + 'extra-space (make-string + (- org-prefix-category-length l 1) ?\ )))) + (if (and org-prefix-category-max-length + (>= (length category) org-prefix-category-max-length)) + (setq category (substring category 0 (1- org-prefix-category-max-length))))) + ;; Evaluate the compiled format + (setq rtn (concat (eval org-prefix-format-compiled) txt))) + + ;; And finally add the text properties + (remove-text-properties 0 (length rtn) '(line-prefix t wrap-prefix t) rtn) + (org-add-props rtn nil + 'org-category (if thecategory (downcase thecategory) category) + 'tags (mapcar 'org-downcase-keep-props tags) + 'org-highest-priority org-highest-priority + 'org-lowest-priority org-lowest-priority + 'prefix-length (- (length rtn) (length txt)) + 'time-of-day time-of-day + 'duration duration + 'effort effort + 'effort-minutes neffort + 'txt txt + 'time time + 'extra extra + 'dotime dotime)))) + +(defun org-agenda-fix-displayed-tags (txt tags add-inherited hide-re) + "Remove tags string from TXT, and add a modified list of tags. +The modified list may contain inherited tags, and tags matched by +`org-agenda-hide-tags-regexp' will be removed." + (when (or add-inherited hide-re) + (if (string-match (org-re "\\([ \t]+\\)\\(:[[:alnum:]_@#%:]+:\\)[ \t]*$") txt) + (setq txt (substring txt 0 (match-beginning 0)))) + (setq tags + (delq nil + (mapcar (lambda (tg) + (if (or (and hide-re (string-match hide-re tg)) + (and (not add-inherited) + (get-text-property 0 'inherited tg))) + nil + tg)) + tags))) + (when tags + (let ((have-i (get-text-property 0 'inherited (car tags))) + i) + (setq txt (concat txt " :" + (mapconcat + (lambda (x) + (setq i (get-text-property 0 'inherited x)) + (if (and have-i (not i)) + (progn + (setq have-i nil) + (concat ":" x)) + x)) + tags ":") + (if have-i "::" ":")))))) + txt) + +(defun org-downcase-keep-props (s) + (let ((props (text-properties-at 0 s))) + (setq s (downcase s)) + (add-text-properties 0 (length s) props s) + s)) + +(defvar org-agenda-sorting-strategy) ;; because the def is in a let form +(defvar org-agenda-sorting-strategy-selected nil) + +(defun org-agenda-add-time-grid-maybe (list ndays todayp) + (catch 'exit + (cond ((not org-agenda-use-time-grid) (throw 'exit list)) + ((and todayp (member 'today (car org-agenda-time-grid)))) + ((and (= ndays 1) (member 'daily (car org-agenda-time-grid)))) + ((member 'weekly (car org-agenda-time-grid))) + (t (throw 'exit list))) + (let* ((have (delq nil (mapcar + (lambda (x) (get-text-property 1 'time-of-day x)) + list))) + (string (nth 1 org-agenda-time-grid)) + (gridtimes (nth 2 org-agenda-time-grid)) + (req (car org-agenda-time-grid)) + (remove (member 'remove-match req)) + new time) + (if (and (member 'require-timed req) (not have)) + ;; don't show empty grid + (throw 'exit list)) + (while (setq time (pop gridtimes)) + (unless (and remove (member time have)) + (setq time (replace-regexp-in-string " " "0" (format "%04s" time))) + (push (org-format-agenda-item + nil string "" nil + (concat (substring time 0 -2) ":" (substring time -2))) + new) + (put-text-property + 2 (length (car new)) 'face 'org-time-grid (car new)))) + (if (member 'time-up org-agenda-sorting-strategy-selected) + (append new list) + (append list new))))) + +(defun org-compile-prefix-format (key) + "Compile the prefix format into a Lisp form that can be evaluated. +The resulting form is returned and stored in the variable +`org-prefix-format-compiled'." + (setq org-prefix-has-time nil org-prefix-has-tag nil + org-prefix-category-length nil org-prefix-has-effort nil) + (let ((s (cond + ((stringp org-agenda-prefix-format) + org-agenda-prefix-format) + ((assq key org-agenda-prefix-format) + (cdr (assq key org-agenda-prefix-format))) + (t " %-12:c%?-12t% s"))) + (start 0) + varform vars var e c f opt) + (while (string-match "%\\(\\?\\)?\\([-+]?[0-9.]*\\)\\([ .;,:!?=|/<>]?\\)\\([ctsei]\\)" + s start) + (setq var (cdr (assoc (match-string 4 s) + '(("c" . category) ("t" . time) ("s" . extra) + ("i" . category-icon) ("T" . tag) ("e" . effort)))) + c (or (match-string 3 s) "") + opt (match-beginning 1) + start (1+ (match-beginning 0))) + (if (equal var 'time) (setq org-prefix-has-time t)) + (if (equal var 'tag) (setq org-prefix-has-tag t)) + (if (equal var 'effort) (setq org-prefix-has-effort t)) + (setq f (concat "%" (match-string 2 s) "s")) + (when (equal var 'category) + (setq org-prefix-category-length + (floor (abs (string-to-number (match-string 2 s))))) + (setq org-prefix-category-max-length + (let ((x (match-string 2 s))) + (save-match-data + (if (string-match "\\.[0-9]+" x) + (string-to-number (substring (match-string 0 x) 1))))))) + (if opt + (setq varform + `(if (equal "" ,var) + "" + (format ,f (if (equal "" ,var) "" (concat ,var ,c))))) + (setq varform `(format ,f (if (equal ,var "") "" (concat ,var ,c (get-text-property 0 'extra-space ,var)))))) + (setq s (replace-match "%s" t nil s)) + (push varform vars)) + (setq vars (nreverse vars)) + (setq org-prefix-format-compiled `(format ,s ,@vars)))) + +(defun org-set-sorting-strategy (key) + (if (symbolp (car org-agenda-sorting-strategy)) + ;; the old format + (setq org-agenda-sorting-strategy-selected org-agenda-sorting-strategy) + (setq org-agenda-sorting-strategy-selected + (or (cdr (assq key org-agenda-sorting-strategy)) + (cdr (assq 'agenda org-agenda-sorting-strategy)) + '(time-up category-keep priority-down))))) + +(defun org-get-time-of-day (s &optional string mod24) + "Check string S for a time of day. +If found, return it as a military time number between 0 and 2400. +If not found, return nil. +The optional STRING argument forces conversion into a 5 character wide string +HH:MM." + (save-match-data + (when + (or (string-match "\\<\\([012]?[0-9]\\)\\(:\\([0-5][0-9]\\)\\)\\([AaPp][Mm]\\)?\\> *" s) + (string-match "\\<\\([012]?[0-9]\\)\\(:\\([0-5][0-9]\\)\\)?\\([AaPp][Mm]\\)\\> *" s)) + (let* ((h (string-to-number (match-string 1 s))) + (m (if (match-end 3) (string-to-number (match-string 3 s)) 0)) + (ampm (if (match-end 4) (downcase (match-string 4 s)))) + (am-p (equal ampm "am")) + (h1 (cond ((not ampm) h) + ((= h 12) (if am-p 0 12)) + (t (+ h (if am-p 0 12))))) + (h2 (if (and string mod24 (not (and (= m 0) (= h1 24)))) + (mod h1 24) h1)) + (t0 (+ (* 100 h2) m)) + (t1 (concat (if (>= h1 24) "+" " ") + (if (and org-agenda-time-leading-zero + (< t0 1000)) "0" "") + (if (< t0 100) "0" "") + (if (< t0 10) "0" "") + (int-to-string t0)))) + (if string (concat (substring t1 -4 -2) ":" (substring t1 -2)) t0))))) + +(defvar org-agenda-before-sorting-filter-function nil + "Function to be applied to agenda items prior to sorting. +Prior to sorting also means just before they are inserted into the agenda. + +To aid sorting, you may revisit the original entries and add more text +properties which will later be used by the sorting functions. + +The function should take a string argument, an agenda line. +It has access to the text properties in that line, which contain among +other things, the property `org-hd-marker' that points to the entry +where the line comes from. Note that not all lines going into the agenda +have this property, only most. + +The function should return the modified string. It is probably best +to ONLY change text properties. + +You can also use this function as a filter, by returning nil for lines +you don't want to have in the agenda at all. For this application, you +could bind the variable in the options section of a custom command.") + +(defun org-finalize-agenda-entries (list &optional nosort) + "Sort and concatenate the agenda items." + (setq list (mapcar 'org-agenda-highlight-todo list)) + (if nosort + list + (when org-agenda-before-sorting-filter-function + (setq list (delq nil (mapcar org-agenda-before-sorting-filter-function list)))) + (mapconcat 'identity (sort list 'org-entries-lessp) "\n"))) + +(defun org-agenda-highlight-todo (x) + (let ((org-done-keywords org-done-keywords-for-agenda) + (case-fold-search nil) + re pl) + (if (eq x 'line) + (save-excursion + (beginning-of-line 1) + (setq re (org-get-at-bol 'org-todo-regexp)) + (goto-char (+ (point) (or (org-get-at-bol 'prefix-length) 0))) + (when (looking-at (concat "[ \t]*\\.*\\(" re "\\) +")) + (add-text-properties (match-beginning 0) (match-end 1) + (list 'face (org-get-todo-face 1))) + (let ((s (buffer-substring (match-beginning 1) (match-end 1)))) + (delete-region (match-beginning 1) (1- (match-end 0))) + (goto-char (match-beginning 1)) + (insert (format org-agenda-todo-keyword-format s))))) + (setq re (concat (get-text-property 0 'org-todo-regexp x)) + pl (get-text-property 0 'prefix-length x)) + (when (and re + (equal (string-match (concat "\\(\\.*\\)" re "\\( +\\)") + x (or pl 0)) pl)) + (add-text-properties + (or (match-end 1) (match-end 0)) (match-end 0) + (list 'face (org-get-todo-face (match-string 2 x))) + x) + (when (match-end 1) + (setq x (concat (substring x 0 (match-end 1)) + (format org-agenda-todo-keyword-format + (match-string 2 x)) + (org-add-props " " (text-properties-at 0 x)) + (substring x (match-end 3)))))) + x))) + +(defsubst org-cmp-priority (a b) + "Compare the priorities of string A and B." + (let ((pa (or (get-text-property 1 'priority a) 0)) + (pb (or (get-text-property 1 'priority b) 0))) + (cond ((> pa pb) +1) + ((< pa pb) -1) + (t nil)))) + +(defsubst org-cmp-effort (a b) + "Compare the priorities of string A and B." + (let* ((def (if org-sort-agenda-noeffort-is-high 32767 -1)) + (ea (or (get-text-property 1 'effort-minutes a) def)) + (eb (or (get-text-property 1 'effort-minutes b) def))) + (cond ((> ea eb) +1) + ((< ea eb) -1) + (t nil)))) + +(defsubst org-cmp-category (a b) + "Compare the string values of categories of strings A and B." + (let ((ca (or (get-text-property 1 'org-category a) "")) + (cb (or (get-text-property 1 'org-category b) ""))) + (cond ((string-lessp ca cb) -1) + ((string-lessp cb ca) +1) + (t nil)))) + +(defsubst org-cmp-todo-state (a b) + "Compare the todo states of strings A and B." + (let* ((ma (or (get-text-property 1 'org-marker a) + (get-text-property 1 'org-hd-marker a))) + (mb (or (get-text-property 1 'org-marker b) + (get-text-property 1 'org-hd-marker b))) + (fa (and ma (marker-buffer ma))) + (fb (and mb (marker-buffer mb))) + (todo-kwds + (or (and fa (with-current-buffer fa org-todo-keywords-1)) + (and fb (with-current-buffer fb org-todo-keywords-1)))) + (ta (or (get-text-property 1 'todo-state a) "")) + (tb (or (get-text-property 1 'todo-state b) "")) + (la (- (length (member ta todo-kwds)))) + (lb (- (length (member tb todo-kwds)))) + (donepa (member ta org-done-keywords-for-agenda)) + (donepb (member tb org-done-keywords-for-agenda))) + (cond ((and donepa (not donepb)) -1) + ((and (not donepa) donepb) +1) + ((< la lb) -1) + ((< lb la) +1) + (t nil)))) + +(defsubst org-cmp-alpha (a b) + "Compare the headlines, alphabetically." + (let* ((pla (get-text-property 0 'prefix-length a)) + (plb (get-text-property 0 'prefix-length b)) + (ta (and pla (substring a pla))) + (tb (and plb (substring b plb)))) + (when pla + (if (string-match (concat "\\`[ \t]*" (or (get-text-property 0 'org-todo-regexp a) "") + "\\([ \t]*\\[[a-zA-Z0-9]\\]\\)? *") ta) + (setq ta (substring ta (match-end 0)))) + (setq ta (downcase ta))) + (when plb + (if (string-match (concat "\\`[ \t]*" (or (get-text-property 0 'org-todo-regexp b) "") + "\\([ \t]*\\[[a-zA-Z0-9]\\]\\)? *") tb) + (setq tb (substring tb (match-end 0)))) + (setq tb (downcase tb))) + (cond ((not ta) +1) + ((not tb) -1) + ((string-lessp ta tb) -1) + ((string-lessp tb ta) +1) + (t nil)))) + +(defsubst org-cmp-tag (a b) + "Compare the string values of the first tags of A and B." + (let ((ta (car (last (get-text-property 1 'tags a)))) + (tb (car (last (get-text-property 1 'tags b))))) + (cond ((not ta) +1) + ((not tb) -1) + ((string-lessp ta tb) -1) + ((string-lessp tb ta) +1) + (t nil)))) + +(defsubst org-cmp-time (a b) + "Compare the time-of-day values of strings A and B." + (let* ((def (if org-sort-agenda-notime-is-late 9901 -1)) + (ta (or (get-text-property 1 'time-of-day a) def)) + (tb (or (get-text-property 1 'time-of-day b) def))) + (cond ((< ta tb) -1) + ((< tb ta) +1) + (t nil)))) + +(defsubst org-cmp-habit-p (a b) + "Compare the todo states of strings A and B." + (let ((ha (get-text-property 1 'org-habit-p a)) + (hb (get-text-property 1 'org-habit-p b))) + (cond ((and ha (not hb)) -1) + ((and (not ha) hb) +1) + (t nil)))) + +(defsubst org-em (x y list) (or (memq x list) (memq y list))) + +(defun org-entries-lessp (a b) + "Predicate for sorting agenda entries." + ;; The following variables will be used when the form is evaluated. + ;; So even though the compiler complains, keep them. + (let* ((ss org-agenda-sorting-strategy-selected) + (time-up (and (org-em 'time-up 'time-down ss) + (org-cmp-time a b))) + (time-down (if time-up (- time-up) nil)) + (priority-up (and (org-em 'priority-up 'priority-down ss) + (org-cmp-priority a b))) + (priority-down (if priority-up (- priority-up) nil)) + (effort-up (and (org-em 'effort-up 'effort-down ss) + (org-cmp-effort a b))) + (effort-down (if effort-up (- effort-up) nil)) + (category-up (and (or (org-em 'category-up 'category-down ss) + (memq 'category-keep ss)) + (org-cmp-category a b))) + (category-down (if category-up (- category-up) nil)) + (category-keep (if category-up +1 nil)) + (tag-up (and (org-em 'tag-up 'tag-down ss) + (org-cmp-tag a b))) + (tag-down (if tag-up (- tag-up) nil)) + (todo-state-up (and (org-em 'todo-state-up 'todo-state-down ss) + (org-cmp-todo-state a b))) + (todo-state-down (if todo-state-up (- todo-state-up) nil)) + (habit-up (and (org-em 'habit-up 'habit-down ss) + (org-cmp-habit-p a b))) + (habit-down (if habit-up (- habit-up) nil)) + (alpha-up (and (org-em 'alpha-up 'alpha-down ss) + (org-cmp-alpha a b))) + (alpha-down (if alpha-up (- alpha-up) nil)) + (need-user-cmp (org-em 'user-defined-up 'user-defined-down ss)) + user-defined-up user-defined-down) + (if (and need-user-cmp org-agenda-cmp-user-defined + (functionp org-agenda-cmp-user-defined)) + (setq user-defined-up + (funcall org-agenda-cmp-user-defined a b) + user-defined-down (if user-defined-up (- user-defined-up) nil))) + (cdr (assoc + (eval (cons 'or org-agenda-sorting-strategy-selected)) + '((-1 . t) (1 . nil) (nil . nil)))))) + +;;; Agenda restriction lock + +(defvar org-agenda-restriction-lock-overlay (make-overlay 1 1) + "Overlay to mark the headline to which agenda commands are restricted.") +(overlay-put org-agenda-restriction-lock-overlay + 'face 'org-agenda-restriction-lock) +(overlay-put org-agenda-restriction-lock-overlay + 'help-echo "Agendas are currently limited to this subtree.") +(org-detach-overlay org-agenda-restriction-lock-overlay) + +(defun org-agenda-set-restriction-lock (&optional type) + "Set restriction lock for agenda, to current subtree or file. +Restriction will be the file if TYPE is `file', or if type is the +universal prefix '(4), or if the cursor is before the first headline +in the file. Otherwise, restriction will be to the current subtree." + (interactive "P") + (and (equal type '(4)) (setq type 'file)) + (setq type (cond + (type type) + ((org-at-heading-p) 'subtree) + ((condition-case nil (org-back-to-heading t) (error nil)) + 'subtree) + (t 'file))) + (if (eq type 'subtree) + (progn + (setq org-agenda-restrict t) + (setq org-agenda-overriding-restriction 'subtree) + (put 'org-agenda-files 'org-restrict + (list (buffer-file-name (buffer-base-buffer)))) + (org-back-to-heading t) + (move-overlay org-agenda-restriction-lock-overlay (point) (point-at-eol)) + (move-marker org-agenda-restrict-begin (point)) + (move-marker org-agenda-restrict-end + (save-excursion (org-end-of-subtree t))) + (message "Locking agenda restriction to subtree")) + (put 'org-agenda-files 'org-restrict + (list (buffer-file-name (buffer-base-buffer)))) + (setq org-agenda-restrict nil) + (setq org-agenda-overriding-restriction 'file) + (move-marker org-agenda-restrict-begin nil) + (move-marker org-agenda-restrict-end nil) + (message "Locking agenda restriction to file")) + (setq current-prefix-arg nil) + (org-agenda-maybe-redo)) + +(defun org-agenda-remove-restriction-lock (&optional noupdate) + "Remove the agenda restriction lock." + (interactive "P") + (org-detach-overlay org-agenda-restriction-lock-overlay) + (org-detach-overlay org-speedbar-restriction-lock-overlay) + (setq org-agenda-overriding-restriction nil) + (setq org-agenda-restrict nil) + (put 'org-agenda-files 'org-restrict nil) + (move-marker org-agenda-restrict-begin nil) + (move-marker org-agenda-restrict-end nil) + (setq current-prefix-arg nil) + (message "Agenda restriction lock removed") + (or noupdate (org-agenda-maybe-redo))) + +(defun org-agenda-maybe-redo () + "If there is any window showing the agenda view, update it." + (let ((w (get-buffer-window org-agenda-buffer-name t)) + (w0 (selected-window))) + (when w + (select-window w) + (org-agenda-redo) + (select-window w0) + (if org-agenda-overriding-restriction + (message "Agenda view shifted to new %s restriction" + org-agenda-overriding-restriction) + (message "Agenda restriction lock removed"))))) + +;;; Agenda commands + +(defun org-agenda-check-type (error &rest types) + "Check if agenda buffer is of allowed type. +If ERROR is non-nil, throw an error, otherwise just return nil." + (if (memq org-agenda-type types) + t + (if error + (error "Not allowed in %s-type agenda buffers" org-agenda-type) + nil))) + +(defun org-agenda-quit () + "Exit agenda by removing the window or the buffer." + (interactive) + (if org-agenda-columns-active + (org-columns-quit) + (let ((buf (current-buffer))) + (if (eq org-agenda-window-setup 'other-frame) + (progn + (kill-buffer buf) + (org-agenda-reset-markers) + (org-columns-remove-overlays) + (setq org-agenda-archives-mode nil) + (delete-frame)) + (and (not (eq org-agenda-window-setup 'current-window)) + (not (one-window-p)) + (delete-window)) + (kill-buffer buf) + (org-agenda-reset-markers) + (org-columns-remove-overlays) + (setq org-agenda-archives-mode nil))) + ;; Maybe restore the pre-agenda window configuration. + (and org-agenda-restore-windows-after-quit + (not (eq org-agenda-window-setup 'other-frame)) + org-pre-agenda-window-conf + (set-window-configuration org-pre-agenda-window-conf)))) + +(defun org-agenda-exit () + "Exit agenda by removing the window or the buffer. +Also kill all Org-mode buffers which have been loaded by `org-agenda'. +Org-mode buffers visited directly by the user will not be touched." + (interactive) + (org-release-buffers org-agenda-new-buffers) + (setq org-agenda-new-buffers nil) + (org-agenda-quit)) + +(defun org-agenda-execute (arg) + "Execute another agenda command, keeping same window. +So this is just a shortcut for \\<global-map>`\\[org-agenda]', available +in the agenda." + (interactive "P") + (let ((org-agenda-window-setup 'current-window)) + (org-agenda arg))) + +(defun org-agenda-redo () + "Rebuild Agenda. +When this is the global TODO list, a prefix argument will be interpreted." + (interactive) + (let* ((org-agenda-keep-modes t) + (filter org-agenda-filter) + (preset (get 'org-agenda-filter :preset-filter)) + (org-agenda-filter-while-redo (or filter preset)) + (cols org-agenda-columns-active) + (line (org-current-line)) + (window-line (- line (org-current-line (window-start)))) + (lprops (get 'org-agenda-redo-command 'org-lprops))) + (put 'org-agenda-filter :preset-filter nil) + (and cols (org-columns-quit)) + (message "Rebuilding agenda buffer...") + (org-let lprops '(eval org-agenda-redo-command)) + (setq org-agenda-undo-list nil + org-agenda-pending-undo-list nil) + (message "Rebuilding agenda buffer...done") + (put 'org-agenda-filter :preset-filter preset) + (and (or filter preset) (org-agenda-filter-apply filter)) + (and cols (interactive-p) (org-agenda-columns)) + (org-goto-line line) + (recenter window-line))) + + +(defvar org-global-tags-completion-table nil) +(defvar org-agenda-filter-form nil) +(defun org-agenda-filter-by-tag (strip &optional char narrow) + "Keep only those lines in the agenda buffer that have a specific tag. +The tag is selected with its fast selection letter, as configured. +With prefix argument STRIP, remove all lines that do have the tag. +A lisp caller can specify CHAR. NARROW means that the new tag should be +used to narrow the search - the interactive user can also press `-' or `+' +to switch to narrowing." + (interactive "P") + (let* ((alist org-tag-alist-for-agenda) + (tag-chars (mapconcat + (lambda (x) (if (and (not (symbolp (car x))) + (cdr x)) + (char-to-string (cdr x)) + "")) + alist "")) + (efforts (org-split-string + (or (cdr (assoc (concat org-effort-property "_ALL") + org-global-properties)) + "0 0:10 0:30 1:00 2:00 3:00 4:00 5:00 6:00 7:00 8:00" ""))) + (effort-op org-agenda-filter-effort-default-operator) + (effort-prompt "") + (inhibit-read-only t) + (current org-agenda-filter) + a n tag) + (unless char + (message + "%s by tag [%s ], [TAB], %s[/]:off, [+-]:narrow, [>=<?]:effort: " + (if narrow "Narrow" "Filter") tag-chars + (if org-agenda-auto-exclude-function "[RET], " "")) + (setq char (read-char))) + (when (member char '(?+ ?-)) + ;; Narrowing down + (cond ((equal char ?-) (setq strip t narrow t)) + ((equal char ?+) (setq strip nil narrow t))) + (message + "Narrow by tag [%s ], [TAB], [/]:off, [>=<]:effort: " tag-chars) + (setq char (read-char))) + (when (member char '(?< ?> ?= ??)) + ;; An effort operator + (setq effort-op (char-to-string char)) + (setq alist nil) ; to make sure it will be interpreted as effort. + (unless (equal char ??) + (loop for i from 0 to 9 do + (setq effort-prompt + (concat + effort-prompt " [" + (if (= i 9) "0" (int-to-string (1+ i))) + "]" (nth i efforts)))) + (message "Effort%s: %s " effort-op effort-prompt) + (setq char (read-char)) + (when (or (< char ?0) (> char ?9)) + (error "Need 1-9,0 to select effort" )))) + (when (equal char ?\t) + (unless (local-variable-p 'org-global-tags-completion-table (current-buffer)) + (org-set-local 'org-global-tags-completion-table + (org-global-tags-completion-table))) + (let ((completion-ignore-case t)) + (setq tag (org-icompleting-read + "Tag: " org-global-tags-completion-table)))) + (cond + ((equal char ?\r) + (org-agenda-filter-by-tag-show-all) + (when org-agenda-auto-exclude-function + (setq org-agenda-filter '()) + (dolist (tag (org-agenda-get-represented-tags)) + (let ((modifier (funcall org-agenda-auto-exclude-function tag))) + (if modifier + (push modifier org-agenda-filter)))) + (if (not (null org-agenda-filter)) + (org-agenda-filter-apply org-agenda-filter)))) + ((equal char ?/) + (org-agenda-filter-by-tag-show-all) + (when (get 'org-agenda-filter :preset-filter) + (org-agenda-filter-apply org-agenda-filter))) + ((or (equal char ?\ ) + (setq a (rassoc char alist)) + (and (>= char ?0) (<= char ?9) + (setq n (if (= char ?0) 9 (- char ?0 1)) + tag (concat effort-op (nth n efforts)) + a (cons tag nil))) + (and (= char ??) + (setq tag "?eff") + a (cons tag nil)) + (and tag (setq a (cons tag nil)))) + (org-agenda-filter-by-tag-show-all) + (setq tag (car a)) + (setq org-agenda-filter + (cons (concat (if strip "-" "+") tag) + (if narrow current nil))) + (org-agenda-filter-apply org-agenda-filter)) + (t (error "Invalid tag selection character %c" char))))) + +(defun org-agenda-get-represented-tags () + "Get a list of all tags currently represented in the agenda." + (let (p tags) + (save-excursion + (goto-char (point-min)) + (while (setq p (next-single-property-change (point) 'tags)) + (goto-char p) + (mapc (lambda (x) (add-to-list 'tags x)) + (get-text-property (point) 'tags)))) + tags)) + +(defun org-agenda-filter-by-tag-refine (strip &optional char) + "Refine the current filter. See `org-agenda-filter-by-tag." + (interactive "P") + (org-agenda-filter-by-tag strip char 'refine)) + +(defun org-agenda-filter-make-matcher () + "Create the form that tests a line for the agenda filter." + (let (f f1) + (dolist (x (append (get 'org-agenda-filter :preset-filter) + org-agenda-filter)) + (if (member x '("-" "+")) + (setq f1 (if (equal x "-") 'tags '(not tags))) + (if (string-match "[<=>?]" x) + (setq f1 (org-agenda-filter-effort-form x)) + (setq f1 (list 'member (downcase (substring x 1)) 'tags))) + (if (equal (string-to-char x) ?-) + (setq f1 (list 'not f1)))) + (push f1 f)) + (cons 'and (nreverse f)))) + +(defun org-agenda-filter-effort-form (e) + "Return the form to compare the effort of the current line with what E says. +E looks like \"+<2:25\"." + (let (op) + (setq e (substring e 1)) + (setq op (string-to-char e) e (substring e 1)) + (setq op (cond ((equal op ?<) '<=) + ((equal op ?>) '>=) + ((equal op ??) op) + (t '=))) + (list 'org-agenda-compare-effort (list 'quote op) + (org-hh:mm-string-to-minutes e)))) + +(defun org-agenda-compare-effort (op value) + "Compare the effort of the current line with VALUE, using OP. +If the line does not have an effort defined, return nil." + (let ((eff (org-get-at-bol 'effort-minutes))) + (if (equal op ??) + (not eff) + (funcall op (or eff (if org-sort-agenda-noeffort-is-high 32767 0)) + value)))) + +(defun org-agenda-filter-apply (filter) + "Set FILTER as the new agenda filter and apply it." + (let (tags) + (setq org-agenda-filter filter + org-agenda-filter-form (org-agenda-filter-make-matcher)) + (org-agenda-set-mode-name) + (save-excursion + (goto-char (point-min)) + (while (not (eobp)) + (if (org-get-at-bol 'org-marker) + (progn + (setq tags (org-get-at-bol 'tags)) ; used in eval + (if (not (eval org-agenda-filter-form)) + (org-agenda-filter-by-tag-hide-line)) + (beginning-of-line 2)) + (beginning-of-line 2)))) + (if (get-char-property (point) 'invisible) + (org-agenda-previous-line)))) + +(defun org-agenda-filter-by-tag-hide-line () + (let (ov) + (setq ov (make-overlay (max (point-min) (1- (point-at-bol))) + (point-at-eol))) + (overlay-put ov 'invisible t) + (overlay-put ov 'type 'tags-filter) + (push ov org-agenda-filter-overlays))) + +(defun org-agenda-fix-tags-filter-overlays-at (&optional pos) + (setq pos (or pos (point))) + (save-excursion + (dolist (ov (overlays-at pos)) + (when (and (overlay-get ov 'invisible) + (eq (overlay-get ov 'type) 'tags-filter)) + (goto-char pos) + (if (< (overlay-start ov) (point-at-eol)) + (move-overlay ov (point-at-eol) + (overlay-end ov))))))) + +(defun org-agenda-filter-by-tag-show-all () + (mapc 'delete-overlay org-agenda-filter-overlays) + (setq org-agenda-filter-overlays nil) + (setq org-agenda-filter nil) + (setq org-agenda-filter-form nil) + (org-agenda-set-mode-name)) + +(defun org-agenda-manipulate-query-add () + "Manipulate the query by adding a search term with positive selection. +Positive selection means the term must be matched for selection of an entry." + (interactive) + (org-agenda-manipulate-query ?\[)) +(defun org-agenda-manipulate-query-subtract () + "Manipulate the query by adding a search term with negative selection. +Negative selection means term must not be matched for selection of an entry." + (interactive) + (org-agenda-manipulate-query ?\])) +(defun org-agenda-manipulate-query-add-re () + "Manipulate the query by adding a search regexp with positive selection. +Positive selection means the regexp must match for selection of an entry." + (interactive) + (org-agenda-manipulate-query ?\{)) +(defun org-agenda-manipulate-query-subtract-re () + "Manipulate the query by adding a search regexp with negative selection. +Negative selection means regexp must not match for selection of an entry." + (interactive) + (org-agenda-manipulate-query ?\})) +(defun org-agenda-manipulate-query (char) + (cond + ((memq org-agenda-type '(timeline agenda)) + (let ((org-agenda-include-inactive-timestamps t)) + (org-agenda-redo)) + (message "Display now includes inactive timestamps as well")) + ((eq org-agenda-type 'search) + (org-add-to-string + 'org-agenda-query-string + (if org-agenda-last-search-view-search-was-boolean + (cdr (assoc char '((?\[ . " +") (?\] . " -") + (?\{ . " +{}") (?\} . " -{}")))) + " ")) + (setq org-agenda-redo-command + (list 'org-search-view + org-todo-only + org-agenda-query-string + (+ (length org-agenda-query-string) + (if (member char '(?\{ ?\})) 0 1)))) + (set-register org-agenda-query-register org-agenda-query-string) + (org-agenda-redo)) + (t (error "Cannot manipulate query for %s-type agenda buffers" + org-agenda-type)))) + +(defun org-add-to-string (var string) + (set var (concat (symbol-value var) string))) + +(defun org-agenda-goto-date (date) + "Jump to DATE in agenda." + (interactive (list (let ((org-read-date-prefer-future + (eval org-agenda-jump-prefer-future))) + (org-read-date)))) + (org-agenda-list nil date)) + +(defun org-agenda-goto-today () + "Go to today." + (interactive) + (org-agenda-check-type t 'timeline 'agenda) + (let ((tdpos (text-property-any (point-min) (point-max) 'org-today t))) + (cond + (tdpos (goto-char tdpos)) + ((eq org-agenda-type 'agenda) + (let* ((sd (org-agenda-compute-starting-span + (org-today) (or org-agenda-ndays org-agenda-span))) + (org-agenda-overriding-arguments org-agenda-last-arguments)) + (setf (nth 1 org-agenda-overriding-arguments) sd) + (org-agenda-redo) + (org-agenda-find-same-or-today-or-agenda))) + (t (error "Cannot find today"))))) + +(defun org-agenda-find-same-or-today-or-agenda (&optional cnt) + (goto-char + (or (and cnt (text-property-any (point-min) (point-max) 'org-day-cnt cnt)) + (text-property-any (point-min) (point-max) 'org-today t) + (text-property-any (point-min) (point-max) 'org-agenda-type 'agenda) + (point-min)))) + +(defun org-agenda-later (arg) + "Go forward in time by thee current span. +With prefix ARG, go forward that many times the current span." + (interactive "p") + (org-agenda-check-type t 'agenda) + (let* ((span org-agenda-current-span) + (sd org-starting-day) + (greg (calendar-gregorian-from-absolute sd)) + (cnt (org-get-at-bol 'org-day-cnt)) + greg2) + (cond + ((eq span 'day) + (setq sd (+ arg sd))) + ((eq span 'week) + (setq sd (+ (* 7 arg) sd))) + ((eq span 'month) + (setq greg2 (list (+ (car greg) arg) (nth 1 greg) (nth 2 greg)) + sd (calendar-absolute-from-gregorian greg2)) + (setcar greg2 (1+ (car greg2)))) + ((eq span 'year) + (setq greg2 (list (car greg) (nth 1 greg) (+ arg (nth 2 greg))) + sd (calendar-absolute-from-gregorian greg2)) + (setcar (nthcdr 2 greg2) (1+ (nth 2 greg2)))) + (t + (setq sd (+ (* span arg) sd)))) + (let ((org-agenda-overriding-arguments + (list (car org-agenda-last-arguments) sd span t))) + (org-agenda-redo) + (org-agenda-find-same-or-today-or-agenda cnt)))) + +(defun org-agenda-earlier (arg) + "Go backward in time by the current span. +With prefix ARG, go backward that many times the current span." + (interactive "p") + (org-agenda-later (- arg))) + +(defun org-agenda-view-mode-dispatch () + "Call one of the view mode commands." + (interactive) + (message "View: [d]ay [w]eek [m]onth [y]ear [q]uit/abort + time[G]rid [[]inactive [f]ollow [l]og [L]og-all [E]ntryText + [a]rch-trees [A]rch-files clock[R]eport include[D]iary") + (let ((a (read-char-exclusive))) + (case a + (?d (call-interactively 'org-agenda-day-view)) + (?w (call-interactively 'org-agenda-week-view)) + (?m (call-interactively 'org-agenda-month-view)) + (?y (call-interactively 'org-agenda-year-view)) + (?l (call-interactively 'org-agenda-log-mode)) + (?L (org-agenda-log-mode '(4))) + ((?F ?f) (call-interactively 'org-agenda-follow-mode)) + (?a (call-interactively 'org-agenda-archives-mode)) + (?A (org-agenda-archives-mode 'files)) + ((?R ?r) (call-interactively 'org-agenda-clockreport-mode)) + ((?E ?e) (call-interactively 'org-agenda-entry-text-mode)) + (?G (call-interactively 'org-agenda-toggle-time-grid)) + (?D (call-interactively 'org-agenda-toggle-diary)) + (?\! (call-interactively 'org-agenda-toggle-deadlines)) + (?\[ (let ((org-agenda-include-inactive-timestamps t)) + (org-agenda-check-type t 'timeline 'agenda) + (org-agenda-redo)) + (message "Display now includes inactive timestamps as well")) + (?q (message "Abort")) + (otherwise (error "Invalid key" ))))) + +(defun org-agenda-day-view (&optional day-of-year) + "Switch to daily view for agenda. +With argument DAY-OF-YEAR, switch to that day of the year." + (interactive "P") + (org-agenda-change-time-span 'day day-of-year)) +(defun org-agenda-week-view (&optional iso-week) + "Switch to daily view for agenda. +With argument ISO-WEEK, switch to the corresponding ISO week. +If ISO-WEEK has more then 2 digits, only the last two encode the +week. Any digits before this encode a year. So 200712 means +week 12 of year 2007. Years in the range 1938-2037 can also be +written as 2-digit years." + (interactive "P") + (org-agenda-change-time-span 'week iso-week)) +(defun org-agenda-month-view (&optional month) + "Switch to monthly view for agenda. +With argument MONTH, switch to that month." + (interactive "P") + (org-agenda-change-time-span 'month month)) +(defun org-agenda-year-view (&optional year) + "Switch to yearly view for agenda. +With argument YEAR, switch to that year. +If MONTH has more then 2 digits, only the last two encode the +month. Any digits before this encode a year. So 200712 means +December year 2007. Years in the range 1938-2037 can also be +written as 2-digit years." + (interactive "P") + (when year + (setq year (org-small-year-to-year year))) + (if (y-or-n-p "Are you sure you want to compute the agenda for an entire year? ") + (org-agenda-change-time-span 'year year) + (error "Abort"))) + +(defun org-agenda-change-time-span (span &optional n) + "Change the agenda view to SPAN. +SPAN may be `day', `week', `month', `year'." + (org-agenda-check-type t 'agenda) + (if (and (not n) (equal org-agenda-current-span span)) + (error "Viewing span is already \"%s\"" span)) + (let* ((sd (or (org-get-at-bol 'day) + org-starting-day)) + (sd (org-agenda-compute-starting-span sd span n)) + (org-agenda-overriding-arguments + (list (car org-agenda-last-arguments) sd span t))) + (org-agenda-redo) + (org-agenda-find-same-or-today-or-agenda)) + (org-agenda-set-mode-name) + (message "Switched to %s view" span)) + +(defun org-agenda-compute-starting-span (sd span &optional n) + "Compute starting date for agenda. +SPAN may be `day', `week', `month', `year'. The return value +is a cons cell with the starting date and the number of days, +so that the date SD will be in that range." + (let* ((greg (calendar-gregorian-from-absolute sd)) + (dg (nth 1 greg)) + (mg (car greg)) + (yg (nth 2 greg))) + (cond + ((eq span 'day) + (when n + (setq sd (+ (calendar-absolute-from-gregorian + (list mg 1 yg)) + n -1)))) + ((eq span 'week) + (let* ((nt (calendar-day-of-week + (calendar-gregorian-from-absolute sd))) + (d (if org-agenda-start-on-weekday + (- nt org-agenda-start-on-weekday) + 0)) + y1) + (setq sd (- sd (+ (if (< d 0) 7 0) d))) + (when n + (require 'cal-iso) + (when (> n 99) + (setq y1 (org-small-year-to-year (/ n 100)) + n (mod n 100))) + (setq sd + (calendar-absolute-from-iso + (list n 1 + (or y1 (nth 2 (calendar-iso-from-absolute sd))))))))) + ((eq span 'month) + (let (y1) + (when (and n (> n 99)) + (setq y1 (org-small-year-to-year (/ n 100)) + n (mod n 100))) + (setq sd (calendar-absolute-from-gregorian + (list (or n mg) 1 (or y1 yg)))))) + ((eq span 'year) + (setq sd (calendar-absolute-from-gregorian + (list 1 1 (or n yg)))))) + sd)) + +(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) + ;; This does not work if user makes date format that starts with a blank + (if (looking-at "^\\S-") (forward-char 1)) + (if (not (re-search-forward "^\\S-" nil t arg)) + (progn + (backward-char 1) + (error "No next date after this line in this buffer"))) + (goto-char (match-beginning 0))) + +(defun org-agenda-previous-date-line (&optional arg) + "Jump to the previous line indicating a date in agenda buffer." + (interactive "p") + (org-agenda-check-type t 'agenda 'timeline) + (beginning-of-line 1) + (if (not (re-search-backward "^\\S-" nil t arg)) + (error "No previous date before this line in this buffer"))) + +;; Initialize the highlight +(defvar org-hl (make-overlay 1 1)) +(overlay-put org-hl 'face 'highlight) + +(defun org-highlight (begin end &optional buffer) + "Highlight a region with overlay." + (move-overlay org-hl begin end (or buffer (current-buffer)))) + +(defun org-unhighlight () + "Detach overlay INDEX." + (org-detach-overlay org-hl)) + +;; FIXME this is currently not used. +(defun org-highlight-until-next-command (beg end &optional buffer) + "Move the highlight overlay to BEG/END, remove it before the next command." + (org-highlight beg end buffer) + (add-hook 'pre-command-hook 'org-unhighlight-once)) +(defun org-unhighlight-once () + "Remove the highlight from its position, and this function from the hook." + (remove-hook 'pre-command-hook 'org-unhighlight-once) + (org-unhighlight)) + +(defun org-agenda-follow-mode () + "Toggle follow mode in an agenda buffer." + (interactive) + (setq org-agenda-follow-mode (not org-agenda-follow-mode)) + (org-agenda-set-mode-name) + (if (and org-agenda-follow-mode (org-get-at-bol 'org-marker)) + (org-agenda-show)) + (message "Follow mode is %s" + (if org-agenda-follow-mode "on" "off"))) + +(defun org-agenda-entry-text-mode (&optional arg) + "Toggle entry text mode in an agenda buffer." + (interactive "P") + (setq org-agenda-entry-text-mode (or (integerp arg) + (not org-agenda-entry-text-mode))) + (org-agenda-entry-text-hide) + (and org-agenda-entry-text-mode + (let ((org-agenda-entry-text-maxlines + (if (integerp arg) arg org-agenda-entry-text-maxlines))) + (org-agenda-entry-text-show))) + (org-agenda-set-mode-name) + (message "Entry text mode is %s. Maximum number of lines is %d" + (if org-agenda-entry-text-mode "on" "off") + (if (integerp arg) arg org-agenda-entry-text-maxlines))) + +(defun org-agenda-clockreport-mode (&optional with-filter) + "Toggle clocktable mode in an agenda buffer. +With prefix arg WITH-FILTER, make the clocktable respect the current +agenda filter." + (interactive "P") + (org-agenda-check-type t 'agenda) + (if with-filter + (setq org-agenda-clockreport-mode 'with-filter) + (setq org-agenda-clockreport-mode (not org-agenda-clockreport-mode))) + (org-agenda-set-mode-name) + (org-agenda-redo) + (message "Clocktable mode is %s" + (if org-agenda-clockreport-mode "on" "off"))) + +(defun org-agenda-log-mode (&optional special) + "Toggle log mode in an agenda buffer. +With argument SPECIAL, show all possible log items, not only the ones +configured in `org-agenda-log-mode-items'. +With a double `C-u' prefix arg, show *only* log items, nothing else." + (interactive "P") + (org-agenda-check-type t 'agenda 'timeline) + (setq org-agenda-show-log + (if (equal special '(16)) + 'only + (if special '(closed clock state) + (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-archives-mode (&optional with-files) + "Toggle inclusion of items in trees marked with :ARCHIVE:. +When called with a prefix argument, include all archive files as well." + (interactive "P") + (setq org-agenda-archives-mode + (if with-files t (if org-agenda-archives-mode nil 'trees))) + (org-agenda-set-mode-name) + (org-agenda-redo) + (message + "%s" + (cond + ((eq org-agenda-archives-mode nil) + "No archives are included") + ((eq org-agenda-archives-mode 'trees) + (format "Trees with :%s: tag are included" org-archive-tag)) + ((eq org-agenda-archives-mode t) + (format "Trees with :%s: tag and all active archive files are included" + org-archive-tag))))) + +(defun org-agenda-toggle-diary () + "Toggle diary inclusion in an agenda buffer." + (interactive) + (org-agenda-check-type t 'agenda) + (setq org-agenda-include-diary (not org-agenda-include-diary)) + (org-agenda-redo) + (org-agenda-set-mode-name) + (message "Diary inclusion turned %s" + (if org-agenda-include-diary "on" "off"))) + +(defun org-agenda-toggle-deadlines () + "Toggle inclusion of entries with a deadline in an agenda buffer." + (interactive) + (org-agenda-check-type t 'agenda) + (setq org-agenda-include-deadlines (not org-agenda-include-deadlines)) + (org-agenda-redo) + (org-agenda-set-mode-name) + (message "Deadlines inclusion turned %s" + (if org-agenda-include-deadlines "on" "off"))) + +(defun org-agenda-toggle-time-grid () + "Toggle time grid in an agenda buffer." + (interactive) + (org-agenda-check-type t 'agenda) + (setq org-agenda-use-time-grid (not org-agenda-use-time-grid)) + (org-agenda-redo) + (org-agenda-set-mode-name) + (message "Time-grid turned %s" + (if org-agenda-use-time-grid "on" "off"))) + +(defun org-agenda-set-mode-name () + "Set the mode name to indicate all the small mode settings." + (setq mode-name + (list "Org-Agenda" + (if (get 'org-agenda-files 'org-restrict) " []" "") + " " + '(:eval (org-agenda-span-name org-agenda-current-span)) + (if org-agenda-follow-mode " Follow" "") + (if org-agenda-entry-text-mode " ETxt" "") + (if org-agenda-include-diary " Diary" "") + (if org-agenda-include-deadlines " Ddl" "") + (if org-agenda-use-time-grid " Grid" "") + (if (and (boundp 'org-habit-show-habits) + org-habit-show-habits) " Habit" "") + (if (consp org-agenda-show-log) " LogAll" + (if org-agenda-show-log " Log" "")) + (if (or org-agenda-filter (get 'org-agenda-filter + :preset-filter)) + (concat " {" (mapconcat + 'identity + (append (get 'org-agenda-filter + :preset-filter) + org-agenda-filter) "") "}") + "") + (if org-agenda-archives-mode + (if (eq org-agenda-archives-mode t) + " Archives" + (format " :%s:" org-archive-tag)) + "") + (if org-agenda-clockreport-mode + (if (eq org-agenda-clockreport-mode 'with-filter) + " Clock{}" " Clock") + ""))) + (force-mode-line-update)) + +(defun org-agenda-post-command-hook () + (setq org-agenda-type + (or (get-text-property (point) 'org-agenda-type) + (get-text-property (max (point-min) (1- (point))) + 'org-agenda-type)))) + +(defun org-agenda-next-line () + "Move cursor to the next line, and show if follow mode is active." + (interactive) + (call-interactively 'next-line) + (org-agenda-do-context-action)) + +(defun org-agenda-previous-line () + "Move cursor to the previous line, and show if follow-mode is active." + (interactive) + (call-interactively 'previous-line) + (org-agenda-do-context-action)) + +(defun org-agenda-do-context-action () + "Show outline path and, maybe, follow mode window." + (let ((m (org-get-at-bol 'org-marker))) + (if (and org-agenda-follow-mode m) + (org-agenda-show)) + (if (and m org-agenda-show-outline-path) + (org-with-point-at m + (org-display-outline-path t))))) + +(defun org-agenda-show-priority () + "Show the priority of the current item. +This priority is composed of the main priority given with the [#A] cookies, +and by additional input from the age of a schedules or deadline entry." + (interactive) + (let* ((pri (org-get-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 (org-get-at-bol 'tags))) + (if tags + (message "Tags are :%s:" + (org-no-properties (mapconcat 'identity tags ":"))) + (message "No tags associated with this line")))) + +(defun org-agenda-goto (&optional highlight) + "Go to the Org-mode file which contains the item at point." + (interactive) + (let* ((marker (or (org-get-at-bol 'org-marker) + (org-agenda-error))) + (buffer (marker-buffer marker)) + (pos (marker-position marker))) + (switch-to-buffer-other-window buffer) + (widen) + (push-mark) + (goto-char pos) + (when (org-mode-p) + (org-show-context 'agenda) + (save-excursion + (and (outline-next-heading) + (org-flag-heading nil)))) ; show the next heading + (recenter (/ (window-height) 2)) + (run-hooks 'org-agenda-after-show-hook) + (and highlight (org-highlight (point-at-bol) (point-at-eol))))) + +(defvar org-agenda-after-show-hook nil + "Normal hook run after an item has been shown from the agenda. +Point is in the buffer where the item originated.") + +(defun org-agenda-kill () + "Kill the entry or subtree belonging to the current agenda entry." + (interactive) + (or (eq major-mode 'org-agenda-mode) (error "Not in agenda")) + (let* ((marker (or (org-get-at-bol 'org-marker) + (org-agenda-error))) + (buffer (marker-buffer marker)) + (pos (marker-position marker)) + (type (org-get-at-bol 'type)) + dbeg dend (n 0) conf) + (org-with-remote-undo buffer + (with-current-buffer buffer + (save-excursion + (goto-char pos) + (if (and (org-mode-p) (not (member type '("sexp")))) + (setq dbeg (progn (org-back-to-heading t) (point)) + dend (org-end-of-subtree t t)) + (setq dbeg (point-at-bol) + dend (min (point-max) (1+ (point-at-eol))))) + (goto-char dbeg) + (while (re-search-forward "^[ \t]*\\S-" dend t) (setq n (1+ n))))) + (setq conf (or (eq t org-agenda-confirm-kill) + (and (numberp org-agenda-confirm-kill) + (> n org-agenda-confirm-kill)))) + (and conf + (not (y-or-n-p + (format "Delete entry with %d lines in buffer \"%s\"? " + n (buffer-name buffer)))) + (error "Abort")) + (org-remove-subtree-entries-from-agenda buffer dbeg dend) + (with-current-buffer buffer (delete-region dbeg dend)) + (message "Agenda item and source killed")))) + +(defvar org-archive-default-command) +(defun org-agenda-archive-default () + "Archive the entry or subtree belonging to the current agenda entry." + (interactive) + (require 'org-archive) + (org-agenda-archive-with org-archive-default-command)) + +(defun org-agenda-archive-default-with-confirmation () + "Archive the entry or subtree belonging to the current agenda entry." + (interactive) + (require 'org-archive) + (org-agenda-archive-with org-archive-default-command 'confirm)) + +(defun org-agenda-archive () + "Archive the entry or subtree belonging to the current agenda entry." + (interactive) + (org-agenda-archive-with 'org-archive-subtree)) + +(defun org-agenda-archive-to-archive-sibling () + "Move the entry to the archive sibling." + (interactive) + (org-agenda-archive-with 'org-archive-to-archive-sibling)) + +(defun org-agenda-archive-with (cmd &optional confirm) + "Move the entry to the archive sibling." + (interactive) + (or (eq major-mode 'org-agenda-mode) (error "Not in agenda")) + (let* ((marker (or (org-get-at-bol 'org-marker) + (org-agenda-error))) + (buffer (marker-buffer marker)) + (pos (marker-position marker))) + (org-with-remote-undo buffer + (with-current-buffer buffer + (if (org-mode-p) + (if (and confirm + (not (y-or-n-p "Archive this subtree or entry? "))) + (error "Abort") + (save-excursion + (goto-char pos) + (org-remove-subtree-entries-from-agenda) + (org-back-to-heading t) + (funcall cmd))) + (error "Archiving works only in Org-mode files")))))) + +(defun org-remove-subtree-entries-from-agenda (&optional buf beg end) + "Remove all lines in the agenda that correspond to a given subtree. +The subtree is the one in buffer BUF, starting at BEG and ending at END. +If this information is not given, the function uses the tree at point." + (let ((buf (or buf (current-buffer))) m p) + (save-excursion + (unless (and beg end) + (org-back-to-heading t) + (setq beg (point)) + (org-end-of-subtree t) + (setq end (point))) + (set-buffer (get-buffer org-agenda-buffer-name)) + (save-excursion + (goto-char (point-max)) + (beginning-of-line 1) + (while (not (bobp)) + (when (and (setq m (org-get-at-bol 'org-marker)) + (equal buf (marker-buffer m)) + (setq p (marker-position m)) + (>= p beg) + (< p end)) + (let ((inhibit-read-only t)) + (delete-region (point-at-bol) (1+ (point-at-eol))))) + (beginning-of-line 0)))))) + +(defun org-agenda-refile (&optional goto rfloc no-update) + "Refile the item at point." + (interactive "P") + (if (equal goto '(16)) + (org-refile-goto-last-stored) + (let* ((marker (or (org-get-at-bol 'org-hd-marker) + (org-agenda-error))) + (buffer (marker-buffer marker)) + (pos (marker-position marker)) + (rfloc (or rfloc + (org-refile-get-location + (if goto "Goto: " "Refile to: ") buffer + org-refile-allow-creating-parent-nodes)))) + (with-current-buffer buffer + (save-excursion + (save-restriction + (widen) + (goto-char marker) + (org-remove-subtree-entries-from-agenda) + (org-refile goto buffer rfloc))))) + (unless no-update (org-agenda-redo)))) + +(defun org-agenda-open-link (&optional arg) + "Follow the link in the current line, if any. +This looks for a link in the displayed line in the agenda. It also looks +at the text of the entry itself." + (interactive "P") + (let* ((marker (or (org-get-at-bol 'org-hd-marker) + (org-get-at-bol 'org-marker))) + (buffer (and marker (marker-buffer marker))) + (prefix (buffer-substring + (point-at-bol) + (+ (point-at-bol) + (or (org-get-at-bol 'prefix-length) 0))))) + (cond + (buffer + (with-current-buffer buffer + (save-excursion + (save-restriction + (widen) + (goto-char marker) + (org-offer-links-in-entry arg prefix))))) + ((or (org-in-regexp (concat "\\(" org-bracket-link-regexp "\\)")) + (save-excursion + (beginning-of-line 1) + (looking-at (concat ".*?\\(" org-bracket-link-regexp "\\)")))) + (org-open-link-from-string (match-string 1))) + (t (error "No link to open here"))))) + +(defun org-agenda-copy-local-variable (var) + "Get a variable from a referenced buffer and install it here." + (let ((m (org-get-at-bol 'org-marker))) + (when (and m (buffer-live-p (marker-buffer m))) + (org-set-local var (with-current-buffer (marker-buffer m) + (symbol-value var)))))) + +(defun org-agenda-switch-to (&optional delete-other-windows) + "Go to the Org-mode file which contains the item at point." + (interactive) + (if (and org-return-follows-link + (not (org-get-at-bol 'org-marker)) + (org-in-regexp org-bracket-link-regexp)) + (org-open-link-from-string (match-string 0)) + (let* ((marker (or (org-get-at-bol 'org-marker) + (org-agenda-error))) + (buffer (marker-buffer marker)) + (pos (marker-position marker))) + (switch-to-buffer buffer) + (and delete-other-windows (delete-other-windows)) + (widen) + (goto-char pos) + (when (org-mode-p) + (org-show-context 'agenda) + (save-excursion + (and (outline-next-heading) + (org-flag-heading nil))))))) ; show the next heading + +(defun org-agenda-goto-mouse (ev) + "Go to the Org-mode file which contains the item at the mouse click." + (interactive "e") + (mouse-set-point ev) + (org-agenda-goto)) + +(defun org-agenda-show (&optional full-entry) + "Display the Org-mode file which contains the item at point. +With prefix argument FULL-ENTRY, make the entire entry visible +if it was hidden in the outline." + (interactive "P") + (let ((win (selected-window))) + (if full-entry + (let ((org-show-entry-below t)) + (org-agenda-goto t)) + (org-agenda-goto t)) + (select-window win))) + +(defvar org-agenda-show-window nil) +(defun org-agenda-show-and-scroll-up () + "Display the Org-mode file which contains the item at point. +When called repeatedly, scroll the window that is displaying the buffer." + (interactive) + (let ((win (selected-window))) + (if (and (window-live-p org-agenda-show-window) + (eq this-command last-command)) + (progn + (select-window org-agenda-show-window) + (ignore-errors (scroll-up))) + (org-agenda-goto t) + (show-subtree) + (setq org-agenda-show-window (selected-window))) + (select-window win))) + +(defun org-agenda-show-scroll-down () + "Scroll down the window showing the agenda." + (interactive) + (let ((win (selected-window))) + (when (window-live-p org-agenda-show-window) + (select-window org-agenda-show-window) + (ignore-errors (scroll-down)) + (select-window win)))) + +(defun org-agenda-show-1 (&optional more) + "Display the Org-mode file which contains the item at point. +The prefix arg selects the amount of information to display: + +0 hide the subtree +1 just show the entry according to defaults. +2 show the children view +3 show the subtree view +4 show the entire subtree and any LOGBOOK drawers +5 show the entire subtree and any drawers +With prefix argument FULL-ENTRY, make the entire entry visible +if it was hidden in the outline." + (interactive "p") + (let ((win (selected-window))) + (org-agenda-goto t) + (org-recenter-heading 1) + (cond + ((= more 0) + (hide-subtree) + (save-excursion + (org-back-to-heading) + (run-hook-with-args 'org-cycle-hook 'folded)) + (message "Remote: FOLDED")) + ((and (interactive-p) (= more 1)) + (message "Remote: show with default settings")) + ((= more 2) + (show-entry) + (show-children) + (save-excursion + (org-back-to-heading) + (run-hook-with-args 'org-cycle-hook 'children)) + (message "Remote: CHILDREN")) + ((= more 3) + (show-subtree) + (save-excursion + (org-back-to-heading) + (run-hook-with-args 'org-cycle-hook 'subtree)) + (message "Remote: SUBTREE")) + ((= more 4) + (let* ((org-drawers (delete "LOGBOOK" (copy-sequence org-drawers))) + (org-drawer-regexp + (concat "^[ \t]*:\\(" + (mapconcat 'regexp-quote org-drawers "\\|") + "\\):[ \t]*$"))) + (show-subtree) + (save-excursion + (org-back-to-heading) + (org-cycle-hide-drawers 'subtree))) + (message "Remote: SUBTREE AND LOGBOOK")) + ((> more 4) + (show-subtree) + (message "Remote: SUBTREE AND ALL DRAWERS"))) + (select-window win))) + +(defun org-recenter-heading (n) + (save-excursion + (org-back-to-heading) + (recenter n))) + +(defvar org-agenda-cycle-counter nil) +(defun org-agenda-cycle-show (&optional n) + "Show the current entry in another window, with default settings. +Default settings are taken from `org-show-hierarchy-above' and siblings. +When use repeatedly in immediate succession, the remote entry will cycle +through visibility + +children -> subtree -> folded + +When called with a numeric prefix arg, that arg will be passed through to +`org-agenda-show-1'. For the interpretation of that argument, see the +docstring of `org-agenda-show-1'." + (interactive "P") + (if (integerp n) + (setq org-agenda-cycle-counter n) + (if (not (eq last-command this-command)) + (setq org-agenda-cycle-counter 1) + (if (equal org-agenda-cycle-counter 0) + (setq org-agenda-cycle-counter 2) + (setq org-agenda-cycle-counter (1+ org-agenda-cycle-counter)) + (if (> org-agenda-cycle-counter 3) + (setq org-agenda-cycle-counter 0))))) + (org-agenda-show-1 org-agenda-cycle-counter)) + +(defun org-agenda-recenter (arg) + "Display the Org-mode file which contains the item at point and recenter." + (interactive "P") + (let ((win (selected-window))) + (org-agenda-goto t) + (recenter arg) + (select-window win))) + +(defun org-agenda-show-mouse (ev) + "Display the Org-mode file which contains the item at the mouse click." + (interactive "e") + (mouse-set-point ev) + (org-agenda-show)) + +(defun org-agenda-check-no-diary () + "Check if the entry is a diary link and abort if yes." + (if (org-get-at-bol 'org-agenda-diary-link) + (org-agenda-error))) + +(defun org-agenda-error () + (error "Command not allowed in this line")) + +(defun org-agenda-tree-to-indirect-buffer () + "Show the subtree corresponding to the current entry in an indirect buffer. +This calls the command `org-tree-to-indirect-buffer' from the original +Org-mode buffer. +With numerical prefix arg ARG, go up to this level and then take that tree. +With a \\[universal-argument] prefix, make a separate frame for this tree (i.e. don't +use the dedicated frame)." + (interactive) + (org-agenda-check-no-diary) + (let* ((marker (or (org-get-at-bol 'org-marker) + (org-agenda-error))) + (buffer (marker-buffer marker)) + (pos (marker-position marker))) + (with-current-buffer buffer + (save-excursion + (goto-char pos) + (call-interactively 'org-tree-to-indirect-buffer))))) + +(defvar org-last-heading-marker (make-marker) + "Marker pointing to the headline that last changed its TODO state +by a remote command from the agenda.") + +(defun org-agenda-todo-nextset () + "Switch TODO entry to next sequence." + (interactive) + (org-agenda-todo 'nextset)) + +(defun org-agenda-todo-previousset () + "Switch TODO entry to previous sequence." + (interactive) + (org-agenda-todo 'previousset)) + +(defun org-agenda-todo (&optional arg) + "Cycle TODO state of line at point, also in Org-mode file. +This changes the line at point, all other lines in the agenda referring to +the same tree node, and the headline of the tree node in the Org-mode file." + (interactive "P") + (org-agenda-check-no-diary) + (let* ((col (current-column)) + (marker (or (org-get-at-bol 'org-marker) + (org-agenda-error))) + (buffer (marker-buffer marker)) + (pos (marker-position marker)) + (hdmarker (org-get-at-bol 'org-hd-marker)) + (todayp (org-agenda-todayp (org-get-at-bol 'day))) + (inhibit-read-only t) + org-agenda-headline-snapshot-before-repeat newhead just-one) + (org-with-remote-undo buffer + (with-current-buffer buffer + (widen) + (goto-char pos) + (org-show-context 'agenda) + (save-excursion + (and (outline-next-heading) + (org-flag-heading nil))) ; show the next heading + (let ((current-prefix-arg arg)) + (call-interactively 'org-todo)) + (and (bolp) (forward-char 1)) + (setq newhead (org-get-heading)) + (when (and (org-bound-and-true-p + org-agenda-headline-snapshot-before-repeat) + (not (equal org-agenda-headline-snapshot-before-repeat + newhead)) + todayp) + (setq newhead org-agenda-headline-snapshot-before-repeat + just-one t)) + (save-excursion + (org-back-to-heading) + (move-marker org-last-heading-marker (point)))) + (beginning-of-line 1) + (save-excursion + (org-agenda-change-all-lines newhead hdmarker 'fixface just-one)) + (org-move-to-column col)))) + +(defun org-agenda-add-note (&optional arg) + "Add a time-stamped note to the entry at point." + (interactive "P") + (org-agenda-check-no-diary) + (let* ((marker (or (org-get-at-bol 'org-marker) + (org-agenda-error))) + (buffer (marker-buffer marker)) + (pos (marker-position marker)) + (hdmarker (org-get-at-bol 'org-hd-marker)) + (inhibit-read-only t)) + (with-current-buffer buffer + (widen) + (goto-char pos) + (org-show-context 'agenda) + (save-excursion + (and (outline-next-heading) + (org-flag-heading nil))) ; show the next heading + (org-add-note)))) + +(defun org-agenda-change-all-lines (newhead hdmarker + &optional fixface just-this) + "Change all lines in the agenda buffer which match HDMARKER. +The new content of the line will be NEWHEAD (as modified by +`org-format-agenda-item'). HDMARKER is checked with +`equal' against all `org-hd-marker' text properties in the file. +If FIXFACE is non-nil, the face of each item is modified according to +the new TODO state. +If JUST-THIS is non-nil, change just the current line, not all. +If FORCE-TAGS is non nil, the car of it returns the new tags." + (let* ((inhibit-read-only t) + (line (org-current-line)) + (thetags (with-current-buffer (marker-buffer hdmarker) + (save-excursion (save-restriction (widen) + (goto-char hdmarker) + (org-get-tags-at))))) + props m pl undone-face done-face finish new dotime cat tags) + (save-excursion + (goto-char (point-max)) + (beginning-of-line 1) + (while (not finish) + (setq finish (bobp)) + (when (and (setq m (org-get-at-bol 'org-hd-marker)) + (or (not just-this) (= (org-current-line) line)) + (equal m hdmarker)) + (setq props (text-properties-at (point)) + dotime (org-get-at-bol 'dotime) + cat (org-get-at-bol 'org-category) + tags thetags + new (org-format-agenda-item "x" newhead cat tags dotime 'noprefix) + pl (org-get-at-bol 'prefix-length) + undone-face (org-get-at-bol 'undone-face) + done-face (org-get-at-bol 'done-face)) + (goto-char (+ (point) pl)) + ;; (org-move-to-column pl) FIXME: does the above line work correctly? + (cond + ((equal new "") + (beginning-of-line 1) + (and (looking-at ".*\n?") (replace-match ""))) + ((looking-at ".*") + (replace-match new t t) + (beginning-of-line 1) + (add-text-properties (point-at-bol) (point-at-eol) props) + (when fixface + (add-text-properties + (point-at-bol) (point-at-eol) + (list 'face + (if org-last-todo-state-is-todo + undone-face done-face)))) + (org-agenda-highlight-todo 'line) + (beginning-of-line 1)) + (t (error "Line update did not work")))) + (beginning-of-line 0))) + (org-finalize-agenda))) + +(defun org-agenda-align-tags (&optional line) + "Align all tags in agenda items to `org-agenda-tags-column'." + (let ((inhibit-read-only t) l c) + (save-excursion + (goto-char (if line (point-at-bol) (point-min))) + (while (re-search-forward (org-re "\\([ \t]+\\)\\(:[[:alnum:]_@#%:]+:\\)[ \t]*$") + (if line (point-at-eol) nil) t) + (add-text-properties + (match-beginning 2) (match-end 2) + (list 'face (delq nil (let ((prop (get-text-property + (match-beginning 2) 'face))) + (or (listp prop) (setq prop (list prop))) + (if (memq 'org-tag prop) + prop + (cons 'org-tag prop)))))) + (setq l (- (match-end 2) (match-beginning 2)) + c (if (< org-agenda-tags-column 0) + (- (abs org-agenda-tags-column) l) + org-agenda-tags-column)) + (delete-region (match-beginning 1) (match-end 1)) + (goto-char (match-beginning 1)) + (insert (org-add-props + (make-string (max 1 (- c (current-column))) ?\ ) + (plist-put (copy-sequence (text-properties-at (point))) + 'face nil)))) + (goto-char (point-min)) + (org-font-lock-add-tag-faces (point-max))))) + +(defun org-agenda-priority-up () + "Increase the priority of line at point, also in Org-mode file." + (interactive) + (org-agenda-priority 'up)) + +(defun org-agenda-priority-down () + "Decrease the priority of line at point, also in Org-mode file." + (interactive) + (org-agenda-priority 'down)) + +(defun org-agenda-priority (&optional force-direction) + "Set the priority of line at point, also in Org-mode file. +This changes the line at point, all other lines in the agenda referring to +the same tree node, and the headline of the tree node in the Org-mode file." + (interactive) + (unless org-enable-priority-commands + (error "Priority commands are disabled")) + (org-agenda-check-no-diary) + (let* ((marker (or (org-get-at-bol 'org-marker) + (org-agenda-error))) + (hdmarker (org-get-at-bol 'org-hd-marker)) + (buffer (marker-buffer hdmarker)) + (pos (marker-position hdmarker)) + (inhibit-read-only t) + newhead) + (org-with-remote-undo buffer + (with-current-buffer buffer + (widen) + (goto-char pos) + (org-show-context 'agenda) + (save-excursion + (and (outline-next-heading) + (org-flag-heading nil))) ; show the next heading + (funcall 'org-priority force-direction) + (end-of-line 1) + (setq newhead (org-get-heading))) + (org-agenda-change-all-lines newhead hdmarker) + (beginning-of-line 1)))) + +;; FIXME: should fix the tags property of the agenda line. +(defun org-agenda-set-tags (&optional tag onoff) + "Set tags for the current headline." + (interactive) + (org-agenda-check-no-diary) + (if (and (org-region-active-p) (interactive-p)) + (call-interactively 'org-change-tag-in-region) + (org-agenda-show) ;;; FIXME This is a stupid hack and should not be needed + (let* ((hdmarker (or (org-get-at-bol 'org-hd-marker) + (org-agenda-error))) + (buffer (marker-buffer hdmarker)) + (pos (marker-position hdmarker)) + (inhibit-read-only t) + newhead) + (org-with-remote-undo buffer + (with-current-buffer buffer + (widen) + (goto-char pos) + (save-excursion + (org-show-context 'agenda)) + (save-excursion + (and (outline-next-heading) + (org-flag-heading nil))) ; show the next heading + (goto-char pos) + (if tag + (org-toggle-tag tag onoff) + (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-set-property () + "Set a property 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 (org-get-at-bol 'org-hd-marker) + (org-agenda-error))) + (buffer (marker-buffer hdmarker)) + (pos (marker-position hdmarker)) + (inhibit-read-only t) + newhead) + (org-with-remote-undo buffer + (with-current-buffer buffer + (widen) + (goto-char pos) + (save-excursion + (org-show-context 'agenda)) + (save-excursion + (and (outline-next-heading) + (org-flag-heading nil))) ; show the next heading + (goto-char pos) + (call-interactively 'org-set-property))))) + +(defun org-agenda-set-effort () + "Set the effort property 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 (org-get-at-bol 'org-hd-marker) + (org-agenda-error))) + (buffer (marker-buffer hdmarker)) + (pos (marker-position hdmarker)) + (inhibit-read-only t) + newhead) + (org-with-remote-undo buffer + (with-current-buffer buffer + (widen) + (goto-char pos) + (save-excursion + (org-show-context 'agenda)) + (save-excursion + (and (outline-next-heading) + (org-flag-heading nil))) ; show the next heading + (goto-char pos) + (call-interactively 'org-set-effort) + (end-of-line 1))))) + +(defun org-agenda-toggle-archive-tag () + "Toggle the archive tag for the current entry." + (interactive) + (org-agenda-check-no-diary) + (org-agenda-show) ;;; FIXME This is a stupid hack and should not be needed + (let* ((hdmarker (or (org-get-at-bol 'org-hd-marker) + (org-agenda-error))) + (buffer (marker-buffer hdmarker)) + (pos (marker-position hdmarker)) + (inhibit-read-only t) + newhead) + (org-with-remote-undo buffer + (with-current-buffer buffer + (widen) + (goto-char pos) + (org-show-context 'agenda) + (save-excursion + (and (outline-next-heading) + (org-flag-heading nil))) ; show the next heading + (call-interactively 'org-toggle-archive-tag) + (end-of-line 1) + (setq newhead (org-get-heading))) + (org-agenda-change-all-lines newhead hdmarker) + (beginning-of-line 1)))) + +(defun org-agenda-do-date-later (arg) + (interactive "P") + (cond + ((or (equal arg '(16)) + (memq last-command + '(org-agenda-date-later-minutes org-agenda-date-earlier-minutes))) + (setq this-command 'org-agenda-date-later-minutes) + (org-agenda-date-later-minutes 1)) + ((or (equal arg '(4)) + (memq last-command + '(org-agenda-date-later-hours org-agenda-date-earlier-hours))) + (setq this-command 'org-agenda-date-later-hours) + (org-agenda-date-later-hours 1)) + (t + (org-agenda-date-later (prefix-numeric-value arg))))) + +(defun org-agenda-do-date-earlier (arg) + (interactive "P") + (cond + ((or (equal arg '(16)) + (memq last-command + '(org-agenda-date-later-minutes org-agenda-date-earlier-minutes))) + (setq this-command 'org-agenda-date-earlier-minutes) + (org-agenda-date-earlier-minutes 1)) + ((or (equal arg '(4)) + (memq last-command + '(org-agenda-date-later-hours org-agenda-date-earlier-hours))) + (setq this-command 'org-agenda-date-earlier-hours) + (org-agenda-date-earlier-hours 1)) + (t + (org-agenda-date-earlier (prefix-numeric-value arg))))) + +(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 (org-get-at-bol 'org-marker) + (org-agenda-error))) + (buffer (marker-buffer marker)) + (pos (marker-position marker))) + (org-with-remote-undo buffer + (with-current-buffer buffer + (widen) + (goto-char pos) + (if (not (org-at-timestamp-p)) + (error "Cannot find time stamp")) + (org-timestamp-change arg (or what 'day))) + (org-agenda-show-new-time marker org-last-changed-timestamp)) + (message "Time stamp changed to %s" org-last-changed-timestamp))) + +(defun org-agenda-date-earlier (arg &optional what) + "Change the date of this item to one day earlier." + (interactive "p") + (org-agenda-date-later (- arg) what)) + +(defun org-agenda-date-later-minutes (arg) + "Change the time of this item, in units of `org-time-stamp-rounding-minutes'." + (interactive "p") + (setq arg (* arg (cadr org-time-stamp-rounding-minutes))) + (org-agenda-date-later arg 'minute)) + +(defun org-agenda-date-earlier-minutes (arg) + "Change the time of this item, in units of `org-time-stamp-rounding-minutes'." + (interactive "p") + (setq arg (* arg (cadr org-time-stamp-rounding-minutes))) + (org-agenda-date-earlier arg 'minute)) + +(defun org-agenda-date-later-hours (arg) + "Change the time of this item, in hour steps." + (interactive "p") + (org-agenda-date-later arg 'hour)) + +(defun org-agenda-date-earlier-hours (arg) + "Change the time of this item, in hour steps." + (interactive "p") + (org-agenda-date-earlier arg 'hour)) + +(defun org-agenda-show-new-time (marker stamp &optional prefix) + "Show new date stamp via text properties." + ;; We use text properties to make this undoable + (let ((inhibit-read-only t) + (buffer-invisibility-spec)) + (setq stamp (concat " " prefix " => " stamp)) + (save-excursion + (goto-char (point-max)) + (while (not (bobp)) + (when (equal marker (org-get-at-bol 'org-marker)) + (org-move-to-column (- (window-width) (length stamp)) t) + (org-agenda-fix-tags-filter-overlays-at (point)) + (if (featurep 'xemacs) + ;; Use `duplicable' property to trigger undo recording + (let ((ex (make-extent nil nil)) + (gl (make-glyph stamp))) + (set-glyph-face gl 'secondary-selection) + (set-extent-properties + ex (list 'invisible t 'end-glyph gl 'duplicable t)) + (insert-extent ex (1- (point)) (point-at-eol))) + (add-text-properties + (1- (point)) (point-at-eol) + (list 'display (org-add-props stamp nil + 'face 'secondary-selection)))) + (beginning-of-line 1)) + (beginning-of-line 0))))) + +(defun org-agenda-date-prompt (arg) + "Change the date of this item. Date is prompted for, with default today. +The prefix ARG is passed to the `org-time-stamp' command and can therefore +be used to request time specification in the time stamp." + (interactive "P") + (org-agenda-check-type t 'agenda 'timeline) + (org-agenda-check-no-diary) + (let* ((marker (or (org-get-at-bol 'org-marker) + (org-agenda-error))) + (buffer (marker-buffer marker)) + (pos (marker-position marker))) + (org-with-remote-undo buffer + (with-current-buffer buffer + (widen) + (goto-char pos) + (if (not (org-at-timestamp-p t)) + (error "Cannot find time stamp")) + (org-time-stamp arg (equal (char-after (match-beginning 0)) ?\[))) + (org-agenda-show-new-time marker org-last-changed-timestamp)) + (message "Time stamp changed to %s" org-last-changed-timestamp))) + +(defun org-agenda-schedule (arg) + "Schedule the item at point. +Arg is passed through to `org-schedule'." + (interactive "P") + (org-agenda-check-type t 'agenda 'timeline 'todo 'tags 'search) + (org-agenda-check-no-diary) + (let* ((marker (or (org-get-at-bol 'org-marker) + (org-agenda-error))) + (type (marker-insertion-type marker)) + (buffer (marker-buffer marker)) + (pos (marker-position marker)) + (org-insert-labeled-timestamps-at-point nil) + ts) + (set-marker-insertion-type marker t) + (org-with-remote-undo buffer + (with-current-buffer buffer + (widen) + (goto-char pos) + (setq ts (org-schedule arg))) + (org-agenda-show-new-time marker ts "S")) + (message "Item scheduled for %s" ts))) + +(defun org-agenda-deadline (arg) + "Schedule the item at point. +Arg is passed through to `org-deadline'." + (interactive "P") + (org-agenda-check-type t 'agenda 'timeline 'todo 'tags 'search) + (org-agenda-check-no-diary) + (let* ((marker (or (org-get-at-bol 'org-marker) + (org-agenda-error))) + (buffer (marker-buffer marker)) + (pos (marker-position marker)) + (org-insert-labeled-timestamps-at-point nil) + ts) + (org-with-remote-undo buffer + (with-current-buffer buffer + (widen) + (goto-char pos) + (setq ts (org-deadline arg))) + (org-agenda-show-new-time marker ts "D")) + (message "Deadline for this item set to %s" ts))) + +(defun org-agenda-action () + "Select entry for agenda action, or execute an agenda action. +This command prompts for another letter. Valid inputs are: + +m Mark the entry at point for an agenda action +s Schedule the marked entry to the date at the cursor +d Set the deadline of the marked entry to the date at the cursor +r Call `org-remember' with cursor date as the default date +c Call `org-capture' with cursor date as the default date +SPC Show marked entry in other window +TAB Visit marked entry in other window + +The cursor may be at a date in the calendar, or in the Org agenda." + (interactive) + (let (ans) + (message "Select action: [m]ark | [s]chedule [d]eadline [r]emember [c]apture [ ]show") + (setq ans (read-char-exclusive)) + (cond + ((equal ans ?m) + ;; Mark this entry + (if (eq major-mode 'org-agenda-mode) + (let ((m (or (org-get-at-bol 'org-hd-marker) + (org-get-at-bol 'org-marker)))) + (if m + (progn + (move-marker org-agenda-action-marker + (marker-position m) (marker-buffer m)) + (message "Entry marked for action; press `k' at desired date in agenda or calendar")) + (error "Don't know which entry to mark"))) + (error "This command works only in the agenda"))) + ((equal ans ?s) + (org-agenda-do-action '(org-schedule nil org-overriding-default-time))) + ((equal ans ?d) + (org-agenda-do-action '(org-deadline nil org-overriding-default-time))) + ((equal ans ?r) + (org-agenda-do-action '(org-remember) t)) + ((equal ans ?c) + (org-agenda-do-action '(org-capture) t)) + ((equal ans ?\ ) + (let ((cw (selected-window))) + (org-switch-to-buffer-other-window + (marker-buffer org-agenda-action-marker)) + (goto-char org-agenda-action-marker) + (org-show-context 'agenda) + (select-window cw))) + ((equal ans ?\C-i) + (org-switch-to-buffer-other-window + (marker-buffer org-agenda-action-marker)) + (goto-char org-agenda-action-marker) + (org-show-context 'agenda)) + (t (error "Invalid agenda action %c" ans))))) + +(defun org-agenda-do-action (form &optional current-buffer) + "Evaluate FORM at the entry pointed to by `org-agenda-action-marker'." + (let ((org-overriding-default-time (org-get-cursor-date))) + (if current-buffer + (eval form) + (if (not (marker-buffer org-agenda-action-marker)) + (error "No entry has been selected for agenda action") + (with-current-buffer (marker-buffer org-agenda-action-marker) + (save-excursion + (save-restriction + (widen) + (goto-char org-agenda-action-marker) + (eval form)))))))) + +(defun org-agenda-clock-in (&optional arg) + "Start the clock on the currently selected item." + (interactive "P") + (org-agenda-check-no-diary) + (if (equal arg '(4)) + (org-clock-in arg) + (let* ((marker (or (org-get-at-bol 'org-marker) + (org-agenda-error))) + (hdmarker (or (org-get-at-bol 'org-hd-marker) + marker)) + (pos (marker-position marker)) + newhead) + (org-with-remote-undo (marker-buffer marker) + (with-current-buffer (marker-buffer marker) + (widen) + (goto-char pos) + (org-show-context 'agenda) + (org-show-entry) + (org-cycle-hide-drawers 'children) + (org-clock-in arg) + (setq newhead (org-get-heading))) + (org-agenda-change-all-lines newhead hdmarker))))) + +(defun org-agenda-clock-out () + "Stop the currently running clock." + (interactive) + (unless (marker-buffer org-clock-marker) + (error "No running clock")) + (let ((marker (make-marker)) newhead) + (org-with-remote-undo (marker-buffer org-clock-marker) + (with-current-buffer (marker-buffer org-clock-marker) + (save-excursion + (save-restriction + (widen) + (goto-char org-clock-marker) + (org-back-to-heading t) + (move-marker marker (point)) + (org-clock-out) + (setq newhead (org-get-heading)))))) + (org-agenda-change-all-lines newhead marker) + (move-marker marker nil))) + +(defun org-agenda-clock-cancel (&optional arg) + "Cancel the currently running clock." + (interactive "P") + (unless (marker-buffer org-clock-marker) + (error "No running clock")) + (org-with-remote-undo (marker-buffer org-clock-marker) + (org-clock-cancel))) + +(defun org-agenda-clock-goto () + "Jump to the currently clocked in task within the agenda. +If the currently clocked in task is not listed in the agenda +buffer, display it in another window." + (interactive) + (let (pos) + (mapc (lambda (o) + (if (eq (overlay-get o 'type) 'org-agenda-clocking) + (setq pos (overlay-start o)))) + (overlays-in (point-min) (point-max))) + (cond (pos (goto-char pos)) + ;; If the currently clocked entry is not in the agenda + ;; buffer, we visit it in another window: + (org-clock-current-task + (org-switch-to-buffer-other-window (org-clock-goto))) + (t (message "No running clock, use `C-c C-x C-j' to jump to the most recent one"))))) + +(defun org-agenda-diary-entry-in-org-file () + "Make a diary entry in the file `org-agenda-diary-file'." + (let (d1 d2 char (text "") dp1 dp2) + (if (equal (buffer-name) "*Calendar*") + (setq d1 (calendar-cursor-to-date t) + d2 (car calendar-mark-ring)) + (setq dp1 (get-text-property (point-at-bol) 'day)) + (unless dp1 (error "No date defined in current line")) + (setq d1 (calendar-gregorian-from-absolute dp1) + d2 (and (ignore-errors (mark)) + (save-excursion + (goto-char (mark)) + (setq dp2 (get-text-property (point-at-bol) 'day))) + (calendar-gregorian-from-absolute dp2)))) + (message "Diary entry: [d]ay [a]nniversary [b]lock [j]ump to date tree") + (setq char (read-char-exclusive)) + (cond + ((equal char ?d) + (setq text (read-string "Day entry: ")) + (org-agenda-add-entry-to-org-agenda-diary-file 'day text d1) + (and (equal (buffer-name) org-agenda-buffer-name) (org-agenda-redo))) + ((equal char ?a) + (setq d1 (list (car d1) (nth 1 d1) + (read-number (format "Reference year [%d]: " (nth 2 d1)) + (nth 2 d1)))) + (setq text (read-string "Anniversary (use %d to show years): ")) + (org-agenda-add-entry-to-org-agenda-diary-file 'anniversary text d1) + (and (equal (buffer-name) org-agenda-buffer-name) (org-agenda-redo))) + ((equal char ?b) + (setq text (read-string "Block entry: ")) + (unless (and d1 d2 (not (equal d1 d2))) + (error "No block of days selected")) + (org-agenda-add-entry-to-org-agenda-diary-file 'block text d1 d2) + (and (equal (buffer-name) org-agenda-buffer-name) (org-agenda-redo))) + ((equal char ?j) + (org-switch-to-buffer-other-window + (find-file-noselect org-agenda-diary-file)) + (require 'org-datetree) + (org-datetree-find-date-create d1) + (org-reveal t)) + (t (error "Invalid selection character `%c'" char))))) + +(defcustom org-agenda-insert-diary-strategy 'date-tree + "Where in `org-agenda-diary-file' should new entries be added? +Valid values: + +date-tree in the date tree, as child of the date +top-level as top-level entries at the end of the file." + :group 'org-agenda + :type '(choice + (const :tag "in a date tree" date-tree) + (const :tag "as top level at end of file" top-level))) + +(defcustom org-agenda-insert-diary-extract-time nil + "Non-nil means extract any time specification from the diary entry." + :group 'org-agenda + :type 'boolean) + +(defun org-agenda-add-entry-to-org-agenda-diary-file (type text &optional d1 d2) + "Add a diary entry with TYPE to `org-agenda-diary-file'. +If TEXT is not empty, it will become the headline of the new entry, and +the resulting entry will not be shown. When TEXT is empty, switch to +`org-agenda-diary-file' and let the user finish the entry there." + (let ((cw (current-window-configuration))) + (org-switch-to-buffer-other-window + (find-file-noselect org-agenda-diary-file)) + (widen) + (goto-char (point-min)) + (cond + ((eq type 'anniversary) + (or (re-search-forward "^*[ \t]+Anniversaries" nil t) + (progn + (or (org-on-heading-p t) + (progn + (outline-next-heading) + (insert "* Anniversaries\n\n") + (beginning-of-line -1))))) + (outline-next-heading) + (org-back-over-empty-lines) + (backward-char 1) + (insert "\n") + (require 'diary-lib) + (let ((calendar-date-display-form + (if (if (boundp 'calendar-date-style) + (eq calendar-date-style 'european) + (with-no-warnings ;; european-calendar-style is obsolete as of version 23.1 + (org-bound-and-true-p european-calendar-style))) ; Emacs 22 + '(day " " month " " year) + '(month " " day " " year)))) + + (insert (format "%%%%(diary-anniversary %s) %s" + (calendar-date-string d1 nil t) text)))) + ((eq type 'day) + (let ((org-prefix-has-time t) + (org-agenda-time-leading-zero t) + fmt time time2) + (if org-agenda-insert-diary-extract-time + ;; Use org-format-agenda-item to parse text for a time-range and + ;; remove it. FIXME: This is a hack, we should refactor + ;; that function to make time extraction available separately + (setq fmt (org-format-agenda-item nil text nil nil t) + time (get-text-property 0 'time fmt) + time2 (if (> (length time) 0) + ;; split-string removes trailing ...... if + ;; no end time given. First space + ;; separates time from date. + (concat " " (car (split-string time "\\."))) + nil) + text (get-text-property 0 'txt fmt))) + (if (eq org-agenda-insert-diary-strategy 'top-level) + (org-agenda-insert-diary-as-top-level text) + (require 'org-datetree) + (org-datetree-find-date-create d1) + (org-agenda-insert-diary-make-new-entry text)) + (org-insert-time-stamp (org-time-from-absolute + (calendar-absolute-from-gregorian d1)) + nil nil nil nil time2)) + (end-of-line 0)) + ((eq type 'block) + (if (> (calendar-absolute-from-gregorian d1) + (calendar-absolute-from-gregorian d2)) + (setq d1 (prog1 d2 (setq d2 d1)))) + (if (eq org-agenda-insert-diary-strategy 'top-level) + (org-agenda-insert-diary-as-top-level text) + (require 'org-datetree) + (org-datetree-find-date-create d1) + (org-agenda-insert-diary-make-new-entry text)) + (org-insert-time-stamp (org-time-from-absolute + (calendar-absolute-from-gregorian d1))) + (insert "--") + (org-insert-time-stamp (org-time-from-absolute + (calendar-absolute-from-gregorian d2))) + (end-of-line 0))) + (if (string-match "\\S-" text) + (progn + (set-window-configuration cw) + (message "%s entry added to %s" + (capitalize (symbol-name type)) + (abbreviate-file-name org-agenda-diary-file))) + (org-reveal t) + (message "Please finish entry here")))) + +(defun org-agenda-insert-diary-as-top-level (text) + "Make new entry as a top-level entry at the end of the file. +Add TEXT as headline, and position the cursor in the second line so that +a timestamp can be added there." + (widen) + (goto-char (point-max)) + (or (bolp) (insert "\n")) + (insert "* " text "\n") + (if org-adapt-indentation (org-indent-to-column 2))) + +(defun org-agenda-insert-diary-make-new-entry (text) + "Make new entry as last child of current entry. +Add TEXT as headline, and position the cursor in the second line so that +a timestamp can be added there." + (let ((org-show-following-heading t) + (org-show-siblings t) + (org-show-hierarchy-above t) + (org-show-entry-below t) + col) + (outline-next-heading) + (org-back-over-empty-lines) + (or (looking-at "[ \t]*$") + (progn (insert "\n") (backward-char 1))) + (org-insert-heading nil t) + (org-do-demote) + (setq col (current-column)) + (insert text "\n") + (if org-adapt-indentation (org-indent-to-column col)) + (let ((org-show-following-heading t) + (org-show-siblings t) + (org-show-hierarchy-above t) + (org-show-entry-below t)) + (org-show-context)))) + +(defun org-agenda-diary-entry () + "Make a diary entry, like the `i' command from the calendar. +All the standard commands work: block, weekly etc. +When `org-agenda-diary-file' points to a file, +`org-agenda-diary-entry-in-org-file' is called instead to create +entries in that Org-mode file." + (interactive) + (org-agenda-check-type t 'agenda 'timeline) + (if (not (eq org-agenda-diary-file 'diary-file)) + (org-agenda-diary-entry-in-org-file) + (require 'diary-lib) + (let* ((char (progn + (message "Diary entry: [d]ay [w]eekly [m]onthly [y]early [a]nniversary [b]lock [c]yclic") + (read-char-exclusive))) + (cmd (cdr (assoc char + '((?d . insert-diary-entry) + (?w . insert-weekly-diary-entry) + (?m . insert-monthly-diary-entry) + (?y . insert-yearly-diary-entry) + (?a . insert-anniversary-diary-entry) + (?b . insert-block-diary-entry) + (?c . insert-cyclic-diary-entry))))) + (oldf (symbol-function 'calendar-cursor-to-date)) + ;; (buf (get-file-buffer (substitute-in-file-name diary-file))) + (point (point)) + (mark (or (mark t) (point)))) + (unless cmd + (error "No command associated with <%c>" char)) + (unless (and (get-text-property point 'day) + (or (not (equal ?b char)) + (get-text-property mark 'day))) + (error "Don't know which date to use for diary entry")) + ;; We implement this by hacking the `calendar-cursor-to-date' function + ;; and the `calendar-mark-ring' variable. Saves a lot of code. + (let ((calendar-mark-ring + (list (calendar-gregorian-from-absolute + (or (get-text-property mark 'day) + (get-text-property point 'day)))))) + (unwind-protect + (progn + (fset 'calendar-cursor-to-date + (lambda (&optional error dummy) + (calendar-gregorian-from-absolute + (get-text-property point 'day)))) + (call-interactively cmd)) + (fset 'calendar-cursor-to-date oldf)))))) + +(defun org-agenda-execute-calendar-command (cmd) + "Execute a calendar command from the agenda, with the date associated to +the cursor position." + (org-agenda-check-type t 'agenda 'timeline) + (require 'diary-lib) + (unless (get-text-property (point) 'day) + (error "Don't know which date to use for calendar command")) + (let* ((oldf (symbol-function 'calendar-cursor-to-date)) + (point (point)) + (date (calendar-gregorian-from-absolute + (get-text-property point 'day))) + ;; the following 2 vars are needed in the calendar + (displayed-month (car date)) + (displayed-year (nth 2 date))) + (unwind-protect + (progn + (fset 'calendar-cursor-to-date + (lambda (&optional error dummy) + (calendar-gregorian-from-absolute + (get-text-property point 'day)))) + (call-interactively cmd)) + (fset 'calendar-cursor-to-date oldf)))) + +(defun org-agenda-phases-of-moon () + "Display the phases of the moon for the 3 months around the cursor date." + (interactive) + (org-agenda-execute-calendar-command 'calendar-phases-of-moon)) + +(defun org-agenda-holidays () + "Display the holidays for the 3 months around the cursor date." + (interactive) + (org-agenda-execute-calendar-command 'list-calendar-holidays)) + +(defvar calendar-longitude) +(defvar calendar-latitude) +(defvar calendar-location-name) + +(defun org-agenda-sunrise-sunset (arg) + "Display sunrise and sunset for the cursor date. +Latitude and longitude can be specified with the variables +`calendar-latitude' and `calendar-longitude'. When called with prefix +argument, latitude and longitude will be prompted for." + (interactive "P") + (require 'solar) + (let ((calendar-longitude (if arg nil calendar-longitude)) + (calendar-latitude (if arg nil calendar-latitude)) + (calendar-location-name + (if arg "the given coordinates" calendar-location-name))) + (org-agenda-execute-calendar-command 'calendar-sunrise-sunset))) + +(defun org-agenda-goto-calendar () + "Open the Emacs calendar with the date at the cursor." + (interactive) + (org-agenda-check-type t 'agenda 'timeline) + (let* ((day (or (get-text-property (point) 'day) + (error "Don't know which date to open in calendar"))) + (date (calendar-gregorian-from-absolute day)) + (calendar-move-hook nil) + (calendar-view-holidays-initially-flag nil) + (calendar-view-diary-initially-flag nil)) + (calendar) + (calendar-goto-date date))) + +;;;###autoload +(defun org-calendar-goto-agenda () + "Compute the Org-mode agenda for the calendar date displayed at the cursor. +This is a command that has to be installed in `calendar-mode-map'." + (interactive) + (org-agenda-list nil (calendar-absolute-from-gregorian + (calendar-cursor-to-date)) + nil)) + +(defun org-agenda-convert-date () + (interactive) + (org-agenda-check-type t 'agenda 'timeline) + (let ((day (get-text-property (point) 'day)) + date s) + (unless day + (error "Don't know which date to convert")) + (setq date (calendar-gregorian-from-absolute day)) + (setq s (concat + "Gregorian: " (calendar-date-string date) "\n" + "ISO: " (calendar-iso-date-string date) "\n" + "Day of Yr: " (calendar-day-of-year-string date) "\n" + "Julian: " (calendar-julian-date-string date) "\n" + "Astron. JD: " (calendar-astro-date-string date) + " (Julian date number at noon UTC)\n" + "Hebrew: " (calendar-hebrew-date-string date) " (until sunset)\n" + "Islamic: " (calendar-islamic-date-string date) " (until sunset)\n" + "French: " (calendar-french-date-string date) "\n" + "Baha'i: " (calendar-bahai-date-string date) " (until sunset)\n" + "Mayan: " (calendar-mayan-date-string date) "\n" + "Coptic: " (calendar-coptic-date-string date) "\n" + "Ethiopic: " (calendar-ethiopic-date-string date) "\n" + "Persian: " (calendar-persian-date-string date) "\n" + "Chinese: " (calendar-chinese-date-string date) "\n")) + (with-output-to-temp-buffer "*Dates*" + (princ s)) + (org-fit-window-to-buffer (get-buffer-window "*Dates*")))) + +;;; Bulk commands + +(defvar org-agenda-bulk-marked-entries nil + "List of markers that refer to marked entries in the agenda.") + +(defun org-agenda-bulk-marked-p () + (eq (get-char-property (point-at-bol) 'type) + 'org-marked-entry-overlay)) + +(defun org-agenda-bulk-mark (&optional arg) + "Mark the entry at point for future bulk action." + (interactive "p") + (dotimes (i (max arg 1)) + (unless (org-get-at-bol 'org-agenda-diary-link) + (let* ((m (org-get-at-bol 'org-hd-marker)) + ov) + (unless (org-agenda-bulk-marked-p) + (unless m (error "Nothing to mark at point")) + (push m org-agenda-bulk-marked-entries) + (setq ov (make-overlay (point-at-bol) (+ 2 (point-at-bol)))) + (org-overlay-display ov "> " + (org-get-todo-face "TODO") + 'evaporate) + (overlay-put ov 'type 'org-marked-entry-overlay)) + (beginning-of-line 2) + (while (and (get-char-property (point) 'invisible) (not (eobp))) + (beginning-of-line 2)) + (message "%d entries marked for bulk action" + (length org-agenda-bulk-marked-entries)))))) + +(defun org-agenda-bulk-unmark () + "Unmark the entry at point for future bulk action." + (interactive) + (when (org-agenda-bulk-marked-p) + (org-agenda-bulk-remove-overlays + (point-at-bol) (+ 2 (point-at-bol))) + (setq org-agenda-bulk-marked-entries + (delete (org-get-at-bol 'org-hd-marker) + org-agenda-bulk-marked-entries))) + (beginning-of-line 2) + (while (and (get-char-property (point) 'invisible) (not (eobp))) + (beginning-of-line 2)) + (message "%d entries marked for bulk action" + (length org-agenda-bulk-marked-entries))) + +(defun org-agenda-bulk-toggle () + "Toggle marking the entry at point for bulk action." + (interactive) + (if (org-agenda-bulk-marked-p) + (org-agenda-bulk-unmark) + (org-agenda-bulk-mark))) + +(defun org-agenda-bulk-remove-overlays (&optional beg end) + "Remove the mark overlays between BEG and END in the agenda buffer. +BEG and END default to the buffer limits. + +This only removes the overlays, it does not remove the markers +from the list in `org-agenda-bulk-marked-entries'." + (interactive) + (mapc (lambda (ov) + (and (eq (overlay-get ov 'type) 'org-marked-entry-overlay) + (delete-overlay ov))) + (overlays-in (or beg (point-min)) (or end (point-max))))) + +(defun org-agenda-bulk-remove-all-marks () + "Remove all marks in the agenda buffer. +This will remove the markers, and the overlays." + (interactive) + (mapc (lambda (m) (move-marker m nil)) org-agenda-bulk-marked-entries) + (setq org-agenda-bulk-marked-entries nil) + (org-agenda-bulk-remove-overlays (point-min) (point-max))) + +(defun org-agenda-bulk-action (&optional arg) + "Execute an remote-editing action on all marked entries. +The prefix arg is passed through to the command if possible." + (interactive "P") + (unless org-agenda-bulk-marked-entries + (error "No entries are marked")) + (message "Bulk: [r]efile [$]arch [A]rch->sib [t]odo [+/-]tag [s]chd [S]catter [d]eadline") + (let* ((action (read-char-exclusive)) + (org-log-refile (if org-log-refile 'time nil)) + (entries (reverse org-agenda-bulk-marked-entries)) + redo-at-end + cmd rfloc state e tag pos (cnt 0) (cntskip 0)) + (cond + ((equal action ?$) + (setq cmd '(org-agenda-archive))) + + ((equal action ?A) + (setq cmd '(org-agenda-archive-to-archive-sibling))) + + ((member action '(?r ?w)) + (setq rfloc (org-refile-get-location + "Refile to: " + (marker-buffer (car org-agenda-bulk-marked-entries)) + org-refile-allow-creating-parent-nodes)) + (if (nth 3 rfloc) + (setcar (nthcdr 3 rfloc) + (move-marker (make-marker) (nth 3 rfloc) + (or (get-file-buffer (nth 1 rfloc)) + (find-buffer-visiting (nth 1 rfloc)) + (error "This should not happen"))))) + + (setq cmd (list 'org-agenda-refile nil (list 'quote rfloc) t) + redo-at-end t)) + + ((equal action ?t) + (setq state (org-icompleting-read + "Todo state: " + (with-current-buffer (marker-buffer (car entries)) + (mapcar 'list org-todo-keywords-1)))) + (setq cmd `(let ((org-inhibit-blocking t) + (org-inhibit-logging 'note)) + (org-agenda-todo ,state)))) + + ((memq action '(?- ?+)) + (setq tag (org-icompleting-read + (format "Tag to %s: " (if (eq action ?+) "add" "remove")) + (with-current-buffer (marker-buffer (car entries)) + (delq nil + (mapcar (lambda (x) + (if (stringp (car x)) x)) org-tag-alist))))) + (setq cmd `(org-agenda-set-tags ,tag ,(if (eq action ?+) ''on ''off)))) + + ((memq action '(?s ?d)) + (let* ((date (unless arg + (org-read-date + nil nil nil + (if (eq action ?s) "(Re)Schedule to" "Set Deadline to")))) + (ans (if arg nil org-read-date-final-answer)) + (c1 (if (eq action ?s) 'org-agenda-schedule 'org-agenda-deadline))) + (setq cmd `(let* ((bound (fboundp 'read-string)) + (old (and bound (symbol-function 'read-string)))) + (unwind-protect + (progn + (fset 'read-string (lambda (&rest ignore) ,ans)) + (eval '(,c1 arg))) + (if bound + (fset 'read-string old) + (fmakunbound 'read-string))))))) + + ((eq action '?S) + (let ((days (read-number + (format "Scatter tasks across how many %sdays: " + (if arg "week" "")) 7))) + (setq cmd + `(let ((distance (random ,(1+ days)))) + (if arg + (let ((dist distance) + (day-of-week + (calendar-day-of-week + (calendar-gregorian-from-absolute (org-today))))) + (dotimes (i (1+ dist)) + (while (member day-of-week org-agenda-weekend-days) + (incf distance) + (incf day-of-week) + (if (= day-of-week 7) + (setq day-of-week 0))) + (incf day-of-week) + (if (= day-of-week 7) + (setq day-of-week 0))))) + (org-agenda-date-later distance))))) + + (t (error "Invalid bulk action"))) + + ;; Sort the markers, to make sure that parents are handled before children + (setq entries (sort entries + (lambda (a b) + (cond + ((equal (marker-buffer a) (marker-buffer b)) + (< (marker-position a) (marker-position b))) + (t + (string< (buffer-name (marker-buffer a)) + (buffer-name (marker-buffer b)))))))) + + ;; Now loop over all markers and apply cmd + (while (setq e (pop entries)) + (setq pos (text-property-any (point-min) (point-max) 'org-hd-marker e)) + (if (not pos) + (progn (message "Skipping removed entry at %s" e) + (setq cntskip (1+ cntskip))) + (goto-char pos) + (eval cmd) + (setq org-agenda-bulk-marked-entries + (delete e org-agenda-bulk-marked-entries)) + (setq cnt (1+ cnt)))) + (setq org-agenda-bulk-marked-entries nil) + (org-agenda-bulk-remove-all-marks) + (when redo-at-end (org-agenda-redo)) + (message "Acted on %d entries%s" + cnt + (if (= cntskip 0) + "" + (format ", skipped %d (disappeared before their turn)" + cntskip))))) + +;;; Flagging notes + +(defun org-agenda-show-the-flagging-note () + "Display the flagging note in the other window. +When called a second time in direct sequence, offer to remove the FLAGGING +tag and (if present) the flagging note." + (interactive) + (let ((hdmarker (org-get-at-bol 'org-hd-marker)) + (win (selected-window)) + note heading newhead) + (unless hdmarker + (error "No linked entry at point")) + (if (and (eq this-command last-command) + (y-or-n-p "Unflag and remove any flagging note? ")) + (progn + (org-agenda-remove-flag hdmarker) + (let ((win (get-buffer-window "*Flagging Note*"))) + (and win (delete-window win))) + (message "Entry unflaged")) + (setq note (org-entry-get hdmarker "THEFLAGGINGNOTE")) + (unless note + (error "No flagging note")) + (org-kill-new note) + (org-switch-to-buffer-other-window "*Flagging Note*") + (erase-buffer) + (insert note) + (goto-char (point-min)) + (while (re-search-forward "\\\\n" nil t) + (replace-match "\n" t t)) + (goto-char (point-min)) + (select-window win) + (message "Flagging note pushed to kill ring. Press [?] again to remove tag and note")))) + +(defun org-agenda-remove-flag (marker) + "Remove the FLAGGED tag and any flagging note in the entry." + (let (newhead) + (org-with-point-at marker + (org-toggle-tag "FLAGGED" 'off) + (org-entry-delete nil "THEFLAGGINGNOTE") + (setq newhead (org-get-heading))) + (org-agenda-change-all-lines newhead marker) + (message "Entry unflaged"))) + +(defun org-agenda-get-any-marker (&optional pos) + (or (get-text-property (or pos (point-at-bol)) 'org-hd-marker) + (get-text-property (or pos (point-at-bol)) 'org-marker))) + +;;; Appointment reminders + +(defvar appt-time-msg-list) + +;;;###autoload +(defun org-agenda-to-appt (&optional refresh filter) + "Activate appointments found in `org-agenda-files'. +With a \\[universal-argument] prefix, refresh the list of +appointments. + +If FILTER is t, interactively prompt the user for a regular +expression, and filter out entries that don't match it. + +If FILTER is a string, use this string as a regular expression +for filtering entries out. + +FILTER can also be an alist with the car of each cell being +either 'headline or 'category. For example: + + '((headline \"IMPORTANT\") + (category \"Work\")) + +will only add headlines containing IMPORTANT or headlines +belonging to the \"Work\" category." + (interactive "P") + (if refresh (setq appt-time-msg-list nil)) + (if (eq filter t) + (setq filter (read-from-minibuffer "Regexp filter: "))) + (let* ((cnt 0) ; count added events + (org-agenda-new-buffers nil) + (org-deadline-warning-days 0) + ;; Do not use `org-today' here because appt only takes + ;; time and without date as argument, so it may pass wrong + ;; information otherwise + (today (org-date-to-gregorian + (time-to-days (current-time)))) + (org-agenda-restrict nil) + (files (org-agenda-files 'unrestricted)) entries file) + ;; Get all entries which may contain an appt + (org-prepare-agenda-buffers files) + (while (setq file (pop files)) + (setq entries + (append entries + (org-agenda-get-day-entries + file today :timestamp :scheduled :deadline)))) + (setq entries (delq nil entries)) + ;; Map thru entries and find if we should filter them out + (mapc + (lambda(x) + (let* ((evt (org-trim (or (get-text-property 1 'txt x) ""))) + (cat (get-text-property 1 'org-category x)) + (tod (get-text-property 1 'time-of-day x)) + (ok (or (null filter) + (and (stringp filter) (string-match filter evt)) + (and (listp filter) + (or (string-match + (cadr (assoc 'category filter)) cat) + (string-match + (cadr (assoc 'headline filter)) evt)))))) + ;; FIXME: Shall we remove text-properties for the appt text? + ;; (setq evt (set-text-properties 0 (length evt) nil evt)) + (when (and ok tod) + (setq tod (concat "00" (number-to-string tod)) + tod (when (string-match + "\\([0-9]\\{1,2\\}\\)\\([0-9]\\{2\\}\\)\\'" tod) + (concat (match-string 1 tod) ":" + (match-string 2 tod)))) + (appt-add tod evt) + (setq cnt (1+ cnt))))) entries) + (org-release-buffers org-agenda-new-buffers) + (if (eq cnt 0) + (message "No event to add") + (message "Added %d event%s for today" cnt (if (> cnt 1) "s" ""))))) + +(defun org-agenda-todayp (date) + "Does DATE mean today, when considering `org-extend-today-until'?" + (let ((today (org-today)) + (date (if (and date (listp date)) (calendar-absolute-from-gregorian date) + date))) + (eq date today))) + +(provide 'org-agenda) + +;; arch-tag: 77f7565d-7c4b-44af-a2df-9f6f7070cff1 + +;;; org-agenda.el ends here diff --git a/.emacs.d/org-7.4/lisp/org-agenda.elc b/.emacs.d/org-7.4/lisp/org-agenda.elc Binary files differnew file mode 100644 index 0000000..3e27fec --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-agenda.elc diff --git a/.emacs.d/org-7.4/lisp/org-archive.el b/.emacs.d/org-7.4/lisp/org-archive.el new file mode 100644 index 0000000..e56b01f --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-archive.el @@ -0,0 +1,471 @@ +;;; org-archive.el --- Archiving for Org-mode + +;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010 +;; Free Software Foundation, Inc. + +;; Author: Carsten Dominik <carsten at orgmode dot org> +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; Version: 7.4 +;; +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: + +;; This file contains the face definitions for Org. + +;;; Code: + +(require 'org) + +(declare-function org-inlinetask-remove-END-maybe "org-inlinetask" ()) + +(defcustom org-archive-default-command 'org-archive-subtree + "The default archiving command." + :group 'org-archive + :type '(choice + (const org-archive-subtree) + (const org-archive-to-archive-sibling) + (const org-archive-set-tag))) + +(defcustom org-archive-reversed-order nil + "Non-nil means make the tree first child under the archive heading, not last." + :group 'org-archive + :type 'boolean) + +(defcustom org-archive-sibling-heading "Archive" + "Name of the local archive sibling that is used to archive entries locally. +Locally means: in the tree, under a sibling. +See `org-archive-to-archive-sibling' for more information." + :group 'org-archive + :type 'string) + +(defcustom org-archive-mark-done nil + "Non-nil means mark entries as DONE when they are moved to the archive file. +This can be a string to set the keyword to use. When t, Org-mode will +use the first keyword in its list that means done." + :group 'org-archive + :type '(choice + (const :tag "No" nil) + (const :tag "Yes" t) + (string :tag "Use this keyword"))) + +(defcustom org-archive-stamp-time t + "Non-nil means add a time stamp to entries moved to an archive file. +This variable is obsolete and has no effect anymore, instead add or remove +`time' from the variable `org-archive-save-context-info'." + :group 'org-archive + :type 'boolean) + +(defcustom org-archive-save-context-info '(time file olpath category todo itags) + "Parts of context info that should be stored as properties when archiving. +When a subtree is moved to an archive file, it loses information given by +context, like inherited tags, the category, and possibly also the TODO +state (depending on the variable `org-archive-mark-done'). +This variable can be a list of any of the following symbols: + +time The time of archiving. +file The file where the entry originates. +ltags The local tags, in the headline of the subtree. +itags The tags the subtree inherits from further up the hierarchy. +todo The pre-archive TODO state. +category The category, taken from file name or #+CATEGORY lines. +olpath The outline path to the item. These are all headlines above + the current item, separated by /, like a file path. + +For each symbol present in the list, a property will be created in +the archived entry, with a prefix \"PRE_ARCHIVE_\", to remember this +information." + :group 'org-archive + :type '(set :greedy t + (const :tag "Time" time) + (const :tag "File" file) + (const :tag "Category" category) + (const :tag "TODO state" todo) + (const :tag "Priority" priority) + (const :tag "Inherited tags" itags) + (const :tag "Outline path" olpath) + (const :tag "Local tags" ltags))) + +(defun org-get-local-archive-location () + "Get the archive location applicable at point." + (let ((re "^#\\+ARCHIVE:[ \t]+\\(\\S-.*\\S-\\)[ \t]*$") + prop) + (save-excursion + (save-restriction + (widen) + (setq prop (org-entry-get nil "ARCHIVE" 'inherit)) + (cond + ((and prop (string-match "\\S-" prop)) + prop) + ((or (re-search-backward re nil t) + (re-search-forward re nil t)) + (match-string 1)) + (t org-archive-location)))))) + +(defun org-add-archive-files (files) + "Splice the archive files into the list of files. +This implies visiting all these files and finding out what the +archive file is." + (org-uniquify + (apply + 'append + (mapcar + (lambda (f) + (if (not (file-exists-p f)) + nil + (with-current-buffer (org-get-agenda-file-buffer f) + (cons f (org-all-archive-files))))) + files)))) + +(defun org-all-archive-files () + "Get a list of all archive files used in the current buffer." + (let (file files) + (save-excursion + (save-restriction + (goto-char (point-min)) + (while (re-search-forward + "^\\(#\\+\\|[ \t]*:\\)ARCHIVE:[ \t]+\\(.*\\)" + nil t) + (setq file (org-extract-archive-file + (org-match-string-no-properties 2))) + (and file (> (length file) 0) (file-exists-p file) + (add-to-list 'files file))))) + (setq files (nreverse files)) + (setq file (org-extract-archive-file)) + (and file (> (length file) 0) (file-exists-p file) + (add-to-list 'files file)) + files)) + +(defun org-extract-archive-file (&optional location) + "Extract and expand the file name from archive LOCATION. +if LOCATION is not given, the value of `org-archive-location' is used." + (setq location (or location org-archive-location)) + (if (string-match "\\(.*\\)::\\(.*\\)" location) + (if (= (match-beginning 1) (match-end 1)) + (buffer-file-name) + (expand-file-name + (format (match-string 1 location) + (file-name-nondirectory buffer-file-name)))))) + +(defun org-extract-archive-heading (&optional location) + "Extract the heading from archive LOCATION. +if LOCATION is not given, the value of `org-archive-location' is used." + (setq location (or location org-archive-location)) + (if (string-match "\\(.*\\)::\\(.*\\)" location) + (format (match-string 2 location) + (file-name-nondirectory buffer-file-name)))) + +(defun org-archive-subtree (&optional find-done) + "Move the current subtree to the archive. +The archive can be a certain top-level heading in the current file, or in +a different file. The tree will be moved to that location, the subtree +heading be marked DONE, and the current time will be added. + +When called with prefix argument FIND-DONE, find whole trees without any +open TODO items and archive them (after getting confirmation from the user). +If the cursor is not at a headline when this command is called, try all level +1 trees. If the cursor is on a headline, only try the direct children of +this heading." + (interactive "P") + (if find-done + (org-archive-all-done) + ;; Save all relevant TODO keyword-relatex variables + + (let ((tr-org-todo-line-regexp org-todo-line-regexp) ; keep despite compiler + (tr-org-todo-keywords-1 org-todo-keywords-1) + (tr-org-todo-kwd-alist org-todo-kwd-alist) + (tr-org-done-keywords org-done-keywords) + (tr-org-todo-regexp org-todo-regexp) + (tr-org-todo-line-regexp org-todo-line-regexp) + (tr-org-odd-levels-only org-odd-levels-only) + (this-buffer (current-buffer)) + ;; start of variables that will be used for saving context + ;; The compiler complains about them - keep them anyway! + (file (abbreviate-file-name (buffer-file-name))) + (olpath (mapconcat 'identity (org-get-outline-path) "/")) + (time (format-time-string + (substring (cdr org-time-stamp-formats) 1 -1) + (current-time))) + category todo priority ltags itags + ;; end of variables that will be used for saving context + location afile heading buffer level newfile-p visiting) + + ;; Find the local archive location + (setq location (org-get-local-archive-location) + afile (org-extract-archive-file location) + heading (org-extract-archive-heading location)) + (unless afile + (error "Invalid `org-archive-location'")) + + (if (> (length afile) 0) + (setq newfile-p (not (file-exists-p afile)) + visiting (find-buffer-visiting afile) + buffer (or visiting (find-file-noselect afile))) + (setq buffer (current-buffer))) + (unless buffer + (error "Cannot access file \"%s\"" afile)) + (if (and (> (length heading) 0) + (string-match "^\\*+" heading)) + (setq level (match-end 0)) + (setq heading nil level 0)) + (save-excursion + (org-back-to-heading t) + ;; Get context information that will be lost by moving the tree + (org-refresh-category-properties) + (setq category (org-get-category) + todo (and (looking-at org-todo-line-regexp) + (match-string 2)) + priority (org-get-priority + (if (match-end 3) (match-string 3) "")) + ltags (org-get-tags) + itags (org-delete-all ltags (org-get-tags-at))) + (setq ltags (mapconcat 'identity ltags " ") + itags (mapconcat 'identity itags " ")) + ;; We first only copy, in case something goes wrong + ;; we need to protect `this-command', to avoid kill-region sets it, + ;; which would lead to duplication of subtrees + (let (this-command) (org-copy-subtree 1 nil t)) + (set-buffer buffer) + ;; Enforce org-mode for the archive buffer + (if (not (org-mode-p)) + ;; Force the mode for future visits. + (let ((org-insert-mode-line-in-empty-file t) + (org-inhibit-startup t)) + (call-interactively 'org-mode))) + (when newfile-p + (goto-char (point-max)) + (insert (format "\nArchived entries from file %s\n\n" + (buffer-file-name this-buffer)))) + ;; Force the TODO keywords of the original buffer + (let ((org-todo-line-regexp tr-org-todo-line-regexp) + (org-todo-keywords-1 tr-org-todo-keywords-1) + (org-todo-kwd-alist tr-org-todo-kwd-alist) + (org-done-keywords tr-org-done-keywords) + (org-todo-regexp tr-org-todo-regexp) + (org-todo-line-regexp tr-org-todo-line-regexp) + (org-odd-levels-only + (if (local-variable-p 'org-odd-levels-only (current-buffer)) + org-odd-levels-only + tr-org-odd-levels-only))) + (goto-char (point-min)) + (show-all) + (if heading + (progn + (if (re-search-forward + (concat "^" (regexp-quote heading) + (org-re "[ \t]*\\(:[[:alnum:]_@#%:]+:\\)?[ \t]*\\($\\|\r\\)")) + nil t) + (goto-char (match-end 0)) + ;; Heading not found, just insert it at the end + (goto-char (point-max)) + (or (bolp) (insert "\n")) + (insert "\n" heading "\n") + (end-of-line 0)) + ;; Make the subtree visible + (show-subtree) + (if org-archive-reversed-order + (progn + (org-back-to-heading t) + (outline-next-heading)) + (org-end-of-subtree t)) + (skip-chars-backward " \t\r\n") + (and (looking-at "[ \t\r\n]*") + (replace-match "\n\n"))) + ;; No specific heading, just go to end of file. + (goto-char (point-max)) (insert "\n")) + ;; Paste + (org-paste-subtree (org-get-valid-level level (and heading 1))) + + ;; Mark the entry as done + (when (and org-archive-mark-done + (looking-at org-todo-line-regexp) + (or (not (match-end 2)) + (not (member (match-string 2) org-done-keywords)))) + (let (org-log-done org-todo-log-states) + (org-todo + (car (or (member org-archive-mark-done org-done-keywords) + org-done-keywords))))) + + ;; Add the context info + (when org-archive-save-context-info + (let ((l org-archive-save-context-info) e n v) + (while (setq e (pop l)) + (when (and (setq v (symbol-value e)) + (stringp v) (string-match "\\S-" v)) + (setq n (concat "ARCHIVE_" (upcase (symbol-name e)))) + (org-entry-put (point) n v))))) + + ;; Save and kill the buffer, if it is not the same buffer. + (when (not (eq this-buffer buffer)) + (save-buffer)) + )) + ;; Here we are back in the original buffer. Everything seems to have + ;; worked. So now cut the tree and finish up. + (let (this-command) (org-cut-subtree)) + (when (featurep 'org-inlinetask) + (org-inlinetask-remove-END-maybe)) + (setq org-markers-to-move nil) + (message "Subtree archived %s" + (if (eq this-buffer buffer) + (concat "under heading: " heading) + (concat "in file: " (abbreviate-file-name afile)))))) + (org-reveal) + (if (looking-at "^[ \t]*$") + (outline-next-visible-heading 1))) + +(defun org-archive-to-archive-sibling () + "Archive the current heading by moving it under the archive sibling. +The archive sibling is a sibling of the heading with the heading name +`org-archive-sibling-heading' and an `org-archive-tag' tag. If this +sibling does not exist, it will be created at the end of the subtree." + (interactive) + (save-restriction + (widen) + (let (b e pos leader level) + (org-back-to-heading t) + (looking-at outline-regexp) + (setq leader (match-string 0) + level (funcall outline-level)) + (setq pos (point)) + (condition-case nil + (outline-up-heading 1 t) + (error (setq e (point-max)) (goto-char (point-min)))) + (setq b (point)) + (unless e + (condition-case nil + (org-end-of-subtree t t) + (error (goto-char (point-max)))) + (setq e (point))) + (goto-char b) + (unless (re-search-forward + (concat "^" (regexp-quote leader) + "[ \t]*" + org-archive-sibling-heading + "[ \t]*:" + org-archive-tag ":") e t) + (goto-char e) + (or (bolp) (newline)) + (insert leader org-archive-sibling-heading "\n") + (beginning-of-line 0) + (org-toggle-tag org-archive-tag 'on)) + (beginning-of-line 1) + (if org-archive-reversed-order + (outline-next-heading) + (org-end-of-subtree t t)) + (save-excursion + (goto-char pos) + (let ((this-command this-command)) (org-cut-subtree))) + (org-paste-subtree (org-get-valid-level level 1)) + (org-set-property + "ARCHIVE_TIME" + (format-time-string + (substring (cdr org-time-stamp-formats) 1 -1) + (current-time))) + (outline-up-heading 1 t) + (hide-subtree) + (org-cycle-show-empty-lines 'folded) + (goto-char pos))) + (org-reveal) + (if (looking-at "^[ \t]*$") + (outline-next-visible-heading 1))) + +(defun org-archive-all-done (&optional tag) + "Archive sublevels of the current tree without open TODO items. +If the cursor is not on a headline, try all level 1 trees. If +it is on a headline, try all direct children. +When TAG is non-nil, don't move trees, but mark them with the ARCHIVE tag." + (let ((re (concat "^\\*+ +" org-not-done-regexp)) re1 + (rea (concat ".*:" org-archive-tag ":")) + (begm (make-marker)) + (endm (make-marker)) + (question (if tag "Set ARCHIVE tag (no open TODO items)? " + "Move subtree to archive (no open TODO items)? ")) + beg end (cntarch 0)) + (if (org-on-heading-p) + (progn + (setq re1 (concat "^" (regexp-quote + (make-string + (+ (- (match-end 0) (match-beginning 0) 1) + (if org-odd-levels-only 2 1)) + ?*)) + " ")) + (move-marker begm (point)) + (move-marker endm (org-end-of-subtree t))) + (setq re1 "^* ") + (move-marker begm (point-min)) + (move-marker endm (point-max))) + (save-excursion + (goto-char begm) + (while (re-search-forward re1 endm t) + (setq beg (match-beginning 0) + end (save-excursion (org-end-of-subtree t) (point))) + (goto-char beg) + (if (re-search-forward re end t) + (goto-char end) + (goto-char beg) + (if (and (or (not tag) (not (looking-at rea))) + (y-or-n-p question)) + (progn + (if tag + (org-toggle-tag org-archive-tag 'on) + (org-archive-subtree)) + (setq cntarch (1+ cntarch))) + (goto-char end))))) + (message "%d trees archived" cntarch))) + +(defun org-toggle-archive-tag (&optional find-done) + "Toggle the archive tag for the current headline. +With prefix ARG, check all children of current headline and offer tagging +the children that do not contain any open TODO items." + (interactive "P") + (if find-done + (org-archive-all-done 'tag) + (let (set) + (save-excursion + (org-back-to-heading t) + (setq set (org-toggle-tag org-archive-tag)) + (when set (hide-subtree))) + (and set (beginning-of-line 1)) + (message "Subtree %s" (if set "archived" "unarchived"))))) + +(defun org-archive-set-tag () + "Set the ARCHIVE tag." + (interactive) + (org-toggle-tag org-archive-tag 'on)) + +;;;###autoload +(defun org-archive-subtree-default () + "Archive the current subtree with the default command. +This command is set with the variable `org-archive-default-command'." + (interactive) + (call-interactively org-archive-default-command)) + +;;;###autoload +(defun org-archive-subtree-default-with-confirmation () + "Archive the current subtree with the default command. +This command is set with the variable `org-archive-default-command'." + (interactive) + (if (y-or-n-p "Archive this subtree or entry? ") + (call-interactively org-archive-default-command) + (error "Abort"))) + +(provide 'org-archive) + +;; arch-tag: 0837f601-9699-43c3-8b90-631572ae6c85 + +;;; org-archive.el ends here diff --git a/.emacs.d/org-7.4/lisp/org-archive.elc b/.emacs.d/org-7.4/lisp/org-archive.elc Binary files differnew file mode 100644 index 0000000..9b0ccff --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-archive.elc diff --git a/.emacs.d/org-7.4/lisp/org-ascii.el b/.emacs.d/org-7.4/lisp/org-ascii.el new file mode 100644 index 0000000..99facb1 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-ascii.el @@ -0,0 +1,723 @@ +;;; org-ascii.el --- ASCII export for Org-mode + +;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010 +;; Free Software Foundation, Inc. + +;; Author: Carsten Dominik <carsten at orgmode dot org> +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; Version: 7.4 +;; +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: + +;;; Code: + +(require 'org-exp) + +(eval-when-compile + (require 'cl)) + +(defgroup org-export-ascii nil + "Options specific for ASCII export of Org-mode files." + :tag "Org Export ASCII" + :group 'org-export) + +(defcustom org-export-ascii-underline '(?\$ ?\# ?^ ?\~ ?\= ?\-) + "Characters for underlining headings in ASCII export. +In the given sequence, these characters will be used for level 1, 2, ..." + :group 'org-export-ascii + :type '(repeat character)) + +(defcustom org-export-ascii-bullets '(?* ?+ ?-) + "Bullet characters for headlines converted to lists in ASCII export. +The first character is used for the first lest level generated in this +way, and so on. If there are more levels than characters given here, +the list will be repeated. +Note that plain lists will keep the same bullets as the have in the +Org-mode file." + :group 'org-export-ascii + :type '(repeat character)) + +(defcustom org-export-ascii-links-to-notes t + "Non-nil means convert links to notes before the next headline. +When nil, the link will be exported in place. If the line becomes long +in this way, it will be wrapped." + :group 'org-export-ascii + :type 'boolean) + +(defcustom org-export-ascii-table-keep-all-vertical-lines nil + "Non-nil means keep all vertical lines in ASCII tables. +When nil, vertical lines will be removed except for those needed +for column grouping." + :group 'org-export-ascii + :type 'boolean) + +(defcustom org-export-ascii-table-widen-columns t + "Non-nil means widen narrowed columns for export. +When nil, narrowed columns will look in ASCII export just like in org-mode, +i.e. with \"=>\" as ellipsis." + :group 'org-export-ascii + :type 'boolean) + +(defvar org-export-ascii-entities 'ascii + "The ascii representation to be used during ascii export. +Possible values are: + +ascii Only use plain ASCII characters +latin1 Include Latin-1 character +utf8 Use all UTF-8 characters") + +;;; Hooks + +(defvar org-export-ascii-final-hook nil + "Hook run at the end of ASCII export, in the new buffer.") + +;;; ASCII export + +(defvar org-ascii-current-indentation nil) ; For communication + +;;;###autoload +(defun org-export-as-latin1 (&rest args) + "Like `org-export-as-ascii', use latin1 encoding for special symbols." + (interactive) + (org-export-as-encoding 'org-export-as-ascii (interactive-p) + 'latin1 args)) + +;;;###autoload +(defun org-export-as-latin1-to-buffer (&rest args) + "Like `org-export-as-ascii-to-buffer', use latin1 encoding for symbols." + (interactive) + (org-export-as-encoding 'org-export-as-ascii-to-buffer (interactive-p) + 'latin1 args)) + +;;;###autoload +(defun org-export-as-utf8 (&rest args) + "Like `org-export-as-ascii', use use encoding for special symbols." + (interactive) + (org-export-as-encoding 'org-export-as-ascii (interactive-p) + 'utf8 args)) + +;;;###autoload +(defun org-export-as-utf8-to-buffer (&rest args) + "Like `org-export-as-ascii-to-buffer', use utf8 encoding for symbols." + (interactive) + (org-export-as-encoding 'org-export-as-ascii-to-buffer (interactive-p) + 'utf8 args)) + +(defun org-export-as-encoding (command interactivep encoding &rest args) + (let ((org-export-ascii-entities encoding)) + (if interactivep + (call-interactively command) + (apply command args)))) + + +;;;###autoload +(defun org-export-as-ascii-to-buffer (arg) + "Call `org-export-as-ascii` with output to a temporary buffer. +No file is created. The prefix ARG is passed through to `org-export-as-ascii'." + (interactive "P") + (org-export-as-ascii arg nil nil "*Org ASCII Export*") + (when org-export-show-temporary-export-buffer + (switch-to-buffer-other-window "*Org ASCII Export*"))) + +;;;###autoload +(defun org-replace-region-by-ascii (beg end) + "Assume the current region has org-mode syntax, and convert it to plain ASCII. +This can be used in any buffer. For example, you could write an +itemized list in org-mode syntax in a Mail buffer and then use this +command to convert it." + (interactive "r") + (let (reg ascii buf pop-up-frames) + (save-window-excursion + (if (org-mode-p) + (setq ascii (org-export-region-as-ascii + beg end t 'string)) + (setq reg (buffer-substring beg end) + buf (get-buffer-create "*Org tmp*")) + (with-current-buffer buf + (erase-buffer) + (insert reg) + (org-mode) + (setq ascii (org-export-region-as-ascii + (point-min) (point-max) t 'string))) + (kill-buffer buf))) + (delete-region beg end) + (insert ascii))) + +;;;###autoload +(defun org-export-region-as-ascii (beg end &optional body-only buffer) + "Convert region from BEG to END in org-mode buffer to plain ASCII. +If prefix arg BODY-ONLY is set, omit file header, footer, and table of +contents, and only produce the region of converted text, useful for +cut-and-paste operations. +If BUFFER is a buffer or a string, use/create that buffer as a target +of the converted ASCII. If BUFFER is the symbol `string', return the +produced ASCII as a string and leave not buffer behind. For example, +a Lisp program could call this function in the following way: + + (setq ascii (org-export-region-as-ascii beg end t 'string)) + +When called interactively, the output buffer is selected, and shown +in a window. A non-interactive call will only return the buffer." + (interactive "r\nP") + (when (interactive-p) + (setq buffer "*Org ASCII Export*")) + (let ((transient-mark-mode t) (zmacs-regions t) + ext-plist rtn) + (setq ext-plist (plist-put ext-plist :ignore-subtree-p t)) + (goto-char end) + (set-mark (point)) ;; to activate the region + (goto-char beg) + (setq rtn (org-export-as-ascii + nil nil ext-plist + buffer body-only)) + (if (fboundp 'deactivate-mark) (deactivate-mark)) + (if (and (interactive-p) (bufferp rtn)) + (switch-to-buffer-other-window rtn) + rtn))) + +;;;###autoload +(defun org-export-as-ascii (arg &optional hidden ext-plist + to-buffer body-only pub-dir) + "Export the outline as a pretty ASCII file. +If there is an active region, export only the region. +The prefix ARG specifies how many levels of the outline should become +underlined headlines, default is 3. Lower levels will become bulleted +lists. When HIDDEN is non-nil, don't display the ASCII buffer. +EXT-PLIST is a property list with external parameters overriding +org-mode's default settings, but still inferior to file-local +settings. When TO-BUFFER is non-nil, create a buffer with that +name and export to that buffer. If TO-BUFFER is the symbol +`string', don't leave any buffer behind but just return the +resulting ASCII as a string. When BODY-ONLY is set, don't produce +the file header and footer. When PUB-DIR is set, use this as the +publishing directory." + (interactive "P") + (run-hooks 'org-export-first-hook) + (setq-default org-todo-line-regexp org-todo-line-regexp) + (let* ((opt-plist (org-combine-plists (org-default-export-plist) + ext-plist + (org-infile-export-plist))) + (region-p (org-region-active-p)) + (rbeg (and region-p (region-beginning))) + (rend (and region-p (region-end))) + (subtree-p + (if (plist-get opt-plist :ignore-subtree-p) + nil + (when region-p + (save-excursion + (goto-char rbeg) + (and (org-at-heading-p) + (>= (org-end-of-subtree t t) rend)))))) + (level-offset (if subtree-p + (save-excursion + (goto-char rbeg) + (+ (funcall outline-level) + (if org-odd-levels-only 1 0))) + 0)) + (opt-plist (setq org-export-opt-plist + (if subtree-p + (org-export-add-subtree-options opt-plist rbeg) + opt-plist))) + ;; The following two are dynamically scoped into other + ;; routines below. + (org-current-export-dir + (or pub-dir (org-export-directory :html opt-plist))) + (org-current-export-file buffer-file-name) + (custom-times org-display-custom-times) + (org-ascii-current-indentation '(0 . 0)) + (level 0) line txt + (umax nil) + (umax-toc nil) + (case-fold-search nil) + (bfname (buffer-file-name (or (buffer-base-buffer) (current-buffer)))) + (filename (if to-buffer + nil + (concat (file-name-as-directory + (or pub-dir + (org-export-directory :ascii opt-plist))) + (file-name-sans-extension + (or (and subtree-p + (org-entry-get (region-beginning) + "EXPORT_FILE_NAME" t)) + (file-name-nondirectory bfname))) + ".txt"))) + (filename (and filename + (if (equal (file-truename filename) + (file-truename bfname)) + (concat filename ".txt") + filename))) + (buffer (if to-buffer + (cond + ((eq to-buffer 'string) + (get-buffer-create "*Org ASCII Export*")) + (t (get-buffer-create to-buffer))) + (find-file-noselect filename))) + (org-levels-open (make-vector org-level-max nil)) + (odd org-odd-levels-only) + (date (plist-get opt-plist :date)) + (author (plist-get opt-plist :author)) + (title (or (and subtree-p (org-export-get-title-from-subtree)) + (plist-get opt-plist :title) + (and (not + (plist-get opt-plist :skip-before-1st-heading)) + (org-export-grab-title-from-buffer)) + (and (buffer-file-name) + (file-name-sans-extension + (file-name-nondirectory bfname))) + "UNTITLED")) + (email (plist-get opt-plist :email)) + (language (plist-get opt-plist :language)) + (quote-re0 (concat "^[ \t]*" org-quote-string "\\>")) + (todo nil) + (lang-words nil) + (region + (buffer-substring + (if (org-region-active-p) (region-beginning) (point-min)) + (if (org-region-active-p) (region-end) (point-max)))) + (lines (org-split-string + (org-export-preprocess-string + region + :for-ascii t + :skip-before-1st-heading + (plist-get opt-plist :skip-before-1st-heading) + :drawers (plist-get opt-plist :drawers) + :tags (plist-get opt-plist :tags) + :priority (plist-get opt-plist :priority) + :footnotes (plist-get opt-plist :footnotes) + :timestamps (plist-get opt-plist :timestamps) + :todo-keywords (plist-get opt-plist :todo-keywords) + :verbatim-multiline t + :select-tags (plist-get opt-plist :select-tags) + :exclude-tags (plist-get opt-plist :exclude-tags) + :archived-trees + (plist-get opt-plist :archived-trees) + :add-text (plist-get opt-plist :text)) + "\n")) + thetoc have-headings first-heading-pos + table-open table-buffer link-buffer link type path desc desc0 rpl wrap fnc) + (let ((inhibit-read-only t)) + (org-unmodified + (remove-text-properties (point-min) (point-max) + '(:org-license-to-kill t)))) + + (setq org-min-level (org-get-min-level lines level-offset)) + (setq org-last-level org-min-level) + (org-init-section-numbers) + (setq lang-words (or (assoc language org-export-language-setup) + (assoc "en" org-export-language-setup))) + (set-buffer buffer) + (erase-buffer) + (fundamental-mode) + (org-install-letbind) + ;; create local variables for all options, to make sure all called + ;; functions get the correct information + (mapc (lambda (x) + (set (make-local-variable (nth 2 x)) + (plist-get opt-plist (car x)))) + org-export-plist-vars) + (org-set-local 'org-odd-levels-only odd) + (setq umax (if arg (prefix-numeric-value arg) + org-export-headline-levels)) + (setq umax-toc (if (integerp org-export-with-toc) + (min org-export-with-toc umax) + umax)) + + ;; File header + (unless body-only + (when (and title (not (string= "" title))) + (org-insert-centered title ?=) + (insert "\n")) + + (if (and (or author email) + org-export-author-info) + (insert (concat (nth 1 lang-words) ": " (or author "") + (if (and org-export-email-info + email (string-match "\\S-" email)) + (concat " <" email ">") "") + "\n"))) + + (cond + ((and date (string-match "%" date)) + (setq date (format-time-string date))) + (date) + (t (setq date (format-time-string "%Y-%m-%d %T %Z")))) + + (if (and date org-export-time-stamp-file) + (insert (concat (nth 2 lang-words) ": " date"\n"))) + + (unless (= (point) (point-min)) + (insert "\n\n"))) + + (if (and org-export-with-toc (not body-only)) + (progn + (push (concat (nth 3 lang-words) "\n") thetoc) + (push (concat (make-string (string-width (nth 3 lang-words)) ?=) + "\n") thetoc) + (mapc '(lambda (line) + (if (string-match org-todo-line-regexp + line) + ;; This is a headline + (progn + (setq have-headings t) + (setq level (- (match-end 1) (match-beginning 1) + level-offset) + level (org-tr-level level) + txt (match-string 3 line) + todo + (or (and org-export-mark-todo-in-toc + (match-beginning 2) + (not (member (match-string 2 line) + org-done-keywords))) + ; TODO, not DONE + (and org-export-mark-todo-in-toc + (= level umax-toc) + (org-search-todo-below + line lines level)))) + (setq txt (org-html-expand-for-ascii txt)) + + (while (string-match org-bracket-link-regexp txt) + (setq txt + (replace-match + (match-string (if (match-end 2) 3 1) txt) + t t txt))) + + (if (and (memq org-export-with-tags '(not-in-toc nil)) + (string-match + (org-re "[ \t]+:[[:alnum:]_@#%:]+:[ \t]*$") + txt)) + (setq txt (replace-match "" t t txt))) + (if (string-match quote-re0 txt) + (setq txt (replace-match "" t t txt))) + + (if org-export-with-section-numbers + (setq txt (concat (org-section-number level) + " " txt))) + (if (<= level umax-toc) + (progn + (push + (concat + (make-string + (* (max 0 (- level org-min-level)) 4) ?\ ) + (format (if todo "%s (*)\n" "%s\n") txt)) + thetoc) + (setq org-last-level level)) + )))) + lines) + (setq thetoc (if have-headings (nreverse thetoc) nil)))) + + (org-init-section-numbers) + (while (setq line (pop lines)) + (when (and link-buffer (string-match "^\\*+ " line)) + (org-export-ascii-push-links (nreverse link-buffer)) + (setq link-buffer nil)) + (setq wrap nil) + ;; Remove the quoted HTML tags. + (setq line (org-html-expand-for-ascii line)) + ;; Replace links with the description when possible + (while (string-match org-bracket-link-analytic-regexp++ line) + (setq path (match-string 3 line) + link (concat (match-string 1 line) path) + type (match-string 2 line) + desc0 (match-string 5 line) + desc (or desc0 link)) + (if (and (> (length link) 8) + (equal (substring link 0 8) "coderef:")) + (setq line (replace-match + (format (org-export-get-coderef-format (substring link 8) desc) + (cdr (assoc + (substring link 8) + org-export-code-refs))) + t t line)) + (setq rpl (concat "[" desc "]")) + (if (functionp (setq fnc (nth 2 (assoc type org-link-protocols)))) + (setq rpl (or (save-match-data + (funcall fnc (org-link-unescape path) + desc0 'ascii)) + rpl)) + (when (and desc0 (not (equal desc0 link))) + (if org-export-ascii-links-to-notes + (push (cons desc0 link) link-buffer) + (setq rpl (concat rpl " (" link ")") + wrap (+ (length line) (- (length (match-string 0 line))) + (length desc)))))) + (setq line (replace-match rpl t t line)))) + (when custom-times + (setq line (org-translate-time line))) + (cond + ((string-match "^\\(\\*+\\)[ \t]+\\(.*\\)" line) + ;; a Headline + (setq first-heading-pos (or first-heading-pos (point))) + (setq level (org-tr-level (- (match-end 1) (match-beginning 1) + level-offset)) + txt (match-string 2 line)) + (org-ascii-level-start level txt umax lines)) + + ((and org-export-with-tables + (string-match "^\\([ \t]*\\)\\(|\\|\\+-+\\+\\)" line)) + (if (not table-open) + ;; New table starts + (setq table-open t table-buffer nil)) + ;; Accumulate lines + (setq table-buffer (cons line table-buffer)) + (when (or (not lines) + (not (string-match "^\\([ \t]*\\)\\(|\\|\\+-+\\+\\)" + (car lines)))) + (setq table-open nil + table-buffer (nreverse table-buffer)) + (insert (mapconcat + (lambda (x) + (org-fix-indentation x org-ascii-current-indentation)) + (org-format-table-ascii table-buffer) + "\n") "\n"))) + (t + (if (string-match "^\\([ \t]*\\)\\([-+*][ \t]+\\)\\(.*?\\)\\( ::\\)" + line) + (setq line (replace-match "\\1\\3:" t nil line))) + (setq line (org-fix-indentation line org-ascii-current-indentation)) + ;; Remove forced line breaks + (if (string-match "\\\\\\\\[ \t]*$" line) + (setq line (replace-match "" t t line))) + (if (and org-export-with-fixed-width + (string-match "^\\([ \t]*\\)\\(:\\( \\|$\\)\\)" line)) + (setq line (replace-match "\\1" nil nil line)) + (if wrap (setq line (org-export-ascii-wrap line wrap)))) + (insert line "\n")))) + + (org-export-ascii-push-links (nreverse link-buffer)) + + (normal-mode) + + ;; insert the table of contents + (when thetoc + (goto-char (point-min)) + (if (re-search-forward "^[ \t]*\\[TABLE-OF-CONTENTS\\][ \t]*$" nil t) + (progn + (goto-char (match-beginning 0)) + (replace-match "")) + (goto-char first-heading-pos)) + (mapc 'insert thetoc) + (or (looking-at "[ \t]*\n[ \t]*\n") + (insert "\n\n"))) + + ;; Convert whitespace place holders + (goto-char (point-min)) + (let (beg end) + (while (setq beg (next-single-property-change (point) 'org-whitespace)) + (setq end (next-single-property-change beg 'org-whitespace)) + (goto-char beg) + (delete-region beg end) + (insert (make-string (- end beg) ?\ )))) + + ;; remove display and invisible chars + (let (beg end) + (goto-char (point-min)) + (while (setq beg (next-single-property-change (point) 'display)) + (setq end (next-single-property-change beg 'display)) + (delete-region beg end) + (goto-char beg) + (insert "=>")) + (goto-char (point-min)) + (while (setq beg (next-single-property-change (point) 'org-cwidth)) + (setq end (next-single-property-change beg 'org-cwidth)) + (delete-region beg end) + (goto-char beg))) + (run-hooks 'org-export-ascii-final-hook) + (or to-buffer (save-buffer)) + (goto-char (point-min)) + (or (org-export-push-to-kill-ring "ASCII") + (message "Exporting... done")) + ;; Return the buffer or a string, according to how this function was called + (if (eq to-buffer 'string) + (prog1 (buffer-substring (point-min) (point-max)) + (kill-buffer (current-buffer))) + (current-buffer)))) + +(defun org-export-ascii-preprocess (parameters) + "Do extra work for ASCII export." + ;; + ;; Realign tables to get rid of narrowing + (when org-export-ascii-table-widen-columns + (let ((org-table-do-narrow nil)) + (goto-char (point-min)) + (org-ascii-replace-entities) + (goto-char (point-min)) + (org-table-map-tables + (lambda () (org-if-unprotected (org-table-align))) + 'quietly))) + ;; Put quotes around verbatim text + (goto-char (point-min)) + (while (re-search-forward org-verbatim-re nil t) + (org-if-unprotected-at (match-beginning 4) + (goto-char (match-end 2)) + (backward-delete-char 1) (insert "'") + (goto-char (match-beginning 2)) + (delete-char 1) (insert "`") + (goto-char (match-end 2)))) + ;; Remove target markers + (goto-char (point-min)) + (while (re-search-forward "<<<?\\([^<>]*\\)>>>?\\([ \t]*\\)" nil t) + (org-if-unprotected-at (match-beginning 1) + (replace-match "\\1\\2"))) + ;; Remove list start counters + (goto-char (point-min)) + (while (org-search-forward-unenclosed + "\\[@\\(?:start:\\)?[0-9]+\\][ \t]*" nil t) + (replace-match "")) + (remove-text-properties + (point-min) (point-max) + '(face nil font-lock-fontified nil font-lock-multiline nil line-prefix nil wrap-prefix nil))) + +(defun org-html-expand-for-ascii (line) + "Handle quoted HTML for ASCII export." + (if org-export-html-expand + (while (string-match "@<[^<>\n]*>" line) + ;; We just remove the tags for now. + (setq line (replace-match "" nil nil line)))) + line) + +(defun org-ascii-replace-entities () + "Replace entities with the ASCII representation." + (let (e) + (while (re-search-forward "\\\\\\([a-zA-Z]+[0-9]*\\)\\({}\\)?" nil t) + (org-if-unprotected-at (match-beginning 1) + (setq e (org-entity-get-representation (match-string 1) + org-export-ascii-entities)) + (and e (replace-match e t t)))))) + +(defun org-export-ascii-wrap (line where) + "Wrap LINE at or before WHERE." + (let ((ind (org-get-indentation line)) + pos) + (catch 'found + (loop for i from where downto (/ where 2) do + (and (equal (aref line i) ?\ ) + (setq pos i) + (throw 'found t)))) + (if pos + (concat (substring line 0 pos) "\n" + (make-string ind ?\ ) + (substring line (1+ pos))) + line))) + +(defun org-export-ascii-push-links (link-buffer) + "Push out links in the buffer." + (when link-buffer + ;; We still have links to push out. + (insert "\n") + (let ((ind "")) + (save-match-data + (if (save-excursion + (re-search-backward + "^\\(\\([ \t]*\\)\\|\\(\\*+ \\)\\)[^ \t\n]" nil t)) + (setq ind (or (match-string 2) + (make-string (length (match-string 3)) ?\ ))))) + (mapc (lambda (x) (insert ind "[" (car x) "]: " (cdr x) "\n")) + link-buffer)) + (insert "\n"))) + +(defun org-ascii-level-start (level title umax &optional lines) + "Insert a new level in ASCII export." + (let (char (n (- level umax 1)) (ind 0)) + (if (> level umax) + (progn + (insert (make-string (* 2 n) ?\ ) + (char-to-string (nth (% n (length org-export-ascii-bullets)) + org-export-ascii-bullets)) + " " title "\n") + ;; find the indentation of the next non-empty line + (catch 'stop + (while lines + (if (string-match "^\\* " (car lines)) (throw 'stop nil)) + (if (string-match "^\\([ \t]*\\)\\S-" (car lines)) + (throw 'stop (setq ind (org-get-indentation (car lines))))) + (pop lines))) + (setq org-ascii-current-indentation (cons (* 2 (1+ n)) ind))) + (if (or (not (equal (char-before) ?\n)) + (not (equal (char-before (1- (point))) ?\n))) + (insert "\n")) + (setq char (nth (- umax level) (reverse org-export-ascii-underline))) + (unless org-export-with-tags + (if (string-match (org-re "[ \t]+\\(:[[:alnum:]_@#%:]+:\\)[ \t]*$") title) + (setq title (replace-match "" t t title)))) + (if org-export-with-section-numbers + (setq title (concat (org-section-number level) " " title))) + (insert title "\n" (make-string (string-width title) char) "\n") + (setq org-ascii-current-indentation '(0 . 0))))) + +(defun org-insert-centered (s &optional underline) + "Insert the string S centered and underline it with character UNDERLINE." + (let ((ind (max (/ (- fill-column (string-width s)) 2) 0))) + (insert (make-string ind ?\ ) s "\n") + (if underline + (insert (make-string ind ?\ ) + (make-string (string-width s) underline) + "\n")))) + +(defvar org-table-colgroup-info nil) +(defun org-format-table-ascii (lines) + "Format a table for ascii export." + (if (stringp lines) + (setq lines (org-split-string lines "\n"))) + (if (not (string-match "^[ \t]*|" (car lines))) + ;; Table made by table.el - test for spanning + lines + + ;; A normal org table + ;; Get rid of hlines at beginning and end + (if (string-match "^[ \t]*|-" (car lines)) (setq lines (cdr lines))) + (setq lines (nreverse lines)) + (if (string-match "^[ \t]*|-" (car lines)) (setq lines (cdr lines))) + (setq lines (nreverse lines)) + (when org-export-table-remove-special-lines + ;; Check if the table has a marking column. If yes remove the + ;; column and the special lines + (setq lines (org-table-clean-before-export lines))) + ;; Get rid of the vertical lines except for grouping + (if org-export-ascii-table-keep-all-vertical-lines + lines + (let ((vl (org-colgroup-info-to-vline-list org-table-colgroup-info)) + rtn line vl1 start) + (while (setq line (pop lines)) + (if (string-match org-table-hline-regexp line) + (and (string-match "|\\(.*\\)|" line) + (setq line (replace-match " \\1" t nil line))) + (setq start 0 vl1 vl) + (while (string-match "|" line start) + (setq start (match-end 0)) + (or (pop vl1) (setq line (replace-match " " t t line))))) + (push line rtn)) + (nreverse rtn))))) + +(defun org-colgroup-info-to-vline-list (info) + (let (vl new last) + (while info + (setq last new new (pop info)) + (if (or (memq last '(:end :startend)) + (memq new '(:start :startend))) + (push t vl) + (push nil vl))) + (setq vl (nreverse vl)) + (and vl (setcar vl nil)) + vl)) + +(provide 'org-ascii) + +;; arch-tag: aa96f882-f477-4e13-86f5-70d43e7adf3c +;;; org-ascii.el ends here diff --git a/.emacs.d/org-7.4/lisp/org-ascii.elc b/.emacs.d/org-7.4/lisp/org-ascii.elc Binary files differnew file mode 100644 index 0000000..3aa6a15 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-ascii.elc diff --git a/.emacs.d/org-7.4/lisp/org-attach.el b/.emacs.d/org-7.4/lisp/org-attach.el new file mode 100644 index 0000000..a894064 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-attach.el @@ -0,0 +1,422 @@ +;;; org-attach.el --- Manage file attachments to org-mode tasks + +;; Copyright (C) 2008, 2009, 2010 Free Software Foundation, Inc. + +;; Author: John Wiegley <johnw@newartisans.com> +;; Keywords: org data task +;; Version: 7.4 + +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; See the Org-mode manual for information on how to use it. +;; +;; Attachments are managed in a special directory called "data", which +;; lives in the same directory as the org file itself. If this data +;; directory is initialized as a Git repository, then org-attach will +;; automatically commit changes when it sees them. +;; +;; Attachment directories are identified using a UUID generated for the +;; task which has the attachments. These are added as property to the +;; task when necessary, and should not be deleted or changed by the +;; user, ever. UUIDs are generated by a mechanism defined in the variable +;; `org-id-method'. + +;;; Code: + +(eval-when-compile + (require 'cl)) +(require 'org-id) +(require 'org) + +(defgroup org-attach nil + "Options concerning entry attachments in Org-mode." + :tag "Org Attach" + :group 'org) + +(defcustom org-attach-directory "data/" + "The directory where attachments are stored. +If this is a relative path, it will be interpreted relative to the directory +where the Org file lives." + :group 'org-attach + :type 'directory) + +(defcustom org-attach-auto-tag "ATTACH" + "Tag that will be triggered automatically when an entry has an attachment." + :group 'org-attach + :type '(choice + (const :tag "None" nil) + (string :tag "Tag"))) + +(defcustom org-attach-file-list-property "Attachments" + "The property used to keep a list of attachment belonging to this entry. +This is not really needed, so you may set this to nil if you don't want it. +Also, for entries where children inherit the directory, the list of +attachments is not kept in this property." + :group 'org-attach + :type '(choice + (const :tag "None" nil) + (string :tag "Tag"))) + +(defcustom org-attach-method 'cp + "The preferred method to attach a file. +Allowed values are: + +mv rename the file to move it into the attachment directory +cp copy the file +ln create a hard link. Note that this is not supported + on all systems, and then the result is not defined." + :group 'org-attach + :type '(choice + (const :tag "Copy" cp) + (const :tag "Move/Rename" mv) + (const :tag "Link" ln))) + +(defcustom org-attach-expert nil + "Non-nil means do not show the splash buffer with the attach dispatcher." + :group 'org-attach + :type 'boolean) + +(defcustom org-attach-allow-inheritance t + "Non-nil means allow attachment directories be inherited." + :group 'org-attach + :type 'boolean) + + +(defvar org-attach-inherited nil + "Indicates if the last access to the attachment directory was inherited.") + +;;;###autoload +(defun org-attach () + "The dispatcher for attachment commands. +Shows a list of commands and prompts for another key to execute a command." + (interactive) + (let (c marker) + (when (eq major-mode 'org-agenda-mode) + (setq marker (or (get-text-property (point) 'org-hd-marker) + (get-text-property (point) 'org-marker))) + (unless marker + (error "No task in current line"))) + (save-excursion + (when marker + (set-buffer (marker-buffer marker)) + (goto-char marker)) + (org-back-to-heading t) + (save-excursion + (save-window-excursion + (unless org-attach-expert + (with-output-to-temp-buffer "*Org Attach*" + (princ "Select an Attachment Command: + +a Select a file and attach it to the task, using `org-attach-method'. +c/m/l Attach a file using copy/move/link method. +n Create a new attachment, as an Emacs buffer. +z Synchronize the current task with its attachment + directory, in case you added attachments yourself. + +o Open current task's attachments. +O Like \"o\", but force opening in Emacs. +f Open current task's attachment directory. +F Like \"f\", but force using dired in Emacs. + +d Delete one attachment, you will be prompted for a file name. +D Delete all of a task's attachments. A safer way is + to open the directory in dired and delete from there. + +s Set a specific attachment directory for this entry. +i Make children of the current entry inherit its attachment directory."))) + (org-fit-window-to-buffer (get-buffer-window "*Org Attach*")) + (message "Select command: [acmlzoOfFdD]") + (setq c (read-char-exclusive)) + (and (get-buffer "*Org Attach*") (kill-buffer "*Org Attach*")))) + (cond + ((memq c '(?a ?\C-a)) (call-interactively 'org-attach-attach)) + ((memq c '(?c ?\C-c)) + (let ((org-attach-method 'cp)) (call-interactively 'org-attach-attach))) + ((memq c '(?m ?\C-m)) + (let ((org-attach-method 'mv)) (call-interactively 'org-attach-attach))) + ((memq c '(?l ?\C-l)) + (let ((org-attach-method 'ln)) (call-interactively 'org-attach-attach))) + ((memq c '(?n ?\C-n)) (call-interactively 'org-attach-new)) + ((memq c '(?z ?\C-z)) (call-interactively 'org-attach-sync)) + ((memq c '(?o ?\C-o)) (call-interactively 'org-attach-open)) + ((eq c ?O) (call-interactively 'org-attach-open-in-emacs)) + ((memq c '(?f ?\C-f)) (call-interactively 'org-attach-reveal)) + ((memq c '(?F)) (call-interactively 'org-attach-reveal-in-emacs)) + ((memq c '(?d ?\C-d)) (call-interactively + 'org-attach-delete-one)) + ((eq c ?D) (call-interactively 'org-attach-delete-all)) + ((eq c ?q) (message "Abort")) + ((memq c '(?s ?\C-s)) (call-interactively + 'org-attach-set-directory)) + ((memq c '(?i ?\C-i)) (call-interactively + 'org-attach-set-inherit)) + (t (error "No such attachment command %c" c)))))) + +(defun org-attach-dir (&optional create-if-not-exists-p) + "Return the directory associated with the current entry. +This first checks for a local property ATTACH_DIR, and then for an inherited +property ATTACH_DIR_INHERIT. If neither exists, the default mechanism +using the entry ID will be invoked to access the unique directory for the +current entry. +If the directory does not exist and CREATE-IF-NOT-EXISTS-P is non-nil, +the directory and (if necessary) the corresponding ID will be created." + (let (attach-dir uuid inherit) + (setq org-attach-inherited (org-entry-get nil "ATTACH_DIR_INHERIT")) + (cond + ((setq attach-dir (org-entry-get nil "ATTACH_DIR")) + (org-attach-check-absolute-path attach-dir)) + ((and org-attach-allow-inheritance + (setq inherit (org-entry-get nil "ATTACH_DIR_INHERIT" t))) + (setq attach-dir + (save-excursion + (save-restriction + (widen) + (goto-char org-entry-property-inherited-from) + (let (org-attach-allow-inheritance) + (org-attach-dir create-if-not-exists-p))))) + (org-attach-check-absolute-path attach-dir) + (setq org-attach-inherited t)) + (t ; use the ID + (org-attach-check-absolute-path nil) + (setq uuid (org-id-get (point) create-if-not-exists-p)) + (when (or uuid create-if-not-exists-p) + (unless uuid (error "ID retrieval/creation failed")) + (setq attach-dir (expand-file-name + (format "%s/%s" + (substring uuid 0 2) + (substring uuid 2)) + (expand-file-name org-attach-directory)))))) + (when attach-dir + (if (and create-if-not-exists-p + (not (file-directory-p attach-dir))) + (make-directory attach-dir t)) + (and (file-exists-p attach-dir) + attach-dir)))) + +(defun org-attach-check-absolute-path (dir) + "Check if we have enough information to root the attachment directory. +When DIR is given, check also if it is already absolute. Otherwise, +assume that it will be relative, and check if `org-attach-directory' is +absolute, or if at least the current buffer has a file name. +Throw an error if we cannot root the directory." + (or (and dir (file-name-absolute-p dir)) + (file-name-absolute-p org-attach-directory) + (buffer-file-name (buffer-base-buffer)) + (error "Need absolute `org-attach-directory' to attach in buffers without filename"))) + +(defun org-attach-set-directory () + "Set the ATTACH_DIR property of the current entry. +The property defines the directory that is used for attachments +of the entry." + (interactive) + (let ((dir (org-entry-get nil "ATTACH_DIR"))) + (setq dir (read-directory-name "Attachment directory: " dir)) + (org-entry-put nil "ATTACH_DIR" dir))) + +(defun org-attach-set-inherit () + "Set the ATTACH_DIR_INHERIT property of the current entry. +The property defines the directory that is used for attachments +of the entry and any children that do not explicitly define (by setting +the ATTACH_DIR property) their own attachment directory." + (interactive) + (org-entry-put nil "ATTACH_DIR_INHERIT" "t") + (message "Children will inherit attachment directory")) + +(defun org-attach-commit () + "Commit changes to git if `org-attach-directory' is properly initialized. +This checks for the existence of a \".git\" directory in that directory." + (let ((dir (expand-file-name org-attach-directory))) + (when (file-exists-p (expand-file-name ".git" dir)) + (with-temp-buffer + (cd dir) + (shell-command "git add .") + (shell-command "git ls-files --deleted" t) + (mapc '(lambda (file) + (unless (string= file "") + (shell-command + (concat "git rm \"" file "\"")))) + (split-string (buffer-string) "\n")) + (shell-command "git commit -m 'Synchronized attachments'"))))) + +(defun org-attach-tag (&optional off) + "Turn the autotag on or (if OFF is set) off." + (when org-attach-auto-tag + (save-excursion + (org-back-to-heading t) + (org-toggle-tag org-attach-auto-tag (if off 'off 'on))))) + +(defun org-attach-untag () + "Turn the autotag off." + (org-attach-tag 'off)) + +(defun org-attach-attach (file &optional visit-dir method) + "Move/copy/link FILE into the attachment directory of the current task. +If VISIT-DIR is non-nil, visit the directory with dired. +METHOD may be `cp', `mv', or `ln', default taken from `org-attach-method'." + (interactive "fFile to keep as an attachment: \nP") + (setq method (or method org-attach-method)) + (let ((basename (file-name-nondirectory file))) + (when (and org-attach-file-list-property (not org-attach-inherited)) + (org-entry-add-to-multivalued-property + (point) org-attach-file-list-property basename)) + (let* ((attach-dir (org-attach-dir t)) + (fname (expand-file-name basename attach-dir))) + (cond + ((eq method 'mv) (rename-file file fname)) + ((eq method 'cp) (copy-file file fname)) + ((eq method 'ln) (add-name-to-file file fname))) + (org-attach-commit) + (org-attach-tag) + (if visit-dir + (dired attach-dir) + (message "File \"%s\" is now a task attachment." basename))))) + +(defun org-attach-attach-cp () + "Attach a file by copying it." + (interactive) + (let ((org-attach-method 'cp)) (call-interactively 'org-attach-attach))) +(defun org-attach-attach-mv () + "Attach a file by moving (renaming) it." + (interactive) + (let ((org-attach-method 'mv)) (call-interactively 'org-attach-attach))) +(defun org-attach-attach-ln () + "Attach a file by creating a hard link to it. +Beware that this does not work on systems that do not support hard links. +On some systems, this apparently does copy the file instead." + (interactive) + (let ((org-attach-method 'ln)) (call-interactively 'org-attach-attach))) + +(defun org-attach-new (file) + "Create a new attachment FILE for the current task. +The attachment is created as an Emacs buffer." + (interactive "sCreate attachment named: ") + (when (and org-attach-file-list-property (not org-attach-inherited)) + (org-entry-add-to-multivalued-property + (point) org-attach-file-list-property file)) + (let ((attach-dir (org-attach-dir t))) + (org-attach-tag) + (find-file (expand-file-name file attach-dir)) + (message "New attachment %s" file))) + +(defun org-attach-delete-one (&optional file) + "Delete a single attachment." + (interactive) + (let* ((attach-dir (org-attach-dir t)) + (files (org-attach-file-list attach-dir)) + (file (or file + (org-icompleting-read + "Delete attachment: " + (mapcar (lambda (f) + (list (file-name-nondirectory f))) + files))))) + (setq file (expand-file-name file attach-dir)) + (unless (file-exists-p file) + (error "No such attachment: %s" file)) + (delete-file file) + (org-attach-commit))) + +(defun org-attach-delete-all (&optional force) + "Delete all attachments from the current task. +This actually deletes the entire attachment directory. +A safer way is to open the directory in dired and delete from there." + (interactive "P") + (when (and org-attach-file-list-property (not org-attach-inherited)) + (org-entry-delete (point) org-attach-file-list-property)) + (let ((attach-dir (org-attach-dir))) + (when + (and attach-dir + (or force + (y-or-n-p "Are you sure you want to remove all attachments of this entry? "))) + (shell-command (format "rm -fr %s" attach-dir)) + (message "Attachment directory removed") + (org-attach-commit) + (org-attach-untag)))) + +(defun org-attach-sync () + "Synchronize the current tasks with its attachments. +This can be used after files have been added externally." + (interactive) + (org-attach-commit) + (when (and org-attach-file-list-property (not org-attach-inherited)) + (org-entry-delete (point) org-attach-file-list-property)) + (let ((attach-dir (org-attach-dir))) + (when attach-dir + (let ((files (org-attach-file-list attach-dir))) + (and files (org-attach-tag)) + (when org-attach-file-list-property + (dolist (file files) + (unless (string-match "^\\." file) + (org-entry-add-to-multivalued-property + (point) org-attach-file-list-property file)))))))) + +(defun org-attach-file-list (dir) + "Return a list of files in the attachment directory. +This ignores files starting with a \".\", and files ending in \"~\"." + (delq nil + (mapcar (lambda (x) (if (string-match "^\\." x) nil x)) + (directory-files dir nil "[^~]\\'")))) + +(defun org-attach-reveal (&optional if-exists) + "Show the attachment directory of the current task in dired." + (interactive "P") + (let ((attach-dir (org-attach-dir (not if-exists)))) + (and attach-dir (org-open-file attach-dir)))) + +(defun org-attach-reveal-in-emacs () + "Show the attachment directory of the current task. +This will attempt to use an external program to show the directory." + (interactive) + (let ((attach-dir (org-attach-dir t))) + (dired attach-dir))) + +(defun org-attach-open (&optional in-emacs) + "Open an attachment of the current task. +If there are more than one attachment, you will be prompted for the file name. +This command will open the file using the settings in `org-file-apps' +and in the system-specific variants of this variable. +If IN-EMACS is non-nil, force opening in Emacs." + (interactive "P") + (let* ((attach-dir (org-attach-dir t)) + (files (org-attach-file-list attach-dir)) + (file (if (= (length files) 1) + (car files) + (org-icompleting-read "Open attachment: " + (mapcar 'list files) nil t)))) + (org-open-file (expand-file-name file attach-dir) in-emacs))) + +(defun org-attach-open-in-emacs () + "Open attachment, force opening in Emacs. +See `org-attach-open'." + (interactive) + (org-attach-open 'in-emacs)) + +(defun org-attach-expand (file) + "Return the full path to the current entry's attachment file FILE. +Basically, this adds the path to the attachment directory." + (expand-file-name file (org-attach-dir))) + +(defun org-attach-expand-link (file) + "Return a file link pointing to the current entry's attachment file FILE. +Basically, this adds the path to the attachment directory, and a \"file:\" +prefix." + (concat "file:" (org-attach-expand file))) + +(provide 'org-attach) + +;; arch-tag: fce93c2e-fe07-4fa3-a905-e10dcc7a6248 +;;; org-attach.el ends here diff --git a/.emacs.d/org-7.4/lisp/org-attach.elc b/.emacs.d/org-7.4/lisp/org-attach.elc Binary files differnew file mode 100644 index 0000000..baee093 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-attach.elc diff --git a/.emacs.d/org-7.4/lisp/org-bbdb.el b/.emacs.d/org-7.4/lisp/org-bbdb.el new file mode 100644 index 0000000..4155f58 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-bbdb.el @@ -0,0 +1,386 @@ +;;; org-bbdb.el --- Support for links to BBDB entries from within Org-mode + +;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010 +;; Free Software Foundation, Inc. + +;; Author: Carsten Dominik <carsten at orgmode dot org>, +;; Thomas Baumann <thomas dot baumann at ch dot tum dot de> +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; Version: 7.4 +;; +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: + +;; This file implements links to BBDB database entries from within Org-mode. +;; Org-mode loads this module by default - if this is not what you want, +;; configure the variable `org-modules'. + +;; It also implements an interface (based on Ivar Rummelhoff's +;; bbdb-anniv.el) for those org-mode users, who do not use the diary +;; but who do want to include the anniversaries stored in the BBDB +;; into the org-agenda. If you already include the `diary' into the +;; agenda, you might want to prefer to include the anniversaries in +;; the diary using bbdb-anniv.el. +;; +;; Put the following in /somewhere/at/home/diary.org and make sure +;; that this file is in `org-agenda-files` +;; +;; %%(org-bbdb-anniversaries) +;; +;; For example my diary.org looks like: +;; * Anniversaries +;; #+CATEGORY: Anniv +;; %%(org-bbdb-anniversaries) +;; +;; +;; To add an anniversary to a BBDB record, press `C-o' in the record. +;; You will be prompted for the field name, in this case it must be +;; "anniversary". If this is the first time you are using this field, +;; you need to confirm that it should be created. +;; +;; The format of an anniversary field stored in BBDB is the following +;; (items in {} are optional): +;; +;; YYYY-MM-DD{ CLASS-OR-FORMAT-STRING} +;; {\nYYYY-MM-DD CLASS-OR-FORMAT-STRING}... +;; +;; CLASS-OR-FORMAT-STRING is one of two things: +;; +;; - an identifier for a class of anniversaries (eg. birthday or +;; wedding) from `org-bbdb-anniversary-format-alist' which then +;; defines the format string for this class +;; - the (format) string displayed in the diary. +;; +;; You can enter multiple anniversaries for a single BBDB record by +;; separating them with a newline character. At the BBDB prompt for +;; the field value, type `C-q C-j' to enter a newline between two +;; anniversaries. +;; +;; If you omit the CLASS-OR-FORMAT-STRING entirely, it defaults to the +;; value of `org-bbdb-default-anniversary-format' ("birthday" by +;; default). +;; +;; The substitutions in the format string are (in order): +;; - the name of the record containing this anniversary +;; - the number of years +;; - an ordinal suffix (st, nd, rd, th) for the year +;; +;; See the documentation of `org-bbdb-anniversary-format-alist' for +;; further options. +;; +;; Example +;; +;; 1973-06-22 +;; 20??-??-?? wedding +;; 1998-03-12 %s created bbdb-anniv.el %d years ago +;; +;; From Org's agenda, you can use `C-c C-o' to jump to the BBDB +;; link from which the entry at point originates. +;; +;;; Code: + +(require 'org) +(eval-when-compile + (require 'cl)) + +;; Declare external functions and variables + +(declare-function bbdb "ext:bbdb-com" (string elidep)) +(declare-function bbdb-company "ext:bbdb-com" (string elidep)) +(declare-function bbdb-current-record "ext:bbdb-com" + (&optional planning-on-modifying)) +(declare-function bbdb-name "ext:bbdb-com" (string elidep)) +(declare-function bbdb-completing-read-record "ext:bbdb-com" + (prompt &optional omit-records)) +(declare-function bbdb-record-getprop "ext:bbdb" (record property)) +(declare-function bbdb-record-name "ext:bbdb" (record)) +(declare-function bbdb-records "ext:bbdb" + (&optional dont-check-disk already-in-db-buffer)) +(declare-function bbdb-split "ext:bbdb" (string separators)) +(declare-function bbdb-string-trim "ext:bbdb" (string)) + +(declare-function calendar-leap-year-p "calendar" (year)) +(declare-function diary-ordinal-suffix "diary-lib" (n)) + +(defvar date) ;; dynamically scoped from Org + +;; Customization + +(defgroup org-bbdb-anniversaries nil + "Customizations for including anniversaries from BBDB into Agenda." + :group 'org-bbdb) + +(defcustom org-bbdb-default-anniversary-format "birthday" + "Default anniversary class." + :type 'string + :group 'org-bbdb-anniversaries + :require 'bbdb) + +(defcustom org-bbdb-anniversary-format-alist + '(("birthday" lambda + (name years suffix) + (concat "Birthday: [[bbdb:" name "][" name " (" + (number-to-string years) + suffix ")]]")) + ("wedding" lambda + (name years suffix) + (concat "[[bbdb:" name "][" name "'s " + (number-to-string years) + suffix " wedding anniversary]]"))) + "How different types of anniversaries should be formatted. +An alist of elements (STRING . FORMAT) where STRING is the name of an +anniversary class and format is either: +1) A format string with the following substitutions (in order): + * the name of the record containing this anniversary + * the number of years + * an ordinal suffix (st, nd, rd, th) for the year + +2) A function to be called with three arguments: NAME YEARS SUFFIX + (string int string) returning a string for the diary or nil. + +3) An Emacs Lisp form that should evaluate to a string (or nil) in the + scope of variables NAME, YEARS and SUFFIX (among others)." + :type 'sexp + :group 'org-bbdb-anniversaries + :require 'bbdb) + +(defcustom org-bbdb-anniversary-field 'anniversary + "The BBDB field which contains anniversaries. +The anniversaries are stored in the following format + +YYYY-MM-DD Class-or-Format-String + +where class is one of the customized classes for anniversaries; +birthday and wedding are predefined. Format-String can take three +substitutions 1) the name of the record containing this +anniversary, 2) the number of years, and 3) an ordinal suffix for +the year. + +Multiple anniversaries can be separated by \\n." + :type 'symbol + :group 'org-bbdb-anniversaries + :require 'bbdb) + +(defcustom org-bbdb-extract-date-fun 'org-bbdb-anniv-extract-date + "How to retrieve `month date year' from the anniversary field. + +Customize if you have already filled your BBDB with dates +different from YYYY-MM-DD. The function must return a list (month +date year)." + :type 'function + :group 'org-bbdb-anniversaries + :require 'bbdb) + + +;; Install the link type +(org-add-link-type "bbdb" 'org-bbdb-open 'org-bbdb-export) +(add-hook 'org-store-link-functions 'org-bbdb-store-link) + +;; Implementation +(defun org-bbdb-store-link () + "Store a link to a BBDB database entry." + (when (eq major-mode 'bbdb-mode) + ;; This is BBDB, we make this link! + (let* ((name (bbdb-record-name (bbdb-current-record))) + (company (bbdb-record-getprop (bbdb-current-record) 'company)) + (link (org-make-link "bbdb:" name))) + (org-store-link-props :type "bbdb" :name name :company company + :link link :description name) + link))) + +(defun org-bbdb-export (path desc format) + "Create the export version of a BBDB link specified by PATH or DESC. +If exporting to either HTML or LaTeX FORMAT the link will be +italicized, in all other cases it is left unchanged." + (cond + ((eq format 'html) (format "<i>%s</i>" (or desc path))) + ((eq format 'latex) (format "\\textit{%s}" (or desc path))) + (t (or desc path)))) + +(defun org-bbdb-open (name) + "Follow a BBDB link to NAME." + (require 'bbdb) + (let ((inhibit-redisplay (not debug-on-error)) + (bbdb-electric-p nil)) + (catch 'exit + ;; Exact match on name + (bbdb-name (concat "\\`" name "\\'") nil) + (if (< 0 (buffer-size (get-buffer "*BBDB*"))) (throw 'exit nil)) + ;; Exact match on name + (bbdb-company (concat "\\`" name "\\'") nil) + (if (< 0 (buffer-size (get-buffer "*BBDB*"))) (throw 'exit nil)) + ;; Partial match on name + (bbdb-name name nil) + (if (< 0 (buffer-size (get-buffer "*BBDB*"))) (throw 'exit nil)) + ;; Partial match on company + (bbdb-company name nil) + (if (< 0 (buffer-size (get-buffer "*BBDB*"))) (throw 'exit nil)) + ;; General match including network address and notes + (bbdb name nil) + (when (= 0 (buffer-size (get-buffer "*BBDB*"))) + (delete-window (get-buffer-window "*BBDB*")) + (error "No matching BBDB record"))))) + +(defun org-bbdb-anniv-extract-date (time-str) + "Convert YYYY-MM-DD to (month date year). +Argument TIME-STR is the value retrieved from BBDB." + (multiple-value-bind (y m d) (values-list (bbdb-split time-str "-")) + (list (string-to-number m) + (string-to-number d) + (string-to-number y)))) + +(defun org-bbdb-anniv-split (str) + "Split multiple entries in the BBDB anniversary field. +Argument STR is the anniversary field in BBDB." + (let ((pos (string-match "[ \t]" str))) + (if pos (list (substring str 0 pos) + (bbdb-string-trim (substring str pos))) + (list str nil)))) + +(defvar org-bbdb-anniv-hash nil + "A hash holding anniversaries extracted from BBDB. +The hash table is created on first use.") + +(defvar org-bbdb-updated-p t + "This is non-nil if BBDB has been updated since we last built the hash.") + +(defun org-bbdb-make-anniv-hash () + "Create a hash with anniversaries extracted from BBDB, for fast access. +The anniversaries are assumed to be stored `org-bbdb-anniversary-field'." + + (let (split tmp annivs) + (clrhash org-bbdb-anniv-hash) + (dolist (rec (bbdb-records)) + (when (setq annivs (bbdb-record-getprop + rec org-bbdb-anniversary-field)) + (setq annivs (bbdb-split annivs "\n")) + (while annivs + (setq split (org-bbdb-anniv-split (pop annivs))) + (multiple-value-bind (m d y) + (values-list (funcall org-bbdb-extract-date-fun (car split))) + (setq tmp (gethash (list m d) org-bbdb-anniv-hash)) + (puthash (list m d) (cons (list y + (bbdb-record-name rec) + (cadr split)) + tmp) + org-bbdb-anniv-hash)))))) + (setq org-bbdb-updated-p nil)) + +(defun org-bbdb-updated (rec) + "Record the fact that BBDB has been updated. +This is used by Org to re-create the anniversary hash table." + (setq org-bbdb-updated-p t)) + +(add-hook 'bbdb-after-change-hook 'org-bbdb-updated) + +;;;###autoload +(defun org-bbdb-anniversaries() + "Extract anniversaries from BBDB for display in the agenda." + (require 'bbdb) + (require 'diary-lib) + (unless (hash-table-p org-bbdb-anniv-hash) + (setq org-bbdb-anniv-hash + (make-hash-table :test 'equal :size 366))) + + (when (or org-bbdb-updated-p + (= 0 (hash-table-count org-bbdb-anniv-hash))) + (org-bbdb-make-anniv-hash)) + + (let* ((m (car date)) ; month + (d (nth 1 date)) ; day + (y (nth 2 date)) ; year + (annivs (gethash (list m d) org-bbdb-anniv-hash)) + (text ()) + rec recs) + + ;; we don't want to miss people born on Feb. 29th + (when (and (= m 3) (= d 1) + (not (null (gethash (list 2 29) org-bbdb-anniv-hash))) + (not (calendar-leap-year-p y))) + (setq recs (gethash (list 2 29) org-bbdb-anniv-hash)) + (while (setq rec (pop recs)) + (push rec annivs))) + + (when annivs + (while (setq rec (pop annivs)) + (when rec + (let* ((class (or (nth 2 rec) + org-bbdb-default-anniversary-format)) + (form (or (cdr (assoc-string + class org-bbdb-anniversary-format-alist t)) + class)) ; (as format string) + (name (nth 1 rec)) + (years (- y (car rec))) + (suffix (diary-ordinal-suffix years)) + (tmp (cond + ((functionp form) + (funcall form name years suffix)) + ((listp form) (eval form)) + (t (format form name years suffix))))) + (org-add-props tmp nil 'org-bbdb-name name) + (if text + (setq text (append text (list tmp))) + (setq text (list tmp))))) + )) + text)) + +(defun org-bbdb-complete-link () + "Read a bbdb link with name completion." + (require 'bbdb-com) + (concat "bbdb:" + (bbdb-record-name (car (bbdb-completing-read-record "Name: "))))) + +(defun org-bbdb-anniv-export-ical () + "Extract anniversaries from BBDB and convert them to icalendar format." + (require 'bbdb) + (require 'diary-lib) + (unless (hash-table-p org-bbdb-anniv-hash) + (setq org-bbdb-anniv-hash + (make-hash-table :test 'equal :size 366))) + (when (or org-bbdb-updated-p + (= 0 (hash-table-count org-bbdb-anniv-hash))) + (org-bbdb-make-anniv-hash)) + (maphash 'org-bbdb-format-vevent org-bbdb-anniv-hash)) + +(defun org-bbdb-format-vevent (key recs) + (let (rec categ) + (while (setq rec (pop recs)) + (setq categ (or (nth 2 rec) org-bbdb-default-anniversary-format)) + (princ (format "BEGIN:VEVENT +UID: ANNIV-%4i%02i%02i-%s +DTSTART:%4i%02i%02i +SUMMARY:%s +DESCRIPTION:%s +CATEGORIES:%s +RRULE:FREQ=YEARLY +END:VEVENT\n" + (nth 0 rec) (nth 0 key) (nth 1 key) + (mapconcat 'identity + (org-split-string (nth 1 rec) "[^a-zA-Z0-90]+") + "-") + (nth 0 rec) (nth 0 key) (nth 1 key) + (nth 1 rec) + (concat (capitalize categ) " " (nth 1 rec)) + categ))))) + +(provide 'org-bbdb) + +;; arch-tag: 9e4f275d-d080-48c1-b040-62247f66b5c2 + +;;; org-bbdb.el ends here diff --git a/.emacs.d/org-7.4/lisp/org-bbdb.elc b/.emacs.d/org-7.4/lisp/org-bbdb.elc Binary files differnew file mode 100644 index 0000000..e270d9c --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-bbdb.elc diff --git a/.emacs.d/org-7.4/lisp/org-beamer.el b/.emacs.d/org-7.4/lisp/org-beamer.el new file mode 100644 index 0000000..c88df85 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-beamer.el @@ -0,0 +1,636 @@ +;;; org-beamer.el --- Beamer-specific LaTeX export for org-mode +;; +;; Copyright (C) 2007, 2008, 2009, 2010 Free Software Foundation, Inc. +;; +;; Version: 7.4 +;; Author: Carsten Dominik <carsten.dominik AT gmail DOT com> +;; Maintainer: Carsten Dominik <carsten.dominik AT gmail DOT com> +;; Keywords: org, wp, tex + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; This library implement the special treatment needed by using the +;; beamer class during LaTeX export. + +;;; Code: + +(require 'org) +(require 'org-exp) + +(defvar org-export-latex-header) +(defvar org-export-latex-options-plist) +(defvar org-export-opt-plist) + +(defgroup org-beamer nil + "Options specific for using the beamer class in LaTeX export." + :tag "Org Beamer" + :group 'org-export-latex) + +(defcustom org-beamer-use-parts nil + "" + :group 'org-beamer + :type 'boolean) + +(defcustom org-beamer-frame-level 1 + "The level that should be interpreted as a frame. +The levels above this one will be translated into a sectioning structure. +Setting this to 2 will allow sections, 3 will allow subsections as well. +You can set this to 4 as well, if you at the same time set +`org-beamer-use-parts' to make the top levels `\part'." + :group 'org-beamer + :type '(choice + (const :tag "Frames need a BEAMER_env property" nil) + (integer :tag "Specific level makes a frame"))) + +(defcustom org-beamer-frame-default-options "" + "Default options string to use for frames, should contains the [brackets]. +And example for this is \"[allowframebreaks]\"." + :group 'org-beamer + :type '(string :tag "[options]")) + +(defcustom org-beamer-column-view-format + "%45ITEM %10BEAMER_env(Env) %10BEAMER_envargs(Env Args) %4BEAMER_col(Col) %8BEAMER_extra(Extra)" + "Default column view format that should be used to fill the template." + :group 'org-beamer + :type '(choice + (const :tag "Do not insert Beamer column view format" nil) + (string :tag "Beamer column view format"))) + +(defcustom org-beamer-themes + "\\usetheme{default}\\usecolortheme{default}" + "Default string to be used for extra heading stuff in beamer presentations. +When a beamer template is filled, this will be the default for +BEAMER_HEADER_EXTRA, which will be inserted just before \\begin{document}." + :group 'org-beamer + :type '(choice + (const :tag "Do not insert Beamer themes" nil) + (string :tag "Beamer themes"))) + +(defconst org-beamer-column-widths + "0.1 0.2 0.3 0.4 0.5 0.6 0.7 0.8 0.9 0.0 :ETC" +"The column widths that should be installed as allowed property values.") + +(defconst org-beamer-transitions + "\transblindsvertical \transblindshorizontal \transboxin \transboxout \transdissolve \transduration \transglitter \transsplithorizontalin \transsplithorizontalout \transsplitverticalin \transsplitverticalout \transwipe :ETC" + "Transitions available for beamer. +These are just a completion help.") + +(defconst org-beamer-environments-default + '(("frame" "f" "dummy- special handling hard coded" "dummy") + ("columns" "C" "\\begin{columns}%o %% %h%x" "\\end{columns}") + ("column" "c" "\\begin{column}%o{%h\\textwidth}%x" "\\end{column}") + ("block" "b" "\\begin{block}%a{%h}%x" "\\end{block}") + ("alertblock" "a" "\\begin{alertblock}%a{%h}%x" "\\end{alertblock}") + ("verse" "v" "\\begin{verse}%a %% %h%x" "\\end{verse}") + ("quotation" "q" "\\begin{quotation}%a %% %h%x" "\\end{quotation}") + ("quote" "Q" "\\begin{quote}%a %% %h%x" "\\end{quote}") + ("structureenv" "s" "\\begin{structureenv}%a %% %h%x" "\\end{structureenv}") + ("theorem" "t" "\\begin{theorem}%a%U%x" "\\end{theorem}") + ("definition" "d" "\\begin{definition}%a%U%x" "\\end{definition}") + ("example" "e" "\\begin{example}%a%U%x" "\\end{example}") + ("proof" "p" "\\begin{proof}%a%U%x" "\\end{proof}") + ("beamercolorbox" "o" "\\begin{beamercolorbox}%o{%h}%x" "\\end{beamercolorbox}") + ("normal" "h" "%h" "") ; Emit the heading as normal text + ("note" "n" "\\note%o%a{%h" "}") + ("noteNH" "N" "\\note%o%a{" "}") ; note, ignore heading + ("ignoreheading" "i" "%%%% %h" "")) + "Environments triggered by properties in Beamer export. +These are the defaults - for user definitions, see +`org-beamer-environments-extra'. +\"normal\" is a special fake environment, which emit the heading as +normal text. It is needed when an environment should be surrounded +by normal text. Since beamer export converts nodes into environments, +you need to have a node to end the environment. +For example + + ** a frame + some text + *** Blocktitle :B_block: + inside the block + *** After the block :B_normal: + continuing here + ** next frame") + +(defcustom org-beamer-environments-extra nil + "Environments triggered by tags in Beamer export. +Each entry has 4 elements: + +name Name of the environment +key Selection key for `org-beamer-select-environment' +open The opening template for the environment, with the following escapes + %a the action/overlay specification + %A the default action/overlay specification + %o the options argument of the template + %h the headline text + %H if there is headline text, that text in {} braces + %U if there is headline text, that text in [] brackets +close The closing string of the environment." + + :group 'org-beamer + :type '(repeat + (list + (string :tag "Environment") + (string :tag "Selection key") + (string :tag "Begin") + (string :tag "End")))) + +(defvar org-beamer-frame-level-now nil) +(defvar org-beamer-header-extra nil) +(defvar org-beamer-export-is-beamer-p nil) +(defvar org-beamer-inside-frame-at-level nil) +(defvar org-beamer-columns-open nil) +(defvar org-beamer-column-open nil) + +(defun org-beamer-cleanup-column-width (width) + "Make sure the width is not empty, and that it has a unit." + (setq width (org-trim (or width ""))) + (unless (string-match "\\S-" width) (setq width "0.5")) + (if (string-match "\\`[.0-9]+\\'" width) + (setq width (concat width "\\textwidth"))) + width) + +(defun org-beamer-open-column (&optional width opt) + (org-beamer-close-column-maybe) + (setq org-beamer-column-open t) + (setq width (org-beamer-cleanup-column-width width)) + (insert (format "\\begin{column}%s{%s}\n" (or opt "") width))) +(defun org-beamer-close-column-maybe () + (when org-beamer-column-open + (setq org-beamer-column-open nil) + (insert "\\end{column}\n"))) +(defun org-beamer-open-columns-maybe (&optional opts) + (unless org-beamer-columns-open + (setq org-beamer-columns-open t) + (insert (format "\\begin{columns}%s\n" (or opts ""))))) +(defun org-beamer-close-columns-maybe () + (org-beamer-close-column-maybe) + (when org-beamer-columns-open + (setq org-beamer-columns-open nil) + (insert "\\end{columns}\n"))) + +(defun org-beamer-select-environment () + "Select the environment to be used by beamer for this entry. +While this uses (for convenience) a tag selection interface, the result +of this command will be that the BEAMER_env *property* of the entry is set. + +In addition to this, the command will also set a tag as a visual aid, but +the tag does not have any semantic meaning." + (interactive) + (let* ((envs (append org-beamer-environments-extra + org-beamer-environments-default)) + (org-tag-alist + (append '((:startgroup)) + (mapcar (lambda (e) (cons (concat "B_" (car e)) + (string-to-char (nth 1 e)))) + envs) + '((:endgroup)) + '(("BMCOL" . ?|)))) + (org-fast-tag-selection-single-key t)) + (org-set-tags) + (let ((tags (or (ignore-errors (org-get-tags-string)) ""))) + (cond + ((equal org-last-tag-selection-key ?|) + (if (string-match ":BMCOL:" tags) + (org-set-property "BEAMER_col" (read-string "Column width: ")) + (org-delete-property "BEAMER_col"))) + ((string-match (concat ":B_\\(" + (mapconcat 'car envs "\\|") + "\\):") + tags) + (org-entry-put nil "BEAMER_env" (match-string 1 tags))) + (t (org-entry-delete nil "BEAMER_env")))))) + + +(defun org-beamer-sectioning (level text) + "Return the sectioning entry for the current headline. +LEVEL is the reduced level of the headline. +TEXT is the text of the headline, everything except the leading stars. +The return value is a cons cell. The car is the headline text, usually +just TEXT, but possibly modified if options have been extracted from the +text. The cdr is the sectioning entry, similar to what is given +in org-export-latex-classes." + (let* ((frame-level (or org-beamer-frame-level-now org-beamer-frame-level)) + (default + (if org-beamer-use-parts + '((1 . ("\\part{%s}" . "\\part*{%s}")) + (2 . ("\\section{%s}" . "\\section*{%s}")) + (3 . ("\\subsection{%s}" . "\\subsection*{%s}"))) + '((1 . ("\\section{%s}" . "\\section*{%s}")) + (2 . ("\\subsection{%s}" . "\\subsection*{%s}"))))) + (envs (append org-beamer-environments-extra + org-beamer-environments-default)) + (props (org-get-text-property-any 0 'org-props text)) + (in "") (out "") option action defaction environment extra + columns-option column-option + env have-text ass tmp) + (if (= frame-level 0) (setq frame-level nil)) + (when (and org-beamer-inside-frame-at-level + (<= level org-beamer-inside-frame-at-level)) + (setq org-beamer-inside-frame-at-level nil)) + (when (setq tmp (org-beamer-assoc-not-empty "BEAMER_col" props)) + (if (and (string-match "\\`[0-9.]+\\'" tmp) + (or (= (string-to-number tmp) 1.0) + (= (string-to-number tmp) 0.0))) + ;; column width 1 means close columns, go back to full width + (org-beamer-close-columns-maybe) + (when (setq ass (assoc "BEAMER_envargs" props)) + (let (case-fold-search) + (while (string-match "C\\(\\[[^][]*\\]\\|<[^<>]*>\\)" (cdr ass)) + (setq columns-option (match-string 1 (cdr ass))) + (setcdr ass (replace-match "" t t (cdr ass)))) + (while (string-match "c\\(\\[[^][]*\\]\\|<[^<>]*>\\)" (cdr ass)) + (setq column-option (match-string 1 (cdr ass))) + (setcdr ass (replace-match "" t t (cdr ass)))))) + (org-beamer-open-columns-maybe columns-option) + (org-beamer-open-column tmp column-option))) + (cond + ((or (equal (cdr (assoc "BEAMER_env" props)) "frame") + (and frame-level (= level frame-level))) + ;; A frame + (org-beamer-get-special props) + + (setq in (org-fill-template + "\\begin{frame}%a%A%o%T%S%x" + (list (cons "a" (or action "")) + (cons "A" (or defaction "")) + (cons "o" (or option org-beamer-frame-default-options "")) + (cons "x" (if extra (concat "\n" extra) "")) + (cons "h" "%s") + (cons "T" (if (string-match "\\S-" text) + "\n\\frametitle{%s}" "")) + (cons "S" (if (string-match "\\\\\\\\" text) + "\n\\framesubtitle{%s}" "")))) + out (copy-sequence "\\end{frame}")) + (org-add-props out + '(org-insert-hook org-beamer-close-columns-maybe)) + (setq org-beamer-inside-frame-at-level level) + (cons text (list in out in out))) + ((and (setq env (cdr (assoc "BEAMER_env" props))) + (setq ass (assoc env envs))) + ;; A beamer environment selected by the BEAMER_env property + (if (string-match "[ \t]+:[ \t]*$" text) + (setq text (replace-match "" t t text))) + (if (member env '("note" "noteNH")) + ;; There should be no labels in a note, so we remove the targets + ;; FIXME??? + (remove-text-properties 0 (length text) '(target nil) text)) + (org-beamer-get-special props) + (setq text (org-trim text)) + (setq have-text (string-match "\\S-" text)) + (setq in (org-fill-template + (nth 2 ass) + (list (cons "a" (or action "")) + (cons "A" (or defaction "")) + (cons "o" (or option "")) + (cons "x" (if extra (concat "\n" extra) "")) + (cons "h" "%s") + (cons "H" (if have-text (concat "{" text "}") "")) + (cons "U" (if have-text (concat "[" text "]") "")))) + out (nth 3 ass)) + (cond + ((equal out "\\end{columns}") + (setq org-beamer-columns-open t) + (setq out (org-add-props (copy-sequence out) + '(org-insert-hook + (lambda () + (org-beamer-close-column-maybe) + (setq org-beamer-columns-open nil)))))) + ((equal out "\\end{column}") + (org-beamer-open-columns-maybe))) + (cons text (list in out in out))) + ((and (not org-beamer-inside-frame-at-level) + (or (not frame-level) + (< level frame-level)) + (assoc level default)) + ;; Normal sectioning + (cons text (cdr (assoc level default)))) + (t nil)))) + +(defvar extra) +(defvar option) +(defvar action) +(defvar defaction) +(defvar environment) +(defun org-beamer-get-special (props) + "Extract an option, action, and default action string from text. +The variables option, action, defaction, extra are all scoped into +this function dynamically." + (let (tmp) + (setq environment (org-beamer-assoc-not-empty "BEAMER_env" props)) + (setq extra (org-beamer-assoc-not-empty "BEAMER_extra" props)) + (when extra + (setq extra (replace-regexp-in-string "\\\\n" "\n" extra))) + (setq tmp (org-beamer-assoc-not-empty "BEAMER_envargs" props)) + (when tmp + (setq tmp (copy-sequence tmp)) + (if (string-match "\\[<[^][<>]*>\\]" tmp) + (setq defaction (match-string 0 tmp) + tmp (replace-match "" t t tmp))) + (if (string-match "\\[[^][]*\\]" tmp) + (setq option (match-string 0 tmp) + tmp (replace-match "" t t tmp))) + (if (string-match "<[^<>]*>" tmp) + (setq action (match-string 0 tmp) + tmp (replace-match "" t t tmp)))))) + +(defun org-beamer-assoc-not-empty (elt list) + (let ((tmp (cdr (assoc elt list)))) + (and tmp (string-match "\\S-" tmp) tmp))) + + +(defvar org-beamer-mode-map (make-sparse-keymap) + "The keymap for `org-beamer-mode'.") +(define-key org-beamer-mode-map "\C-c\C-b" 'org-beamer-select-environment) + +(define-minor-mode org-beamer-mode + "Special support for editing Org-mode files made to export to beamer." + nil " Bm" nil) +(when (fboundp 'font-lock-add-keywords) + (font-lock-add-keywords + 'org-mode + '((":\\(B_[a-z]+\\|BMCOL\\):" 1 'org-beamer-tag prepend)) + 'prepent)) + +(defun org-beamer-place-default-actions-for-lists () + "Find default overlay specifications in items, and move them. +The need to be after the begin statement of the environment." + (when org-beamer-export-is-beamer-p + (let (dovl) + (goto-char (point-min)) + (while (re-search-forward + "^[ \t]*\\\\begin{\\(itemize\\|enumerate\\|description\\)}[ \t\n]*\\\\item\\>\\( ?\\(<[^<>\n]*>\\|\\[[^][\n*]\\]\\)\\)?[ \t]*\\S-" nil t) + (if (setq dovl (cdr (assoc "BEAMER_dovl" + (get-text-property (match-end 0) + 'org-props)))) + (save-excursion + (goto-char (1+ (match-end 1))) + (insert dovl))))))) + +(defun org-beamer-amend-header () + "Add `org-beamer-header-extra' to the LaTeX header. +If the file contains the string BEAMER-HEADER-EXTRA-HERE on a line +by itself, it will be replaced with `org-beamer-header-extra'. If not, +the value will be inserted right after the documentclass statement." + (when (and org-beamer-export-is-beamer-p + org-beamer-header-extra) + (goto-char (point-min)) + (cond + ((re-search-forward + "^[ \t]*\\[?BEAMER-HEADER-EXTRA\\(-HERE\\)?\\]?[ \t]*$" nil t) + (replace-match org-beamer-header-extra t t) + (or (bolp) (insert "\n"))) + ((re-search-forward "^[ \t]*\\\\begin{document}" nil t) + (beginning-of-line 1) + (insert org-beamer-header-extra) + (or (bolp) (insert "\n")))))) + +(defcustom org-beamer-fragile-re "^[ \t]*\\\\begin{\\(verbatim\\|lstlisting\\)}" + "If this regexp matches in a frame, the frame is marked as fragile." + :group 'org-beamer + :type 'regexp) + +(defface org-beamer-tag '((t (:box (:line-width 1 :color grey40)))) + "The special face for beamer tags." + :group 'org-beamer) + + +;; Functions to initialize and post-process +;; These fuctions will be hooked into various places in the export process + +(defun org-beamer-initialize-open-trackers () + "Reset variables that track if certain environments are open during export." + (setq org-beamer-columns-open nil) + (setq org-beamer-column-open nil) + (setq org-beamer-inside-frame-at-level nil) + (setq org-beamer-export-is-beamer-p nil)) + +(defun org-beamer-after-initial-vars () + "Find special settings for beamer and store them. +The effect is that these values will be accessible during export." + ;; First verify that we are exporting using the beamer class + (setq org-beamer-export-is-beamer-p + (string-match "\\\\documentclass\\(\\[[^][]*?\\]\\)?{beamer}" + org-export-latex-header)) + (when org-beamer-export-is-beamer-p + ;; Find the frame level + (setq org-beamer-frame-level-now + (or (and (org-region-active-p) + (save-excursion + (goto-char (region-beginning)) + (and (looking-at org-complex-heading-regexp) + (org-entry-get nil "BEAMER_FRAME_LEVEL" 'selective)))) + (save-excursion + (save-restriction + (widen) + (goto-char (point-min)) + (and (re-search-forward + "^#\\+BEAMER_FRAME_LEVEL:[ \t]*\\(.*?\\)[ \t]*$" nil t) + (match-string 1)))) + (plist-get org-export-latex-options-plist :beamer-frame-level) + org-beamer-frame-level)) + ;; Normalize the value so that the functions can trust the value + (cond + ((not org-beamer-frame-level-now) + (setq org-beamer-frame-level-now nil)) + ((stringp org-beamer-frame-level-now) + (setq org-beamer-frame-level-now + (string-to-number org-beamer-frame-level-now)))) + ;; Find the header additons, most likely theme commands + (setq org-beamer-header-extra + (or (and (org-region-active-p) + (save-excursion + (goto-char (region-beginning)) + (and (looking-at org-complex-heading-regexp) + (org-entry-get nil "BEAMER_HEADER_EXTRA" + 'selective)))) + (save-excursion + (save-restriction + (widen) + (let ((txt "")) + (goto-char (point-min)) + (while (re-search-forward + "^#\\+BEAMER_HEADER_EXTRA:[ \t]*\\(.*?\\)[ \t]*$" + nil t) + (setq txt (concat txt "\n" (match-string 1)))) + (if (> (length txt) 0) (substring txt 1))))) + (plist-get org-export-latex-options-plist + :beamer-header-extra))) + (let ((inhibit-read-only t) + (case-fold-search nil) + props) + (org-unmodified + (remove-text-properties (point-min) (point-max) '(org-props nil)) + (org-map-entries + '(progn + (setq props (org-entry-properties nil 'standard)) + (if (and (not (assoc "BEAMER_env" props)) + (looking-at ".*?:B_\\(note\\(NH\\)?\\):")) + (push (cons "BEAMER_env" (match-string 1)) props)) + (put-text-property (point-at-bol) (point-at-eol) 'org-props props))) + (setq org-export-latex-options-plist + (plist-put org-export-latex-options-plist :tags nil)))))) + +(defun org-beamer-auto-fragile-frames () + "Mark any frames containing verbatim environments as fragile. +This function will run in the final LaTeX document." + (when org-beamer-export-is-beamer-p + (let (opts) + (goto-char (point-min)) + ;; Find something that might be fragile + (while (re-search-forward org-beamer-fragile-re nil t) + (save-excursion + ;; Are we inside a frame here? + (when (and (re-search-backward "^[ \t]*\\\\\\(begin\\|end\\){frame}" + nil t) + (equal (match-string 1) "begin")) + ;; yes, inside a frame, make sure "fragile" is one of the options + (goto-char (match-end 0)) + (if (not (looking-at "\\[.*?\\]")) + (insert "[fragile]") + (setq opts (substring (match-string 0) 1 -1)) + (delete-region (match-beginning 0) (match-end 0)) + (setq opts (org-split-string opts ",")) + (add-to-list 'opts "fragile") + (insert "[" (mapconcat 'identity opts ",") "]")))))))) + +(defcustom org-beamer-outline-frame-title "Outline" + "Default title of a frame containing an outline." + :group 'org-beamer + :type '(string :tag "Outline frame title") +) + +(defcustom org-beamer-outline-frame-options nil + "Outline frame options appended after \\begin{frame}. +You might want to put e.g. [allowframebreaks=0.9] here. Remember to +include square brackets." + :group 'org-beamer + :type '(string :tag "Outline frame options") +) + +(defun org-beamer-fix-toc () + "Fix the table of contents by removing the vspace line." + (when org-beamer-export-is-beamer-p + (save-excursion + (goto-char (point-min)) + (when (re-search-forward "\\(\\\\setcounter{tocdepth.*\n\\\\tableofcontents.*\n\\)\\(\\\\vspace\\*.*\\)" + nil t) + (replace-match + (concat "\\\\begin{frame}" org-beamer-outline-frame-options + "\n\\\\frametitle{" + org-beamer-outline-frame-title + "}\n\\1\\\\end{frame}") + t nil))))) + +(defun org-beamer-property-changed (property value) + "Track the BEAMER_env property with tags." + (cond + ((equal property "BEAMER_env") + (save-excursion + (org-back-to-heading t) + (let ((tags (org-get-tags))) + (setq tags (delq nil (mapcar (lambda (x) + (if (string-match "^B_" x) nil x)) + tags))) + (org-set-tags-to tags)) + (when (and value (stringp value) (string-match "\\S-" value)) + (org-toggle-tag (concat "B_" value) 'on)))) + ((equal property "BEAMER_col") + (org-toggle-tag "BMCOL" (if (and value (string-match "\\S-" value)) + 'on 'off))))) + +(defun org-beamer-select-beamer-code () + "Take code marked for BEAMER and turn it into marked for LaTeX." + (when org-beamer-export-is-beamer-p + (goto-char (point-min)) + (while (re-search-forward + "^\\([ \]*#\\+\\(begin_\\|end_\\)?\\)\\(beamer\\)\\>" nil t) + (replace-match "\\1latex")))) + +;; OK, hook all these functions into appropriate places +(add-hook 'org-export-first-hook + 'org-beamer-initialize-open-trackers) +(add-hook 'org-property-changed-functions + 'org-beamer-property-changed) +(add-hook 'org-export-latex-after-initial-vars-hook + 'org-beamer-after-initial-vars) +(add-hook 'org-export-latex-final-hook + 'org-beamer-place-default-actions-for-lists) +(add-hook 'org-export-latex-final-hook + 'org-beamer-auto-fragile-frames) +(add-hook 'org-export-latex-final-hook + 'org-beamer-fix-toc) +(add-hook 'org-export-latex-final-hook + 'org-beamer-amend-header) +(add-hook 'org-export-preprocess-before-selecting-backend-code-hook + 'org-beamer-select-beamer-code) + +(defun org-insert-beamer-options-template (kind) + "Insert a settings template, to make sure users do this right." + (interactive (progn + (message "Current [s]ubtree or [g]lobal?") + (if (equal (read-char-exclusive) ?g) + (list 'global) + (list 'subtree)))) + (if (eq kind 'subtree) + (progn + (org-back-to-heading t) + (org-reveal) + (org-entry-put nil "LaTeX_CLASS" "beamer") + (org-entry-put nil "LaTeX_CLASS_OPTIONS" "[presentation]") + (org-entry-put nil "EXPORT_FILE_NAME" "presentation.pdf") + (org-entry-put nil "BEAMER_FRAME_LEVEL" (number-to-string + org-beamer-frame-level)) + (when org-beamer-themes + (org-entry-put nil "BEAMER_HEADER_EXTRA" org-beamer-themes)) + (when org-beamer-column-view-format + (org-entry-put nil "COLUMNS" org-beamer-column-view-format)) + (org-entry-put nil "BEAMER_col_ALL" "0.1 0.2 0.3 0.4 0.5 0.6 0.7 0.8 0.9 1.0 :ETC")) + (insert "#+LaTeX_CLASS: beamer\n") + (insert "#+LaTeX_CLASS_OPTIONS: [presentation]\n") + (insert (format "#+BEAMER_FRAME_LEVEL: %d\n" org-beamer-frame-level) "\n") + (when org-beamer-themes + (insert "#+BEAMER_HEADER_EXTRA: " org-beamer-themes "\n")) + (when org-beamer-column-view-format + (insert "#+COLUMNS: " org-beamer-column-view-format "\n")) + (insert "#+PROPERTY: BEAMER_col_ALL 0.1 0.2 0.3 0.4 0.5 0.6 0.7 0.8 0.9 1.0 :ETC\n"))) + + +(defun org-beamer-allowed-property-values (property) + "Supply allowed values for BEAMER properties." + (cond + ((and (equal property "BEAMER_env") + (not (org-entry-get nil (concat property "_ALL") 'inherit))) + ;; If no allowed values for BEAMER_env have been defined, + ;; supply all defined environments + (mapcar 'car (append org-beamer-environments-extra + org-beamer-environments-default))) + ((and (equal property "BEAMER_col") + (not (org-entry-get nil (concat property "_ALL") 'inherit))) + ;; If no allowed values for BEAMER_col have been defined, + ;; supply some + '("0.1" "0.2" "0.3" "0.4" "0.5" "0.6" "0.7" "0.8" "0.9" "" ":ETC")) + (t nil))) + +(add-hook 'org-property-allowed-value-functions + 'org-beamer-allowed-property-values) + +(provide 'org-beamer) + +;; arch-tag: 68bac91a-a946-43a3-8173-a9269306f67c + +;;; org-beamer.el ends here diff --git a/.emacs.d/org-7.4/lisp/org-beamer.elc b/.emacs.d/org-7.4/lisp/org-beamer.elc Binary files differnew file mode 100644 index 0000000..9a78f15 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-beamer.elc diff --git a/.emacs.d/org-7.4/lisp/org-bibtex.el b/.emacs.d/org-7.4/lisp/org-bibtex.el new file mode 100644 index 0000000..e34e157 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-bibtex.el @@ -0,0 +1,205 @@ +;;; org-bibtex.el --- Org links to BibTeX entries +;; +;; Copyright (C) 2007, 2008, 2009, 2010 Free Software Foundation, Inc. +;; +;; Author: Bastien Guerry <bzg at altern dot org> +;; Carsten Dominik <carsten dot dominik at gmail dot com> +;; Keywords: org, wp, remember +;; Version: 7.4 +;; +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. +;; +;;; Commentary: +;; +;; This file implements links to database entries in BibTeX files. +;; Instead of defining a special link prefix, it uses the normal file +;; links combined with a custom search mechanism to find entries +;; by reference key. And it constructs a nice description tag for +;; the link that contains the author name, the year and a short title. +;; +;; It also stores detailed information about the entry so that +;; remember templates can access and enter this information easily. +;; +;; The available properties for each entry are listed here: +;; +;; :author :publisher :volume :pages +;; :editor :url :number :journal +;; :title :year :series :address +;; :booktitle :month :annote :abstract +;; :key :btype +;; +;; Here is an example of a remember template that use some of this +;; information (:author :year :title :journal :pages): +;; +;; (setq org-remember-templates +;; '((?b "* READ %?\n\n%a\n\n%:author (%:year): %:title\n \ +;; In %:journal, %:pages."))) +;; +;; Let's say you want to remember this BibTeX entry: +;; +;; @Article{dolev83, +;; author = {Danny Dolev and Andrew C. Yao}, +;; title = {On the security of public-key protocols}, +;; journal = {IEEE Transaction on Information Theory}, +;; year = 1983, +;; volume = 2, +;; number = 29, +;; pages = {198--208}, +;; month = {Mars} +;; } +;; +;; M-x `org-remember' on this entry will produce this buffer: +;; +;; ===================================================================== +;; * READ <== [point here] +;; +;; [[file:/file.bib::dolev83][Dolev & Yao 1983: security of public key protocols]] +;; +;; Danny Dolev and Andrew C. Yao (1983): On the security of public-key protocols +;; In IEEE Transaction on Information Theory, 198--208. +;; ===================================================================== +;; +;;; History: +;; +;; The link creation part has been part of Org-mode for a long time. +;; +;; Creating better remember template information was inspired by a request +;; of Austin Frank: http://article.gmane.org/gmane.emacs.orgmode/4112 +;; and then implemented by Bastien Guerry. +;; +;; Org-mode loads this module by default - if this is not what you want, +;; configure the variable `org-modules'. + +;;; Code: + +(require 'org) + +(defvar description nil) ; dynamically scoped from org.el + +(declare-function bibtex-beginning-of-entry "bibtex" ()) +(declare-function bibtex-generate-autokey "bibtex" ()) +(declare-function bibtex-parse-entry "bibtex" (&optional content)) +(declare-function bibtex-url "bibtex" (&optional pos no-browse)) + +(org-add-link-type "bibtex" 'org-bibtex-open) +(add-hook 'org-store-link-functions 'org-bibtex-store-link) + +;; (defun org-bibtex-publish (path) +;; "Build the description of the BibTeX entry for publishing." +;; (let* ((search (when (string-match "::\\(.+\\)\\'" path) +;; (match-string 1 path))) +;; (path (substring path 0 (match-beginning 0))) +;; key) +;; (with-temp-buffer +;; (org-open-file path t nil search) +;; (setq key (org-create-file-search-functions))) +;; (or description key))) + +(defun org-bibtex-open (path) + "Visit the bibliography entry on PATH." + (let* ((search (when (string-match "::\\(.+\\)\\'" path) + (match-string 1 path))) + (path (substring path 0 (match-beginning 0)))) + (org-open-file path t nil search))) + +(defun org-bibtex-store-link () + "Store a link to a BibTeX entry." + (when (eq major-mode 'bibtex-mode) + (let* ((search (org-create-file-search-in-bibtex)) + (link (concat "file:" (abbreviate-file-name buffer-file-name) + "::" search)) + (entry (mapcar ; repair strings enclosed in "..." or {...} + (lambda(c) + (if (string-match + "^\\(?:{\\|\"\\)\\(.*\\)\\(?:}\\|\"\\)$" (cdr c)) + (cons (car c) (match-string 1 (cdr c))) c)) + (save-excursion + (bibtex-beginning-of-entry) + (bibtex-parse-entry))))) + (org-store-link-props + :key (cdr (assoc "=key=" entry)) + :author (or (cdr (assoc "author" entry)) "[no author]") + :editor (or (cdr (assoc "editor" entry)) "[no editor]") + :title (or (cdr (assoc "title" entry)) "[no title]") + :booktitle (or (cdr (assoc "booktitle" entry)) "[no booktitle]") + :journal (or (cdr (assoc "journal" entry)) "[no journal]") + :publisher (or (cdr (assoc "publisher" entry)) "[no publisher]") + :pages (or (cdr (assoc "pages" entry)) "[no pages]") + :url (or (cdr (assoc "url" entry)) "[no url]") + :year (or (cdr (assoc "year" entry)) "[no year]") + :month (or (cdr (assoc "month" entry)) "[no month]") + :address (or (cdr (assoc "address" entry)) "[no address]") + :volume (or (cdr (assoc "volume" entry)) "[no volume]") + :number (or (cdr (assoc "number" entry)) "[no number]") + :annote (or (cdr (assoc "annote" entry)) "[no annotation]") + :series (or (cdr (assoc "series" entry)) "[no series]") + :abstract (or (cdr (assoc "abstract" entry)) "[no abstract]") + :btype (or (cdr (assoc "=type=" entry)) "[no type]") + :type "bibtex" + :link link + :description description)))) + +(defun org-create-file-search-in-bibtex () + "Create the search string and description for a BibTeX database entry." + ;; Make a good description for this entry, using names, year and the title + ;; Put it into the `description' variable which is dynamically scoped. + (let ((bibtex-autokey-names 1) + (bibtex-autokey-names-stretch 1) + (bibtex-autokey-name-case-convert-function 'identity) + (bibtex-autokey-name-separator " & ") + (bibtex-autokey-additional-names " et al.") + (bibtex-autokey-year-length 4) + (bibtex-autokey-name-year-separator " ") + (bibtex-autokey-titlewords 3) + (bibtex-autokey-titleword-separator " ") + (bibtex-autokey-titleword-case-convert-function 'identity) + (bibtex-autokey-titleword-length 'infty) + (bibtex-autokey-year-title-separator ": ")) + (setq description (bibtex-generate-autokey))) + ;; Now parse the entry, get the key and return it. + (save-excursion + (bibtex-beginning-of-entry) + (cdr (assoc "=key=" (bibtex-parse-entry))))) + +(defun org-execute-file-search-in-bibtex (s) + "Find the link search string S as a key for a database entry." + (when (eq major-mode 'bibtex-mode) + ;; Yes, we want to do the search in this file. + ;; We construct a regexp that searches for "@entrytype{" followed by the key + (goto-char (point-min)) + (and (re-search-forward (concat "@[a-zA-Z]+[ \t\n]*{[ \t\n]*" + (regexp-quote s) "[ \t\n]*,") nil t) + (goto-char (match-beginning 0))) + (if (and (match-beginning 0) (equal current-prefix-arg '(16))) + ;; Use double prefix to indicate that any web link should be browsed + (let ((b (current-buffer)) (p (point))) + ;; Restore the window configuration because we just use the web link + (set-window-configuration org-window-config-before-follow-link) + (with-current-buffer b + (goto-char p) + (bibtex-url))) + (recenter 0)) ; Move entry start to beginning of window + ;; return t to indicate that the search is done. + t)) + +;; Finally add the link search function to the right hook. +(add-hook 'org-execute-file-search-functions 'org-execute-file-search-in-bibtex) + +(provide 'org-bibtex) + +;; arch-tag: 83987d5a-01b8-41c7-85bc-77700f1285f5 + +;;; org-bibtex.el ends here diff --git a/.emacs.d/org-7.4/lisp/org-bibtex.elc b/.emacs.d/org-7.4/lisp/org-bibtex.elc Binary files differnew file mode 100644 index 0000000..c12de93 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-bibtex.elc diff --git a/.emacs.d/org-7.4/lisp/org-capture.el b/.emacs.d/org-7.4/lisp/org-capture.el new file mode 100644 index 0000000..5c7b038 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-capture.el @@ -0,0 +1,1391 @@ +;;; org-capture.el --- Fast note taking in Org-mode + +;; Copyright (C) 2010 Free Software Foundation, Inc. + +;; Author: Carsten Dominik <carsten at orgmode dot org> +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; Version: 7.4 +;; +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: + +;; This file contains an alternative implementation of the same functionality +;; that is also provided by org-remember.el. The implementation is more +;; streamlined, can produce more target types (e.g. plain list items or +;; table lines). Also, it does not use a temporary buffer for editing +;; the captured entry - instead it uses an indirect buffer that visits +;; the new entry already in the target buffer (this was an idea by Samuel +;; Wales). John Wiegley's excellent `remember.el' is not needed for this +;; implementation, even though we borrow heavily from its ideas. + +;; This implementation heavily draws on ideas by James TD Smith and +;; Samuel Wales, and, of cause, uses John Wiegley's remember.el as inspiration. + +;;; TODO + +;; - find a clever way to not always insert an annotation maybe a +;; predicate function that can check for conditions for %a to be +;; used. This could be one of the properties. + +;; - Should there be plist members that arrange for properties to be +;; asked for, like James proposed in his RFC? + +;;; Code: + +(eval-when-compile + (require 'cl)) +(require 'org) +(require 'org-mks) + +(declare-function org-datetree-find-date-create "org-datetree" + (DATE &optional KEEP-RESTRICTION)) +(declare-function org-table-get-specials "org-table" ()) +(declare-function org-table-goto-line "org-table" (N)) +(defvar org-remember-default-headline) +(defvar org-remember-templates) +(defvar org-table-hlines) + +(defvar org-capture-clock-was-started nil + "Internal flag, noting if the clock was started.") + +(defvar org-capture-last-stored-marker (make-marker) + "Marker pointing to the entry most recently stored with `org-capture'.") + +;; The following variable is scoped dynamically by org-protocol +;; to indicate that the link properties have already been stored +(defvar org-capture-link-is-already-stored nil) + +(defgroup org-capture nil + "Options concerning capturing new entries." + :tag "Org Capture" + :group 'org) + +(defcustom org-capture-templates nil + "Templates for the creation of new entries. + +Each entry is a list with the following items: + +keys The keys that will select the template, as a string, characters + only, for example \"a\" for a template to be selected with a + single key, or \"bt\" for selection with two keys. When using + several keys, keys using the same prefix key must be together + in the list and preceded by a 2-element entry explaining the + prefix key, for example + + (\"b\" \"Templates for marking stuff to buy\") + + The \"C\" key is used by default for quick access to the + customization of the template variable. But if you want to use + that key for a template, you can. + +description A short string describing the template, will be shown during + selection. + +type The type of entry. Valid types are: + entry an Org-mode node, with a headline. Will be + filed as the child of the target entry or as + a top-level entry. + item a plain list item, will be placed in the + first plain list at the target + location. + checkitem a checkbox item. This differs from the + plain list item only is so far as it uses a + different default template. + table-line a new line in the first table at target location. + plain text to be inserted as it is. + +target Specification of where the captured item should be placed. + In Org-mode files, targets usually define a node. Entries will + become children of this node, other types will be added to the + table or list in the body of this node. + + Valid values are: + + (file \"path/to/file\") + Text will be placed at the beginning or end of that file + + (id \"id of existing org entry\") + File as child of this entry, or in the body of the entry + + (file+headline \"path/to/file\" \"node headline\") + Fast configuration if the target heading is unique in the file + + (file+olp \"path/to/file\" \"Level 1 heading\" \"Level 2\" ...) + For non-unique headings, the full path is safer + + (file+regexp \"path/to/file\" \"regexp to find location\") + File to the entry matching regexp + + (file+datetree \"path/to/file\") + Will create a heading in a date tree for today's date + + (file+datetree+prompt \"path/to/file\") + Will create a heading in a date tree, promts for date + + (file+function \"path/to/file\" function-finding-location) + A function to find the right location in the file + + (clock) + File to the entry that is currently being clocked + + (function function-finding-location) + Most general way, write your own function to find both + file and location + +template The template for creating the capture item. If you leave this + empty, an appropriate default template will be used. See below + for more details. Instead of a string, this may also be one of + + (file \"/path/to/template-file\") + (function function-returning-the-template) + + in order to get a template from a file, or dynamically + from a function. + +The rest of the entry is a property list of additional options. Recognized +properties are: + + :prepend Normally newly captured information will be appended at + the target location (last child, last table line, + last list item...). Setting this property will + change that. + + :immediate-finish When set, do not offer to edit the information, just + file it away immediately. This makes sense if the + template only needs information that can be added + automatically. + + :empty-lines Set this to the number of lines the should be inserted + before and after the new item. Default 0, only common + other value is 1. + + :clock-in Start the clock in this item. + + :clock-resume Start the interrupted clock when finishing the capture. + + :unnarrowed Do not narrow the target buffer, simply show the + full buffer. Default is to narrow it so that you + only see the new stuff. + + :table-line-pos Specification of the location in the table where the + new line should be inserted. It looks like \"II-3\" + which means that the new line should become the third + line before the second horizontal separator line. + + :kill-buffer If the target file was not yet visited by a buffer when + capture was invoked, kill the buffer again after capture + is finalized. + +The template defines the text to be inserted. Often this is an org-mode +entry (so the first line should start with a star) that will be filed as a +child of the target headline. It can also be freely formatted text. +Furthermore, the following %-escapes will be replaced with content: + + %^{prompt} prompt the user for a string and replace this sequence with it. + A default value and a completion table ca be specified like this: + %^{prompt|default|completion2|completion3|...} + %t time stamp, date only + %T time stamp with date and time + %u, %U like the above, but inactive time stamps + %^t like %t, but prompt for date. Similarly %^T, %^u, %^U. + You may define a prompt like %^{Please specify birthday + %n user name (taken from `user-full-name') + %a annotation, normally the link created with `org-store-link' + %i initial content, copied from the active region. If %i is + indented, the entire inserted text will be indented as well. + %c current kill ring head + %x content of the X clipboard + %^C interactive selection of which kill or clip to use + %^L like %^C, but insert as link + %k title of currently clocked task + %K link to currently clocked task + %^g prompt for tags, with completion on tags in target file + %^G prompt for tags, with completion on all tags in all agenda files + %^{prop}p prompt the user for a value for property `prop' + %:keyword specific information for certain link types, see below + %[pathname] insert the contents of the file given by `pathname' + %(sexp) evaluate elisp `(sexp)' and replace with the result + + %? After completing the template, position cursor here. + +Apart from these general escapes, you can access information specific to the +link type that is created. For example, calling `org-capture' in emails +or gnus will record the author and the subject of the message, which you +can access with \"%:from\" and \"%:subject\", respectively. Here is a +complete list of what is recorded for each link type. + +Link type | Available information +------------------------+------------------------------------------------------ +bbdb | %:type %:name %:company +vm, wl, mh, mew, rmail | %:type %:subject %:message-id + | %:from %:fromname %:fromaddress + | %:to %:toname %:toaddress + | %:fromto (either \"to NAME\" or \"from NAME\") + | %:date + | %:date-timestamp (as active timestamp) + | %:date-timestamp-inactive (as inactive timestamp) +gnus | %:group, for messages also all email fields +w3, w3m | %:type %:url +info | %:type %:file %:node +calendar | %:type %:date" + :group 'org-capture + :type + '(repeat + (choice :value ("" "" entry (file "~/org/notes.org") "") + (list :tag "Multikey description" + (string :tag "Keys ") + (string :tag "Description")) + (list :tag "Template entry" + (string :tag "Keys ") + (string :tag "Description ") + (choice :tag "Capture Type " :value entry + (const :tag "Org entry" entry) + (const :tag "Plain list item" item) + (const :tag "Checkbox item" checkitem) + (const :tag "Plain text" plain) + (const :tag "Table line" table-line)) + (choice :tag "Target location" + (list :tag "File" + (const :format "" file) + (file :tag " File")) + (list :tag "ID" + (const :format "" id) + (string :tag " ID")) + (list :tag "File & Headline" + (const :format "" file+headline) + (file :tag " File ") + (string :tag " Headline")) + (list :tag "File & Outline path" + (const :format "" file+olp) + (file :tag " File ") + (repeat :tag "Outline path" :inline t + (string :tag "Headline"))) + (list :tag "File & Regexp" + (const :format "" file+regexp) + (file :tag " File ") + (regexp :tag " Regexp")) + (list :tag "File & Date tree" + (const :format "" file+datetree) + (file :tag " File")) + (list :tag "File & Date tree, prompt for date" + (const :format "" file+datetree+prompt) + (file :tag " File")) + (list :tag "File & function" + (const :format "" file+function) + (file :tag " File ") + (sexp :tag " Function")) + (list :tag "Current clocking task" + (const :format "" clock)) + (list :tag "Function" + (const :format "" function) + (sexp :tag " Function"))) + (choice :tag "Template" + (string) + (list :tag "File" + (const :format "" file) + (file :tag "Template file")) + (list :tag "Function" + (const :format "" function) + (function :tag "Template function"))) + (plist :inline t + ;; Give the most common options as checkboxes + :options (((const :format "%v " :prepend) (const t)) + ((const :format "%v " :immediate-finish) (const t)) + ((const :format "%v " :empty-lines) (const 1)) + ((const :format "%v " :clock-in) (const t)) + ((const :format "%v " :clock-resume) (const t)) + ((const :format "%v " :unnarrowed) (const t)) + ((const :format "%v " :kill-buffer) (const t)))))))) + +(defcustom org-capture-before-finalize-hook nil + "Hook that is run right before a remember process is finalized. +The remember buffer is still current when this hook runs." + :group 'org-capture + :type 'hook) + +(defcustom org-capture-after-finalize-hook nil + "Hook that is run right after a capture process is finalized. + Suitable for window cleanup" + :group 'org-capture + :type 'hook) + +;;; The property list for keeping information about the capture process + +(defvar org-capture-plist nil + "Plist for the current capture process, global, to avoid having to pass it.") +(defvar org-capture-current-plist nil + "Local variable holding the plist in a capture buffer. +This is used to store the plist for use when finishing a capture process. +Another such process might have changed the global variable by then.") + +(defun org-capture-put (&rest stuff) + (while stuff + (setq org-capture-plist (plist-put org-capture-plist + (pop stuff) (pop stuff))))) +(defun org-capture-get (prop &optional local) + (plist-get (if local org-capture-current-plist org-capture-plist) prop)) + +(defun org-capture-member (prop) + (plist-get org-capture-plist prop)) + +;;; The minor mode + +(defvar org-capture-mode-map (make-sparse-keymap) + "Keymap for `org-capture-mode', a minor mode. +Use this map to set additional keybindings for when Org-mode is used +for a Remember buffer.") + +(defvar org-capture-mode-hook nil + "Hook for the minor `org-capture-mode'.") + +(define-minor-mode org-capture-mode + "Minor mode for special key bindings in a remember buffer." + nil " Rem" org-capture-mode-map + (org-set-local + 'header-line-format + "Capture buffer. Finish `C-c C-c', refile `C-c C-w', abort `C-c C-k'.") + (run-hooks 'org-capture-mode-hook)) +(define-key org-capture-mode-map "\C-c\C-c" 'org-capture-finalize) +(define-key org-capture-mode-map "\C-c\C-k" 'org-capture-kill) +(define-key org-capture-mode-map "\C-c\C-w" 'org-capture-refile) + +;;; The main commands + +;;;###autoload +(defun org-capture (&optional goto keys) + "Capture something. +\\<org-capture-mode-map> +This will let you select a template from `org-capture-templates', and then +file the newly captured information. The text is immediately inserted +at the target location, and an indirect buffer is shown where you can +edit it. Pressing \\[org-capture-finalize] brings you back to the previous state +of Emacs, so that you can continue your work. + +When called interactively with a \\[universal-argument] prefix argument GOTO, don't capture +anything, just go to the file/headline where the selected template +stores its notes. With a double prefix argument \ +\\[universal-argument] \\[universal-argument], go to the last note +stored. + +When called with a `C-0' (zero) prefix, insert a template at point. + +Lisp programs can set KEYS to a string associated with a template in +`org-capture-templates'. In this case, interactive selection will be +bypassed." + (interactive "P") + (cond + ((equal goto '(4)) (org-capture-goto-target)) + ((equal goto '(16)) (org-capture-goto-last-stored)) + (t + ;; FIXME: Are these needed? + (let* ((orig-buf (current-buffer)) + (annotation (if (and (boundp 'org-capture-link-is-already-stored) + org-capture-link-is-already-stored) + (plist-get org-store-link-plist :annotation) + (org-store-link nil))) + (initial (and (org-region-active-p) + (buffer-substring (point) (mark)))) + (entry (org-capture-select-template keys))) + (when (stringp initial) + (remove-text-properties 0 (length initial) '(read-only t) initial)) + (when (stringp annotation) + (remove-text-properties 0 (length annotation) + '(read-only t) annotation)) + (cond + ((equal entry "C") + (customize-variable 'org-capture-templates)) + ((equal entry "q") + (error "Abort")) + (t + (org-capture-set-plist entry) + (org-capture-get-template) + (org-capture-put :original-buffer orig-buf :annotation annotation + :initial initial) + (org-capture-put :default-time + (or org-overriding-default-time + (org-current-time))) + (org-capture-set-target-location) + (condition-case error + (org-capture-put :template (org-capture-fill-template)) + ((error quit) + (if (get-buffer "*Capture*") (kill-buffer "*Capture*")) + (error "Capture abort: %s" error))) + + (if (equal goto 0) + ;;insert at point + (org-capture-insert-template-here) + (condition-case error + (org-capture-place-template) + ((error quit) + (if (and (buffer-base-buffer (current-buffer)) + (string-match "\\`CAPTURE-" (buffer-name))) + (kill-buffer (current-buffer))) + (set-window-configuration (org-capture-get :return-to-wconf)) + (error "Capture template `%s': %s" + (org-capture-get :key) + (nth 1 error)))) + (if (org-capture-get :immediate-finish) + (org-capture-finalize) + (if (and (org-mode-p) + (org-capture-get :clock-in)) + (condition-case nil + (progn + (if (org-clock-is-active) + (org-capture-put :interrupted-clock + (copy-marker org-clock-marker))) + (org-clock-in) + (org-set-local 'org-capture-clock-was-started t)) + (error + "Could not start the clock in this capture buffer"))))))))))) + + +(defun org-capture-get-template () + "Get the template from a file or a function if necessary." + (let ((txt (org-capture-get :template)) file) + (cond + ((and (listp txt) (eq (car txt) 'file)) + (if (file-exists-p + (setq file (expand-file-name (nth 1 txt) org-directory))) + (setq txt (org-file-contents file)) + (setq txt (format "* Template file %s not found" (nth 1 txt))))) + ((and (listp txt) (eq (car txt) 'function)) + (if (fboundp (nth 1 txt)) + (setq txt (funcall (nth 1 txt))) + (setq txt (format "* Template function %s not found" (nth 1 txt))))) + ((not txt) (setq txt "")) + ((stringp txt)) + (t (setq txt "* Invalid capture template"))) + (org-capture-put :template txt))) + +(defun org-capture-finalize (&optional stay-with-capture) + "Finalize the capture process. +With prefix argument STAY-WITH-CAPTURE, jump to the location of the +captured item after finalizing." + (interactive "P") + (unless (and org-capture-mode + (buffer-base-buffer (current-buffer))) + (error "This does not seem to be a capture buffer for Org-mode")) + + ;; Did we start the clock in this capture buffer? + (when (and org-capture-clock-was-started + org-clock-marker (marker-buffer org-clock-marker) + (equal (marker-buffer org-clock-marker) (buffer-base-buffer)) + (> org-clock-marker (point-min)) + (< org-clock-marker (point-max))) + ;; Looks like the clock we started is still running. Clock out. + (let (org-log-note-clock-out) (org-clock-out)) + (when (and (org-capture-get :clock-resume 'local) + (markerp (org-capture-get :interrupted-clock 'local)) + (buffer-live-p (marker-buffer + (org-capture-get :interrupted-clock 'local)))) + (let ((clock-in-task (org-capture-get :interrupted-clock 'local))) + (org-with-point-at clock-in-task + (org-clock-in))) + (message "Interrupted clock has been resumed"))) + + (let ((beg (point-min)) + (end (point-max)) + (abort-note nil)) + (widen) + + (if org-note-abort + (let ((m1 (org-capture-get :begin-marker 'local)) + (m2 (org-capture-get :end-marker 'local))) + (if (and m1 m2 (= m1 beg) (= m2 end)) + (progn + (setq abort-note 'clean) + (kill-region m1 m2)) + (setq abort-note 'dirty))) + + ;; Make sure that the empty lines after are correct + (when (and (> (point-max) end) ; indeed, the buffer was still narrowed + (member (org-capture-get :type 'local) + '(entry item checkitem plain))) + (save-excursion + (goto-char end) + (or (bolp) (newline)) + (org-capture-empty-lines-after + (or (org-capture-get :empty-lines 'local) 0)))) + ;; Postprocessing: Update Statistics cookies, do the sorting + (when (org-mode-p) + (save-excursion + (when (ignore-errors (org-back-to-heading)) + (org-update-parent-todo-statistics) + (org-update-checkbox-count))) + ;; FIXME Here we should do the sorting + ;; If we have added a table line, maybe recompute? + (when (and (eq (org-capture-get :type 'local) 'table-line) + (org-at-table-p)) + (if (org-table-get-stored-formulas) + (org-table-recalculate 'all) ;; FIXME: Should we iterate??? + (org-table-align))) + ) + ;; Store this place as the last one where we stored something + ;; Do the marking in the base buffer, so that it makes sense after + ;; the indirect buffer has been killed. + (org-capture-bookmark-last-stored-position) + + ;; Run the hook + (run-hooks 'org-capture-before-finalize-hook) + ) + + ;; Kill the indirect buffer + (save-buffer) + (let ((return-wconf (org-capture-get :return-to-wconf 'local)) + (new-buffer (org-capture-get :new-buffer 'local)) + (kill-buffer (org-capture-get :kill-buffer 'local)) + (base-buffer (buffer-base-buffer (current-buffer)))) + + ;; Kill the indiret buffer + (kill-buffer (current-buffer)) + + ;; Kill the target buffer if that is desired + (when (and base-buffer new-buffer kill-buffer) + (with-current-buffer base-buffer (save-buffer)) + (kill-buffer base-buffer)) + + ;; Restore the window configuration before capture + (set-window-configuration return-wconf)) + + (run-hooks 'org-capture-after-finalize-hook) + ;; Special cases + (cond + (abort-note + (cond + ((equal abort-note 'clean) + (message "Capture process aborted and target buffer cleaned up")) + ((equal abort-note 'dirty) + (error "Capture process aborted, but target buffer could not be cleaned up correctly")))) + (stay-with-capture + (org-capture-goto-last-stored))) + ;; Return if we did store something + (not abort-note))) + +(defun org-capture-refile () + "Finalize the current capture and then refile the entry. +Refiling is done from the base buffer, because the indirect buffer is then +already gone. Any prefix argument will be passed to the refile comand." + (interactive) + (unless (eq (org-capture-get :type 'local) 'entry) + (error + "Refiling from a capture buffer makes only sense for `entry'-type templates")) + (let ((pos (point)) + (base (buffer-base-buffer (current-buffer))) + (org-refile-for-capture t)) + (org-capture-finalize) + (save-window-excursion + (with-current-buffer (or base (current-buffer)) + (save-excursion + (save-restriction + (widen) + (goto-char pos) + (call-interactively 'org-refile))))))) + +(defun org-capture-kill () + "Abort the current capture process." + (interactive) + ;; FIXME: This does not do the right thing, we need to remove the new stuff + ;; By hand it is easy: undo, then kill the buffer + (let ((org-note-abort t) (org-capture-before-finalize-hook nil)) + (org-capture-finalize))) + +(defun org-capture-goto-last-stored () + "Go to the location where the last remember note was stored." + (interactive) + (org-goto-marker-or-bmk org-capture-last-stored-marker + "org-capture-last-stored") + (message "This is the last note stored by a capture process")) + +;;; Supporting functions for handling the process + +(defun org-capture-set-target-location (&optional target) + "Find target buffer and position and store then in the property list." + (let ((target-entry-p t)) + (setq target (or target (org-capture-get :target))) + (save-excursion + (cond + ((eq (car target) 'file) + (set-buffer (org-capture-target-buffer (nth 1 target))) + (setq target-entry-p nil)) + + ((eq (car target) 'id) + (let ((loc (org-id-find (nth 1 target)))) + (if (not loc) + (error "Cannot find target ID \"%s\"" (nth 1 target)) + (set-buffer (org-capture-target-buffer (car loc))) + (goto-char (cdr loc))))) + + ((eq (car target) 'file+headline) + (set-buffer (org-capture-target-buffer (nth 1 target))) + (let ((hd (nth 2 target))) + (goto-char (point-min)) + (unless (org-mode-p) + (error "Target buffer for file+headline should be in Org mode")) + (if (re-search-forward + (format org-complex-heading-regexp-format (regexp-quote hd)) + nil t) + (goto-char (point-at-bol)) + (goto-char (point-max)) + (or (bolp) (insert "\n")) + (insert "* " hd "\n") + (beginning-of-line 0)))) + + ((eq (car target) 'file+olp) + (let ((m (org-find-olp (cdr target)))) + (set-buffer (marker-buffer m)) + (goto-char m))) + + ((eq (car target) 'file+regexp) + (set-buffer (org-capture-target-buffer (nth 1 target))) + (goto-char (point-min)) + (if (re-search-forward (nth 2 target) nil t) + (progn + (goto-char (if (org-capture-get :prepend) + (match-beginning 0) (match-end 0))) + (org-capture-put :exact-position (point)) + (setq target-entry-p (and (org-mode-p) (org-at-heading-p)))) + (error "No match for target regexp in file %s" (nth 1 target)))) + + ((memq (car target) '(file+datetree file+datetree+prompt)) + (require 'org-datetree) + (set-buffer (org-capture-target-buffer (nth 1 target))) + ;; Make a date tree entry, with the current date (or yesterday, + ;; if we are extending dates for a couple of hours) + (org-datetree-find-date-create + (calendar-gregorian-from-absolute + (cond + + (org-overriding-default-time + ;; use the overriding default time + (time-to-days org-overriding-default-time)) + + ((eq (car target) 'file+datetree+prompt) + ;; prompt for date + (time-to-days (org-read-date + nil t nil "Date for tree entry:" + (days-to-time (org-today))))) + (t + ;; current date, possible corrected for late night workers + (org-today)))))) + + ((eq (car target) 'file+function) + (set-buffer (org-capture-target-buffer (nth 1 target))) + (funcall (nth 2 target)) + (org-capture-put :exact-position (point)) + (setq target-entry-p (and (org-mode-p) (org-at-heading-p)))) + + ((eq (car target) 'function) + (funcall (nth 1 target)) + (org-capture-put :exact-position (point)) + (setq target-entry-p (and (org-mode-p) (org-at-heading-p)))) + + ((eq (car target) 'clock) + (if (and (markerp org-clock-hd-marker) + (marker-buffer org-clock-hd-marker)) + (progn (set-buffer (marker-buffer org-clock-hd-marker)) + (goto-char org-clock-hd-marker)) + (error "No running clock that could be used as capture target"))) + + (t (error "Invalid capture target specification"))) + + (org-capture-put :buffer (current-buffer) :pos (point) + :target-entry-p target-entry-p)))) + +(defun org-capture-target-buffer (file) + "Get a buffer for FILE." + (setq file (or (org-string-nw-p file) + org-default-notes-file + (error "No notes file specified, and no default available"))) + (or (org-find-base-buffer-visiting file) + (progn (org-capture-put :new-buffer t) + (find-file-noselect (expand-file-name file org-directory))))) + +(defun org-capture-steal-local-variables (buffer) + "Install Org-mode local variables." + (mapc (lambda (v) + (ignore-errors (org-set-local (car v) (cdr v)))) + (buffer-local-variables buffer))) + +(defun org-capture-place-template () + "Insert the template at the target location, and display the buffer." + (org-capture-put :return-to-wconf (current-window-configuration)) + (delete-other-windows) + (org-switch-to-buffer-other-window + (org-capture-get-indirect-buffer (org-capture-get :buffer) "CAPTURE")) + (widen) + (show-all) + (goto-char (org-capture-get :pos)) + (org-set-local 'org-capture-target-marker + (move-marker (make-marker) (point))) + (let* ((template (org-capture-get :template)) + (type (org-capture-get :type))) + (case type + ((nil entry) (org-capture-place-entry)) + (table-line (org-capture-place-table-line)) + (plain (org-capture-place-plain-text)) + (item (org-capture-place-item)) + (checkitem (org-capture-place-item)))) + (org-capture-mode 1) + (org-set-local 'org-capture-current-plist org-capture-plist)) + +(defun org-capture-place-entry () + "Place the template as a new Org entry." + (let* ((txt (org-capture-get :template)) + (reversed (org-capture-get :prepend)) + (target-entry-p (org-capture-get :target-entry-p)) + level beg end file) + + (cond + ((org-capture-get :exact-position) + (goto-char (org-capture-get :exact-position))) + ((not target-entry-p) + ;; Insert as top-level entry, either at beginning or at end of file + (setq level 1) + (if reversed + (progn (goto-char (point-min)) + (or (org-at-heading-p) + (outline-next-heading))) + (goto-char (point-max)) + (or (bolp) (insert "\n")))) + (t + ;; Insert as a child of the current entry + (and (looking-at "\\*+") + (setq level (- (match-end 0) (match-beginning 0)))) + (setq level (org-get-valid-level (or level 1) 1)) + (if reversed + (progn + (outline-next-heading) + (or (bolp) (insert "\n"))) + (org-end-of-subtree t t) + (or (bolp) (insert "\n"))))) + (org-capture-empty-lines-before) + (setq beg (point)) + (org-paste-subtree level txt 'for-yank) + (org-capture-empty-lines-after 1) + (org-capture-position-for-last-stored beg) + (outline-next-heading) + (setq end (point)) + (org-capture-mark-kill-region beg (1- end)) + (org-capture-narrow beg (1- end)) + (goto-char beg) + (if (re-search-forward "%\\?" end t) (replace-match "")))) + +(defun org-capture-place-item () + "Place the template as a new plain list item." + (let* ((txt (org-capture-get :template)) + (target-entry-p (org-capture-get :target-entry-p)) + (ind 0) + beg end) + (cond + ((org-capture-get :exact-position) + (goto-char (org-capture-get :exact-position))) + ((not target-entry-p) + ;; Insert as top-level entry, either at beginning or at end of file + (setq beg (point-min) end (point-max))) + (t + (setq beg (1+ (point-at-eol)) + end (save-excursion (outline-next-heading) (point))))) + (if (org-capture-get :prepend) + (progn + (goto-char beg) + (if (org-search-forward-unenclosed org-item-beginning-re end t) + (progn + (goto-char (match-beginning 0)) + (setq ind (org-get-indentation))) + (goto-char end) + (setq ind 0))) + (goto-char end) + (if (org-search-backward-unenclosed org-item-beginning-re beg t) + (progn + (setq ind (org-get-indentation)) + (org-end-of-item)) + (setq ind 0))) + ;; Remove common indentation + (setq txt (org-remove-indentation txt)) + ;; Make sure this is indeed an item + (unless (string-match (concat "\\`" (org-item-re)) txt) + (setq txt (concat "- " + (mapconcat 'identity (split-string txt "\n") + "\n ")))) + ;; Set the correct indentation, depending on context + (setq ind (make-string ind ?\ )) + (setq txt (concat ind + (mapconcat 'identity (split-string txt "\n") + (concat "\n" ind)) + "\n")) + ;; Insert, with surrounding empty lines + (org-capture-empty-lines-before) + (setq beg (point)) + (insert txt) + (or (bolp) (insert "\n")) + (org-capture-empty-lines-after 1) + (org-capture-position-for-last-stored beg) + (forward-char 1) + (setq end (point)) + (org-capture-mark-kill-region beg (1- end)) + (org-capture-narrow beg (1- end)) + (if (re-search-forward "%\\?" end t) (replace-match "")))) + +(defun org-capture-place-table-line () + "Place the template as a table line." + (require 'org-table) + (let* ((txt (org-capture-get :template)) + (target-entry-p (org-capture-get :target-entry-p)) + (table-line-pos (org-capture-get :table-line-pos)) + ind beg end) + (cond + ((org-capture-get :exact-position) + (goto-char (org-capture-get :exact-position))) + ((not target-entry-p) + ;; Table is not necessarily under a heading + (setq beg (point-min) end (point-max))) + (t + ;; WE are at a heading, limit search to the body + (setq beg (1+ (point-at-eol)) + end (save-excursion (outline-next-heading) (point))))) + (if (re-search-forward org-table-dataline-regexp end t) + (let ((b (org-table-begin)) (e (org-table-end))) + (goto-char e) + (if (looking-at "[ \t]*#\\+TBLFM:") + (forward-line 1)) + (narrow-to-region b (point))) + (goto-char end) + (insert "\n| |\n|----|\n| |\n") + (narrow-to-region (1+ end) (point))) + ;; We are narrowed to the table, or to an empty line if there was no table + + ;; Check if the template is good + (if (not (string-match org-table-dataline-regexp txt)) + (setq txt "| %?Bad template |\n")) + (cond + ((and table-line-pos + (string-match "\\(I+\\)\\([-+][0-9]\\)" table-line-pos)) + ;; we have a complex line specification + (goto-char (point-min)) + (let ((nh (- (match-end 1) (match-beginning 1))) + (delta (string-to-number (match-string 2 table-line-pos))) + ll) + ;; The user wants a special position in the table + (org-table-get-specials) + (setq ll (ignore-errors (aref org-table-hlines nh))) + (unless ll (error "Invalid table line specification \"%s\"" + table-line-pos)) + (setq ll (+ ll delta (if (< delta 0) 0 -1))) + (org-goto-line ll) + (org-table-insert-row 'below) + (beginning-of-line 1) + (delete-region (point) (1+ (point-at-eol))) + (setq beg (point)) + (insert txt) + (setq end (point)))) + ((org-capture-get :prepend) + (goto-char (point-min)) + (re-search-forward org-table-hline-regexp nil t) + (beginning-of-line 1) + (re-search-forward org-table-dataline-regexp nil t) + (beginning-of-line 1) + (setq beg (point)) + (org-table-insert-row) + (beginning-of-line 1) + (delete-region (point) (1+ (point-at-eol))) + (insert txt) + (setq end (point))) + (t + (goto-char (point-max)) + (re-search-backward org-table-dataline-regexp nil t) + (beginning-of-line 1) + (org-table-insert-row 'below) + (beginning-of-line 1) + (delete-region (point) (1+ (point-at-eol))) + (setq beg (point)) + (insert txt) + (setq end (point)))) + (goto-char beg) + (org-capture-position-for-last-stored 'table-line) + (if (re-search-forward "%\\?" end t) (replace-match "")) + (org-table-align))) + +(defun org-capture-place-plain-text () + "Place the template plainly." + (let* ((txt (org-capture-get :template)) + beg end) + (goto-char (cond + ((org-capture-get :exact-position)) + ((org-capture-get :prepend) (point-min)) + (t (point-max)))) + (or (bolp) (newline)) + (org-capture-empty-lines-before) + (setq beg (point)) + (insert txt) + (org-capture-empty-lines-after 1) + (org-capture-position-for-last-stored beg) + (setq end (point)) + (org-capture-mark-kill-region beg (1- end)) + (org-capture-narrow beg (1- end)) + (if (re-search-forward "%\\?" end t) (replace-match "")))) + +(defun org-capture-mark-kill-region (beg end) + "Mark the region that will have to be killed when aborting capture." + (let ((m1 (move-marker (make-marker) beg)) + (m2 (move-marker (make-marker) end))) + (org-capture-put :begin-marker m1) + (org-capture-put :end-marker m2))) + +(defun org-capture-position-for-last-stored (where) + "Memorize the position that should later become the position of last capture." + (cond + ((integerp where) + (org-capture-put :position-for-last-stored + (move-marker (make-marker) where + (or (buffer-base-buffer (current-buffer)) + (current-buffer))))) + ((eq where 'table-line) + (org-capture-put :position-for-last-stored + (list 'table-line + (org-table-current-dline)))) + (t (error "This should not happen")))) + +(defun org-capture-bookmark-last-stored-position () + "Bookmark the last-captured position." + (let* ((where (org-capture-get :position-for-last-stored 'local)) + (pos (cond + ((markerp where) + (prog1 (marker-position where) + (move-marker where nil))) + ((and (listp where) (eq (car where) 'table-line)) + (if (org-at-table-p) + (save-excursion + (org-table-goto-line (nth 1 where)) + (point-at-bol)) + (point)))))) + (with-current-buffer (buffer-base-buffer (current-buffer)) + (save-excursion + (save-restriction + (widen) + (goto-char pos) + (bookmark-set "org-capture-last-stored") + (move-marker org-capture-last-stored-marker (point))))))) + +(defun org-capture-narrow (beg end) + "Narrow, unless configuration says not to narrow." + (unless (org-capture-get :unnarrowed) + (narrow-to-region beg end) + (goto-char beg))) + +(defun org-capture-empty-lines-before (&optional n) + "Arrange for the correct number of empty lines before the insertion point. +Point will be after the empty lines, so insertion can directly be done." + (setq n (or n (org-capture-get :empty-lines) 0)) + (let ((pos (point))) + (org-back-over-empty-lines) + (delete-region (point) pos) + (if (> n 0) (newline n)))) + +(defun org-capture-empty-lines-after (&optional n) + "Arrange for the correct number of empty lines after the inserted string. +Point will remain at the first line after the inserted text." + (setq n (or n (org-capture-get :empty-lines) 0)) + (org-back-over-empty-lines) + (while (looking-at "[ \t]*\n") (replace-match "")) + (let ((pos (point))) + (if (> n 0) (newline n)) + (goto-char pos))) + +(defvar org-clock-marker) ; Defined in org.el +;;;###autoload +(defun org-capture-insert-template-here () + (let* ((template (org-capture-get :template)) + (type (org-capture-get :type)) + beg end pp) + (or (bolp) (newline)) + (setq beg (point)) + (cond + ((and (eq type 'entry) (org-mode-p)) + (org-paste-subtree nil template t)) + ((and (memq type '(item checkitem)) + (org-mode-p) + (save-excursion (skip-chars-backward " \t\n") + (setq pp (point)) + (org-in-item-p))) + (goto-char pp) + (org-insert-item) + (skip-chars-backward " ") + (skip-chars-backward "-+*0123456789).") + (delete-region (point) (point-at-eol)) + (setq beg (point)) + (org-remove-indentation template) + (insert template) + (org-capture-empty-lines-after) + (goto-char beg) + (org-list-repair) + (org-end-of-item) + (setq end (point))) + (t (insert template))) + (setq end (point)) + (goto-char beg) + (if (re-search-forward "%\\?" end t) + (replace-match "")))) + +(defun org-capture-set-plist (entry) + "Initialize the property list from the template definition." + (setq org-capture-plist (copy-sequence (nthcdr 5 entry))) + (org-capture-put :key (car entry) :description (nth 1 entry) + :target (nth 3 entry)) + (let ((txt (nth 4 entry)) (type (or (nth 2 entry) 'entry))) + (when (or (not txt) (and (stringp txt) (not (string-match "\\S-" txt)))) + ;; The template may be empty or omitted for special types. + ;; Here we insert the default templates for such cases. + (cond + ((eq type 'item) (setq txt "- %?")) + ((eq type 'checkitem) (setq txt "- [ ] %?")) + ((eq type 'table-line) (setq txt "| %? |")) + ((member type '(nil entry)) (setq txt "* %?\n %a")))) + (org-capture-put :template txt :type type))) + +(defun org-capture-goto-target (&optional template-key) + "Go to the target location of a capture template. +The user is queried for the template." + (interactive) + (let* (org-select-template-temp-major-mode + (entry (org-capture-select-template template-key))) + (unless entry + (error "No capture template selected")) + (org-capture-set-plist entry) + (org-capture-set-target-location) + (switch-to-buffer (org-capture-get :buffer)) + (goto-char (org-capture-get :pos)))) + +(defun org-capture-get-indirect-buffer (&optional buffer prefix) + "Make an indirect buffer for a capture process. +Use PREFIX as a prefix for the name of the indirect buffer." + (setq buffer (or buffer (current-buffer))) + (let ((n 1) (base (buffer-name buffer)) bname) + (setq bname (concat prefix "-" base)) + (while (buffer-live-p (get-buffer bname)) + (setq bname (concat prefix "-" (number-to-string (incf n)) "-" base))) + (condition-case nil + (make-indirect-buffer buffer bname 'clone) + (error (make-indirect-buffer buffer bname))))) + + +;;; The template code + +(defun org-capture-select-template (&optional keys) + "Select a capture template. +Lisp programs can force the template by setting KEYS to a string." + (if org-capture-templates + (if keys + (or (assoc keys org-capture-templates) + (error "No capture template referred to by \"%s\" keys" keys)) + (if (= 1 (length org-capture-templates)) + (car org-capture-templates) + (org-mks org-capture-templates + "Select a capture template\n=========================" + "Template key: " + '(("C" "Customize org-capture-templates") + ("q" "Abort"))))) + ;; Use an arbitrary default template + '("t" "Task" entry (file+headline "" "Tasks") "* TODO %?\n %u\n %a"))) + +(defun org-capture-fill-template (&optional template initial annotation) + "Fill a template and return the filled template as a string. +The template may still contain \"%?\" for cursor positioning." + (setq template (or template (org-capture-get :template))) + (when (stringp initial) + (setq initial (org-no-properties initial)) + (remove-text-properties 0 (length initial) '(read-only t) initial)) + (let* ((buffer (org-capture-get :buffer)) + (file (buffer-file-name (or (buffer-base-buffer buffer) buffer))) + (ct (org-capture-get :default-time)) + (dct (decode-time ct)) + (ct1 + (if (< (nth 2 dct) org-extend-today-until) + (encode-time 0 59 23 (1- (nth 3 dct)) (nth 4 dct) (nth 5 dct)) + ct)) + (plist-p (if org-store-link-plist t nil)) + (v-c (and (> (length kill-ring) 0) (current-kill 0))) + (v-x (or (org-get-x-clipboard 'PRIMARY) + (org-get-x-clipboard 'CLIPBOARD) + (org-get-x-clipboard 'SECONDARY))) + (v-t (format-time-string (car org-time-stamp-formats) ct)) + (v-T (format-time-string (cdr org-time-stamp-formats) ct)) + (v-u (concat "[" (substring v-t 1 -1) "]")) + (v-U (concat "[" (substring v-T 1 -1) "]")) + ;; `initial' and `annotation' might habe been passed. + ;; But if the property list has them, we prefer those values + (v-i (or (plist-get org-store-link-plist :initial) + initial + (org-capture-get :initial) + "")) + (v-a (or (plist-get org-store-link-plist :annotation) + annotation + (org-capture-get :annotation) + "")) + ;; Is the link empty? Then we do not want it... + (v-a (if (equal v-a "[[]]") "" v-a)) + (clipboards (remove nil (list v-i + (org-get-x-clipboard 'PRIMARY) + (org-get-x-clipboard 'CLIPBOARD) + (org-get-x-clipboard 'SECONDARY) + v-c))) + (v-A (if (and v-a + (string-match + "\\[\\(\\[.*?\\]\\)\\(\\[.*?\\]\\)?\\]" v-a)) + (replace-match "[\\1[%^{Link description}]]" nil nil v-a) + v-a)) + (v-n user-full-name) + (v-k (if (marker-buffer org-clock-marker) + (org-substring-no-properties org-clock-heading))) + (v-K (if (marker-buffer org-clock-marker) + (org-make-link-string + (buffer-file-name (marker-buffer org-clock-marker)) + org-clock-heading))) + v-I + (org-startup-folded nil) + (org-inhibit-startup t) + org-time-was-given org-end-time-was-given x + prompt completions char time pos default histvar) + + (setq org-store-link-plist + (plist-put org-store-link-plist :annotation v-a) + org-store-link-plist + (plist-put org-store-link-plist :initial v-i)) + (setq initial v-i) + + (unless template (setq template "") (message "No template") (ding) + (sit-for 1)) + (save-window-excursion + (delete-other-windows) + (switch-to-buffer (get-buffer-create "*Capture*")) + (erase-buffer) + (insert template) + (goto-char (point-min)) + (org-capture-steal-local-variables buffer) + (setq buffer-file-name nil) + + ;; %[] Insert contents of a file. + (goto-char (point-min)) + (while (re-search-forward "%\\[\\(.+\\)\\]" nil t) + (unless (org-capture-escaped-%) + (let ((start (match-beginning 0)) + (end (match-end 0)) + (filename (expand-file-name (match-string 1)))) + (goto-char start) + (delete-region start end) + (condition-case error + (insert-file-contents filename) + (error (insert (format "%%![Couldn't insert %s: %s]" + filename error))))))) + ;; %() embedded elisp + (goto-char (point-min)) + (while (re-search-forward "%\\((.+)\\)" nil t) + (unless (org-capture-escaped-%) + (goto-char (match-beginning 0)) + (let ((template-start (point))) + (forward-char 1) + (let ((result + (condition-case error + (eval (read (current-buffer))) + (error (format "%%![Error: %s]" error))))) + (delete-region template-start (point)) + (insert result))))) + + ;; Simple %-escapes + (goto-char (point-min)) + (while (re-search-forward "%\\([tTuUaiAcxkKI]\\)" nil t) + (unless (org-capture-escaped-%) + (when (and initial (equal (match-string 0) "%i")) + (save-match-data + (let* ((lead (buffer-substring + (point-at-bol) (match-beginning 0)))) + (setq v-i (mapconcat 'identity + (org-split-string initial "\n") + (concat "\n" lead)))))) + (replace-match + (or (eval (intern (concat "v-" (match-string 1)))) "") + t t))) + + ;; From the property list + (when plist-p + (goto-char (point-min)) + (while (re-search-forward "%\\(:[-a-zA-Z]+\\)" nil t) + (unless (org-capture-escaped-%) + (and (setq x (or (plist-get org-store-link-plist + (intern (match-string 1))) "")) + (replace-match x t t))))) + + ;; Turn on org-mode in temp buffer, set local variables + ;; This is to support completion in interactive prompts + (let ((org-inhibit-startup t)) (org-mode)) + ;; Interactive template entries + (goto-char (point-min)) + (while (re-search-forward "%^\\({\\([^}]*\\)}\\)?\\([gGtTuUCLp]\\)?" + nil t) + (unless (org-capture-escaped-%) + (setq char (if (match-end 3) (match-string 3)) + prompt (if (match-end 2) (match-string 2))) + (goto-char (match-beginning 0)) + (replace-match "") + (setq completions nil default nil) + (when prompt + (setq completions (org-split-string prompt "|") + prompt (pop completions) + default (car completions) + histvar (intern (concat + "org-capture-template-prompt-history::" + (or prompt ""))) + completions (mapcar 'list completions))) + (unless (boundp histvar) (set histvar nil)) + (cond + ((member char '("G" "g")) + (let* ((org-last-tags-completion-table + (org-global-tags-completion-table + (if (equal char "G") + (org-agenda-files) + (and file (list file))))) + (org-add-colon-after-tag-completion t) + (ins (org-icompleting-read + (if prompt (concat prompt ": ") "Tags: ") + 'org-tags-completion-function nil nil nil + 'org-tags-history))) + (setq ins (mapconcat 'identity + (org-split-string + ins (org-re "[^[:alnum:]_@#%]+")) + ":")) + (when (string-match "\\S-" ins) + (or (equal (char-before) ?:) (insert ":")) + (insert ins) + (or (equal (char-after) ?:) (insert ":")) + (and (org-on-heading-p) (org-set-tags nil 'align))))) + ((equal char "C") + (cond ((= (length clipboards) 1) (insert (car clipboards))) + ((> (length clipboards) 1) + (insert (read-string "Clipboard/kill value: " + (car clipboards) '(clipboards . 1) + (car clipboards)))))) + ((equal char "L") + (cond ((= (length clipboards) 1) + (org-insert-link 0 (car clipboards))) + ((> (length clipboards) 1) + (org-insert-link 0 (read-string "Clipboard/kill value: " + (car clipboards) + '(clipboards . 1) + (car clipboards)))))) + ((equal char "p") + (let* + ((prop (org-substring-no-properties prompt)) + (pall (concat prop "_ALL")) + (allowed + (with-current-buffer + (get-buffer (file-name-nondirectory file)) + (or (cdr (assoc pall org-file-properties)) + (cdr (assoc pall org-global-properties)) + (cdr (assoc pall org-global-properties-fixed))))) + (existing (with-current-buffer + (get-buffer (file-name-nondirectory file)) + (mapcar 'list (org-property-values prop)))) + (propprompt (concat "Value for " prop ": ")) + (val (if allowed + (org-completing-read + propprompt + (mapcar 'list (org-split-string allowed + "[ \t]+")) + nil 'req-match) + (org-completing-read-no-i propprompt + existing nil nil + "" nil "")))) + (org-set-property prop val))) + (char + ;; These are the date/time related ones + (setq org-time-was-given (equal (upcase char) char)) + (setq time (org-read-date (equal (upcase char) char) t nil + prompt)) + (if (equal (upcase char) char) (setq org-time-was-given t)) + (org-insert-time-stamp time org-time-was-given + (member char '("u" "U")) + nil nil (list org-end-time-was-given))) + (t + (let (org-completion-use-ido) + (insert (org-completing-read-no-i + (concat (if prompt prompt "Enter string") + (if default (concat " [" default "]")) + ": ") + completions nil nil nil histvar default))))))) + ;; Make sure there are no empty lines before the text, and that + ;; it ends with a newline character + (goto-char (point-min)) + (while (looking-at "[ \t]*\n") (replace-match "")) + (if (re-search-forward "[ \t\n]*\\'" nil t) (replace-match "\n")) + ;; Return the expanded tempate and kill the temporary buffer + (untabify (point-min) (point-max)) + (set-buffer-modified-p nil) + (prog1 (buffer-string) (kill-buffer (current-buffer)))))) + +(defun org-capture-escaped-% () + "Check if % was escaped - if yes, unescape it now." + (if (equal (char-before (match-beginning 0)) ?\\) + (progn + (delete-region (1- (match-beginning 0)) (match-beginning 0)) + t) + nil)) + +;;;###autoload +(defun org-capture-import-remember-templates () + "Set org-capture-templates to be similar to `org-remember-templates'." + (interactive) + (when (and (yes-or-no-p + "Import old remember templates into org-capture-templates? ") + (yes-or-no-p + "Note that this will remove any templates currently defined in `org-capture-templates'. Do you still want to go ahead? ")) + (require 'org-remember) + (setq org-capture-templates + (mapcar + (lambda (entry) + (let ((desc (car entry)) + (key (char-to-string (nth 1 entry))) + (template (nth 2 entry)) + (file (or (nth 3 entry) org-default-notes-file)) + (position (or (nth 4 entry) org-remember-default-headline)) + (type 'entry) + (prepend org-reverse-note-order) + immediate target) + (cond + ((member position '(top bottom)) + (setq target (list 'file file) + prepend (eq position 'top))) + ((eq position 'date-tree) + (setq target (list 'file+datetree file) + prepend nil)) + (t (setq target (list 'file+headline file position)))) + + (when (string-match "%!" template) + (setq template (replace-match "" t t template) + immediate t)) + + (append (list key desc type target template) + (if prepend '(:prepend t)) + (if immediate '(:immediate-finish t))))) + + org-remember-templates)))) + +(provide 'org-capture) + +;; arch-tag: 986bf41b-8ada-4e28-bf20-e8388a7205a0 + +;;; org-capture.el ends here diff --git a/.emacs.d/org-7.4/lisp/org-capture.elc b/.emacs.d/org-7.4/lisp/org-capture.elc Binary files differnew file mode 100644 index 0000000..1341270 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-capture.elc diff --git a/.emacs.d/org-7.4/lisp/org-clock.el b/.emacs.d/org-7.4/lisp/org-clock.el new file mode 100644 index 0000000..93b0b52 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-clock.el @@ -0,0 +1,2499 @@ +;;; org-clock.el --- The time clocking code for Org-mode + +;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010 +;; Free Software Foundation, Inc. + +;; Author: Carsten Dominik <carsten at orgmode dot org> +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; Version: 7.4 +;; +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: + +;; This file contains the time clocking code for Org-mode + +(require 'org) +;;; Code: + +(eval-when-compile + (require 'cl)) + +(declare-function calendar-absolute-from-iso "cal-iso" (&optional date)) +(declare-function notifications-notify "notifications" (&rest params)) +(defvar org-time-stamp-formats) + +(defgroup org-clock nil + "Options concerning clocking working time in Org-mode." + :tag "Org Clock" + :group 'org-progress) + +(defcustom org-clock-into-drawer org-log-into-drawer + "Should clocking info be wrapped into a drawer? +When t, clocking info will always be inserted into a :LOGBOOK: drawer. +If necessary, the drawer will be created. +When nil, the drawer will not be created, but used when present. +When an integer and the number of clocking entries in an item +reaches or exceeds this number, a drawer will be created. +When a string, it names the drawer to be used. + +The default for this variable is the value of `org-log-into-drawer', +which see." + :group 'org-todo + :group 'org-clock + :type '(choice + (const :tag "Always" t) + (const :tag "Only when drawer exists" nil) + (integer :tag "When at least N clock entries") + (const :tag "Into LOGBOOK drawer" "LOGBOOK") + (string :tag "Into Drawer named..."))) + +(defcustom org-clock-out-when-done t + "When non-nil, clock will be stopped when the clocked entry is marked DONE. +DONE here means any DONE-like state. +A nil value means clock will keep running until stopped explicitly with +`C-c C-x C-o', or until the clock is started in a different item. +Instead of t, this can also be a list of TODO states that should trigger +clocking out." + :group 'org-clock + :type '(choice + (const :tag "No" nil) + (const :tag "Yes, when done" t) + (repeat :tag "State list" + (string :tag "TODO keyword")))) + +(defcustom org-clock-out-remove-zero-time-clocks nil + "Non-nil means remove the clock line when the resulting time is zero." + :group 'org-clock + :type 'boolean) + +(defcustom org-clock-in-switch-to-state nil + "Set task to a special todo state while clocking it. +The value should be the state to which the entry should be +switched. If the value is a function, it must take one +parameter (the current TODO state of the item) and return the +state to switch it to." + :group 'org-clock + :group 'org-todo + :type '(choice + (const :tag "Don't force a state" nil) + (string :tag "State") + (symbol :tag "Function"))) + +(defcustom org-clock-out-switch-to-state nil + "Set task to a special todo state after clocking out. +The value should be the state to which the entry should be +switched. If the value is a function, it must take one +parameter (the current TODO state of the item) and return the +state to switch it to." + :group 'org-clock + :group 'org-todo + :type '(choice + (const :tag "Don't force a state" nil) + (string :tag "State") + (symbol :tag "Function"))) + +(defcustom org-clock-history-length 5 + "Number of clock tasks to remember in history." + :group 'org-clock + :type 'integer) + +(defcustom org-clock-goto-may-find-recent-task t + "Non-nil means `org-clock-goto' can go to recent task if no active clock." + :group 'org-clock + :type 'boolean) + +(defcustom org-clock-heading-function nil + "When non-nil, should be a function to create `org-clock-heading'. +This is the string shown in the mode line when a clock is running. +The function is called with point at the beginning of the headline." + :group 'org-clock + :type 'function) + +(defcustom org-clock-string-limit 0 + "Maximum length of clock strings in the modeline. 0 means no limit." + :group 'org-clock + :type 'integer) + +(defcustom org-clock-in-resume nil + "If non-nil, resume clock when clocking into task with open clock. +When clocking into a task with a clock entry which has not been closed, +the clock can be resumed from that point." + :group 'org-clock + :type 'boolean) + +(defcustom org-clock-persist nil + "When non-nil, save the running clock when Emacs is closed. +The clock is resumed when Emacs restarts. +When this is t, both the running clock, and the entire clock +history are saved. When this is the symbol `clock', only the +running clock is saved. + +When Emacs restarts with saved clock information, the file containing the +running clock as well as all files mentioned in the clock history will +be visited. +All this depends on running `org-clock-persistence-insinuate' in .emacs" + :group 'org-clock + :type '(choice + (const :tag "Just the running clock" clock) + (const :tag "Just the history" history) + (const :tag "Clock and history" t) + (const :tag "No persistence" nil))) + +(defcustom org-clock-persist-file (convert-standard-filename + "~/.emacs.d/org-clock-save.el") + "File to save clock data to." + :group 'org-clock + :type 'string) + +(defcustom org-clock-persist-query-save nil + "When non-nil, ask before saving the current clock on exit." + :group 'org-clock + :type 'boolean) + +(defcustom org-clock-persist-query-resume t + "When non-nil, ask before resuming any stored clock during load." + :group 'org-clock + :type 'boolean) + +(defcustom org-clock-sound nil + "Sound that will used for notifications. +Possible values: + +nil no sound played. +t standard Emacs beep +file name play this sound file. If not possible, fall back to beep" + :group 'org-clock + :type '(choice + (const :tag "No sound" nil) + (const :tag "Standard beep" t) + (file :tag "Play sound file"))) + +(defcustom org-clock-modeline-total 'auto + "Default setting for the time included for the modeline clock. +This can be overruled locally using the CLOCK_MODELINE_TOTAL property. +Allowed values are: + +current Only the time in the current instance of the clock +today All time clocked into this task today +repeat All time clocked into this task since last repeat +all All time ever recorded for this task +auto Automatically, either `all', or `repeat' for repeating tasks" + :group 'org-clock + :type '(choice + (const :tag "Current clock" current) + (const :tag "Today's task time" today) + (const :tag "Since last repeat" repeat) + (const :tag "All task time" all) + (const :tag "Automatically, `all' or since `repeat'" auto))) + +(defcustom org-task-overrun-text nil + "The extra modeline text that should indicate that the clock is overrun. +The can be nil to indicate that instead of adding text, the clock time +should get a different face (`org-mode-line-clock-overrun'). +When this is a string, it is prepended to the clock string as an indication, +also using the face `org-mode-line-clock-overrun'." + :group 'org-clock + :type '(choice + (const :tag "Just mark the time string" nil) + (string :tag "Text to prepend"))) + +(defcustom org-show-notification-handler nil + "Function or program to send notification with. +The function or program will be called with the notification +string as argument." + :group 'org-clock + :type '(choice + (string :tag "Program") + (function :tag "Function"))) + +(defgroup org-clocktable nil + "Options concerning the clock table in Org-mode." + :tag "Org Clock Table" + :group 'org-clock) + +(defcustom org-clocktable-defaults + (list + :maxlevel 2 + :scope 'file + :block nil + :tstart nil + :tend nil + :step nil + :stepskip0 nil + :fileskip0 nil + :tags nil + :emphasize nil + :link nil + :narrow '40! + :indent t + :formula nil + :timestamp nil + :level nil + :tcolumns nil + :formatter nil) + "Default properties for clock tables." + :group 'org-clock + :type 'plist) + +(defcustom org-clock-clocktable-formatter 'org-clocktable-write-default + "Function to turn clocking data into a table. +For more information, see `org-clocktable-write-default'." + :group 'org-clocktable + :type 'function) + +(defcustom org-clock-clocktable-default-properties '(:maxlevel 2 :scope file) + "Default properties for new clocktables. +These will be inserted into the BEGIN line, to make it easy for users to +play with them." + :group 'org-clocktable + :type 'plist) + +(defcustom org-clock-idle-time nil + "When non-nil, resolve open clocks if the user is idle more than X minutes." + :group 'org-clock + :type '(choice + (const :tag "Never" nil) + (integer :tag "After N minutes"))) + +(defcustom org-clock-auto-clock-resolution 'when-no-clock-is-running + "When to automatically resolve open clocks found in Org buffers." + :group 'org-clock + :type '(choice + (const :tag "Never" nil) + (const :tag "Always" t) + (const :tag "When no clock is running" when-no-clock-is-running))) + +(defcustom org-clock-report-include-clocking-task nil + "When non-nil, include the current clocking task time in clock reports." + :group 'org-clock + :type 'boolean) + +(defcustom org-clock-resolve-expert nil + "Non-nil means do not show the splash buffer with the clock resolver." + :group 'org-clock + :type 'boolean) + +(defvar org-clock-in-prepare-hook nil + "Hook run when preparing the clock. +This hook is run before anything happens to the task that +you want to clock in. For example, you can use this hook +to add an effort property.") +(defvar org-clock-in-hook nil + "Hook run when starting the clock.") +(defvar org-clock-out-hook nil + "Hook run when stopping the current clock.") + +(defvar org-clock-cancel-hook nil + "Hook run when cancelling the current clock.") +(defvar org-clock-goto-hook nil + "Hook run when selecting the currently clocked-in entry.") +(defvar org-clock-has-been-used nil + "Has the clock been used during the current Emacs session?") + +;;; The clock for measuring work time. + +(defvar org-mode-line-string "") +(put 'org-mode-line-string 'risky-local-variable t) + +(defvar org-clock-mode-line-timer nil) +(defvar org-clock-idle-timer nil) +(defvar org-clock-heading) ; defined in org.el +(defvar org-clock-heading-for-remember "") +(defvar org-clock-start-time "") + +(defvar org-clock-leftover-time nil + "If non-nil, user cancelled a clock; this is when leftover time started.") + +(defvar org-clock-effort "" + "Effort estimate of the currently clocking task.") + +(defvar org-clock-total-time nil + "Holds total time, spent previously on currently clocked item. +This does not include the time in the currently running clock.") + +(defvar org-clock-history nil + "List of marker pointing to recent clocked tasks.") + +(defvar org-clock-default-task (make-marker) + "Marker pointing to the default task that should clock time. +The clock can be made to switch to this task after clocking out +of a different task.") + +(defvar org-clock-interrupted-task (make-marker) + "Marker pointing to the task that has been interrupted by the current clock.") + +(defvar org-clock-mode-line-map (make-sparse-keymap)) +(define-key org-clock-mode-line-map [mode-line mouse-2] 'org-clock-goto) +(define-key org-clock-mode-line-map [mode-line mouse-1] 'org-clock-menu) + +(defun org-clock-menu () + (interactive) + (popup-menu + '("Clock" + ["Clock out" org-clock-out t] + ["Change effort estimate" org-clock-modify-effort-estimate t] + ["Go to clock entry" org-clock-goto t] + ["Switch task" (lambda () (interactive) (org-clock-in '(4))) :active t :keys "C-u C-c C-x C-i"]))) + +(defun org-clock-history-push (&optional pos buffer) + "Push a marker to the clock history." + (setq org-clock-history-length (max 1 (min 35 org-clock-history-length))) + (let ((m (move-marker (make-marker) + (or pos (point)) (org-base-buffer + (or buffer (current-buffer))))) + n l) + (while (setq n (member m org-clock-history)) + (move-marker (car n) nil)) + (setq org-clock-history + (delq nil + (mapcar (lambda (x) (if (marker-buffer x) x nil)) + org-clock-history))) + (when (>= (setq l (length org-clock-history)) org-clock-history-length) + (setq org-clock-history + (nreverse + (nthcdr (- l org-clock-history-length -1) + (nreverse org-clock-history))))) + (push m org-clock-history))) + +(defun org-clock-save-markers-for-cut-and-paste (beg end) + "Save relative positions of markers in region." + (org-check-and-save-marker org-clock-marker beg end) + (org-check-and-save-marker org-clock-hd-marker beg end) + (org-check-and-save-marker org-clock-default-task beg end) + (org-check-and-save-marker org-clock-interrupted-task beg end) + (mapc (lambda (m) (org-check-and-save-marker m beg end)) + org-clock-history)) + +(defun org-clocking-buffer () + "Return the clocking buffer if we are currently clocking a task or nil." + (marker-buffer org-clock-marker)) + +(defun org-clocking-p () + "Return t when clocking a task." + (not (equal (org-clocking-buffer) nil))) + +(defun org-clock-select-task (&optional prompt) + "Select a task that recently was associated with clocking." + (interactive) + (let (sel-list rpl (i 0) s) + (save-window-excursion + (org-switch-to-buffer-other-window + (get-buffer-create "*Clock Task Select*")) + (erase-buffer) + (when (marker-buffer org-clock-default-task) + (insert (org-add-props "Default Task\n" nil 'face 'bold)) + (setq s (org-clock-insert-selection-line ?d org-clock-default-task)) + (push s sel-list)) + (when (marker-buffer org-clock-interrupted-task) + (insert (org-add-props "The task interrupted by starting the last one\n" nil 'face 'bold)) + (setq s (org-clock-insert-selection-line ?i org-clock-interrupted-task)) + (push s sel-list)) + (when (org-clocking-p) + (insert (org-add-props "Current Clocking Task\n" nil 'face 'bold)) + (setq s (org-clock-insert-selection-line ?c org-clock-marker)) + (push s sel-list)) + (insert (org-add-props "Recent Tasks\n" nil 'face 'bold)) + (mapc + (lambda (m) + (when (marker-buffer m) + (setq i (1+ i) + s (org-clock-insert-selection-line + (if (< i 10) + (+ i ?0) + (+ i (- ?A 10))) m)) + (if (fboundp 'int-to-char) (setf (car s) (int-to-char (car s)))) + (push s sel-list))) + org-clock-history) + (org-fit-window-to-buffer) + (message (or prompt "Select task for clocking:")) + (setq rpl (read-char-exclusive)) + (cond + ((eq rpl ?q) nil) + ((eq rpl ?x) nil) + ((assoc rpl sel-list) (cdr (assoc rpl sel-list))) + (t (error "Invalid task choice %c" rpl)))))) + +(defun org-clock-insert-selection-line (i marker) + "Insert a line for the clock selection menu. +And return a cons cell with the selection character integer and the marker +pointing to it." + (when (marker-buffer marker) + (let (file cat task heading prefix) + (with-current-buffer (org-base-buffer (marker-buffer marker)) + (save-excursion + (save-restriction + (widen) + (ignore-errors + (goto-char marker) + (setq file (buffer-file-name (marker-buffer marker)) + cat (or (org-get-category) + (progn (org-refresh-category-properties) + (org-get-category))) + heading (org-get-heading 'notags) + prefix (save-excursion + (org-back-to-heading t) + (looking-at "\\*+ ") + (match-string 0)) + task (substring + (org-fontify-like-in-org-mode + (concat prefix heading) + org-odd-levels-only) + (length prefix))))))) + (when (and cat task) + (insert (format "[%c] %-15s %s\n" i cat task)) + (cons i marker))))) + +(defvar org-task-overrun nil + "Internal flag indicating if the clock has overrun the planned time.") +(defvar org-clock-update-period 60 + "Number of seconds between mode line clock string updates.") + +(defun org-clock-get-clock-string () + "Form a clock-string, that will be shown in the mode line. +If an effort estimate was defined for the current item, use +01:30/01:50 format (clocked/estimated). +If not, show simply the clocked time like 01:50." + (let* ((clocked-time (org-clock-get-clocked-time)) + (h (floor clocked-time 60)) + (m (- clocked-time (* 60 h)))) + (if org-clock-effort + (let* ((effort-in-minutes + (org-hh:mm-string-to-minutes org-clock-effort)) + (effort-h (floor effort-in-minutes 60)) + (effort-m (- effort-in-minutes (* effort-h 60))) + (work-done-str + (org-propertize + (format org-time-clocksum-format h m) + 'face (if (and org-task-overrun (not org-task-overrun-text)) + 'org-mode-line-clock-overrun 'org-mode-line-clock))) + (effort-str (format org-time-clocksum-format effort-h effort-m)) + (clockstr (org-propertize + (concat "[%s/" effort-str + "] (" (replace-regexp-in-string "%" "%%" org-clock-heading) ")") + 'face 'org-mode-line-clock))) + (format clockstr work-done-str)) + (org-propertize (format + (concat "[" org-time-clocksum-format " (%s)]") + h m org-clock-heading) + 'face 'org-mode-line-clock)))) + +(defun org-clock-update-mode-line () + (if org-clock-effort + (org-clock-notify-once-if-expired) + (setq org-task-overrun nil)) + (setq org-mode-line-string + (org-propertize + (let ((clock-string (org-clock-get-clock-string)) + (help-text "Org-mode clock is running.\nmouse-1 shows a menu\nmouse-2 will jump to task")) + (if (and (> org-clock-string-limit 0) + (> (length clock-string) org-clock-string-limit)) + (org-propertize + (substring clock-string 0 org-clock-string-limit) + 'help-echo (concat help-text ": " org-clock-heading)) + (org-propertize clock-string 'help-echo help-text))) + 'local-map org-clock-mode-line-map + 'mouse-face (if (featurep 'xemacs) 'highlight 'mode-line-highlight) + )) + (if (and org-task-overrun org-task-overrun-text) + (setq org-mode-line-string + (concat (org-propertize + org-task-overrun-text + 'face 'org-mode-line-clock-overrun) org-mode-line-string))) + (force-mode-line-update)) + +(defun org-clock-get-clocked-time () + "Get the clocked time for the current item in minutes. +The time returned includes the time spent on this task in +previous clocking intervals." + (let ((currently-clocked-time + (floor (- (org-float-time) + (org-float-time org-clock-start-time)) 60))) + (+ currently-clocked-time (or org-clock-total-time 0)))) + +(defun org-clock-modify-effort-estimate (&optional value) + "Add to or set the effort estimate of the item currently being clocked. +VALUE can be a number of minutes, or a string with format hh:mm or mm. +When the string starts with a + or a - sign, the current value of the effort +property will be changed by that amount. +This will update the \"Effort\" property of currently clocked item, and +the mode line." + (interactive) + (when (org-clock-is-active) + (let ((current org-clock-effort) sign) + (unless value + ;; Prompt user for a value or a change + (setq value + (read-string + (format "Set effort (hh:mm or mm%s): " + (if current + (format ", prefix + to add to %s" org-clock-effort) + ""))))) + (when (stringp value) + ;; A string. See if it is a delta + (setq sign (string-to-char value)) + (if (member sign '(?- ?+)) + (setq current (org-hh:mm-string-to-minutes current) + value (substring value 1)) + (setq current 0)) + (setq value (org-hh:mm-string-to-minutes value)) + (if (equal ?- sign) + (setq value (- current value)) + (if (equal ?+ sign) (setq value (+ current value))))) + (setq value (max 0 value) + org-clock-effort (org-minutes-to-hh:mm-string value)) + (org-entry-put org-clock-marker "Effort" org-clock-effort) + (org-clock-update-mode-line) + (message "Effort is now %s" org-clock-effort)))) + +(defvar org-clock-notification-was-shown nil + "Shows if we have shown notification already.") + +(defun org-clock-notify-once-if-expired () + "Show notification if we spent more time than we estimated before. +Notification is shown only once." + (when (org-clocking-p) + (let ((effort-in-minutes (org-hh:mm-string-to-minutes org-clock-effort)) + (clocked-time (org-clock-get-clocked-time))) + (if (setq org-task-overrun + (if (or (null effort-in-minutes) (zerop effort-in-minutes)) + nil + (>= clocked-time effort-in-minutes))) + (unless org-clock-notification-was-shown + (setq org-clock-notification-was-shown t) + (org-notify + (format "Task '%s' should be finished by now. (%s)" + org-clock-heading org-clock-effort) t)) + (setq org-clock-notification-was-shown nil))))) + +(defun org-notify (notification &optional play-sound) + "Send a NOTIFICATION and maybe PLAY-SOUND." + (org-show-notification notification) + (if play-sound (org-clock-play-sound))) + +(defun org-show-notification (notification) + "Show notification. +Use `org-show-notification-handler' if defined, +use libnotify if available, or fall back on a message." + (cond ((functionp org-show-notification-handler) + (funcall org-show-notification-handler notification)) + ((stringp org-show-notification-handler) + (start-process "emacs-timer-notification" nil + org-show-notification-handler notification)) + ((featurep 'notifications) + (require 'notifications) + (notifications-notify + :title "Org-mode message" + :body notification + ;; FIXME how to link to the Org icon? + ;; :app-icon "~/.emacs.d/icons/mail.png" + :urgency 'low)) + ((org-program-exists "notify-send") + (start-process "emacs-timer-notification" nil + "notify-send" notification)) + ;; Maybe the handler will send a message, so only use message as + ;; a fall back option + (t (message "%s" notification)))) + +(defun org-clock-play-sound () + "Play sound as configured by `org-clock-sound'. +Use alsa's aplay tool if available." + (cond + ((not org-clock-sound)) + ((eq org-clock-sound t) (beep t) (beep t)) + ((stringp org-clock-sound) + (let ((file (expand-file-name org-clock-sound))) + (if (file-exists-p file) + (if (org-program-exists "aplay") + (start-process "org-clock-play-notification" nil + "aplay" file) + (condition-case nil + (play-sound-file file) + (error (beep t) (beep t))))))))) + +(defun org-program-exists (program-name) + "Checks whenever we can locate program and launch it." + (if (eq system-type 'gnu/linux) + (= 0 (call-process "which" nil nil nil program-name)))) + +(defvar org-clock-mode-line-entry nil + "Information for the modeline about the running clock.") + +(defun org-find-open-clocks (file) + "Search through the given file and find all open clocks." + (let ((buf (or (get-file-buffer file) + (find-file-noselect file))) + clocks) + (with-current-buffer buf + (save-excursion + (goto-char (point-min)) + (while (re-search-forward "CLOCK: \\(\\[.*?\\]\\)$" nil t) + (push (cons (copy-marker (match-end 1) t) + (org-time-string-to-time (match-string 1))) clocks)))) + clocks)) + +(defsubst org-is-active-clock (clock) + "Return t if CLOCK is the currently active clock." + (and (org-clock-is-active) + (= org-clock-marker (car clock)))) + +(defmacro org-with-clock-position (clock &rest forms) + "Evaluate FORMS with CLOCK as the current active clock." + `(with-current-buffer (marker-buffer (car ,clock)) + (save-excursion + (save-restriction + (widen) + (goto-char (car ,clock)) + (beginning-of-line) + ,@forms)))) + +(put 'org-with-clock-position 'lisp-indent-function 1) + +(defmacro org-with-clock (clock &rest forms) + "Evaluate FORMS with CLOCK as the current active clock. +This macro also protects the current active clock from being altered." + `(org-with-clock-position ,clock + (let ((org-clock-start-time (cdr ,clock)) + (org-clock-total-time) + (org-clock-history) + (org-clock-effort) + (org-clock-marker (car ,clock)) + (org-clock-hd-marker (save-excursion + (outline-back-to-heading t) + (point-marker)))) + ,@forms))) + +(put 'org-with-clock 'lisp-indent-function 1) + +(defsubst org-clock-clock-in (clock &optional resume start-time) + "Clock in to the clock located by CLOCK. +If necessary, clock-out of the currently active clock." + (org-with-clock-position clock + (let ((org-clock-in-resume (or resume org-clock-in-resume))) + (org-clock-in nil start-time)))) + +(defsubst org-clock-clock-out (clock &optional fail-quietly at-time) + "Clock out of the clock located by CLOCK." + (let ((temp (copy-marker (car clock) + (marker-insertion-type (car clock))))) + (if (org-is-active-clock clock) + (org-clock-out fail-quietly at-time) + (org-with-clock clock + (org-clock-out fail-quietly at-time))) + (setcar clock temp))) + +(defsubst org-clock-clock-cancel (clock) + "Cancel the clock located by CLOCK." + (let ((temp (copy-marker (car clock) + (marker-insertion-type (car clock))))) + (if (org-is-active-clock clock) + (org-clock-cancel) + (org-with-clock clock + (org-clock-cancel))) + (setcar clock temp))) + +(defvar org-clock-clocking-in nil) +(defvar org-clock-resolving-clocks nil) +(defvar org-clock-resolving-clocks-due-to-idleness nil) + +(defun org-clock-resolve-clock (clock resolve-to clock-out-time + &optional close-p restart-p fail-quietly) + "Resolve `CLOCK' given the time `RESOLVE-TO', and the present. +`CLOCK' is a cons cell of the form (MARKER START-TIME)." + (let ((org-clock-resolving-clocks t)) + (cond + ((null resolve-to) + (org-clock-clock-cancel clock) + (if (and restart-p (not org-clock-clocking-in)) + (org-clock-clock-in clock))) + + ((eq resolve-to 'now) + (if restart-p + (error "RESTART-P is not valid here")) + (if (or close-p org-clock-clocking-in) + (org-clock-clock-out clock fail-quietly) + (unless (org-is-active-clock clock) + (org-clock-clock-in clock t)))) + + ((not (time-less-p resolve-to (current-time))) + (error "RESOLVE-TO must refer to a time in the past")) + + (t + (if restart-p + (error "RESTART-P is not valid here")) + (org-clock-clock-out clock fail-quietly (or clock-out-time + resolve-to)) + (unless org-clock-clocking-in + (if close-p + (setq org-clock-leftover-time (and (null clock-out-time) + resolve-to)) + (org-clock-clock-in clock nil (and clock-out-time + resolve-to)))))))) + +(defun org-clock-jump-to-current-clock (&optional effective-clock) + (interactive) + (let ((clock (or effective-clock (cons org-clock-marker + org-clock-start-time)))) + (unless (marker-buffer (car clock)) + (error "No clock is currently running")) + (org-with-clock clock (org-clock-goto)) + (with-current-buffer (marker-buffer (car clock)) + (goto-char (car clock)) + (if org-clock-into-drawer + (let ((logbook + (if (stringp org-clock-into-drawer) + (concat ":" org-clock-into-drawer ":") + ":LOGBOOK:"))) + (ignore-errors + (outline-flag-region + (save-excursion + (outline-back-to-heading t) + (search-forward logbook) + (goto-char (match-beginning 0))) + (save-excursion + (outline-back-to-heading t) + (search-forward logbook) + (search-forward ":END:") + (goto-char (match-end 0))) + nil))))))) + +(defun org-clock-resolve (clock &optional prompt-fn last-valid fail-quietly) + "Resolve an open org-mode clock. +An open clock was found, with `dangling' possibly being non-nil. +If this function was invoked with a prefix argument, non-dangling +open clocks are ignored. The given clock requires some sort of +user intervention to resolve it, either because a clock was left +dangling or due to an idle timeout. The clock resolution can +either be: + + (a) deleted, the user doesn't care about the clock + (b) restarted from the current time (if no other clock is open) + (c) closed, giving the clock X minutes + (d) closed and then restarted + (e) resumed, as if the user had never left + +The format of clock is (CONS MARKER START-TIME), where MARKER +identifies the buffer and position the clock is open at (and +thus, the heading it's under), and START-TIME is when the clock +was started." + (assert clock) + (let* ((ch + (save-window-excursion + (save-excursion + (unless org-clock-resolving-clocks-due-to-idleness + (org-clock-jump-to-current-clock clock)) + (unless org-clock-resolve-expert + (with-output-to-temp-buffer "*Org Clock*" + (princ "Select a Clock Resolution Command: + +i/q/C-g Ignore this question; the same as keeping all the idle time. + +k/K Keep X minutes of the idle time (default is all). If this + amount is less than the default, you will be clocked out + that many minutes after the time that idling began, and then + clocked back in at the present time. +g/G Indicate that you \"got back\" X minutes ago. This is quite + different from 'k': it clocks you out from the beginning of + the idle period and clock you back in X minutes ago. +s/S Subtract the idle time from the current clock. This is the + same as keeping 0 minutes. +C Cancel the open timer altogether. It will be as though you + never clocked in. +j/J Jump to the current clock, to make manual adjustments. + +For all these options, using uppercase makes your final state +to be CLOCKED OUT."))) + (org-fit-window-to-buffer (get-buffer-window "*Org Clock*")) + (let (char-pressed) + (when (featurep 'xemacs) + (message (concat (funcall prompt-fn clock) + " [jkKgGsScCiq]? ")) + (setq char-pressed (read-char-exclusive))) + (while (or (null char-pressed) + (and (not (memq char-pressed + '(?k ?K ?g ?G ?s ?S ?C + ?j ?J ?i ?q))) + (or (ding) t))) + (setq char-pressed + (read-char (concat (funcall prompt-fn clock) + " [jkKgGSscCiq]? ") + nil 45))) + (and (not (memq char-pressed '(?i ?q))) char-pressed))))) + (default + (floor (/ (org-float-time + (time-subtract (current-time) last-valid)) 60))) + (keep + (and (memq ch '(?k ?K)) + (read-number "Keep how many minutes? " default))) + (gotback + (and (memq ch '(?g ?G)) + (read-number "Got back how many minutes ago? " default))) + (subtractp (memq ch '(?s ?S))) + (barely-started-p (< (- (org-float-time last-valid) + (org-float-time (cdr clock))) 45)) + (start-over (and subtractp barely-started-p))) + (cond + ((memq ch '(?j ?J)) + (if (eq ch ?J) + (org-clock-resolve-clock clock 'now nil t nil fail-quietly)) + (org-clock-jump-to-current-clock clock)) + ((or (null ch) + (not (memq ch '(?k ?K ?g ?G ?s ?S ?C)))) + (message "")) + (t + (org-clock-resolve-clock + clock (cond + ((or (eq ch ?C) + ;; If the time on the clock was less than a minute before + ;; the user went away, and they've ask to subtract all the + ;; time... + start-over) + nil) + ((or subtractp + (and gotback (= gotback 0))) + last-valid) + ((or (and keep (= keep default)) + (and gotback (= gotback default))) + 'now) + (keep + (time-add last-valid (seconds-to-time (* 60 keep)))) + (gotback + (time-subtract (current-time) + (seconds-to-time (* 60 gotback)))) + (t + (error "Unexpected, please report this as a bug"))) + (and gotback last-valid) + (memq ch '(?K ?G ?S)) + (and start-over + (not (memq ch '(?K ?G ?S ?C)))) + fail-quietly))))) + +(defun org-resolve-clocks (&optional only-dangling-p prompt-fn last-valid) + "Resolve all currently open org-mode clocks. +If `only-dangling-p' is non-nil, only ask to resolve dangling +\(i.e., not currently open and valid) clocks." + (interactive "P") + (unless org-clock-resolving-clocks + (let ((org-clock-resolving-clocks t)) + (dolist (file (org-files-list)) + (let ((clocks (org-find-open-clocks file))) + (dolist (clock clocks) + (let ((dangling (or (not (org-clock-is-active)) + (/= (car clock) org-clock-marker)))) + (if (or (not only-dangling-p) dangling) + (org-clock-resolve + clock + (or prompt-fn + (function + (lambda (clock) + (format + "Dangling clock started %d mins ago" + (floor + (/ (- (org-float-time (current-time)) + (org-float-time (cdr clock))) 60)))))) + (or last-valid + (cdr clock))))))))))) + +(defun org-emacs-idle-seconds () + "Return the current Emacs idle time in seconds, or nil if not idle." + (let ((idle-time (current-idle-time))) + (if idle-time + (org-float-time idle-time) + 0))) + +(defun org-mac-idle-seconds () + "Return the current Mac idle time in seconds." + (string-to-number (shell-command-to-string "ioreg -c IOHIDSystem | perl -ane 'if (/Idle/) {$idle=(pop @F)/1000000000; print $idle; last}'"))) + +(defun org-x11-idle-seconds () + "Return the current X11 idle time in seconds." + (/ (string-to-number (shell-command-to-string "x11idle")) 1000)) + +(defun org-user-idle-seconds () + "Return the number of seconds the user has been idle for. +This routine returns a floating point number." + (cond + ((eq system-type 'darwin) + (org-mac-idle-seconds)) + ((eq window-system 'x) + (org-x11-idle-seconds)) + (t + (org-emacs-idle-seconds)))) + +(defvar org-clock-user-idle-seconds) + +(defun org-resolve-clocks-if-idle () + "Resolve all currently open org-mode clocks. +This is performed after `org-clock-idle-time' minutes, to check +if the user really wants to stay clocked in after being idle for +so long." + (when (and org-clock-idle-time (not org-clock-resolving-clocks) + org-clock-marker) + (let* ((org-clock-user-idle-seconds (org-user-idle-seconds)) + (org-clock-user-idle-start + (time-subtract (current-time) + (seconds-to-time org-clock-user-idle-seconds))) + (org-clock-resolving-clocks-due-to-idleness t)) + (if (> org-clock-user-idle-seconds (* 60 org-clock-idle-time)) + (org-clock-resolve + (cons org-clock-marker + org-clock-start-time) + (function + (lambda (clock) + (format "Clocked in & idle for %.1f mins" + (/ (org-float-time + (time-subtract (current-time) + org-clock-user-idle-start)) + 60.0)))) + org-clock-user-idle-start))))) + +(defun org-clock-in (&optional select start-time) + "Start the clock on the current item. +If necessary, clock-out of the currently active clock. +With a prefix argument SELECT (\\[universal-argument]), offer a list of \ +recently clocked tasks to +clock into. When SELECT is \\[universal-argument] \\[universal-argument], \ +clock into the current task and mark +is as the default task, a special task that will always be offered in +the clocking selection, associated with the letter `d'." + (interactive "P") + (setq org-clock-notification-was-shown nil) + (catch 'abort + (let ((interrupting (and (not org-clock-resolving-clocks-due-to-idleness) + (org-clocking-p))) + ts selected-task target-pos (msg-extra "") + (leftover (and (not org-clock-resolving-clocks) + org-clock-leftover-time))) + (when (and org-clock-auto-clock-resolution + (or (not interrupting) + (eq t org-clock-auto-clock-resolution)) + (not org-clock-clocking-in) + (not org-clock-resolving-clocks)) + (setq org-clock-leftover-time nil) + (let ((org-clock-clocking-in t)) + (org-resolve-clocks))) ; check if any clocks are dangling + (when (equal select '(4)) + (setq selected-task (org-clock-select-task "Clock-in on task: ")) + (if selected-task + (setq selected-task (copy-marker selected-task)) + (error "Abort"))) + (when interrupting + ;; We are interrupting the clocking of a different task. + ;; Save a marker to this task, so that we can go back. + ;; First check if we are trying to clock into the same task! + (when (save-excursion + (unless selected-task + (org-back-to-heading t)) + (and (equal (marker-buffer org-clock-hd-marker) + (if selected-task + (marker-buffer selected-task) + (current-buffer))) + (= (marker-position org-clock-hd-marker) + (if selected-task + (marker-position selected-task) + (point))))) + (message "Clock continues in \"%s\"" org-clock-heading) + (throw 'abort nil)) + (move-marker org-clock-interrupted-task + (marker-position org-clock-marker) + (marker-buffer org-clock-marker)) + (let ((org-clock-clocking-in t)) + (org-clock-out t))) + + (when (equal select '(16)) + ;; Mark as default clocking task + (org-clock-mark-default-task)) + + ;; Clock in at which position? + (setq target-pos + (if (and (eobp) (not (org-on-heading-p))) + (point-at-bol 0) + (point))) + (run-hooks 'org-clock-in-prepare-hook) + (save-excursion + (when (and selected-task (marker-buffer selected-task)) + ;; There is a selected task, move to the correct buffer + ;; and set the new target position. + (set-buffer (org-base-buffer (marker-buffer selected-task))) + (setq target-pos (marker-position selected-task)) + (move-marker selected-task nil)) + (save-excursion + (save-restriction + (widen) + (goto-char target-pos) + (org-back-to-heading t) + (or interrupting (move-marker org-clock-interrupted-task nil)) + (org-clock-history-push) + (org-clock-set-current) + (cond ((functionp org-clock-in-switch-to-state) + (looking-at org-complex-heading-regexp) + (let ((newstate (funcall org-clock-in-switch-to-state + (match-string 2)))) + (if newstate (org-todo newstate)))) + ((and org-clock-in-switch-to-state + (not (looking-at (concat outline-regexp "[ \t]*" + org-clock-in-switch-to-state + "\\>")))) + (org-todo org-clock-in-switch-to-state))) + (setq org-clock-heading-for-remember + (and (looking-at org-complex-heading-regexp) + (match-end 4) + (org-trim (buffer-substring (match-end 1) + (match-end 4))))) + (setq org-clock-heading + (cond ((and org-clock-heading-function + (functionp org-clock-heading-function)) + (funcall org-clock-heading-function)) + ((looking-at org-complex-heading-regexp) + (replace-regexp-in-string + "\\[\\[.*?\\]\\[\\(.*?\\)\\]\\]" "\\1" + (match-string 4))) + (t "???"))) + (setq org-clock-heading (org-propertize org-clock-heading + 'face nil)) + (org-clock-find-position org-clock-in-resume) + (cond + ((and org-clock-in-resume + (looking-at + (concat "^[ \t]* " org-clock-string + " \\[\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\}" + " +\\sw+\.? +[012][0-9]:[0-5][0-9]\\)\\][ \t]*$"))) + (message "Matched %s" (match-string 1)) + (setq ts (concat "[" (match-string 1) "]")) + (goto-char (match-end 1)) + (setq org-clock-start-time + (apply 'encode-time + (org-parse-time-string (match-string 1)))) + (setq org-clock-effort (org-get-effort)) + (setq org-clock-total-time (org-clock-sum-current-item + (org-clock-get-sum-start)))) + ((eq org-clock-in-resume 'auto-restart) + ;; called from org-clock-load during startup, + ;; do not interrupt, but warn! + (message "Cannot restart clock because task does not contain unfinished clock") + (ding) + (sit-for 2) + (throw 'abort nil)) + (t + (insert-before-markers "\n") + (backward-char 1) + (org-indent-line-function) + (when (and (save-excursion + (end-of-line 0) + (org-in-item-p))) + (beginning-of-line 1) + (org-indent-line-to (- (org-get-indentation) 2))) + (insert org-clock-string " ") + (setq org-clock-effort (org-get-effort)) + (setq org-clock-total-time (org-clock-sum-current-item + (org-clock-get-sum-start))) + (setq org-clock-start-time + (or (and leftover + (y-or-n-p + (format + "You stopped another clock %d mins ago; start this one from then? " + (/ (- (org-float-time (current-time)) + (org-float-time leftover)) 60))) + leftover) + start-time + (current-time))) + (setq ts (org-insert-time-stamp org-clock-start-time + 'with-hm 'inactive)))) + (move-marker org-clock-marker (point) (buffer-base-buffer)) + (move-marker org-clock-hd-marker + (save-excursion (org-back-to-heading t) (point)) + (buffer-base-buffer)) + (setq org-clock-has-been-used t) + (or global-mode-string (setq global-mode-string '(""))) + (or (memq 'org-mode-line-string global-mode-string) + (setq global-mode-string + (append global-mode-string '(org-mode-line-string)))) + (org-clock-update-mode-line) + (when org-clock-mode-line-timer + (cancel-timer org-clock-mode-line-timer) + (setq org-clock-mode-line-timer nil)) + (setq org-clock-mode-line-timer + (run-with-timer org-clock-update-period + org-clock-update-period + 'org-clock-update-mode-line)) + (when org-clock-idle-timer + (cancel-timer org-clock-idle-timer) + (setq org-clock-idle-timer nil)) + (setq org-clock-idle-timer + (run-with-timer 60 60 'org-resolve-clocks-if-idle)) + (message "Clock starts at %s - %s" ts msg-extra) + (run-hooks 'org-clock-in-hook))))))) + +(defvar org-clock-current-task nil + "Task currently clocked in.") +(defun org-clock-set-current () + "Set `org-clock-current-task' to the task currently clocked in." + (setq org-clock-current-task (nth 4 (org-heading-components)))) + +(defun org-clock-delete-current () + "Reset `org-clock-current-task' to nil." + (setq org-clock-current-task nil)) + +(defun org-clock-mark-default-task () + "Mark current task as default task." + (interactive) + (save-excursion + (org-back-to-heading t) + (move-marker org-clock-default-task (point)))) + +(defvar msg-extra) +(defun org-clock-get-sum-start () + "Return the time from which clock times should be counted. +This is for the currently running clock as it is displayed +in the mode line. This function looks at the properties +LAST_REPEAT and in particular CLOCK_MODELINE_TOTAL and the +corresponding variable `org-clock-modeline-total' and then +decides which time to use." + (let ((cmt (or (org-entry-get nil "CLOCK_MODELINE_TOTAL") + (symbol-name org-clock-modeline-total))) + (lr (org-entry-get nil "LAST_REPEAT"))) + (cond + ((equal cmt "current") + (setq msg-extra "showing time in current clock instance") + (current-time)) + ((equal cmt "today") + (setq msg-extra "showing today's task time.") + (let* ((dt (decode-time (current-time)))) + (setq dt (append (list 0 0 0) (nthcdr 3 dt))) + (if org-extend-today-until + (setf (nth 2 dt) org-extend-today-until)) + (apply 'encode-time dt))) + ((or (equal cmt "all") + (and (or (not cmt) (equal cmt "auto")) + (not lr))) + (setq msg-extra "showing entire task time.") + nil) + ((or (equal cmt "repeat") + (and (or (not cmt) (equal cmt "auto")) + lr)) + (setq msg-extra "showing task time since last repeat.") + (if (not lr) + nil + (org-time-string-to-time lr))) + (t nil)))) + +(defun org-clock-find-position (find-unclosed) + "Find the location where the next clock line should be inserted. +When FIND-UNCLOSED is non-nil, first check if there is an unclosed clock +line and position cursor in that line." + (org-back-to-heading t) + (catch 'exit + (let ((beg (save-excursion + (beginning-of-line 2) + (or (bolp) (newline)) + (point))) + (end (progn (outline-next-heading) (point))) + (re (concat "^[ \t]*" org-clock-string)) + (cnt 0) + (drawer (if (stringp org-clock-into-drawer) + org-clock-into-drawer "LOGBOOK")) + first last ind-last) + (goto-char beg) + (when (and find-unclosed + (re-search-forward + (concat "^[ \t]* " org-clock-string + " \\[\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\}" + " +\\sw+ +[012][0-9]:[0-5][0-9]\\)\\][ \t]*$") + end t)) + (beginning-of-line 1) + (throw 'exit t)) + (when (eobp) (newline) (setq end (max (point) end))) + (when (re-search-forward (concat "^[ \t]*:" drawer ":") end t) + ;; we seem to have a CLOCK drawer, so go there. + (beginning-of-line 2) + (or org-log-states-order-reversed + (and (re-search-forward org-property-end-re nil t) + (goto-char (match-beginning 0)))) + (throw 'exit t)) + ;; Lets count the CLOCK lines + (goto-char beg) + (while (re-search-forward re end t) + (setq first (or first (match-beginning 0)) + last (match-beginning 0) + cnt (1+ cnt))) + (when (and (integerp org-clock-into-drawer) + last + (>= (1+ cnt) org-clock-into-drawer)) + ;; Wrap current entries into a new drawer + (goto-char last) + (setq ind-last (org-get-indentation)) + (beginning-of-line 2) + (if (and (>= (org-get-indentation) ind-last) + (org-at-item-p)) + (org-end-of-item)) + (insert ":END:\n") + (beginning-of-line 0) + (org-indent-line-to ind-last) + (goto-char first) + (insert ":" drawer ":\n") + (beginning-of-line 0) + (org-indent-line-function) + (org-flag-drawer t) + (beginning-of-line 2) + (or org-log-states-order-reversed + (and (re-search-forward org-property-end-re nil t) + (goto-char (match-beginning 0)))) + (throw 'exit nil)) + + (goto-char beg) + (while (and (looking-at (concat "[ \t]*" org-keyword-time-regexp)) + (not (equal (match-string 1) org-clock-string))) + ;; Planning info, skip to after it + (beginning-of-line 2) + (or (bolp) (newline))) + (when (or (eq org-clock-into-drawer t) + (stringp org-clock-into-drawer) + (and (integerp org-clock-into-drawer) + (< org-clock-into-drawer 2))) + (insert ":" drawer ":\n:END:\n") + (beginning-of-line -1) + (org-indent-line-function) + (org-flag-drawer t) + (beginning-of-line 2) + (org-indent-line-function) + (beginning-of-line) + (or org-log-states-order-reversed + (and (re-search-forward org-property-end-re nil t) + (goto-char (match-beginning 0)))))))) + +(defun org-clock-out (&optional fail-quietly at-time) + "Stop the currently running clock. +If there is no running clock, throw an error, unless FAIL-QUIETLY is set." + (interactive) + (catch 'exit + (when (not (org-clocking-p)) + (setq global-mode-string + (delq 'org-mode-line-string global-mode-string)) + (force-mode-line-update) + (if fail-quietly (throw 'exit t) (error "No active clock"))) + (let (ts te s h m remove) + (save-excursion ; Do not replace this with `with-current-buffer'. + (with-no-warnings (set-buffer (org-clocking-buffer))) + (save-restriction + (widen) + (goto-char org-clock-marker) + (beginning-of-line 1) + (if (and (looking-at (concat "[ \t]*" org-keyword-time-regexp)) + (equal (match-string 1) org-clock-string)) + (setq ts (match-string 2)) + (if fail-quietly (throw 'exit nil) (error "Clock start time is gone"))) + (goto-char (match-end 0)) + (delete-region (point) (point-at-eol)) + (insert "--") + (setq te (org-insert-time-stamp (or at-time (current-time)) + 'with-hm 'inactive)) + (setq s (- (org-float-time (apply 'encode-time (org-parse-time-string te))) + (org-float-time (apply 'encode-time (org-parse-time-string ts)))) + h (floor (/ s 3600)) + s (- s (* 3600 h)) + m (floor (/ s 60)) + s (- s (* 60 s))) + (insert " => " (format "%2d:%02d" h m)) + (when (setq remove (and org-clock-out-remove-zero-time-clocks + (= (+ h m) 0))) + (beginning-of-line 1) + (delete-region (point) (point-at-eol)) + (and (looking-at "\n") (> (point-max) (1+ (point))) + (delete-char 1))) + (move-marker org-clock-marker nil) + (move-marker org-clock-hd-marker nil) + (when org-log-note-clock-out + (org-add-log-setup 'clock-out nil nil nil nil + (concat "# Task: " (org-get-heading t) "\n\n"))) + (when org-clock-mode-line-timer + (cancel-timer org-clock-mode-line-timer) + (setq org-clock-mode-line-timer nil)) + (when org-clock-idle-timer + (cancel-timer org-clock-idle-timer) + (setq org-clock-idle-timer nil)) + (setq global-mode-string + (delq 'org-mode-line-string global-mode-string)) + (when org-clock-out-switch-to-state + (save-excursion + (org-back-to-heading t) + (let ((org-inhibit-logging t) + (org-clock-out-when-done nil)) + (cond + ((functionp org-clock-out-switch-to-state) + (looking-at org-complex-heading-regexp) + (let ((newstate (funcall org-clock-out-switch-to-state + (match-string 2)))) + (if newstate (org-todo newstate)))) + ((and org-clock-out-switch-to-state + (not (looking-at (concat outline-regexp "[ \t]*" + org-clock-out-switch-to-state + "\\>")))) + (org-todo org-clock-out-switch-to-state)))))) + (force-mode-line-update) + (message (concat "Clock stopped at %s after HH:MM = " org-time-clocksum-format "%s") te h m + (if remove " => LINE REMOVED" "")) + (run-hooks 'org-clock-out-hook) + (org-clock-delete-current)))))) + +(defun org-clock-cancel () + "Cancel the running clock by removing the start timestamp." + (interactive) + (when (not (org-clocking-p)) + (setq global-mode-string + (delq 'org-mode-line-string global-mode-string)) + (force-mode-line-update) + (error "No active clock")) + (save-excursion ; Do not replace this with `with-current-buffer'. + (with-no-warnings (set-buffer (org-clocking-buffer))) + (goto-char org-clock-marker) + (delete-region (1- (point-at-bol)) (point-at-eol)) + ;; Just in case, remove any empty LOGBOOK left over + (org-remove-empty-drawer-at "LOGBOOK" (point))) + (move-marker org-clock-marker nil) + (move-marker org-clock-hd-marker nil) + (setq global-mode-string + (delq 'org-mode-line-string global-mode-string)) + (force-mode-line-update) + (message "Clock canceled") + (run-hooks 'org-clock-cancel-hook)) + +(defun org-clock-goto (&optional select) + "Go to the currently clocked-in entry, or to the most recently clocked one. +With prefix arg SELECT, offer recently clocked tasks for selection." + (interactive "@P") + (let* ((recent nil) + (m (cond + (select + (or (org-clock-select-task "Select task to go to: ") + (error "No task selected"))) + ((org-clocking-p) org-clock-marker) + ((and org-clock-goto-may-find-recent-task + (car org-clock-history) + (marker-buffer (car org-clock-history))) + (setq recent t) + (car org-clock-history)) + (t (error "No active or recent clock task"))))) + (switch-to-buffer (marker-buffer m)) + (if (or (< m (point-min)) (> m (point-max))) (widen)) + (goto-char m) + (org-show-entry) + (org-back-to-heading t) + (org-cycle-hide-drawers 'children) + (recenter) + (org-reveal) + (if recent + (message "No running clock, this is the most recently clocked task")) + (run-hooks 'org-clock-goto-hook))) + +(defvar org-clock-file-total-minutes nil + "Holds the file total time in minutes, after a call to `org-clock-sum'.") +(make-variable-buffer-local 'org-clock-file-total-minutes) + +(defun org-clock-sum (&optional tstart tend headline-filter) + "Sum the times for each subtree. +Puts the resulting times in minutes as a text property on each headline. +TSTART and TEND can mark a time range to be considered. HEADLINE-FILTER is a +zero-arg function that, if specified, is called for each headline in the time +range with point at the headline. Headlines for which HEADLINE-FILTER returns +nil are excluded from the clock summation." + (interactive) + (let* ((bmp (buffer-modified-p)) + (re (concat "^\\(\\*+\\)[ \t]\\|^[ \t]*" + org-clock-string + "[ \t]*\\(?:\\(\\[.*?\\]\\)-+\\(\\[.*?\\]\\)\\|=>[ \t]+\\([0-9]+\\):\\([0-9]+\\)\\)")) + (lmax 30) + (ltimes (make-vector lmax 0)) + (t1 0) + (level 0) + ts te dt + time) + (if (stringp tstart) (setq tstart (org-time-string-to-seconds tstart))) + (if (stringp tend) (setq tend (org-time-string-to-seconds tend))) + (if (consp tstart) (setq tstart (org-float-time tstart))) + (if (consp tend) (setq tend (org-float-time tend))) + (remove-text-properties (point-min) (point-max) + '(:org-clock-minutes t + :org-clock-force-headline-inclusion t)) + (save-excursion + (goto-char (point-max)) + (while (re-search-backward re nil t) + (cond + ((match-end 2) + ;; Two time stamps + (setq ts (match-string 2) + te (match-string 3) + ts (org-float-time + (apply 'encode-time (org-parse-time-string ts))) + te (org-float-time + (apply 'encode-time (org-parse-time-string te))) + ts (if tstart (max ts tstart) ts) + te (if tend (min te tend) te) + dt (- te ts) + t1 (if (> dt 0) (+ t1 (floor (/ dt 60))) t1))) + ((match-end 4) + ;; A naked time + (setq t1 (+ t1 (string-to-number (match-string 5)) + (* 60 (string-to-number (match-string 4)))))) + (t ;; A headline + ;; Add the currently clocking item time to the total + (when (and org-clock-report-include-clocking-task + (equal (org-clocking-buffer) (current-buffer)) + (equal (marker-position org-clock-hd-marker) (point)) + tstart + tend + (>= (org-float-time org-clock-start-time) tstart) + (<= (org-float-time org-clock-start-time) tend)) + (let ((time (floor (- (org-float-time) + (org-float-time org-clock-start-time)) 60))) + (setq t1 (+ t1 time)))) + (let* ((headline-forced + (get-text-property (point) + :org-clock-force-headline-inclusion)) + (headline-included + (or (null headline-filter) + (save-excursion + (save-match-data (funcall headline-filter)))))) + (setq level (- (match-end 1) (match-beginning 1))) + (when (or (> t1 0) (> (aref ltimes level) 0)) + (when (or headline-included headline-forced) + (if headline-included + (loop for l from 0 to level do + (aset ltimes l (+ (aref ltimes l) t1)))) + (setq time (aref ltimes level)) + (goto-char (match-beginning 0)) + (put-text-property (point) (point-at-eol) :org-clock-minutes time) + (if headline-filter + (save-excursion + (save-match-data + (while + (> (funcall outline-level) 1) + (outline-up-heading 1 t) + (put-text-property + (point) (point-at-eol) + :org-clock-force-headline-inclusion t)))))) + (setq t1 0) + (loop for l from level to (1- lmax) do + (aset ltimes l 0))))))) + (setq org-clock-file-total-minutes (aref ltimes 0))) + (set-buffer-modified-p bmp))) + +(defun org-clock-sum-current-item (&optional tstart) + "Return time, clocked on current item in total." + (save-excursion + (save-restriction + (org-narrow-to-subtree) + (org-clock-sum tstart) + org-clock-file-total-minutes))) + +(defun org-clock-display (&optional total-only) + "Show subtree times in the entire buffer. +If TOTAL-ONLY is non-nil, only show the total time for the entire file +in the echo area." + (interactive) + (org-clock-remove-overlays) + (let (time h m p) + (org-clock-sum) + (unless total-only + (save-excursion + (goto-char (point-min)) + (while (or (and (equal (setq p (point)) (point-min)) + (get-text-property p :org-clock-minutes)) + (setq p (next-single-property-change + (point) :org-clock-minutes))) + (goto-char p) + (when (setq time (get-text-property p :org-clock-minutes)) + (org-clock-put-overlay time (funcall outline-level)))) + (setq h (/ org-clock-file-total-minutes 60) + m (- org-clock-file-total-minutes (* 60 h))) + ;; Arrange to remove the overlays upon next change. + (when org-remove-highlights-with-change + (org-add-hook 'before-change-functions 'org-clock-remove-overlays + nil 'local)))) + (if org-time-clocksum-use-fractional + (message (concat "Total file time: " org-time-clocksum-fractional-format + " (%d hours and %d minutes)") + (/ (+ (* h 60.0) m) 60.0) h m) + (message (concat "Total file time: " org-time-clocksum-format + " (%d hours and %d minutes)") h m h m)))) + +(defvar org-clock-overlays nil) +(make-variable-buffer-local 'org-clock-overlays) + +(defun org-clock-put-overlay (time &optional level) + "Put an overlays on the current line, displaying TIME. +If LEVEL is given, prefix time with a corresponding number of stars. +This creates a new overlay and stores it in `org-clock-overlays', so that it +will be easy to remove." + (let* ((c 60) (h (floor (/ time 60))) (m (- time (* 60 h))) + (l (if level (org-get-valid-level level 0) 0)) + (fmt (concat "%s " (if org-time-clocksum-use-fractional + org-time-clocksum-fractional-format + org-time-clocksum-format) "%s")) + (off 0) + ov tx) + (org-move-to-column c) + (unless (eolp) (skip-chars-backward "^ \t")) + (skip-chars-backward " \t") + (setq ov (make-overlay (1- (point)) (point-at-eol)) + tx (concat (buffer-substring (1- (point)) (point)) + (make-string (+ off (max 0 (- c (current-column)))) ?.) + (org-add-props (if org-time-clocksum-use-fractional + (format fmt + (make-string l ?*) + (/ (+ (* h 60.0) m) 60.0) + (make-string (- 16 l) ?\ )) + (format fmt + (make-string l ?*) h m + (make-string (- 16 l) ?\ ))) + (list 'face 'org-clock-overlay)) + "")) + (if (not (featurep 'xemacs)) + (overlay-put ov 'display tx) + (overlay-put ov 'invisible t) + (overlay-put ov 'end-glyph (make-glyph tx))) + (push ov org-clock-overlays))) + +(defun org-clock-remove-overlays (&optional beg end noremove) + "Remove the occur highlights from the buffer. +BEG and END are ignored. If NOREMOVE is nil, remove this function +from the `before-change-functions' in the current buffer." + (interactive) + (unless org-inhibit-highlight-removal + (mapc 'delete-overlay org-clock-overlays) + (setq org-clock-overlays nil) + (unless noremove + (remove-hook 'before-change-functions + 'org-clock-remove-overlays 'local)))) + +(defvar state) ;; dynamically scoped into this function +(defun org-clock-out-if-current () + "Clock out if the current entry contains the running clock. +This is used to stop the clock after a TODO entry is marked DONE, +and is only done if the variable `org-clock-out-when-done' is not nil." + (when (and org-clock-out-when-done + (or (and (eq t org-clock-out-when-done) + (member state org-done-keywords)) + (and (listp org-clock-out-when-done) + (member state org-clock-out-when-done))) + (equal (or (buffer-base-buffer (org-clocking-buffer)) + (org-clocking-buffer)) + (or (buffer-base-buffer (current-buffer)) + (current-buffer))) + (< (point) org-clock-marker) + (> (save-excursion (outline-next-heading) (point)) + org-clock-marker)) + ;; Clock out, but don't accept a logging message for this. + (let ((org-log-note-clock-out nil) + (org-clock-out-switch-to-state nil)) + (org-clock-out)))) + +(add-hook 'org-after-todo-state-change-hook + 'org-clock-out-if-current) + +;;;###autoload +(defun org-get-clocktable (&rest props) + "Get a formatted clocktable with parameters according to PROPS. +The table is created in a temporary buffer, fully formatted and +fontified, and then returned." + ;; Set the defaults + (setq props (plist-put props :name "clocktable")) + (unless (plist-member props :maxlevel) + (setq props (plist-put props :maxlevel 2))) + (unless (plist-member props :scope) + (setq props (plist-put props :scope 'agenda))) + (with-temp-buffer + (org-mode) + (org-create-dblock props) + (org-update-dblock) + (font-lock-fontify-buffer) + (forward-line 2) + (buffer-substring (point) (progn + (re-search-forward "^[ \t]*#\\+END" nil t) + (point-at-bol))))) + +(defun org-clock-report (&optional arg) + "Create a table containing a report about clocked time. +If the cursor is inside an existing clocktable block, then the table +will be updated. If not, a new clocktable will be inserted. +When called with a prefix argument, move to the first clock table in the +buffer and update it." + (interactive "P") + (org-clock-remove-overlays) + (when arg + (org-find-dblock "clocktable") + (org-show-entry)) + (if (org-in-clocktable-p) + (goto-char (org-in-clocktable-p)) + (org-create-dblock (append (list :name "clocktable") + org-clock-clocktable-default-properties))) + (org-update-dblock)) + +(defun org-in-clocktable-p () + "Check if the cursor is in a clocktable." + (let ((pos (point)) start) + (save-excursion + (end-of-line 1) + (and (re-search-backward "^[ \t]*#\\+BEGIN:[ \t]+clocktable" nil t) + (setq start (match-beginning 0)) + (re-search-forward "^[ \t]*#\\+END:.*" nil t) + (>= (match-end 0) pos) + start)))) + +(defun org-day-of-week (day month year) + "Returns the day of the week as an integer." + (nth 6 + (decode-time + (date-to-time + (format "%d-%02d-%02dT00:00:00" year month day))))) + +(defun org-quarter-to-date (quarter year) + "Get the date (week day year) of the first day of a given quarter." + (let (startday) + (cond + ((= quarter 1) + (setq startday (org-day-of-week 1 1 year)) + (cond + ((= startday 0) + (list 52 7 (- year 1))) + ((= startday 6) + (list 52 6 (- year 1))) + ((<= startday 4) + (list 1 startday year)) + ((> startday 4) + (list 53 startday (- year 1))) + ) + ) + ((= quarter 2) + (setq startday (org-day-of-week 1 4 year)) + (cond + ((= startday 0) + (list 13 startday year)) + ((< startday 4) + (list 14 startday year)) + ((>= startday 4) + (list 13 startday year)) + ) + ) + ((= quarter 3) + (setq startday (org-day-of-week 1 7 year)) + (cond + ((= startday 0) + (list 26 startday year)) + ((< startday 4) + (list 27 startday year)) + ((>= startday 4) + (list 26 startday year)) + ) + ) + ((= quarter 4) + (setq startday (org-day-of-week 1 10 year)) + (cond + ((= startday 0) + (list 39 startday year)) + ((<= startday 4) + (list 40 startday year)) + ((> startday 4) + (list 39 startday year))))))) + +(defun org-clock-special-range (key &optional time as-strings) + "Return two times bordering a special time range. +Key is a symbol specifying the range and can be one of `today', `yesterday', +`thisweek', `lastweek', `thismonth', `lastmonth', `thisyear', `lastyear'. +A week starts Monday 0:00 and ends Sunday 24:00. +The range is determined relative to TIME. TIME defaults to the current time. +The return value is a cons cell with two internal times like the ones +returned by `current time' or `encode-time'. if AS-STRINGS is non-nil, +the returned times will be formatted strings." + (if (integerp key) (setq key (intern (number-to-string key)))) + (let* ((tm (decode-time (or time (current-time)))) + (s 0) (m (nth 1 tm)) (h (nth 2 tm)) + (d (nth 3 tm)) (month (nth 4 tm)) (y (nth 5 tm)) + (dow (nth 6 tm)) + (skey (symbol-name key)) + (shift 0) + (q (cond ((>= (nth 4 tm) 10) 4) + ((>= (nth 4 tm) 7) 3) + ((>= (nth 4 tm) 4) 2) + ((>= (nth 4 tm) 1) 1))) + s1 m1 h1 d1 month1 y1 diff ts te fm txt w date + interval tmp shiftedy shiftedm shiftedq) + (cond + ((string-match "^[0-9]+$" skey) + (setq y (string-to-number skey) m 1 d 1 key 'year)) + ((string-match "^\\([0-9]+\\)-\\([0-9]\\{1,2\\}\\)$" skey) + (setq y (string-to-number (match-string 1 skey)) + month (string-to-number (match-string 2 skey)) + d 1 key 'month)) + ((string-match "^\\([0-9]+\\)-[wW]\\([0-9]\\{1,2\\}\\)$" skey) + (require 'cal-iso) + (setq y (string-to-number (match-string 1 skey)) + w (string-to-number (match-string 2 skey))) + (setq date (calendar-gregorian-from-absolute + (calendar-absolute-from-iso (list w 1 y)))) + (setq d (nth 1 date) month (car date) y (nth 2 date) + dow 1 + key 'week)) + ((string-match "^\\([0-9]+\\)-[qQ]\\([1-4]\\)$" skey) + (require 'cal-iso) + (setq y (string-to-number (match-string 1 skey))) + (setq q (string-to-number (match-string 2 skey))) + (setq date (calendar-gregorian-from-absolute + (calendar-absolute-from-iso (org-quarter-to-date q y)))) + (setq d (nth 1 date) month (car date) y (nth 2 date) + dow 1 + key 'quarter)) + ((string-match "^\\([0-9]+\\)-\\([0-9]\\{1,2\\}\\)-\\([0-9]\\{1,2\\}\\)$" skey) + (setq y (string-to-number (match-string 1 skey)) + month (string-to-number (match-string 2 skey)) + d (string-to-number (match-string 3 skey)) + key 'day)) + ((string-match "\\([-+][0-9]+\\)$" skey) + (setq shift (string-to-number (match-string 1 skey)) + key (intern (substring skey 0 (match-beginning 1)))) + (if(and (memq key '(quarter thisq)) (> shift 0)) + (error "Looking forward with quarters isn't implemented.") + ()))) + + (when (= shift 0) + (cond ((eq key 'yesterday) (setq key 'today shift -1)) + ((eq key 'lastweek) (setq key 'week shift -1)) + ((eq key 'lastmonth) (setq key 'month shift -1)) + ((eq key 'lastyear) (setq key 'year shift -1)) + ((eq key 'lastq) (setq key 'quarter shift -1)))) + (cond + ((memq key '(day today)) + (setq d (+ d shift) h 0 m 0 h1 24 m1 0)) + ((memq key '(week thisweek)) + (setq diff (+ (* -7 shift) (if (= dow 0) 6 (1- dow))) + m 0 h 0 d (- d diff) d1 (+ 7 d))) + ((memq key '(month thismonth)) + (setq d 1 h 0 m 0 d1 1 month (+ month shift) month1 (1+ month) h1 0 m1 0)) + ((memq key '(quarter thisq)) + ; compute if this shift remains in this year + ; if not, compute how many years and quarters we have to shift (via floor*) + ; and compute the shifted years, months and quarters + (cond + ((< (+ (- q 1) shift) 0) ; shift not in this year + (setq interval (* -1 (+ (- q 1) shift))) + ; set tmp to ((years to shift) (quarters to shift)) + (setq tmp (org-floor* interval 4)) + ; due to the use of floor, 0 quarters actually means 4 + (if (= 0 (nth 1 tmp)) + (setq shiftedy (- y (nth 0 tmp)) + shiftedm 1 + shiftedq 1) + (setq shiftedy (- y (+ 1 (nth 0 tmp))) + shiftedm (- 13 (* 3 (nth 1 tmp))) + shiftedq (- 5 (nth 1 tmp)))) + (setq d 1 h 0 m 0 d1 1 month shiftedm month1 (+ 3 shiftedm) h1 0 m1 0 y shiftedy)) + ((> (+ q shift) 0) ; shift is whitin this year + (setq shiftedq (+ q shift)) + (setq shiftedy y) + (setq d 1 h 0 m 0 d1 1 month (+ 1 (* 3 (- (+ q shift) 1))) month1 (+ 4 (* 3 (- (+ q shift) 1))) h1 0 m1 0)))) + ((memq key '(year thisyear)) + (setq m 0 h 0 d 1 month 1 y (+ y shift) y1 (1+ y))) + (t (error "No such time block %s" key))) + (setq ts (encode-time s m h d month y) + te (encode-time (or s1 s) (or m1 m) (or h1 h) + (or d1 d) (or month1 month) (or y1 y))) + (setq fm (cdr org-time-stamp-formats)) + (cond + ((memq key '(day today)) + (setq txt (format-time-string "%A, %B %d, %Y" ts))) + ((memq key '(week thisweek)) + (setq txt (format-time-string "week %G-W%V" ts))) + ((memq key '(month thismonth)) + (setq txt (format-time-string "%B %Y" ts))) + ((memq key '(year thisyear)) + (setq txt (format-time-string "the year %Y" ts))) + ((memq key '(quarter thisq)) + (setq txt (concatenate 'string (org-count-quarter shiftedq) " quarter of " (number-to-string shiftedy)))) + ) + (if as-strings + (list (format-time-string fm ts) (format-time-string fm te) txt) + (list ts te txt)))) + +(defun org-count-quarter (n) + (cond + ((= n 1) "1st") + ((= n 2) "2nd") + ((= n 3) "3rd") + ((= n 4) "4th"))) + +(defun org-clocktable-shift (dir n) + "Try to shift the :block date of the clocktable at point. +Point must be in the #+BEGIN: line of a clocktable, or this function +will throw an error. +DIR is a direction, a symbol `left', `right', `up', or `down'. +Both `left' and `down' shift the block toward the past, `up' and `right' +push it toward the future. +N is the number of shift steps to take. The size of the step depends on +the currently selected interval size." + (setq n (prefix-numeric-value n)) + (and (memq dir '(left down)) (setq n (- n))) + (save-excursion + (goto-char (point-at-bol)) + (if (not (looking-at "^[ \t]*#\\+BEGIN:[ \t]+clocktable\\>.*?:block[ \t]+\\(\\S-+\\)")) + (error "Line needs a :block definition before this command works") + (let* ((b (match-beginning 1)) (e (match-end 1)) + (s (match-string 1)) + block shift ins y mw d date wp m) + (cond + ((equal s "yesterday") (setq s "today-1")) + ((equal s "lastweek") (setq s "thisweek-1")) + ((equal s "lastmonth") (setq s "thismonth-1")) + ((equal s "lastyear") (setq s "thisyear-1")) + ((equal s "lastq") (setq s "thisq-1"))) + + (cond + ((string-match "^\\(today\\|thisweek\\|thismonth\\|thisyear\\|thisq\\)\\([-+][0-9]+\\)?$" s) + (setq block (match-string 1 s) + shift (if (match-end 2) + (string-to-number (match-string 2 s)) + 0)) + (setq shift (+ shift n)) + (setq ins (if (= shift 0) block (format "%s%+d" block shift)))) + ((string-match "\\([0-9]+\\)\\(-\\([wWqQ]?\\)\\([0-9]\\{1,2\\}\\)\\(-\\([0-9]\\{1,2\\}\\)\\)?\\)?" s) + ;; 1 1 2 3 3 4 4 5 6 6 5 2 + (setq y (string-to-number (match-string 1 s)) + wp (and (match-end 3) (match-string 3 s)) + mw (and (match-end 4) (string-to-number (match-string 4 s))) + d (and (match-end 6) (string-to-number (match-string 6 s)))) + (cond + (d (setq ins (format-time-string + "%Y-%m-%d" + (encode-time 0 0 0 (+ d n) m y)))) + ((and wp (string-match "w\\|W" wp) mw (> (length wp) 0)) + (require 'cal-iso) + (setq date (calendar-gregorian-from-absolute (calendar-absolute-from-iso (list (+ mw n) 1 y)))) + (setq ins (format-time-string + "%G-W%V" + (encode-time 0 0 0 (nth 1 date) (car date) (nth 2 date))))) + ((and wp (string-match "q\\|Q" wp) mw (> (length wp) 0)) + (require 'cal-iso) + ; if the 4th + 1 quarter is requested we flip to the 1st quarter of the next year + (if (> (+ mw n) 4) + (setq mw 0 + y (+ 1 y)) + ()) + ; if the 1st - 1 quarter is requested we flip to the 4th quarter of the previous year + (if (= (+ mw n) 0) + (setq mw 5 + y (- y 1)) + ()) + (setq date (calendar-gregorian-from-absolute (calendar-absolute-from-iso (org-quarter-to-date (+ mw n) y)))) + (setq ins (format-time-string + (concatenate 'string (number-to-string y) "-Q" (number-to-string (+ mw n))) + (encode-time 0 0 0 (nth 1 date) (car date) (nth 2 date))))) + (mw + (setq ins (format-time-string + "%Y-%m" + (encode-time 0 0 0 1 (+ mw n) y)))) + (y + (setq ins (number-to-string (+ y n)))))) + (t (error "Cannot shift clocktable block"))) + (when ins + (goto-char b) + (insert ins) + (delete-region (point) (+ (point) (- e b))) + (beginning-of-line 1) + (org-update-dblock) + t))))) + +(defun org-dblock-write:clocktable (params) + "Write the standard clocktable." + (setq params (org-combine-plists org-clocktable-defaults params)) + (catch 'exit + (let* ((scope (plist-get params :scope)) + (block (plist-get params :block)) + (ts (plist-get params :tstart)) + (te (plist-get params :tend)) + (link (plist-get params :link)) + (maxlevel (or (plist-get params :maxlevel) 3)) + (step (plist-get params :step)) + (timestamp (plist-get params :timestamp)) + (formatter (or (plist-get params :formatter) + org-clock-clocktable-formatter + 'org-clocktable-write-default)) + cc range-text ipos pos one-file-with-archives + scope-is-list tbls level) + + ;; Check if we need to do steps + (when block + ;; Get the range text for the header + (setq cc (org-clock-special-range block nil t) + ts (car cc) te (nth 1 cc) range-text (nth 2 cc))) + (when step + ;; Write many tables, in steps + (unless (or block (and ts te)) + (error "Clocktable `:step' can only be used with `:block' or `:tstart,:end'")) + (org-clocktable-steps params) + (throw 'exit nil)) + + (setq ipos (point)) ; remember the insertion position + + ;; Get the right scope + (setq pos (point)) + (cond + ((and scope (listp scope) (symbolp (car scope))) + (setq scope (eval scope))) + ((eq scope 'agenda) + (setq scope (org-agenda-files t))) + ((eq scope 'agenda-with-archives) + (setq scope (org-agenda-files t)) + (setq scope (org-add-archive-files scope))) + ((eq scope 'file-with-archives) + (setq scope (org-add-archive-files (list (buffer-file-name))) + one-file-with-archives t))) + (setq scope-is-list (and scope (listp scope))) + (if scope-is-list + ;; we collect from several files + (let* ((files scope) + file) + (org-prepare-agenda-buffers files) + (while (setq file (pop files)) + (with-current-buffer (find-buffer-visiting file) + (save-excursion + (save-restriction + (push (org-clock-get-table-data file params) tbls)))))) + ;; Just from the current file + (save-restriction + ;; get the right range into the restriction + (org-prepare-agenda-buffers (list (buffer-file-name))) + (cond + ((not scope)) ; use the restriction as it is now + ((eq scope 'file) (widen)) + ((eq scope 'subtree) (org-narrow-to-subtree)) + ((eq scope 'tree) + (while (org-up-heading-safe)) + (org-narrow-to-subtree)) + ((and (symbolp scope) (string-match "^tree\\([0-9]+\\)$" + (symbol-name scope))) + (setq level (string-to-number (match-string 1 (symbol-name scope)))) + (catch 'exit + (while (org-up-heading-safe) + (looking-at outline-regexp) + (if (<= (org-reduced-level (funcall outline-level)) level) + (throw 'exit nil)))) + (org-narrow-to-subtree))) + ;; do the table, with no file name. + (push (org-clock-get-table-data nil params) tbls))) + + ;; OK, at this point we tbls as a list of tables, one per file + (setq tbls (nreverse tbls)) + + (setq params (plist-put params :multifile scope-is-list)) + (setq params (plist-put params :one-file-with-archives + one-file-with-archives)) + + (funcall formatter ipos tbls params)))) + +(defun org-clocktable-write-default (ipos tables params) + "Write out a clock table at position IPOS in the current buffer. +TABLES is a list of tables with clocking data as produced by +`org-clock-get-table-data'. PARAMS is the parameter property list obtained +from the dynamic block defintion." + ;; This function looks quite complicated, mainly because there are a lot + ;; of options which can add or remove columns. I have massively commented + ;; function, to I hope it is understandable. If someone want to write + ;; there own special formatter, this maybe much easier because there can + ;; be a fixed format with a well-defined number of columns... + (let* ((hlchars '((1 . "*") (2 . "/"))) + (multifile (plist-get params :multifile)) + (block (plist-get params :block)) + (ts (plist-get params :tstart)) + (te (plist-get params :tend)) + (header (plist-get params :header)) + (narrow (plist-get params :narrow)) + (link (plist-get params :link)) + (maxlevel (or (plist-get params :maxlevel) 3)) + (emph (plist-get params :emphasize)) + (level-p (plist-get params :level)) + (timestamp (plist-get params :timestamp)) + (ntcol (max 1 (or (plist-get params :tcolumns) 100))) + (rm-file-column (plist-get params :one-file-with-archives)) + (indent (plist-get params :indent)) + range-text total-time tbl level hlc formula pcol + file-time entries entry headline + recalc content narrow-cut-p tcol) + + ;; Implement abbreviations + (when (plist-get params :compact) + (setq level nil indent t narrow (or narrow '40!) ntcol 1)) + + ;; Some consistency test for parameters + (unless (integerp ntcol) + (setq params (plist-put params :tcolumns (setq ntcol 100)))) + + (when (and narrow (integerp narrow) link) + ;; We cannot have both integer narrow and link + (message + "Using hard narrowing in clocktable to allow for links") + (setq narrow (intern (format "%d!" narrow)))) + + (when narrow + (cond + ((integerp narrow)) + ((and (symbolp narrow) + (string-match "\\`[0-9]+!\\'" (symbol-name narrow))) + (setq narrow-cut-p t + narrow (string-to-number (substring (symbol-name narrow) + 0 -1)))) + (t + (error "Invalid value %s of :narrow property in clock table" + narrow)))) + + (when block + ;; Get the range text for the header + (setq range-text (nth 2 (org-clock-special-range block nil t)))) + + ;; Compute the total time + (setq total-time (apply '+ (mapcar 'cadr tables))) + + ;; Now we need to output this tsuff + (goto-char ipos) + + ;; Insert the text *before* the actual table + (insert-before-markers + (or header + ;; Format the standard header + (concat + "Clock summary at [" + (substring + (format-time-string (cdr org-time-stamp-formats)) + 1 -1) + "]" + (if block (concat ", for " range-text ".") "") + "\n\n"))) + + ;; Insert the narrowing line + (when (and narrow (integerp narrow) (not narrow-cut-p)) + (insert-before-markers + "|" ; table line starter + (if multifile "|" "") ; file column, maybe + (if level-p "|" "") ; level column, maybe + (if timestamp "|" "") ; timestamp column, maybe + (format "<%d>| |\n" narrow))) ; headline and time columns + + ;; Insert the table header line + (insert-before-markers + "|" ; table line starter + (if multifile "File|" "") ; file column, maybe + (if level-p "L|" "") ; level column, maybe + (if timestamp "Timestamp|" "") ; timestamp column, maybe + "Headline|Time|\n") ; headline and time columns + + ;; Insert the total time in the table + (insert-before-markers + "|-\n" ; a hline + "|" ; table line starter + (if multifile "| ALL " "") ; file column, maybe + (if level-p "|" "") ; level column, maybe + (if timestamp "|" "") ; timestamp column, maybe + "*Total time*| " ; instead of a headline + "*" + (org-minutes-to-hh:mm-string (or total-time 0)) ; the time + "*|\n") ; close line + + ;; Now iterate over the tables and insert the data + ;; but only if any time has been collected + (when (and total-time (> total-time 0)) + + (while (setq tbl (pop tables)) + ;; now tbl is the table resulting from one file. + (setq file-time (nth 1 tbl)) + (when (or (and file-time (> file-time 0)) + (not (plist-get params :fileskip0))) + (insert-before-markers "|-\n") ; a hline because a new file starts + ;; First the file time, if we have multiple files + (when multifile + ;; Summarize the time colleted from this file + (insert-before-markers + (format "| %s %s | %s*File time* | *%s*|\n" + (file-name-nondirectory (car tbl)) + (if level-p "| " "") ; level column, maybe + (if timestamp "| " "") ; timestamp column, maybe + (org-minutes-to-hh:mm-string (nth 1 tbl))))) ; the time + + ;; Get the list of node entries and iterate over it + (setq entries (nth 2 tbl)) + (while (setq entry (pop entries)) + (setq level (car entry) + headline (nth 1 entry) + hlc (if emph (or (cdr (assoc level hlchars)) "") "")) + (when narrow-cut-p + (if (and (string-match (concat "\\`" org-bracket-link-regexp + "\\'") + headline) + (match-end 3)) + (setq headline + (format "[[%s][%s]]" + (match-string 1 headline) + (org-shorten-string (match-string 3 headline) + narrow))) + (setq headline (org-shorten-string headline narrow)))) + (insert-before-markers + "|" ; start the table line + (if multifile "|" "") ; free space for file name column? + (if level-p (format "%d|" (car entry)) "") ; level, maybe + (if timestamp (concat (nth 2 entry) "|") "") ; timestamp, maybe + (if indent (org-clocktable-indent-string level) "") ; indentation + hlc headline hlc "|" ; headline + (make-string (min (1- ntcol) (or (- level 1))) ?|) + ; empty fields for higher levels + hlc (org-minutes-to-hh:mm-string (nth 3 entry)) hlc ; time + "|\n" ; close line + ))))) + (backward-delete-char 1) + (if (setq formula (plist-get params :formula)) + (cond + ((eq formula '%) + ;; compute the column where the % numbers need to go + (setq pcol (+ 2 + (if multifile 1 0) + (if level-p 1 0) + (if timestamp 1 0) + (min maxlevel (or ntcol 100)))) + ;; compute the column where the total time is + (setq tcol (+ 2 + (if multifile 1 0) + (if level-p 1 0) + (if timestamp 1 0))) + (insert + (format + "\n#+TBLFM: $%d='(org-clock-time%% @%d$%d $%d..$%d);%%.1f" + pcol ; the column where the % numbers should go + (if (and narrow (not narrow-cut-p)) 3 2) ; row of the total time + tcol ; column of the total time + tcol (1- pcol) ; range of columns where times can be found + )) + (setq recalc t)) + ((stringp formula) + (insert "\n#+TBLFM: " formula) + (setq recalc t)) + (t (error "invalid formula in clocktable"))) + ;; Should we rescue an old formula? + (when (stringp (setq content (plist-get params :content))) + (when (string-match "^\\([ \t]*#\\+TBLFM:.*\\)" content) + (setq recalc t) + (insert "\n" (match-string 1 (plist-get params :content))) + (beginning-of-line 0)))) + ;; Back to beginning, align the table, recalculate if necessary + (goto-char ipos) + (skip-chars-forward "^|") + (org-table-align) + (when org-hide-emphasis-markers + ;; we need to align a second time + (org-table-align)) + (when recalc + (if (eq formula '%) + (save-excursion + (if (and narrow (not narrow-cut-p)) (beginning-of-line 2)) + (org-table-goto-column pcol nil 'force) + (insert "%"))) + (org-table-recalculate 'all)) + (when rm-file-column + ;; The file column is actually not wanted + (forward-char 1) + (org-table-delete-column)) + total-time)) + +(defun org-clocktable-indent-string (level) + (if (= level 1) + "" + (let ((str "\\__")) + (while (> level 2) + (setq level (1- level) + str (concat str "___"))) + (concat str " ")))) + +(defun org-clocktable-steps (params) + "Step through the range to make a number of clock tables." + (let* ((p1 (copy-sequence params)) + (ts (plist-get p1 :tstart)) + (te (plist-get p1 :tend)) + (step0 (plist-get p1 :step)) + (step (cdr (assoc step0 '((day . 86400) (week . 604800))))) + (stepskip0 (plist-get p1 :stepskip0)) + (block (plist-get p1 :block)) + cc range-text step-time) + (when block + (setq cc (org-clock-special-range block nil t) + ts (car cc) te (nth 1 cc) range-text (nth 2 cc))) + (cond + ((numberp ts) + ;; If ts is a number, it's an absolute day number from org-agenda. + (destructuring-bind (month day year) (calendar-gregorian-from-absolute ts) + (setq ts (org-float-time (encode-time 0 0 0 day month year))))) + (ts + (setq ts (org-float-time + (apply 'encode-time (org-parse-time-string ts)))))) + (cond + ((numberp te) + ;; Likewise for te. + (destructuring-bind (month day year) (calendar-gregorian-from-absolute te) + (setq te (org-float-time (encode-time 0 0 0 day month year))))) + (te + (setq te (org-float-time + (apply 'encode-time (org-parse-time-string te)))))) + (setq p1 (plist-put p1 :header "")) + (setq p1 (plist-put p1 :step nil)) + (setq p1 (plist-put p1 :block nil)) + (while (< ts te) + (or (bolp) (insert "\n")) + (setq p1 (plist-put p1 :tstart (format-time-string + (org-time-stamp-format nil t) + (seconds-to-time ts)))) + (setq p1 (plist-put p1 :tend (format-time-string + (org-time-stamp-format nil t) + (seconds-to-time (setq ts (+ ts step)))))) + (insert "\n" (if (eq step0 'day) "Daily report: " + "Weekly report starting on: ") + (plist-get p1 :tstart) "\n") + (setq step-time (org-dblock-write:clocktable p1)) + (re-search-forward "^[ \t]*#\\+END:") + (when (and (equal step-time 0) stepskip0) + ;; Remove the empty table + (delete-region (point-at-bol) + (save-excursion + (re-search-backward "^\\(Daily\\|Weekly\\) report" + nil t) + (point)))) + (end-of-line 0)))) + +(defun org-clock-get-table-data (file params) + "Get the clocktable data for file FILE, with parameters PARAMS. +FILE is only for identification - this function assumes that +the correct buffer is current, and that the wanted restriction is +in place. +The return value will be a list with the file name and the total +file time (in minutes) as 1st and 2nd elements. The third element +of this list will be a list of headline entries. Each entry has the +following structure: + + (LEVEL HEADLINE TIMESTAMP TIME) + +LEVEL: The level of the headline, as an integer. This will be + the reduced leve, so 1,2,3,... even if only odd levels + are being used. +HEADLINE: The text of the headline. Depending on PARAMS, this may + already be formatted like a link. +TIMESTAMP: If PARAMS require it, this will be a time stamp found in the + entry, any of SCHEDULED, DEADLINE, NORMAL, or first inactive, + in this sequence. +TIME: The sum of all time spend in this tree, in minutes. This time + will of cause be restricted to the time block and tags match + specified in PARAMS." + (let* ((maxlevel (or (plist-get params :maxlevel) 3)) + (timestamp (plist-get params :timestamp)) + (ts (plist-get params :tstart)) + (te (plist-get params :tend)) + (block (plist-get params :block)) + (link (plist-get params :link)) + (tags (plist-get params :tags)) + (matcher (if tags (cdr (org-make-tags-matcher tags)))) + cc range-text st p time level hdl props tsp tbl) + + (setq org-clock-file-total-minutes nil) + (when block + (setq cc (org-clock-special-range block nil t) + ts (car cc) te (nth 1 cc) range-text (nth 2 cc))) + (when (integerp ts) (setq ts (calendar-gregorian-from-absolute ts))) + (when (integerp te) (setq te (calendar-gregorian-from-absolute te))) + (when (and ts (listp ts)) + (setq ts (format "%4d-%02d-%02d" (nth 2 ts) (car ts) (nth 1 ts)))) + (when (and te (listp te)) + (setq te (format "%4d-%02d-%02d" (nth 2 te) (car te) (nth 1 te)))) + ;; Now the times are strings we can parse. + (if ts (setq ts (org-float-time + (apply 'encode-time (org-parse-time-string ts))))) + (if te (setq te (org-float-time + (apply 'encode-time (org-parse-time-string te))))) + (save-excursion + (org-clock-sum ts te + (unless (null matcher) + (lambda () + (let ((tags-list (org-get-tags-at))) + (eval matcher))))) + (goto-char (point-min)) + (setq st t) + (while (or (and (bobp) (prog1 st (setq st nil)) + (get-text-property (point) :org-clock-minutes) + (setq p (point-min))) + (setq p (next-single-property-change + (point) :org-clock-minutes))) + (goto-char p) + (when (setq time (get-text-property p :org-clock-minutes)) + (save-excursion + (beginning-of-line 1) + (when (and (looking-at (org-re "\\(\\*+\\)[ \t]+\\(.*?\\)\\([ \t]+:[[:alnum:]_@#%:]+:\\)?[ \t]*$")) + (setq level (org-reduced-level + (- (match-end 1) (match-beginning 1)))) + (<= level maxlevel)) + (setq hdl (if (not link) + (match-string 2) + (org-make-link-string + (format "file:%s::%s" + (buffer-file-name) + (save-match-data + (org-make-org-heading-search-string + (match-string 2)))) + (match-string 2))) + tsp (when timestamp + (setq props (org-entry-properties (point))) + (or (cdr (assoc "SCHEDULED" props)) + (cdr (assoc "DEADLINE" props)) + (cdr (assoc "TIMESTAMP" props)) + (cdr (assoc "TIMESTAMP_IA" props))))) + (when (> time 0) (push (list level hdl tsp time) tbl)))))) + (setq tbl (nreverse tbl)) + (list file org-clock-file-total-minutes tbl)))) + +(defun org-clock-time% (total &rest strings) + "Compute a time fraction in percent. +TOTAL s a time string like 10:21 specifying the total times. +STRINGS is a list of strings that should be checked for a time. +The first string that does have a time will be used. +This function is made for clock tables." + (let ((re "\\([0-9]+\\):\\([0-9]+\\)") + tot s) + (save-match-data + (catch 'exit + (if (not (string-match re total)) + (throw 'exit 0.) + (setq tot (+ (string-to-number (match-string 2 total)) + (* 60 (string-to-number (match-string 1 total))))) + (if (= tot 0.) (throw 'exit 0.))) + (while (setq s (pop strings)) + (if (string-match "\\([0-9]+\\):\\([0-9]+\\)" s) + (throw 'exit + (/ (* 100.0 (+ (string-to-number (match-string 2 s)) + (* 60 (string-to-number + (match-string 1 s))))) + tot)))) + 0)))) + +(defvar org-clock-loaded nil + "Was the clock file loaded?") + +(defun org-clock-save () + "Persist various clock-related data to disk. +The details of what will be saved are regulated by the variable +`org-clock-persist'." + (when (and org-clock-persist + (or org-clock-loaded + org-clock-has-been-used + (not (file-exists-p org-clock-persist-file)))) + (let (b) + (with-current-buffer (find-file (expand-file-name org-clock-persist-file)) + (progn + (delete-region (point-min) (point-max)) + ;;Store clock + (insert (format ";; org-persist.el - %s at %s\n" + system-name (format-time-string + (cdr org-time-stamp-formats)))) + (if (and (memq org-clock-persist '(t clock)) + (setq b (org-clocking-buffer)) + (setq b (or (buffer-base-buffer b) b)) + (buffer-live-p b) + (buffer-file-name b) + (or (not org-clock-persist-query-save) + (y-or-n-p (concat "Save current clock (" + (substring-no-properties + org-clock-heading) + ") ")))) + (insert "(setq resume-clock '(\"" + (buffer-file-name (org-clocking-buffer)) + "\" . " (int-to-string (marker-position org-clock-marker)) + "))\n")) + ;; Store clocked task history. Tasks are stored reversed to make + ;; reading simpler + (when (and (memq org-clock-persist '(t history)) + org-clock-history) + (insert + "(setq stored-clock-history '(" + (mapconcat + (lambda (m) + (when (and (setq b (marker-buffer m)) + (setq b (or (buffer-base-buffer b) b)) + (buffer-live-p b) + (buffer-file-name b)) + (concat "(\"" (buffer-file-name b) + "\" . " (int-to-string (marker-position m)) + ")"))) + (reverse org-clock-history) " ") "))\n")) + (save-buffer) + (kill-buffer (current-buffer))))))) + +(defun org-clock-load () + "Load clock-related data from disk, maybe resuming a stored clock." + (when (and org-clock-persist (not org-clock-loaded)) + (let ((filename (expand-file-name org-clock-persist-file)) + (org-clock-in-resume 'auto-restart) + resume-clock stored-clock-history) + (if (not (file-readable-p filename)) + (message "Not restoring clock data; %s not found" + org-clock-persist-file) + (message "%s" "Restoring clock data") + (setq org-clock-loaded t) + (load-file filename) + ;; load history + (when stored-clock-history + (save-window-excursion + (mapc (lambda (task) + (if (file-exists-p (car task)) + (org-clock-history-push (cdr task) + (find-file (car task))))) + stored-clock-history))) + ;; resume clock + (when (and resume-clock org-clock-persist + (file-exists-p (car resume-clock)) + (or (not org-clock-persist-query-resume) + (y-or-n-p + (concat + "Resume clock (" + (with-current-buffer (find-file (car resume-clock)) + (save-excursion + (goto-char (cdr resume-clock)) + (org-back-to-heading t) + (and (looking-at org-complex-heading-regexp) + (match-string 4)))) + ") ")))) + (when (file-exists-p (car resume-clock)) + (with-current-buffer (find-file (car resume-clock)) + (goto-char (cdr resume-clock)) + (let ((org-clock-auto-clock-resolution nil)) + (org-clock-in) + (if (org-invisible-p) + (org-show-context)))))))))) + +;;;###autoload +(defun org-clock-persistence-insinuate () + "Set up hooks for clock persistence." + (add-hook 'org-mode-hook 'org-clock-load) + (add-hook 'kill-emacs-hook 'org-clock-save)) + +;; Suggested bindings +(org-defkey org-mode-map "\C-c\C-x\C-e" 'org-clock-modify-effort-estimate) + +(provide 'org-clock) + +;; arch-tag: 7b42c5d4-9b36-48be-97c0-66a869daed4c + +;;; org-clock.el ends here + diff --git a/.emacs.d/org-7.4/lisp/org-clock.elc b/.emacs.d/org-7.4/lisp/org-clock.elc Binary files differnew file mode 100644 index 0000000..7c9a932 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-clock.elc diff --git a/.emacs.d/org-7.4/lisp/org-colview-xemacs.el b/.emacs.d/org-7.4/lisp/org-colview-xemacs.el new file mode 100644 index 0000000..06a1253 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-colview-xemacs.el @@ -0,0 +1,1736 @@ +;;; org-colview-xemacs.el --- Column View in Org-mode, XEmacs-specific version + +;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010 +;; Free Software Foundation, Inc. + +;; Author: Carsten Dominik <carsten at orgmode dot org> +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; Version: 7.4 +;; +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: + +;; This file contains the column view for Org. + +;;; Code: + +(eval-when-compile (require 'cl)) +(require 'org) + +(declare-function org-agenda-redo "org-agenda" ()) + + +;;; Define additional faces for column view + +(when (featurep 'xemacs) + + (defface org-columns-level-1;; font-lock-function-name-face + (org-compatible-face + 'outline-1 + '((((class color) (min-colors 88) (background light)) (:foreground "Blue1" :background "grey90")) + (((class color) (min-colors 88) (background dark)) (:foreground "LightSkyBlue" :background "grey30")) + (((class color) (min-colors 16) (background light)) (:foreground "Blue" :background "grey90")) + (((class color) (min-colors 16) (background dark)) (:foreground "LightSkyBlue" :background "grey30")) + (((class color) (min-colors 8)) (:foreground "blue" :bold t)) + (t (:bold t)))) + "Face used for columns-level 1 headlines." + :group 'org-faces) + + (defface org-columns-level-2;; font-lock-variable-name-face + (org-compatible-face + 'outline-2 + '((((class color) (min-colors 16) (background light)) (:foreground "DarkGoldenrod" :background "grey90")) + (((class color) (min-colors 16) (background dark)) (:foreground "LightGoldenrod" :background "grey30")) + (((class color) (min-colors 8) (background light)) (:foreground "yellow" :background "grey90")) + (((class color) (min-colors 8) (background dark)) (:foreground "yellow" :bold t)) + (t (:bold t)))) + "Face used for columns-level 2 headlines." + :group 'org-faces) + + (defface org-columns-level-3;; font-lock-keyword-face + (org-compatible-face + 'outline-3 + '((((class color) (min-colors 88) (background light)) (:foreground "Purple" :background "grey90")) + (((class color) (min-colors 88) (background dark)) (:foreground "Cyan1" :background "grey30")) + (((class color) (min-colors 16) (background light)) (:foreground "Purple" :background "grey90")) + (((class color) (min-colors 16) (background dark)) (:foreground "Cyan" :background "grey30")) + (((class color) (min-colors 8) (background light)) (:foreground "purple" :bold t)) + (((class color) (min-colors 8) (background dark)) (:foreground "cyan" :bold t)) + (t (:bold t)))) + "Face used for columns-level 3 headlines." + :group 'org-faces) + + (defface org-columns-level-4;; font-lock-comment-face + (org-compatible-face + 'outline-4 + '((((class color) (min-colors 88) (background light)) (:foreground "Firebrick" :background "grey90")) + (((class color) (min-colors 88) (background dark)) (:foreground "chocolate1" :background "grey30")) + (((class color) (min-colors 16) (background light)) (:foreground "red")) + (((class color) (min-colors 16) (background dark)) (:foreground "red1")) + (((class color) (min-colors 8) (background light)) (:foreground "red" :bold t)) + (((class color) (min-colors 8) (background dark)) (:foreground "red" :bold t)) + (t (:bold t)))) + "Face used for columns-level 4 headlines." + :group 'org-faces) + + (defface org-columns-level-5;; font-lock-type-face + (org-compatible-face + 'outline-5 + '((((class color) (min-colors 16) (background light)) (:foreground "ForestGreen" :background "grey90")) + (((class color) (min-colors 16) (background dark)) (:foreground "PaleGreen" :background "grey30")) + (((class color) (min-colors 8)) (:foreground "green")))) + "Face used for columns-level 5 headlines." + :group 'org-faces) + + (defface org-columns-level-6;; font-lock-constant-face + (org-compatible-face + 'outline-6 + '((((class color) (min-colors 16) (background light)) (:foreground "CadetBlue" :background "grey90")) + (((class color) (min-colors 16) (background dark)) (:foreground "Aquamarine" :background "grey30")) + (((class color) (min-colors 8)) (:foreground "magenta")))) + "Face used for columns-level 6 headlines." + :group 'org-faces) + + (defface org-columns-level-7;; font-lock-builtin-face + (org-compatible-face + 'outline-7 + '((((class color) (min-colors 16) (background light)) (:foreground "Orchid" :background "grey90")) + (((class color) (min-colors 16) (background dark)) (:foreground "LightSteelBlue" :background "grey30")) + (((class color) (min-colors 8)) (:foreground "blue")))) + "Face used for columns-level 7 headlines." + :group 'org-faces) + + (defface org-columns-level-8;; font-lock-string-face + (org-compatible-face + 'outline-8 + '((((class color) (min-colors 16) (background light)) (:foreground "RosyBrown" :background "grey90")) + (((class color) (min-colors 16) (background dark)) (:foreground "LightSalmon" :background "grey30")) + (((class color) (min-colors 8)) (:foreground "green")))) + "Face used for columns-level 8 headlines." + :group 'org-faces) + + + (defface org-columns-space;; font-lock-function-name-face + (org-compatible-face + 'outline-1 + '((((class color) (min-colors 88) (background light)) (:background "grey90")) + (((class color) (min-colors 88) (background dark)) (:background "grey30")) + (((class color) (min-colors 16) (background light)) (:background "grey90")) + (((class color) (min-colors 16) (background dark)) (:background "grey30")) + (((class color) (min-colors 8)) (:bold t :underline t)))) + "Face used for columns space headlines." + :group 'org-faces) + + (defface org-columns-space1;; font-lock-function-name-face + (org-compatible-face + 'outline-1 + '((((class color) (min-colors 88) (background light)) (:background "grey90")) + (((class color) (min-colors 88) (background dark)) (:background "grey30")) + (((class color) (min-colors 16) (background light)) (:background "grey90")) + (((class color) (min-colors 16) (background dark)) (:background "grey30")) + (((class color) (min-colors 8)) (:bold t :underline t)))) + "Face used for columns space headlines." + :group 'org-faces) + ) + +(when (featurep 'xemacs) + (defconst org-columns-level-faces + '(org-columns-level-1 + org-columns-level-2 org-columns-level-3 + org-columns-level-4 org-columns-level-5 org-columns-level-6 + org-columns-level-7 org-columns-level-8 + )) + + (defun org-get-columns-level-face (n) + "Get the right face for match N in font-lock matching of headlines." + (setq org-l (- (match-end 2) (match-beginning 1) 1)) + (if org-odd-levels-only (setq org-l (1+ (/ org-l 2)))) + (setq org-f (nth (% (1- org-l) org-n-level-faces) org-columns-level-faces)) + (cond + ((eq n 1) (if org-hide-leading-stars 'org-hide org-f)) + ((eq n 2) org-f) + (t (if org-level-color-stars-only nil org-f)))) + ) + + +;;; Column View + +(defvar org-columns-overlays nil + "Holds the list of current column overlays.") + +(defvar org-columns-current-fmt nil + "Local variable, holds the currently active column format.") +(make-variable-buffer-local 'org-columns-current-fmt) +(defvar org-columns-current-fmt-compiled nil + "Local variable, holds the currently active column format. +This is the compiled version of the format.") +(make-variable-buffer-local 'org-columns-current-fmt-compiled) +(defvar org-columns-current-widths nil + "Local variable, holds the currently widths of fields.") +(make-variable-buffer-local 'org-columns-current-widths) +(defvar org-columns-current-maxwidths nil + "Local variable, holds the currently active maximum column widths.") +(make-variable-buffer-local 'org-columns-current-maxwidths) +(defvar org-columns-begin-marker (make-marker) + "Points to the position where last a column creation command was called.") +(defvar org-columns-top-level-marker (make-marker) + "Points to the position where current columns region starts.") + +(defvar org-columns-map (make-sparse-keymap) + "The keymap valid in column display.") + +(defun org-columns-content () + "Switch to contents view while in columns view." + (interactive) + (org-overview) + (org-content)) + +(org-defkey org-columns-map "c" 'org-columns-content) +(org-defkey org-columns-map "o" 'org-overview) +(org-defkey org-columns-map "e" 'org-columns-edit-value) +(org-defkey org-columns-map "\C-c\C-t" 'org-columns-todo) +(org-defkey org-columns-map "\C-c\C-c" 'org-columns-set-tags-or-toggle) +(org-defkey org-columns-map "\C-c\C-o" 'org-columns-open-link) +(org-defkey org-columns-map "v" 'org-columns-show-value) +(org-defkey org-columns-map "q" 'org-columns-quit) +(org-defkey org-columns-map "r" 'org-columns-redo) +(org-defkey org-columns-map "g" 'org-columns-redo) +(org-defkey org-columns-map [left] 'org-columns-backward-char) +(org-defkey org-columns-map "\M-b" 'org-columns-backward-char) +(org-defkey org-columns-map "a" 'org-columns-edit-allowed) +(org-defkey org-columns-map "s" 'org-columns-edit-attributes) +(org-defkey org-columns-map "\M-f" 'org-columns-forward-char) +(org-defkey org-columns-map [right] 'org-columns-forward-char) +(org-defkey org-columns-map [(shift right)] 'org-columns-next-allowed-value) +(org-defkey org-columns-map "n" 'org-columns-next-allowed-value) +(org-defkey org-columns-map [(shift left)] 'org-columns-previous-allowed-value) +(org-defkey org-columns-map "p" 'org-columns-previous-allowed-value) +(org-defkey org-columns-map "<" 'org-columns-narrow) +(org-defkey org-columns-map ">" 'org-columns-widen) +(org-defkey org-columns-map [(meta right)] 'org-columns-move-right) +(org-defkey org-columns-map [(meta left)] 'org-columns-move-left) +(org-defkey org-columns-map [(shift meta right)] 'org-columns-new) +(org-defkey org-columns-map [(shift meta left)] 'org-columns-delete) +(dotimes (i 10) + (org-defkey org-columns-map (number-to-string i) + `(lambda () (interactive) + (org-columns-next-allowed-value nil ,i)))) + +(easy-menu-define org-columns-menu org-columns-map "Org Column Menu" + '("Column" + ["Edit property" org-columns-edit-value t] + ["Next allowed value" org-columns-next-allowed-value t] + ["Previous allowed value" org-columns-previous-allowed-value t] + ["Show full value" org-columns-show-value t] + ["Edit allowed values" org-columns-edit-allowed t] + "--" + ["Edit column attributes" org-columns-edit-attributes t] + ["Increase column width" org-columns-widen t] + ["Decrease column width" org-columns-narrow t] + "--" + ["Move column right" org-columns-move-right t] + ["Move column left" org-columns-move-left t] + ["Add column" org-columns-new t] + ["Delete column" org-columns-delete t] + "--" + ["CONTENTS" org-columns-content t] + ["OVERVIEW" org-overview t] + ["Refresh columns display" org-columns-redo t] + "--" + ["Open link" org-columns-open-link t] + "--" + ["Quit" org-columns-quit t])) + +(defun org-columns-current-column () + (if (featurep 'xemacs) + (/ (current-column) 2) + (current-column))) + +(defun org-columns-forward-char () + (interactive) + (forward-char) + (if (featurep 'xemacs) + (while (not (or (eolp) + (member (extent-at + (point) (current-buffer) + 'org-columns-key) org-columns-overlays))) + (forward-char)))) + +(defun org-columns-backward-char () + (interactive) + (backward-char) + (if (featurep 'xemacs) + (while (not (or (bolp) + (member (extent-at (point) (current-buffer) 'org-columns-key) org-columns-overlays))) + (backward-char)))) + +(defun org-columns-new-overlay (beg end &optional string face) + "Create a new column overlay and add it to the list." + (let ((ov (make-overlay beg end))) + (if (featurep 'xemacs) + (progn + (overlay-put ov 'face (or face 'org-columns-space1)) + (overlay-put ov 'start-open t) + (if string + (org-overlay-display ov string (or face 'org-columns-space1)))) + (overlay-put ov 'face (or face 'secondary-selection)) + (org-overlay-display ov string face)) + (push ov org-columns-overlays) + ov)) + +(defun org-columns-display-here (&optional props) + "Overlay the current line with column display." + (interactive) + (let* ((fmt org-columns-current-fmt-compiled) + (beg (point-at-bol)) + (level-face (save-excursion + (beginning-of-line 1) + (and (looking-at "\\(\\**\\)\\(\\* \\)") + (org-get-level-face 2)))) + (item (save-match-data + (org-no-properties + (org-remove-tabs + (buffer-substring-no-properties + (point-at-bol) (point-at-eol)))))) + (color (if (featurep 'xemacs) + (save-excursion + (beginning-of-line 1) + (and (looking-at "\\(\\**\\)\\(\\* \\)") + (org-get-columns-level-face 2))) + (list :foreground + (face-attribute + (or level-face + (and (eq major-mode 'org-agenda-mode) + (get-text-property (point-at-bol) 'face)) + 'default) :foreground)))) + (face (if (featurep 'xemacs) color (list color 'org-column))) + (pl (or (get-text-property (point-at-bol) 'prefix-length) 0)) + (cphr (get-text-property (point-at-bol) 'org-complex-heading-regexp)) + pom property ass width f string ov column val modval s2 title calc) + ;; Check if the entry is in another buffer. + (unless props + (if (eq major-mode 'org-agenda-mode) + (setq pom (or (org-get-at-bol 'org-hd-marker) + (org-get-at-bol 'org-marker)) + props (if pom (org-entry-properties pom) nil)) + (setq props (org-entry-properties nil)))) + ;; Walk the format + (while (setq column (pop fmt)) + (setq property (car column) + title (nth 1 column) + ass (if (equal property "ITEM") + (cons "ITEM" item) + (assoc property props)) + width (or (cdr (assoc property org-columns-current-maxwidths)) + (nth 2 column) + (length property)) + f (format (if (featurep 'xemacs) "%%-%d.%ds |" "%%-%d.%ds | ") + width width) + val (or (cdr ass) "") + calc (nth 7 column) + modval (cond ((and org-columns-modify-value-for-display-function + (functionp + org-columns-modify-value-for-display-function)) + (funcall org-columns-modify-value-for-display-function + title val)) + ((equal property "ITEM") + (if (org-mode-p) + (org-columns-cleanup-item + val org-columns-current-fmt-compiled) + (org-agenda-columns-cleanup-item + val pl cphr org-columns-current-fmt-compiled))) + ((and calc (functionp calc) + (not (string= val "")) + (not (get-text-property 0 'org-computed val))) + (org-columns-number-to-string + (funcall calc (org-columns-string-to-number + val (nth 4 column))) + (nth 4 column))))) + (setq s2 (org-columns-add-ellipses (or modval val) width)) + (setq string (format f s2)) + ;; Create the overlay + (org-unmodified + (setq ov (org-columns-new-overlay + beg (setq beg (1+ beg)) string face)) + (overlay-put ov 'keymap org-columns-map) + (overlay-put ov 'org-columns-key property) + (overlay-put ov 'org-columns-value (cdr ass)) + (overlay-put ov 'org-columns-value-modified modval) + (overlay-put ov 'org-columns-pom pom) + (overlay-put ov 'org-columns-format f) + (when (featurep 'xemacs) + (if (or (not (char-after beg)) + (equal (char-after beg) ?\n)) + (let ((inhibit-read-only t)) + (save-excursion + (goto-char beg) + (org-unmodified (insert " ")) + ;; FIXME: add props and remove later? + ))) + (goto-char beg) + (org-columns-new-overlay + beg (1+ beg) nil 'org-columns-space) + (setq beg (1+ beg)))) + + (if (or (not (char-after beg)) + (equal (char-after beg) ?\n)) + (let ((inhibit-read-only t)) + (save-excursion + (goto-char beg) + ;; FIXME: add props and remove later? + (org-unmodified (insert " ")))))) + ;; Make the rest of the line disappear. + (org-unmodified + (setq ov (org-columns-new-overlay beg (point-at-eol))) + (overlay-put ov 'invisible t) + (overlay-put ov 'keymap org-columns-map) + (overlay-put ov 'intangible t) + (push ov org-columns-overlays) + (setq ov (make-overlay (1- (point-at-eol)) (1+ (point-at-eol)))) + (overlay-put ov 'keymap org-columns-map) + (push ov org-columns-overlays) + (let ((inhibit-read-only t)) + (put-text-property (max (point-min) (1- (point-at-bol))) + (min (point-max) (1+ (point-at-eol))) + 'read-only "Type `e' to edit property"))))) + +(defun org-columns-add-ellipses (string width) + "Truncate STRING with WIDTH characters, with ellipses." + (cond + ((<= (length string) width) string) + ((<= width (length org-columns-ellipses)) + (substring org-columns-ellipses 0 width)) + (t (concat (substring string 0 (- width (length org-columns-ellipses))) + org-columns-ellipses)))) + +(defvar org-columns-full-header-line-format nil + "The full header line format, will be shifted by horizontal scrolling." ) +(defvar org-previous-header-line-format nil + "The header line format before column view was turned on.") +(defvar org-columns-inhibit-recalculation nil + "Inhibit recomputing of columns on column view startup.") + + +(defvar header-line-format) +(defvar org-columns-previous-hscroll 0) + +(defun org-columns-display-here-title () + "Overlay the newline before the current line with the table title." + (interactive) + (let ((fmt org-columns-current-fmt-compiled) + string (title "") + property width f column str widths) + (while (setq column (pop fmt)) + (setq property (car column) + str (or (nth 1 column) property) + width (or (cdr (assoc property org-columns-current-maxwidths)) + (nth 2 column) + (length str)) + widths (push width widths) + f (format "%%-%d.%ds | " width width) + string (format f str) + title (concat title string))) + (if (featurep 'xemacs) + (let ((ext (make-extent nil nil))) + (set-extent-endpoints ext 0 (length title) title) + (set-extent-face ext (list 'bold 'underline 'org-columns-space1)) + (org-set-local 'org-previous-header-line-format + (specifier-specs top-gutter)) + (org-set-local 'org-columns-current-widths (nreverse widths)) + (set-specifier top-gutter (make-gutter-specifier + (cons (current-buffer) title)))) + (setq title (concat + (org-add-props " " nil 'display '(space :align-to 0)) + (org-add-props title nil 'face '(:weight bold :underline t)))) + (org-set-local 'org-previous-header-line-format header-line-format) + (org-set-local 'org-columns-current-widths (nreverse widths)) + (setq org-columns-full-header-line-format title) + (setq org-columns-previous-hscroll -1) + (org-add-hook 'post-command-hook 'org-columns-hscoll-title nil 'local)))) + +(defun org-columns-hscoll-title () + "Set the `header-line-format' so that it scrolls along with the table." + (sit-for .0001) ; need to force a redisplay to update window-hscroll + (when (not (= (window-hscroll) org-columns-previous-hscroll)) + (setq header-line-format + (concat (substring org-columns-full-header-line-format 0 1) + (substring org-columns-full-header-line-format + (1+ (window-hscroll)))) + org-columns-previous-hscroll (window-hscroll)) + (force-mode-line-update))) + +(defvar org-colview-initial-truncate-line-value nil + "Remember the value of `truncate-lines' across colview.") + +(defun org-columns-remove-overlays () + "Remove all currently active column overlays." + (interactive) + (when (marker-buffer org-columns-begin-marker) + (with-current-buffer (marker-buffer org-columns-begin-marker) + (when (local-variable-p 'org-previous-header-line-format (current-buffer)) + (if (featurep 'xemacs) + (set-specifier top-gutter + (make-gutter-specifier + (cons (current-buffer) + (cdar org-previous-header-line-format)))) + (setq header-line-format org-previous-header-line-format) + (remove-hook 'post-command-hook 'org-columns-hscoll-title 'local)) + (kill-local-variable 'org-previous-header-line-format)) + (move-marker org-columns-begin-marker nil) + (move-marker org-columns-top-level-marker nil) + (org-unmodified + (mapc 'delete-overlay org-columns-overlays) + (setq org-columns-overlays nil) + (let ((inhibit-read-only t)) + (remove-text-properties (point-min) (point-max) '(read-only t)))) + (when (local-variable-p 'org-colview-initial-truncate-line-value + (current-buffer)) + (setq truncate-lines org-colview-initial-truncate-line-value))))) + + +(defun org-columns-cleanup-item (item fmt) + "Remove from ITEM what is a column in the format FMT." + (if (not org-complex-heading-regexp) + item + (when (string-match org-complex-heading-regexp item) + (setq item + (concat + (org-add-props (match-string 1 item) nil + 'org-whitespace (* 2 (1- (org-reduced-level (- (match-end 1) (match-beginning 1)))))) + (and (match-end 2) (not (assoc "TODO" fmt)) (concat " " (match-string 2 item))) + (and (match-end 3) (not (assoc "PRIORITY" fmt)) (concat " " (match-string 3 item))) + " " (save-match-data (org-columns-compact-links (match-string 4 item))) + (and (match-end 5) (not (assoc "TAGS" fmt)) (concat " " (match-string 5 item))))) + (add-text-properties + 0 (1+ (match-end 1)) + (list 'org-whitespace (* 2 (1- (org-reduced-level (- (match-end 1) (match-beginning 1)))))) + item) + item))) + +(defun org-columns-compact-links (s) + "Replace [[link][desc]] with [desc] or [link]." + (while (string-match org-bracket-link-regexp s) + (setq s (replace-match + (concat "[" (match-string (if (match-end 3) 3 1) s) "]") + t t s))) + s) + +(defvar org-agenda-columns-remove-prefix-from-item) + +(defun org-agenda-columns-cleanup-item (item pl cphr fmt) + "Cleanup the time property for agenda column view. +See also the variable `org-agenda-columns-remove-prefix-from-item'." + (let* ((org-complex-heading-regexp cphr) + (prefix (substring item 0 pl)) + (rest (substring item pl)) + (fake (concat "* " rest)) + (cleaned (org-trim (substring (org-columns-cleanup-item fake fmt) 1)))) + (if org-agenda-columns-remove-prefix-from-item + cleaned + (concat prefix cleaned)))) + +(defun org-columns-show-value () + "Show the full value of the property." + (interactive) + (let ((value (get-char-property (point) 'org-columns-value))) + (message "Value is: %s" (or value "")))) + +(defvar org-agenda-columns-active) ;; defined in org-agenda.el + +(defun org-columns-quit () + "Remove the column overlays and in this way exit column editing." + (interactive) + (org-unmodified + (org-columns-remove-overlays) + (let ((inhibit-read-only t)) + (remove-text-properties (point-min) (point-max) '(read-only t)))) + (when (eq major-mode 'org-agenda-mode) + (setq org-agenda-columns-active nil) + (message + "Modification not yet reflected in Agenda buffer, use `r' to refresh"))) + +(defun org-columns-check-computed () + "Check if this column value is computed. +If yes, throw an error indicating that changing it does not make sense." + (let ((val (get-char-property (point) 'org-columns-value))) + (when (and (stringp val) + (get-char-property 0 'org-computed val)) + (error "This value is computed from the entry's children")))) + +(defun org-columns-todo (&optional arg) + "Change the TODO state during column view." + (interactive "P") + (org-columns-edit-value "TODO")) + +(defun org-columns-set-tags-or-toggle (&optional arg) + "Toggle checkbox at point, or set tags for current headline." + (interactive "P") + (if (string-match "\\`\\[[ xX-]\\]\\'" + (get-char-property (point) 'org-columns-value)) + (org-columns-next-allowed-value) + (org-columns-edit-value "TAGS"))) + +(defun org-columns-edit-value (&optional key) + "Edit the value of the property at point in column view. +Where possible, use the standard interface for changing this line." + (interactive) + (org-columns-check-computed) + (let* ((col (current-column)) + (key (or key (get-char-property (point) 'org-columns-key))) + (value (get-char-property (point) 'org-columns-value)) + (bol (point-at-bol)) (eol (point-at-eol)) + (pom (or (get-text-property bol 'org-hd-marker) + (point))) ; keep despite of compiler warning + (line-overlays + (delq nil (mapcar (lambda (x) + (and (eq (overlay-buffer x) (current-buffer)) + (>= (overlay-start x) bol) + (<= (overlay-start x) eol) + x)) + org-columns-overlays))) + (org-columns-time (time-to-number-of-days (current-time))) + nval eval allowed) + (cond + ((equal key "CLOCKSUM") + (error "This special column cannot be edited")) + ((equal key "ITEM") + (setq eval '(org-with-point-at pom (org-edit-headline)))) + ((equal key "TODO") + (setq eval '(org-with-point-at + pom + (call-interactively 'org-todo)))) + ((equal key "PRIORITY") + (setq eval '(org-with-point-at pom + (call-interactively 'org-priority)))) + ((equal key "TAGS") + (setq eval '(org-with-point-at + pom + (let ((org-fast-tag-selection-single-key + (if (eq org-fast-tag-selection-single-key 'expert) + t org-fast-tag-selection-single-key))) + (call-interactively 'org-set-tags))))) + ((equal key "DEADLINE") + (setq eval '(org-with-point-at + pom + (call-interactively 'org-deadline)))) + ((equal key "SCHEDULED") + (setq eval '(org-with-point-at + pom + (call-interactively 'org-schedule)))) + (t + (setq allowed (org-property-get-allowed-values pom key 'table)) + (if allowed + (setq nval (org-icompleting-read + "Value: " allowed nil + (not (get-text-property 0 'org-unrestricted + (caar allowed))))) + (setq nval (read-string "Edit: " value))) + (setq nval (org-trim nval)) + (when (not (equal nval value)) + (setq eval '(org-entry-put pom key nval))))) + (when eval + + (cond + ((equal major-mode 'org-agenda-mode) + (org-columns-eval eval) + ;; The following let preserves the current format, and makes sure + ;; that in only a single file things need to be upated. + (let* ((org-agenda-overriding-columns-format org-columns-current-fmt) + (buffer (marker-buffer pom)) + (org-agenda-contributing-files + (list (with-current-buffer buffer + (buffer-file-name (buffer-base-buffer)))))) + (org-agenda-columns))) + (t + (let ((inhibit-read-only t)) + (org-unmodified + (remove-text-properties + (max (point-min) (1- bol)) eol '(read-only t))) + (unwind-protect + (progn + (setq org-columns-overlays + (org-delete-all line-overlays org-columns-overlays)) + (mapc 'delete-overlay line-overlays) + (org-columns-eval eval)) + (org-columns-display-here))) + (org-move-to-column col) + (if (and (org-mode-p) + (nth 3 (assoc key org-columns-current-fmt-compiled))) + (org-columns-update key))))))) + +(defun org-edit-headline () ; FIXME: this is not columns specific. Make interactive????? Use from agenda???? + "Edit the current headline, the part without TODO keyword, TAGS." + (org-back-to-heading) + (when (looking-at org-todo-line-regexp) + (let ((pos (point)) + (pre (buffer-substring (match-beginning 0) (match-beginning 3))) + (txt (match-string 3)) + (post "") + txt2) + (if (string-match (org-re "[ \t]+:[[:alnum:]:_@#%]+:[ \t]*$") txt) + (setq post (match-string 0 txt) + txt (substring txt 0 (match-beginning 0)))) + (setq txt2 (read-string "Edit: " txt)) + (when (not (equal txt txt2)) + (goto-char pos) + (insert pre txt2 post) + (delete-region (point) (point-at-eol)) + (org-set-tags nil t))))) + +(defun org-columns-edit-allowed () + "Edit the list of allowed values for the current property." + (interactive) + (let* ((pom (or (org-get-at-bol 'org-marker) + (org-get-at-bol 'org-hd-marker) + (point))) + (key (get-char-property (point) 'org-columns-key)) + (key1 (concat key "_ALL")) + (allowed (org-entry-get pom key1 t)) + nval) + ;; FIXME: Cover editing TODO, TAGS etc in-buffer settings.???? + ;; FIXME: Write back to #+PROPERTY setting if that is needed. + (setq nval (read-string "Allowed: " allowed)) + (org-entry-put + (cond ((marker-position org-entry-property-inherited-from) + org-entry-property-inherited-from) + ((marker-position org-columns-top-level-marker) + org-columns-top-level-marker) + (t pom)) + key1 nval))) + +(defun org-columns-eval (form) + (let (hidep) + (save-excursion + (beginning-of-line 1) + ;; `next-line' is needed here, because it skips invisible line. + (condition-case nil (org-no-warnings (next-line 1)) (error nil)) + (setq hidep (org-on-heading-p 1))) + (eval form) + (and hidep (hide-entry)))) + +(defun org-columns-previous-allowed-value () + "Switch to the previous allowed value for this column." + (interactive) + (org-columns-next-allowed-value t)) + +(defun org-columns-next-allowed-value (&optional previous nth) + "Switch to the next allowed value for this column. +When PREVIOUS is set, go to the previous value. When NTH is +an integer, select that value." + (interactive) + (org-columns-check-computed) + (let* ((col (current-column)) + (key (get-char-property (point) 'org-columns-key)) + (value (get-char-property (point) 'org-columns-value)) + (bol (point-at-bol)) (eol (point-at-eol)) + (pom (or (get-text-property bol 'org-hd-marker) + (point))) ; keep despite of compiler waring + (line-overlays + (delq nil (mapcar (lambda (x) + (and (eq (overlay-buffer x) (current-buffer)) + (>= (overlay-start x) bol) + (<= (overlay-start x) eol) + x)) + org-columns-overlays))) + (allowed (or (org-property-get-allowed-values pom key) + (and (memq + (nth 4 (assoc key org-columns-current-fmt-compiled)) + '(checkbox checkbox-n-of-m checkbox-percent)) + '("[ ]" "[X]")) + (org-colview-construct-allowed-dates value))) + nval) + (when (integerp nth) + (setq nth (1- nth)) + (if (= nth -1) (setq nth 9))) + (when (equal key "ITEM") + (error "Cannot edit item headline from here")) + (unless (or allowed (member key '("SCHEDULED" "DEADLINE"))) + (error "Allowed values for this property have not been defined")) + (if (member key '("SCHEDULED" "DEADLINE")) + (setq nval (if previous 'earlier 'later)) + (if previous (setq allowed (reverse allowed))) + (cond + (nth + (setq nval (nth nth allowed)) + (if (not nval) + (error "There are only %d allowed values for property `%s'" + (length allowed) key))) + ((member value allowed) + (setq nval (or (car (cdr (member value allowed))) + (car allowed))) + (if (equal nval value) + (error "Only one allowed value for this property"))) + (t (setq nval (car allowed))))) + (cond + ((equal major-mode 'org-agenda-mode) + (org-columns-eval '(org-entry-put pom key nval)) + ;; The following let preserves the current format, and makes sure + ;; that in only a single file things need to be upated. + (let* ((org-agenda-overriding-columns-format org-columns-current-fmt) + (buffer (marker-buffer pom)) + (org-agenda-contributing-files + (list (with-current-buffer buffer + (buffer-file-name (buffer-base-buffer)))))) + (org-agenda-columns))) + (t + (let ((inhibit-read-only t)) + (remove-text-properties (1- bol) eol '(read-only t)) + (unwind-protect + (progn + (setq org-columns-overlays + (org-delete-all line-overlays org-columns-overlays)) + (mapc 'delete-overlay line-overlays) + (org-columns-eval '(org-entry-put pom key nval))) + (org-columns-display-here))) + (org-move-to-column col) + (and (nth 3 (assoc key org-columns-current-fmt-compiled)) + (org-columns-update key)))))) + +(defun org-colview-construct-allowed-dates (s) + "Construct a list of three dates around the date in S. +This respects the format of the time stamp in S, active or non-active, +and also including time or not. S must be just a time stamp, no text +around it." + (when (and s (string-match (concat "^" org-ts-regexp3 "$") s)) + (let* ((time (org-parse-time-string s 'nodefaults)) + (active (equal (string-to-char s) ?<)) + (fmt (funcall (if (nth 1 time) 'cdr 'car) org-time-stamp-formats)) + time-before time-after) + (unless active (setq fmt (concat "[" (substring fmt 1 -1) "]"))) + (setf (car time) (or (car time) 0)) + (setf (nth 1 time) (or (nth 1 time) 0)) + (setf (nth 2 time) (or (nth 2 time) 0)) + (setq time-before (copy-sequence time)) + (setq time-after (copy-sequence time)) + (setf (nth 3 time-before) (1- (nth 3 time))) + (setf (nth 3 time-after) (1+ (nth 3 time))) + (mapcar (lambda (x) (format-time-string fmt (apply 'encode-time x))) + (list time-before time time-after))))) + +(defun org-verify-version (task) + (cond + ((eq task 'columns) + (if (or (and (featurep 'xemacs) (not (featurep 'org-colview-xemacs))) + (and (not (featurep 'xemacs)) (< emacs-major-version 22))) + (error "This version of Emacs cannot run Column View"))))) + +(defun org-columns-open-link (&optional arg) + (interactive "P") + (let ((value (get-char-property (point) 'org-columns-value))) + (org-open-link-from-string value arg))) + +(defun org-columns-get-format-and-top-level () + (let (fmt) + (when (condition-case nil (org-back-to-heading) (error nil)) + (setq fmt (org-entry-get nil "COLUMNS" t))) + (setq fmt (or fmt org-columns-default-format)) + (org-set-local 'org-columns-current-fmt fmt) + (org-columns-compile-format fmt) + (if (marker-position org-entry-property-inherited-from) + (move-marker org-columns-top-level-marker + org-entry-property-inherited-from) + (move-marker org-columns-top-level-marker (point))) + fmt)) + +(defun org-columns () + "Turn on column view on an org-mode file." + (interactive) + (org-verify-version 'columns) + (when (featurep 'xemacs) + (set-face-foreground 'org-columns-space + (face-background 'org-columns-space))) + (org-columns-remove-overlays) + (move-marker org-columns-begin-marker (point)) + (let ((org-columns-time (time-to-number-of-days (current-time))) + beg end fmt cache maxwidths) + (setq fmt (org-columns-get-format-and-top-level)) + (save-excursion + (goto-char org-columns-top-level-marker) + (setq beg (point)) + (unless org-columns-inhibit-recalculation + (org-columns-compute-all)) + (setq end (or (condition-case nil (org-end-of-subtree t t) (error nil)) + (point-max))) + ;; Get and cache the properties + (goto-char beg) + (when (assoc "CLOCKSUM" org-columns-current-fmt-compiled) + (save-excursion + (save-restriction + (narrow-to-region beg end) + (org-clock-sum)))) + (while (re-search-forward (concat "^" outline-regexp) end t) + (if (and org-columns-skip-archived-trees + (looking-at (concat ".*:" org-archive-tag ":"))) + (org-end-of-subtree t) + (push (cons (org-current-line) (org-entry-properties)) cache))) + (when cache + (setq maxwidths (org-columns-get-autowidth-alist fmt cache)) + (org-set-local 'org-columns-current-maxwidths maxwidths) + (org-columns-display-here-title) + (unless (local-variable-p 'org-colview-initial-truncate-line-value + (current-buffer)) + (org-set-local 'org-colview-initial-truncate-line-value + truncate-lines)) + (setq truncate-lines t) + (mapc (lambda (x) + (org-goto-line (car x)) + (org-columns-display-here (cdr x))) + cache))))) + +(eval-when-compile (defvar org-columns-time)) + +(defvar org-columns-compile-map + '(("none" none +) + (":" add_times +) + ("+" add_numbers +) + ("$" currency +) + ("X" checkbox +) + ("X/" checkbox-n-of-m +) + ("X%" checkbox-percent +) + ("max" max_numbers max) + ("min" min_numbers min) + ("mean" mean_numbers + (lambda (&rest x) (/ (apply '+ x) (float (length x))))) + (":max" max_times max) + (":min" min_times min) + (":mean" mean_times + (lambda (&rest x) (/ (apply '+ x) (float (length x))))) + ("@min" min_age min (lambda (x) (- org-columns-time x))) + ("@max" max_age max (lambda (x) (- org-columns-time x))) + ("@mean" mean_age + (lambda (&rest x) (/ (apply '+ x) (float (length x)))) + (lambda (x) (- org-columns-time x))) + ("est+" estimate org-estimate-combine)) + "Operator <-> format,function,calc map. +Used to compile/uncompile columns format and completing read in +interactive function `org-columns-new'. + + operator string used in #+COLUMNS definition describing the + summary type + format symbol describing summary type selected interactively in + `org-columns-new' and internally in + `org-columns-number-to-string' and + `org-columns-string-to-number' + function called with a list of values as argument to calculate + the summary value + calc function called on every element before summarizing. This is + optional and should only be specified if needed") + + +(defun org-columns-new (&optional prop title width op fmt fun &rest rest) + "Insert a new column, to the left of the current column." + (interactive) + (let ((n (org-columns-current-column)) + (editp (and prop (assoc prop org-columns-current-fmt-compiled))) + cell) + (setq prop (org-icompleting-read + "Property: " (mapcar 'list (org-buffer-property-keys t nil t)) + nil nil prop)) + (setq title (read-string (concat "Column title [" prop "]: ") (or title prop))) + (setq width (read-string "Column width: " (if width (number-to-string width)))) + (if (string-match "\\S-" width) + (setq width (string-to-number width)) + (setq width nil)) + (setq fmt (org-icompleting-read "Summary [none]: " + (mapcar (lambda (x) (list (symbol-name (cadr x)))) org-columns-compile-map) + nil t)) + (setq fmt (intern fmt) + fun (cdr (assoc fmt (mapcar 'cdr org-columns-compile-map)))) + (if (eq fmt 'none) (setq fmt nil)) + (if editp + (progn + (setcar editp prop) + (setcdr editp (list title width nil fmt nil fun))) + (setq cell (nthcdr (1- n) org-columns-current-fmt-compiled)) + (setcdr cell (cons (list prop title width nil fmt nil + (car fun) (cadr fun)) + (cdr cell)))) + (org-columns-store-format) + (org-columns-redo))) + +(defun org-columns-delete () + "Delete the column at point from columns view." + (interactive) + (let* ((n (org-columns-current-column)) + (title (nth 1 (nth n org-columns-current-fmt-compiled)))) + (when (y-or-n-p + (format "Are you sure you want to remove column \"%s\"? " title)) + (setq org-columns-current-fmt-compiled + (delq (nth n org-columns-current-fmt-compiled) + org-columns-current-fmt-compiled)) + (org-columns-store-format) + (org-columns-redo) + (if (>= (org-columns-current-column) + (length org-columns-current-fmt-compiled)) + (org-columns-backward-char))))) + +(defun org-columns-edit-attributes () + "Edit the attributes of the current column." + (interactive) + (let* ((n (org-columns-current-column)) + (info (nth n org-columns-current-fmt-compiled))) + (apply 'org-columns-new info))) + +(defun org-columns-widen (arg) + "Make the column wider by ARG characters." + (interactive "p") + (let* ((n (org-columns-current-column)) + (entry (nth n org-columns-current-fmt-compiled)) + (width (or (nth 2 entry) + (cdr (assoc (car entry) org-columns-current-maxwidths))))) + (setq width (max 1 (+ width arg))) + (setcar (nthcdr 2 entry) width) + (org-columns-store-format) + (org-columns-redo))) + +(defun org-columns-narrow (arg) + "Make the column narrower by ARG characters." + (interactive "p") + (org-columns-widen (- arg))) + +(defun org-columns-move-right () + "Swap this column with the one to the right." + (interactive) + (let* ((n (org-columns-current-column)) + (cell (nthcdr n org-columns-current-fmt-compiled)) + e) + (when (>= n (1- (length org-columns-current-fmt-compiled))) + (error "Cannot shift this column further to the right")) + (setq e (car cell)) + (setcar cell (car (cdr cell))) + (setcdr cell (cons e (cdr (cdr cell)))) + (org-columns-store-format) + (org-columns-redo) + (org-columns-forward-char))) + +(defun org-columns-move-left () + "Swap this column with the one to the left." + (interactive) + (let* ((n (org-columns-current-column))) + (when (= n 0) + (error "Cannot shift this column further to the left")) + (org-columns-backward-char) + (org-columns-move-right) + (org-columns-backward-char))) + +(defun org-columns-store-format () + "Store the text version of the current columns format in appropriate place. +This is either in the COLUMNS property of the node starting the current column +display, or in the #+COLUMNS line of the current buffer." + (let (fmt (cnt 0)) + (setq fmt (org-columns-uncompile-format org-columns-current-fmt-compiled)) + (org-set-local 'org-columns-current-fmt fmt) + (if (marker-position org-columns-top-level-marker) + (save-excursion + (goto-char org-columns-top-level-marker) + (if (and (org-at-heading-p) + (org-entry-get nil "COLUMNS")) + (org-entry-put nil "COLUMNS" fmt) + (goto-char (point-min)) + ;; Overwrite all #+COLUMNS lines.... + (while (re-search-forward "^#\\+COLUMNS:.*" nil t) + (setq cnt (1+ cnt)) + (replace-match (concat "#+COLUMNS: " fmt) t t)) + (unless (> cnt 0) + (goto-char (point-min)) + (or (org-on-heading-p t) (outline-next-heading)) + (let ((inhibit-read-only t)) + (insert-before-markers "#+COLUMNS: " fmt "\n"))) + (org-set-local 'org-columns-default-format fmt)))))) + +(defvar org-agenda-overriding-columns-format nil + "When set, overrides any other format definition for the agenda. +Don't set this, this is meant for dynamic scoping.") + +(defun org-columns-get-autowidth-alist (s cache) + "Derive the maximum column widths from the format and the cache." + (let ((start 0) rtn) + (while (string-match (org-re "%\\([[:alpha:]][[:alnum:]_-]*\\)") s start) + (push (cons (match-string 1 s) 1) rtn) + (setq start (match-end 0))) + (mapc (lambda (x) + (setcdr x (apply 'max + (mapcar + (lambda (y) + (length (or (cdr (assoc (car x) (cdr y))) " "))) + cache)))) + rtn) + rtn)) + +(defun org-columns-compute-all () + "Compute all columns that have operators defined." + (org-unmodified + (remove-text-properties (point-min) (point-max) '(org-summaries t))) + (let ((columns org-columns-current-fmt-compiled) + (org-columns-time (time-to-number-of-days (current-time))) + col) + (while (setq col (pop columns)) + (when (nth 3 col) + (save-excursion + (org-columns-compute (car col))))))) + +(defun org-columns-update (property) + "Recompute PROPERTY, and update the columns display for it." + (org-columns-compute property) + (let (fmt val pos face) + (save-excursion + (mapc (lambda (ov) + (when (equal (overlay-get ov 'org-columns-key) property) + (setq pos (overlay-start ov)) + (goto-char pos) + (when (setq val (cdr (assoc property + (get-text-property + (point-at-bol) 'org-summaries)))) + (setq fmt (overlay-get ov 'org-columns-format)) + (overlay-put ov 'org-columns-value val) + (if (featurep 'xemacs) + (progn + (setq face (glyph-face (extent-end-glyph ov))) + (org-overlay-display ov (format fmt val) face)) + (org-overlay-display ov (format fmt val)))))) + org-columns-overlays)))) + +(defun org-columns-compute (property) + "Sum the values of property PROPERTY hierarchically, for the entire buffer." + (interactive) + (let* ((re (concat "^" outline-regexp)) + (lmax 30) ; Does anyone use deeper levels??? + (lvals (make-vector lmax nil)) + (lflag (make-vector lmax nil)) + (level 0) + (ass (assoc property org-columns-current-fmt-compiled)) + (format (nth 4 ass)) + (printf (nth 5 ass)) + (fun (nth 6 ass)) + (calc (or (nth 7 ass) 'identity)) + (beg org-columns-top-level-marker) + last-level val valflag flag end sumpos sum-alist sum str str1 useval) + (save-excursion + ;; Find the region to compute + (goto-char beg) + (setq end (condition-case nil (org-end-of-subtree t) (error (point-max)))) + (goto-char end) + ;; Walk the tree from the back and do the computations + (while (re-search-backward re beg t) + (setq sumpos (match-beginning 0) + last-level level + level (org-outline-level) + val (org-entry-get nil property) + valflag (and val (string-match "\\S-" val))) + (cond + ((< level last-level) + ;; put the sum of lower levels here as a property + (setq sum (when (aref lvals last-level) + (apply fun (aref lvals last-level))) + flag (aref lflag last-level) ; any valid entries from children? + str (org-columns-number-to-string sum format printf) + str1 (org-add-props (copy-sequence str) nil 'org-computed t 'face 'bold) + useval (if flag str1 (if valflag val "")) + sum-alist (get-text-property sumpos 'org-summaries)) + (if (assoc property sum-alist) + (setcdr (assoc property sum-alist) useval) + (push (cons property useval) sum-alist) + (org-unmodified + (add-text-properties sumpos (1+ sumpos) + (list 'org-summaries sum-alist)))) + (when (and val (not (equal val (if flag str val)))) + (org-entry-put nil property (if flag str val))) + ;; add current to current level accumulator + (when (or flag valflag) + (push (if flag + sum + (funcall calc (org-columns-string-to-number + (if flag str val) format))) + (aref lvals level)) + (aset lflag level t)) + ;; clear accumulators for deeper levels + (loop for l from (1+ level) to (1- lmax) do + (aset lvals l nil) + (aset lflag l nil))) + ((>= level last-level) + ;; add what we have here to the accumulator for this level + (when valflag + (push (funcall calc (org-columns-string-to-number val format)) + (aref lvals level)) + (aset lflag level t))) + (t (error "This should not happen"))))))) + +(defun org-columns-redo () + "Construct the column display again." + (interactive) + (message "Recomputing columns...") + (save-excursion + (if (marker-position org-columns-begin-marker) + (goto-char org-columns-begin-marker)) + (org-columns-remove-overlays) + (if (org-mode-p) + (call-interactively 'org-columns) + (org-agenda-redo) + (call-interactively 'org-agenda-columns))) + (when (featurep 'xemacs) + (while (not (or (eolp) + (member (extent-at (point)) org-columns-overlays))) + (forward-char))) + (message "Recomputing columns...done")) + +(defun org-columns-not-in-agenda () + (if (eq major-mode 'org-agenda-mode) + (error "This command is only allowed in Org-mode buffers"))) + +(defun org-string-to-number (s) + "Convert string to number, and interpret hh:mm:ss." + (if (not (string-match ":" s)) + (string-to-number s) + (let ((l (nreverse (org-split-string s ":"))) (sum 0.0)) + (while l + (setq sum (+ (string-to-number (pop l)) (/ sum 60)))) + sum))) + +(defun org-columns-number-to-string (n fmt &optional printf) + "Convert a computed column number to a string value, according to FMT." + (cond + ((memq fmt '(estimate)) (org-estimate-print n printf)) + ((not (numberp n)) "") + ((memq fmt '(add_times max_times min_times mean_times)) + (let* ((h (floor n)) (m (floor (+ 0.5 (* 60 (- n h)))))) + (format org-time-clocksum-format h m))) + ((eq fmt 'checkbox) + (cond ((= n (floor n)) "[X]") + ((> n 1.) "[-]") + (t "[ ]"))) + ((memq fmt '(checkbox-n-of-m checkbox-percent)) + (let* ((n1 (floor n)) (n2 (floor (+ .5 (* 1000000 (- n n1)))))) + (org-nofm-to-completion n1 (+ n2 n1) (eq fmt 'checkbox-percent)))) + (printf (format printf n)) + ((eq fmt 'currency) + (format "%.2f" n)) + ((memq fmt '(min_age max_age mean_age)) + (org-format-time-period n)) + (t (number-to-string n)))) + +(defun org-nofm-to-completion (n m &optional percent) + (if (not percent) + (format "[%d/%d]" n m) + (format "[%d%%]"(floor (+ 0.5 (* 100. (/ (* 1.0 n) m))))))) + +(defun org-columns-string-to-number (s fmt) + "Convert a column value to a number that can be used for column computing." + (if s + (cond + ((memq fmt '(min_age max_age mean_age)) + (cond ((string= s "") org-columns-time) + ((string-match + "\\([0-9]+\\)d \\([0-9]+\\)h \\([0-9]+\\)m \\([0-9]+\\)s" + s) + (+ (* 60 (+ (* 60 (+ (* 24 (string-to-number (match-string 1 s))) + (string-to-number (match-string 2 s)))) + (string-to-number (match-string 3 s)))) + (string-to-number (match-string 4 s)))) + (t (time-to-number-of-days (apply 'encode-time + (org-parse-time-string s t)))))) + ((string-match ":" s) + (let ((l (nreverse (org-split-string s ":"))) (sum 0.0)) + (while l + (setq sum (+ (string-to-number (pop l)) (/ sum 60)))) + sum)) + ((memq fmt '(checkbox checkbox-n-of-m checkbox-percent)) + (if (equal s "[X]") 1. 0.000001)) + ((memq fmt '(estimate)) (org-string-to-estimate s)) + (t (string-to-number s))))) + +(defun org-columns-uncompile-format (cfmt) + "Turn the compiled columns format back into a string representation." + (let ((rtn "") e s prop title op op-match width fmt printf fun calc) + (while (setq e (pop cfmt)) + (setq prop (car e) + title (nth 1 e) + width (nth 2 e) + op (nth 3 e) + fmt (nth 4 e) + printf (nth 5 e) + fun (nth 6 e) + calc (nth 7 e)) + (when (setq op-match (rassoc (list fmt fun calc) org-columns-compile-map)) + (setq op (car op-match))) + (if (and op printf) (setq op (concat op ";" printf))) + (if (equal title prop) (setq title nil)) + (setq s (concat "%" (if width (number-to-string width)) + prop + (if title (concat "(" title ")")) + (if op (concat "{" op "}")))) + (setq rtn (concat rtn " " s))) + (org-trim rtn))) + +(defun org-columns-compile-format (fmt) + "Turn a column format string into an alist of specifications. +The alist has one entry for each column in the format. The elements of +that list are: +property the property +title the title field for the columns +width the column width in characters, can be nil for automatic +operator the operator if any +format the output format for computed results, derived from operator +printf a printf format for computed values +fun the lisp function to compute summary values, derived from operator +calc function to get values from base elements" + (let ((start 0) width prop title op op-match f printf fun calc) + (setq org-columns-current-fmt-compiled nil) + (while (string-match + (org-re "%\\([0-9]+\\)?\\([[:alnum:]_-]+\\)\\(?:(\\([^)]+\\))\\)?\\(?:{\\([^}]+\\)}\\)?\\s-*") + fmt start) + (setq start (match-end 0) + width (match-string 1 fmt) + prop (match-string 2 fmt) + title (or (match-string 3 fmt) prop) + op (match-string 4 fmt) + f nil + printf nil + fun '+ + calc nil) + (if width (setq width (string-to-number width))) + (when (and op (string-match ";" op)) + (setq printf (substring op (match-end 0)) + op (substring op 0 (match-beginning 0)))) + (when (setq op-match (assoc op org-columns-compile-map)) + (setq f (cadr op-match) + fun (caddr op-match) + calc (cadddr op-match))) + (push (list prop title width op f printf fun calc) + org-columns-current-fmt-compiled)) + (setq org-columns-current-fmt-compiled + (nreverse org-columns-current-fmt-compiled)))) + + +;;; Dynamic block for Column view + +(defun org-columns-capture-view (&optional maxlevel skip-empty-rows) + "Get the column view of the current buffer or subtree. +The first optional argument MAXLEVEL sets the level limit. A +second optional argument SKIP-EMPTY-ROWS tells whether to skip +empty rows, an empty row being one where all the column view +specifiers except ITEM are empty. This function returns a list +containing the title row and all other rows. Each row is a list +of fields." + (if (featurep 'xemacs) + (save-excursion + (let* ((title (mapcar 'cadr org-columns-current-fmt-compiled)) + (re-comment (concat "\\*+[ \t]+" org-comment-string "\\>")) + (re-archive (concat ".*:" org-archive-tag ":")) + (n (length title)) row tbl) + (goto-char (point-min)) + + (while (re-search-forward "^\\(\\*+\\) " nil t) + (catch 'next + (when (and (or (null maxlevel) + (>= maxlevel + (if org-odd-levels-only + (/ (1+ (length (match-string 1))) 2) + (length (match-string 1))))) + (get-char-property (match-beginning 0) 'org-columns-key)) + (goto-char (match-beginning 0)) + (when (save-excursion + (goto-char (point-at-bol)) + (or (looking-at re-comment) + (looking-at re-archive))) + (org-end-of-subtree t) + (throw 'next t)) + (setq row nil) + (loop for i from 0 to (1- n) do + (push + (org-quote-vert + (or (get-char-property (point) + 'org-columns-value-modified) + (get-char-property (point) 'org-columns-value) + "")) + row) + (org-columns-forward-char)) + (setq row (nreverse row)) + (unless (and skip-empty-rows + (eq 1 (length (delete "" (delete-dups (copy-sequence row)))))) + (push row tbl))))) + (append (list title 'hline) (nreverse tbl)))) + (save-excursion + (let* ((title (mapcar 'cadr org-columns-current-fmt-compiled)) + (n (length title)) row tbl) + (goto-char (point-min)) + (while (and (re-search-forward "^\\(\\*+\\) " nil t) + (or (null maxlevel) + (>= maxlevel + (if org-odd-levels-only + (/ (1+ (length (match-string 1))) 2) + (length (match-string 1)))))) + (when (get-char-property (match-beginning 0) 'org-columns-key) + (setq row nil) + (loop for i from 0 to (1- n) do + (push (or (get-char-property (+ (match-beginning 0) i) + 'org-columns-value-modified) + (get-char-property (+ (match-beginning 0) i) + 'org-columns-value) + "") + row)) + (setq row (nreverse row)) + (unless (and skip-empty-rows + (eq 1 (length (delete "" (delete-dups row))))) + (push row tbl)))) + (append (list title 'hline) (nreverse tbl)))))) + +(defun org-dblock-write:columnview (params) + "Write the column view table. +PARAMS is a property list of parameters: + +:width enforce same column widths with <N> specifiers. +:id the :ID: property of the entry where the columns view + should be built. When the symbol `local', call locally. + When `global' call column view with the cursor at the beginning + of the buffer (usually this means that the whole buffer switches + to column view). When \"file:path/to/file.org\", invoke column + view at the start of that file. Otherwise, the ID is located + using `org-id-find'. +:hlines When t, insert a hline before each item. When a number, insert + a hline before each level <= that number. +:vlines When t, make each column a colgroup to enforce vertical lines. +:maxlevel When set to a number, don't capture headlines below this level. +:skip-empty-rows + When t, skip rows where all specifiers other than ITEM are empty." + (let ((pos (move-marker (make-marker) (point))) + (hlines (plist-get params :hlines)) + (vlines (plist-get params :vlines)) + (maxlevel (plist-get params :maxlevel)) + (content-lines (org-split-string (plist-get params :content) "\n")) + (skip-empty-rows (plist-get params :skip-empty-rows)) + tbl id idpos nfields tmp recalc line + id-as-string view-file view-pos) + (when (setq id (plist-get params :id)) + (setq id-as-string (cond ((numberp id) (number-to-string id)) + ((symbolp id) (symbol-name id)) + ((stringp id) id) + (t ""))) + (cond ((not id) nil) + ((eq id 'global) (setq view-pos (point-min))) + ((eq id 'local)) + ((string-match "^file:\\(.*\\)" id-as-string) + (setq view-file (match-string 1 id-as-string) + view-pos 1) + (unless (file-exists-p view-file) + (error "No such file: \"%s\"" id-as-string))) + ((setq idpos (org-find-entry-with-id id)) + (setq view-pos idpos)) + ((setq idpos (org-id-find id)) + (setq view-file (car idpos)) + (setq view-pos (cdr idpos))) + (t (error "Cannot find entry with :ID: %s" id)))) + (with-current-buffer (if view-file + (get-file-buffer view-file) + (current-buffer)) + (save-excursion + (save-restriction + (widen) + (goto-char (or view-pos (point))) + (org-columns) + (setq tbl (org-columns-capture-view maxlevel skip-empty-rows)) + (setq nfields (length (car tbl))) + (org-columns-quit)))) + (goto-char pos) + (move-marker pos nil) + (when tbl + (when (plist-get params :hlines) + (setq tmp nil) + (while tbl + (if (eq (car tbl) 'hline) + (push (pop tbl) tmp) + (if (string-match "\\` *\\(\\*+\\)" (caar tbl)) + (if (and (not (eq (car tmp) 'hline)) + (or (eq hlines t) + (and (numberp hlines) + (<= (- (match-end 1) (match-beginning 1)) + hlines)))) + (push 'hline tmp))) + (push (pop tbl) tmp))) + (setq tbl (nreverse tmp))) + (when vlines + (setq tbl (mapcar (lambda (x) + (if (eq 'hline x) x (cons "" x))) + tbl)) + (setq tbl (append tbl (list (cons "/" (make-list nfields "<>")))))) + (setq pos (point)) + (when content-lines + (while (string-match "^#" (car content-lines)) + (insert (pop content-lines) "\n"))) + (insert (org-listtable-to-string tbl)) + (when (plist-get params :width) + (insert "\n|" (mapconcat (lambda (x) (format "<%d>" (max 3 x))) + org-columns-current-widths "|"))) + (while (setq line (pop content-lines)) + (when (string-match "^#" line) + (insert "\n" line) + (when (string-match "^[ \t]*#\\+TBLFM" line) + (setq recalc t)))) + (if recalc + (progn (goto-char pos) (org-table-recalculate 'all)) + (goto-char pos) + (org-table-align))))) + +(defun org-listtable-to-string (tbl) + "Convert a listtable TBL to a string that contains the Org-mode table. +The table still need to be aligned. The resulting string has no leading +and tailing newline characters." + (mapconcat + (lambda (x) + (cond + ((listp x) + (concat "|" (mapconcat 'identity x "|") "|")) + ((eq x 'hline) "|-|") + (t (error "Garbage in listtable: %s" x)))) + tbl "\n")) + +(defun org-insert-columns-dblock () + "Create a dynamic block capturing a column view table." + (interactive) + (when (featurep 'xemacs) (org-columns-quit)) + (let ((defaults '(:name "columnview" :hlines 1)) + (id (org-icompleting-read + "Capture columns (local, global, entry with :ID: property) [local]: " + (append '(("global") ("local")) + (mapcar 'list (org-property-values "ID")))))) + (if (equal id "") (setq id 'local)) + (if (equal id "global") (setq id 'global)) + (setq defaults (append defaults (list :id id))) + (org-create-dblock defaults) + (org-update-dblock))) + +;;; Column view in the agenda + +(defvar org-agenda-view-columns-initially nil + "When set, switch to columns view immediately after creating the agenda.") + +(defvar org-agenda-columns-show-summaries) ; defined in org-agenda.el +(defvar org-agenda-columns-compute-summary-properties); defined in org-agenda.el +(defvar org-agenda-columns-add-appointments-to-effort-sum); as well + +(defun org-agenda-columns () + "Turn on or update column view in the agenda." + (interactive) + (org-verify-version 'columns) + (org-columns-remove-overlays) + (move-marker org-columns-begin-marker (point)) + (let ((org-columns-time (time-to-number-of-days (current-time))) + cache maxwidths m p a d fmt) + (cond + ((and (boundp 'org-agenda-overriding-columns-format) + org-agenda-overriding-columns-format) + (setq fmt org-agenda-overriding-columns-format) + (org-set-local 'org-agenda-overriding-columns-format fmt)) + ((setq m (org-get-at-bol 'org-hd-marker)) + (setq fmt (or (org-entry-get m "COLUMNS" t) + (with-current-buffer (marker-buffer m) + org-columns-default-format)))) + ((and (boundp 'org-columns-current-fmt) + (local-variable-p 'org-columns-current-fmt (current-buffer)) + org-columns-current-fmt) + (setq fmt org-columns-current-fmt)) + ((setq m (next-single-property-change (point-min) 'org-hd-marker)) + (setq m (get-text-property m 'org-hd-marker)) + (setq fmt (or (org-entry-get m "COLUMNS" t) + (with-current-buffer (marker-buffer m) + org-columns-default-format))))) + (setq fmt (or fmt org-columns-default-format)) + (org-set-local 'org-columns-current-fmt fmt) + (org-columns-compile-format fmt) + (when org-agenda-columns-compute-summary-properties + (org-agenda-colview-compute org-columns-current-fmt-compiled)) + (save-excursion + ;; Get and cache the properties + (goto-char (point-min)) + (while (not (eobp)) + (when (setq m (or (org-get-at-bol 'org-hd-marker) + (org-get-at-bol 'org-marker))) + (setq p (org-entry-properties m)) + + (when (or (not (setq a (assoc org-effort-property p))) + (not (string-match "\\S-" (or (cdr a) "")))) + ;; OK, the property is not defined. Use appointment duration? + (when (and org-agenda-columns-add-appointments-to-effort-sum + (setq d (get-text-property (point) 'duration))) + (setq d (org-minutes-to-hh:mm-string d)) + (put-text-property 0 (length d) 'face 'org-warning d) + (push (cons org-effort-property d) p))) + (push (cons (org-current-line) p) cache)) + (beginning-of-line 2)) + (when cache + (setq maxwidths (org-columns-get-autowidth-alist fmt cache)) + (org-set-local 'org-columns-current-maxwidths maxwidths) + (org-columns-display-here-title) + (mapc (lambda (x) + (org-goto-line (car x)) + (org-columns-display-here (cdr x))) + cache) + (when org-agenda-columns-show-summaries + (org-agenda-colview-summarize cache)))))) + +(defun org-agenda-colview-summarize (cache) + "Summarize the summarizable columns in column view in the agenda. +This will add overlays to the date lines, to show the summary for each day." + (let* ((fmt (mapcar (lambda (x) + (if (equal (car x) "CLOCKSUM") + (list "CLOCKSUM" (nth 2 x) nil 'add_times nil '+ 'identity) + (cdr x))) + org-columns-current-fmt-compiled)) + line c c1 stype calc sumfunc props lsum entries prop v) + (catch 'exit + (when (delq nil (mapcar 'cadr fmt)) + ;; OK, at least one summation column, it makes sense to try this + (goto-char (point-max)) + (while t + (when (or (get-text-property (point) 'org-date-line) + (eq (get-text-property (point) 'face) + 'org-agenda-structure)) + ;; OK, this is a date line that should be used + (setq line (org-current-line)) + (setq entries nil c cache cache nil) + (while (setq c1 (pop c)) + (if (> (car c1) line) + (push c1 entries) + (push c1 cache))) + ;; now ENTRIES are the ones we want to use, CACHE is the rest + ;; Compute the summaries for the properties we want, + ;; set nil properties for the rest. + (when (setq entries (mapcar 'cdr entries)) + (setq props + (mapcar + (lambda (f) + (setq prop (car f) + stype (nth 3 f) + sumfunc (nth 5 f) + calc (or (nth 6 f) 'identity)) + (cond + ((equal prop "ITEM") + (cons prop (buffer-substring (point-at-bol) + (point-at-eol)))) + ((not stype) (cons prop "")) + (t ;; do the summary + (setq lsum nil) + (dolist (x entries) + (setq v (cdr (assoc prop x))) + (if v + (push + (funcall + (if (not (get-text-property 0 'org-computed v)) + calc + 'identity) + (org-columns-string-to-number + v stype)) + lsum))) + (setq lsum (remove nil lsum)) + (setq lsum + (cond ((> (length lsum) 1) + (org-columns-number-to-string + (apply sumfunc lsum) stype)) + ((eq (length lsum) 1) + (org-columns-number-to-string + (car lsum) stype)) + (t ""))) + (put-text-property 0 (length lsum) 'face 'bold lsum) + (unless (eq calc 'identity) + (put-text-property 0 (length lsum) 'org-computed t lsum)) + (cons prop lsum)))) + fmt)) + (org-columns-display-here props) + (org-set-local 'org-agenda-columns-active t))) + (if (bobp) (throw 'exit t)) + (beginning-of-line 0)))))) + +(defun org-agenda-colview-compute (fmt) + "Compute the relevant columns in the contributing source buffers." + (let ((files org-agenda-contributing-files) + (org-columns-begin-marker (make-marker)) + (org-columns-top-level-marker (make-marker)) + f fm a b) + (while (setq f (pop files)) + (setq b (find-buffer-visiting f)) + (with-current-buffer (or (buffer-base-buffer b) b) + (save-excursion + (save-restriction + (widen) + (org-unmodified + (remove-text-properties (point-min) (point-max) + '(org-summaries t))) + (goto-char (point-min)) + (org-columns-get-format-and-top-level) + (while (setq fm (pop fmt)) + (if (equal (car fm) "CLOCKSUM") + (org-clock-sum) + (when (and (nth 4 fm) + (setq a (assoc (car fm) + org-columns-current-fmt-compiled)) + (equal (nth 4 a) (nth 4 fm))) + (org-columns-compute (car fm))))))))))) + +(defun org-format-time-period (interval) + "Convert time in fractional days to days/hours/minutes/seconds." + (if (numberp interval) + (let* ((days (floor interval)) + (frac-hours (* 24 (- interval days))) + (hours (floor frac-hours)) + (minutes (floor (* 60 (- frac-hours hours)))) + (seconds (floor (* 60 (- (* 60 (- frac-hours hours)) minutes))))) + (format "%dd %02dh %02dm %02ds" days hours minutes seconds)) + "")) + +(defun org-estimate-mean-and-var (v) + "Return the mean and variance of an estimate." + (let* ((low (float (car v))) + (high (float (cadr v))) + (mean (/ (+ low high) 2.0)) + (var (/ (+ (expt (- mean low) 2.0) (expt (- high mean) 2.0)) 2.0))) + (list mean var))) + +(defun org-estimate-combine (&rest el) + "Combine a list of estimates, using mean and variance. +The mean and variance of the result will be the sum of the means +and variances (respectively) of the individual estimates." + (let ((mean 0) + (var 0)) + (mapc (lambda (e) + (let ((stats (org-estimate-mean-and-var e))) + (setq mean (+ mean (car stats))) + (setq var (+ var (cadr stats))))) + el) + (let ((stdev (sqrt var))) + (list (- mean stdev) (+ mean stdev))))) + +(defun org-estimate-print (e &optional fmt) + "Prepare a string representation of an estimate. +This formats these numbers as two numbers with a \"-\" between them." + (if (null fmt) (set 'fmt "%.0f")) + (format "%s" (mapconcat (lambda (n) (format fmt n)) e "-"))) + +(defun org-string-to-estimate (s) + "Convert a string to an estimate. +The string should be two numbers joined with a \"-\"." + (if (string-match "\\(.*\\)-\\(.*\\)" s) + (list (string-to-number (match-string 1 s)) + (string-to-number(match-string 2 s))) + (list (string-to-number s) (string-to-number s)))) + +(provide 'org-colview) +(provide 'org-colview-xemacs) + +;;; org-colview-xemacs.el ends here diff --git a/.emacs.d/org-7.4/lisp/org-colview-xemacs.elc b/.emacs.d/org-7.4/lisp/org-colview-xemacs.elc Binary files differnew file mode 100644 index 0000000..d4efe65 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-colview-xemacs.elc diff --git a/.emacs.d/org-7.4/lisp/org-colview.el b/.emacs.d/org-7.4/lisp/org-colview.el new file mode 100644 index 0000000..c4f18c7 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-colview.el @@ -0,0 +1,1542 @@ +;;; org-colview.el --- Column View in Org-mode + +;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010 +;; Free Software Foundation, Inc. + +;; Author: Carsten Dominik <carsten at orgmode dot org> +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; Version: 7.4 +;; +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: + +;; This file contains the column view for Org. + +;;; Code: + +(eval-when-compile (require 'cl)) +(require 'org) + +(declare-function org-agenda-redo "org-agenda" ()) +(declare-function org-agenda-do-context-action "org-agenda" ()) + +(when (featurep 'xemacs) + (error "Do not load this file into XEmacs, use 'org-colview-xemacs.el'.")) + +;;; Column View + +(defvar org-columns-overlays nil + "Holds the list of current column overlays.") + +(defvar org-columns-current-fmt nil + "Local variable, holds the currently active column format.") +(make-variable-buffer-local 'org-columns-current-fmt) +(defvar org-columns-current-fmt-compiled nil + "Local variable, holds the currently active column format. +This is the compiled version of the format.") +(make-variable-buffer-local 'org-columns-current-fmt-compiled) +(defvar org-columns-current-widths nil + "Loval variable, holds the currently widths of fields.") +(make-variable-buffer-local 'org-columns-current-widths) +(defvar org-columns-current-maxwidths nil + "Loval variable, holds the currently active maximum column widths.") +(make-variable-buffer-local 'org-columns-current-maxwidths) +(defvar org-columns-begin-marker (make-marker) + "Points to the position where last a column creation command was called.") +(defvar org-columns-top-level-marker (make-marker) + "Points to the position where current columns region starts.") + +(defvar org-columns-map (make-sparse-keymap) + "The keymap valid in column display.") + +(defun org-columns-content () + "Switch to contents view while in columns view." + (interactive) + (org-overview) + (org-content)) + +(org-defkey org-columns-map "c" 'org-columns-content) +(org-defkey org-columns-map "o" 'org-overview) +(org-defkey org-columns-map "e" 'org-columns-edit-value) +(org-defkey org-columns-map "\C-c\C-t" 'org-columns-todo) +(org-defkey org-columns-map "\C-c\C-c" 'org-columns-set-tags-or-toggle) +(org-defkey org-columns-map "\C-c\C-o" 'org-columns-open-link) +(org-defkey org-columns-map "v" 'org-columns-show-value) +(org-defkey org-columns-map "q" 'org-columns-quit) +(org-defkey org-columns-map "r" 'org-columns-redo) +(org-defkey org-columns-map "g" 'org-columns-redo) +(org-defkey org-columns-map [left] 'backward-char) +(org-defkey org-columns-map "\M-b" 'backward-char) +(org-defkey org-columns-map "a" 'org-columns-edit-allowed) +(org-defkey org-columns-map "s" 'org-columns-edit-attributes) +(org-defkey org-columns-map "\M-f" + (lambda () (interactive) (goto-char (1+ (point))))) +(org-defkey org-columns-map [right] + (lambda () (interactive) (goto-char (1+ (point))))) +(org-defkey org-columns-map [down] + (lambda () (interactive) + (let ((col (current-column))) + (beginning-of-line 2) + (while (and (org-invisible-p2) (not (eobp))) + (beginning-of-line 2)) + (move-to-column col) + (if (eq major-mode 'org-agenda-mode) + (org-agenda-do-context-action))))) +(org-defkey org-columns-map [up] + (lambda () (interactive) + (let ((col (current-column))) + (beginning-of-line 0) + (while (and (org-invisible-p2) (not (bobp))) + (beginning-of-line 0)) + (move-to-column col) + (if (eq major-mode 'org-agenda-mode) + (org-agenda-do-context-action))))) +(org-defkey org-columns-map [(shift right)] 'org-columns-next-allowed-value) +(org-defkey org-columns-map "n" 'org-columns-next-allowed-value) +(org-defkey org-columns-map [(shift left)] 'org-columns-previous-allowed-value) +(org-defkey org-columns-map "p" 'org-columns-previous-allowed-value) +(org-defkey org-columns-map "<" 'org-columns-narrow) +(org-defkey org-columns-map ">" 'org-columns-widen) +(org-defkey org-columns-map [(meta right)] 'org-columns-move-right) +(org-defkey org-columns-map [(meta left)] 'org-columns-move-left) +(org-defkey org-columns-map [(shift meta right)] 'org-columns-new) +(org-defkey org-columns-map [(shift meta left)] 'org-columns-delete) +(dotimes (i 10) + (org-defkey org-columns-map (number-to-string i) + `(lambda () (interactive) + (org-columns-next-allowed-value nil ,i)))) + +(easy-menu-define org-columns-menu org-columns-map "Org Column Menu" + '("Column" + ["Edit property" org-columns-edit-value t] + ["Next allowed value" org-columns-next-allowed-value t] + ["Previous allowed value" org-columns-previous-allowed-value t] + ["Show full value" org-columns-show-value t] + ["Edit allowed values" org-columns-edit-allowed t] + "--" + ["Edit column attributes" org-columns-edit-attributes t] + ["Increase column width" org-columns-widen t] + ["Decrease column width" org-columns-narrow t] + "--" + ["Move column right" org-columns-move-right t] + ["Move column left" org-columns-move-left t] + ["Add column" org-columns-new t] + ["Delete column" org-columns-delete t] + "--" + ["CONTENTS" org-columns-content t] + ["OVERVIEW" org-overview t] + ["Refresh columns display" org-columns-redo t] + "--" + ["Open link" org-columns-open-link t] + "--" + ["Quit" org-columns-quit t])) + +(defun org-columns-new-overlay (beg end &optional string face) + "Create a new column overlay and add it to the list." + (let ((ov (make-overlay beg end))) + (overlay-put ov 'face (or face 'secondary-selection)) + (org-overlay-display ov string face) + (push ov org-columns-overlays) + ov)) + +(defun org-columns-display-here (&optional props dateline) + "Overlay the current line with column display." + (interactive) + (let* ((fmt org-columns-current-fmt-compiled) + (beg (point-at-bol)) + (level-face (save-excursion + (beginning-of-line 1) + (and (looking-at "\\(\\**\\)\\(\\* \\)") + (org-get-level-face 2)))) + (ref-face (or level-face + (and (eq major-mode 'org-agenda-mode) + (get-text-property (point-at-bol) 'face)) + 'default)) + (color (list :foreground (face-attribute ref-face :foreground))) + (face (list color 'org-column ref-face)) + (face1 (list color 'org-agenda-column-dateline ref-face)) + (pl (or (get-text-property (point-at-bol) 'prefix-length) 0)) + (cphr (get-text-property (point-at-bol) 'org-complex-heading-regexp)) + pom property ass width f string ov column val modval s2 title calc) + ;; Check if the entry is in another buffer. + (unless props + (if (eq major-mode 'org-agenda-mode) + (setq pom (or (org-get-at-bol 'org-hd-marker) + (org-get-at-bol 'org-marker)) + props (if pom (org-entry-properties pom) nil)) + (setq props (org-entry-properties nil)))) + ;; Walk the format + (while (setq column (pop fmt)) + (setq property (car column) + title (nth 1 column) + ass (if (equal property "ITEM") + (cons "ITEM" + (save-match-data + (org-no-properties + (org-remove-tabs + (buffer-substring-no-properties + (point-at-bol) (point-at-eol)))))) + (assoc property props)) + width (or (cdr (assoc property org-columns-current-maxwidths)) + (nth 2 column) + (length property)) + f (format "%%-%d.%ds | " width width) + calc (nth 7 column) + val (or (cdr ass) "") + modval (cond ((and org-columns-modify-value-for-display-function + (functionp + org-columns-modify-value-for-display-function)) + (funcall org-columns-modify-value-for-display-function + title val)) + ((equal property "ITEM") + (if (org-mode-p) + (org-columns-cleanup-item + val org-columns-current-fmt-compiled) + (org-agenda-columns-cleanup-item + val pl cphr org-columns-current-fmt-compiled))) + ((and calc (functionp calc) + (not (string= val "")) + (not (get-text-property 0 'org-computed val))) + (org-columns-number-to-string + (funcall calc (org-columns-string-to-number + val (nth 4 column))) + (nth 4 column))))) + (setq s2 (org-columns-add-ellipses (or modval val) width)) + (setq string (format f s2)) + ;; Create the overlay + (org-unmodified + (setq ov (org-columns-new-overlay + beg (setq beg (1+ beg)) string (if dateline face1 face))) + (overlay-put ov 'keymap org-columns-map) + (overlay-put ov 'org-columns-key property) + (overlay-put ov 'org-columns-value (cdr ass)) + (overlay-put ov 'org-columns-value-modified modval) + (overlay-put ov 'org-columns-pom pom) + (overlay-put ov 'org-columns-format f) + (overlay-put ov 'line-prefix "") + (overlay-put ov 'wrap-prefix "")) + (if (or (not (char-after beg)) + (equal (char-after beg) ?\n)) + (let ((inhibit-read-only t)) + (save-excursion + (goto-char beg) + (org-unmodified (insert " ")))))) ;; FIXME: add props and remove later? + ;; Make the rest of the line disappear. + (org-unmodified + (setq ov (org-columns-new-overlay beg (point-at-eol))) + (overlay-put ov 'invisible t) + (overlay-put ov 'keymap org-columns-map) + (overlay-put ov 'intangible t) + (overlay-put ov 'line-prefix "") + (overlay-put ov 'wrap-prefix "") + (push ov org-columns-overlays) + (setq ov (make-overlay (1- (point-at-eol)) (1+ (point-at-eol)))) + (overlay-put ov 'keymap org-columns-map) + (push ov org-columns-overlays) + (let ((inhibit-read-only t)) + (put-text-property (max (point-min) (1- (point-at-bol))) + (min (point-max) (1+ (point-at-eol))) + 'read-only "Type `e' to edit property"))))) + +(defun org-columns-add-ellipses (string width) + "Truncate STRING with WIDTH characters, with ellipses." + (cond + ((<= (length string) width) string) + ((<= width (length org-columns-ellipses)) + (substring org-columns-ellipses 0 width)) + (t (concat (substring string 0 (- width (length org-columns-ellipses))) + org-columns-ellipses)))) + +(defvar org-columns-full-header-line-format nil + "The full header line format, will be shifted by horizontal scrolling." ) +(defvar org-previous-header-line-format nil + "The header line format before column view was turned on.") +(defvar org-columns-inhibit-recalculation nil + "Inhibit recomputing of columns on column view startup.") +(defvar org-columns-flyspell-was-active nil + "Remember the state of `flyspell-mode' before column view. +Flyspell-mode can cause problems in columns view, so it is turned off +for the duration of the command.") + +(defvar header-line-format) +(defvar org-columns-previous-hscroll 0) + +(defun org-columns-display-here-title () + "Overlay the newline before the current line with the table title." + (interactive) + (let ((fmt org-columns-current-fmt-compiled) + string (title "") + property width f column str widths) + (while (setq column (pop fmt)) + (setq property (car column) + str (or (nth 1 column) property) + width (or (cdr (assoc property org-columns-current-maxwidths)) + (nth 2 column) + (length str)) + widths (push width widths) + f (format "%%-%d.%ds | " width width) + string (format f str) + title (concat title string))) + (setq title (concat + (org-add-props " " nil 'display '(space :align-to 0)) + ;;(org-add-props title nil 'face '(:weight bold :underline t :inherit default)))) + (org-add-props title nil 'face 'org-column-title))) + (org-set-local 'org-previous-header-line-format header-line-format) + (org-set-local 'org-columns-current-widths (nreverse widths)) + (setq org-columns-full-header-line-format title) + (setq org-columns-previous-hscroll -1) +; (org-columns-hscoll-title) + (org-add-hook 'post-command-hook 'org-columns-hscoll-title nil 'local))) + +(defun org-columns-hscoll-title () + "Set the `header-line-format' so that it scrolls along with the table." + (sit-for .0001) ; need to force a redisplay to update window-hscroll + (when (not (= (window-hscroll) org-columns-previous-hscroll)) + (setq header-line-format + (concat (substring org-columns-full-header-line-format 0 1) + (substring org-columns-full-header-line-format + (1+ (window-hscroll)))) + org-columns-previous-hscroll (window-hscroll)) + (force-mode-line-update))) + +(defvar org-colview-initial-truncate-line-value nil + "Remember the value of `truncate-lines' across colview.") + +(defun org-columns-remove-overlays () + "Remove all currently active column overlays." + (interactive) + (when (marker-buffer org-columns-begin-marker) + (with-current-buffer (marker-buffer org-columns-begin-marker) + (when (local-variable-p 'org-previous-header-line-format) + (setq header-line-format org-previous-header-line-format) + (kill-local-variable 'org-previous-header-line-format) + (remove-hook 'post-command-hook 'org-columns-hscoll-title 'local)) + (move-marker org-columns-begin-marker nil) + (move-marker org-columns-top-level-marker nil) + (org-unmodified + (mapc 'delete-overlay org-columns-overlays) + (setq org-columns-overlays nil) + (let ((inhibit-read-only t)) + (remove-text-properties (point-min) (point-max) '(read-only t)))) + (when org-columns-flyspell-was-active + (flyspell-mode 1)) + (when (local-variable-p 'org-colview-initial-truncate-line-value) + (setq truncate-lines org-colview-initial-truncate-line-value))))) + +(defun org-columns-cleanup-item (item fmt) + "Remove from ITEM what is a column in the format FMT." + (if (not org-complex-heading-regexp) + item + (when (string-match org-complex-heading-regexp item) + (setq item + (concat + (org-add-props (match-string 1 item) nil + 'org-whitespace (* 2 (1- (org-reduced-level (- (match-end 1) (match-beginning 1)))))) + (and (match-end 2) (not (assoc "TODO" fmt)) (concat " " (match-string 2 item))) + (and (match-end 3) (not (assoc "PRIORITY" fmt)) (concat " " (match-string 3 item))) + " " (save-match-data (org-columns-compact-links (match-string 4 item))) + (and (match-end 5) (not (assoc "TAGS" fmt)) (concat " " (match-string 5 item))))) + (add-text-properties + 0 (1+ (match-end 1)) + (list 'org-whitespace (* 2 (1- (org-reduced-level (- (match-end 1) (match-beginning 1)))))) + item) + item))) + +(defun org-columns-compact-links (s) + "Replace [[link][desc]] with [desc] or [link]." + (while (string-match org-bracket-link-regexp s) + (setq s (replace-match + (concat "[" (match-string (if (match-end 3) 3 1) s) "]") + t t s))) + s) + +(defvar org-agenda-columns-remove-prefix-from-item) + +(defun org-agenda-columns-cleanup-item (item pl cphr fmt) + "Cleanup the time property for agenda column view. +See also the variable `org-agenda-columns-remove-prefix-from-item'." + (let* ((org-complex-heading-regexp cphr) + (prefix (substring item 0 pl)) + (rest (substring item pl)) + (fake (concat "* " rest)) + (cleaned (org-trim (substring (org-columns-cleanup-item fake fmt) 1)))) + (if org-agenda-columns-remove-prefix-from-item + cleaned + (concat prefix cleaned)))) + +(defun org-columns-show-value () + "Show the full value of the property." + (interactive) + (let ((value (get-char-property (point) 'org-columns-value))) + (message "Value is: %s" (or value "")))) + +(defvar org-agenda-columns-active) ;; defined in org-agenda.el + +(defun org-columns-quit () + "Remove the column overlays and in this way exit column editing." + (interactive) + (org-unmodified + (org-columns-remove-overlays) + (let ((inhibit-read-only t)) + (remove-text-properties (point-min) (point-max) '(read-only t)))) + (when (eq major-mode 'org-agenda-mode) + (setq org-agenda-columns-active nil) + (message + "Modification not yet reflected in Agenda buffer, use `r' to refresh"))) + +(defun org-columns-check-computed () + "Check if this column value is computed. +If yes, throw an error indicating that changing it does not make sense." + (let ((val (get-char-property (point) 'org-columns-value))) + (when (and (stringp val) + (get-char-property 0 'org-computed val)) + (error "This value is computed from the entry's children")))) + +(defun org-columns-todo (&optional arg) + "Change the TODO state during column view." + (interactive "P") + (org-columns-edit-value "TODO")) + +(defun org-columns-set-tags-or-toggle (&optional arg) + "Toggle checkbox at point, or set tags for current headline." + (interactive "P") + (if (string-match "\\`\\[[ xX-]\\]\\'" + (get-char-property (point) 'org-columns-value)) + (org-columns-next-allowed-value) + (org-columns-edit-value "TAGS"))) + +(defun org-columns-edit-value (&optional key) + "Edit the value of the property at point in column view. +Where possible, use the standard interface for changing this line." + (interactive) + (org-columns-check-computed) + (let* ((col (current-column)) + (key (or key (get-char-property (point) 'org-columns-key))) + (value (get-char-property (point) 'org-columns-value)) + (bol (point-at-bol)) (eol (point-at-eol)) + (pom (or (get-text-property bol 'org-hd-marker) + (point))) ; keep despite of compiler waring + (line-overlays + (delq nil (mapcar (lambda (x) + (and (eq (overlay-buffer x) (current-buffer)) + (>= (overlay-start x) bol) + (<= (overlay-start x) eol) + x)) + org-columns-overlays))) + (org-columns-time (time-to-number-of-days (current-time))) + nval eval allowed) + (cond + ((equal key "CLOCKSUM") + (error "This special column cannot be edited")) + ((equal key "ITEM") + (setq eval '(org-with-point-at pom + (org-edit-headline)))) + ((equal key "TODO") + (setq eval '(org-with-point-at + pom + (call-interactively 'org-todo)))) + ((equal key "PRIORITY") + (setq eval '(org-with-point-at pom + (call-interactively 'org-priority)))) + ((equal key "TAGS") + (setq eval '(org-with-point-at pom + (let ((org-fast-tag-selection-single-key + (if (eq org-fast-tag-selection-single-key 'expert) + t org-fast-tag-selection-single-key))) + (call-interactively 'org-set-tags))))) + ((equal key "DEADLINE") + (setq eval '(org-with-point-at pom + (call-interactively 'org-deadline)))) + ((equal key "SCHEDULED") + (setq eval '(org-with-point-at pom + (call-interactively 'org-schedule)))) + ((equal key "BEAMER_env") + (setq eval '(org-with-point-at pom + (call-interactively 'org-beamer-select-environment)))) + (t + (setq allowed (org-property-get-allowed-values pom key 'table)) + (if allowed + (setq nval (org-icompleting-read + "Value: " allowed nil + (not (get-text-property 0 'org-unrestricted + (caar allowed))))) + (setq nval (read-string "Edit: " value))) + (setq nval (org-trim nval)) + (when (not (equal nval value)) + (setq eval '(org-entry-put pom key nval))))) + (when eval + + (cond + ((equal major-mode 'org-agenda-mode) + (org-columns-eval eval) + ;; The following let preserves the current format, and makes sure + ;; that in only a single file things need to be upated. + (let* ((org-agenda-overriding-columns-format org-columns-current-fmt) + (buffer (marker-buffer pom)) + (org-agenda-contributing-files + (list (with-current-buffer buffer + (buffer-file-name (buffer-base-buffer)))))) + (org-agenda-columns))) + (t + (let ((inhibit-read-only t)) + (org-unmodified + (remove-text-properties + (max (point-min) (1- bol)) eol '(read-only t))) + (unwind-protect + (progn + (setq org-columns-overlays + (org-delete-all line-overlays org-columns-overlays)) + (mapc 'delete-overlay line-overlays) + (org-columns-eval eval)) + (org-columns-display-here))) + (org-move-to-column col) + (if (and (org-mode-p) + (nth 3 (assoc key org-columns-current-fmt-compiled))) + (org-columns-update key))))))) + +(defun org-edit-headline () ; FIXME: this is not columns specific. Make interactive????? Use from agenda???? + "Edit the current headline, the part without TODO keyword, TAGS." + (org-back-to-heading) + (when (looking-at org-todo-line-regexp) + (let ((pos (point)) + (pre (buffer-substring (match-beginning 0) (match-beginning 3))) + (txt (match-string 3)) + (post "") + txt2) + (if (string-match (org-re "[ \t]+:[[:alnum:]:_@#%]+:[ \t]*$") txt) + (setq post (match-string 0 txt) + txt (substring txt 0 (match-beginning 0)))) + (setq txt2 (read-string "Edit: " txt)) + (when (not (equal txt txt2)) + (goto-char pos) + (insert pre txt2 post) + (delete-region (point) (point-at-eol)) + (org-set-tags nil t))))) + +(defun org-columns-edit-allowed () + "Edit the list of allowed values for the current property." + (interactive) + (let* ((pom (or (org-get-at-bol 'org-marker) + (org-get-at-bol 'org-hd-marker) + (point))) + (key (get-char-property (point) 'org-columns-key)) + (key1 (concat key "_ALL")) + (allowed (org-entry-get pom key1 t)) + nval) + ;; FIXME: Cover editing TODO, TAGS etc in-buffer settings.???? + ;; FIXME: Write back to #+PROPERTY setting if that is needed. + (setq nval (read-string "Allowed: " allowed)) + (org-entry-put + (cond ((marker-position org-entry-property-inherited-from) + org-entry-property-inherited-from) + ((marker-position org-columns-top-level-marker) + org-columns-top-level-marker) + (t pom)) + key1 nval))) + +(defun org-columns-eval (form) + (let (hidep) + (save-excursion + (beginning-of-line 1) + ;; `next-line' is needed here, because it skips invisible line. + (condition-case nil (org-no-warnings (next-line 1)) (error nil)) + (setq hidep (org-on-heading-p 1))) + (eval form) + (and hidep (hide-entry)))) + +(defun org-columns-previous-allowed-value () + "Switch to the previous allowed value for this column." + (interactive) + (org-columns-next-allowed-value t)) + +(defun org-columns-next-allowed-value (&optional previous nth) + "Switch to the next allowed value for this column. +When PREVIOUS is set, go to the previous value. When NTH is +an integer, select that value." + (interactive) + (org-columns-check-computed) + (let* ((col (current-column)) + (key (get-char-property (point) 'org-columns-key)) + (value (get-char-property (point) 'org-columns-value)) + (bol (point-at-bol)) (eol (point-at-eol)) + (pom (or (get-text-property bol 'org-hd-marker) + (point))) ; keep despite of compiler waring + (line-overlays + (delq nil (mapcar (lambda (x) + (and (eq (overlay-buffer x) (current-buffer)) + (>= (overlay-start x) bol) + (<= (overlay-start x) eol) + x)) + org-columns-overlays))) + (allowed (or (org-property-get-allowed-values pom key) + (and (memq + (nth 4 (assoc key org-columns-current-fmt-compiled)) + '(checkbox checkbox-n-of-m checkbox-percent)) + '("[ ]" "[X]")) + (org-colview-construct-allowed-dates value))) + nval) + (when (integerp nth) + (setq nth (1- nth)) + (if (= nth -1) (setq nth 9))) + (when (equal key "ITEM") + (error "Cannot edit item headline from here")) + (unless (or allowed (member key '("SCHEDULED" "DEADLINE"))) + (error "Allowed values for this property have not been defined")) + (if (member key '("SCHEDULED" "DEADLINE")) + (setq nval (if previous 'earlier 'later)) + (if previous (setq allowed (reverse allowed))) + (cond + (nth + (setq nval (nth nth allowed)) + (if (not nval) + (error "There are only %d allowed values for property `%s'" + (length allowed) key))) + ((member value allowed) + (setq nval (or (car (cdr (member value allowed))) + (car allowed))) + (if (equal nval value) + (error "Only one allowed value for this property"))) + (t (setq nval (car allowed))))) + (cond + ((equal major-mode 'org-agenda-mode) + (org-columns-eval '(org-entry-put pom key nval)) + ;; The following let preserves the current format, and makes sure + ;; that in only a single file things need to be upated. + (let* ((org-agenda-overriding-columns-format org-columns-current-fmt) + (buffer (marker-buffer pom)) + (org-agenda-contributing-files + (list (with-current-buffer buffer + (buffer-file-name (buffer-base-buffer)))))) + (org-agenda-columns))) + (t + (let ((inhibit-read-only t)) + (remove-text-properties (1- bol) eol '(read-only t)) + (unwind-protect + (progn + (setq org-columns-overlays + (org-delete-all line-overlays org-columns-overlays)) + (mapc 'delete-overlay line-overlays) + (org-columns-eval '(org-entry-put pom key nval))) + (org-columns-display-here))) + (org-move-to-column col) + (and (nth 3 (assoc key org-columns-current-fmt-compiled)) + (org-columns-update key)))))) + +(defun org-colview-construct-allowed-dates (s) + "Construct a list of three dates around the date in S. +This respects the format of the time stamp in S, active or non-active, +and also including time or not. S must be just a time stamp, no text +around it." + (when (and s (string-match (concat "^" org-ts-regexp3 "$") s)) + (let* ((time (org-parse-time-string s 'nodefaults)) + (active (equal (string-to-char s) ?<)) + (fmt (funcall (if (nth 1 time) 'cdr 'car) org-time-stamp-formats)) + time-before time-after) + (unless active (setq fmt (concat "[" (substring fmt 1 -1) "]"))) + (setf (car time) (or (car time) 0)) + (setf (nth 1 time) (or (nth 1 time) 0)) + (setf (nth 2 time) (or (nth 2 time) 0)) + (setq time-before (copy-sequence time)) + (setq time-after (copy-sequence time)) + (setf (nth 3 time-before) (1- (nth 3 time))) + (setf (nth 3 time-after) (1+ (nth 3 time))) + (mapcar (lambda (x) (format-time-string fmt (apply 'encode-time x))) + (list time-before time time-after))))) + +(defun org-verify-version (task) + (cond + ((eq task 'columns) + (if (or (featurep 'xemacs) + (< emacs-major-version 22)) + (error "Emacs 22 is required for the columns feature"))))) + +(defun org-columns-open-link (&optional arg) + (interactive "P") + (let ((value (get-char-property (point) 'org-columns-value))) + (org-open-link-from-string value arg))) + +(defun org-columns-get-format-and-top-level () + (let (fmt) + (when (condition-case nil (org-back-to-heading) (error nil)) + (setq fmt (org-entry-get nil "COLUMNS" t))) + (setq fmt (or fmt org-columns-default-format)) + (org-set-local 'org-columns-current-fmt fmt) + (org-columns-compile-format fmt) + (if (marker-position org-entry-property-inherited-from) + (move-marker org-columns-top-level-marker + org-entry-property-inherited-from) + (move-marker org-columns-top-level-marker (point))) + fmt)) + +(defun org-columns () + "Turn on column view on an org-mode file." + (interactive) + (org-verify-version 'columns) + (org-columns-remove-overlays) + (move-marker org-columns-begin-marker (point)) + (let ((org-columns-time (time-to-number-of-days (current-time))) + beg end fmt cache maxwidths) + (setq fmt (org-columns-get-format-and-top-level)) + (save-excursion + (goto-char org-columns-top-level-marker) + (setq beg (point)) + (unless org-columns-inhibit-recalculation + (org-columns-compute-all)) + (setq end (or (condition-case nil (org-end-of-subtree t t) (error nil)) + (point-max))) + ;; Get and cache the properties + (goto-char beg) + (when (assoc "CLOCKSUM" org-columns-current-fmt-compiled) + (save-excursion + (save-restriction + (narrow-to-region beg end) + (org-clock-sum)))) + (while (re-search-forward (concat "^" outline-regexp) end t) + (if (and org-columns-skip-archived-trees + (looking-at (concat ".*:" org-archive-tag ":"))) + (org-end-of-subtree t) + (push (cons (org-current-line) (org-entry-properties)) cache))) + (when cache + (setq maxwidths (org-columns-get-autowidth-alist fmt cache)) + (org-set-local 'org-columns-current-maxwidths maxwidths) + (org-columns-display-here-title) + (when (org-set-local 'org-columns-flyspell-was-active + (org-bound-and-true-p flyspell-mode)) + (flyspell-mode 0)) + (unless (local-variable-p 'org-colview-initial-truncate-line-value) + (org-set-local 'org-colview-initial-truncate-line-value + truncate-lines)) + (setq truncate-lines t) + (mapc (lambda (x) + (org-goto-line (car x)) + (org-columns-display-here (cdr x))) + cache))))) + +(eval-when-compile (defvar org-columns-time)) + +(defvar org-columns-compile-map + '(("none" none +) + (":" add_times +) + ("+" add_numbers +) + ("$" currency +) + ("X" checkbox +) + ("X/" checkbox-n-of-m +) + ("X%" checkbox-percent +) + ("max" max_numbers max) + ("min" min_numbers min) + ("mean" mean_numbers + (lambda (&rest x) (/ (apply '+ x) (float (length x))))) + (":max" max_times max) + (":min" min_times min) + (":mean" mean_times + (lambda (&rest x) (/ (apply '+ x) (float (length x))))) + ("@min" min_age min (lambda (x) (- org-columns-time x))) + ("@max" max_age max (lambda (x) (- org-columns-time x))) + ("@mean" mean_age + (lambda (&rest x) (/ (apply '+ x) (float (length x)))) + (lambda (x) (- org-columns-time x))) + ("est+" estimate org-estimate-combine)) + "Operator <-> format,function,calc map. +Used to compile/uncompile columns format and completing read in +interactive function `org-columns-new'. + +operator string used in #+COLUMNS definition describing the + summary type +format symbol describing summary type selected interactively in + `org-columns-new' and internally in + `org-columns-number-to-string' and + `org-columns-string-to-number' +function called with a list of values as argument to calculate + the summary value +calc function called on every element before summarizing. This is + optional and should only be specified if needed") + +(defun org-columns-new (&optional prop title width op fmt fun &rest rest) + "Insert a new column, to the left of the current column." + (interactive) + (let ((editp (and prop (assoc prop org-columns-current-fmt-compiled))) + cell) + (setq prop (org-icompleting-read + "Property: " (mapcar 'list (org-buffer-property-keys t nil t)) + nil nil prop)) + (setq title (read-string (concat "Column title [" prop "]: ") (or title prop))) + (setq width (read-string "Column width: " (if width (number-to-string width)))) + (if (string-match "\\S-" width) + (setq width (string-to-number width)) + (setq width nil)) + (setq fmt (org-icompleting-read + "Summary [none]: " + (mapcar (lambda (x) (list (symbol-name (cadr x)))) + org-columns-compile-map) + nil t)) + (setq fmt (intern fmt) + fun (cdr (assoc fmt (mapcar 'cdr org-columns-compile-map)))) + (if (eq fmt 'none) (setq fmt nil)) + (if editp + (progn + (setcar editp prop) + (setcdr editp (list title width nil fmt nil fun))) + (setq cell (nthcdr (1- (current-column)) + org-columns-current-fmt-compiled)) + (setcdr cell (cons (list prop title width nil fmt nil + (car fun) (cadr fun)) + (cdr cell)))) + (org-columns-store-format) + (org-columns-redo))) + +(defun org-columns-delete () + "Delete the column at point from columns view." + (interactive) + (let* ((n (current-column)) + (title (nth 1 (nth n org-columns-current-fmt-compiled)))) + (when (y-or-n-p + (format "Are you sure you want to remove column \"%s\"? " title)) + (setq org-columns-current-fmt-compiled + (delq (nth n org-columns-current-fmt-compiled) + org-columns-current-fmt-compiled)) + (org-columns-store-format) + (org-columns-redo) + (if (>= (current-column) (length org-columns-current-fmt-compiled)) + (backward-char 1))))) + +(defun org-columns-edit-attributes () + "Edit the attributes of the current column." + (interactive) + (let* ((n (current-column)) + (info (nth n org-columns-current-fmt-compiled))) + (apply 'org-columns-new info))) + +(defun org-columns-widen (arg) + "Make the column wider by ARG characters." + (interactive "p") + (let* ((n (current-column)) + (entry (nth n org-columns-current-fmt-compiled)) + (width (or (nth 2 entry) + (cdr (assoc (car entry) org-columns-current-maxwidths))))) + (setq width (max 1 (+ width arg))) + (setcar (nthcdr 2 entry) width) + (org-columns-store-format) + (org-columns-redo))) + +(defun org-columns-narrow (arg) + "Make the column narrower by ARG characters." + (interactive "p") + (org-columns-widen (- arg))) + +(defun org-columns-move-right () + "Swap this column with the one to the right." + (interactive) + (let* ((n (current-column)) + (cell (nthcdr n org-columns-current-fmt-compiled)) + e) + (when (>= n (1- (length org-columns-current-fmt-compiled))) + (error "Cannot shift this column further to the right")) + (setq e (car cell)) + (setcar cell (car (cdr cell))) + (setcdr cell (cons e (cdr (cdr cell)))) + (org-columns-store-format) + (org-columns-redo) + (forward-char 1))) + +(defun org-columns-move-left () + "Swap this column with the one to the left." + (interactive) + (let* ((n (current-column))) + (when (= n 0) + (error "Cannot shift this column further to the left")) + (backward-char 1) + (org-columns-move-right) + (backward-char 1))) + +(defun org-columns-store-format () + "Store the text version of the current columns format in appropriate place. +This is either in the COLUMNS property of the node starting the current column +display, or in the #+COLUMNS line of the current buffer." + (let (fmt (cnt 0)) + (setq fmt (org-columns-uncompile-format org-columns-current-fmt-compiled)) + (org-set-local 'org-columns-current-fmt fmt) + (if (marker-position org-columns-top-level-marker) + (save-excursion + (goto-char org-columns-top-level-marker) + (if (and (org-at-heading-p) + (org-entry-get nil "COLUMNS")) + (org-entry-put nil "COLUMNS" fmt) + (goto-char (point-min)) + ;; Overwrite all #+COLUMNS lines.... + (while (re-search-forward "^#\\+COLUMNS:.*" nil t) + (setq cnt (1+ cnt)) + (replace-match (concat "#+COLUMNS: " fmt) t t)) + (unless (> cnt 0) + (goto-char (point-min)) + (or (org-on-heading-p t) (outline-next-heading)) + (let ((inhibit-read-only t)) + (insert-before-markers "#+COLUMNS: " fmt "\n"))) + (org-set-local 'org-columns-default-format fmt)))))) + +(defvar org-agenda-overriding-columns-format nil + "When set, overrides any other format definition for the agenda. +Don't set this, this is meant for dynamic scoping.") + +(defun org-columns-get-autowidth-alist (s cache) + "Derive the maximum column widths from the format and the cache." + (let ((start 0) rtn) + (while (string-match (org-re "%\\([[:alpha:]][[:alnum:]_-]*\\)") s start) + (push (cons (match-string 1 s) 1) rtn) + (setq start (match-end 0))) + (mapc (lambda (x) + (setcdr x (apply 'max + (mapcar + (lambda (y) + (length (or (cdr (assoc (car x) (cdr y))) " "))) + cache)))) + rtn) + rtn)) + +(defun org-columns-compute-all () + "Compute all columns that have operators defined." + (org-unmodified + (remove-text-properties (point-min) (point-max) '(org-summaries t))) + (let ((columns org-columns-current-fmt-compiled) + (org-columns-time (time-to-number-of-days (current-time))) + col) + (while (setq col (pop columns)) + (when (nth 3 col) + (save-excursion + (org-columns-compute (car col))))))) + +(defun org-columns-update (property) + "Recompute PROPERTY, and update the columns display for it." + (org-columns-compute property) + (let (fmt val pos) + (save-excursion + (mapc (lambda (ov) + (when (equal (overlay-get ov 'org-columns-key) property) + (setq pos (overlay-start ov)) + (goto-char pos) + (when (setq val (cdr (assoc property + (get-text-property + (point-at-bol) 'org-summaries)))) + (setq fmt (overlay-get ov 'org-columns-format)) + (overlay-put ov 'org-columns-value val) + (overlay-put ov 'display (format fmt val))))) + org-columns-overlays)))) + +(defun org-columns-compute (property) + "Sum the values of property PROPERTY hierarchically, for the entire buffer." + (interactive) + (let* ((re (concat "^" outline-regexp)) + (lmax 30) ; Does anyone use deeper levels??? + (lvals (make-vector lmax nil)) + (lflag (make-vector lmax nil)) + (level 0) + (ass (assoc property org-columns-current-fmt-compiled)) + (format (nth 4 ass)) + (printf (nth 5 ass)) + (fun (nth 6 ass)) + (calc (or (nth 7 ass) 'identity)) + (beg org-columns-top-level-marker) + last-level val valflag flag end sumpos sum-alist sum str str1 useval) + (save-excursion + ;; Find the region to compute + (goto-char beg) + (setq end (condition-case nil (org-end-of-subtree t) (error (point-max)))) + (goto-char end) + ;; Walk the tree from the back and do the computations + (while (re-search-backward re beg t) + (setq sumpos (match-beginning 0) + last-level level + level (org-outline-level) + val (org-entry-get nil property) + valflag (and val (string-match "\\S-" val))) + (cond + ((< level last-level) + ;; put the sum of lower levels here as a property + (setq sum (when (aref lvals last-level) + (apply fun (aref lvals last-level))) + flag (aref lflag last-level) ; any valid entries from children? + str (org-columns-number-to-string sum format printf) + str1 (org-add-props (copy-sequence str) nil 'org-computed t 'face 'bold) + useval (if flag str1 (if valflag val "")) + sum-alist (get-text-property sumpos 'org-summaries)) + (if (assoc property sum-alist) + (setcdr (assoc property sum-alist) useval) + (push (cons property useval) sum-alist) + (org-unmodified + (add-text-properties sumpos (1+ sumpos) + (list 'org-summaries sum-alist)))) + (when (and val (not (equal val (if flag str val)))) + (org-entry-put nil property (if flag str val))) + ;; add current to current level accumulator + (when (or flag valflag) + (push (if flag + sum + (funcall calc (org-columns-string-to-number + (if flag str val) format))) + (aref lvals level)) + (aset lflag level t)) + ;; clear accumulators for deeper levels + (loop for l from (1+ level) to (1- lmax) do + (aset lvals l nil) + (aset lflag l nil))) + ((>= level last-level) + ;; add what we have here to the accumulator for this level + (when valflag + (push (funcall calc (org-columns-string-to-number val format)) + (aref lvals level)) + (aset lflag level t))) + (t (error "This should not happen"))))))) + +(defun org-columns-redo () + "Construct the column display again." + (interactive) + (message "Recomputing columns...") + (let ((line (org-current-line)) + (col (current-column))) + (save-excursion + (if (marker-position org-columns-begin-marker) + (goto-char org-columns-begin-marker)) + (org-columns-remove-overlays) + (if (org-mode-p) + (call-interactively 'org-columns) + (org-agenda-redo) + (call-interactively 'org-agenda-columns))) + (org-goto-line line) + (move-to-column col)) + (message "Recomputing columns...done")) + +(defun org-columns-not-in-agenda () + (if (eq major-mode 'org-agenda-mode) + (error "This command is only allowed in Org-mode buffers"))) + +(defun org-string-to-number (s) + "Convert string to number, and interpret hh:mm:ss." + (if (not (string-match ":" s)) + (string-to-number s) + (let ((l (nreverse (org-split-string s ":"))) (sum 0.0)) + (while l + (setq sum (+ (string-to-number (pop l)) (/ sum 60)))) + sum))) + +(defun org-columns-number-to-string (n fmt &optional printf) + "Convert a computed column number to a string value, according to FMT." + (cond + ((memq fmt '(estimate)) (org-estimate-print n printf)) + ((not (numberp n)) "") + ((memq fmt '(add_times max_times min_times mean_times)) + (let* ((h (floor n)) (m (floor (+ 0.5 (* 60 (- n h)))))) + (format org-time-clocksum-format h m))) + ((eq fmt 'checkbox) + (cond ((= n (floor n)) "[X]") + ((> n 1.) "[-]") + (t "[ ]"))) + ((memq fmt '(checkbox-n-of-m checkbox-percent)) + (let* ((n1 (floor n)) (n2 (floor (+ .5 (* 1000000 (- n n1)))))) + (org-nofm-to-completion n1 (+ n2 n1) (eq fmt 'checkbox-percent)))) + (printf (format printf n)) + ((eq fmt 'currency) + (format "%.2f" n)) + ((memq fmt '(min_age max_age mean_age)) + (org-format-time-period n)) + (t (number-to-string n)))) + +(defun org-nofm-to-completion (n m &optional percent) + (if (not percent) + (format "[%d/%d]" n m) + (format "[%d%%]"(floor (+ 0.5 (* 100. (/ (* 1.0 n) m))))))) + + +(defun org-columns-string-to-number (s fmt) + "Convert a column value to a number that can be used for column computing." + (if s + (cond + ((memq fmt '(min_age max_age mean_age)) + (cond ((string= s "") org-columns-time) + ((string-match + "\\([0-9]+\\)d \\([0-9]+\\)h \\([0-9]+\\)m \\([0-9]+\\)s" + s) + (+ (* 60 (+ (* 60 (+ (* 24 (string-to-number (match-string 1 s))) + (string-to-number (match-string 2 s)))) + (string-to-number (match-string 3 s)))) + (string-to-number (match-string 4 s)))) + (t (time-to-number-of-days (apply 'encode-time + (org-parse-time-string s t)))))) + ((string-match ":" s) + (let ((l (nreverse (org-split-string s ":"))) (sum 0.0)) + (while l + (setq sum (+ (string-to-number (pop l)) (/ sum 60)))) + sum)) + ((memq fmt '(checkbox checkbox-n-of-m checkbox-percent)) + (if (equal s "[X]") 1. 0.000001)) + ((memq fmt '(estimate)) (org-string-to-estimate s)) + (t (string-to-number s))))) + +(defun org-columns-uncompile-format (cfmt) + "Turn the compiled columns format back into a string representation." + (let ((rtn "") e s prop title op op-match width fmt printf fun calc) + (while (setq e (pop cfmt)) + (setq prop (car e) + title (nth 1 e) + width (nth 2 e) + op (nth 3 e) + fmt (nth 4 e) + printf (nth 5 e) + fun (nth 6 e) + calc (nth 7 e)) + (when (setq op-match (rassoc (list fmt fun calc) org-columns-compile-map)) + (setq op (car op-match))) + (if (and op printf) (setq op (concat op ";" printf))) + (if (equal title prop) (setq title nil)) + (setq s (concat "%" (if width (number-to-string width)) + prop + (if title (concat "(" title ")")) + (if op (concat "{" op "}")))) + (setq rtn (concat rtn " " s))) + (org-trim rtn))) + +(defun org-columns-compile-format (fmt) + "Turn a column format string into an alist of specifications. +The alist has one entry for each column in the format. The elements of +that list are: +property the property +title the title field for the columns +width the column width in characters, can be nil for automatic +operator the operator if any +format the output format for computed results, derived from operator +printf a printf format for computed values +fun the lisp function to compute summary values, derived from operator +calc function to get values from base elements" + (let ((start 0) width prop title op op-match f printf fun calc) + (setq org-columns-current-fmt-compiled nil) + (while (string-match + (org-re "%\\([0-9]+\\)?\\([[:alnum:]_-]+\\)\\(?:(\\([^)]+\\))\\)?\\(?:{\\([^}]+\\)}\\)?\\s-*") + fmt start) + (setq start (match-end 0) + width (match-string 1 fmt) + prop (match-string 2 fmt) + title (or (match-string 3 fmt) prop) + op (match-string 4 fmt) + f nil + printf nil + fun '+ + calc nil) + (if width (setq width (string-to-number width))) + (when (and op (string-match ";" op)) + (setq printf (substring op (match-end 0)) + op (substring op 0 (match-beginning 0)))) + (when (setq op-match (assoc op org-columns-compile-map)) + (setq f (cadr op-match) + fun (caddr op-match) + calc (cadddr op-match))) + (push (list prop title width op f printf fun calc) + org-columns-current-fmt-compiled)) + (setq org-columns-current-fmt-compiled + (nreverse org-columns-current-fmt-compiled)))) + + +;;; Dynamic block for Column view + +(defun org-columns-capture-view (&optional maxlevel skip-empty-rows) + "Get the column view of the current buffer or subtree. +The first optional argument MAXLEVEL sets the level limit. A +second optional argument SKIP-EMPTY-ROWS tells whether to skip +empty rows, an empty row being one where all the column view +specifiers except ITEM are empty. This function returns a list +containing the title row and all other rows. Each row is a list +of fields." + (save-excursion + (let* ((title (mapcar 'cadr org-columns-current-fmt-compiled)) + (re-comment (concat "\\*+[ \t]+" org-comment-string "\\>")) + (re-archive (concat ".*:" org-archive-tag ":")) + (n (length title)) row tbl) + (goto-char (point-min)) + (while (re-search-forward "^\\(\\*+\\) " nil t) + (catch 'next + (when (and (or (null maxlevel) + (>= maxlevel + (if org-odd-levels-only + (/ (1+ (length (match-string 1))) 2) + (length (match-string 1))))) + (get-char-property (match-beginning 0) 'org-columns-key)) + (when (save-excursion + (goto-char (point-at-bol)) + (or (looking-at re-comment) + (looking-at re-archive))) + (org-end-of-subtree t) + (throw 'next t)) + (setq row nil) + (loop for i from 0 to (1- n) do + (push + (org-quote-vert + (or (get-char-property (+ (match-beginning 0) i) 'org-columns-value-modified) + (get-char-property (+ (match-beginning 0) i) 'org-columns-value) + "")) + row)) + (setq row (nreverse row)) + (unless (and skip-empty-rows + (eq 1 (length (delete "" (delete-dups (copy-sequence row)))))) + (push row tbl))))) + (append (list title 'hline) (nreverse tbl))))) + +(defun org-dblock-write:columnview (params) + "Write the column view table. +PARAMS is a property list of parameters: + +:width enforce same column widths with <N> specifiers. +:id the :ID: property of the entry where the columns view + should be built. When the symbol `local', call locally. + When `global' call column view with the cursor at the beginning + of the buffer (usually this means that the whole buffer switches + to column view). When \"file:path/to/file.org\", invoke column + view at the start of that file. Otherwise, the ID is located + using `org-id-find'. +:hlines When t, insert a hline before each item. When a number, insert + a hline before each level <= that number. +:vlines When t, make each column a colgroup to enforce vertical lines. +:maxlevel When set to a number, don't capture headlines below this level. +:skip-empty-rows + When t, skip rows where all specifiers other than ITEM are empty." + (let ((pos (move-marker (make-marker) (point))) + (hlines (plist-get params :hlines)) + (vlines (plist-get params :vlines)) + (maxlevel (plist-get params :maxlevel)) + (content-lines (org-split-string (plist-get params :content) "\n")) + (skip-empty-rows (plist-get params :skip-empty-rows)) + tbl id idpos nfields tmp recalc line + id-as-string view-file view-pos) + (when (setq id (plist-get params :id)) + (setq id-as-string (cond ((numberp id) (number-to-string id)) + ((symbolp id) (symbol-name id)) + ((stringp id) id) + (t ""))) + (cond ((not id) nil) + ((eq id 'global) (setq view-pos (point-min))) + ((eq id 'local)) + ((string-match "^file:\\(.*\\)" id-as-string) + (setq view-file (match-string 1 id-as-string) + view-pos 1) + (unless (file-exists-p view-file) + (error "No such file: \"%s\"" id-as-string))) + ((setq idpos (org-find-entry-with-id id)) + (setq view-pos idpos)) + ((setq idpos (org-id-find id)) + (setq view-file (car idpos)) + (setq view-pos (cdr idpos))) + (t (error "Cannot find entry with :ID: %s" id)))) + (with-current-buffer (if view-file + (get-file-buffer view-file) + (current-buffer)) + (save-excursion + (save-restriction + (widen) + (goto-char (or view-pos (point))) + (org-columns) + (setq tbl (org-columns-capture-view maxlevel skip-empty-rows)) + (setq nfields (length (car tbl))) + (org-columns-quit)))) + (goto-char pos) + (move-marker pos nil) + (when tbl + (when (plist-get params :hlines) + (setq tmp nil) + (while tbl + (if (eq (car tbl) 'hline) + (push (pop tbl) tmp) + (if (string-match "\\` *\\(\\*+\\)" (caar tbl)) + (if (and (not (eq (car tmp) 'hline)) + (or (eq hlines t) + (and (numberp hlines) + (<= (- (match-end 1) (match-beginning 1)) + hlines)))) + (push 'hline tmp))) + (push (pop tbl) tmp))) + (setq tbl (nreverse tmp))) + (when vlines + (setq tbl (mapcar (lambda (x) + (if (eq 'hline x) x (cons "" x))) + tbl)) + (setq tbl (append tbl (list (cons "/" (make-list nfields "<>")))))) + (setq pos (point)) + (when content-lines + (while (string-match "^#" (car content-lines)) + (insert (pop content-lines) "\n"))) + (insert (org-listtable-to-string tbl)) + (when (plist-get params :width) + (insert "\n|" (mapconcat (lambda (x) (format "<%d>" (max 3 x))) + org-columns-current-widths "|"))) + (while (setq line (pop content-lines)) + (when (string-match "^#" line) + (insert "\n" line) + (when (string-match "^[ \t]*#\\+TBLFM" line) + (setq recalc t)))) + (if recalc + (progn (goto-char pos) (org-table-recalculate 'all)) + (goto-char pos) + (org-table-align))))) + +(defun org-listtable-to-string (tbl) + "Convert a listtable TBL to a string that contains the Org-mode table. +The table still need to be aligned. The resulting string has no leading +and tailing newline characters." + (mapconcat + (lambda (x) + (cond + ((listp x) + (concat "|" (mapconcat 'identity x "|") "|")) + ((eq x 'hline) "|-|") + (t (error "Garbage in listtable: %s" x)))) + tbl "\n")) + +(defun org-insert-columns-dblock () + "Create a dynamic block capturing a column view table." + (interactive) + (let ((defaults '(:name "columnview" :hlines 1)) + (id (org-icompleting-read + "Capture columns (local, global, entry with :ID: property) [local]: " + (append '(("global") ("local")) + (mapcar 'list (org-property-values "ID")))))) + (if (equal id "") (setq id 'local)) + (if (equal id "global") (setq id 'global)) + (setq defaults (append defaults (list :id id))) + (org-create-dblock defaults) + (org-update-dblock))) + +;;; Column view in the agenda + +(defvar org-agenda-view-columns-initially nil + "When set, switch to columns view immediately after creating the agenda.") + +(defvar org-agenda-columns-show-summaries) ; defined in org-agenda.el +(defvar org-agenda-columns-compute-summary-properties); defined in org-agenda.el +(defvar org-agenda-columns-add-appointments-to-effort-sum); as well + +(defun org-agenda-columns () + "Turn on or update column view in the agenda." + (interactive) + (org-verify-version 'columns) + (org-columns-remove-overlays) + (move-marker org-columns-begin-marker (point)) + (let ((org-columns-time (time-to-number-of-days (current-time))) + cache maxwidths m p a d fmt) + (cond + ((and (boundp 'org-agenda-overriding-columns-format) + org-agenda-overriding-columns-format) + (setq fmt org-agenda-overriding-columns-format) + (org-set-local 'org-agenda-overriding-columns-format fmt)) + ((setq m (org-get-at-bol 'org-hd-marker)) + (setq fmt (or (org-entry-get m "COLUMNS" t) + (with-current-buffer (marker-buffer m) + org-columns-default-format)))) + ((and (boundp 'org-columns-current-fmt) + (local-variable-p 'org-columns-current-fmt) + org-columns-current-fmt) + (setq fmt org-columns-current-fmt)) + ((setq m (next-single-property-change (point-min) 'org-hd-marker)) + (setq m (get-text-property m 'org-hd-marker)) + (setq fmt (or (org-entry-get m "COLUMNS" t) + (with-current-buffer (marker-buffer m) + org-columns-default-format))))) + (setq fmt (or fmt org-columns-default-format)) + (org-set-local 'org-columns-current-fmt fmt) + (org-columns-compile-format fmt) + (when org-agenda-columns-compute-summary-properties + (org-agenda-colview-compute org-columns-current-fmt-compiled)) + (save-excursion + ;; Get and cache the properties + (goto-char (point-min)) + (while (not (eobp)) + (when (setq m (or (org-get-at-bol 'org-hd-marker) + (org-get-at-bol 'org-marker))) + (setq p (org-entry-properties m)) + + (when (or (not (setq a (assoc org-effort-property p))) + (not (string-match "\\S-" (or (cdr a) "")))) + ;; OK, the property is not defined. Use appointment duration? + (when (and org-agenda-columns-add-appointments-to-effort-sum + (setq d (get-text-property (point) 'duration))) + (setq d (org-minutes-to-hh:mm-string d)) + (put-text-property 0 (length d) 'face 'org-warning d) + (push (cons org-effort-property d) p))) + (push (cons (org-current-line) p) cache)) + (beginning-of-line 2)) + (when cache + (setq maxwidths (org-columns-get-autowidth-alist fmt cache)) + (org-set-local 'org-columns-current-maxwidths maxwidths) + (org-columns-display-here-title) + (when (org-set-local 'org-columns-flyspell-was-active + (org-bound-and-true-p flyspell-mode)) + (flyspell-mode 0)) + (mapc (lambda (x) + (org-goto-line (car x)) + (org-columns-display-here (cdr x))) + cache) + (when org-agenda-columns-show-summaries + (org-agenda-colview-summarize cache)))))) + +(defun org-agenda-colview-summarize (cache) + "Summarize the summarizable columns in column view in the agenda. +This will add overlays to the date lines, to show the summary for each day." + (let* ((fmt (mapcar (lambda (x) + (if (equal (car x) "CLOCKSUM") + (list "CLOCKSUM" (nth 1 x) (nth 2 x) ":" 'add_times + nil '+ nil) + x)) + org-columns-current-fmt-compiled)) + line c c1 stype calc sumfunc props lsum entries prop v title) + (catch 'exit + (when (delq nil (mapcar 'cadr fmt)) + ;; OK, at least one summation column, it makes sense to try this + (goto-char (point-max)) + (while t + (when (or (get-text-property (point) 'org-date-line) + (eq (get-text-property (point) 'face) + 'org-agenda-structure)) + ;; OK, this is a date line that should be used + (setq line (org-current-line)) + (setq entries nil c cache cache nil) + (while (setq c1 (pop c)) + (if (> (car c1) line) + (push c1 entries) + (push c1 cache))) + ;; now ENTRIES are the ones we want to use, CACHE is the rest + ;; Compute the summaries for the properties we want, + ;; set nil properties for the rest. + (when (setq entries (mapcar 'cdr entries)) + (setq props + (mapcar + (lambda (f) + (setq prop (car f) + title (nth 1 f) + stype (nth 4 f) + sumfunc (nth 6 f) + calc (or (nth 7 f) 'identity)) + (cond + ((equal prop "ITEM") + (cons prop (buffer-substring (point-at-bol) + (point-at-eol)))) + ((not stype) (cons prop "")) + (t ;; do the summary + (setq lsum nil) + (dolist (x entries) + (setq v (cdr (assoc prop x))) + (if v + (push + (funcall + (if (not (get-text-property 0 'org-computed v)) + calc + 'identity) + (org-columns-string-to-number + v stype)) + lsum))) + (setq lsum (remove nil lsum)) + (setq lsum + (cond ((> (length lsum) 1) + (org-columns-number-to-string + (apply sumfunc lsum) stype)) + ((eq (length lsum) 1) + (org-columns-number-to-string + (car lsum) stype)) + (t ""))) + (put-text-property 0 (length lsum) 'face 'bold lsum) + (unless (eq calc 'identity) + (put-text-property 0 (length lsum) 'org-computed t lsum)) + (cons prop lsum)))) + fmt)) + (org-columns-display-here props 'dateline) + (org-set-local 'org-agenda-columns-active t))) + (if (bobp) (throw 'exit t)) + (beginning-of-line 0)))))) + +(defun org-agenda-colview-compute (fmt) + "Compute the relevant columns in the contributing source buffers." + (let ((files org-agenda-contributing-files) + (org-columns-begin-marker (make-marker)) + (org-columns-top-level-marker (make-marker)) + f fm a b) + (while (setq f (pop files)) + (setq b (find-buffer-visiting f)) + (with-current-buffer (or (buffer-base-buffer b) b) + (save-excursion + (save-restriction + (widen) + (org-unmodified + (remove-text-properties (point-min) (point-max) + '(org-summaries t))) + (goto-char (point-min)) + (org-columns-get-format-and-top-level) + (while (setq fm (pop fmt)) + (if (equal (car fm) "CLOCKSUM") + (org-clock-sum) + (when (and (nth 4 fm) + (setq a (assoc (car fm) + org-columns-current-fmt-compiled)) + (equal (nth 4 a) (nth 4 fm))) + (org-columns-compute (car fm))))))))))) + +(defun org-format-time-period (interval) + "Convert time in fractional days to days/hours/minutes/seconds." + (if (numberp interval) + (let* ((days (floor interval)) + (frac-hours (* 24 (- interval days))) + (hours (floor frac-hours)) + (minutes (floor (* 60 (- frac-hours hours)))) + (seconds (floor (* 60 (- (* 60 (- frac-hours hours)) minutes))))) + (format "%dd %02dh %02dm %02ds" days hours minutes seconds)) + "")) + +(defun org-estimate-mean-and-var (v) + "Return the mean and variance of an estimate." + (let* ((low (float (car v))) + (high (float (cadr v))) + (mean (/ (+ low high) 2.0)) + (var (/ (+ (expt (- mean low) 2.0) (expt (- high mean) 2.0)) 2.0))) + (list mean var))) + +(defun org-estimate-combine (&rest el) + "Combine a list of estimates, using mean and variance. +The mean and variance of the result will be the sum of the means +and variances (respectively) of the individual estimates." + (let ((mean 0) + (var 0)) + (mapc (lambda (e) + (let ((stats (org-estimate-mean-and-var e))) + (setq mean (+ mean (car stats))) + (setq var (+ var (cadr stats))))) + el) + (let ((stdev (sqrt var))) + (list (- mean stdev) (+ mean stdev))))) + +(defun org-estimate-print (e &optional fmt) + "Prepare a string representation of an estimate. +This formats these numbers as two numbers with a \"-\" between them." + (if (null fmt) (set 'fmt "%.0f")) + (format "%s" (mapconcat (lambda (n) (format fmt n)) e "-"))) + +(defun org-string-to-estimate (s) + "Convert a string to an estimate. +The string should be two numbers joined with a \"-\"." + (if (string-match "\\(.*\\)-\\(.*\\)" s) + (list (string-to-number (match-string 1 s)) + (string-to-number(match-string 2 s))) + (list (string-to-number s) (string-to-number s)))) + +(provide 'org-colview) + +;; arch-tag: 61f5128d-747c-4983-9479-e3871fa3d73c + +;;; org-colview.el ends here diff --git a/.emacs.d/org-7.4/lisp/org-colview.elc b/.emacs.d/org-7.4/lisp/org-colview.elc Binary files differnew file mode 100644 index 0000000..d92c944 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-colview.elc diff --git a/.emacs.d/org-7.4/lisp/org-compat.el b/.emacs.d/org-7.4/lisp/org-compat.el new file mode 100644 index 0000000..452a261 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-compat.el @@ -0,0 +1,431 @@ +;;; org-compat.el --- Compatibility code for Org-mode + +;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010 +;; Free Software Foundation, Inc. + +;; Author: Carsten Dominik <carsten at orgmode dot org> +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; Version: 7.4 +;; +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: + +;; This file contains code needed for compatibility with XEmacs and older +;; versions of GNU Emacs. + +;;; Code: + +(eval-when-compile + (require 'cl)) + +(require 'org-macs) + +(declare-function find-library-name "find-func" (library)) +(declare-function w32-focus-frame "term/w32-win" (frame)) + +;; The following constant is for backward compatibility. We do not use +;; it in org-mode, because the Byte compiler evaluates (featurep 'xemacs) +;; at compilation time and can therefore optimize code better. +(defconst org-xemacs-p (featurep 'xemacs)) +(defconst org-format-transports-properties-p + (let ((x "a")) + (add-text-properties 0 1 '(test t) x) + (get-text-property 0 'test (format "%s" x))) + "Does format transport text properties?") + +(defun org-compatible-face (inherits specs) + "Make a compatible face specification. +If INHERITS is an existing face and if the Emacs version supports it, +just inherit the face. If INHERITS is set and the Emacs version does +not support it, copy the face specification from the inheritance face. +If INHERITS is not given and SPECS is, use SPECS to define the face. +XEmacs and Emacs 21 do not know about the `min-colors' attribute. +For them we convert a (min-colors 8) entry to a `tty' entry and move it +to the top of the list. The `min-colors' attribute will be removed from +any other entries, and any resulting duplicates will be removed entirely." + (when (and inherits (facep inherits) (not specs)) + (setq specs (or specs + (get inherits 'saved-face) + (get inherits 'face-defface-spec)))) + (cond + ((and inherits (facep inherits) + (not (featurep 'xemacs)) + (>= emacs-major-version 22) + ;; do not inherit outline faces before Emacs 23 + (or (>= emacs-major-version 23) + (not (string-match "\\`outline-[0-9]+" + (symbol-name inherits))))) + (list (list t :inherit inherits))) + ((or (featurep 'xemacs) (< emacs-major-version 22)) + ;; These do not understand the `min-colors' attribute. + (let (r e a) + (while (setq e (pop specs)) + (cond + ((memq (car e) '(t default)) (push e r)) + ((setq a (member '(min-colors 8) (car e))) + (nconc r (list (cons (cons '(type tty) (delq (car a) (car e))) + (cdr e))))) + ((setq a (assq 'min-colors (car e))) + (setq e (cons (delq a (car e)) (cdr e))) + (or (assoc (car e) r) (push e r))) + (t (or (assoc (car e) r) (push e r))))) + (nreverse r))) + (t specs))) +(put 'org-compatible-face 'lisp-indent-function 1) + +(defun org-version-check (version feature level) + (let* ((v1 (mapcar 'string-to-number (split-string version "[.]"))) + (v2 (mapcar 'string-to-number (split-string emacs-version "[.]"))) + (rmaj (or (nth 0 v1) 99)) + (rmin (or (nth 1 v1) 99)) + (rbld (or (nth 2 v1) 99)) + (maj (or (nth 0 v2) 0)) + (min (or (nth 1 v2) 0)) + (bld (or (nth 2 v2) 0))) + (if (or (< maj rmaj) + (and (= maj rmaj) + (< min rmin)) + (and (= maj rmaj) + (= min rmin) + (< bld rbld))) + (if (eq level :predicate) + ;; just return if we have the version + nil + (let ((msg (format "Emacs %s or greater is recommended for %s" + version feature))) + (display-warning 'org msg level) + t)) + t))) + +;;;; Emacs/XEmacs compatibility + +;; Keys +(defconst org-xemacs-key-equivalents + '(([mouse-1] . [button1]) + ([mouse-2] . [button2]) + ([mouse-3] . [button3]) + ([C-mouse-4] . [(control mouse-4)]) + ([C-mouse-5] . [(control mouse-5)])) + "Translation alist for a couple of keys.") + +;; Overlay compatibility functions +(defun org-detach-overlay (ovl) + (if (featurep 'xemacs) (detach-extent ovl) (delete-overlay ovl))) +(defun org-overlay-display (ovl text &optional face evap) + "Make overlay OVL display TEXT with face FACE." + (if (featurep 'xemacs) + (let ((gl (make-glyph text))) + (and face (set-glyph-face gl face)) + (set-extent-property ovl 'invisible t) + (set-extent-property ovl 'end-glyph gl)) + (overlay-put ovl 'display text) + (if face (overlay-put ovl 'face face)) + (if evap (overlay-put ovl 'evaporate t)))) +(defun org-overlay-before-string (ovl text &optional face evap) + "Make overlay OVL display TEXT with face FACE." + (if (featurep 'xemacs) + (let ((gl (make-glyph text))) + (and face (set-glyph-face gl face)) + (set-extent-property ovl 'begin-glyph gl)) + (if face (org-add-props text nil 'face face)) + (overlay-put ovl 'before-string text) + (if evap (overlay-put ovl 'evaporate t)))) +(defun org-find-overlays (prop &optional pos delete) + "Find all overlays specifying PROP at POS or point. +If DELETE is non-nil, delete all those overlays." + (let ((overlays (overlays-at (or pos (point)))) + ov found) + (while (setq ov (pop overlays)) + (if (overlay-get ov prop) + (if delete (delete-overlay ov) (push ov found)))) + found)) + +(defun org-get-x-clipboard (value) + "Get the value of the x clipboard, compatible with XEmacs, and GNU Emacs 21." + (if (eq window-system 'x) + (let ((x (org-get-x-clipboard-compat value))) + (if x (org-no-properties x))))) + +(defsubst org-decompose-region (beg end) + "Decompose from BEG to END." + (if (featurep 'xemacs) + (let ((modified-p (buffer-modified-p)) + (buffer-read-only nil)) + (remove-text-properties beg end '(composition nil)) + (set-buffer-modified-p modified-p)) + (decompose-region beg end))) + +;; Miscellaneous functions + +(defun org-add-hook (hook function &optional append local) + "Add-hook, compatible with both Emacsen." + (if (and local (featurep 'xemacs)) + (add-local-hook hook function append) + (add-hook hook function append local))) + +(defun org-add-props (string plist &rest props) + "Add text properties to entire string, from beginning to end. +PLIST may be a list of properties, PROPS are individual properties and values +that will be added to PLIST. Returns the string that was modified." + (add-text-properties + 0 (length string) (if props (append plist props) plist) string) + string) +(put 'org-add-props 'lisp-indent-function 2) + +(defun org-fit-window-to-buffer (&optional window max-height min-height + shrink-only) + "Fit WINDOW to the buffer, but only if it is not a side-by-side window. +WINDOW defaults to the selected window. MAX-HEIGHT and MIN-HEIGHT are +passed through to `fit-window-to-buffer'. If SHRINK-ONLY is set, call +`shrink-window-if-larger-than-buffer' instead, the height limit is +ignored in this case." + (cond ((if (fboundp 'window-full-width-p) + (not (window-full-width-p window)) + (> (frame-width) (window-width window))) + ;; do nothing if another window would suffer + ) + ((and (fboundp 'fit-window-to-buffer) (not shrink-only)) + (fit-window-to-buffer window max-height min-height)) + ((fboundp 'shrink-window-if-larger-than-buffer) + (shrink-window-if-larger-than-buffer window))) + (or window (selected-window))) + +(defun org-number-sequence (from &optional to inc) + "Call `number-sequence or emulate it." + (if (fboundp 'number-sequence) + (number-sequence from to inc) + (if (or (not to) (= from to)) + (list from) + (or inc (setq inc 1)) + (when (zerop inc) (error "The increment can not be zero")) + (let (seq (n 0) (next from)) + (if (> inc 0) + (while (<= next to) + (setq seq (cons next seq) + n (1+ n) + next (+ from (* n inc)))) + (while (>= next to) + (setq seq (cons next seq) + n (1+ n) + next (+ from (* n inc))))) + (nreverse seq))))) + +;; Region compatibility + +(defvar org-ignore-region nil + "To temporarily disable the active region.") + +(defun org-region-active-p () + "Is `transient-mark-mode' on and the region active? +Works on both Emacs and XEmacs." + (if org-ignore-region + nil + (if (featurep 'xemacs) + (and zmacs-regions (region-active-p)) + (if (fboundp 'use-region-p) + (use-region-p) + (and transient-mark-mode mark-active))))) ; Emacs 22 and before + +(defun org-cursor-to-region-beginning () + (when (and (org-region-active-p) + (> (point) (region-beginning))) + (exchange-point-and-mark))) + +;; Invisibility compatibility + +(defun org-remove-from-invisibility-spec (arg) + "Remove elements from `buffer-invisibility-spec'." + (if (fboundp 'remove-from-invisibility-spec) + (remove-from-invisibility-spec arg) + (if (consp buffer-invisibility-spec) + (setq buffer-invisibility-spec + (delete arg buffer-invisibility-spec))))) + +(defun org-in-invisibility-spec-p (arg) + "Is ARG a member of `buffer-invisibility-spec'?" + (if (consp buffer-invisibility-spec) + (member arg buffer-invisibility-spec) + nil)) + +(defmacro org-xemacs-without-invisibility (&rest body) + "Turn off exents with invisibility while executing BODY." + `(let ((ext-inv (extent-list nil (point-at-bol) (point-at-eol) + 'all-extents-closed-open 'invisible)) + ext-inv-specs) + (dolist (ext ext-inv) + (when (extent-property ext 'invisible) + (add-to-list 'ext-inv-specs (list ext (extent-property + ext 'invisible))) + (set-extent-property ext 'invisible nil))) + ,@body + (dolist (ext-inv-spec ext-inv-specs) + (set-extent-property (car ext-inv-spec) 'invisible + (cadr ext-inv-spec))))) + +(defun org-indent-to-column (column &optional minimum buffer) + "Work around a bug with extents with invisibility in XEmacs." + (if (featurep 'xemacs) + (org-xemacs-without-invisibility (indent-to-column column minimum buffer)) + (indent-to-column column minimum))) + +(defun org-indent-line-to (column) + "Work around a bug with extents with invisibility in XEmacs." + (if (featurep 'xemacs) + (org-xemacs-without-invisibility (indent-line-to column)) + (indent-line-to column))) + +(defun org-move-to-column (column &optional force buffer) + (if (featurep 'xemacs) + (org-xemacs-without-invisibility (move-to-column column force buffer)) + (move-to-column column force))) + +(defun org-get-x-clipboard-compat (value) + "Get the clipboard value on XEmacs or Emacs 21." + (cond ((featurep 'xemacs) + (org-no-warnings (get-selection-no-error value))) + ((fboundp 'x-get-selection) + (condition-case nil + (or (x-get-selection value 'UTF8_STRING) + (x-get-selection value 'COMPOUND_TEXT) + (x-get-selection value 'STRING) + (x-get-selection value 'TEXT)) + (error nil))))) + +(defun org-propertize (string &rest properties) + (if (featurep 'xemacs) + (progn + (add-text-properties 0 (length string) properties string) + string) + (apply 'propertize string properties))) + +(defun org-substring-no-properties (string &optional from to) + (if (featurep 'xemacs) + (org-no-properties (substring string (or from 0) to)) + (substring-no-properties string from to))) + +(defun org-find-library-name (library) + (if (fboundp 'find-library-name) + (file-name-directory (find-library-name library)) + ; XEmacs does not have `find-library-name' + (flet ((find-library-name-helper (filename ignored-codesys) + filename) + (find-library-name (library) + (find-library library nil 'find-library-name-helper))) + (file-name-directory (find-library-name library))))) + +(defun org-count-lines (s) + "How many lines in string S?" + (let ((start 0) (n 1)) + (while (string-match "\n" s start) + (setq start (match-end 0) n (1+ n))) + (if (and (> (length s) 0) (= (aref s (1- (length s))) ?\n)) + (setq n (1- n))) + n)) + +(defun org-kill-new (string &rest args) + (remove-text-properties 0 (length string) '(line-prefix t wrap-prefix t) + string) + (apply 'kill-new string args)) + +(defun org-select-frame-set-input-focus (frame) + "Select FRAME, raise it, and set input focus, if possible." + (cond ((featurep 'xemacs) + (if (fboundp 'select-frame-set-input-focus) + (select-frame-set-input-focus frame) + (raise-frame frame) + (select-frame frame) + (focus-frame frame))) + ;; `select-frame-set-input-focus' defined in Emacs 21 will not + ;; set the input focus. + ((>= emacs-major-version 22) + (select-frame-set-input-focus frame)) + (t + (raise-frame frame) + (select-frame frame) + (cond ((memq window-system '(x ns mac)) + (x-focus-frame frame)) + ((eq window-system 'w32) + (w32-focus-frame frame))) + (when focus-follows-mouse + (set-mouse-position frame (1- (frame-width frame)) 0))))) + +(defun org-float-time (&optional time) + "Convert time value TIME to a floating point number. +TIME defaults to the current time." + (if (featurep 'xemacs) + (time-to-seconds (or time (current-time))) + (float-time time))) + +(if (fboundp 'string-match-p) + (defalias 'org-string-match-p 'string-match-p) + (defun org-string-match-p (regexp string &optional start) + (save-match-data + (funcall 'string-match regexp string start)))) + +(if (fboundp 'looking-at-p) + (defalias 'org-looking-at-p 'looking-at-p) + (defun org-looking-at-p (&rest args) + (save-match-data + (apply 'looking-at args)))) + +; XEmacs does not have `looking-back'. +(if (fboundp 'looking-back) + (defalias 'org-looking-back 'looking-back) + (defun org-looking-back (regexp &optional limit greedy) + "Return non-nil if text before point matches regular expression REGEXP. +Like `looking-at' except matches before point, and is slower. +LIMIT if non-nil speeds up the search by specifying a minimum +starting position, to avoid checking matches that would start +before LIMIT. + +If GREEDY is non-nil, extend the match backwards as far as +possible, stopping when a single additional previous character +cannot be part of a match for REGEXP. When the match is +extended, its starting position is allowed to occur before +LIMIT." + (let ((start (point)) + (pos + (save-excursion + (and (re-search-backward (concat "\\(?:" regexp "\\)\\=") limit t) + (point))))) + (if (and greedy pos) + (save-restriction + (narrow-to-region (point-min) start) + (while (and (> pos (point-min)) + (save-excursion + (goto-char pos) + (backward-char 1) + (looking-at (concat "\\(?:" regexp "\\)\\'")))) + (setq pos (1- pos))) + (save-excursion + (goto-char pos) + (looking-at (concat "\\(?:" regexp "\\)\\'"))))) + (not (null pos))))) + +(defun org-floor* (x &optional y) + "Return a list of the floor of X and the fractional part of X. +With two arguments, return floor and remainder of their quotient." + (let ((q (floor x y))) + (list q (- x (if y (* y q) q))))) + +(provide 'org-compat) + +;; arch-tag: a0a0579f-e68c-4bdf-9e55-93768b846bbe + +;;; org-compat.el ends here diff --git a/.emacs.d/org-7.4/lisp/org-compat.elc b/.emacs.d/org-7.4/lisp/org-compat.elc Binary files differnew file mode 100644 index 0000000..18bd678 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-compat.elc diff --git a/.emacs.d/org-7.4/lisp/org-complete.el b/.emacs.d/org-7.4/lisp/org-complete.el new file mode 100644 index 0000000..2eb1f4c --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-complete.el @@ -0,0 +1,279 @@ +;;; org-complete.el --- In-buffer completion code + +;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010 +;; Free Software Foundation, Inc. +;; +;; Author: Carsten Dominik <carsten at orgmode dot org> +;; John Wiegley <johnw at gnu dot org> +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; Version: 7.4 +;; +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Code: + +;;;; Require other packages + +(eval-when-compile + (require 'cl)) + +(require 'org-macs) +(require 'pcomplete) + +(declare-function org-split-string "org" (string &optional separators)) +(declare-function org-get-current-options "org-exp" ()) +(declare-function org-make-org-heading-search-string "org" + (&optional string heading)) +(declare-function org-get-buffer-tags "org" ()) +(declare-function org-get-tags "org" ()) +(declare-function org-buffer-property-keys "org" + (&optional include-specials include-defaults include-columns)) +(declare-function org-entry-properties "org" (&optional pom which specific)) + +;;;; Customization variables + +(defgroup org-complete nil + "Outline-based notes management and organizer." + :tag "Org" + :group 'org) + +(defun org-thing-at-point () + "Examine the thing at point and let the caller know what it is. +The return value is a string naming the thing at point." + (let ((beg1 (save-excursion + (skip-chars-backward (org-re "[:alnum:]_@")) + (point))) + (beg (save-excursion + (skip-chars-backward "a-zA-Z0-9_:$") + (point))) + (line-to-here (buffer-substring (point-at-bol) (point)))) + (cond + ((string-match "\\`[ \t]*#\\+begin: clocktable[ \t]+" line-to-here) + (cons "block-option" "clocktable")) + ((string-match "\\`[ \t]*#\\+begin_src[ \t]+" line-to-here) + (cons "block-option" "src")) + ((save-excursion + (re-search-backward "^[ \t]*#\\+\\([A-Z_]+\\):.*" + (line-beginning-position) t)) + (cons "file-option" (match-string-no-properties 1))) + ((string-match "\\`[ \t]*#\\+[a-zA-Z]*\\'" line-to-here) + (cons "file-option" nil)) + ((equal (char-before beg) ?\[) + (cons "link" nil)) + ((equal (char-before beg) ?\\) + (cons "tex" nil)) + ((string-match "\\`\\*+[ \t]+\\'" + (buffer-substring (point-at-bol) beg)) + (cons "todo" nil)) + ((equal (char-before beg) ?*) + (cons "searchhead" nil)) + ((and (equal (char-before beg1) ?:) + (equal (char-after (point-at-bol)) ?*)) + (cons "tag" nil)) + ((and (equal (char-before beg1) ?:) + (not (equal (char-after (point-at-bol)) ?*))) + (cons "prop" nil)) + (t nil)))) + +(defun org-command-at-point () + "Return the qualified name of the Org completion entity at point. +When completing for #+STARTUP, for example, this function returns +\"file-option/startup\"." + (let ((thing (org-thing-at-point))) + (cond + ((string= "file-option" (car thing)) + (concat (car thing) "/" (downcase (cdr thing)))) + ((string= "block-option" (car thing)) + (concat (car thing) "/" (downcase (cdr thing)))) + (t + (car thing))))) + +(defun org-parse-arguments () + "Parse whitespace separated arguments in the current region." + (let ((begin (line-beginning-position)) + (end (line-end-position)) + begins args) + (save-restriction + (narrow-to-region begin end) + (save-excursion + (goto-char (point-min)) + (while (not (eobp)) + (skip-chars-forward " \t\n[") + (setq begins (cons (point) begins)) + (skip-chars-forward "^ \t\n[") + (setq args (cons (buffer-substring-no-properties + (car begins) (point)) + args))) + (cons (reverse args) (reverse begins)))))) + + +(defun org-complete-initial () + "Calls the right completion function for first argument completions." + (ignore + (funcall (or (pcomplete-find-completion-function + (car (org-thing-at-point))) + pcomplete-default-completion-function)))) + +(defvar org-additional-option-like-keywords) +(defun pcomplete/org-mode/file-option () + "Complete against all valid file options." + (require 'org-exp) + (pcomplete-here + (org-complete-case-double + (mapcar (lambda (x) + (if (= ?: (aref x (1- (length x)))) + (concat x " ") + x)) + (delq nil + (pcomplete-uniqify-list + (append + (mapcar (lambda (x) + (if (string-match "^#\\+\\([A-Z_]+:?\\)" x) + (match-string 1 x))) + (org-split-string (org-get-current-options) "\n")) + org-additional-option-like-keywords))))) + (substring pcomplete-stub 2))) + +(defvar org-startup-options) +(defun pcomplete/org-mode/file-option/startup () + "Complete arguments for the #+STARTUP file option." + (while (pcomplete-here + (let ((opts (pcomplete-uniqify-list + (mapcar 'car org-startup-options)))) + ;; Some options are mutually exclusive, and shouldn't be completed + ;; against if certain other options have already been seen. + (dolist (arg pcomplete-args) + (cond + ((string= arg "hidestars") + (setq opts (delete "showstars" opts))))) + opts)))) + +(defun pcomplete/org-mode/file-option/bind () + "Complete arguments for the #+BIND file option, which are variable names" + (let (vars) + (mapatoms + (lambda (a) (if (boundp a) (setq vars (cons (symbol-name a) vars))))) + (pcomplete-here vars))) + +(defvar org-link-abbrev-alist-local) +(defvar org-link-abbrev-alist) +(defun pcomplete/org-mode/link () + "Complete against defined #+LINK patterns." + (pcomplete-here + (pcomplete-uniqify-list (append (mapcar 'car org-link-abbrev-alist-local) + (mapcar 'car org-link-abbrev-alist))))) + +(defvar org-entities) +(defun pcomplete/org-mode/tex () + "Complete against TeX-style HTML entity names." + (require 'org-entities) + (while (pcomplete-here + (pcomplete-uniqify-list (remove nil (mapcar 'car-safe org-entities))) + (substring pcomplete-stub 1)))) + +(defvar org-todo-keywords-1) +(defun pcomplete/org-mode/todo () + "Complete against known TODO keywords." + (pcomplete-here (pcomplete-uniqify-list org-todo-keywords-1))) + +(defvar org-todo-line-regexp) +(defun pcomplete/org-mode/searchhead () + "Complete against all headings. +This needs more work, to handle headings with lots of spaces in them." + (while + (pcomplete-here + (save-excursion + (goto-char (point-min)) + (let (tbl) + (while (re-search-forward org-todo-line-regexp nil t) + (push (org-make-org-heading-search-string + (match-string-no-properties 3) t) + tbl)) + (pcomplete-uniqify-list tbl))) + (substring pcomplete-stub 1)))) + +(defvar org-tag-alist) +(defun pcomplete/org-mode/tag () + "Complete a tag name. Omit tags already set." + (while (pcomplete-here + (mapcar (lambda (x) + (concat x ":")) + (let ((lst (pcomplete-uniqify-list + (or (remove + nil + (mapcar (lambda (x) + (and (stringp (car x)) (car x))) + org-tag-alist)) + (mapcar 'car (org-get-buffer-tags)))))) + (dolist (tag (org-get-tags)) + (setq lst (delete tag lst))) + lst)) + (and (string-match ".*:" pcomplete-stub) + (substring pcomplete-stub (match-end 0)))))) + +(defun pcomplete/org-mode/prop () + "Complete a property name. Omit properties already set." + (pcomplete-here + (mapcar (lambda (x) + (concat x ": ")) + (let ((lst (pcomplete-uniqify-list + (org-buffer-property-keys nil t t)))) + (dolist (prop (org-entry-properties)) + (setq lst (delete (car prop) lst))) + lst)) + (substring pcomplete-stub 1))) + +(defun pcomplete/org-mode/block-option/src () + "Complete the arguments of a begin_src block. +Complete a language in the first field, the header arguments and switches." + (pcomplete-here + (mapcar + (lambda(x) (symbol-name (nth 3 x))) + (cdr (car (cdr (memq :key-type (plist-get + (symbol-plist + 'org-babel-load-languages) + 'custom-type))))))) + (while (pcomplete-here + '("-n" "-r" "-l" + ":cache" ":colnames" ":comments" ":dir" ":eval" ":exports" + ":file" ":hlines" ":no-expand" ":noweb" ":results" ":rownames" + ":session" ":shebang" ":tangle" ":var")))) + +(defun pcomplete/org-mode/block-option/clocktable () + "Complete keywords in a clocktable line" + (while (pcomplete-here '(":maxlevel" ":scope" + ":tstart" ":tend" ":block" ":step" + ":stepskip0" ":fileskip0" + ":emphasize" ":link" ":narrow" ":indent" + ":tcolumns" ":level" ":compact" ":timestamp" + ":formula" ":formatter")))) + +(defun org-complete-case-double (list) + "Return list with both upcase and downcase version of all strings in LIST." + (let (e res) + (while (setq e (pop list)) + (setq res (cons (downcase e) (cons (upcase e) res)))) + (nreverse res))) + +;;;; Finish up + +(provide 'org-complete) + +;; arch-tag: + +;;; org-complete.el ends here diff --git a/.emacs.d/org-7.4/lisp/org-complete.elc b/.emacs.d/org-7.4/lisp/org-complete.elc Binary files differnew file mode 100644 index 0000000..10df9cb --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-complete.elc diff --git a/.emacs.d/org-7.4/lisp/org-crypt.el b/.emacs.d/org-7.4/lisp/org-crypt.el new file mode 100644 index 0000000..1d76104 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-crypt.el @@ -0,0 +1,187 @@ +;;; org-crypt.el --- Public key encryption for org-mode entries + +;; Copyright (C) 2007, 2009, 2010 Free Software Foundation, Inc. + +;; Emacs Lisp Archive Entry +;; Filename: org-crypt.el +;; Version: 7.4 +;; Keywords: org-mode +;; Author: John Wiegley <johnw@gnu.org> +;; Maintainer: Peter Jones <pjones@pmade.com> +;; Description: Adds public key encryption to org-mode buffers +;; URL: http://www.newartisans.com/software/emacs.html +;; Compatibility: Emacs22 + +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Right now this is just a set of functions to play with. It depends +;; on the epg library. Here's how you would use it: +;; +;; 1. To mark an entry for encryption, tag the heading with "crypt". +;; You can change the tag to any complex tag matching string by +;; setting the `org-crypt-tag-matcher' variable. +;; +;; 2. Set the encryption key to use in the `org-crypt-key' variable, +;; or use `M-x org-set-property' to set the property CRYPTKEY to +;; any address in your public keyring. The text of the entry (but +;; not its properties or headline) will be encrypted for this user. +;; For them to read it, the corresponding secret key must be +;; located in the secret key ring of the account where you try to +;; decrypt it. This makes it possible to leave secure notes that +;; only the intended recipient can read in a shared-org-mode-files +;; scenario. +;; If the key is not set, org-crypt will default to symmetric encryption. +;; +;; 3. To later decrypt an entry, use `org-decrypt-entries' or +;; `org-decrypt-entry'. It might be useful to bind this to a key, +;; like C-c C-/. I hope that in the future, C-c C-r can be might +;; overloaded to also decrypt an entry if it's encrypted, since +;; that fits nicely with the meaning of "reveal". +;; +;; 4. To automatically encrypt all necessary entries when saving a +;; file, call `org-crypt-use-before-save-magic' after loading +;; org-crypt.el. +;; +;; TODO: +;; - Allow symmetric encryption as well + +;;; Thanks: + +;; - Carsten Dominik +;; - Vitaly Ostanin + +(require 'org) + +;;; Code: + +(declare-function epg-decrypt-string "epg" (context cipher)) +(declare-function epg-list-keys "epg" (context &optional name mode)) +(declare-function epg-make-context "epg" + (&optional protocol armor textmode include-certs + cipher-algorithm digest-algorithm + compress-algorithm)) +(declare-function epg-encrypt-string "epg" + (context plain recipients &optional sign always-trust)) + +(defgroup org-crypt nil + "Org Crypt" + :tag "Org Crypt" :group 'org) + +(defcustom org-crypt-tag-matcher "crypt" + "The tag matcher used to find headings whose contents should be encrypted. + +See the \"Match syntax\" section of the org manual for more details." + :type 'string :group 'org-crypt) + +(defcustom org-crypt-key nil + "The default key to use when encrypting the contents of a heading. + +This setting can also be overridden in the CRYPTKEY property." + :type 'string :group 'org-crypt) + +(defun org-crypt-key-for-heading () + "Return the encryption key for the current heading." + (save-excursion + (org-back-to-heading t) + (or (org-entry-get nil "CRYPTKEY" 'selective) + org-crypt-key + (and (boundp 'epa-file-encrypt-to) epa-file-encrypt-to) + (message "No crypt key set, using symmetric encryption.")))) + +(defun org-encrypt-entry () + "Encrypt the content of the current headline." + (interactive) + (require 'epg) + (save-excursion + (org-back-to-heading t) + (let ((start-heading (point))) + (forward-line) + (when (not (looking-at "-----BEGIN PGP MESSAGE-----")) + (let ((folded (org-invisible-p)) + (epg-context (epg-make-context nil t t)) + (crypt-key (org-crypt-key-for-heading)) + (beg (point)) + end encrypted-text) + (goto-char start-heading) + (org-end-of-subtree t t) + (org-back-over-empty-lines) + (setq end (point) + encrypted-text + (epg-encrypt-string + epg-context + (buffer-substring-no-properties beg end) + (epg-list-keys epg-context crypt-key))) + (delete-region beg end) + (insert encrypted-text) + (when folded + (goto-char start-heading) + (hide-subtree)) + nil))))) + +(defun org-decrypt-entry () + "Decrypt the content of the current headline." + (interactive) + (require 'epg) + (unless (org-before-first-heading-p) + (save-excursion + (org-back-to-heading t) + (forward-line) + (when (looking-at "-----BEGIN PGP MESSAGE-----") + (let* ((beg (point)) + (end (save-excursion + (search-forward "-----END PGP MESSAGE-----") + (forward-line) + (point))) + (epg-context (epg-make-context nil t t)) + (decrypted-text + (decode-coding-string + (epg-decrypt-string + epg-context + (buffer-substring-no-properties beg end)) + 'utf-8))) + (delete-region beg end) + (insert decrypted-text) + nil))))) + +(defun org-encrypt-entries () + "Encrypt all top-level entries in the current buffer." + (interactive) + (org-scan-tags + 'org-encrypt-entry + (cdr (org-make-tags-matcher org-crypt-tag-matcher)))) + +(defun org-decrypt-entries () + "Decrypt all entries in the current buffer." + (interactive) + (org-scan-tags + 'org-decrypt-entry + (cdr (org-make-tags-matcher org-crypt-tag-matcher)))) + +(defun org-crypt-use-before-save-magic () + "Add a hook to automatically encrypt entries before a file is saved to disk." + (add-hook + 'org-mode-hook + (lambda () (add-hook 'before-save-hook 'org-encrypt-entries nil t)))) + +(add-hook 'org-reveal-start-hook 'org-decrypt-entry) + +(provide 'org-crypt) + +;; arch-tag: 8202ed2c-221e-4001-9e4b-54674a7e846e + +;;; org-crypt.el ends here diff --git a/.emacs.d/org-7.4/lisp/org-crypt.elc b/.emacs.d/org-7.4/lisp/org-crypt.elc Binary files differnew file mode 100644 index 0000000..049ba01 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-crypt.elc diff --git a/.emacs.d/org-7.4/lisp/org-ctags.el b/.emacs.d/org-7.4/lisp/org-ctags.el new file mode 100644 index 0000000..f2c631a --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-ctags.el @@ -0,0 +1,541 @@ +;;; org-ctags.el - Integrate Emacs "tags" facility with org mode. +;; +;; Copyright (C) 2007, 2008, 2009, 2010 Free Software Foundation, Inc. + +;; Author: Paul Sexton <eeeickythump@gmail.com> +;; Version: 7.4 + +;; Keywords: org, wp +;; Version: 7.4 +;; +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;; +;; Synopsis +;; ======== +;; +;; Allows org-mode to make use of the Emacs `etags' system. Defines tag +;; destinations in org-mode files as any text between <<double angled +;; brackets>>. This allows the tags-generation program `exuberant ctags' to +;; parse these files and create tag tables that record where these +;; destinations are found. Plain [[links]] in org mode files which do not have +;; <<matching destinations>> within the same file will then be interpreted as +;; links to these 'tagged' destinations, allowing seamless navigation between +;; multiple org-mode files. Topics can be created in any org mode file and +;; will always be found by plain links from other files. Other file types +;; recognised by ctags (source code files, latex files, etc) will also be +;; available as destinations for plain links, and similarly, org-mode links +;; will be available as tags from source files. Finally, the function +;; `org-ctags-find-tag-interactive' lets you choose any known tag, using +;; autocompletion, and quickly jump to it. +;; +;; Installation +;; ============ +;; +;; Install org mode +;; Ensure org-ctags.el is somewhere in your emacs load path. +;; Download and install Exuberant ctags -- "http://ctags.sourceforge.net/" +;; Edit your .emacs file (see next section) and load emacs. + +;; To put in your init file (.emacs): +;; ================================== +;; +;; Assuming you already have org mode installed and set up: +;; +;; (setq org-ctags-path-to-ctags "/path/to/ctags/executable") +;; (add-hook 'org-mode-hook +;; (lambda () +;; (define-key org-mode-map "\C-co" 'org-ctags-find-tag-interactive))) +;; +;; By default, with org-ctags loaded, org will first try and visit the tag +;; with the same name as the link; then, if unsuccessful, ask the user if +;; he/she wants to rebuild the 'TAGS' database and try again; then ask if +;; the user wishes to append 'tag' as a new toplevel heading at the end of +;; the buffer; and finally, defer to org's default behaviour which is to +;; search the entire text of the current buffer for 'tag'. +;; +;; This behaviour can be modified by changing the value of +;; ORG-CTAGS-OPEN-LINK-FUNCTIONS. For example I have the following in my +;; .emacs, which describes the same behaviour as the above paragraph with +;; one difference: +;; +;; (setq org-ctags-open-link-functions +;; '(org-ctags-find-tag +;; org-ctags-ask-rebuild-tags-file-then-find-tag +;; org-ctags-ask-append-topic +;; org-ctags-fail-silently)) ; <-- prevents org default behaviour +;; +;; +;; Usage +;; ===== +;; +;; When you click on a link "[[foo]]" and org cannot find a matching "<<foo>>" +;; in the current buffer, the tags facility will take over. The file TAGS in +;; the active directory is examined to see if the tags facility knows about +;; "<<foo>>" in any other files. If it does, the matching file will be opened +;; and the cursor will jump to the position of "<<foo>>" in that file. +;; +;; User-visible functions: +;; - `org-ctags-find-tag-interactive': type a tag (plain link) name and visit +;; it. With autocompletion. Bound to ctrl-O in the above setup. +;; - All the etags functions should work. These include: +;; +;; M-. `find-tag' -- finds the tag at point +;; +;; C-M-. find-tag based on regular expression +;; +;; M-x tags-search RET -- like C-M-. but searches through ENTIRE TEXT +;; of ALL the files referenced in the TAGS file. A quick way to +;; search through an entire 'project'. +;; +;; M-* "go back" from a tag jump. Like `org-mark-ring-goto'. +;; You may need to bind this key yourself with (eg) +;; (global-set-key (kbd "<M-kp-multiply>") 'pop-tag-mark) +;; +;; (see etags chapter in Emacs manual for more) +;; +;; +;; Keeping the TAGS file up to date +;; ================================ +;; +;; Tags mode has no way of knowing that you have created new tags by typing in +;; your org-mode buffer. New tags make it into the TAGS file in 3 ways: +;; +;; 1. You re-run (org-ctags-create-tags "directory") to rebuild the file. +;; 2. You put the function `org-ctags-ask-rebuild-tags-file-then-find-tag' in +;; your `org-open-link-functions' list, as is done in the setup +;; above. This will cause the TAGS file to be rebuilt whenever a link +;; cannot be found. This may be slow with large file collections however. +;; 3. You run the following from the command line (all 1 line): +;; +;; ctags --langdef=orgmode --langmap=orgmode:.org +;; --regex-orgmode="/<<([^>]+)>>/\1/d,definition/" +;; -f /your/path/TAGS -e -R /your/path/*.org +;; +;; If you are paranoid, you might want to run (org-ctags-create-tags +;; "/path/to/org/files") at startup, by including the following toplevel form +;; in .emacs. However this can cause a pause of several seconds if ctags has +;; to scan lots of files. +;; +;; (progn +;; (message "-- rebuilding tags tables...") +;; (mapc 'org-create-tags tags-table-list)) + +;;; Code: + +(eval-when-compile (require 'cl)) + +(require 'org) + +(defgroup org-ctags nil + "Options concerning use of ctags within org mode." + :tag "Org-Ctags" + :group 'org-link) + +(defvar org-ctags-enabled-p t + "Activate ctags support in org mode?") + +(defvar org-ctags-tag-regexp "/<<([^>]+)>>/\\1/d,definition/" + "Regexp expression used by ctags external program. +The regexp matches tag destinations in org-mode files. +Format is: /REGEXP/TAGNAME/FLAGS,TAGTYPE/ +See the ctags documentation for more information.") + +(defcustom org-ctags-path-to-ctags + (case system-type + (windows-nt "ctags.exe") + (darwin "ctags-exuberant") + (t "ctags-exuberant")) + "Full path to the ctags executable file." + :group 'org-ctags + :type 'file) + +(defcustom org-ctags-open-link-functions + '(org-ctags-find-tag + org-ctags-ask-rebuild-tags-file-then-find-tag + org-ctags-ask-append-topic) + "List of functions to be prepended to ORG-OPEN-LINK-FUNCTIONS when ORG-CTAGS is active." + :group 'org-ctags + :type 'hook + :options '(org-ctags-find-tag + org-ctags-ask-rebuild-tags-file-then-find-tag + org-ctags-rebuild-tags-file-then-find-tag + org-ctags-ask-append-topic + org-ctags-append-topic + org-ctags-ask-visit-buffer-or-file + org-ctags-visit-buffer-or-file + org-ctags-fail-silently)) + + +(defvar org-ctags-tag-list nil + "List of all tags in the active TAGS file. +Created as a local variable in each buffer.") + +(defcustom org-ctags-new-topic-template + "* <<%t>>\n\n\n\n\n\n" + "Text to insert when creating a new org file via opening a hyperlink. +The following patterns are replaced in the string: + `%t' - replaced with the capitalized title of the hyperlink" + :group 'org-ctags + :type 'string) + + +(add-hook 'org-mode-hook + (lambda () + (when (and org-ctags-enabled-p + (buffer-file-name)) + ;; Make sure this file's directory is added to default + ;; directories in which to search for tags. + (let ((tags-filename + (expand-file-name + (concat (file-name-directory (buffer-file-name)) + "/TAGS")))) + (when (file-exists-p tags-filename) + (visit-tags-table tags-filename)))))) + + +(defadvice visit-tags-table (after org-ctags-load-tag-list activate compile) + (when (and org-ctags-enabled-p tags-file-name) + (set (make-local-variable 'org-ctags-tag-list) + (org-ctags-all-tags-in-current-tags-table)))) + + +(defun org-ctags-enable () + (put 'org-mode 'find-tag-default-function 'org-ctags-find-tag-at-point) + (setq org-ctags-enabled-p t) + (dolist (fn org-ctags-open-link-functions) + (add-hook 'org-open-link-functions fn t))) + + +;;; General utility functions. =============================================== +;; These work outside org-ctags mode. + +(defun org-ctags-get-filename-for-tag (tag) + "TAG is a string. Search the active TAGS file for a matching tag. +If the tag is found, return a list containing the filename, line number, and +buffer position where the tag is found." + (interactive "sTag: ") + (unless tags-file-name + (call-interactively (visit-tags-table))) + (save-excursion + (visit-tags-table-buffer 'same) + (when tags-file-name + (with-current-buffer (get-file-buffer tags-file-name) + (goto-char (point-min)) + (cond + ((re-search-forward (format "^.*%s\\([0-9]+\\),\\([0-9]+\\)$" + (regexp-quote tag)) nil t) + (let ((line (string-to-number (match-string 1))) + (pos (string-to-number (match-string 2)))) + (cond + ((re-search-backward " \n\\(.*\\),[0-9]+\n") + (list (match-string 1) line pos)) + (t ; can't find a file name preceding the matched + ; tag?? + (error "Malformed TAGS file: %s" (buffer-name)))))) + (t ; tag not found + nil)))))) + + +(defun org-ctags-all-tags-in-current-tags-table () + "Read all tags defined in the active TAGS file, into a list of strings. +Return the list." + (interactive) + (let ((taglist nil)) + (unless tags-file-name + (call-interactively (visit-tags-table))) + (save-excursion + (visit-tags-table-buffer 'same) + (with-current-buffer (get-file-buffer tags-file-name) + (goto-char (point-min)) + (while (re-search-forward "^.*\\(.*\\)\\([0-9]+\\),\\([0-9]+\\)$" + nil t) + (push (substring-no-properties (match-string 1)) taglist))) + taglist))) + + +(defun org-ctags-string-search-and-replace (search replace string) + "Replace all instances of SEARCH with REPLACE in STRING." + (replace-regexp-in-string (regexp-quote search) replace string t t)) + + +(defun y-or-n-minibuffer (prompt) + (let ((use-dialog-box nil)) + (y-or-n-p prompt))) + + +;;; Internal functions ======================================================= + + +(defun org-ctags-open-file (name &optional title) + "Visit or create a file called `NAME.org', and insert a new topic. +The new topic will be titled NAME (or TITLE if supplied)." + (interactive "sFile name: ") + (let ((filename (substitute-in-file-name (expand-file-name name)))) + (condition-case v + (progn + (org-open-file name t) + (message "Opened file OK") + (goto-char (point-max)) + (insert (org-ctags-string-search-and-replace + "%t" (capitalize (or title name)) + org-ctags-new-topic-template)) + (message "Inserted new file text OK") + (org-mode-restart)) + (error (error "Error %S in org-ctags-open-file" v))))) + + +;;;; Misc interoperability with etags system ================================= + + +(defadvice find-tag (before org-ctags-set-org-mark-before-finding-tag + activate compile) + "Before trying to find a tag, save our current position on org mark ring." + (save-excursion + (if (and (org-mode-p) org-ctags-enabled-p) + (org-mark-ring-push)))) + + + +(defun org-ctags-find-tag-at-point () + "Determine default tag to search for, based on text at point. +If there is no plausible default, return nil." + (let (from to bound) + (when (or (ignore-errors + ;; Look for hyperlink around `point'. + (save-excursion + (search-backward "[[") (setq from (+ 2 (point)))) + (save-excursion + (goto-char from) + (search-forward "]") (setq to (- (point) 1))) + (and (> to from) (>= (point) from) (<= (point) to))) + (progn + ;; Look at text around `point'. + (save-excursion + (skip-syntax-backward "w_") (setq from (point))) + (save-excursion + (skip-syntax-forward "w_") (setq to (point))) + (> to from)) + ;; Look between `line-beginning-position' and `point'. + (save-excursion + (and (setq bound (line-beginning-position)) + (skip-syntax-backward "^w_" bound) + (> (setq to (point)) bound) + (skip-syntax-backward "w_") + (setq from (point)))) + ;; Look between `point' and `line-end-position'. + (save-excursion + (and (setq bound (line-end-position)) + (skip-syntax-forward "^w_" bound) + (< (setq from (point)) bound) + (skip-syntax-forward "w_") + (setq to (point))))) + (buffer-substring-no-properties from to)))) + + +;;; Functions for use with 'org-open-link-functions' hook ================= + + +(defun org-ctags-find-tag (name) + "This function is intended to be used in ORG-OPEN-LINK-FUNCTIONS. +Look for a tag called `NAME' in the current TAGS table. If it is found, +visit the file and location where the tag is found." + (interactive "sTag: ") + (let ((old-buf (current-buffer)) + (old-pnt (point-marker)) + (old-mark (copy-marker (mark-marker)))) + (condition-case nil + (progn (find-tag name) + t) + (error + ;; only restore old location if find-tag raises error + (set-buffer old-buf) + (goto-char old-pnt) + (set-marker (mark-marker) old-mark) + nil)))) + + +(defun org-ctags-visit-buffer-or-file (name &optional create) + "This function is intended to be used in ORG-OPEN-LINK-FUNCTIONS. +Visit buffer named `NAME.org'. If there is no such buffer, visit the file +with the same name if it exists. If the file does not exist, then behavior +depends on the value of CREATE. + +If CREATE is nil (default), then return nil. Do not create a new file. +If CREATE is t, create the new file and visit it. +If CREATE is the symbol `ask', then ask the user if they wish to create +the new file." + (interactive) + (let ((filename (concat (substitute-in-file-name + (expand-file-name name)) + ".org"))) + (cond + ((get-buffer (concat name ".org")) + ;; Buffer is already open + (switch-to-buffer (get-buffer (concat name ".org")))) + ((file-exists-p filename) + ;; File exists but is not open --> open it + (message "Opening existing org file `%S'..." + filename) + (org-open-file filename t)) + ((or (eql create t) + (and (eql create 'ask) + (y-or-n-p (format "File `%s.org' not found; create?" name)))) + (org-ctags-open-file filename name)) + (t ;; File does not exist, and we don't want to create it. + nil)))) + + +(defun org-ctags-ask-visit-buffer-or-file (name) + "This function is intended to be used in ORG-OPEN-LINK-FUNCTIONS. +Wrapper for org-ctags-visit-buffer-or-file, which ensures the user is +asked before creating a new file." + (org-ctags-visit-buffer-or-file name 'ask)) + + +(defun org-ctags-append-topic (name &optional narrowp) + "This function is intended to be used in ORG-OPEN-LINK-FUNCTIONS. +Append a new toplevel heading to the end of the current buffer. The +heading contains NAME surrounded by <<angular brackets>>, thus making +the heading a destination for the tag `NAME'." + (interactive "sTopic: ") + (widen) + (goto-char (point-max)) + (newline 2) + (message "Adding topic in buffer %s" (buffer-name)) + (insert (org-ctags-string-search-and-replace + "%t" (capitalize name) org-ctags-new-topic-template)) + (backward-char 4) + (org-update-radio-target-regexp) + (end-of-line) + (forward-line 2) + (when narrowp + ;;(org-tree-to-indirect-buffer 1) ;; opens new frame + (org-narrow-to-subtree)) + t) + + +(defun org-ctags-ask-append-topic (name &optional narrowp) + "This function is intended to be used in ORG-OPEN-LINK-FUNCTIONS. +Wrapper for org-ctags-append-topic, which first asks the user if they want +to append a new topic." + (if (y-or-n-p (format "Topic `%s' not found; append to end of buffer?" + name)) + (org-ctags-append-topic name narrowp) + nil)) + + +(defun org-ctags-rebuild-tags-file-then-find-tag (name) + "This function is intended to be used in ORG-OPEN-LINK-FUNCTIONS. +Like ORG-CTAGS-FIND-TAG, but calls the external ctags program first, +to rebuild (update) the TAGS file." + (unless tags-file-name + (call-interactively (visit-tags-table))) + (when (buffer-file-name) + (org-ctags-create-tags)) + (org-ctags-find-tag name)) + + +(defun org-ctags-ask-rebuild-tags-file-then-find-tag (name) + "This function is intended to be used in ORG-OPEN-LINK-FUNCTIONS. +Wrapper for org-ctags-rebuild-tags-file-then-find-tag." + (if (and (buffer-file-name) + (y-or-n-p + (format + "Tag `%s' not found. Rebuild table `%s/TAGS' and look again?" + name + (file-name-directory (buffer-file-name))))) + (org-ctags-rebuild-tags-file-then-find-tag name) + nil)) + + +(defun org-ctags-fail-silently (name) + "This function is intended to be used in ORG-OPEN-LINK-FUNCTIONS. +Put as the last function in the list if you want to prevent org's default +behavior of free text search." + t) + + +;;; User-visible functions =================================================== + + +(defun org-ctags-create-tags (&optional directory-name) + "(Re)create tags file in the directory of the active buffer. +The file will contain tag definitions for all the files in the +directory and its subdirectories which are recognized by ctags. +This will include files ending in `.org' as well as most other +source files (.C, .H, .EL, .LISP, etc). All the resulting tags +end up in one file, called TAGS, located in the directory. This +function may take several seconds to finish if the directory or +its subdirectories contain large numbers of taggable files." + (interactive) + (assert (buffer-file-name)) + (let ((dir-name (or directory-name + (file-name-directory (buffer-file-name)))) + (exitcode nil)) + (save-excursion + (setq exitcode + (shell-command + (format (concat "%s --langdef=orgmode --langmap=orgmode:.org " + "--regex-orgmode=\"%s\" -f \"%s\" -e -R \"%s\"") + org-ctags-path-to-ctags + org-ctags-tag-regexp + (expand-file-name (concat dir-name "/TAGS")) + (expand-file-name (concat dir-name "/*"))))) + (cond + ((eql 0 exitcode) + (set (make-local-variable 'org-ctags-tag-list) + (org-ctags-all-tags-in-current-tags-table))) + (t + ;; This seems to behave differently on Linux, so just ignore + ;; error codes for now + ;;(error "Calling ctags executable resulted in error code: %s" + ;; exitcode) + nil))))) + + +(defvar org-ctags-find-tag-history nil + "History of tags visited by org-ctags-find-tag-interactive.") + +(defun org-ctags-find-tag-interactive () + "Prompt for the name of a tag, with autocompletion, then visit the named tag. +Uses `ido-mode' if available. +If the user enters a string that does not match an existing tag, create +a new topic." + (interactive) + (let* ((completing-read-fn (if (fboundp 'ido-completing-read) + 'ido-completing-read + 'completing-read)) + (tag (funcall completing-read-fn "Topic: " org-ctags-tag-list + nil 'confirm nil 'org-ctags-find-tag-history))) + (when tag + (cond + ((member tag org-ctags-tag-list) + ;; Existing tag + (push tag org-ctags-find-tag-history) + (find-tag tag)) + (t + ;; New tag + (run-hook-with-args-until-success + 'org-open-link-functions tag)))))) + + +(org-ctags-enable) + +(provide 'org-ctags) + +;; arch-tag: 4b1ddd5a-8529-4b17-bcde-96a922d26343 +;;; org-ctags.el ends here diff --git a/.emacs.d/org-7.4/lisp/org-ctags.elc b/.emacs.d/org-7.4/lisp/org-ctags.elc Binary files differnew file mode 100644 index 0000000..fdaa19f --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-ctags.elc diff --git a/.emacs.d/org-7.4/lisp/org-datetree.el b/.emacs.d/org-7.4/lisp/org-datetree.el new file mode 100644 index 0000000..8014f8f --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-datetree.el @@ -0,0 +1,200 @@ +;;; org-datetree.el --- Create date entries in a tree + +;; Copyright (C) 2009, 2010 Free Software Foundation, Inc. + +;; Author: Carsten Dominik <carsten at orgmode dot org> +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; Version: 7.4 +;; +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: + +;; This file contains code to create entries in a tree where the top-level +;; nodes represent years, the level 2 nodes represent the months, and the +;; level 1 entries days. + +;;; Code: + +(require 'org) + +(defvar org-datetree-base-level 1 + "The level at which years should be placed in the date tree. +This is normally one, but if the buffer has an entry with a DATE_TREE +property (any value), the date tree will become a subtree under that entry, +so the base level will be properly adjusted.") + +;;;###autoload +(defun org-datetree-find-date-create (date &optional keep-restriction) + "Find or create an entry for DATE. +If KEEP-RESTRICTION is non-nil, do not widen the buffer. +When it is nil, the buffer will be widened to make sure an existing date +tree can be found." + (let ((year (nth 2 date)) + (month (car date)) + (day (nth 1 date))) + (org-set-local 'org-datetree-base-level 1) + (or keep-restriction (widen)) + (goto-char (point-min)) + (save-restriction + (when (re-search-forward "^[ \t]*:DATE_TREE:[ \t]+\\S-" nil t) + (org-back-to-heading t) + (org-set-local 'org-datetree-base-level + (org-get-valid-level (funcall outline-level) 1)) + (org-narrow-to-subtree)) + (goto-char (point-min)) + (org-datetree-find-year-create year) + (org-datetree-find-month-create year month) + (org-datetree-find-day-create year month day) + (goto-char (prog1 (point) (widen)))))) + +(defun org-datetree-find-year-create (year) + (let ((re "^\\*+[ \t]+\\([12][0-9][0-9][0-9]\\)[ \t\n]") + match) + (goto-char (point-min)) + (while (and (setq match (re-search-forward re nil t)) + (goto-char (match-beginning 1)) + (< (string-to-number (match-string 1)) year))) + (cond + ((not match) + (goto-char (point-max)) + (or (bolp) (newline)) + (org-datetree-insert-line year)) + ((= (string-to-number (match-string 1)) year) + (goto-char (point-at-bol))) + (t + (beginning-of-line 1) + (org-datetree-insert-line year))))) + +(defun org-datetree-find-month-create (year month) + (org-narrow-to-subtree) + (let ((re (format "^\\*+[ \t]+%d-\\([01][0-9]\\)[ \t\n]" year)) + match) + (goto-char (point-min)) + (while (and (setq match (re-search-forward re nil t)) + (goto-char (match-beginning 1)) + (< (string-to-number (match-string 1)) month))) + (cond + ((not match) + (goto-char (point-max)) + (or (bolp) (newline)) + (org-datetree-insert-line year month)) + ((= (string-to-number (match-string 1)) month) + (goto-char (point-at-bol))) + (t + (beginning-of-line 1) + (org-datetree-insert-line year month))))) + +(defun org-datetree-find-day-create (year month day) + (org-narrow-to-subtree) + (let ((re (format "^\\*+[ \t]+%d-%02d-\\([0123][0-9]\\)[ \t\n]" year month)) + match) + (goto-char (point-min)) + (while (and (setq match (re-search-forward re nil t)) + (goto-char (match-beginning 1)) + (< (string-to-number (match-string 1)) day))) + (cond + ((not match) + (goto-char (point-max)) + (or (bolp) (newline)) + (org-datetree-insert-line year month day)) + ((= (string-to-number (match-string 1)) day) + (goto-char (point-at-bol))) + (t + (beginning-of-line 1) + (org-datetree-insert-line year month day))))) + +(defun org-datetree-insert-line (year &optional month day) + (let ((pos (point))) + (skip-chars-backward " \t\n") + (delete-region (point) pos) + (insert "\n" (make-string org-datetree-base-level ?*) " \n") + (backward-char 1) + (if month (org-do-demote)) + (if day (org-do-demote)) + (insert (format "%d" year)) + (when month + (insert (format "-%02d" month)) + (if day + (insert (format "-%02d %s" + day (format-time-string + "%A" (encode-time 0 0 0 day month year)))) + (insert (format " %s" + (format-time-string + "%B" (encode-time 0 0 0 1 month year)))))) + (beginning-of-line 1))) + +(defun org-datetree-file-entry-under (txt date) + "Insert a node TXT into the date tree under DATE." + (org-datetree-find-date-create date) + (let ((level (org-get-valid-level (funcall outline-level) 1))) + (org-end-of-subtree t t) + (org-back-over-empty-lines) + (org-paste-subtree level txt))) + +(defun org-datetree-cleanup () + "Make sure all entries in the current tree are under the correct date. +It may be useful to restrict the buffer to the applicable portion +before running this command, even though the command tries to be smart." + (interactive) + (goto-char (point-min)) + (let ((dre (concat "\\<" org-deadline-string "\\>[ \t]*\\'")) + (sre (concat "\\<" org-scheduled-string "\\>[ \t]*\\'")) + dct ts tmp date year month day pos hdl-pos) + (while (re-search-forward org-ts-regexp nil t) + (catch 'next + (setq ts (match-string 0)) + (setq tmp (buffer-substring + (max (point-at-bol) (- (match-beginning 0) + org-ds-keyword-length)) + (match-beginning 0))) + (if (or (string-match "-\\'" tmp) + (string-match dre tmp) + (string-match sre tmp)) + (throw 'next nil)) + (setq dct (decode-time (org-time-string-to-time (match-string 0))) + date (list (nth 4 dct) (nth 3 dct) (nth 5 dct)) + year (nth 2 date) + month (car date) + day (nth 1 date) + pos (point)) + (org-back-to-heading t) + (setq hdl-pos (point)) + (unless (org-up-heading-safe) + ;; No parent, we are not in a date tree + (goto-char pos) + (throw 'next nil)) + (unless (looking-at "\\*+[ \t]+[0-9]+-[0-1][0-9]-[0-3][0-9]") + ;; Parent looks wrong, we are not in a date tree + (goto-char pos) + (throw 'next nil)) + (when (looking-at (format "\\*+[ \t]+%d-%02d-%02d" year month day)) + ;; At correct date already, do nothing + (progn (goto-char pos) (throw 'next nil))) + ;; OK, we need to refile this entry + (goto-char hdl-pos) + (org-cut-subtree) + (save-excursion + (save-restriction + (org-datetree-file-entry-under (current-kill 0) date))))))) + +(provide 'org-datetree) + +;; arch-tag: 1daea962-fd08-448b-9f98-6e8b511b3601 + +;;; org-datetree.el ends here diff --git a/.emacs.d/org-7.4/lisp/org-datetree.elc b/.emacs.d/org-7.4/lisp/org-datetree.elc Binary files differnew file mode 100644 index 0000000..1404b1c --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-datetree.elc diff --git a/.emacs.d/org-7.4/lisp/org-docbook.el b/.emacs.d/org-7.4/lisp/org-docbook.el new file mode 100644 index 0000000..91ebb97 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-docbook.el @@ -0,0 +1,1444 @@ +;;; org-docbook.el --- DocBook exporter for org-mode +;; +;; Copyright (C) 2007, 2008, 2009, 2010 Free Software Foundation, Inc. +;; +;; Emacs Lisp Archive Entry +;; Filename: org-docbook.el +;; Version: 7.4 +;; Author: Baoqiu Cui <cbaoqiu AT yahoo DOT com> +;; Maintainer: Baoqiu Cui <cbaoqiu AT yahoo DOT com> +;; Keywords: org, wp, docbook +;; Description: Converts an org-mode buffer into DocBook +;; URL: + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; This library implements a DocBook exporter for org-mode. The basic +;; idea and design is very similar to what `org-export-as-html' has. +;; Code prototype was also started with `org-export-as-html'. +;; +;; Put this file into your load-path and the following line into your +;; ~/.emacs: +;; +;; (require 'org-docbook) +;; +;; The interactive functions are similar to those of the HTML and LaTeX +;; exporters: +;; +;; M-x `org-export-as-docbook' +;; M-x `org-export-as-docbook-pdf' +;; M-x `org-export-as-docbook-pdf-and-open' +;; M-x `org-export-as-docbook-batch' +;; M-x `org-export-as-docbook-to-buffer' +;; M-x `org-export-region-as-docbook' +;; M-x `org-replace-region-by-docbook' +;; +;; Note that, in order to generate PDF files using the DocBook XML files +;; created by DocBook exporter, the following two variables have to be +;; set based on what DocBook tools you use for XSLT processor and XSL-FO +;; processor: +;; +;; org-export-docbook-xslt-proc-command +;; org-export-docbook-xsl-fo-proc-command +;; +;; Check the document of these two variables to see examples of how they +;; can be set. +;; +;; If the Org file to be exported contains special characters written in +;; TeX-like syntax, like \alpha and \beta, you need to include the right +;; entity file(s) in the DOCTYPE declaration for the DocBook XML file. +;; This is required to make the DocBook XML file valid. The DOCTYPE +;; declaration string can be set using the following variable: +;; +;; org-export-docbook-doctype +;; +;;; Code: + +(eval-when-compile + (require 'cl)) + +(require 'footnote) +(require 'org) +(require 'org-exp) +(require 'org-html) +(require 'format-spec) + +;;; Variables: + +(defvar org-docbook-para-open nil) +(defvar org-export-docbook-inline-images t) +(defvar org-export-docbook-link-org-files-as-docbook nil) + +(declare-function org-id-find-id-file "org-id" (id)) + +;;; User variables: + +(defgroup org-export-docbook nil + "Options for exporting Org-mode files to DocBook." + :tag "Org Export DocBook" + :group 'org-export) + +(defcustom org-export-docbook-extension ".xml" + "Extension of DocBook XML files." + :group 'org-export-docbook + :type 'string) + +(defcustom org-export-docbook-header "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n" + "Header of DocBook XML files." + :group 'org-export-docbook + :type 'string) + +(defcustom org-export-docbook-doctype nil + "DOCTYPE declaration string for DocBook XML files. +This can be used to include entities that are needed to handle +special characters in Org files. + +For example, if the Org file to be exported contains XHTML +entities, you can set this variable to: + +\"<!DOCTYPE article [ +<!ENTITY % xhtml1-symbol PUBLIC +\"-//W3C//ENTITIES Symbol for HTML//EN//XML\" +\"http://www.w3.org/2003/entities/2007/xhtml1-symbol.ent\" +> +%xhtml1-symbol; +]> +\" + +If you want to process DocBook documents without an Internet +connection, it is suggested that you download the required entity +file(s) and use system identifier(s) (external files) in the +DOCTYPE declaration." + :group 'org-export-docbook + :type 'string) + +(defcustom org-export-docbook-article-header "<article xmlns=\"http://docbook.org/ns/docbook\" + xmlns:xlink=\"http://www.w3.org/1999/xlink\" version=\"5.0\" xml:lang=\"en\">" + "Article header of DocBook XML files." + :group 'org-export-docbook + :type 'string) + +(defcustom org-export-docbook-section-id-prefix "sec-" + "Prefix of section IDs used during exporting. +This can be set before exporting to avoid same set of section IDs +being used again and again, which can be a problem when multiple +people work on the same document." + :group 'org-export-docbook + :type 'string) + +(defcustom org-export-docbook-footnote-id-prefix "fn-" + "The prefix of footnote IDs used during exporting. +Like `org-export-docbook-section-id-prefix', this variable can help +avoid same set of footnote IDs being used multiple times." + :group 'org-export-docbook + :type 'string) + +(defcustom org-export-docbook-emphasis-alist + `(("*" "<emphasis role=\"bold\">" "</emphasis>") + ("/" "<emphasis>" "</emphasis>") + ("_" "<emphasis role=\"underline\">" "</emphasis>") + ("=" "<code>" "</code>") + ("~" "<literal>" "</literal>") + ("+" "<emphasis role=\"strikethrough\">" "</emphasis>")) + "A list of DocBook expressions to convert emphasis fontifiers. +Each element of the list is a list of three elements. +The first element is the character used as a marker for fontification. +The second element is a formatting string to wrap fontified text with. +The third element decides whether to protect converted text from other +conversions." + :group 'org-export-docbook + :type 'alist) + +(defcustom org-export-docbook-default-image-attributes + `(("align" . "\"center\"") + ("valign". "\"middle\"")) + "Alist of default DocBook image attributes. +These attributes will be inserted into element <imagedata> by +default, but users can override them using `#+ATTR_DocBook:'." + :group 'org-export-docbook + :type 'alist) + +(defcustom org-export-docbook-inline-image-extensions + '("jpeg" "jpg" "png" "gif" "svg") + "Extensions of image files that can be inlined into DocBook." + :group 'org-export-docbook + :type '(repeat (string :tag "Extension"))) + +(defcustom org-export-docbook-coding-system nil + "Coding system for DocBook XML files." + :group 'org-export-docbook + :type 'coding-system) + +(defcustom org-export-docbook-xslt-stylesheet nil + "File name of the XSLT stylesheet used by DocBook exporter. +This XSLT stylesheet is used by +`org-export-docbook-xslt-proc-command' to generate the Formatting +Object (FO) files. You can use either `fo/docbook.xsl' that +comes with DocBook, or any customization layer you may have." + :group 'org-export-docbook + :type 'string) + +(defcustom org-export-docbook-xslt-proc-command nil + "Format of XSLT processor command used by DocBook exporter. +This command is used to process a DocBook XML file to generate +the Formatting Object (FO) file. + +The value of this variable should be a format control string that +includes three arguments: `%i', `%o', and `%s'. During exporting +time, `%i' is replaced by the input DocBook XML file name, `%o' +is replaced by the output FO file name, and `%s' is replaced by +`org-export-docbook-xslt-stylesheet' (or the #+XSLT option if it +is specified in the Org file). + +For example, if you use Saxon as the XSLT processor, you may want +to set the variable to + + \"java com.icl.saxon.StyleSheet -o %o %i %s\" + +If you use Xalan, you can set it to + + \"java org.apache.xalan.xslt.Process -out %o -in %i -xsl %s\" + +For xsltproc, the following string should work: + + \"xsltproc --output %o %s %i\" + +You can include additional stylesheet parameters in this command. +Just make sure that they meet the syntax requirement of each +processor." + :group 'org-export-docbook + :type 'string) + +(defcustom org-export-docbook-xsl-fo-proc-command nil + "Format of XSL-FO processor command used by DocBook exporter. +This command is used to process a Formatting Object (FO) file to +generate the PDF file. + +The value of this variable should be a format control string that +includes two arguments: `%i' and `%o'. During exporting time, +`%i' is replaced by the input FO file name, and `%o' is replaced +by the output PDF file name. + +For example, if you use FOP as the XSL-FO processor, you can set +the variable to + + \"fop %i %o\"" + :group 'org-export-docbook + :type 'string) + +(defcustom org-export-docbook-keywords-markup "<literal>%s</literal>" + "A printf format string to be applied to keywords by DocBook exporter." + :group 'org-export-docbook + :type 'string) + +(defcustom org-export-docbook-timestamp-markup "<emphasis>%s</emphasis>" + "A printf format string to be applied to time stamps by DocBook exporter." + :group 'org-export-docbook + :type 'string) + +;;; Hooks + +(defvar org-export-docbook-final-hook nil + "Hook run at the end of DocBook export, in the new buffer.") + +;;; Autoload functions: + +;;;###autoload +(defun org-export-as-docbook-batch () + "Call `org-export-as-docbook' in batch style. +This function can be used in batch processing. + +For example: + +$ emacs --batch + --load=$HOME/lib/emacs/org.el + --visit=MyOrgFile.org --funcall org-export-as-docbook-batch" + (org-export-as-docbook 'hidden)) + +;;;###autoload +(defun org-export-as-docbook-to-buffer () + "Call `org-export-as-docbook' with output to a temporary buffer. +No file is created." + (interactive) + (org-export-as-docbook nil nil "*Org DocBook Export*") + (when org-export-show-temporary-export-buffer + (switch-to-buffer-other-window "*Org DocBook Export*"))) + +;;;###autoload +(defun org-replace-region-by-docbook (beg end) + "Replace the region from BEG to END with its DocBook export. +It assumes the region has `org-mode' syntax, and then convert it to +DocBook. This can be used in any buffer. For example, you could +write an itemized list in `org-mode' syntax in an DocBook buffer and +then use this command to convert it." + (interactive "r") + (let (reg docbook buf) + (save-window-excursion + (if (org-mode-p) + (setq docbook (org-export-region-as-docbook + beg end t 'string)) + (setq reg (buffer-substring beg end) + buf (get-buffer-create "*Org tmp*")) + (with-current-buffer buf + (erase-buffer) + (insert reg) + (org-mode) + (setq docbook (org-export-region-as-docbook + (point-min) (point-max) t 'string))) + (kill-buffer buf))) + (delete-region beg end) + (insert docbook))) + +;;;###autoload +(defun org-export-region-as-docbook (beg end &optional body-only buffer) + "Convert region from BEG to END in `org-mode' buffer to DocBook. +If prefix arg BODY-ONLY is set, omit file header and footer and +only produce the region of converted text, useful for +cut-and-paste operations. If BUFFER is a buffer or a string, +use/create that buffer as a target of the converted DocBook. If +BUFFER is the symbol `string', return the produced DocBook as a +string and leave not buffer behind. For example, a Lisp program +could call this function in the following way: + + (setq docbook (org-export-region-as-docbook beg end t 'string)) + +When called interactively, the output buffer is selected, and shown +in a window. A non-interactive call will only return the buffer." + (interactive "r\nP") + (when (interactive-p) + (setq buffer "*Org DocBook Export*")) + (let ((transient-mark-mode t) + (zmacs-regions t) + rtn) + (goto-char end) + (set-mark (point)) ;; To activate the region + (goto-char beg) + (setq rtn (org-export-as-docbook + nil nil + buffer body-only)) + (if (fboundp 'deactivate-mark) (deactivate-mark)) + (if (and (interactive-p) (bufferp rtn)) + (switch-to-buffer-other-window rtn) + rtn))) + +;;;###autoload +(defun org-export-as-docbook-pdf (&optional hidden ext-plist + to-buffer body-only pub-dir) + "Export as DocBook XML file, and generate PDF file." + (interactive "P") + (if (or (not org-export-docbook-xslt-proc-command) + (not (string-match "%[ios].+%[ios].+%[ios]" org-export-docbook-xslt-proc-command))) + (error "XSLT processor command is not set correctly")) + (if (or (not org-export-docbook-xsl-fo-proc-command) + (not (string-match "%[io].+%[io]" org-export-docbook-xsl-fo-proc-command))) + (error "XSL-FO processor command is not set correctly")) + (message "Exporting to PDF...") + (let* ((wconfig (current-window-configuration)) + (opt-plist + (org-export-process-option-filters + (org-combine-plists (org-default-export-plist) + ext-plist + (org-infile-export-plist)))) + (docbook-buf (org-export-as-docbook hidden ext-plist + to-buffer body-only pub-dir)) + (filename (buffer-file-name docbook-buf)) + (base (file-name-sans-extension filename)) + (fofile (concat base ".fo")) + (pdffile (concat base ".pdf"))) + (and (file-exists-p pdffile) (delete-file pdffile)) + (message "Processing DocBook XML file...") + (shell-command (format-spec org-export-docbook-xslt-proc-command + (format-spec-make + ?i (shell-quote-argument filename) + ?o (shell-quote-argument fofile) + ?s (shell-quote-argument + (or (plist-get opt-plist :xslt) + org-export-docbook-xslt-stylesheet))))) + (shell-command (format-spec org-export-docbook-xsl-fo-proc-command + (format-spec-make + ?i (shell-quote-argument fofile) + ?o (shell-quote-argument pdffile)))) + (message "Processing DocBook file...done") + (if (not (file-exists-p pdffile)) + (error "PDF file was not produced") + (set-window-configuration wconfig) + (message "Exporting to PDF...done") + pdffile))) + +;;;###autoload +(defun org-export-as-docbook-pdf-and-open () + "Export as DocBook XML file, generate PDF file, and open it." + (interactive) + (let ((pdffile (org-export-as-docbook-pdf))) + (if pdffile + (org-open-file pdffile) + (error "PDF file was not produced")))) + +;;;###autoload +(defun org-export-as-docbook (&optional hidden ext-plist + to-buffer body-only pub-dir) + "Export the current buffer as a DocBook file. +If there is an active region, export only the region. When +HIDDEN is obsolete and does nothing. EXT-PLIST is a +property list with external parameters overriding org-mode's +default settings, but still inferior to file-local settings. +When TO-BUFFER is non-nil, create a buffer with that name and +export to that buffer. If TO-BUFFER is the symbol `string', +don't leave any buffer behind but just return the resulting HTML +as a string. When BODY-ONLY is set, don't produce the file +header and footer, simply return the content of the document (all +top-level sections). When PUB-DIR is set, use this as the +publishing directory." + (interactive "P") + (run-hooks 'org-export-first-hook) + + ;; Make sure we have a file name when we need it. + (when (and (not (or to-buffer body-only)) + (not buffer-file-name)) + (if (buffer-base-buffer) + (org-set-local 'buffer-file-name + (with-current-buffer (buffer-base-buffer) + buffer-file-name)) + (error "Need a file name to be able to export"))) + + (message "Exporting...") + (setq-default org-todo-line-regexp org-todo-line-regexp) + (setq-default org-deadline-line-regexp org-deadline-line-regexp) + (setq-default org-done-keywords org-done-keywords) + (setq-default org-maybe-keyword-time-regexp org-maybe-keyword-time-regexp) + (let* ((opt-plist + (org-export-process-option-filters + (org-combine-plists (org-default-export-plist) + ext-plist + (org-infile-export-plist)))) + (link-validate (plist-get opt-plist :link-validation-function)) + valid + (odd org-odd-levels-only) + (region-p (org-region-active-p)) + (rbeg (and region-p (region-beginning))) + (rend (and region-p (region-end))) + (subtree-p + (if (plist-get opt-plist :ignore-subtree-p) + nil + (when region-p + (save-excursion + (goto-char rbeg) + (and (org-at-heading-p) + (>= (org-end-of-subtree t t) rend)))))) + (level-offset (if subtree-p + (save-excursion + (goto-char rbeg) + (+ (funcall outline-level) + (if org-odd-levels-only 1 0))) + 0)) + (opt-plist (setq org-export-opt-plist + (if subtree-p + (org-export-add-subtree-options opt-plist rbeg) + opt-plist))) + ;; The following two are dynamically scoped into other + ;; routines below. + (org-current-export-dir + (or pub-dir (org-export-directory :docbook opt-plist))) + (org-current-export-file buffer-file-name) + (level 0) (line "") (origline "") txt todo + (filename (if to-buffer nil + (expand-file-name + (concat + (file-name-sans-extension + (or (and subtree-p + (org-entry-get (region-beginning) + "EXPORT_FILE_NAME" t)) + (file-name-nondirectory buffer-file-name))) + org-export-docbook-extension) + (file-name-as-directory + (or pub-dir (org-export-directory :docbook opt-plist)))))) + (current-dir (if buffer-file-name + (file-name-directory buffer-file-name) + default-directory)) + (buffer (if to-buffer + (cond + ((eq to-buffer 'string) (get-buffer-create "*Org DocBook Export*")) + (t (get-buffer-create to-buffer))) + (find-file-noselect filename))) + ;; org-levels-open is a global variable + (org-levels-open (make-vector org-level-max nil)) + (date (plist-get opt-plist :date)) + (author (or (plist-get opt-plist :author) + user-full-name)) + (email (plist-get opt-plist :email)) + firstname othername surname + (title (or (and subtree-p (org-export-get-title-from-subtree)) + (plist-get opt-plist :title) + (and (not + (plist-get opt-plist :skip-before-1st-heading)) + (org-export-grab-title-from-buffer)) + (and buffer-file-name + (file-name-sans-extension + (file-name-nondirectory buffer-file-name))) + "UNTITLED")) + ;; We will use HTML table formatter to export tables to DocBook + ;; format, so need to set html-table-tag here. + (html-table-tag (plist-get opt-plist :html-table-tag)) + (quote-re0 (concat "^[ \t]*" org-quote-string "\\>")) + (quote-re (concat "^\\(\\*+\\)\\([ \t]+" org-quote-string "\\>\\)")) + (inquote nil) + (infixed nil) + (inverse nil) + (in-local-list nil) + (local-list-type nil) + (local-list-indent nil) + (llt org-plain-list-ordered-item-terminator) + (email (plist-get opt-plist :email)) + (language (plist-get opt-plist :language)) + (lang-words nil) + cnt + (start 0) + (coding-system (and (boundp 'buffer-file-coding-system) + buffer-file-coding-system)) + (coding-system-for-write (or org-export-docbook-coding-system + coding-system)) + (save-buffer-coding-system (or org-export-docbook-coding-system + coding-system)) + (charset (and coding-system-for-write + (fboundp 'coding-system-get) + (coding-system-get coding-system-for-write + 'mime-charset))) + (region + (buffer-substring + (if region-p (region-beginning) (point-min)) + (if region-p (region-end) (point-max)))) + (lines + (org-split-string + (org-export-preprocess-string + region + :emph-multiline t + :for-docbook t + :skip-before-1st-heading + (plist-get opt-plist :skip-before-1st-heading) + :drawers (plist-get opt-plist :drawers) + :todo-keywords (plist-get opt-plist :todo-keywords) + :tags (plist-get opt-plist :tags) + :priority (plist-get opt-plist :priority) + :footnotes (plist-get opt-plist :footnotes) + :timestamps (plist-get opt-plist :timestamps) + :archived-trees + (plist-get opt-plist :archived-trees) + :select-tags (plist-get opt-plist :select-tags) + :exclude-tags (plist-get opt-plist :exclude-tags) + :add-text + (plist-get opt-plist :text) + :LaTeX-fragments + (plist-get opt-plist :LaTeX-fragments)) + "[\r\n]")) + ;; Use literal output to show check boxes. + (checkbox-start + (nth 1 (assoc "=" org-export-docbook-emphasis-alist))) + (checkbox-end + (nth 2 (assoc "=" org-export-docbook-emphasis-alist))) + table-open type + table-buffer table-orig-buffer + ind item-type starter + rpl path attr caption label desc descp desc1 desc2 link + fnc item-tag item-number + footref-seen footnote-list + id-file + ) + + ;; Fine detailed info about author name. + (if (string-match "\\([^ ]+\\) \\(.+ \\)?\\([^ ]+\\)" author) + (progn + (setq firstname (match-string 1 author) + othername (or (match-string 2 author) "") + surname (match-string 3 author)))) + + ;; Get all footnote text. + (setq footnote-list + (org-export-docbook-get-footnotes lines)) + + (let ((inhibit-read-only t)) + (org-unmodified + (remove-text-properties (point-min) (point-max) + '(:org-license-to-kill t)))) + + (setq org-min-level (org-get-min-level lines level-offset)) + (setq org-last-level org-min-level) + (org-init-section-numbers) + + ;; Get and save the date. + (cond + ((and date (string-match "%" date)) + (setq date (format-time-string date))) + (date) + (t (setq date (format-time-string "%Y-%m-%d %T %Z")))) + + ;; Get the language-dependent settings + (setq lang-words (or (assoc language org-export-language-setup) + (assoc "en" org-export-language-setup))) + + ;; Switch to the output buffer. Use fundamental-mode for now. We + ;; could turn on nXML mode later and do some indentation. + (set-buffer buffer) + (let ((inhibit-read-only t)) (erase-buffer)) + (fundamental-mode) + (org-install-letbind) + + (and (fboundp 'set-buffer-file-coding-system) + (set-buffer-file-coding-system coding-system-for-write)) + + ;; The main body... + (let ((case-fold-search nil) + (org-odd-levels-only odd)) + + ;; Create local variables for all options, to make sure all called + ;; functions get the correct information + (mapc (lambda (x) + (set (make-local-variable (nth 2 x)) + (plist-get opt-plist (car x)))) + org-export-plist-vars) + + ;; Insert DocBook file header, title, and author info. + (unless body-only + (insert org-export-docbook-header) + (if org-export-docbook-doctype + (insert org-export-docbook-doctype)) + (insert "<!-- Date: " date " -->\n") + (insert (format "<!-- DocBook XML file generated by Org-mode %s Emacs %s -->\n" + org-version emacs-major-version)) + (insert org-export-docbook-article-header) + (insert (format + "\n <title>%s</title> + <info> + <author> + <personname> + <firstname>%s</firstname> <othername>%s</othername> <surname>%s</surname> + </personname> + %s + </author> + </info>\n" + (org-docbook-expand title) + firstname othername surname + (if (and org-export-email-info + email (string-match "\\S-" email)) + (concat "<email>" email "</email>") "") + ))) + + (org-init-section-numbers) + + (org-export-docbook-open-para) + + ;; Loop over all the lines... + (while (setq line (pop lines) origline line) + (catch 'nextline + + ;; End of quote section? + (when (and inquote (string-match "^\\*+ " line)) + (insert "]]></programlisting>\n") + (org-export-docbook-open-para) + (setq inquote nil)) + ;; Inside a quote section? + (when inquote + (insert (org-docbook-protect line) "\n") + (throw 'nextline nil)) + + ;; Fixed-width, verbatim lines (examples) + (when (and org-export-with-fixed-width + (string-match "^[ \t]*:\\(\\([ \t]\\|$\\)\\(.*\\)\\)" line)) + (when (not infixed) + (setq infixed t) + (org-export-docbook-close-para-maybe) + (insert "<programlisting><![CDATA[")) + (insert (match-string 3 line) "\n") + (when (or (not lines) + (not (string-match "^[ \t]*\\(:.*\\)" + (car lines)))) + (setq infixed nil) + (insert "]]></programlisting>\n") + (org-export-docbook-open-para)) + (throw 'nextline nil)) + + ;; List ender: close every open list. + (when (equal "ORG-LIST-END" line) + (while local-list-type + (let ((listtype (car local-list-type))) + (org-export-docbook-close-li listtype) + (insert (cond + ((equal listtype "o") "</orderedlist>\n") + ((equal listtype "u") "</itemizedlist>\n") + ((equal listtype "d") "</variablelist>\n")))) + (pop local-list-type)) + ;; We did close a list, normal text follows: need <para> + (org-export-docbook-open-para) + (setq local-list-indent nil + in-local-list nil) + (throw 'nextline nil)) + + ;; Protected HTML + (when (get-text-property 0 'org-protected line) + (let (par (ind (get-text-property 0 'original-indentation line))) + (when (re-search-backward + "\\(<para>\\)\\([ \t\r\n]*\\)\\=" (- (point) 100) t) + (setq par (match-string 1)) + (replace-match "\\2\n")) + (insert line "\n") + (while (and lines + (or (= (length (car lines)) 0) + (not ind) + (equal ind (get-text-property 0 'original-indentation (car lines)))) + (or (= (length (car lines)) 0) + (get-text-property 0 'org-protected (car lines)))) + (insert (pop lines) "\n")) + (and par (insert "<para>\n"))) + (throw 'nextline nil)) + + ;; Start of block quotes and verses + (when (or (equal "ORG-BLOCKQUOTE-START" line) + (and (equal "ORG-VERSE-START" line) + (setq inverse t))) + (org-export-docbook-close-para-maybe) + (insert "<blockquote>") + ;; Check whether attribution for this blockquote exists. + (let (tmp1 + attribution + (end (if inverse "ORG-VERSE-END" "ORG-BLOCKQUOTE-END")) + (quote-lines nil)) + (while (and (setq tmp1 (pop lines)) + (not (equal end tmp1))) + (push tmp1 quote-lines)) + (push tmp1 lines) ; Put back quote end mark + ;; Check the last line in the quote to see if it contains + ;; the attribution. + (setq tmp1 (pop quote-lines)) + (if (string-match "\\(^.*\\)\\(--[ \t]+\\)\\(.+\\)$" tmp1) + (progn + (setq attribution (match-string 3 tmp1)) + (when (save-match-data + (string-match "[^ \t]" (match-string 1 tmp1))) + (push (match-string 1 tmp1) lines))) + (push tmp1 lines)) + (while (setq tmp1 (pop quote-lines)) + (push tmp1 lines)) + (when attribution + (insert "<attribution>" attribution "</attribution>"))) + ;; Insert <literallayout> for verse. + (if inverse + (insert "\n<literallayout>") + (org-export-docbook-open-para)) + (throw 'nextline nil)) + + ;; End of block quotes + (when (equal "ORG-BLOCKQUOTE-END" line) + (org-export-docbook-close-para-maybe) + (insert "</blockquote>\n") + (org-export-docbook-open-para) + (throw 'nextline nil)) + + ;; End of verses + (when (equal "ORG-VERSE-END" line) + (insert "</literallayout>\n</blockquote>\n") + (org-export-docbook-open-para) + (setq inverse nil) + (throw 'nextline nil)) + + ;; Text centering. Element <para role="centered"> does not + ;; seem to work with FOP, so for now we use <informaltable> to + ;; center the text, which can contain multiple paragraphs. + (when (equal "ORG-CENTER-START" line) + (org-export-docbook-close-para-maybe) + (insert "<informaltable frame=\"none\" colsep=\"0\" rowsep=\"0\">\n" + "<tgroup align=\"center\" cols=\"1\">\n" + "<tbody><row><entry>\n") + (org-export-docbook-open-para) + (throw 'nextline nil)) + + (when (equal "ORG-CENTER-END" line) + (org-export-docbook-close-para-maybe) + (insert "</entry></row></tbody>\n" + "</tgroup>\n</informaltable>\n") + (org-export-docbook-open-para) + (throw 'nextline nil)) + + ;; Make targets to anchors. Note that currently FOP does not + ;; seem to support <anchor> tags when generating PDF output, + ;; but this can be used in DocBook --> HTML conversion. + (setq start 0) + (while (string-match + "<<<?\\([^<>]*\\)>>>?\\((INVISIBLE)\\)?[ \t]*\n?" line start) + (cond + ((get-text-property (match-beginning 1) 'org-protected line) + (setq start (match-end 1))) + ((match-end 2) + (setq line (replace-match + (format "@<anchor xml:id=\"%s\"/>" + (org-solidify-link-text (match-string 1 line))) + t t line))) + (t + (setq line (replace-match + (format "@<anchor xml:id=\"%s\"/>" + (org-solidify-link-text (match-string 1 line))) + t t line))))) + + ;; Put time stamps and related keywords into special mark-up + ;; elements. + (setq line (org-export-docbook-handle-time-stamps line)) + + ;; Replace "&", "<" and ">" by "&", "<" and ">". + ;; Handle @<..> HTML tags (replace "@>..<" by "<..>"). + ;; Also handle sub_superscripts and check boxes. + (or (string-match org-table-hline-regexp line) + (setq line (org-docbook-expand line))) + + ;; Format the links + (setq start 0) + (while (string-match org-bracket-link-analytic-regexp++ line start) + (setq start (match-beginning 0)) + (setq path (save-match-data (org-link-unescape + (match-string 3 line)))) + (setq type (cond + ((match-end 2) (match-string 2 line)) + ((save-match-data + (or (file-name-absolute-p path) + (string-match "^\\.\\.?/" path))) + "file") + (t "internal"))) + (setq path (org-extract-attributes (org-link-unescape path))) + (setq attr (get-text-property 0 'org-attributes path) + caption (get-text-property 0 'org-caption path) + label (get-text-property 0 'org-label path)) + (setq desc1 (if (match-end 5) (match-string 5 line)) + desc2 (if (match-end 2) (concat type ":" path) path) + descp (and desc1 (not (equal desc1 desc2))) + desc (or desc1 desc2)) + ;; Make an image out of the description if that is so wanted + (when (and descp (org-file-image-p + desc org-export-docbook-inline-image-extensions)) + (save-match-data + (if (string-match "^file:" desc) + (setq desc (substring desc (match-end 0)))))) + ;; FIXME: do we need to unescape here somewhere? + (cond + ((equal type "internal") + (setq rpl (format "<link linkend=\"%s\">%s</link>" + (org-solidify-link-text + (save-match-data (org-link-unescape path)) nil) + (org-export-docbook-format-desc desc)))) + ((and (equal type "id") + (setq id-file (org-id-find-id-file path))) + ;; This is an id: link to another file (if it was the same file, + ;; it would have become an internal link...) + (save-match-data + (setq id-file (file-relative-name + id-file (file-name-directory org-current-export-file))) + (setq id-file (concat (file-name-sans-extension id-file) + org-export-docbook-extension)) + (setq rpl (format "<link xlink:href=\"%s#%s\">%s</link>" + id-file path (org-export-docbook-format-desc desc))))) + ((member type '("http" "https")) + ;; Standard URL, just check if we need to inline an image + (if (and (or (eq t org-export-docbook-inline-images) + (and org-export-docbook-inline-images (not descp))) + (org-file-image-p + path org-export-docbook-inline-image-extensions)) + (setq rpl (org-export-docbook-format-image + (concat type ":" path))) + (setq link (concat type ":" path)) + (setq rpl (format "<link xlink:href=\"%s\">%s</link>" + (org-export-html-format-href link) + (org-export-docbook-format-desc desc))) + )) + ((member type '("ftp" "mailto" "news")) + ;; Standard URL + (setq link (concat type ":" path)) + (setq rpl (format "<link xlink:href=\"%s\">%s</link>" + (org-export-html-format-href link) + (org-export-docbook-format-desc desc)))) + ((string= type "coderef") + (setq rpl (format (org-export-get-coderef-format path (and descp desc)) + (cdr (assoc path org-export-code-refs))))) + ((functionp (setq fnc (nth 2 (assoc type org-link-protocols)))) + ;; The link protocol has a function for format the link + (setq rpl + (save-match-data + (funcall fnc (org-link-unescape path) desc1 'html)))) + + ((string= type "file") + ;; FILE link + (let* ((filename path) + (abs-p (file-name-absolute-p filename)) + thefile file-is-image-p search) + (save-match-data + (if (string-match "::\\(.*\\)" filename) + (setq search (match-string 1 filename) + filename (replace-match "" t nil filename))) + (setq valid + (if (functionp link-validate) + (funcall link-validate filename current-dir) + t)) + (setq file-is-image-p + (org-file-image-p + filename org-export-docbook-inline-image-extensions)) + (setq thefile (if abs-p (expand-file-name filename) filename)) + ;; Carry over the properties (expand-file-name will + ;; discard the properties of filename) + (add-text-properties 0 (1- (length thefile)) + (list 'org-caption caption + 'org-attributes attr + 'org-label label) + thefile) + (when (and org-export-docbook-link-org-files-as-docbook + (string-match "\\.org$" thefile)) + (setq thefile (concat (substring thefile 0 + (match-beginning 0)) + org-export-docbook-extension)) + (if (and search + ;; make sure this is can be used as target search + (not (string-match "^[0-9]*$" search)) + (not (string-match "^\\*" search)) + (not (string-match "^/.*/$" search))) + (setq thefile (concat thefile "#" + (org-solidify-link-text + (org-link-unescape search))))) + (when (string-match "^file:" desc) + (setq desc (replace-match "" t t desc)) + (if (string-match "\\.org$" desc) + (setq desc (replace-match "" t t desc)))))) + (setq rpl (if (and file-is-image-p + (or (eq t org-export-docbook-inline-images) + (and org-export-docbook-inline-images + (not descp)))) + (progn + (message "image %s %s" thefile org-docbook-para-open) + (org-export-docbook-format-image thefile)) + (format "<link xlink:href=\"%s\">%s</link>" + thefile (org-export-docbook-format-desc desc)))) + (if (not valid) (setq rpl desc)))) + + (t + ;; Just publish the path, as default + (setq rpl (concat "<" type ":" + (save-match-data (org-link-unescape path)) + ">")))) + (setq line (replace-match rpl t t line) + start (+ start (length rpl)))) + + ;; TODO items: can we do something better?! + (if (and (string-match org-todo-line-regexp line) + (match-beginning 2)) + (setq line + (concat (substring line 0 (match-beginning 2)) + "[" (match-string 2 line) "]" + (substring line (match-end 2))))) + + ;; Does this contain a reference to a footnote? + (when org-export-with-footnotes + (setq start 0) + (while (string-match "\\([^* \t].*?\\)\\[\\([0-9]+\\)\\]" line start) + (if (get-text-property (match-beginning 2) 'org-protected line) + (setq start (match-end 2)) + (let* ((num (match-string 2 line)) + (footnote-def (assoc num footnote-list))) + (if (assoc num footref-seen) + (setq line (replace-match + (format "%s<footnoteref linkend=\"%s%s\"/>" + (match-string 1 line) + org-export-docbook-footnote-id-prefix num) + t t line)) + (setq line (replace-match + (format "%s<footnote xml:id=\"%s%s\"><para>%s</para></footnote>" + (match-string 1 line) + org-export-docbook-footnote-id-prefix + num + (if footnote-def + (save-match-data + (org-docbook-expand (cdr footnote-def))) + (format "FOOTNOTE DEFINITION NOT FOUND: %s" num))) + t t line)) + (push (cons num 1) footref-seen)))))) + + (cond + ((string-match "^\\(\\*+\\)[ \t]+\\(.*\\)" line) + ;; This is a headline + (setq level (org-tr-level (- (match-end 1) (match-beginning 1) + level-offset)) + txt (match-string 2 line)) + (if (string-match quote-re0 txt) + (setq txt (replace-match "" t t txt))) + (org-export-docbook-level-start level txt) + ;; QUOTES + (when (string-match quote-re line) + (org-export-docbook-close-para-maybe) + (insert "<programlisting><![CDATA[") + (setq inquote t))) + + ;; Tables: since version 4.3 of DocBook DTD, HTML tables are + ;; supported. We can use existing HTML table exporter code + ;; here. + ((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)) + (org-export-docbook-close-para-maybe) + (insert (org-export-docbook-finalize-table + (org-format-table-html table-buffer table-orig-buffer + 'no-css))))) + + (t + ;; Normal lines + (when (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 (or (get-text-property 0 'original-indentation line) + (org-get-string-indentation line)) + item-type (if (match-beginning 4) "o" "u") + starter (if (match-beginning 2) + (substring (match-string 2 line) 0 -1)) + line (substring line (match-beginning 5)) + item-tag nil + item-number nil) + (if (string-match "\\[@\\(?:start:\\)?\\([0-9]+\\)\\][ \t]?" line) + (setq item-number (match-string 1 line) + line (replace-match "" t t line))) + (if (and starter (string-match "\\(.*?\\) ::[ \t]*" line)) + (setq item-type "d" + item-tag (match-string 1 line) + line (substring line (match-end 0)))) + (cond + ((and starter + (or (not in-local-list) + (> ind (car local-list-indent)))) + ;; Start new (level of) list + (org-export-docbook-close-para-maybe) + (insert (cond + ((equal item-type "u") "<itemizedlist>\n<listitem>\n") + ((and (equal item-type "o") item-number) + ;; Check for a specific start number. If it + ;; is specified, we use the ``override'' + ;; attribute of element <listitem> to pass the + ;; info to DocBook. We could also use the + ;; ``startingnumber'' attribute of element + ;; <orderedlist>, but the former works on both + ;; DocBook 5.0 and prior versions. + (format "<orderedlist>\n<listitem override=\"%s\">\n" item-number)) + ((equal item-type "o") "<orderedlist>\n<listitem>\n") + ((equal item-type "d") + (format "<variablelist>\n<varlistentry><term>%s</term><listitem>\n" item-tag)))) + ;; For DocBook, we need to open a para right after tag + ;; <listitem>. + (org-export-docbook-open-para) + (push item-type local-list-type) + (push ind local-list-indent) + (setq in-local-list t)) + ;; Continue current list + (starter + ;; terminate any previous sublist but first ensure + ;; list is not ill-formed + (let ((min-ind (apply 'min local-list-indent))) + (when (< ind min-ind) (setq ind min-ind))) + (while (< ind (car local-list-indent)) + (let ((listtype (car local-list-type))) + (org-export-docbook-close-li listtype) + (insert (cond + ((equal listtype "o") "</orderedlist>\n") + ((equal listtype "u") "</itemizedlist>\n") + ((equal listtype "d") "</variablelist>\n")))) + (pop local-list-type) (pop local-list-indent) + (setq in-local-list local-list-indent)) + ;; insert new item + (let ((listtype (car local-list-type))) + (org-export-docbook-close-li listtype) + (insert (cond + ((and (equal listtype "o") item-number) + (format "<listitem override=\"%s\">" item-number)) + ((equal listtype "o") "<listitem>") + ((equal listtype "u") "<listitem>") + ((equal listtype "d") (format + "<varlistentry><term>%s</term><listitem>" + (or item-tag + "???")))))) + ;; For DocBook, we need to open a para right after tag + ;; <listitem>. + (org-export-docbook-open-para))) + ;; Checkboxes. + (if (string-match "^[ \t]*\\(\\[[X -]\\]\\)" line) + (setq line + (replace-match (concat checkbox-start + (match-string 1 line) + checkbox-end) + t t line)))) + + ;; Empty lines start a new paragraph. If hand-formatted lists + ;; are not fully interpreted, lines starting with "-", "+", "*" + ;; also start a new paragraph. + (if (and (string-match "^ [-+*]-\\|^[ \t]*$" line) + (not inverse)) + (org-export-docbook-open-para)) + + ;; Is this the start of a footnote? + (when org-export-with-footnotes + (when (and (boundp 'footnote-section-tag-regexp) + (string-match (concat "^" footnote-section-tag-regexp) + line)) + ;; ignore this line + (throw 'nextline nil)) + ;; These footnote lines have been read and saved before, + ;; ignore them at this time. + (when (string-match "^[ \t]*\\[\\([0-9]+\\)\\]" line) + (org-export-docbook-close-para-maybe) + (throw 'nextline nil))) + + ;; FIXME: It might be a good idea to add an option to + ;; support line break processing instruction <?linebreak?>. + ;; Org-mode supports line break "\\" in HTML exporter, and + ;; some DocBook users may also want to force line breaks + ;; even though DocBook only supports that in + ;; <literallayout>. + + (insert line "\n"))))) + + ;; Properly close all local lists and other lists + (when inquote + (insert "]]></programlisting>\n") + (org-export-docbook-open-para)) + + ;; Close all open sections. + (org-export-docbook-level-start 1 nil) + + (unless (plist-get opt-plist :buffer-will-be-killed) + (normal-mode) + (if (eq major-mode (default-value 'major-mode)) + (nxml-mode))) + + ;; Remove empty paragraphs and lists. Replace them with a + ;; newline. + (goto-char (point-min)) + (while (re-search-forward + "[ \r\n\t]*\\(<para>\\)[ \r\n\t]*</para>[ \r\n\t]*" nil t) + (when (not (get-text-property (match-beginning 1) 'org-protected)) + (replace-match "\n") + ;; Avoid empty <listitem></listitem> caused by inline tasks. + ;; We should add an empty para to make everything valid. + (when (and (looking-at "</listitem>") + (save-excursion + (backward-char (length "<listitem>\n")) + (looking-at "<listitem>"))) + (insert "<para></para>")) + (backward-char 1))) + ;; Fill empty sections with <para></para>. This is to make sure + ;; that the DocBook document generated is valid and well-formed. + (goto-char (point-min)) + (while (re-search-forward + "</title>\\([ \r\n\t]*\\)</section>" nil t) + (when (not (get-text-property (match-beginning 0) 'org-protected)) + (replace-match "\n<para></para>\n" nil nil nil 1))) + ;; Insert the last closing tag. + (goto-char (point-max)) + (unless body-only + (insert "</article>")) + (run-hooks 'org-export-docbook-final-hook) + (or to-buffer (save-buffer)) + (goto-char (point-min)) + (or (org-export-push-to-kill-ring "DocBook") + (message "Exporting... done")) + (if (eq to-buffer 'string) + (prog1 (buffer-substring (point-min) (point-max)) + (kill-buffer (current-buffer))) + (current-buffer))))) + +(defun org-export-docbook-open-para () + "Insert <para>, but first close previous paragraph if any." + (org-export-docbook-close-para-maybe) + (insert "\n<para>") + (setq org-docbook-para-open t)) + +(defun org-export-docbook-close-para-maybe () + "Close DocBook paragraph if there is one open." + (when org-docbook-para-open + (insert "</para>\n") + (setq org-docbook-para-open nil))) + +(defun org-export-docbook-close-li (&optional type) + "Close list if necessary." + (org-export-docbook-close-para-maybe) + (if (equal type "d") + (insert "</listitem></varlistentry>\n") + (insert "</listitem>\n"))) + +(defvar in-local-list) +(defvar local-list-indent) +(defvar local-list-type) + +(defun org-export-docbook-level-start (level title) + "Insert a new level in DocBook export. +When TITLE is nil, just close all open levels." + (org-export-docbook-close-para-maybe) + (let* ((target (and title (org-get-text-property-any 0 'target title))) + (l org-level-max) + section-number) + (while (>= l level) + (if (aref org-levels-open (1- l)) + (progn + (insert "</section>\n") + (aset org-levels-open (1- l) nil))) + (setq l (1- l))) + (when title + ;; If title is nil, this means this function is called to close + ;; all levels, so the rest is done only if title is given. + ;; + ;; Format tags: put them into a superscript like format. + (when (string-match (org-re "\\(:[[:alnum:]_@#%:]+:\\)[ \t]*$") title) + (setq title + (replace-match + (if org-export-with-tags + (save-match-data + (concat + "<superscript>" + (match-string 1 title) + "</superscript>")) + "") + t t title))) + (aset org-levels-open (1- level) t) + (setq section-number (org-section-number level)) + (insert (format "\n<section xml:id=\"%s%s\">\n<title>%s</title>" + org-export-docbook-section-id-prefix + (replace-regexp-in-string "\\." "_" section-number) + title)) + (org-export-docbook-open-para)))) + +(defun org-docbook-expand (string) + "Prepare STRING for DocBook export. +Applies all active conversions. If there are links in the +string, don't modify these." + (let* ((re (concat org-bracket-link-regexp "\\|" + (org-re "[ \t]+\\(:[[:alnum:]_@#%:]+:\\)[ \t]*$"))) + m s l res) + (while (setq m (string-match re string)) + (setq s (substring string 0 m) + l (match-string 0 string) + string (substring string (match-end 0))) + (push (org-docbook-do-expand s) res) + (push l res)) + (push (org-docbook-do-expand string) res) + (apply 'concat (nreverse res)))) + +(defun org-docbook-do-expand (s) + "Apply all active conversions to translate special ASCII to DocBook." + (setq s (org-html-protect s)) + (while (string-match "@<\\([^&]*\\)>" s) + (setq s (replace-match "<\\1>" t nil s))) + (if org-export-with-emphasize + (setq s (org-export-docbook-convert-emphasize s))) + (if org-export-with-special-strings + (setq s (org-export-docbook-convert-special-strings s))) + (if org-export-with-sub-superscripts + (setq s (org-export-docbook-convert-sub-super s))) + (if org-export-with-TeX-macros + (let ((start 0) wd rep) + (while (setq start (string-match "\\\\\\([a-zA-Z]+\\)\\({}\\)?" + s start)) + (if (get-text-property (match-beginning 0) 'org-protected s) + (setq start (match-end 0)) + (setq wd (match-string 1 s)) + (if (setq rep (org-entity-get-representation wd 'html)) + (setq s (replace-match rep t t s)) + (setq start (+ start (length wd)))))))) + s) + +(defun org-export-docbook-format-desc (desc) + "Make sure DESC is valid as a description in a link." + (save-match-data + (org-docbook-do-expand desc))) + +(defun org-export-docbook-convert-emphasize (string) + "Apply emphasis for DocBook exporting." + (let ((s 0) rpl) + (while (string-match org-emph-re string s) + (if (not (equal + (substring string (match-beginning 3) (1+ (match-beginning 3))) + (substring string (match-beginning 4) (1+ (match-beginning 4))))) + (setq s (match-beginning 0) + rpl + (concat + (match-string 1 string) + (nth 1 (assoc (match-string 3 string) + org-export-docbook-emphasis-alist)) + (match-string 4 string) + (nth 2 (assoc (match-string 3 string) + org-export-docbook-emphasis-alist)) + (match-string 5 string)) + string (replace-match rpl t t string) + s (+ s (- (length rpl) 2))) + (setq s (1+ s)))) + string)) + +(defun org-docbook-protect (string) + (org-html-protect string)) + +;; For now, simply return string as it is. +(defun org-export-docbook-convert-special-strings (string) + "Convert special characters in STRING to DocBook." + string) + +(defun org-export-docbook-get-footnotes (lines) + "Given a list of LINES, return a list of alist footnotes." + (let ((list nil) line) + (while (setq line (pop lines)) + (if (string-match "^[ \t]*\\[\\([0-9]+\\)\\] \\(.+\\)" line) + (push (cons (match-string 1 line) (match-string 2 line)) + list))) + list)) + +(defun org-export-docbook-format-image (src) + "Create image element in DocBook." + (save-match-data + (let* ((caption (org-find-text-property-in-string 'org-caption src)) + (attr (or (org-find-text-property-in-string 'org-attributes src) + "")) + (label (org-find-text-property-in-string 'org-label src)) + (default-attr org-export-docbook-default-image-attributes) + tmp) + (setq caption (and caption (org-html-do-expand caption))) + (while (setq tmp (pop default-attr)) + (if (not (string-match (concat (car tmp) "=") attr)) + (setq attr (concat attr " " (car tmp) "=" (cdr tmp))))) + (format "<mediaobject%s> +<imageobject>\n<imagedata fileref=\"%s\" %s/>\n</imageobject> +%s</mediaobject>" + (if label (concat " xml:id=\"" label "\"") "") + src attr + (if caption + (concat "<caption>\n<para>" + caption + "</para>\n</caption>\n") + "") + )))) + +(defun org-export-docbook-preprocess (parameters) + "Extra preprocessing work for DocBook export." + ;; Merge lines starting with "\par" to one line. Such lines are + ;; regarded as the continuation of a long footnote. + (goto-char (point-min)) + (while (re-search-forward "\n\\(\\\\par\\>\\)" nil t) + (if (not (get-text-property (match-beginning 1) 'org-protected)) + (replace-match "")))) + +(defun org-export-docbook-finalize-table (table) + "Clean up TABLE and turn it into DocBook format. +This function adds a label to the table if it is available, and +also changes TABLE to informaltable if caption does not exist. +TABLE is a string containing the HTML code generated by +`org-format-table-html' for a table in Org-mode buffer." + (let (table-with-label) + ;; Get the label if it exists, and move it into the <table> element. + (setq table-with-label + (if (string-match + "^<table \\(\\(.\\|\n\\)+\\)<a name=\"\\(.+\\)\" id=\".+\"></a>\n\\(\\(.\\|\n\\)+\\)</table>" + table) + (replace-match (concat "<table xml:id=\"" (match-string 3 table) "\" " + (match-string 1 table) + (match-string 4 table) + "</table>") + nil nil table) + table)) + ;; Change <table> into <informaltable> if caption does not exist. + (if (string-match + "^<table \\(\\(.\\|\n\\)+\\)<caption></caption>\n\\(\\(.\\|\n\\)+\\)</table>" + table-with-label) + (replace-match (concat "<informaltable " + (match-string 1 table-with-label) + (match-string 3 table-with-label) + "</informaltable>") + nil nil table-with-label) + table-with-label))) + +;; Note: This function is very similar to +;; org-export-html-convert-sub-super. They can be merged in the future. +(defun org-export-docbook-convert-sub-super (string) + "Convert sub- and superscripts in STRING for DocBook." + (let (key c (s 0) (requireb (eq org-export-with-sub-superscripts '{}))) + (while (string-match org-match-substring-regexp string s) + (cond + ((and requireb (match-end 8)) (setq s (match-end 2))) + ((get-text-property (match-beginning 2) 'org-protected string) + (setq s (match-end 2))) + (t + (setq s (match-end 1) + key (if (string= (match-string 2 string) "_") + "subscript" + "superscript") + c (or (match-string 8 string) + (match-string 6 string) + (match-string 5 string)) + string (replace-match + (concat (match-string 1 string) + "<" key ">" c "</" key ">") + t t string))))) + (while (string-match "\\\\\\([_^]\\)" string) + (setq string (replace-match (match-string 1 string) t t string))) + string)) + +(defun org-export-docbook-protect-tags (string) + "Change ``<...>'' in string STRING into ``@<...>''. +This is normally needed when STRING contains DocBook elements +that need to be preserved in later phase of DocBook exporting." + (let ((start 0)) + (while (string-match "<\\([^>]*\\)>" string start) + (setq string (replace-match + "@<\\1>" t nil string) + start (match-end 0))) + string)) + +(defun org-export-docbook-handle-time-stamps (line) + "Format time stamps in string LINE." + (let (replaced + (kw-markup (org-export-docbook-protect-tags + org-export-docbook-keywords-markup)) + (ts-markup (org-export-docbook-protect-tags + org-export-docbook-timestamp-markup))) + (while (string-match org-maybe-keyword-time-regexp line) + (setq replaced + (concat replaced + (substring line 0 (match-beginning 0)) + (if (match-end 1) + (format kw-markup + (match-string 1 line))) + " " + (format ts-markup + (substring (org-translate-time + (match-string 3 line)) 1 -1))) + line (substring line (match-end 0)))) + (concat replaced line))) + +(provide 'org-docbook) + +;; arch-tag: a24a127c-d365-4c2a-9e9b-f7dcb0ebfdc3 +;;; org-docbook.el ends here diff --git a/.emacs.d/org-7.4/lisp/org-docbook.elc b/.emacs.d/org-7.4/lisp/org-docbook.elc Binary files differnew file mode 100644 index 0000000..5c8c867 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-docbook.elc diff --git a/.emacs.d/org-7.4/lisp/org-docview.el b/.emacs.d/org-7.4/lisp/org-docview.el new file mode 100644 index 0000000..cb0f241 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-docview.el @@ -0,0 +1,93 @@ +;;; org-docview.el --- support for links to doc-view-mode buffers + +;; Copyright (C) 2009, 2010 Free Software Foundation, Inc. + +;; Author: Jan Böcker <jan.boecker at jboecker dot de> +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; Version: 7.4 +;; +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: + +;; This file implements links to open files in doc-view-mode. +;; Org-mode loads this module by default - if this is not what you want, +;; configure the variable `org-modules'. + +;; The links take the form +;; +;; docview:<file path>::<page number> +;; +;; for example: [[docview:~/.elisp/org/doc/org.pdf::1][Org-Mode Manual]] +;; +;; Autocompletion for inserting links is supported; you will be +;; prompted for a file and a page number. +;; +;; If you use org-store-link in a doc-view mode buffer, the stored +;; link will point to the current page. + +;;; Code: + + +(require 'org) + +(declare-function doc-view-goto-page "ext:doc-view" (page)) +(declare-function image-mode-window-get "ext:image-mode" + (prop &optional winprops)) + +(autoload 'doc-view-goto-page "doc-view") + +(org-add-link-type "docview" 'org-docview-open) +(add-hook 'org-store-link-functions 'org-docview-store-link) + +(defun org-docview-open (link) + (when (string-match "\\(.*\\)::\\([0-9]+\\)$" link) + (let* ((path (match-string 1 link)) + (page (string-to-number (match-string 2 link)))) + (org-open-file path 1) ;; let org-mode open the file (in-emacs = 1) + ;; to ensure org-link-frame-setup is respected + (doc-view-goto-page page) + ))) + +(defun org-docview-store-link () + "Store a link to a docview buffer." + (when (eq major-mode 'doc-view-mode) + ;; This buffer is in doc-view-mode + (let* ((path buffer-file-name) + (page (image-mode-window-get 'page)) + (link (concat "docview:" path "::" (number-to-string page))) + (description "")) + (org-store-link-props + :type "docview" + :link link + :description path)))) + +(defun org-docview-complete-link () + "Use the existing file name completion for file. +Links to get the file name, then ask the user for the page number +and append it." + (concat (replace-regexp-in-string "^file:" "docview:" (org-file-complete-link)) + "::" + (read-from-minibuffer "Page:" "1"))) + + +(provide 'org-docview) + +;; arch-tag: dd147a78-cce1-481b-b40a-15869417debe + +;;; org-docview.el ends here diff --git a/.emacs.d/org-7.4/lisp/org-docview.elc b/.emacs.d/org-7.4/lisp/org-docview.elc Binary files differnew file mode 100644 index 0000000..e51e7fb --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-docview.elc diff --git a/.emacs.d/org-7.4/lisp/org-entities.el b/.emacs.d/org-7.4/lisp/org-entities.el new file mode 100644 index 0000000..1c99b9e --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-entities.el @@ -0,0 +1,573 @@ +;;; org-entities.el --- Support for special entities in Org-mode + +;; Copyright (C) 2010 Free Software Foundation, Inc. + +;; Author: Carsten Dominik <carsten at orgmode dot org>, +;; Ulf Stegemann <ulf at zeitform dot de> +;; Keywords: outlines, calendar, wp +;; Homepage: http://orgmode.org +;; Version: 7.4 +;; +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: + +;;; Code: + +(require 'org-macs) + +(declare-function org-table-align "org-table" ()) + +(eval-when-compile + (require 'cl)) + +(defgroup org-entities nil + "Options concerning entities in Org-mode." + :tag "Org Entities" + :group 'org) + +(defcustom org-entities-ascii-explanatory nil + "Non-nil means replace special entities in ASCII. +For example, this will replace \"\\nsup\" with \"[not a superset of]\" +in backends where the corresponding character is not available." + :group 'org-entities + :type 'boolean) + +(defcustom org-entities-user nil + "User-defined entities used in Org-mode to produce special characters. +Each entry in this list is a list of strings. It associates the name +of the entity that can be inserted into an Org file as \\name with the +appropriate replacements for the different export backends. The order +of the fields is the following + +name As a string, without the leading backslash +LaTeX replacement In ready LaTeX, no further processing will take place +LaTeX mathp A Boolean, either t or nil. t if this entity needs + to be in math mode. +HTML replacement In ready HTML, no further processing will take place. + Usually this will be an &...; entity. +ASCII replacement Plain ASCII, no extensions. Symbols that cannot be + represented will be left as they are, but see the. + variable `org-entities-ascii-explanatory'. +Latin1 replacement Use the special characters available in latin1. +utf-8 replacement Use the special characters available in utf-8. + +If you define new entities here that require specific LaTeX packages to be +loaded, add these packages to `org-export-latex-packages-alist'." + :group 'org-entities + :type '(repeat + (list + (string :tag "name ") + (string :tag "LaTeX ") + (boolean :tag "Require LaTeX math?") + (string :tag "HTML ") + (string :tag "ASCII ") + (string :tag "Latin1") + (string :tag "utf-8 ")))) + +(defconst org-entities + '( + "* Letters" + "** Latin" + ("Agrave" "\\`{A}" nil "À" "A" "À" "À") + ("agrave" "\\`{a}" nil "à" "a" "à " "à ") + ("Aacute" "\\'{A}" nil "Á" "A" "Ã" "Ã") + ("aacute" "\\'{a}" nil "á" "a" "á" "á") + ("Acirc" "\\^{A}" nil "Â" "A" "Â" "Â") + ("acirc" "\\^{a}" nil "â" "a" "â" "â") + ("Atilde" "\\~{A}" nil "Ã" "A" "Ã" "Ã") + ("atilde" "\\~{a}" nil "ã" "a" "ã" "ã") + ("Auml" "\\\"{A}" nil "Ä" "Ae" "Ä" "Ä") + ("auml" "\\\"{a}" nil "ä" "ae" "ä" "ä") + ("Aring" "\\AA{}" nil "Å" "A" "Ã…" "Ã…") + ("AA" "\\AA{}" nil "Å" "A" "Ã…" "Ã…") + ("aring" "\\aa{}" nil "å" "a" "Ã¥" "Ã¥") + ("AElig" "\\AE{}" nil "Æ" "AE" "Æ" "Æ") + ("aelig" "\\ae{}" nil "æ" "ae" "æ" "æ") + ("Ccedil" "\\c{C}" nil "Ç" "C" "Ç" "Ç") + ("ccedil" "\\c{c}" nil "ç" "c" "ç" "ç") + ("Egrave" "\\`{E}" nil "È" "E" "È" "È") + ("egrave" "\\`{e}" nil "è" "e" "è" "è") + ("Eacute" "\\'{E}" nil "É" "E" "É" "É") + ("eacute" "\\'{e}" nil "é" "e" "é" "é") + ("Ecirc" "\\^{E}" nil "Ê" "E" "Ê" "Ê") + ("ecirc" "\\^{e}" nil "ê" "e" "ê" "ê") + ("Euml" "\\\"{E}" nil "Ë" "E" "Ë" "Ë") + ("euml" "\\\"{e}" nil "ë" "e" "ë" "ë") + ("Igrave" "\\`{I}" nil "Ì" "I" "ÃŒ" "ÃŒ") + ("igrave" "\\`{i}" nil "ì" "i" "ì" "ì") + ("Iacute" "\\'{I}" nil "Í" "I" "Ã" "Ã") + ("iacute" "\\'{i}" nil "í" "i" "Ã" "Ã") + ("Icirc" "\\^{I}" nil "Î" "I" "ÃŽ" "ÃŽ") + ("icirc" "\\^{i}" nil "î" "i" "î" "î") + ("Iuml" "\\\"{I}" nil "Ï" "I" "Ã" "Ã") + ("iuml" "\\\"{i}" nil "ï" "i" "ï" "ï") + ("Ntilde" "\\~{N}" nil "Ñ" "N" "Ñ" "Ñ") + ("ntilde" "\\~{n}" nil "ñ" "n" "ñ" "ñ") + ("Ograve" "\\`{O}" nil "Ò" "O" "Ã’" "Ã’") + ("ograve" "\\`{o}" nil "ò" "o" "ò" "ò") + ("Oacute" "\\'{O}" nil "Ó" "O" "Ó" "Ó") + ("oacute" "\\'{o}" nil "ó" "o" "ó" "ó") + ("Ocirc" "\\^{O}" nil "Ô" "O" "Ô" "Ô") + ("ocirc" "\\^{o}" nil "ô" "o" "ô" "ô") + ("Otilde" "\\~{O}" nil "Õ" "O" "Õ" "Õ") + ("otilde" "\\~{o}" nil "õ" "o" "õ" "õ") + ("Ouml" "\\\"{O}" nil "Ö" "Oe" "Ö" "Ö") + ("ouml" "\\\"{o}" nil "ö" "oe" "ö" "ö") + ("Oslash" "\\O" nil "Ø" "O" "Ø" "Ø") + ("oslash" "\\o{}" nil "ø" "o" "ø" "ø") + ("OElig" "\\OE{}" nil "Œ" "OE" "OE" "Å’") + ("oelig" "\\oe{}" nil "œ" "oe" "oe" "Å“") + ("Scaron" "\\v{S}" nil "Š" "S" "S" "Å ") + ("scaron" "\\v{s}" nil "š" "s" "s" "Å¡") + ("szlig" "\\ss{}" nil "ß" "ss" "ß" "ß") + ("Ugrave" "\\`{U}" nil "Ù" "U" "Ù" "Ù") + ("ugrave" "\\`{u}" nil "ù" "u" "ù" "ù") + ("Uacute" "\\'{U}" nil "Ú" "U" "Ú" "Ú") + ("uacute" "\\'{u}" nil "ú" "u" "ú" "ú") + ("Ucirc" "\\^{U}" nil "Û" "U" "Û" "Û") + ("ucirc" "\\^{u}" nil "û" "u" "û" "û") + ("Uuml" "\\\"{U}" nil "Ü" "Ue" "Ãœ" "Ãœ") + ("uuml" "\\\"{u}" nil "ü" "ue" "ü" "ü") + ("Yacute" "\\'{Y}" nil "Ý" "Y" "Ã" "Ã") + ("yacute" "\\'{y}" nil "ý" "y" "ý" "ý") + ("Yuml" "\\\"{Y}" nil "Ÿ" "Y" "Y" "Ÿ") + ("yuml" "\\\"{y}" nil "ÿ" "y" "ÿ" "ÿ") + + "** Latin (special face)" + ("fnof" "\\textit{f}" nil "ƒ" "f" "f" "Æ’") + ("real" "\\Re" t "ℜ" "R" "R" "â„œ") + ("image" "\\Im" t "ℑ" "I" "I" "â„‘") + ("weierp" "\\wp" t "℘" "P" "P" "℘") + + "** Greek" + ("Alpha" "A" nil "Α" "Alpha" "Alpha" "Α") + ("alpha" "\\alpha" t "α" "alpha" "alpha" "α") + ("Beta" "B" nil "Β" "Beta" "Beta" "Î’") + ("beta" "\\beta" t "β" "beta" "beta" "β") + ("Gamma" "\\Gamma" t "Γ" "Gamma" "Gamma" "Γ") + ("gamma" "\\gamma" t "γ" "gamma" "gamma" "γ") + ("Delta" "\\Delta" t "Δ" "Delta" "Gamma" "Δ") + ("delta" "\\delta" t "δ" "delta" "delta" "δ") + ("Epsilon" "E" nil "Ε" "Epsilon" "Epsilon" "Ε") + ("epsilon" "\\epsilon" t "ε" "epsilon" "epsilon" "ε") + ("varepsilon" "\\varepsilon" t "ε" "varepsilon" "varepsilon" "ε") + ("Zeta" "Z" nil "Ζ" "Zeta" "Zeta" "Ζ") + ("zeta" "\\zeta" t "ζ" "zeta" "zeta" "ζ") + ("Eta" "H" nil "Η" "Eta" "Eta" "Η") + ("eta" "\\eta" t "η" "eta" "eta" "η") + ("Theta" "\\Theta" t "Θ" "Theta" "Theta" "Θ") + ("theta" "\\theta" t "θ" "theta" "theta" "θ") + ("thetasym" "\\vartheta" t "ϑ" "theta" "theta" "Ï‘") + ("vartheta" "\\vartheta" t "ϑ" "theta" "theta" "Ï‘") + ("Iota" "I" nil "Ι" "Iota" "Iota" "Ι") + ("iota" "\\iota" t "ι" "iota" "iota" "ι") + ("Kappa" "K" nil "Κ" "Kappa" "Kappa" "Κ") + ("kappa" "\\kappa" t "κ" "kappa" "kappa" "κ") + ("Lambda" "\\Lambda" t "Λ" "Lambda" "Lambda" "Λ") + ("lambda" "\\lambda" t "λ" "lambda" "lambda" "λ") + ("Mu" "M" nil "Μ" "Mu" "Mu" "Îœ") + ("mu" "\\mu" t "μ" "mu" "mu" "μ") + ("nu" "\\nu" t "ν" "nu" "nu" "ν") + ("Nu" "N" nil "Ν" "Nu" "Nu" "Î") + ("Xi" "\\Xi" t "Ξ" "Xi" "Xi" "Ξ") + ("xi" "\\xi" t "ξ" "xi" "xi" "ξ") + ("Omicron" "O" nil "Ο" "Omicron" "Omicron" "Ο") + ("omicron" "\\textit{o}" nil "ο" "omicron" "omicron" "ο") + ("Pi" "\\Pi" t "Π" "Pi" "Pi" "Î ") + ("pi" "\\pi" t "π" "pi" "pi" "Ï€") + ("Rho" "P" nil "Ρ" "Rho" "Rho" "Ρ") + ("rho" "\\rho" t "ρ" "rho" "rho" "Ï") + ("Sigma" "\\Sigma" t "Σ" "Sigma" "Sigma" "Σ") + ("sigma" "\\sigma" t "σ" "sigma" "sigma" "σ") + ("sigmaf" "\\varsigma" t "ς" "sigmaf" "sigmaf" "Ï‚") + ("varsigma" "\\varsigma" t "ς" "varsigma" "varsigma" "Ï‚") + ("Tau" "T" nil "Τ" "Tau" "Tau" "Τ") + ("Upsilon" "\\Upsilon" t "Υ" "Upsilon" "Upsilon" "Î¥") + ("upsih" "\\Upsilon" t "ϒ" "upsilon" "upsilon" "Ï’") + ("upsilon" "\\upsilon" t "υ" "upsilon" "upsilon" "Ï…") + ("Phi" "\\Phi" t "Φ" "Phi" "Phi" "Φ") + ("phi" "\\phi" t "φ" "phi" "phi" "φ") + ("Chi" "X" nil "Χ" "Chi" "Chi" "Χ") + ("chi" "\\chi" t "χ" "chi" "chi" "χ") + ("acutex" "\\acute x" t "´x" "'x" "'x" "ð‘¥Ì") + ("Psi" "\\Psi" t "Ψ" "Psi" "Psi" "Ψ") + ("psi" "\\psi" t "ψ" "psi" "psi" "ψ") + ("tau" "\\tau" t "τ" "tau" "tau" "Ï„") + ("Omega" "\\Omega" t "Ω" "Omega" "Omega" "Ω") + ("omega" "\\omega" t "ω" "omega" "omega" "ω") + ("piv" "\\varpi" t "ϖ" "omega-pi" "omega-pi" "Ï–") + ("partial" "\\partial" t "∂" "[partial differential]" "[partial differential]" "∂") + + "** Hebrew" + ("alefsym" "\\aleph" t "ℵ" "aleph" "aleph" "ℵ") + + "** Dead languages" + ("ETH" "\\DH{}" nil "Ð" "D" "Ã" "Ã") + ("eth" "\\dh{}" nil "ð" "dh" "ð" "ð") + ("THORN" "\\TH{}" nil "Þ" "TH" "Þ" "Þ") + ("thorn" "\\th{}" nil "þ" "th" "þ" "þ") + + "* Punctuation" + "** Dots and Marks" + ("dots" "\\dots{}" nil "…" "..." "..." "…") + ("hellip" "\\dots{}" nil "…" "..." "..." "…") + ("middot" "\\textperiodcentered{}" nil "·" "." "·" "·") + ("iexcl" "!`" nil "¡" "!" "¡" "¡") + ("iquest" "?`" nil "¿" "?" "¿" "¿") + + "** Dash-like" + ("shy" "\\-" nil "­" "" "" "") + ("ndash" "--" nil "–" "-" "-" "–") + ("mdash" "---" nil "—" "--" "--" "—") + + "** Quotations" + ("quot" "\\textquotedbl{}" nil """ "\"" "\"" "\"") + ("acute" "\\textasciiacute{}" nil "´" "'" "´" "´") + ("ldquo" "\\textquotedblleft{}" nil "“" "\"" "\"" "“") + ("rdquo" "\\textquotedblright{}" nil "”" "\"" "\"" "â€") + ("bdquo" "\\quotedblbase{}" nil "„" "\"" "\"" "„") + ("lsquo" "\\textquoteleft{}" nil "‘" "`" "`" "‘") + ("rsquo" "\\textquoteright{}" nil "’" "'" "'" "’") + ("sbquo" "\\quotesinglbase{}" nil "‚" "," "," "‚") + ("laquo" "\\guillemotleft{}" nil "«" "<<" "«" "«") + ("raquo" "\\guillemotright{}" nil "»" ">>" "»" "»") + ("lsaquo" "\\guilsinglleft{}" nil "‹" "<" "<" "‹") + ("rsaquo" "\\guilsinglright{}" nil "›" ">" ">" "›") + + "* Other" + "** Misc. (often used)" + ("circ" "\\circ" t "ˆ" "^" "^" "ˆ") + ("vert" "\\vert{}" t "|" "|" "|" "|") + ("brvbar" "\\textbrokenbar{}" nil "¦" "|" "¦" "¦") + ("sect" "\\S" nil "§" "paragraph" "§" "§") + ("amp" "\\&" nil "&" "&" "&" "&") + ("lt" "\\textless{}" nil "<" "<" "<" "<") + ("gt" "\\textgreater{}" nil ">" ">" ">" ">") + ("tilde" "\\~{}" nil "˜" "~" "~" "~") + ("dagger" "\\textdagger{}" nil "†" "[dagger]" "[dagger]" "†") + ("Dagger" "\\textdaggerdbl{}" nil "‡" "[doubledagger]" "[doubledagger]" "‡") + + "** Whitespace" + ("nbsp" "~" nil " " " " " " " ") + ("ensp" "\\hspace*{.5em}" nil " " " " " " " ") + ("emsp" "\\hspace*{1em}" nil " " " " " " " ") + ("thinsp" "\\hspace*{.2em}" nil " " " " " " " ") + + "** Currency" + ("curren" "\\textcurrency{}" nil "¤" "curr." "¤" "¤") + ("cent" "\\textcent{}" nil "¢" "cent" "¢" "¢") + ("pound" "\\pounds{}" nil "£" "pound" "£" "£") + ("yen" "\\textyen{}" nil "¥" "yen" "Â¥" "Â¥") + ("euro" "\\texteuro{}" nil "€" "EUR" "EUR" "€") + ("EUR" "\\EUR{}" nil "€" "EUR" "EUR" "€") + ("EURdig" "\\EURdig{}" nil "€" "EUR" "EUR" "€") + ("EURhv" "\\EURhv{}" nil "€" "EUR" "EUR" "€") + ("EURcr" "\\EURcr{}" nil "€" "EUR" "EUR" "€") + ("EURtm" "\\EURtm{}" nil "€" "EUR" "EUR" "€") + + "** Property Marks" + ("copy" "\\textcopyright{}" nil "©" "(c)" "©" "©") + ("reg" "\\textregistered{}" nil "®" "(r)" "®" "®") + ("trade" "\\texttrademark{}" nil "™" "TM" "TM" "â„¢") + + "** Science et al." + ("minus" "\\minus" t "−" "-" "-" "−") + ("pm" "\\textpm{}" nil "±" "+-" "±" "±") + ("plusmn" "\\textpm{}" nil "±" "+-" "±" "±") + ("times" "\\texttimes{}" nil "×" "*" "×" "×") + ("frasl" "/" nil "⁄" "/" "/" "â„") + ("div" "\\textdiv{}" nil "÷" "/" "÷" "÷") + ("frac12" "\\textonehalf{}" nil "½" "1/2" "½" "½") + ("frac14" "\\textonequarter{}" nil "¼" "1/4" "¼" "¼") + ("frac34" "\\textthreequarters{}" nil "¾" "3/4" "¾" "¾") + ("permil" "\\textperthousand{}" nil "‰" "per thousand" "per thousand" "‰") + ("sup1" "\\textonesuperior{}" nil "¹" "^1" "¹" "¹") + ("sup2" "\\texttwosuperior{}" nil "²" "^2" "²" "²") + ("sup3" "\\textthreesuperior{}" nil "³" "^3" "³" "³") + ("radic" "\\sqrt{\\,}" t "√" "[square root]" "[square root]" "√") + ("sum" "\\sum" t "∑" "[sum]" "[sum]" "∑") + ("prod" "\\prod" t "∏" "[product]" "[n-ary product]" "âˆ") + ("micro" "\\textmu{}" nil "µ" "micro" "µ" "µ") + ("macr" "\\textasciimacron{}" nil "¯" "[macron]" "¯" "¯") + ("deg" "\\textdegree{}" nil "deg" "degree" "°" "°") + ("prime" "\\prime" t "′" "'" "'" "′") + ("Prime" "\\prime{}\\prime" t "″" "''" "''" "″") + ("infin" "\\propto" t "∞" "[infinity]" "[infinity]" "∞") + ("infty" "\\infty" t "∞" "[infinity]" "[infinity]" "∞") + ("prop" "\\propto" t "∝" "[proportional to]" "[proportional to]" "âˆ") + ("proptp" "\\propto" t "∝" "[proportional to]" "[proportional to]" "âˆ") + ("not" "\\textlnot{}" nil "¬" "[angled dash]" "¬" "¬") + ("land" "\\land" t "∧" "[logical and]" "[logical and]" "∧") + ("wedge" "\\wedge" t "∧" "[logical and]" "[logical and]" "∧") + ("lor" "\\lor" t "∨" "[logical or]" "[logical or]" "∨") + ("vee" "\\vee" t "∨" "[logical or]" "[logical or]" "∨") + ("cap" "\\cap" t "∩" "[intersection]" "[intersection]" "∩") + ("cup" "\\cup" t "∪" "[union]" "[union]" "∪") + ("int" "\\int" t "∫" "[integral]" "[integral]" "∫") + ("there4" "\\therefore" t "∴" "[therefore]" "[therefore]" "∴") + ("sim" "\\sim" t "∼" "~" "~" "∼") + ("cong" "\\cong" t "≅" "[approx. equal to]" "[approx. equal to]" "≅") + ("simeq" "\\simeq" t "≅" "[approx. equal to]" "[approx. equal to]" "≅") + ("asymp" "\\asymp" t "≈" "[almost equal to]" "[almost equal to]" "≈") + ("approx" "\\approx" t "≈" "[almost equal to]" "[almost equal to]" "≈") + ("ne" "\\ne" t "≠" "[not equal to]" "[not equal to]" "≠") + ("neq" "\\neq" t "≠" "[not equal to]" "[not equal to]" "≠") + ("equiv" "\\equiv" t "≡" "[identical to]" "[identical to]" "≡") + ("le" "\\le" t "≤" "<=" "<=" "≤") + ("ge" "\\ge" t "≥" ">=" ">=" "≥") + ("sub" "\\subset" t "⊂" "[subset of]" "[subset of]" "⊂") + ("subset" "\\subset" t "⊂" "[subset of]" "[subset of]" "⊂") + ("sup" "\\supset" t "⊃" "[superset of]" "[superset of]" "⊃") + ("supset" "\\supset" t "⊃" "[superset of]" "[superset of]" "⊃") + ("nsub" "\\not\\subset" t "⊄" "[not a subset of]" "[not a subset of" "⊄") + ("sube" "\\subseteq" t "⊆" "[subset of or equal to]" "[subset of or equal to]" "⊆") + ("nsup" "\\not\\supset" t "⊅" "[not a superset of]" "[not a superset of]" "⊅") + ("supe" "\\supseteq" t "⊇" "[superset of or equal to]" "[superset of or equal to]" "⊇") + ("forall" "\\forall" t "∀" "[for all]" "[for all]" "∀") + ("exist" "\\exists" t "∃" "[there exists]" "[there exists]" "∃") + ("exists" "\\exists" t "∃" "[there exists]" "[there exists]" "∃") + ("empty" "\\empty" t "∅" "[empty set]" "[empty set]" "∅") + ("emptyset" "\\emptyset" t "∅" "[empty set]" "[empty set]" "∅") + ("isin" "\\in" t "∈" "[element of]" "[element of]" "∈") + ("in" "\\in" t "∈" "[element of]" "[element of]" "∈") + ("notin" "\\notin" t "∉" "[not an element of]" "[not an element of]" "∉") + ("ni" "\\ni" t "∋" "[contains as member]" "[contains as member]" "∋") + ("nabla" "\\nabla" t "∇" "[nabla]" "[nabla]" "∇") + ("ang" "\\angle" t "∠" "[angle]" "[angle]" "∠") + ("angle" "\\angle" t "∠" "[angle]" "[angle]" "∠") + ("perp" "\\perp" t "⊥" "[up tack]" "[up tack]" "⊥") + ("sdot" "\\cdot" t "⋅" "[dot]" "[dot]" "â‹…") + ("cdot" "\\cdot" t "⋅" "[dot]" "[dot]" "â‹…") + ("lceil" "\\lceil" t "⌈" "[left ceiling]" "[left ceiling]" "⌈") + ("rceil" "\\rceil" t "⌉" "[right ceiling]" "[right ceiling]" "⌉") + ("lfloor" "\\lfloor" t "⌊" "[left floor]" "[left floor]" "⌊") + ("rfloor" "\\rfloor" t "⌋" "[right floor]" "[right floor]" "⌋") + ("lang" "\\langle" t "⟨" "<" "<" "⟨") + ("rang" "\\rangle" t "⟩" ">" ">" "⟩") + + "** Arrows" + ("larr" "\\leftarrow" t "←" "<-" "<-" "â†") + ("leftarrow" "\\leftarrow" t "←" "<-" "<-" "â†") + ("gets" "\\gets" t "←" "<-" "<-" "â†") + ("lArr" "\\Leftarrow" t "⇐" "<=" "<=" "â‡") + ("Leftarrow" "\\Leftarrow" t "⇐" "<=" "<=" "â‡") + ("uarr" "\\uparrow" t "↑" "[uparrow]" "[uparrow]" "↑") + ("uparrow" "\\uparrow" t "↑" "[uparrow]" "[uparrow]" "↑") + ("uArr" "\\Uparrow" t "⇑" "[dbluparrow]" "[dbluparrow]" "⇑") + ("Uparrow" "\\Uparrow" t "⇑" "[dbluparrow]" "[dbluparrow]" "⇑") + ("rarr" "\\rightarrow" t "→" "->" "->" "→") + ("to" "\\to" t "→" "->" "->" "→") + ("rightarrow" "\\rightarrow" t "→" "->" "->" "→") + ("rArr" "\\Rightarrow" t "⇒" "=>" "=>" "⇒") + ("Rightarrow" "\\Rightarrow" t "⇒" "=>" "=>" "⇒") + ("darr" "\\downarrow" t "↓" "[downarrow]" "[downarrow]" "↓") + ("downarrow" "\\downarrow" t "↓" "[downarrow]" "[downarrow]" "↓") + ("dArr" "\\Downarrow" t "⇓" "[dbldownarrow]" "[dbldownarrow]" "⇓") + ("Downarrow" "\\Downarrow" t "⇓" "[dbldownarrow]" "[dbldownarrow]" "⇓") + ("harr" "\\leftrightarrow" t "↔" "<->" "<->" "↔") + ("leftrightarrow" "\\leftrightarrow" t "↔" "<->" "<->" "↔") + ("hArr" "\\Leftrightarrow" t "⇔" "<=>" "<=>" "⇔") + ("Leftrightarrow" "\\Leftrightarrow" t "⇔" "<=>" "<=>" "⇔") + ("crarr" "\\hookleftarrow" t "↵" "<-'" "<-'" "↵") + ("hookleftarrow" "\\hookleftarrow" t "↵" "<-'" "<-'" "↵") + + "** Function names" + ("arccos" "\\arccos" t "arccos" "arccos" "arccos" "arccos") + ("arcsin" "\\arcsin" t "arcsin" "arcsin" "arcsin" "arcsin") + ("arctan" "\\arctan" t "arctan" "arctan" "arctan" "arctan") + ("arg" "\\arg" t "arg" "arg" "arg" "arg") + ("cos" "\\cos" t "cos" "cos" "cos" "cos") + ("cosh" "\\cosh" t "cosh" "cosh" "cosh" "cosh") + ("cot" "\\cot" t "cot" "cot" "cot" "cot") + ("coth" "\\coth" t "coth" "coth" "coth" "coth") + ("csc" "\\csc" t "csc" "csc" "csc" "csc") + ("deg" "\\deg" t "°" "deg" "deg" "deg") + ("det" "\\det" t "det" "det" "det" "det") + ("dim" "\\dim" t "dim" "dim" "dim" "dim") + ("exp" "\\exp" t "exp" "exp" "exp" "exp") + ("gcd" "\\gcd" t "gcd" "gcd" "gcd" "gcd") + ("hom" "\\hom" t "hom" "hom" "hom" "hom") + ("inf" "\\inf" t "inf" "inf" "inf" "inf") + ("ker" "\\ker" t "ker" "ker" "ker" "ker") + ("lg" "\\lg" t "lg" "lg" "lg" "lg") + ("lim" "\\lim" t "lim" "lim" "lim" "lim") + ("liminf" "\\liminf" t "liminf" "liminf" "liminf" "liminf") + ("limsup" "\\limsup" t "limsup" "limsup" "limsup" "limsup") + ("ln" "\\ln" t "ln" "ln" "ln" "ln") + ("log" "\\log" t "log" "log" "log" "log") + ("max" "\\max" t "max" "max" "max" "max") + ("min" "\\min" t "min" "min" "min" "min") + ("Pr" "\\Pr" t "Pr" "Pr" "Pr" "Pr") + ("sec" "\\sec" t "sec" "sec" "sec" "sec") + ("sin" "\\sin" t "sin" "sin" "sin" "sin") + ("sinh" "\\sinh" t "sinh" "sinh" "sinh" "sinh") + ("sup" "\\sup" t "⊃" "sup" "sup" "sup") + ("tan" "\\tan" t "tan" "tan" "tan" "tan") + ("tanh" "\\tanh" t "tanh" "tanh" "tanh" "tanh") + + "** Signs & Symbols" + ("bull" "\\textbullet{}" nil "•" "*" "*" "•") + ("bullet" "\\textbullet{}" nil "•" "*" "*" "•") + ("star" "\\star" t "*" "*" "*" "⋆") + ("lowast" "\\ast" t "∗" "*" "*" "∗") + ("ast" "\\ast" t "∗" "*" "*" "*") + ("odot" "\\odot" t "o" "[circled dot]" "[circled dot]" "ʘ") + ("oplus" "\\oplus" t "⊕" "[circled plus]" "[circled plus]" "⊕") + ("otimes" "\\otimes" t "⊗" "[circled times]" "[circled times]" "⊗") + ("checkmark" "\\checkmark" t "✓" "[checkmark]" "[checkmark]" "✓") + + "** Miscellaneous (seldom used)" + ("para" "\\P{}" nil "¶" "[pilcrow]" "¶" "¶") + ("ordf" "\\textordfeminine{}" nil "ª" "_a_" "ª" "ª") + ("ordm" "\\textordmasculine{}" nil "º" "_o_" "º" "º") + ("cedil" "\\c{}" nil "¸" "[cedilla]" "¸" "¸") + ("oline" "\\overline{~}" t "‾" "[overline]" "¯" "‾") + ("uml" "\\textasciidieresis{}" nil "¨" "[diaeresis]" "¨" "¨") + ("zwnj" "\\/{}" nil "‌" "" "" "‌") + ("zwj" "" nil "‍" "" "" "â€") + ("lrm" "" nil "‎" "" "" "‎") + ("rlm" "" nil "‏" "" "" "â€") + + "** Smilies" + ("smile" "\\smile" t "☺" ":-)" ":-)" "⌣") + ("smiley" "\\smiley{}" nil "☺" ":-)" ":-)" "☺") + ("blacksmile" "\\blacksmiley{}" nil "☻" ":-)" ":-)" "☻") + ("sad" "\\frownie{}" nil "☹" ":-(" ":-(" "☹") + + "** Suits" + ("clubs" "\\clubsuit" t "♣" "[clubs]" "[clubs]" "♣") + ("clubsuit" "\\clubsuit" t "♣" "[clubs]" "[clubs]" "♣") + ("spades" "\\spadesuit" t "♠" "[spades]" "[spades]" "â™ ") + ("spadesuit" "\\spadesuit" t "♠" "[spades]" "[spades]" "â™ ") + ("hearts" "\\heartsuit" t "♥" "[hearts]" "[hearts]" "♥") + ("heartsuit" "\\heartsuit" t "♥" "[hearts]" "[hearts]" "♥") + ("diams" "\\diamondsuit" t "♦" "[diamonds]" "[diamonds]" "♦") + ("diamondsuit" "\\diamondsuit" t "♦" "[diamonds]" "[diamonds]" "♦") + ("Diamond" "\\diamond" t "⋄" "[diamond]" "[diamond]" "â‹„") + ("loz" "\\diamond" t "◊" "[lozenge]" "[lozenge]" "â—Š") + ) + "Default entities used in Org-mode to produce special characters. +For details see `org-entities-user'.") + +(defsubst org-entity-get (name) + "Get the proper association for NAME from the entity lists. +This first checks the user list, then the built-in list." + (or (assoc name org-entities-user) + (assoc name org-entities))) + +(defun org-entity-get-representation (name kind) + "Get the correct representation of entity NAME for export type KIND. +Kind can be any of `latex', `html', `ascii', `latin1', or `utf8'." + (let* ((e (org-entity-get name)) + (n (cdr (assq kind '((latex . 1) (html . 3) (ascii . 4) + (latin1 . 5) (utf8 . 6))))) + (r (and e n (nth n e)))) + (if (and e r + (not org-entities-ascii-explanatory) + (memq kind '(ascii latin1 utf8)) + (= (string-to-char r) ?\[)) + (concat "\\" name) + r))) + +(defsubst org-entity-latex-math-p (name) + "Does entity NAME require math mode in LaTeX?" + (nth 2 (org-entity-get name))) + +;; Helpfunctions to create a table for orgmode.org/worg/org-symbols.org + +(defun org-entities-create-table () + "Create an org-mode table with all entities." + (interactive) + (let ((ll org-entities) + (pos (point)) + e latex mathp html latin utf8 name ascii) + (insert "|Name|LaTeX code|LaTeX|HTML code |HTML|ASCII|Latin1|UTF-8\n|-\n") + (while ll + (when (listp e) + (setq e (pop ll)) + (setq name (car e) + latex (nth 1 e) + mathp (nth 2 e) + html (nth 3 e) + ascii (nth 4 e) + latin (nth 5 e) + utf8 (nth 6 e)) + (if (equal ascii "|") (setq ascii "\\vert")) + (if (equal latin "|") (setq latin "\\vert")) + (if (equal utf8 "|") (setq utf8 "\\vert")) + (if (equal ascii "=>") (setq ascii "= >")) + (if (equal latin "=>") (setq latin "= >")) + (insert "|" name + "|" (format "=%s=" latex) + "|" (format (if mathp "$%s$" "$\\mbox{%s}$") + latex) + "|" (format "=%s=" html) "|" html + "|" ascii "|" latin "|" utf8 + "|\n"))) + (goto-char pos) + (org-table-align))) + +(defun org-entities-help () + "Create a Help buffer with all available entities." + (interactive) + (with-output-to-temp-buffer "*Org Entity Help*" + (princ "Org-mode entities\n=================\n\n") + (let ((ll (append '("* User-defined additions (variable org-entities-user)") + org-entities-user + org-entities)) + e latex mathp html latin utf8 name ascii + (lastwasstring t) + (head (concat + "\n" + " Symbol Org entity LaTeX code HTML code\n" + " -----------------------------------------------------------\n"))) + (while ll + (setq e (pop ll)) + (if (stringp e) + (progn + (princ e) + (princ "\n") + (setq lastwasstring t)) + (if lastwasstring (princ head)) + (setq lastwasstring nil) + (setq name (car e) + latex (nth 1 e) + html (nth 3 e) + utf8 (nth 6 e)) + (princ (format " %-8s \\%-16s %-22s %-13s\n" + utf8 name latex html)))))) + (with-current-buffer "*Org Entity Help*" + (org-mode)) + (select-window (get-buffer-window "*Org Entity Help*"))) + + +(defun replace-amp () + "Postprocess HTML file to unescape the ampersand." + (interactive) + (while (re-search-forward "<td>&\\([^<;]+;\\)" nil t) + (replace-match (concat "<td>&" (match-string 1)) t t))) + +(provide 'org-entities) + +;; Local variables: +;; coding: utf-8 +;; End: + +;; arch-tag: e6bd163f-7419-4009-9c93-a74623016424 + +;;; org-entities.el ends here diff --git a/.emacs.d/org-7.4/lisp/org-entities.elc b/.emacs.d/org-7.4/lisp/org-entities.elc Binary files differnew file mode 100644 index 0000000..cfd0609 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-entities.elc diff --git a/.emacs.d/org-7.4/lisp/org-exp-blocks.el b/.emacs.d/org-7.4/lisp/org-exp-blocks.el new file mode 100644 index 0000000..57087e1 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-exp-blocks.el @@ -0,0 +1,356 @@ +;;; org-exp-blocks.el --- pre-process blocks when exporting org files + +;; Copyright (C) 2009, 2010 +;; Free Software Foundation, Inc. + +;; Author: Eric Schulte +;; Version: 7.4 + +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; This is a utility for pre-processing blocks in org files before +;; export using the `org-export-preprocess-hook'. It can be used for +;; exporting new types of blocks from org-mode files and also for +;; changing the default export behavior of existing org-mode blocks. +;; The `org-export-blocks' and `org-export-interblocks' variables can +;; be used to control how blocks and the spaces between blocks +;; respectively are processed upon export. +;; +;; The type of a block is defined as the string following =#+begin_=, +;; so for example the following block would be of type ditaa. Note +;; that both upper or lower case are allowed in =#+BEGIN_= and +;; =#+END_=. +;; +;; #+begin_ditaa blue.png -r -S +;; +---------+ +;; | cBLU | +;; | | +;; | +----+ +;; | |cPNK| +;; | | | +;; +----+----+ +;; #+end_ditaa +;; +;;; Currently Implemented Block Types +;; +;; ditaa :: Convert ascii pictures to actual images using ditaa +;; http://ditaa.sourceforge.net/. To use this set +;; `org-ditaa-jar-path' to the path to ditaa.jar on your +;; system (should be set automatically in most cases) . +;; +;; dot :: Convert graphs defined using the dot graphing language to +;; images using the dot utility. For information on dot see +;; http://www.graphviz.org/ +;; +;; comment :: Wrap comments with titles and author information, in +;; their own divs with author-specific ids allowing for css +;; coloring of comments based on the author. +;; +;;; Adding new blocks +;; +;; When adding a new block type first define a formatting function +;; along the same lines as `org-export-blocks-format-dot' and then use +;; `org-export-blocks-add-block' to add your block type to +;; `org-export-blocks'. + +;;; Code: + +(eval-when-compile + (require 'cl)) +(require 'org) + +(defvar htmlp) +(defvar latexp) +(defvar docbookp) +(defvar asciip) + +(defun org-export-blocks-set (var value) + "Set the value of `org-export-blocks' and install fontification." + (set var value) + (mapc (lambda (spec) + (if (nth 2 spec) + (setq org-protecting-blocks + (delete (symbol-name (car spec)) + org-protecting-blocks)) + (add-to-list 'org-protecting-blocks + (symbol-name (car spec))))) + value)) + +(defcustom org-export-blocks + '((comment org-export-blocks-format-comment t) + (ditaa org-export-blocks-format-ditaa nil) + (dot org-export-blocks-format-dot nil)) + "Use this alist to associate block types with block exporting functions. +The type of a block is determined by the text immediately +following the '#+BEGIN_' portion of the block header. Each block +export function should accept three arguments." + :group 'org-export-general + :type '(repeat + (list + (symbol :tag "Block name") + (function :tag "Block formatter") + (boolean :tag "Fontify content as Org syntax"))) + :set 'org-export-blocks-set) + +(defun org-export-blocks-add-block (block-spec) + "Add a new block type to `org-export-blocks'. +BLOCK-SPEC should be a three element list the first element of +which should indicate the name of the block, the second element +should be the formatting function called by +`org-export-blocks-preprocess' and the third element a flag +indicating whether these types of blocks should be fontified in +org-mode buffers (see `org-protecting-blocks'). For example the +BLOCK-SPEC for ditaa blocks is as follows. + + (ditaa org-export-blocks-format-ditaa nil)" + (unless (member block-spec org-export-blocks) + (setq org-export-blocks (cons block-spec org-export-blocks)) + (org-export-blocks-set 'org-export-blocks org-export-blocks))) + +(defcustom org-export-interblocks + '() + "Use this a-list to associate block types with block exporting functions. +The type of a block is determined by the text immediately +following the '#+BEGIN_' portion of the block header. Each block +export function should accept three arguments." + :group 'org-export-general + :type 'alist) + +(defcustom org-export-blocks-witheld + '(hidden) + "List of block types (see `org-export-blocks') which should not be exported." + :group 'org-export-general + :type 'list) + +(defcustom org-export-blocks-postblock-hook nil + "Run after blocks have been processed with `org-export-blocks-preprocess'." + :group 'org-export-general + :type 'hook) + +(defun org-export-blocks-html-quote (body &optional open close) + "Protect BODY from org html export. +The optional OPEN and CLOSE tags will be inserted around BODY." + + (concat + "\n#+BEGIN_HTML\n" + (or open "") + body (if (string-match "\n$" body) "" "\n") + (or close "") + "#+END_HTML\n")) + +(defun org-export-blocks-latex-quote (body &optional open close) + "Protect BODY from org latex export. +The optional OPEN and CLOSE tags will be inserted around BODY." + (concat + "\n#+BEGIN_LaTeX\n" + (or open "") + body (if (string-match "\n$" body) "" "\n") + (or close "") + "#+END_LaTeX\n")) + +(defun org-export-blocks-preprocess () + "Export all blocks according to the `org-export-blocks' block export alist. +Does not export block types specified in specified in BLOCKS +which defaults to the value of `org-export-blocks-witheld'." + (interactive) + (save-window-excursion + (let ((case-fold-search t) + (types '()) + indentation type func start body headers preserve-indent progress-marker) + (flet ((interblock (start end) + (mapcar (lambda (pair) (funcall (second pair) start end)) + org-export-interblocks))) + (goto-char (point-min)) + (setq start (point)) + (while (re-search-forward + "^\\([ \t]*\\)#\\+begin_\\(\\S-+\\)[ \t]*\\(.*\\)?[\r\n]\\([^\000]*?\\)[\r\n][ \t]*#\\+end_\\S-+.*[\r\n]?" nil t) + (setq indentation (length (match-string 1))) + (setq type (intern (downcase (match-string 2)))) + (setq headers (save-match-data (org-split-string (match-string 3) "[ \t]+"))) + (setq body (match-string 4)) + (setq preserve-indent (or org-src-preserve-indentation (member "-i" headers))) + (unless preserve-indent + (setq body (save-match-data (org-remove-indentation body)))) + (unless (memq type types) (setq types (cons type types))) + (save-match-data (interblock start (match-beginning 0))) + (when (setq func (cadr (assoc type org-export-blocks))) + (let ((replacement (save-match-data + (if (memq type org-export-blocks-witheld) "" + (apply func body headers))))) + (when replacement + (replace-match replacement t t) + (unless preserve-indent + (indent-code-rigidly + (match-beginning 0) (match-end 0) indentation))))) + (setq start (match-end 0))) + (interblock start (point-max)) + (run-hooks 'org-export-blocks-postblock-hook))))) + +;;================================================================================ +;; type specific functions + +;;-------------------------------------------------------------------------------- +;; ditaa: create images from ASCII art using the ditaa utility +(defvar org-ditaa-jar-path (expand-file-name + "ditaa.jar" + (file-name-as-directory + (expand-file-name + "scripts" + (file-name-as-directory + (expand-file-name + "../contrib" + (file-name-directory (or load-file-name buffer-file-name))))))) + "Path to the ditaa jar executable.") + +(defun org-export-blocks-format-ditaa (body &rest headers) + "Pass block BODY to the ditaa utility creating an image. +Specify the path at which the image should be saved as the first +element of headers, any additional elements of headers will be +passed to the ditaa utility as command line arguments." + (message "ditaa-formatting...") + (let* ((args (if (cdr headers) (mapconcat 'identity (cdr headers) " "))) + (data-file (make-temp-file "org-ditaa")) + (hash (progn + (set-text-properties 0 (length body) nil body) + (sha1 (prin1-to-string (list body args))))) + (raw-out-file (if headers (car headers))) + (out-file-parts (if (string-match "\\(.+\\)\\.\\([^\\.]+\\)$" raw-out-file) + (cons (match-string 1 raw-out-file) + (match-string 2 raw-out-file)) + (cons raw-out-file "png"))) + (out-file (concat (car out-file-parts) "_" hash "." (cdr out-file-parts)))) + (unless (file-exists-p org-ditaa-jar-path) + (error (format "Could not find ditaa.jar at %s" org-ditaa-jar-path))) + (setq body (if (string-match "^\\([^:\\|:[^ ]\\)" body) + body + (mapconcat (lambda (x) (substring x (if (> (length x) 1) 2 1))) + (org-split-string body "\n") + "\n"))) + (cond + ((or htmlp latexp docbookp) + (unless (file-exists-p out-file) + (mapc ;; remove old hashed versions of this file + (lambda (file) + (when (and (string-match (concat (regexp-quote (car out-file-parts)) + "_\\([[:alnum:]]+\\)\\." + (regexp-quote (cdr out-file-parts))) + file) + (= (length (match-string 1 out-file)) 40)) + (delete-file (expand-file-name file + (file-name-directory out-file))))) + (directory-files (or (file-name-directory out-file) + default-directory))) + (with-temp-file data-file (insert body)) + (message (concat "java -jar " org-ditaa-jar-path " " args " " data-file " " out-file)) + (shell-command (concat "java -jar " org-ditaa-jar-path " " args " " data-file " " out-file))) + (format "\n[[file:%s]]\n" out-file)) + (t (concat + "\n#+BEGIN_EXAMPLE\n" + body (if (string-match "\n$" body) "" "\n") + "#+END_EXAMPLE\n"))))) + +;;-------------------------------------------------------------------------------- +;; dot: create graphs using the dot graphing language +;; (require the dot executable to be in your path) +(defun org-export-blocks-format-dot (body &rest headers) + "Pass block BODY to the dot graphing utility creating an image. +Specify the path at which the image should be saved as the first +element of headers, any additional elements of headers will be +passed to the dot utility as command line arguments. Don't +forget to specify the output type for the dot command, so if you +are exporting to a file with a name like 'image.png' you should +include a '-Tpng' argument, and your block should look like the +following. + +#+begin_dot models.png -Tpng +digraph data_relationships { + \"data_requirement\" [shape=Mrecord, label=\"{DataRequirement|description\lformat\l}\"] + \"data_product\" [shape=Mrecord, label=\"{DataProduct|name\lversion\lpoc\lformat\l}\"] + \"data_requirement\" -> \"data_product\" +} +#+end_dot" + (message "dot-formatting...") + (let* ((args (if (cdr headers) (mapconcat 'identity (cdr headers) " "))) + (data-file (make-temp-file "org-ditaa")) + (hash (progn + (set-text-properties 0 (length body) nil body) + (sha1 (prin1-to-string (list body args))))) + (raw-out-file (if headers (car headers))) + (out-file-parts (if (string-match "\\(.+\\)\\.\\([^\\.]+\\)$" raw-out-file) + (cons (match-string 1 raw-out-file) + (match-string 2 raw-out-file)) + (cons raw-out-file "png"))) + (out-file (concat (car out-file-parts) "_" hash "." (cdr out-file-parts)))) + (cond + ((or htmlp latexp docbookp) + (unless (file-exists-p out-file) + (mapc ;; remove old hashed versions of this file + (lambda (file) + (when (and (string-match (concat (regexp-quote (car out-file-parts)) + "_\\([[:alnum:]]+\\)\\." + (regexp-quote (cdr out-file-parts))) + file) + (= (length (match-string 1 out-file)) 40)) + (delete-file (expand-file-name file + (file-name-directory out-file))))) + (directory-files (or (file-name-directory out-file) + default-directory))) + (with-temp-file data-file (insert body)) + (message (concat "dot " data-file " " args " -o " out-file)) + (shell-command (concat "dot " data-file " " args " -o " out-file))) + (format "\n[[file:%s]]\n" out-file)) + (t (concat + "\n#+BEGIN_EXAMPLE\n" + body (if (string-match "\n$" body) "" "\n") + "#+END_EXAMPLE\n"))))) + +;;-------------------------------------------------------------------------------- +;; comment: export comments in author-specific css-stylable divs +(defun org-export-blocks-format-comment (body &rest headers) + "Format comment BODY by OWNER and return it formatted for export. +Currently, this only does something for HTML export, for all +other backends, it converts the comment into an EXAMPLE segment." + (let ((owner (if headers (car headers))) + (title (if (cdr headers) (mapconcat 'identity (cdr headers) " ")))) + (cond + (htmlp ;; We are exporting to HTML + (concat "#+BEGIN_HTML\n" + "<div class=\"org-comment\"" + (if owner (format " id=\"org-comment-%s\" " owner)) + ">\n" + (if owner (concat "<b>" owner "</b> ") "") + (if (and title (> (length title) 0)) (concat " -- " title "</br>\n") "</br>\n") + "<p>\n" + "#+END_HTML\n" + body + "#+BEGIN_HTML\n" + "</p>\n" + "</div>\n" + "#+END_HTML\n")) + (t ;; This is not HTML, so just make it an example. + (concat "#+BEGIN_EXAMPLE\n" + (if title (concat "Title:" title "\n") "") + (if owner (concat "By:" owner "\n") "") + body + (if (string-match "\n\\'" body) "" "\n") + "#+END_EXAMPLE\n"))))) + +(provide 'org-exp-blocks) + +;; arch-tag: 1c365fe9-8808-4f72-bb15-0b00f36d8024 +;;; org-exp-blocks.el ends here diff --git a/.emacs.d/org-7.4/lisp/org-exp-blocks.elc b/.emacs.d/org-7.4/lisp/org-exp-blocks.elc Binary files differnew file mode 100644 index 0000000..52d982e --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-exp-blocks.elc diff --git a/.emacs.d/org-7.4/lisp/org-exp.el b/.emacs.d/org-7.4/lisp/org-exp.el new file mode 100644 index 0000000..d45ef9c --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-exp.el @@ -0,0 +1,2968 @@ +;;; org-exp.el --- ASCII, HTML, XOXO and iCalendar export for Org-mode + +;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010 +;; Free Software Foundation, Inc. + +;; Author: Carsten Dominik <carsten at orgmode dot org> +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; Version: 7.4 +;; +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: + +;;; Code: + +(require 'org) +(require 'org-macs) +(require 'org-agenda) +(require 'org-exp-blocks) +(require 'ob-exp) +(require 'org-src) + +(eval-when-compile + (require 'cl)) + +(declare-function org-export-latex-preprocess "org-latex" (parameters)) +(declare-function org-export-ascii-preprocess "org-ascii" (parameters)) +(declare-function org-export-html-preprocess "org-html" (parameters)) +(declare-function org-export-docbook-preprocess "org-docbook" (parameters)) +(declare-function org-infojs-options-inbuffer-template "org-jsinfo" ()) +(declare-function org-export-htmlize-region-for-paste "org-html" (beg end)) +(declare-function htmlize-buffer "ext:htmlize" (&optional buffer)) +(declare-function org-inlinetask-remove-END-maybe "org-inlinetask" ()) +(declare-function org-table-cookie-line-p "org-table" (line)) +(declare-function org-table-colgroup-line-p "org-table" (line)) +(autoload 'org-export-generic "org-export-generic" "Export using the generic exporter" t) +(defgroup org-export nil + "Options for exporting org-listings." + :tag "Org Export" + :group 'org) + +(defgroup org-export-general nil + "General options for exporting Org-mode files." + :tag "Org Export General" + :group 'org-export) + +(defcustom org-export-allow-BIND 'confirm + "Non-nil means allow #+BIND to define local variable values for export. +This is a potential security risk, which is why the user must confirm the +use of these lines." + :group 'org-export-general + :type '(choice + (const :tag "Never" nil) + (const :tag "Always" t) + (const :tag "Make the user confirm for each file" confirm))) + +;; FIXME +(defvar org-export-publishing-directory nil) + +(defcustom org-export-show-temporary-export-buffer t + "Non-nil means show buffer after exporting to temp buffer. +When Org exports to a file, the buffer visiting that file is ever +shown, but remains buried. However, when exporting to a temporary +buffer, that buffer is popped up in a second window. When this variable +is nil, the buffer remains buried also in these cases." + :group 'org-export-general + :type 'boolean) + +(defcustom org-export-copy-to-kill-ring t + "Non-nil means exported stuff will also be pushed onto the kill ring." + :group 'org-export-general + :type 'boolean) + +(defcustom org-export-kill-product-buffer-when-displayed nil + "Non-nil means kill the product buffer if it is displayed immediately. +This applied to the commands `org-export-html-and-open' and +`org-export-as-pdf-and-open'." + :group 'org-export-general + :type 'boolean) + +(defcustom org-export-run-in-background nil + "Non-nil means export and publishing commands will run in background. +This works by starting up a separate Emacs process visiting the same file +and doing the export from there. +Not all export commands are affected by this - only the ones which +actually write to a file, and that do not depend on the buffer state. +\\<org-mode-map> +If this option is nil, you can still get background export by calling +`org-export' with a double prefix arg: \ +\\[universal-argument] \\[universal-argument] \\[org-export]. + +If this option is t, the double prefix can be used to exceptionally +force an export command into the current process." + :group 'org-export-general + :type 'boolean) + +(defcustom org-export-select-tags '("export") + "Tags that select a tree for export. +If any such tag is found in a buffer, all trees that do not carry one +of these tags will be deleted before export. +Inside trees that are selected like this, you can still deselect a +subtree by tagging it with one of the `org-export-exclude-tags'." + :group 'org-export-general + :type '(repeat (string :tag "Tag"))) + +(defcustom org-export-exclude-tags '("noexport") + "Tags that exclude a tree from export. +All trees carrying any of these tags will be excluded from export. +This is without condition, so even subtrees inside that carry one of the +`org-export-select-tags' will be removed." + :group 'org-export-general + :type '(repeat (string :tag "Tag"))) + +;; FIXME: rename, this is a general variable +(defcustom org-export-html-expand t + "Non-nil means for HTML export, treat @<...> as HTML tag. +When nil, these tags will be exported as plain text and therefore +not be interpreted by a browser. + +This option can also be set with the +OPTIONS line, e.g. \"@:nil\"." + :group 'org-export-html + :group 'org-export-general + :type 'boolean) + +(defcustom org-export-with-special-strings t + "Non-nil means interpret \"\-\", \"--\" and \"---\" for export. +When this option is turned on, these strings will be exported as: + + Org HTML LaTeX + -----+----------+-------- + \\- ­ \\- + -- – -- + --- — --- + ... … \ldots + +This option can also be set with the +OPTIONS line, e.g. \"-:nil\"." + :group 'org-export-translation + :type 'boolean) + +(defcustom org-export-html-link-up "" + "Where should the \"UP\" link of exported HTML pages lead?" + :group 'org-export-html + :group 'org-export-general + :type '(string :tag "File or URL")) + +(defcustom org-export-html-link-home "" + "Where should the \"HOME\" link of exported HTML pages lead?" + :group 'org-export-html + :group 'org-export-general + :type '(string :tag "File or URL")) + +(defcustom org-export-language-setup + '(("en" "Author" "Date" "Table of Contents" "Footnotes") + ("ca" "Autor" "Data" "Índex" "Peus de pàgina") + ("cs" "Autor" "Datum" "Obsah" "Pozn\xe1mky pod carou") + ("da" "Ophavsmand" "Dato" "Indhold" "Fodnoter") + ("de" "Autor" "Datum" "Inhaltsverzeichnis" "Fußnoten") + ("eo" "Aŭtoro" "Dato" "Enhavo" "Piednotoj") + ("es" "Autor" "Fecha" "Índice" "Pies de página") + ("fi" "Tekijä" "Päivämäärä" "Sisällysluettelo" "Alaviitteet") + ("fr" "Auteur" "Date" "Table des matières" "Notes de bas de page") + ("hu" "Szerzõ" "Dátum" "Tartalomjegyzék" "Lábjegyzet") + ("is" "Höfundur" "Dagsetning" "Efnisyfirlit" "Aftanmálsgreinar") + ("it" "Autore" "Data" "Indice" "Note a piè di pagina") + ("nl" "Auteur" "Datum" "Inhoudsopgave" "Voetnoten") + ("no" "Forfatter" "Dato" "Innhold" "Fotnoter") + ("nb" "Forfatter" "Dato" "Innhold" "Fotnoter") ;; nb = Norsk (bokm.l) + ("nn" "Forfattar" "Dato" "Innhald" "Fotnotar") ;; nn = Norsk (nynorsk) + ("pl" "Autor" "Data" "Spis treści" "Przypis") + ("sv" "Författare" "Datum" "Innehåll" "Fotnoter")) + "Terms used in export text, translated to different languages. +Use the variable `org-export-default-language' to set the language, +or use the +OPTION lines for a per-file setting." + :group 'org-export-general + :type '(repeat + (list + (string :tag "HTML language tag") + (string :tag "Author") + (string :tag "Date") + (string :tag "Table of Contents") + (string :tag "Footnotes")))) + +(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'." + :group 'org-export-general + :type 'string) + +(defvar org-export-page-description "" + "The page description, for the XHTML meta tag. +This is best set with the #+DESCRIPTION line in a file, it does not make +sense to set this globally.") + +(defvar org-export-page-keywords "" + "The page description, for the XHTML meta tag. +This is best set with the #+KEYWORDS line in a file, it does not make +sense to set this globally.") + +(defcustom org-export-skip-text-before-1st-heading nil + "Non-nil means skip all text before the first headline when exporting. +When nil, that text is exported as well." + :group 'org-export-general + :type 'boolean) + +(defcustom org-export-headline-levels 3 + "The last level which is still exported as a headline. +Inferior levels will produce itemize lists when exported. +Note that a numeric prefix argument to an exporter function overrides +this setting. + +This option can also be set with the +OPTIONS line, e.g. \"H:2\"." + :group 'org-export-general + :type 'integer) + +(defcustom org-export-with-section-numbers t + "Non-nil means add section numbers to headlines when exporting. + +This option can also be set with the +OPTIONS line, e.g. \"num:t\"." + :group 'org-export-general + :type 'boolean) + +(defcustom org-export-section-number-format '((("1" ".")) . "") + "Format of section numbers for export. +The variable has two components. +1. A list of lists, each indicating a counter type and a separator. + The counter type can be any of \"1\", \"A\", \"a\", \"I\", or \"i\". + It causes causes numeric, alphabetic, or roman counters, respectively. + The separator is only used if another counter for a subsection is being + added. + If there are more numbered section levels than entries in this lists, + then the last entry will be reused. +2. A terminator string that will be added after the entire + section number." + :group 'org-export-general + :type '(cons + (repeat + (list + (string :tag "Counter Type") + (string :tag "Separator "))) + (string :tag "Terminator"))) + +(defcustom org-export-with-toc t + "Non-nil means create a table of contents in exported files. +The TOC contains headlines with levels up to`org-export-headline-levels'. +When an integer, include levels up to N in the toc, this may then be +different from `org-export-headline-levels', but it will not be allowed +to be larger than the number of headline levels. +When nil, no table of contents is made. + +Headlines which contain any TODO items will be marked with \"(*)\" in +ASCII export, and with red color in HTML output, if the option +`org-export-mark-todo-in-toc' is set. + +In HTML output, the TOC will be clickable. + +This option can also be set with the +OPTIONS line, e.g. \"toc:nil\" +or \"toc:3\"." + :group 'org-export-general + :type '(choice + (const :tag "No Table of Contents" nil) + (const :tag "Full Table of Contents" t) + (integer :tag "TOC to level"))) + +(defcustom org-export-mark-todo-in-toc nil + "Non-nil means mark TOC lines that contain any open TODO items." + :group 'org-export-general + :type 'boolean) + +(defcustom org-export-with-todo-keywords t + "Non-nil means include TODO keywords in export. +When nil, remove all these keywords from the export." + :group 'org-export-general + :type 'boolean) + +(defcustom org-export-with-priority nil + "Non-nil means include priority cookies in export. +When nil, remove priority cookies for export." + :group 'org-export-general + :type 'boolean) + +(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 +export, line breaks will always be preserved, regardless of this variable. + +This option can also be set with the +OPTIONS line, e.g. \"\\n:t\"." + :group 'org-export-general + :type 'boolean) + +(defcustom org-export-with-archived-trees 'headline + "Whether subtrees with the ARCHIVE tag should be exported. +This can have three different values +nil Do not export, pretend this tree is not present +t Do export the entire tree +headline Only export the headline, but skip the tree below it." + :group 'org-export-general + :group 'org-archive + :type '(choice + (const :tag "not at all" nil) + (const :tag "headline only" 'headline) + (const :tag "entirely" t))) + +(defcustom org-export-author-info t + "Non-nil means insert author name and email into the exported file. + +This option can also be set with the +OPTIONS line, +e.g. \"author:nil\"." + :group 'org-export-general + :type 'boolean) + +(defcustom org-export-email-info nil + "Non-nil means insert author name and email into the exported file. + +This option can also be set with the +OPTIONS line, +e.g. \"email:t\"." + :group 'org-export-general + :type 'boolean) + +(defcustom org-export-creator-info t + "Non-nil means the postamble should contain a creator sentence. +This sentence is \"HTML generated by org-mode XX in emacs XXX\"." + :group 'org-export-general + :type 'boolean) + +(defcustom org-export-time-stamp-file t + "Non-nil means insert a time stamp into the exported file. +The time stamp shows when the file was created. + +This option can also be set with the +OPTIONS line, +e.g. \"timestamp:nil\"." + :group 'org-export-general + :type 'boolean) + +(defcustom org-export-with-timestamps t + "If nil, do not export time stamps and associated keywords." + :group 'org-export-general + :type 'boolean) + +(defcustom org-export-remove-timestamps-from-toc t + "If t, remove timestamps from the table of contents entries." + :group 'org-export-general + :type 'boolean) + +(defcustom org-export-with-tags 'not-in-toc + "If nil, do not export tags, just remove them from headlines. +If this is the symbol `not-in-toc', tags will be removed from table of +contents entries, but still be shown in the headlines of the document. + +This option can also be set with the +OPTIONS line, e.g. \"tags:nil\"." + :group 'org-export-general + :type '(choice + (const :tag "Off" nil) + (const :tag "Not in TOC" not-in-toc) + (const :tag "On" t))) + +(defcustom org-export-with-drawers nil + "Non-nil means export with drawers like the property drawer. +When t, all drawers are exported. This may also be a list of +drawer names to export." + :group 'org-export-general + :type '(choice + (const :tag "All drawers" t) + (const :tag "None" nil) + (repeat :tag "Selected drawers" + (string :tag "Drawer name")))) + +(defvar org-export-first-hook nil + "Hook called as the first thing in each exporter. +Point will be still in the original buffer. +Good for general initialization") + +(defvar org-export-preprocess-hook nil + "Hook for preprocessing an export buffer. +Pretty much the first thing when exporting is running this hook. +Point will be in a temporary buffer that contains a copy of +the original buffer, or of the section that is being export. +All the other hooks in the org-export-preprocess... category +also work in that temporary buffer, already modified by various +stages of the processing.") + +(defvar org-export-preprocess-after-include-files-hook nil + "Hook for preprocessing an export buffer. +This is run after the contents of included files have been inserted.") + +(defvar org-export-preprocess-after-tree-selection-hook nil + "Hook for preprocessing an export buffer. +This is run after selection of trees to be exported has happened. +This selection includes tags-based selection, as well as removal +of commented and archived trees.") + +(defvar org-export-preprocess-after-headline-targets-hook nil + "Hook for preprocessing export buffer. +This is run just after the headline targets have been defined and +the target-alist has been set up.") + +(defvar org-export-preprocess-before-selecting-backend-code-hook nil + "Hook for preprocessing an export buffer. +This is run just before backend-specific blocks get selected.") + +(defvar org-export-preprocess-after-blockquote-hook nil + "Hook for preprocessing an export buffer. +This is run after blockquote/quote/verse/center have been marked +with cookies.") + +(defvar org-export-preprocess-after-radio-targets-hook nil + "Hook for preprocessing an export buffer. +This is run after radio target processing.") + +(defvar org-export-preprocess-before-normalizing-links-hook nil + "Hook for preprocessing an export buffer. +This hook is run before links are normalized.") + +(defvar org-export-preprocess-before-backend-specifics-hook nil + "Hook run before backend-specific functions are called during preprocessing.") + +(defvar org-export-preprocess-final-hook nil + "Hook for preprocessing an export buffer. +This is run as the last thing in the preprocessing buffer, just before +returning the buffer string to the backend.") + +(defgroup org-export-translation nil + "Options for translating special ascii sequences for the export backends." + :tag "Org Export Translation" + :group 'org-export) + +(defcustom org-export-with-emphasize t + "Non-nil means interpret *word*, /word/, and _word_ as emphasized text. +If the export target supports emphasizing text, the word will be +typeset in bold, italic, or underlined, respectively. Works only for +single words, but you can say: I *really* *mean* *this*. +Not all export backends support this. + +This option can also be set with the +OPTIONS line, e.g. \"*:nil\"." + :group 'org-export-translation + :type 'boolean) + +(defcustom org-export-with-footnotes t + "If nil, export [1] as a footnote marker. +Lines starting with [1] will be formatted as footnotes. + +This option can also be set with the +OPTIONS line, e.g. \"f:nil\"." + :group 'org-export-translation + :type 'boolean) + +(defcustom org-export-with-TeX-macros t + "Non-nil means interpret simple TeX-like macros when exporting. +For example, HTML export converts \\alpha to α and \\AA to Å. +Not only real TeX macros will work here, but the standard HTML entities +for math can be used as macro names as well. For a list of supported +names in HTML export, see the constant `org-entities' and the user option +`org-entities-user'. +Not all export backends support this. + +This option can also be set with the +OPTIONS line, e.g. \"TeX:nil\"." + :group 'org-export-translation + :group 'org-export-latex + :type 'boolean) + +(defcustom org-export-with-LaTeX-fragments t + "Non-nil means process LaTeX math fragments for HTML display. +When set, the exporter will find and process LaTeX environments if the +\\begin line is the first non-white thing on a line. It will also find +and process the math delimiters like $a=b$ and \\( a=b \\) for inline math, +$$a=b$$ and \\[ a=b \\] for display math. + +This option can also be set with the +OPTIONS line, e.g. \"LaTeX:mathjax\". + +Allowed values are: + +nil Don't do anything. +verbatim Keep eveything in verbatim +dvipng Process the LaTeX fragments to images. + This will also include processing of non-math environments. +t Do MathJax preprocessing if there is at least on math snippet, + and arrange for MathJax.js to be loaded. + +The default is nil, because this option needs the `dvipng' program which +is not available on all systems." + :group 'org-export-translation + :group 'org-export-latex + :type '(choice + (const :tag "Do not process math in any way" nil) + (const :tag "Obsolete, use dvipng setting" t) + (const :tag "Use dvipng to make images" dvipng) + (const :tag "Use MathJax to display math" mathjax) + (const :tag "Leave math verbatim" verbatim))) + +(defcustom org-export-with-fixed-width t + "Non-nil means lines starting with \":\" will be in fixed width font. +This can be used to have pre-formatted text, fragments of code etc. For +example: + : ;; Some Lisp examples + : (while (defc cnt) + : (ding)) +will be looking just like this in also HTML. See also the QUOTE keyword. +Not all export backends support this. + +This option can also be set with the +OPTIONS line, e.g. \"::nil\"." + :group 'org-export-translation + :type 'boolean) + +(defgroup org-export-tables nil + "Options for exporting tables in Org-mode." + :tag "Org Export Tables" + :group 'org-export) + +(defcustom org-export-with-tables t + "If non-nil, lines starting with \"|\" define a table. +For example: + + | Name | Address | Birthday | + |-------------+----------+-----------| + | Arthur Dent | England | 29.2.2100 | + +Not all export backends support this. + +This option can also be set with the +OPTIONS line, e.g. \"|:nil\"." + :group 'org-export-tables + :type 'boolean) + +(defcustom org-export-highlight-first-table-line t + "Non-nil means highlight the first table line. +In HTML export, this means use <th> instead of <td>. +In tables created with table.el, this applies to the first table line. +In Org-mode tables, all lines before the first horizontal separator +line will be formatted with <th> tags." + :group 'org-export-tables + :type 'boolean) + +(defcustom org-export-table-remove-special-lines t + "Remove special lines and marking characters in calculating tables. +This removes the special marking character column from tables that are set +up for spreadsheet calculations. It also removes the entire lines +marked with `!', `_', or `^'. The lines with `$' are kept, because +the values of constants may be useful to have." + :group 'org-export-tables + :type 'boolean) + +(defcustom org-export-prefer-native-exporter-for-tables nil + "Non-nil means always export tables created with table.el natively. +Natively means use the HTML code generator in table.el. +When nil, Org-mode's own HTML generator is used when possible (i.e. if +the table does not use row- or column-spanning). This has the +advantage, that the automatic HTML conversions for math symbols and +sub/superscripts can be applied. Org-mode's HTML generator is also +much faster. The LaTeX exporter always use the native exporter for +table.el tables." + :group 'org-export-tables + :type 'boolean) + + +(defgroup org-export-xml nil + "Options specific for XML export of Org-mode files." + :tag "Org Export XML" + :group 'org-export) + +;;;; Exporting + +;;; Variables, constants, and parameter plists + +(defconst org-level-max 20) + +(defvar org-current-export-file nil) ; dynamically scoped parameter +(defvar org-current-export-dir nil) ; dynamically scoped parameter +(defvar org-export-opt-plist nil + "Contains the current option plist.") +(defvar org-last-level nil) ; dynamically scoped variable +(defvar org-min-level nil) ; dynamically scoped variable +(defvar org-levels-open nil) ; dynamically scoped parameter + +(defconst org-export-plist-vars + '((:link-up nil org-export-html-link-up) + (:link-home nil org-export-html-link-home) + (:language nil org-export-default-language) + (:keywords nil org-export-page-keywords) + (:description nil org-export-page-description) + (:customtime nil org-display-custom-times) + (:headline-levels "H" org-export-headline-levels) + (:section-numbers "num" org-export-with-section-numbers) + (:section-number-format nil org-export-section-number-format) + (:table-of-contents "toc" org-export-with-toc) + (:preserve-breaks "\\n" org-export-preserve-breaks) + (:archived-trees nil org-export-with-archived-trees) + (:emphasize "*" org-export-with-emphasize) + (:sub-superscript "^" org-export-with-sub-superscripts) + (:special-strings "-" org-export-with-special-strings) + (:footnotes "f" org-export-with-footnotes) + (:drawers "d" org-export-with-drawers) + (:tags "tags" org-export-with-tags) + (:todo-keywords "todo" org-export-with-todo-keywords) + (:priority "pri" org-export-with-priority) + (:TeX-macros "TeX" org-export-with-TeX-macros) + (:LaTeX-fragments "LaTeX" org-export-with-LaTeX-fragments) + (:latex-listings nil org-export-latex-listings) + (:skip-before-1st-heading "skip" org-export-skip-text-before-1st-heading) + (:fixed-width ":" org-export-with-fixed-width) + (:timestamps "<" org-export-with-timestamps) + (:author-info "author" org-export-author-info) + (:email-info "email" org-export-email-info) + (:creator-info "creator" org-export-creator-info) + (:time-stamp-file "timestamp" org-export-time-stamp-file) + (:tables "|" org-export-with-tables) + (:table-auto-headline nil org-export-highlight-first-table-line) + (:style-include-default nil org-export-html-style-include-default) + (:style-include-scripts nil org-export-html-style-include-scripts) + (:style nil org-export-html-style) + (:style-extra nil org-export-html-style-extra) + (:agenda-style nil org-agenda-export-html-style) + (:convert-org-links nil org-export-html-link-org-files-as-html) + (:inline-images nil org-export-html-inline-images) + (:html-extension nil org-export-html-extension) + (:xml-declaration nil org-export-html-xml-declaration) + (:html-table-tag nil org-export-html-table-tag) + (:expand-quoted-html "@" org-export-html-expand) + (:timestamp nil org-export-html-with-timestamp) + (:publishing-directory nil org-export-publishing-directory) + (:preamble nil org-export-html-preamble) + (:postamble nil org-export-html-postamble) + (:auto-preamble nil org-export-html-auto-preamble) + (:auto-postamble nil org-export-html-auto-postamble) + (:author nil user-full-name) + (:email nil user-mail-address) + (:select-tags nil org-export-select-tags) + (:exclude-tags nil org-export-exclude-tags) + + (:latex-image-options nil org-export-latex-image-default-option)) + "List of properties that represent export/publishing variables. +Each element is a list of 3 items: +1. The property that is used internally, and also for org-publish-project-alist +2. The string that can be used in the OPTION lines to set this option, + or nil if this option cannot be changed in this way +3. The customization variable that sets the default for this option." +) + +(defun org-default-export-plist () + "Return the property list with default settings for the export variables." + (let* ((infile (org-infile-export-plist)) + (letbind (plist-get infile :let-bind)) + (l org-export-plist-vars) rtn e s v) + (while (setq e (pop l)) + (setq s (nth 2 e) + v (cond + ((assq s letbind) (nth 1 (assq s letbind))) + ((boundp s) (symbol-value s)) + (t nil)) + rtn (cons (car e) (cons v rtn)))) + rtn)) + +(defvar org-export-inbuffer-options-extra nil + "List of additional in-buffer options that should be detected. +Just before export, the buffer is scanned for options like #+TITLE, #+EMAIL, +etc. Extensions can add to this list to get their options detected, and they +can then add a function to `org-export-options-filters' to process these +options. +Each element in this list must be a list, with the in-buffer keyword as car, +and a property (a symbol) as the next element. All occurrences of the +keyword will be found, the values concatenated with a space character +in between, and the result stored in the export options property list.") + +(defvar org-export-options-filters nil + "Functions to be called to finalize the export/publishing options. +All these options are stored in a property list, and each of the functions +in this hook gets a chance to modify this property list. Each function +must accept the property list as an argument, and must return the (possibly +modified) list.") + +;; FIXME: should we fold case here? +(defun org-infile-export-plist () + "Return the property list with file-local settings for export." + (save-excursion + (save-restriction + (widen) + (goto-char (point-min)) + (let ((re (org-make-options-regexp + (append + '("TITLE" "AUTHOR" "DATE" "EMAIL" "TEXT" "OPTIONS" "LANGUAGE" + "MATHJAX" + "LINK_UP" "LINK_HOME" "SETUPFILE" "STYLE" + "LATEX_HEADER" "LATEX_CLASS" + "EXPORT_SELECT_TAGS" "EXPORT_EXCLUDE_TAGS" + "KEYWORDS" "DESCRIPTION" "MACRO" "BIND" "XSLT") + (mapcar 'car org-export-inbuffer-options-extra)))) + (case-fold-search t) + p key val text options mathjax a pr style + latex-header latex-class macros letbind + ext-setup-or-nil setup-contents (start 0)) + (while (or (and ext-setup-or-nil + (string-match re ext-setup-or-nil start) + (setq start (match-end 0))) + (and (setq ext-setup-or-nil nil start 0) + (re-search-forward re nil t))) + (setq key (upcase (org-match-string-no-properties 1 ext-setup-or-nil)) + val (org-match-string-no-properties 2 ext-setup-or-nil)) + (cond + ((setq a (assoc key org-export-inbuffer-options-extra)) + (setq pr (nth 1 a)) + (setq p (plist-put p pr (concat (plist-get p pr) " " val)))) + ((string-equal key "TITLE") (setq p (plist-put p :title val))) + ((string-equal key "AUTHOR")(setq p (plist-put p :author val))) + ((string-equal key "EMAIL") (setq p (plist-put p :email val))) + ((string-equal key "DATE") (setq p (plist-put p :date val))) + ((string-equal key "KEYWORDS") (setq p (plist-put p :keywords val))) + ((string-equal key "DESCRIPTION") + (setq p (plist-put p :description val))) + ((string-equal key "LANGUAGE") (setq p (plist-put p :language val))) + ((string-equal key "STYLE") + (setq style (concat style "\n" val))) + ((string-equal key "LATEX_HEADER") + (setq latex-header (concat latex-header "\n" val))) + ((string-equal key "LATEX_CLASS") + (setq latex-class val)) + ((string-equal key "TEXT") + (setq text (if text (concat text "\n" val) val))) + ((string-equal key "OPTIONS") + (setq options (concat val " " options))) + ((string-equal key "MATHJAX") + (setq mathjax (concat val " " mathjax))) + ((string-equal key "BIND") + (push (read (concat "(" val ")")) letbind)) + ((string-equal key "XSLT") + (setq p (plist-put p :xslt val))) + ((string-equal key "LINK_UP") + (setq p (plist-put p :link-up val))) + ((string-equal key "LINK_HOME") + (setq p (plist-put p :link-home val))) + ((string-equal key "EXPORT_SELECT_TAGS") + (setq p (plist-put p :select-tags (org-split-string val)))) + ((string-equal key "EXPORT_EXCLUDE_TAGS") + (setq p (plist-put p :exclude-tags (org-split-string val)))) + ((string-equal key "MACRO") + (push val macros)) + ((equal key "SETUPFILE") + (setq setup-contents (org-file-contents + (expand-file-name + (org-remove-double-quotes + (org-trim val))) + 'noerror)) + (if (not ext-setup-or-nil) + (setq ext-setup-or-nil setup-contents start 0) + (setq ext-setup-or-nil + (concat (substring ext-setup-or-nil 0 start) + "\n" setup-contents "\n" + (substring ext-setup-or-nil start))))))) + (setq p (plist-put p :text text)) + (when (and letbind (org-export-confirm-letbind)) + (setq p (plist-put p :let-bind letbind))) + (when style (setq p (plist-put p :style-extra style))) + (when latex-header + (setq p (plist-put p :latex-header-extra (substring latex-header 1)))) + (when latex-class + (setq p (plist-put p :latex-class latex-class))) + (when options + (setq p (org-export-add-options-to-plist p options))) + (when mathjax + (setq p (plist-put p :mathjax mathjax))) + ;; Add macro definitions + (setq p (plist-put p :macro-date "(eval (format-time-string \"$1\"))")) + (setq p (plist-put p :macro-time "(eval (format-time-string \"$1\"))")) + (setq p (plist-put p :macro-property "(eval (org-entry-get nil \"$1\" 'selective))")) + (setq p (plist-put + p :macro-modification-time + (and (buffer-file-name) + (file-exists-p (buffer-file-name)) + (concat + "(eval (format-time-string \"$1\" '" + (prin1-to-string (nth 5 (file-attributes + (buffer-file-name)))) + "))")))) + (setq p (plist-put p :macro-input-file (and (buffer-file-name) + (file-name-nondirectory + (buffer-file-name))))) + (while (setq val (pop macros)) + (when (string-match "^\\([-a-zA-Z0-9_]+\\)[ \t]+\\(.*?[ \t]*$\\)" val) + (setq p (plist-put + p (intern + (concat ":macro-" (downcase (match-string 1 val)))) + (org-export-interpolate-newlines (match-string 2 val)))))) + p)))) + +(defun org-export-interpolate-newlines (s) + (while (string-match "\\\\n" s) + (setq s (replace-match "\n" t t s))) + s) + +(defvar org-export-allow-BIND-local nil) +(defun org-export-confirm-letbind () + "Can we use #+BIND values during export? +By default this will ask fro confirmation by the user, to divert possible +security risks." + (cond + ((not org-export-allow-BIND) nil) + ((eq org-export-allow-BIND t) t) + ((local-variable-p 'org-export-allow-BIND-local (current-buffer)) + org-export-allow-BIND-local) + (t (org-set-local 'org-export-allow-BIND-local + (yes-or-no-p "Allow BIND values in this buffer? "))))) + +(defun org-install-letbind () + "Install the values from #+BIND lines as local variables." + (let ((letbind (plist-get org-export-opt-plist :let-bind)) + pair) + (while (setq pair (pop letbind)) + (org-set-local (car pair) (nth 1 pair))))) + +(defun org-export-add-options-to-plist (p options) + "Parse an OPTIONS line and set values in the property list P." + (let (o) + (when options + (let ((op org-export-plist-vars)) + (while (setq o (pop op)) + (if (and (nth 1 o) + (string-match (concat (regexp-quote (nth 1 o)) + ":\\([^ \t\n\r;,.]*\\)") + options)) + (setq p (plist-put p (car o) + (car (read-from-string + (match-string 1 options)))))))))) + p) + +(defun org-export-add-subtree-options (p pos) + "Add options in subtree at position POS to property list P." + (save-excursion + (goto-char pos) + (when (org-at-heading-p) + (let (a) + ;; This is actually read in `org-export-get-title-from-subtree' + ;; (when (setq a (org-entry-get pos "EXPORT_TITLE")) + ;; (setq p (plist-put p :title a))) + (when (setq a (org-entry-get pos "EXPORT_TEXT")) + (setq p (plist-put p :text a))) + (when (setq a (org-entry-get pos "EXPORT_AUTHOR")) + (setq p (plist-put p :author a))) + (when (setq a (org-entry-get pos "EXPORT_DATE")) + (setq p (plist-put p :date a))) + (when (setq a (org-entry-get pos "EXPORT_OPTIONS")) + (setq p (org-export-add-options-to-plist p a))))) + p)) + +(defun org-export-directory (type plist) + (let* ((val (plist-get plist :publishing-directory)) + (dir (if (listp val) + (or (cdr (assoc type val)) ".") + val))) + dir)) + +(defun org-export-process-option-filters (plist) + (let ((functions org-export-options-filters) f) + (while (setq f (pop functions)) + (setq plist (funcall f plist)))) + plist) + +;;;###autoload +(defun org-export (&optional arg) + "Export dispatcher for Org-mode. +When `org-export-run-in-background' is non-nil, try to run the command +in the background. This will be done only for commands that write +to a file. For details see the docstring of `org-export-run-in-background'. + +The prefix argument ARG will be passed to the exporter. However, if +ARG is a double universal prefix \\[universal-argument] \\[universal-argument], \ +that means to inverse the +value of `org-export-run-in-background'." + (interactive "P") + (let* ((bg (org-xor (equal arg '(16)) org-export-run-in-background)) + subtree-p + (help "[t] insert the export option template +\[v] limit export to visible part of outline tree +\[1] only export the current subtree +\[SPC] publish enclosing subtree (with LaTeX_CLASS or EXPORT_FILE_NAME prop) + +\[a/n/u] export as ASCII/Latin-1/UTF-8 [A/N/U] to temporary buffer + +\[h] export as HTML [H] to temporary buffer [R] export region +\[b] export as HTML and open in browser + +\[l] export as LaTeX [L] to temporary buffer +\[p] export as LaTeX and process to PDF [d] ... and open PDF file + +\[D] export as DocBook [V] export as DocBook, process to PDF, and open + +\[j] export as TaskJuggler [J] ... and open + +\[m] export as Freemind mind map +\[x] export as XOXO +\[g] export using Wes Hardaker's generic exporter + +\[i] export current file as iCalendar file +\[I] export all agenda files as iCalendar files [c] ...as one combined file + +\[F] publish current file [P] publish current project +\[X] publish a project... [E] publish every projects") + (cmds + '((?t org-insert-export-options-template nil) + (?v org-export-visible nil) + (?a org-export-as-ascii t) + (?A org-export-as-ascii-to-buffer t) + (?n org-export-as-latin1 t) + (?N org-export-as-latin1-to-buffer t) + (?u org-export-as-utf8 t) + (?U org-export-as-utf8-to-buffer t) + (?h org-export-as-html t) + (?b org-export-as-html-and-open t) + (?H org-export-as-html-to-buffer nil) + (?R org-export-region-as-html nil) + (?x org-export-as-xoxo t) + (?g org-export-generic t) + (?D org-export-as-docbook t) + (?V org-export-as-docbook-pdf-and-open t) + (?j org-export-as-taskjuggler t) + (?J org-export-as-taskjuggler-and-open t) + (?m org-export-as-freemind t) + (?l org-export-as-latex t) + (?p org-export-as-pdf t) + (?d org-export-as-pdf-and-open t) + (?L org-export-as-latex-to-buffer nil) + (?i org-export-icalendar-this-file t) + (?I org-export-icalendar-all-agenda-files t) + (?c org-export-icalendar-combine-agenda-files t) + (?F org-publish-current-file t) + (?P org-publish-current-project t) + (?X org-publish t) + (?E org-publish-all t))) + r1 r2 ass + (cpos (point)) (cbuf (current-buffer)) bpos) + (save-excursion + (save-window-excursion + (delete-other-windows) + (with-output-to-temp-buffer "*Org Export/Publishing Help*" + (princ help)) + (org-fit-window-to-buffer (get-buffer-window + "*Org Export/Publishing Help*")) + (message "Select command: ") + (setq r1 (read-char-exclusive)) + (when (eq r1 ?1) + (setq subtree-p t) + (message "Select command (for subtree): ") + (setq r1 (read-char-exclusive))) + (when (eq r1 ?\ ) + (let ((case-fold-search t)) + (if (re-search-backward + "^[ \t]+\\(:latex_class:\\|:export_title:\\)[ \t]+\\S-" + nil t) + (progn + (org-back-to-heading t) + (setq subtree-p t) + (setq bpos (point)) + (message "Select command (for subtree): ") + (setq r1 (read-char-exclusive))) + (error "No enclosing node with LaTeX_CLASS or EXPORT_FILE_NAME") + ))))) + (and bpos (goto-char bpos)) + (setq r2 (if (< r1 27) (+ r1 96) r1)) + (unless (setq ass (assq r2 cmds)) + (error "No command associated with key %c" r1)) + (if (and bg (nth 2 ass) + (not (buffer-base-buffer)) + (not (org-region-active-p))) + ;; execute in background + (let ((p (start-process + (concat "Exporting " (file-name-nondirectory (buffer-file-name))) + "*Org Processes*" + (expand-file-name invocation-name invocation-directory) + "-batch" + "-l" user-init-file + "--eval" "(require 'org-exp)" + "--eval" "(setq org-wait .2)" + (buffer-file-name) + "-f" (symbol-name (nth 1 ass))))) + (set-process-sentinel p 'org-export-process-sentinel) + (message "Background process \"%s\": started" p)) + ;; background processing not requested, or not possible + (if subtree-p (progn (org-mark-subtree) (activate-mark))) + (call-interactively (nth 1 ass)) + (when (and bpos (get-buffer-window cbuf)) + (let ((cw (selected-window))) + (select-window (get-buffer-window cbuf)) + (goto-char cpos) + (deactivate-mark) + (select-window cw)))))) + +(defun org-export-process-sentinel (process status) + (if (string-match "\n+\\'" status) + (setq status (substring status 0 -1))) + (message "Background process \"%s\": %s" process status)) + +;;; General functions for all backends + +(defvar org-export-target-aliases nil + "Alist of targets with invisible aliases.") +(defvar org-export-preferred-target-alist nil + "Alist of section id's with preferred aliases.") +(defvar org-export-id-target-alist nil + "Alist of section id's with preferred aliases.") +(defvar org-export-code-refs nil + "Alist of code references and line numbers.") + +(defun org-export-preprocess-string (string &rest parameters) + "Cleanup STRING so that that the true exported has a more consistent source. +This function takes STRING, which should be a buffer-string of an org-file +to export. It then creates a temporary buffer where it does its job. +The result is then again returned as a string, and the exporter works +on this string to produce the exported version." + (interactive) + (let* ((htmlp (plist-get parameters :for-html)) + (asciip (plist-get parameters :for-ascii)) + (latexp (plist-get parameters :for-LaTeX)) + (docbookp (plist-get parameters :for-docbook)) + (backend (cond (htmlp 'html) + (latexp 'latex) + (asciip 'ascii) + (docbookp 'docbook))) + (archived-trees (plist-get parameters :archived-trees)) + (inhibit-read-only t) + (drawers org-drawers) + (outline-regexp "\\*+ ") + target-alist rtn) + + (setq org-export-target-aliases nil + org-export-preferred-target-alist nil + org-export-id-target-alist nil + org-export-code-refs nil) + + (with-current-buffer (get-buffer-create " org-mode-tmp") + (erase-buffer) + (insert string) + (setq case-fold-search t) + + (let ((inhibit-read-only t)) + (remove-text-properties (point-min) (point-max) + '(read-only t))) + + ;; Remove license-to-kill stuff + ;; The caller marks some stuff for killing, stuff that has been + ;; used to create the page title, for example. + (org-export-kill-licensed-text) + + (let ((org-inhibit-startup t)) (org-mode)) + (setq case-fold-search t) + (org-install-letbind) + + ;; Call the hook + (run-hooks 'org-export-preprocess-hook) + + ;; Process the macros + (org-export-preprocess-apply-macros) + (run-hooks 'org-export-preprocess-after-macros-hook) + + (untabify (point-min) (point-max)) + + ;; Handle include files, and call a hook + (org-export-handle-include-files-recurse) + (run-hooks 'org-export-preprocess-after-include-files-hook) + + ;; Get rid of archived trees + (org-export-remove-archived-trees archived-trees) + + ;; Remove comment environment and comment subtrees + (org-export-remove-comment-blocks-and-subtrees) + + ;; Get rid of excluded trees, and call a hook + (org-export-handle-export-tags (plist-get parameters :select-tags) + (plist-get parameters :exclude-tags)) + (run-hooks 'org-export-preprocess-after-tree-selection-hook) + + ;; Mark end of lists + (org-export-mark-list-ending backend) + + ;; Export code blocks + (org-export-blocks-preprocess) + + ;; Handle source code snippets + (org-export-replace-src-segments-and-examples backend) + + ;; Protect short examples marked by a leading colon + (org-export-protect-colon-examples) + + ;; Protected spaces + (org-export-convert-protected-spaces backend) + + ;; Normalize footnotes + (when (plist-get parameters :footnotes) + (org-footnote-normalize nil t)) + + ;; Find all headings and compute the targets for them + (setq target-alist (org-export-define-heading-targets target-alist)) + + (run-hooks 'org-export-preprocess-after-headline-targets-hook) + + ;; Find HTML special classes for headlines + (org-export-remember-html-container-classes) + + ;; Get rid of drawers + (org-export-remove-or-extract-drawers + drawers (plist-get parameters :drawers) backend) + + ;; Get the correct stuff before the first headline + (when (plist-get parameters :skip-before-1st-heading) + (goto-char (point-min)) + (when (re-search-forward "^\\(#.*\n\\)?\\*+[ \t]" nil t) + (delete-region (point-min) (match-beginning 0)) + (goto-char (point-min)) + (insert "\n"))) + (when (plist-get parameters :add-text) + (goto-char (point-min)) + (insert (plist-get parameters :add-text) "\n")) + + ;; Remove todo-keywords before exporting, if the user has requested so + (org-export-remove-headline-metadata parameters) + + ;; Find targets in comments and move them out of comments, + ;; but mark them as targets that should be invisible + (setq target-alist (org-export-handle-invisible-targets target-alist)) + + ;; Select and protect backend specific stuff, throw away stuff + ;; that is specific for other backends + (run-hooks 'org-export-preprocess-before-selecting-backend-code-hook) + (org-export-select-backend-specific-text backend) + + ;; Protect quoted subtrees + (org-export-protect-quoted-subtrees) + + ;; Remove clock lines + (org-export-remove-clock-lines) + + ;; Protect verbatim elements + (org-export-protect-verbatim) + + ;; Blockquotes, verse, and center + (org-export-mark-blockquote-verse-center) + (run-hooks 'org-export-preprocess-after-blockquote-hook) + + ;; Remove timestamps, if the user has requested so + (unless (plist-get parameters :timestamps) + (org-export-remove-timestamps)) + + ;; Attach captions to the correct object + (setq target-alist (org-export-attach-captions-and-attributes + backend target-alist)) + + ;; Find matches for radio targets and turn them into internal links + (org-export-mark-radio-links) + (run-hooks 'org-export-preprocess-after-radio-targets-hook) + + ;; Find all links that contain a newline and put them into a single line + (org-export-concatenate-multiline-links) + + ;; Normalize links: Convert angle and plain links into bracket links + ;; and expand link abbreviations + (run-hooks 'org-export-preprocess-before-normalizing-links-hook) + (org-export-normalize-links) + + ;; Find all internal links. If they have a fuzzy match (i.e. not + ;; a *dedicated* target match, let the link point to the + ;; corresponding section. + (org-export-target-internal-links target-alist) + + ;; Find multiline emphasis and put them into single line + (when (plist-get parameters :emph-multiline) + (org-export-concatenate-multiline-emphasis)) + + ;; Remove special table lines, and store alignment information + (org-store-forced-table-alignment) + (when org-export-table-remove-special-lines + (org-export-remove-special-table-lines)) + + ;; Another hook + (run-hooks 'org-export-preprocess-before-backend-specifics-hook) + + ;; LaTeX-specific preprocessing + (when latexp + (require 'org-latex nil) + (org-export-latex-preprocess parameters)) + + ;; ASCII-specific preprocessing + (when asciip + (org-export-ascii-preprocess parameters)) + + ;; HTML-specific preprocessing + (when htmlp + (org-export-html-preprocess parameters)) + + ;; DocBook-specific preprocessing + (when docbookp + (require 'org-docbook nil) + (org-export-docbook-preprocess parameters)) + + ;; Remove or replace comments + (org-export-handle-comments (plist-get parameters :comments)) + + ;; Remove #+TBLFM and #+TBLNAME lines + (org-export-handle-table-metalines) + + ;; Run the final hook + (run-hooks 'org-export-preprocess-final-hook) + + (setq rtn (buffer-string))) + (kill-buffer " org-mode-tmp") + rtn)) + +(defun org-export-kill-licensed-text () + "Remove all text that is marked with a :org-license-to-kill property." + (let (p) + (while (setq p (text-property-any (point-min) (point-max) + :org-license-to-kill t)) + (delete-region + p (or (next-single-property-change p :org-license-to-kill) + (point-max)))))) + +(defvar org-export-define-heading-targets-headline-hook nil + "Hook that is run when a headline was matched during target search. +This is part of the preprocessing for export.") + +(defun org-export-define-heading-targets (target-alist) + "Find all headings and define the targets for them. +The new targets are added to TARGET-ALIST, which is also returned. +Also find all ID and CUSTOM_ID properties and store them." + (goto-char (point-min)) + (org-init-section-numbers) + (let ((re (concat "^" org-outline-regexp + "\\|" + "^[ \t]*:\\(ID\\|CUSTOM_ID\\):[ \t]*\\([^ \t\r\n]+\\)")) + level target last-section-target a id) + (while (re-search-forward re nil t) + (org-if-unprotected-at (match-beginning 0) + (if (match-end 2) + (progn + (setq id (org-match-string-no-properties 2)) + (push (cons id target) target-alist) + (setq a (or (assoc last-section-target org-export-target-aliases) + (progn + (push (list last-section-target) + org-export-target-aliases) + (car org-export-target-aliases)))) + (push (caar target-alist) (cdr a)) + (when (equal (match-string 1) "CUSTOM_ID") + (if (not (assoc last-section-target + org-export-preferred-target-alist)) + (push (cons last-section-target id) + org-export-preferred-target-alist))) + (when (equal (match-string 1) "ID") + (if (not (assoc last-section-target + org-export-id-target-alist)) + (push (cons last-section-target (concat "ID-" id)) + org-export-id-target-alist)))) + (setq level (org-reduced-level + (save-excursion (goto-char (point-at-bol)) + (org-outline-level)))) + (setq target (org-solidify-link-text + (format "sec-%s" (replace-regexp-in-string + "\\." "_" + (org-section-number level))))) + (setq last-section-target target) + (push (cons target target) target-alist) + (add-text-properties + (point-at-bol) (point-at-eol) + (list 'target target)) + (run-hooks 'org-export-define-heading-targets-headline-hook))))) + target-alist) + +(defun org-export-handle-invisible-targets (target-alist) + "Find targets in comments and move them out of comments. +Mark them as invisible targets." + (let (target tmp a) + (goto-char (point-min)) + (while (re-search-forward "^#.*?\\(<<<?\\([^>\r\n]+\\)>>>?\\).*" nil t) + ;; Check if the line before or after is a headline with a target + (if (setq target (or (get-text-property (point-at-bol 0) 'target) + (get-text-property (point-at-bol 2) 'target))) + (progn + ;; use the existing target in a neighboring line + (setq tmp (match-string 2)) + (replace-match "") + (and (looking-at "\n") (delete-char 1)) + (push (cons (setq tmp (org-solidify-link-text tmp)) target) + target-alist) + (setq a (or (assoc target org-export-target-aliases) + (progn + (push (list target) org-export-target-aliases) + (car org-export-target-aliases)))) + (push tmp (cdr a))) + ;; Make an invisible target + (replace-match "\\1(INVISIBLE)")))) + target-alist) + +(defun org-export-target-internal-links (target-alist) + "Find all internal links and assign targets to them. +If a link has a fuzzy match (i.e. not a *dedicated* target match), +let the link point to the corresponding section. +This function also handles the id links, if they have a match in +the current file." + (goto-char (point-min)) + (while (re-search-forward org-bracket-link-regexp nil t) + (org-if-unprotected-at (1+ (match-beginning 0)) + (let* ((md (match-data)) + (desc (match-end 2)) + (link (org-link-unescape (match-string 1))) + (slink (org-solidify-link-text link)) + found props pos cref + (target + (cond + ((= (string-to-char link) ?#) + ;; user wants exactly this link + link) + ((cdr (assoc slink target-alist)) + (or (cdr (assoc (assoc slink target-alist) + org-export-preferred-target-alist)) + (cdr (assoc slink target-alist)))) + ((and (string-match "^id:" link) + (cdr (assoc (substring link 3) target-alist)))) + ((string-match "^(\\(.*\\))$" link) + (setq cref (match-string 1 link)) + (concat "coderef:" cref)) + ((string-match org-link-types-re link) nil) + ((or (file-name-absolute-p link) + (string-match "^\\." link)) + nil) + (t + (let ((org-link-search-inhibit-query t)) + (save-excursion + (setq found (condition-case nil (org-link-search link) + (error nil))) + (when (and found + (or (org-on-heading-p) + (not (eq found 'dedicated)))) + (or (get-text-property (point) 'target) + (get-text-property + (max (point-min) + (1- (or (previous-single-property-change + (point) 'target) 0))) + 'target))))))))) + (when target + (set-match-data md) + (goto-char (match-beginning 1)) + (setq props (text-properties-at (point))) + (delete-region (match-beginning 1) (match-end 1)) + (setq pos (point)) + (insert target) + (unless desc (insert "][" link)) + (add-text-properties pos (point) props)))))) + +(defun org-export-remember-html-container-classes () + "Store the HTML_CONTAINER_CLASS properties in a text property." + (goto-char (point-min)) + (let (class) + (while (re-search-forward + "^[ \t]*:HTML_CONTAINER_CLASS:[ \t]+\\(.+\\)$" nil t) + (setq class (match-string 1)) + (save-excursion + (org-back-to-heading t) + (put-text-property (point-at-bol) (point-at-eol) 'html-container-class class))))) + +(defvar org-export-format-drawer-function nil + "Function to be called to format the contents of a drawer. +The function must accept three parameters: + NAME the drawer name, like \"PROPERTIES\" + CONTENT the content of the drawer. + BACKEND one of the symbols html, docbook, latex, ascii, xoxo +The function should return the text to be inserted into the buffer. +If this is nil, `org-export-format-drawer' is used as a default.") + +(defun org-export-remove-or-extract-drawers (all-drawers exp-drawers backend) + "Remove drawers, or extract and format the content. +ALL-DRAWERS is a list of all drawer names valid in the current buffer. +EXP-DRAWERS can be t to keep all drawer contents, or a list of drawers +whose content to keep. Any drawers that are in ALL-DRAWERS but not in +EXP-DRAWERS will be removed. +BACKEND is the current export backend." + (goto-char (point-min)) + (let ((re (concat "^[ \t]*:\\(" + (mapconcat 'identity all-drawers "\\|") + "\\):[ \t]*$")) + name beg beg-content eol content) + (while (re-search-forward re nil t) + (org-if-unprotected + (setq name (match-string 1)) + (setq beg (match-beginning 0) + beg-content (1+ (point-at-eol)) + eol (point-at-eol)) + (if (not (and (re-search-forward + "^\\([ \t]*:END:[ \t]*\n?\\)\\|^\\*+[ \t]" nil t) + (match-end 1))) + (goto-char eol) + (goto-char (match-beginning 0)) + (and (looking-at ".*\n?") (replace-match "")) + (setq content (buffer-substring beg-content (point))) + (delete-region beg (point)) + (when (or (eq exp-drawers t) + (member name exp-drawers)) + (setq content (funcall (or org-export-format-drawer-function + 'org-export-format-drawer) + name content backend)) + (insert content))))))) + +(defun org-export-format-drawer (name content backend) + "Format the content of a drawer as a colon example." + (if (string-match "[ \t]+\\'" content) + (setq content (substring content (match-beginning 0)))) + (while (string-match "\\`[ \t]*\n" content) + (setq content (substring content (match-end 0)))) + (setq content (org-remove-indentation content)) + (setq content (concat ": " (mapconcat 'identity + (org-split-string content "\n") + "\n: ") + "\n")) + (setq content (concat " : " (upcase name) "\n" content)) + (org-add-props content nil 'org-protected t)) + +(defun org-export-handle-export-tags (select-tags exclude-tags) + "Modify the buffer, honoring SELECT-TAGS and EXCLUDE-TAGS. +Both arguments are lists of tags. +If any of SELECT-TAGS is found, all trees not marked by a SELECT-TAG +will be removed. +After that, all subtrees that are marked by EXCLUDE-TAGS will be +removed as well." + (remove-text-properties (point-min) (point-max) '(:org-delete t)) + (let* ((re-sel (concat ":\\(" (mapconcat 'regexp-quote + select-tags "\\|") + "\\):")) + (re-excl (concat ":\\(" (mapconcat 'regexp-quote + exclude-tags "\\|") + "\\):")) + beg end cont) + (goto-char (point-min)) + (when (and select-tags + (re-search-forward + (concat "^\\*+[ \t].*" re-sel "[^ \t\n]*[ \t]*$") nil t)) + ;; At least one tree is marked for export, this means + ;; all the unmarked stuff needs to go. + ;; Dig out the trees that should be exported + (goto-char (point-min)) + (outline-next-heading) + (setq beg (point)) + (put-text-property beg (point-max) :org-delete t) + (while (re-search-forward re-sel nil t) + (when (org-on-heading-p) + (org-back-to-heading) + (remove-text-properties + (max (1- (point)) (point-min)) + (setq cont (save-excursion (org-end-of-subtree t t))) + '(:org-delete t)) + (while (and (org-up-heading-safe) + (get-text-property (point) :org-delete)) + (remove-text-properties (max (1- (point)) (point-min)) + (point-at-eol) '(:org-delete t))) + (goto-char cont)))) + ;; Remove the trees explicitly marked for noexport + (when exclude-tags + (goto-char (point-min)) + (while (re-search-forward re-excl nil t) + (when (org-at-heading-p) + (org-back-to-heading t) + (setq beg (point)) + (org-end-of-subtree t t) + (delete-region beg (point)) + (when (featurep 'org-inlinetask) + (org-inlinetask-remove-END-maybe))))) + ;; Remove everything that is now still marked for deletion + (goto-char (point-min)) + (while (setq beg (text-property-any (point-min) (point-max) :org-delete t)) + (setq end (or (next-single-property-change beg :org-delete) + (point-max))) + (delete-region beg end)))) + +(defun org-export-remove-archived-trees (export-archived-trees) + "Remove archived trees. +When EXPORT-ARCHIVED-TREES is `headline;, only the headline will be exported. +When it is t, the entire archived tree will be exported. +When it is nil the entire tree including the headline will be removed +from the buffer." + (let ((re-archive (concat ":" org-archive-tag ":")) + a b) + (when (not (eq export-archived-trees t)) + (goto-char (point-min)) + (while (re-search-forward re-archive nil t) + (if (not (org-on-heading-p t)) + (goto-char (point-at-eol)) + (beginning-of-line 1) + (setq a (if export-archived-trees + (1+ (point-at-eol)) (point)) + b (org-end-of-subtree t)) + (if (> b a) (delete-region a b))))))) + +(defun org-export-remove-headline-metadata (opts) + "Remove meta data from the headline, according to user options." + (let ((re org-complex-heading-regexp) + (todo (plist-get opts :todo-keywords)) + (tags (plist-get opts :tags)) + (pri (plist-get opts :priority)) + (elts '(1 2 3 4 5)) + rpl) + (setq elts (delq nil (list 1 (if todo 2) (if pri 3) 4 (if tags 5)))) + (when (or (not todo) (not tags) (not pri)) + (goto-char (point-min)) + (while (re-search-forward re nil t) + (org-if-unprotected + (setq rpl (mapconcat (lambda (i) (if (match-end i) (match-string i) "")) + elts " ")) + (replace-match rpl t t)))))) + +(defun org-export-remove-timestamps () + "Remove timestamps and keywords for export." + (goto-char (point-min)) + (while (re-search-forward org-maybe-keyword-time-regexp nil t) + (backward-char 1) + (org-if-unprotected + (unless (save-match-data (org-at-table-p)) + (replace-match "") + (beginning-of-line 1) + (if (looking-at "[- \t]*\\(=>[- \t0-9:]*\\)?[ \t]*\n") + (replace-match "")))))) + +(defun org-export-remove-clock-lines () + "Remove clock lines for export." + (goto-char (point-min)) + (let ((re (concat "^[ \t]*" org-clock-string ".*\n?"))) + (while (re-search-forward re nil t) + (org-if-unprotected + (replace-match ""))))) + +(defun org-export-protect-quoted-subtrees () + "Mark quoted subtrees with the protection property." + (let ((re-quote (concat "^\\*+[ \t]+" org-quote-string "\\>"))) + (goto-char (point-min)) + (while (re-search-forward re-quote nil t) + (goto-char (match-beginning 0)) + (end-of-line 1) + (add-text-properties (point) (org-end-of-subtree t) + '(org-protected t))))) + +(defun org-export-convert-protected-spaces (backend) + "Convert strings like \\____ to protected spaces in all backends." + (goto-char (point-min)) + (while (re-search-forward "\\\\__+" nil t) + (org-if-unprotected-1 + (replace-match + (org-add-props + (cond + ((eq backend 'latex) + (format "\\hspace{%dex}" (- (match-end 0) (match-beginning 0)))) + ((eq backend 'html) + (org-add-props (match-string 0) nil + 'org-whitespace (- (match-end 0) (match-beginning 0)))) + ;; ((eq backend 'docbook)) + ((eq backend 'ascii) + (org-add-props (match-string 0) '(org-whitespace t))) + (t (make-string (- (match-end 0) (match-beginning 0)) ?\ ))) + '(org-protected t)) + t t)))) + +(defun org-export-protect-verbatim () + "Mark verbatim snippets with the protection property." + (goto-char (point-min)) + (while (re-search-forward org-verbatim-re nil t) + (org-if-unprotected + (add-text-properties (match-beginning 4) (match-end 4) + '(org-protected t org-verbatim-emph t)) + (goto-char (1+ (match-end 4)))))) + +(defun org-export-protect-colon-examples () + "Protect lines starting with a colon." + (goto-char (point-min)) + (let ((re "^[ \t]*:\\([ \t]\\|$\\)") beg) + (while (re-search-forward re nil t) + (beginning-of-line 1) + (setq beg (point)) + (while (looking-at re) + (end-of-line 1) + (or (eobp) (forward-char 1))) + (add-text-properties beg (if (bolp) (1- (point)) (point)) + '(org-protected t))))) + +(defun org-export-select-backend-specific-text (backend) + (let ((formatters + '((docbook "DOCBOOK" "BEGIN_DOCBOOK" "END_DOCBOOK") + (html "HTML" "BEGIN_HTML" "END_HTML") + (beamer "BEAMER" "BEGIN_BEAMER" "END_BEAMER") + (ascii "ASCII" "BEGIN_ASCII" "END_ASCII") + (latex "LaTeX" "BEGIN_LaTeX" "END_LaTeX"))) + (case-fold-search t) + fmt beg beg-content end end-content) + + (while formatters + (setq fmt (pop formatters)) + ;; Handle #+Backend: stuff + (goto-char (point-min)) + (while (re-search-forward (concat "^\\([ \t]*\\)#\\+" (cadr fmt) + ":[ \t]*\\(.*\\)") nil t) + (if (not (eq (car fmt) backend)) + (delete-region (point-at-bol) (min (1+ (point-at-eol)) (point-max))) + (replace-match "\\1\\2" t) + (add-text-properties + (point-at-bol) (min (1+ (point-at-eol)) (point-max)) + '(org-protected t)))) + ;; Delete #+attr_Backend: stuff of another backend. Those + ;; matching the current backend will be taken care of by + ;; `org-export-attach-captions-and-attributes' + (goto-char (point-min)) + (while (re-search-forward (concat "^\\([ \t]*\\)#\\+attr_" (cadr fmt) + ":[ \t]*\\(.*\\)") nil t) + (when (not (eq (car fmt) backend)) + (delete-region (point-at-bol) (min (1+ (point-at-eol)) (point-max))))) + ;; Handle #+begin_Backend and #+end_Backend stuff + (goto-char (point-min)) + (while (re-search-forward (concat "^[ \t]*#\\+" (caddr fmt) "\\>.*\n?") + nil t) + (setq beg (match-beginning 0) beg-content (match-end 0)) + (when (re-search-forward (concat "^[ \t]*#\\+" (cadddr fmt) "\\>.*\n?") + nil t) + (setq end (match-end 0) end-content (match-beginning 0)) + (if (eq (car fmt) backend) + ;; yes, keep this + (progn + (add-text-properties beg-content end-content '(org-protected t)) + (delete-region (match-beginning 0) (match-end 0)) + (save-excursion + (goto-char beg) + (delete-region (point) (1+ (point-at-eol))))) + ;; No, this is for a different backend, kill it + (delete-region beg end))))))) + +(defun org-export-mark-blockquote-verse-center () + "Mark block quote and verse environments with special cookies. +These special cookies will later be interpreted by the backend." + ;; Blockquotes + (let (type t1 ind beg end beg1 end1 content) + (goto-char (point-min)) + (while (re-search-forward + "^\\([ \t]*\\)#\\+\\(begin_\\(\\(block\\)?quote\\|verse\\|center\\)\\>.*\\)" + nil t) + (setq ind (length (match-string 1)) + type (downcase (match-string 3)) + t1 (if (equal type "quote") "blockquote" type)) + (setq beg (match-beginning 0) + beg1 (1+ (match-end 0))) + (when (re-search-forward (concat "^[ \t]*#\\+end_" type "\\>.*") nil t) + (setq end1 (1- (match-beginning 0)) + end (+ (point-at-eol) (if (looking-at "\n$") 1 0))) + (setq content (org-remove-indentation (buffer-substring beg1 end1))) + (setq content (concat "ORG-" (upcase t1) "-START\n" + content "\n" + "ORG-" (upcase t1) "-END\n")) + (delete-region beg end) + (insert (org-add-props content nil 'original-indentation ind)))))) + +(defun org-export-mark-list-ending (backend) + "Mark list endings with special cookies. +These special cookies will later be interpreted by the backend. +`org-list-end-re' is replaced by a blank line in the process." + (let ((process-buffer + (lambda (end-list-marker) + (goto-char (point-min)) + (while (org-search-forward-unenclosed org-item-beginning-re nil t) + (goto-char (org-list-bottom-point)) + (when (and (not (eq org-list-ending-method 'indent)) + (looking-at (org-list-end-re))) + (replace-match "\n")) + (insert end-list-marker))))) + ;; We need to divide backends into 3 categories. + (cond + ;; 1. Backends using `org-list-parse-list' do not need markers. + ((memq backend '(latex)) + nil) + ;; 2. Line-processing backends need to be told where lists end. + ((memq backend '(html docbook)) + (funcall process-buffer "ORG-LIST-END\n")) + ;; 3. Others backends do not need to know this: clean list enders. + (t + (funcall process-buffer ""))))) + +(defun org-export-attach-captions-and-attributes (backend target-alist) + "Move #+CAPTION, #+ATTR_BACKEND, and #+LABEL text into text properties. +If the next thing following is a table, add the text properties to the first +table line. If it is a link, add it to the line containing the link." + (goto-char (point-min)) + (remove-text-properties (point-min) (point-max) + '(org-caption nil org-attributes nil)) + (let ((case-fold-search t) + (re (concat "^[ \t]*#\\+caption:[ \t]+\\(.*\\)" + "\\|" + "^[ \t]*#\\+attr_" (symbol-name backend) ":[ \t]+\\(.*\\)" + "\\|" + "^[ \t]*#\\+label:[ \t]+\\(.*\\)" + "\\|" + "^[ \t]*\\(|[^-]\\)" + "\\|" + "^[ \t]*\\[\\[.*\\]\\][ \t]*$")) + cap shortn attr label end) + (while (re-search-forward re nil t) + (cond + ((match-end 1) + (progn + (setq cap (concat cap (if cap " " "") (org-trim (match-string 1)))) + (when (string-match "\\[\\(.*\\)\\]{\\(.*\\)}" cap) + (setq shortn (match-string 1 cap) + cap (match-string 2 cap))) + (delete-region (point-at-bol) (min (1+ (point-at-eol)) (point-max))))) + ((match-end 2) + (progn + (setq attr (concat attr (if attr " " "") (org-trim (match-string 2)))) + (delete-region (point-at-bol) (min (1+ (point-at-eol)) (point-max))))) + ((match-end 3) + (progn + (setq label (org-trim (match-string 3))) + (delete-region (point-at-bol) (min (1+ (point-at-eol)) (point-max))))) + (t + (setq end (if (match-end 4) + (let ((ee (org-table-end))) + (prog1 (1- (marker-position ee)) (move-marker ee nil))) + (point-at-eol))) + (add-text-properties (point-at-bol) end + (list 'org-caption cap + 'org-caption-shortn shortn + 'org-attributes attr + 'org-label label)) + (if label (push (cons label label) target-alist)) + (goto-char end) + (setq cap nil attr nil label nil))))) + target-alist) + +(defun org-export-remove-comment-blocks-and-subtrees () + "Remove the comment environment, and also commented subtrees." + (let ((re-commented (concat "^\\*+[ \t]+" org-comment-string "\\>")) + case-fold-search) + ;; Remove comment environment + (goto-char (point-min)) + (setq case-fold-search t) + (while (re-search-forward + "^#\\+begin_comment[ \t]*\n[^\000]*?^#\\+end_comment\\>.*" nil t) + (replace-match "" t t)) + ;; Remove subtrees that are commented + (goto-char (point-min)) + (setq case-fold-search nil) + (while (re-search-forward re-commented nil t) + (goto-char (match-beginning 0)) + (delete-region (point) (org-end-of-subtree t))))) + +(defun org-export-handle-comments (commentsp) + "Remove comments, or convert to backend-specific format. +COMMENTSP can be a format string for publishing comments. +When it is nil, all comments will be removed." + (let ((re "^\\(#\\|[ \t]*#\\+ \\)\\(.*\n?\\)") + pos) + (goto-char (point-min)) + (while (or (looking-at re) + (re-search-forward re nil t)) + (setq pos (match-beginning 0)) + (if (get-text-property pos 'org-protected) + (goto-char (1+ pos)) + (if (and commentsp + (not (equal (char-before (match-end 1)) ?+))) + (progn (add-text-properties + (match-beginning 0) (match-end 0) '(org-protected t)) + (replace-match (format commentsp (match-string 2)) t t)) + (goto-char (1+ pos)) + (replace-match "") + (goto-char (max (point-min) (1- pos)))))))) + +(defun org-export-handle-table-metalines () + "Remove table specific metalines #+TBLNAME: and #+TBLFM:." + (let ((re "^[ \t]*#\\+TBL\\(NAME\\|FM\\):\\(.*\n?\\)") + pos) + (goto-char (point-min)) + (while (or (looking-at re) + (re-search-forward re nil t)) + (setq pos (match-beginning 0)) + (if (get-text-property (match-beginning 1) 'org-protected) + (goto-char (1+ pos)) + (goto-char (1+ pos)) + (replace-match "") + (goto-char (max (point-min) (1- pos))))))) + +(defun org-export-mark-radio-links () + "Find all matches for radio targets and turn them into internal links." + (let ((re-radio (and org-target-link-regexp + (concat "\\([^<]\\)\\(" org-target-link-regexp "\\)")))) + (goto-char (point-min)) + (when re-radio + (while (re-search-forward re-radio nil t) + (unless + (save-match-data + (or (org-in-regexp org-bracket-link-regexp) + (org-in-regexp org-plain-link-re) + (org-in-regexp "<<[^<>]+>>"))) + (org-if-unprotected + (replace-match "\\1[[\\2]]"))))))) + +(defun org-store-forced-table-alignment () + "Find table lines which force alignment, store the results in properties." + (let (line cnt aligns) + (goto-char (point-min)) + (while (re-search-forward "|[ \t]*<[lrc][0-9]*>[ \t]*|" nil t) + ;; OK, this looks like a table line with an alignment cookie + (org-if-unprotected + (setq line (buffer-substring (point-at-bol) (point-at-eol))) + (when (and (org-at-table-p) + (org-table-cookie-line-p line)) + (setq cnt 0 aligns nil) + (mapc + (lambda (x) + (setq cnt (1+ cnt)) + (if (string-match "\\`<\\([lrc]\\)" x) + (push (cons cnt (downcase (match-string 1 x))) aligns))) + (org-split-string line "[ \t]*|[ \t]*")) + (add-text-properties (org-table-begin) (org-table-end) + (list 'org-forced-aligns aligns)))) + (goto-char (point-at-eol))))) + +(defun org-export-remove-special-table-lines () + "Remove tables lines that are used for internal purposes. +Also, store forcedalignment information found in such lines." + (goto-char (point-min)) + (while (re-search-forward "^[ \t]*|" nil t) + (org-if-unprotected-at (1- (point)) + (beginning-of-line 1) + (if (or (looking-at "[ \t]*| *[!_^] *|") + (not + (memq + nil + (mapcar + (lambda (f) + (or (= (length f) 0) + (string-match + "\\`<\\([0-9]\\|[lrc]\\|[lrc][0-9]+\\)>\\'" f))) + (org-split-string ;; FIXME, can't we do without splitting??? + (buffer-substring (point-at-bol) (point-at-eol)) + "[ \t]*|[ \t]*"))))) + (delete-region (max (point-min) (1- (point-at-bol))) + (point-at-eol)) + (end-of-line 1))))) + +(defun org-export-protect-sub-super (s) + (save-match-data + (while (string-match "\\([^\\\\]\\)\\([_^]\\)" s) + (setq s (replace-match "\\1\\\\\\2" nil nil s))) + s)) + +(defun org-export-normalize-links () + "Convert all links to bracket links, and expand link abbreviations." + (let ((re-plain-link (concat "\\([^[<]\\)" org-plain-link-re)) + (re-angle-link (concat "\\([^[]\\)" org-angle-link-re)) + nodesc) + (goto-char (point-min)) + (while (re-search-forward re-plain-link nil t) + (unless (org-string-match-p + "\\[\\[\\S+:\\S-*?\\<" + (buffer-substring (point-at-bol) (match-beginning 0))) + (goto-char (1- (match-end 0))) + (org-if-unprotected-at (1+ (match-beginning 0)) + (let* ((s (concat (match-string 1) + "[[" (match-string 2) ":" (match-string 3) + "][" (match-string 2) ":" (org-export-protect-sub-super + (match-string 3)) + "]]"))) + ;; added 'org-link face to links + (put-text-property 0 (length s) 'face 'org-link s) + (replace-match s t t))))) + (goto-char (point-min)) + (while (re-search-forward re-angle-link nil t) + (goto-char (1- (match-end 0))) + (org-if-unprotected + (let* ((s (concat (match-string 1) + "[[" (match-string 2) ":" (match-string 3) + "][" (match-string 2) ":" (org-export-protect-sub-super + (match-string 3)) + "]]"))) + (put-text-property 0 (length s) 'face 'org-link s) + (replace-match s t t)))) + (goto-char (point-min)) + (while (re-search-forward org-bracket-link-regexp nil t) + (goto-char (1- (match-end 0))) + (setq nodesc (not (match-end 3))) + (org-if-unprotected + (let* ((xx (save-match-data + (org-translate-link + (org-link-expand-abbrev (match-string 1))))) + (s (concat + "[[" (org-add-props (copy-sequence xx) + nil 'org-protected t 'org-no-description nodesc) + "]" + (if (match-end 3) + (match-string 2) + (concat "[" (copy-sequence xx) + "]")) + "]"))) + (put-text-property 0 (length s) 'face 'org-link s) + (replace-match s t t)))))) + +(defun org-export-concatenate-multiline-links () + "Find multi-line links and put it all into a single line. +This is to make sure that the line-processing export backends +can work correctly." + (goto-char (point-min)) + (while (re-search-forward "\\(\\(\\[\\|\\]\\)\\[[^]]*?\\)[ \t]*\n[ \t]*\\([^]]*\\]\\(\\[\\|\\]\\)\\)" nil t) + (org-if-unprotected-at (match-beginning 1) + (replace-match "\\1 \\3") + (goto-char (match-beginning 0))))) + +(defun org-export-concatenate-multiline-emphasis () + "Find multi-line emphasis and put it all into a single line. +This is to make sure that the line-processing export backends +can work correctly." + (goto-char (point-min)) + (while (re-search-forward org-emph-re nil t) + (if (and (not (= (char-after (match-beginning 3)) + (char-after (match-beginning 4)))) + (save-excursion (goto-char (match-beginning 0)) + (save-match-data + (and (not (org-at-table-p)) + (not (org-at-heading-p)))))) + (org-if-unprotected + (subst-char-in-region (match-beginning 0) (match-end 0) + ?\n ?\ t) + (goto-char (1- (match-end 0)))) + (goto-char (1+ (match-beginning 0)))))) + +(defun org-export-grab-title-from-buffer () + "Get a title for the current document, from looking at the buffer." + (let ((inhibit-read-only t)) + (save-excursion + (goto-char (point-min)) + (let ((end (if (looking-at org-outline-regexp) + (point) + (save-excursion (outline-next-heading) (point))))) + (when (re-search-forward "^[ \t]*[^|# \t\r\n].*\n" end t) + ;; Mark the line so that it will not be exported as normal text. + (org-unmodified + (add-text-properties (match-beginning 0) (match-end 0) + (list :org-license-to-kill t))) + ;; Return the title string + (org-trim (match-string 0))))))) + +(defun org-export-get-title-from-subtree () + "Return subtree title and exclude it from export." + (let (title (rbeg (region-beginning)) (rend (region-end))) + (save-excursion + (goto-char rbeg) + (when (and (org-at-heading-p) + (>= (org-end-of-subtree t t) rend)) + ;; This is a subtree, we take the title from the first heading + (goto-char rbeg) + (looking-at org-todo-line-regexp) + (setq title (match-string 3)) + (org-unmodified + (add-text-properties (point) (1+ (point-at-eol)) + (list :org-license-to-kill t))) + (setq title (or (org-entry-get nil "EXPORT_TITLE") title)))) + title)) + +(defun org-solidify-link-text (s &optional alist) + "Take link text and make a safe target out of it." + (save-match-data + (let* ((rtn + (mapconcat + 'identity + (org-split-string s "[ \t\r\n]+") "==")) + (a (assoc rtn alist))) + (or (cdr a) rtn)))) + +(defun org-get-min-level (lines &optional offset) + "Get the minimum level in LINES." + (let ((re "^\\(\\*+\\) ") l) + (catch 'exit + (while (setq l (pop lines)) + (if (string-match re l) + (throw 'exit (org-tr-level (- (length (match-string 1 l)) + (or offset 0)))))) + 1))) + +;; Variable holding the vector with section numbers +(defvar org-section-numbers (make-vector org-level-max 0)) + +(defun org-init-section-numbers () + "Initialize the vector for the section numbers." + (let* ((level -1) + (numbers (nreverse (org-split-string "" "\\."))) + (depth (1- (length org-section-numbers))) + (i depth) number-string) + (while (>= i 0) + (if (> i level) + (aset org-section-numbers i 0) + (setq number-string (or (car numbers) "0")) + (if (string-match "\\`[A-Z]\\'" number-string) + (aset org-section-numbers i + (- (string-to-char number-string) ?A -1)) + (aset org-section-numbers i (string-to-number number-string))) + (pop numbers)) + (setq i (1- i))))) + +(defun org-section-number (&optional level) + "Return a string with the current section number. +When LEVEL is non-nil, increase section numbers on that level." + (let* ((depth (1- (length org-section-numbers))) + (string "") + (fmts (car org-export-section-number-format)) + (term (cdr org-export-section-number-format)) + (sep "") + ctype fmt idx n) + (when level + (when (> level -1) + (aset org-section-numbers + level (1+ (aref org-section-numbers level)))) + (setq idx (1+ level)) + (while (<= idx depth) + (if (not (= idx 1)) + (aset org-section-numbers idx 0)) + (setq idx (1+ idx)))) + (setq idx 0) + (while (<= idx depth) + (when (> (aref org-section-numbers idx) 0) + (setq fmt (or (pop fmts) fmt) + ctype (car fmt) + n (aref org-section-numbers idx) + string (if (> n 0) + (concat string sep (org-number-to-counter n ctype)) + (concat string ".0")) + sep (nth 1 fmt))) + (setq idx (1+ idx))) + (save-match-data + (if (string-match "\\`\\([@0]\\.\\)+" string) + (setq string (replace-match "" t nil string))) + (if (string-match "\\(\\.0\\)+\\'" string) + (setq string (replace-match "" t nil string)))) + (concat string term))) + +(defun org-number-to-counter (n type) + "Concert number N to a string counter, according to TYPE. +TYPE must be a string, any of: + 1 number + A A,B,.... + a a,b,.... + I upper case roman numeral + i lower case roman numeral" + (cond + ((equal type "1") (number-to-string n)) + ((equal type "A") (char-to-string (+ ?A n -1))) + ((equal type "a") (char-to-string (+ ?a n -1))) + ((equal type "I") (org-number-to-roman n)) + ((equal type "i") (downcase (org-number-to-roman n))) + (t (error "Invalid counter type `%s'" type)))) + +(defun org-number-to-roman (n) + "Convert integer N into a roman numeral." + (let ((roman '((1000 . "M") (900 . "CM") (500 . "D") (400 . "CD") + ( 100 . "C") ( 90 . "XC") ( 50 . "L") ( 40 . "XL") + ( 10 . "X") ( 9 . "IX") ( 5 . "V") ( 4 . "IV") + ( 1 . "I"))) + (res "")) + (if (<= n 0) + (number-to-string n) + (while roman + (if (>= n (caar roman)) + (setq n (- n (caar roman)) + res (concat res (cdar roman))) + (pop roman))) + res))) + +;;; Macros + +(defun org-export-preprocess-apply-macros () + "Replace macro references." + (goto-char (point-min)) + (let (sy val key args args2 s n) + (while (re-search-forward + "{{{\\([a-zA-Z][-a-zA-Z0-9_]*\\)\\(([ \t\n]*\\([^\000]*?\\))\\)?}}}" + nil t) + (unless (save-match-data + (save-excursion + (goto-char (point-at-bol)) + (looking-at "[ \t]*#\\+macro"))) + (setq key (downcase (match-string 1)) + args (match-string 3)) + (when (setq val (or (plist-get org-export-opt-plist + (intern (concat ":macro-" key))) + (plist-get org-export-opt-plist + (intern (concat ":" key))))) + (save-match-data + (when args + (setq args (org-split-string args ",") args2 nil) + (while args + (while (string-match "\\\\\\'" (car args)) + ;; repair bad splits + (setcar (cdr args) (concat (substring (car args) 0 -1) + "," (nth 1 args))) + (pop args)) + (push (pop args) args2)) + (setq args (mapcar 'org-trim (nreverse args2))) + (setq s 0) + (while (string-match "\\$\\([0-9]+\\)" val s) + (setq s (1+ (match-beginning 0)) + n (string-to-number (match-string 1 val))) + (and (>= (length args) n) + (setq val (replace-match (nth (1- n) args) t t val))))) + (when (string-match "\\`(eval\\>" val) + (setq val (eval (read val)))) + (if (and val (not (stringp val))) + (setq val (format "%s" val)))) + (and (stringp val) + (prog1 (replace-match val t t) + (goto-char (match-beginning 0))))))))) + +(defun org-export-apply-macros-in-string (s) + "Apply the macros in string S." + (when s + (with-temp-buffer + (insert s) + (org-export-preprocess-apply-macros) + (buffer-string)))) + +;;; Include files + +(defun org-export-handle-include-files () + "Include the contents of include files, with proper formatting." + (let ((case-fold-search t) + params file markup lang start end prefix prefix1 switches all minlevel) + (goto-char (point-min)) + (while (re-search-forward "^#\\+INCLUDE:?[ \t]+\\(.*\\)" nil t) + (setq params (read (concat "(" (match-string 1) ")")) + prefix (org-get-and-remove-property 'params :prefix) + prefix1 (org-get-and-remove-property 'params :prefix1) + minlevel (org-get-and-remove-property 'params :minlevel) + file (org-symname-or-string (pop params)) + markup (org-symname-or-string (pop params)) + lang (and (member markup '("src" "SRC")) + (org-symname-or-string (pop params))) + switches (mapconcat '(lambda (x) (format "%s" x)) params " ") + start nil end nil) + (delete-region (match-beginning 0) (match-end 0)) + (if (or (not file) + (not (file-exists-p file)) + (not (file-readable-p file))) + (insert (format "CANNOT INCLUDE FILE %s" file)) + (setq all (cons file all)) + (when markup + (if (equal (downcase markup) "src") + (setq start (format "#+begin_src %s %s\n" + (or lang "fundamental") + (or switches "")) + end "#+end_src") + (setq start (format "#+begin_%s %s\n" markup switches) + end (format "#+end_%s" markup)))) + (insert (or start "")) + (insert (org-get-file-contents (expand-file-name file) + prefix prefix1 markup minlevel)) + (or (bolp) (newline)) + (insert (or end "")))) + all)) + +(defun org-export-handle-include-files-recurse () + "Recursively include files aborting on circular inclusion." + (let ((now (list org-current-export-file)) all) + (while now + (setq all (append now all)) + (setq now (org-export-handle-include-files)) + (let ((intersection + (delq nil + (mapcar (lambda (el) (when (member el all) el)) now)))) + (when intersection + (error "Recursive #+INCLUDE: %S" intersection)))))) + +(defun org-get-file-contents (file &optional prefix prefix1 markup minlevel) + "Get the contents of FILE and return them as a string. +If PREFIX is a string, prepend it to each line. If PREFIX1 +is a string, prepend it to the first line instead of PREFIX. +If MARKUP, don't protect org-like lines, the exporter will +take care of the block they are in." + (if (stringp markup) (setq markup (downcase markup))) + (with-temp-buffer + (insert-file-contents file) + (when (or prefix prefix1) + (goto-char (point-min)) + (while (not (eobp)) + (insert (or prefix1 prefix)) + (setq prefix1 "") + (beginning-of-line 2))) + (buffer-string) + (when (member markup '("src" "example")) + (goto-char (point-min)) + (while (re-search-forward "^\\([*#]\\|[ \t]*#\\+\\)" nil t) + (goto-char (match-beginning 0)) + (insert ",") + (end-of-line 1))) + (when minlevel + (dotimes (lvl minlevel) + (org-map-region 'org-demote (point-min) (point-max)))) + (buffer-string))) + +(defun org-get-and-remove-property (listvar prop) + "Check if the value of LISTVAR contains PROP as a property. +If yes, return the value of that property (i.e. the element following +in the list) and remove property and value from the list in LISTVAR." + (let ((list (symbol-value listvar)) m v) + (when (setq m (member prop list)) + (setq v (nth 1 m)) + (if (equal (car list) prop) + (set listvar (cddr list)) + (setcdr (nthcdr (- (length list) (length m) 1) list) + (cddr m)) + (set listvar list))) + v)) + +(defun org-symname-or-string (s) + (if (symbolp s) + (if s (symbol-name s) s) + s)) + +;;; Fontification and line numbers for code examples + +(defvar org-export-last-code-line-counter-value 0) + +(defun org-export-replace-src-segments-and-examples (backend) + "Replace source code segments with special code for export." + (setq org-export-last-code-line-counter-value 0) + (let ((case-fold-search t) + lang code trans opts indent caption) + (goto-char (point-min)) + (while (re-search-forward + "\\(^\\([ \t]*\\)#\\+BEGIN_SRC:?\\([ \t]+\\([^ \t\n]+\\)\\)?\\(.*\\)\n\\([^\000]+?\n\\)[ \t]*#\\+END_SRC.*\n?\\)\\|\\(^\\([ \t]*\\)#\\+BEGIN_EXAMPLE:?\\(?:[ \t]+\\(.*\\)\\)?\n\\([^\000]+?\n\\)[ \t]*#\\+END_EXAMPLE.*\n?\\)" + nil t) + (if (match-end 1) + (if (not (match-string 4)) + (error "Source block missing language specification: %s" + (let* ((body (match-string 6)) + (nothing (message "body:%s" body)) + (preview (or (and (string-match + "^[ \t]*\\([^\n\r]*\\)" body) + (match-string 1 body)) body))) + (if (> (length preview) 35) + (concat (substring preview 0 32) "...") + preview))) + ;; src segments + (setq lang (match-string 4) + opts (match-string 5) + code (match-string 6) + indent (length (match-string 2)) + caption (get-text-property 0 'org-caption (match-string 0)))) + (setq lang nil + opts (match-string 9) + code (match-string 10) + indent (length (match-string 8)) + caption (get-text-property 0 'org-caption (match-string 0)))) + + (setq trans (org-export-format-source-code-or-example + backend lang code opts indent caption)) + (replace-match trans t t)))) + +(defvar htmlp) ;; dynamically scoped +(defvar latexp) ;; dynamically scoped +(defvar org-export-latex-verbatim-wrap) ;; defined in org-latex.el +(defvar org-export-latex-listings) ;; defined in org-latex.el +(defvar org-export-latex-listings-langs) ;; defined in org-latex.el +(defvar org-export-latex-listings-w-names) ;; defined in org-latex.el +(defvar org-export-latex-minted-langs) ;; defined in org-latex.el +(defun org-export-format-source-code-or-example + (backend lang code &optional opts indent caption) + "Format CODE from language LANG and return it formatted for export. +If LANG is nil, do not add any fontification. +OPTS contains formatting options, like `-n' for triggering numbering lines, +and `+n' for continuing previous numbering. +Code formatting according to language currently only works for HTML. +Numbering lines works for all three major backends (html, latex, and ascii). +INDENT was the original indentation of the block." + (save-match-data + (let (num cont rtn rpllbl keepp textareap preserve-indentp cols rows fmt) + (setq opts (or opts "") + num (string-match "[-+]n\\>" opts) + cont (string-match "\\+n\\>" opts) + rpllbl (string-match "-r\\>" opts) + keepp (string-match "-k\\>" opts) + textareap (string-match "-t\\>" opts) + preserve-indentp (or org-src-preserve-indentation + (string-match "-i\\>" opts)) + cols (if (string-match "-w[ \t]+\\([0-9]+\\)" opts) + (string-to-number (match-string 1 opts)) + 80) + rows (if (string-match "-h[ \t]+\\([0-9]+\\)" opts) + (string-to-number (match-string 1 opts)) + (org-count-lines code)) + fmt (if (string-match "-l[ \t]+\"\\([^\"\n]+\\)\"" opts) + (match-string 1 opts))) + (when (and textareap (eq backend 'html)) + ;; we cannot use numbering or highlighting. + (setq num nil cont nil lang nil)) + (if keepp (setq rpllbl 'keep)) + (setq rtn (if preserve-indentp code (org-remove-indentation code))) + (when (string-match "^," rtn) + (setq rtn (with-temp-buffer + (insert rtn) + ;; Free up the protected lines + (goto-char (point-min)) + (while (re-search-forward "^," nil t) + (if (or (equal lang "org") + (save-match-data + (looking-at "\\([*#]\\|[ \t]*#\\+\\)"))) + (replace-match "")) + (end-of-line 1)) + (buffer-string)))) + ;; Now backend-specific coding + (setq rtn + (cond + ((eq backend 'docbook) + (setq rtn (org-export-number-lines rtn 'docbook 0 0 num cont rpllbl fmt)) + (concat "\n#+BEGIN_DOCBOOK\n" + (org-add-props (concat "<programlisting><![CDATA[" + rtn + "]]></programlisting>\n") + '(org-protected t org-example t)) + "#+END_DOCBOOK\n")) + ((eq backend 'html) + ;; We are exporting to HTML + (when lang + (if (featurep 'xemacs) + (require 'htmlize) + (require 'htmlize nil t)) + (when (not (fboundp 'htmlize-region-for-paste)) + ;; we do not have htmlize.el, or an old version of it + (setq lang nil) + (message + "htmlize.el 1.34 or later is needed for source code formatting"))) + + (if lang + (let* ((lang-m (when lang + (or (cdr (assoc lang org-src-lang-modes)) + lang))) + (mode (and lang-m (intern + (concat + (if (symbolp lang-m) + (symbol-name lang-m) + lang-m) + "-mode")))) + (org-inhibit-startup t) + (org-startup-folded nil)) + (setq rtn + (with-temp-buffer + (insert rtn) + (if (functionp mode) + (funcall mode) + (fundamental-mode)) + (font-lock-fontify-buffer) + (org-src-mode) + (set-buffer-modified-p nil) + (org-export-htmlize-region-for-paste + (point-min) (point-max)))) + (if (string-match "<pre\\([^>]*\\)>\n*" rtn) + (setq rtn + (concat + (if caption + (concat + "<div class=\"org-src-container\">" + (format + "<label class=\"org-src-name\">%s</label>" + caption)) + "") + (replace-match + (format "<pre class=\"src src-%s\">\n" lang) + t t rtn) + (if caption "</div>" ""))))) + (if textareap + (setq rtn (concat + (format "<p>\n<textarea cols=\"%d\" rows=\"%d\">" + cols rows) + rtn "</textarea>\n</p>\n")) + (with-temp-buffer + (insert rtn) + (goto-char (point-min)) + (while (re-search-forward "[<>&]" nil t) + (replace-match (cdr (assq (char-before) + '((?&."&")(?<."<")(?>.">")))) + t t)) + (setq rtn (buffer-string))) + (setq rtn (concat "<pre class=\"example\">\n" rtn "</pre>\n")))) + (unless textareap + (setq rtn (org-export-number-lines rtn 'html 1 1 num + cont rpllbl fmt))) + (if (string-match "\\(\\`<[^>]*>\\)\n" rtn) + (setq rtn (replace-match "\\1" t nil rtn))) + (concat "\n#+BEGIN_HTML\n" (org-add-props rtn '(org-protected t org-example t)) "\n#+END_HTML\n\n")) + ((eq backend 'latex) + (setq rtn (org-export-number-lines rtn 'latex 0 0 num cont rpllbl fmt)) + (concat "#+BEGIN_LaTeX\n" + (org-add-props + (cond + ((and org-export-latex-listings + (not (eq org-export-latex-listings 'minted))) + (concat + (if lang + (let* + ((lang-sym (intern lang)) + (lstlang + (or (cadr + (assq + lang-sym + org-export-latex-listings-langs)) + lang))) + (format "\\lstset{language=%s}\n" lstlang)) + "\n") + (when (and caption + org-export-latex-listings-w-names) + (format "\n%s $\\equiv$ \n" + (replace-regexp-in-string + "_" "\\\\_" caption))) + "\\begin{lstlisting}\n" + rtn "\\end{lstlisting}\n")) + ((eq org-export-latex-listings 'minted) + (if lang + (let* + ((lang-sym (intern lang)) + (minted-lang + (or (cadr + (assq + lang-sym + org-export-latex-minted-langs)) + (downcase lang)))) + (concat + (when (and caption + org-export-latex-listings-w-names) + (format "\n%s $\\equiv$ \n" + (replace-regexp-in-string + "_" "\\\\_" caption))) + (format "\\begin{minted}{%s}\n" minted-lang) + rtn "\\end{minted}\n")))) + (t (concat (car org-export-latex-verbatim-wrap) + rtn (cdr org-export-latex-verbatim-wrap)))) + '(org-protected t org-example t)) + "#+END_LaTeX\n")) + ((eq backend 'ascii) + ;; This is not HTML or LaTeX, so just make it an example. + (setq rtn (org-export-number-lines rtn 'ascii 0 0 num cont rpllbl fmt)) + (concat caption "\n" + "#+BEGIN_ASCII\n" + (org-add-props + (concat + (mapconcat + (lambda (l) (concat " " l)) + (org-split-string rtn "\n") + "\n") + "\n") + '(org-protected t org-example t)) + "#+END_ASCII\n")))) + (org-add-props rtn nil 'original-indentation indent)))) + +(defun org-export-number-lines (text backend + &optional skip1 skip2 number cont + replace-labels label-format) + (setq skip1 (or skip1 0) skip2 (or skip2 0)) + (if (not cont) (setq org-export-last-code-line-counter-value 0)) + (with-temp-buffer + (insert text) + (goto-char (point-max)) + (skip-chars-backward " \t\n\r") + (delete-region (point) (point-max)) + (beginning-of-line (- 1 skip2)) + (let* ((last (org-current-line)) + (n org-export-last-code-line-counter-value) + (nmax (+ n (- last skip1))) + (fmt (format "%%%dd: " (length (number-to-string nmax)))) + (fm + (cond + ((eq backend 'html) (format "<span class=\"linenr\">%s</span>" + fmt)) + ((eq backend 'ascii) fmt) + ((eq backend 'latex) fmt) + ((eq backend 'docbook) fmt) + (t ""))) + (label-format (or label-format org-coderef-label-format)) + (label-pre (if (string-match "%s" label-format) + (substring label-format 0 (match-beginning 0)) + label-format)) + (label-post (if (string-match "%s" label-format) + (substring label-format (match-end 0)) + "")) + (lbl-re + (concat + ".*?\\S-.*?\\([ \t]*\\(" + (regexp-quote label-pre) + "\\([-a-zA-Z0-9_ ]+\\)" + (regexp-quote label-post) + "\\)\\)")) + ref) + + (org-goto-line (1+ skip1)) + (while (and (re-search-forward "^" nil t) (not (eobp)) (< n nmax)) + (if number + (insert (format fm (incf n))) + (forward-char 1)) + (when (looking-at lbl-re) + (setq ref (match-string 3)) + (cond ((numberp replace-labels) + ;; remove labels; use numbers for references when lines + ;; are numbered, use labels otherwise + (delete-region (match-beginning 1) (match-end 1)) + (push (cons ref (if (> n 0) n ref)) org-export-code-refs)) + ((eq replace-labels 'keep) + ;; don't remove labels; use numbers for references when + ;; lines are numbered, use labels otherwise + (goto-char (match-beginning 2)) + (delete-region (match-beginning 2) (match-end 2)) + (insert "(" ref ")") + (push (cons ref (if (> n 0) n (concat "(" ref ")"))) + org-export-code-refs)) + (t + ;; don't remove labels and don't use numbers for + ;; references + (goto-char (match-beginning 2)) + (delete-region (match-beginning 2) (match-end 2)) + (insert "(" ref ")") + (push (cons ref (concat "(" ref ")")) org-export-code-refs))) + (when (eq backend 'html) + (save-excursion + (beginning-of-line 1) + (insert (format "<span id=\"coderef-%s\" class=\"coderef-off\">" + ref)) + (end-of-line 1) + (insert "</span>"))))) + (setq org-export-last-code-line-counter-value n) + (goto-char (point-max)) + (newline) + (buffer-string)))) + +(defun org-search-todo-below (line lines level) + "Search the subtree below LINE for any TODO entries." + (let ((rest (cdr (memq line lines))) + (re org-todo-line-regexp) + line lv todo) + (catch 'exit + (while (setq line (pop rest)) + (if (string-match re line) + (progn + (setq lv (- (match-end 1) (match-beginning 1)) + todo (and (match-beginning 2) + (not (member (match-string 2 line) + org-done-keywords)))) + ; TODO, not DONE + (if (<= lv level) (throw 'exit nil)) + (if todo (throw 'exit t)))))))) + +;;;###autoload +(defun org-export-visible (type arg) + "Create a copy of the visible part of the current buffer, and export it. +The copy is created in a temporary buffer and removed after use. +TYPE is the final key (as a string) that also selects the export command in +the \\<org-mode-map>\\[org-export] export dispatcher. +As a special case, if the you type SPC at the prompt, the temporary +org-mode file will not be removed but presented to you so that you can +continue to use it. The prefix arg ARG is passed through to the exporting +command." + (interactive + (list (progn + (message "Export visible: [a]SCII [h]tml [b]rowse HTML [H/R]buffer with HTML [D]ocBook [l]atex [p]df [d]view pdf [L]atex buffer [x]OXO [ ]keep buffer") + (read-char-exclusive)) + current-prefix-arg)) + (if (not (member type '(?a ?n ?u ?\C-a ?b ?\C-b ?h ?D ?x ?\ ?l ?p ?d ?L))) + (error "Invalid export key")) + (let* ((binding (cdr (assoc type + '( + (?a . org-export-as-ascii) + (?A . org-export-as-ascii-to-buffer) + (?n . org-export-as-latin1) + (?N . org-export-as-latin1-to-buffer) + (?u . org-export-as-utf8) + (?U . org-export-as-utf8-to-buffer) + (?\C-a . org-export-as-ascii) + (?b . org-export-as-html-and-open) + (?\C-b . org-export-as-html-and-open) + (?h . org-export-as-html) + (?H . org-export-as-html-to-buffer) + (?R . org-export-region-as-html) + (?D . org-export-as-docbook) + + (?l . org-export-as-latex) + (?p . org-export-as-pdf) + (?d . org-export-as-pdf-and-open) + (?L . org-export-as-latex-to-buffer) + + (?x . org-export-as-xoxo))))) + (keepp (equal type ?\ )) + (file buffer-file-name) + (buffer (get-buffer-create "*Org Export Visible*")) + s e) + ;; Need to hack the drawers here. + (save-excursion + (goto-char (point-min)) + (while (re-search-forward org-drawer-regexp nil t) + (goto-char (match-beginning 1)) + (or (org-invisible-p) (org-flag-drawer nil)))) + (with-current-buffer buffer (erase-buffer)) + (save-excursion + (setq s (goto-char (point-min))) + (while (not (= (point) (point-max))) + (goto-char (org-find-invisible)) + (append-to-buffer buffer s (point)) + (setq s (goto-char (org-find-visible)))) + (org-cycle-hide-drawers 'all) + (goto-char (point-min)) + (unless keepp + ;; Copy all comment lines to the end, to make sure #+ settings are + ;; still available for the second export step. Kind of a hack, but + ;; does do the trick. + (if (looking-at "#[^\r\n]*") + (append-to-buffer buffer (match-beginning 0) (1+ (match-end 0)))) + (when (re-search-forward "^\\*+[ \t]+" nil t) + (while (re-search-backward "[\n\r]#[^\n\r]*" nil t) + (append-to-buffer buffer (1+ (match-beginning 0)) + (min (point-max) (1+ (match-end 0))))))) + (set-buffer buffer) + (let ((buffer-file-name file) + (org-inhibit-startup t)) + (org-mode) + (show-all) + (unless keepp (funcall binding arg)))) + (if (not keepp) + (kill-buffer buffer) + (switch-to-buffer-other-window buffer) + (goto-char (point-min))))) + +(defun org-find-visible () + (let ((s (point))) + (while (and (not (= (point-max) (setq s (next-overlay-change s)))) + (get-char-property s 'invisible))) + s)) +(defun org-find-invisible () + (let ((s (point))) + (while (and (not (= (point-max) (setq s (next-overlay-change s)))) + (not (get-char-property s 'invisible)))) + s)) + +(defvar org-export-htmlized-org-css-url) ;; defined in org-html.el + +(defun org-export-string (string fmt &optional dir) + "Export STRING to FMT using existing export facilities. +During export STRING is saved to a temporary file whose location +could vary. Optional argument DIR can be used to force the +directory in which the temporary file is created during export +which can be useful for resolving relative paths. Dir defaults +to the value of `temporary-file-directory'." + (let ((temporary-file-directory (or dir temporary-file-directory)) + (tmp-file (make-temp-file "org-"))) + (unwind-protect + (with-temp-buffer + (insert string) + (write-file tmp-file) + (org-load-modules-maybe) + (unless org-local-vars + (setq org-local-vars (org-get-local-variables))) + (eval ;; convert to fmt -- mimicing `org-run-like-in-org-mode' + (list 'let org-local-vars + (list (intern (concat "org-export-as-" fmt)) + nil nil nil ''string t)))) + (delete-file tmp-file)))) + +;;;###autoload +(defun org-export-as-org (arg &optional hidden ext-plist + to-buffer body-only pub-dir) + "Make a copy with not-exporting stuff removed. +The purpose of this function is to provide a way to export the source +Org file of a webpage in Org format, but with sensitive and/or irrelevant +stuff removed. This command will remove the following: + +- archived trees (if the variable `org-export-with-archived-trees' is nil) +- comment blocks and trees starting with the COMMENT keyword +- only trees that are consistent with `org-export-select-tags' + and `org-export-exclude-tags'. + +The only arguments that will be used are EXT-PLIST and PUB-DIR, +all the others will be ignored (but are present so that the general +mechanism to call publishing functions will work). + +EXT-PLIST is a property list with external parameters overriding +org-mode's default settings, but still inferior to file-local +settings. When PUB-DIR is set, use this as the publishing +directory." + (interactive "P") + (let* ((opt-plist (org-combine-plists (org-default-export-plist) + ext-plist + (org-infile-export-plist))) + (bfname (buffer-file-name (or (buffer-base-buffer) (current-buffer)))) + (filename (concat (file-name-as-directory + (or pub-dir + (org-export-directory :org opt-plist))) + (file-name-sans-extension + (file-name-nondirectory bfname)) + ".org")) + (filename (and filename + (if (equal (file-truename filename) + (file-truename bfname)) + (concat (file-name-sans-extension filename) + "-source." + (file-name-extension filename)) + filename))) + (backup-inhibited t) + (buffer (find-file-noselect filename)) + (region (buffer-string)) + str-ret) + (save-excursion + (switch-to-buffer buffer) + (erase-buffer) + (insert region) + (let ((org-inhibit-startup t)) (org-mode)) + (org-install-letbind) + + ;; Get rid of archived trees + (org-export-remove-archived-trees (plist-get opt-plist :archived-trees)) + + ;; Remove comment environment and comment subtrees + (org-export-remove-comment-blocks-and-subtrees) + + ;; Get rid of excluded trees + (org-export-handle-export-tags (plist-get opt-plist :select-tags) + (plist-get opt-plist :exclude-tags)) + + (when (or (plist-get opt-plist :plain-source) + (not (or (plist-get opt-plist :plain-source) + (plist-get opt-plist :htmlized-source)))) + ;; Either nothing special is requested (default call) + ;; or the plain source is explicitly requested + ;; so: save it + (save-buffer)) + (when (plist-get opt-plist :htmlized-source) + ;; Make the htmlized version + (require 'htmlize) + (require 'org-html) + (font-lock-fontify-buffer) + (let* ((htmlize-output-type 'css) + (newbuf (htmlize-buffer))) + (with-current-buffer newbuf + (when org-export-htmlized-org-css-url + (goto-char (point-min)) + (and (re-search-forward + "<style type=\"text/css\">[^\000]*?\n[ \t]*</style>.*" + nil t) + (replace-match + (format + "<link rel=\"stylesheet\" type=\"text/css\" href=\"%s\">" + org-export-htmlized-org-css-url) + t t))) + (write-file (concat filename ".html"))) + (kill-buffer newbuf))) + (set-buffer-modified-p nil) + (if (equal to-buffer 'string) + (progn (setq str-ret (buffer-string)) + (kill-buffer (current-buffer)) + str-ret) + (kill-buffer (current-buffer)))))) + +(defvar org-archive-location) ;; gets loaded with the org-archive require. +(defun org-get-current-options () + "Return a string with current options as keyword options. +Does include HTML export options as well as TODO and CATEGORY stuff." + (require 'org-archive) + (format + "#+TITLE: %s +#+AUTHOR: %s +#+EMAIL: %s +#+DATE: %s +#+DESCRIPTION: +#+KEYWORDS: +#+LANGUAGE: %s +#+OPTIONS: H:%d num:%s toc:%s \\n:%s @:%s ::%s |:%s ^:%s -:%s f:%s *:%s <:%s +#+OPTIONS: TeX:%s LaTeX:%s skip:%s d:%s todo:%s pri:%s tags:%s +%s +#+EXPORT_SELECT_TAGS: %s +#+EXPORT_EXCLUDE_TAGS: %s +#+LINK_UP: %s +#+LINK_HOME: %s +#+XSLT: +#+CATEGORY: %s +#+SEQ_TODO: %s +#+TYP_TODO: %s +#+PRIORITIES: %c %c %c +#+DRAWERS: %s +#+STARTUP: %s %s %s %s %s +#+TAGS: %s +#+FILETAGS: %s +#+ARCHIVE: %s +#+LINK: %s +" + (buffer-name) (user-full-name) user-mail-address + (format-time-string (substring (car org-time-stamp-formats) 1 -1)) + org-export-default-language + org-export-headline-levels + org-export-with-section-numbers + org-export-with-toc + org-export-preserve-breaks + org-export-html-expand + org-export-with-fixed-width + org-export-with-tables + org-export-with-sub-superscripts + org-export-with-special-strings + org-export-with-footnotes + org-export-with-emphasize + org-export-with-timestamps + org-export-with-TeX-macros + org-export-with-LaTeX-fragments + org-export-skip-text-before-1st-heading + org-export-with-drawers + org-export-with-todo-keywords + org-export-with-priority + org-export-with-tags + (if (featurep 'org-jsinfo) (org-infojs-options-inbuffer-template) "") + (mapconcat 'identity org-export-select-tags " ") + (mapconcat 'identity org-export-exclude-tags " ") + org-export-html-link-up + org-export-html-link-home + (or (ignore-errors + (file-name-sans-extension + (file-name-nondirectory (buffer-file-name (buffer-base-buffer))))) + "NOFILENAME") + "TODO FEEDBACK VERIFY DONE" + "Me Jason Marie DONE" + org-highest-priority org-lowest-priority org-default-priority + (mapconcat 'identity org-drawers " ") + (cdr (assoc org-startup-folded + '((nil . "showall") (t . "overview") (content . "content")))) + (if org-odd-levels-only "odd" "oddeven") + (if org-hide-leading-stars "hidestars" "showstars") + (if org-startup-align-all-tables "align" "noalign") + (cond ((eq org-log-done t) "logdone") + ((equal org-log-done 'note) "lognotedone") + ((not org-log-done) "nologdone")) + (or (mapconcat (lambda (x) + (cond + ((equal :startgroup (car x)) "{") + ((equal :endgroup (car x)) "}") + ((equal :newline (car x)) "") + ((cdr x) (format "%s(%c)" (car x) (cdr x))) + (t (car x)))) + (or org-tag-alist (org-get-buffer-tags)) " ") "") + (mapconcat 'identity org-file-tags " ") + org-archive-location + "org file:~/org/%s.org" + )) + +;;;###autoload +(defun org-insert-export-options-template () + "Insert into the buffer a template with information for exporting." + (interactive) + (if (not (bolp)) (newline)) + (let ((s (org-get-current-options))) + (and (string-match "#\\+CATEGORY" s) + (setq s (substring s 0 (match-beginning 0)))) + (insert s))) + +(defvar org-table-colgroup-info nil) + +(defun org-table-clean-before-export (lines &optional maybe-quoted) + "Check if the table has a marking column. +If yes remove the column and the special lines." + (setq org-table-colgroup-info nil) + (if (memq nil + (mapcar + (lambda (x) (or (string-match "^[ \t]*|-" x) + (string-match + (if maybe-quoted + "^[ \t]*| *\\\\?\\([\#!$*_^ /]\\) *|" + "^[ \t]*| *\\([\#!$*_^ /]\\) *|") + x))) + lines)) + ;; No special marking column + (progn + (setq org-table-clean-did-remove-column nil) + (delq nil + (mapcar + (lambda (x) + (cond + ((org-table-colgroup-line-p x) + ;; This line contains colgroup info, extract it + ;; and then discard the line + (setq org-table-colgroup-info + (mapcar (lambda (x) + (cond ((member x '("<" "<")) :start) + ((member x '(">" ">")) :end) + ((member x '("<>" "<>")) :startend) + (t nil))) + (org-split-string x "[ \t]*|[ \t]*"))) + nil) + ((org-table-cookie-line-p x) + ;; This line contains formatting cookies, discard it + nil) + (t x))) + lines))) + ;; there is a special marking column + (setq org-table-clean-did-remove-column t) + (delq nil + (mapcar + (lambda (x) + (cond + ((org-table-colgroup-line-p x) + ;; This line contains colgroup info, extract it + ;; and then discard the line + (setq org-table-colgroup-info + (mapcar (lambda (x) + (cond ((member x '("<" "<")) :start) + ((member x '(">" ">")) :end) + ((member x '("<>" "<>")) :startend) + (t nil))) + (cdr (org-split-string x "[ \t]*|[ \t]*")))) + nil) + ((org-table-cookie-line-p x) + ;; This line contains formatting cookies, discard it + nil) + ((string-match "^[ \t]*| *[!_^/] *|" x) + ;; ignore this line + nil) + ((or (string-match "^\\([ \t]*\\)|-+\\+" x) + (string-match "^\\([ \t]*\\)|[^|]*|" x)) + ;; remove the first column + (replace-match "\\1|" t nil x)))) + lines)))) + +(defun org-export-cleanup-toc-line (s) + "Remove tags and timestamps from lines going into the toc." + (when (memq org-export-with-tags '(not-in-toc nil)) + (if (string-match (org-re " +:[[:alnum:]_@#%:]+: *$") s) + (setq s (replace-match "" t t s)))) + (when org-export-remove-timestamps-from-toc + (while (string-match org-maybe-keyword-time-regexp s) + (setq s (replace-match "" t t s)))) + (while (string-match org-bracket-link-regexp s) + (setq s (replace-match (match-string (if (match-end 3) 3 1) s) + t t s))) + (while (string-match "\\[\\([0-9]\\|fn:[^]]*\\)\\]" s) + (setq s (replace-match "" t t s))) + s) + + +(defun org-get-text-property-any (pos prop &optional object) + (or (get-text-property pos prop object) + (and (setq pos (next-single-property-change pos prop object)) + (get-text-property pos prop object)))) + +(defun org-export-get-coderef-format (path desc) + (save-match-data + (if (and desc (string-match + (regexp-quote (concat "(" path ")")) + desc)) + (replace-match "%s" t t desc) + (or desc "%s")))) + +(defun org-export-push-to-kill-ring (format) + "Push buffer content to kill ring. +The depends on the variable `org-export-copy-to-kill'." + (when org-export-copy-to-kill-ring + (org-kill-new (buffer-string)) + (when (fboundp 'x-set-selection) + (ignore-errors (x-set-selection 'PRIMARY (buffer-string))) + (ignore-errors (x-set-selection 'CLIPBOARD (buffer-string)))) + (message "%s export done, pushed to kill ring and clipboard" format))) + +(provide 'org-exp) + +;; arch-tag: 65985fe9-095c-49c7-a7b6-cb4ee15c0a95 + +;;; org-exp.el ends here + diff --git a/.emacs.d/org-7.4/lisp/org-exp.elc b/.emacs.d/org-7.4/lisp/org-exp.elc Binary files differnew file mode 100644 index 0000000..3d4c686 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-exp.elc diff --git a/.emacs.d/org-7.4/lisp/org-faces.el b/.emacs.d/org-7.4/lisp/org-faces.el new file mode 100644 index 0000000..3f82457 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-faces.el @@ -0,0 +1,723 @@ +;;; org-faces.el --- Face definitions for Org-mode. + +;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010 +;; Free Software Foundation, Inc. + +;; Author: Carsten Dominik <carsten at orgmode dot org> +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; Version: 7.4 +;; +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: + +;; This file contains the face definitions for Org. + +;;; Code: + +(require 'org-macs) +(require 'org-compat) + +(defun org-copy-face (old-face new-face docstring &rest attributes) + (unless (facep new-face) + (if (fboundp 'set-face-attribute) + (progn + (make-face new-face) + (set-face-attribute new-face nil :inherit old-face) + (apply 'set-face-attribute new-face nil attributes) + (set-face-doc-string new-face docstring)) + (copy-face old-face new-face) + (if (fboundp 'set-face-doc-string) + (set-face-doc-string new-face docstring))))) +(put 'org-copy-face 'lisp-indent-function 2) + +(defgroup org-faces nil + "Faces in Org-mode." + :tag "Org Faces" + :group 'org-appearance) + +(defface org-hide + '((((background light)) (:foreground "white")) + (((background dark)) (:foreground "black"))) + "Face used to hide leading stars in headlines. +The foreground color of this face should be equal to the background +color of the frame." + :group 'org-faces) + +(defface org-level-1 ;; originally copied from font-lock-function-name-face + (org-compatible-face 'outline-1 + '((((class color) (min-colors 88) (background light)) (:foreground "Blue1")) + (((class color) (min-colors 88) (background dark)) (:foreground "LightSkyBlue")) + (((class color) (min-colors 16) (background light)) (:foreground "Blue")) + (((class color) (min-colors 16) (background dark)) (:foreground "LightSkyBlue")) + (((class color) (min-colors 8)) (:foreground "blue" :bold t)) + (t (:bold t)))) + "Face used for level 1 headlines." + :group 'org-faces) + +(defface org-level-2 ;; originally copied from font-lock-variable-name-face + (org-compatible-face 'outline-2 + '((((class color) (min-colors 16) (background light)) (:foreground "DarkGoldenrod")) + (((class color) (min-colors 16) (background dark)) (:foreground "LightGoldenrod")) + (((class color) (min-colors 8) (background light)) (:foreground "yellow")) + (((class color) (min-colors 8) (background dark)) (:foreground "yellow" :bold t)) + (t (:bold t)))) + "Face used for level 2 headlines." + :group 'org-faces) + +(defface org-level-3 ;; originally copied from font-lock-keyword-face + (org-compatible-face 'outline-3 + '((((class color) (min-colors 88) (background light)) (:foreground "Purple")) + (((class color) (min-colors 88) (background dark)) (:foreground "Cyan1")) + (((class color) (min-colors 16) (background light)) (:foreground "Purple")) + (((class color) (min-colors 16) (background dark)) (:foreground "Cyan")) + (((class color) (min-colors 8) (background light)) (:foreground "purple" :bold t)) + (((class color) (min-colors 8) (background dark)) (:foreground "cyan" :bold t)) + (t (:bold t)))) + "Face used for level 3 headlines." + :group 'org-faces) + +(defface org-level-4 ;; originally copied from font-lock-comment-face + (org-compatible-face 'outline-4 + '((((class color) (min-colors 88) (background light)) (:foreground "Firebrick")) + (((class color) (min-colors 88) (background dark)) (:foreground "chocolate1")) + (((class color) (min-colors 16) (background light)) (:foreground "red")) + (((class color) (min-colors 16) (background dark)) (:foreground "red1")) + (((class color) (min-colors 8) (background light)) (:foreground "red" :bold t)) + (((class color) (min-colors 8) (background dark)) (:foreground "red" :bold t)) + (t (:bold t)))) + "Face used for level 4 headlines." + :group 'org-faces) + +(defface org-level-5 ;; originally copied from font-lock-type-face + (org-compatible-face 'outline-5 + '((((class color) (min-colors 16) (background light)) (:foreground "ForestGreen")) + (((class color) (min-colors 16) (background dark)) (:foreground "PaleGreen")) + (((class color) (min-colors 8)) (:foreground "green")))) + "Face used for level 5 headlines." + :group 'org-faces) + +(defface org-level-6 ;; originally copied from font-lock-constant-face + (org-compatible-face 'outline-6 + '((((class color) (min-colors 16) (background light)) (:foreground "CadetBlue")) + (((class color) (min-colors 16) (background dark)) (:foreground "Aquamarine")) + (((class color) (min-colors 8)) (:foreground "magenta")))) + "Face used for level 6 headlines." + :group 'org-faces) + +(defface org-level-7 ;; originally copied from font-lock-builtin-face + (org-compatible-face 'outline-7 + '((((class color) (min-colors 16) (background light)) (:foreground "Orchid")) + (((class color) (min-colors 16) (background dark)) (:foreground "LightSteelBlue")) + (((class color) (min-colors 8)) (:foreground "blue")))) + "Face used for level 7 headlines." + :group 'org-faces) + +(defface org-level-8 ;; originally copied from font-lock-string-face + (org-compatible-face 'outline-8 + '((((class color) (min-colors 16) (background light)) (:foreground "RosyBrown")) + (((class color) (min-colors 16) (background dark)) (:foreground "LightSalmon")) + (((class color) (min-colors 8)) (:foreground "green")))) + "Face used for level 8 headlines." + :group 'org-faces) + +(defface org-special-keyword ;; originally copied from font-lock-string-face + (org-compatible-face nil + '((((class color) (min-colors 16) (background light)) (:foreground "RosyBrown")) + (((class color) (min-colors 16) (background dark)) (:foreground "LightSalmon")) + (t (:italic t)))) + "Face used for special keywords." + :group 'org-faces) + +(defface org-drawer ;; originally copied from font-lock-function-name-face + (org-compatible-face nil + '((((class color) (min-colors 88) (background light)) (:foreground "Blue1")) + (((class color) (min-colors 88) (background dark)) (:foreground "LightSkyBlue")) + (((class color) (min-colors 16) (background light)) (:foreground "Blue")) + (((class color) (min-colors 16) (background dark)) (:foreground "LightSkyBlue")) + (((class color) (min-colors 8)) (:foreground "blue" :bold t)) + (t (:bold t)))) + "Face used for drawers." + :group 'org-faces) + +(defface org-property-value nil + "Face used for the value of a property." + :group 'org-faces) + +(defface org-column + (org-compatible-face nil + '((((class color) (min-colors 16) (background light)) + (:background "grey90" :weight normal :slant normal :strike-through nil + :underline nil)) + (((class color) (min-colors 16) (background dark)) + (:background "grey30" :weight normal :slant normal :strike-through nil + :underline nil)) + (((class color) (min-colors 8)) + (:background "cyan" :foreground "black" + :weight normal :slant normal :strike-through nil + :underline nil)) + (t (:inverse-video t)))) + "Face for column display of entry properties. +This is actually only part of the face definition for the text in column view. +The following faces apply, with this priority. + +1. The color of the reference face. This is normally the level fact that + is used in the outline. In agenda-mode, it will be the face of the + first character in the line. The color is explicitly retained to + make sure that the column line still looks a bit like the structure + line it is masking. + +2. The `org-column' face. + +3. The remaining properties of the reference face. + +Since column view works by putting overlays with a display property +over individual characters in the buffer, the face of the underlining +character (this might for example be the a TODO keyword) might still +shine through in some properties. So when your column view looks +funny, with \"random\" colors, weight, strike-through, try to explicitly +set the properties in the `org-column' face. For example, set +:underline to nil, or the :slant to `normal'. + +Under XEmacs, the rules are simpler, because the XEmacs version of +column view defines special faces for each outline level. See the file +`org-colview-xemacs.el' for details." + :group 'org-faces) + +(defface org-column-title + (org-compatible-face nil + '((((class color) (min-colors 16) (background light)) + (:background "grey90" :underline t :weight bold)) + (((class color) (min-colors 16) (background dark)) + (:background "grey30" :underline t :weight bold)) + (((class color) (min-colors 8)) + (:background "cyan" :foreground "black" :underline t :weight bold)) + (t (:inverse-video t)))) + "Face for column display of entry properties." + :group 'org-faces) + +(when (fboundp 'set-face-attribute) + ;; Make sure that a fixed-width face is used when we have a column table. + (set-face-attribute 'org-column nil + :height (face-attribute 'default :height) + :family (face-attribute 'default :family))) + +(defface org-agenda-column-dateline + (org-compatible-face 'org-column + '((t nil))) + "Face used in agenda column view for datelines with summaries." + :group 'org-faces) + +(defface org-warning + (org-compatible-face 'font-lock-warning-face + '((((class color) (min-colors 16) (background light)) (:foreground "Red1" :bold t)) + (((class color) (min-colors 16) (background dark)) (:foreground "Pink" :bold t)) + (((class color) (min-colors 8) (background light)) (:foreground "red" :bold t)) + (((class color) (min-colors 8) (background dark)) (:foreground "red" :bold t)) + (t (:bold t)))) + "Face for deadlines and TODO keywords." + :group 'org-faces) + +(defface org-archived ; similar to shadow + (org-compatible-face 'shadow + '((((class color grayscale) (min-colors 88) (background light)) + (:foreground "grey50")) + (((class color grayscale) (min-colors 88) (background dark)) + (:foreground "grey70")) + (((class color) (min-colors 8) (background light)) + (:foreground "green")) + (((class color) (min-colors 8) (background dark)) + (:foreground "yellow")))) + "Face for headline with the ARCHIVE tag." + :group 'org-faces) + +(defface org-link + '((((class color) (background light)) (:foreground "Purple" :underline t)) + (((class color) (background dark)) (:foreground "Cyan" :underline t)) + (t (:underline t))) + "Face for links." + :group 'org-faces) + +(defface org-footnote + '((((class color) (background light)) (:foreground "Purple" :underline t)) + (((class color) (background dark)) (:foreground "Cyan" :underline t)) + (t (:underline t))) + "Face for links." + :group 'org-faces) + +(defface org-ellipsis + '((((class color) (background light)) (:foreground "DarkGoldenrod" :underline t)) + (((class color) (background dark)) (:foreground "LightGoldenrod" :underline t)) + (t (:strike-through t))) + "Face for the ellipsis in folded text." + :group 'org-faces) + +(defface org-target + '((((class color) (background light)) (:underline t)) + (((class color) (background dark)) (:underline t)) + (t (:underline t))) + "Face for link targets." + :group 'org-faces) + +(defface org-date + '((((class color) (background light)) (:foreground "Purple" :underline t)) + (((class color) (background dark)) (:foreground "Cyan" :underline t)) + (t (:underline t))) + "Face for date/time stamps." + :group 'org-faces) + +(defface org-sexp-date + '((((class color) (background light)) (:foreground "Purple")) + (((class color) (background dark)) (:foreground "Cyan")) + (t (:underline t))) + "Face for diary-like sexp date specifications." + :group 'org-faces) + +(defface org-tag + '((t (:bold t))) + "Default face for tags. +Note that the variable `org-tag-faces' can be used to overrule this face for +specific tags." + :group 'org-faces) + +(defface org-todo ; font-lock-warning-face + (org-compatible-face nil + '((((class color) (min-colors 16) (background light)) (:foreground "Red1" :bold t)) + (((class color) (min-colors 16) (background dark)) (:foreground "Pink" :bold t)) + (((class color) (min-colors 8) (background light)) (:foreground "red" :bold t)) + (((class color) (min-colors 8) (background dark)) (:foreground "red" :bold t)) + (t (:inverse-video t :bold t)))) + "Face for TODO keywords." + :group 'org-faces) + +(defface org-done ;; originally copied from font-lock-type-face + (org-compatible-face nil + '((((class color) (min-colors 16) (background light)) (:foreground "ForestGreen" :bold t)) + (((class color) (min-colors 16) (background dark)) (:foreground "PaleGreen" :bold t)) + (((class color) (min-colors 8)) (:foreground "green")) + (t (:bold t)))) + "Face used for todo keywords that indicate DONE items." + :group 'org-faces) + +(defface org-agenda-done ;; originally copied from font-lock-type-face + (org-compatible-face nil + '((((class color) (min-colors 16) (background light)) (:foreground "ForestGreen")) + (((class color) (min-colors 16) (background dark)) (:foreground "PaleGreen")) + (((class color) (min-colors 8)) (:foreground "green")) + (t (:bold nil)))) + "Face used in agenda, to indicate lines switched to DONE. +This face is used to de-emphasize items that where brightly colord in the +agenda because they were things to do, or overdue. The DONE state itself +is of course immediately visible, but for example a passed deadline is +\(by default) very bright read. This face could be simply the default face +of the frame, for example." + :group 'org-faces) + +(defface org-headline-done ;; originally copied from font-lock-string-face + (org-compatible-face nil + '((((class color) (min-colors 16) (background light)) (:foreground "RosyBrown")) + (((class color) (min-colors 16) (background dark)) (:foreground "LightSalmon")) + (((class color) (min-colors 8) (background light)) (:bold nil)))) + "Face used to indicate that a headline is DONE. +This face is only used if `org-fontify-done-headline' is set. If applies +to the part of the headline after the DONE keyword." + :group 'org-faces) + +(defcustom org-faces-easy-properties + '((todo . :foreground) (tag . :foreground) (priority . :foreground)) + "The property changes by easy faces. +This is an alist, the keys show the area of application, the values +can be `:foreground' or `:background'. A color string for special +keywords will then be interpreted as either foreground or background +color." + :group 'org-faces + :group 'org-todo + :type '(repeat + (cons (choice (const todo) (const tag) (const priority)) + (choice (const :foreground) (const :background))))) + +(defcustom org-todo-keyword-faces nil + "Faces for specific TODO keywords. +This is a list of cons cells, with TODO keywords in the car +and faces in the cdr. The face can be a symbol, a color +as a string (in which case the rest is inherited from the `org-todo' face), +or a property list of attributes, like + (:foreground \"blue\" :weight bold :underline t). +If it is a color string, the variable `org-faces-easy-properties' +determines if it is a foreground or a background color." + :group 'org-faces + :group 'org-todo + :type '(repeat + (cons + (string :tag "Keyword") + (choice :tag "Face " + (string :tag "Color") + (sexp :tag "Face"))))) + +(defcustom org-priority-faces nil + "Faces for specific Priorities. +This is a list of cons cells, with priority character in the car +and faces in the cdr. The face can be a symbol, a color as +as a string, or a property list of attributes, like + (:foreground \"blue\" :weight bold :underline t). +If it is a color string, the variable `org-faces-easy-properties' +determines if it is a foreground or a background color." + :group 'org-faces + :group 'org-todo + :type '(repeat + (cons + (character :tag "Priority") + (choice :tag "Face " + (string :tag "Color") + (sexp :tag "Face"))))) + +(defvar org-tags-special-faces-re nil) +(defun org-set-tag-faces (var value) + (set var value) + (if (not value) + (setq org-tags-special-faces-re nil) + (setq org-tags-special-faces-re + (concat ":\\(" (mapconcat 'car value "\\|") "\\):")))) + +(defface org-checkbox + (org-compatible-face 'bold + '((t (:bold t)))) + "Face for checkboxes" + :group 'org-faces) + + +(org-copy-face 'org-todo 'org-checkbox-statistics-todo + "Face used for unfinished checkbox statistics.") + +(org-copy-face 'org-done 'org-checkbox-statistics-done + "Face used for finished checkbox statistics.") + +(defcustom org-tag-faces nil + "Faces for specific tags. +This is a list of cons cells, with tags in the car and faces in the cdr. +The face can be a symbol, a foreground color (in which case the rest is +inherited from the `org-tag' face) or a property list of attributes, +like (:foreground \"blue\" :weight bold :underline t). +If you set this variable through customize, it will immediately be effective +in new buffers and in modified lines. +If you set it with Lisp, a restart of Emacs is required to activate the +changes." + :group 'org-faces + :group 'org-tags + :set 'org-set-tag-faces + :type '(repeat + (cons + (string :tag "Tag ") + (choice :tag "Face" + (string :tag "Foreground color") + (sexp :tag "Face"))))) + +(defface org-table ;; originally copied from font-lock-function-name-face + (org-compatible-face nil + '((((class color) (min-colors 88) (background light)) (:foreground "Blue1")) + (((class color) (min-colors 88) (background dark)) (:foreground "LightSkyBlue")) + (((class color) (min-colors 16) (background light)) (:foreground "Blue")) + (((class color) (min-colors 16) (background dark)) (:foreground "LightSkyBlue")) + (((class color) (min-colors 8) (background light)) (:foreground "blue")) + (((class color) (min-colors 8) (background dark))))) + "Face used for tables." + :group 'org-faces) + +(defface org-formula + (org-compatible-face nil + '((((class color) (min-colors 88) (background light)) (:foreground "Firebrick")) + (((class color) (min-colors 88) (background dark)) (:foreground "chocolate1")) + (((class color) (min-colors 8) (background light)) (:foreground "red")) + (((class color) (min-colors 8) (background dark)) (:foreground "red")) + (t (:bold t :italic t)))) + "Face for formulas." + :group 'org-faces) + +(defface org-code + (org-compatible-face 'shadow + '((((class color grayscale) (min-colors 88) (background light)) + (:foreground "grey50")) + (((class color grayscale) (min-colors 88) (background dark)) + (:foreground "grey70")) + (((class color) (min-colors 8) (background light)) + (:foreground "green")) + (((class color) (min-colors 8) (background dark)) + (:foreground "yellow")))) + "Face for fixed-width text like code snippets." + :group 'org-faces + :version "22.1") + +(defface org-meta-line + (org-compatible-face 'font-lock-comment-face nil) + "Face for meta lines startin with \"#+\"." + :group 'org-faces + :version "22.1") + +(defface org-document-title + '((((class color) (background light)) (:foreground "midnight blue" :weight bold :height 1.44)) + (((class color) (background dark)) (:foreground "pale turquoise" :weight bold :height 1.44)) + (t (:weight bold :height 1.44))) + "Face for document title, i.e. that which follows the #+TITLE: keyword." + :group 'org-faces) + +(defface org-document-info + '((((class color) (background light)) (:foreground "midnight blue")) + (((class color) (background dark)) (:foreground "pale turquoise")) + (t nil)) + "Face for document date, author and email; i.e. that which +follows a #+DATE:, #+AUTHOR: or #+EMAIL: keyword." + :group 'org-faces) + +(defface org-document-info-keyword + (org-compatible-face 'shadow + '((((class color grayscale) (min-colors 88) (background light)) + (:foreground "grey50")) + (((class color grayscale) (min-colors 88) (background dark)) + (:foreground "grey70")) + (((class color) (min-colors 8) (background light)) + (:foreground "green")) + (((class color) (min-colors 8) (background dark)) + (:foreground "yellow")))) + "Face for #+TITLE:, #+AUTHOR:, #+EMAIL: and #+DATE: keywords." + :group 'org-faces) + +(defface org-block + (org-compatible-face 'shadow + '((((class color grayscale) (min-colors 88) (background light)) + (:foreground "grey50")) + (((class color grayscale) (min-colors 88) (background dark)) + (:foreground "grey70")) + (((class color) (min-colors 8) (background light)) + (:foreground "green")) + (((class color) (min-colors 8) (background dark)) + (:foreground "yellow")))) + "Face text in #+begin ... #+end blocks." + :group 'org-faces + :version "22.1") + +(defface org-verbatim + (org-compatible-face 'shadow + '((((class color grayscale) (min-colors 88) (background light)) + (:foreground "grey50" :underline t)) + (((class color grayscale) (min-colors 88) (background dark)) + (:foreground "grey70" :underline t)) + (((class color) (min-colors 8) (background light)) + (:foreground "green" :underline t)) + (((class color) (min-colors 8) (background dark)) + (:foreground "yellow" :underline t)))) + "Face for fixed-with text like code snippets." + :group 'org-faces + :version "22.1") + +(org-copy-face 'org-block 'org-quote + "Face for #+BEGIN_QUOTE ... #+END_QUOTE blocks.") +(org-copy-face 'org-block 'org-verse + "Face for #+BEGIN_VERSE ... #+END_VERSE blocks.") + +(defcustom org-fontify-quote-and-verse-blocks nil + "Non-nil means, add a special face to #+begin_quote and #+begin_verse block. +When nil, format these as normal Org. This is the default, because the +content of these blocks will still be treated as Org syntax." + :group 'org-faces + :type 'boolean) + +(defface org-clock-overlay ;; copied from secondary-selection + (org-compatible-face nil + '((((class color) (min-colors 88) (background light)) + (:background "yellow1")) + (((class color) (min-colors 88) (background dark)) + (:background "SkyBlue4")) + (((class color) (min-colors 16) (background light)) + (:background "yellow")) + (((class color) (min-colors 16) (background dark)) + (:background "SkyBlue4")) + (((class color) (min-colors 8)) + (:background "cyan" :foreground "black")) + (t (:inverse-video t)))) + "Basic face for displaying the secondary selection." + :group 'org-faces) + +(defface org-agenda-structure ;; originally copied from font-lock-function-name-face + (org-compatible-face nil + '((((class color) (min-colors 88) (background light)) (:foreground "Blue1")) + (((class color) (min-colors 88) (background dark)) (:foreground "LightSkyBlue")) + (((class color) (min-colors 16) (background light)) (:foreground "Blue")) + (((class color) (min-colors 16) (background dark)) (:foreground "LightSkyBlue")) + (((class color) (min-colors 8)) (:foreground "blue" :bold t)) + (t (:bold t)))) + "Face used in agenda for captions and dates." + :group 'org-faces) + +(org-copy-face 'org-agenda-structure 'org-agenda-date + "Face used in agenda for normal days.") + +(org-copy-face 'org-agenda-date 'org-agenda-date-today + "Face used in agenda for today." + :weight 'bold :italic 't) + +(org-copy-face 'secondary-selection 'org-agenda-clocking + "Face marking the current clock item in the agenda.") + +(org-copy-face 'org-agenda-date 'org-agenda-date-weekend + "Face used in agenda for weekend days. +See the variable `org-agenda-weekend-days' for a definition of which days +belong to the weekend." + :weight 'bold) + +(defface org-scheduled + (org-compatible-face nil + '((((class color) (min-colors 88) (background light)) (:foreground "DarkGreen")) + (((class color) (min-colors 88) (background dark)) (:foreground "PaleGreen")) + (((class color) (min-colors 8)) (:foreground "green")) + (t (:bold t :italic t)))) + "Face for items scheduled for a certain day." + :group 'org-faces) + +(defface org-scheduled-today + (org-compatible-face nil + '((((class color) (min-colors 88) (background light)) (:foreground "DarkGreen")) + (((class color) (min-colors 88) (background dark)) (:foreground "PaleGreen")) + (((class color) (min-colors 8)) (:foreground "green")) + (t (:bold t :italic t)))) + "Face for items scheduled for a certain day." + :group 'org-faces) + +(defface org-agenda-dimmed-todo-face + '((((background light)) (:foreground "grey50")) + (((background dark)) (:foreground "grey50"))) + "Face used to dim blocked tasks in the agenda." + :group 'org-faces) + +(defface org-scheduled-previously + (org-compatible-face nil + '((((class color) (min-colors 88) (background light)) (:foreground "Firebrick")) + (((class color) (min-colors 88) (background dark)) (:foreground "chocolate1")) + (((class color) (min-colors 8) (background light)) (:foreground "red")) + (((class color) (min-colors 8) (background dark)) (:foreground "red" :bold t)) + (t (:bold t)))) + "Face for items scheduled previously, and not yet done." + :group 'org-faces) + +(defface org-upcoming-deadline + (org-compatible-face nil + '((((class color) (min-colors 88) (background light)) (:foreground "Firebrick")) + (((class color) (min-colors 88) (background dark)) (:foreground "chocolate1")) + (((class color) (min-colors 8) (background light)) (:foreground "red")) + (((class color) (min-colors 8) (background dark)) (:foreground "red" :bold t)) + (t (:bold t)))) + "Face for items scheduled previously, and not yet done." + :group 'org-faces) + +(defcustom org-agenda-deadline-faces + '((1.0 . org-warning) + (0.5 . org-upcoming-deadline) + (0.0 . default)) + "Faces for showing deadlines in the agenda. +This is a list of cons cells. The cdr of each cell is a face to be used, +and it can also just be like '(:foreground \"yellow\"). +Each car is a fraction of the head-warning time that must have passed for +this the face in the cdr to be used for display. The numbers must be +given in descending order. The head-warning time is normally taken +from `org-deadline-warning-days', but can also be specified in the deadline +timestamp itself, like this: + + DEADLINE: <2007-08-13 Mon -8d> + +You may use d for days, w for weeks, m for months and y for years. Months +and years will only be treated in an approximate fashion (30.4 days for a +month and 365.24 days for a year)." + :group 'org-faces + :group 'org-agenda-daily/weekly + :type '(repeat + (cons + (number :tag "Fraction of head-warning time passed") + (sexp :tag "Face")))) + +(defface org-agenda-restriction-lock + (org-compatible-face nil + '((((class color) (min-colors 88) (background light)) (:background "yellow1")) + (((class color) (min-colors 88) (background dark)) (:background "skyblue4")) + (((class color) (min-colors 16) (background light)) (:background "yellow1")) + (((class color) (min-colors 16) (background dark)) (:background "skyblue4")) + (((class color) (min-colors 8)) (:background "cyan" :foreground "black")) + (t (:inverse-video t)))) + "Face for showing the agenda restriction lock." + :group 'org-faces) + +(defface org-time-grid ;; originally copied from font-lock-variable-name-face + (org-compatible-face nil + '((((class color) (min-colors 16) (background light)) (:foreground "DarkGoldenrod")) + (((class color) (min-colors 16) (background dark)) (:foreground "LightGoldenrod")) + (((class color) (min-colors 8)) (:foreground "yellow" :weight light)))) + "Face used for time grids." + :group 'org-faces) + +(defface org-agenda-diary + (org-compatible-face 'default + nil) + "Face used for agenda entries that come from the Emacs diary." + :group 'org-faces) + +(defconst org-level-faces + '(org-level-1 org-level-2 org-level-3 org-level-4 + org-level-5 org-level-6 org-level-7 org-level-8 + )) + +(defcustom org-n-level-faces (length org-level-faces) + "The number of different faces to be used for headlines. +Org-mode defines 8 different headline faces, so this can be at most 8. +If it is less than 8, the level-1 face gets re-used for level N+1 etc." + :type 'integer + :group 'org-faces) + +(defcustom org-cycle-level-faces t + "Non-nil means level styles cycle after level `org-n-level-faces'. +Then so level org-n-level-faces+1 is styled like level 1. +If nil, then all levels >=org-n-level-faces are styled like +level org-n-level-faces" + :group 'org-appearance + :group 'org-faces + :type 'boolean) + +(defface org-latex-and-export-specials + (let ((font (cond ((assq :inherit custom-face-attributes) + '(:inherit underline)) + (t '(:underline t))))) + `((((class grayscale) (background light)) + (:foreground "DimGray" ,@font)) + (((class grayscale) (background dark)) + (:foreground "LightGray" ,@font)) + (((class color) (background light)) + (:foreground "SaddleBrown")) + (((class color) (background dark)) + (:foreground "burlywood")) + (t (,@font)))) + "Face used to highlight math latex and other special exporter stuff." + :group 'org-faces) + +(org-copy-face 'modeline 'org-mode-line-clock + "Face used for clock display in mode line.") +(org-copy-face 'modeline 'org-mode-line-clock-overrun + "Face used for clock display for overrun tasks in mode line." + :background "red") + +(provide 'org-faces) + +;; arch-tag: 9dab5f91-c4b9-4d6f-bac3-1f6211ad0a04 + +;;; org-faces.el ends here diff --git a/.emacs.d/org-7.4/lisp/org-faces.elc b/.emacs.d/org-7.4/lisp/org-faces.elc Binary files differnew file mode 100644 index 0000000..8a5d614 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-faces.elc diff --git a/.emacs.d/org-7.4/lisp/org-feed.el b/.emacs.d/org-7.4/lisp/org-feed.el new file mode 100644 index 0000000..32da49b --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-feed.el @@ -0,0 +1,678 @@ +;;; org-feed.el --- Add RSS feed items to Org files +;; +;; Copyright (C) 2009, 2010 Free Software Foundation, Inc. +;; +;; Author: Carsten Dominik <carsten at orgmode dot org> +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; Version: 7.4 +;; +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: +;; +;; This module allows to create and change entries in an Org-mode +;; file triggered by items in an RSS feed. The basic functionality is +;; geared toward simply adding new items found in a feed as outline nodes +;; to an Org file. Using hooks, arbitrary actions can be triggered for +;; new or changed items. +;; +;; Selecting feeds and target locations +;; ------------------------------------ +;; +;; This module is configured through a single variable, `org-feed-alist'. +;; Here is an example, using a notes/tasks feed from reQall.com. +;; +;; (setq org-feed-alist +;; '(("ReQall" +;; "http://www.reqall.com/user/feeds/rss/a1b2c3....." +;; "~/org/feeds.org" "ReQall Entries") +;; +;; With this setup, the command `M-x org-feed-update-all' will +;; collect new entries in the feed at the given URL and create +;; entries as subheadings under the "ReQall Entries" heading in the +;; file "~/org/feeds.org". Each feed should normally have its own +;; heading - however see the `:drawer' parameter. +;; +;; Besides these standard elements that need to be specified for each +;; feed, keyword-value pairs can set additional options. For example, +;; to de-select transitional entries with a title containing +;; +;; "reQall is typing what you said", +;; +;; you could use the `:filter' argument: +;; +;; (setq org-feed-alist +;; '(("ReQall" +;; "http://www.reqall.com/user/feeds/rss/a1b2c3....." +;; "~/org/feeds.org" "ReQall Entries" +;; :filter my-reqall-filter))) +;; +;; (defun my-reqall-filter (e) +;; (if (string-match "reQall is typing what you said" +;; (plist-get e :title)) +;; nil +;; e)) +;; +;; See the docstring for `org-feed-alist' for more details. +;; +;; +;; Keeping track of previously added entries +;; ----------------------------------------- +;; +;; Since Org allows you to delete, archive, or move outline nodes, +;; org-feed.el needs to keep track of which feed items have been handled +;; before, so that they will not be handled again. For this, org-feed.el +;; stores information in a special drawer, FEEDSTATUS, under the heading +;; that received the input of the feed. You should add FEEDSTATUS +;; to your list of drawers in the files that receive feed input: +;; +;; #+DRAWERS: PROPERTIES LOGBOOK FEEDSTATUS +;; +;; Acknowledgments +;; --------------- +;; +;; org-feed.el is based on ideas by Brad Bozarth who implemented a +;; similar mechanism using shell and awk scripts. + +;;; Code: + +(require 'org) +(require 'sha1) + +(declare-function url-retrieve-synchronously "url" (url)) +(declare-function xml-node-children "xml" (node)) +(declare-function xml-get-children "xml" (node child-name)) +(declare-function xml-get-attribute "xml" (node attribute)) +(declare-function xml-get-attribute-or-nil "xml" (node attribute)) +(declare-function xml-substitute-special "xml" (string)) + +(defgroup org-feed nil + "Options concerning RSS feeds as inputs for Org files." + :tag "Org Feed" + :group 'org) + +(defcustom org-feed-alist nil + "Alist specifying RSS feeds that should create inputs for Org. +Each entry in this list specified an RSS feed tat should be queried +to create inbox items in Org. Each entry is a list with the following items: + +name a custom name for this feed +URL the Feed URL +file the target Org file where entries should be listed +headline the headline under which entries should be listed + +Additional arguments can be given using keyword-value pairs. Many of these +specify functions that receive one or a list of \"entries\" as their single +argument. An entry is a property list that describes a feed item. The +property list has properties for each field in the item, for example `:title' +for the `<title>' field and `:pubDate' for the publication date. In addition, +it contains the following properties: + +`:item-full-text' the full text in the <item> tag +`:guid-permalink' t when the guid property is a permalink + +Here are the keyword-value pair allows in `org-feed-alist'. + +:drawer drawer-name + The name of the drawer for storing feed information. The default is + \"FEEDSTATUS\". Using different drawers for different feeds allows + several feeds to target the same inbox heading. + +:filter filter-function + A function to select interesting entries in the feed. It gets a single + entry as parameter. It should return the entry if it is relevant, or + nil if it is not. + +:template template-string + The default action on new items in the feed is to add them as children + under the headline for the feed. The template describes how the entry + should be formatted. If not given, it defaults to + `org-feed-default-template'. + +:formatter formatter-function + Instead of relying on a template, you may specify a function to format + the outline node to be inserted as a child. This function gets passed + a property list describing a single feed item, and it should return a + string that is a properly formatted Org outline node of level 1. + +:new-handler function + If adding new items as children to the outline is not what you want + to do with new items, define a handler function that is called with + a list of all new items in the feed, each one represented as a property + list. The handler should do what needs to be done, and org-feed will + mark all items given to this handler as \"handled\", i.e. they will not + be passed to this handler again in future readings of the feed. + When the handler is called, point will be at the feed headline. + +:changed-handler function + This function gets passed a list of all entries that have been + handled before, but are now still in the feed and have *changed* + since last handled (as evidenced by a different sha1 hash). + When the handler is called, point will be at the feed headline. + +:parse-feed function + This function gets passed a buffer, and should return a list + of entries, each being a property list containing the + `:guid' and `:item-full-text' keys. The default is + `org-feed-parse-rss-feed'; `org-feed-parse-atom-feed' is an + alternative. + +:parse-entry function + This function gets passed an entry as returned by the parse-feed + function, and should return the entry with interesting properties added. + The default is `org-feed-parse-rss-entry'; `org-feed-parse-atom-entry' + is an alternative." + :group 'org-feed + :type '(repeat + (list :value ("" "http://" "" "") + (string :tag "Name") + (string :tag "Feed URL") + (file :tag "File for inbox") + (string :tag "Headline for inbox") + (repeat :inline t + (choice + (list :inline t :tag "Filter" + (const :filter) + (symbol :tag "Filter Function")) + (list :inline t :tag "Template" + (const :template) + (string :tag "Template")) + (list :inline t :tag "Formatter" + (const :formatter) + (symbol :tag "Formatter Function")) + (list :inline t :tag "New items handler" + (const :new-handler) + (symbol :tag "Handler Function")) + (list :inline t :tag "Changed items" + (const :changed-handler) + (symbol :tag "Handler Function")) + (list :inline t :tag "Parse Feed" + (const :parse-feed) + (symbol :tag "Parse Feed Function")) + (list :inline t :tag "Parse Entry" + (const :parse-entry) + (symbol :tag "Parse Entry Function")) + ))))) + +(defcustom org-feed-drawer "FEEDSTATUS" + "The name of the drawer for feed status information. +Each feed may also specify its own drawer name using the `:drawer' +parameter in `org-feed-alist'. +Note that in order to make these drawers behave like drawers, they must +be added to the variable `org-drawers' or configured with a #+DRAWERS +line." + :group 'org-feed + :type '(string :tag "Drawer Name")) + +(defcustom org-feed-default-template "\n* %h\n %U\n %description\n %a\n" + "Template for the Org node created from RSS feed items. +This is just the default, each feed can specify its own. +Any fields from the feed item can be interpolated into the template with +%name, for example %title, %description, %pubDate etc. In addition, the +following special escapes are valid as well: + +%h the title, or the first line of the description +%t the date as a stamp, either from <pubDate> (if present), or + the current date. +%T date and time +%u,%U like %t,%T, but inactive time stamps +%a A link, from <guid> if that is a permalink, else from <link>" + :group 'org-feed + :type '(string :tag "Template")) + +(defcustom org-feed-save-after-adding t + "Non-nil means save buffer after adding new feed items." + :group 'org-feed + :type 'boolean) + +(defcustom org-feed-retrieve-method 'url-retrieve-synchronously + "The method to be used to retrieve a feed URL. +This can be `curl' or `wget' to call these external programs, or it can be +an Emacs Lisp function that will return a buffer containing the content +of the file pointed to by the URL." + :group 'org-feed + :type '(choice + (const :tag "Internally with url.el" url-retrieve-synchronously) + (const :tag "Externally with curl" curl) + (const :tag "Externally with wget" wget) + (function :tag "Function"))) + + (defcustom org-feed-before-adding-hook nil + "Hook that is run before adding new feed items to a file. +You might want to commit the file in its current state to version control, +for example." + :group 'org-feed + :type 'hook) + +(defcustom org-feed-after-adding-hook nil + "Hook that is run after new items have been added to a file. +Depending on `org-feed-save-after-adding', the buffer will already +have been saved." + :group 'org-feed + :type 'hook) + +(defvar org-feed-buffer "*Org feed*" + "The buffer used to retrieve a feed.") + +;;;###autoload +(defun org-feed-update-all () + "Get inbox items from all feeds in `org-feed-alist'." + (interactive) + (let ((nfeeds (length org-feed-alist)) + (nnew (apply '+ (mapcar 'org-feed-update org-feed-alist)))) + (message "%s from %d %s" + (cond ((= nnew 0) "No new entries") + ((= nnew 1) "1 new entry") + (t (format "%d new entries" nnew))) + nfeeds + (if (= nfeeds 1) "feed" "feeds")))) + +;;;###autoload +(defun org-feed-update (feed &optional retrieve-only) + "Get inbox items from FEED. +FEED can be a string with an association in `org-feed-alist', or +it can be a list structured like an entry in `org-feed-alist'." + (interactive (list (org-completing-read "Feed name: " org-feed-alist))) + (if (stringp feed) (setq feed (assoc feed org-feed-alist))) + (unless feed + (error "No such feed in `org-feed-alist")) + (catch 'exit + (let ((name (car feed)) + (url (nth 1 feed)) + (file (nth 2 feed)) + (headline (nth 3 feed)) + (filter (nth 1 (memq :filter feed))) + (formatter (nth 1 (memq :formatter feed))) + (new-handler (nth 1 (memq :new-handler feed))) + (changed-handler (nth 1 (memq :changed-handler feed))) + (template (or (nth 1 (memq :template feed)) + org-feed-default-template)) + (drawer (or (nth 1 (memq :drawer feed)) + org-feed-drawer)) + (parse-feed (or (nth 1 (memq :parse-feed feed)) + 'org-feed-parse-rss-feed)) + (parse-entry (or (nth 1 (memq :parse-entry feed)) + 'org-feed-parse-rss-entry)) + feed-buffer inbox-pos new-formatted + entries old-status status new changed guid-alist e guid olds) + (setq feed-buffer (org-feed-get-feed url)) + (unless (and feed-buffer (bufferp (get-buffer feed-buffer))) + (error "Cannot get feed %s" name)) + (when retrieve-only + (throw 'exit feed-buffer)) + (setq entries (funcall parse-feed feed-buffer)) + (ignore-errors (kill-buffer feed-buffer)) + (save-excursion + (save-window-excursion + (setq inbox-pos (org-feed-goto-inbox-internal file headline)) + (setq old-status (org-feed-read-previous-status inbox-pos drawer)) + ;; Add the "handled" status to the appropriate entries + (setq entries (mapcar (lambda (e) + (setq e + (plist-put e :handled + (nth 1 (assoc + (plist-get e :guid) + old-status))))) + entries)) + ;; Find out which entries are new and which are changed + (dolist (e entries) + (if (not (plist-get e :handled)) + (push e new) + (setq olds (nth 2 (assoc (plist-get e :guid) old-status))) + (if (and olds + (not (string= (sha1 + (plist-get e :item-full-text)) + olds))) + (push e changed)))) + + ;; Parse the relevant entries fully + (setq new (mapcar parse-entry new) + changed (mapcar parse-entry changed)) + + ;; Run the filter + (when filter + (setq new (delq nil (mapcar filter new)) + changed (delq nil (mapcar filter new)))) + + (when (not (or new changed)) + (message "No new items in feed %s" name) + (throw 'exit 0)) + + ;; Get alist based on guid, to look up entries + (setq guid-alist + (append + (mapcar (lambda (e) (list (plist-get e :guid) e)) new) + (mapcar (lambda (e) (list (plist-get e :guid) e)) changed))) + + ;; Construct the new status + (setq status + (mapcar + (lambda (e) + (setq guid (plist-get e :guid)) + (list guid + ;; things count as handled if we handle them now, + ;; or if they were handled previously + (if (assoc guid guid-alist) t (plist-get e :handled)) + ;; A hash, to detect changes + (sha1 (plist-get e :item-full-text)))) + entries)) + + ;; Handle new items in the feed + (when new + (if new-handler + (progn + (goto-char inbox-pos) + (funcall new-handler new)) + ;; No custom handler, do the default adding + ;; Format the new entries into an alist with GUIDs in the car + (setq new-formatted + (mapcar + (lambda (e) (org-feed-format-entry e template formatter)) + new))) + + ;; Insert the new items + (org-feed-add-items inbox-pos new-formatted)) + + ;; Handle changed items in the feed + (when (and changed-handler changed) + (goto-char inbox-pos) + (funcall changed-handler changed)) + + ;; Write the new status + ;; We do this only now, in case something goes wrong above, so + ;; that would would end up with a status that does not reflect + ;; which items truely have been handled + (org-feed-write-status inbox-pos drawer status) + + ;; Normalize the visibility of the inbox tree + (goto-char inbox-pos) + (hide-subtree) + (show-children) + (org-cycle-hide-drawers 'children) + + ;; Hooks and messages + (when org-feed-save-after-adding (save-buffer)) + (message "Added %d new item%s from feed %s to file %s, heading %s" + (length new) (if (> (length new) 1) "s" "") + name + (file-name-nondirectory file) headline) + (run-hooks 'org-feed-after-adding-hook) + (length new)))))) + +;;;###autoload +(defun org-feed-goto-inbox (feed) + "Go to the inbox that captures the feed named FEED." + (interactive + (list (if (= (length org-feed-alist) 1) + (car org-feed-alist) + (org-completing-read "Feed name: " org-feed-alist)))) + (if (stringp feed) (setq feed (assoc feed org-feed-alist))) + (unless feed + (error "No such feed in `org-feed-alist")) + (org-feed-goto-inbox-internal (nth 2 feed) (nth 3 feed))) + +;;;###autoload +(defun org-feed-show-raw-feed (feed) + "Show the raw feed buffer of a feed." + (interactive + (list (if (= (length org-feed-alist) 1) + (car org-feed-alist) + (org-completing-read "Feed name: " org-feed-alist)))) + (if (stringp feed) (setq feed (assoc feed org-feed-alist))) + (unless feed + (error "No such feed in `org-feed-alist")) + (switch-to-buffer + (org-feed-update feed 'retrieve-only)) + (goto-char (point-min))) + +(defun org-feed-goto-inbox-internal (file heading) + "Find or create HEADING in FILE. +Switch to that buffer, and return the position of that headline." + (find-file file) + (widen) + (goto-char (point-min)) + (if (re-search-forward + (concat "^\\*+[ \t]+" heading "[ \t]*\\(:.*?:[ \t]*\\)?$") + nil t) + (goto-char (match-beginning 0)) + (goto-char (point-max)) + (insert "\n\n* " heading "\n\n") + (org-back-to-heading t)) + (point)) + +(defun org-feed-read-previous-status (pos drawer) + "Get the alist of old GUIDs from the entry at POS. +This will find DRAWER and extract the alist." + (save-excursion + (goto-char pos) + (let ((end (save-excursion (org-end-of-subtree t t)))) + (if (re-search-forward + (concat "^[ \t]*:" drawer ":[ \t]*\n\\([^\000]*?\\)\n[ \t]*:END:") + end t) + (read (match-string 1)) + nil)))) + +(defun org-feed-write-status (pos drawer status) + "Write the feed STATUS to DRAWER in entry at POS." + (save-excursion + (goto-char pos) + (let ((end (save-excursion (org-end-of-subtree t t))) + guid) + (if (re-search-forward (concat "^[ \t]*:" drawer ":[ \t]*\n") + end t) + (progn + (goto-char (match-end 0)) + (delete-region (point) + (save-excursion + (and (re-search-forward "^[ \t]*:END:" nil t) + (match-beginning 0))))) + (outline-next-heading) + (insert " :" drawer ":\n :END:\n") + (beginning-of-line 0)) + (insert (pp-to-string status))))) + +(defun org-feed-add-items (pos entries) + "Add the formatted items to the headline as POS." + (let (entry level) + (save-excursion + (goto-char pos) + (unless (looking-at org-complex-heading-regexp) + (error "Wrong position")) + (setq level (org-get-valid-level (length (match-string 1)) 1)) + (org-end-of-subtree t t) + (skip-chars-backward " \t\n") + (beginning-of-line 2) + (setq pos (point)) + (while (setq entry (pop entries)) + (org-paste-subtree level entry 'yank)) + (org-mark-ring-push pos)))) + +(defun org-feed-format-entry (entry template formatter) + "Format ENTRY so that it can be inserted into an Org file. +ENTRY is a property list. This function adds a `:formatted-for-org' property +and returns the full property list. +If that property is already present, nothing changes." + (if formatter + (funcall formatter entry) + (let (dlines fmt tmp indent time name + v-h v-t v-T v-u v-U v-a) + (setq dlines (org-split-string (or (plist-get entry :description) "???") + "\n") + v-h (or (plist-get entry :title) (car dlines) "???") + time (or (if (plist-get entry :pubDate) + (org-read-date t t (plist-get entry :pubDate))) + (current-time)) + v-t (format-time-string (org-time-stamp-format nil nil) time) + v-T (format-time-string (org-time-stamp-format t nil) time) + v-u (format-time-string (org-time-stamp-format nil t) time) + v-U (format-time-string (org-time-stamp-format t t) time) + v-a (if (setq tmp (or (and (plist-get entry :guid-permalink) + (plist-get entry :guid)) + (plist-get entry :link))) + (concat "[[" tmp "]]\n") + "")) + (with-temp-buffer + (insert template) + (goto-char (point-min)) + (while (re-search-forward "%\\([a-zA-Z]+\\)" nil t) + (setq name (match-string 1)) + (cond + ((member name '("h" "t" "T" "u" "U" "a")) + (replace-match (symbol-value (intern (concat "v-" name))) t t)) + ((setq tmp (plist-get entry (intern (concat ":" name)))) + (save-excursion + (save-match-data + (beginning-of-line 1) + (when (looking-at (concat "^\\([ \t]*\\)%" name "[ \t]*$")) + (setq tmp (org-feed-make-indented-block + tmp (org-get-indentation)))))) + (replace-match tmp t t)))) + (decode-coding-string + (buffer-string) (detect-coding-region (point-min) (point-max) t)))))) + +(defun org-feed-make-indented-block (s n) + "Add indentation of N spaces to a multiline string S." + (if (not (string-match "\n" s)) + s + (mapconcat 'identity + (org-split-string s "\n") + (concat "\n" (make-string n ?\ ))))) + +(defun org-feed-skip-http-headers (buffer) + "Remove HTTP headers from BUFFER, and return it. +Assumes headers are indeed present!" + (with-current-buffer buffer + (widen) + (goto-char (point-min)) + (search-forward "\n\n") + (delete-region (point-min) (point)) + buffer)) + +(defun org-feed-get-feed (url) + "Get the RSS feed file at URL and return the buffer." + (cond + ((eq org-feed-retrieve-method 'url-retrieve-synchronously) + (org-feed-skip-http-headers (url-retrieve-synchronously url))) + ((eq org-feed-retrieve-method 'curl) + (ignore-errors (kill-buffer org-feed-buffer)) + (call-process "curl" nil org-feed-buffer nil "--silent" url) + org-feed-buffer) + ((eq org-feed-retrieve-method 'wget) + (ignore-errors (kill-buffer org-feed-buffer)) + (call-process "wget" nil org-feed-buffer nil "-q" "-O" "-" url) + org-feed-buffer) + ((functionp org-feed-retrieve-method) + (funcall org-feed-retrieve-method url)))) + +(defun org-feed-parse-rss-feed (buffer) + "Parse BUFFER for RSS feed entries. +Returns a list of entries, with each entry a property list, +containing the properties `:guid' and `:item-full-text'." + (let ((case-fold-search t) + entries beg end item guid entry) + (with-current-buffer buffer + (widen) + (goto-char (point-min)) + (while (re-search-forward "<item\\>.*?>" nil t) + (setq beg (point) + end (and (re-search-forward "</item>" nil t) + (match-beginning 0))) + (setq item (buffer-substring beg end) + guid (if (string-match "<guid\\>.*?>\\(.*?\\)</guid>" item) + (org-match-string-no-properties 1 item))) + (setq entry (list :guid guid :item-full-text item)) + (push entry entries) + (widen) + (goto-char end)) + (nreverse entries)))) + +(defun org-feed-parse-rss-entry (entry) + "Parse the `:item-full-text' field for xml tags and create new properties." + (require 'xml) + (with-temp-buffer + (insert (plist-get entry :item-full-text)) + (goto-char (point-min)) + (while (re-search-forward "<\\([a-zA-Z]+\\>\\).*?>\\([^\000]*?\\)</\\1>" + nil t) + (setq entry (plist-put entry + (intern (concat ":" (match-string 1))) + (xml-substitute-special (match-string 2))))) + (goto-char (point-min)) + (unless (re-search-forward "isPermaLink[ \t]*=[ \t]*\"false\"" nil t) + (setq entry (plist-put entry :guid-permalink t)))) + entry) + +(defun org-feed-parse-atom-feed (buffer) + "Parse BUFFER for Atom feed entries. +Returns a list of entries, with each entry a property list, +containing the properties `:guid' and `:item-full-text'. + +The `:item-full-text' property actually contains the sexp +formatted as a string, not the original XML data." + (require 'xml) + (with-current-buffer buffer + (widen) + (let ((feed (car (xml-parse-region (point-min) (point-max))))) + (mapcar + (lambda (entry) + (list + :guid (car (xml-node-children (car (xml-get-children entry 'id)))) + :item-full-text (prin1-to-string entry))) + (xml-get-children feed 'entry))))) + +(defun org-feed-parse-atom-entry (entry) + "Parse the `:item-full-text' as a sexp and create new properties." + (let ((xml (car (read-from-string (plist-get entry :item-full-text))))) + ;; Get first <link href='foo'/>. + (setq entry (plist-put entry :link + (xml-get-attribute + (car (xml-get-children xml 'link)) + 'href))) + ;; Add <title/> as :title. + (setq entry (plist-put entry :title + (xml-substitute-special + (car (xml-node-children + (car (xml-get-children xml 'title))))))) + (let* ((content (car (xml-get-children xml 'content))) + (type (xml-get-attribute-or-nil content 'type))) + (when content + (cond + ((string= type "text") + ;; We like plain text. + (setq entry (plist-put entry :description + (xml-substitute-special + (car (xml-node-children content)))))) + ((string= type "html") + ;; TODO: convert HTML to Org markup. + (setq entry (plist-put entry :description + (xml-substitute-special + (car (xml-node-children content)))))) + ((string= type "xhtml") + ;; TODO: convert XHTML to Org markup. + (setq entry (plist-put entry :description + (prin1-to-string + (xml-node-children content))))) + (t + (setq entry (plist-put entry :description + (format "Unknown '%s' content." type))))))) + entry)) + +(provide 'org-feed) + +;; arch-tag: 0929b557-9bc4-47f4-9633-30a12dbb5ae2 +;;; org-feed.el ends here diff --git a/.emacs.d/org-7.4/lisp/org-feed.elc b/.emacs.d/org-7.4/lisp/org-feed.elc Binary files differnew file mode 100644 index 0000000..a1d96d0 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-feed.elc diff --git a/.emacs.d/org-7.4/lisp/org-footnote.el b/.emacs.d/org-7.4/lisp/org-footnote.el new file mode 100644 index 0000000..88ffd6e --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-footnote.el @@ -0,0 +1,590 @@ +;;; org-footnote.el --- Footnote support in Org and elsewhere +;; +;; Copyright (C) 2009, 2010 Free Software Foundation, Inc. +;; +;; Author: Carsten Dominik <carsten at orgmode dot org> +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; Version: 7.4 +;; +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: + +;; This file contains the code dealing with footnotes in Org-mode. +;; The code can also be used in arbitrary text modes to provide +;; footnotes. Compared to Steven L Baur's footnote.el it provides +;; better support for resuming editing. It is less configurable than +;; Steve's code, though. + +;;; Code: + +(eval-when-compile + (require 'cl)) +(require 'org-macs) +(require 'org-compat) + +(declare-function org-in-commented-line "org" ()) +(declare-function org-in-regexp "org" (re &optional nlines visually)) +(declare-function org-mark-ring-push "org" (&optional pos buffer)) +(declare-function outline-next-heading "outline") +(declare-function org-trim "org" (s)) +(declare-function org-show-context "org" (&optional key)) +(declare-function org-back-to-heading "org" (&optional invisible-ok)) +(declare-function org-end-of-subtree "org" (&optional invisible-ok to-heading)) +(declare-function org-in-verbatim-emphasis "org" ()) +(declare-function org-inside-latex-macro-p "org" ()) +(defvar org-odd-levels-only) ;; defined in org.el +(defvar message-signature-separator) ;; defined in message.el + +(defconst org-footnote-re + (concat "[^][\n]" ; to make sure it is not at the beginning of a line + "\\[" + "\\(?:" + "\\([0-9]+\\)" + "\\|" + (org-re "\\(fn:\\([-_[:word:]]+?\\)?\\)\\(?::\\([^\]]*?\\)\\)?") + "\\)" + "\\]") + "Regular expression for matching footnotes.") + +(defconst org-footnote-definition-re + (org-re "^\\(\\[\\([0-9]+\\|fn:[-_[:word:]]+\\)\\]\\)") + "Regular expression matching the definition of a footnote.") + +(defgroup org-footnote nil + "Footnotes in Org-mode." + :tag "Org Footnote" + :group 'org) + +(defcustom org-footnote-section "Footnotes" + "Outline heading containing footnote definitions before export. +This can be nil, to place footnotes locally at the end of the current +outline node. If can also be the name of a special outline heading +under which footnotes should be put. +This variable defines the place where Org puts the definition +automatically, i.e. when creating the footnote, and when sorting the notes. +However, by hand you may place definitions *anywhere*. +If this is a string, during export, all subtrees starting with this +heading will be removed after extracting footnote definitions." + :group 'org-footnote + :type '(choice + (string :tag "Collect footnotes under heading") + (const :tag "Define footnotes locally" nil))) + +(defcustom org-footnote-tag-for-non-org-mode-files "Footnotes:" + "Tag marking the beginning of footnote section. +The Org-mode footnote engine can be used in arbitrary text files as well +as in Org-mode. Outside Org-mode, new footnotes are always placed at +the end of the file. When you normalize the notes, any line containing +only this tag will be removed, a new one will be inserted at the end +of the file, followed by the collected and normalized footnotes." + :group 'org-footnote + :type 'string) + +(defcustom org-footnote-define-inline nil + "Non-nil means define footnotes inline, at reference location. +When nil, footnotes will be defined in a special section near +the end of the document. When t, the [fn:label:definition] notation +will be used to define the footnote at the reference position." + :group 'org-footnote + :type 'boolean) + +(defcustom org-footnote-auto-label t + "Non-nil means define automatically new labels for footnotes. +Possible values are: + +nil prompt the user for each label +t create unique labels of the form [fn:1], [fn:2], ... +confirm like t, but let the user edit the created value. In particular, + the label can be removed from the minibuffer, to create + an anonymous footnote. +plain Automatically create plain number labels like [1]" + :group 'org-footnote + :type '(choice + (const :tag "Prompt for label" nil) + (const :tag "Create automatic [fn:N]" t) + (const :tag "Offer automatic [fn:N] for editing" confirm) + (const :tag "Create automatic [N]" plain))) + +(defcustom org-footnote-auto-adjust nil + "Non-nil means automatically adjust footnotes after insert/delete. +When this is t, after each insertion or deletion of a footnote, +simple fn:N footnotes will be renumbered, and all footnotes will be sorted. +If you want to have just sorting or just renumbering, set this variable +to `sort' or `renumber'. + +The main values of this variable can be set with in-buffer options: + +#+STARTUP: fnadjust +#+STARTUP: nofnadjust" + :group 'org-footnote + :type '(choice + (const :tag "Renumber" renumber) + (const :tag "Sort" sort) + (const :tag "Renumber and Sort" t))) + +(defcustom org-footnote-fill-after-inline-note-extraction nil + "Non-nil means fill paragraphs after extracting footnotes. +When extracting inline footnotes, the lengths of lines can change a lot. +When this option is set, paragraphs from which an inline footnote has been +extracted will be filled again." + :group 'org-footnote + :type 'boolean) + +(defun org-footnote-at-reference-p () + "Is the cursor at a footnote reference? +If yes, return the beginning position, the label, and the definition, if local." + (when (org-in-regexp org-footnote-re 15) + (list (match-beginning 0) + (or (match-string 1) + (if (equal (match-string 2) "fn:") nil (match-string 2))) + (match-string 4)))) + +(defun org-footnote-at-definition-p () + "Is the cursor at a footnote definition. +This matches only pure definitions like [1] or [fn:name] at the beginning +of a line. It does not a references like [fn:name:definition], where the +footnote text is included and defined locally. +The return value will be nil if not at a footnote definition, and a list +with start and label of the footnote if there is a definition at point." + (save-excursion + (end-of-line 1) + (let ((lim (save-excursion (re-search-backward "^\\*+ \\|^[ \t]*$" nil t)))) + (when (re-search-backward org-footnote-definition-re lim t) + (list (match-beginning 0) (match-string 2)))))) + +(defun org-footnote-goto-definition (label) + "Find the definition of the footnote with label LABEL." + (interactive "sLabel: ") + (org-mark-ring-push) + (setq label (org-footnote-normalize-label label)) + (let ((re (format "^\\[%s\\]\\|.\\[%s:" label label)) + pos) + (save-excursion + (setq pos (or (re-search-forward re nil t) + (and (goto-char (point-min)) + (re-search-forward re nil t)) + (and (progn (widen) t) + (goto-char (point-min)) + (re-search-forward re nil t))))) + (if (not pos) + (error "Cannot find definition of footnote %s" label) + (goto-char pos) + (org-show-context 'link-search) + (message "Edit definition and go back with `C-c &' or, if unique, with `C-c C-c'.")))) + +(defun org-footnote-goto-previous-reference (label) + "Find the first closest (to point) reference of footnote with label LABEL." + (interactive "sLabel: ") + (org-mark-ring-push) + (setq label (org-footnote-normalize-label label)) + (let ((re (format ".\\[%s[]:]" label)) + (p0 (point)) pos) + (save-excursion + (setq pos (or (re-search-backward re nil t) + (and (goto-char (point-max)) + (re-search-backward re nil t)) + (and (progn (widen) t) + (goto-char p0) + (re-search-backward re nil t)) + (and (goto-char (point-max)) + (re-search-forward re nil t))))) + (if pos + (progn + (goto-char (match-end 0)) + (org-show-context 'link-search)) + (error "Cannot find reference of footnote %s" label)))) + +(defun org-footnote-normalize-label (label) + (if (numberp label) (setq label (number-to-string label))) + (if (not (string-match "^[0-9]+$\\|^$\\|^fn:" label)) + (setq label (concat "fn:" label))) + label) + +(defun org-footnote-all-labels () + "Return list with all defined foot labels used in the buffer." + (let (rtn l) + (save-excursion + (save-restriction + (widen) + (goto-char (point-min)) + (while (re-search-forward org-footnote-definition-re nil t) + (setq l (org-match-string-no-properties 2)) + (and l (add-to-list 'rtn l))) + (goto-char (point-min)) + (while (re-search-forward org-footnote-re nil t) + (setq l (or (org-match-string-no-properties 1) + (org-match-string-no-properties 2))) + (and l (not (equal l "fn:")) (add-to-list 'rtn l))))) + rtn)) + +(defun org-footnote-unique-label (&optional current) + "Return a new unique footnote label. +The returns the firsts fn:N labels that is currently not used." + (unless current (setq current (org-footnote-all-labels))) + (let ((fmt (if (eq org-footnote-auto-label 'plain) "%d" "fn:%d")) + (cnt 1)) + (while (member (format fmt cnt) current) + (incf cnt)) + (format fmt cnt))) + +(defvar org-footnote-label-history nil + "History of footnote labels entered in current buffer.") +(make-variable-buffer-local 'org-footnote-label-history) + +(defun org-footnote-new () + "Insert a new footnote. +This command prompts for a label. If this is a label referencing an +existing label, only insert the label. If the footnote label is empty +or new, let the user edit the definition of the footnote." + (interactive) + (let* ((labels (org-footnote-all-labels)) + (propose (org-footnote-unique-label labels)) + (label + (if (member org-footnote-auto-label '(t plain)) + propose + (completing-read + "Label (leave empty for anonymous): " + (mapcar 'list labels) nil nil + (if (eq org-footnote-auto-label 'confirm) propose nil) + 'org-footnote-label-history)))) + (setq label (org-footnote-normalize-label label)) + (cond + ((equal label "") + (insert "[fn:: ]") + (backward-char 1)) + ((member label labels) + (insert "[" label "]") + (message "New reference to existing note")) + (org-footnote-define-inline + (insert "[" label ": ]") + (backward-char 1) + (org-footnote-auto-adjust-maybe)) + (t + (insert "[" label "]") + (org-footnote-create-definition label) + (org-footnote-auto-adjust-maybe))))) + +(defun org-footnote-create-definition (label) + "Start the definition of a footnote with label LABEL." + (interactive "sLabel: ") + (setq label (org-footnote-normalize-label label)) + (let (re) + (cond + ((org-mode-p) + (if (not org-footnote-section) + ;; No section, put footnote into the current outline node + nil + ;; Try to find or make the special node + (setq re (concat "^\\*+[ \t]+" org-footnote-section "[ \t]*$")) + (unless (or (re-search-forward re nil t) + (and (progn (widen) t) + (re-search-forward re nil t))) + (goto-char (point-max)) + (insert "\n\n* " org-footnote-section "\n"))) + ;; Now go to the end of this entry and insert there. + (org-footnote-goto-local-insertion-point) + (org-show-context 'link-search)) + (t + (setq re (concat "^" org-footnote-tag-for-non-org-mode-files "[ \t]*$")) + (unless (re-search-forward re nil t) + (let ((max (if (and (derived-mode-p 'message-mode) + (re-search-forward message-signature-separator nil t)) + (progn (beginning-of-line) (point)) + (goto-char (point-max))))) + (skip-chars-backward " \t\r\n") + (delete-region (point) max) + (insert "\n\n") + (insert org-footnote-tag-for-non-org-mode-files "\n"))))) + ;; Skip existing footnotes + (while (re-search-forward "^[[:space:]]*\\[[^]]+\\] " nil t) + (forward-line)) + (insert "[" label "] \n") + (goto-char (1- (point))) + (message "Edit definition and go back with `C-c &' or, if unique, with `C-c C-c'."))) + +;;;###autoload +(defun org-footnote-action (&optional special) + "Do the right thing for footnotes. +When at a footnote reference, jump to the definition. When at a definition, +jump to the references. When neither at definition or reference, +create a new footnote, interactively. +With prefix arg SPECIAL, offer additional commands in a menu." + (interactive "P") + (let (tmp c) + (cond + (special + (message "Footnotes: [s]ort | [r]enumber fn:N | [S]=r+s |->[n]umeric | [d]elete") + (setq c (read-char-exclusive)) + (cond + ((equal c ?s) + (org-footnote-normalize 'sort)) + ((equal c ?r) + (org-footnote-renumber-fn:N)) + ((equal c ?S) + (org-footnote-renumber-fn:N) + (org-footnote-normalize 'sort)) + ((equal c ?n) + (org-footnote-normalize)) + ((equal c ?d) + (org-footnote-delete)) + (t (error "No such footnote command %c" c)))) + ((setq tmp (org-footnote-at-reference-p)) + (if (nth 1 tmp) + (org-footnote-goto-definition (nth 1 tmp)) + (goto-char (match-beginning 4)))) + ((setq tmp (org-footnote-at-definition-p)) + (org-footnote-goto-previous-reference (nth 1 tmp))) + (t (org-footnote-new))))) + +;;;###autoload +(defun org-footnote-normalize (&optional sort-only for-preprocessor) + "Collect the footnotes in various formats and normalize them. +This finds the different sorts of footnotes allowed in Org, and +normalizes them to the usual [N] format that is understood by the +Org-mode exporters. +When SORT-ONLY is set, only sort the footnote definitions into the +referenced sequence." + ;; This is based on Paul's function, but rewritten. + (let* ((limit-level + (and (boundp 'org-inlinetask-min-level) + org-inlinetask-min-level + (1- org-inlinetask-min-level))) + (nstars (and limit-level + (if org-odd-levels-only + (and limit-level (1- (* limit-level 2))) + limit-level))) + (outline-regexp + (concat "\\*" (if nstars (format "\\{1,%d\\} " nstars) "+ "))) + (count 0) + ref def idef ref-table beg beg1 marker a before ins-point) + (save-excursion + ;; Now find footnote references, and extract the definitions + (goto-char (point-min)) + (while (re-search-forward org-footnote-re nil t) + (unless (or (org-in-commented-line) (org-in-verbatim-emphasis) + (org-inside-latex-macro-p)) + (org-if-unprotected + (setq def (match-string 4) + idef def + ref (or (match-string 1) (match-string 2)) + before (char-to-string (char-after (match-beginning 0)))) + (if (equal ref "fn:") (setq ref nil)) + (if (and ref (setq a (assoc ref ref-table))) + (progn + (setq marker (nth 1 a)) + (unless (nth 2 a) (setf (caddr a) def))) + (setq marker (number-to-string (incf count)))) + (save-match-data + (if def + (setq def (org-trim def)) + (save-excursion + (goto-char (point-min)) + (if (not (re-search-forward (concat "^\\[" (regexp-quote ref) + "\\]") nil t)) + (setq def nil) + (setq beg (match-beginning 0)) + (setq beg1 (match-end 0)) + (re-search-forward + (org-re "^[ \t]*$\\|^\\*+ \\|^\\[\\([0-9]+\\|fn:[-_[:word:]]+\\)\\]") + nil 'move) + (setq def (buffer-substring beg1 (or (match-beginning 0) + (point-max)))) + (goto-char beg) + (skip-chars-backward " \t\n\t") + (delete-region (1+ (point)) (match-beginning 0)))))) + (unless sort-only + (replace-match (concat before "[" marker "]") t t) + (and idef + org-footnote-fill-after-inline-note-extraction + (fill-paragraph))) + (if (not a) (push (list ref marker def (if idef t nil)) + ref-table))))) + + ;; First find and remove the footnote section + (goto-char (point-min)) + (cond + ((org-mode-p) + (if (and org-footnote-section + (re-search-forward + (concat "^\\*[ \t]+" (regexp-quote org-footnote-section) + "[ \t]*$") + nil t)) + (if (or for-preprocessor (not org-footnote-section)) + (replace-match "") + (org-back-to-heading t) + (forward-line 1) + (setq ins-point (point)) + (delete-region (point) (org-end-of-subtree t))) + (goto-char (point-max)) + (unless for-preprocessor + (when org-footnote-section + (or (bolp) (insert "\n")) + (insert "* " org-footnote-section "\n") + (setq ins-point (point)))))) + (t + (if (re-search-forward + (concat "^" + (regexp-quote org-footnote-tag-for-non-org-mode-files) + "[ \t]*$") + nil t) + (replace-match "")) + (goto-char (point-max)) + (skip-chars-backward " \t\n\r") + (delete-region (point) (point-max)) + (insert "\n\n" org-footnote-tag-for-non-org-mode-files "\n") + (setq ins-point (point)))) + + ;; Insert the footnotes again + (goto-char (or ins-point (point-max))) + (setq ref-table (reverse ref-table)) + (when sort-only + ;; remove anonymous and inline footnotes from the list + (setq ref-table + (delq nil (mapcar + (lambda (x) (and (car x) + (not (equal (car x) "fn:")) + (not (nth 3 x)) + x)) + ref-table)))) + ;; Make sure each footnote has a description, or an error message. + (setq ref-table + (mapcar + (lambda (x) + (if (not (nth 2 x)) + (setcar (cddr x) + (format "FOOTNOTE DEFINITION NOT FOUND: %s" (car x))) + (setcar (cddr x) (org-trim (nth 2 x)))) + x) + ref-table)) + + (if (or (not (org-mode-p)) ; not an Org file + org-footnote-section ; we do not use a footnote section + (not sort-only) ; this is normalization + for-preprocessor) ; the is the preprocessor + ;; Insert the footnotes together in one place + (progn + (setq def + (mapconcat + (lambda (x) + (format "[%s] %s" (nth (if sort-only 0 1) x) + (org-trim (nth 2 x)))) + ref-table "\n\n")) + (if ref-table (insert "\n" def "\n\n"))) + ;; Insert each footnote near the first reference + ;; Happens only in Org files with no special footnote section, + ;; and only when doing sorting + (mapc 'org-insert-footnote-reference-near-definition + ref-table))))) + +(defun org-insert-footnote-reference-near-definition (entry) + "Find first reference of footnote ENTRY and insert the definition there. +ENTRY is (fn-label num-mark definition)." + (when (car entry) + (goto-char (point-min)) + (when (re-search-forward (format ".\\[%s[]:]" (regexp-quote (car entry))) + nil t) + (org-footnote-goto-local-insertion-point) + (insert (format "\n\n[%s] %s" (car entry) (nth 2 entry)))))) + +(defun org-footnote-goto-local-insertion-point () + "Find insertion point for footnote, just before next outline heading." + (org-with-limited-levels (outline-next-heading)) + (or (bolp) (newline)) + (beginning-of-line 0) + (while (and (not (bobp)) (= (char-after) ?#)) + (beginning-of-line 0)) + (if (looking-at "[ \t]*#\\+TBLFM:") (beginning-of-line 2)) + (end-of-line 1) + (skip-chars-backward "\n\r\t ") + (forward-line)) + +(defun org-footnote-delete (&optional label) + "Delete the footnote at point. +This will remove the definition (even multiple definitions if they exist) +and all references of a footnote label." + (catch 'done + (let (x label l beg def-re (nref 0) (ndef 0)) + (unless label + (when (setq x (org-footnote-at-reference-p)) + (setq label (nth 1 x)) + (when (or (not label) (equal "fn:" label)) + (delete-region (1+ (match-beginning 0)) (match-end 0)) + (message "Anonymous footnote removed") + (throw 'done t))) + (when (and (not label) (setq x (org-footnote-at-definition-p))) + (setq label (nth 1 x))) + (unless label (error "Don't know which footnote to remove"))) + (save-excursion + (save-restriction + (goto-char (point-min)) + (while (re-search-forward org-footnote-re nil t) + (setq l (or (match-string 1) (match-string 2))) + (when (equal l label) + (delete-region (1+ (match-beginning 0)) (match-end 0)) + (incf nref))) + (goto-char (point-min)) + (setq def-re (concat "^\\[" (regexp-quote label) "\\]")) + (while (re-search-forward def-re nil t) + (setq beg (match-beginning 0)) + (if (re-search-forward "^\\[\\|^[ \t]*$\\|^\\*+ " nil t) + (goto-char (match-beginning 0)) + (goto-char (point-max))) + (delete-region beg (point)) + (incf ndef)))) + (org-footnote-auto-adjust-maybe) + (message "%d definition(s) of and %d reference(s) of footnote %s removed" + ndef nref label)))) + +(defun org-footnote-renumber-fn:N () + "Renumber the simple footnotes like fn:17 into a sequence in the document." + (interactive) + (let (map i (n 0)) + (save-excursion + (save-restriction + (widen) + (goto-char (point-min)) + (while (re-search-forward "\\[fn:\\([0-9]+\\)[]:]" nil t) + (setq i (string-to-number (match-string 1))) + (when (and (string-match "\\S-" (buffer-substring + (point-at-bol) (match-beginning 0))) + (not (assq i map))) + (push (cons i (number-to-string (incf n))) map))) + (goto-char (point-min)) + (while (re-search-forward "\\(\\[fn:\\)\\([0-9]+\\)\\([]:]\\)" nil t) + (replace-match (concat "\\1" (cdr (assq (string-to-number (match-string 2)) map)) "\\3"))))))) + +(defun org-footnote-auto-adjust-maybe () + "Renumber and/or sort footnotes according to user settings." + (when (memq org-footnote-auto-adjust '(t renumber)) + (org-footnote-renumber-fn:N)) + (when (memq org-footnote-auto-adjust '(t sort)) + (let ((label (nth 1 (org-footnote-at-definition-p)))) + (org-footnote-normalize 'sort) + (when label + (goto-char (point-min)) + (and (re-search-forward (concat "^\\[" (regexp-quote label) "\\]") + nil t) + (progn (insert " ") + (just-one-space))))))) + +(provide 'org-footnote) + +;; arch-tag: 1b5954df-fb5d-4da5-8709-78d944dbfc37 + +;;; org-footnote.el ends here diff --git a/.emacs.d/org-7.4/lisp/org-footnote.elc b/.emacs.d/org-7.4/lisp/org-footnote.elc Binary files differnew file mode 100644 index 0000000..0f98d19 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-footnote.elc diff --git a/.emacs.d/org-7.4/lisp/org-freemind.el b/.emacs.d/org-7.4/lisp/org-freemind.el new file mode 100644 index 0000000..d9486af --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-freemind.el @@ -0,0 +1,1243 @@ +;;; org-freemind.el --- Export Org files to freemind + +;; Copyright (C) 2009, 2010 Free Software Foundation, Inc. + +;; Author: Lennart Borgman (lennart O borgman A gmail O com) +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; Version: 7.4 +;; +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;; -------------------------------------------------------------------- +;; Features that might be required by this library: +;; +;; `backquote', `bytecomp', `cl', `easymenu', `font-lock', +;; `noutline', `org', `org-compat', `org-faces', `org-footnote', +;; `org-list', `org-macs', `org-src', `outline', `syntax', +;; `time-date', `xml'. +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: +;; +;; This file tries to implement some functions useful for +;; transformation between org-mode and FreeMind files. +;; +;; Here are the commands you can use: +;; +;; M-x `org-freemind-from-org-mode' +;; M-x `org-freemind-from-org-mode-node' +;; M-x `org-freemind-from-org-sparse-tree' +;; +;; M-x `org-freemind-to-org-mode' +;; +;; M-x `org-freemind-show' +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Change log: +;; +;; 2009-02-15: Added check for next level=current+1 +;; 2009-02-21: Fixed bug in `org-freemind-to-org-mode'. +;; 2009-10-25: Added support for `org-odd-levels-only'. +;; Added y/n question before showing in FreeMind. +;; 2009-11-04: Added support for #+BEGIN_HTML. +;; +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, or +;; (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth +;; Floor, Boston, MA 02110-1301, USA. +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Code: + +(require 'xml) +(require 'org) +;(require 'rx) +(require 'org-exp) +(eval-when-compile (require 'cl)) + +(defgroup org-freemind nil + "Customization group for org-freemind export/import." + :group 'org) + +;; Fix-me: I am not sure these are useful: +;; +;; (defcustom org-freemind-main-fgcolor "black" +;; "Color of main node's text." +;; :type 'color +;; :group 'org-freemind) + +;; (defcustom org-freemind-main-color "black" +;; "Background color of main node." +;; :type 'color +;; :group 'org-freemind) + +;; (defcustom org-freemind-child-fgcolor "black" +;; "Color of child nodes' text." +;; :type 'color +;; :group 'org-freemind) + +;; (defcustom org-freemind-child-color "black" +;; "Background color of child nodes." +;; :type 'color +;; :group 'org-freemind) + +(defvar org-freemind-node-style nil "Internal use.") + +(defcustom org-freemind-node-styles nil + "Styles to apply to node. +NOT READY YET." + :type '(repeat + (list :tag "Node styles for file" + (regexp :tag "File name") + (repeat + (list :tag "Node" + (regexp :tag "Node name regexp") + (set :tag "Node properties" + (list :format "%v" (const :format "" node-style) + (choice :tag "Style" + :value bubble + (const bubble) + (const fork))) + (list :format "%v" (const :format "" color) + (color :tag "Color" :value "red")) + (list :format "%v" (const :format "" background-color) + (color :tag "Background color" :value "yellow")) + (list :format "%v" (const :format "" edge-color) + (color :tag "Edge color" :value "green")) + (list :format "%v" (const :format "" edge-style) + (choice :tag "Edge style" :value bezier + (const :tag "Linear" linear) + (const :tag "Bezier" bezier) + (const :tag "Sharp Linear" sharp-linear) + (const :tag "Sharp Bezier" sharp-bezier))) + (list :format "%v" (const :format "" edge-width) + (choice :tag "Edge width" :value thin + (const :tag "Parent" parent) + (const :tag "Thin" thin) + (const 1) + (const 2) + (const 4) + (const 8))) + (list :format "%v" (const :format "" italic) + (const :tag "Italic font" t)) + (list :format "%v" (const :format "" bold) + (const :tag "Bold font" t)) + (list :format "%v" (const :format "" font-name) + (string :tag "Font name" :value "SansSerif")) + (list :format "%v" (const :format "" font-size) + (integer :tag "Font size" :value 12))))))) + :group 'org-freemind) + +;;;###autoload +(defun org-export-as-freemind (&optional hidden ext-plist + to-buffer body-only pub-dir) + "Export the current buffer as a Freemind file. +If there is an active region, export only the region. HIDDEN is +obsolete and does nothing. EXT-PLIST is a property list with +external parameters overriding org-mode's default settings, but +still inferior to file-local settings. When TO-BUFFER is +non-nil, create a buffer with that name and export to that +buffer. If TO-BUFFER is the symbol `string', don't leave any +buffer behind but just return the resulting HTML as a string. +When BODY-ONLY is set, don't produce the file header and footer, +simply return the content of the document (all top level +sections). When PUB-DIR is set, use this as the publishing +directory. + +See `org-freemind-from-org-mode' for more information." + (interactive "P") + (let* ((opt-plist (org-combine-plists (org-default-export-plist) + ext-plist + (org-infile-export-plist))) + (region-p (org-region-active-p)) + (rbeg (and region-p (region-beginning))) + (rend (and region-p (region-end))) + (subtree-p + (if (plist-get opt-plist :ignore-subtree-p) + nil + (when region-p + (save-excursion + (goto-char rbeg) + (and (org-at-heading-p) + (>= (org-end-of-subtree t t) rend)))))) + (opt-plist (setq org-export-opt-plist + (if subtree-p + (org-export-add-subtree-options opt-plist rbeg) + opt-plist))) + (bfname (buffer-file-name (or (buffer-base-buffer) (current-buffer)))) + (filename (concat (file-name-as-directory + (or pub-dir + (org-export-directory :ascii opt-plist))) + (file-name-sans-extension + (or (and subtree-p + (org-entry-get (region-beginning) + "EXPORT_FILE_NAME" t)) + (file-name-nondirectory bfname))) + ".mm"))) + (when (file-exists-p filename) + (delete-file filename)) + (cond + (subtree-p + (org-freemind-from-org-mode-node (line-number-at-pos rbeg) + filename)) + (t (org-freemind-from-org-mode bfname filename))))) + +;;;###autoload +(defun org-freemind-show (mm-file) + "Show file MM-FILE in Freemind." + (interactive + (list + (save-match-data + (let ((name (read-file-name "FreeMind file: " + nil nil nil + (if (buffer-file-name) + (let* ((name-ext (file-name-nondirectory (buffer-file-name))) + (name (file-name-sans-extension name-ext)) + (ext (file-name-extension name-ext))) + (cond + ((string= "mm" ext) + name-ext) + ((string= "org" ext) + (let ((name-mm (concat name ".mm"))) + (if (file-exists-p name-mm) + name-mm + (message "Not exported to Freemind format yet") + ""))) + (t + ""))) + "") + ;; Fix-me: Is this an Emacs bug? + ;; This predicate function is never + ;; called. + (lambda (fn) + (string-match "^mm$" (file-name-extension fn)))))) + (setq name (expand-file-name name)) + name)))) + (org-open-file mm-file)) + +(defconst org-freemind-org-nfix "--org-mode: ") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Format converters + +(defun org-freemind-escape-str-from-org (org-str) + "Do some html-escaping of ORG-STR and return the result. +The characters \"&<> will be escaped." + (let ((chars (append org-str nil)) + (fm-str "")) + (dolist (cc chars) + (setq fm-str + (concat fm-str + (if (< cc 160) + (cond + ((= cc ?\") """) + ((= cc ?\&) "&") + ((= cc ?\<) "<") + ((= cc ?\>) ">") + (t (char-to-string cc))) + ;; Formatting as &#number; is maybe needed + ;; according to a bug report from kazuo + ;; fujimoto, but I have now instead added a xml + ;; processing instruction saying that the mm + ;; file is utf-8: + ;; + ;; (format "&#x%x;" (- cc ;; ?\x800)) + (format "&#x%x;" (encode-char cc 'ucs)) + )))) + fm-str)) + +;;(org-freemind-unescape-str-to-org "mA≌B<C<=") +;;(org-freemind-unescape-str-to-org "<<") +(defun org-freemind-unescape-str-to-org (fm-str) + "Do some html-unescaping of FM-STR and return the result. +This is the opposite of `org-freemind-escape-str-from-org' but it +will also unescape &#nn;." + (let ((org-str fm-str)) + (setq org-str (replace-regexp-in-string """ "\"" org-str)) + (setq org-str (replace-regexp-in-string "&" "&" org-str)) + (setq org-str (replace-regexp-in-string "<" "<" org-str)) + (setq org-str (replace-regexp-in-string ">" ">" org-str)) + (setq org-str (replace-regexp-in-string + "&#x\\([a-f0-9]\\{2,4\\}\\);" + (lambda (m) + (char-to-string + (+ (string-to-number (match-string 1 m) 16) + 0 ;?\x800 ;; What is this for? Encoding? + ))) + org-str)))) + +;; (let* ((str1 "a quote: \", an amp: &, lt: <; over 256: öåäÖÅÄ") +;; (str2 (org-freemind-escape-str-from-org str1)) +;; (str3 (org-freemind-unescape-str-to-org str2))) +;; (unless (string= str1 str3) +;; (error "Error str3=%s" str3))) + +(defun org-freemind-convert-links-helper (matched) + "Helper for `org-freemind-convert-links-from-org'. +MATCHED is the link just matched." + (let* ((link (match-string 1 matched)) + (text (match-string 2 matched)) + (ext (file-name-extension link)) + (col-pos (string-match-p ":" link)) + (is-img (and (image-type-from-file-name link) + (let ((url-type (substring link 0 col-pos))) + (member url-type '("file" "http" "https"))))) + ) + (if is-img + ;; Fix-me: I can't find a way to get the border to "shrink + ;; wrap" around the image using <div>. + ;; + ;; (concat "<div style=\"border: solid 1px #ddd; width:auto;\">" + ;; "<img src=\"" link "\" alt=\"" text "\" />" + ;; "<br />" + ;; "<i>" text "</i>" + ;; "</div>") + (concat "<table border=\"0\" style=\"border: solid 1px #ddd;\"><tr><td>" + "<img src=\"" link "\" alt=\"" text "\" />" + "<br />" + "<i>" text "</i>" + "</td></tr></table>") + (concat "<a href=\"" link "\">" text "</a>")))) + +(defun org-freemind-convert-links-from-org (org-str) + "Convert org links in ORG-STR to freemind links and return the result." + (let ((fm-str (replace-regexp-in-string + ;;(rx (not (any "[\"")) + ;; (submatch + ;; "http" + ;; (opt ?\s) + ;; "://" + ;; (1+ + ;; (any "-%.?@a-zA-Z0-9()_/:~=&#")))) + "[^\"[]\\(http ?://[--:#%&()=?-Z_a-z~]+\\)" + "[[\\1][\\1]]" + org-str + nil ;; fixedcase + nil ;; literal + 1 ;; subexp + ))) + (replace-regexp-in-string + ;;(rx "[[" + ;; (submatch (*? nonl)) + ;; "][" + ;; (submatch (*? nonl)) + ;; "]]") + "\\[\\[\\(.*?\\)]\\[\\(.*?\\)]]" + ;;"<a href=\"\\1\">\\2</a>" + 'org-freemind-convert-links-helper + fm-str))) + +;;(org-freemind-convert-links-to-org "<a href=\"http://www.somewhere/\">link-text</a>") +(defun org-freemind-convert-links-to-org (fm-str) + "Convert freemind links in FM-STR to org links and return the result." + (let ((org-str (replace-regexp-in-string + ;;(rx "<a" + ;; space + ;; (0+ + ;; (0+ (not (any ">"))) + ;; space) + ;; "href=\"" + ;; (submatch (0+ (not (any "\"")))) + ;; "\"" + ;; (0+ (not (any ">"))) + ;; ">" + ;; (submatch (0+ (not (any "<")))) + ;; "</a>") + "<a[[:space:]]\\(?:[^>]*[[:space:]]\\)*href=\"\\([^\"]*\\)\"[^>]*>\\([^<]*\\)</a>" + "[[\\1][\\2]]" + fm-str))) + org-str)) + +;; Fix-me: +;;(defun org-freemind-convert-drawers-from-org (text) +;; ) + +;; (let* ((str1 "[[http://www.somewhere/][link-text]") +;; (str2 (org-freemind-convert-links-from-org str1)) +;; (str3 (org-freemind-convert-links-to-org str2))) +;; (unless (string= str1 str3) +;; (error "Error str3=%s" str3))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Org => FreeMind + +(defvar org-freemind-bol-helper-base-indent nil) + +(defun org-freemind-bol-helper (matched) + "Helper for `org-freemind-convert-text-p'. +MATCHED is the link just matched." + (let ((res "") + (bi org-freemind-bol-helper-base-indent)) + (dolist (cc (append matched nil)) + (if (= 32 cc) + ;;(setq res (concat res " ")) + ;; We need to use the numerical version. Otherwise Freemind + ;; ver 0.9.0 RC9 can not export to html/javascript. + (progn + (if (< 0 bi) + (setq bi (1- bi)) + (setq res (concat res " ")))) + (setq res (concat res (char-to-string cc))))) + res)) +;; (setq x (replace-regexp-in-string "\n +" 'org-freemind-bol-nbsp-helper "\n ")) + +(defun org-freemind-convert-text-p (text) + "Convert TEXT to html with <p> paragraphs." + ;; (string-match-p "[^ ]" " a") + (setq org-freemind-bol-helper-base-indent (string-match-p "[^ ]" text)) + (setq text (org-freemind-escape-str-from-org text)) + + (setq text (replace-regexp-in-string "\\([[:space:]]\\)\\(/\\)\\([^/]+\\)\\(/\\)\\([[:space:]]\\)" "\\1<i>\\3</i>\\5" text)) + (setq text (replace-regexp-in-string "\\([[:space:]]\\)\\(\*\\)\\([^*]+\\)\\(\*\\)\\([[:space:]]\\)" "\\1<b>\\3</b>\\5" text)) + + (setq text (concat "<p>" text)) + (setq text (replace-regexp-in-string "\n[[:blank:]]*\n" "</p><p>" text)) + (setq text (replace-regexp-in-string "\\(?:<p>\\|\n\\) +" 'org-freemind-bol-helper text)) + (setq text (replace-regexp-in-string "\n" "<br />" text)) + (setq text (concat text "</p>")) + + (org-freemind-convert-links-from-org text)) + +(defcustom org-freemind-node-css-style + "p { margin-top: 3px; margin-bottom: 3px; }" + "CSS style for Freemind nodes." + ;; Fix-me: I do not understand this. It worked to export from Freemind + ;; with this setting now, but not before??? Was this perhaps a java + ;; bug or is it a windows xp bug (some resource gets exhausted if you + ;; use sticky keys which I do). + :group 'org-freemind) + +(defun org-freemind-org-text-to-freemind-subnode/note (node-name start end drawers-regexp) + "Convert text part of org node to freemind subnode or note. +Convert the text part of the org node named NODE-NAME. The text +is in the current buffer between START and END. Drawers matching +DRAWERS-REGEXP are converted to freemind notes." + ;; fix-me: doc + (let ((text (buffer-substring-no-properties start end)) + (node-res "") + (note-res "")) + (save-match-data + ;;(setq text (org-freemind-escape-str-from-org text)) + ;; First see if there is something that should be moved to the + ;; note part: + (let (drawers) + (while (string-match drawers-regexp text) + (setq drawers (cons (match-string 0 text) drawers)) + (setq text + (concat (substring text 0 (match-beginning 0)) + (substring text (match-end 0)))) + ) + (when drawers + (dolist (drawer drawers) + (let ((lines (split-string drawer "\n"))) + (dolist (line lines) + (setq note-res (concat + note-res + org-freemind-org-nfix line "<br />\n"))) + )))) + + (when (> (length note-res) 0) + (setq note-res (concat + "<richcontent TYPE=\"NOTE\"><html>\n" + "<head>\n" + "</head>\n" + "<body>\n" + note-res + "</body>\n" + "</html>\n" + "</richcontent>\n")) + ) + + ;; There is always an LF char: + (when (> (length text) 1) + (setq node-res (concat + "<node style=\"bubble\" background_color=\"#eeee00\">\n" + "<richcontent TYPE=\"NODE\"><html>\n" + "<head>\n" + (if (= 0 (length org-freemind-node-css-style)) + "" + (concat + "<style type=\"text/css\">\n" + "<!--\n" + org-freemind-node-css-style + "-->\n" + "</style>\n")) + "</head>\n" + "<body>\n")) + (let ((begin-html-mark (regexp-quote "#+BEGIN_HTML")) + (end-html-mark (regexp-quote "#+END_HTML")) + head + end-pos + end-pos-match + ) + ;; Take care of #+BEGIN_HTML - #+END_HTML + (while (string-match begin-html-mark text) + (setq head (substring text 0 (match-beginning 0))) + (setq end-pos-match (match-end 0)) + (setq node-res (concat node-res + (org-freemind-convert-text-p head))) + (setq text (substring text end-pos-match)) + (setq end-pos (string-match end-html-mark text)) + (if end-pos + (setq end-pos-match (match-end 0)) + (message "org-freemind: Missing #+END_HTML") + (setq end-pos (length text)) + (setq end-pos-match end-pos)) + (setq node-res (concat node-res + (substring text 0 end-pos))) + (setq text (substring text end-pos-match))) + (setq node-res (concat node-res + (org-freemind-convert-text-p text)))) + (setq node-res (concat + node-res + "</body>\n" + "</html>\n" + "</richcontent>\n" + ;; Put a note that this is for the parent node + ;; "<richcontent TYPE=\"NOTE\"><html>" + ;; "<head>" + ;; "</head>" + ;; "<body>" + ;; "<p>" + ;; "-- This is more about \"" node-name "\" --" + ;; "</p>" + ;; "</body>" + ;; "</html>" + ;; "</richcontent>\n" + note-res + "</node>\n" ;; ok + ))) + (list node-res note-res)))) + +(defun org-freemind-write-node (mm-buffer drawers-regexp + num-left-nodes base-level + current-level next-level this-m2 + this-node-end + this-children-visible + next-node-start + next-has-some-visible-child) + (let* (this-icons + this-bg-color + this-m2-escaped + this-rich-node + this-rich-note + ) + (when (string-match "TODO" this-m2) + (setq this-m2 (replace-match "" nil nil this-m2)) + (add-to-list 'this-icons "button_cancel") + (setq this-bg-color "#ffff88") + (when (string-match "\\[#\\(.\\)\\]" this-m2) + (let ((prior (string-to-char (match-string 1 this-m2)))) + (setq this-m2 (replace-match "" nil nil this-m2)) + (cond + ((= prior ?A) + (add-to-list 'this-icons "full-1") + (setq this-bg-color "#ff0000")) + ((= prior ?B) + (add-to-list 'this-icons "full-2") + (setq this-bg-color "#ffaa00")) + ((= prior ?C) + (add-to-list 'this-icons "full-3") + (setq this-bg-color "#ffdd00")) + ((= prior ?D) + (add-to-list 'this-icons "full-4") + (setq this-bg-color "#ffff00")) + ((= prior ?E) + (add-to-list 'this-icons "full-5")) + ((= prior ?F) + (add-to-list 'this-icons "full-6")) + ((= prior ?G) + (add-to-list 'this-icons "full-7")) + )))) + (setq this-m2 (org-trim this-m2)) + (setq this-m2-escaped (org-freemind-escape-str-from-org this-m2)) + (let ((node-notes (org-freemind-org-text-to-freemind-subnode/note + this-m2-escaped + this-node-end + (1- next-node-start) + drawers-regexp))) + (setq this-rich-node (nth 0 node-notes)) + (setq this-rich-note (nth 1 node-notes))) + (with-current-buffer mm-buffer + (insert "<node text=\"" this-m2-escaped "\"") + (org-freemind-get-node-style this-m2) + (when (> next-level current-level) + (unless (or this-children-visible + next-has-some-visible-child) + (insert " folded=\"true\""))) + (when (and (= current-level (1+ base-level)) + (> num-left-nodes 0)) + (setq num-left-nodes (1- num-left-nodes)) + (insert " position=\"left\"")) + (when this-bg-color + (insert " background_color=\"" this-bg-color "\"")) + (insert ">\n") + (when this-icons + (dolist (icon this-icons) + (insert "<icon builtin=\"" icon "\"/>\n"))) + ) + (with-current-buffer mm-buffer + ;;(when this-rich-note (insert this-rich-note)) + (when this-rich-node (insert this-rich-node)))) + num-left-nodes) + +(defun org-freemind-check-overwrite (file interactively) + "Check if file FILE already exists. +If FILE does not exists return t. + +If INTERACTIVELY is non-nil ask if the file should be replaced +and return t/nil if it should/should not be replaced. + +Otherwise give an error say the file exists." + (if (file-exists-p file) + (if interactively + (y-or-n-p (format "File %s exists, replace it? " file)) + (error "File %s already exists" file)) + t)) + +(defvar org-freemind-node-pattern + ;;(rx bol + ;; (submatch (1+ "*")) + ;; (1+ space) + ;; (submatch (*? nonl)) + ;; eol) + "^\\(\\*+\\)[[:space:]]+\\(.*?\\)$") + +(defun org-freemind-look-for-visible-child (node-level) + (save-excursion + (save-match-data + (let ((found-visible-child nil)) + (while (and (not found-visible-child) + (re-search-forward org-freemind-node-pattern nil t)) + (let* ((m1 (match-string-no-properties 1)) + (level (length m1))) + (if (>= node-level level) + (setq found-visible-child 'none) + (unless (get-char-property (line-beginning-position) 'invisible) + (setq found-visible-child 'found))))) + (eq found-visible-child 'found) + )))) + +(defun org-freemind-goto-line (line) + "Go to line number LINE." + (save-restriction + (widen) + (goto-char (point-min)) + (forward-line (1- line)))) + +(defun org-freemind-write-mm-buffer (org-buffer mm-buffer node-at-line) + (with-current-buffer org-buffer + (dolist (node-style org-freemind-node-styles) + (when (string-match-p (car node-style) buffer-file-name) + (setq org-freemind-node-style (cadr node-style)))) + ;;(message "org-freemind-node-style =%s" org-freemind-node-style) + (save-match-data + (let* ((drawers (copy-sequence org-drawers)) + drawers-regexp + (num-top1-nodes 0) + (num-top2-nodes 0) + num-left-nodes + (unclosed-nodes 0) + (odd-only org-odd-levels-only) + (first-time t) + (current-level 1) + base-level + prev-node-end + rich-text + unfinished-tag + node-at-line-level + node-at-line-last) + (with-current-buffer mm-buffer + (erase-buffer) + (setq buffer-file-coding-system 'utf-8) + ;; Fix-me: Currentl Freemind (ver 0.9.0 RC9) does not support this: + ;;(insert "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n") + (insert "<map version=\"0.9.0\">\n") + (insert "<!-- To view this file, download free mind mapping software FreeMind from http://freemind.sourceforge.net -->\n")) + (save-excursion + ;; Get special buffer vars: + (goto-char (point-min)) + (message "Writing Freemind file...") + (while (re-search-forward "^#\\+DRAWERS:" nil t) + (let ((dr-txt (buffer-substring-no-properties (match-end 0) (line-end-position)))) + (setq drawers (append drawers (split-string dr-txt) nil)))) + (setq drawers-regexp + (concat "^[[:blank:]]*:" + (regexp-opt drawers) + ;;(rx ":" (0+ blank) + ;; "\n" + ;; (*? anything) + ;; "\n" + ;; (0+ blank) + ;; ":END:" + ;; (0+ blank) + ;; eol) + ":[[:blank:]]*\n\\(?:.\\|\n\\)*?\n[[:blank:]]*:END:[[:blank:]]*$" + )) + + (if node-at-line + ;; Get number of top nodes and last line for this node + (progn + (org-freemind-goto-line node-at-line) + (unless (looking-at org-freemind-node-pattern) + (error "No node at line %s" node-at-line)) + (setq node-at-line-level (length (match-string-no-properties 1))) + (forward-line) + (setq node-at-line-last + (catch 'last-line + (while (re-search-forward org-freemind-node-pattern nil t) + (let* ((m1 (match-string-no-properties 1)) + (level (length m1))) + (if (<= level node-at-line-level) + (progn + (beginning-of-line) + (throw 'last-line (1- (point)))) + (if (= level (1+ node-at-line-level)) + (setq num-top2-nodes (1+ num-top2-nodes)))))))) + (setq current-level node-at-line-level) + (setq num-top1-nodes 1) + (org-freemind-goto-line node-at-line)) + + ;; First get number of top nodes + (goto-char (point-min)) + (while (re-search-forward org-freemind-node-pattern nil t) + (let* ((m1 (match-string-no-properties 1)) + (level (length m1))) + (if (= level 1) + (setq num-top1-nodes (1+ num-top1-nodes)) + (if (= level 2) + (setq num-top2-nodes (1+ num-top2-nodes)))))) + ;; If there is more than one top node we need to insert a node + ;; to keep them together. + (goto-char (point-min)) + (when (> num-top1-nodes 1) + (setq num-top2-nodes num-top1-nodes) + (setq current-level 0) + (let ((orig-name (if buffer-file-name + (file-name-nondirectory (buffer-file-name)) + (buffer-name)))) + (with-current-buffer mm-buffer + (insert "<node text=\"" orig-name "\" background_color=\"#00bfff\">\n" + ;; Put a note that this is for the parent node + "<richcontent TYPE=\"NOTE\"><html>" + "<head>" + "</head>" + "<body>" + "<p>" + org-freemind-org-nfix "WHOLE FILE" + "</p>" + "</body>" + "</html>" + "</richcontent>\n"))))) + + (setq num-left-nodes (floor num-top2-nodes 2)) + (setq base-level current-level) + (let (this-m2 + this-node-end + this-children-visible + next-m2 + next-node-start + next-level + next-has-some-visible-child + next-children-visible + ) + (while (and + (re-search-forward org-freemind-node-pattern nil t) + (if node-at-line-last (<= (point) node-at-line-last) t) + ) + (let* ((next-m1 (match-string-no-properties 1)) + (next-node-end (match-end 0)) + ) + (setq next-node-start (match-beginning 0)) + (setq next-m2 (match-string-no-properties 2)) + (setq next-level (length next-m1)) + (setq next-children-visible + (not (eq 'outline + (get-char-property (line-end-position) 'invisible)))) + (setq next-has-some-visible-child + (if next-children-visible t + (org-freemind-look-for-visible-child next-level))) + (when this-m2 + (setq num-left-nodes (org-freemind-write-node mm-buffer drawers-regexp num-left-nodes base-level current-level next-level this-m2 this-node-end this-children-visible next-node-start next-has-some-visible-child))) + (when (if (= num-top1-nodes 1) (> current-level base-level) t) + (while (>= current-level next-level) + (with-current-buffer mm-buffer + (insert "</node>\n") + (setq current-level + (- current-level (if odd-only 2 1)))))) + (setq this-node-end (1+ next-node-end)) + (setq this-m2 next-m2) + (setq current-level next-level) + (setq this-children-visible next-children-visible) + (forward-char) + )) +;;; (unless (if node-at-line-last +;;; (>= (point) node-at-line-last) +;;; nil) + ;; Write last node: + (setq this-m2 next-m2) + (setq current-level next-level) + (setq next-node-start (if node-at-line-last + (1+ node-at-line-last) + (point-max))) + (setq num-left-nodes (org-freemind-write-node mm-buffer drawers-regexp num-left-nodes base-level current-level next-level this-m2 this-node-end this-children-visible next-node-start next-has-some-visible-child)) + (with-current-buffer mm-buffer (insert "</node>\n")) + ;) + ) + (with-current-buffer mm-buffer + (while (> current-level base-level) + (insert "</node>\n") + (setq current-level + (- current-level (if odd-only 2 1))) + )) + (with-current-buffer mm-buffer + (insert "</map>") + (delete-trailing-whitespace) + (goto-char (point-min)) + )))))) + +(defun org-freemind-get-node-style (node-name) + "NOT READY YET." + ;;<node BACKGROUND_COLOR="#eeee00" CREATED="1234668815593" MODIFIED="1234668815593" STYLE="bubble"> + ;;<font BOLD="true" NAME="SansSerif" SIZE="12"/> + (let (node-styles + node-style) + (dolist (style-list org-freemind-node-style) + (let ((node-regexp (car style-list))) + (message "node-regexp=%s node-name=%s" node-regexp node-name) + (when (string-match-p node-regexp node-name) + ;;(setq node-style (org-freemind-do-apply-node-style style-list)) + (setq node-style (cadr style-list)) + (when node-style + (message "node-style=%s" node-style) + (setq node-styles (append node-styles node-style))) + ))))) + +(defun org-freemind-do-apply-node-style (style-list) + (message "style-list=%S" style-list) + (let ((node-style 'fork) + (color "red") + (background-color "yellow") + (edge-color "green") + (edge-style 'bezier) + (edge-width 'thin) + (italic t) + (bold t) + (font-name "SansSerif") + (font-size 12)) + (dolist (style (cadr style-list)) + (message " style=%s" style) + (let ((what (car style))) + (cond + ((eq what 'node-style) + (setq node-style (cadr style))) + ((eq what 'color) + (setq color (cadr style))) + ((eq what 'background-color) + (setq background-color (cadr style))) + + ((eq what 'edge-color) + (setq edge-color (cadr style))) + + ((eq what 'edge-style) + (setq edge-style (cadr style))) + + ((eq what 'edge-width) + (setq edge-width (cadr style))) + + ((eq what 'italic) + (setq italic (cadr style))) + + ((eq what 'bold) + (setq bold (cadr style))) + + ((eq what 'font-name) + (setq font-name (cadr style))) + + ((eq what 'font-size) + (setq font-size (cadr style))) + ) + (insert (format " style=\"%s\"" node-style)) + (insert (format " color=\"%s\"" color)) + (insert (format " background_color=\"%s\"" background-color)) + (insert ">\n") + (insert "<edge") + (insert (format " color=\"%s\"" edge-color)) + (insert (format " style=\"%s\"" edge-style)) + (insert (format " width=\"%s\"" edge-width)) + (insert "/>\n") + (insert "<font") + (insert (format " italic=\"%s\"" italic)) + (insert (format " bold=\"%s\"" bold)) + (insert (format " name=\"%s\"" font-name)) + (insert (format " size=\"%s\"" font-size)) + )))) + +;;;###autoload +(defun org-freemind-from-org-mode-node (node-line mm-file) + "Convert node at line NODE-LINE to the FreeMind file MM-FILE. +See `org-freemind-from-org-mode' for more information." + (interactive + (progn + (unless (org-back-to-heading nil) + (error "Can't find org-mode node start")) + (let* ((line (line-number-at-pos)) + (default-mm-file (concat (if buffer-file-name + (file-name-nondirectory buffer-file-name) + "nofile") + "-line-" (number-to-string line) + ".mm")) + (mm-file (read-file-name "Output FreeMind file: " nil nil nil default-mm-file))) + (list line mm-file)))) + (when (org-freemind-check-overwrite mm-file (org-called-interactively-p 'any)) + (let ((org-buffer (current-buffer)) + (mm-buffer (find-file-noselect mm-file))) + (org-freemind-write-mm-buffer org-buffer mm-buffer node-line) + (with-current-buffer mm-buffer + (basic-save-buffer) + (when (org-called-interactively-p 'any) + (switch-to-buffer-other-window mm-buffer) + (when (y-or-n-p "Show in FreeMind? ") + (org-freemind-show buffer-file-name))))))) + +;;;###autoload +(defun org-freemind-from-org-mode (org-file mm-file) + "Convert the `org-mode' file ORG-FILE to the FreeMind file MM-FILE. +All the nodes will be opened or closed in Freemind just as you +have them in `org-mode'. + +Note that exporting to Freemind also gives you an alternative way +to export from `org-mode' to html. You can create a dynamic html +version of the your org file, by first exporting to Freemind and +then exporting from Freemind to html. The 'As +XHTML (JavaScript)' version in Freemind works very well \(and you +can use a CSS stylesheet to style it)." + ;; Fix-me: better doc, include recommendations etc. + (interactive + (let* ((org-file buffer-file-name) + (default-mm-file (concat + (if org-file + (file-name-nondirectory org-file) + "nofile") + ".mm")) + (mm-file (read-file-name "Output FreeMind file: " nil nil nil default-mm-file))) + (list org-file mm-file))) + (when (org-freemind-check-overwrite mm-file (org-called-interactively-p 'any)) + (let ((org-buffer (if org-file (find-file-noselect org-file) (current-buffer))) + (mm-buffer (find-file-noselect mm-file))) + (org-freemind-write-mm-buffer org-buffer mm-buffer nil) + (with-current-buffer mm-buffer + (basic-save-buffer) + (when (org-called-interactively-p 'any) + (switch-to-buffer-other-window mm-buffer) + (when (y-or-n-p "Show in FreeMind? ") + (org-freemind-show buffer-file-name))))))) + +;;;###autoload +(defun org-freemind-from-org-sparse-tree (org-buffer mm-file) + "Convert visible part of buffer ORG-BUFFER to FreeMind file MM-FILE." + (interactive + (let* ((org-file buffer-file-name) + (default-mm-file (concat + (if org-file + (file-name-nondirectory org-file) + "nofile") + "-sparse.mm")) + (mm-file (read-file-name "Output FreeMind file: " nil nil nil default-mm-file))) + (list (current-buffer) mm-file))) + (when (org-freemind-check-overwrite mm-file (org-called-interactively-p 'any)) + (let (org-buffer + (mm-buffer (find-file-noselect mm-file))) + (save-window-excursion + (org-export-visible ?\ nil) + (setq org-buffer (current-buffer))) + (org-freemind-write-mm-buffer org-buffer mm-buffer nil) + (with-current-buffer mm-buffer + (basic-save-buffer) + (when (org-called-interactively-p 'any) + (switch-to-buffer-other-window mm-buffer) + (when (y-or-n-p "Show in FreeMind? ") + (org-freemind-show buffer-file-name))))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; FreeMind => Org + +;; (sort '(b a c) 'org-freemind-lt-symbols) +(defun org-freemind-lt-symbols (sym-a sym-b) + (string< (symbol-name sym-a) (symbol-name sym-b))) +;; (sort '((b . 1) (a . 2) (c . 3)) 'org-freemind-lt-xml-attrs) +(defun org-freemind-lt-xml-attrs (attr-a attr-b) + (string< (symbol-name (car attr-a)) (symbol-name (car attr-b)))) + +;; xml-parse-region gives things like +;; ((p nil "\n" +;; (a +;; ((href . "link")) +;; "text") +;; "\n" +;; (b nil "hej") +;; "\n")) + +;; '(a . nil) + +;; (org-freemind-symbols= 'a (car '(A B))) +(defsubst org-freemind-symbols= (sym-a sym-b) + "Return t if downcased names of SYM-A and SYM-B are equal. +SYM-A and SYM-B should be symbols." + (or (eq sym-a sym-b) + (string= (downcase (symbol-name sym-a)) + (downcase (symbol-name sym-b))))) + +(defun org-freemind-get-children (parent path) + "Find children node to PARENT from PATH. +PATH should be a list of steps, where each step has the form + + '(NODE-NAME (ATTR-NAME . ATTR-VALUE))" + ;; Fix-me: maybe implement op? step: Name, number, attr, attr op val + ;; Fix-me: case insensitive version for children? + (let* ((children (if (not (listp (car parent))) + (cddr parent) + (let (cs) + (dolist (p parent) + (dolist (c (cddr p)) + (add-to-list 'cs c))) + cs) + )) + (step (car path)) + (step-node (if (listp step) (car step) step)) + (step-attr-list (when (listp step) (sort (cdr step) 'org-freemind-lt-xml-attrs))) + (path-tail (cdr path)) + path-children) + (dolist (child children) + ;; skip xml.el formatting nodes + (unless (stringp child) + ;; compare node name + (when (if (not step-node) + t ;; any node name + (org-freemind-symbols= step-node (car child))) + (if (not step-attr-list) + ;;(throw 'path-child child) ;; no attr to care about + (add-to-list 'path-children child) + (let* ((child-attr-list (cadr child)) + (step-attr-copy (copy-sequence step-attr-list))) + (dolist (child-attr child-attr-list) + ;; Compare attr names: + (when (org-freemind-symbols= (caar step-attr-copy) (car child-attr)) + ;; Compare values: + (let ((step-val (cdar step-attr-copy)) + (child-val (cdr child-attr))) + (when (if (not step-val) + t ;; any value + (string= step-val child-val)) + (setq step-attr-copy (cdr step-attr-copy)))))) + ;; Did we find all? + (unless step-attr-copy + ;;(throw 'path-child child) + (add-to-list 'path-children child) + )))))) + (if path-tail + (org-freemind-get-children path-children path-tail) + path-children))) + +(defun org-freemind-get-richcontent-node (node) + (let ((rc-nodes + (org-freemind-get-children node '((richcontent (type . "NODE")) html body)))) + (when (> (length rc-nodes) 1) + (lwarn t :warning "Unexpected structure: several <richcontent type=\"NODE\" ...>")) + (car rc-nodes))) + +(defun org-freemind-get-richcontent-note (node) + (let ((rc-notes + (org-freemind-get-children node '((richcontent (type . "NOTE")) html body)))) + (when (> (length rc-notes) 1) + (lwarn t :warning "Unexpected structure: several <richcontent type=\"NOTE\" ...>")) + (car rc-notes))) + +(defun org-freemind-test-get-tree-text () + (let ((node '(p nil "\n" + (a + ((href . "link")) + "text") + "\n" + (b nil "hej") + "\n"))) + (org-freemind-get-tree-text node))) +;; (org-freemind-test-get-tree-text) + +(defun org-freemind-get-tree-text (node) + (when node + (let ((ntxt "") + (link nil) + (lf-after nil)) + (dolist (n node) + (case n + ;;(a (setq is-link t) ) + ((h1 h2 h3 h4 h5 h6 p) + ;;(setq ntxt (concat "\n" ntxt)) + (setq lf-after 2) + ) + (br + (setq lf-after 1) + ) + (t + (cond + ((stringp n) + (when (string= n "\n") (setq n "")) + (if link + (setq ntxt (concat ntxt + "[[" link "][" n "]]")) + (setq ntxt (concat ntxt n)))) + ((and n (listp n)) + (if (symbolp (car n)) + (setq ntxt (concat ntxt (org-freemind-get-tree-text n))) + ;; This should be the attributes: + (dolist (att-val n) + (let ((att (car att-val)) + (val (cdr att-val))) + (when (eq att 'href) + (setq link val))))) + ))))) + (if lf-after + (setq ntxt (concat ntxt (make-string lf-after ?\n))) + (setq ntxt (concat ntxt " "))) + ;;(setq ntxt (concat ntxt (format "{%s}" n))) + ntxt))) + +(defun org-freemind-get-richcontent-node-text (node) + "Get the node text as from the richcontent node NODE." + (save-match-data + (let* ((rc (org-freemind-get-richcontent-node node)) + (txt (org-freemind-get-tree-text rc))) + ;;(when txt (setq txt (replace-regexp-in-string "[[:space:]]+" " " txt))) + txt + ))) + +(defun org-freemind-get-richcontent-note-text (node) + "Get the node text as from the richcontent note NODE." + (save-match-data + (let* ((rc (org-freemind-get-richcontent-note node)) + (txt (when rc (org-freemind-get-tree-text rc)))) + ;;(when txt (setq txt (replace-regexp-in-string "[[:space:]]+" " " txt))) + txt + ))) + +(defun org-freemind-get-icon-names (node) + (let* ((icon-nodes (org-freemind-get-children node '((icon )))) + names) + (dolist (icn icon-nodes) + (setq names (cons (cdr (assq 'builtin (cadr icn))) names))) + ;; (icon (builtin . "full-1")) + names)) + +(defun org-freemind-node-to-org (node level skip-levels) + (let ((qname (car node)) + (attributes (cadr node)) + text + ;; Fix-me: note is never inserted + (note (org-freemind-get-richcontent-note-text node)) + (mark "-- This is more about ") + (icons (org-freemind-get-icon-names node)) + (children (cddr node))) + (when (< 0 (- level skip-levels)) + (dolist (attrib attributes) + (case (car attrib) + ('TEXT (setq text (cdr attrib))) + ('text (setq text (cdr attrib))))) + (unless text + ;; There should be a richcontent node holding the text: + (setq text (org-freemind-get-richcontent-node-text node))) + (when icons + (when (member "full-1" icons) (setq text (concat "[#A] " text))) + (when (member "full-2" icons) (setq text (concat "[#B] " text))) + (when (member "full-3" icons) (setq text (concat "[#C] " text))) + (when (member "full-4" icons) (setq text (concat "[#D] " text))) + (when (member "full-5" icons) (setq text (concat "[#E] " text))) + (when (member "full-6" icons) (setq text (concat "[#F] " text))) + (when (member "full-7" icons) (setq text (concat "[#G] " text))) + (when (member "button_cancel" icons) (setq text (concat "TODO " text))) + ) + (if (and note + (string= mark (substring note 0 (length mark)))) + (progn + (setq text (replace-regexp-in-string "\n $" "" text)) + (insert text)) + (case qname + ('node + (insert (make-string (- level skip-levels) ?*) " " text "\n") + (when note + (insert ":COMMENT:\n" note "\n:END:\n")) + )))) + (dolist (child children) + (unless (or (null child) + (stringp child)) + (org-freemind-node-to-org child (1+ level) skip-levels))))) + +;; Fix-me: put back special things, like drawers that are stored in +;; the notes. Should maybe all notes contents be put in drawers? +;;;###autoload +(defun org-freemind-to-org-mode (mm-file org-file) + "Convert FreeMind file MM-FILE to `org-mode' file ORG-FILE." + (interactive + (save-match-data + (let* ((mm-file (buffer-file-name)) + (default-org-file (concat (file-name-nondirectory mm-file) ".org")) + (org-file (read-file-name "Output org-mode file: " nil nil nil default-org-file))) + (list mm-file org-file)))) + (when (org-freemind-check-overwrite org-file (org-called-interactively-p 'any)) + (let ((mm-buffer (find-file-noselect mm-file)) + (org-buffer (find-file-noselect org-file))) + (with-current-buffer mm-buffer + (let* ((xml-list (xml-parse-file mm-file)) + (top-node (cadr (cddar xml-list))) + (note (org-freemind-get-richcontent-note-text top-node)) + (skip-levels + (if (and note + (string-match "^--org-mode: WHOLE FILE$" note)) + 1 + 0))) + (with-current-buffer org-buffer + (erase-buffer) + (org-freemind-node-to-org top-node 1 skip-levels) + (goto-char (point-min)) + (org-set-tags t t) ;; Align all tags + ) + (switch-to-buffer-other-window org-buffer) + ))))) + +(provide 'org-freemind) + +;; arch-tag: e7b0d776-94fd-404a-b35e-0f855fae3627 + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; org-freemind.el ends here diff --git a/.emacs.d/org-7.4/lisp/org-freemind.elc b/.emacs.d/org-7.4/lisp/org-freemind.elc Binary files differnew file mode 100644 index 0000000..3cf0ab2 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-freemind.elc diff --git a/.emacs.d/org-7.4/lisp/org-gnus.el b/.emacs.d/org-7.4/lisp/org-gnus.el new file mode 100644 index 0000000..fccd3e9 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-gnus.el @@ -0,0 +1,263 @@ +;;; org-gnus.el --- Support for links to Gnus groups and messages from within Org-mode + +;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010 +;; Free Software Foundation, Inc. + +;; Author: Carsten Dominik <carsten at orgmode dot org> +;; Tassilo Horn <tassilo at member dot fsf dot org> +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; Version: 7.4 +;; +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: + +;; This file implements links to Gnus groups and messages from within Org-mode. +;; Org-mode loads this module by default - if this is not what you want, +;; configure the variable `org-modules'. + +;;; Code: + +(require 'org) +(eval-when-compile (require 'gnus-sum)) + +;; Declare external functions and variables +(declare-function message-fetch-field "message" (header &optional not-all)) +(declare-function message-narrow-to-head-1 "message" nil) +(declare-function nnimap-group-overview-filename "nnimap" (group server)) +;; The following line suppresses a compiler warning stemming from gnus-sum.el +(declare-function gnus-summary-last-subject "gnus-sum" nil) +;; Customization variables + +(when (fboundp 'defvaralias) + (defvaralias 'org-usenet-links-prefer-google 'org-gnus-prefer-web-links)) + +(defcustom org-gnus-prefer-web-links nil + "If non-nil, `org-store-link' creates web links to Google groups or Gmane. +When nil, Gnus will be used for such links. +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-store + :type 'boolean) + +(defcustom org-gnus-nnimap-query-article-no-from-file nil + "If non-nil, `org-gnus-follow-link' will try to translate +Message-Ids to article numbers by querying the .overview file. +Normally, this translation is done by querying the IMAP server, +which is usually very fast. Unfortunately, some (maybe badly +configured) IMAP servers don't support this operation quickly. +So if following a link to a Gnus article takes ages, try setting +this variable to `t'." + :group 'org-link-store + :type 'boolean) + + +;; Install the link type +(org-add-link-type "gnus" 'org-gnus-open) +(add-hook 'org-store-link-functions 'org-gnus-store-link) + +;; Implementation + +(defun org-gnus-nnimap-cached-article-number (group server message-id) + "Return cached article number (uid) of message in GROUP on SERVER. +MESSAGE-ID is the message-id header field that identifies the +message. If the uid is not cached, return nil." + (with-temp-buffer + (let ((nov (nnimap-group-overview-filename group server))) + (when (file-exists-p nov) + (mm-insert-file-contents nov) + (set-buffer-modified-p nil) + (goto-char (point-min)) + (catch 'found + (while (search-forward message-id nil t) + (let ((hdr (split-string (thing-at-point 'line) "\t"))) + (if (string= (nth 4 hdr) message-id) + (throw 'found (nth 0 hdr)))))))))) + +(defun org-gnus-group-link (group) + "Create a link to the Gnus group GROUP. +If GROUP is a newsgroup and `org-gnus-prefer-web-links' is +non-nil, create a link to groups.google.com or gmane.org. +Otherwise create a link to the group inside Gnus. + +If `org-store-link' was called with a prefix arg the meaning of +`org-gnus-prefer-web-links' is reversed." + (let ((unprefixed-group (replace-regexp-in-string "^[^:]+:" "" group))) + (if (and (string-match "^nntp" group) ;; Only for nntp groups + (org-xor current-prefix-arg + org-gnus-prefer-web-links)) + (org-make-link (if (string-match "gmane" unprefixed-group) + "http://news.gmane.org/" + "http://groups.google.com/group/") + unprefixed-group) + (org-make-link "gnus:" group)))) + +(defun org-gnus-article-link (group newsgroups message-id x-no-archive) + "Create a link to a Gnus article. +The article is specified by its MESSAGE-ID. Additional +parameters are the Gnus GROUP, the NEWSGROUPS the article was +posted to and the X-NO-ARCHIVE header value of that article. + +If GROUP is a newsgroup and `org-gnus-prefer-web-links' is +non-nil, create a link to groups.google.com or gmane.org. +Otherwise create a link to the article inside Gnus. + +If `org-store-link' was called with a prefix arg the meaning of +`org-gnus-prefer-web-links' is reversed." + (if (and (org-xor current-prefix-arg org-gnus-prefer-web-links) + newsgroups ;; Make web links only for nntp groups + (not x-no-archive)) ;; and if X-No-Archive isn't set. + (format (if (string-match "gmane\\." newsgroups) + "http://mid.gmane.org/%s" + "http://groups.google.com/groups/search?as_umsgid=%s") + (org-fixup-message-id-for-http message-id)) + (org-make-link "gnus:" group "#" message-id))) + +(defun org-gnus-store-link () + "Store a link to a Gnus folder or message." + (cond + ((eq major-mode 'gnus-group-mode) + (let* ((group (cond ((fboundp 'gnus-group-group-name) ; depending on Gnus + (gnus-group-group-name)) ; version + ((fboundp 'gnus-group-name) + (gnus-group-name)) + (t "???"))) + desc link) + (when group + (org-store-link-props :type "gnus" :group group) + (setq desc (org-gnus-group-link group) + link desc) + (org-add-link-props :link link :description desc) + link))) + + ((memq major-mode '(gnus-summary-mode gnus-article-mode)) + (let* ((group gnus-newsgroup-name) + (header (with-current-buffer gnus-summary-buffer + (gnus-summary-article-header))) + (from (mail-header-from header)) + (message-id (org-remove-angle-brackets (mail-header-id header))) + (date (mail-header-date header)) + (date-ts (and date (format-time-string + (org-time-stamp-format t) (date-to-time date)))) + (date-ts-ia (and date (format-time-string + (org-time-stamp-format t t) + (date-to-time date)))) + (subject (copy-sequence (mail-header-subject header))) + (to (cdr (assq 'To (mail-header-extra header)))) + newsgroups x-no-archive desc link) + ;; Remove text properties of subject string to avoid Emacs bug + ;; #3506 + (set-text-properties 0 (length subject) nil subject) + + ;; Fetching an article is an expensive operation; newsgroup and + ;; x-no-archive are only needed for web links. + (when (org-xor current-prefix-arg org-gnus-prefer-web-links) + ;; Make sure the original article buffer is up-to-date + (save-window-excursion (gnus-summary-select-article)) + (setq to (or to (gnus-fetch-original-field "To")) + newsgroups (gnus-fetch-original-field "Newsgroups") + x-no-archive (gnus-fetch-original-field "x-no-archive"))) + (org-store-link-props :type "gnus" :from from :subject subject + :message-id message-id :group group :to to) + (when date + (org-add-link-props :date date :date-timestamp date-ts + :date-timestamp-inactive date-ts-ia)) + (setq desc (org-email-link-description) + link (org-gnus-article-link + group newsgroups message-id x-no-archive)) + (org-add-link-props :link link :description desc) + link)))) + +(defun org-gnus-open-nntp (path) + "Follow the nntp: link specified by PATH." + (let* ((spec (split-string path "/")) + (server (split-string (nth 2 spec) "@")) + (group (nth 3 spec)) + (article (nth 4 spec))) + (org-gnus-follow-link + (format "nntp+%s:%s" (or (cdr server) (car server)) group) + article))) + +(defun org-gnus-open (path) + "Follow the Gnus message or folder link specified by PATH." + (let (group article) + (if (not (string-match "\\`\\([^#]+\\)\\(#\\(.*\\)\\)?" path)) + (error "Error in Gnus link")) + (setq group (match-string 1 path) + article (match-string 3 path)) + (when group + (setq group (org-substring-no-properties group))) + (when article + (setq article (org-substring-no-properties article))) + (org-gnus-follow-link group article))) + +(defun org-gnus-follow-link (&optional group article) + "Follow a Gnus link to GROUP and ARTICLE." + (require 'gnus) + (funcall (cdr (assq 'gnus org-link-frame-setup))) + (if gnus-other-frame-object (select-frame gnus-other-frame-object)) + (when group + (setq group (org-substring-no-properties group))) + (when article + (setq article (org-substring-no-properties article))) + (cond ((and group article) + (gnus-activate-group group t) + (condition-case nil + (let* ((method (gnus-find-method-for-group group)) + (backend (car method)) + (server (cadr method))) + (cond + ((eq backend 'nndoc) + (if (gnus-group-read-group t nil group) + (gnus-summary-goto-article article nil t) + (message "Couldn't follow gnus link. %s" + "The summary couldn't be opened."))) + (t + (let ((articles 1) + group-opened) + (when (and (eq backend 'nnimap) + org-gnus-nnimap-query-article-no-from-file) + (setq article + (or (org-gnus-nnimap-cached-article-number + (nth 1 (split-string group ":")) + server (concat "<" article ">")) article))) + (while (and (not group-opened) + ;; stop on integer overflows + (> articles 0)) + (setq group-opened (gnus-group-read-group + articles nil group) + articles (if (< articles 16) + (1+ articles) + (* articles 2)))) + (if group-opened + (gnus-summary-goto-article article nil t) + (message "Couldn't follow gnus link. %s" + "The summary couldn't be opened.")))))) + (quit (message "Couldn't follow gnus link. %s" + "The linked group is empty.")))) + (group (gnus-group-jump-to-group group)))) + +(defun org-gnus-no-new-news () + "Like `M-x gnus' but doesn't check for new news." + (if (not (gnus-alive-p)) (gnus))) + +(provide 'org-gnus) + +;; arch-tag: 512e0840-58fa-45b3-b456-71e10fa2376d + +;;; org-gnus.el ends here diff --git a/.emacs.d/org-7.4/lisp/org-gnus.elc b/.emacs.d/org-7.4/lisp/org-gnus.elc Binary files differnew file mode 100644 index 0000000..9191171 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-gnus.elc diff --git a/.emacs.d/org-7.4/lisp/org-habit.el b/.emacs.d/org-7.4/lisp/org-habit.el new file mode 100644 index 0000000..b174a1f --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-habit.el @@ -0,0 +1,355 @@ +;;; org-habit.el --- The habit tracking code for Org-mode + +;; Copyright (C) 2009, 2010 Free Software Foundation, Inc. + +;; Author: John Wiegley <johnw at gnu dot org> +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; Version: 7.4 +;; +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: + +;; This file contains the habit tracking code for Org-mode + +;;; Code: + +(require 'org) +(require 'org-agenda) + +(eval-when-compile + (require 'cl)) + +(defgroup org-habit nil + "Options concerning habit tracking in Org-mode." + :tag "Org Habit" + :group 'org-progress) + +(defcustom org-habit-graph-column 40 + "The absolute column at which to insert habit consistency graphs. +Note that consistency graphs will overwrite anything else in the buffer." + :group 'org-habit + :type 'integer) + +(defcustom org-habit-preceding-days 21 + "Number of days before today to appear in consistency graphs." + :group 'org-habit + :type 'integer) + +(defcustom org-habit-following-days 7 + "Number of days after today to appear in consistency graphs." + :group 'org-habit + :type 'integer) + +(defcustom org-habit-show-habits t + "If non-nil, show habits in agenda buffers." + :group 'org-habit + :type 'boolean) + +(defcustom org-habit-show-habits-only-for-today t + "If non-nil, only show habits on today's agenda, and not for future days. +Note that even when shown for future days, the graph is always +relative to the current effective date." + :group 'org-habit + :type 'boolean) + +(defface org-habit-clear-face + '((((background light)) (:background "#8270f9")) + (((background dark)) (:background "blue"))) + "Face for days on which a task shouldn't be done yet." + :group 'org-habit + :group 'org-faces) +(defface org-habit-clear-future-face + '((((background light)) (:background "#d6e4fc")) + (((background dark)) (:background "midnightblue"))) + "Face for future days on which a task shouldn't be done yet." + :group 'org-habit + :group 'org-faces) + +(defface org-habit-ready-face + '((((background light)) (:background "#4df946")) + (((background dark)) (:background "forestgreen"))) + "Face for days on which a task should start to be done." + :group 'org-habit + :group 'org-faces) +(defface org-habit-ready-future-face + '((((background light)) (:background "#acfca9")) + (((background dark)) (:background "darkgreen"))) + "Face for days on which a task should start to be done." + :group 'org-habit + :group 'org-faces) + +(defface org-habit-alert-face + '((((background light)) (:background "#f5f946")) + (((background dark)) (:background "gold"))) + "Face for days on which a task is due." + :group 'org-habit + :group 'org-faces) +(defface org-habit-alert-future-face + '((((background light)) (:background "#fafca9")) + (((background dark)) (:background "darkgoldenrod"))) + "Face for days on which a task is due." + :group 'org-habit + :group 'org-faces) + +(defface org-habit-overdue-face + '((((background light)) (:background "#f9372d")) + (((background dark)) (:background "firebrick"))) + "Face for days on which a task is overdue." + :group 'org-habit + :group 'org-faces) +(defface org-habit-overdue-future-face + '((((background light)) (:background "#fc9590")) + (((background dark)) (:background "darkred"))) + "Face for days on which a task is overdue." + :group 'org-habit + :group 'org-faces) + +(defun org-habit-duration-to-days (ts) + (if (string-match "\\([0-9]+\\)\\([dwmy]\\)" ts) + ;; lead time is specified. + (floor (* (string-to-number (match-string 1 ts)) + (cdr (assoc (match-string 2 ts) + '(("d" . 1) ("w" . 7) + ("m" . 30.4) ("y" . 365.25)))))) + (error "Invalid duration string: %s" ts))) + +(defun org-is-habit-p (&optional pom) + "Is the task at POM or point a habit?" + (string= "habit" (org-entry-get (or pom (point)) "STYLE"))) + +(defun org-habit-parse-todo (&optional pom) + "Parse the TODO surrounding point for its habit-related data. +Returns a list with the following elements: + + 0: Scheduled date for the habit (may be in the past) + 1: \".+\"-style repeater for the schedule, in days + 2: Optional deadline (nil if not present) + 3: If deadline, the repeater for the deadline, otherwise nil + 4: A list of all the past dates this todo was mark closed + +This list represents a \"habit\" for the rest of this module." + (save-excursion + (if pom (goto-char pom)) + (assert (org-is-habit-p (point))) + (let* ((scheduled (org-get-scheduled-time (point))) + (scheduled-repeat (org-get-repeat org-scheduled-string)) + (end (org-entry-end-position)) + (habit-entry (org-no-properties (nth 4 (org-heading-components)))) + closed-dates deadline dr-days sr-days) + (if scheduled + (setq scheduled (time-to-days scheduled)) + (error "Habit %s has no scheduled date" habit-entry)) + (unless scheduled-repeat + (error + "Habit '%s' has no scheduled repeat period or has an incorrect one" + habit-entry)) + (setq sr-days (org-habit-duration-to-days scheduled-repeat)) + (unless (> sr-days 0) + (error "Habit %s scheduled repeat period is less than 1d" habit-entry)) + (when (string-match "/\\([0-9]+[dwmy]\\)" scheduled-repeat) + (setq dr-days (org-habit-duration-to-days + (match-string-no-properties 1 scheduled-repeat))) + (if (<= dr-days sr-days) + (error "Habit %s deadline repeat period is less than or equal to scheduled (%s)" + habit-entry scheduled-repeat)) + (setq deadline (+ scheduled (- dr-days sr-days)))) + (org-back-to-heading t) + (while (re-search-forward "- State \"DONE\".*\\[\\([^]]+\\)\\]" end t) + (push (time-to-days + (org-time-string-to-time (match-string-no-properties 1))) + closed-dates)) + (list scheduled sr-days deadline dr-days closed-dates)))) + +(defsubst org-habit-scheduled (habit) + (nth 0 habit)) +(defsubst org-habit-scheduled-repeat (habit) + (nth 1 habit)) +(defsubst org-habit-deadline (habit) + (let ((deadline (nth 2 habit))) + (or deadline + (if (nth 3 habit) + (+ (org-habit-scheduled habit) + (1- (org-habit-scheduled-repeat habit))) + (org-habit-scheduled habit))))) +(defsubst org-habit-deadline-repeat (habit) + (or (nth 3 habit) + (org-habit-scheduled-repeat habit))) +(defsubst org-habit-done-dates (habit) + (nth 4 habit)) + +(defsubst org-habit-get-priority (habit &optional moment) + "Determine the relative priority of a habit. +This must take into account not just urgency, but consistency as well." + (let ((pri 1000) + (now (if moment (time-to-days moment) (org-today))) + (scheduled (org-habit-scheduled habit)) + (deadline (org-habit-deadline habit))) + ;; add 10 for every day past the scheduled date, and subtract for every + ;; day before it + (setq pri (+ pri (* (- now scheduled) 10))) + ;; add 50 if the deadline is today + (if (and (/= scheduled deadline) + (= now deadline)) + (setq pri (+ pri 50))) + ;; add 100 for every day beyond the deadline date, and subtract 10 for + ;; every day before it + (let ((slip (- now (1- deadline)))) + (if (> slip 0) + (setq pri (+ pri (* slip 100))) + (setq pri (+ pri (* slip 10))))) + pri)) + +(defun org-habit-get-faces (habit &optional now-days scheduled-days donep) + "Return faces for HABIT relative to NOW-DAYS and SCHEDULED-DAYS. +NOW-DAYS defaults to the current time's days-past-the-epoch if nil. +SCHEDULED-DAYS defaults to the habit's actual scheduled days if nil. + +Habits are assigned colors on the following basis: + Blue Task is before the scheduled date. + Green Task is on or after scheduled date, but before the + end of the schedule's repeat period. + Yellow If the task has a deadline, then it is after schedule's + repeat period, but before the deadline. + Orange The task has reached the deadline day, or if there is + no deadline, the end of the schedule's repeat period. + Red The task has gone beyond the deadline day or the + schedule's repeat period." + (let* ((scheduled (or scheduled-days (org-habit-scheduled habit))) + (s-repeat (org-habit-scheduled-repeat habit)) + (scheduled-end (+ scheduled (1- s-repeat))) + (d-repeat (org-habit-deadline-repeat habit)) + (deadline (if scheduled-days + (+ scheduled-days (- d-repeat s-repeat)) + (org-habit-deadline habit))) + (m-days (or now-days (time-to-days (current-time))))) + (cond + ((< m-days scheduled) + '(org-habit-clear-face . org-habit-clear-future-face)) + ((< m-days deadline) + '(org-habit-ready-face . org-habit-ready-future-face)) + ((= m-days deadline) + (if donep + '(org-habit-ready-face . org-habit-ready-future-face) + '(org-habit-alert-face . org-habit-alert-future-face))) + (t + '(org-habit-overdue-face . org-habit-overdue-future-face))))) + +(defun org-habit-build-graph (habit starting current ending) + "Build a graph for the given HABIT, from STARTING to ENDING. +CURRENT gives the current time between STARTING and ENDING, for +the purpose of drawing the graph. It need not be the actual +current time." + (let* ((done-dates (sort (org-habit-done-dates habit) '<)) + (scheduled (org-habit-scheduled habit)) + (s-repeat (org-habit-scheduled-repeat habit)) + (start (time-to-days starting)) + (now (time-to-days current)) + (end (time-to-days ending)) + (graph (make-string (1+ (- end start)) ?\ )) + (index 0) + last-done-date) + (while (and done-dates (< (car done-dates) start)) + (setq last-done-date (car done-dates) + done-dates (cdr done-dates))) + (while (< start end) + (let* ((in-the-past-p (< start now)) + (todayp (= start now)) + (donep (and done-dates + (= start (car done-dates)))) + (faces (if (and in-the-past-p + (not last-done-date) + (not (< scheduled now))) + '(org-habit-clear-face . org-habit-clear-future-face) + (org-habit-get-faces + habit start (and in-the-past-p + (if last-done-date + (+ last-done-date s-repeat) + scheduled)) + donep))) + markedp face) + (if donep + (let ((done-time (time-add + starting + (days-to-time + (- start (time-to-days starting)))))) + + (aset graph index ?*) + (setq markedp t) + (put-text-property + index (1+ index) 'help-echo + (format-time-string (org-time-stamp-format) done-time) graph) + (while (and done-dates + (= start (car done-dates))) + (setq last-done-date (car done-dates) + done-dates (cdr done-dates)))) + (if todayp + (aset graph index ?!))) + (setq face (if (or in-the-past-p todayp) + (car faces) + (cdr faces))) + (if (and in-the-past-p + (not (eq face 'org-habit-overdue-face)) + (not markedp)) + (setq face (cdr faces))) + (put-text-property index (1+ index) 'face face graph)) + (setq start (1+ start) + index (1+ index))) + graph)) + +(defun org-habit-insert-consistency-graphs (&optional line) + "Insert consistency graph for any habitual tasks." + (let ((inhibit-read-only t) l c + (buffer-invisibility-spec '(org-link)) + (moment (time-subtract (current-time) + (list 0 (* 3600 org-extend-today-until) 0)))) + (save-excursion + (goto-char (if line (point-at-bol) (point-min))) + (while (not (eobp)) + (let ((habit (get-text-property (point) 'org-habit-p))) + (when habit + (move-to-column org-habit-graph-column t) + (delete-char (min (+ 1 org-habit-preceding-days + org-habit-following-days) + (- (line-end-position) (point)))) + (insert (org-habit-build-graph + habit + (time-subtract moment + (days-to-time org-habit-preceding-days)) + moment + (time-add moment + (days-to-time org-habit-following-days)))))) + (forward-line))))) + +(defun org-habit-toggle-habits () + "Toggle display of habits in an agenda buffer." + (interactive) + (org-agenda-check-type t 'agenda) + (setq org-habit-show-habits (not org-habit-show-habits)) + (org-agenda-redo) + (org-agenda-set-mode-name) + (message "Habits turned %s" + (if org-habit-show-habits "on" "off"))) + +(org-defkey org-agenda-mode-map "K" 'org-habit-toggle-habits) + +(provide 'org-habit) + +;; arch-tag: 64e070d9-bd09-4917-bd44-44465f5ed348 + +;;; org-habit.el ends here diff --git a/.emacs.d/org-7.4/lisp/org-habit.elc b/.emacs.d/org-7.4/lisp/org-habit.elc Binary files differnew file mode 100644 index 0000000..248fd1c --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-habit.elc diff --git a/.emacs.d/org-7.4/lisp/org-html.el b/.emacs.d/org-7.4/lisp/org-html.el new file mode 100644 index 0000000..47e8231 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-html.el @@ -0,0 +1,2419 @@ +;;; org-html.el --- HTML export for Org-mode + +;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010 +;; Free Software Foundation, Inc. + +;; Author: Carsten Dominik <carsten at orgmode dot org> +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; Version: 7.4 +;; +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: + +;;; Code: + +(require 'org-exp) + +(eval-when-compile (require 'cl)) + +(declare-function org-id-find-id-file "org-id" (id)) +(declare-function htmlize-region "ext:htmlize" (beg end)) + +(defgroup org-export-html nil + "Options specific for HTML export of Org-mode files." + :tag "Org Export HTML" + :group 'org-export) + +(defcustom org-export-html-footnotes-section "<div id=\"footnotes\"> +<h2 class=\"footnotes\">%s: </h2> +<div id=\"text-footnotes\"> +%s +</div> +</div>" + "Format for the footnotes section. +Should contain a two instances of %s. The first will be replaced with the +language-specific word for \"Footnotes\", the second one will be replaced +by the footnotes themselves." + :group 'org-export-html + :type 'string) + +(defcustom org-export-html-footnote-format "<sup>%s</sup>" + "The format for the footnote reference. +%s will be replaced by the footnote reference itself." + :group 'org-export-html + :type 'string) + +(defcustom org-export-html-coding-system nil + "Coding system for HTML export, defaults to `buffer-file-coding-system'." + :group 'org-export-html + :type 'coding-system) + +(defcustom org-export-html-extension "html" + "The extension for exported HTML files." + :group 'org-export-html + :type 'string) + +(defcustom org-export-html-xml-declaration + '(("html" . "<?xml version=\"1.0\" encoding=\"%s\"?>") + ("php" . "<?php echo \"<?xml version=\\\"1.0\\\" encoding=\\\"%s\\\" ?>\"; ?>")) + "The extension for exported HTML files. +%s will be replaced with the charset of the exported file. +This may be a string, or an alist with export extensions +and corresponding declarations." + :group 'org-export-html + :type '(choice + (string :tag "Single declaration") + (repeat :tag "Dependent on extension" + (cons (string :tag "Extension") + (string :tag "Declaration"))))) + +(defcustom org-export-html-style-include-scripts t + "Non-nil means include the JavaScript snippets in exported HTML files. +The actual script is defined in `org-export-html-scripts' and should +not be modified." + :group 'org-export-html + :type 'boolean) + +(defconst org-export-html-scripts +"<script type=\"text/javascript\"> +<!--/*--><![CDATA[/*><!--*/ + function CodeHighlightOn(elem, id) + { + var target = document.getElementById(id); + if(null != target) { + elem.cacheClassElem = elem.className; + elem.cacheClassTarget = target.className; + target.className = \"code-highlighted\"; + elem.className = \"code-highlighted\"; + } + } + function CodeHighlightOff(elem, id) + { + var target = document.getElementById(id); + if(elem.cacheClassElem) + elem.className = elem.cacheClassElem; + if(elem.cacheClassTarget) + target.className = elem.cacheClassTarget; + } +/*]]>*///--> +</script>" +"Basic JavaScript that is needed by HTML files produced by Org-mode.") + +(defconst org-export-html-style-default +"<style type=\"text/css\"> + <!--/*--><![CDATA[/*><!--*/ + html { font-family: Times, serif; font-size: 12pt; } + .title { text-align: center; } + .todo { color: red; } + .done { color: green; } + .tag { background-color: #add8e6; font-weight:normal } + .target { } + .timestamp { color: #bebebe; } + .timestamp-kwd { color: #5f9ea0; } + .right {margin-left:auto; margin-right:0px; text-align:right;} + .left {margin-left:0px; margin-right:auto; text-align:left;} + .center {margin-left:auto; margin-right:auto; text-align:center;} + p.verse { margin-left: 3% } + pre { + border: 1pt solid #AEBDCC; + background-color: #F3F5F7; + padding: 5pt; + font-family: courier, monospace; + font-size: 90%; + overflow:auto; + } + table { border-collapse: collapse; } + td, th { vertical-align: top; } + th.right { text-align:center; } + th.left { text-align:center; } + th.center { text-align:center; } + td.right { text-align:right; } + td.left { text-align:left; } + td.center { text-align:center; } + dt { font-weight: bold; } + div.figure { padding: 0.5em; } + div.figure p { text-align: center; } + textarea { overflow-x: auto; } + .linenr { font-size:smaller } + .code-highlighted {background-color:#ffff00;} + .org-info-js_info-navigation { border-style:none; } + #org-info-js_console-label { font-size:10px; font-weight:bold; + white-space:nowrap; } + .org-info-js_search-highlight {background-color:#ffff00; color:#000000; + font-weight:bold; } + /*]]>*/--> +</style>" + "The default style specification for exported HTML files. +Please use the variables `org-export-html-style' and +`org-export-html-style-extra' to add to this style. If you wish to not +have the default style included, customize the variable +`org-export-html-style-include-default'.") + +(defcustom org-export-html-style-include-default t + "Non-nil means include the default style in exported HTML files. +The actual style is defined in `org-export-html-style-default' and should +not be modified. Use the variables `org-export-html-style' to add +your own style information." + :group 'org-export-html + :type 'boolean) +;;;###autoload +(put 'org-export-html-style-include-default 'safe-local-variable 'booleanp) + +(defcustom org-export-html-style "" + "Org-wide style definitions for exported HTML files. + +This variable needs to contain the full HTML structure to provide a style, +including the surrounding HTML tags. If you set the value of this variable, +you should consider to include definitions for the following classes: + title, todo, done, timestamp, timestamp-kwd, tag, target. + +For example, a valid value would be: + + <style type=\"text/css\"> + <![CDATA[ + p { font-weight: normal; color: gray; } + h1 { color: black; } + .title { text-align: center; } + .todo, .timestamp-kwd { color: red; } + .done { color: green; } + ]]> + </style> + +If you'd like to refer to en external style file, use something like + + <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. +See also the variable `org-export-html-style-extra'." + :group 'org-export-html + :type 'string) +;;;###autoload +(put 'org-export-html-style 'safe-local-variable 'stringp) + +(defcustom org-export-html-style-extra "" + "Additional style information for HTML export. +The value of this variable is inserted into the HTML buffer right after +the value of `org-export-html-style'. Use this variable for per-file +settings of style information, and do not forget to surround the style +settings with <style>...</style> tags." + :group 'org-export-html + :type 'string) +;;;###autoload +(put 'org-export-html-style-extra 'safe-local-variable 'stringp) + +(defcustom org-export-html-mathjax-options + '((path "http://orgmode.org/mathjax/MathJax.js") + (scale "100") + (align "center") + (indent "2em") + (mathml nil)) + "Options for MathJax setup. + +path The path where to find MathJax +scale Scaling for the HTML-CSS backend, usually between 100 and 133 +align How to align display math: left, center, or right +indent If align is not center, how far from the left/right side? +mathml Should a MathML player be used if available? + This is faster and reduces bandwidth use, but currently + sometimes has lower spacing quality. Therefore, the default is + nil. When browsers get better, this switch can be flipped. + +You can also customize this for each buffer, using something like + +#+MATHJAX: scale:\"133\" align:\"right\" mathml:t path:\"/MathJax/\"" + :group 'org-export-html + :type '(list :greedy t + (list :tag "path (the path from where to load MathJax.js)" + (const :format " " path) (string)) + (list :tag "scale (scaling for the displayed math)" + (const :format " " scale) (string)) + (list :tag "align (alignment of displayed equations)" + (const :format " " align) (string)) + (list :tag "indent (indentation with left or right alignment)" + (const :format " " indent) (string)) + (list :tag "mathml (should MathML display be used is possible)" + (const :format " " mathml) (boolean)))) + +(defun org-export-html-mathjax-config (template options in-buffer) + "Insert the user setup into the matchjax template." + (let (name val (yes " ") (no "// ") x) + (mapc + (lambda (e) + (setq name (car e) val (nth 1 e)) + (if (string-match (concat "\\<" (symbol-name name) ":") in-buffer) + (setq val (car (read-from-string + (substring in-buffer (match-end 0)))))) + (if (not (stringp val)) (setq val (format "%s" val))) + (if (string-match (concat "%" (upcase (symbol-name name))) template) + (setq template (replace-match val t t template)))) + options) + (setq val (nth 1 (assq 'mathml options))) + (if (string-match (concat "\\<mathml:") in-buffer) + (setq val (car (read-from-string + (substring in-buffer (match-end 0)))))) + ;; Exchange prefixes depending on mathml setting + (if (not val) (setq x yes yes no no x)) + ;; Replace cookies to turn on or off the config/jax lines + (if (string-match ":MMLYES:" template) + (setq template (replace-match yes t t template))) + (if (string-match ":MMLNO:" template) + (setq template (replace-match no t t template))) + ;; Return the modified template + template)) + +(defcustom org-export-html-mathjax-template + "<script type=\"text/javascript\" src=\"%PATH\"> +<!--/*--><![CDATA[/*><!--*/ + MathJax.Hub.Config({ + // Only one of the two following lines, depending on user settings + // First allows browser-native MathML display, second forces HTML/CSS + :MMLYES: config: [\"MMLorHTML.js\"], jax: [\"input/TeX\"], + :MMLNO: jax: [\"input/TeX\", \"output/HTML-CSS\"], + extensions: [\"tex2jax.js\",\"TeX/AMSmath.js\",\"TeX/AMSsymbols.js\", + \"TeX/noUndefined.js\"], + tex2jax: { + inlineMath: [ [\"\\\\(\",\"\\\\)\"] ], + displayMath: [ ['$$','$$'], [\"\\\\[\",\"\\\\]\"] ], + skipTags: [\"script\",\"noscript\",\"style\",\"textarea\",\"pre\",\"code\"], + ignoreClass: \"tex2jax_ignore\", + processEscapes: false, + processEnvironments: true, + preview: \"TeX\" + }, + showProcessingMessages: true, + displayAlign: \"%ALIGN\", + displayIndent: \"%INDENT\", + + \"HTML-CSS\": { + scale: %SCALE, + availableFonts: [\"STIX\",\"TeX\"], + preferredFont: \"TeX\", + webFont: \"TeX\", + imageFont: \"TeX\", + showMathMenu: true, + }, + MMLorHTML: { + prefer: { + MSIE: \"MML\", + Firefox: \"MML\", + Opera: \"HTML\", + other: \"HTML\" + } + } + }); +/*]]>*///--> +</script>" + "The MathJax setup for XHTML files." + :group 'org-export-html + :type 'string) + +(defcustom org-export-html-tag-class-prefix "" + "Prefix to class names for TODO keywords. +Each tag gets a class given by the tag itself, with this prefix. +The default prefix is empty because it is nice to just use the keyword +as a class name. But if you get into conflicts with other, existing +CSS classes, then this prefix can be very useful." + :group 'org-export-html + :type 'string) + +(defcustom org-export-html-todo-kwd-class-prefix "" + "Prefix to class names for TODO keywords. +Each TODO keyword gets a class given by the keyword itself, with this prefix. +The default prefix is empty because it is nice to just use the keyword +as a class name. But if you get into conflicts with other, existing +CSS classes, then this prefix can be very useful." + :group 'org-export-html + :type 'string) + +(defcustom org-export-html-title-format "<h1 class=\"title\">%s</h1>\n" + "Format for typesetting the document title in HTML export." + :group 'org-export-html + :type 'string) + +(defcustom org-export-html-home/up-format + "<div id=\"org-div-home-and-up\" style=\"text-align:right;font-size:70%%;white-space:nowrap;\"> + <a accesskey=\"h\" href=\"%s\"> UP </a> + | + <a accesskey=\"H\" href=\"%s\"> HOME </a> +</div>" + "Snippet used to insert the HOME and UP links. +This is a format string, the first %s will receive the UP link, +the second the HOME link. If both `org-export-html-link-up' and +`org-export-html-link-home' are empty, the entire snippet will be +ignored." + :group 'org-export-html + :type 'string) + +(defcustom org-export-html-toplevel-hlevel 2 + "The <H> level for level 1 headings in HTML export. +This is also important for the classes that will be wrapped around headlines +and outline structure. If this variable is 1, the top-level headlines will +be <h1>, and the corresponding classes will be outline-1, section-number-1, +and outline-text-1. If this is 2, all of these will get a 2 instead. +The default for this variable is 2, because we use <h1> for formatting the +document title." + :group 'org-export-html + :type 'string) + +(defcustom org-export-html-link-org-files-as-html t + "Non-nil means make file links to `file.org' point to `file.html'. +When org-mode is exporting an org-mode file to HTML, links to +non-html files are directly put into a href tag in HTML. +However, links to other Org-mode files (recognized by the +extension `.org.) should become links to the corresponding html +file, assuming that the linked org-mode file will also be +converted to HTML. +When nil, the links still point to the plain `.org' file." + :group 'org-export-html + :type 'boolean) + +(defcustom org-export-html-inline-images 'maybe + "Non-nil means inline images into exported HTML pages. +This is done using an <img> tag. When nil, an anchor with href is used to +link to the image. If this option is `maybe', then images in links with +an empty description will be inlined, while images with a description will +be linked only." + :group 'org-export-html + :type '(choice (const :tag "Never" nil) + (const :tag "Always" t) + (const :tag "When there is no description" maybe))) + +(defcustom org-export-html-inline-image-extensions + '("png" "jpeg" "jpg" "gif" "svg") + "Extensions of image files that can be inlined into HTML." + :group 'org-export-html + :type '(repeat (string :tag "Extension"))) + +(defcustom org-export-html-table-tag + "<table border=\"2\" cellspacing=\"0\" cellpadding=\"6\" rules=\"groups\" frame=\"hsides\">" + "The HTML tag that is used to start a table. +This must be a <table> tag, but you may change the options like +borders and spacing." + :group 'org-export-html + :type 'string) + +(defcustom org-export-table-header-tags '("<th scope=\"%s\"%s>" . "</th>") + "The opening tag for table header fields. +This is customizable so that alignment options can be specified. +The first %s will be filled with the scope of the field, either row or col. +The second %s will be replaced by a style entry to align the field. +See also the variable `org-export-html-table-use-header-tags-for-first-column'. +See also the variable `org-export-html-table-align-individual-fields'." + :group 'org-export-tables + :type '(cons (string :tag "Opening tag") (string :tag "Closing tag"))) + +(defcustom org-export-table-data-tags '("<td%s>" . "</td>") + "The opening tag for table data fields. +This is customizable so that alignment options can be specified. +The first %s will be filled with the scope of the field, either row or col. +The second %s will be replaced by a style entry to align the field. +See also the variable `org-export-html-table-align-individual-fields'." + :group 'org-export-tables + :type '(cons (string :tag "Opening tag") (string :tag "Closing tag"))) + +(defcustom org-export-table-row-tags '("<tr>" . "</tr>") + "The opening tag for table data fields. +This is customizable so that alignment options can be specified. +Instead of strings, these can be Lisp forms that will be evaluated +for each row in order to construct the table row tags. During evaluation, +the variable `head' will be true when this is a header line, nil when this +is a body line. And the variable `nline' will contain the line number, +starting from 1 in the first header line. For example + + (setq org-export-table-row-tags + (cons '(if head + \"<tr>\" + (if (= (mod nline 2) 1) + \"<tr class=\\\"tr-odd\\\">\" + \"<tr class=\\\"tr-even\\\">\")) + \"</tr>\")) + +will give even lines the class \"tr-even\" and odd lines the class \"tr-odd\"." + :group 'org-export-tables + :type '(cons + (choice :tag "Opening tag" + (string :tag "Specify") + (sexp)) + (choice :tag "Closing tag" + (string :tag "Specify") + (sexp)))) + +(defcustom org-export-html-table-align-individual-fields t + "Non-nil means attach style attributes for alignment to each table field. +When nil, alignment will only be specified in the column tags, but this +is ignored by some browsers (like Firefox, Safari). Opera does it right +though." + :group 'org-export-tables + :type 'boolean) + +(defcustom org-export-html-table-use-header-tags-for-first-column nil + "Non-nil means format column one in tables with header tags. +When nil, also column one will use data tags." + :group 'org-export-tables + :type 'boolean) + +(defcustom org-export-html-validation-link nil + "Non-nil means add validation link to postamble of HTML exported files." + :group 'org-export-html + :type '(choice + (const :tag "Nothing" nil) + (const :tag "XHTML 1.0" "<p class=\"xhtml-validation\"><a href=\"http://validator.w3.org/check?uri=referer\">Validate XHTML 1.0</a></p>") + (string :tag "Specify full HTML"))) + + +(defcustom org-export-html-with-timestamp nil + "If non-nil, write timestamp into the exported HTML text. +If non-nil Write `org-export-html-html-helper-timestamp' into the +exported HTML text. Otherwise, the buffer will just be saved to +a file." + :group 'org-export-html + :type 'boolean) + +(defcustom org-export-html-html-helper-timestamp + "<br/><br/><hr><p><!-- hhmts start --> <!-- hhmts end --></p>\n" + "The HTML tag used as timestamp delimiter for HTML-helper-mode." + :group 'org-export-html + :type 'string) + +(defgroup org-export-htmlize nil + "Options for processing examples with htmlize.el." + :tag "Org Export Htmlize" + :group 'org-export-html) + +(defcustom org-export-htmlize-output-type 'inline-css + "Output type to be used by htmlize when formatting code snippets. +We use as default `inline-css', in order to make the resulting +HTML self-containing. +However, this will fail when using Emacs in batch mode for export, because +then no rich font definitions are in place. It will also not be good if +people with different Emacs setup contribute HTML files to a website, +because the fonts will represent the individual setups. In these cases, +it is much better to let Org/Htmlize assign classes only, and to use +a style file to define the look of these classes. +To get a start for your css file, start Emacs session and make sure that +all the faces you are interested in are defined, for example by loading files +in all modes you want. Then, use the command +\\[org-export-htmlize-generate-css] to extract class definitions." + :group 'org-export-htmlize + :type '(choice (const css) (const inline-css))) + +(defcustom org-export-htmlize-css-font-prefix "org-" + "The prefix for CSS class names for htmlize font specifications." + :group 'org-export-htmlize + :type 'string) + +(defcustom org-export-htmlized-org-css-url nil + "URL pointing to a CSS file defining text colors for htmlized Emacs buffers. +Normally when creating an htmlized version of an Org buffer, htmlize will +create CSS to define the font colors. However, this does not work when +converting in batch mode, and it also can look bad if different people +with different fontification setup work on the same website. +When this variable is non-nil, creating an htmlized version of an Org buffer +using `org-export-as-org' will remove the internal CSS section and replace it +with a link to this URL." + :group 'org-export-htmlize + :type '(choice + (const :tag "Keep internal css" nil) + (string :tag "URL or local href"))) + +;;; Variables, constants, and parameter plists + +(defvar org-export-html-preamble nil + "Preamble, to be inserted just after <body>. Set by publishing functions. +This may also be a function, building and inserting the preamble.") +(defvar org-export-html-postamble nil + "Postamble, to be inserted just before </body>. Set by publishing functions. +This may also be a function, building and inserting the postamble.") +(defvar org-export-html-auto-preamble t + "Should default preamble be inserted? Set by publishing functions.") +(defvar org-export-html-auto-postamble t + "Should default postamble be inserted? Set by publishing functions.") + +;;; Hooks + +(defvar org-export-html-after-blockquotes-hook nil + "Hook run during HTML export, after blockquote, verse, center are done.") + +(defvar org-export-html-final-hook nil + "Hook run at the end of HTML export, in the new buffer.") + +;;; HTML export + +(defun org-export-html-preprocess (parameters) + "Convert LaTeX fragments to images." + (when (and org-current-export-file + (plist-get parameters :LaTeX-fragments)) + (org-format-latex + (concat "ltxpng/" (file-name-sans-extension + (file-name-nondirectory + org-current-export-file))) + org-current-export-dir nil "Creating LaTeX image %s" + nil nil + (cond + ((eq (plist-get parameters :LaTeX-fragments) 'verbatim) 'verbatim) + ((eq (plist-get parameters :LaTeX-fragments) 'mathjax ) 'mathjax) + ((eq (plist-get parameters :LaTeX-fragments) t ) 'mathjax) + ((eq (plist-get parameters :LaTeX-fragments) 'dvipng ) 'dvipng) + (t nil)))) + (goto-char (point-min)) + (let (label l1) + (while (re-search-forward "\\\\ref{\\([^{}\n]+\\)}" nil t) + (org-if-unprotected-at (match-beginning 1) + (setq label (match-string 1)) + (save-match-data + (if (string-match "\\`[a-z]\\{1,10\\}:\\(.+\\)" label) + (setq l1 (substring label (match-beginning 1))) + (setq l1 label))) + (replace-match (format "[[#%s][%s]]" label l1) t t))))) + +;;;###autoload +(defun org-export-as-html-and-open (arg) + "Export the outline as HTML and immediately open it with a browser. +If there is an active region, export only the region. +The prefix ARG specifies how many levels of the outline should become +headlines. The default is 3. Lower levels will become bulleted lists." + (interactive "P") + (org-export-as-html arg 'hidden) + (org-open-file buffer-file-name) + (when org-export-kill-product-buffer-when-displayed + (kill-buffer (current-buffer)))) + +;;;###autoload +(defun org-export-as-html-batch () + "Call the function `org-export-as-html'. +This function can be used in batch processing as: +emacs --batch + --load=$HOME/lib/emacs/org.el + --eval \"(setq org-export-headline-levels 2)\" + --visit=MyFile --funcall org-export-as-html-batch" + (org-export-as-html org-export-headline-levels 'hidden)) + +;;;###autoload +(defun org-export-as-html-to-buffer (arg) + "Call `org-export-as-html` with output to a temporary buffer. +No file is created. The prefix ARG is passed through to `org-export-as-html'." + (interactive "P") + (org-export-as-html arg nil nil "*Org HTML Export*") + (when org-export-show-temporary-export-buffer + (switch-to-buffer-other-window "*Org HTML Export*"))) + +;;;###autoload +(defun org-replace-region-by-html (beg end) + "Assume the current region has org-mode syntax, and convert it to HTML. +This can be used in any buffer. For example, you could write an +itemized list in org-mode syntax in an HTML buffer and then use this +command to convert it." + (interactive "r") + (let (reg html buf pop-up-frames) + (save-window-excursion + (if (org-mode-p) + (setq html (org-export-region-as-html + beg end t 'string)) + (setq reg (buffer-substring beg end) + buf (get-buffer-create "*Org tmp*")) + (with-current-buffer buf + (erase-buffer) + (insert reg) + (org-mode) + (setq html (org-export-region-as-html + (point-min) (point-max) t 'string))) + (kill-buffer buf))) + (delete-region beg end) + (insert html))) + +;;;###autoload +(defun org-export-region-as-html (beg end &optional body-only buffer) + "Convert region from BEG to END in org-mode buffer to HTML. +If prefix arg BODY-ONLY is set, omit file header, footer, and table of +contents, and only produce the region of converted text, useful for +cut-and-paste operations. +If BUFFER is a buffer or a string, use/create that buffer as a target +of the converted HTML. If BUFFER is the symbol `string', return the +produced HTML as a string and leave not buffer behind. For example, +a Lisp program could call this function in the following way: + + (setq html (org-export-region-as-html beg end t 'string)) + +When called interactively, the output buffer is selected, and shown +in a window. A non-interactive call will only return the buffer." + (interactive "r\nP") + (when (interactive-p) + (setq buffer "*Org HTML Export*")) + (let ((transient-mark-mode t) (zmacs-regions t) + ext-plist rtn) + (setq ext-plist (plist-put ext-plist :ignore-subtree-p t)) + (goto-char end) + (set-mark (point)) ;; to activate the region + (goto-char beg) + (setq rtn (org-export-as-html + nil nil ext-plist + buffer body-only)) + (if (fboundp 'deactivate-mark) (deactivate-mark)) + (if (and (interactive-p) (bufferp rtn)) + (switch-to-buffer-other-window rtn) + rtn))) + +(defvar html-table-tag nil) ; dynamically scoped into this. +(defvar org-par-open nil) + +;;; org-html-cvt-link-fn +(defconst org-html-cvt-link-fn + nil + "Function to convert link URLs to exportable URLs. +Takes two arguments, TYPE and PATH. +Returns exportable url as (TYPE PATH), or nil to signal that it +didn't handle this case. +Intended to be locally bound around a call to `org-export-as-html'." ) + +(defun org-html-cvt-org-as-html (opt-plist type path) + "Convert an org filename to an equivalent html filename. +If TYPE is not file, just return `nil'. +See variable `org-export-html-link-org-files-as-html'" + + (save-match-data + (and + org-export-html-link-org-files-as-html + (string= type "file") + (string-match "\\.org$" path) + (progn + (list + "file" + (concat + (substring path 0 (match-beginning 0)) + "." + (plist-get opt-plist :html-extension))))))) + + +;;; org-html-should-inline-p +(defun org-html-should-inline-p (filename descp) + "Return non-nil if link FILENAME should be inlined. +The decision to inline the FILENAME link is based on the current +settings. DESCP is the boolean of whether there was a link +description. See variables `org-export-html-inline-images' and +`org-export-html-inline-image-extensions'." + (declare (special + org-export-html-inline-images + org-export-html-inline-image-extensions)) + (and (or (eq t org-export-html-inline-images) + (and org-export-html-inline-images (not descp))) + (org-file-image-p + filename org-export-html-inline-image-extensions))) + +;;; org-html-make-link +(defun org-html-make-link (opt-plist type path fragment desc attr + may-inline-p) + "Make an HTML link. +OPT-PLIST is an options list. +TYPE is the device-type of the link (THIS://foo.html) +PATH is the path of the link (http://THIS#locationx) +FRAGMENT is the fragment part of the link, if any (foo.html#THIS) +DESC is the link description, if any. +ATTR is a string of other attributes of the a element. +MAY-INLINE-P allows inlining it as an image." + + (declare (special org-par-open)) + (save-match-data + (let* ((filename path) + ;;First pass. Just sanity stuff. + (components-1 + (cond + ((string= type "file") + (list + type + ;;Substitute just if original path was absolute. + ;;(Otherwise path must remain relative) + (if (file-name-absolute-p path) + (concat "file://" (expand-file-name path)) + path))) + ((string= type "") + (list nil path)) + (t (list type path)))) + + ;;Second pass. Components converted so they can refer + ;;to a remote site. + (components-2 + (or + (and org-html-cvt-link-fn + (apply org-html-cvt-link-fn + opt-plist components-1)) + (apply #'org-html-cvt-org-as-html + opt-plist components-1) + components-1)) + (type (first components-2)) + (thefile (second components-2))) + + + ;;Third pass. Build final link except for leading type + ;;spec. + (cond + ((or + (not type) + (string= type "http") + (string= type "https") + (string= type "file")) + (if fragment + (setq thefile (concat thefile "#" fragment)))) + + (t)) + + ;;Final URL-build, for all types. + (setq thefile + (let + ((str (org-export-html-format-href thefile))) + (if (and type (not (string= "file" type))) + (concat type ":" str) + str))) + + (if (and + may-inline-p + ;;Can't inline a URL with a fragment. + (not fragment)) + (progn + (message "image %s %s" thefile org-par-open) + (org-export-html-format-image thefile org-par-open)) + (concat + "<a href=\"" thefile "\"" attr ">" + (org-export-html-format-desc desc) + "</a>"))))) + +;;; org-export-as-html +;;;###autoload +(defun org-export-as-html (arg &optional hidden ext-plist + to-buffer body-only pub-dir) + "Export the outline as a pretty HTML file. +If there is an active region, export only the region. The prefix +ARG specifies how many levels of the outline should become +headlines. The default is 3. Lower levels will become bulleted +lists. HIDDEN is obsolete and does nothing. +EXT-PLIST is a property list with external parameters overriding +org-mode's default settings, but still inferior to file-local +settings. When TO-BUFFER is non-nil, create a buffer with that +name and export to that buffer. If TO-BUFFER is the symbol +`string', don't leave any buffer behind but just return the +resulting HTML as a string. When BODY-ONLY is set, don't produce +the file header and footer, simply return the content of +<body>...</body>, without even the body tags themselves. When +PUB-DIR is set, use this as the publishing directory." + (interactive "P") + (run-hooks 'org-export-first-hook) + + ;; Make sure we have a file name when we need it. + (when (and (not (or to-buffer body-only)) + (not buffer-file-name)) + (if (buffer-base-buffer) + (org-set-local 'buffer-file-name + (with-current-buffer (buffer-base-buffer) + buffer-file-name)) + (error "Need a file name to be able to export"))) + + (message "Exporting...") + (setq-default org-todo-line-regexp org-todo-line-regexp) + (setq-default org-deadline-line-regexp org-deadline-line-regexp) + (setq-default org-done-keywords org-done-keywords) + (setq-default org-maybe-keyword-time-regexp org-maybe-keyword-time-regexp) + (let* ((opt-plist + (org-export-process-option-filters + (org-combine-plists (org-default-export-plist) + ext-plist + (org-infile-export-plist)))) + (body-only (or body-only (plist-get opt-plist :body-only))) + (style (concat (if (plist-get opt-plist :style-include-default) + org-export-html-style-default) + (plist-get opt-plist :style) + (plist-get opt-plist :style-extra) + "\n" + (if (plist-get opt-plist :style-include-scripts) + org-export-html-scripts))) + (html-extension (plist-get opt-plist :html-extension)) + (link-validate (plist-get opt-plist :link-validation-function)) + valid thetoc have-headings first-heading-pos + (odd org-odd-levels-only) + (region-p (org-region-active-p)) + (rbeg (and region-p (region-beginning))) + (rend (and region-p (region-end))) + (subtree-p + (if (plist-get opt-plist :ignore-subtree-p) + nil + (when region-p + (save-excursion + (goto-char rbeg) + (and (org-at-heading-p) + (>= (org-end-of-subtree t t) rend)))))) + (level-offset (if subtree-p + (save-excursion + (goto-char rbeg) + (+ (funcall outline-level) + (if org-odd-levels-only 1 0))) + 0)) + (opt-plist (setq org-export-opt-plist + (if subtree-p + (org-export-add-subtree-options opt-plist rbeg) + opt-plist))) + ;; The following two are dynamically scoped into other + ;; routines below. + (org-current-export-dir + (or pub-dir (org-export-directory :html opt-plist))) + (org-current-export-file buffer-file-name) + (level 0) (line "") (origline "") txt todo + (umax nil) + (umax-toc nil) + (filename (if to-buffer nil + (expand-file-name + (concat + (file-name-sans-extension + (or (and subtree-p + (org-entry-get (region-beginning) + "EXPORT_FILE_NAME" t)) + (file-name-nondirectory buffer-file-name))) + "." html-extension) + (file-name-as-directory + (or pub-dir (org-export-directory :html opt-plist)))))) + (current-dir (if buffer-file-name + (file-name-directory buffer-file-name) + default-directory)) + (buffer (if to-buffer + (cond + ((eq to-buffer 'string) (get-buffer-create "*Org HTML Export*")) + (t (get-buffer-create to-buffer))) + (find-file-noselect filename))) + (org-levels-open (make-vector org-level-max nil)) + (date (plist-get opt-plist :date)) + (author (plist-get opt-plist :author)) + (title (or (and subtree-p (org-export-get-title-from-subtree)) + (plist-get opt-plist :title) + (and (not body-only) + (not + (plist-get opt-plist :skip-before-1st-heading)) + (org-export-grab-title-from-buffer)) + (and buffer-file-name + (file-name-sans-extension + (file-name-nondirectory buffer-file-name))) + "UNTITLED")) + (link-up (and (plist-get opt-plist :link-up) + (string-match "\\S-" (plist-get opt-plist :link-up)) + (plist-get opt-plist :link-up))) + (link-home (and (plist-get opt-plist :link-home) + (string-match "\\S-" (plist-get opt-plist :link-home)) + (plist-get opt-plist :link-home))) + (dummy (setq opt-plist (plist-put opt-plist :title title))) + (html-table-tag (plist-get opt-plist :html-table-tag)) + (quote-re0 (concat "^[ \t]*" org-quote-string "\\>")) + (quote-re (concat "^\\(\\*+\\)\\([ \t]+" org-quote-string "\\>\\)")) + (inquote nil) + (infixed nil) + (inverse nil) + (in-local-list nil) + (local-list-type nil) + (local-list-indent nil) + (llt org-plain-list-ordered-item-terminator) + (email (plist-get opt-plist :email)) + (language (plist-get opt-plist :language)) + (keywords (plist-get opt-plist :keywords)) + (description (plist-get opt-plist :description)) + (lang-words nil) + (head-count 0) cnt + (start 0) + (coding-system (and (boundp 'buffer-file-coding-system) + buffer-file-coding-system)) + (coding-system-for-write (or org-export-html-coding-system + coding-system)) + (save-buffer-coding-system (or org-export-html-coding-system + coding-system)) + (charset (and coding-system-for-write + (fboundp 'coding-system-get) + (coding-system-get coding-system-for-write + 'mime-charset))) + (region + (buffer-substring + (if region-p (region-beginning) (point-min)) + (if region-p (region-end) (point-max)))) + (org-export-have-math nil) + (lines + (org-split-string + (org-export-preprocess-string + region + :emph-multiline t + :for-html t + :skip-before-1st-heading + (plist-get opt-plist :skip-before-1st-heading) + :drawers (plist-get opt-plist :drawers) + :todo-keywords (plist-get opt-plist :todo-keywords) + :tags (plist-get opt-plist :tags) + :priority (plist-get opt-plist :priority) + :footnotes (plist-get opt-plist :footnotes) + :timestamps (plist-get opt-plist :timestamps) + :archived-trees + (plist-get opt-plist :archived-trees) + :select-tags (plist-get opt-plist :select-tags) + :exclude-tags (plist-get opt-plist :exclude-tags) + :add-text + (plist-get opt-plist :text) + :LaTeX-fragments + (plist-get opt-plist :LaTeX-fragments)) + "[\r\n]")) + (mathjax + (if (or (eq (plist-get opt-plist :LaTeX-fragments) 'mathjax) + (and org-export-have-math + (eq (plist-get opt-plist :LaTeX-fragments) t))) + + (org-export-html-mathjax-config + org-export-html-mathjax-template + org-export-html-mathjax-options + (or (plist-get opt-plist :mathjax) "")) + "")) + table-open type + table-buffer table-orig-buffer + ind item-type starter + rpl path attr desc descp desc1 desc2 link + snumber fnc item-tag item-number + footnotes footref-seen + id-file href + ) + + (let ((inhibit-read-only t)) + (org-unmodified + (remove-text-properties (point-min) (point-max) + '(:org-license-to-kill t)))) + + (message "Exporting...") + + (setq org-min-level (org-get-min-level lines level-offset)) + (setq org-last-level org-min-level) + (org-init-section-numbers) + + (cond + ((and date (string-match "%" date)) + (setq date (format-time-string date))) + (date) + (t (setq date (format-time-string "%Y-%m-%d %T %Z")))) + + ;; Get the language-dependent settings + (setq lang-words (or (assoc language org-export-language-setup) + (assoc "en" org-export-language-setup))) + + ;; Switch to the output buffer + (set-buffer buffer) + (let ((inhibit-read-only t)) (erase-buffer)) + (fundamental-mode) + (org-install-letbind) + + (and (fboundp 'set-buffer-file-coding-system) + (set-buffer-file-coding-system coding-system-for-write)) + + (let ((case-fold-search nil) + (org-odd-levels-only odd)) + ;; create local variables for all options, to make sure all called + ;; functions get the correct information + (mapc (lambda (x) + (set (make-local-variable (nth 2 x)) + (plist-get opt-plist (car x)))) + org-export-plist-vars) + (setq umax (if arg (prefix-numeric-value arg) + org-export-headline-levels)) + (setq umax-toc (if (integerp org-export-with-toc) + (min org-export-with-toc umax) + umax)) + (unless body-only + ;; File header + (insert (format + "%s +<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" + \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\"> +<html xmlns=\"http://www.w3.org/1999/xhtml\" +lang=\"%s\" xml:lang=\"%s\"> +<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\"/> +<meta name=\"author\" content=\"%s\"/> +<meta name=\"description\" content=\"%s\"/> +<meta name=\"keywords\" content=\"%s\"/> +%s +%s +</head> +<body> +<div id=\"content\"> +%s +" + (format + (or (and (stringp org-export-html-xml-declaration) + org-export-html-xml-declaration) + (cdr (assoc html-extension org-export-html-xml-declaration)) + (cdr (assoc "html" org-export-html-xml-declaration)) + + "") + (or charset "iso-8859-1")) + language language + title + (or charset "iso-8859-1") + date author description keywords + style + mathjax + (if (or link-up link-home) + (concat + (format org-export-html-home/up-format + (or link-up link-home) + (or link-home link-up)) + "\n") + ""))) + + (org-export-html-insert-plist-item opt-plist :preamble opt-plist) + + (when (plist-get opt-plist :auto-preamble) + (if title (insert (format org-export-html-title-format + (org-html-expand title)))))) + + (if (and org-export-with-toc (not body-only)) + (progn + (push (format "<h%d>%s</h%d>\n" + org-export-html-toplevel-hlevel + (nth 3 lang-words) + org-export-html-toplevel-hlevel) + thetoc) + (push "<div id=\"text-table-of-contents\">\n" thetoc) + (push "<ul>\n<li>" thetoc) + (setq lines + (mapcar '(lambda (line) + (if (and (string-match org-todo-line-regexp line) + (not (get-text-property 0 'org-protected line))) + ;; This is a headline + (progn + (setq have-headings t) + (setq level (- (match-end 1) (match-beginning 1) + level-offset) + level (org-tr-level level) + txt (save-match-data + (org-html-expand + (org-export-cleanup-toc-line + (match-string 3 line)))) + todo + (or (and org-export-mark-todo-in-toc + (match-beginning 2) + (not (member (match-string 2 line) + org-done-keywords))) + ; TODO, not DONE + (and org-export-mark-todo-in-toc + (= level umax-toc) + (org-search-todo-below + line lines level)))) + (if (string-match + (org-re "[ \t]+:\\([[:alnum:]_@:]+\\):[ \t]*$") txt) + (setq txt (replace-match " <span class=\"tag\"> \\1</span>" t nil txt))) + (if (string-match quote-re0 txt) + (setq txt (replace-match "" t t txt))) + (setq snumber (org-section-number level)) + (if org-export-with-section-numbers + (setq txt (concat snumber " " txt))) + (if (<= level (max umax umax-toc)) + (setq head-count (+ head-count 1))) + (if (<= level umax-toc) + (progn + (if (> level org-last-level) + (progn + (setq cnt (- level org-last-level)) + (while (>= (setq cnt (1- cnt)) 0) + (push "\n<ul>\n<li>" thetoc)) + (push "\n" thetoc))) + (if (< level org-last-level) + (progn + (setq cnt (- org-last-level level)) + (while (>= (setq cnt (1- cnt)) 0) + (push "</li>\n</ul>" thetoc)) + (push "\n" thetoc))) + ;; Check for targets + (while (string-match org-any-target-regexp line) + (setq line (replace-match + (concat "@<span class=\"target\">" (match-string 1 line) "@</span> ") + t t line))) + (while (string-match "<\\(<\\)+\\|>\\(>\\)+" txt) + (setq txt (replace-match "" t t txt))) + (setq href + (replace-regexp-in-string + "\\." "_" (format "sec-%s" snumber))) + (setq href (or (cdr (assoc href org-export-preferred-target-alist)) href)) + (push + (format + (if todo + "</li>\n<li><a href=\"#%s\"><span class=\"todo\">%s</span></a>" + "</li>\n<li><a href=\"#%s\">%s</a>") + href txt) thetoc) + + (setq org-last-level level)) + ))) + line) + lines)) + (while (> org-last-level (1- org-min-level)) + (setq org-last-level (1- org-last-level)) + (push "</li>\n</ul>\n" thetoc)) + (push "</div>\n" thetoc) + (setq thetoc (if have-headings (nreverse thetoc) nil)))) + + (setq head-count 0) + (org-init-section-numbers) + + (org-open-par) + + (while (setq line (pop lines) origline line) + (catch 'nextline + + ;; end of quote section? + (when (and inquote (string-match "^\\*+ " line)) + (insert "</pre>\n") + (org-open-par) + (setq inquote nil)) + ;; inside a quote section? + (when inquote + (insert (org-html-protect line) "\n") + (throw 'nextline nil)) + + ;; Fixed-width, verbatim lines (examples) + (when (and org-export-with-fixed-width + (string-match "^[ \t]*:\\(\\([ \t]\\|$\\)\\(.*\\)\\)" line)) + (when (not infixed) + (setq infixed t) + (org-close-par-maybe) + + (insert "<pre class=\"example\">\n")) + (insert (org-html-protect (match-string 3 line)) "\n") + (when (or (not lines) + (not (string-match "^[ \t]*:\\(\\([ \t]\\|$\\)\\(.*\\)\\)" + (car lines)))) + (setq infixed nil) + (insert "</pre>\n") + (org-open-par)) + (throw 'nextline nil)) + + ;; Explicit list closure + (when (equal "ORG-LIST-END" line) + (while local-list-indent + (org-close-li (car local-list-type)) + (insert (format "</%sl>\n" (car local-list-type))) + (pop local-list-type) + (pop local-list-indent)) + (setq in-local-list nil) + (org-open-par) + (throw 'nextline nil)) + + ;; Protected HTML + (when (and (get-text-property 0 'org-protected line) + ;; Make sure it is the entire line that is protected + (not (< (or (next-single-property-change + 0 'org-protected line) 10000) + (length line)))) + (let (par (ind (get-text-property 0 'original-indentation line))) + (when (re-search-backward + "\\(<p>\\)\\([ \t\r\n]*\\)\\=" (- (point) 100) t) + (setq par (match-string 1)) + (replace-match "\\2\n")) + (insert line "\n") + (while (and lines + (or (= (length (car lines)) 0) + (not ind) + (equal ind (get-text-property 0 'original-indentation (car lines)))) + (or (= (length (car lines)) 0) + (get-text-property 0 'org-protected (car lines)))) + (insert (pop lines) "\n")) + (and par (insert "<p>\n"))) + (throw 'nextline nil)) + + ;; Blockquotes, verse, and center + (when (equal "ORG-BLOCKQUOTE-START" line) + (org-close-par-maybe) + (insert "<blockquote>\n") + (org-open-par) + (throw 'nextline nil)) + (when (equal "ORG-BLOCKQUOTE-END" line) + (org-close-par-maybe) + (insert "\n</blockquote>\n") + (org-open-par) + (throw 'nextline nil)) + (when (equal "ORG-VERSE-START" line) + (org-close-par-maybe) + (insert "\n<p class=\"verse\">\n") + (setq org-par-open t) + (setq inverse t) + (throw 'nextline nil)) + (when (equal "ORG-VERSE-END" line) + (insert "</p>\n") + (setq org-par-open nil) + (org-open-par) + (setq inverse nil) + (throw 'nextline nil)) + (when (equal "ORG-CENTER-START" line) + (org-close-par-maybe) + (insert "\n<div style=\"text-align: center\">") + (org-open-par) + (throw 'nextline nil)) + (when (equal "ORG-CENTER-END" line) + (org-close-par-maybe) + (insert "\n</div>") + (org-open-par) + (throw 'nextline nil)) + (run-hooks 'org-export-html-after-blockquotes-hook) + (when inverse + (let ((i (org-get-string-indentation line))) + (if (> i 0) + (setq line (concat (mapconcat 'identity + (make-list (* 2 i) "\\nbsp") "") + " " (org-trim line)))) + (unless (string-match "\\\\\\\\[ \t]*$" line) + (setq line (concat line "\\\\"))))) + + ;; make targets to anchors + (setq start 0) + (while (string-match + "<<<?\\([^<>]*\\)>>>?\\((INVISIBLE)\\)?[ \t]*\n?" line start) + (cond + ((get-text-property (match-beginning 1) 'org-protected line) + (setq start (match-end 1))) + ((match-end 2) + (setq line (replace-match + (format + "@<a name=\"%s\" id=\"%s\">@</a>" + (org-solidify-link-text (match-string 1 line)) + (org-solidify-link-text (match-string 1 line))) + t t line))) + ((and org-export-with-toc (equal (string-to-char line) ?*)) + ;; FIXME: NOT DEPENDENT on TOC????????????????????? + (setq line (replace-match + (concat "@<span class=\"target\">" + (match-string 1 line) "@</span> ") + ;; (concat "@<i>" (match-string 1 line) "@</i> ") + t t line))) + (t + (setq line (replace-match + (concat "@<a name=\"" + (org-solidify-link-text (match-string 1 line)) + "\" class=\"target\">" (match-string 1 line) + "@</a> ") + t t line))))) + + (setq line (org-html-handle-time-stamps line)) + + ;; replace "&" by "&", "<" and ">" by "<" and ">" + ;; handle @<..> HTML tags (replace "@>..<" by "<..>") + ;; Also handle sub_superscripts and checkboxes + (or (string-match org-table-hline-regexp line) + (setq line (org-html-expand line))) + + ;; Format the links + (setq start 0) + (while (string-match org-bracket-link-analytic-regexp++ line start) + (setq start (match-beginning 0)) + (setq path (save-match-data (org-link-unescape + (match-string 3 line)))) + (setq type (cond + ((match-end 2) (match-string 2 line)) + ((save-match-data + (or (file-name-absolute-p path) + (string-match "^\\.\\.?/" path))) + "file") + (t "internal"))) + (setq path (org-extract-attributes (org-link-unescape path))) + (setq attr (get-text-property 0 'org-attributes path)) + (setq desc1 (if (match-end 5) (match-string 5 line)) + desc2 (if (match-end 2) (concat type ":" path) path) + descp (and desc1 (not (equal desc1 desc2))) + desc (or desc1 desc2)) + ;; Make an image out of the description if that is so wanted + (when (and descp (org-file-image-p + desc org-export-html-inline-image-extensions)) + (save-match-data + (if (string-match "^file:" desc) + (setq desc (substring desc (match-end 0))))) + (setq desc (org-add-props + (concat "<img src=\"" desc "\"/>") + '(org-protected t)))) + (cond + ((equal type "internal") + (let + ((frag-0 + (if (= (string-to-char path) ?#) + (substring path 1) + path))) + (setq rpl + (org-html-make-link + opt-plist + "" + "" + (org-solidify-link-text + (save-match-data (org-link-unescape frag-0)) + nil) + desc attr nil)))) + ((and (equal type "id") + (setq id-file (org-id-find-id-file path))) + ;; This is an id: link to another file (if it was the same file, + ;; it would have become an internal link...) + (save-match-data + (setq id-file (file-relative-name + id-file + (file-name-directory org-current-export-file))) + (setq rpl + (org-html-make-link opt-plist + "file" id-file + (concat (if (org-uuidgen-p path) "ID-") path) + desc + attr + nil)))) + ((member type '("http" "https")) + ;; standard URL, can inline as image + (setq rpl + (org-html-make-link opt-plist + type path nil + desc + attr + (org-html-should-inline-p path descp)))) + ((member type '("ftp" "mailto" "news")) + ;; standard URL, can't inline as image + (setq rpl + (org-html-make-link opt-plist + type path nil + desc + attr + nil))) + + ((string= type "coderef") + (let* + ((coderef-str (format "coderef-%s" path)) + (attr-1 + (format "class=\"coderef\" onmouseover=\"CodeHighlightOn(this, '%s');\" onmouseout=\"CodeHighlightOff(this, '%s');\"" + coderef-str coderef-str))) + (setq rpl + (org-html-make-link opt-plist + type "" coderef-str + (format + (org-export-get-coderef-format + path + (and descp desc)) + (cdr (assoc path org-export-code-refs))) + attr-1 + nil)))) + + ((functionp (setq fnc (nth 2 (assoc type org-link-protocols)))) + ;; The link protocol has a function for format the link + (setq rpl + (save-match-data + (funcall fnc (org-link-unescape path) desc1 'html)))) + + ((string= type "file") + ;; FILE link + (save-match-data + (let* + ((components + (if + (string-match "::\\(.*\\)" path) + (list + (replace-match "" t nil path) + (match-string 1 path)) + (list path nil))) + + ;;The proper path, without a fragment + (path-1 + (first components)) + + ;;The raw fragment + (fragment-0 + (second components)) + + ;;Check the fragment. If it can't be used as + ;;target fragment we'll pass nil instead. + (fragment-1 + (if + (and fragment-0 + (not (string-match "^[0-9]*$" fragment-0)) + (not (string-match "^\\*" fragment-0)) + (not (string-match "^/.*/$" fragment-0))) + (org-solidify-link-text + (org-link-unescape fragment-0)) + nil)) + (desc-2 + ;;Description minus "file:" and ".org" + (if (string-match "^file:" desc) + (let + ((desc-1 (replace-match "" t t desc))) + (if (string-match "\\.org$" desc-1) + (replace-match "" t t desc-1) + desc-1)) + desc))) + + (setq rpl + (if + (and + (functionp link-validate) + (not (funcall link-validate path-1 current-dir))) + desc + (org-html-make-link opt-plist + "file" path-1 fragment-1 desc-2 attr + (org-html-should-inline-p path-1 descp))))))) + + (t + ;; just publish the path, as default + (setq rpl (concat "<i><" type ":" + (save-match-data (org-link-unescape path)) + "></i>")))) + (setq line (replace-match rpl t t line) + start (+ start (length rpl)))) + + ;; TODO items + (if (and (string-match org-todo-line-regexp line) + (match-beginning 2)) + + (setq line + (concat (substring line 0 (match-beginning 2)) + "<span class=\"" + (if (member (match-string 2 line) + org-done-keywords) + "done" "todo") + " " (match-string 2 line) + "\"> " (org-export-html-get-todo-kwd-class-name + (match-string 2 line)) + "</span>" (substring line (match-end 2))))) + + ;; Does this contain a reference to a footnote? + (when org-export-with-footnotes + (setq start 0) + (while (string-match "\\([^* \t].*?\\)\\[\\([0-9]+\\)\\]" line start) + (if (get-text-property (match-beginning 2) 'org-protected line) + (setq start (match-end 2)) + (let ((n (match-string 2 line)) extra a) + (if (setq a (assoc n footref-seen)) + (progn + (setcdr a (1+ (cdr a))) + (setq extra (format ".%d" (cdr a)))) + (setq extra "") + (push (cons n 1) footref-seen)) + (setq line + (replace-match + (format + (concat "%s" + (format org-export-html-footnote-format + "<a class=\"footref\" name=\"fnr.%s%s\" href=\"#fn.%s\">%s</a>")) + (or (match-string 1 line) "") n extra n n) + t t line)))))) + + (cond + ((string-match "^\\(\\*+\\)[ \t]+\\(.*\\)" line) + ;; This is a headline + (setq level (org-tr-level (- (match-end 1) (match-beginning 1) + level-offset)) + txt (match-string 2 line)) + (if (string-match quote-re0 txt) + (setq txt (replace-match "" t t txt))) + (if (<= level (max umax umax-toc)) + (setq head-count (+ head-count 1))) + (setq first-heading-pos (or first-heading-pos (point))) + (org-html-level-start level txt umax + (and org-export-with-toc (<= level umax)) + head-count) + + ;; QUOTES + (when (string-match quote-re line) + (org-close-par-maybe) + (insert "<pre>") + (setq inquote t))) + + ((and org-export-with-tables + (string-match "^\\([ \t]*\\)\\(|\\|\\+-+\\+\\)" line)) + (when (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)) + (org-close-par-maybe) + (insert (org-format-table-html table-buffer table-orig-buffer)))) + (t + ;; Normal lines + (when (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 (or (get-text-property 0 'original-indentation line) + (org-get-string-indentation line)) + item-type (if (match-beginning 4) "o" "u") + starter (if (match-beginning 2) + (substring (match-string 2 line) 0 -1)) + line (substring line (match-beginning 5)) + item-number nil + item-tag nil) + (if (string-match "\\[@\\(?:start:\\)?\\([0-9]+\\)\\][ \t]?" line) + (setq item-number (match-string 1 line) + line (replace-match "" t t line))) + (if (and starter (string-match "\\(.*?\\) ::[ \t]*" line)) + (setq item-type "d" + item-tag (match-string 1 line) + line (substring line (match-end 0)))) + (cond + ((and starter + (or (not in-local-list) + (> ind (car local-list-indent)))) + ;; Start new (level of) list + (org-close-par-maybe) + (insert (cond + ((equal item-type "u") "<ul>\n<li>\n") + ((and (equal item-type "o") item-number) + (format "<ol>\n<li value=\"%s\">\n" item-number)) + ((equal item-type "o") "<ol>\n<li>\n") + ((equal item-type "d") + (format "<dl>\n<dt>%s</dt><dd>\n" item-tag)))) + (push item-type local-list-type) + (push ind local-list-indent) + (setq in-local-list t)) + ;; Continue list + (starter + ;; terminate any previous sublist but first ensure + ;; list is not ill-formed. + (let ((min-ind (apply 'min local-list-indent))) + (when (< ind min-ind) (setq ind min-ind))) + (while (< ind (car local-list-indent)) + (org-close-li (car local-list-type)) + (insert (format "</%sl>\n" (car local-list-type))) + (pop local-list-type) (pop local-list-indent) + (setq in-local-list local-list-indent)) + ;; insert new item + (org-close-li (car local-list-type)) + (insert (cond + ((equal (car local-list-type) "d") + (format "<dt>%s</dt><dd>\n" (or item-tag "???"))) + ((and (equal item-type "o") item-number) + (format "<li value=\"%s\">\n" item-number)) + (t "<li>\n"))))) + (if (string-match "^[ \t]*\\[\\([X ]\\)\\]" line) + (setq line + (replace-match + (if (equal (match-string 1 line) "X") + "<b>[X]</b>" + "<b>[<span style=\"visibility:hidden;\">X</span>]</b>") + t t line)))) + + ;; Horizontal line + (when (string-match "^[ \t]*-\\{5,\\}[ \t]*$" line) + (if org-par-open + (insert "\n</p>\n<hr/>\n<p>\n") + (insert "\n<hr/>\n")) + (throw 'nextline nil)) + + ;; 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) (org-open-par)) + + ;; Is this the start of a footnote? + (when org-export-with-footnotes + (when (and (boundp 'footnote-section-tag-regexp) + (string-match (concat "^" footnote-section-tag-regexp) + line)) + ;; ignore this line + (throw 'nextline nil)) + (when (string-match "^[ \t]*\\[\\([0-9]+\\)\\]" line) + (org-close-par-maybe) + (let ((n (match-string 1 line))) + (setq org-par-open t + line (replace-match + (format + (concat "<p class=\"footnote\">" + (format org-export-html-footnote-format + "<a class=\"footnum\" name=\"fn.%s\" href=\"#fnr.%s\">%s</a>")) + n n n) t t line))))) + ;; Check if the line break needs to be conserved + (cond + ((string-match "\\\\\\\\[ \t]*$" line) + (setq line (replace-match "<br/>" t t line))) + (org-export-preserve-breaks + (setq line (concat line "<br/>")))) + + ;; Check if a paragraph should be started + (let ((start 0)) + (while (and org-par-open + (string-match "\\\\par\\>" line start)) + ;; Leave a space in the </p> so that the footnote matcher + ;; does not see this. + (if (not (get-text-property (match-beginning 0) + 'org-protected line)) + (setq line (replace-match "</p ><p >" t t line))) + (setq start (match-end 0)))) + + (insert line "\n"))))) + + ;; Properly close all local lists and other lists + (when inquote + (insert "</pre>\n") + (org-open-par)) + + (org-html-level-start 1 nil umax + (and org-export-with-toc (<= level umax)) + head-count) + ;; the </div> to close the last text-... div. + (when (and (> umax 0) first-heading-pos) (insert "</div>\n")) + + (save-excursion + (goto-char (point-min)) + (while (re-search-forward "<p class=\"footnote\">[^\000]*?\\(</p>\\|\\'\\)" nil t) + (push (match-string 0) footnotes) + (replace-match "" t t))) + (when footnotes + (insert (format org-export-html-footnotes-section + (nth 4 lang-words) + (mapconcat 'identity (nreverse footnotes) "\n")) + "\n")) + (let ((bib (org-export-html-get-bibliography))) + (when bib + (insert "\n" bib "\n"))) + (unless body-only + (when (plist-get opt-plist :auto-postamble) + (insert "<div id=\"postamble\">\n") + (when (and org-export-author-info author) + (insert "<p class=\"author\"> " + (nth 1 lang-words) ": " author "\n") + (when (and org-export-email-info email (string-match "\\S-" email)) + (if (listp (split-string email ",+ *")) + (mapc (lambda(e) + (insert "<a href=\"mailto:" e "\"><" + e "></a>\n")) + (split-string email ",+ *")) + (insert "<a href=\"mailto:" email "\"><" + email "></a>\n"))) + (insert "</p>\n")) + (when (and date org-export-time-stamp-file) + (insert "<p class=\"date\"> " + (nth 2 lang-words) ": " + date "</p>\n")) + (when org-export-creator-info + (insert (format "<p class=\"creator\">HTML generated by org-mode %s in emacs %s</p>\n" + org-version emacs-major-version))) + (when org-export-html-validation-link + (insert org-export-html-validation-link "\n")) + (insert "</div>")) + + (if org-export-html-with-timestamp + (insert org-export-html-html-helper-timestamp)) + (org-export-html-insert-plist-item opt-plist :postamble opt-plist) + (insert "\n</div>\n</body>\n</html>\n")) + + (unless (plist-get opt-plist :buffer-will-be-killed) + (normal-mode) + (if (eq major-mode (default-value 'major-mode)) + (html-mode))) + + ;; insert the table of contents + (goto-char (point-min)) + (when thetoc + (if (or (re-search-forward + "<p>\\s-*\\[TABLE-OF-CONTENTS\\]\\s-*</p>" nil t) + (re-search-forward + "\\[TABLE-OF-CONTENTS\\]" nil t)) + (progn + (goto-char (match-beginning 0)) + (replace-match "")) + (goto-char first-heading-pos) + (when (looking-at "\\s-*</p>") + (goto-char (match-end 0)) + (insert "\n"))) + (insert "<div id=\"table-of-contents\">\n") + (mapc 'insert thetoc) + (insert "</div>\n")) + ;; remove empty paragraphs and lists + (goto-char (point-min)) + (while (re-search-forward "<p>[ \r\n\t]*</p>" nil t) + (replace-match "")) + (goto-char (point-min)) + (while (re-search-forward "<li>[ \r\n\t]*</li>\n?" nil t) + (replace-match "")) + (goto-char (point-min)) + ;; Convert whitespace place holders + (goto-char (point-min)) + (let (beg end n) + (while (setq beg (next-single-property-change (point) 'org-whitespace)) + (setq n (get-text-property beg 'org-whitespace) + end (next-single-property-change beg 'org-whitespace)) + (goto-char beg) + (delete-region beg end) + (insert (format "<span style=\"visibility:hidden;\">%s</span>" + (make-string n ?x))))) + ;; Remove empty lines at the beginning of the file. + (goto-char (point-min)) + (when (looking-at "\\s-+\n") (replace-match "")) + ;; Remove display properties + (remove-text-properties (point-min) (point-max) '(display t)) + ;; Run the hook + (run-hooks 'org-export-html-final-hook) + (or to-buffer (save-buffer)) + (goto-char (point-min)) + (or (org-export-push-to-kill-ring "HTML") + (message "Exporting... done")) + (if (eq to-buffer 'string) + (prog1 (buffer-substring (point-min) (point-max)) + (kill-buffer (current-buffer))) + (current-buffer))))) + +(defun org-export-html-insert-plist-item (plist key &rest args) + (let ((item (plist-get plist key))) + (cond ((functionp item) + (apply item args)) + (item + (insert item))))) + +(defun org-export-html-format-href (s) + "Make sure the S is valid as a href reference in an XHTML document." + (save-match-data + (let ((start 0)) + (while (string-match "&" s start) + (setq start (+ (match-beginning 0) 3) + s (replace-match "&" t t s))))) + s) + +(defun org-export-html-format-desc (s) + "Make sure the S is valid as a description in a link." + (if (and s (not (get-text-property 1 'org-protected s))) + (save-match-data + (org-html-do-expand s)) + s)) + +(defun org-export-html-format-image (src par-open) + "Create image tag with source and attributes." + (save-match-data + (if (string-match "^ltxpng/" src) + (format "<img src=\"%s\" alt=\"%s\"/>" + src (org-find-text-property-in-string 'org-latex-src src)) + (let* ((caption (org-find-text-property-in-string 'org-caption src)) + (attr (org-find-text-property-in-string 'org-attributes src)) + (label (org-find-text-property-in-string 'org-label src))) + (setq caption (and caption (org-html-do-expand caption))) + (concat + (if caption + (format "%s<div %sclass=\"figure\"> +<p>" + (if org-par-open "</p>\n" "") + (if label (format "id=\"%s\" " label) ""))) + (format "<img src=\"%s\"%s />" + src + (if (string-match "\\<alt=" (or attr "")) + (concat " " attr ) + (concat " " attr " alt=\"" src "\""))) + (if caption + (format "</p>%s +</div>%s" + (concat "\n<p>" caption "</p>") + (if org-par-open "\n<p>" "")))))))) + +(defun org-export-html-get-bibliography () + "Find bibliography, cut it out and return it." + (catch 'exit + (let (beg end (cnt 1) bib) + (save-excursion + (goto-char (point-min)) + (when (re-search-forward "^[ \t]*<div \\(id\\|class\\)=\"bibliography\"" nil t) + (setq beg (match-beginning 0)) + (while (re-search-forward "</?div\\>" nil t) + (setq cnt (+ cnt (if (string= (match-string 0) "<div") +1 -1))) + (when (= cnt 0) + (and (looking-at ">") (forward-char 1)) + (setq bib (buffer-substring beg (point))) + (delete-region beg (point)) + (throw 'exit bib)))) + nil)))) + +(defvar org-table-number-regexp) ; defined in org-table.el +(defun org-format-table-html (lines olines &optional no-css) + "Find out which HTML converter to use and return the HTML code. +NO-CSS is passed to the exporter." + (if (stringp lines) + (setq lines (org-split-string lines "\n"))) + (if (string-match "^[ \t]*|" (car lines)) + ;; A normal org table + (org-format-org-table-html lines nil no-css) + ;; Table made by table.el - test for spanning + (let* ((hlines (delq nil (mapcar + (lambda (x) + (if (string-match "^[ \t]*\\+-" x) x + nil)) + lines))) + (first (car hlines)) + (ll (and (string-match "\\S-+" first) + (match-string 0 first))) + (re (concat "^[ \t]*" (regexp-quote ll))) + (spanning (delq nil (mapcar (lambda (x) (not (string-match re x))) + hlines)))) + (if (and (not spanning) + (not org-export-prefer-native-exporter-for-tables)) + ;; We can use my own converter with HTML conversions + (org-format-table-table-html lines) + ;; Need to use the code generator in table.el, with the original text. + (org-format-table-table-html-using-table-generate-source olines))))) + +(defvar org-table-number-fraction) ; defined in org-table.el +(defun org-format-org-table-html (lines &optional splice no-css) + "Format a table into HTML. +LINES is a list of lines. Optional argument SPLICE means, do not +insert header and surrounding <table> tags, just format the lines. +Optional argument NO-CSS means use XHTML attributes instead of CSS +for formatting. This is required for the DocBook exporter." + (require 'org-table) + ;; Get rid of hlines at beginning and end + (if (string-match "^[ \t]*|-" (car lines)) (setq lines (cdr lines))) + (setq lines (nreverse lines)) + (if (string-match "^[ \t]*|-" (car lines)) (setq lines (cdr lines))) + (setq lines (nreverse lines)) + (when org-export-table-remove-special-lines + ;; Check if the table has a marking column. If yes remove the + ;; column and the special lines + (setq lines (org-table-clean-before-export lines))) + + (let* ((caption (org-find-text-property-in-string 'org-caption (car lines))) + (label (org-find-text-property-in-string 'org-label (car lines))) + (forced-aligns (org-find-text-property-in-string 'org-forced-aligns + (car lines))) + (attributes (org-find-text-property-in-string 'org-attributes + (car lines))) + (html-table-tag (org-export-splice-attributes + html-table-tag attributes)) + (head (and org-export-highlight-first-table-line + (delq nil (mapcar + (lambda (x) (string-match "^[ \t]*|-" x)) + (cdr lines))))) + (nline 0) fnum nfields i (cnt 0) + tbopen line fields html gr colgropen rowstart rowend + ali align aligns n) + (setq caption (and caption (org-html-do-expand caption))) + (when (and forced-aligns org-table-clean-did-remove-column) + (setq forced-aligns + (mapcar (lambda (x) (cons (1- (car x)) (cdr x))) forced-aligns))) + (if splice (setq head nil)) + (unless splice (push (if head "<thead>" "<tbody>") html)) + (setq tbopen t) + (while (setq line (pop lines)) + (catch 'next-line + (if (string-match "^[ \t]*|-" line) + (progn + (unless splice + (push (if head "</thead>" "</tbody>") html) + (if lines (push "<tbody>" html) (setq tbopen nil))) + (setq head nil) ;; head ends here, first time around + ;; ignore this line + (throw 'next-line t))) + ;; Break the line into fields + (setq fields (org-split-string line "[ \t]*|[ \t]*")) + (unless fnum (setq fnum (make-vector (length fields) 0) + nfields (length fnum))) + (setq nline (1+ nline) i -1 + rowstart (eval (car org-export-table-row-tags)) + rowend (eval (cdr org-export-table-row-tags))) + (push (concat rowstart + (mapconcat + (lambda (x) + (setq i (1+ i) ali (format "@@class%03d@@" i)) + (if (and (< i nfields) ; make sure no rogue line causes an error here + (string-match org-table-number-regexp x)) + (incf (aref fnum i))) + (cond + (head + (concat + (format (car org-export-table-header-tags) + "col" ali) + x + (cdr org-export-table-header-tags))) + ((and (= i 0) org-export-html-table-use-header-tags-for-first-column) + (concat + (format (car org-export-table-header-tags) + "row" ali) + x + (cdr org-export-table-header-tags))) + (t + (concat (format (car org-export-table-data-tags) ali) + x + (cdr org-export-table-data-tags))))) + fields "") + rowend) + html))) + (unless splice (if tbopen (push "</tbody>" html))) + (unless splice (push "</table>\n" html)) + (setq html (nreverse html)) + (unless splice + ;; Put in col tags with the alignment (unfortunately often ignored...) + (unless (car org-table-colgroup-info) + (setq org-table-colgroup-info + (cons :start (cdr org-table-colgroup-info)))) + (setq i 0) + (push (mapconcat + (lambda (x) + (setq gr (pop org-table-colgroup-info) + i (1+ i) + align (if (assoc i forced-aligns) + (cdr (assoc (cdr (assoc i forced-aligns)) + '(("l" . "left") ("r" . "right") + ("c" . "center")))) + (if (> (/ (float x) nline) + org-table-number-fraction) + "right" "left"))) + (push align aligns) + (format (if no-css + "%s<col align=\"%s\" />%s" + "%s<col class=\"%s\" />%s") + (if (memq gr '(:start :startend)) + (prog1 + (if colgropen + "</colgroup>\n<colgroup>" + "<colgroup>") + (setq colgropen t)) + "") + align + (if (memq gr '(:end :startend)) + (progn (setq colgropen nil) "</colgroup>") + ""))) + fnum "") + html) + (setq aligns (nreverse aligns)) + (if colgropen (setq html (cons (car html) + (cons "</colgroup>" (cdr html))))) + ;; Since the output of HTML table formatter can also be used in + ;; DocBook document, we want to always include the caption to make + ;; DocBook XML file valid. + (push (format "<caption>%s</caption>" (or caption "")) html) + (when label (push (format "<a name=\"%s\" id=\"%s\"></a>" label label) + html)) + (push html-table-tag html)) + (setq html (mapcar + (lambda (x) + (replace-regexp-in-string + "@@class\\([0-9]+\\)@@" + (lambda (txt) + (if (not org-export-html-table-align-individual-fields) + "" + (setq n (string-to-number (match-string 1 txt))) + (format (if no-css " align=\"%s\"" " class=\"%s\"") + (or (nth n aligns) "left")))) + x)) + html)) + (concat (mapconcat 'identity html "\n") "\n"))) + +(defun org-export-splice-attributes (tag attributes) + "Read attributes in string ATTRIBUTES, add and replace in HTML tag TAG." + (if (not attributes) + tag + (let (oldatt newatt) + (setq oldatt (org-extract-attributes-from-string tag) + tag (pop oldatt) + newatt (cdr (org-extract-attributes-from-string attributes))) + (while newatt + (setq oldatt (plist-put oldatt (pop newatt) (pop newatt)))) + (if (string-match ">" tag) + (setq tag + (replace-match (concat (org-attributes-to-string oldatt) ">") + t t tag))) + tag))) + +(defun org-format-table-table-html (lines) + "Format a table generated by table.el into HTML. +This conversion does *not* use `table-generate-source' from table.el. +This has the advantage that Org-mode's HTML conversions can be used. +But it has the disadvantage, that no cell- or row-spanning is allowed." + (let (line field-buffer + (head org-export-highlight-first-table-line) + fields html empty i) + (setq html (concat html-table-tag "\n")) + (while (setq line (pop lines)) + (setq empty " ") + (catch 'next-line + (if (string-match "^[ \t]*\\+-" line) + (progn + (if field-buffer + (progn + (setq + html + (concat + html + "<tr>" + (mapconcat + (lambda (x) + (if (equal x "") (setq x empty)) + (if head + (concat + (format (car org-export-table-header-tags) "col" "") + x + (cdr org-export-table-header-tags)) + (concat (format (car org-export-table-data-tags) "") x + (cdr org-export-table-data-tags)))) + field-buffer "\n") + "</tr>\n")) + (setq head nil) + (setq field-buffer nil))) + ;; Ignore this line + (throw 'next-line t))) + ;; Break the line into fields and store the fields + (setq fields (org-split-string line "[ \t]*|[ \t]*")) + (if field-buffer + (setq field-buffer (mapcar + (lambda (x) + (concat x "<br/>" (pop fields))) + field-buffer)) + (setq field-buffer fields)))) + (setq html (concat html "</table>\n")) + html)) + +(defun org-format-table-table-html-using-table-generate-source (lines) + "Format a table into html, using `table-generate-source' from table.el. +This has the advantage that cell- or row-spanning is allowed. +But it has the disadvantage, that Org-mode's HTML conversions cannot be used." + (require 'table) + (with-current-buffer (get-buffer-create " org-tmp1 ") + (erase-buffer) + (insert (mapconcat 'identity lines "\n")) + (goto-char (point-min)) + (if (not (re-search-forward "|[^+]" nil t)) + (error "Error processing table")) + (table-recognize-table) + (with-current-buffer (get-buffer-create " org-tmp2 ") (erase-buffer)) + (table-generate-source 'html " org-tmp2 ") + (set-buffer " org-tmp2 ") + (buffer-substring (point-min) (point-max)))) + +(defun org-export-splice-style (style extra) + "Splice EXTRA into STYLE, just before \"</style>\"." + (if (and (stringp extra) + (string-match "\\S-" extra) + (string-match "</style>" style)) + (concat (substring style 0 (match-beginning 0)) + "\n" extra "\n" + (substring style (match-beginning 0))) + style)) + +(defun org-html-handle-time-stamps (s) + "Format time stamps in string S, or remove them." + (catch 'exit + (let (r b) + (while (string-match org-maybe-keyword-time-regexp s) + (or b (setq b (substring s 0 (match-beginning 0)))) + (setq r (concat + r (substring s 0 (match-beginning 0)) + " @<span class=\"timestamp-wrapper\">" + (if (match-end 1) + (format "@<span class=\"timestamp-kwd\">%s @</span>" + (match-string 1 s))) + (format " @<span class=\"timestamp\">%s@</span>" + (substring + (org-translate-time (match-string 3 s)) 1 -1)) + "@</span>") + s (substring s (match-end 0)))) + ;; Line break if line started and ended with time stamp stuff + (if (not r) + s + (setq r (concat r s)) + (unless (string-match "\\S-" (concat b s)) + (setq r (concat r "@<br/>"))) + r)))) + +(defvar htmlize-buffer-places) ; from htmlize.el +(defun org-export-htmlize-region-for-paste (beg end) + "Convert the region to HTML, using htmlize.el. +This is much like `htmlize-region-for-paste', only that it uses +the settings define in the org-... variables." + (let* ((htmlize-output-type org-export-htmlize-output-type) + (htmlize-css-name-prefix org-export-htmlize-css-font-prefix) + (htmlbuf (htmlize-region beg end))) + (unwind-protect + (with-current-buffer htmlbuf + (buffer-substring (plist-get htmlize-buffer-places 'content-start) + (plist-get htmlize-buffer-places 'content-end))) + (kill-buffer htmlbuf)))) + +;;;###autoload +(defun org-export-htmlize-generate-css () + "Create the CSS for all font definitions in the current Emacs session. +Use this to create face definitions in your CSS style file that can then +be used by code snippets transformed by htmlize. +This command just produces a buffer that contains class definitions for all +faces used in the current Emacs session. You can copy and paste the ones you +need into your CSS file. + +If you then set `org-export-htmlize-output-type' to `css', calls to +the function `org-export-htmlize-region-for-paste' will produce code +that uses these same face definitions." + (interactive) + (require 'htmlize) + (and (get-buffer "*html*") (kill-buffer "*html*")) + (with-temp-buffer + (let ((fl (face-list)) + (htmlize-css-name-prefix "org-") + (htmlize-output-type 'css) + f i) + (while (setq f (pop fl) + i (and f (face-attribute f :inherit))) + (when (and (symbolp f) (or (not i) (not (listp i)))) + (insert (org-add-props (copy-sequence "1") nil 'face f)))) + (htmlize-region (point-min) (point-max)))) + (switch-to-buffer "*html*") + (goto-char (point-min)) + (if (re-search-forward "<style" nil t) + (delete-region (point-min) (match-beginning 0))) + (if (re-search-forward "</style>" nil t) + (delete-region (1+ (match-end 0)) (point-max))) + (beginning-of-line 1) + (if (looking-at " +") (replace-match "")) + (goto-char (point-min))) + +(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))) +; (while (string-match "\"" s) +; (setq s (replace-match """ t t s))) + ) + s) + +(defun org-html-expand (string) + "Prepare STRING for HTML export. Apply all active conversions. +If there are links in the string, don't modify these." + (let* ((re (concat org-bracket-link-regexp "\\|" + (org-re "[ \t]+\\(:[[:alnum:]_@#%:]+:\\)[ \t]*$"))) + m s l res) + (if (string-match "^[ \t]*\\+-[-+]*\\+[ \t]*$" string) + string + (while (setq m (string-match re string)) + (setq s (substring string 0 m) + l (match-string 0 string) + string (substring string (match-end 0))) + (push (org-html-do-expand s) res) + (push l res)) + (push (org-html-do-expand string) res) + (apply 'concat (nreverse res))))) + +(defun org-html-do-expand (s) + "Apply all active conversions to translate special ASCII to HTML." + (setq s (org-html-protect s)) + (if org-export-html-expand + (while (string-match "@<\\([^&]*\\)>" s) + (setq s (replace-match "<\\1>" t nil s)))) + (if org-export-with-emphasize + (setq s (org-export-html-convert-emphasize s))) + (if org-export-with-special-strings + (setq s (org-export-html-convert-special-strings s))) + (if org-export-with-sub-superscripts + (setq s (org-export-html-convert-sub-super s))) + (if org-export-with-TeX-macros + (let ((start 0) wd rep) + (while (setq start (string-match "\\\\\\([a-zA-Z]+[0-9]*\\)\\({}\\)?" + s start)) + (if (get-text-property (match-beginning 0) 'org-protected s) + (setq start (match-end 0)) + (setq wd (match-string 1 s)) + (if (setq rep (org-entity-get-representation wd 'html)) + (setq s (replace-match rep t t s)) + (setq start (+ start (length wd)))))))) + s) + +(defun org-export-html-convert-special-strings (string) + "Convert special characters in STRING to HTML." + (let ((all org-export-html-special-string-regexps) + e a re rpl start) + (while (setq a (pop all)) + (setq re (car a) rpl (cdr a) start 0) + (while (string-match re string start) + (if (get-text-property (match-beginning 0) 'org-protected string) + (setq start (match-end 0)) + (setq string (replace-match rpl t nil string))))) + string)) + +(defun org-export-html-convert-sub-super (string) + "Convert sub- and superscripts in STRING to HTML." + (let (key c (s 0) (requireb (eq org-export-with-sub-superscripts '{}))) + (while (string-match org-match-substring-regexp string s) + (cond + ((and requireb (match-end 8)) (setq s (match-end 2))) + ((get-text-property (match-beginning 2) 'org-protected string) + (setq s (match-end 2))) + (t + (setq s (match-end 1) + key (if (string= (match-string 2 string) "_") "sub" "sup") + c (or (match-string 8 string) + (match-string 6 string) + (match-string 5 string)) + string (replace-match + (concat (match-string 1 string) + "<" key ">" c "</" key ">") + t t string))))) + (while (string-match "\\\\\\([_^]\\)" string) + (setq string (replace-match (match-string 1 string) t t string))) + string)) + +(defun org-export-html-convert-emphasize (string) + "Apply emphasis." + (let ((s 0) rpl) + (while (string-match org-emph-re string s) + (if (not (equal + (substring string (match-beginning 3) (1+ (match-beginning 3))) + (substring string (match-beginning 4) (1+ (match-beginning 4))))) + (setq s (match-beginning 0) + rpl + (concat + (match-string 1 string) + (nth 2 (assoc (match-string 3 string) org-emphasis-alist)) + (match-string 4 string) + (nth 3 (assoc (match-string 3 string) + org-emphasis-alist)) + (match-string 5 string)) + string (replace-match rpl t t string) + s (+ s (- (length rpl) 2))) + (setq s (1+ s)))) + string)) + +(defun org-open-par () + "Insert <p>, but first close previous paragraph if any." + (org-close-par-maybe) + (insert "\n<p>") + (setq org-par-open t)) +(defun org-close-par-maybe () + "Close paragraph if there is one open." + (when org-par-open + (insert "</p>") + (setq org-par-open nil))) +(defun org-close-li (&optional type) + "Close <li> if necessary." + (org-close-par-maybe) + (insert (if (equal type "d") "</dd>\n" "</li>\n"))) + +(defvar in-local-list) +(defvar local-list-indent) +(defvar local-list-type) + +(defvar body-only) ; dynamically scoped into this. +(defun org-html-level-start (level title umax with-toc head-count) + "Insert a new level in HTML export. +When TITLE is nil, just close all open levels." + (org-close-par-maybe) + (let* ((target (and title (org-get-text-property-any 0 'target title))) + (extra-targets (and target + (assoc target org-export-target-aliases))) + (extra-class (and title (org-get-text-property-any 0 'html-container-class title))) + (preferred (and target + (cdr (assoc target org-export-preferred-target-alist)))) + (l org-level-max) + snumber snu href suffix) + (setq extra-targets (remove (or preferred target) extra-targets)) + (setq extra-targets + (mapconcat (lambda (x) + (if (org-uuidgen-p x) (setq x (concat "ID-" x))) + (format "<a name=\"%s\" id=\"%s\"></a>" + x x)) + extra-targets + "")) + (while (>= l level) + (if (aref org-levels-open (1- l)) + (progn + (org-html-level-close l umax) + (aset org-levels-open (1- l) nil))) + (setq l (1- l))) + (when title + ;; If title is nil, this means this function is called to close + ;; all levels, so the rest is done only if title is given + (when (string-match (org-re "\\(:[[:alnum:]_@#%:]+:\\)[ \t]*$") title) + (setq title (replace-match + (if org-export-with-tags + (save-match-data + (concat + " <span class=\"tag\">" + (mapconcat + (lambda (x) + (format "<span class=\"%s\">%s</span>" + (org-export-html-get-tag-class-name x) + x)) + (org-split-string (match-string 1 title) ":") + " ") + "</span>")) + "") + t t title))) + (if (> level umax) + (progn + (if (aref org-levels-open (1- level)) + (progn + (org-close-li) + (if target + (insert (format "<li id=\"%s\">" (or preferred target)) + extra-targets title "<br/>\n") + (insert "<li>" title "<br/>\n"))) + (aset org-levels-open (1- level) t) + (org-close-par-maybe) + (if target + (insert (format "<ul>\n<li id=\"%s\">" (or preferred target)) + extra-targets title "<br/>\n") + (insert "<ul>\n<li>" title "<br/>\n")))) + (aset org-levels-open (1- level) t) + (setq snumber (org-section-number level) + snu (replace-regexp-in-string "\\." "_" snumber)) + (setq level (+ level org-export-html-toplevel-hlevel -1)) + (if (and org-export-with-section-numbers (not body-only)) + (setq title (concat + (format "<span class=\"section-number-%d\">%s</span>" + level snumber) + " " title))) + (unless (= head-count 1) (insert "\n</div>\n")) + (setq href (cdr (assoc (concat "sec-" snu) org-export-preferred-target-alist))) + (setq suffix (or href snu)) + (setq href (or href (concat "sec-" snu))) + (insert (format "\n<div id=\"outline-container-%s\" class=\"outline-%d%s\">\n<h%d id=\"%s\">%s%s</h%d>\n<div class=\"outline-text-%d\" id=\"text-%s\">\n" + suffix level (if extra-class (concat " " extra-class) "") + level href + extra-targets + title level level suffix)) + (org-open-par))))) + +(defun org-export-html-get-tag-class-name (tag) + "Turn tag into a valid class name. +Replaces invalid characters with \"_\" and then prepends a prefix." + (save-match-data + (while (string-match "[^a-zA-Z0-9_]" tag) + (setq tag (replace-match "_" t t tag)))) + (concat org-export-html-tag-class-prefix tag)) + +(defun org-export-html-get-todo-kwd-class-name (kwd) + "Turn todo keyword into a valid class name. +Replaces invalid characters with \"_\" and then prepends a prefix." + (save-match-data + (while (string-match "[^a-zA-Z0-9_]" kwd) + (setq kwd (replace-match "_" t t kwd)))) + (concat org-export-html-todo-kwd-class-prefix kwd)) + +(defun org-html-level-close (level max-outline-level) + "Terminate one level in HTML export." + (if (<= level max-outline-level) + (insert "</div>\n") + (org-close-li) + (insert "</ul>\n"))) + +(provide 'org-html) + +;; arch-tag: 8109d84d-eb8f-460b-b1a8-f45f3a6c7ea1 +;;; org-html.el ends here diff --git a/.emacs.d/org-7.4/lisp/org-html.elc b/.emacs.d/org-7.4/lisp/org-html.elc Binary files differnew file mode 100644 index 0000000..abd5a33 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-html.elc diff --git a/.emacs.d/org-7.4/lisp/org-icalendar.el b/.emacs.d/org-7.4/lisp/org-icalendar.el new file mode 100644 index 0000000..d4034fe --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-icalendar.el @@ -0,0 +1,655 @@ +;;; org-icalendar.el --- iCalendar export for Org-mode + +;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010 +;; Free Software Foundation, Inc. + +;; Author: Carsten Dominik <carsten at orgmode dot org> +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; Version: 7.4 +;; +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: + +;;; Code: + +(require 'org-exp) + +(eval-when-compile + (require 'cl)) + +(declare-function org-bbdb-anniv-export-ical "org-bbdb" nil) + +(defgroup org-export-icalendar nil + "Options specific for iCalendar export of Org-mode files." + :tag "Org Export iCalendar" + :group 'org-export) + +(defcustom org-combined-agenda-icalendar-file "~/org.ics" + "The file name for the iCalendar file covering all agenda files. +This file is created with the command \\[org-export-icalendar-all-agenda-files]. +The file name should be absolute, the file will be overwritten without warning." + :group 'org-export-icalendar + :type 'file) + +(defcustom org-icalendar-alarm-time 0 + "Number of minutes for triggering an alarm for exported timed events. +A zero value (the default) turns off the definition of an alarm trigger +for timed events. If non-zero, alarms are created. + +- a single alarm per entry is defined +- The alarm will go off N minutes before the event +- only a DISPLAY action is defined." + :group 'org-export-icalendar + :type 'integer) + +(defcustom org-icalendar-combined-name "OrgMode" + "Calendar name for the combined iCalendar representing all agenda files." + :group 'org-export-icalendar + :type 'string) + +(defcustom org-icalendar-combined-description nil + "Calendar description for the combined iCalendar (all agenda files)." + :group 'org-export-icalendar + :type 'string) + +(defcustom org-icalendar-use-plain-timestamp t + "Non-nil means make an event from every plain time stamp." + :group 'org-export-icalendar + :type 'boolean) + +(defcustom org-icalendar-use-deadline '(event-if-not-todo todo-due) + "Contexts where iCalendar export should use a deadline time stamp. +This is a list with several symbols in it. Valid symbol are: + +event-if-todo Deadlines in TODO entries become calendar events. +event-if-not-todo Deadlines in non-TODO entries become calendar events. +todo-due Use deadlines in TODO entries as due-dates" + :group 'org-export-icalendar + :type '(set :greedy t + (const :tag "Deadlines in non-TODO entries become events" + event-if-not-todo) + (const :tag "Deadline in TODO entries become events" + event-if-todo) + (const :tag "Deadlines in TODO entries become due-dates" + todo-due))) + +(defcustom org-icalendar-use-scheduled '(todo-start) + "Contexts where iCalendar export should use a scheduling time stamp. +This is a list with several symbols in it. Valid symbol are: + +event-if-todo Scheduling time stamps in TODO entries become an event. +event-if-not-todo Scheduling time stamps in non-TODO entries become an event. +todo-start Scheduling time stamps in TODO entries become start date. + Some calendar applications show TODO entries only after + that date." + :group 'org-export-icalendar + :type '(set :greedy t + (const :tag + "SCHEDULED timestamps in non-TODO entries become events" + event-if-not-todo) + (const :tag "SCHEDULED timestamps in TODO entries become events" + event-if-todo) + (const :tag "SCHEDULED in TODO entries become start date" + todo-start))) + +(defcustom org-icalendar-categories '(local-tags category) + "Items that should be entered into the categories field. +This is a list of symbols, the following are valid: + +category The Org-mode category of the current file or tree +todo-state The todo state, if any +local-tags The tags, defined in the current line +all-tags All tags, including inherited ones." + :group 'org-export-icalendar + :type '(repeat + (choice + (const :tag "The file or tree category" category) + (const :tag "The TODO state" todo-state) + (const :tag "Tags defined in current line" local-tags) + (const :tag "All tags, including inherited ones" all-tags)))) + +(defcustom org-icalendar-include-todo nil + "Non-nil means export to iCalendar files should also cover TODO items. +Valid values are: +nil don't include any TODO items +t include all TODO items that are not in a DONE state +unblocked include all TODO items that are not blocked +all include both done and not done items." + :group 'org-export-icalendar + :type '(choice + (const :tag "None" nil) + (const :tag "Unfinished" t) + (const :tag "Unblocked" unblocked) + (const :tag "All" all))) + +(defvar org-icalendar-verify-function nil + "Function to verify entries for iCalendar export. +This can be set to a function that will be called at each entry that +is considered for export to iCalendar. When the function returns nil, +the entry will be skipped. When it returns a non-nil value, the entry +will be considered for export. +This is used internally when an agenda buffer is exported to an ics file, +to make sure that only entries currently listed in the agenda will end +up in the ics file. But for normal iCalendar export, you can use this +for whatever you need.") + +(defcustom org-icalendar-include-bbdb-anniversaries nil + "Non-nil means a combined iCalendar files should include anniversaries. +The anniversaries are define in the BBDB database." + :group 'org-export-icalendar + :type 'boolean) + +(defcustom org-icalendar-include-sexps t + "Non-nil means export to iCalendar files should also cover sexp entries. +These are entries like in the diary, but directly in an Org-mode file." + :group 'org-export-icalendar + :type 'boolean) + +(defcustom org-icalendar-include-body 100 + "Amount of text below headline to be included in iCalendar export. +This is a number of characters that should maximally be included. +Properties, scheduling and clocking lines will always be removed. +The text will be inserted into the DESCRIPTION field." + :group 'org-export-icalendar + :type '(choice + (const :tag "Nothing" nil) + (const :tag "Everything" t) + (integer :tag "Max characters"))) + +(defcustom org-icalendar-store-UID nil + "Non-nil means store any created UIDs in properties. +The iCalendar standard requires that all entries have a unique identifier. +Org will create these identifiers as needed. When this variable is non-nil, +the created UIDs will be stored in the ID property of the entry. Then the +next time this entry is exported, it will be exported with the same UID, +superseding the previous form of it. This is essential for +synchronization services. +This variable is not turned on by default because we want to avoid creating +a property drawer in every entry if people are only playing with this feature, +or if they are only using it locally." + :group 'org-export-icalendar + :type 'boolean) + +(defcustom org-icalendar-timezone (getenv "TZ") + "The time zone string for iCalendar export. +When nil of the empty string, use the abbreviation retrieved from Emacs." + :group 'org-export-icalendar + :type '(choice + (const :tag "Unspecified" nil) + (string :tag "Time zone"))) + +(defcustom org-icalendar-use-UTC-date-time () + "Non-nil force the use of the universal time for iCalendar DATE-TIME. +The iCalendar DATE-TIME can be expressed with local time or universal Time, +universal time could be more compatible with some external tools." + :group 'org-export-icalendar + :type 'boolean) + +;;; iCalendar export + +;;;###autoload +(defun org-export-icalendar-this-file () + "Export current file as an iCalendar file. +The iCalendar file will be located in the same directory as the Org-mode +file, but with extension `.ics'." + (interactive) + (org-export-icalendar nil buffer-file-name)) + +;;;###autoload +(defun org-export-icalendar-all-agenda-files () + "Export all files in the variable `org-agenda-files' to iCalendar .ics files. +Each iCalendar file will be located in the same directory as the Org-mode +file, but with extension `.ics'." + (interactive) + (apply 'org-export-icalendar nil (org-agenda-files t))) + +;;;###autoload +(defun org-export-icalendar-combine-agenda-files () + "Export all files in `org-agenda-files' to a single combined iCalendar file. +The file is stored under the name `org-combined-agenda-icalendar-file'." + (interactive) + (apply 'org-export-icalendar t (org-agenda-files t))) + +(defun org-export-icalendar (combine &rest files) + "Create iCalendar files for all elements of FILES. +If COMBINE is non-nil, combine all calendar entries into a single large +file and store it under the name `org-combined-agenda-icalendar-file'." + (save-excursion + (org-prepare-agenda-buffers files) + (let* ((dir (org-export-directory + :ical (list :publishing-directory + org-export-publishing-directory))) + file ical-file ical-buffer category started org-agenda-new-buffers) + (and (get-buffer "*ical-tmp*") (kill-buffer "*ical-tmp*")) + (when combine + (setq ical-file + (if (file-name-absolute-p org-combined-agenda-icalendar-file) + org-combined-agenda-icalendar-file + (expand-file-name org-combined-agenda-icalendar-file dir)) + ical-buffer (org-get-agenda-file-buffer ical-file)) + (set-buffer ical-buffer) (erase-buffer)) + (while (setq file (pop files)) + (catch 'nextfile + (org-check-agenda-file file) + (set-buffer (org-get-agenda-file-buffer file)) + (unless combine + (setq ical-file (concat (file-name-as-directory dir) + (file-name-sans-extension + (file-name-nondirectory buffer-file-name)) + ".ics")) + (setq ical-buffer (org-get-agenda-file-buffer ical-file)) + (with-current-buffer ical-buffer (erase-buffer))) + (setq category (or org-category + (file-name-sans-extension + (file-name-nondirectory buffer-file-name)))) + (if (symbolp category) (setq category (symbol-name category))) + (let ((standard-output ical-buffer)) + (if combine + (and (not started) (setq started t) + (org-start-icalendar-file org-icalendar-combined-name)) + (org-start-icalendar-file category)) + (org-print-icalendar-entries combine) + (when (or (and combine (not files)) (not combine)) + (when (and combine org-icalendar-include-bbdb-anniversaries) + (require 'org-bbdb) + (org-bbdb-anniv-export-ical)) + (org-finish-icalendar-file) + (set-buffer ical-buffer) + (run-hooks 'org-before-save-iCalendar-file-hook) + (save-buffer) + (run-hooks 'org-after-save-iCalendar-file-hook) + (and (boundp 'org-wait) (numberp org-wait) (sit-for org-wait)) + )))) + (org-release-buffers org-agenda-new-buffers)))) + +(defvar org-before-save-iCalendar-file-hook nil + "Hook run before an iCalendar file has been saved. +This can be used to modify the result of the export.") + +(defvar org-after-save-iCalendar-file-hook nil + "Hook run after an iCalendar file has been saved. +The iCalendar buffer is still current when this hook is run. +A good way to use this is to tell a desktop calendar application to re-read +the iCalendar file.") + +(defvar org-agenda-default-appointment-duration) ; defined in org-agenda.el +(defun org-print-icalendar-entries (&optional combine) + "Print iCalendar entries for the current Org-mode file to `standard-output'. +When COMBINE is non nil, add the category to each line." + (require 'org-agenda) + (let ((re1 (concat org-ts-regexp "\\|<%%([^>\n]+>")) + (re2 (concat "--?-?\\(" org-ts-regexp "\\)")) + (dts (org-ical-ts-to-string + (format-time-string (cdr org-time-stamp-formats) (current-time)) + "DTSTART")) + hd ts ts2 state status (inc t) pos b sexp rrule + scheduledp deadlinep todo prefix due start + tmp pri categories location summary desc uid alarm + (sexp-buffer (get-buffer-create "*ical-tmp*"))) + (org-refresh-category-properties) + (save-excursion + (goto-char (point-min)) + (while (re-search-forward re1 nil t) + (catch :skip + (org-agenda-skip) + (when org-icalendar-verify-function + (unless (save-match-data (funcall org-icalendar-verify-function)) + (outline-next-heading) + (backward-char 1) + (throw :skip nil))) + (setq pos (match-beginning 0) + ts (match-string 0) + inc t + hd (condition-case nil + (org-icalendar-cleanup-string + (org-get-heading t)) + (error (throw :skip nil))) + summary (org-icalendar-cleanup-string + (org-entry-get nil "SUMMARY")) + desc (org-icalendar-cleanup-string + (or (org-entry-get nil "DESCRIPTION") + (and org-icalendar-include-body (org-get-entry))) + t org-icalendar-include-body) + location (org-icalendar-cleanup-string + (org-entry-get nil "LOCATION" 'selective)) + uid (if org-icalendar-store-UID + (org-id-get-create) + (or (org-id-get) (org-id-new))) + categories (org-export-get-categories) + alarm "" + deadlinep nil scheduledp nil) + (if (looking-at re2) + (progn + (goto-char (match-end 0)) + (setq ts2 (match-string 1) + inc (not (string-match "[0-9]\\{1,2\\}:[0-9][0-9]" ts2)))) + (setq tmp (buffer-substring (max (point-min) + (- pos org-ds-keyword-length)) + pos) + ts2 (if (string-match "[0-9]\\{1,2\\}:[0-9][0-9]-\\([0-9]\\{1,2\\}:[0-9][0-9]\\)" ts) + (progn + (setq inc nil) + (replace-match "\\1" t nil ts)) + ts) + deadlinep (string-match org-deadline-regexp tmp) + scheduledp (string-match org-scheduled-regexp tmp) + todo (org-get-todo-state) + ;; donep (org-entry-is-done-p) + )) + (when (and (not org-icalendar-use-plain-timestamp) + (not deadlinep) (not scheduledp)) + (throw :skip t)) + (when (and + deadlinep + (if todo + (not (memq 'event-if-todo org-icalendar-use-deadline)) + (not (memq 'event-if-not-todo org-icalendar-use-deadline)))) + (throw :skip t)) + (when (and + scheduledp + (if todo + (not (memq 'event-if-todo org-icalendar-use-scheduled)) + (not (memq 'event-if-not-todo org-icalendar-use-scheduled)))) + (throw :skip t)) + (setq prefix (if deadlinep "DL-" (if scheduledp "SC-" "TS-"))) + (if (or (string-match org-tr-regexp hd) + (string-match org-ts-regexp hd)) + (setq hd (replace-match "" t t hd))) + (if (string-match "\\+\\([0-9]+\\)\\([dwmy]\\)>" ts) + (setq rrule + (concat "\nRRULE:FREQ=" + (cdr (assoc + (match-string 2 ts) + '(("d" . "DAILY")("w" . "WEEKLY") + ("m" . "MONTHLY")("y" . "YEARLY")))) + ";INTERVAL=" (match-string 1 ts))) + (setq rrule "")) + (setq summary (or summary hd)) + ;; create an alarm entry if the entry is timed. this is not very general in that: + ;; (a) only one alarm per entry is defined, + ;; (b) only minutes are allowed for the trigger period ahead of the start time, and + ;; (c) only a DISPLAY action is defined. + ;; [ESF] + (let ((t1 (ignore-errors (org-parse-time-string ts 'nodefault)))) + (if (and (> org-icalendar-alarm-time 0) + (car t1) (nth 1 t1) (nth 2 t1)) + (setq alarm (format "\nBEGIN:VALARM\nACTION:DISPLAY\nDESCRIPTION:%s\nTRIGGER:-P0D0H%dM0S\nEND:VALARM" summary org-icalendar-alarm-time)) + (setq alarm "")) + ) + (if (string-match org-bracket-link-regexp summary) + (setq summary + (replace-match (if (match-end 3) + (match-string 3 summary) + (match-string 1 summary)) + t t summary))) + (if deadlinep (setq summary (concat "DL: " summary))) + (if scheduledp (setq summary (concat "S: " summary))) + (if (string-match "\\`<%%" ts) + (with-current-buffer sexp-buffer + (insert (substring ts 1 -1) " " summary "\n")) + (princ (format "BEGIN:VEVENT +UID: %s +%s +%s%s +SUMMARY:%s%s%s +CATEGORIES:%s%s +END:VEVENT\n" + (concat prefix uid) + (org-ical-ts-to-string ts "DTSTART") + (org-ical-ts-to-string ts2 "DTEND" inc) + rrule summary + (if (and desc (string-match "\\S-" desc)) + (concat "\nDESCRIPTION: " desc) "") + (if (and location (string-match "\\S-" location)) + (concat "\nLOCATION: " location) "") + categories + alarm))))) + (when (and org-icalendar-include-sexps + (condition-case nil (require 'icalendar) (error nil)) + (fboundp 'icalendar-export-region)) + ;; Get all the literal sexps + (goto-char (point-min)) + (while (re-search-forward "^&?%%(" nil t) + (catch :skip + (org-agenda-skip) + (when org-icalendar-verify-function + (unless (save-match-data (funcall org-icalendar-verify-function)) + (outline-next-heading) + (backward-char 1) + (throw :skip nil))) + (setq b (match-beginning 0)) + (goto-char (1- (match-end 0))) + (forward-sexp 1) + (end-of-line 1) + (setq sexp (buffer-substring b (point))) + (with-current-buffer sexp-buffer + (insert sexp "\n")))) + (princ (org-diary-to-ical-string sexp-buffer)) + (kill-buffer sexp-buffer)) + + (when org-icalendar-include-todo + (setq prefix "TODO-") + (goto-char (point-min)) + (while (re-search-forward org-complex-heading-regexp nil t) + (catch :skip + (org-agenda-skip) + (when org-icalendar-verify-function + (unless (save-match-data + (funcall org-icalendar-verify-function)) + (outline-next-heading) + (backward-char 1) + (throw :skip nil))) + (setq state (match-string 2)) + (setq status (if (member state org-done-keywords) + "COMPLETED" "NEEDS-ACTION")) + (when (and state + (cond + ;; check if the state is one we should use + ((eq org-icalendar-include-todo 'all) + ;; all should be included + t) + ((eq org-icalendar-include-todo 'unblocked) + ;; only undone entries that are not blocked + (and (member state org-not-done-keywords) + (or (not org-blocker-hook) + (save-match-data + (run-hook-with-args-until-failure + 'org-blocker-hook + (list :type 'todo-state-change + :position (point-at-bol) + :from 'todo + :to 'done)))))) + ((eq org-icalendar-include-todo t) + ;; include everything that is not done + (member state org-not-done-keywords)))) + (setq hd (match-string 4) + summary (org-icalendar-cleanup-string + (org-entry-get nil "SUMMARY")) + desc (org-icalendar-cleanup-string + (or (org-entry-get nil "DESCRIPTION") + (and org-icalendar-include-body (org-get-entry))) + t org-icalendar-include-body) + location (org-icalendar-cleanup-string + (org-entry-get nil "LOCATION" 'selective)) + due (and (member 'todo-due org-icalendar-use-deadline) + (org-entry-get nil "DEADLINE")) + start (and (member 'todo-start org-icalendar-use-scheduled) + (org-entry-get nil "SCHEDULED")) + categories (org-export-get-categories) + uid (if org-icalendar-store-UID + (org-id-get-create) + (or (org-id-get) (org-id-new)))) + (and due (setq due (org-ical-ts-to-string due "DUE"))) + (and start (setq start (org-ical-ts-to-string start "DTSTART"))) + + (if (string-match org-bracket-link-regexp hd) + (setq hd (replace-match (if (match-end 3) (match-string 3 hd) + (match-string 1 hd)) + t t hd))) + (if (string-match org-priority-regexp hd) + (setq pri (string-to-char (match-string 2 hd)) + hd (concat (substring hd 0 (match-beginning 1)) + (substring hd (match-end 1)))) + (setq pri org-default-priority)) + (setq pri (floor (- 9 (* 8. (/ (float (- org-lowest-priority pri)) + (- org-lowest-priority org-highest-priority)))))) + + (princ (format "BEGIN:VTODO +UID: %s +%s +SUMMARY:%s%s%s%s +CATEGORIES:%s +SEQUENCE:1 +PRIORITY:%d +STATUS:%s +END:VTODO\n" + (concat prefix uid) + (or start dts) + (or summary hd) + (if (and location (string-match "\\S-" location)) + (concat "\nLOCATION: " location) "") + (if (and desc (string-match "\\S-" desc)) + (concat "\nDESCRIPTION: " desc) "") + (if due (concat "\n" due) "") + categories + pri status))))))))) + +(defun org-export-get-categories () + "Get categories according to `org-icalendar-categories'." + (let ((cs org-icalendar-categories) c rtn tmp) + (while (setq c (pop cs)) + (cond + ((eq c 'category) (push (org-get-category) rtn)) + ((eq c 'todo-state) + (setq tmp (org-get-todo-state)) + (and tmp (push tmp rtn))) + ((eq c 'local-tags) + (setq rtn (append (nreverse (org-get-local-tags-at (point))) rtn))) + ((eq c 'all-tags) + (setq rtn (append (nreverse (org-get-tags-at (point))) rtn))))) + (mapconcat 'identity (nreverse rtn) ","))) + +(defun org-icalendar-cleanup-string (s &optional is-body maxlength) + "Take out stuff and quote what needs to be quoted. +When IS-BODY is non-nil, assume that this is the body of an item, clean up +whitespace, newlines, drawers, and timestamps, and cut it down to MAXLENGTH +characters." + (if (not s) + nil + (if is-body + (let ((re (concat "\\(" org-drawer-regexp "\\)[^\000]*?:END:.*\n?")) + (re2 (concat "^[ \t]*" org-keyword-time-regexp ".*\n?"))) + (while (string-match re s) (setq s (replace-match "" t t s))) + (while (string-match re2 s) (setq s (replace-match "" t t s)))) + (setq s (replace-regexp-in-string "[[:space:]]+" " " s))) + (let ((start 0)) + (while (string-match "\\([,;]\\)" s start) + (setq start (+ (match-beginning 0) 2) + s (replace-match "\\\\\\1" nil nil s)))) + (setq s (org-trim s)) + (when is-body + (while (string-match "[ \t]*\n[ \t]*" s) + (setq s (replace-match "\\n" t t s)))) + (if is-body + (if maxlength + (if (and (numberp maxlength) + (> (length s) maxlength)) + (setq s (substring s 0 maxlength))))) + s)) + +(defun org-icalendar-cleanup-string-rfc2455 (s &optional is-body maxlength) + "Take out stuff and quote what needs to be quoted. +When IS-BODY is non-nil, assume that this is the body of an item, clean up +whitespace, newlines, drawers, and timestamps, and cut it down to MAXLENGTH +characters. +This seems to be more like RFC 2455, but it causes problems, so it is +not used right now." + (if (not s) + nil + (if is-body + (let ((re (concat "\\(" org-drawer-regexp "\\)[^\000]*?:END:.*\n?")) + (re2 (concat "^[ \t]*" org-keyword-time-regexp ".*\n?"))) + (while (string-match re s) (setq s (replace-match "" t t s))) + (while (string-match re2 s) (setq s (replace-match "" t t s))) + (setq s (org-trim s)) + (while (string-match "[ \t]*\n[ \t]*" s) + (setq s (replace-match "\\n" t t s))) + (if maxlength + (if (and (numberp maxlength) + (> (length s) maxlength)) + (setq s (substring s 0 maxlength))))) + (setq s (org-trim s))) + (while (string-match "\"" s) (setq s (replace-match "''" t t s))) + (when (string-match "[;,:]" s) (setq s (concat "\"" s "\""))) + s)) + +(defun org-start-icalendar-file (name) + "Start an iCalendar file by inserting the header." + (let ((user user-full-name) + (name (or name "unknown")) + (timezone (if (> (length org-icalendar-timezone) 0) + org-icalendar-timezone + (cadr (current-time-zone)))) + (description org-icalendar-combined-description)) + (princ + (format "BEGIN:VCALENDAR +VERSION:2.0 +X-WR-CALNAME:%s +PRODID:-//%s//Emacs with Org-mode//EN +X-WR-TIMEZONE:%s +X-WR-CALDESC:%s +CALSCALE:GREGORIAN\n" name user timezone description)))) + +(defun org-finish-icalendar-file () + "Finish an iCalendar file by inserting the END statement." + (princ "END:VCALENDAR\n")) + +(defun org-ical-ts-to-string (s keyword &optional inc) + "Take a time string S and convert it to iCalendar format. +KEYWORD is added in front, to make a complete line like DTSTART.... +When INC is non-nil, increase the hour by two (if time string contains +a time), or the day by one (if it does not contain a time)." + (let ((t1 (ignore-errors (org-parse-time-string s 'nodefault))) + t2 fmt have-time time) + (if (not t1) + "" + (if (and (car t1) (nth 1 t1) (nth 2 t1)) + (setq t2 t1 have-time t) + (setq t2 (org-parse-time-string s))) + (let ((s (car t2)) (mi (nth 1 t2)) (h (nth 2 t2)) + (d (nth 3 t2)) (m (nth 4 t2)) (y (nth 5 t2))) + (when inc + (if have-time + (if org-agenda-default-appointment-duration + (setq mi (+ org-agenda-default-appointment-duration mi)) + (setq h (+ 2 h))) + (setq d (1+ d)))) + (setq time (encode-time s mi h d m y))) + (setq fmt (if have-time (if org-icalendar-use-UTC-date-time + ":%Y%m%dT%H%M%SZ" + ":%Y%m%dT%H%M%S") + ";VALUE=DATE:%Y%m%d")) + (concat keyword (format-time-string fmt time + (and org-icalendar-use-UTC-date-time + have-time)))))) + +(provide 'org-icalendar) + +;; arch-tag: 2dee2b6e-9211-4aee-8a47-a3c7e5bc30cf +;;; org-icalendar.el ends here diff --git a/.emacs.d/org-7.4/lisp/org-icalendar.elc b/.emacs.d/org-7.4/lisp/org-icalendar.elc Binary files differnew file mode 100644 index 0000000..1438753 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-icalendar.elc diff --git a/.emacs.d/org-7.4/lisp/org-id.el b/.emacs.d/org-7.4/lisp/org-id.el new file mode 100644 index 0000000..a8004af --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-id.el @@ -0,0 +1,647 @@ +;;; org-id.el --- Global identifiers for Org-mode entries +;; +;; Copyright (C) 2008, 2009, 2010 Free Software Foundation, Inc. +;; +;; Author: Carsten Dominik <carsten at orgmode dot org> +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; Version: 7.4 +;; +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: + +;; This file implements globally unique identifiers for Org-mode entries. +;; Identifiers are stored in the entry as an :ID: property. Functions +;; are provided that create and retrieve such identifiers, and that find +;; entries based on the identifier. + +;; Identifiers consist of a prefix (default "Org" given by the variable +;; `org-id-prefix') and a unique part that can be created by a number +;; of different methods, see the variable `org-id-method'. +;; Org has a builtin method that uses a compact encoding of the creation +;; time of the ID, with microsecond accuracy. This virtually +;; guarantees globally unique identifiers, even if several people are +;; creating IDs at the same time in files that will eventually be used +;; together. +;; +;; By default Org uses UUIDs as global unique identifiers. +;; +;; This file defines the following API: +;; +;; org-id-get-create +;; Create an ID for the entry at point if it does not yet have one. +;; Returns the ID (old or new). This function can be used +;; interactively, with prefix argument the creation of a new ID is +;; forced, even if there was an old one. +;; +;; org-id-get +;; Get the ID property of an entry. Using appropriate arguments +;; to the function, it can also create the ID for this entry. +;; +;; org-id-goto +;; Command to go to a specific ID, this command can be used +;; interactively. +;; +;; org-id-get-with-outline-path-completion +;; Retrieve the ID of an entry, using outline path completion. +;; This function can work for multiple files. +;; +;; org-id-get-with-outline-drilling +;; Retrieve the ID of an entry, using outline path completion. +;; This function only works for the current file. +;; +;; org-id-find +;; Find the location of an entry with specific id. +;; + +;;; Code: + +(require 'org) + +(declare-function message-make-fqdn "message" ()) + +;;; Customization + +(defgroup org-id nil + "Options concerning global entry identifiers in Org-mode." + :tag "Org ID" + :group 'org) + +(defcustom org-id-uuid-program "uuidgen" + "The uuidgen program." + :group 'org-id + :type 'string) + +(defcustom org-id-method 'uuid + "The method that should be used to create new IDs. + +An ID will consist of the optional prefix specified in `org-id-prefix', +and a unique part created by the method this variable specifies. + +Allowed values are: + +org Org's own internal method, using an encoding of the current time to + microsecond accuracy, and optionally the current domain of the + computer. See the variable `org-id-include-domain'. + +uuid Create random (version 4) UUIDs. If the program defined in + `org-id-uuid-program' is available it is used to create the ID. + Otherwise an internal functions is used." + :group 'org-id + :type '(choice + (const :tag "Org's internal method" org) + (const :tag "external: uuidgen" uuid))) + +(defcustom org-id-prefix nil + "The prefix for IDs. + +This may be a string, or it can be nil to indicate that no prefix is required. +When a string, the string should have no space characters as IDs are expected +to have no space characters in them." + :group 'org-id + :type '(choice + (const :tag "No prefix") + (string :tag "Prefix"))) + +(defcustom org-id-include-domain nil + "Non-nil means add the domain name to new IDs. +This ensures global uniqueness of IDs, and is also suggested by +RFC 2445 in combination with RFC 822. This is only relevant if +`org-id-method' is `org'. When uuidgen is used, the domain will never +be added. +The default is to not use this because we have no really good way to get +the true domain, and Org entries will normally not be shared with enough +people to make this necessary." + :group 'org-id + :type 'boolean) + +(defcustom org-id-track-globally t + "Non-nil means track IDs through files, so that links work globally. +This work by maintaining a hash table for IDs and writing this table +to disk when exiting Emacs. Because of this, it works best if you use +a single Emacs process, not many. + +When nil, IDs are not tracked. Links to IDs will still work within +a buffer, but not if the entry is located in another file. +IDs can still be used if the entry with the id is in the same file as +the link." + :group 'org-id + :type 'boolean) + +(defcustom org-id-locations-file (convert-standard-filename + "~/.emacs.d/.org-id-locations") + "The file for remembering in which file an ID was defined. +This variable is only relevant when `org-id-track-globally' is set." + :group 'org-id + :type 'file) + +(defvar org-id-locations nil + "List of files with IDs in those files. +Depending on `org-id-use-hash' this can also be a hash table mapping IDs +to files.") + +(defvar org-id-files nil + "List of files that contain IDs.") + +(defcustom org-id-extra-files 'org-agenda-text-search-extra-files + "Files to be searched for IDs, besides the agenda files. +When Org reparses files to remake the list of files and IDs it is tracking, +it will normally scan the agenda files, the archives related to agenda files, +any files that are listed as ID containing in the current register, and +any Org-mode files currently visited by Emacs. +You can list additional files here. +This variable is only relevant when `org-id-track-globally' is set." + :group 'org-id + :type + '(choice + (symbol :tag "Variable") + (repeat :tag "List of files" + (file)))) + +(defcustom org-id-search-archives t + "Non-nil means search also the archive files of agenda files for entries. +This is a possibility to reduce overhead, but it means that entries moved +to the archives can no longer be found by ID. +This variable is only relevant when `org-id-track-globally' is set." + :group 'org-id + :type 'boolean) + +;;; The API functions + +;;;###autoload +(defun org-id-get-create (&optional force) + "Create an ID for the current entry and return it. +If the entry already has an ID, just return it. +With optional argument FORCE, force the creation of a new ID." + (interactive "P") + (when force + (org-entry-put (point) "ID" nil)) + (org-id-get (point) 'create)) + +;;;###autoload +(defun org-id-copy () + "Copy the ID of the entry at point to the kill ring. +Create an ID if necessary." + (interactive) + (org-kill-new (org-id-get nil 'create))) + +;;;###autoload +(defun org-id-get (&optional pom create prefix) + "Get the ID property of the entry at point-or-marker POM. +If POM is nil, refer to the entry at point. +If the entry does not have an ID, the function returns nil. +However, when CREATE is non nil, create an ID if none is present already. +PREFIX will be passed through to `org-id-new'. +In any case, the ID of the entry is returned." + (org-with-point-at pom + (let ((id (org-entry-get nil "ID"))) + (cond + ((and id (stringp id) (string-match "\\S-" id)) + id) + (create + (setq id (org-id-new prefix)) + (org-entry-put pom "ID" id) + (org-id-add-location id (buffer-file-name (buffer-base-buffer))) + id) + (t nil))))) + +;;;###autoload +(defun org-id-get-with-outline-path-completion (&optional targets) + "Use outline-path-completion to retrieve the ID of an entry. +TARGETS may be a setting for `org-refile-targets' to define the eligible +headlines. When omitted, all headlines in all agenda files are +eligible. +It returns the ID of the entry. If necessary, the ID is created." + (let* ((org-refile-targets (or targets '((nil . (:maxlevel . 10))))) + (org-refile-use-outline-path + (if (caar org-refile-targets) 'file t)) + (org-refile-target-verify-function nil) + (spos (org-refile-get-location "Entry: ")) + (pom (and spos (move-marker (make-marker) (nth 3 spos) + (get-file-buffer (nth 1 spos)))))) + (prog1 (org-id-get pom 'create) + (move-marker pom nil)))) + +;;;###autoload +(defun org-id-get-with-outline-drilling (&optional targets) + "Use an outline-cycling interface to retrieve the ID of an entry. +This only finds entries in the current buffer, using `org-get-location'. +It returns the ID of the entry. If necessary, the ID is created." + (let* ((spos (org-get-location (current-buffer) org-goto-help)) + (pom (and spos (move-marker (make-marker) (car spos))))) + (prog1 (org-id-get pom 'create) + (move-marker pom nil)))) + +;;;###autoload +(defun org-id-goto (id) + "Switch to the buffer containing the entry with id ID. +Move the cursor to that entry in that buffer." + (interactive "sID: ") + (let ((m (org-id-find id 'marker))) + (unless m + (error "Cannot find entry with ID \"%s\"" id)) + (switch-to-buffer (marker-buffer m)) + (goto-char m) + (move-marker m nil) + (org-show-context))) + +;;;###autoload +(defun org-id-find (id &optional markerp) + "Return the location of the entry with the id ID. +The return value is a cons cell (file-name . position), or nil +if there is no entry with that ID. +With optional argument MARKERP, return the position as a new marker." + (cond + ((symbolp id) (setq id (symbol-name id))) + ((numberp id) (setq id (number-to-string id)))) + (let ((file (org-id-find-id-file id)) + org-agenda-new-buffers where) + (when file + (setq where (org-id-find-id-in-file id file markerp))) + (unless where + (org-id-update-id-locations) + (setq file (org-id-find-id-file id)) + (when file + (setq where (org-id-find-id-in-file id file markerp)))) + where)) + +;;; Internal functions + +;; Creating new IDs + +(defun org-id-new (&optional prefix) + "Create a new globally unique ID. + +An ID consists of two parts separated by a colon: +- a prefix +- a unique part that will be created according to `org-id-method'. + +PREFIX can specify the prefix, the default is given by the variable +`org-id-prefix'. However, if PREFIX is the symbol `none', don't use any +prefix even if `org-id-prefix' specifies one. + +So a typical ID could look like \"Org:4nd91V40HI\"." + (let* ((prefix (if (eq prefix 'none) + "" + (concat (or prefix org-id-prefix) ":"))) + unique) + (if (equal prefix ":") (setq prefix "")) + (cond + ((memq org-id-method '(uuidgen uuid)) + (setq unique (org-trim (shell-command-to-string org-id-uuid-program))) + (unless (org-uuidgen-p unique) + (setq unique (org-id-uuid)))) + ((eq org-id-method 'org) + (let* ((etime (org-id-reverse-string (org-id-time-to-b36))) + (postfix (if org-id-include-domain + (progn + (require 'message) + (concat "@" (message-make-fqdn)))))) + (setq unique (concat etime postfix)))) + (t (error "Invalid `org-id-method'"))) + (concat prefix unique))) + +(defun org-id-uuid () + "Return string with random (version 4) UUID." + (let ((rnd (md5 (format "%s%s%s%s%s%s%s" + (random t) + (current-time) + (user-uid) + (emacs-pid) + (user-full-name) + user-mail-address + (recent-keys))))) + (format "%s-%s-4%s-%s%s-%s" + (substring rnd 0 8) + (substring rnd 8 12) + (substring rnd 13 16) + (format "%x" + (logior + #b10000000 + (logand + #b10111111 + (string-to-number + (substring rnd 16 18) 16)))) + (substring rnd 18 20) + (substring rnd 20 32)))) + +(defun org-id-reverse-string (s) + (mapconcat 'char-to-string (nreverse (string-to-list s)) "")) + +(defun org-id-int-to-b36-one-digit (i) + "Turn an integer between 0 and 61 into a single character 0..9, A..Z, a..z." + (cond + ((< i 10) (+ ?0 i)) + ((< i 36) (+ ?a i -10)) + (t (error "Larger that 35")))) + +(defun org-id-b36-to-int-one-digit (i) + "Turn a character 0..9, A..Z, a..z into a number 0..61. +The input I may be a character, or a single-letter string." + (and (stringp i) (setq i (string-to-char i))) + (cond + ((and (>= i ?0) (<= i ?9)) (- i ?0)) + ((and (>= i ?a) (<= i ?z)) (+ (- i ?a) 10)) + (t (error "Invalid b36 letter")))) + +(defun org-id-int-to-b36 (i &optional length) + "Convert an integer to a base-36 number represented as a string." + (let ((s "")) + (while (> i 0) + (setq s (concat (char-to-string + (org-id-int-to-b36-one-digit (mod i 36))) s) + i (/ i 36))) + (setq length (max 1 (or length 1))) + (if (< (length s) length) + (setq s (concat (make-string (- length (length s)) ?0) s))) + s)) + +(defun org-id-b36-to-int (s) + "Convert a base-36 string into the corresponding integer." + (let ((r 0)) + (mapc (lambda (i) (setq r (+ (* r 36) (org-id-b36-to-int-one-digit i)))) + s) + r)) + +(defun org-id-time-to-b36 (&optional time) + "Encode TIME as a 10-digit string. +This string holds the time to micro-second accuracy, and can be decoded +using `org-id-decode'." + (setq time (or time (current-time))) + (concat (org-id-int-to-b36 (nth 0 time) 4) + (org-id-int-to-b36 (nth 1 time) 4) + (org-id-int-to-b36 (or (nth 2 time) 0) 4))) + +(defun org-id-decode (id) + "Split ID into the prefix and the time value that was used to create it. +The return value is (prefix . time) where PREFIX is nil or a string, +and time is the usual three-integer representation of time." + (let (prefix time parts) + (setq parts (org-split-string id ":")) + (if (= 2 (length parts)) + (setq prefix (car parts) time (nth 1 parts)) + (setq prefix nil time (nth 0 parts))) + (setq time (org-id-reverse-string time)) + (setq time (list (org-id-b36-to-int (substring time 0 4)) + (org-id-b36-to-int (substring time 4 8)) + (org-id-b36-to-int (substring time 8 12)))) + (cons prefix time))) + +;; Storing ID locations (files) + +(defun org-id-update-id-locations (&optional files) + "Scan relevant files for IDs. +Store the relation between files and corresponding IDs. +This will scan all agenda files, all associated archives, and all +files currently mentioned in `org-id-locations'. +When FILES is given, scan these files instead. +When CHECK is given, prepare detailed information about duplicate IDs." + (interactive) + (if (not org-id-track-globally) + (error "Please turn on `org-id-track-globally' if you want to track IDs") + (let* ((org-id-search-archives + (or org-id-search-archives + (and (symbolp org-id-extra-files) + (symbol-value org-id-extra-files) + (member 'agenda-archives org-id-extra-files)))) + (files + (or files + (append + ;; Agenda files and all associated archives + (org-agenda-files t org-id-search-archives) + ;; Explicit extra files + (if (symbolp org-id-extra-files) + (symbol-value org-id-extra-files) + org-id-extra-files) + ;; Files associated with live org-mode buffers + (delq nil + (mapcar (lambda (b) + (with-current-buffer b + (and (org-mode-p) (buffer-file-name)))) + (buffer-list))) + ;; All files known to have IDs + org-id-files))) + org-agenda-new-buffers + file nfiles tfile ids reg found id seen (ndup 0)) + (when (member 'agenda-archives files) + (setq files (delq 'agenda-archives (copy-sequence files)))) + (setq nfiles (length files)) + (while (setq file (pop files)) + (message "Finding ID locations (%d/%d files): %s" + (- nfiles (length files)) nfiles file) + (setq tfile (file-truename file)) + (when (and (file-exists-p file) (not (member tfile seen))) + (push tfile seen) + (setq ids nil) + (with-current-buffer (org-get-agenda-file-buffer file) + (save-excursion + (save-restriction + (widen) + (goto-char (point-min)) + (while (re-search-forward "^[ \t]*:ID:[ \t]+\\(\\S-+\\)[ \t]*$" + nil t) + (setq id (org-match-string-no-properties 1)) + (if (member id found) + (progn + (message "Duplicate ID \"%s\", also in file %s" + id (or (car (delq + nil + (mapcar + (lambda (x) + (if (member id (cdr x)) + (car x))) + reg))) + (buffer-file-name))) + (when (= ndup 0) + (ding) + (sit-for 2)) + (setq ndup (1+ ndup))) + (push id found) + (push id ids))) + (push (cons (abbreviate-file-name file) ids) reg)))))) + (org-release-buffers org-agenda-new-buffers) + (setq org-agenda-new-buffers nil) + (setq org-id-locations reg) + (setq org-id-files (mapcar 'car org-id-locations)) + (org-id-locations-save) ;; this function can also handle the alist form + ;; now convert to a hash + (setq org-id-locations (org-id-alist-to-hash org-id-locations)) + (if (> ndup 0) + (message "WARNING: %d duplicate IDs found, check *Messages* buffer" ndup) + (message "%d unique files scanned for IDs" (length org-id-files))) + org-id-locations))) + +(defun org-id-locations-save () + "Save `org-id-locations' in `org-id-locations-file'." + (when (and org-id-track-globally org-id-locations) + (let ((out (if (hash-table-p org-id-locations) + (org-id-hash-to-alist org-id-locations) + org-id-locations))) + (with-temp-file org-id-locations-file + (print out (current-buffer)))))) + +(defun org-id-locations-load () + "Read the data from `org-id-locations-file'." + (setq org-id-locations nil) + (when org-id-track-globally + (with-temp-buffer + (condition-case nil + (progn + (insert-file-contents-literally org-id-locations-file) + (goto-char (point-min)) + (setq org-id-locations (read (current-buffer)))) + (error + (message "Could not read org-id-values from %s. Setting it to nil." + org-id-locations-file)))) + (setq org-id-files (mapcar 'car org-id-locations)) + (setq org-id-locations (org-id-alist-to-hash org-id-locations)))) + +(defun org-id-add-location (id file) + "Add the ID with location FILE to the database of ID locations." + ;; Only if global tracking is on, and when the buffer has a file + (when (and org-id-track-globally id file) + (unless org-id-locations (org-id-locations-load)) + (puthash id (abbreviate-file-name file) org-id-locations) + (add-to-list 'org-id-files (abbreviate-file-name file)))) + +(add-hook 'kill-emacs-hook 'org-id-locations-save) + +(defun org-id-hash-to-alist (hash) + "Turn an org-id hash into an alist, so that it can be written to a file." + (let (res x) + (maphash + (lambda (k v) + (if (setq x (member v res)) + (setcdr x (cons k (cdr x))) + (push (list v k) res))) + hash) + res)) + +(defun org-id-alist-to-hash (list) + "Turn an org-id location list into a hash table." + (let ((res (make-hash-table + :test 'equal + :size (apply '+ (mapcar 'length list)))) + f) + (mapc + (lambda (x) + (setq f (car x)) + (mapc (lambda (i) (puthash i f res)) (cdr x))) + list) + res)) + +(defun org-id-paste-tracker (txt &optional buffer-or-file) + "Update any IDs in TXT and assign BUFFER-OR-FILE to them." + (when org-id-track-globally + (save-match-data + (setq buffer-or-file (or buffer-or-file (current-buffer))) + (when (bufferp buffer-or-file) + (setq buffer-or-file (or (buffer-base-buffer buffer-or-file) + buffer-or-file)) + (setq buffer-or-file (buffer-file-name buffer-or-file))) + (when buffer-or-file + (let ((fname (abbreviate-file-name buffer-or-file)) + (s 0)) + (while (string-match "^[ \t]*:ID:[ \t]+\\([^ \t\n\r]+\\)" txt s) + (setq s (match-end 0)) + (org-id-add-location (match-string 1 txt) fname))))))) + +;; Finding entries with specified id + +;;;###autoload +(defun org-id-find-id-file (id) + "Query the id database for the file in which this ID is located." + (unless org-id-locations (org-id-locations-load)) + (or (and org-id-locations + (hash-table-p org-id-locations) + (gethash id org-id-locations)) + ;; ball back on current buffer + (buffer-file-name (or (buffer-base-buffer (current-buffer)) + (current-buffer))))) + +(defun org-id-find-id-in-file (id file &optional markerp) + "Return the position of the entry ID in FILE. +If that files does not exist, or if it does not contain this ID, +return nil. +The position is returned as a cons cell (file-name . position). With +optional argument MARKERP, return the position as a new marker." + (let (org-agenda-new-buffers buf pos) + (cond + ((not file) nil) + ((not (file-exists-p file)) nil) + (t (with-current-buffer (setq buf (org-get-agenda-file-buffer file)) + (setq pos (org-find-entry-with-id id)) + (when pos + (if markerp + (move-marker (make-marker) pos buf) + (cons file pos)))))))) + +;; id link type + +;; Calling the following function is hard-coded into `org-store-link', +;; so we do have to add it to `org-store-link-functions'. + +;;;###autoload +(defun org-id-store-link () + "Store a link to the current entry, using its ID." + (interactive) + (when (and (buffer-file-name (buffer-base-buffer)) (org-mode-p)) + (let* ((link (org-make-link "id:" (org-id-get-create))) + (case-fold-search nil) + (desc (save-excursion + (org-back-to-heading t) + (or (and (looking-at org-complex-heading-regexp) + (if (match-end 4) + (match-string 4) + (match-string 0))) + link)))) + (org-store-link-props :link link :description desc :type "id") + link))) + +(defun org-id-open (id) + "Go to the entry with id ID." + (org-mark-ring-push) + (let ((m (org-id-find id 'marker)) + cmd) + (unless m + (error "Cannot find entry with ID \"%s\"" id)) + ;; Use a buffer-switching command in analogy to finding files + (setq cmd + (or + (cdr + (assq + (cdr (assq 'file org-link-frame-setup)) + '((find-file . switch-to-buffer) + (find-file-other-window . switch-to-buffer-other-window) + (find-file-other-frame . switch-to-buffer-other-frame)))) + 'switch-to-buffer-other-window)) + (if (not (equal (current-buffer) (marker-buffer m))) + (funcall cmd (marker-buffer m))) + (goto-char m) + (move-marker m nil) + (org-show-context))) + +(org-add-link-type "id" 'org-id-open) + +(provide 'org-id) + +;;; org-id.el ends here + +;; arch-tag: e5abaca4-e16f-4b25-832a-540cfb63a712 + + diff --git a/.emacs.d/org-7.4/lisp/org-id.elc b/.emacs.d/org-7.4/lisp/org-id.elc Binary files differnew file mode 100644 index 0000000..183b8c0 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-id.elc diff --git a/.emacs.d/org-7.4/lisp/org-indent.el b/.emacs.d/org-7.4/lisp/org-indent.el new file mode 100644 index 0000000..a177a6f --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-indent.el @@ -0,0 +1,326 @@ +;;; org-indent.el --- Dynamic indentation for Org-mode +;; Copyright (C) 2009, 2010 Free Software Foundation, Inc. +;; +;; Author: Carsten Dominik <carsten at orgmode dot org> +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; Version: 7.4 +;; +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: + +;; This is an implementation of dynamic virtual indentation. It works +;; by adding text properties to a buffer to make sure lines are +;; indented according to outline structure. + +;;; Code: + +(require 'org-macs) +(require 'org-compat) +(require 'org) + +(eval-when-compile + (require 'cl)) + +(defvar org-inlinetask-min-level) +(declare-function org-inlinetask-get-task-level "org-inlinetask" ()) +(declare-function org-inlinetask-in-task-p "org-inlinetask" ()) + +(defgroup org-indent nil + "Options concerning dynamic virtual outline indentation." + :tag "Org Indent" + :group 'org) + +(defconst org-indent-max 40 + "Maximum indentation in characters.") +(defconst org-indent-max-levels 40 + "Maximum indentation in characters.") + +(defvar org-indent-strings nil + "Vector with all indentation strings. +It will be set in `org-indent-initialize'.") +(defvar org-indent-stars nil + "Vector with all indentation star strings. +It will be set in `org-indent-initialize'.") +(defvar org-hide-leading-stars-before-indent-mode nil + "Used locally.") + +(defcustom org-indent-boundary-char ?\ ; comment to protect space char + "The end of the virtual indentation strings, a single-character string. +The default is just a space, but if you wish, you can use \"|\" or so. +This can be useful on a terminal window - under a windowing system, +it may be prettier to customize the org-indent face." + :group 'org-indent + :set (lambda (var val) + (set var val) + (and org-indent-strings (org-indent-initialize))) + :type 'character) + +(defcustom org-indent-mode-turns-off-org-adapt-indentation t + "Non-nil means setting the variable `org-indent-mode' will \ +turn off indentation adaptation. +For details see the variable `org-adapt-indentation'." + :group 'org-indent + :type 'boolean) + +(defcustom org-indent-mode-turns-on-hiding-stars t + "Non-nil means setting the variable `org-indent-mode' will \ +turn on `org-hide-leading-stars'." + :group 'org-indent + :type 'boolean) + +(defcustom org-indent-indentation-per-level 2 + "Indentation per level in number of characters." + :group 'org-indent + :type 'integer) + +(defcustom org-indent-fix-section-after-idle-time 0.2 + "Seconds of idle time before fixing virtual indentation of section. +The hooking-in of virtual indentation is not yet perfect. Occasionally, +a change does not trigger to proper change of indentation. For this we +have a timer action that fixes indentation in the current section after +a short amount idle time. If we ever get the integration to work perfectly, +this variable can be set to nil to get rid of the timer." + :group 'org-indent + :type '(choice + (const "Do not install idle timer" nil) + (number :tag "Idle time"))) + +(defun org-indent-initialize () + "Initialize the indentation strings and set the idle timer." + ;; We use an idle timer to "repair" the current section, because the + ;; redisplay seems to have some problems. + (unless org-indent-strings + (when org-indent-fix-section-after-idle-time + (run-with-idle-timer + org-indent-fix-section-after-idle-time + t 'org-indent-refresh-section))) + ;; Initialize the indentation and star vectors + (setq org-indent-strings (make-vector (1+ org-indent-max) nil)) + (setq org-indent-stars (make-vector (1+ org-indent-max) nil)) + (aset org-indent-strings 0 nil) + (aset org-indent-stars 0 nil) + (loop for i from 1 to org-indent-max do + (aset org-indent-strings i + (org-add-props + (concat (make-string (1- i) ?\ ) + (char-to-string org-indent-boundary-char)) + nil 'face 'org-indent))) + (loop for i from 1 to org-indent-max-levels do + (aset org-indent-stars i + (org-add-props (make-string i ?*) + nil 'face 'org-hide)))) + +;;;###autoload +(define-minor-mode org-indent-mode + "When active, indent text according to outline structure. + +Internally this works by adding `line-prefix' properties to all non-headlines. +These properties are updated locally in idle time. +FIXME: How to update when broken?" + nil " Ind" nil + (cond + ((org-bound-and-true-p org-inhibit-startup) + (setq org-indent-mode nil)) + ((and org-indent-mode (featurep 'xemacs)) + (message "org-indent-mode does not work in XEmacs - refusing to turn it on") + (setq org-indent-mode nil)) + ((and org-indent-mode + (not (org-version-check "23.1.50" "Org Indent mode" :predicate))) + (message "org-indent-mode can crash Emacs 23.1 - refusing to turn it on!") + (ding) + (sit-for 1) + (setq org-indent-mode nil)) + (org-indent-mode + ;; mode was turned on. + (org-set-local 'indent-tabs-mode nil) + (or org-indent-strings (org-indent-initialize)) + (when org-indent-mode-turns-off-org-adapt-indentation + (org-set-local 'org-adapt-indentation nil)) + (when org-indent-mode-turns-on-hiding-stars + (org-set-local 'org-hide-leading-stars-before-indent-mode + org-hide-leading-stars) + (org-set-local 'org-hide-leading-stars t)) + (make-local-variable 'buffer-substring-filters) + (add-to-list 'buffer-substring-filters + 'org-indent-remove-properties-from-string) + (org-add-hook 'org-after-demote-entry-hook + 'org-indent-refresh-section nil 'local) + (org-add-hook 'org-after-promote-entry-hook + 'org-indent-refresh-section nil 'local) + (org-add-hook 'org-font-lock-hook + 'org-indent-refresh-to nil 'local) + (and font-lock-mode (org-restart-font-lock)) + ) + (t + ;; mode was turned off (or we refused to turn it on) + (save-excursion + (save-restriction + (org-indent-remove-properties (point-min) (point-max)) + (kill-local-variable 'org-adapt-indentation) + (when (boundp 'org-hide-leading-stars-before-indent-mode) + (org-set-local 'org-hide-leading-stars + org-hide-leading-stars-before-indent-mode)) + (setq buffer-substring-filters + (delq 'org-indent-remove-properties-from-string + buffer-substring-filters)) + (remove-hook 'org-after-promote-entry-hook + 'org-indent-refresh-section 'local) + (remove-hook 'org-after-demote-entry-hook + 'org-indent-refresh-section 'local) + (and font-lock-mode (org-restart-font-lock)) + (redraw-display)))))) + + +(defface org-indent + (org-compatible-face nil nil) + "Face for outline indentation. +The default is to make it look like whitespace. But you may find it +useful to make it ever so slightly different." + :group 'org-faces) + +(defun org-indent-indent-buffer () + "Add indentation properties for the whole buffer." + (interactive) + (when org-indent-mode + (save-excursion + (save-restriction + (widen) + (org-indent-remove-properties (point-min) (point-max)) + (org-indent-add-properties (point-min) (point-max)))))) + +(defun org-indent-remove-properties (beg end) + "Remove indentations between BEG and END." + (let ((inhibit-modification-hooks t)) + (with-silent-modifications + (remove-text-properties beg end '(line-prefix nil wrap-prefix nil))))) + +(defun org-indent-remove-properties-from-string (string) + "Remove indentations between BEG and END." + (remove-text-properties 0 (length string) + '(line-prefix nil wrap-prefix nil) string) + string) + +(defvar org-indent-outline-re (concat "^" org-outline-regexp) + "Outline heading regexp.") + +(defun org-indent-add-properties (beg end) + "Add indentation properties between BEG and END. +Assumes that BEG is at the beginning of a line." + (let* ((inhibit-modification-hooks t) + (inlinetaskp (featurep 'org-inlinetask)) + (get-real-level (lambda (pos lvl) + (save-excursion + (goto-char pos) + (if (and inlinetaskp (org-inlinetask-in-task-p)) + (org-inlinetask-get-task-level) + lvl)))) + (b beg) + (e end) + (level 0) + (n 0) + exit nstars) + (with-silent-modifications + (save-excursion + (goto-char beg) + (while (not exit) + (setq e end) + (if (not (re-search-forward org-indent-outline-re nil t)) + (setq e (point-max) exit t) + (setq e (match-beginning 0)) + (if (>= e end) (setq exit t)) + (unless (and inlinetaskp (org-inlinetask-in-task-p)) + (setq level (- (match-end 0) (match-beginning 0) 1))) + (setq nstars (* (1- (funcall get-real-level e level)) + (1- org-indent-indentation-per-level))) + (add-text-properties + (point-at-bol) (point-at-eol) + (list 'line-prefix + (aref org-indent-stars nstars) + 'wrap-prefix + (aref org-indent-strings + (* (funcall get-real-level e level) + org-indent-indentation-per-level))))) + (when (> e b) + (add-text-properties + b e (list 'line-prefix (aref org-indent-strings n) + 'wrap-prefix (aref org-indent-strings n)))) + (setq b (1+ (point-at-eol)) + n (* (funcall get-real-level b level) + org-indent-indentation-per-level))))))) + +(defvar org-inlinetask-min-level) +(defun org-indent-refresh-section () + "Refresh indentation properties in the current outline section. +Point is assumed to be at the beginning of a headline." + (interactive) + (when org-indent-mode + (let (beg end) + (save-excursion + (when (ignore-errors (let ((outline-regexp (format "\\*\\{1,%s\\}[ \t]+" + (if (featurep 'org-inlinetask) + (1- org-inlinetask-min-level) + "")))) + (org-back-to-heading))) + (setq beg (point)) + (setq end (or (save-excursion (or (outline-next-heading) (point))))) + (org-indent-remove-properties beg end) + (org-indent-add-properties beg end)))))) + +(defun org-indent-refresh-to (limit) + "Refresh indentation properties in the current outline section. +Point is assumed to be at the beginning of a headline." + (interactive) + (when org-indent-mode + (let ((beg (point)) (end limit)) + (save-excursion + (and (ignore-errors (let ((outline-regexp (format "\\*\\{1,%s\\}[ \t]+" + (if (featurep 'org-inlinetask) + (1- org-inlinetask-min-level) + "")))) + (org-back-to-heading))) + (setq beg (point)))) + (org-indent-remove-properties beg end) + (org-indent-add-properties beg end))) + (goto-char limit)) + +(defun org-indent-refresh-subtree () + "Refresh indentation properties in the current outline subtree. +Point is assumed to be at the beginning of a headline." + (interactive) + (when org-indent-mode + (save-excursion + (let (beg end) + (setq beg (point)) + (setq end (save-excursion (org-end-of-subtree t t))) + (org-indent-remove-properties beg end) + (org-indent-add-properties beg end))))) + +(defun org-indent-refresh-buffer () + "Refresh indentation properties in the current outline subtree. +Point is assumed to be at the beginning of a headline." + (interactive) + (when org-indent-mode + (org-indent-mode -1) + (org-indent-mode 1))) + +(provide 'org-indent) + +;; arch-tag: b76736bc-9f4a-43cd-977c-ecfd6689846a +;;; org-indent.el ends here diff --git a/.emacs.d/org-7.4/lisp/org-indent.elc b/.emacs.d/org-7.4/lisp/org-indent.elc Binary files differnew file mode 100644 index 0000000..ce71db5 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-indent.elc diff --git a/.emacs.d/org-7.4/lisp/org-info.el b/.emacs.d/org-7.4/lisp/org-info.el new file mode 100644 index 0000000..250f438 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-info.el @@ -0,0 +1,83 @@ +;;; org-info.el --- Support for links to Info nodes from within Org-Mode + +;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010 +;; Free Software Foundation, Inc. + +;; Author: Carsten Dominik <carsten at orgmode dot org> +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; Version: 7.4 +;; +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: + +;; This file implements links to Info nodes from within Org-mode. +;; Org-mode loads this module by default - if this is not what you want, +;; configure the variable `org-modules'. + +;;; Code: + +(require 'org) + +;; Declare external functions and variables + +(declare-function Info-find-node "info" (filename nodename + &optional no-going-back)) +(defvar Info-current-file) +(defvar Info-current-node) + +;; Install the link type +(org-add-link-type "info" 'org-info-open) +(add-hook 'org-store-link-functions 'org-info-store-link) + +;; Implementation +(defun org-info-store-link () + "Store a link to an Info file and node." + (when (eq major-mode 'Info-mode) + (let (link desc) + (setq link (org-make-link "info:" + (file-name-nondirectory Info-current-file) + ":" Info-current-node)) + (setq desc (concat (file-name-nondirectory Info-current-file) + ":" Info-current-node)) + (org-store-link-props :type "info" :file Info-current-file + :node Info-current-node + :link link :desc desc) + link))) + +(defun org-info-open (path) + "Follow an Info file and node link specified by PATH." + (org-info-follow-link path)) + + +(defun org-info-follow-link (name) + "Follow an Info file and node link specified by NAME." + (if (or (string-match "\\(.*\\)::?\\(.*\\)" name) + (string-match "\\(.*\\)" name)) + (progn + (require 'info) + (if (match-string 2 name) ; If there isn't a node, choose "Top" + (Info-find-node (match-string 1 name) (match-string 2 name)) + (Info-find-node (match-string 1 name) "Top"))) + (message "Could not open: %s" name))) + +(provide 'org-info) + +;; arch-tag: 1e289f54-7176-487f-b575-dd4854bab15e + +;;; org-info.el ends here diff --git a/.emacs.d/org-7.4/lisp/org-info.elc b/.emacs.d/org-7.4/lisp/org-info.elc Binary files differnew file mode 100644 index 0000000..1dd0768 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-info.elc diff --git a/.emacs.d/org-7.4/lisp/org-inlinetask.el b/.emacs.d/org-7.4/lisp/org-inlinetask.el new file mode 100644 index 0000000..3f2d6fb --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-inlinetask.el @@ -0,0 +1,338 @@ +;;; org-inlinetask.el --- Tasks independent of outline hierarchy + +;; Copyright (C) 2009, 2010 Free Software Foundation, Inc. +;; +;; Author: Carsten Dominik <carsten at orgmode dot org> +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; Version: 7.4 + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify + +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: +;; +;; This module implements inline tasks in Org-mode. Inline tasks are +;; tasks that have all the properties of normal outline nodes, including +;; the ability to store meta data like scheduling dates, TODO state, tags +;; and properties. However, these nodes are treated specially by the +;; visibility cycling and export commands. +;; +;; Visibility cycling exempts these nodes from cycling. So whenever their +;; parent is opened, so are these tasks. This will only work with +;; `org-cycle', so if you are also using other commands to show/hide +;; entries, you will occasionally find these tasks to behave like +;; all other outline nodes, seemingly splitting the text of the parent +;; into children. +;; +;; Export commands do not treat these nodes as part of the sectioning +;; structure, but as a special inline text that is either removed, or +;; formatted in some special way. +;; +;; Special fontification of inline tasks, so that they can be immediately +;; recognized. From the stars of the headline, only the first and the +;; last two will be visible, the others will be hidden using the +;; `org-hide' face. +;; +;; An inline task is identified solely by a minimum outline level, given +;; by the variable `org-inlinetask-min-level', default 15. +;; +;; Inline tasks are normally assumed to contain at most a time planning +;; line (DEADLINE etc) after it, and then any number of drawers, for +;; example LOGBOOK of PROPERTIES. No empty lines are allowed. +;; If you need to have normal text as part of an inline task, you +;; can do so by adding an "END" headline with the same number of stars, +;; for example +;; +;; **************** TODO some small task +;; DEADLINE: <2009-03-30 Mon> +;; :PROPERTIES: +;; :SOMETHING: or other +;; :END: +;; And here is some extra text +;; **************** END +;; +;; Also, if you want to use refiling and archiving for inline tasks, +;; The END line must be present to make things work properly. +;; +;; This package installs one new command: +;; +;; C-c C-x t Insert a new inline task with END line + +;;; Code: + +(require 'org) + +(defgroup org-inlinetask nil + "Options concerning inline tasks in Org mode." + :tag "Org Inline Tasks" + :group 'org-structure) + +(defcustom org-inlinetask-min-level 15 + "Minimum level a headline must have before it is treated as an inline task. +It is strongly recommended that you set `org-cycle-max-level' not at all, +or to a number smaller than this one. In fact, when `org-cycle-max-level' is +not set, it will be assumed to be one less than the value of smaller than +the value of this variable." + :group 'org-inlinetask + :type '(choice + (const :tag "Off" nil) + (integer))) + +(defcustom org-inlinetask-export t + "Non-nil means export inline tasks. +When nil, they will not be exported." + :group 'org-inlinetask + :type 'boolean) + +(defvar org-inlinetask-export-templates + '((html "<pre class=\"inlinetask\"><b>%s%s</b><br>%s</pre>" + '((unless (eq todo "") + (format "<span class=\"%s %s\">%s%s</span> " + class todo todo priority)) + heading content)) + (latex "\\begin\{description\}\\item[%s%s]%s\\end\{description\}" + '((unless (eq todo "") (format "\\textsc\{%s%s\} " todo priority)) + heading content)) + (ascii " -- %s%s%s" + '((unless (eq todo "") (format "%s%s " todo priority)) + heading + (unless (eq content "") + (format "\n ¦ %s" + (mapconcat 'identity (org-split-string content "\n") + "\n ¦ "))))) + (docbook "<variablelist> +<varlistentry> +<term>%s%s</term> +<listitem><para>%s</para></listitem> +</varlistentry> +</variablelist>" + '((unless (eq todo "") (format "%s%s " todo priority)) + heading content))) + "Templates for inline tasks in various exporters. + +This variable is an alist in the shape of (BACKEND STRING OBJECTS). + +BACKEND is the name of the backend for the template (ascii, html...). + +STRING is a format control string. + +OBJECTS is a list of elements to be substituted into the format +string. They can be of any type, from a string to a form +returning a value (thus allowing conditional insertion). A nil +object will be substituted as the empty string. Obviously, there +must be at least as many objects as %-sequences in the format +string. + +Moreover, the following special keywords are provided: `todo', +`priority', `heading', `content', `tags'. If some of them are not +defined in an inline task, their value is the empty string. + +As an example, valid associations are: + +(html \"<ul><li>%s <p>%s</p></li></ul>\" (heading content)) + +or, with the additional package \"todonotes\" for LaTeX, + +(latex \"\\todo[inline]{\\textbf{\\textsf{%s %s}}\\linebreak{} %s}\" + '((unless (eq todo \"\") + (format \"\\textsc{%s%s}\" todo priority)) + heading content)))") + +(defvar org-odd-levels-only) +(defvar org-keyword-time-regexp) +(defvar org-drawer-regexp) +(defvar org-complex-heading-regexp) +(defvar org-property-end-re) + +(defcustom org-inlinetask-default-state nil + "Non-nil means make inline tasks have a TODO keyword initially. +This should be the state `org-inlinetask-insert-task' should use by +default, or nil of no state should be assigned." + :group 'org-inlinetask + :type '(choice + (const :tag "No state" nil) + (string :tag "Specific state"))) + +(defun org-inlinetask-insert-task (&optional no-state) + "Insert an inline task. +If prefix arg NO-STATE is set, ignore `org-inlinetask-default-state'." + (interactive "P") + (or (bolp) (newline)) + (let ((indent org-inlinetask-min-level)) + (if org-odd-levels-only + (setq indent (- (* 2 indent) 1))) + (insert (make-string indent ?*) + (if (or no-state (not org-inlinetask-default-state)) + " \n" + (concat " " org-inlinetask-default-state " \n")) + (make-string indent ?*) " END\n")) + (end-of-line -1)) +(define-key org-mode-map "\C-c\C-xt" 'org-inlinetask-insert-task) + +(defun org-inlinetask-outline-regexp () + "Return string matching an inline task heading. +The number of levels is controlled by `org-inlinetask-min-level'." + (let ((nstars (if org-odd-levels-only + (1- (* org-inlinetask-min-level 2)) + org-inlinetask-min-level))) + (format "^\\(\\*\\{%d,\\}\\)[ \t]+" nstars))) + +(defun org-inlinetask-in-task-p () + "Return true if point is inside an inline task." + (save-excursion + (let* ((stars-re (org-inlinetask-outline-regexp)) + (task-beg-re (concat stars-re "\\(?:.*\\)")) + (task-end-re (concat stars-re "\\(?:END\\|end\\)[ \t]*$"))) + (beginning-of-line) + (or (looking-at task-beg-re) + (and (re-search-forward "^\\*+[ \t]+" nil t) + (progn (beginning-of-line) (looking-at task-end-re))))))) + +(defun org-inlinetask-goto-beginning () + "Go to the beginning of the inline task at point." + (end-of-line) + (re-search-backward (org-inlinetask-outline-regexp) nil t) + (when (org-looking-at-p (concat (org-inlinetask-outline-regexp) "END[ \t]*$")) + (re-search-backward (org-inlinetask-outline-regexp) nil t))) + +(defun org-inlinetask-goto-end () + "Go to the end of the inline task at point." + (beginning-of-line) + (cond + ((org-looking-at-p (concat (org-inlinetask-outline-regexp) "END[ \t]*$")) + (forward-line 1)) + ((org-looking-at-p (org-inlinetask-outline-regexp)) + (forward-line 1) + (when (org-inlinetask-in-task-p) + (re-search-forward (org-inlinetask-outline-regexp) nil t) + (forward-line 1))) + (t + (re-search-forward (org-inlinetask-outline-regexp) nil t) + (forward-line 1)))) + +(defun org-inlinetask-get-task-level () + "Get the level of the inline task around. +This assumes the point is inside an inline task." + (save-excursion + (end-of-line) + (re-search-backward (org-inlinetask-outline-regexp) nil t) + (- (match-end 1) (match-beginning 1)))) + +(defvar backend) ; dynamically scoped into the next function +(defun org-inlinetask-export-handler () + "Handle headlines with level larger or equal to `org-inlinetask-min-level'. +Either remove headline and meta data, or do special formatting." + (goto-char (point-min)) + (let* ((nstars (if org-odd-levels-only + (1- (* 2 (or org-inlinetask-min-level 200))) + (or org-inlinetask-min-level 200))) + (re1 (format "^\\(\\*\\{%d,\\}\\) .*\n" nstars)) + (re2 (concat "^[ \t]*" org-keyword-time-regexp)) + headline beg end stars content) + (while (re-search-forward re1 nil t) + (setq headline (match-string 0) + stars (match-string 1) + content nil) + (replace-match "") + (while (looking-at re2) + (delete-region (point) (1+ (point-at-eol)))) + (while (looking-at org-drawer-regexp) + (setq beg (point)) + (if (re-search-forward org-property-end-re nil t) + (delete-region beg (1+ (match-end 0))))) + (setq beg (point)) + (when (and (re-search-forward "^\\(\\*+\\) " nil t) + (= (length (match-string 1)) (length stars)) + (progn (goto-char (match-end 0)) + (looking-at "END[ \t]*$"))) + (setq content (buffer-substring beg (1- (point-at-bol)))) + (delete-region beg (1+ (match-end 0)))) + (goto-char beg) + (when org-inlinetask-export + ;; content formatting + (when content + (if (not (string-match "\\S-" content)) + (setq content nil) + (if (string-match "[ \t\n]+\\'" content) + (setq content (substring content 0 (match-beginning 0)))) + (setq content (org-remove-indentation content)))) + (setq content (or content "")) + ;; grab elements to export + (when (string-match org-complex-heading-regexp headline) + (let* ((todo (or (match-string 2 headline) "")) + (class (or (and (eq "" todo) "") + (if (member todo org-done-keywords) "done" "todo"))) + (priority (or (match-string 3 headline) "")) + (heading (or (match-string 4 headline) "")) + (tags (or (match-string 5 headline) "")) + (backend-spec (assq backend org-inlinetask-export-templates)) + (format-str (nth 1 backend-spec)) + (tokens (cadr (nth 2 backend-spec))) + ;; change nil arguments into empty strings + (nil-to-str (lambda (el) (or (eval el) ""))) + ;; build and protect export string + (export-str (org-add-props + (eval (append '(format format-str) + (mapcar nil-to-str tokens))) + nil 'org-protected t))) + ;; eventually insert it + (insert export-str "\n"))))))) + +(defun org-inlinetask-get-current-indentation () + "Get the indentation of the last non-while line above this one." + (save-excursion + (beginning-of-line 1) + (skip-chars-backward " \t\n") + (beginning-of-line 1) + (or (org-at-item-p) + (looking-at "[ \t]*")) + (goto-char (match-end 0)) + (current-column))) + +(defun org-inlinetask-fontify (limit) + "Fontify the inline tasks." + (let* ((nstars (if org-odd-levels-only + (1- (* 2 (or org-inlinetask-min-level 200))) + (or org-inlinetask-min-level 200))) + (re (concat "^\\(\\*\\)\\(\\*\\{" + (format "%d" (- nstars 3)) + ",\\}\\)\\(\\*\\* .*\\)"))) + (while (re-search-forward re limit t) + (add-text-properties (match-beginning 1) (match-end 1) + '(face org-warning font-lock-fontified t)) + (add-text-properties (match-beginning 2) (match-end 2) + '(face org-hide font-lock-fontified t)) + (add-text-properties (match-beginning 3) (match-end 3) + '(face shadow font-lock-fontified t))))) + +(defun org-inlinetask-remove-END-maybe () + "Remove an END line when present." + (when (looking-at (format "\\([ \t]*\n\\)*\\*\\{%d,\\}[ \t]+END[ \t]*$" + org-inlinetask-min-level)) + (replace-match ""))) + +(eval-after-load "org-exp" + '(add-hook 'org-export-preprocess-after-tree-selection-hook + 'org-inlinetask-export-handler)) +(eval-after-load "org" + '(add-hook 'org-font-lock-hook 'org-inlinetask-fontify)) + +(provide 'org-inlinetask) + +;;; org-inlinetask.el ends here diff --git a/.emacs.d/org-7.4/lisp/org-inlinetask.elc b/.emacs.d/org-7.4/lisp/org-inlinetask.elc Binary files differnew file mode 100644 index 0000000..2881120 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-inlinetask.elc diff --git a/.emacs.d/org-7.4/lisp/org-install.el b/.emacs.d/org-7.4/lisp/org-install.el new file mode 100644 index 0000000..e82a017 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-install.el @@ -0,0 +1,1762 @@ + +;;;### (autoloads (org-customize org-reload org-require-autoloaded-modules +;;;;;; org-submit-bug-report org-cycle-agenda-files org-switchb +;;;;;; org-map-entries org-open-link-from-string org-open-at-point-global +;;;;;; org-insert-link-global org-store-link org-run-like-in-org-mode +;;;;;; turn-on-orgstruct++ turn-on-orgstruct orgstruct-mode org-global-cycle +;;;;;; org-mode org-babel-do-load-languages) "org" "lisp/org.el" +;;;;;; (19714 9811)) +;;; Generated autoloads from lisp/org.el + +(autoload 'org-babel-do-load-languages "org" "\ +Load the languages defined in `org-babel-load-languages'. + +\(fn SYM VALUE)" nil nil) + +(autoload 'org-mode "org" "\ +Outline-based notes management and organizer, alias +\"Carsten's outline-mode for keeping track of everything.\" + +Org-mode develops organizational tasks around a NOTES file which +contains information about projects as plain text. Org-mode is +implemented on top of outline-mode, which is ideal to keep the content +of large files well structured. It supports ToDo items, deadlines and +time stamps, which magically appear in the diary listing of the Emacs +calendar. Tables are easily created with a built-in table editor. +Plain text URL-like links connect to websites, emails (VM), Usenet +messages (Gnus), BBDB entries, and any files related to the project. +For printing and sharing of notes, an Org-mode file (or a part of it) +can be exported as a structured ASCII or HTML file. + +The following commands are available: + +\\{org-mode-map} + +\(fn)" t nil) + +(defvar org-inlinetask-min-level) + +(autoload 'org-global-cycle "org" "\ +Cycle the global visibility. For details see `org-cycle'. +With \\[universal-argument] prefix arg, switch to startup visibility. +With a numeric prefix, show all headlines up to that level. + +\(fn &optional ARG)" t nil) + +(autoload 'orgstruct-mode "org" "\ +Toggle the minor mode `orgstruct-mode'. +This mode is for using Org-mode structure commands in other +modes. The following keys behave as if Org-mode were active, if +the cursor is on a headline, or on a plain list item (both as +defined by Org-mode). + +M-up Move entry/item up +M-down Move entry/item down +M-left Promote +M-right Demote +M-S-up Move entry/item up +M-S-down Move entry/item down +M-S-left Promote subtree +M-S-right Demote subtree +M-q Fill paragraph and items like in Org-mode +C-c ^ Sort entries +C-c - Cycle list bullet +TAB Cycle item visibility +M-RET Insert new heading/item +S-M-RET Insert new TODO heading / Checkbox item +C-c C-c Set tags / toggle checkbox + +\(fn &optional ARG)" t nil) + +(autoload 'turn-on-orgstruct "org" "\ +Unconditionally turn on `orgstruct-mode'. + +\(fn)" nil nil) + +(autoload 'turn-on-orgstruct++ "org" "\ +Unconditionally turn on `orgstruct++-mode'. + +\(fn)" nil nil) + +(autoload 'org-run-like-in-org-mode "org" "\ +Run a command, pretending that the current buffer is in Org-mode. +This will temporarily bind local variables that are typically bound in +Org-mode to the values they have in Org-mode, and then interactively +call CMD. + +\(fn CMD)" nil nil) + +(autoload 'org-store-link "org" "\ +\\<org-mode-map>Store an org-link to the current location. +This link is added to `org-stored-links' and can later be inserted +into an org-buffer with \\[org-insert-link]. + +For some link types, a prefix arg is interpreted: +For links to usenet articles, arg negates `org-gnus-prefer-web-links'. +For file links, arg negates `org-context-in-file-links'. + +\(fn ARG)" t nil) + +(autoload 'org-insert-link-global "org" "\ +Insert a link like Org-mode does. +This command can be called in any mode to insert a link in Org-mode syntax. + +\(fn)" t nil) + +(autoload 'org-open-at-point-global "org" "\ +Follow a link like Org-mode does. +This command can be called in any mode to follow a link that has +Org-mode syntax. + +\(fn)" t nil) + +(autoload 'org-open-link-from-string "org" "\ +Open a link in the string S, as if it was in Org-mode. + +\(fn S &optional ARG REFERENCE-BUFFER)" t nil) + +(autoload 'org-map-entries "org" "\ +Call FUNC at each headline selected by MATCH in SCOPE. + +FUNC is a function or a lisp form. The function will be called without +arguments, with the cursor positioned at the beginning of the headline. +The return values of all calls to the function will be collected and +returned as a list. + +The call to FUNC will be wrapped into a save-excursion form, so FUNC +does not need to preserve point. After evaluation, the cursor will be +moved to the end of the line (presumably of the headline of the +processed entry) and search continues from there. Under some +circumstances, this may not produce the wanted results. For example, +if you have removed (e.g. archived) the current (sub)tree it could +mean that the next entry will be skipped entirely. In such cases, you +can specify the position from where search should continue by making +FUNC set the variable `org-map-continue-from' to the desired buffer +position. + +MATCH is a tags/property/todo match as it is used in the agenda tags view. +Only headlines that are matched by this query will be considered during +the iteration. When MATCH is nil or t, all headlines will be +visited by the iteration. + +SCOPE determines the scope of this command. It can be any of: + +nil The current buffer, respecting the restriction if any +tree The subtree started with the entry at point +file The current buffer, without restriction +file-with-archives + The current buffer, and any archives associated with it +agenda All agenda files +agenda-with-archives + All agenda files with any archive files associated with them +\(file1 file2 ...) + If this is a list, all files in the list will be scanned + +The remaining args are treated as settings for the skipping facilities of +the scanner. The following items can be given here: + + archive skip trees with the archive tag. + comment skip trees with the COMMENT keyword + function or Emacs Lisp form: + will be used as value for `org-agenda-skip-function', so whenever + the function returns t, FUNC will not be called for that + entry and search will continue from the point where the + function leaves it. + +If your function needs to retrieve the tags including inherited tags +at the *current* entry, you can use the value of the variable +`org-scanner-tags' which will be much faster than getting the value +with `org-get-tags-at'. If your function gets properties with +`org-entry-properties' at the *current* entry, bind `org-trust-scanner-tags' +to t around the call to `org-entry-properties' to get the same speedup. +Note that if your function moves around to retrieve tags and properties at +a *different* entry, you cannot use these techniques. + +\(fn FUNC &optional MATCH SCOPE &rest SKIP)" nil nil) + +(autoload 'org-switchb "org" "\ +Switch between Org buffers. +With a prefix argument, restrict available to files. +With two prefix arguments, restrict available buffers to agenda files. + +Defaults to `iswitchb' for buffer name completion. +Set `org-completion-use-ido' to make it use ido instead. + +\(fn &optional ARG)" t nil) + +(defalias 'org-ido-switchb 'org-switchb) + +(defalias 'org-iswitchb 'org-switchb) + +(autoload 'org-cycle-agenda-files "org" "\ +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. + +\(fn)" t nil) + +(autoload 'org-submit-bug-report "org" "\ +Submit a bug report on Org-mode via mail. + +Don't hesitate to report any problems or inaccurate documentation. + +If you don't have setup sending mail from (X)Emacs, please copy the +output buffer into your mail program, as it gives us important +information about your Org-mode version and configuration. + +\(fn)" t nil) + +(autoload 'org-require-autoloaded-modules "org" "\ +Not documented + +\(fn)" t nil) + +(autoload 'org-reload "org" "\ +Reload all org lisp files. +With prefix arg UNCOMPILED, load the uncompiled versions. + +\(fn &optional UNCOMPILED)" t nil) + +(autoload 'org-customize "org" "\ +Call the customize function with org as argument. + +\(fn)" t nil) + +;;;*** + +;;;### (autoloads (org-agenda-to-appt org-calendar-goto-agenda org-agenda-check-for-timestamp-as-reason-to-ignore-todo-item +;;;;;; org-diary org-agenda-list-stuck-projects org-tags-view org-todo-list +;;;;;; org-search-view org-agenda-list org-batch-store-agenda-views +;;;;;; org-store-agenda-views org-batch-agenda-csv org-batch-agenda +;;;;;; org-agenda) "org-agenda" "lisp/org-agenda.el" (19708 61313)) +;;; Generated autoloads from lisp/org-agenda.el + +(autoload 'org-agenda "org-agenda" "\ +Dispatch agenda commands to collect entries to the agenda buffer. +Prompts for a command to execute. Any prefix arg will be passed +on to the selected command. The default selections are: + +a Call `org-agenda-list' to display the agenda for current day or week. +t Call `org-todo-list' to display the global todo list. +T Call `org-todo-list' to display the global todo list, select only + entries with a specific TODO keyword (the user gets a prompt). +m Call `org-tags-view' to display headlines with tags matching + a condition (the user is prompted for the condition). +M Like `m', but select only TODO entries, no ordinary headlines. +L Create a timeline for the current buffer. +e Export views to associated files. +s Search entries for keywords. +/ Multi occur across all agenda files and also files listed + in `org-agenda-text-search-extra-files'. +< Restrict agenda commands to buffer, subtree, or region. + Press several times to get the desired effect. +> Remove a previous restriction. +# List \"stuck\" projects. +! Configure what \"stuck\" means. +C Configure custom agenda commands. + +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 `<' once to indicate that the agenda should be temporarily +\(until the next use of \\[org-agenda]) restricted to the current file. +Pressing `<' twice means to restrict to the current subtree or region +\(if active). + +\(fn &optional ARG KEYS RESTRICTION)" t nil) + +(autoload 'org-batch-agenda "org-agenda" "\ +Run an agenda command in batch mode and send the result to STDOUT. +If CMD-KEY is a string of length 1, it is used as a key in +`org-agenda-custom-commands' and triggers this command. If it is a +longer string it is used as a tags/todo match string. +Parameters are alternating variable names and values that will be bound +before running the agenda command. + +\(fn CMD-KEY &rest PARAMETERS)" nil (quote macro)) + +(autoload 'org-batch-agenda-csv "org-agenda" "\ +Run an agenda command in batch mode and send the result to STDOUT. +If CMD-KEY is a string of length 1, it is used as a key in +`org-agenda-custom-commands' and triggers this command. If it is a +longer string it is used as a tags/todo match string. +Parameters are alternating variable names and values that will be bound +before running the agenda command. + +The output gives a line for each selected agenda item. Each +item is a list of comma-separated values, like this: + +category,head,type,todo,tags,date,time,extra,priority-l,priority-n + +category The category of the item +head The headline, without TODO kwd, TAGS and PRIORITY +type The type of the agenda entry, can be + todo selected in TODO match + tagsmatch selected in tags match + diary imported from diary + deadline a deadline on given date + scheduled scheduled on given date + timestamp entry has timestamp on given date + closed entry was closed on given date + upcoming-deadline warning about deadline + past-scheduled forwarded scheduled item + block entry has date block including g. date +todo The todo keyword, if any +tags All tags including inherited ones, separated by colons +date The relevant date, like 2007-2-14 +time The time, like 15:00-16:50 +extra Sting with extra planning info +priority-l The priority letter if any was given +priority-n The computed numerical priority +agenda-day The day in the agenda where this is listed + +\(fn CMD-KEY &rest PARAMETERS)" nil (quote macro)) + +(autoload 'org-store-agenda-views "org-agenda" "\ +Not documented + +\(fn &rest PARAMETERS)" t nil) + +(autoload 'org-batch-store-agenda-views "org-agenda" "\ +Run all custom agenda commands that have a file argument. + +\(fn &rest PARAMETERS)" nil (quote macro)) + +(autoload 'org-agenda-list "org-agenda" "\ +Produce a daily/weekly view from all files in variable `org-agenda-files'. +The view will be for the current day or week, but from the overview buffer +you will be able to go to other days/weeks. + +With one \\[universal-argument] prefix argument INCLUDE-ALL, +all unfinished TODO items will also be shown, before the agenda. +This feature is considered obsolete, please use the TODO list or a block +agenda instead. + +With a numeric prefix argument in an interactive call, the agenda will +span INCLUDE-ALL days. Lisp programs should instead specify SPAN to change +the number of days. SPAN defaults to `org-agenda-span'. + +START-DAY defaults to TODAY, or to the most recent match for the weekday +given in `org-agenda-start-on-weekday'. + +\(fn &optional INCLUDE-ALL START-DAY SPAN)" t nil) + +(autoload 'org-search-view "org-agenda" "\ +Show all entries that contain a phrase or words or regular expressions. + +With optional prefix argument TODO-ONLY, only consider entries that are +TODO entries. The argument STRING can be used to pass a default search +string into this function. If EDIT-AT is non-nil, it means that the +user should get a chance to edit this string, with cursor at position +EDIT-AT. + +The search string can be viewed either as a phrase that should be found as +is, or it can be broken into a number of snippets, each of which must match +in a Boolean way to select an entry. The default depends on the variable +`org-agenda-search-view-always-boolean'. +Even if this is turned off (the default) you can always switch to +Boolean search dynamically by preceding the first word with \"+\" or \"-\". + +The default is a direct search of the whole phrase, where each space in +the search string can expand to an arbitrary amount of whitespace, +including newlines. + +If using a Boolean search, the search string is split on whitespace and +each snippet is searched separately, with logical AND to select an entry. +Words prefixed with a minus must *not* occur in the entry. Words without +a prefix or prefixed with a plus must occur in the entry. Matching is +case-insensitive. Words are enclosed by word delimiters (i.e. they must +match whole words, not parts of a word) if +`org-agenda-search-view-force-full-words' is set (default is nil). + +Boolean search snippets enclosed by curly braces are interpreted as +regular expressions that must or (when preceded with \"-\") must not +match in the entry. Snippets enclosed into double quotes will be taken +as a whole, to include whitespace. + +- If the search string starts with an asterisk, search only in headlines. +- If (possibly after the leading star) the search string starts with an + exclamation mark, this also means to look at TODO entries only, an effect + that can also be achieved with a prefix argument. +- If (possibly after star and exclamation mark) the search string starts + with a colon, this will mean that the (non-regexp) snippets of the + Boolean search must match as full words. + +This command searches the agenda files, and in addition the files listed +in `org-agenda-text-search-extra-files'. + +\(fn &optional TODO-ONLY STRING EDIT-AT)" t nil) + +(autoload 'org-todo-list "org-agenda" "\ +Show all (not done) 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-1'. + +\(fn ARG)" t nil) + +(autoload 'org-tags-view "org-agenda" "\ +Show all headlines for all `org-agenda-files' matching a TAGS criterion. +The prefix arg TODO-ONLY limits the search to TODO entries. + +\(fn &optional TODO-ONLY MATCH)" t nil) + +(autoload 'org-agenda-list-stuck-projects "org-agenda" "\ +Create agenda view for projects that are stuck. +Stuck projects are project that have no next actions. For the definitions +of what a project is and how to check if it stuck, customize the variable +`org-stuck-projects'. + +\(fn &rest IGNORE)" t nil) + +(autoload 'org-diary "org-agenda" "\ +Return diary information from org-files. +This function can be used in a \"sexp\" diary entry in the Emacs calendar. +It accesses org files and extracts information from those files to be +listed in the diary. The function accepts arguments specifying what +items should be listed. For a list of arguments allowed here, see the +variable `org-agenda-entry-types'. + +The call in the diary file should look like this: + + &%%(org-diary) ~/path/to/some/orgfile.org + +Use a separate line for each org file to check. Or, if you omit the file name, +all files listed in `org-agenda-files' will be checked automatically: + + &%%(org-diary) + +If you don't give any arguments (as in the example above), the default +arguments (:deadline :scheduled :timestamp :sexp) are used. +So the example above may also be written as + + &%%(org-diary :deadline :timestamp :sexp :scheduled) + +The function expects the lisp variables `entry' and `date' to be provided +by the caller, because this is how the calendar works. Don't use this +function from a program - use `org-agenda-get-day-entries' instead. + +\(fn &rest ARGS)" nil nil) + +(autoload 'org-agenda-check-for-timestamp-as-reason-to-ignore-todo-item "org-agenda" "\ +Do we have a reason to ignore this TODO entry because it has a time stamp? + +\(fn &optional END)" nil nil) + +(autoload 'org-calendar-goto-agenda "org-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'. + +\(fn)" t nil) + +(autoload 'org-agenda-to-appt "org-agenda" "\ +Activate appointments found in `org-agenda-files'. +With a \\[universal-argument] prefix, refresh the list of +appointments. + +If FILTER is t, interactively prompt the user for a regular +expression, and filter out entries that don't match it. + +If FILTER is a string, use this string as a regular expression +for filtering entries out. + +FILTER can also be an alist with the car of each cell being +either 'headline or 'category. For example: + + '((headline \"IMPORTANT\") + (category \"Work\")) + +will only add headlines containing IMPORTANT or headlines +belonging to the \"Work\" category. + +\(fn &optional REFRESH FILTER)" t nil) + +;;;*** + +;;;### (autoloads (org-export-as-ascii org-export-region-as-ascii +;;;;;; org-replace-region-by-ascii org-export-as-ascii-to-buffer +;;;;;; org-export-as-utf8-to-buffer org-export-as-utf8 org-export-as-latin1-to-buffer +;;;;;; org-export-as-latin1) "org-ascii" "lisp/org-ascii.el" (19683 +;;;;;; 36308)) +;;; Generated autoloads from lisp/org-ascii.el + +(autoload 'org-export-as-latin1 "org-ascii" "\ +Like `org-export-as-ascii', use latin1 encoding for special symbols. + +\(fn &rest ARGS)" t nil) + +(autoload 'org-export-as-latin1-to-buffer "org-ascii" "\ +Like `org-export-as-ascii-to-buffer', use latin1 encoding for symbols. + +\(fn &rest ARGS)" t nil) + +(autoload 'org-export-as-utf8 "org-ascii" "\ +Like `org-export-as-ascii', use use encoding for special symbols. + +\(fn &rest ARGS)" t nil) + +(autoload 'org-export-as-utf8-to-buffer "org-ascii" "\ +Like `org-export-as-ascii-to-buffer', use utf8 encoding for symbols. + +\(fn &rest ARGS)" t nil) + +(autoload 'org-export-as-ascii-to-buffer "org-ascii" "\ +Call `org-export-as-ascii` with output to a temporary buffer. +No file is created. The prefix ARG is passed through to `org-export-as-ascii'. + +\(fn ARG)" t nil) + +(autoload 'org-replace-region-by-ascii "org-ascii" "\ +Assume the current region has org-mode syntax, and convert it to plain ASCII. +This can be used in any buffer. For example, you could write an +itemized list in org-mode syntax in a Mail buffer and then use this +command to convert it. + +\(fn BEG END)" t nil) + +(autoload 'org-export-region-as-ascii "org-ascii" "\ +Convert region from BEG to END in org-mode buffer to plain ASCII. +If prefix arg BODY-ONLY is set, omit file header, footer, and table of +contents, and only produce the region of converted text, useful for +cut-and-paste operations. +If BUFFER is a buffer or a string, use/create that buffer as a target +of the converted ASCII. If BUFFER is the symbol `string', return the +produced ASCII as a string and leave not buffer behind. For example, +a Lisp program could call this function in the following way: + + (setq ascii (org-export-region-as-ascii beg end t 'string)) + +When called interactively, the output buffer is selected, and shown +in a window. A non-interactive call will only return the buffer. + +\(fn BEG END &optional BODY-ONLY BUFFER)" t nil) + +(autoload 'org-export-as-ascii "org-ascii" "\ +Export the outline as a pretty ASCII file. +If there is an active region, export only the region. +The prefix ARG specifies how many levels of the outline should become +underlined headlines, default is 3. Lower levels will become bulleted +lists. When HIDDEN is non-nil, don't display the ASCII buffer. +EXT-PLIST is a property list with external parameters overriding +org-mode's default settings, but still inferior to file-local +settings. When TO-BUFFER is non-nil, create a buffer with that +name and export to that buffer. If TO-BUFFER is the symbol +`string', don't leave any buffer behind but just return the +resulting ASCII as a string. When BODY-ONLY is set, don't produce +the file header and footer. When PUB-DIR is set, use this as the +publishing directory. + +\(fn ARG &optional HIDDEN EXT-PLIST TO-BUFFER BODY-ONLY PUB-DIR)" t nil) + +;;;*** + +;;;### (autoloads (org-attach) "org-attach" "lisp/org-attach.el" +;;;;;; (19683 36308)) +;;; Generated autoloads from lisp/org-attach.el + +(autoload 'org-attach "org-attach" "\ +The dispatcher for attachment commands. +Shows a list of commands and prompts for another key to execute a command. + +\(fn)" t nil) + +;;;*** + +;;;### (autoloads (org-archive-subtree-default-with-confirmation +;;;;;; org-archive-subtree-default) "org-archive" "lisp/org-archive.el" +;;;;;; (19683 36308)) +;;; Generated autoloads from lisp/org-archive.el + +(autoload 'org-archive-subtree-default "org-archive" "\ +Archive the current subtree with the default command. +This command is set with the variable `org-archive-default-command'. + +\(fn)" t nil) + +(autoload 'org-archive-subtree-default-with-confirmation "org-archive" "\ +Archive the current subtree with the default command. +This command is set with the variable `org-archive-default-command'. + +\(fn)" t nil) + +;;;*** + +;;;### (autoloads (org-bbdb-anniversaries) "org-bbdb" "lisp/org-bbdb.el" +;;;;;; (19683 36308)) +;;; Generated autoloads from lisp/org-bbdb.el + +(autoload 'org-bbdb-anniversaries "org-bbdb" "\ +Extract anniversaries from BBDB for display in the agenda. + +\(fn)" nil nil) + +;;;*** + +;;;### (autoloads (org-capture-import-remember-templates org-capture-insert-template-here +;;;;;; org-capture) "org-capture" "lisp/org-capture.el" (19708 43444)) +;;; Generated autoloads from lisp/org-capture.el + +(autoload 'org-capture "org-capture" "\ +Capture something. +\\<org-capture-mode-map> +This will let you select a template from `org-capture-templates', and then +file the newly captured information. The text is immediately inserted +at the target location, and an indirect buffer is shown where you can +edit it. Pressing \\[org-capture-finalize] brings you back to the previous state +of Emacs, so that you can continue your work. + +When called interactively with a \\[universal-argument] prefix argument GOTO, don't capture +anything, just go to the file/headline where the selected template +stores its notes. With a double prefix argument \\[universal-argument] \\[universal-argument], go to the last note +stored. + +When called with a `C-0' (zero) prefix, insert a template at point. + +Lisp programs can set KEYS to a string associated with a template in +`org-capture-templates'. In this case, interactive selection will be +bypassed. + +\(fn &optional GOTO KEYS)" t nil) + +(autoload 'org-capture-insert-template-here "org-capture" "\ +Not documented + +\(fn)" nil nil) + +(autoload 'org-capture-import-remember-templates "org-capture" "\ +Set org-capture-templates to be similar to `org-remember-templates'. + +\(fn)" t nil) + +;;;*** + +;;;### (autoloads (org-clock-persistence-insinuate org-get-clocktable) +;;;;;; "org-clock" "lisp/org-clock.el" (19708 43444)) +;;; Generated autoloads from lisp/org-clock.el + +(autoload 'org-get-clocktable "org-clock" "\ +Get a formatted clocktable with parameters according to PROPS. +The table is created in a temporary buffer, fully formatted and +fontified, and then returned. + +\(fn &rest PROPS)" nil nil) + +(autoload 'org-clock-persistence-insinuate "org-clock" "\ +Set up hooks for clock persistence. + +\(fn)" nil nil) + +;;;*** + +;;;### (autoloads (org-datetree-find-date-create) "org-datetree" +;;;;;; "lisp/org-datetree.el" (19683 36308)) +;;; Generated autoloads from lisp/org-datetree.el + +(autoload 'org-datetree-find-date-create "org-datetree" "\ +Find or create an entry for DATE. +If KEEP-RESTRICTION is non-nil, do not widen the buffer. +When it is nil, the buffer will be widened to make sure an existing date +tree can be found. + +\(fn DATE &optional KEEP-RESTRICTION)" nil nil) + +;;;*** + +;;;### (autoloads (org-insert-export-options-template org-export-as-org +;;;;;; org-export-visible org-export) "org-exp" "lisp/org-exp.el" +;;;;;; (19714 9624)) +;;; Generated autoloads from lisp/org-exp.el + +(autoload 'org-export "org-exp" "\ +Export dispatcher for Org-mode. +When `org-export-run-in-background' is non-nil, try to run the command +in the background. This will be done only for commands that write +to a file. For details see the docstring of `org-export-run-in-background'. + +The prefix argument ARG will be passed to the exporter. However, if +ARG is a double universal prefix \\[universal-argument] \\[universal-argument], that means to inverse the +value of `org-export-run-in-background'. + +\(fn &optional ARG)" t nil) + +(autoload 'org-export-visible "org-exp" "\ +Create a copy of the visible part of the current buffer, and export it. +The copy is created in a temporary buffer and removed after use. +TYPE is the final key (as a string) that also selects the export command in +the \\<org-mode-map>\\[org-export] export dispatcher. +As a special case, if the you type SPC at the prompt, the temporary +org-mode file will not be removed but presented to you so that you can +continue to use it. The prefix arg ARG is passed through to the exporting +command. + +\(fn TYPE ARG)" t nil) + +(autoload 'org-export-as-org "org-exp" "\ +Make a copy with not-exporting stuff removed. +The purpose of this function is to provide a way to export the source +Org file of a webpage in Org format, but with sensitive and/or irrelevant +stuff removed. This command will remove the following: + +- archived trees (if the variable `org-export-with-archived-trees' is nil) +- comment blocks and trees starting with the COMMENT keyword +- only trees that are consistent with `org-export-select-tags' + and `org-export-exclude-tags'. + +The only arguments that will be used are EXT-PLIST and PUB-DIR, +all the others will be ignored (but are present so that the general +mechanism to call publishing functions will work). + +EXT-PLIST is a property list with external parameters overriding +org-mode's default settings, but still inferior to file-local +settings. When PUB-DIR is set, use this as the publishing +directory. + +\(fn ARG &optional HIDDEN EXT-PLIST TO-BUFFER BODY-ONLY PUB-DIR)" t nil) + +(autoload 'org-insert-export-options-template "org-exp" "\ +Insert into the buffer a template with information for exporting. + +\(fn)" t nil) + +;;;*** + +;;;### (autoloads (org-export-as-docbook org-export-as-docbook-pdf-and-open +;;;;;; org-export-as-docbook-pdf org-export-region-as-docbook org-replace-region-by-docbook +;;;;;; org-export-as-docbook-to-buffer org-export-as-docbook-batch) +;;;;;; "org-docbook" "lisp/org-docbook.el" (19683 36308)) +;;; Generated autoloads from lisp/org-docbook.el + +(autoload 'org-export-as-docbook-batch "org-docbook" "\ +Call `org-export-as-docbook' in batch style. +This function can be used in batch processing. + +For example: + +$ emacs --batch + --load=$HOME/lib/emacs/org.el + --visit=MyOrgFile.org --funcall org-export-as-docbook-batch + +\(fn)" nil nil) + +(autoload 'org-export-as-docbook-to-buffer "org-docbook" "\ +Call `org-export-as-docbook' with output to a temporary buffer. +No file is created. + +\(fn)" t nil) + +(autoload 'org-replace-region-by-docbook "org-docbook" "\ +Replace the region from BEG to END with its DocBook export. +It assumes the region has `org-mode' syntax, and then convert it to +DocBook. This can be used in any buffer. For example, you could +write an itemized list in `org-mode' syntax in an DocBook buffer and +then use this command to convert it. + +\(fn BEG END)" t nil) + +(autoload 'org-export-region-as-docbook "org-docbook" "\ +Convert region from BEG to END in `org-mode' buffer to DocBook. +If prefix arg BODY-ONLY is set, omit file header and footer and +only produce the region of converted text, useful for +cut-and-paste operations. If BUFFER is a buffer or a string, +use/create that buffer as a target of the converted DocBook. If +BUFFER is the symbol `string', return the produced DocBook as a +string and leave not buffer behind. For example, a Lisp program +could call this function in the following way: + + (setq docbook (org-export-region-as-docbook beg end t 'string)) + +When called interactively, the output buffer is selected, and shown +in a window. A non-interactive call will only return the buffer. + +\(fn BEG END &optional BODY-ONLY BUFFER)" t nil) + +(autoload 'org-export-as-docbook-pdf "org-docbook" "\ +Export as DocBook XML file, and generate PDF file. + +\(fn &optional HIDDEN EXT-PLIST TO-BUFFER BODY-ONLY PUB-DIR)" t nil) + +(autoload 'org-export-as-docbook-pdf-and-open "org-docbook" "\ +Export as DocBook XML file, generate PDF file, and open it. + +\(fn)" t nil) + +(autoload 'org-export-as-docbook "org-docbook" "\ +Export the current buffer as a DocBook file. +If there is an active region, export only the region. When +HIDDEN is obsolete and does nothing. EXT-PLIST is a +property list with external parameters overriding org-mode's +default settings, but still inferior to file-local settings. +When TO-BUFFER is non-nil, create a buffer with that name and +export to that buffer. If TO-BUFFER is the symbol `string', +don't leave any buffer behind but just return the resulting HTML +as a string. When BODY-ONLY is set, don't produce the file +header and footer, simply return the content of the document (all +top-level sections). When PUB-DIR is set, use this as the +publishing directory. + +\(fn &optional HIDDEN EXT-PLIST TO-BUFFER BODY-ONLY PUB-DIR)" t nil) + +;;;*** + +;;;### (autoloads (org-feed-show-raw-feed org-feed-goto-inbox org-feed-update +;;;;;; org-feed-update-all) "org-feed" "lisp/org-feed.el" (19683 +;;;;;; 36308)) +;;; Generated autoloads from lisp/org-feed.el + +(autoload 'org-feed-update-all "org-feed" "\ +Get inbox items from all feeds in `org-feed-alist'. + +\(fn)" t nil) + +(autoload 'org-feed-update "org-feed" "\ +Get inbox items from FEED. +FEED can be a string with an association in `org-feed-alist', or +it can be a list structured like an entry in `org-feed-alist'. + +\(fn FEED &optional RETRIEVE-ONLY)" t nil) + +(autoload 'org-feed-goto-inbox "org-feed" "\ +Go to the inbox that captures the feed named FEED. + +\(fn FEED)" t nil) + +(autoload 'org-feed-show-raw-feed "org-feed" "\ +Show the raw feed buffer of a feed. + +\(fn FEED)" t nil) + +;;;*** + +;;;### (autoloads (org-footnote-normalize org-footnote-action) "org-footnote" +;;;;;; "lisp/org-footnote.el" (19714 9624)) +;;; Generated autoloads from lisp/org-footnote.el + +(autoload 'org-footnote-action "org-footnote" "\ +Do the right thing for footnotes. +When at a footnote reference, jump to the definition. When at a definition, +jump to the references. When neither at definition or reference, +create a new footnote, interactively. +With prefix arg SPECIAL, offer additional commands in a menu. + +\(fn &optional SPECIAL)" t nil) + +(autoload 'org-footnote-normalize "org-footnote" "\ +Collect the footnotes in various formats and normalize them. +This finds the different sorts of footnotes allowed in Org, and +normalizes them to the usual [N] format that is understood by the +Org-mode exporters. +When SORT-ONLY is set, only sort the footnote definitions into the +referenced sequence. + +\(fn &optional SORT-ONLY FOR-PREPROCESSOR)" nil nil) + +;;;*** + +;;;### (autoloads (org-freemind-to-org-mode org-freemind-from-org-sparse-tree +;;;;;; org-freemind-from-org-mode org-freemind-from-org-mode-node +;;;;;; org-freemind-show org-export-as-freemind) "org-freemind" +;;;;;; "lisp/org-freemind.el" (19683 36308)) +;;; Generated autoloads from lisp/org-freemind.el + +(autoload 'org-export-as-freemind "org-freemind" "\ +Export the current buffer as a Freemind file. +If there is an active region, export only the region. HIDDEN is +obsolete and does nothing. EXT-PLIST is a property list with +external parameters overriding org-mode's default settings, but +still inferior to file-local settings. When TO-BUFFER is +non-nil, create a buffer with that name and export to that +buffer. If TO-BUFFER is the symbol `string', don't leave any +buffer behind but just return the resulting HTML as a string. +When BODY-ONLY is set, don't produce the file header and footer, +simply return the content of the document (all top level +sections). When PUB-DIR is set, use this as the publishing +directory. + +See `org-freemind-from-org-mode' for more information. + +\(fn &optional HIDDEN EXT-PLIST TO-BUFFER BODY-ONLY PUB-DIR)" t nil) + +(autoload 'org-freemind-show "org-freemind" "\ +Show file MM-FILE in Freemind. + +\(fn MM-FILE)" t nil) + +(autoload 'org-freemind-from-org-mode-node "org-freemind" "\ +Convert node at line NODE-LINE to the FreeMind file MM-FILE. +See `org-freemind-from-org-mode' for more information. + +\(fn NODE-LINE MM-FILE)" t nil) + +(autoload 'org-freemind-from-org-mode "org-freemind" "\ +Convert the `org-mode' file ORG-FILE to the FreeMind file MM-FILE. +All the nodes will be opened or closed in Freemind just as you +have them in `org-mode'. + +Note that exporting to Freemind also gives you an alternative way +to export from `org-mode' to html. You can create a dynamic html +version of the your org file, by first exporting to Freemind and +then exporting from Freemind to html. The 'As +XHTML (JavaScript)' version in Freemind works very well (and you +can use a CSS stylesheet to style it). + +\(fn ORG-FILE MM-FILE)" t nil) + +(autoload 'org-freemind-from-org-sparse-tree "org-freemind" "\ +Convert visible part of buffer ORG-BUFFER to FreeMind file MM-FILE. + +\(fn ORG-BUFFER MM-FILE)" t nil) + +(autoload 'org-freemind-to-org-mode "org-freemind" "\ +Convert FreeMind file MM-FILE to `org-mode' file ORG-FILE. + +\(fn MM-FILE ORG-FILE)" t nil) + +;;;*** + +;;;### (autoloads (org-export-htmlize-generate-css org-export-as-html +;;;;;; org-export-region-as-html org-replace-region-by-html org-export-as-html-to-buffer +;;;;;; org-export-as-html-batch org-export-as-html-and-open) "org-html" +;;;;;; "lisp/org-html.el" (19699 28931)) +;;; Generated autoloads from lisp/org-html.el + +(put 'org-export-html-style-include-default 'safe-local-variable 'booleanp) + +(put 'org-export-html-style 'safe-local-variable 'stringp) + +(put 'org-export-html-style-extra 'safe-local-variable 'stringp) + +(autoload 'org-export-as-html-and-open "org-html" "\ +Export the outline as HTML and immediately open it with a browser. +If there is an active region, export only the region. +The prefix ARG specifies how many levels of the outline should become +headlines. The default is 3. Lower levels will become bulleted lists. + +\(fn ARG)" t nil) + +(autoload 'org-export-as-html-batch "org-html" "\ +Call the function `org-export-as-html'. +This function can be used in batch processing as: +emacs --batch + --load=$HOME/lib/emacs/org.el + --eval \"(setq org-export-headline-levels 2)\" + --visit=MyFile --funcall org-export-as-html-batch + +\(fn)" nil nil) + +(autoload 'org-export-as-html-to-buffer "org-html" "\ +Call `org-export-as-html` with output to a temporary buffer. +No file is created. The prefix ARG is passed through to `org-export-as-html'. + +\(fn ARG)" t nil) + +(autoload 'org-replace-region-by-html "org-html" "\ +Assume the current region has org-mode syntax, and convert it to HTML. +This can be used in any buffer. For example, you could write an +itemized list in org-mode syntax in an HTML buffer and then use this +command to convert it. + +\(fn BEG END)" t nil) + +(autoload 'org-export-region-as-html "org-html" "\ +Convert region from BEG to END in org-mode buffer to HTML. +If prefix arg BODY-ONLY is set, omit file header, footer, and table of +contents, and only produce the region of converted text, useful for +cut-and-paste operations. +If BUFFER is a buffer or a string, use/create that buffer as a target +of the converted HTML. If BUFFER is the symbol `string', return the +produced HTML as a string and leave not buffer behind. For example, +a Lisp program could call this function in the following way: + + (setq html (org-export-region-as-html beg end t 'string)) + +When called interactively, the output buffer is selected, and shown +in a window. A non-interactive call will only return the buffer. + +\(fn BEG END &optional BODY-ONLY BUFFER)" t nil) + +(autoload 'org-export-as-html "org-html" "\ +Export the outline as a pretty HTML file. +If there is an active region, export only the region. The prefix +ARG specifies how many levels of the outline should become +headlines. The default is 3. Lower levels will become bulleted +lists. HIDDEN is obsolete and does nothing. +EXT-PLIST is a property list with external parameters overriding +org-mode's default settings, but still inferior to file-local +settings. When TO-BUFFER is non-nil, create a buffer with that +name and export to that buffer. If TO-BUFFER is the symbol +`string', don't leave any buffer behind but just return the +resulting HTML as a string. When BODY-ONLY is set, don't produce +the file header and footer, simply return the content of +<body>...</body>, without even the body tags themselves. When +PUB-DIR is set, use this as the publishing directory. + +\(fn ARG &optional HIDDEN EXT-PLIST TO-BUFFER BODY-ONLY PUB-DIR)" t nil) + +(autoload 'org-export-htmlize-generate-css "org-html" "\ +Create the CSS for all font definitions in the current Emacs session. +Use this to create face definitions in your CSS style file that can then +be used by code snippets transformed by htmlize. +This command just produces a buffer that contains class definitions for all +faces used in the current Emacs session. You can copy and paste the ones you +need into your CSS file. + +If you then set `org-export-htmlize-output-type' to `css', calls to +the function `org-export-htmlize-region-for-paste' will produce code +that uses these same face definitions. + +\(fn)" t nil) + +;;;*** + +;;;### (autoloads (org-export-icalendar-combine-agenda-files org-export-icalendar-all-agenda-files +;;;;;; org-export-icalendar-this-file) "org-icalendar" "lisp/org-icalendar.el" +;;;;;; (19683 36308)) +;;; Generated autoloads from lisp/org-icalendar.el + +(autoload 'org-export-icalendar-this-file "org-icalendar" "\ +Export current file as an iCalendar file. +The iCalendar file will be located in the same directory as the Org-mode +file, but with extension `.ics'. + +\(fn)" t nil) + +(autoload 'org-export-icalendar-all-agenda-files "org-icalendar" "\ +Export all files in the variable `org-agenda-files' to iCalendar .ics files. +Each iCalendar file will be located in the same directory as the Org-mode +file, but with extension `.ics'. + +\(fn)" t nil) + +(autoload 'org-export-icalendar-combine-agenda-files "org-icalendar" "\ +Export all files in `org-agenda-files' to a single combined iCalendar file. +The file is stored under the name `org-combined-agenda-icalendar-file'. + +\(fn)" t nil) + +;;;*** + +;;;### (autoloads (org-id-store-link org-id-find-id-file org-id-find +;;;;;; org-id-goto org-id-get-with-outline-drilling org-id-get-with-outline-path-completion +;;;;;; org-id-get org-id-copy org-id-get-create) "org-id" "lisp/org-id.el" +;;;;;; (19683 36308)) +;;; Generated autoloads from lisp/org-id.el + +(autoload 'org-id-get-create "org-id" "\ +Create an ID for the current entry and return it. +If the entry already has an ID, just return it. +With optional argument FORCE, force the creation of a new ID. + +\(fn &optional FORCE)" t nil) + +(autoload 'org-id-copy "org-id" "\ +Copy the ID of the entry at point to the kill ring. +Create an ID if necessary. + +\(fn)" t nil) + +(autoload 'org-id-get "org-id" "\ +Get the ID property of the entry at point-or-marker POM. +If POM is nil, refer to the entry at point. +If the entry does not have an ID, the function returns nil. +However, when CREATE is non nil, create an ID if none is present already. +PREFIX will be passed through to `org-id-new'. +In any case, the ID of the entry is returned. + +\(fn &optional POM CREATE PREFIX)" nil nil) + +(autoload 'org-id-get-with-outline-path-completion "org-id" "\ +Use outline-path-completion to retrieve the ID of an entry. +TARGETS may be a setting for `org-refile-targets' to define the eligible +headlines. When omitted, all headlines in all agenda files are +eligible. +It returns the ID of the entry. If necessary, the ID is created. + +\(fn &optional TARGETS)" nil nil) + +(autoload 'org-id-get-with-outline-drilling "org-id" "\ +Use an outline-cycling interface to retrieve the ID of an entry. +This only finds entries in the current buffer, using `org-get-location'. +It returns the ID of the entry. If necessary, the ID is created. + +\(fn &optional TARGETS)" nil nil) + +(autoload 'org-id-goto "org-id" "\ +Switch to the buffer containing the entry with id ID. +Move the cursor to that entry in that buffer. + +\(fn ID)" t nil) + +(autoload 'org-id-find "org-id" "\ +Return the location of the entry with the id ID. +The return value is a cons cell (file-name . position), or nil +if there is no entry with that ID. +With optional argument MARKERP, return the position as a new marker. + +\(fn ID &optional MARKERP)" nil nil) + +(autoload 'org-id-find-id-file "org-id" "\ +Query the id database for the file in which this ID is located. + +\(fn ID)" nil nil) + +(autoload 'org-id-store-link "org-id" "\ +Store a link to the current entry, using its ID. + +\(fn)" t nil) + +;;;*** + +;;;### (autoloads (org-indent-mode) "org-indent" "lisp/org-indent.el" +;;;;;; (19714 9997)) +;;; Generated autoloads from lisp/org-indent.el + +(autoload 'org-indent-mode "org-indent" "\ +When active, indent text according to outline structure. + +Internally this works by adding `line-prefix' properties to all non-headlines. +These properties are updated locally in idle time. +FIXME: How to update when broken? + +\(fn &optional ARG)" t nil) + +;;;*** + +;;;### (autoloads (org-irc-store-link) "org-irc" "lisp/org-irc.el" +;;;;;; (19683 36308)) +;;; Generated autoloads from lisp/org-irc.el + +(autoload 'org-irc-store-link "org-irc" "\ +Dispatch to the appropriate function to store a link to an IRC session. + +\(fn)" nil nil) + +;;;*** + +;;;### (autoloads (org-export-as-pdf-and-open org-export-as-pdf org-export-as-latex +;;;;;; org-export-region-as-latex org-replace-region-by-latex org-export-as-latex-to-buffer +;;;;;; org-export-as-latex-batch) "org-latex" "lisp/org-latex.el" +;;;;;; (19714 9624)) +;;; Generated autoloads from lisp/org-latex.el + +(autoload 'org-export-as-latex-batch "org-latex" "\ +Call `org-export-as-latex', may be used in batch processing. +For example: + +emacs --batch + --load=$HOME/lib/emacs/org.el + --eval \"(setq org-export-headline-levels 2)\" + --visit=MyFile --funcall org-export-as-latex-batch + +\(fn)" nil nil) + +(autoload 'org-export-as-latex-to-buffer "org-latex" "\ +Call `org-export-as-latex` with output to a temporary buffer. +No file is created. The prefix ARG is passed through to `org-export-as-latex'. + +\(fn ARG)" t nil) + +(autoload 'org-replace-region-by-latex "org-latex" "\ +Replace the region from BEG to END with its LaTeX export. +It assumes the region has `org-mode' syntax, and then convert it to +LaTeX. This can be used in any buffer. For example, you could +write an itemized list in `org-mode' syntax in an LaTeX buffer and +then use this command to convert it. + +\(fn BEG END)" t nil) + +(autoload 'org-export-region-as-latex "org-latex" "\ +Convert region from BEG to END in `org-mode' buffer to LaTeX. +If prefix arg BODY-ONLY is set, omit file header, footer, and table of +contents, and only produce the region of converted text, useful for +cut-and-paste operations. +If BUFFER is a buffer or a string, use/create that buffer as a target +of the converted LaTeX. If BUFFER is the symbol `string', return the +produced LaTeX as a string and leave no buffer behind. For example, +a Lisp program could call this function in the following way: + + (setq latex (org-export-region-as-latex beg end t 'string)) + +When called interactively, the output buffer is selected, and shown +in a window. A non-interactive call will only return the buffer. + +\(fn BEG END &optional BODY-ONLY BUFFER)" t nil) + +(autoload 'org-export-as-latex "org-latex" "\ +Export current buffer to a LaTeX file. +If there is an active region, export only the region. The prefix +ARG specifies how many levels of the outline should become +headlines. The default is 3. Lower levels will be exported +depending on `org-export-latex-low-levels'. The default is to +convert them as description lists. +HIDDEN is obsolete and does nothing. +EXT-PLIST is a property list with +external parameters overriding org-mode's default settings, but +still inferior to file-local settings. When TO-BUFFER is +non-nil, create a buffer with that name and export to that +buffer. If TO-BUFFER is the symbol `string', don't leave any +buffer behind but just return the resulting LaTeX as a string. +When BODY-ONLY is set, don't produce the file header and footer, +simply return the content of \\begin{document}...\\end{document}, +without even the \\begin{document} and \\end{document} commands. +when PUB-DIR is set, use this as the publishing directory. + +\(fn ARG &optional HIDDEN EXT-PLIST TO-BUFFER BODY-ONLY PUB-DIR)" t nil) + +(autoload 'org-export-as-pdf "org-latex" "\ +Export as LaTeX, then process through to PDF. + +\(fn ARG &optional HIDDEN EXT-PLIST TO-BUFFER BODY-ONLY PUB-DIR)" t nil) + +(autoload 'org-export-as-pdf-and-open "org-latex" "\ +Export as LaTeX, then process through to PDF, and open. + +\(fn ARG)" t nil) + +;;;*** + +;;;### (autoloads (org-mobile-create-sumo-agenda org-mobile-pull +;;;;;; org-mobile-push) "org-mobile" "lisp/org-mobile.el" (19683 +;;;;;; 36308)) +;;; Generated autoloads from lisp/org-mobile.el + +(autoload 'org-mobile-push "org-mobile" "\ +Push the current state of Org affairs to the WebDAV directory. +This will create the index file, copy all agenda files there, and also +create all custom agenda views, for upload to the mobile phone. + +\(fn)" t nil) + +(autoload 'org-mobile-pull "org-mobile" "\ +Pull the contents of `org-mobile-capture-file' and integrate them. +Apply all flagged actions, flag entries to be flagged and then call an +agenda view showing the flagged items. + +\(fn)" t nil) + +(autoload 'org-mobile-create-sumo-agenda "org-mobile" "\ +Create a file that contains all custom agenda views. + +\(fn)" t nil) + +;;;*** + +;;;### (autoloads (org-publish-current-project org-publish-current-file +;;;;;; org-publish-all org-publish) "org-publish" "lisp/org-publish.el" +;;;;;; (19683 36308)) +;;; Generated autoloads from lisp/org-publish.el + +(defalias 'org-publish-project 'org-publish) + +(autoload 'org-publish "org-publish" "\ +Publish PROJECT. + +\(fn PROJECT &optional FORCE)" t nil) + +(autoload 'org-publish-all "org-publish" "\ +Publish all projects. +With prefix argument, remove all files in the timestamp +directory and force publishing all files. + +\(fn &optional FORCE)" t nil) + +(autoload 'org-publish-current-file "org-publish" "\ +Publish the current file. +With prefix argument, force publish the file. + +\(fn &optional FORCE)" t nil) + +(autoload 'org-publish-current-project "org-publish" "\ +Publish the project associated with the current file. +With a prefix argument, force publishing of all files in +the project. + +\(fn &optional FORCE)" t nil) + +;;;*** + +;;;### (autoloads (org-plot/gnuplot) "org-plot" "lisp/org-plot.el" +;;;;;; (19683 36308)) +;;; Generated autoloads from lisp/org-plot.el + +(autoload 'org-plot/gnuplot "org-plot" "\ +Plot table using gnuplot. Gnuplot options can be specified with PARAMS. +If not given options will be taken from the +PLOT +line directly before or after the table. + +\(fn &optional PARAMS)" t nil) + +;;;*** + +;;;### (autoloads (org-remember-handler org-remember org-remember-apply-template +;;;;;; org-remember-annotation org-remember-insinuate) "org-remember" +;;;;;; "lisp/org-remember.el" (19683 36308)) +;;; Generated autoloads from lisp/org-remember.el + +(autoload 'org-remember-insinuate "org-remember" "\ +Setup remember.el for use with Org-mode. + +\(fn)" nil nil) + +(autoload 'org-remember-annotation "org-remember" "\ +Return a link to the current location as an annotation for remember.el. +If you are using Org-mode files as target for data storage with +remember.el, then the annotations should include a link compatible with the +conventions in Org-mode. This function returns such a link. + +\(fn)" nil nil) + +(autoload 'org-remember-apply-template "org-remember" "\ +Initialize *remember* buffer with template, invoke `org-mode'. +This function should be placed into `remember-mode-hook' and in fact requires +to be run from that hook to function properly. + +\(fn &optional USE-CHAR SKIP-INTERACTIVE)" nil nil) + +(autoload 'org-remember "org-remember" "\ +Call `remember'. If this is already a remember buffer, re-apply template. +If there is an active region, make sure remember uses it as initial content +of the remember buffer. + +When called interactively with a \\[universal-argument] prefix argument GOTO, don't remember +anything, just go to the file/headline where the selected template usually +stores its notes. With a double prefix argument \\[universal-argument] \\[universal-argument], go to the last +note stored by remember. + +Lisp programs can set ORG-FORCE-REMEMBER-TEMPLATE-CHAR to a character +associated with a template in `org-remember-templates'. + +\(fn &optional GOTO ORG-FORCE-REMEMBER-TEMPLATE-CHAR)" t nil) + +(autoload 'org-remember-handler "org-remember" "\ +Store stuff from remember.el into an org file. +When the template has specified a file and a headline, the entry is filed +there, or in the location defined by `org-default-notes-file' and +`org-remember-default-headline'. +\\<org-remember-mode-map> +If no defaults have been defined, or if the current prefix argument +is 1 (using C-1 \\[org-remember-finalize] to exit remember), an interactive +process is used to select the target location. + +When the prefix is 0 (i.e. when remember is exited with C-0 \\[org-remember-finalize]), +the entry is filed to the same location as the previous note. + +When the prefix is 2 (i.e. when remember is exited with C-2 \\[org-remember-finalize]), +the entry is filed as a subentry of the entry where the clock is +currently running. + +When \\[universal-argument] has been used as prefix argument, the +note is stored and Emacs moves point to the new location of the +note, so that editing can be continued there (similar to +inserting \"%&\" into the template). + +Before storing the note, the function ensures that the text has an +org-mode-style headline, i.e. a first line that starts with +a \"*\". If not, a headline is constructed from the current date and +some additional data. + +If the variable `org-adapt-indentation' is non-nil, the entire text is +also indented so that it starts in the same column as the headline +\(i.e. after the stars). + +See also the variable `org-reverse-note-order'. + +\(fn)" nil nil) + +;;;*** + +;;;### (autoloads (org-table-to-lisp orgtbl-mode turn-on-orgtbl) +;;;;;; "org-table" "lisp/org-table.el" (19683 53402)) +;;; Generated autoloads from lisp/org-table.el + +(autoload 'turn-on-orgtbl "org-table" "\ +Unconditionally turn on `orgtbl-mode'. + +\(fn)" nil nil) + +(autoload 'orgtbl-mode "org-table" "\ +The `org-mode' table editor as a minor mode for use in other modes. + +\(fn &optional ARG)" t nil) + +(autoload 'org-table-to-lisp "org-table" "\ +Convert the table at point to a Lisp structure. +The structure will be a list. Each item is either the symbol `hline' +for a horizontal separator line, or a list of field values as strings. +The table is taken from the parameter TXT, or from the buffer at point. + +\(fn &optional TXT)" nil nil) + +;;;*** + +;;;### (autoloads (org-export-as-taskjuggler-and-open org-export-as-taskjuggler) +;;;;;; "org-taskjuggler" "lisp/org-taskjuggler.el" (19683 36308)) +;;; Generated autoloads from lisp/org-taskjuggler.el + +(autoload 'org-export-as-taskjuggler "org-taskjuggler" "\ +Export parts of the current buffer as a TaskJuggler file. +The exporter looks for a tree with tag, property or todo that +matches `org-export-taskjuggler-project-tag' and takes this as +the tasks for this project. The first node of this tree defines +the project properties such as project name and project period. +If there is a tree with tag, property or todo that matches +`org-export-taskjuggler-resource-tag' this three is taken as +resources for the project. If no resources are specified, a +default resource is created and allocated to the project. Also +the taskjuggler project will be created with default reports as +defined in `org-export-taskjuggler-default-reports'. + +\(fn)" t nil) + +(autoload 'org-export-as-taskjuggler-and-open "org-taskjuggler" "\ +Export the current buffer as a TaskJuggler file and open it +with the TaskJuggler GUI. + +\(fn)" t nil) + +;;;*** + +;;;### (autoloads (org-timer-set-timer org-timer-item org-timer-change-times-in-region +;;;;;; org-timer org-timer-start) "org-timer" "lisp/org-timer.el" +;;;;;; (19683 36308)) +;;; Generated autoloads from lisp/org-timer.el + +(autoload 'org-timer-start "org-timer" "\ +Set the starting time for the relative timer to now. +When called with prefix argument OFFSET, prompt the user for an offset time, +with the default taken from a timer stamp at point, if any. +If OFFSET is a string or an integer, it is directly taken to be the offset +without user interaction. +When called with a double prefix arg, all timer strings in the active +region will be shifted by a specific amount. You will be prompted for +the amount, with the default to make the first timer string in +the region 0:00:00. + +\(fn &optional OFFSET)" t nil) + +(autoload 'org-timer "org-timer" "\ +Insert a H:MM:SS string from the timer into the buffer. +The first time this command is used, the timer is started. When used with +a \\[universal-argument] prefix, force restarting the timer. +When used with a double prefix argument \\[universal-argument], change all the timer string +in the region by a fixed amount. This can be used to recalibrate a timer +that was not started at the correct moment. + +If NO-INSERT-P is non-nil, return the string instead of inserting +it in the buffer. + +\(fn &optional RESTART NO-INSERT-P)" t nil) + +(autoload 'org-timer-change-times-in-region "org-timer" "\ +Change all h:mm:ss time in region by a DELTA. + +\(fn BEG END DELTA)" t nil) + +(autoload 'org-timer-item "org-timer" "\ +Insert a description-type item with the current timer value. + +\(fn &optional ARG)" t nil) + +(autoload 'org-timer-set-timer "org-timer" "\ +Prompt for a duration and set a timer. + +If `org-timer-default-timer' is not zero, suggest this value as +the default duration for the timer. If a timer is already set, +prompt the user if she wants to replace it. + +Called with a numeric prefix argument, use this numeric value as +the duration of the timer. + +Called with a `C-u' prefix arguments, use `org-timer-default-timer' +without prompting the user for a duration. + +With two `C-u' prefix arguments, use `org-timer-default-timer' +without prompting the user for a duration and automatically +replace any running timer. + +\(fn &optional OPT)" t nil) + +;;;*** + +;;;### (autoloads (org-export-as-xoxo) "org-xoxo" "lisp/org-xoxo.el" +;;;;;; (19683 36308)) +;;; Generated autoloads from lisp/org-xoxo.el + +(autoload 'org-export-as-xoxo "org-xoxo" "\ +Export the org buffer as XOXO. +The XOXO buffer is named *xoxo-<source buffer name>* + +\(fn &optional BUFFER)" t nil) + +;;;*** + +;;;### (autoloads (org-babel-mark-block org-babel-previous-src-block +;;;;;; org-babel-next-src-block org-babel-goto-named-result org-babel-goto-named-src-block +;;;;;; org-babel-goto-src-block-head org-babel-hide-result-toggle-maybe +;;;;;; org-babel-sha1-hash org-babel-execute-subtree org-babel-execute-buffer +;;;;;; org-babel-map-src-blocks org-babel-open-src-block-result +;;;;;; org-babel-switch-to-session-with-code org-babel-switch-to-session +;;;;;; org-babel-initiate-session org-babel-load-in-session org-babel-expand-src-block +;;;;;; org-babel-execute-src-block org-babel-pop-to-session-maybe +;;;;;; org-babel-load-in-session-maybe org-babel-expand-src-block-maybe +;;;;;; org-babel-execute-maybe org-babel-execute-safely-maybe) "ob" +;;;;;; "lisp/ob.el" (19714 9624)) +;;; Generated autoloads from lisp/ob.el + +(autoload 'org-babel-execute-safely-maybe "ob" "\ +Not documented + +\(fn)" nil nil) + +(autoload 'org-babel-execute-maybe "ob" "\ +Not documented + +\(fn)" t nil) + +(autoload 'org-babel-expand-src-block-maybe "ob" "\ +Conditionally expand a source block. +Detect if this is context for a org-babel src-block and if so +then run `org-babel-expand-src-block'. + +\(fn)" t nil) + +(autoload 'org-babel-load-in-session-maybe "ob" "\ +Conditionally load a source block in a session. +Detect if this is context for a org-babel src-block and if so +then run `org-babel-load-in-session'. + +\(fn)" t nil) + +(autoload 'org-babel-pop-to-session-maybe "ob" "\ +Conditionally pop to a session. +Detect if this is context for a org-babel src-block and if so +then run `org-babel-pop-to-session'. + +\(fn)" t nil) + +(autoload 'org-babel-execute-src-block "ob" "\ +Execute the current source code block. +Insert the results of execution into the buffer. Source code +execution and the collection and formatting of results can be +controlled through a variety of header arguments. + +With prefix argument ARG, force re-execution even if a an +existing result cached in the buffer would otherwise have been +returned. + +Optionally supply a value for INFO in the form returned by +`org-babel-get-src-block-info'. + +Optionally supply a value for PARAMS which will be merged with +the header arguments specified at the front of the source code +block. + +\(fn &optional ARG INFO PARAMS)" t nil) + +(autoload 'org-babel-expand-src-block "ob" "\ +Expand the current source code block. +Expand according to the source code block's header +arguments and pop open the results in a preview buffer. + +\(fn &optional ARG INFO PARAMS)" t nil) + +(autoload 'org-babel-load-in-session "ob" "\ +Load the body of the current source-code block. +Evaluate the header arguments for the source block before +entering the session. After loading the body this pops open the +session. + +\(fn &optional ARG INFO)" t nil) + +(autoload 'org-babel-initiate-session "ob" "\ +Initiate session for current code block. +If called with a prefix argument then resolve any variable +references in the header arguments and assign these variables in +the session. Copy the body of the code block to the kill ring. + +\(fn &optional ARG INFO)" t nil) + +(autoload 'org-babel-switch-to-session "ob" "\ +Switch to the session of the current code block. +Uses `org-babel-initiate-session' to start the session. If called +with a prefix argument then this is passed on to +`org-babel-initiate-session'. + +\(fn &optional ARG INFO)" t nil) + +(autoload 'org-babel-switch-to-session-with-code "ob" "\ +Switch to code buffer and display session. + +\(fn &optional ARG INFO)" t nil) + +(autoload 'org-babel-open-src-block-result "ob" "\ +If `point' is on a src block then open the results of the +source code block, otherwise return nil. With optional prefix +argument RE-RUN the source-code block is evaluated even if +results already exist. + +\(fn &optional RE-RUN)" t nil) + +(autoload 'org-babel-map-src-blocks "ob" "\ +Evaluate BODY forms on each source-block in FILE. +If FILE is nil evaluate BODY forms on source blocks in current +buffer. During evaluation of BODY the following local variables +are set relative to the currently matched code block. + +full-block ------- string holding the entirety of the code block +beg-block -------- point at the beginning of the code block +end-block -------- point at the end of the matched code block +lang ------------- string holding the language of the code block +beg-lang --------- point at the beginning of the lang +end-lang --------- point at the end of the lang +switches --------- string holding the switches +beg-switches ----- point at the beginning of the switches +end-switches ----- point at the end of the switches +header-args ------ string holding the header-args +beg-header-args -- point at the beginning of the header-args +end-header-args -- point at the end of the header-args +body ------------- string holding the body of the code block +beg-body --------- point at the beginning of the body +end-body --------- point at the end of the body + +\(fn FILE &rest BODY)" nil (quote macro)) + +(autoload 'org-babel-execute-buffer "ob" "\ +Execute source code blocks in a buffer. +Call `org-babel-execute-src-block' on every source block in +the current buffer. + +\(fn &optional ARG)" t nil) + +(autoload 'org-babel-execute-subtree "ob" "\ +Execute source code blocks in a subtree. +Call `org-babel-execute-src-block' on every source block in +the current subtree. + +\(fn &optional ARG)" t nil) + +(autoload 'org-babel-sha1-hash "ob" "\ +Generate an sha1 hash based on the value of info. + +\(fn &optional INFO)" t nil) + +(autoload 'org-babel-hide-result-toggle-maybe "ob" "\ +Toggle visibility of result at point. + +\(fn)" t nil) + +(autoload 'org-babel-goto-src-block-head "ob" "\ +Go to the beginning of the current code block. + +\(fn)" t nil) + +(autoload 'org-babel-goto-named-src-block "ob" "\ +Go to a named source-code block. + +\(fn NAME)" t nil) + +(autoload 'org-babel-goto-named-result "ob" "\ +Go to a named result. + +\(fn NAME)" t nil) + +(autoload 'org-babel-next-src-block "ob" "\ +Jump to the next source block. +With optional prefix argument ARG, jump forward ARG many source blocks. + +\(fn &optional ARG)" t nil) + +(autoload 'org-babel-previous-src-block "ob" "\ +Jump to the previous source block. +With optional prefix argument ARG, jump backward ARG many source blocks. + +\(fn &optional ARG)" t nil) + +(autoload 'org-babel-mark-block "ob" "\ +Mark current src block + +\(fn)" t nil) + +;;;*** + +;;;### (autoloads (org-babel-lob-get-info org-babel-lob-execute-maybe +;;;;;; org-babel-lob-ingest) "ob-lob" "lisp/ob-lob.el" (19683 36308)) +;;; Generated autoloads from lisp/ob-lob.el + +(autoload 'org-babel-lob-ingest "ob-lob" "\ +Add all named source-blocks defined in FILE to +`org-babel-library-of-babel'. + +\(fn &optional FILE)" t nil) + +(autoload 'org-babel-lob-execute-maybe "ob-lob" "\ +Execute a Library of Babel source block, if appropriate. +Detect if this is context for a Library Of Babel source block and +if so then run the appropriate source block from the Library. + +\(fn)" t nil) + +(autoload 'org-babel-lob-get-info "ob-lob" "\ +Return a Library of Babel function call as a string. + +\(fn)" nil nil) + +;;;*** + +;;;### (autoloads (org-babel-tangle org-babel-tangle-file org-babel-load-file +;;;;;; org-babel-tangle-lang-exts) "ob-tangle" "lisp/ob-tangle.el" +;;;;;; (19699 28931)) +;;; Generated autoloads from lisp/ob-tangle.el + +(defvar org-babel-tangle-lang-exts '(("emacs-lisp" . "el")) "\ +Alist mapping languages to their file extensions. +The key is the language name, the value is the string that should +be inserted as the extension commonly used to identify files +written in this language. If no entry is found in this list, +then the name of the language is used.") + +(custom-autoload 'org-babel-tangle-lang-exts "ob-tangle" t) + +(autoload 'org-babel-load-file "ob-tangle" "\ +Load Emacs Lisp source code blocks in the Org-mode FILE. +This function exports the source code using +`org-babel-tangle' and then loads the resulting file using +`load-file'. + +\(fn FILE)" t nil) + +(autoload 'org-babel-tangle-file "ob-tangle" "\ +Extract the bodies of source code blocks in FILE. +Source code blocks are extracted with `org-babel-tangle'. +Optional argument TARGET-FILE can be used to specify a default +export file for all source blocks. Optional argument LANG can be +used to limit the exported source code blocks by language. + +\(fn FILE &optional TARGET-FILE LANG)" t nil) + +(autoload 'org-babel-tangle "ob-tangle" "\ +Write code blocks to source-specific files. +Extract the bodies of all source code blocks from the current +file into their own source-specific files. Optional argument +TARGET-FILE can be used to specify a default export file for all +source blocks. Optional argument LANG can be used to limit the +exported source code blocks by language. + +\(fn &optional TARGET-FILE LANG)" t nil) + +;;;*** + +;;;### (autoloads (org-babel-describe-bindings) "ob-keys" "lisp/ob-keys.el" +;;;;;; (19683 36308)) +;;; Generated autoloads from lisp/ob-keys.el + +(autoload 'org-babel-describe-bindings "ob-keys" "\ +Describe all keybindings behind `org-babel-key-prefix'. + +\(fn)" t nil) + +;;;*** + +(provide (quote org-install)) diff --git a/.emacs.d/org-7.4/lisp/org-install.elc b/.emacs.d/org-7.4/lisp/org-install.elc Binary files differnew file mode 100644 index 0000000..de1ef9e --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-install.elc diff --git a/.emacs.d/org-7.4/lisp/org-irc.el b/.emacs.d/org-7.4/lisp/org-irc.el new file mode 100644 index 0000000..fba2741 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-irc.el @@ -0,0 +1,256 @@ +;;; org-irc.el --- Store links to IRC sessions +;; +;; Copyright (C) 2008, 2009, 2010 Free Software Foundation, Inc. +;; +;; Author: Philip Jackson <emacs@shellarchive.co.uk> +;; Keywords: erc, irc, link, org +;; Version: 7.4 +;; +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This file implements links to an IRC session from within Org-mode. +;; Org-mode loads this module by default - if this is not what you want, +;; configure the variable `org-modules'. +;; +;; Please customize the variable `org-modules' to select +;; extensions you would like to use, and to deselect those which you don't +;; want. +;; +;; Please note that at the moment only ERC is supported. Other clients +;; shouldn't be difficult to add though. +;; +;; Then set `org-irc-link-to-logs' to non-nil if you would like a +;; file:/ type link to be created to the current line in the logs or +;; to t if you would like to create an irc:/ style link. +;; +;; Links within an org buffer might look like this: +;; +;; [[irc:/irc.freenode.net/#emacs/bob][chat with bob in #emacs on freenode]] +;; [[irc:/irc.freenode.net/#emacs][#emacs on freenode]] +;; [[irc:/irc.freenode.net/]] +;; +;; If, when the resulting link is visited, there is no connection to a +;; requested server then one will be created. + +;;; Code: + +(require 'org) + +;; Declare the function form ERC that we use. +(declare-function erc-current-logfile "erc-log" (&optional buffer)) +(declare-function erc-prompt "erc" ()) +(declare-function erc-default-target "erc" ()) +(declare-function erc-channel-p "erc" (channel)) +(declare-function erc-buffer-filter "erc" (predicate &optional proc)) +(declare-function erc-server-buffer "erc" ()) +(declare-function erc-get-server-nickname-list "erc" ()) +(declare-function erc-cmd-JOIN "erc" (channel &optional key)) + +(defvar org-irc-client 'erc + "The IRC client to act on.") +(defvar org-irc-link-to-logs nil + "Non-nil will store a link to the logs, nil will store an irc: style link.") + +(defvar erc-default-port) ; dynamically scoped from erc.el +(defvar erc-session-port) ; dynamically scoped form erc-backend.el +(defvar erc-session-server) ; dynamically scoped form erc-backend.el + +;; Generic functions/config (extend these for other clients) + +(add-to-list 'org-store-link-functions 'org-irc-store-link) + +(org-add-link-type "irc" 'org-irc-visit nil) + +(defun org-irc-visit (link) + "Parse LINK and dispatch to the correct function based on the client found." + (let ((link (org-irc-parse-link link))) + (cond + ((eq org-irc-client 'erc) + (org-irc-visit-erc link)) + (t + (error "erc only known client"))))) + +(defun org-irc-parse-link (link) + "Parse an IRC LINK and return the attributes found. +Parse a LINK that looks like server:port/chan/user (port, chan +and user being optional) and return any of the port, channel or user +attributes that are found." + (let* ((parts (split-string link "/" t)) + (len (length parts))) + (when (or (< len 1) (> len 3)) + (error "Failed to parse link needed 1-3 parts, got %d" len)) + (setcar parts (split-string (car parts) ":" t)) + parts)) + +;;;###autoload +(defun org-irc-store-link () + "Dispatch to the appropriate function to store a link to an IRC session." + (cond + ((eq major-mode 'erc-mode) + (org-irc-erc-store-link)))) + +(defun org-irc-elipsify-description (string &optional after) + "Remove unnecessary white space from STRING and add ellipses if necessary. +Strip starting and ending white space from STRING and replace any +chars that the value AFTER with '...'" + (let* ((after (number-to-string (or after 30))) + (replace-map (list (cons "^[ \t]*" "") + (cons "[ \t]*$" "") + (cons (concat "^\\(.\\{" after + "\\}\\).*") "\\1...")))) + (mapc (lambda (x) + (when (string-match (car x) string) + (setq string (replace-match (cdr x) nil nil string)))) + replace-map) + string)) + +;; ERC specific functions + +(defun org-irc-erc-get-line-from-log (erc-line) + "Find the best line to link to from the ERC logs given ERC-LINE as a start. +If the user is on the ERC-prompt then search backward for the +first non-blank line, otherwise return the current line. The +result is a cons of the filename and search string." + (erc-save-buffer-in-logs) + (require 'erc-log) + (with-current-buffer (find-file-noselect (erc-current-logfile)) + (goto-char (point-max)) + (list + (abbreviate-file-name buffer-file-name) + ;; can we get a '::' part? + (if (string= erc-line (erc-prompt)) + (progn + (goto-char (point-at-bol)) + (when (search-backward-regexp "^[^ ]" nil t) + (buffer-substring-no-properties (point-at-bol) + (point-at-eol)))) + (when (search-backward erc-line nil t) + (buffer-substring-no-properties (point-at-bol) + (point-at-eol))))))) + +(defun org-irc-erc-store-link () + "Store a link to the IRC log file or the session itself. +Depending on the variable `org-irc-link-to-logs' store either a +link to the log file for the current session or an irc: link to +the session itself." + (require 'erc-log) + (if org-irc-link-to-logs + (let* ((erc-line (buffer-substring-no-properties + (point-at-bol) (point-at-eol))) + (parsed-line (org-irc-erc-get-line-from-log erc-line))) + (if (erc-logging-enabled nil) + (progn + (org-store-link-props + :type "file" + :description (concat "'" (org-irc-elipsify-description + (cadr parsed-line) 20) + "' from an IRC conversation") + :link (concat "file:" (car parsed-line) "::" + (cadr parsed-line))) + t) + (error "This ERC session is not being logged"))) + (let* ((link-text (org-irc-get-erc-link)) + (link (org-irc-parse-link link-text))) + (if link-text + (progn + (org-store-link-props + :type "irc" + :link (org-make-link "irc:/" link-text) + :description (concat "irc session '" link-text "'") + :server (car (car link)) + :port (or (string-to-number (cadr (pop link))) erc-default-port) + :nick (pop link)) + t) + (error "Failed to create ('irc:/' style) ERC link"))))) + +(defun org-irc-get-erc-link () + "Return an org compatible irc:/ link from an ERC buffer." + (let* ((session-port (if (numberp erc-session-port) + (number-to-string erc-session-port) + erc-session-port)) + (link (concat erc-session-server ":" session-port))) + (concat link "/" + (if (and (erc-default-target) + (erc-channel-p (erc-default-target)) + (car (get-text-property (point) 'erc-data))) + ;; we can get a nick + (let ((nick (car (get-text-property (point) 'erc-data)))) + (concat (erc-default-target) "/" nick)) + (erc-default-target))))) + +(defun org-irc-get-current-erc-port () + "Return the current port as a number. +Return the current port number or, if none is set, return the ERC +default." + (cond + ((stringp erc-session-port) + (string-to-number erc-session-port)) + ((numberp erc-session-port) + erc-session-port) + (t + erc-default-port))) + +(defun org-irc-visit-erc (link) + "Visit an ERC buffer based on criteria found in LINK." + (require 'erc) + (require 'erc-log) + (let* ((server (car (car link))) + (port (or (string-to-number (cadr (pop link))) erc-default-port)) + (server-buffer) + (buffer-list + (erc-buffer-filter + (lambda nil + (let ((tmp-server-buf (erc-server-buffer))) + (and tmp-server-buf + (with-current-buffer tmp-server-buf + (and + (eq (org-irc-get-current-erc-port) port) + (string= erc-session-server server) + (setq server-buffer tmp-server-buf))))))))) + (if buffer-list + (let ((chan-name (pop link))) + ;; if we got a channel name then switch to it or join it + (if chan-name + (let ((chan-buf (catch 'found + (dolist (x buffer-list) + (if (string= (buffer-name x) chan-name) + (throw 'found x)))))) + (if chan-buf + (progn + (switch-to-buffer chan-buf) + ;; if we got a nick, and they're in the chan, + ;; then start a chat with them + (let ((nick (pop link))) + (when nick + (if (member nick (erc-get-server-nickname-list)) + (progn + (goto-char (point-max)) + (insert (concat nick ": "))) + (error "%s not found in %s" nick chan-name))))) + (progn + (switch-to-buffer server-buffer) + (erc-cmd-JOIN chan-name)))) + (switch-to-buffer server-buffer))) + ;; no server match, make new connection + (erc-select :server server :port port)))) + +(provide 'org-irc) + +;; arch-tag: 018d7dda-53b8-4a35-ba92-6670939e525a + +;;; org-irc.el ends here diff --git a/.emacs.d/org-7.4/lisp/org-irc.elc b/.emacs.d/org-7.4/lisp/org-irc.elc Binary files differnew file mode 100644 index 0000000..89b01d2 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-irc.elc diff --git a/.emacs.d/org-7.4/lisp/org-jsinfo.el b/.emacs.d/org-7.4/lisp/org-jsinfo.el new file mode 100644 index 0000000..e5c65b0 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-jsinfo.el @@ -0,0 +1,210 @@ +;;; org-jsinfo.el --- Support for org-info.js Javascript in Org HTML export + +;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010 +;; Free Software Foundation, Inc. + +;; Author: Carsten Dominik <carsten at orgmode dot org> +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; Version: 7.4 +;; +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: + +;; This file implements the support for Sebastian Rose's JavaScript +;; org-info.js to display an org-mode file exported to HTML in an +;; Info-like way, or using folding similar to the outline structure +;; org org-mode itself. + +;; Documentation for using this module is in the Org manual. The script +;; itself is documented by Sebastian Rose in a file distributed with +;; the script. FIXME: Accurate pointers! + +;; Org-mode loads this module by default - if this is not what you want, +;; configure the variable `org-modules'. + +;;; Code: + +(require 'org-exp) +(require 'org-html) + +(add-to-list 'org-export-inbuffer-options-extra '("INFOJS_OPT" :infojs-opt)) +(add-hook 'org-export-options-filters 'org-infojs-handle-options) + +(defgroup org-infojs nil + "Options specific for using org-info.js in HTML export of Org-mode files." + :tag "Org Export HTML INFOJS" + :group 'org-export-html) + +(defcustom org-export-html-use-infojs 'when-configured + "Should Sebastian Rose's Java Script org-info.js be linked into HTML files? +This option can be nil or t to never or always use the script. It can +also be the symbol `when-configured', meaning that the script will be +linked into the export file if and only if there is a \"#+INFOJS_OPT:\" +line in the buffer. See also the variable `org-infojs-options'." + :group 'org-export-html + :group 'org-infojs + :type '(choice + (const :tag "Never" nil) + (const :tag "When configured in buffer" when-configured) + (const :tag "Always" t))) + +(defconst org-infojs-opts-table + '((path PATH "http://orgmode.org/org-info.js") + (view VIEW "info") + (toc TOC :table-of-contents) + (ftoc FIXED_TOC "0") + (tdepth TOC_DEPTH "max") + (sdepth SECTION_DEPTH "max") + (mouse MOUSE_HINT "underline") + (buttons VIEW_BUTTONS "0") + (ltoc LOCAL_TOC "1") + (up LINK_UP :link-up) + (home LINK_HOME :link-home)) + "JavaScript options, long form for script, default values.") + +(defvar org-infojs-options) +(when (and (boundp 'org-infojs-options) + (assq 'runs org-infojs-options)) + (setq org-infojs-options (delq (assq 'runs org-infojs-options) + org-infojs-options))) + +(defcustom org-infojs-options + (mapcar (lambda (x) (cons (car x) (nth 2 x))) + org-infojs-opts-table) + "Options settings for the INFOJS JavaScript. +Each of the options must have an entry in `org-export-html/infojs-opts-table'. +The value can either be a string that will be passed to the script, or +a property. This property is then assumed to be a property that is defined +by the Export/Publishing setup of Org. +The `sdepth' and `tdepth' parameters can also be set to \"max\", which +means to use the maximum value consistent with other options." + :group 'org-infojs + :type + `(set :greedy t :inline t + ,@(mapcar + (lambda (x) + (list 'cons (list 'const (car x)) + '(choice + (symbol :tag "Publishing/Export property") + (string :tag "Value")))) + org-infojs-opts-table))) + +(defcustom org-infojs-template + "<script type=\"text/javascript\" src=\"%SCRIPT_PATH\"></script> +<script type=\"text/javascript\" > +<!--/*--><![CDATA[/*><!--*/ +%MANAGER_OPTIONS +org_html_manager.setup(); // activate after the parameters are set +/*]]>*///--> +</script>" + "The template for the export style additions when org-info.js is used. +Option settings will replace the %MANAGER-OPTIONS cookie." + :group 'org-infojs + :type 'string) + +(defun org-infojs-handle-options (exp-plist) + "Analyze JavaScript options in INFO-PLIST and modify EXP-PLIST accordingly." + (if (or (not org-export-html-use-infojs) + (and (eq org-export-html-use-infojs 'when-configured) + (or (not (plist-get exp-plist :infojs-opt)) + (string-match "\\<view:nil\\>" + (plist-get exp-plist :infojs-opt))))) + ;; We do not want to use the script + exp-plist + ;; We do want to use the script, set it up + (let ((template org-infojs-template) + (ptoc (plist-get exp-plist :table-of-contents)) + (hlevels (plist-get exp-plist :headline-levels)) + tdepth sdepth s v e opt var val table default) + (setq sdepth hlevels + tdepth hlevels) + (if (integerp ptoc) (setq tdepth (min ptoc tdepth))) + (setq v (plist-get exp-plist :infojs-opt) + table org-infojs-opts-table) + (while (setq e (pop table)) + (setq opt (car e) var (nth 1 e) + default (cdr (assoc opt org-infojs-options))) + (and (symbolp default) (not (memq default '(t nil))) + (setq default (plist-get exp-plist default))) + (if (and v (string-match (format " %s:\\(\\S-+\\)" opt) v)) + (setq val (match-string 1 v)) + (setq val default)) + (cond + ((eq opt 'path) + (and (string-match "%SCRIPT_PATH" template) + (setq template (replace-match val t t template)))) + ((eq opt 'sdepth) + (if (integerp (read val)) + (setq sdepth (min (read val) hlevels)))) + ((eq opt 'tdepth) + (if (integerp (read val)) + (setq tdepth (min (read val) hlevels)))) + (t + (setq val + (cond + ((or (eq val t) (equal val "t")) "1") + ((or (eq val nil) (equal val "nil")) "0") + ((stringp val) val) + (t (format "%s" val)))) + (push (cons var val) s)))) + + ;; Now we set the depth of the *generated* TOC to SDEPTH, because the + ;; toc will actually determine the splitting. How much of the toc will + ;; actually be displayed is governed by the TDEPTH option. + (setq exp-plist (plist-put exp-plist :table-of-contents sdepth)) + + ;; The table of contents should not show more sections then we generate + (setq tdepth (min tdepth sdepth)) + (push (cons "TOC_DEPTH" tdepth) s) + + (setq s (mapconcat + (lambda (x) (format "org_html_manager.set(\"%s\", \"%s\");" + (car x) (cdr x))) + s "\n")) + (when (and s (> (length s) 0)) + (and (string-match "%MANAGER_OPTIONS" template) + (setq s (replace-match s t t template)) + (setq exp-plist + (plist-put + exp-plist :style-extra + (concat (or (plist-get exp-plist :style-extra) "") "\n" s))))) + ;; This script absolutely needs the table of contents, to we change that + ;; setting + (if (not (plist-get exp-plist :table-of-contents)) + (setq exp-plist (plist-put exp-plist :table-of-contents t))) + ;; Return the modified property list + exp-plist))) + +(defun org-infojs-options-inbuffer-template () + (format "#+INFOJS_OPT: view:%s toc:%s ltoc:%s mouse:%s buttons:%s path:%s" + (if (eq t org-export-html-use-infojs) (cdr (assoc 'view org-infojs-options)) nil) + (let ((a (cdr (assoc 'toc org-infojs-options)))) + (cond ((memq a '(nil t)) a) + (t (plist-get (org-infile-export-plist) :table-of-contents)))) + (if (equal (cdr (assoc 'ltoc org-infojs-options)) "1") t nil) + (cdr (assoc 'mouse org-infojs-options)) + (cdr (assoc 'buttons org-infojs-options)) + (cdr (assoc 'path org-infojs-options)))) + +(provide 'org-infojs) +(provide 'org-jsinfo) + +;; arch-tag: c71d1d85-3337-4817-a066-725e74ac9eac + +;;; org-jsinfo.el ends here diff --git a/.emacs.d/org-7.4/lisp/org-jsinfo.elc b/.emacs.d/org-7.4/lisp/org-jsinfo.elc Binary files differnew file mode 100644 index 0000000..be7086f --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-jsinfo.elc diff --git a/.emacs.d/org-7.4/lisp/org-latex.el b/.emacs.d/org-7.4/lisp/org-latex.el new file mode 100644 index 0000000..a29c9f3 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-latex.el @@ -0,0 +1,2578 @@ +;;; org-latex.el --- LaTeX exporter for org-mode +;; +;; Copyright (C) 2007, 2008, 2009, 2010 Free Software Foundation, Inc. +;; +;; Emacs Lisp Archive Entry +;; Filename: org-latex.el +;; Version: 7.4 +;; Author: Bastien Guerry <bzg AT altern DOT org> +;; Maintainer: Carsten Dominik <carsten.dominik AT gmail DOT com> +;; Keywords: org, wp, tex +;; Description: Converts an org-mode buffer into LaTeX + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; This library implements a LaTeX exporter for org-mode. +;; +;; It is part of Org and will be autoloaded +;; +;; The interactive functions are similar to those of the HTML exporter: +;; +;; M-x `org-export-as-latex' +;; M-x `org-export-as-pdf' +;; M-x `org-export-as-pdf-and-open' +;; M-x `org-export-as-latex-batch' +;; M-x `org-export-as-latex-to-buffer' +;; M-x `org-export-region-as-latex' +;; M-x `org-replace-region-by-latex' +;; +;;; Code: + +(eval-when-compile + (require 'cl)) + +(require 'footnote) +(require 'org) +(require 'org-exp) +(require 'org-macs) +(require 'org-beamer) + +;;; Variables: +(defvar org-export-latex-class nil) +(defvar org-export-latex-class-options nil) +(defvar org-export-latex-header nil) +(defvar org-export-latex-append-header nil) +(defvar org-export-latex-options-plist nil) +(defvar org-export-latex-todo-keywords-1 nil) +(defvar org-export-latex-complex-heading-re nil) +(defvar org-export-latex-not-done-keywords nil) +(defvar org-export-latex-done-keywords nil) +(defvar org-export-latex-display-custom-times nil) +(defvar org-export-latex-all-targets-re nil) +(defvar org-export-latex-add-level 0) +(defvar org-export-latex-sectioning "") +(defvar org-export-latex-sectioning-depth 0) +(defvar org-export-latex-special-keyword-regexp + (concat "\\<\\(" org-scheduled-string "\\|" + org-deadline-string "\\|" + org-closed-string"\\)") + "Regexp matching special time planning keywords plus the time after it.") + +(defvar latexp) ; dynamically scoped from org.el +(defvar re-quote) ; dynamically scoped from org.el +(defvar commentsp) ; dynamically scoped from org.el + +;;; User variables: + +(defgroup org-export-latex nil + "Options for exporting Org-mode files to LaTeX." + :tag "Org Export LaTeX" + :group 'org-export) + +(defcustom org-export-latex-default-class "article" + "The default LaTeX class." + :group 'org-export-latex + :type '(string :tag "LaTeX class")) + +(defcustom org-export-latex-classes + '(("article" + "\\documentclass[11pt]{article}" + ("\\section{%s}" . "\\section*{%s}") + ("\\subsection{%s}" . "\\subsection*{%s}") + ("\\subsubsection{%s}" . "\\subsubsection*{%s}") + ("\\paragraph{%s}" . "\\paragraph*{%s}") + ("\\subparagraph{%s}" . "\\subparagraph*{%s}")) + ("report" + "\\documentclass[11pt]{report}" + ("\\part{%s}" . "\\part*{%s}") + ("\\chapter{%s}" . "\\chapter*{%s}") + ("\\section{%s}" . "\\section*{%s}") + ("\\subsection{%s}" . "\\subsection*{%s}") + ("\\subsubsection{%s}" . "\\subsubsection*{%s}")) + ("book" + "\\documentclass[11pt]{book}" + ("\\part{%s}" . "\\part*{%s}") + ("\\chapter{%s}" . "\\chapter*{%s}") + ("\\section{%s}" . "\\section*{%s}") + ("\\subsection{%s}" . "\\subsection*{%s}") + ("\\subsubsection{%s}" . "\\subsubsection*{%s}")) + ("beamer" + "\\documentclass{beamer}" + org-beamer-sectioning + )) + "Alist of LaTeX classes and associated header and structure. +If #+LaTeX_CLASS is set in the buffer, use its value and the +associated information. Here is the structure of each cell: + + \(class-name + header-string + (numbered-section . unnumbered-section\) + ...\) + +The header string +----------------- + +The HEADER-STRING is the header that will be inserted into the LaTeX file. +It should contain the \\documentclass macro, and anything else that is needed +for this setup. To this header, the following commands will be added: + +- Calls to \\usepackage for all packages mentioned in the variables + `org-export-latex-default-packages-alist' and + `org-export-latex-packages-alist'. Thus, your header definitions should + avoid to also request these packages. + +- Lines specified via \"#+LaTeX_HEADER:\" + +If you need more control about the sequence in which the header is built +up, or if you want to exclude one of these building blocks for a particular +class, you can use the following macro-like placeholders. + + [DEFAULT-PACKAGES] \\usepackage statements for default packages + [NO-DEFAULT-PACKAGES] do not include any of the default packages + [PACKAGES] \\usepackage statements for packages + [NO-PACKAGES] do not include the packages + [EXTRA] the stuff from #+LaTeX_HEADER + [NO-EXTRA] do not include #+LaTeX_HEADER stuff + [BEAMER-HEADER-EXTRA] the beamer extra headers + +So a header like + + \\documentclass{article} + [NO-DEFAULT-PACKAGES] + [EXTRA] + \\providecommand{\\alert}[1]{\\textbf{#1}} + [PACKAGES] + +will omit the default packages, and will include the #+LaTeX_HEADER lines, +then have a call to \\providecommand, and then place \\usepackage commands +based on the content of `org-export-latex-packages-alist'. + +If your header or `org-export-latex-default-packages-alist' inserts +\"\\usepackage[AUTO]{inputenc}\", AUTO will automatically be replaced with +a coding system derived from `buffer-file-coding-system'. See also the +variable `org-export-latex-inputenc-alist' for a way to influence this +mechanism. + +The sectioning structure +------------------------ + +The sectioning structure of the class is given by the elements following +the header string. For each sectioning level, a number of strings is +specified. A %s formatter is mandatory in each section string and will +be replaced by the title of the section. + +Instead of a cons cell (numbered . unnumbered), you can also provide a list +of 2 or 4 elements, + + (numbered-open numbered-close) + +or + + (numbered-open numbered-close unnumbered-open unnumbered-close) + +providing opening and closing strings for a LaTeX environment that should +represent the document section. The opening clause should have a %s +to represent the section title. + +Instead of a list of sectioning commands, you can also specify a +function name. That function will be called with two parameters, +the (reduced) level of the headline, and the headline text. The function +must return a cons cell with the (possibly modified) headline text, and the +sectioning list in the cdr." + :group 'org-export-latex + :type '(repeat + (list (string :tag "LaTeX class") + (string :tag "LaTeX header") + (repeat :tag "Levels" :inline t + (choice + (cons :tag "Heading" + (string :tag " numbered") + (string :tag "unnumbered")) + (list :tag "Environment" + (string :tag "Opening (numbered)") + (string :tag "Closing (numbered)") + (string :tag "Opening (unnumbered)") + (string :tag "Closing (unnumbered)")) + (function :tag "Hook computing sectioning")))))) + +(defcustom org-export-latex-inputenc-alist nil + "Alist of inputenc coding system names, and what should really be used. +For example, adding an entry + + (\"utf8\" . \"utf8x\") + +will cause \\usepackage[utf8x]{inputenc} to be used for buffers that +are written as utf8 files." + :group 'org-export-latex + :type '(repeat + (cons + (string :tag "Derived from buffer") + (string :tag "Use this instead")))) + + +(defcustom org-export-latex-emphasis-alist + '(("*" "\\textbf{%s}" nil) + ("/" "\\emph{%s}" nil) + ("_" "\\underline{%s}" nil) + ("+" "\\st{%s}" nil) + ("=" "\\verb" t) + ("~" "\\verb" t)) + "Alist of LaTeX expressions to convert emphasis fontifiers. +Each element of the list is a list of three elements. +The first element is the character used as a marker for fontification. +The second element is a formatting string to wrap fontified text with. +If it is \"\\verb\", Org will automatically select a delimiter +character that is not in the string. +The third element decides whether to protect converted text from other +conversions." + :group 'org-export-latex + :type 'alist) + +(defcustom org-export-latex-title-command "\\maketitle" + "The command used to insert the title just after \\begin{document}. +If this string contains the formatting specification \"%s\" then +it will be used as a formatting string, passing the title as an +argument." + :group 'org-export-latex + :type 'string) + +(defcustom org-export-latex-import-inbuffer-stuff nil + "Non-nil means define TeX macros for Org's inbuffer definitions. +For example \orgTITLE for #+TITLE." + :group 'org-export-latex + :type 'boolean) + +(defcustom org-export-latex-date-format + "%d %B %Y" + "Format string for \\date{...}." + :group 'org-export-latex + :type 'string) + +(defcustom org-export-latex-todo-keyword-markup "\\textbf{%s}" + "Markup for TODO keywords, as a printf format. +This can be a single format for all keywords, a cons cell with separate +formats for not-done and done states, or an association list with setup +for individual keywords. If a keyword shows up for which there is no +markup defined, the first one in the association list will be used." + :group 'org-export-latex + :type '(choice + (string :tag "Default") + (cons :tag "Distinguish undone and done" + (string :tag "Not-DONE states") + (string :tag "DONE states")) + (repeat :tag "Per keyword markup" + (cons + (string :tag "Keyword") + (string :tag "Markup"))))) + +(defcustom org-export-latex-tag-markup "\\textbf{%s}" + "Markup for tags, as a printf format." + :group 'org-export-latex + :type 'string) + +(defcustom org-export-latex-timestamp-markup "\\textit{%s}" + "A printf format string to be applied to time stamps." + :group 'org-export-latex + :type 'string) + +(defcustom org-export-latex-timestamp-keyword-markup "\\texttt{%s}" + "A printf format string to be applied to time stamps." + :group 'org-export-latex + :type 'string) + +(defcustom org-export-latex-href-format "\\href{%s}{%s}" + "A printf format string to be applied to href links. +The format must contain two %s instances. The first will be filled with +the link, the second with the link description." + :group 'org-export-latex + :type 'string) + +(defcustom org-export-latex-hyperref-format "\\hyperref[%s]{%s}" + "A printf format string to be applied to hyperref links. +The format must contain two %s instances. The first will be filled with +the link, the second with the link description." + :group 'org-export-latex + :type 'string) + +(defcustom org-export-latex-tables-verbatim nil + "When non-nil, tables are exported verbatim." + :group 'org-export-latex + :type 'boolean) + +(defcustom org-export-latex-tables-centered t + "When non-nil, tables are exported in a center environment." + :group 'org-export-latex + :type 'boolean) + +(defcustom org-export-latex-tables-column-borders nil + "When non-nil, grouping columns can cause outer vertical lines in tables. +When nil, grouping causes only separation lines between groups." + :group 'org-export-latex + :type 'boolean) + +(defcustom org-export-latex-low-levels 'itemize + "How to convert sections below the current level of sectioning. +This is specified by the `org-export-headline-levels' option or the +value of \"H:\" in Org's #+OPTION line. + +This can be either nil (skip the sections), `description', `itemize', +or `enumerate' (convert the sections as the corresponding list type), or +a string to be used instead of \\section{%s}. In this latter case, +the %s stands here for the inserted headline and is mandatory. + +It may also be a list of three string to define a user-defined environment +that should be used. The first string should be the like +\"\\begin{itemize}\", the second should be like \"\\item %s %s\" with up +to two occurrences of %s for the title and a label, respectively. The third +string should be like \"\\end{itemize\"." + :group 'org-export-latex + :type '(choice (const :tag "Ignore" nil) + (const :tag "Convert as descriptive list" description) + (const :tag "Convert as itemized list" itemize) + (const :tag "Convert as enumerated list" enumerate) + (list :tag "User-defined environment" + :value ("\\begin{itemize}" "\\end{itemize}" "\\item %s") + (string :tag "Start") + (string :tag "End") + (string :tag "item")) + (string :tag "Use a section string" :value "\\subparagraph{%s}"))) + +(defcustom org-export-latex-list-parameters + '(:cbon "$\\boxtimes$" :cboff "$\\Box$") + "Parameters for the LaTeX list exporter. +These parameters will be passed on to `org-list-to-latex', which in turn +will pass them (combined with the LaTeX default list parameters) to +`org-list-to-generic'." + :group 'org-export-latex + :type 'plist) + +(defcustom org-export-latex-verbatim-wrap + '("\\begin{verbatim}\n" . "\\end{verbatim}\n") + "Environment to be wrapped around a fixed-width section in LaTeX export. +This is a cons with two strings, to be added before and after the +fixed-with text. + +Defaults to \\begin{verbatim} and \\end{verbatim}." + :group 'org-export-translation + :group 'org-export-latex + :type '(cons (string :tag "Open") + (string :tag "Close"))) + +(defcustom org-export-latex-listings nil + "Non-nil means export source code using the listings package. +This package will fontify source code, possibly even with color. +If you want to use this, you also need to make LaTeX use the +listings package, and if you want to have color, the color +package. Just add these to `org-export-latex-packages-alist', +for example using customize, or with something like + + (require 'org-latex) + (add-to-list 'org-export-latex-packages-alist '(\"\" \"listings\")) + (add-to-list 'org-export-latex-packages-alist '(\"\" \"color\")) + +Alternatively, + + (setq org-export-latex-listings 'minted) + +causes source code to be exported using the minted package as +opposed to listings. If you want to use minted, you need to add +the minted package to `org-export-latex-packages-alist', for +example using customize, or with + + (require 'org-latex) + (add-to-list 'org-export-latex-packages-alist '(\"\" \"minted\")) + +In addition, it is neccessary to install +pygments (http://pygments.org), and to configure +`org-latex-to-pdf-process' so that the -shell-escape option is +passed to pdflatex. +" + :group 'org-export-latex + :type 'boolean) + +(defcustom org-export-latex-listings-langs + '((emacs-lisp "Lisp") (lisp "Lisp") (clojure "Lisp") + (c "C") (cc "C++") + (fortran "fortran") + (perl "Perl") (cperl "Perl") (python "Python") (ruby "Ruby") + (html "HTML") (xml "XML") + (tex "TeX") (latex "TeX") + (shell-script "bash") + (gnuplot "Gnuplot") + (ocaml "Caml") (caml "Caml") + (sql "SQL") (sqlite "sql")) + "Alist mapping languages to their listing language counterpart. +The key is a symbol, the major mode symbol without the \"-mode\". +The value is the string that should be inserted as the language parameter +for the listings package. If the mode name and the listings name are +the same, the language does not need an entry in this list - but it does not +hurt if it is present." + :group 'org-export-latex + :type '(repeat + (list + (symbol :tag "Major mode ") + (string :tag "Listings language")))) + +(defcustom org-export-latex-listings-w-names t + "Non-nil means export names of named code blocks. +Code blocks exported with the listings package (controlled by the +`org-export-latex-listings' variable) can be named in the style +of noweb." + :group 'org-export-latex + :type 'boolean) + +(defcustom org-export-latex-minted-langs + '((emacs-lisp "common-lisp") + (cc "c++") + (cperl "perl") + (shell-script "bash") + (caml "ocaml")) + "Alist mapping languages to their minted language counterpart. +The key is a symbol, the major mode symbol without the \"-mode\". +The value is the string that should be inserted as the language parameter +for the minted package. If the mode name and the listings name are +the same, the language does not need an entry in this list - but it does not +hurt if it is present. + +Note that minted uses all lower case for language identifiers, +and that the full list of language identifiers can be obtained +with: +pygmentize -L lexers +" + :group 'org-export-latex + :type '(repeat + (list + (symbol :tag "Major mode ") + (string :tag "Listings language")))) + +(defcustom org-export-latex-remove-from-headlines + '(:todo nil :priority nil :tags nil) + "A plist of keywords to remove from headlines. OBSOLETE. +Non-nil means remove this keyword type from the headline. + +Don't remove the keys, just change their values. + +Obsolete, this variable is no longer used. Use the separate +variables `org-export-with-todo-keywords', `org-export-with-priority', +and `org-export-with-tags' instead." + :type 'plist + :group 'org-export-latex) + +(defcustom org-export-latex-image-default-option "width=10em" + "Default option for images." + :group 'org-export-latex + :type 'string) + +(defcustom org-export-latex-tabular-environment "tabular" + "Default environment used to build tables." + :group 'org-export-latex + :type 'string) + +(defcustom org-export-latex-inline-image-extensions + '("pdf" "jpeg" "jpg" "png" "ps" "eps") + "Extensions of image files that can be inlined into LaTeX. +Note that the image extension *actually* allowed depend on the way the +LaTeX file is processed. When used with pdflatex, pdf, jpg and png images +are OK. When processing through dvi to Postscript, only ps and eps are +allowed. The default we use here encompasses both." + :group 'org-export-latex + :type '(repeat (string :tag "Extension"))) + +(defcustom org-export-latex-coding-system nil + "Coding system for the exported LaTeX file." + :group 'org-export-latex + :type 'coding-system) + +(defgroup org-export-pdf nil + "Options for exporting Org-mode files to PDF, via LaTeX." + :tag "Org Export PDF" + :group 'org-export-latex + :group 'org-export) + +(defcustom org-latex-to-pdf-process + '("pdflatex -interaction nonstopmode -output-directory %o %f" + "pdflatex -interaction nonstopmode -output-directory %o %f" + "pdflatex -interaction nonstopmode -output-directory %o %f") + "Commands to process a LaTeX file to a PDF file. +This is a list of strings, each of them will be given to the shell +as a command. %f in the command will be replaced by the full file name, %b +by the file base name (i.e. without extension) and %o by the base directory +of the file. + +The reason why this is a list is that it usually takes several runs of +`pdflatex', maybe mixed with a call to `bibtex'. Org does not have a clever +mechanism to detect which of these commands have to be run to get to a stable +result, and it also does not do any error checking. + +By default, Org uses 3 runs of `pdflatex' to do the processing. If you +have texi2dvi on your system and if that does not cause the infamous +egrep/locale bug: + + http://lists.gnu.org/archive/html/bug-texinfo/2010-03/msg00031.html + +then `texi2dvi' is the superior choice. Org does offer it as one +of the customize options. + +Alternatively, this may be a Lisp function that does the processing, so you +could use this to apply the machinery of AUCTeX or the Emacs LaTeX mode. +This function should accept the file name as its single argument." + :group 'org-export-pdf + :type '(choice + (repeat :tag "Shell command sequence" + (string :tag "Shell command")) + (const :tag "2 runs of pdflatex" + ("pdflatex -interaction nonstopmode -output-directory %o %f" + "pdflatex -interaction nonstopmode -output-directory %o %f")) + (const :tag "3 runs of pdflatex" + ("pdflatex -interaction nonstopmode -output-directory %o %f" + "pdflatex -interaction nonstopmode -output-directory %o %f" + "pdflatex -interaction nonstopmode -output-directory %o %f")) + (const :tag "pdflatex,bibtex,pdflatex,pdflatex" + ("pdflatex -interaction nonstopmode -output-directory %o %f" + "bibtex %b" + "pdflatex -interaction nonstopmode -output-directory %o %f" + "pdflatex -interaction nonstopmode -output-directory %o %f")) + (const :tag "texi2dvi" + ("texi2dvi -p -b -c -V %f")) + (const :tag "rubber" + ("rubber -d --into %o %f")) + (function))) + +(defcustom org-export-pdf-logfiles + '("aux" "idx" "log" "out" "toc" "nav" "snm" "vrb") + "The list of file extensions to consider as LaTeX logfiles." + :group 'org-export-pdf + :type '(repeat (string :tag "Extension"))) + +(defcustom org-export-pdf-remove-logfiles t + "Non-nil means remove the logfiles produced by PDF production. +These are the .aux, .log, .out, and .toc files." + :group 'org-export-pdf + :type 'boolean) + +;;; Hooks + +(defvar org-export-latex-after-initial-vars-hook nil + "Hook run before LaTeX export. +The exact moment is after the initial variables like org-export-latex-class +have been determined from the environment.") + +(defvar org-export-latex-after-blockquotes-hook nil + "Hook run during LaTeX export, after blockquote, verse, center are done.") + +(defvar org-export-latex-final-hook nil + "Hook run in the finalized LaTeX buffer.") + +(defvar org-export-latex-after-save-hook nil + "Hook run in the finalized LaTeX buffer, after it has been saved.") + +;;; Autoload functions: + +;;;###autoload +(defun org-export-as-latex-batch () + "Call `org-export-as-latex', may be used in batch processing. +For example: + +emacs --batch + --load=$HOME/lib/emacs/org.el + --eval \"(setq org-export-headline-levels 2)\" + --visit=MyFile --funcall org-export-as-latex-batch" + (org-export-as-latex org-export-headline-levels 'hidden)) + +;;;###autoload +(defun org-export-as-latex-to-buffer (arg) + "Call `org-export-as-latex` with output to a temporary buffer. +No file is created. The prefix ARG is passed through to `org-export-as-latex'." + (interactive "P") + (org-export-as-latex arg nil nil "*Org LaTeX Export*") + (when org-export-show-temporary-export-buffer + (switch-to-buffer-other-window "*Org LaTeX Export*"))) + +;;;###autoload +(defun org-replace-region-by-latex (beg end) + "Replace the region from BEG to END with its LaTeX export. +It assumes the region has `org-mode' syntax, and then convert it to +LaTeX. This can be used in any buffer. For example, you could +write an itemized list in `org-mode' syntax in an LaTeX buffer and +then use this command to convert it." + (interactive "r") + (let (reg latex buf) + (save-window-excursion + (if (org-mode-p) + (setq latex (org-export-region-as-latex + beg end t 'string)) + (setq reg (buffer-substring beg end) + buf (get-buffer-create "*Org tmp*")) + (with-current-buffer buf + (erase-buffer) + (insert reg) + (org-mode) + (setq latex (org-export-region-as-latex + (point-min) (point-max) t 'string))) + (kill-buffer buf))) + (delete-region beg end) + (insert latex))) + +;;;###autoload +(defun org-export-region-as-latex (beg end &optional body-only buffer) + "Convert region from BEG to END in `org-mode' buffer to LaTeX. +If prefix arg BODY-ONLY is set, omit file header, footer, and table of +contents, and only produce the region of converted text, useful for +cut-and-paste operations. +If BUFFER is a buffer or a string, use/create that buffer as a target +of the converted LaTeX. If BUFFER is the symbol `string', return the +produced LaTeX as a string and leave no buffer behind. For example, +a Lisp program could call this function in the following way: + + (setq latex (org-export-region-as-latex beg end t 'string)) + +When called interactively, the output buffer is selected, and shown +in a window. A non-interactive call will only return the buffer." + (interactive "r\nP") + (when (interactive-p) + (setq buffer "*Org LaTeX Export*")) + (let ((transient-mark-mode t) (zmacs-regions t) + ext-plist rtn) + (setq ext-plist (plist-put ext-plist :ignore-subtree-p t)) + (goto-char end) + (set-mark (point)) ;; to activate the region + (goto-char beg) + (setq rtn (org-export-as-latex + nil nil ext-plist + buffer body-only)) + (if (fboundp 'deactivate-mark) (deactivate-mark)) + (if (and (interactive-p) (bufferp rtn)) + (switch-to-buffer-other-window rtn) + rtn))) + +;;;###autoload +(defun org-export-as-latex (arg &optional hidden ext-plist + to-buffer body-only pub-dir) + "Export current buffer to a LaTeX file. +If there is an active region, export only the region. The prefix +ARG specifies how many levels of the outline should become +headlines. The default is 3. Lower levels will be exported +depending on `org-export-latex-low-levels'. The default is to +convert them as description lists. +HIDDEN is obsolete and does nothing. +EXT-PLIST is a property list with +external parameters overriding org-mode's default settings, but +still inferior to file-local settings. When TO-BUFFER is +non-nil, create a buffer with that name and export to that +buffer. If TO-BUFFER is the symbol `string', don't leave any +buffer behind but just return the resulting LaTeX as a string. +When BODY-ONLY is set, don't produce the file header and footer, +simply return the content of \\begin{document}...\\end{document}, +without even the \\begin{document} and \\end{document} commands. +when PUB-DIR is set, use this as the publishing directory." + (interactive "P") + (when (and (not body-only) arg (listp arg)) (setq body-only t)) + (run-hooks 'org-export-first-hook) + + ;; Make sure we have a file name when we need it. + (when (and (not (or to-buffer body-only)) + (not buffer-file-name)) + (if (buffer-base-buffer) + (org-set-local 'buffer-file-name + (with-current-buffer (buffer-base-buffer) + buffer-file-name)) + (error "Need a file name to be able to export"))) + + (message "Exporting to LaTeX...") + (org-unmodified + (let ((inhibit-read-only t)) + (remove-text-properties (point-min) (point-max) + '(:org-license-to-kill nil)))) + (org-update-radio-target-regexp) + (org-export-latex-set-initial-vars ext-plist arg) + (setq org-export-opt-plist org-export-latex-options-plist) + (org-install-letbind) + (run-hooks 'org-export-latex-after-initial-vars-hook) + (let* ((wcf (current-window-configuration)) + (opt-plist org-export-latex-options-plist) + (region-p (org-region-active-p)) + (rbeg (and region-p (region-beginning))) + (rend (and region-p (region-end))) + (subtree-p + (if (plist-get opt-plist :ignore-subtree-p) + nil + (when region-p + (save-excursion + (goto-char rbeg) + (and (org-at-heading-p) + (>= (org-end-of-subtree t t) rend)))))) + (opt-plist (setq org-export-opt-plist + (if subtree-p + (org-export-add-subtree-options opt-plist rbeg) + opt-plist))) + ;; Make sure the variable contains the updated values. + (org-export-latex-options-plist (setq org-export-opt-plist opt-plist)) + ;; The following two are dynamically scoped into other + ;; routines below. + (org-current-export-dir + (or pub-dir (org-export-directory :html opt-plist))) + (org-current-export-file buffer-file-name) + (title (or (and subtree-p (org-export-get-title-from-subtree)) + (plist-get opt-plist :title) + (and (not + (plist-get opt-plist :skip-before-1st-heading)) + (org-export-grab-title-from-buffer)) + (and buffer-file-name + (file-name-sans-extension + (file-name-nondirectory buffer-file-name))) + "No Title")) + (filename + (and (not to-buffer) + (concat + (file-name-as-directory + (or pub-dir + (org-export-directory :LaTeX ext-plist))) + (file-name-sans-extension + (or (and subtree-p + (org-entry-get rbeg "EXPORT_FILE_NAME" t)) + (file-name-nondirectory ;sans-extension + (or buffer-file-name + (error "Don't know which export file to use"))))) + ".tex"))) + (filename + (and filename + (if (equal (file-truename filename) + (file-truename (or buffer-file-name "dummy.org"))) + (concat filename ".tex") + filename))) + (buffer (if to-buffer + (cond + ((eq to-buffer 'string) (get-buffer-create + "*Org LaTeX Export*")) + (t (get-buffer-create to-buffer))) + (find-file-noselect filename))) + (odd org-odd-levels-only) + (header (org-export-latex-make-header title opt-plist)) + (skip (cond (subtree-p nil) + (region-p nil) + (t (plist-get opt-plist :skip-before-1st-heading)))) + (text (plist-get opt-plist :text)) + (org-export-preprocess-hook + (cons + `(lambda () (org-set-local 'org-complex-heading-regexp + ,org-export-latex-complex-heading-re)) + org-export-preprocess-hook)) + (first-lines (if skip "" (org-export-latex-first-lines + opt-plist + (if subtree-p + (save-excursion + (goto-char rbeg) + (point-at-bol 2)) + rbeg) + (if region-p rend)))) + (coding-system (and (boundp 'buffer-file-coding-system) + buffer-file-coding-system)) + (coding-system-for-write (or org-export-latex-coding-system + coding-system)) + (save-buffer-coding-system (or org-export-latex-coding-system + coding-system)) + (region (buffer-substring + (if region-p (region-beginning) (point-min)) + (if region-p (region-end) (point-max)))) + (text + (and text (string-match "\\S-" text) + (org-export-preprocess-string + text + :emph-multiline t + :for-LaTeX t + :comments nil + :tags (plist-get opt-plist :tags) + :priority (plist-get opt-plist :priority) + :footnotes (plist-get opt-plist :footnotes) + :drawers (plist-get opt-plist :drawers) + :timestamps (plist-get opt-plist :timestamps) + :todo-keywords (plist-get opt-plist :todo-keywords) + :add-text nil + :skip-before-1st-heading skip + :select-tags nil + :exclude-tags nil + :LaTeX-fragments nil))) + (string-for-export + (org-export-preprocess-string + region + :emph-multiline t + :for-LaTeX t + :comments nil + :tags (plist-get opt-plist :tags) + :priority (plist-get opt-plist :priority) + :footnotes (plist-get opt-plist :footnotes) + :drawers (plist-get opt-plist :drawers) + :timestamps (plist-get opt-plist :timestamps) + :todo-keywords (plist-get opt-plist :todo-keywords) + :add-text (if (eq to-buffer 'string) nil text) + :skip-before-1st-heading skip + :select-tags (plist-get opt-plist :select-tags) + :exclude-tags (plist-get opt-plist :exclude-tags) + :LaTeX-fragments nil))) + + (set-buffer buffer) + (erase-buffer) + (org-install-letbind) + + (and (fboundp 'set-buffer-file-coding-system) + (set-buffer-file-coding-system coding-system-for-write)) + + ;; insert the header and initial document commands + (unless (or (eq to-buffer 'string) body-only) + (insert header)) + + ;; insert text found in #+TEXT + (when (and text (not (eq to-buffer 'string))) + (insert (org-export-latex-content + text '(lists tables fixed-width keywords)) + "\n\n")) + + ;; insert lines before the first headline + (unless skip + (insert first-lines)) + + ;; export the content of headlines + (org-export-latex-global + (with-temp-buffer + (insert string-for-export) + (goto-char (point-min)) + (when (re-search-forward "^\\(\\*+\\) " nil t) + (let* ((asters (length (match-string 1))) + (level (if odd (- asters 2) (- asters 1)))) + (setq org-export-latex-add-level + (if odd (1- (/ (1+ asters) 2)) (1- asters))) + (org-export-latex-parse-global level odd))))) + + ;; finalization + (unless body-only (insert "\n\\end{document}")) + + ;; Attach description terms to the \item macro + (goto-char (point-min)) + (while (re-search-forward "^[ \t]*\\\\item\\([ \t]+\\)\\[" nil t) + (delete-region (match-beginning 1) (match-end 1))) + + ;; Relocate the table of contents + (goto-char (point-min)) + (when (re-search-forward "\\[TABLE-OF-CONTENTS\\]" nil t) + (goto-char (point-min)) + (while (re-search-forward "\\\\tableofcontents\\>[ \t]*\n?" nil t) + (replace-match "")) + (goto-char (point-min)) + (and (re-search-forward "\\[TABLE-OF-CONTENTS\\]" nil t) + (replace-match "\\tableofcontents" t t))) + + ;; Cleanup forced line ends in items where they are not needed + (goto-char (point-min)) + (while (re-search-forward + "^[ \t]*\\\\item\\>.*\\(\\\\\\\\\\)[ \t]*\\(\n\\\\label.*\\)*\n\\\\begin" + nil t) + (delete-region (match-beginning 1) (match-end 1))) + (goto-char (point-min)) + (while (re-search-forward + "^[ \t]*\\\\item\\>.*\\(\\\\\\\\\\)[ \t]*\\(\n\\\\label.*\\)*" + nil t) + (if (looking-at "[\n \t]+") + (replace-match "\n"))) + + (run-hooks 'org-export-latex-final-hook) + (if to-buffer + (unless (eq major-mode 'latex-mode) (latex-mode)) + (save-buffer)) + (org-export-latex-fix-inputenc) + (run-hooks 'org-export-latex-after-save-hook) + (goto-char (point-min)) + (or (org-export-push-to-kill-ring "LaTeX") + (message "Exporting to LaTeX...done")) + (prog1 + (if (eq to-buffer 'string) + (prog1 (buffer-substring (point-min) (point-max)) + (kill-buffer (current-buffer))) + (current-buffer)) + (set-window-configuration wcf)))) + +;;;###autoload +(defun org-export-as-pdf (arg &optional hidden ext-plist + to-buffer body-only pub-dir) + "Export as LaTeX, then process through to PDF." + (interactive "P") + (message "Exporting to PDF...") + (let* ((wconfig (current-window-configuration)) + (lbuf (org-export-as-latex arg hidden ext-plist + to-buffer body-only pub-dir)) + (file (buffer-file-name lbuf)) + (base (file-name-sans-extension (buffer-file-name lbuf))) + (pdffile (concat base ".pdf")) + (cmds org-latex-to-pdf-process) + (outbuf (get-buffer-create "*Org PDF LaTeX Output*")) + (bibtex-p (with-current-buffer lbuf + (save-excursion + (goto-char (point-min)) + (re-search-forward "\\\\bibliography{" nil t)))) + cmd output-dir errors) + (with-current-buffer outbuf (erase-buffer)) + (message (concat "Processing LaTeX file " file "...")) + (setq output-dir (file-name-directory file)) + (if (and cmds (symbolp cmds)) + (funcall cmds (shell-quote-argument file)) + (while cmds + (setq cmd (pop cmds)) + (while (string-match "%b" cmd) + (setq cmd (replace-match + (save-match-data + (shell-quote-argument base)) + t t cmd))) + (while (string-match "%f" cmd) + (setq cmd (replace-match + (save-match-data + (shell-quote-argument file)) + t t cmd))) + (while (string-match "%o" cmd) + (setq cmd (replace-match + (save-match-data + (shell-quote-argument output-dir)) + t t cmd))) + (shell-command cmd outbuf))) + (message (concat "Processing LaTeX file " file "...done")) + (setq errors (org-export-latex-get-error outbuf)) + (if (not (file-exists-p pdffile)) + (error (concat "PDF file " pdffile " was not produced" + (if errors (concat ":" errors "") ""))) + (set-window-configuration wconfig) + (when org-export-pdf-remove-logfiles + (dolist (ext org-export-pdf-logfiles) + (setq file (concat base "." ext)) + (and (file-exists-p file) (delete-file file)))) + (message (concat + "Exporting to PDF...done" + (if errors + (concat ", with some errors:" errors) + ""))) + pdffile))) + +(defun org-export-latex-get-error (buf) + "Collect the kinds of errors that remain in pdflatex processing." + (with-current-buffer buf + (save-excursion + (goto-char (point-max)) + (when (re-search-backward "^[ \t]*This is pdf.*?TeX.*?Version" nil t) + ;; OK, we are at the location of the final run + (let ((pos (point)) (errors "") (case-fold-search t)) + (if (re-search-forward "Reference.*?undefined" nil t) + (setq errors (concat errors " [undefined reference]"))) + (goto-char pos) + (if (re-search-forward "Citation.*?undefined" nil t) + (setq errors (concat errors " [undefined citation]"))) + (goto-char pos) + (if (re-search-forward "Undefined control sequence" nil t) + (setq errors (concat errors " [undefined control sequence]"))) + (and (org-string-nw-p errors) errors)))))) + +;;;###autoload +(defun org-export-as-pdf-and-open (arg) + "Export as LaTeX, then process through to PDF, and open." + (interactive "P") + (let ((pdffile (org-export-as-pdf arg))) + (if pdffile + (progn + (org-open-file pdffile) + (when org-export-kill-product-buffer-when-displayed + (kill-buffer (find-buffer-visiting + (concat (file-name-sans-extension (buffer-file-name)) + ".tex"))))) + (error "PDF file was not produced")))) + +;;; Parsing functions: + +(defun org-export-latex-parse-global (level odd) + "Parse the current buffer recursively, starting at LEVEL. +If ODD is non-nil, assume the buffer only contains odd sections. +Return a list reflecting the document structure." + (save-excursion + (goto-char (point-min)) + (let* ((cnt 0) output + (depth org-export-latex-sectioning-depth)) + (while (org-re-search-forward-unprotected + (concat "^\\(\\(?:\\*\\)\\{" + (number-to-string (+ (if odd 2 1) level)) + "\\}\\) \\(.*\\)$") + ;; make sure that there is no upper heading + (when (> level 0) + (save-excursion + (save-match-data + (org-re-search-forward-unprotected + (concat "^\\(\\(?:\\*\\)\\{" + (number-to-string level) + "\\}\\) \\(.*\\)$") nil t)))) t) + (setq cnt (1+ cnt)) + (let* ((pos (match-beginning 0)) + (heading (match-string 2)) + (nlevel (if odd (/ (+ 3 level) 2) (1+ level)))) + (save-excursion + (narrow-to-region + (point) + (save-match-data + (if (org-re-search-forward-unprotected + (concat "^\\(\\(?:\\*\\)\\{" + (number-to-string (+ (if odd 2 1) level)) + "\\}\\) \\(.*\\)$") nil t) + (match-beginning 0) + (point-max)))) + (goto-char (point-min)) + (setq output + (append output + (list + (list + `(pos . ,pos) + `(level . ,nlevel) + `(occur . ,cnt) + `(heading . ,heading) + `(content . ,(org-export-latex-parse-content)) + `(subcontent . ,(org-export-latex-parse-subcontent + level odd))))))) + (widen))) + (list output)))) + +(defun org-export-latex-parse-content () + "Extract the content of a section." + (let ((beg (point)) + (end (if (org-re-search-forward-unprotected "^\\(\\*\\)+ .*$" nil t) + (progn (beginning-of-line) (point)) + (point-max)))) + (buffer-substring beg end))) + +(defun org-export-latex-parse-subcontent (level odd) + "Extract the subcontent of a section at LEVEL. +If ODD Is non-nil, assume subcontent only contains odd sections." + (if (not (org-re-search-forward-unprotected + (concat "^\\(\\(?:\\*\\)\\{" + (number-to-string (+ (if odd 4 2) level)) + "\\}\\) \\(.*\\)$") + nil t)) + nil ; subcontent is nil + (org-export-latex-parse-global (+ (if odd 2 1) level) odd))) + +;;; Rendering functions: +(defun org-export-latex-global (content) + "Export CONTENT to LaTeX. +CONTENT is an element of the list produced by +`org-export-latex-parse-global'." + (if (eq (car content) 'subcontent) + (mapc 'org-export-latex-sub (cdr content)) + (org-export-latex-sub (car content)))) + +(defun org-export-latex-sub (subcontent) + "Export the list SUBCONTENT to LaTeX. +SUBCONTENT is an alist containing information about the headline +and its content." + (let ((num (plist-get org-export-latex-options-plist :section-numbers))) + (mapc (lambda(x) (org-export-latex-subcontent x num)) subcontent))) + +(defun org-export-latex-subcontent (subcontent num) + "Export each cell of SUBCONTENT to LaTeX. +If NUM, export sections as numerical sections." + (let* ((heading (cdr (assoc 'heading subcontent))) + (level (- (cdr (assoc 'level subcontent)) + org-export-latex-add-level)) + (occur (number-to-string (cdr (assoc 'occur subcontent)))) + (content (cdr (assoc 'content subcontent))) + (subcontent (cadr (assoc 'subcontent subcontent))) + (label (org-get-text-property-any 0 'target heading)) + (label-list (cons label (cdr (assoc label + org-export-target-aliases)))) + (sectioning org-export-latex-sectioning) + (depth org-export-latex-sectioning-depth) + main-heading sub-heading) + (when (symbolp (car sectioning)) + (setq sectioning (funcall (car sectioning) level heading)) + (when sectioning + (setq heading (car sectioning) + sectioning (cdr sectioning) + ;; target property migh have changed... + label (org-get-text-property-any 0 'target heading) + label-list (cons label (cdr (assoc label + org-export-target-aliases))))) + (if sectioning (setq sectioning (make-list 10 sectioning))) + (setq depth (if sectioning 10000 0))) + (if (string-match "[ \t]*\\\\\\\\[ \t]*" heading) + (setq main-heading (substring heading 0 (match-beginning 0)) + sub-heading (substring heading (match-end 0)))) + (setq heading (org-export-latex-fontify-headline heading) + sub-heading (and sub-heading + (org-export-latex-fontify-headline sub-heading)) + main-heading (and main-heading + (org-export-latex-fontify-headline main-heading))) + (cond + ;; Normal conversion + ((<= level depth) + (let* ((sec (nth (1- level) sectioning)) + start end) + (if (consp (cdr sec)) + (setq start (nth (if num 0 2) sec) + end (nth (if num 1 3) sec)) + (setq start (if num (car sec) (cdr sec)))) + (insert (format start (if main-heading main-heading heading) + (or sub-heading ""))) + (insert "\n") + (when label + (insert (mapconcat (lambda (l) (format "\\label{%s}" l)) + label-list "\n") "\n")) + (insert (org-export-latex-content content)) + (cond ((stringp subcontent) (insert subcontent)) + ((listp subcontent) + (while (org-looking-back "\n\n") (backward-delete-char 1)) + (org-export-latex-sub subcontent))) + (when (and end (string-match "[^ \t]" end)) + (let ((hook (org-get-text-property-any 0 'org-insert-hook end))) + (and (functionp hook) (funcall hook))) + (insert end "\n")))) + ;; At a level under the hl option: we can drop this subsection + ((> level depth) + (cond ((eq org-export-latex-low-levels 'description) + (if (string-match "% ends low level$" + (buffer-substring (point-at-bol 0) (point))) + (delete-region (point-at-bol 0) (point)) + (insert "\\begin{description}\n")) + (insert (format "\n\\item[%s]%s~\n" + heading + (if label (format "\\label{%s}" label) ""))) + (insert (org-export-latex-content content)) + (cond ((stringp subcontent) (insert subcontent)) + ((listp subcontent) (org-export-latex-sub subcontent))) + (insert "\\end{description} % ends low level\n")) + ((memq org-export-latex-low-levels '(itemize enumerate)) + (if (string-match "% ends low level$" + (buffer-substring (point-at-bol 0) (point))) + (delete-region (point-at-bol 0) (point)) + (insert (format "\\begin{%s}\n" + (symbol-name org-export-latex-low-levels)))) + (insert (format "\n\\item %s\\\\\n%s%%" + heading + (if label (format "\\label{%s}" label) ""))) + (insert (org-export-latex-content content)) + (cond ((stringp subcontent) (insert subcontent)) + ((listp subcontent) (org-export-latex-sub subcontent))) + (insert (format "\\end{%s} %% ends low level\n" + (symbol-name org-export-latex-low-levels)))) + + ((listp org-export-latex-low-levels) + (if (string-match "% ends low level$" + (buffer-substring (point-at-bol 0) (point))) + (delete-region (point-at-bol 0) (point)) + (insert (car org-export-latex-low-levels) "\n")) + (insert (format (nth 2 org-export-latex-low-levels) + heading + (if label (format "\\label{%s}" label) ""))) + (insert (org-export-latex-content content)) + (cond ((stringp subcontent) (insert subcontent)) + ((listp subcontent) (org-export-latex-sub subcontent))) + (insert (nth 1 org-export-latex-low-levels) + " %% ends low level\n")) + + ((stringp org-export-latex-low-levels) + (insert (format org-export-latex-low-levels heading) "\n") + (when label (insert (format "\\label{%s}\n" label))) + (insert (org-export-latex-content content)) + (cond ((stringp subcontent) (insert subcontent)) + ((listp subcontent) (org-export-latex-sub subcontent))))))))) + +;;; Exporting internals: +(defun org-export-latex-set-initial-vars (ext-plist level) + "Store org local variables required for LaTeX export. +EXT-PLIST is an optional additional plist. +LEVEL indicates the default depth for export." + (setq org-export-latex-todo-keywords-1 org-todo-keywords-1 + org-export-latex-done-keywords org-done-keywords + org-export-latex-not-done-keywords org-not-done-keywords + org-export-latex-complex-heading-re org-complex-heading-regexp + org-export-latex-display-custom-times org-display-custom-times + org-export-latex-all-targets-re + (org-make-target-link-regexp (org-all-targets)) + org-export-latex-options-plist + (org-combine-plists (org-default-export-plist) ext-plist + (org-infile-export-plist)) + org-export-latex-class + (or (and (org-region-active-p) + (save-excursion + (goto-char (region-beginning)) + (and (looking-at org-complex-heading-regexp) + (org-entry-get nil "LaTeX_CLASS" 'selective)))) + (save-excursion + (save-restriction + (widen) + (goto-char (point-min)) + (and (re-search-forward "^#\\+LaTeX_CLASS:[ \t]*\\(-[a-zA-Z]+\\)" nil t) + (match-string 1)))) + (plist-get org-export-latex-options-plist :latex-class) + org-export-latex-default-class) + org-export-latex-class-options + (or (and (org-region-active-p) + (save-excursion + (goto-char (region-beginning)) + (and (looking-at org-complex-heading-regexp) + (org-entry-get nil "LaTeX_CLASS_OPTIONS" 'selective)))) + (save-excursion + (save-restriction + (widen) + (goto-char (point-min)) + (and (re-search-forward "^#\\+LaTeX_CLASS_OPTIONS:[ \t]*\\(.*?\\)[ \t]*$" nil t) + (match-string 1)))) + (plist-get org-export-latex-options-plist :latex-class-options)) + org-export-latex-class + (or (car (assoc org-export-latex-class org-export-latex-classes)) + (error "No definition for class `%s' in `org-export-latex-classes'" + org-export-latex-class)) + org-export-latex-header + (cadr (assoc org-export-latex-class org-export-latex-classes)) + org-export-latex-sectioning + (cddr (assoc org-export-latex-class org-export-latex-classes)) + org-export-latex-sectioning-depth + (or level + (let ((hl-levels + (plist-get org-export-latex-options-plist :headline-levels)) + (sec-depth (length org-export-latex-sectioning))) + (if (> hl-levels sec-depth) sec-depth hl-levels)))) + (when (and org-export-latex-class-options + (string-match "\\S-" org-export-latex-class-options) + (string-match "^[ \t]*\\(\\\\documentclass\\)\\(\\[.*?\\]\\)?" + org-export-latex-header)) + (setq org-export-latex-header + (concat (substring org-export-latex-header 0 (match-end 1)) + org-export-latex-class-options + (substring org-export-latex-header (match-end 0)))))) + +(defvar org-export-latex-format-toc-function + 'org-export-latex-format-toc-default + "The function formatting returning the string to create the table of contents. +The function mus take one parameter, the depth of the table of contents.") + +(defun org-export-latex-make-header (title opt-plist) + "Make the LaTeX header and return it as a string. +TITLE is the current title from the buffer or region. +OPT-PLIST is the options plist for current buffer." + (let ((toc (plist-get opt-plist :table-of-contents)) + (author (org-export-apply-macros-in-string + (plist-get opt-plist :author)))) + (concat + (if (plist-get opt-plist :time-stamp-file) + (format-time-string "%% Created %Y-%m-%d %a %H:%M\n")) + ;; insert LaTeX custom header and packages from the list + (org-splice-latex-header + (org-export-apply-macros-in-string org-export-latex-header) + org-export-latex-default-packages-alist + org-export-latex-packages-alist nil + (org-export-apply-macros-in-string + (plist-get opt-plist :latex-header-extra))) + ;; append another special variable + (org-export-apply-macros-in-string org-export-latex-append-header) + ;; define alert if not yet defined + "\n\\providecommand{\\alert}[1]{\\textbf{#1}}" + ;; beginning of the document + "\n\\begin{document}\n\n" + ;; insert the title + (format + "\n\n\\title{%s}\n" + ;; convert the title + (org-export-latex-fontify-headline title)) + ;; insert author info + (if (plist-get opt-plist :author-info) + (format "\\author{%s}\n" + (org-export-latex-fontify-headline (or author user-full-name))) + (format "%%\\author{%s}\n" + (org-export-latex-fontify-headline (or author user-full-name)))) + ;; insert the date + (format "\\date{%s}\n" + (format-time-string + (or (plist-get opt-plist :date) + org-export-latex-date-format))) + ;; insert the title command + (when (string-match "\\S-" title) + (if (string-match "%s" org-export-latex-title-command) + (format org-export-latex-title-command title) + org-export-latex-title-command)) + "\n\n" + ;; table of contents + (when (and org-export-with-toc + (plist-get opt-plist :section-numbers)) + (funcall org-export-latex-format-toc-function + (cond ((numberp toc) + (min toc (plist-get opt-plist :headline-levels))) + (toc (plist-get opt-plist :headline-levels)))))))) + +(defun org-export-latex-format-toc-default (depth) + (when depth + (format "\\setcounter{tocdepth}{%s}\n\\tableofcontents\n\\vspace*{1cm}\n" + depth))) + +(defun org-export-latex-first-lines (opt-plist &optional beg end) + "Export the first lines before first headline. +If BEG is non-nil, it is the beginning of the region. +If END is non-nil, it is the end of the region." + (save-excursion + (goto-char (or beg (point-min))) + (let* ((pt (point)) + (end (if (re-search-forward (org-get-limited-outline-regexp) end t) + (goto-char (match-beginning 0)) + (goto-char (or end (point-max)))))) + (prog1 + (org-export-latex-content + (org-export-preprocess-string + (buffer-substring pt end) + :for-LaTeX t + :emph-multiline t + :add-text nil + :comments nil + :skip-before-1st-heading nil + :LaTeX-fragments nil + :timestamps (plist-get opt-plist :timestamps) + :footnotes (plist-get opt-plist :footnotes))) + (org-unmodified + (let ((inhibit-read-only t) + (limit (max pt (1- end)))) + (add-text-properties pt limit + '(:org-license-to-kill t)) + (save-excursion + (goto-char pt) + (while (re-search-forward "^[ \t]*#\\+.*\n?" limit t) + (let ((case-fold-search t)) + (unless (org-string-match-p + "^[ \t]*#\\+\\(attr_\\|caption\\>\\|label\\>\\)" + (match-string 0)) + (remove-text-properties (match-beginning 0) (match-end 0) + '(:org-license-to-kill t)))))))))))) + + +(defvar org-export-latex-header-defs nil + "The header definitions that might be used in the LaTeX body.") +(defvar org-export-latex-header-defs-re nil + "The header definitions that might be used in the LaTeX body.") + +(defun org-export-latex-content (content &optional exclude-list) + "Convert CONTENT string to LaTeX. +Don't perform conversions that are in EXCLUDE-LIST. Recognized +conversion types are: quotation-marks, emphasis, sub-superscript, +links, keywords, lists, tables, fixed-width" + (with-temp-buffer + (insert content) + (unless (memq 'timestamps exclude-list) + (org-export-latex-time-stamps)) + (unless (memq 'quotation-marks exclude-list) + (org-export-latex-quotation-marks)) + (unless (memq 'emphasis exclude-list) + (when (plist-get org-export-latex-options-plist :emphasize) + (org-export-latex-fontify))) + (unless (memq 'sub-superscript exclude-list) + (org-export-latex-special-chars + (plist-get org-export-latex-options-plist :sub-superscript))) + (unless (memq 'links exclude-list) + (org-export-latex-links)) + (unless (memq 'keywords exclude-list) + (org-export-latex-keywords)) + (unless (memq 'lists exclude-list) + (org-export-latex-lists)) + (unless (memq 'tables exclude-list) + (org-export-latex-tables + (plist-get org-export-latex-options-plist :tables))) + (unless (memq 'fixed-width exclude-list) + (org-export-latex-fixed-width + (plist-get org-export-latex-options-plist :fixed-width))) + ;; return string + (buffer-substring (point-min) (point-max)))) + +(defun org-export-latex-protect-string (s) + "Add the org-protected property to string S." + (add-text-properties 0 (length s) '(org-protected t) s) s) + +(defun org-export-latex-protect-char-in-string (char-list string) + "Add org-protected text-property to char from CHAR-LIST in STRING." + (with-temp-buffer + (save-match-data + (insert string) + (goto-char (point-min)) + (while (re-search-forward (regexp-opt char-list) nil t) + (add-text-properties (match-beginning 0) + (match-end 0) '(org-protected t))) + (buffer-string)))) + +(defun org-export-latex-keywords-maybe (&optional remove-list) + "Maybe remove keywords depending on rules in REMOVE-LIST." + (goto-char (point-min)) + (let ((re-todo (mapconcat 'identity org-export-latex-todo-keywords-1 "\\|")) + (case-fold-search nil) + (todo-markup org-export-latex-todo-keyword-markup) + fmt) + ;; convert TODO keywords + (when (re-search-forward (concat "^\\(" re-todo "\\)") nil t) + (if (plist-get remove-list :todo) + (replace-match "") + (setq fmt (cond + ((stringp todo-markup) todo-markup) + ((and (consp todo-markup) (stringp (car todo-markup))) + (if (member (match-string 1) org-export-latex-done-keywords) + (cdr todo-markup) (car todo-markup))) + (t (cdr (or (assoc (match-string 1) todo-markup) + (car todo-markup)))))) + (replace-match (org-export-latex-protect-string + (format fmt (match-string 1))) t t))) + ;; convert priority string + (when (re-search-forward "\\[\\\\#.\\]" nil t) + (if (plist-get remove-list :priority) + (replace-match "") + (replace-match (format "\\textbf{%s}" (match-string 0)) t t))) + ;; convert tags + (when (re-search-forward "\\(:[a-zA-Z0-9_@#%]+\\)+:" nil t) + (if (or (not org-export-with-tags) + (plist-get remove-list :tags)) + (replace-match "") + (replace-match + (org-export-latex-protect-string + (format org-export-latex-tag-markup + (save-match-data + (replace-regexp-in-string + "_" "\\\\_" (match-string 0))))) + t t))))) + +(defun org-export-latex-fontify-headline (string) + "Fontify special words in STRING." + (with-temp-buffer + ;; FIXME: org-inside-LaTeX-fragment-p doesn't work when the $...$ is at + ;; the beginning of the buffer - inserting "\n" is safe here though. + (insert "\n" string) + + ;; Preserve math snippets + + (let* ((matchers (plist-get org-format-latex-options :matchers)) + (re-list org-latex-regexps) + beg end re e m n block off) + ;; Check the different regular expressions + (while (setq e (pop re-list)) + (setq m (car e) re (nth 1 e) n (nth 2 e) + block (if (nth 3 e) "\n\n" "")) + (setq off (if (member m '("$" "$1")) 1 0)) + (when (and (member m matchers) (not (equal m "begin"))) + (goto-char (point-min)) + (while (re-search-forward re nil t) + (setq beg (+ (match-beginning 0) off) end (- (match-end 0) 0)) + (add-text-properties beg end + '(org-protected t org-latex-math t)))))) + + ;; Convert LaTeX to \LaTeX{} and TeX to \TeX{} + (goto-char (point-min)) + (let ((case-fold-search nil)) + (while (re-search-forward "\\<\\(\\(La\\)?TeX\\)\\>" nil t) + (unless (eq (char-before (match-beginning 1)) ?\\) + (org-if-unprotected-1 + (replace-match (org-export-latex-protect-string + (concat "\\" (match-string 1) + "{}")) t t))))) + (goto-char (point-min)) + (let ((re (concat "\\\\\\([a-zA-Z]+\\)" + "\\(?:<[^<>\n]*>\\)*" + "\\(?:\\[[^][\n]*?\\]\\)*" + "\\(?:<[^<>\n]*>\\)*" + "\\(" + (org-create-multibrace-regexp "{" "}" 3) + "\\)\\{1,3\\}"))) + (while (re-search-forward re nil t) + (unless (or + ;; check for comment line + (save-excursion (goto-char (match-beginning 0)) + (org-in-indented-comment-line)) + ;; Check if this is a defined entity, so that is may need conversion + (org-entity-get (match-string 1))) + (add-text-properties (match-beginning 0) (match-end 0) + '(org-protected t))))) + (when (plist-get org-export-latex-options-plist :emphasize) + (org-export-latex-fontify)) + (org-export-latex-keywords-maybe) + (org-export-latex-special-chars + (plist-get org-export-latex-options-plist :sub-superscript)) + (org-export-latex-links) + (org-trim (buffer-string)))) + +(defun org-export-latex-time-stamps () + "Format time stamps." + (goto-char (point-min)) + (let ((org-display-custom-times org-export-latex-display-custom-times)) + (while (re-search-forward org-ts-regexp-both nil t) + (org-if-unprotected-at (1- (point)) + (replace-match + (org-export-latex-protect-string + (format org-export-latex-timestamp-markup + (substring (org-translate-time (match-string 0)) 1 -1))) + t t))))) + +(defun org-export-latex-quotation-marks () + "Export quotation marks depending on language conventions." + (let* ((lang (plist-get org-export-latex-options-plist :language)) + (quote-rpl (if (equal lang "fr") + '(("\\(\\s-\\)\"" "«~") + ("\\(\\S-\\)\"" "~»") + ("\\(\\s-\\)'" "`")) + '(("\\(\\s-\\|[[(]\\)\"" "``") + ("\\(\\S-\\)\"" "''") + ("\\(\\s-\\|(\\)'" "`"))))) + (mapc (lambda(l) (goto-char (point-min)) + (while (re-search-forward (car l) nil t) + (let ((rpl (concat (match-string 1) + (org-export-latex-protect-string + (copy-sequence (cadr l)))))) + (org-if-unprotected-1 + (replace-match rpl t t))))) quote-rpl))) + +(defun org-export-latex-special-chars (sub-superscript) + "Export special characters to LaTeX. +If SUB-SUPERSCRIPT is non-nil, convert \\ and ^. +See the `org-export-latex.el' code for a complete conversion table." + (goto-char (point-min)) + (mapc (lambda(c) + (goto-char (point-min)) + (while (re-search-forward c nil t) + ;; Put the point where to check for org-protected + (unless (get-text-property (match-beginning 2) 'org-protected) + (cond ((member (match-string 2) '("\\$" "$")) + (if (equal (match-string 2) "\\$") + nil + (replace-match "\\$" t t))) + ((member (match-string 2) '("&" "%" "#")) + (if (equal (match-string 1) "\\") + (replace-match (match-string 2) t t) + (replace-match (concat (match-string 1) "\\" + (match-string 2)) t t) + (backward-char 1))) + ((equal (match-string 2) "...") + (replace-match + (concat (match-string 1) + (org-export-latex-protect-string "\\ldots{}")) t t)) + ((equal (match-string 2) "~") + (cond ((equal (match-string 1) "\\") nil) + ((eq 'org-link (get-text-property 0 'face (match-string 2))) + (replace-match (concat (match-string 1) "\\~") t t)) + (t (replace-match + (org-export-latex-protect-string + (concat (match-string 1) "\\~{}")) t t)))) + ((member (match-string 2) '("{" "}")) + (unless (save-match-data (org-inside-latex-math-p)) + (if (equal (match-string 1) "\\") + (replace-match (match-string 2) t t) + (replace-match (concat (match-string 1) "\\" + (match-string 2)) t t))))) + (unless (save-match-data (org-inside-latex-math-p)) + (cond ((equal (match-string 2) "\\") + (replace-match (or (save-match-data + (org-export-latex-treat-backslash-char + (match-string 1) + (or (match-string 3) ""))) + "") t t) + (when (and (get-text-property (1- (point)) 'org-entity) + (looking-at "{}")) + ;; OK, this was an entity replacement, and the user + ;; had terminated the entity with {}. Make sure + ;; {} is protected as well, and remove the extra {} + ;; inserted by the conversion. + (put-text-property (point) (+ 2 (point)) 'org-protected t) + (if (save-excursion (goto-char (max (- (point) 2) (point-min))) + (looking-at "{}")) + (replace-match "")) + (forward-char 2)) + (backward-char 1)) + ((member (match-string 2) '("_" "^")) + (replace-match (or (save-match-data + (org-export-latex-treat-sub-super-char + sub-superscript + (match-string 2) + (match-string 1) + (match-string 3))) "") t t) + (backward-char 1))))))) + '(;"^\\([^\n$]*?\\|^\\)\\(\\\\?\\$\\)\\([^\n$]*\\)$" + "\\(\\(\\\\?\\$\\)\\)" + "\\([a-zA-Z0-9()]+\\|[ \t\n]\\|\\b\\|\\\\\\)\\(_\\|\\^\\)\\({[^{}]+}\\|[a-zA-Z0-9]+\\|[ \t\n]\\|[:punct:]\\|)\\|{[a-zA-Z0-9]+}\\|([a-zA-Z0-9]+)\\)" + "\\(.\\|^\\)\\(\\\\\\)\\([ \t\n]\\|\\([&#%{}\"]\\|[a-zA-Z][a-zA-Z0-9]*\\)\\)" + "\\(.\\|^\\)\\(&\\)" + "\\(.\\|^\\)\\(#\\)" + "\\(.\\|^\\)\\(%\\)" + "\\(.\\|^\\)\\({\\)" + "\\(.\\|^\\)\\(}\\)" + "\\(.\\|^\\)\\(~\\)" + "\\(.\\|^\\)\\(\\.\\.\\.\\)" + ;; (?\< . "\\textless{}") + ;; (?\> . "\\textgreater{}") + ))) + +(defun org-inside-latex-math-p () + (get-text-property (point) 'org-latex-math)) + +(defun org-export-latex-treat-sub-super-char + (subsup char string-before string-after) + "Convert the \"_\" and \"^\" characters to LaTeX. +SUBSUP corresponds to the ^: option in the #+OPTIONS line. +Convert CHAR depending on STRING-BEFORE and STRING-AFTER." + (cond ((equal string-before "\\") + (concat string-before char string-after)) + ((and (string-match "\\S-+" string-after)) + ;; this is part of a math formula + (cond ((eq 'org-link (get-text-property 0 'face char)) + (concat string-before "\\" char string-after)) + ((save-match-data (org-inside-latex-math-p)) + (if subsup + (cond ((eq 1 (length string-after)) + (concat string-before char string-after)) + ((string-match "[({]?\\([^)}]+\\)[)}]?" string-after) + (format "%s%s{%s}" string-before char + (match-string 1 string-after)))))) + ((and (> (length string-after) 1) + (or (eq subsup t) + (and (equal subsup '{}) (eq (string-to-char string-after) ?\{))) + (or (string-match "[{]?\\([^}]+\\)[}]?" string-after) + (string-match "[(]?\\([^)]+\\)[)]?" string-after))) + + (org-export-latex-protect-string + (format "%s$%s{%s}$" string-before char + (if (and (> (match-end 1) (1+ (match-beginning 1))) + (not (equal (substring string-after 0 2) "{\\"))) + (concat "\\mathrm{" (match-string 1 string-after) "}") + (match-string 1 string-after))))) + ((eq subsup t) (concat string-before "$" char string-after "$")) + (t (org-export-latex-protect-string + (concat string-before "\\" char "{}" string-after))))) + (t (org-export-latex-protect-string + (concat string-before "\\" char "{}" string-after))))) + +(defun org-export-latex-treat-backslash-char (string-before string-after) + "Convert the \"$\" special character to LaTeX. +The conversion is made depending of STRING-BEFORE and STRING-AFTER." + (let ((ass (org-entity-get string-after))) + (cond + (ass (org-add-props + (if (nth 2 ass) + (concat string-before + (org-export-latex-protect-string + (concat "$" (nth 1 ass) "$"))) + (concat string-before (org-export-latex-protect-string + (nth 1 ass)))) + nil 'org-entity t)) + ((and (not (string-match "^[ \n\t]" string-after)) + (not (string-match "[ \t]\\'\\|^" string-before))) + ;; backslash is inside a word + (concat string-before + (org-export-latex-protect-string + (concat "\\textbackslash{}" string-after)))) + ((not (or (equal string-after "") + (string-match "^[ \t\n]" string-after))) + ;; backslash might escape a character (like \#) or a user TeX + ;; macro (like \setcounter) + (concat string-before + (org-export-latex-protect-string (concat "\\" string-after)))) + ((and (string-match "^[ \t\n]" string-after) + (string-match "[ \t\n]\\'" string-before)) + ;; backslash is alone, convert it to $\backslash$ + (org-export-latex-protect-string + (concat string-before "\\textbackslash{}" string-after))) + (t (org-export-latex-protect-string + (concat string-before "\\textbackslash{}" string-after)))))) + +(defun org-export-latex-keywords () + "Convert special keywords to LaTeX." + (goto-char (point-min)) + (while (re-search-forward org-export-latex-special-keyword-regexp nil t) + (replace-match (format org-export-latex-timestamp-keyword-markup + (match-string 0)) t t) + (save-excursion + (beginning-of-line 1) + (unless (looking-at ".*\n[ \t]*\n") + (end-of-line 1) + (insert "\n"))))) + +(defun org-export-latex-fixed-width (opt) + "When OPT is non-nil convert fixed-width sections to LaTeX." + (goto-char (point-min)) + (while (re-search-forward "^[ \t]*:\\([ \t]\\|$\\)" nil t) + (unless (get-text-property (point) 'org-example) + (if opt + (progn (goto-char (match-beginning 0)) + (insert "\\begin{verbatim}\n") + (while (looking-at "^\\([ \t]*\\):\\(\\([ \t]\\|$\\).*\\)$") + (replace-match (concat (match-string 1) + (match-string 2)) t t) + (forward-line)) + (insert "\\end{verbatim}\n\n")) + (progn (goto-char (match-beginning 0)) + (while (looking-at "^\\([ \t]*\\):\\(\\([ \t]\\|$\\).*\\)$") + (replace-match (concat "%" (match-string 1) + (match-string 2)) t t) + (forward-line))))))) + +(defvar org-table-last-alignment) ; defined in org-table.el +(defvar org-table-last-column-widths) ; defined in org-table.el +(declare-function orgtbl-to-latex "org-table" (table params) t) +(defun org-export-latex-tables (insert) + "Convert tables to LaTeX and INSERT it." + ;; First, get the table.el tables + (goto-char (point-min)) + (while (re-search-forward "^[ \t]*\\(\\+-[-+]*\\+\\)[ \t]*\n[ \t]*|" nil t) + (org-if-unprotected + (require 'table) + (org-export-latex-convert-table.el-table))) + + ;; And now the Org-mode tables + (goto-char (point-min)) + (while (re-search-forward "^\\([ \t]*\\)|" nil t) + (org-if-unprotected-at (1- (point)) + (org-table-align) + (let* ((beg (org-table-begin)) + (end (org-table-end)) + (raw-table (buffer-substring beg end)) + (org-table-last-alignment (copy-sequence org-table-last-alignment)) + (org-table-last-column-widths (copy-sequence + org-table-last-column-widths)) + fnum fields line lines olines gr colgropen line-fmt align + caption shortn label attr floatp placement longtblp) + (if org-export-latex-tables-verbatim + (let* ((tbl (concat "\\begin{verbatim}\n" raw-table + "\\end{verbatim}\n"))) + (apply 'delete-region (list beg end)) + (insert (org-export-latex-protect-string tbl))) + (progn + (setq caption (org-find-text-property-in-string + 'org-caption raw-table) + shortn (org-find-text-property-in-string + 'org-caption-shortn raw-table) + attr (org-find-text-property-in-string + 'org-attributes raw-table) + label (org-find-text-property-in-string + 'org-label raw-table) + longtblp (and attr (stringp attr) + (string-match "\\<longtable\\>" attr)) + align (and attr (stringp attr) + (string-match "\\<align=\\([^ \t\n\r]+\\)" attr) + (match-string 1 attr)) + floatp (or caption label) + placement (if (and attr + (stringp attr) + (string-match "[ \t]*\\<placement=\\(\\S-+\\)" attr)) + (match-string 1 attr) + "[htb]")) + (setq caption (and caption (org-export-latex-fontify-headline caption))) + (setq lines (org-split-string raw-table "\n")) + (apply 'delete-region (list beg end)) + (when org-export-table-remove-special-lines + (setq lines (org-table-clean-before-export lines 'maybe-quoted))) + (when org-table-clean-did-remove-column + (pop org-table-last-alignment) + (pop org-table-last-column-widths)) + ;; make a formatting string to reflect alignment + (setq olines lines) + (while (and (not line-fmt) (setq line (pop olines))) + (unless (string-match "^[ \t]*|-" line) + (setq fields (org-split-string line "[ \t]*|[ \t]*")) + (setq fnum (make-vector (length fields) 0)) + (setq line-fmt + (mapconcat + (lambda (x) + (setq gr (pop org-table-colgroup-info)) + (format "%s%%s%s" + (cond ((eq gr :start) + (prog1 (if colgropen "|" "|") + (setq colgropen t))) + ((eq gr :startend) + (prog1 (if colgropen "|" "|") + (setq colgropen nil))) + (t "")) + (if (memq gr '(:end :startend)) + (progn (setq colgropen nil) "|") + ""))) + fnum "")))) + ;; fix double || in line-fmt + (setq line-fmt (replace-regexp-in-string "||" "|" line-fmt)) + ;; maybe remove the first and last "|" + (when (and (not org-export-latex-tables-column-borders) + (string-match "^\\(|\\)?\\(.+\\)|$" line-fmt)) + (setq line-fmt (match-string 2 line-fmt))) + ;; format alignment + (unless align + (setq align (apply 'format + (cons line-fmt + (mapcar (lambda (x) (if x "r" "l")) + org-table-last-alignment))))) + ;; prepare the table to send to orgtbl-to-latex + (setq lines + (mapcar + (lambda(elem) + (or (and (string-match "[ \t]*|-+" elem) 'hline) + (org-split-string (org-trim elem) "|"))) + lines)) + (when insert + (insert (org-export-latex-protect-string + (concat + (if longtblp + (concat "\\begin{longtable}{" align "}\n") + (if floatp (format "\\begin{table}%s\n" placement))) + (if floatp + (format + "\\caption%s{%s} %s" + (if shortn (concat "[" shortn "]") "") + (or caption "") + (if label (format "\\label{%s}" label) ""))) + (if (and longtblp caption) "\\\\\n" "\n") + (if (and org-export-latex-tables-centered (not longtblp)) + "\\begin{center}\n") + (if (not longtblp) + (format "\\begin{%s}{%s}\n" + org-export-latex-tabular-environment align)) + (orgtbl-to-latex + lines + `(:tstart nil :tend nil + :hlend ,(if longtblp + (format "\\\\ +\\hline +\\endhead +\\hline\\multicolumn{%d}{r}{Continued on next page}\\ +\\endfoot +\\endlastfoot" (length org-table-last-alignment)) + nil))) + (if (not longtblp) + (format "\n\\end{%s}" + org-export-latex-tabular-environment)) + (if longtblp "\n" (if org-export-latex-tables-centered + "\n\\end{center}\n" "\n")) + (if longtblp + "\\end{longtable}" + (if floatp "\\end{table}")))) + "\n\n")))))))) + +(defun org-export-latex-convert-table.el-table () + "Replace table.el table at point with LaTeX code." + (let (tbl caption shortn label line floatp attr align rmlines) + (setq line (buffer-substring (point-at-bol) (point-at-eol)) + label (org-get-text-property-any 0 'org-label line) + caption (org-get-text-property-any 0 'org-caption line) + shortn (org-get-text-property-any 0 'org-caption-shortn line) + attr (org-get-text-property-any 0 'org-attributes line) + align (and attr (stringp attr) + (string-match "\\<align=\\([^ \t\n\r,]+\\)" attr) + (match-string 1 attr)) + rmlines (and attr (stringp attr) + (string-match "\\<rmlines\\>" attr)) + floatp (or label caption)) + (and (get-buffer "*org-export-table*") + (kill-buffer (get-buffer "*org-export-table*"))) + (table-generate-source 'latex "*org-export-table*" "caption") + (setq tbl (with-current-buffer "*org-export-table*" + (buffer-string))) + (while (string-match "^%.*\n" tbl) + (setq tbl (replace-match "" t t tbl))) + ;; fix the hlines + (when rmlines + (let ((n 0) lines) + (setq lines (mapcar (lambda (x) + (if (string-match "^\\\\hline$" x) + (progn + (setq n (1+ n)) + (if (= n 2) x nil)) + x)) + (org-split-string tbl "\n"))) + (setq tbl (mapconcat 'identity (delq nil lines) "\n")))) + (when (and align (string-match "\\\\begin{tabular}{.*}" tbl)) + (setq tbl (replace-match (concat "\\begin{tabular}{" align "}") + t t tbl))) + (and (get-buffer "*org-export-table*") + (kill-buffer (get-buffer "*org-export-table*"))) + (beginning-of-line 0) + (while (looking-at "[ \t]*\\(|\\|\\+-\\)") + (delete-region (point) (1+ (point-at-eol)))) + (when org-export-latex-tables-centered + (setq tbl (concat "\\begin{center}\n" tbl "\\end{center}"))) + (when floatp + (setq tbl (concat "\\begin{table}\n" + (format "\\caption%s{%s}%s\n" + (if shortn (format "[%s]" shortn) "") + (if label (format "\\label{%s}" label) "") + (or caption "")) + tbl + "\n\\end{table}\n"))) + (insert (org-export-latex-protect-string tbl)))) + +(defun org-export-latex-fontify () + "Convert fontification to LaTeX." + (goto-char (point-min)) + (while (re-search-forward org-emph-re nil t) + ;; The match goes one char after the *string*, except at the end of a line + (let ((emph (assoc (match-string 3) + org-export-latex-emphasis-alist)) + (beg (match-beginning 0)) + (end (match-end 0)) + rpl s) + (unless emph + (message "`org-export-latex-emphasis-alist' has no entry for formatting triggered by \"%s\"" + (match-string 3))) + (unless (or (and (get-text-property (- (point) 2) 'org-protected) + (not (get-text-property + (- (point) 2) 'org-verbatim-emph))) + (equal (char-after (match-beginning 3)) + (char-after (1+ (match-beginning 3)))) + (save-excursion + (goto-char (match-beginning 1)) + (save-match-data + (and (org-at-table-p) + (string-match + "[|\n]" (buffer-substring beg end))))) + (and (equal (match-string 3) "+") + (save-match-data + (string-match "\\`-+\\'" (match-string 4))))) + (setq s (match-string 4)) + (setq rpl (concat (match-string 1) + (org-export-latex-emph-format (cadr emph) + (match-string 4)) + (match-string 5))) + (if (caddr emph) + (setq rpl (org-export-latex-protect-string rpl)) + (save-match-data + (if (string-match "\\`.?\\(\\\\[a-z]+{\\)\\(.*\\)\\(}\\).?\\'" rpl) + (progn + (add-text-properties (match-beginning 1) (match-end 1) + '(org-protected t) rpl) + (add-text-properties (match-beginning 3) (match-end 3) + '(org-protected t) rpl))))) + (replace-match rpl t t))) + (backward-char))) + +(defvar org-export-latex-use-verb nil) +(defun org-export-latex-emph-format (format string) + "Format an emphasis string and handle the \\verb special case." + (when (equal format "\\verb") + (save-match-data + (if org-export-latex-use-verb + (let ((ll "~,./?;':\"|!@#%^&-_=+abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ<>()[]{}")) + (catch 'exit + (loop for i from 0 to (1- (length ll)) do + (if (not (string-match (regexp-quote (substring ll i (1+ i))) + string)) + (progn + (setq format (concat "\\verb" (substring ll i (1+ i)) + "%s" (substring ll i (1+ i)))) + (throw 'exit nil)))))) + (let ((start 0) + (trans '(("\\" . "\\textbackslash{}") + ("~" . "\\textasciitilde{}") + ("^" . "\\textasciicircum{}"))) + (rtn "") char) + (while (string-match "[\\{}$%&_#~^]" string) + (setq char (match-string 0 string)) + (if (> (match-beginning 0) 0) + (setq rtn (concat rtn (substring string + 0 (match-beginning 0))))) + (setq string (substring string (1+ (match-beginning 0)))) + (setq char (or (cdr (assoc char trans)) (concat "\\" char)) + rtn (concat rtn char))) + (setq string (concat rtn string) format "\\texttt{%s}"))))) + (format format string)) + +(defun org-export-latex-links () + ;; Make sure to use the LaTeX hyperref and graphicx package + ;; or send some warnings. + "Convert links to LaTeX." + (goto-char (point-min)) + (while (re-search-forward org-bracket-link-analytic-regexp++ nil t) + (org-if-unprotected-1 + (goto-char (match-beginning 0)) + (let* ((re-radio org-export-latex-all-targets-re) + (remove (list (match-beginning 0) (match-end 0))) + (raw-path (org-extract-attributes (match-string 3))) + (full-raw-path (concat (match-string 1) raw-path)) + (desc (match-string 5)) + (type (or (match-string 2) + (if (or (file-name-absolute-p raw-path) + (string-match "^\\.\\.?/" raw-path)) + "file"))) + (coderefp (equal type "coderef")) + (caption (org-find-text-property-in-string 'org-caption raw-path)) + (shortn (org-find-text-property-in-string 'org-caption-shortn raw-path)) + (attr (or (org-find-text-property-in-string 'org-attributes raw-path) + (plist-get org-export-latex-options-plist :latex-image-options))) + (label (org-find-text-property-in-string 'org-label raw-path)) + imgp radiop fnc + ;; define the path of the link + (path (cond + ((member type '("coderef")) + raw-path) + ((member type '("http" "https" "ftp")) + (concat type ":" raw-path)) + ((and re-radio (string-match re-radio raw-path)) + (setq radiop t)) + ((equal type "mailto") + (concat type ":" raw-path)) + ((equal type "file") + (if (and (org-file-image-p + (expand-file-name + raw-path) + org-export-latex-inline-image-extensions) + (or (get-text-property 0 'org-no-description + raw-path) + (equal desc full-raw-path))) + (setq imgp t) + (progn (when (string-match "\\(.+\\)::.+" raw-path) + (setq raw-path (match-string 1 raw-path))) + (if (file-exists-p raw-path) + (concat type "://" (expand-file-name raw-path)) + (concat type "://" (org-export-directory + :LaTeX org-export-latex-options-plist) + raw-path)))))))) + ;; process with link inserting + (apply 'delete-region remove) + (setq caption (and caption (org-export-latex-fontify-headline caption))) + (cond ((and imgp + (plist-get org-export-latex-options-plist :inline-images)) + ;; OK, we need to inline an image + (insert + (org-export-latex-format-image raw-path caption label attr shortn))) + (coderefp + (insert (format + (org-export-get-coderef-format path desc) + (cdr (assoc path org-export-code-refs))))) + (radiop (insert (format org-export-latex-hyperref-format + (org-solidify-link-text raw-path) desc))) + ((not type) + (insert (format org-export-latex-hyperref-format + (org-remove-initial-hash + (org-solidify-link-text raw-path)) + desc))) + (path + (when (org-at-table-p) + ;; There is a strange problem when we have a link in a table, + ;; ampersands then cause a problem. I think this must be + ;; a LaTeX issue, but we here implement a work-around anyway. + (setq path (org-export-latex-protect-amp path) + desc (org-export-latex-protect-amp desc))) + (insert (format org-export-latex-href-format path desc))) + + ((functionp (setq fnc (nth 2 (assoc type org-link-protocols)))) + ;; The link protocol has a function for formatting the link + (insert + (save-match-data + (funcall fnc (org-link-unescape raw-path) desc 'latex)))) + + (t (insert "\\texttt{" desc "}"))))))) + + +(defun org-export-latex-format-image (path caption label attr &optional shortn) + "Format the image element, depending on user settings." + (let (ind floatp wrapp multicolumnp placement figenv) + (setq floatp (or caption label)) + (setq ind (org-get-text-property-any 0 'original-indentation path)) + (when (and attr (stringp attr)) + (if (string-match "[ \t]*\\<wrap\\>" attr) + (setq wrapp t floatp nil attr (replace-match "" t t attr))) + (if (string-match "[ \t]*\\<float\\>" attr) + (setq wrapp nil floatp t attr (replace-match "" t t attr))) + (if (string-match "[ \t]*\\<multicolumn\\>" attr) + (setq multicolumnp t attr (replace-match "" t t attr)))) + + (setq placement + (cond + (wrapp "{l}{0.5\\textwidth}") + (floatp "[htb]") + (t ""))) + + (when (and attr (stringp attr) + (string-match "[ \t]*\\<placement=\\(\\S-+\\)" attr)) + (setq placement (match-string 1 attr) + attr (replace-match "" t t attr))) + (setq attr (and attr (org-trim attr))) + (when (or (not attr) (= (length attr) 0)) + (setq attr (cond (floatp "width=0.7\\textwidth") + (wrapp "width=0.48\\textwidth") + (t attr)))) + (setq figenv + (cond + (wrapp "\\begin{wrapfigure}%placement +\\centering +\\includegraphics[%attr]{%path} +\\caption%shortn{%labelcmd%caption} +\\end{wrapfigure}") + (multicolumnp "\\begin{figure*}%placement +\\centering +\\includegraphics[%attr]{%path} +\\caption{%labelcmd%caption} +\\end{figure*}") + (floatp "\\begin{figure}%placement +\\centering +\\includegraphics[%attr]{%path} +\\caption{%labelcmd%caption} +\\end{figure}") + (t "\\includegraphics[%attr]{%path}"))) + + + (setq figenv (mapconcat 'identity (split-string figenv "\n") + (save-excursion (beginning-of-line 1) + (looking-at "[ \t]*") + (concat "\n" (match-string 0))))) + + (if (and (not label) (not caption) + (string-match "^\\\\caption{.*\n" figenv)) + (setq figenv (replace-match "" t t figenv))) + (org-add-props + (org-fill-template + figenv + (list (cons "path" + (if (file-name-absolute-p path) + (expand-file-name path) + path)) + (cons "attr" attr) + (cons "shortn" (if shortn (format "[%s]" shortn) "")) + (cons "labelcmd" (if label (format "\\label{%s}" + label)"")) + (cons "caption" (or caption "")) + (cons "placement" (or placement "")))) + nil 'original-indentation ind))) + +(defun org-export-latex-protect-amp (s) + (while (string-match "\\([^\\\\]\\)\\(&\\)" s) + (setq s (replace-match (concat (match-string 1 s) "\\" (match-string 2 s)) + t t s))) + s) + +(defun org-remove-initial-hash (s) + (if (string-match "\\`#" s) + (substring s 1) + s)) +(defvar org-latex-entities) ; defined below +(defvar org-latex-entities-regexp) ; defined below + +(defun org-export-latex-preprocess (parameters) + "Clean stuff in the LaTeX export." + ;; Preserve line breaks + (goto-char (point-min)) + (while (re-search-forward "\\\\\\\\" nil t) + (add-text-properties (match-beginning 0) (match-end 0) + '(org-protected t))) + + ;; Preserve latex environments + (goto-char (point-min)) + (while (re-search-forward "^[ \t]*\\\\begin{\\([a-zA-Z]+\\*?\\)}" nil t) + (org-if-unprotected + (let* ((start (progn (beginning-of-line) (point))) + (end (and (re-search-forward + (concat "^[ \t]*\\\\end{" + (regexp-quote (match-string 1)) + "}") nil t) + (point-at-eol)))) + (if end + (add-text-properties start end '(org-protected t)) + (goto-char (point-at-eol)))))) + + ;; Preserve math snippets + + (let* ((matchers (plist-get org-format-latex-options :matchers)) + (re-list org-latex-regexps) + beg end re e m n block off) + ;; Check the different regular expressions + (while (setq e (pop re-list)) + (setq m (car e) re (nth 1 e) n (nth 2 e) + block (if (nth 3 e) "\n\n" "")) + (setq off (if (member m '("$" "$1")) 1 0)) + (when (and (member m matchers) (not (equal m "begin"))) + (goto-char (point-min)) + (while (re-search-forward re nil t) + (setq beg (+ (match-beginning 0) off) end (- (match-end 0) 0)) + (add-text-properties beg end '(org-protected t org-latex-math t)))))) + + ;; Convert LaTeX to \LaTeX{} and TeX to \TeX{} + (goto-char (point-min)) + (let ((case-fold-search nil)) + (while (re-search-forward "\\<\\(\\(La\\)?TeX\\)\\>" nil t) + (unless (eq (char-before (match-beginning 1)) ?\\) + (org-if-unprotected-1 + (replace-match (org-export-latex-protect-string + (concat "\\" (match-string 1) + "{}")) t t))))) + + ;; Convert blockquotes + (goto-char (point-min)) + (while (search-forward "ORG-BLOCKQUOTE-START" nil t) + (org-replace-match-keep-properties "\\begin{quote}" t t)) + (goto-char (point-min)) + (while (search-forward "ORG-BLOCKQUOTE-END" nil t) + (org-replace-match-keep-properties "\\end{quote}" t t)) + + ;; Convert verse + (goto-char (point-min)) + (while (search-forward "ORG-VERSE-START" nil t) + (org-replace-match-keep-properties "\\begin{verse}" t t) + (beginning-of-line 2) + (while (and (not (looking-at "[ \t]*ORG-VERSE-END.*")) (not (eobp))) + (when (looking-at "\\([ \t]+\\)\\([^ \t\n]\\)") + (goto-char (match-end 1)) + (org-replace-match-keep-properties + (org-export-latex-protect-string + (concat "\\hspace*{1cm}" (match-string 2))) t t) + (beginning-of-line 1)) + (if (looking-at "[ \t]*$") + (insert (org-export-latex-protect-string "\\vspace*{1em}")) + (unless (looking-at ".*?[^ \t\n].*?\\\\\\\\[ \t]*$") + (end-of-line 1) + (insert "\\\\"))) + (beginning-of-line 2)) + (and (looking-at "[ \t]*ORG-VERSE-END.*") + (org-replace-match-keep-properties "\\end{verse}" t t))) + + ;; Convert center + (goto-char (point-min)) + (while (search-forward "ORG-CENTER-START" nil t) + (org-replace-match-keep-properties "\\begin{center}" t t)) + (goto-char (point-min)) + (while (search-forward "ORG-CENTER-END" nil t) + (org-replace-match-keep-properties "\\end{center}" t t)) + + (run-hooks 'org-export-latex-after-blockquotes-hook) + + ;; Convert horizontal rules + (goto-char (point-min)) + (while (re-search-forward "^----+.$" nil t) + (org-if-unprotected + (replace-match (org-export-latex-protect-string "\\hrule") t t))) + + ;; Protect LaTeX commands like \command[...]{...} or \command{...} + (goto-char (point-min)) + (let ((re (concat + "\\\\\\([a-zA-Z]+\\)" + "\\(?:<[^<>\n]*>\\)*" + "\\(?:\\[[^][\n]*?\\]\\)*" + "\\(?:<[^<>\n]*>\\)*" + "\\(" (org-create-multibrace-regexp "{" "}" 3) "\\)\\{1,3\\}"))) + (while (re-search-forward re nil t) + (unless (or + ;; check for comment line + (save-excursion (goto-char (match-beginning 0)) + (org-in-indented-comment-line)) + ;; Check if this is a defined entity, so that is may need conversion + (org-entity-get (match-string 1)) + ) + (add-text-properties (match-beginning 0) (match-end 0) + '(org-protected t))))) + + ;; Special case for \nbsp + (goto-char (point-min)) + (while (re-search-forward "\\\\nbsp\\({}\\|\\>\\)" nil t) + (org-if-unprotected + (replace-match (org-export-latex-protect-string "~")))) + + ;; Protect LaTeX entities + (goto-char (point-min)) + (while (re-search-forward org-latex-entities-regexp nil t) + (org-if-unprotected + (add-text-properties (match-beginning 0) (match-end 0) + '(org-protected t)))) + + ;; Replace radio links + (goto-char (point-min)) + (while (re-search-forward + (concat "<<<?" org-export-latex-all-targets-re + ">>>?\\((INVISIBLE)\\)?") nil t) + (org-if-unprotected-at (+ (match-beginning 0) 2) + (replace-match + (concat + (org-export-latex-protect-string + (format "\\label{%s}" (save-match-data (org-solidify-link-text + (match-string 1))))) + (if (match-string 2) "" (match-string 1))) + t t))) + + ;; Delete @<...> constructs + ;; Thanks to Daniel Clemente for this regexp + (goto-char (point-min)) + (while (re-search-forward "@<\\(?:[^\"\n]\\|\".*\"\\)*?>" nil t) + (org-if-unprotected + (replace-match ""))) + + ;; When converting to LaTeX, replace footnotes + ;; FIXME: don't protect footnotes from conversion + (when (plist-get org-export-latex-options-plist :footnotes) + (goto-char (point-min)) + (while (re-search-forward "\\[\\([0-9]+\\)\\]" nil t) + (org-if-unprotected + (when (and (save-match-data + (save-excursion (beginning-of-line) + (looking-at "[^:|#]"))) + (not (org-in-verbatim-emphasis))) + (let ((foot-beg (match-beginning 0)) + (foot-end (match-end 0)) + (foot-prefix (match-string 0)) + footnote footnote-rpl) + (save-excursion + (if (not (re-search-forward (concat "^" (regexp-quote foot-prefix)) + nil t)) + (replace-match (org-export-latex-protect-string + (concat "$^{" (match-string 1) "}$"))) + (replace-match "") + (let ((end (save-excursion + (if (re-search-forward "^$\\|^#.*$\\|\\[[0-9]+\\]" nil t) + (match-beginning 0) (point-max))))) + (setq footnote (concat (org-trim (buffer-substring (point) end)) + " ")) ; prevent last } being part of a link + (delete-region (point) end)) + (goto-char foot-beg) + (delete-region foot-beg foot-end) + (unless (null footnote) + (setq footnote-rpl (format "\\footnote{%s}" footnote)) + (add-text-properties 0 10 '(org-protected t) footnote-rpl) + (add-text-properties (1- (length footnote-rpl)) + (length footnote-rpl) + '(org-protected t) footnote-rpl) + (if (org-on-heading-p) + (setq footnote-rpl + (concat (org-export-latex-protect-string "\\protect") + footnote-rpl))) + (insert footnote-rpl))) + ))))) + + ;; Remove footnote section tag for LaTeX + (goto-char (point-min)) + (while (re-search-forward + (concat "^" footnote-section-tag-regexp) nil t) + (org-if-unprotected + (replace-match ""))))) + +(defun org-export-latex-fix-inputenc () + "Set the coding system in inputenc to what the buffer is." + (let* ((cs buffer-file-coding-system) + (opt (or (ignore-errors (latexenc-coding-system-to-inputenc cs)) + "utf8"))) + (when opt + ;; Translate if that is requested + (setq opt (or (cdr (assoc opt org-export-latex-inputenc-alist)) opt)) + ;; find the \usepackage statement and replace the option + (goto-char (point-min)) + (while (re-search-forward "\\\\usepackage\\[\\(AUTO\\)\\]{inputenc}" + nil t) + (goto-char (match-beginning 1)) + (delete-region (match-beginning 1) (match-end 1)) + (insert opt)) + (and buffer-file-name + (save-buffer))))) + +;;; List handling: + +(defun org-export-latex-lists () + "Convert plain text lists in current buffer into LaTeX lists." + (let (res) + (goto-char (point-min)) + (while (org-search-forward-unenclosed org-item-beginning-re nil t) + (beginning-of-line) + (setq res (org-list-to-latex (org-list-parse-list t) + org-export-latex-list-parameters)) + (while (string-match "^\\(\\\\item[ \t]+\\)\\[@\\(?:start:\\)?\\([0-9]+\\)\\]" + res) + (setq res (replace-match + (concat (format "\\setcounter{enumi}{%d}" + (1- (string-to-number + (match-string 2 res)))) + "\n" + (match-string 1 res)) + t t res))) + (insert res)))) + +(defconst org-latex-entities + '("\\!" + "\\'" + "\\+" + "\\," + "\\-" + "\\:" + "\\;" + "\\<" + "\\=" + "\\>" + "\\Huge" + "\\LARGE" + "\\Large" + "\\Styles" + "\\\\" + "\\`" + "\\addcontentsline" + "\\address" + "\\addtocontents" + "\\addtocounter" + "\\addtolength" + "\\addvspace" + "\\alph" + "\\appendix" + "\\arabic" + "\\author" + "\\begin{array}" + "\\begin{center}" + "\\begin{description}" + "\\begin{enumerate}" + "\\begin{eqnarray}" + "\\begin{equation}" + "\\begin{figure}" + "\\begin{flushleft}" + "\\begin{flushright}" + "\\begin{itemize}" + "\\begin{list}" + "\\begin{minipage}" + "\\begin{picture}" + "\\begin{quotation}" + "\\begin{quote}" + "\\begin{tabbing}" + "\\begin{table}" + "\\begin{tabular}" + "\\begin{thebibliography}" + "\\begin{theorem}" + "\\begin{titlepage}" + "\\begin{verbatim}" + "\\begin{verse}" + "\\bf" + "\\bf" + "\\bibitem" + "\\bigskip" + "\\cdots" + "\\centering" + "\\circle" + "\\cite" + "\\cleardoublepage" + "\\clearpage" + "\\cline" + "\\closing" + "\\dashbox" + "\\date" + "\\ddots" + "\\dotfill" + "\\em" + "\\fbox" + "\\flushbottom" + "\\fnsymbol" + "\\footnote" + "\\footnotemark" + "\\footnotesize" + "\\footnotetext" + "\\frac" + "\\frame" + "\\framebox" + "\\hfill" + "\\hline" + "\\hrulespace" + "\\hspace" + "\\huge" + "\\hyphenation" + "\\include" + "\\includeonly" + "\\indent" + "\\input" + "\\it" + "\\kill" + "\\label" + "\\large" + "\\ldots" + "\\line" + "\\linebreak" + "\\linethickness" + "\\listoffigures" + "\\listoftables" + "\\location" + "\\makebox" + "\\maketitle" + "\\mark" + "\\mbox" + "\\medskip" + "\\multicolumn" + "\\multiput" + "\\newcommand" + "\\newcounter" + "\\newenvironment" + "\\newfont" + "\\newlength" + "\\newline" + "\\newpage" + "\\newsavebox" + "\\newtheorem" + "\\nocite" + "\\nofiles" + "\\noindent" + "\\nolinebreak" + "\\nopagebreak" + "\\normalsize" + "\\onecolumn" + "\\opening" + "\\oval" + "\\overbrace" + "\\overline" + "\\pagebreak" + "\\pagenumbering" + "\\pageref" + "\\pagestyle" + "\\par" + "\\parbox" + "\\put" + "\\raggedbottom" + "\\raggedleft" + "\\raggedright" + "\\raisebox" + "\\ref" + "\\rm" + "\\roman" + "\\rule" + "\\savebox" + "\\sc" + "\\scriptsize" + "\\setcounter" + "\\setlength" + "\\settowidth" + "\\sf" + "\\shortstack" + "\\signature" + "\\sl" + "\\small" + "\\smallskip" + "\\sqrt" + "\\tableofcontents" + "\\telephone" + "\\thanks" + "\\thispagestyle" + "\\tiny" + "\\title" + "\\tt" + "\\twocolumn" + "\\typein" + "\\typeout" + "\\underbrace" + "\\underline" + "\\usebox" + "\\usecounter" + "\\value" + "\\vdots" + "\\vector" + "\\verb" + "\\vfill" + "\\vline" + "\\vspace") + "A list of LaTeX commands to be protected when performing conversion.") + +(defconst org-latex-entities-regexp + (let (names rest) + (dolist (x org-latex-entities) + (if (string-match "[a-zA-Z]$" x) + (push x names) + (push x rest))) + (concat "\\(" (regexp-opt (nreverse names)) "\\>\\)" + "\\|\\(" (regexp-opt (nreverse rest)) "\\)"))) + +(provide 'org-export-latex) +(provide 'org-latex) + +;; arch-tag: 23c2b87d-da04-4c2d-ad2d-1eb6487bc3ad + +;;; org-latex.el ends here diff --git a/.emacs.d/org-7.4/lisp/org-latex.elc b/.emacs.d/org-7.4/lisp/org-latex.elc Binary files differnew file mode 100644 index 0000000..c593d87 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-latex.elc diff --git a/.emacs.d/org-7.4/lisp/org-list.el b/.emacs.d/org-7.4/lisp/org-list.el new file mode 100644 index 0000000..bc8e7bd --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-list.el @@ -0,0 +1,2292 @@ +;;; org-list.el --- Plain lists for Org-mode +;; +;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010 +;; Free Software Foundation, Inc. +;; +;; Author: Carsten Dominik <carsten at orgmode dot org> +;; Bastien Guerry <bzg AT altern DOT org> +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; Version: 7.4 +;; +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: + +;; This file contains the code dealing with plain lists in Org-mode. + +;;; Code: + +(eval-when-compile + (require 'cl)) +(require 'org-macs) +(require 'org-compat) + +(defvar org-blank-before-new-entry) +(defvar org-M-RET-may-split-line) +(defvar org-complex-heading-regexp) +(defvar org-odd-levels-only) +(defvar org-outline-regexp) +(defvar org-ts-regexp) +(defvar org-ts-regexp-both) + +(declare-function org-invisible-p "org" ()) +(declare-function org-on-heading-p "org" (&optional invisible-ok)) +(declare-function outline-next-heading "outline" ()) +(declare-function org-back-to-heading "org" (&optional invisible-ok)) +(declare-function org-back-over-empty-lines "org" ()) +(declare-function org-trim "org" (s)) +(declare-function org-get-indentation "org" (&optional line)) +(declare-function org-timer-item "org-timer" (&optional arg)) +(declare-function org-timer-hms-to-secs "org-timer" (hms)) +(declare-function org-combine-plists "org" (&rest plists)) +(declare-function org-entry-get "org" + (pom property &optional inherit literal-nil)) +(declare-function org-narrow-to-subtree "org" ()) +(declare-function org-show-subtree "org" ()) +(declare-function org-in-regexps-block-p "org" + (start-re end-re &optional bound)) +(declare-function org-level-increment "org" ()) +(declare-function org-at-heading-p "org" (&optional ignored)) +(declare-function outline-previous-heading "outline" ()) +(declare-function org-icompleting-read "org" (&rest args)) +(declare-function org-time-string-to-seconds "org" (s)) + +(defgroup org-plain-lists nil + "Options concerning plain lists in Org-mode." + :tag "Org Plain lists" + :group 'org-structure) + +(defcustom org-cycle-include-plain-lists t + "When t, make TAB cycle visibility on plain list items. +Cycling plain lists works only when the cursor is on a plain list +item. When the cursor is on an outline heading, plain lists are +treated as text. This is the most stable way of handling this, +which is why it is the default. + +When this is the symbol `integrate', then 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. This setting can lead to strange effects when switching +visibility to `children', because the first \"child\" in a +subtree decides what children should be listed. If that first +\"child\" is a plain list item with an implied large level +number, all true children and grand children of the outline +heading will be exposed in a children' view." + :group 'org-plain-lists + :type '(choice + (const :tag "Never" nil) + (const :tag "With cursor in plain list (recommended)" t) + (const :tag "As children of outline headings" integrate))) + +(defcustom org-list-demote-modify-bullet nil + "Default bullet type installed when demoting an item. +This is an association list, for each bullet type, this alist will point +to the bullet that should be used when this item is demoted. +For example, + + (setq org-list-demote-modify-bullet + '((\"+\" . \"-\") (\"-\" . \"+\") (\"*\" . \"+\"))) + +will make + + + Movies + + Silence of the Lambs + + My Cousin Vinny + + Books + + The Hunt for Red October + + The Road to Omaha + +into + + + Movies + - Silence of the Lambs + - My Cousin Vinny + + Books + - The Hunt for Red October + - The Road to Omaha" + :group 'org-plain-lists + :type '(repeat + (cons + (choice :tag "If the current bullet is " + (const "-") + (const "+") + (const "*") + (const "1.") + (const "1)")) + (choice :tag "demotion will change it to" + (const "-") + (const "+") + (const "*") + (const "1.") + (const "1)"))))) + +(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-plain-lists + :type '(choice (const :tag "dot like in \"2.\"" ?.) + (const :tag "paren like in \"2)\"" ?\)) + (const :tab "both" t))) + +(defcustom org-list-two-spaces-after-bullet-regexp nil + "A regular expression matching bullets that should have 2 spaces after them. +When nil, no bullet will have two spaces after them. +When a string, it will be used as a regular expression. When the +bullet type of a list is changed, the new bullet type will be +matched against this regexp. If it matches, there will be two +spaces instead of one after the bullet in each item of the list." + :group 'org-plain-lists + :type '(choice + (const :tag "never" nil) + (regexp))) + +(defcustom org-list-ending-method 'both + "Determine where plain lists should end. +Valid values are: `regexp', `indent' or `both'. + +When set to `regexp', Org will look into two variables, +`org-empty-line-terminates-plain-lists' and the more general +`org-list-end-regexp', to determine what will end lists. This is +the fastest method. + +When set to `indent', a list will end whenever a line following +an item, but not starting one, is less or equally indented than +it. + +When set to `both', each of the preceding methods is applied to +determine lists endings. This is the default method." + :group 'org-plain-lists + :type '(choice + (const :tag "With a regexp defining ending" regexp) + (const :tag "With indentation of regular (no bullet) text" indent) + (const :tag "With both methods" both))) + +(defcustom org-empty-line-terminates-plain-lists nil + "Non-nil means an empty line ends all plain list levels. +This variable only makes sense if `org-list-ending-method' is set +to `regexp' or `both'. This is then equivalent to set +`org-list-end-regexp' to \"^[ \\t]*$\"." + :group 'org-plain-lists + :type 'boolean) + +(defcustom org-list-end-regexp "^[ \t]*\n[ \t]*\n" + "Regexp matching the end of all plain list levels. +It must start with \"^\" and end with \"\\n\". It defaults to 2 +blank lines. `org-empty-line-terminates-plain-lists' has +precedence over it." + :group 'org-plain-lists + :type 'string) + +(defcustom org-list-automatic-rules '((bullet . t) + (checkbox . t) + (indent . t) + (insert . t)) + "Non-nil means apply set of rules when acting on lists. +By default, automatic actions are taken when using + \\[org-meta-return], \\[org-metaright], \\[org-metaleft], + \\[org-shiftmetaright], \\[org-shiftmetaleft], + \\[org-ctrl-c-minus], \\[org-toggle-checkbox] or + \\[org-insert-todo-heading]. You can disable individually these + rules by setting them to nil. Valid rules are: + +bullet when non-nil, cycling bullet do not allow lists at + column 0 to have * as a bullet and descriptions lists + to be numbered. +checkbox when non-nil, checkbox statistics is updated each time + you either insert a new checkbox or toggle a checkbox. + It also prevents from inserting a checkbox in a + description item. +indent when non-nil, indenting or outdenting list top-item + with its subtree will move the whole list and + outdenting a list whose bullet is * to column 0 will + change that bullet to - +insert when non-nil, trying to insert an item inside a block + will insert it right before the block instead of + throwing an error." + :group 'org-plain-lists + :type '(alist :tag "Sets of rules" + :key-type + (choice + (const :tag "Bullet" bullet) + (const :tag "Checkbox" checkbox) + (const :tag "Indent" indent) + (const :tag "Insert" insert)) + :value-type + (boolean :tag "Activate" :value t))) + +(defcustom org-hierarchical-checkbox-statistics t + "Non-nil means checkbox statistics counts only the state of direct children. +When nil, all boxes below the cookie are counted. +This can be set to nil on a per-node basis using a COOKIE_DATA property +with the word \"recursive\" in the value." + :group 'org-plain-lists + :type 'boolean) + +(defcustom org-description-max-indent 20 + "Maximum indentation for the second line of a description list. +When the indentation would be larger than this, it will become +5 characters instead." + :group 'org-plain-lists + :type 'integer) + +(defcustom org-list-radio-list-templates + '((latex-mode "% BEGIN RECEIVE ORGLST %n +% END RECEIVE ORGLST %n +\\begin{comment} +#+ORGLST: SEND %n org-list-to-latex +- +\\end{comment}\n") + (texinfo-mode "@c BEGIN RECEIVE ORGLST %n +@c END RECEIVE ORGLST %n +@ignore +#+ORGLST: SEND %n org-list-to-texinfo +- +@end ignore\n") + (html-mode "<!-- BEGIN RECEIVE ORGLST %n --> +<!-- END RECEIVE ORGLST %n --> +<!-- +#+ORGLST: SEND %n org-list-to-html +- +-->\n")) + "Templates for radio lists in different major modes. +All occurrences of %n in a template will be replaced with the name of the +list, obtained by prompting the user." + :group 'org-plain-lists + :type '(repeat + (list (symbol :tag "Major mode") + (string :tag "Format")))) + +;;; Internal functions + +(defun org-list-end-re () + "Return the regex corresponding to the end of a list. +It depends on `org-empty-line-terminates-plain-lists'." + (if org-empty-line-terminates-plain-lists + "^[ \t]*\n" + org-list-end-regexp)) + +(defun org-item-re (&optional general) + "Return the correct regular expression for plain lists. +If GENERAL is non-nil, return the general regexp independent of the value +of `org-plain-list-ordered-item-terminator'." + (cond + ((or general (eq org-plain-list-ordered-item-terminator t)) + "\\([ \t]*\\([-+]\\|\\([0-9]+[.)]\\)\\)\\|[ \t]+\\*\\)\\([ \t]+\\|$\\)") + ((= org-plain-list-ordered-item-terminator ?.) + "\\([ \t]*\\([-+]\\|\\([0-9]+\\.\\)\\)\\|[ \t]+\\*\\)\\([ \t]+\\|$\\)") + ((= org-plain-list-ordered-item-terminator ?\)) + "\\([ \t]*\\([-+]\\|\\([0-9]+)\\)\\)\\|[ \t]+\\*\\)\\([ \t]+\\|$\\)") + (t (error "Invalid value of `org-plain-list-ordered-item-terminator'")))) + +(defconst org-item-beginning-re (concat "^" (org-item-re)) + "Regexp matching the beginning of a plain list item.") + +(defun org-list-ending-between (min max &optional firstp) + "Find the position of a list ending between MIN and MAX, or nil. +This function looks for `org-list-end-re' outside a block. + +If FIRSTP in non-nil, return the point at the beginning of the +nearest valid terminator from MIN. Otherwise, return the point at +the end of the nearest terminator from MAX." + (save-excursion + (let* ((start (if firstp min max)) + (end (if firstp max min)) + (search-fun (if firstp + #'org-search-forward-unenclosed + #'org-search-backward-unenclosed)) + (list-end-p (progn + (goto-char start) + (funcall search-fun (org-list-end-re) end t)))) + ;; Is there a valid list ending somewhere ? + (and list-end-p + ;; we want to be on the first line of the list ender + (match-beginning 0))))) + +(defun org-list-maybe-skip-block (search limit) + "Return non-nil value if point is in a block, skipping it on the way. +It looks for the boundary of the block in SEARCH direction, +stopping at LIMIT." + (save-match-data + (let ((case-fold-search t) + (boundary (if (eq search 're-search-forward) 3 5))) + (when (save-excursion + (and (funcall search "^[ \t]*#\\+\\(begin\\|end\\)_" limit t) + (= (length (match-string 1)) boundary))) + ;; We're in a block: get out of it + (goto-char (match-beginning 0)))))) + +(defun org-list-search-unenclosed-generic (search re bound noerr) + "Search a string outside blocks and protected places. +Arguments SEARCH, RE, BOUND and NOERR are similar to those in +`search-forward', `search-backward', `re-search-forward' and +`re-search-backward'." + (catch 'exit + (let ((origin (point))) + (while t + ;; 1. No match: return to origin or bound, depending on NOERR. + (unless (funcall search re bound noerr) + (throw 'exit (and (goto-char (if (memq noerr '(t nil)) origin bound)) + nil))) + ;; 2. Match not in block or protected: return point. Else + ;; skip the block and carry on. + (unless (or (get-text-property (match-beginning 0) 'org-protected) + (org-list-maybe-skip-block search bound)) + (throw 'exit (point))))))) + +(defun org-search-backward-unenclosed (regexp &optional bound noerror) + "Like `re-search-backward' but don't stop inside blocks or protected places. +Arguments REGEXP, BOUND and NOERROR are similar to those used in +`re-search-backward'." + (org-list-search-unenclosed-generic + #'re-search-backward regexp (or bound (point-min)) noerror)) + +(defun org-search-forward-unenclosed (regexp &optional bound noerror) + "Like `re-search-forward' but don't stop inside blocks or protected places. +Arguments REGEXP, BOUND and NOERROR are similar to those used in +`re-search-forward'." + (org-list-search-unenclosed-generic + #'re-search-forward regexp (or bound (point-max)) noerror)) + +(defun org-list-in-item-p-with-indent (limit) + "Is the cursor inside a plain list? +Plain lists are considered ending when a non-blank line is less +indented than the previous item within LIMIT." + (save-excursion + (beginning-of-line) + (cond + ;; do not start searching inside a block... + ((org-list-maybe-skip-block #'re-search-backward limit)) + ;; ... or at a blank line + ((looking-at "^[ \t]*$") + (skip-chars-backward " \r\t\n") + (beginning-of-line))) + (beginning-of-line) + (or (org-at-item-p) + (let* ((case-fold-search t) + (ind-ref (org-get-indentation)) + ;; Ensure there is at least an item above + (up-item-p (save-excursion + (org-search-backward-unenclosed + org-item-beginning-re limit t)))) + (and up-item-p + (catch 'exit + (while t + (cond + ((org-at-item-p) + (throw 'exit (< (org-get-indentation) ind-ref))) + ((looking-at "^[ \t]*$") + (skip-chars-backward " \r\t\n") + (beginning-of-line)) + ((looking-at "^[ \t]*#\\+end_") + (re-search-backward "^[ \t]*#\\+begin_")) + (t + (setq ind-ref (min (org-get-indentation) ind-ref)) + (forward-line -1)))))))))) + +(defun org-list-in-item-p-with-regexp (limit) + "Is the cursor inside a plain list? +Plain lists end when `org-list-end-regexp' is matched, or at a +blank line if `org-empty-line-terminates-plain-lists' is true. + +Argument LIMIT specifies the upper-bound of the search." + (save-excursion + (let* ((actual-pos (goto-char (point-at-eol))) + ;; Moved to eol so current line can be matched by + ;; `org-item-re'. + (last-item-start (save-excursion + (org-search-backward-unenclosed + org-item-beginning-re limit t))) + (list-ender (org-list-ending-between + last-item-start actual-pos))) + ;; We are in a list when we are on an item line or when we can + ;; find an item before point and there is no valid list ender + ;; between it and the point. + (and last-item-start (not list-ender))))) + +(defun org-list-top-point-with-regexp (limit) + "Return point at the top level item in a list. +Argument LIMIT specifies the upper-bound of the search. + +List ending is determined by regexp. See +`org-list-ending-method'. for more information." + (save-excursion + (let ((pos (point-at-eol))) + ;; Is there some list above this one ? If so, go to its ending. + ;; Otherwise, go back to the heading above or bob. + (goto-char (or (org-list-ending-between limit pos) limit)) + ;; From there, search down our list. + (org-search-forward-unenclosed org-item-beginning-re pos t) + (point-at-bol)))) + +(defun org-list-bottom-point-with-regexp (limit) + "Return point just before list ending. +Argument LIMIT specifies the lower-bound of the search. + +List ending is determined by regexp. See +`org-list-ending-method'. for more information." + (save-excursion + (let ((pos (org-get-item-beginning))) + ;; The list ending is either first point matching + ;; `org-list-end-re', point at first white-line before next + ;; heading, or eob. + (or (org-list-ending-between (min pos limit) limit t) limit)))) + +(defun org-list-top-point-with-indent (limit) + "Return point at the top level in a list. +Argument LIMIT specifies the upper-bound of the search. + +List ending is determined by indentation of text. See +`org-list-ending-method'. for more information." + (save-excursion + (let ((case-fold-search t)) + (let ((item-ref (goto-char (org-get-item-beginning))) + (ind-ref 10000)) + (forward-line -1) + (catch 'exit + (while t + (let ((ind (+ (or (get-text-property (point) 'original-indentation) 0) + (org-get-indentation)))) + (cond + ((looking-at "^[ \t]*:END:") + (throw 'exit item-ref)) + ((<= (point) limit) + (throw 'exit + (if (and (org-at-item-p) (< ind ind-ref)) + (point-at-bol) + item-ref))) + ((looking-at "^[ \t]*$") + (skip-chars-backward " \r\t\n") + (beginning-of-line)) + ((looking-at "^[ \t]*#\\+end_") + (re-search-backward "^[ \t]*#\\+begin_")) + ((not (org-at-item-p)) + (setq ind-ref (min ind ind-ref)) + (forward-line -1)) + ((>= ind ind-ref) + (throw 'exit item-ref)) + (t + (setq item-ref (point-at-bol) ind-ref 10000) + (forward-line -1)))))))))) + +(defun org-list-bottom-point-with-indent (limit) + "Return point just before list ending or nil if not in a list. +Argument LIMIT specifies the lower-bound of the search. + +List ending is determined by the indentation of text. See +`org-list-ending-method' for more information." + (save-excursion + (let ((ind-ref (progn + (goto-char (org-get-item-beginning)) + (org-get-indentation))) + (case-fold-search t)) + ;; do not start inside a block + (org-list-maybe-skip-block #'re-search-forward limit) + (beginning-of-line) + (catch 'exit + (while t + (skip-chars-forward " \t") + (let ((ind (+ (or (get-text-property (point) 'original-indentation) 0) + (org-get-indentation)))) + (cond + ((or (>= (point) limit) + (looking-at ":END:")) + (throw 'exit (progn + ;; Ensure bottom is just after a + ;; non-blank line. + (skip-chars-backward " \r\t\n") + (min (point-max) (1+ (point-at-eol)))))) + ((= (point) (point-at-eol)) + (skip-chars-forward " \r\t\n") + (beginning-of-line)) + ((org-at-item-p) + (setq ind-ref ind) + (forward-line 1)) + ((<= ind ind-ref) + (throw 'exit (progn + ;; Again, ensure bottom is just after a + ;; non-blank line. + (skip-chars-backward " \r\t\n") + (min (point-max) (1+ (point-at-eol)))))) + ((looking-at "#\\+begin_") + (re-search-forward "[ \t]*#\\+end_") + (forward-line 1)) + (t (forward-line 1))))))))) + +(defun org-list-at-regexp-after-bullet-p (regexp) + "Is point at a list item with REGEXP after bullet?" + (and (org-at-item-p) + (save-excursion + (goto-char (match-end 0)) + ;; Ignore counter if any + (when (looking-at "\\(?:\\[@\\(?:start:\\)?[0-9]+\\][ \t]*\\)?") + (goto-char (match-end 0))) + (looking-at regexp)))) + +(defun org-list-get-item-same-level (search-fun pos limit pre-move) + "Return point at the beginning of next item at the same level. +Search items using function SEARCH-FUN, from POS to LIMIT. It +uses PRE-MOVE before search. Return nil if no item was found." + (save-excursion + (goto-char pos) + (let* ((start (org-get-item-beginning)) + (ind (progn (goto-char start) (org-get-indentation)))) + ;; We don't want to match the current line. + (funcall pre-move) + ;; Skip any sublist on the way + (while (and (funcall search-fun org-item-beginning-re limit t) + (> (org-get-indentation) ind))) + (when (and (/= (point-at-bol) start) ; Have we moved ? + (= (org-get-indentation) ind)) + (point-at-bol))))) + +(defun org-list-separating-blank-lines-number (pos top bottom) + "Return number of blank lines that should separate items in list. +POS is the position of point to be considered. + +TOP and BOTTOM are respectively position of list beginning and +list ending. + +Assume point is at item's beginning. If the item is alone, apply +some heuristics to guess the result." + (save-excursion + (let ((insert-blank-p + (cdr (assq 'plain-list-item org-blank-before-new-entry))) + usr-blank) + (cond + ;; Trivial cases where there should be none. + ((or (and (not (eq org-list-ending-method 'indent)) + org-empty-line-terminates-plain-lists) + (not insert-blank-p)) 0) + ;; When `org-blank-before-new-entry' says so, it is 1. + ((eq insert-blank-p t) 1) + ;; plain-list-item is 'auto. Count blank lines separating + ;; neighbours items in list. + (t (let ((next-p (org-get-next-item (point) bottom))) + (cond + ;; Is there a next item? + (next-p (goto-char next-p) + (org-back-over-empty-lines)) + ;; Is there a previous item? + ((org-get-previous-item (point) top) + (org-back-over-empty-lines)) + ;; User inserted blank lines, trust him + ((and (> pos (org-end-of-item-before-blank bottom)) + (> (save-excursion + (goto-char pos) + (skip-chars-backward " \t") + (setq usr-blank (org-back-over-empty-lines))) 0)) + usr-blank) + ;; Are there blank lines inside the item ? + ((save-excursion + (org-search-forward-unenclosed + "^[ \t]*$" (org-end-of-item-before-blank bottom) t)) 1) + ;; No parent: no blank line. + (t 0)))))))) + +(defun org-list-insert-item-generic (pos &optional checkbox after-bullet) + "Insert a new list item at POS. +If POS is before first character after bullet of the item, the +new item will be created before the current one. + +Insert a checkbox if CHECKBOX is non-nil, and string AFTER-BULLET +after the bullet. Cursor will be after this text once the +function ends." + (goto-char pos) + ;; Is point in a special block? + (when (org-in-regexps-block-p + "^[ \t]*#\\+\\(begin\\|BEGIN\\)_\\([a-zA-Z0-9_]+\\)" + '(concat "^[ \t]*#\\+\\(end\\|END\\)_" (match-string 2))) + (if (not (cdr (assq 'insert org-list-automatic-rules))) + ;; Rule in `org-list-automatic-rules' forbids insertion. + (error "Cannot insert item inside a block") + ;; Else, move before it prior to add a new item. + (end-of-line) + (re-search-backward "^[ \t]*#\\+\\(begin\\|BEGIN\\)_" nil t) + (end-of-line 0))) + (let* ((true-pos (point)) + (top (org-list-top-point)) + (bottom (copy-marker (org-list-bottom-point))) + (bullet (and (goto-char (org-get-item-beginning)) + (org-list-bullet-string (org-get-bullet)))) + (ind (org-get-indentation)) + (before-p (progn + ;; Description item: text starts after colons. + (or (org-at-item-description-p) + ;; At a checkbox: text starts after it. + (org-at-item-checkbox-p) + ;; Otherwise, text starts after bullet. + (org-at-item-p)) + (<= true-pos (match-end 0)))) + (blank-lines-nb (org-list-separating-blank-lines-number + true-pos top bottom)) + (insert-fun + (lambda (text) + ;; insert bullet above item in order to avoid bothering + ;; with possible blank lines ending last item. + (goto-char (org-get-item-beginning)) + (org-indent-to-column ind) + (insert (concat bullet (when checkbox "[ ] ") after-bullet)) + ;; Stay between after-bullet and before text. + (save-excursion + (insert (concat text (make-string (1+ blank-lines-nb) ?\n)))) + (unless before-p + ;; store bottom: exchanging items doesn't change list + ;; bottom point but will modify marker anyway + (setq bottom (marker-position bottom)) + (let ((col (current-column))) + (org-list-exchange-items + (org-get-item-beginning) (org-get-next-item (point) bottom) + bottom) + ;; recompute next-item: last sexp modified list + (goto-char (org-get-next-item (point) bottom)) + (org-move-to-column col))) + ;; checkbox update might modify bottom point, so use a + ;; marker here + (setq bottom (copy-marker bottom)) + (when checkbox (org-update-checkbox-count-maybe)) + (org-list-repair nil top bottom)))) + (goto-char true-pos) + (cond + (before-p (funcall insert-fun nil) t) + ;; Can't split item: insert bullet at the end of item. + ((not (org-get-alist-option org-M-RET-may-split-line 'item)) + (funcall insert-fun nil) t) + ;; else, insert a new bullet along with everything from point + ;; down to last non-blank line of item. + (t + (delete-horizontal-space) + ;; Get pos again in case previous command modified line. + (let* ((pos (point)) + (end-before-blank (org-end-of-item-before-blank bottom)) + (after-text + (when (< pos end-before-blank) + (prog1 + (delete-and-extract-region pos end-before-blank) + ;; delete any blank line at and before point. + (beginning-of-line) + (while (looking-at "^[ \t]*$") + (delete-region (point-at-bol) (1+ (point-at-eol))) + (beginning-of-line 0)))))) + (funcall insert-fun after-text) t))))) + +(defvar org-last-indent-begin-marker (make-marker)) +(defvar org-last-indent-end-marker (make-marker)) + +(defun org-list-indent-item-generic (arg no-subtree top bottom) + "Indent a local list item including its children. +When number ARG is a negative, item will be outdented, otherwise +it will be indented. + +If a region is active, all items inside will be moved. + +If NO-SUBTREE is non-nil, only indent the item itself, not its +children. + +TOP and BOTTOM are respectively position at item beginning and at +item ending. + +Return t if successful." + (let* ((regionp (org-region-active-p)) + (rbeg (and regionp (region-beginning))) + (rend (and regionp (region-end)))) + (cond + ((and regionp + (goto-char rbeg) + (not (org-search-forward-unenclosed org-item-beginning-re rend t))) + (error "No item in region")) + ((not (org-at-item-p)) + (error "Not on an item")) + (t + ;; Are we going to move the whole list? + (let* ((specialp (and (cdr (assq 'indent org-list-automatic-rules)) + (not no-subtree) + (= top (point-at-bol))))) + ;; Determine begin and end points of zone to indent. If moving + ;; more than one item, ensure we keep them on subsequent moves. + (unless (and (memq last-command '(org-shiftmetaright org-shiftmetaleft)) + (memq this-command '(org-shiftmetaright org-shiftmetaleft))) + (if regionp + (progn + (set-marker org-last-indent-begin-marker rbeg) + (set-marker org-last-indent-end-marker rend)) + (set-marker org-last-indent-begin-marker (point-at-bol)) + (set-marker org-last-indent-end-marker + (save-excursion + (cond + (specialp bottom) + (no-subtree (org-end-of-item-or-at-child bottom)) + (t (org-get-end-of-item bottom))))))) + ;; Get everything ready + (let* ((beg (marker-position org-last-indent-begin-marker)) + (end (marker-position org-last-indent-end-marker)) + (struct (org-list-struct + beg end top (if specialp end bottom) (< arg 0))) + (origins (org-list-struct-origins struct)) + (beg-item (assq beg struct))) + (cond + ;; Special case: moving top-item with indent rule + (specialp + (let* ((level-skip (org-level-increment)) + (offset (if (< arg 0) (- level-skip) level-skip)) + (top-ind (nth 1 beg-item))) + (if (< (+ top-ind offset) 0) + (error "Cannot outdent beyond margin") + ;; Change bullet if necessary + (when (and (= (+ top-ind offset) 0) + (string-match "*" (nth 2 beg-item))) + (setcdr beg-item (list (nth 1 beg-item) + (org-list-bullet-string "-")))) + ;; Shift ancestor + (let ((anc (car struct))) + (setcdr anc (list (+ (nth 1 anc) offset) "" nil))) + (org-list-struct-fix-struct struct origins) + (org-list-struct-apply-struct struct end)))) + ;; Forbidden move + ((and (< arg 0) + (or (and no-subtree + (not regionp) + (org-list-struct-get-child beg-item struct)) + (let ((last-item (save-excursion + (goto-char end) + (skip-chars-backward " \r\t\n") + (goto-char (org-get-item-beginning)) + (org-list-struct-assoc-at-point)))) + (org-list-struct-get-child last-item struct)))) + (error "Cannot outdent an item without its children")) + ;; Normal shifting + (t + (let* ((shifted-ori (if (< arg 0) + (org-list-struct-outdent beg end origins) + (org-list-struct-indent beg end origins struct)))) + (org-list-struct-fix-struct struct shifted-ori) + (org-list-struct-apply-struct struct bottom)))))))))) + +;;; Predicates + +(defun org-in-item-p () + "Is the cursor inside a plain list? +This checks `org-list-ending-method'." + (unless (let ((outline-regexp org-outline-regexp)) (org-at-heading-p)) + (let* ((prev-head (save-excursion (outline-previous-heading))) + (bound (if prev-head + (or (save-excursion + (let ((case-fold-search t)) + (re-search-backward "^[ \t]*:END:" prev-head t))) + prev-head) + (point-min)))) + (cond + ((eq org-list-ending-method 'regexp) + (org-list-in-item-p-with-regexp bound)) + ((eq org-list-ending-method 'indent) + (org-list-in-item-p-with-indent bound)) + (t (and (org-list-in-item-p-with-regexp bound) + (org-list-in-item-p-with-indent bound))))))) + +(defun org-list-first-item-p (top) + "Is this item the first item in a plain list? +Assume point is at an item. + +TOP is the position of list's top-item." + (save-excursion + (beginning-of-line) + (let ((ind (org-get-indentation))) + (or (not (org-search-backward-unenclosed org-item-beginning-re top t)) + (< (org-get-indentation) ind))))) + +(defun org-at-item-p () + "Is point in a line starting a hand-formatted item?" + (save-excursion + (beginning-of-line) (looking-at org-item-beginning-re))) + +(defun org-at-item-bullet-p () + "Is point at the bullet of a plain list item?" + (and (org-at-item-p) + (not (member (char-after) '(?\ ?\t))) + (< (point) (match-end 0)))) + +(defun org-at-item-timer-p () + "Is point at a line starting a plain list item with a timer?" + (org-list-at-regexp-after-bullet-p + "\\([0-9]+:[0-9]+:[0-9]+\\)[ \t]+::[ \t]+")) + +(defun org-at-item-description-p () + "Is point at a description list item?" + (org-list-at-regexp-after-bullet-p "\\(\\S-.+\\)[ \t]+::[ \t]+")) + +(defun org-at-item-checkbox-p () + "Is point at a line starting a plain-list item with a checklet?" + (org-list-at-regexp-after-bullet-p "\\(\\[[- X]\\]\\)[ \t]+")) + +(defun org-checkbox-blocked-p () + "Is the current checkbox blocked from for being checked now? +A checkbox is blocked if all of the following conditions are fulfilled: + +1. The checkbox is not checked already. +2. The current entry has the ORDERED property set. +3. There is an unchecked checkbox in this entry before the current line." + (catch 'exit + (save-match-data + (save-excursion + (unless (org-at-item-checkbox-p) (throw 'exit nil)) + (when (equal (match-string 1) "[X]") + ;; the box is already checked! + (throw 'exit nil)) + (let ((end (point-at-bol))) + (condition-case nil (org-back-to-heading t) + (error (throw 'exit nil))) + (unless (org-entry-get nil "ORDERED") (throw 'exit nil)) + (when (org-search-forward-unenclosed + "^[ \t]*[-+*0-9.)]+[ \t]+\\(\\[@\\(?:start:\\)?[0-9]+\\][ \t]*\\)?\\[[- ]\\]" end t) + (org-current-line))))))) + +;;; Navigate + +;; Every interactive navigation function is derived from a +;; non-interactive one, which doesn't move point, assumes point is +;; already in a list and doesn't compute list boundaries. + +;; If you plan to use more than one org-list function is some code, +;; you should therefore first check if point is in a list with +;; `org-in-item-p' or `org-at-item-p', then compute list boundaries +;; with `org-list-top-point' and `org-list-bottom-point', and make use +;; of non-interactive forms. + +(defun org-list-top-point () + "Return point at the top level in a list. +Assume point is in a list." + (let* ((prev-head (save-excursion (outline-previous-heading))) + (bound (if prev-head + (or (save-excursion + (let ((case-fold-search t)) + (re-search-backward "^[ \t]*:END:" prev-head t))) + prev-head) + (point-min)))) + (cond + ((eq org-list-ending-method 'regexp) + (org-list-top-point-with-regexp bound)) + ((eq org-list-ending-method 'indent) + (org-list-top-point-with-indent bound)) + (t (let ((top-re (org-list-top-point-with-regexp bound))) + (org-list-top-point-with-indent (or top-re bound))))))) + +(defun org-list-bottom-point () + "Return point just before list ending. +Assume point is in a list." + (let* ((next-head (save-excursion + (and (let ((outline-regexp org-outline-regexp)) + ;; Use default regexp because folding + ;; changes OUTLINE-REGEXP. + (outline-next-heading))))) + (limit (or (save-excursion + (and (re-search-forward "^[ \t]*:END:" next-head t) + (point-at-bol))) + next-head + (point-max)))) + (cond + ((eq org-list-ending-method 'regexp) + (org-list-bottom-point-with-regexp limit)) + ((eq org-list-ending-method 'indent) + (org-list-bottom-point-with-indent limit)) + (t (let ((bottom-re (org-list-bottom-point-with-regexp limit))) + (org-list-bottom-point-with-indent (or bottom-re limit))))))) + +(defun org-get-item-beginning () + "Return position of current item beginning." + (save-excursion + ;; possibly match current line + (end-of-line) + (org-search-backward-unenclosed org-item-beginning-re nil t) + (point-at-bol))) + +(defun org-beginning-of-item () + "Go to the beginning of the current hand-formatted item. +If the cursor is not in an item, throw an error." + (interactive) + (if (org-in-item-p) + (goto-char (org-get-item-beginning)) + (error "Not in an item"))) + +(defun org-get-beginning-of-list (top) + "Return position of the first item of the current list or sublist. +TOP is the position at list beginning." + (save-excursion + (let (prev-p) + (while (setq prev-p (org-get-previous-item (point) top)) + (goto-char prev-p)) + (point-at-bol)))) + +(defun org-beginning-of-item-list () + "Go to the beginning item of the current list or sublist. +Return an error if not in a list." + (interactive) + (if (org-in-item-p) + (goto-char (org-get-beginning-of-list (org-list-top-point))) + (error "Not in an item"))) + +(defun org-get-end-of-list (bottom) + "Return position at the end of the current list or sublist. +BOTTOM is the position at list ending." + (save-excursion + (goto-char (org-get-item-beginning)) + (let ((ind (org-get-indentation))) + (while (and (/= (point) bottom) + (>= (org-get-indentation) ind)) + (org-search-forward-unenclosed org-item-beginning-re bottom 'move)) + (if (= (point) bottom) bottom (point-at-bol))))) + +(defun org-end-of-item-list () + "Go to the end of the current list or sublist. +If the cursor in not in an item, throw an error." + (interactive) + (if (org-in-item-p) + (goto-char (org-get-end-of-list (org-list-bottom-point))) + (error "Not in an item"))) + +(defun org-get-end-of-item (bottom) + "Return position at the end of the current item. +BOTTOM is the position at list ending." + (or (org-get-next-item (point) bottom) + (org-get-end-of-list bottom))) + +(defun org-end-of-item () + "Go to the end of the current hand-formatted item. +If the cursor is not in an item, throw an error." + (interactive) + (if (org-in-item-p) + (goto-char (org-get-end-of-item (org-list-bottom-point))) + (error "Not in an item"))) + +(defun org-end-of-item-or-at-child (bottom) + "Move to the end of the item, stops before the first child if any. +BOTTOM is the position at list ending." + (end-of-line) + (goto-char + (if (org-search-forward-unenclosed org-item-beginning-re bottom t) + (point-at-bol) + (org-get-end-of-item bottom)))) + +(defun org-end-of-item-before-blank (bottom) + "Return point at end of item, before any blank line. +Point returned is at eol. + +BOTTOM is the position at list ending." + (save-excursion + (goto-char (org-get-end-of-item bottom)) + (skip-chars-backward " \r\t\n") + (point-at-eol))) + +(defun org-get-previous-item (pos limit) + "Return point of the previous item at the same level as POS. +Stop searching at LIMIT. Return nil if no item is found." + (org-list-get-item-same-level + #'org-search-backward-unenclosed pos limit #'beginning-of-line)) + +(defun org-previous-item () + "Move to the beginning of the previous item. +Item is at the same level in the current plain list. Error if not +in a plain list, or if this is the first item in the list." + (interactive) + (if (not (org-in-item-p)) + (error "Not in an item") + (let ((prev-p (org-get-previous-item (point) (org-list-top-point)))) + (if prev-p (goto-char prev-p) (error "On first item"))))) + +(defun org-get-next-item (pos limit) + "Return point of the next item at the same level as POS. +Stop searching at LIMIT. Return nil if no item is found." + (org-list-get-item-same-level + #'org-search-forward-unenclosed pos limit #'end-of-line)) + +(defun org-next-item () + "Move to the beginning of the next item. +Item is at the same level in the current plain list. Error if not +in a plain list, or if this is the last item in the list." + (interactive) + (if (not (org-in-item-p)) + (error "Not in an item") + (let ((next-p (org-get-next-item (point) (org-list-bottom-point)))) + (if next-p (goto-char next-p) (error "On last item"))))) + +;;; Manipulate + +(defun org-list-exchange-items (beg-A beg-B bottom) + "Swap item starting at BEG-A with item starting at BEG-B. +Blank lines at the end of items are left in place. Assume BEG-A +is lesser than BEG-B. + +BOTTOM is the position at list ending." + (save-excursion + (let* ((end-of-item-no-blank + (lambda (pos) + (goto-char pos) + (goto-char (org-end-of-item-before-blank bottom)))) + (end-A-no-blank (funcall end-of-item-no-blank beg-A)) + (end-B-no-blank (funcall end-of-item-no-blank beg-B)) + (body-A (buffer-substring beg-A end-A-no-blank)) + (body-B (buffer-substring beg-B end-B-no-blank)) + (between-A-no-blank-and-B (buffer-substring end-A-no-blank beg-B))) + (goto-char beg-A) + (delete-region beg-A end-B-no-blank) + (insert (concat body-B between-A-no-blank-and-B body-A))))) + +(defun org-move-item-down () + "Move the plain list item at point down, i.e. swap with following item. +Subitems (items with larger indentation) are considered part of the item, +so this really moves item trees." + (interactive) + (if (not (org-at-item-p)) + (error "Not at an item") + (let* ((pos (point)) + (col (current-column)) + (bottom (org-list-bottom-point)) + (actual-item (goto-char (org-get-item-beginning))) + (next-item (org-get-next-item (point) bottom))) + (if (not next-item) + (progn + (goto-char pos) + (error "Cannot move this item further down")) + (org-list-exchange-items actual-item next-item bottom) + (org-list-repair nil nil bottom) + (goto-char (org-get-next-item (point) bottom)) + (org-move-to-column col))))) + +(defun org-move-item-up () + "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) + (if (not (org-at-item-p)) + (error "Not at an item") + (let* ((pos (point)) + (col (current-column)) + (top (org-list-top-point)) + (bottom (org-list-bottom-point)) + (actual-item (goto-char (org-get-item-beginning))) + (prev-item (org-get-previous-item (point) top))) + (if (not prev-item) + (progn + (goto-char pos) + (error "Cannot move this item further up")) + (org-list-exchange-items prev-item actual-item bottom) + (org-list-repair nil top bottom) + (org-move-to-column col))))) + +(defun org-insert-item (&optional checkbox) + "Insert a new item at the current level. +If cursor is before first character after bullet of the item, the +new item will be created before the current one. + +If CHECKBOX is non-nil, add a checkbox next to the bullet. + +Return t when things worked, nil when we are not in an item, or +item is invisible." + (unless (or (not (org-in-item-p)) + (save-excursion + (goto-char (org-get-item-beginning)) + (org-invisible-p))) + (if (save-excursion + (goto-char (org-get-item-beginning)) + (org-at-item-timer-p)) + ;; Timer list: delegate to `org-timer-item'. + (progn (org-timer-item) t) + ;; if we're in a description list, ask for the new term. + (let ((desc-text (when (save-excursion + (and (goto-char (org-get-item-beginning)) + (org-at-item-description-p))) + (concat (read-string "Term: ") " :: ")))) + ;; Don't insert a checkbox if checkbox rule is applied and it + ;; is a description item. + (org-list-insert-item-generic + (point) (and checkbox + (or (not desc-text) + (not (cdr (assq 'checkbox org-list-automatic-rules))))) + desc-text))))) + +;;; Structures + +;; The idea behind structures is to avoid moving back and forth in the +;; buffer on costly operations like indenting or fixing bullets. + +;; It achieves this by taking a snapshot of an interesting part of the +;; list, in the shape of an alist, using `org-list-struct'. + +;; It then proceeds to changes directly on the alist, with the help of +;; and `org-list-struct-origins'. When those are done, +;; `org-list-struct-apply-struct' applies the changes to the buffer. + +(defun org-list-struct-assoc-at-point () + "Return the structure association at point. +It is a cons-cell whose key is point and values are indentation, +bullet string and bullet counter, if any." + (save-excursion + (beginning-of-line) + (list (point-at-bol) + (org-get-indentation) + (progn + (looking-at "^[ \t]*\\([-+*0-9.)]+[ \t]+\\)") + (match-string 1)) + (progn + (goto-char (match-end 0)) + (and (looking-at "\\[@\\(?:start:\\)?\\([0-9]+\\)\\]") + (match-string 1)))))) + +(defun org-list-struct (begin end top bottom &optional outdent) + "Return the structure containing the list between BEGIN and END. +A structure is an alist where key is point of item and values +are, in that order, indentation, bullet string and value of +counter, if any. A structure contains every list and sublist that +has items between BEGIN and END along with their common ancestor. +If no such ancestor can be found, the function will add a virtual +ancestor at position 0. + +TOP and BOTTOM are respectively the position of list beginning +and list ending. + +If OUTDENT is non-nil, it will also grab all of the parent list +and the grand-parent. Setting OUTDENT to t is mandatory when next +change is an outdent." + (save-excursion + (let* (struct + (extend + (lambda (struct) + (let* ((ind-min (apply 'min (mapcar 'cadr struct))) + (begin (caar struct)) + (end (caar (last struct))) + pre-list post-list) + (goto-char begin) + ;; Find beginning of most outdented list (min list) + (while (and (org-search-backward-unenclosed + org-item-beginning-re top t) + (>= (org-get-indentation) ind-min)) + (setq pre-list (cons (org-list-struct-assoc-at-point) + pre-list))) + ;; Now get the parent. If none, add a virtual ancestor + (if (< (org-get-indentation) ind-min) + (setq pre-list (cons (org-list-struct-assoc-at-point) + pre-list)) + (setq pre-list (cons (list 0 (org-get-indentation) "" nil) + pre-list))) + ;; Find end of min list + (goto-char end) + (end-of-line) + (while (and (org-search-forward-unenclosed + org-item-beginning-re bottom 'move) + (>= (org-get-indentation) ind-min)) + (setq post-list (cons (org-list-struct-assoc-at-point) + post-list))) + ;; Is list is malformed? If some items are less + ;; indented that top-item, add them anyhow. + (when (and (= (caar pre-list) 0) (< (point) bottom)) + (beginning-of-line) + (while (org-search-forward-unenclosed + org-item-beginning-re bottom t) + (setq post-list (cons (org-list-struct-assoc-at-point) + post-list)))) + (append pre-list struct (reverse post-list)))))) + ;; Here we start: first get the core zone... + (goto-char end) + (while (org-search-backward-unenclosed org-item-beginning-re begin t) + (setq struct (cons (org-list-struct-assoc-at-point) struct))) + ;; ... then, extend it to make it a structure... + (let ((extended (funcall extend struct))) + ;; ... twice when OUTDENT is non-nil and struct still can be + ;; extended + (if (and outdent (> (caar extended) 0)) + (funcall extend extended) + extended))))) + +(defun org-list-struct-origins (struct) + "Return an alist where key is item's position and value parent's. +STRUCT is the list's structure looked up." + (let* ((struct-rev (reverse struct)) + (acc (list (cons (nth 1 (car struct)) 0))) + (prev-item (lambda (item) + (car (nth 1 (member (assq item struct) struct-rev))))) + (get-origins + (lambda (item) + (let* ((item-pos (car item)) + (ind (nth 1 item)) + (prev-ind (caar acc))) + (cond + ;; List closing. + ((> prev-ind ind) + (let ((current-origin (or (member (assq ind acc) acc) + ;; needed if top-point is + ;; not the most outdented + (last acc)))) + (setq acc current-origin) + (cons item-pos (cdar acc)))) + ;; New list + ((< prev-ind ind) + (let ((origin (funcall prev-item item-pos))) + (setq acc (cons (cons ind origin) acc)) + (cons item-pos origin))) + ;; Current list going on + (t (cons item-pos (cdar acc)))))))) + (cons '(0 . 0) (mapcar get-origins (cdr struct))))) + +(defun org-list-struct-get-parent (item struct origins) + "Return parent association of ITEM in STRUCT or nil. +ORIGINS is the alist of parents. See `org-list-struct-origins'." + (let* ((parent-pos (cdr (assq (car item) origins)))) + (when (> parent-pos 0) (assq parent-pos struct)))) + +(defun org-list-struct-get-child (item struct) + "Return child association of ITEM in STRUCT or nil." + (let ((ind (nth 1 item)) + (next-item (cadr (member item struct)))) + (when (and next-item (> (nth 1 next-item) ind)) next-item))) + +(defun org-list-struct-fix-bul (struct origins) + "Verify and correct bullets for every association in STRUCT. +ORIGINS is the alist of parents. See `org-list-struct-origins'. + +This function modifies STRUCT." + (let* (acc + (init-bul (lambda (item) + (let ((counter (nth 3 item)) + (bullet (org-list-bullet-string (nth 2 item)))) + (cond + ((and (string-match "[0-9]+" bullet) counter) + (replace-match counter nil nil bullet)) + ((string-match "[0-9]+" bullet) + (replace-match "1" nil nil bullet)) + (t bullet))))) + (set-bul (lambda (item bullet) + (setcdr item (list (nth 1 item) bullet (nth 3 item))))) + (get-bul (lambda (item bullet) + (let* ((counter (nth 3 item))) + (if (and counter (string-match "[0-9]+" bullet)) + (replace-match counter nil nil bullet) + bullet)))) + (fix-bul + (lambda (item) struct + (let* ((parent (cdr (assq (car item) origins))) + (orig-ref (assq parent acc))) + (if orig-ref + ;; Continuing previous list + (let* ((prev-bul (cdr orig-ref)) + (new-bul (funcall get-bul item prev-bul))) + (setcdr orig-ref (org-list-inc-bullet-maybe new-bul)) + (funcall set-bul item new-bul)) + ;; A new list is starting + (let ((new-bul (funcall init-bul item))) + (funcall set-bul item new-bul) + (setq acc (cons (cons parent + (org-list-inc-bullet-maybe new-bul)) + acc)))))))) + (mapc fix-bul (cdr struct)))) + +(defun org-list-struct-fix-ind (struct origins) + "Verify and correct indentation for every association in STRUCT. +ORIGINS is the alist of parents. See `org-list-struct-origins'. + +This function modifies STRUCT." + (let* ((headless (cdr struct)) + (ancestor (car struct)) + (top-ind (+ (nth 1 ancestor) (length (nth 2 ancestor)))) + (new-ind + (lambda (item) + (let* ((parent (org-list-struct-get-parent item headless origins))) + (if parent + ;; Indent like parent + length of parent's bullet + (setcdr item (cons (+ (length (nth 2 parent)) (nth 1 parent)) + (cddr item))) + ;; If no parent, indent like top-point + (setcdr item (cons top-ind (cddr item)))))))) + (mapc new-ind headless))) + +(defun org-list-struct-fix-struct (struct origins) + "Return STRUCT with correct bullets and indentation. +ORIGINS is the alist of parents. See `org-list-struct-origins'. + +Only elements of STRUCT that have changed are returned." + (let ((old (copy-alist struct))) + (org-list-struct-fix-bul struct origins) + (org-list-struct-fix-ind struct origins) + (delq nil (mapcar (lambda (e) (when (not (equal (pop old) e)) e)) struct)))) + +(defun org-list-struct-outdent (start end origins) + "Outdent items in a structure. +Items are indented when their key is between START, included, and +END, excluded. + +ORIGINS is the alist of parents. See `org-list-struct-origins'. + +STRUCT is the concerned structure." + (let* (acc + (out (lambda (cell) + (let* ((item (car cell)) + (parent (cdr cell))) + (cond + ;; Item not yet in zone: keep association + ((< item start) cell) + ;; Item out of zone: follow associations in acc + ((>= item end) + (let ((convert (assq parent acc))) + (if convert (cons item (cdr convert)) cell))) + ;; Item has no parent: error + ((<= parent 0) + (error "Cannot outdent top-level items")) + ;; Parent is outdented: keep association + ((>= parent start) + (setq acc (cons (cons parent item) acc)) cell) + (t + ;; Parent isn't outdented: reparent to grand-parent + (let ((grand-parent (cdr (assq parent origins)))) + (setq acc (cons (cons parent item) acc)) + (cons item grand-parent)))))))) + (mapcar out origins))) + +(defun org-list-struct-indent (start end origins struct) + "Indent items in a structure. +Items are indented when their key is between START, included, and +END, excluded. + +ORIGINS is the alist of parents. See `org-list-struct-origins'. + +STRUCT is the concerned structure. It may be modified if +`org-list-demote-modify-bullet' matches bullets between START and +END." + (let* (acc + (orig-rev (reverse origins)) + (get-prev-item + (lambda (cell parent) + (car (rassq parent (cdr (memq cell orig-rev)))))) + (set-assoc + (lambda (cell) + (setq acc (cons cell acc)) cell)) + (change-bullet-maybe + (lambda (item) + (let* ((full-item (assq item struct)) + (item-bul (org-trim (nth 2 full-item))) + (new-bul-p (cdr (assoc item-bul org-list-demote-modify-bullet)))) + (when new-bul-p + ;; new bullet is stored without space to ensure item + ;; will be modified + (setcdr full-item + (list (nth 1 full-item) + new-bul-p + (nth 3 full-item))))))) + (ind + (lambda (cell) + (let* ((item (car cell)) + (parent (cdr cell))) + (cond + ;; Item not yet in zone: keep association + ((< item start) cell) + ((>= item end) + ;; Item out of zone: follow associations in acc + (let ((convert (assq parent acc))) + (if convert (cons item (cdr convert)) cell))) + (t + ;; Item is in zone... + (let ((prev (funcall get-prev-item cell parent))) + ;; Check if bullet needs to be changed + (funcall change-bullet-maybe item) + (cond + ;; First item indented but not parent: error + ((and (or (not prev) (= prev 0)) (< parent start)) + (error "Cannot indent the first item of a list")) + ;; First item and parent indented: keep same parent + ((or (not prev) (= prev 0)) + (funcall set-assoc cell)) + ;; Previous item not indented: reparent to it + ((< prev start) + (funcall set-assoc (cons item prev))) + ;; Previous item indented: reparent like it + (t + (funcall set-assoc (cons item + (cdr (assq prev acc))))))))))))) + (mapcar ind origins))) + +(defun org-list-struct-apply-struct (struct bottom) + "Apply modifications to list so it mirrors STRUCT. +BOTTOM is position at list ending. + +Initial position is restored after the changes." + (let* ((pos (copy-marker (point))) + (ancestor (caar struct)) + (modify + (lambda (item) + (goto-char (car item)) + (let* ((new-ind (nth 1 item)) + (new-bul (org-list-bullet-string (nth 2 item))) + (old-ind (org-get-indentation)) + (old-bul (progn + (looking-at "[ \t]*\\(\\S-+[ \t]*\\)") + (match-string 1))) + (old-body-ind (+ (length old-bul) old-ind)) + (new-body-ind (+ (length new-bul) new-ind))) + ;; 1. Shift item's body + (unless (= old-body-ind new-body-ind) + (org-shift-item-indentation + (- new-body-ind old-body-ind) bottom)) + ;; 2. Replace bullet + (unless (equal new-bul old-bul) + (save-excursion + (looking-at "[ \t]*\\(\\S-+[ \t]*\\)") + (replace-match new-bul nil nil nil 1))) + ;; 3. Indent item to appropriate column + (unless (= new-ind old-ind) + (delete-region (point-at-bol) + (progn + (skip-chars-forward " \t") + (point))) + (indent-to new-ind))))) + ;; Remove ancestor if it is left. + (struct-to-apply (if (or (not ancestor) (= 0 ancestor)) + (cdr struct) + struct))) + ;; Apply changes from bottom to top + (mapc modify (nreverse struct-to-apply)) + (goto-char pos))) + +;;; Indentation + +(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-shift-item-indentation (delta bottom) + "Shift the indentation in current item by DELTA. +Sub-items are not moved. + +BOTTOM is position at list ending." + (save-excursion + (let ((beg (point-at-bol)) + (end (org-end-of-item-or-at-child bottom))) + (beginning-of-line (unless (eolp) 0)) + (while (> (point) beg) + (when (looking-at "[ \t]*\\S-") + ;; this is not an empty line + (let ((i (org-get-indentation))) + (when (and (> i 0) (> (+ i delta) 0)) + (org-indent-line-to (+ i delta))))) + (beginning-of-line 0))))) + +(defun org-outdent-item () + "Outdent a local list item, but not its children. +If a region is active, all items inside will be moved." + (interactive) + (org-list-indent-item-generic + -1 t (org-list-top-point) (org-list-bottom-point))) + +(defun org-indent-item () + "Indent a local list item, but not its children. +If a region is active, all items inside will be moved." + (interactive) + (org-list-indent-item-generic + 1 t (org-list-top-point) (org-list-bottom-point))) + +(defun org-outdent-item-tree () + "Outdent a local list item including its children. +If a region is active, all items inside will be moved." + (interactive) + (org-list-indent-item-generic + -1 nil (org-list-top-point) (org-list-bottom-point))) + +(defun org-indent-item-tree () + "Indent a local list item including its children. +If a region is active, all items inside will be moved." + (interactive) + (org-list-indent-item-generic + 1 nil (org-list-top-point) (org-list-bottom-point))) + +(defvar org-tab-ind-state) +(defun org-cycle-item-indentation () + "Cycle levels of indentation of an empty item. +The first run indent the item, if applicable. Subsequents runs +outdent it at meaningful levels in the list. When done, item is +put back at its original position with its original bullet. + +Return t at each successful move." + (let ((org-adapt-indentation nil) + (ind (org-get-indentation)) + (bottom (and (org-at-item-p) (org-list-bottom-point)))) + (when (and (or (org-at-item-description-p) + (org-at-item-checkbox-p) + (org-at-item-p)) + ;; Check that item is really empty + (>= (match-end 0) (save-excursion + (org-end-of-item-or-at-child bottom) + (skip-chars-backward " \r\t\n") + (point)))) + (setq this-command 'org-cycle-item-indentation) + (let ((top (org-list-top-point))) + ;; When in the middle of the cycle, try to outdent first. If it + ;; fails, and point is still at initial position, indent. Else, + ;; go back to original position. + (if (eq last-command 'org-cycle-item-indentation) + (cond + ((ignore-errors (org-list-indent-item-generic -1 t top bottom))) + ((and (= (org-get-indentation) (car org-tab-ind-state)) + (ignore-errors + (org-list-indent-item-generic 1 t top bottom)))) + (t (back-to-indentation) + (org-indent-to-column (car org-tab-ind-state)) + (end-of-line) + (org-list-repair (cdr org-tab-ind-state)) + ;; Break cycle + (setq this-command 'identity))) + ;; If a cycle is starting, remember indentation and bullet, + ;; then try to indent. If it fails, try to outdent. + (setq org-tab-ind-state (cons ind (org-get-bullet))) + (cond + ((ignore-errors (org-list-indent-item-generic 1 t top bottom))) + ((ignore-errors (org-list-indent-item-generic -1 t top bottom))) + (t (error "Cannot move item"))))) + t))) + +;;; Bullets + +(defun org-get-bullet () + "Return the bullet of the item at point. +Assume cursor is at an item." + (save-excursion + (beginning-of-line) + (and (looking-at "[ \t]*\\(\\S-+\\)") (match-string 1)))) + +(defun org-list-bullet-string (bullet) + "Return BULLET with the correct number of whitespaces. +It determines the number of whitespaces to append by looking at +`org-list-two-spaces-after-bullet-regexp'." + (save-match-data + (string-match "\\S-+\\([ \t]*\\)" bullet) + (replace-match + (save-match-data + (concat + " " + ;; Do we need to concat another white space ? + (when (and org-list-two-spaces-after-bullet-regexp + (string-match org-list-two-spaces-after-bullet-regexp bullet)) + " "))) + nil nil bullet 1))) + +(defun org-list-inc-bullet-maybe (bullet) + "Increment BULLET if applicable." + (if (string-match "[0-9]+" bullet) + (replace-match + (number-to-string (1+ (string-to-number (match-string 0 bullet)))) + nil nil bullet) + bullet)) + +(defun org-list-repair (&optional force-bullet top bottom) + "Make sure all items are correctly indented, with the right bullet. +This function scans the list at point, along with any sublist. + +If FORCE-BULLET is a string, ensure all items in list share this +bullet, or a logical successor in the case of an ordered list. + +When non-nil, TOP and BOTTOM specify respectively position of +list beginning and list ending. + +Item's body is not indented, only shifted with the bullet." + (interactive) + (unless (org-at-item-p) (error "This is not a list")) + (let* ((bottom (or bottom (org-list-bottom-point))) + (struct (org-list-struct + (point-at-bol) (point-at-eol) + (or top (org-list-top-point)) bottom)) + (origins (org-list-struct-origins struct)) + fixed-struct) + (if (stringp force-bullet) + (let ((begin (nth 1 struct))) + (setcdr begin (list (nth 1 begin) + (org-list-bullet-string force-bullet) + (nth 3 begin))) + (setq fixed-struct + (cons begin (org-list-struct-fix-struct struct origins)))) + (setq fixed-struct (org-list-struct-fix-struct struct origins))) + (org-list-struct-apply-struct fixed-struct bottom))) + +(defun org-cycle-list-bullet (&optional which) + "Cycle through the different itemize/enumerate bullets. +This cycle the entire list level through the sequence: + + `-' -> `+' -> `*' -> `1.' -> `1)' + +If WHICH is a valid string, use that as the new bullet. If WHICH +is an integer, 0 means `-', 1 means `+' etc. If WHICH is +'previous, cycle backwards." + (interactive "P") + (save-excursion + (let* ((top (org-list-top-point)) + (bullet (progn + (goto-char (org-get-beginning-of-list top)) + (org-get-bullet))) + (current (cond + ((string-match "\\." bullet) "1.") + ((string-match ")" bullet) "1)") + (t bullet))) + (bullet-rule-p (cdr (assq 'bullet org-list-automatic-rules))) + (bullet-list (append '("-" "+" ) + ;; *-bullets are not allowed at column 0 + (unless (and bullet-rule-p + (looking-at "\\S-")) '("*")) + ;; Description items cannot be numbered + (unless (and bullet-rule-p + (or (eq org-plain-list-ordered-item-terminator ?\)) + (org-at-item-description-p))) '("1.")) + (unless (and bullet-rule-p + (or (eq org-plain-list-ordered-item-terminator ?.) + (org-at-item-description-p))) '("1)")))) + (len (length bullet-list)) + (item-index (- len (length (member current bullet-list)))) + (get-value (lambda (index) (nth (mod index len) bullet-list))) + (new (cond + ((member which bullet-list) which) + ((numberp which) (funcall get-value which)) + ((eq 'previous which) (funcall get-value (1- item-index))) + (t (funcall get-value (1+ item-index)))))) + (org-list-repair new top)))) + +;;; Checkboxes + +(defun org-toggle-checkbox (&optional toggle-presence) + "Toggle the checkbox in the current line. +With prefix arg TOGGLE-PRESENCE, add or remove checkboxes. With +double prefix, set checkbox to [-]. + +When there is an active region, toggle status or presence of the +first checkbox there, and make every item inside have the +same status or presence, respectively. + +If the cursor is in a headline, apply this to all checkbox items +in the text below the heading, taking as reference the first item +in subtree, ignoring drawers." + (interactive "P") + ;; Bounds is a list of type (beg end single-p) where single-p is t + ;; when `org-toggle-checkbox' is applied to a single item. Only + ;; toggles on single items will return errors. + (let* ((bounds + (cond + ((org-region-active-p) + (let ((rbeg (region-beginning)) + (rend (region-end))) + (save-excursion + (goto-char rbeg) + (if (org-search-forward-unenclosed org-item-beginning-re rend 'move) + (list (point-at-bol) rend nil) + (error "No item in region"))))) + ((org-on-heading-p) + ;; In this case, reference line is the first item in + ;; subtree outside drawers + (let ((pos (point)) + (limit (save-excursion (outline-next-heading) (point)))) + (save-excursion + (goto-char limit) + (org-search-backward-unenclosed ":END:" pos 'move) + (org-search-forward-unenclosed + org-item-beginning-re limit 'move) + (list (point) limit nil)))) + ((org-at-item-p) + (list (point-at-bol) (1+ (point-at-eol)) t)) + (t (error "Not at an item or heading, and no active region")))) + (beg (car bounds)) + ;; marker is needed because deleting or inserting checkboxes + ;; will change bottom point + (end (copy-marker (nth 1 bounds))) + (single-p (nth 2 bounds)) + (ref-presence (save-excursion + (goto-char beg) + (org-at-item-checkbox-p))) + (ref-status (equal (match-string 1) "[X]")) + (act-on-item + (lambda (ref-pres ref-stat) + (if (equal toggle-presence '(4)) + (cond + ((and ref-pres (org-at-item-checkbox-p)) + (replace-match "")) + ((and (not ref-pres) + (not (org-at-item-checkbox-p)) + (org-at-item-p)) + (goto-char (match-end 0)) + ;; Ignore counter, if any + (when (looking-at "\\(?:\\[@\\(?:start:\\)?[0-9]+\\][ \t]*\\)?") + (goto-char (match-end 0))) + (let ((desc-p (and (org-at-item-description-p) + (cdr (assq 'checkbox org-list-automatic-rules))))) + (cond + ((and single-p desc-p) + (error "Cannot add a checkbox in a description list")) + ((not desc-p) (insert "[ ] ")))))) + (let ((blocked (org-checkbox-blocked-p))) + (cond + ((and blocked single-p) + (error "Checkbox blocked because of unchecked box in line %d" blocked)) + (blocked nil) + ((org-at-item-checkbox-p) + (replace-match + (cond ((equal toggle-presence '(16)) "[-]") + (ref-stat "[ ]") + (t "[X]")) + t t nil 1)))))))) + (save-excursion + (goto-char beg) + (while (< (point) end) + (funcall act-on-item ref-presence ref-status) + (org-search-forward-unenclosed org-item-beginning-re end 'move))) + (org-update-checkbox-count-maybe))) + +(defun org-reset-checkbox-state-subtree () + "Reset all checkboxes in an entry subtree." + (interactive "*") + (save-restriction + (save-excursion + (org-narrow-to-subtree) + (org-show-subtree) + (goto-char (point-min)) + (let ((end (point-max))) + (while (< (point) end) + (when (org-at-item-checkbox-p) + (replace-match "[ ]" t t nil 1)) + (beginning-of-line 2)))) + (org-update-checkbox-count-maybe))) + +(defvar org-checkbox-statistics-hook nil + "Hook that is run whenever Org thinks checkbox statistics should be updated. +This hook runs even if checkbox rule in +`org-list-automatic-rules' does not apply, so it can be used to +implement alternative ways of collecting statistics +information.") + +(defun org-update-checkbox-count-maybe () + "Update checkbox statistics unless turned off by user." + (when (cdr (assq 'checkbox org-list-automatic-rules)) + (org-update-checkbox-count)) + (run-hooks 'org-checkbox-statistics-hook)) + +(defun org-update-checkbox-count (&optional all) + "Update the checkbox statistics in the current section. +This will find all statistic cookies like [57%] and [6/12] and update them +with the current numbers. With optional prefix argument ALL, do this for +the whole buffer." + (interactive "P") + (save-excursion + (let ((cstat 0)) + (catch 'exit + (while t + (let* ((buffer-invisibility-spec (org-inhibit-invisibility)) ; Emacs 21 + (beg (condition-case nil + (progn (org-back-to-heading) (point)) + (error (point-min)))) + (end (copy-marker (save-excursion + (outline-next-heading) (point)))) + (re-cookie "\\(\\(\\[[0-9]*%\\]\\)\\|\\(\\[[0-9]*/[0-9]*\\]\\)\\)") + (re-box "^[ \t]*\\([-+*]\\|[0-9]+[.)]\\)[ \t]+\\(?:\\[@\\(?:start:\\)?[0-9]+\\][ \t]*\\)?\\(\\[[- X]\\]\\)") + beg-cookie end-cookie is-percent c-on c-off lim new + curr-ind next-ind continue-from startsearch list-beg list-end + (recursive + (or (not org-hierarchical-checkbox-statistics) + (string-match "\\<recursive\\>" + (or (ignore-errors + (org-entry-get nil "COOKIE_DATA")) + ""))))) + (goto-char end) + ;; find each statistics cookie + (while (and (org-search-backward-unenclosed re-cookie beg 'move) + (not (save-match-data + (and (org-on-heading-p) + (string-match "\\<todo\\>" + (downcase + (or (org-entry-get + nil "COOKIE_DATA") + ""))))))) + (setq beg-cookie (match-beginning 1) + end-cookie (match-end 1) + cstat (+ cstat (if end-cookie 1 0)) + startsearch (point-at-eol) + continue-from (match-beginning 0) + is-percent (match-beginning 2) + lim (cond + ((org-on-heading-p) (outline-next-heading) (point)) + ;; Ensure many cookies in the same list won't imply + ;; computing list boundaries as many times. + ((org-at-item-p) + (unless (and list-beg (>= (point) list-beg)) + (setq list-beg (org-list-top-point) + list-end (copy-marker + (org-list-bottom-point)))) + (org-get-end-of-item list-end)) + (t nil)) + c-on 0 + c-off 0) + (when lim + ;; find first checkbox for this cookie and gather + ;; statistics from all that are at this indentation level + (goto-char startsearch) + (if (org-search-forward-unenclosed re-box lim t) + (progn + (beginning-of-line) + (setq curr-ind (org-get-indentation)) + (setq next-ind curr-ind) + (while (and (bolp) (org-at-item-p) + (if recursive + (<= curr-ind next-ind) + (= curr-ind next-ind))) + (when (org-at-item-checkbox-p) + (if (member (match-string 1) '("[ ]" "[-]")) + (setq c-off (1+ c-off)) + (setq c-on (1+ c-on)))) + (if (not recursive) + ;; org-get-next-item goes through list-enders + ;; with proper limit. + (goto-char (or (org-get-next-item (point) lim) lim)) + (end-of-line) + (when (org-search-forward-unenclosed + org-item-beginning-re lim t) + (beginning-of-line))) + (setq next-ind (org-get-indentation))))) + (goto-char continue-from) + ;; update cookie + (when end-cookie + (setq new (if is-percent + (format "[%d%%]" (/ (* 100 c-on) + (max 1 (+ c-on c-off)))) + (format "[%d/%d]" c-on (+ c-on c-off)))) + (goto-char beg-cookie) + (insert new) + (delete-region (point) (+ (point) (- end-cookie beg-cookie)))) + ;; update items checkbox if it has one + (when (and (org-at-item-checkbox-p) + (> (+ c-on c-off) 0)) + (setq beg-cookie (match-beginning 1) + end-cookie (match-end 1)) + (delete-region beg-cookie end-cookie) + (goto-char beg-cookie) + (cond ((= c-off 0) (insert "[X]")) + ((= c-on 0) (insert "[ ]")) + (t (insert "[-]"))))) + (goto-char continue-from))) + (unless (and all (outline-next-heading)) (throw 'exit nil)))) + (when (interactive-p) + (message "Checkbox statistics updated %s (%d places)" + (if all "in entire file" "in current outline entry") cstat))))) + +(defun org-get-checkbox-statistics-face () + "Select the face for checkbox statistics. +The face will be `org-done' when all relevant boxes are checked. +Otherwise it will be `org-todo'." + (if (match-end 1) + (if (equal (match-string 1) "100%") + 'org-checkbox-statistics-done + 'org-checkbox-statistics-todo) + (if (and (> (match-end 2) (match-beginning 2)) + (equal (match-string 2) (match-string 3))) + 'org-checkbox-statistics-done + 'org-checkbox-statistics-todo))) + +;;; Misc Tools + +(defun org-apply-on-list (function init-value &rest args) + "Call FUNCTION on each item of the list at point. +FUNCTION must be called with at least one argument: INIT-VALUE, +that will contain the value returned by the function at the +previous item, plus ARGS extra arguments. + +As an example, (org-apply-on-list (lambda (result) (1+ result)) 0) +will return the number of items in the current list. + +Sublists of the list are skipped. Cursor is always at the +beginning of the item." + (let* ((pos (copy-marker (point))) + (end (copy-marker (org-list-bottom-point))) + (next-p (copy-marker (org-get-beginning-of-list (org-list-top-point)))) + (value init-value)) + (while (< next-p end) + (goto-char next-p) + (set-marker next-p (or (org-get-next-item (point) end) end)) + (setq value (apply function value args))) + (goto-char pos) + value)) + +(defun org-sort-list (&optional with-case sorting-type getkey-func compare-func) + "Sort plain list items. +The cursor may be at any item of the list that should be sorted. +Sublists are not sorted. Checkboxes, if any, are ignored. + +Sorting can be alphabetically, numerically, by date/time as given by +a time stamp, by a property or by priority. + +Comparing entries ignores case by default. However, with an +optional argument WITH-CASE, the sorting considers case as well. + +The command prompts for the sorting type unless it has been given +to the function through the SORTING-TYPE argument, which needs to +be a character, \(?n ?N ?a ?A ?t ?T ?f ?F). Here is the precise +meaning of each character: + +n Numerically, by converting the beginning of the item to a number. +a Alphabetically. Only the first line of item is checked. +t By date/time, either the first active time stamp in the entry, if + any, or by the first inactive one. In a timer list, sort the timers. + +Capital letters will reverse the sort order. + +If the SORTING-TYPE is ?f or ?F, then GETKEY-FUNC specifies a +function to be called with point at the beginning of the record. +It must return either a string or a number that should serve as +the sorting key for that record. It will then use COMPARE-FUNC to +compare entries." + (interactive "P") + (let* ((case-func (if with-case 'identity 'downcase)) + (top (org-list-top-point)) + (bottom (org-list-bottom-point)) + (start (org-get-beginning-of-list top)) + (end (org-get-end-of-list bottom)) + (sorting-type + (progn + (message + "Sort plain list: [a]lpha [n]umeric [t]ime [f]unc A/N/T/F means reversed:") + (read-char-exclusive))) + (getkey-func (and (= (downcase sorting-type) ?f) + (org-icompleting-read "Sort using function: " + obarray 'fboundp t nil nil) + (intern getkey-func)))) + (message "Sorting items...") + (save-restriction + (narrow-to-region start end) + (goto-char (point-min)) + (let* ((dcst (downcase sorting-type)) + (case-fold-search nil) + (now (current-time)) + (sort-func (cond + ((= dcst ?a) 'string<) + ((= dcst ?f) compare-func) + ((= dcst ?t) '<) + (t nil))) + (begin-record (lambda () + (skip-chars-forward " \r\t\n") + (beginning-of-line))) + (end-record (lambda () + (goto-char (org-end-of-item-before-blank end)))) + (value-to-sort + (lambda () + (when (looking-at "[ \t]*[-+*0-9.)]+\\([ \t]+\\[[- X]\\]\\)?[ \t]+") + (cond + ((= dcst ?n) + (string-to-number (buffer-substring (match-end 0) + (point-at-eol)))) + ((= dcst ?a) + (buffer-substring (match-end 0) (point-at-eol))) + ((= dcst ?t) + (cond + ;; If it is a timer list, convert timer to seconds + ((org-at-item-timer-p) + (org-timer-hms-to-secs (match-string 1))) + ((or (org-search-forward-unenclosed org-ts-regexp + (point-at-eol) t) + (org-search-forward-unenclosed org-ts-regexp-both + (point-at-eol) t)) + (org-time-string-to-seconds (match-string 0))) + (t (org-float-time now)))) + ((= dcst ?f) + (if getkey-func + (let ((value (funcall getkey-func))) + (if (stringp value) + (funcall case-func value) + value)) + (error "Invalid key function `%s'" getkey-func))) + (t (error "Invalid sorting type `%c'" sorting-type))))))) + (sort-subr (/= dcst sorting-type) + begin-record + end-record + value-to-sort + nil + sort-func) + (org-list-repair nil top bottom) + (run-hooks 'org-after-sorting-entries-or-items-hook) + (message "Sorting items...done"))))) + +;;; Send and receive lists + +(defun org-list-parse-list (&optional delete) + "Parse the list at point and maybe DELETE it. +Return a list containing first level items as strings and +sublevels as a list of strings." + (let* ((start (goto-char (org-list-top-point))) + (end (org-list-bottom-point)) + output itemsep ltype) + (while (org-search-forward-unenclosed org-item-beginning-re end t) + (save-excursion + (beginning-of-line) + (setq ltype (cond ((org-looking-at-p "^[ \t]*[0-9]") 'ordered) + ((org-at-item-description-p) 'descriptive) + (t 'unordered)))) + (let* ((indent1 (org-get-indentation)) + (nextitem (or (org-get-next-item (point) end) end)) + (item (org-trim (buffer-substring (point) + (org-end-of-item-or-at-child end)))) + (nextindent (if (= (point) end) 0 (org-get-indentation))) + (item (if (string-match + "^\\(?:\\[@\\(?:start:\\)?[0-9]+\\][ \t]*\\)?\\[\\([xX ]\\)\\]" + item) + (replace-match (if (equal (match-string 1 item) " ") + "CBOFF" + "CBON") + t nil item 1) + item))) + (push item output) + (when (> nextindent indent1) + (save-restriction + (narrow-to-region (point) nextitem) + (push (org-list-parse-list) output))))) + (when delete + (delete-region start end) + (save-match-data + (when (and (not (eq org-list-ending-method 'indent)) + (looking-at (org-list-end-re))) + (replace-match "\n")))) + (setq output (nreverse output)) + (push ltype output))) + +(defun org-list-make-subtree () + "Convert the plain list at point into a subtree." + (interactive) + (if (not (org-in-item-p)) + (error "Not in a list") + (let ((list (org-list-parse-list t)) nstars) + (save-excursion + (if (ignore-errors + (org-back-to-heading)) + (progn (looking-at org-complex-heading-regexp) + (setq nstars (length (match-string 1)))) + (setq nstars 0))) + (org-list-make-subtrees list (1+ nstars))))) + +(defun org-list-make-subtrees (list level) + "Convert LIST into subtrees starting at LEVEL." + (if (symbolp (car list)) + (org-list-make-subtrees (cdr list) level) + (mapcar (lambda (item) + (if (stringp item) + (insert (make-string + (if org-odd-levels-only + (1- (* 2 level)) level) ?*) " " item "\n") + (org-list-make-subtrees item (1+ level)))) + list))) + +(defun org-list-insert-radio-list () + "Insert a radio list template appropriate for this major mode." + (interactive) + (let* ((e (assq major-mode org-list-radio-list-templates)) + (txt (nth 1 e)) + name pos) + (unless e (error "No radio list setup defined for %s" major-mode)) + (setq name (read-string "List name: ")) + (while (string-match "%n" txt) + (setq txt (replace-match name t t txt))) + (or (bolp) (insert "\n")) + (setq pos (point)) + (insert txt) + (goto-char pos))) + +(defun org-list-send-list (&optional maybe) + "Send a transformed version of this list to the receiver position. +With argument MAYBE, fail quietly if no transformation is defined for +this list." + (interactive) + (catch 'exit + (unless (org-at-item-p) (error "Not at a list item")) + (save-excursion + (re-search-backward "#\\+ORGLST" nil t) + (unless (looking-at "[ \t]*#\\+ORGLST[: \t][ \t]*SEND[ \t]+\\([^ \t\r\n]+\\)[ \t]+\\([^ \t\r\n]+\\)\\([ \t]+.*\\)?") + (if maybe + (throw 'exit nil) + (error "Don't know how to transform this list")))) + (let* ((name (match-string 1)) + (transform (intern (match-string 2))) + (bottom-point + (save-excursion + (re-search-forward + "\\(\\\\end{comment}\\|@end ignore\\|-->\\)" nil t) + (match-beginning 0))) + (top-point + (progn + (re-search-backward "#\\+ORGLST" nil t) + (re-search-forward org-item-beginning-re bottom-point t) + (match-beginning 0))) + (list (save-restriction + (narrow-to-region top-point bottom-point) + (org-list-parse-list))) + beg txt) + (unless (fboundp transform) + (error "No such transformation function %s" transform)) + (let ((txt (funcall transform list))) + ;; Find the insertion place + (save-excursion + (goto-char (point-min)) + (unless (re-search-forward + (concat "BEGIN RECEIVE ORGLST +" + name + "\\([ \t]\\|$\\)") nil t) + (error "Don't know where to insert translated list")) + (goto-char (match-beginning 0)) + (beginning-of-line 2) + (setq beg (point)) + (unless (re-search-forward (concat "END RECEIVE ORGLST +" name) nil t) + (error "Cannot find end of insertion region")) + (delete-region beg (point-at-bol)) + (goto-char beg) + (insert txt "\n"))) + (message "List converted and installed at receiver location")))) + +(defun org-list-to-generic (list params) + "Convert a LIST parsed through `org-list-parse-list' to other formats. +Valid parameters PARAMS are + +:ustart String to start an unordered list +:uend String to end an unordered list + +:ostart String to start an ordered list +:oend String to end an ordered list + +:dstart String to start a descriptive list +:dend String to end a descriptive list +:dtstart String to start a descriptive term +:dtend String to end a descriptive term +:ddstart String to start a description +:ddend String to end a description + +:splice When set to t, return only list body lines, don't wrap + them into :[u/o]start and :[u/o]end. Default is nil. + +:istart String to start a list item +:iend String to end a list item +:isep String to separate items +:lsep String to separate sublists + +:cboff String to insert for an unchecked checkbox +:cbon String to insert for a checked checkbox" + (interactive) + (let* ((p params) sublist + (splicep (plist-get p :splice)) + (ostart (plist-get p :ostart)) + (oend (plist-get p :oend)) + (ustart (plist-get p :ustart)) + (uend (plist-get p :uend)) + (dstart (plist-get p :dstart)) + (dend (plist-get p :dend)) + (dtstart (plist-get p :dtstart)) + (dtend (plist-get p :dtend)) + (ddstart (plist-get p :ddstart)) + (ddend (plist-get p :ddend)) + (istart (plist-get p :istart)) + (iend (plist-get p :iend)) + (isep (plist-get p :isep)) + (lsep (plist-get p :lsep)) + (cbon (plist-get p :cbon)) + (cboff (plist-get p :cboff))) + (let ((wrapper + (cond ((eq (car list) 'ordered) + (concat ostart "\n%s" oend "\n")) + ((eq (car list) 'unordered) + (concat ustart "\n%s" uend "\n")) + ((eq (car list) 'descriptive) + (concat dstart "\n%s" dend "\n")))) + rtn term defstart defend) + (while (setq sublist (pop list)) + (cond ((symbolp sublist) nil) + ((stringp sublist) + (when (string-match "^\\(.*\\)[ \t]+::" sublist) + (setq term (org-trim (format (concat dtstart "%s" dtend) + (match-string 1 sublist)))) + (setq sublist (concat ddstart + (org-trim (substring sublist + (match-end 0))) + ddend))) + (if (string-match "\\[CBON\\]" sublist) + (setq sublist (replace-match cbon t t sublist))) + (if (string-match "\\[CBOFF\\]" sublist) + (setq sublist (replace-match cboff t t sublist))) + (if (string-match "\\[-\\]" sublist) + (setq sublist (replace-match "$\\boxminus$" t t sublist))) + (setq rtn (concat rtn istart term sublist iend isep))) + (t (setq rtn (concat rtn ;; previous list + lsep ;; list separator + (org-list-to-generic sublist p) + lsep ;; list separator + ))))) + (format wrapper rtn)))) + +(defun org-list-to-latex (list &optional params) + "Convert LIST into a LaTeX list. +LIST is as returned by `org-list-parse-list'. PARAMS is a property list +with overruling parameters for `org-list-to-generic'." + (org-list-to-generic + list + (org-combine-plists + '(:splicep nil :ostart "\\begin{enumerate}" :oend "\\end{enumerate}" + :ustart "\\begin{itemize}" :uend "\\end{itemize}" + :dstart "\\begin{description}" :dend "\\end{description}" + :dtstart "[" :dtend "]" + :ddstart "" :ddend "" + :istart "\\item " :iend "" + :isep "\n" :lsep "\n" + :cbon "\\texttt{[X]}" :cboff "\\texttt{[ ]}") + params))) + +(defun org-list-to-html (list &optional params) + "Convert LIST into a HTML list. +LIST is as returned by `org-list-parse-list'. PARAMS is a property list +with overruling parameters for `org-list-to-generic'." + (org-list-to-generic + list + (org-combine-plists + '(:splicep nil :ostart "<ol>" :oend "</ol>" + :ustart "<ul>" :uend "</ul>" + :dstart "<dl>" :dend "</dl>" + :dtstart "<dt>" :dtend "</dt>" + :ddstart "<dd>" :ddend "</dd>" + :istart "<li>" :iend "</li>" + :isep "\n" :lsep "\n" + :cbon "<code>[X]</code>" :cboff "<code>[ ]</code>") + params))) + +(defun org-list-to-texinfo (list &optional params) + "Convert LIST into a Texinfo list. +LIST is as returned by `org-list-parse-list'. PARAMS is a property list +with overruling parameters for `org-list-to-generic'." + (org-list-to-generic + list + (org-combine-plists + '(:splicep nil :ostart "@itemize @minus" :oend "@end itemize" + :ustart "@enumerate" :uend "@end enumerate" + :dstart "@table" :dend "@end table" + :dtstart "@item " :dtend "\n" + :ddstart "" :ddend "" + :istart "@item\n" :iend "" + :isep "\n" :lsep "\n" + :cbon "@code{[X]}" :cboff "@code{[ ]}") + params))) + +(provide 'org-list) + +;; arch-tag: 73cf50c1-200f-4d1d-8a53-4e842a5b11c8 +;;; org-list.el ends here diff --git a/.emacs.d/org-7.4/lisp/org-list.elc b/.emacs.d/org-7.4/lisp/org-list.elc Binary files differnew file mode 100644 index 0000000..071c8b3 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-list.elc diff --git a/.emacs.d/org-7.4/lisp/org-mac-message.el b/.emacs.d/org-7.4/lisp/org-mac-message.el new file mode 100644 index 0000000..a146cc8 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-mac-message.el @@ -0,0 +1,219 @@ +;;; org-mac-message.el --- Links to Apple Mail.app messages from within Org-mode + +;; Copyright (C) 2008, 2009, 2010 Free Software Foundation, Inc. + +;; Author: John Wiegley <johnw@gnu.org> +;; Christopher Suckling <suckling at gmail dot com> + +;; Version: 7.4 +;; Keywords: outlines, hypermedia, calendar, wp + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; This file implements links to Apple Mail.app messages from within Org-mode. +;; Org-mode does not load this module by default - if you would actually like +;; this to happen then configure the variable `org-modules'. + +;; If you would like to create links to all flagged messages in an +;; Apple Mail.app account, please customize the variable +;; `org-mac-mail-account' and then call one of the following functions: + +;; (org-mac-message-insert-selected) copies a formatted list of links to +;; the kill ring. + +;; (org-mac-message-insert-selected) inserts at point links to any +;; messages selected in Mail.app. + +;; (org-mac-message-insert-flagged) searches within an org-mode buffer +;; for a specific heading, creating it if it doesn't exist. Any +;; message:// links within the first level of the heading are deleted +;; and replaced with links to flagged messages. + +;;; Code: + +(require 'org) + +(defgroup org-mac-flagged-mail nil + "Options concerning linking to flagged Mail.app messages" + :tag "Org Mail.app" + :group 'org-link) + +(defcustom org-mac-mail-account "customize" + "The Mail.app account in which to search for flagged messages." + :group 'org-mac-flagged-mail + :type 'string) + +(org-add-link-type "message" 'org-mac-message-open) + +;; In mac.c, removed in Emacs 23. +(declare-function do-applescript "org-mac-message" (script)) +(unless (fboundp 'do-applescript) + ;; Need to fake this using shell-command-to-string + (defun do-applescript (script) + (let (start cmd return) + (while (string-match "\n" script) + (setq script (replace-match "\r" t t script))) + (while (string-match "'" script start) + (setq start (+ 2 (match-beginning 0)) + script (replace-match "\\'" t t script))) + (setq cmd (concat "osascript -e '" script "'")) + (setq return (shell-command-to-string cmd)) + (concat "\"" (org-trim return) "\"")))) + +(defun org-mac-message-open (message-id) + "Visit the message with the given MESSAGE-ID. +This will use the command `open' with the message URL." + (start-process (concat "open message:" message-id) nil + "open" (concat "message://<" (substring message-id 2) ">"))) + +(defun as-get-selected-mail () + "AppleScript to create links to selected messages in Mail.app." + (do-applescript + (concat + "tell application \"Mail\"\n" + "set theLinkList to {}\n" + "set theSelection to selection\n" + "repeat with theMessage in theSelection\n" + "set theID to message id of theMessage\n" + "set theSubject to subject of theMessage\n" + "set theLink to \"message://\" & theID & \"::split::\" & theSubject & \"\n\"\n" + "copy theLink to end of theLinkList\n" + "end repeat\n" + "return theLinkList as string\n" + "end tell"))) + +(defun as-get-flagged-mail () + "AppleScript to create links to flagged messages in Mail.app." + (do-applescript + (concat + ;; Is Growl installed? + "tell application \"System Events\"\n" + "set growlHelpers to the name of every process whose creator type contains \"GRRR\"\n" + "if (count of growlHelpers) > 0 then\n" + "set growlHelperApp to item 1 of growlHelpers\n" + "else\n" + "set growlHelperApp to \"\"\n" + "end if\n" + "end tell\n" + + ;; Get links + "tell application \"Mail\"\n" + "set theMailboxes to every mailbox of account \"" org-mac-mail-account "\"\n" + "set theLinkList to {}\n" + "repeat with aMailbox in theMailboxes\n" + "set theSelection to (every message in aMailbox whose flagged status = true)\n" + "repeat with theMessage in theSelection\n" + "set theID to message id of theMessage\n" + "set theSubject to subject of theMessage\n" + "set theLink to \"message://\" & theID & \"::split::\" & theSubject & \"\n\"\n" + "copy theLink to end of theLinkList\n" + + ;; Report progress through Growl + ;; This "double tell" idiom is described in detail at + ;; http://macscripter.net/viewtopic.php?id=24570 The + ;; script compiler needs static knowledge of the + ;; growlHelperApp. Hmm, since we're compiling + ;; on-the-fly here, this is likely to be way less + ;; portable than I'd hoped. It'll work when the name + ;; is still "GrowlHelperApp", though. + "if growlHelperApp is not \"\" then\n" + "tell application \"GrowlHelperApp\"\n" + "tell application growlHelperApp\n" + "set the allNotificationsList to {\"FlaggedMail\"}\n" + "set the enabledNotificationsList to allNotificationsList\n" + "register as application \"FlaggedMail\" all notifications allNotificationsList default notifications enabledNotificationsList icon of application \"Mail\"\n" + "notify with name \"FlaggedMail\" title \"Importing flagged message\" description theSubject application name \"FlaggedMail\"\n" + "end tell\n" + "end tell\n" + "end if\n" + "end repeat\n" + "end repeat\n" + "return theLinkList as string\n" + "end tell"))) + +(defun org-mac-message-get-links (&optional select-or-flag) + "Create links to the messages currently selected or flagged in Mail.app. +This will use AppleScript to get the message-id and the subject of the +messages in Mail.app and make a link out of it. +When SELECT-OR-FLAG is \"s\", get the selected messages (this is also +the default). When SELECT-OR-FLAG is \"f\", get the flagged messages. +The Org-syntax text will be pushed to the kill ring, and also returned." + (interactive "sLink to (s)elected or (f)lagged messages: ") + (setq select-or-flag (or select-or-flag "s")) + (message "AppleScript: searching mailboxes...") + (let* ((as-link-list + (if (string= select-or-flag "s") + (as-get-selected-mail) + (if (string= select-or-flag "f") + (as-get-flagged-mail) + (error "Please select \"s\" or \"f\"")))) + (link-list + (mapcar + (lambda (x) (if (string-match "\\`\"\\(.*\\)\"\\'" x) (setq x (match-string 1 x))) x) + (split-string as-link-list "[\r\n]+"))) + split-link URL description orglink orglink-insert rtn orglink-list) + (while link-list + (setq split-link (split-string (pop link-list) "::split::")) + (setq URL (car split-link)) + (setq description (cadr split-link)) + (when (not (string= URL "")) + (setq orglink (org-make-link-string URL description)) + (push orglink orglink-list))) + (setq rtn (mapconcat 'identity orglink-list "\n")) + (kill-new rtn) + rtn)) + +(defun org-mac-message-insert-selected () + "Insert a link to the messages currently selected in Mail.app. +This will use AppleScript to get the message-id and the subject of the +active mail in Mail.app and make a link out of it." + (interactive) + (insert (org-mac-message-get-links "s"))) + +;; The following line is for backward compatibility +(defalias 'org-mac-message-insert-link 'org-mac-message-insert-selected) + +(defun org-mac-message-insert-flagged (org-buffer org-heading) + "Asks for an org buffer and a heading within it, and replace message links. +If heading exists, delete all message:// links within heading's first +level. If heading doesn't exist, create it at point-max. Insert +list of message:// links to flagged mail after heading." + (interactive "bBuffer in which to insert links: \nsHeading after which to insert links: ") + (with-current-buffer org-buffer + (goto-char (point-min)) + (let ((isearch-forward t) + (message-re "\\[\\[\\(message:\\)\\([^]]+\\)\\]\\(\\[\\([^]]+\\)\\]\\)?\\]")) + (if (org-goto-local-search-headings org-heading nil t) + (if (not (eobp)) + (progn + (save-excursion + (while (re-search-forward + message-re (save-excursion (outline-next-heading)) t) + (delete-region (match-beginning 0) (match-end 0))) + (insert "\n" (org-mac-message-get-links "f"))) + (flush-lines "^$" (point) (outline-next-heading))) + (insert "\n" (org-mac-message-get-links "f"))) + (goto-char (point-max)) + (insert "\n") + (org-insert-heading nil t) + (insert org-heading "\n" (org-mac-message-get-links "f")))))) + +(provide 'org-mac-message) + +;; arch-tag: 3806d0c1-abe1-4db6-9c31-f3ed7d4a9b32 + +;;; org-mac-message.el ends here diff --git a/.emacs.d/org-7.4/lisp/org-mac-message.elc b/.emacs.d/org-7.4/lisp/org-mac-message.elc Binary files differnew file mode 100644 index 0000000..75bda17 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-mac-message.elc diff --git a/.emacs.d/org-7.4/lisp/org-macs.el b/.emacs.d/org-7.4/lisp/org-macs.el new file mode 100644 index 0000000..97a8fdc --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-macs.el @@ -0,0 +1,349 @@ +;;; org-macs.el --- Top-level definitions for Org-mode + +;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010 +;; Free Software Foundation, Inc. + +;; Author: Carsten Dominik <carsten at orgmode dot org> +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; Version: 7.4 +;; +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: + +;; This file contains macro definitions, defsubst definitions, other +;; stuff needed for compilation and top-level forms in Org-mode, as well +;; lots of small functions that are not org-mode specific but simply +;; generally useful stuff. + +;;; Code: + +(eval-and-compile + (unless (fboundp 'declare-function) + (defmacro declare-function (fn file &optional arglist fileonly)))) + +(declare-function org-add-props "org-compat" (string plist &rest props)) +(declare-function org-string-match-p "org-compat" (&rest args)) + +(defmacro org-called-interactively-p (&optional kind) + `(if (featurep 'xemacs) + (interactive-p) + (if (or (> emacs-major-version 23) + (and (>= emacs-major-version 23) + (>= emacs-minor-version 2))) + (with-no-warnings (called-interactively-p ,kind)) ;; defined with no argument in <=23.1 + (interactive-p)))) + +(if (and (not (fboundp 'with-silent-modifications)) + (or (< emacs-major-version 23) + (and (= emacs-major-version 23) + (< emacs-minor-version 2)))) + (defmacro with-silent-modifications (&rest body) + `(org-unmodified ,@body))) + +(defmacro org-bound-and-true-p (var) + "Return the value of symbol VAR if it is bound, else nil." + `(and (boundp (quote ,var)) ,var)) + +(defun org-string-nw-p (s) + "Is S a string with a non-white character?" + (and (stringp s) + (org-string-match-p "\\S-" s) + s)) + +(defun org-not-nil (v) + "If V not nil, and also not the string \"nil\", then return V. +Otherwise return nil." + (and v (not (equal v "nil")) v)) + +(defmacro org-unmodified (&rest body) + "Execute body without changing `buffer-modified-p'. +Also, do not record undo information." + `(set-buffer-modified-p + (prog1 (buffer-modified-p) + (let ((buffer-undo-list t) + before-change-functions after-change-functions) + ,@body)))) + +(defmacro org-re (s) + "Replace posix classes in regular expression." + (if (featurep 'xemacs) + (let ((ss s)) + (save-match-data + (while (string-match "\\[:alnum:\\]" ss) + (setq ss (replace-match "a-zA-Z0-9" t t ss))) + (while (string-match "\\[:word:\\]" ss) + (setq ss (replace-match "a-zA-Z0-9" t t ss))) + (while (string-match "\\[:alpha:\\]" ss) + (setq ss (replace-match "a-zA-Z" t t ss))) + (while (string-match "\\[:punct:\\]" ss) + (setq ss (replace-match "\001-@[-`{-~" t t ss))) + ss)) + s)) + +(defmacro org-preserve-lc (&rest body) + `(let ((_line (org-current-line)) + (_col (current-column))) + (unwind-protect + (progn ,@body) + (org-goto-line _line) + (org-move-to-column _col)))) + +(defmacro org-without-partial-completion (&rest body) + `(let ((pc-mode (and (boundp 'partial-completion-mode) + partial-completion-mode))) + (unwind-protect + (progn + (if pc-mode (partial-completion-mode -1)) + ,@body) + (if pc-mode (partial-completion-mode 1))))) + +(defmacro org-maybe-intangible (props) + "Add '(intangible t) to PROPS if Emacs version is earlier than Emacs 22. +In Emacs 21, invisible text is not avoided by the command loop, so the +intangible property is needed to make sure point skips this text. +In Emacs 22, this is not necessary. The intangible text property has +led to problems with flyspell. These problems are fixed in flyspell.el, +but we still avoid setting the property in Emacs 22 and later. +We use a macro so that the test can happen at compilation time." + (if (< emacs-major-version 22) + `(append '(intangible t) ,props) + props)) + +(defmacro org-with-point-at (pom &rest body) + "Move to buffer and point of point-or-marker POM for the duration of BODY." + `(save-excursion + (if (markerp ,pom) (set-buffer (marker-buffer ,pom))) + (save-excursion + (goto-char (or ,pom (point))) + ,@body))) +(put 'org-with-point-at 'lisp-indent-function 1) + +(defmacro org-no-warnings (&rest body) + (cons (if (fboundp 'with-no-warnings) 'with-no-warnings 'progn) body)) + +(defmacro org-if-unprotected (&rest body) + "Execute BODY if there is no `org-protected' text property at point." + `(unless (get-text-property (point) 'org-protected) + ,@body)) + +(defmacro org-if-unprotected-1 (&rest body) + "Execute BODY if there is no `org-protected' text property at point-1." + `(unless (get-text-property (1- (point)) 'org-protected) + ,@body)) + +(defmacro org-if-unprotected-at (pos &rest body) + "Execute BODY if there is no `org-protected' text property at POS." + `(unless (get-text-property ,pos 'org-protected) + ,@body)) +(put 'org-if-unprotected-at 'lisp-indent-function 1) + +(defun org-re-search-forward-unprotected (&rest args) + "Like re-search-forward, but stop only in unprotected places." + (catch 'exit + (while t + (unless (apply 're-search-forward args) + (throw 'exit nil)) + (unless (get-text-property (match-beginning 0) 'org-protected) + (throw 'exit (point)))))) + +(defmacro org-with-remote-undo (_buffer &rest _body) + "Execute BODY while recording undo information in two buffers." + `(let ((_cline (org-current-line)) + (_cmd this-command) + (_buf1 (current-buffer)) + (_buf2 ,_buffer) + (_undo1 buffer-undo-list) + (_undo2 (with-current-buffer ,_buffer buffer-undo-list)) + _c1 _c2) + ,@_body + (when org-agenda-allow-remote-undo + (setq _c1 (org-verify-change-for-undo + _undo1 (with-current-buffer _buf1 buffer-undo-list)) + _c2 (org-verify-change-for-undo + _undo2 (with-current-buffer _buf2 buffer-undo-list))) + (when (or _c1 _c2) + ;; make sure there are undo boundaries + (and _c1 (with-current-buffer _buf1 (undo-boundary))) + (and _c2 (with-current-buffer _buf2 (undo-boundary))) + ;; remember which buffer to undo + (push (list _cmd _cline _buf1 _c1 _buf2 _c2) + org-agenda-undo-list))))) + +(defmacro org-no-read-only (&rest body) + "Inhibit read-only for BODY." + `(let ((inhibit-read-only t)) ,@body)) + +(defconst org-rm-props '(invisible t face t keymap t intangible t mouse-face t + rear-nonsticky t mouse-map t fontified t + org-emphasis t) + "Properties to remove when a string without properties is wanted.") + +(defsubst org-match-string-no-properties (num &optional string) + (if (featurep 'xemacs) + (let ((s (match-string num string))) + (and s (remove-text-properties 0 (length s) org-rm-props s)) + s) + (match-string-no-properties num string))) + +(defsubst org-no-properties (s) + (if (fboundp 'set-text-properties) + (set-text-properties 0 (length s) nil s) + (remove-text-properties 0 (length s) org-rm-props s)) + s) + +(defsubst org-get-alist-option (option key) + (cond ((eq key t) t) + ((eq option t) t) + ((assoc key option) (cdr (assoc key option))) + (t (cdr (assq 'default option))))) + +(defsubst org-check-external-command (cmd &optional use no-error) + "Check if external program CMD for USE exists, error if not. +When the program does exist, return its path. +When it does not exist and NO-ERROR is set, return nil. +Otherwise, throw an error. The optional argument USE can describe what this +program is needed for, so that the error message can be more informative." + (or (executable-find cmd) + (if no-error + nil + (error "Can't find `%s'%s" cmd + (if use (format " (%s)" use) ""))))) + +(defsubst org-inhibit-invisibility () + "Modified `buffer-invisibility-spec' for Emacs 21. +Some ops with invisible text do not work correctly on Emacs 21. For these +we turn off invisibility temporarily. Use this in a `let' form." + (if (< emacs-major-version 22) nil buffer-invisibility-spec)) + +(defsubst org-set-local (var value) + "Make VAR local in current buffer and set it to VALUE." + (set (make-local-variable var) value)) + +(defsubst org-mode-p () + "Check if the current buffer is in Org-mode." + (eq major-mode 'org-mode)) + +(defsubst org-last (list) + "Return the last element of LIST." + (car (last list))) + +(defun org-let (list &rest body) + (eval (cons 'let (cons list body)))) +(put 'org-let 'lisp-indent-function 1) + +(defun org-let2 (list1 list2 &rest body) + (eval (cons 'let (cons list1 (list (cons 'let (cons list2 body))))))) +(put 'org-let2 'lisp-indent-function 2) + +(defsubst org-call-with-arg (command arg) + "Call COMMAND interactively, but pretend prefix arg was ARG." + (let ((current-prefix-arg arg)) (call-interactively command))) + +(defsubst org-current-line (&optional pos) + (save-excursion + (and pos (goto-char pos)) + ;; works also in narrowed buffer, because we start at 1, not point-min + (+ (if (bolp) 1 0) (count-lines 1 (point))))) + +(defsubst org-goto-line (N) + (save-restriction + (widen) + (goto-char (point-min)) + (forward-line (1- N)))) + +(defsubst org-current-line-string (&optional to-here) + (buffer-substring (point-at-bol) (if to-here (point) (point-at-eol)))) + +(defsubst org-pos-in-match-range (pos n) + (and (match-beginning n) + (<= (match-beginning n) pos) + (>= (match-end n) pos))) + +(defun org-autoload (file functions) + "Establish autoload for all FUNCTIONS in FILE, if not bound already." + (let ((d (format "Documentation will be available after `%s.el' is loaded." + file)) + f) + (while (setq f (pop functions)) + (or (fboundp f) (autoload f file d t))))) + +(defun org-match-line (re) + "Looking-at at the beginning of the current line." + (save-excursion + (goto-char (point-at-bol)) + (looking-at re))) + +(defun org-plist-delete (plist property) + "Delete PROPERTY from PLIST. +This is in contrast to merely setting it to 0." + (let (p) + (while plist + (if (not (eq property (car plist))) + (setq p (plist-put p (car plist) (nth 1 plist)))) + (setq plist (cddr plist))) + p)) + +(defun org-replace-match-keep-properties (newtext &optional fixedcase + literal string) + "Like `replace-match', but add the text properties found original text." + (setq newtext (org-add-props newtext (text-properties-at + (match-beginning 0) string))) + (replace-match newtext fixedcase literal string)) + +(defmacro org-save-outline-visibility (use-markers &rest body) + "Save and restore outline visibility around BODY. +If USE-MARKERS is non-nil, use markers for the positions. +This means that the buffer may change while running BODY, +but it also means that the buffer should stay alive +during the operation, because otherwise all these markers will +point nowhere." + (declare (indent 1)) + `(let ((data (org-outline-overlay-data ,use-markers))) + (unwind-protect + (progn + ,@body + (org-set-outline-overlay-data data)) + (when ,use-markers + (mapc (lambda (c) + (and (markerp (car c)) (move-marker (car c) nil)) + (and (markerp (cdr c)) (move-marker (cdr c) nil))) + data))))) + +(defmacro org-with-limited-levels (&rest body) + "Execute BODY with limited number of outline levels." + `(let* ((outline-regexp (org-get-limited-outline-regexp))) + ,@body)) + +(defvar org-odd-levels-only) ; defined in org.el +(defvar org-inlinetask-min-level) ; defined in org-inlinetask.el +(defun org-get-limited-outline-regexp () + "Return outline-regexp with limited number of levels. +The number of levels is controlled by `org-inlinetask-min-level'" + (if (or (not (org-mode-p)) (not (featurep 'org-inlinetask))) + + outline-regexp + (let* ((limit-level (1- org-inlinetask-min-level)) + (nstars (if org-odd-levels-only (1- (* limit-level 2)) limit-level))) + (format "\\*\\{1,%d\\} " nstars)))) + +(provide 'org-macs) + +;; arch-tag: 7e6a73ce-aac9-4fc0-9b30-ce6f89dc6668 + +;;; org-macs.el ends here diff --git a/.emacs.d/org-7.4/lisp/org-macs.elc b/.emacs.d/org-7.4/lisp/org-macs.elc Binary files differnew file mode 100644 index 0000000..fd20f0f --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-macs.elc diff --git a/.emacs.d/org-7.4/lisp/org-mew.el b/.emacs.d/org-7.4/lisp/org-mew.el new file mode 100644 index 0000000..9636a1a --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-mew.el @@ -0,0 +1,140 @@ +;;; org-mew.el --- Support for links to Mew messages from within Org-mode + +;; Copyright (C) 2008, 2009, 2010 Free Software Foundation, Inc. + +;; Author: Tokuya Kameshima <kames at fa2 dot so-net dot ne dot jp> +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; Version: 7.4 + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: + +;; This file implements links to Mew messages from within Org-mode. +;; Org-mode loads this module by default - if this is not what you want, +;; configure the variable `org-modules'. + +;;; Code: + +(require 'org) + +(defgroup org-mew nil + "Options concerning the Mew link." + :tag "Org Startup" + :group 'org-link) + +(defcustom org-mew-link-to-refile-destination t + "Create a link to the refile destination if the message is marked as refile." + :group 'org-mew + :type 'boolean) + +;; Declare external functions and variables +(declare-function mew-cache-hit "ext:mew-cache" (fld msg &optional must-hit)) +(declare-function mew-case-folder "ext:mew-func" (case folder)) +(declare-function mew-header-get-value "ext:mew-header" + (field &optional as-list)) +(declare-function mew-init "ext:mew" ()) +(declare-function mew-refile-get "ext:mew-refile" (msg)) +(declare-function mew-sinfo-get-case "ext:mew-summary" ()) +(declare-function mew-summary-display "ext:mew-summary2" (&optional redisplay)) +(declare-function mew-summary-folder-name "ext:mew-syntax" (&optional ext)) +(declare-function mew-summary-get-mark "ext:mew-mark" ()) +(declare-function mew-summary-message-number2 "ext:mew-syntax" ()) +(declare-function mew-summary-pick-with-mewl "ext:mew-pick" + (pattern folder src-msgs)) +(declare-function mew-summary-search-msg "ext:mew-const" (msg)) +(declare-function mew-summary-set-message-buffer "ext:mew-summary3" (fld msg)) +(declare-function mew-summary-visit-folder "ext:mew-summary4" + (folder &optional goend no-ls)) +(declare-function mew-window-push "ext:mew" ()) +(defvar mew-init-p) +(defvar mew-summary-goto-line-then-display) + +;; Install the link type +(org-add-link-type "mew" 'org-mew-open) +(add-hook 'org-store-link-functions 'org-mew-store-link) + +;; Implementation +(defun org-mew-store-link () + "Store a link to a Mew folder or message." + (when (memq major-mode '(mew-summary-mode mew-virtual-mode)) + (let* ((msgnum (mew-summary-message-number2)) + (mark-info (mew-summary-get-mark)) + (folder-name + (if (and org-mew-link-to-refile-destination + (eq mark-info ?o)) ; marked as refile + (mew-case-folder (mew-sinfo-get-case) + (nth 1 (mew-refile-get msgnum))) + (mew-summary-folder-name))) + message-id from to subject desc link date date-ts date-ts-ia) + (save-window-excursion + (if (fboundp 'mew-summary-set-message-buffer) + (mew-summary-set-message-buffer folder-name msgnum) + (set-buffer (mew-cache-hit folder-name msgnum t))) + (setq message-id (mew-header-get-value "Message-Id:")) + (setq from (mew-header-get-value "From:")) + (setq to (mew-header-get-value "To:")) + (setq date (mew-header-get-value "Date:")) + (setq date-ts (and date (format-time-string + (org-time-stamp-format t) + (date-to-time date)))) + (setq date-ts-ia (and date (format-time-string + (org-time-stamp-format t t) + (date-to-time date)))) + (setq subject (mew-header-get-value "Subject:"))) + (org-store-link-props :type "mew" :from from :to to + :subject subject :message-id message-id) + (when date + (org-add-link-props :date date :date-timestamp date-ts + :date-timestamp-inactive date-ts-ia)) + (setq message-id (org-remove-angle-brackets message-id)) + (setq desc (org-email-link-description)) + (setq link (org-make-link "mew:" folder-name + "#" message-id)) + (org-add-link-props :link link :description desc) + link))) + +(defun org-mew-open (path) + "Follow the Mew message link specified by PATH." + (let (folder msgnum) + (cond ((string-match "\\`\\(+.*\\)+\\+\\([0-9]+\\)\\'" path) ; for Bastien's + (setq folder (match-string 1 path)) + (setq msgnum (match-string 2 path))) + ((string-match "\\`\\(\\(%#\\)?[^#]+\\)\\(#\\(.*\\)\\)?" path) + (setq folder (match-string 1 path)) + (setq msgnum (match-string 4 path))) + (t (error "Error in Mew link"))) + (require 'mew) + (mew-window-push) + (unless mew-init-p (mew-init)) + (mew-summary-visit-folder folder) + (when msgnum + (if (not (string-match "\\`[0-9]+\\'" msgnum)) + (let* ((pattern (concat "message-id=" msgnum)) + (msgs (mew-summary-pick-with-mewl pattern folder nil))) + (setq msgnum (car msgs)))) + (if (mew-summary-search-msg msgnum) + (if mew-summary-goto-line-then-display + (mew-summary-display)) + (error "Message not found"))))) + +(provide 'org-mew) + +;; arch-tag: 07ccdca7-6020-4941-a593-588a1e51b870 + +;;; org-mew.el ends here diff --git a/.emacs.d/org-7.4/lisp/org-mew.elc b/.emacs.d/org-7.4/lisp/org-mew.elc Binary files differnew file mode 100644 index 0000000..894cef3 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-mew.elc diff --git a/.emacs.d/org-7.4/lisp/org-mhe.el b/.emacs.d/org-7.4/lisp/org-mhe.el new file mode 100644 index 0000000..c384062 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-mhe.el @@ -0,0 +1,230 @@ +;;; org-mhe.el --- Support for links to MH-E messages from within Org-mode + +;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010 +;; Free Software Foundation, Inc. + +;; Author: Thomas Baumann <thomas dot baumann at ch dot tum dot de> +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; Version: 7.4 +;; +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: + +;; This file implements links to MH-E messages from within Org-mode. +;; Org-mode loads this module by default - if this is not what you want, +;; configure the variable `org-modules'. + +;;; Code: + +(require 'org) + +;; Customization variables + +(defcustom org-mhe-search-all-folders nil + "Non-nil means the search for the mh-message may extend to all folders. +When non-nil, the search for a message will extend to all other +folders if it cannot be found in the folder given in the link. +Searching all folders may be slow with the default pick based +search but is very efficient with one of the other search engines +supported by MH-E." + :group 'org-link-follow + :type 'boolean) + +;; Declare external functions and variables +(declare-function mh-display-msg "mh-show" (msg-num folder-name)) +(declare-function mh-find-path "mh-utils" ()) +(declare-function mh-get-header-field "mh-utils" (field)) +(declare-function mh-get-msg-num "mh-utils" (error-if-no-message)) +(declare-function mh-header-display "mh-show" ()) +(declare-function mh-index-previous-folder "mh-search" ()) +(declare-function mh-normalize-folder-name "mh-utils" + (folder &optional empty-string-okay dont-remove-trailing-slash + return-nil-if-folder-empty)) +(declare-function mh-search "mh-search" + (folder search-regexp &optional redo-search-flag + window-config)) +(declare-function mh-search-choose "mh-search" (&optional searcher)) +(declare-function mh-show "mh-show" (&optional message redisplay-flag)) +(declare-function mh-show-buffer-message-number "mh-comp" (&optional buffer)) +(declare-function mh-show-header-display "mh-show" t t) +(declare-function mh-show-msg "mh-show" (msg)) +(declare-function mh-show-show "mh-show" t t) +(declare-function mh-visit-folder "mh-folder" (folder &optional + range index-data)) +(defvar mh-progs) +(defvar mh-current-folder) +(defvar mh-show-folder-buffer) +(defvar mh-index-folder) +(defvar mh-searcher) +(defvar mh-search-regexp-builder) + +;; Install the link type +(org-add-link-type "mhe" 'org-mhe-open) +(add-hook 'org-store-link-functions 'org-mhe-store-link) + +;; Implementation +(defun org-mhe-store-link () + "Store a link to an MH-E folder or message." + (when (or (equal major-mode 'mh-folder-mode) + (equal major-mode 'mh-show-mode)) + (let* ((from (org-mhe-get-header "From:")) + (to (org-mhe-get-header "To:")) + (message-id (org-mhe-get-header "Message-Id:")) + (subject (org-mhe-get-header "Subject:")) + (date (org-mhe-get-header "Date:")) + (date-ts (and date (format-time-string + (org-time-stamp-format t) (date-to-time date)))) + (date-ts-ia (and date (format-time-string + (org-time-stamp-format t t) + (date-to-time date)))) + link desc) + (org-store-link-props :type "mh" :from from :to to + :subject subject :message-id message-id) + (when date + (org-add-link-props :date date :date-timestamp date-ts + :date-timestamp-inactive date-ts-ia)) + (setq desc (org-email-link-description)) + (setq link (org-make-link "mhe:" (org-mhe-get-message-real-folder) "#" + (org-remove-angle-brackets message-id))) + (org-add-link-props :link link :description desc) + link))) + +(defun org-mhe-open (path) + "Follow an MH-E message link specified by PATH." + (let (folder article) + (if (not (string-match "\\`\\([^#]+\\)\\(#\\(.*\\)\\)?" path)) + (error "Error in MH-E link")) + (setq folder (match-string 1 path) + article (match-string 3 path)) + (org-mhe-follow-link folder article))) + +;;; mh-e integration based on planner-mode +(defun org-mhe-get-message-real-folder () + "Return the name of the real folder for the current message. +So if you use sequences, it will now work." + (save-excursion + (let* ((folder + (if (equal major-mode 'mh-folder-mode) + mh-current-folder + ;; Refer to the show buffer + mh-show-folder-buffer)) + (end-index + (if (boundp 'mh-index-folder) + (min (length mh-index-folder) (length folder)))) + ) + ;; a simple test on mh-index-data does not work, because + ;; mh-index-data is always nil in a show buffer. + (if (and (boundp 'mh-index-folder) + (string= mh-index-folder (substring folder 0 end-index))) + (if (equal major-mode 'mh-show-mode) + (save-window-excursion + (let (pop-up-frames) + (when (buffer-live-p (get-buffer folder)) + (progn + (pop-to-buffer folder) + (org-mhe-get-message-folder-from-index) + ) + ))) + (org-mhe-get-message-folder-from-index) + ) + folder + ) + ))) + +(defun org-mhe-get-message-folder-from-index () + "Return the name of the message folder in an index folder buffer." + (save-excursion + (mh-index-previous-folder) + (if (re-search-forward "^\\(+.*\\)$" nil t) + (message "%s" (match-string 1))))) + +(defun org-mhe-get-message-folder () + "Return the name of the current message folder. +Be careful if you use sequences." + (save-excursion + (if (equal major-mode 'mh-folder-mode) + mh-current-folder + ;; Refer to the show buffer + mh-show-folder-buffer))) + +(defun org-mhe-get-message-num () + "Return the number of the current message. +Be careful if you use sequences." + (save-excursion + (if (equal major-mode 'mh-folder-mode) + (mh-get-msg-num nil) + ;; Refer to the show buffer + (mh-show-buffer-message-number)))) + +(defun org-mhe-get-header (header) + "Return the field for HEADER of the message in folder mode. +This will create a show buffer for the corresponding message. If +you have a better idea of how to do this then please let us know." + (let* ((folder (org-mhe-get-message-folder)) + (num (org-mhe-get-message-num)) + (buffer (get-buffer-create (concat "show-" folder))) + (header-field)) + (with-current-buffer buffer + (mh-display-msg num folder) + (if (equal major-mode 'mh-folder-mode) + (mh-header-display) + (mh-show-header-display)) + (set-buffer buffer) + (setq header-field (mh-get-header-field header)) + (if (equal major-mode 'mh-folder-mode) + (mh-show) + (mh-show-show)) + (org-trim header-field)))) + +(defun org-mhe-follow-link (folder article) + "Follow an MH-E link to FOLDER and ARTICLE. +If ARTICLE is nil FOLDER is shown. If the configuration variable +`org-mhe-search-all-folders' is t and `mh-searcher' is pick, +ARTICLE is searched in all folders. Indexed searches (swish++, +namazu, and others supported by MH-E) will always search in all +folders." + (require 'mh-e) + (require 'mh-search) + (require 'mh-utils) + (mh-find-path) + (if (not article) + (mh-visit-folder (mh-normalize-folder-name folder)) + (mh-search-choose) + (if (equal mh-searcher 'pick) + (progn + (setq article (org-add-angle-brackets article)) + (mh-search folder (list "--message-id" article)) + (when (and org-mhe-search-all-folders + (not (org-mhe-get-message-real-folder))) + (kill-this-buffer) + (mh-search "+" (list "--message-id" article)))) + (if mh-search-regexp-builder + (mh-search "+" (funcall mh-search-regexp-builder + (list (cons 'message-id article)))) + (mh-search "+" article))) + (if (org-mhe-get-message-real-folder) + (mh-show-msg 1) + (kill-this-buffer) + (error "Message not found")))) + +(provide 'org-mhe) + +;; arch-tag: dcb05484-8627-491d-a8c1-01dbd2bde4ae + +;;; org-mhe.el ends here diff --git a/.emacs.d/org-7.4/lisp/org-mhe.elc b/.emacs.d/org-7.4/lisp/org-mhe.elc Binary files differnew file mode 100644 index 0000000..7f40b13 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-mhe.elc diff --git a/.emacs.d/org-7.4/lisp/org-mks.el b/.emacs.d/org-7.4/lisp/org-mks.el new file mode 100644 index 0000000..df4ab3e --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-mks.el @@ -0,0 +1,137 @@ +;;; org-mks.el --- Multi-key-selection for Org-mode + +;; Copyright (C) 2010 Free Software Foundation, Inc. + +;; Author: Carsten Dominik <carsten at orgmode dot org> +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; Version: 7.4 +;; +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +;;; Commentary: +;; + +;;; Code: + +(require 'org) +(eval-when-compile + (require 'cl)) + +(defun org-mks (table title &optional prompt specials) + "Select a member of an alist with multiple keys. +TABLE is the alist which should contain entries where the car is a string. +There should be two types of entries. + +1. prefix descriptions like (\"a\" \"Description\") + This indicates that `a' is a prefix key for multi-letter selection, and + that there are entries following with keys like \"ab\", \"ax\"... + +2. Selectable members must have more than two elements, with the first + being the string of keys that lead to selecting it, and the second a + short description string of the item. + +The command will then make a temporary buffer listing all entries +that can be selected with a single key, and all the single key +prefixes. When you press the key for a single-letter entry, it is selected. +When you press a prefix key, the commands (and maybe further prefixes) +under this key will be shown and offered for selection. + +TITLE will be placed over the selection in the temporary buffer, +PROMPT will be used when prompting for a key. SPECIAL is an alist with +also (\"key\" \"description\") entries. When one of these is selection, +only the bare key is returned." + (setq prompt (or prompt "Select: ")) + (let (tbl orig-table dkey ddesc des-keys allowed-keys + current prefix rtn re pressed buffer (inhibit-quit t)) + (save-window-excursion + (setq buffer (org-switch-to-buffer-other-window "*Org Select*")) + (setq orig-table table) + (catch 'exit + (while t + (erase-buffer) + (insert title "\n\n") + (setq tbl table + des-keys nil + allowed-keys nil) + (setq prefix (if current (concat current " ") "")) + (while tbl + (cond + ((and (= 2 (length (car tbl))) (= (length (caar tbl)) 1)) + ;; This is a description on this level + (setq dkey (caar tbl) ddesc (cadar tbl)) + (pop tbl) + (push dkey des-keys) + (push dkey allowed-keys) + (insert prefix "[" dkey "]" "..." " " ddesc "..." "\n") + ;; Skip keys which are below this prefix + (setq re (concat "\\`" (regexp-quote dkey))) + (while (and tbl (string-match re (caar tbl))) (pop tbl))) + ((= 2 (length (car tbl))) + ;; Not yet a usable description, skip it + ) + (t + ;; usable entry on this level + (insert prefix "[" (caar tbl) "]" " " (nth 1 (car tbl)) "\n") + (push (caar tbl) allowed-keys) + (pop tbl)))) + (when specials + (insert "-------------------------------------------------------------------------------\n") + (let ((sp specials)) + (while sp + (insert (format "[%s] %s\n" + (caar sp) (nth 1 (car sp)))) + (push (caar sp) allowed-keys) + (pop sp)))) + (push "\C-g" allowed-keys) + (goto-char (point-min)) + (if (not (pos-visible-in-window-p (point-max))) + (org-fit-window-to-buffer)) + (message prompt) + (setq pressed (char-to-string (read-char-exclusive))) + (while (not (member pressed allowed-keys)) + (message "Invalid key `%s'" pressed) (sit-for 1) + (message prompt) + (setq pressed (char-to-string (read-char-exclusive)))) + (when (equal pressed "\C-g") + (kill-buffer buffer) + (error "Abort")) + (when (and (not (assoc pressed table)) + (not (member pressed des-keys)) + (assoc pressed specials)) + (throw 'exit (setq rtn pressed))) + (unless (member pressed des-keys) + (throw 'exit (setq rtn (rassoc (cdr (assoc pressed table)) + orig-table)))) + (setq current (concat current pressed)) + (setq table (mapcar + (lambda (x) + (if (and (> (length (car x)) 1) + (equal (substring (car x) 0 1) pressed)) + (cons (substring (car x) 1) (cdr x)) + nil)) + table)) + (setq table (remove nil table))))) + (when buffer (kill-buffer buffer)) + rtn)) + +(provide 'org-mks) + +;; arch-tag: 4ea90d0e-c6e4-4684-bd61-baf878712f9f + +;;; org-mks.el ends here diff --git a/.emacs.d/org-7.4/lisp/org-mks.elc b/.emacs.d/org-7.4/lisp/org-mks.elc Binary files differnew file mode 100644 index 0000000..e1c644c --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-mks.elc diff --git a/.emacs.d/org-7.4/lisp/org-mobile.el b/.emacs.d/org-7.4/lisp/org-mobile.el new file mode 100644 index 0000000..4b16e2b --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-mobile.el @@ -0,0 +1,1089 @@ +;;; org-mobile.el --- Code for asymmetric sync with a mobile device +;; Copyright (C) 2009, 2010 Free Software Foundation, Inc. +;; +;; Author: Carsten Dominik <carsten at orgmode dot org> +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; Version: 7.4 +;; +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: +;; +;; This file contains the code to interact with Richard Moreland's iPhone +;; application MobileOrg, as well as with the Android version by Matthew Jones. +;; This code is documented in Appendix B of the Org-mode manual. The code is +;; not specific for the iPhone and Android - any external +;; viewer/flagging/editing application that uses the same conventions could +;; be used. + +(require 'org) +(require 'org-agenda) +;;; Code: + +(eval-when-compile (require 'cl)) + +(defgroup org-mobile nil + "Options concerning support for a viewer/editor on a mobile device." + :tag "Org Mobile" + :group 'org) + +(defcustom org-mobile-files '(org-agenda-files) + "Files to be staged for MobileOrg. +This is basically a list of files and directories. Files will be staged +directly. Directories will be search for files with the extension `.org'. +In addition to this, the list may also contain the following symbols: + +org-agenda-files + This means include the complete, unrestricted list of files given in + the variable `org-agenda-files'. +org-agenda-text-search-extra-files + Include the files given in the variable + `org-agenda-text-search-extra-files'" + :group 'org-mobile + :type '(list :greedy t + (option (const :tag "org-agenda-files" org-agenda-files)) + (option (const :tag "org-agenda-text-search-extra-files" + org-agenda-text-search-extra-files)) + (repeat :inline t :tag "Additional files" + (file)))) + +(defcustom org-mobile-directory "" + "The WebDAV directory where the interaction with the mobile takes place." + :group 'org-mobile + :type 'directory) + +(defcustom org-mobile-use-encryption nil + "Non-nil means keep only encrypted files on the WebDAV server. +Encryption uses AES-256, with a password given in +`org-mobile-encryption-password'. +When nil, plain files are kept on the server. +Turning on encryption requires to set the same password in the MobileOrg +application. Before turning this on, check of MobileOrg does already +support it - at the time of this writing it did not yet." + :group 'org-mobile + :type 'boolean) + +(defcustom org-mobile-encryption-tempfile "~/orgtmpcrypt" + "File that is being used as a temporary file for encryption. +This must be local file on your local machine (not on the WebDAV server). +You might want to put this file into a directory where only you have access." + :group 'org-mobile + :type 'directory) + +(defcustom org-mobile-encryption-password "" + "Password for encrypting files uploaded to the server. +This is a single password which is used for AES-256 encryption. The same +password must also be set in the MobileOrg application. All Org files, +including mobileorg.org will be encrypted using this password. + +SECURITY CONSIDERATIONS: + +Note that, when Org runs the encryption commands, the password could +be visible briefly on your system with the `ps' command. So this method is +only intended to keep the files secure on the server, not on your own machine. + +Also, if you set this variable in an init file (.emacs or .emacs.d/init.el +or custom.el...) and if that file is stored in a way so that other can read +it, this also limits the security of this approach. You can also leave +this variable empty - Org will then ask for the password once per Emacs +session." + :group 'org-mobile + :type '(string :tag "Password")) + +(defvar org-mobile-encryption-password-session nil) + +(defun org-mobile-encryption-password () + (or (org-string-nw-p org-mobile-encryption-password) + (org-string-nw-p org-mobile-encryption-password-session) + (setq org-mobile-encryption-password-session + (read-passwd "Password for MobileOrg: " t)))) + +(defcustom org-mobile-inbox-for-pull "~/org/from-mobile.org" + "The file where captured notes and flags will be appended to. +During the execution of `org-mobile-pull', the file +`org-mobile-capture-file' will be emptied it's contents have +been appended to the file given here. This file should be in +`org-directory', and not in the staging area or on the web server." + :group 'org-mobile + :type 'file) + +(defconst org-mobile-capture-file "mobileorg.org" + "The capture file where the mobile stores captured notes and flags. +This should not be changed, because MobileOrg assumes this name.") + +(defcustom org-mobile-index-file "index.org" + "The index file with inks to all Org files that should be loaded by MobileOrg. +Relative to `org-mobile-directory'. The Address field in the MobileOrg setup +should point to this file." + :group 'org-mobile + :type 'file) + +(defcustom org-mobile-agendas 'all + "The agendas that should be pushed to MobileOrg. +Allowed values: + +default the weekly agenda and the global TODO list +custom all custom agendas defined by the user +all the custom agendas and the default ones +list a list of selection key(s) as string." + :group 'org-mobile + :type '(choice + (const :tag "Default Agendas" default) + (const :tag "Custom Agendas" custom) + (const :tag "Default and Custom Agendas" all) + (repeat :tag "Selected" + (string :tag "Selection Keys")))) + +(defcustom org-mobile-force-id-on-agenda-items t + "Non-nil means make all agenda items carry an ID." + :group 'org-mobile + :type 'boolean) + +(defcustom org-mobile-force-mobile-change nil + "Non-nil means force the change made on the mobile device. +So even if there have been changes to the computer version of the entry, +force the new value set on the mobile. +When nil, mark the entry from the mobile with an error message. +Instead of nil or t, this variable can also be a list of symbols, indicating +the editing types for which the mobile version should always dominate." + :group 'org-mobile + :type '(choice + (const :tag "Always" t) + (const :tag "Never" nil) + (set :greedy t :tag "Specify" + (const todo) + (const tags) + (const priority) + (const heading) + (const body)))) + +(defcustom org-mobile-action-alist + '(("edit" . (org-mobile-edit data old new))) + "Alist with flags and actions for mobile sync. +When flagging an entry, MobileOrg will create entries that look like + + * F(action:data) [[id:entry-id][entry title]] + +This alist defines that the ACTION in the parentheses of F() should mean, +i.e. what action should be taken. The :data part in the parenthesis is +optional. If present, the string after the colon will be passed to the +action form as the `data' variable. +The car of each elements of the alist is an actions string. The cdr is +an Emacs Lisp form that will be evaluated with the cursor on the headline +of that entry. + +For now, it is not recommended to change this variable." + :group 'org-mobile + :type '(repeat + (cons (string :tag "Action flag") + (sexp :tag "Action form")))) + +(defcustom org-mobile-checksum-binary (or (executable-find "shasum") + (executable-find "sha1sum") + (executable-find "md5sum") + (executable-find "md5")) + "Executable used for computing checksums of agenda files." + :group 'org-mobile + :type 'string) + +(defvar org-mobile-pre-push-hook nil + "Hook run before running `org-mobile-push'. +This could be used to clean up `org-mobile-directory', for example to +remove files that used to be included in the agenda but no longer are. +The presence of such files would not really be a problem, but after time +they may accumulate.") + +(defvar org-mobile-post-push-hook nil + "Hook run after running `org-mobile-push'. +If Emacs does not have direct write access to the WebDAV directory used +by the mobile device, this hook should be used to copy all files from the +local staging directory `org-mobile-directory' to the WebDAV directory, +for example using `rsync' or `scp'.") + +(defvar org-mobile-pre-pull-hook nil + "Hook run before executing `org-mobile-pull'. +If Emacs does not have direct write access to the WebDAV directory used +by the mobile device, this hook should be used to copy the capture file +`mobileorg.org' from the WebDAV location to the local staging +directory `org-mobile-directory'.") + +(defvar org-mobile-post-pull-hook nil + "Hook run after running `org-mobile-pull'. +If Emacs does not have direct write access to the WebDAV directory used +by the mobile device, this hook should be used to copy the emptied +capture file `mobileorg.org' back to the WebDAV directory, for example +using `rsync' or `scp'.") + +(defvar org-mobile-last-flagged-files nil + "List of files containing entries flagged in the latest pull.") + +(defvar org-mobile-files-alist nil) +(defvar org-mobile-checksum-files nil) + +(defun org-mobile-prepare-file-lists () + (setq org-mobile-files-alist (org-mobile-files-alist)) + (setq org-mobile-checksum-files nil)) + +(defun org-mobile-files-alist () + "Expand the list in `org-mobile-files' to a list of existing files." + (let* ((include-archives + (and (member 'org-agenda-text-search-extra-files org-mobile-files) + (member 'agenda-archives org-agenda-text-search-extra-files) + t)) + (files + (apply 'append + (mapcar + (lambda (f) + (cond + ((eq f 'org-agenda-files) + (org-agenda-files t include-archives)) + ((eq f 'org-agenda-text-search-extra-files) + (delq 'agenda-archives + (copy-sequence + org-agenda-text-search-extra-files))) + ((and (stringp f) (file-directory-p f)) + (directory-files f 'full "\\.org\\'")) + ((and (stringp f) (file-exists-p f)) + (list f)) + (t nil))) + org-mobile-files))) + (orgdir-uname (file-name-as-directory (file-truename org-directory))) + (orgdir-re (concat "\\`" (regexp-quote orgdir-uname))) + uname seen rtn file link-name) + ;; Make the files unique, and determine the name under which they will + ;; be listed. + (while (setq file (pop files)) + (if (not (file-name-absolute-p file)) + (setq file (expand-file-name file org-directory))) + (setq uname (file-truename file)) + (unless (member uname seen) + (push uname seen) + (if (string-match orgdir-re uname) + (setq link-name (substring uname (match-end 0))) + (setq link-name (file-name-nondirectory uname))) + (push (cons file link-name) rtn))) + (nreverse rtn))) + +;;;###autoload +(defun org-mobile-push () + "Push the current state of Org affairs to the WebDAV directory. +This will create the index file, copy all agenda files there, and also +create all custom agenda views, for upload to the mobile phone." + (interactive) + (let ((a-buffer (get-buffer org-agenda-buffer-name))) + (let ((org-agenda-buffer-name "*SUMO*") + (org-agenda-filter org-agenda-filter) + (org-agenda-redo-command org-agenda-redo-command)) + (save-excursion + (save-window-excursion + (org-mobile-check-setup) + (org-mobile-prepare-file-lists) + (run-hooks 'org-mobile-pre-push-hook) + (message "Creating agendas...") + (let ((inhibit-redisplay t)) (org-mobile-create-sumo-agenda)) + (message "Creating agendas...done") + (org-save-all-org-buffers) ; to save any IDs created by this process + (message "Copying files...") + (org-mobile-copy-agenda-files) + (message "Writing index file...") + (org-mobile-create-index-file) + (message "Writing checksums...") + (org-mobile-write-checksums) + (run-hooks 'org-mobile-post-push-hook)))) + (redraw-display) + (when (and a-buffer (buffer-live-p a-buffer)) + (if (not (get-buffer-window a-buffer)) + (kill-buffer a-buffer) + (let ((cw (selected-window))) + (select-window (get-buffer-window a-buffer)) + (org-agenda-redo) + (select-window cw))))) + (message "Files for mobile viewer staged")) + +(defvar org-mobile-before-process-capture-hook nil + "Hook that is run after content was moved to `org-mobile-inbox-for-pull'. +The inbox file is visited by the current buffer, and the buffer is +narrowed to the newly captured data.") + +;;;###autoload +(defun org-mobile-pull () + "Pull the contents of `org-mobile-capture-file' and integrate them. +Apply all flagged actions, flag entries to be flagged and then call an +agenda view showing the flagged items." + (interactive) + (org-mobile-check-setup) + (run-hooks 'org-mobile-pre-pull-hook) + (let ((insertion-marker (org-mobile-move-capture))) + (if (not (markerp insertion-marker)) + (message "No new items") + (org-with-point-at insertion-marker + (save-restriction + (narrow-to-region (point) (point-max)) + (run-hooks 'org-mobile-before-process-capture-hook))) + (org-with-point-at insertion-marker + (org-mobile-apply (point) (point-max))) + (move-marker insertion-marker nil) + (run-hooks 'org-mobile-post-pull-hook) + (when org-mobile-last-flagged-files + ;; Make an agenda view of flagged entries, but only in the files + ;; where stuff has been added. + (put 'org-agenda-files 'org-restrict org-mobile-last-flagged-files) + (let ((org-agenda-keep-restricted-file-list t)) + (org-agenda nil "?")))))) + +(defun org-mobile-check-setup () + "Check if org-mobile-directory has been set up." + (org-mobile-cleanup-encryption-tempfile) + (unless (and org-directory + (stringp org-directory) + (string-match "\\S-" org-directory) + (file-exists-p org-directory) + (file-directory-p org-directory)) + (error + "Please set `org-directory' to the directory where your org files live")) + (unless (and org-mobile-directory + (stringp org-mobile-directory) + (string-match "\\S-" org-mobile-directory) + (file-exists-p org-mobile-directory) + (file-directory-p org-mobile-directory)) + (error + "Variable `org-mobile-directory' must point to an existing directory")) + (unless (and org-mobile-inbox-for-pull + (stringp org-mobile-inbox-for-pull) + (string-match "\\S-" org-mobile-inbox-for-pull) + (file-exists-p + (file-name-directory org-mobile-inbox-for-pull))) + (error + "Variable `org-mobile-inbox-for-pull' must point to a file in an existing directory")) + (unless (and org-mobile-checksum-binary + (string-match "\\S-" org-mobile-checksum-binary)) + (error "No executable found to compute checksums")) + (when org-mobile-use-encryption + (unless (string-match "\\S-" (org-mobile-encryption-password)) + (error + "To use encryption, you must set `org-mobile-encryption-password'")) + (unless (file-writable-p org-mobile-encryption-tempfile) + (error "Cannot write to encryption tempfile %s" + org-mobile-encryption-tempfile)) + (unless (executable-find "openssl") + (error "openssl is needed to encrypt files")))) + +(defun org-mobile-create-index-file () + "Write the index file in the WebDAV directory." + (let ((files-alist (sort (copy-sequence org-mobile-files-alist) + (lambda (a b) (string< (cdr a) (cdr b))))) + (def-todo (default-value 'org-todo-keywords)) + (def-tags (default-value 'org-tag-alist)) + (target-file (expand-file-name org-mobile-index-file + org-mobile-directory)) + file link-name todo-kwds done-kwds tags drawers entry kwds dwds twds) + + (org-prepare-agenda-buffers (mapcar 'car files-alist)) + (setq done-kwds (org-uniquify org-done-keywords-for-agenda)) + (setq todo-kwds (org-delete-all + done-kwds + (org-uniquify org-todo-keywords-for-agenda))) + (setq drawers (org-uniquify org-drawers-for-agenda)) + (setq tags (org-uniquify + (delq nil + (mapcar + (lambda (e) + (cond ((stringp e) e) + ((listp e) + (if (stringp (car e)) (car e) nil)) + (t nil))) + org-tag-alist-for-agenda)))) + (with-temp-file + (if org-mobile-use-encryption + org-mobile-encryption-tempfile + target-file) + (while (setq entry (pop def-todo)) + (insert "#+READONLY\n") + (setq kwds (mapcar (lambda (x) (if (string-match "(" x) + (substring x 0 (match-beginning 0)) + x)) + (cdr entry))) + (insert "#+TODO: " (mapconcat 'identity kwds " ") "\n") + (setq dwds (member "|" kwds) + twds (org-delete-all dwds kwds) + todo-kwds (org-delete-all twds todo-kwds) + done-kwds (org-delete-all dwds done-kwds))) + (when (or todo-kwds done-kwds) + (insert "#+TODO: " (mapconcat 'identity todo-kwds " ") " | " + (mapconcat 'identity done-kwds " ") "\n")) + (setq def-tags (mapcar + (lambda (x) + (cond ((null x) nil) + ((stringp x) x) + ((eq (car x) :startgroup) "{") + ((eq (car x) :endgroup) "}") + ((eq (car x) :newline) nil) + ((listp x) (car x)) + (t nil))) + def-tags)) + (setq def-tags (delq nil def-tags)) + (setq tags (org-delete-all def-tags tags)) + (setq tags (sort tags (lambda (a b) (string< (downcase a) (downcase b))))) + (setq tags (append def-tags tags nil)) + (insert "#+TAGS: " (mapconcat 'identity tags " ") "\n") + (insert "#+DRAWERS: " (mapconcat 'identity drawers " ") "\n") + (insert "#+ALLPRIORITIES: A B C" "\n") + (when (file-exists-p (expand-file-name + org-mobile-directory "agendas.org")) + (insert "* [[file:agendas.org][Agenda Views]]\n")) + (while (setq entry (pop files-alist)) + (setq file (car entry) + link-name (cdr entry)) + (insert (format "* [[file:%s][%s]]\n" + link-name link-name))) + (push (cons org-mobile-index-file (md5 (buffer-string))) + org-mobile-checksum-files)) + (when org-mobile-use-encryption + (org-mobile-encrypt-and-move org-mobile-encryption-tempfile + target-file) + (org-mobile-cleanup-encryption-tempfile)))) + +(defun org-mobile-copy-agenda-files () + "Copy all agenda files to the stage or WebDAV directory." + (let ((files-alist org-mobile-files-alist) + file buf entry link-name target-path target-dir check) + (while (setq entry (pop files-alist)) + (setq file (car entry) link-name (cdr entry)) + (when (file-exists-p file) + (setq target-path (expand-file-name link-name org-mobile-directory) + target-dir (file-name-directory target-path)) + (unless (file-directory-p target-dir) + (make-directory target-dir 'parents)) + (if org-mobile-use-encryption + (org-mobile-encrypt-and-move file target-path) + (copy-file file target-path 'ok-if-exists)) + (setq check (shell-command-to-string + (concat org-mobile-checksum-binary " " + (shell-quote-argument (expand-file-name file))))) + (when (string-match "[a-fA-F0-9]\\{30,40\\}" check) + (push (cons link-name (match-string 0 check)) + org-mobile-checksum-files)))) + + (setq file (expand-file-name org-mobile-capture-file + org-mobile-directory)) + (save-excursion + (setq buf (find-file file)) + (when (and (= (point-min) (point-max))) + (insert "\n") + (save-buffer) + (when org-mobile-use-encryption + (write-file org-mobile-encryption-tempfile) + (org-mobile-encrypt-and-move org-mobile-encryption-tempfile file))) + (push (cons org-mobile-capture-file (md5 (buffer-string))) + org-mobile-checksum-files)) + (org-mobile-cleanup-encryption-tempfile) + (kill-buffer buf))) + +(defun org-mobile-write-checksums () + "Create checksums for all files in `org-mobile-directory'. +The table of checksums is written to the file mobile-checksums." + (let ((sumfile (expand-file-name "checksums.dat" org-mobile-directory)) + (files org-mobile-checksum-files) + entry file sum) + (with-temp-file sumfile + (set-buffer-file-coding-system 'undecided-unix nil) + (while (setq entry (pop files)) + (setq file (car entry) sum (cdr entry)) + (insert (format "%s %s\n" sum file)))))) + +(defun org-mobile-sumo-agenda-command () + "Return an agenda custom command that comprises all custom commands." + (let ((custom-list + ;; normalize different versions + (delq nil + (mapcar + (lambda (x) + (cond ((stringp (cdr x)) nil) + ((stringp (nth 1 x)) x) + ((not (nth 1 x)) (cons (car x) (cons "" (cddr x)))) + (t (cons (car x) (cons "" (cdr x)))))) + org-agenda-custom-commands))) + (default-list '(("a" "Agenda" agenda) ("t" "All TODO" alltodo))) + thelist new e key desc type match settings cmds gkey gdesc gsettings cnt) + (cond + ((eq org-mobile-agendas 'custom) + (setq thelist custom-list)) + ((eq org-mobile-agendas 'default) + (setq thelist default-list)) + ((eq org-mobile-agendas 'all) + (setq thelist custom-list) + (unless (assoc "t" thelist) (push '("t" "ALL TODO" alltodo) thelist)) + (unless (assoc "a" thelist) (push '("a" "Agenda" agenda) thelist))) + ((listp org-mobile-agendas) + (setq thelist (append custom-list default-list)) + (setq thelist (delq nil (mapcar (lambda (k) (assoc k thelist)) + org-mobile-agendas))))) + (while (setq e (pop thelist)) + (cond + ((stringp (cdr e)) + ;; this is a description entry - skip it + ) + ((eq (nth 2 e) 'search) + ;; Search view is interactive, skip + ) + ((memq (nth 2 e) '(todo-tree tags-tree occur-tree)) + ;; These are trees, not really agenda commands + ) + ((and (memq (nth 2 e) '(todo tags tags-todo)) + (or (null (nth 3 e)) + (not (string-match "\\S-" (nth 3 e))))) + ;; These would be interactive because the match string is empty + ) + ((memq (nth 2 e) '(agenda alltodo todo tags tags-todo)) + ;; a normal command + (setq key (car e) desc (nth 1 e) type (nth 2 e) match (nth 3 e) + settings (nth 4 e)) + (setq settings + (cons (list 'org-agenda-title-append + (concat "<after>KEYS=" key " TITLE: " + (if (and (stringp desc) (> (length desc) 0)) + desc (symbol-name type)) + " " match "</after>")) + settings)) + (push (list type match settings) new)) + ((symbolp (nth 2 e)) + ;; A user-defined function, not sure how to handle that yet + ) + (t + ;; a block agenda + (setq gkey (car e) gdesc (nth 1 e) gsettings (nth 3 e) cmds (nth 2 e)) + (setq cnt 0) + (while (setq e (pop cmds)) + (setq type (car e) match (nth 1 e) settings (nth 2 e)) + (setq settings (append gsettings settings)) + (setq settings + (cons (list 'org-agenda-title-append + (concat "<after>KEYS=" gkey "#" (number-to-string + (setq cnt (1+ cnt))) + " TITLE: " gdesc " " match "</after>")) + settings)) + (push (list type match settings) new))))) + (and new (list "X" "SUMO" (reverse new) + '((org-agenda-compact-blocks nil)))))) + +(defvar org-mobile-creating-agendas nil) +(defun org-mobile-write-agenda-for-mobile (file) + (let ((all (buffer-string)) in-date id pl prefix line app short m sexp) + (with-temp-file file + (org-mode) + (insert "#+READONLY\n") + (insert all) + (goto-char (point-min)) + (while (not (eobp)) + (cond + ((looking-at "[ \t]*$")) ; keep empty lines + ((looking-at "=+$") + ;; remove underlining + (delete-region (point) (point-at-eol))) + ((get-text-property (point) 'org-agenda-structural-header) + (setq in-date nil) + (setq app (get-text-property (point) + 'org-agenda-title-append)) + (setq short (get-text-property (point) + 'short-heading)) + (when (and short (looking-at ".+")) + (replace-match short) + (beginning-of-line 1)) + (when app + (end-of-line 1) + (insert app) + (beginning-of-line 1)) + (insert "* ")) + ((get-text-property (point) 'org-agenda-date-header) + (setq in-date t) + (insert "** ")) + ((setq m (or (get-text-property (point) 'org-hd-marker) + (get-text-property (point) 'org-marker))) + (setq sexp (member (get-text-property (point) 'type) + '("diary" "sexp"))) + (if (setq pl (get-text-property (point) 'prefix-length)) + (progn + (setq prefix (org-trim (buffer-substring + (point) (+ (point) pl))) + line (org-trim (buffer-substring + (+ (point) pl) + (point-at-eol)))) + (delete-region (point-at-bol) (point-at-eol)) + (insert line "<before>" prefix "</before>") + (beginning-of-line 1)) + (and (looking-at "[ \t]+") (replace-match ""))) + (insert (if in-date "*** " "** ")) + (end-of-line 1) + (insert "\n") + (unless sexp + (insert (org-agenda-get-some-entry-text + m 10 " " 'planning) + "\n") + (when (setq id + (if (org-bound-and-true-p + org-mobile-force-id-on-agenda-items) + (org-id-get m 'create) + (or (org-entry-get m "ID") + (org-mobile-get-outline-path-link m)))) + (insert " :PROPERTIES:\n :ORIGINAL_ID: " id + "\n :END:\n"))))) + (beginning-of-line 2)) + (push (cons "agendas.org" (md5 (buffer-string))) + org-mobile-checksum-files)) + (message "Agenda written to Org file %s" file))) + +(defun org-mobile-get-outline-path-link (pom) + (org-with-point-at pom + (concat "olp:" + (org-mobile-escape-olp (file-name-nondirectory buffer-file-name)) + "/" + (mapconcat 'org-mobile-escape-olp + (org-get-outline-path) + "/") + "/" + (org-mobile-escape-olp (nth 4 (org-heading-components)))))) + +(defun org-mobile-escape-olp (s) + (let ((table '((?: . "%3a") (?\[ . "%5b") (?\] . "%5d") (?/ . "%2f")))) + (org-link-escape s table))) + +;;;###autoload +(defun org-mobile-create-sumo-agenda () + "Create a file that contains all custom agenda views." + (interactive) + (let* ((file (expand-file-name "agendas.org" + org-mobile-directory)) + (file1 (if org-mobile-use-encryption + org-mobile-encryption-tempfile + file)) + (sumo (org-mobile-sumo-agenda-command)) + (org-agenda-custom-commands + (list (append sumo (list (list file1))))) + (org-mobile-creating-agendas t)) + (unless (file-writable-p file1) + (error "Cannot write to file %s" file1)) + (when sumo + (org-store-agenda-views)) + (when org-mobile-use-encryption + (org-mobile-encrypt-and-move file1 file) + (delete-file file1) + (org-mobile-cleanup-encryption-tempfile)))) + +(defun org-mobile-encrypt-and-move (infile outfile) + "Encrypt INFILE locally to INFILE_enc, then move it to OUTFILE. +We do this in two steps so that remote paths will work, even if the +encryption program does not understand them." + (let ((encfile (concat infile "_enc"))) + (org-mobile-encrypt-file infile encfile) + (when outfile + (copy-file encfile outfile 'ok-if-exists) + (delete-file encfile)))) + +(defun org-mobile-encrypt-file (infile outfile) + "Encrypt INFILE to OUTFILE, using `org-mobile-encryption-password'." + (shell-command + (format "openssl enc -aes-256-cbc -salt -pass %s -in %s -out %s" + (shell-quote-argument (concat "pass:" + (org-mobile-encryption-password))) + (shell-quote-argument (expand-file-name infile)) + (shell-quote-argument (expand-file-name outfile))))) + +(defun org-mobile-decrypt-file (infile outfile) + "Decrypt INFILE to OUTFILE, using `org-mobile-encryption-password'." + (shell-command + (format "openssl enc -d -aes-256-cbc -salt -pass %s -in %s -out %s" + (shell-quote-argument (concat "pass:" + (org-mobile-encryption-password))) + (shell-quote-argument (expand-file-name infile)) + (shell-quote-argument (expand-file-name outfile))))) + +(defun org-mobile-cleanup-encryption-tempfile () + "Remove the encryption tempfile if it exists." + (and (stringp org-mobile-encryption-tempfile) + (file-exists-p org-mobile-encryption-tempfile) + (delete-file org-mobile-encryption-tempfile))) + +(defun org-mobile-move-capture () + "Move the contents of the capture file to the inbox file. +Return a marker to the location where the new content has been added. +If nothing new has been added, return nil." + (interactive) + (let* ((encfile nil) + (capture-file (expand-file-name org-mobile-capture-file + org-mobile-directory)) + (inbox-buffer (find-file-noselect org-mobile-inbox-for-pull)) + (capture-buffer + (if (not org-mobile-use-encryption) + (find-file-noselect capture-file) + (org-mobile-cleanup-encryption-tempfile) + (setq encfile (concat org-mobile-encryption-tempfile "_enc")) + (copy-file capture-file encfile) + (org-mobile-decrypt-file encfile org-mobile-encryption-tempfile) + (find-file-noselect org-mobile-encryption-tempfile))) + (insertion-point (make-marker)) + not-empty content) + (with-current-buffer capture-buffer + (setq content (buffer-string)) + (setq not-empty (string-match "\\S-" content)) + (when not-empty + (set-buffer inbox-buffer) + (widen) + (goto-char (point-max)) + (or (bolp) (newline)) + (move-marker insertion-point + (prog1 (point) (insert content))) + (save-buffer) + (set-buffer capture-buffer) + (erase-buffer) + (save-buffer) + (org-mobile-update-checksum-for-capture-file (buffer-string)))) + (kill-buffer capture-buffer) + (when org-mobile-use-encryption + (org-mobile-encrypt-and-move org-mobile-encryption-tempfile + capture-file) + (org-mobile-cleanup-encryption-tempfile)) + (if not-empty insertion-point))) + +(defun org-mobile-update-checksum-for-capture-file (buffer-string) + "Find the checksum line and modify it to match BUFFER-STRING." + (let* ((file (expand-file-name "checksums.dat" org-mobile-directory)) + (buffer (find-file-noselect file))) + (when buffer + (with-current-buffer buffer + (when (re-search-forward (concat "\\([0-9a-fA-F]\\{30,\\}\\).*?" + (regexp-quote org-mobile-capture-file) + "[ \t]*$") nil t) + (goto-char (match-beginning 1)) + (delete-region (match-beginning 1) (match-end 1)) + (insert (md5 buffer-string)) + (save-buffer))) + (kill-buffer buffer)))) + +(defun org-mobile-apply (&optional beg end) + "Apply all change requests in the current buffer. +If BEG and END are given, only do this in that region." + (interactive) + (require 'org-archive) + (setq org-mobile-last-flagged-files nil) + (setq beg (or beg (point-min)) end (or end (point-max))) + + ;; Remove all Note IDs + (goto-char beg) + (while (re-search-forward "^\\*\\* Note ID: [-0-9A-F]+[ \t]*\n" end t) + (replace-match "")) + + ;; Find all the referenced entries, without making any changes yet + (let ((marker (make-marker)) + (bos-marker (make-marker)) + (end (move-marker (make-marker) end)) + (cnt-new 0) + (cnt-edit 0) + (cnt-flag 0) + (cnt-error 0) + buf-list + id-pos org-mobile-error) + + ;; Count the new captures + (goto-char beg) + (while (re-search-forward "^\\* \\(.*\\)" end t) + (and (>= (- (match-end 1) (match-beginning 1)) 2) + (not (equal (downcase (substring (match-string 1) 0 2)) "f(")) + (incf cnt-new))) + + (goto-char beg) + (while (re-search-forward + "^\\*+[ \t]+F(\\([^():\n]*\\)\\(:\\([^()\n]*\\)\\)?)[ \t]+\\[\\[\\(\\(id\\|olp\\):\\([^]\n]+\\)\\)" end t) + (setq id-pos (condition-case msg + (org-mobile-locate-entry (match-string 4)) + (error (nth 1 msg)))) + (when (and (markerp id-pos) + (not (member (marker-buffer id-pos) buf-list))) + (org-mobile-timestamp-buffer (marker-buffer id-pos)) + (push (marker-buffer id-pos) buf-list)) + + (if (or (not id-pos) (stringp id-pos)) + (progn + (goto-char (+ 2 (point-at-bol))) + (insert id-pos " ") + (incf cnt-error)) + (add-text-properties (point-at-bol) (point-at-eol) + (list 'org-mobile-marker + (or id-pos "Linked entry not found"))))) + + ;; OK, now go back and start applying + (goto-char beg) + (while (re-search-forward "^\\*+[ \t]+F(\\([^():\n]*\\)\\(:\\([^()\n]*\\)\\)?)" end t) + (catch 'next + (setq id-pos (get-text-property (point-at-bol) 'org-mobile-marker)) + (if (not (markerp id-pos)) + (progn + (incf cnt-error) + (insert "UNKNOWN PROBLEM")) + (let* ((action (match-string 1)) + (data (and (match-end 3) (match-string 3))) + (bos (point-at-bol)) + (eos (save-excursion (org-end-of-subtree t t))) + (cmd (if (equal action "") + '(progn + (incf cnt-flag) + (org-toggle-tag "FLAGGED" 'on) + (and note + (org-entry-put nil "THEFLAGGINGNOTE" note))) + (incf cnt-edit) + (cdr (assoc action org-mobile-action-alist)))) + (note (and (equal action "") + (buffer-substring (1+ (point-at-eol)) eos))) + (org-inhibit-logging 'note) ;; Do not take notes interactively + old new) + (goto-char bos) + (move-marker bos-marker (point)) + (if (re-search-forward "^** Old value[ \t]*$" eos t) + (setq old (buffer-substring + (1+ (match-end 0)) + (progn (outline-next-heading) (point))))) + (if (re-search-forward "^** New value[ \t]*$" eos t) + (setq new (buffer-substring + (1+ (match-end 0)) + (progn (outline-next-heading) + (if (eobp) (org-back-over-empty-lines)) + (point))))) + (setq old (and old (if (string-match "\\S-" old) old nil))) + (setq new (and new (if (string-match "\\S-" new) new nil))) + (if (and note (> (length note) 0)) + ;; Make Note into a single line, to fit into a property + (setq note (mapconcat 'identity + (org-split-string (org-trim note) "\n") + "\\n"))) + (unless (equal data "body") + (setq new (and new (org-trim new)) + old (and old (org-trim old)))) + (goto-char (+ 2 bos-marker)) + (unless (markerp id-pos) + (insert "BAD REFERENCE ") + (incf cnt-error) + (throw 'next t)) + (unless cmd + (insert "BAD FLAG ") + (incf cnt-error) + (throw 'next t)) + ;; Remember this place so that we can return + (move-marker marker (point)) + (setq org-mobile-error nil) + (save-excursion + (condition-case msg + (org-with-point-at id-pos + (progn + (eval cmd) + (if (member "FLAGGED" (org-get-tags)) + (add-to-list 'org-mobile-last-flagged-files + (buffer-file-name (current-buffer)))))) + (error (setq org-mobile-error msg)))) + (when org-mobile-error + (switch-to-buffer (marker-buffer marker)) + (goto-char marker) + (incf cnt-error) + (insert (if (stringp (nth 1 org-mobile-error)) + (nth 1 org-mobile-error) + "EXECUTION FAILED") + " ") + (throw 'next t)) + ;; If we get here, the action has been applied successfully + ;; So remove the entry + (goto-char bos-marker) + (delete-region (point) (org-end-of-subtree t t)))))) + (save-buffer) + (move-marker marker nil) + (move-marker end nil) + (message "%d new, %d edits, %d flags, %d errors" cnt-new + cnt-edit cnt-flag cnt-error) + (sit-for 1))) + +(defun org-mobile-timestamp-buffer (buf) + "Time stamp buffer BUF, just to make sure its checksum will change." + (with-current-buffer buf + (save-excursion + (save-restriction + (widen) + (goto-char (point-min)) + (if (re-search-forward + "^\\([ \t]*\\)#\\+LAST_MOBILE_CHANGE:.*\n?" nil t) + (progn + (goto-char (match-end 1)) + (delete-region (point) (match-end 0))) + (if (looking-at ".*?-\\*-.*-\\*-") + (forward-line 1))) + (insert "#+LAST_MOBILE_CHANGE: " + (format-time-string "%Y-%m-%d %T") "\n"))))) + +(defun org-mobile-smart-read () + "Parse the entry at point for shortcuts and expand them. +These shortcuts are meant for fast and easy typing on the limited +keyboards of a mobile device. Below we show a list of the shortcuts +currently implemented. + +The entry is expected to contain an inactive time stamp indicating when +the entry was created. When setting dates and +times (for example for deadlines), the time strings are interpreted +relative to that creation date. +Abbreviations are expected to take up entire lines, just because it is so +easy to type RET on a mobile device. Abbreviations start with one or two +letters, followed immediately by a dot and then additional information. +Generally the entire shortcut line is removed after action have been taken. +Time stamps will be constructed using `org-read-date'. So for example a +line \"dd. 2tue\" will set a deadline on the second Tuesday after the +creation date. + +Here are the shortcuts currently implemented: + +dd. string set deadline +ss. string set scheduling +tt. string set time tamp, here. +ti. string set inactive time + +tg. tag1 tag2 tag3 set all these tags, change case where necessary +td. kwd set this todo keyword, change case where necessary + +FIXME: Hmmm, not sure if we can make his work against the +auto-correction feature. Needs a bit more thinking. So this function +is currently a noop.") + +(defun org-mobile-locate-entry (link) + (if (string-match "\\`id:\\(.*\\)$" link) + (org-id-find (match-string 1 link) 'marker) + (if (not (string-match "\\`olp:\\(.*?\\):\\(.*\\)$" link)) + nil + (let ((file (match-string 1 link)) + (path (match-string 2 link)) + (table '((?: . "%3a") (?\[ . "%5b") (?\] . "%5d") (?/ . "%2f")))) + (setq file (org-link-unescape file table)) + (setq file (expand-file-name file org-directory)) + (setq path (mapcar (lambda (x) (org-link-unescape x table)) + (org-split-string path "/"))) + (org-find-olp (cons file path)))))) + +(defun org-mobile-edit (what old new) + "Edit item WHAT in the current entry by replacing OLD with NEW. +WHAT can be \"heading\", \"todo\", \"tags\", \"priority\", or \"body\". +The edit only takes place if the current value is equal (except for +white space) the OLD. If this is so, OLD will be replace by NEW +and the command will return t. If something goes wrong, a string will +be returned that indicates what went wrong." + (let (current old1 new1) + (if (stringp what) (setq what (intern what))) + + (cond + + ((memq what '(todo todostate)) + (setq current (org-get-todo-state)) + (cond + ((equal new "DONEARCHIVE") + (org-todo 'done) + (org-archive-subtree-default)) + ((equal new current) t) ; nothing needs to be done + ((or (equal current old) + (eq org-mobile-force-mobile-change t) + (memq 'todo org-mobile-force-mobile-change)) + (org-todo (or new 'none)) t) + (t (error "State before change was expected as \"%s\", but is \"%s\"" + old current)))) + + ((eq what 'tags) + (setq current (org-get-tags) + new1 (and new (org-split-string new ":+")) + old1 (and old (org-split-string old ":+"))) + (cond + ((org-mobile-tags-same-p current new1) t) ; no change needed + ((or (org-mobile-tags-same-p current old1) + (eq org-mobile-force-mobile-change t) + (memq 'tags org-mobile-force-mobile-change)) + (org-set-tags-to new1) t) + (t (error "Tags before change were expected as \"%s\", but are \"%s\"" + (or old "") (or current ""))))) + + ((eq what 'priority) + (when (looking-at org-complex-heading-regexp) + (setq current (and (match-end 3) (substring (match-string 3) 2 3))) + (cond + ((equal current new) t) ; no action required + ((or (equal current old) + (eq org-mobile-force-mobile-change t) + (memq 'tags org-mobile-force-mobile-change)) + (org-priority (and new (string-to-char new)))) + (t (error "Priority was expected to be %s, but is %s" + old current))))) + + ((eq what 'heading) + (when (looking-at org-complex-heading-regexp) + (setq current (match-string 4)) + (cond + ((equal current new) t) ; no action required + ((or (equal current old) + (eq org-mobile-force-mobile-change t) + (memq 'heading org-mobile-force-mobile-change)) + (goto-char (match-beginning 4)) + (insert new) + (delete-region (point) (+ (point) (length current))) + (org-set-tags nil 'align)) + (t (error "Heading changed in MobileOrg and on the computer"))))) + + ((eq what 'body) + (setq current (buffer-substring (min (1+ (point-at-eol)) (point-max)) + (save-excursion (outline-next-heading) + (point)))) + (if (not (string-match "\\S-" current)) (setq current nil)) + (cond + ((org-mobile-bodies-same-p current new) t) ; no action necessary + ((or (org-mobile-bodies-same-p current old) + (eq org-mobile-force-mobile-change t) + (memq 'body org-mobile-force-mobile-change)) + (save-excursion + (end-of-line 1) + (insert "\n" new) + (or (bolp) (insert "\n")) + (delete-region (point) (progn (org-back-to-heading t) + (outline-next-heading) + (point)))) + t) + (t (error "Body was changed in MobileOrg and on the computer"))))))) + +(defun org-mobile-tags-same-p (list1 list2) + "Are the two tag lists the same?" + (not (or (org-delete-all list1 list2) + (org-delete-all list2 list1)))) + +(defun org-mobile-bodies-same-p (a b) + "Compare if A and B are visually equal strings. +We first remove leading and trailing white space from the entire strings. +Then we split the strings into lines and remove leading/trailing whitespace +from each line. Then we compare. +A and B must be strings or nil." + (cond + ((and (not a) (not b)) t) + ((or (not a) (not b)) nil) + (t (setq a (org-trim a) b (org-trim b)) + (setq a (mapconcat 'identity (org-split-string a "[ \t]*\n[ \t]*") "\n")) + (setq b (mapconcat 'identity (org-split-string b "[ \t]*\n[ \t]*") "\n")) + (equal a b)))) + +(provide 'org-mobile) + +;; arch-tag: ace0e26c-58f2-4309-8a61-05ec1535f658 + +;;; org-mobile.el ends here + diff --git a/.emacs.d/org-7.4/lisp/org-mobile.elc b/.emacs.d/org-7.4/lisp/org-mobile.elc Binary files differnew file mode 100644 index 0000000..7ea62fc --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-mobile.elc diff --git a/.emacs.d/org-7.4/lisp/org-mouse.el b/.emacs.d/org-7.4/lisp/org-mouse.el new file mode 100644 index 0000000..d1540c3 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-mouse.el @@ -0,0 +1,1148 @@ +;;; org-mouse.el --- Better mouse support for org-mode + +;; Copyright (C) 2006, 2007, 2008, 2009, 2010 Free Software Foundation +;; +;; Author: Piotr Zielinski <piotr dot zielinski at gmail dot com> +;; Maintainer: Carsten Dominik <carsten at orgmode dot org> +;; Version: 7.4 +;; +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: +;; +;; Org-mouse provides mouse support for org-mode. +;; +;; http://orgmode.org +;; +;; Org-mouse implements the following features: +;; * following links with the left mouse button (in Emacs 22) +;; * subtree expansion/collapse (org-cycle) with the left mouse button +;; * several context menus on the right mouse button: +;; + general text +;; + headlines +;; + timestamps +;; + priorities +;; + links +;; + tags +;; * promoting/demoting/moving subtrees with mouse-3 +;; + if the drag starts and ends in the same line then promote/demote +;; + otherwise move the subtree +;; +;; Use +;; --- +;; +;; To use this package, put the following line in your .emacs: +;; +;; (require 'org-mouse) +;; + +;; FIXME: +;; + deal with folding / unfolding issues + +;; TODO (This list is only theoretical, if you'd like to have some +;; feature implemented or a bug fix please send me an email, even if +;; something similar appears in the list below. This will help me get +;; the priorities right.): +;; +;; + org-store-link, insert link +;; + org tables +;; + occur with the current word/tag (same menu item) +;; + ctrl-c ctrl-c, for example, renumber the current list +;; + internal links + +;; Please email the maintainer with new feature suggestions / bugs + +;; History: +;; +;; Since version 5.10: Changes are listed in the general org-mode docs. +;; +;; Version 5.09 +;; + Version number synchronization with Org-mode. +;; +;; Version 0.25 +;; + made compatible with org-mode 4.70 (thanks to Carsten for the patch) +;; +;; Version 0.24 +;; + minor changes to the table menu +;; +;; Version 0.23 +;; + preliminary support for tables and calculation marks +;; + context menu support for org-agenda-undo & org-sort-entries +;; +;; Version 0.22 +;; + handles undo support for the agenda buffer (requires org-mode >=4.58) +;; +;; Version 0.21 +;; + selected text activates its context menu +;; + shift-middleclick or right-drag inserts the text from the clipboard in the form of a link +;; +;; Version 0.20 +;; + the new "TODO Status" submenu replaces the "Cycle TODO" menu item +;; + the TODO menu can now list occurrences of a specific TODO keyword +;; + #+STARTUP line is now recognized +;; +;; Version 0.19 +;; + added support for dragging URLs to the org-buffer +;; +;; Version 0.18 +;; + added support for agenda blocks +;; +;; Version 0.17 +;; + toggle checkboxes with a single click +;; +;; Version 0.16 +;; + added support for checkboxes +;; +;; Version 0.15 +;; + org-mode now works with the Agenda buffer as well +;; +;; Version 0.14 +;; + added a menu option that converts plain list items to outline items +;; +;; Version 0.13 +;; + "Insert Heading" now inserts a sibling heading if the point is +;; on "***" and a child heading otherwise +;; +;; Version 0.12 +;; + compatible with Emacs 21 +;; + custom agenda commands added to the main menu +;; + moving trees should now work between windows in the same frame +;; +;; Version 0.11 +;; + fixed org-mouse-at-link (thanks to Carsten) +;; + removed [follow-link] bindings +;; +;; Version 0.10 +;; + added a menu option to remove highlights +;; + compatible with org-mode 4.21 now +;; +;; Version 0.08: +;; + trees can be moved/promoted/demoted by dragging with the right +;; mouse button (mouse-3) +;; + small changes in the above function +;; +;; Versions 0.01 -- 0.07: (I don't remember) + +;;; Code: + +(eval-when-compile (require 'cl)) +(require 'org) + +(defvar org-agenda-allow-remote-undo) +(defvar org-agenda-undo-list) +(defvar org-agenda-custom-commands) +(declare-function org-agenda-change-all-lines "org-agenda" + (newhead hdmarker &optional fixface just-this)) +(declare-function org-verify-change-for-undo "org-agenda" (l1 l2)) +(declare-function org-apply-on-list "org-list" (function init-value &rest args)) + +(defvar org-mouse-plain-list-regexp "\\([ \t]*\\)\\([-+*]\\|[0-9]+[.)]\\) " + "Regular expression that matches a plain list.") +(defvar org-mouse-direct t + "Internal variable indicating whether the current action is direct. + +If t, then the current action has been invoked directly through the buffer +it is intended to operate on. If nil, then the action has been invoked +indirectly, for example, through the agenda buffer.") + +(defgroup org-mouse nil + "Mouse support for org-mode." + :tag "Org Mouse" + :group 'org) + +(defcustom org-mouse-punctuation ":" + "Punctuation used when inserting text by drag and drop." + :group 'org-mouse + :type 'string) + +(defcustom org-mouse-features + '(context-menu yank-link activate-stars activate-bullets activate-checkboxes) + "The features of org-mouse that should be activated. +Changing this variable requires a restart of Emacs to get activated." + :group 'org-mouse + :type '(set :greedy t + (const :tag "Mouse-3 shows context menu" context-menu) + (const :tag "C-mouse-1 and mouse-3 move trees" move-tree) + (const :tag "S-mouse-2 and drag-mouse-3 yank link" yank-link) + (const :tag "Activate headline stars" activate-stars) + (const :tag "Activate item bullets" activate-bullets) + (const :tag "Activate checkboxes" activate-checkboxes))) + +(defun org-mouse-re-search-line (regexp) + "Search the current line for a given regular expression." + (beginning-of-line) + (re-search-forward regexp (point-at-eol) t)) + +(defun org-mouse-end-headline () + "Go to the end of current headline (ignoring tags)." + (interactive) + (end-of-line) + (skip-chars-backward "\t ") + (when (org-looking-back ":[A-Za-z]+:") + (skip-chars-backward ":A-Za-z") + (skip-chars-backward "\t "))) + +(defvar org-mouse-context-menu-function nil + "Function to create the context menu. +The value of this variable is the function invoked by +`org-mouse-context-menu' as the context menu.") +(make-variable-buffer-local 'org-mouse-context-menu-function) + +(defun org-mouse-show-context-menu (event prefix) + "Invoke the context menu. + +If the value of `org-mouse-context-menu-function' is a function, then +this function is called. Otherwise, the current major mode menu is used." + (interactive "@e \nP") + (if (and (= (event-click-count event) 1) + (or (not mark-active) + (sit-for (/ double-click-time 1000.0)))) + (progn + (select-window (posn-window (event-start event))) + (when (not (org-mouse-mark-active)) + (goto-char (posn-point (event-start event))) + (when (not (eolp)) (save-excursion (run-hooks 'post-command-hook))) + (let ((redisplay-dont-pause t)) + (sit-for 0))) + (if (functionp org-mouse-context-menu-function) + (funcall org-mouse-context-menu-function event) + (if (fboundp 'mouse-menu-major-mode-map) + (popup-menu (mouse-menu-major-mode-map) event prefix) + (org-no-warnings ; don't warn about fallback, obsolete since 23.1 + (mouse-major-mode-menu event prefix))))) + (setq this-command 'mouse-save-then-kill) + (mouse-save-then-kill event))) + +(defun org-mouse-line-position () + "Return `:beginning' or `:middle' or `:end', depending on the point position. + +If the point is at the end of the line, return `:end'. +If the point is separated from the beginning of the line only by white +space and *'s (`org-mouse-bolp'), return `:beginning'. Otherwise, +return `:middle'." + (cond + ((eolp) :end) + ((org-mouse-bolp) :beginning) + (t :middle))) + +(defun org-mouse-empty-line () + "Return non-nil iff the line contains only white space." + (save-excursion (beginning-of-line) (looking-at "[ \t]*$"))) + +(defun org-mouse-next-heading () + "Go to the next heading. +If there is none, ensure that the point is at the beginning of an empty line." + (unless (outline-next-heading) + (beginning-of-line) + (unless (org-mouse-empty-line) + (end-of-line) + (newline)))) + +(defun org-mouse-insert-heading () + "Insert a new heading, as `org-insert-heading'. + +If the point is at the :beginning (`org-mouse-line-position') of the line, +insert the new heading before the current line. Otherwise, insert it +after the current heading." + (interactive) + (case (org-mouse-line-position) + (:beginning (beginning-of-line) + (org-insert-heading)) + (t (org-mouse-next-heading) + (org-insert-heading)))) + +(defun org-mouse-timestamp-today (&optional shift units) + "Change the timestamp into SHIFT UNITS in the future. + +For the acceptable UNITS, see `org-timestamp-change'." + (interactive) + (flet ((org-read-date (&rest rest) (current-time))) + (org-time-stamp nil)) + (when shift + (org-timestamp-change shift units))) + +(defun org-mouse-keyword-menu (keywords function &optional selected itemformat) + "A helper function. + +Returns a menu fragment consisting of KEYWORDS. When a keyword +is selected by the user, FUNCTION is called with the selected +keyword as the only argument. + +If SELECTED is nil, then all items are normal menu items. If +SELECTED is a function, then each item is a checkbox, which is +enabled for a given keyword iff (funcall SELECTED keyword) return +non-nil. If SELECTED is neither nil nor a function, then the +items are radio buttons. A radio button is enabled for the +keyword `equal' to SELECTED. + +ITEMFORMAT governs formatting of the elements of KEYWORDS. If it +is a function, it is invoked with the keyword as the only +argument. If it is a string, it is interpreted as the format +string to (format ITEMFORMAT keyword). If it is neither a string +nor a function, elements of KEYWORDS are used directly." + (mapcar + `(lambda (keyword) + (vector (cond + ((functionp ,itemformat) (funcall ,itemformat keyword)) + ((stringp ,itemformat) (format ,itemformat keyword)) + (t keyword)) + (list 'funcall ,function keyword) + :style (cond + ((null ,selected) t) + ((functionp ,selected) 'toggle) + (t 'radio)) + :selected (if (functionp ,selected) + (and (funcall ,selected keyword) t) + (equal ,selected keyword)))) + keywords)) + +(defun org-mouse-remove-match-and-spaces () + "Remove the match, make just one space around the point." + (interactive) + (replace-match "") + (just-one-space)) + +(defvar rest) +(defun org-mouse-replace-match-and-surround (newtext &optional fixedcase + literal string subexp) + "The same as `replace-match', but surrounds the replacement with spaces." + (apply 'replace-match rest) + (save-excursion + (goto-char (match-beginning (or subexp 0))) + (just-one-space) + (goto-char (match-end (or subexp 0))) + (just-one-space))) + + +(defun org-mouse-keyword-replace-menu (keywords &optional group itemformat + nosurround) + "A helper function. + +Returns a menu fragment consisting of KEYWORDS. When a keyword +is selected, group GROUP of the current match is replaced by the +keyword. The method ensures that both ends of the replacement +are separated from the rest of the text in the buffer by +individual spaces (unless NOSURROUND is non-nil). + +The final entry of the menu is always \"None\", which removes the +match. + +ITEMFORMAT governs formatting of the elements of KEYWORDS. If it +is a function, it is invoked with the keyword as the only +argument. If it is a string, it is interpreted as the format +string to (format ITEMFORMAT keyword). If it is neither a string +nor a function, elements of KEYWORDS are used directly." + (setq group (or group 0)) + (let ((replace (org-mouse-match-closure + (if nosurround 'replace-match + 'org-mouse-replace-match-and-surround)))) + (append + (org-mouse-keyword-menu + keywords + `(lambda (keyword) (funcall ,replace keyword t t nil ,group)) + (match-string group) + itemformat) + `(["None" org-mouse-remove-match-and-spaces + :style radio + :selected ,(not (member (match-string group) keywords))])))) + +(defun org-mouse-show-headlines () + "Change the visibility of the current org buffer to only show headlines." + (interactive) + (let ((this-command 'org-cycle) + (last-command 'org-cycle) + (org-cycle-global-status nil)) + (org-cycle '(4)) + (org-cycle '(4)))) + +(defun org-mouse-show-overview () + "Change visibility of current org buffer to first-level headlines only." + (interactive) + (let ((org-cycle-global-status nil)) + (org-cycle '(4)))) + +(defun org-mouse-set-priority (priority) + "Set the priority of the current headline to PRIORITY." + (flet ((read-char-exclusive () priority)) + (org-priority))) + +(defvar org-mouse-priority-regexp "\\[#\\([A-Z]\\)\\]" + "Regular expression matching the priority indicator. +Differs from `org-priority-regexp' in that it doesn't contain the +leading '.*?'.") + +(defun org-mouse-get-priority (&optional default) + "Return the priority of the current headline. +DEFAULT is returned if no priority is given in the headline." + (save-excursion + (if (org-mouse-re-search-line org-mouse-priority-regexp) + (match-string 1) + (when default (char-to-string org-default-priority))))) + +;; (defun org-mouse-at-link () +;; (and (eq (get-text-property (point) 'face) 'org-link) +;; (save-excursion +;; (goto-char (previous-single-property-change (point) 'face)) +;; (or (looking-at org-bracket-link-regexp) +;; (looking-at org-angle-link-re) +;; (looking-at org-plain-link-re))))) + + +(defun org-mouse-delete-timestamp () + "Deletes the current timestamp as well as the preceding keyword. +SCHEDULED: or DEADLINE: or ANYTHINGLIKETHIS:" + (when (or (org-at-date-range-p) (org-at-timestamp-p)) + (replace-match "") ; delete the timestamp + (skip-chars-backward " :A-Z") + (when (looking-at " *[A-Z][A-Z]+:") + (replace-match "")))) + +(defun org-mouse-looking-at (regexp skipchars &optional movechars) + (save-excursion + (let ((point (point))) + (if (looking-at regexp) t + (skip-chars-backward skipchars) + (forward-char (or movechars 0)) + (when (looking-at regexp) + (> (match-end 0) point)))))) + +(defun org-mouse-priority-list () + (loop for priority from ?A to org-lowest-priority + collect (char-to-string priority))) + +(defun org-mouse-todo-menu (state) + "Create the menu with TODO keywords." + (append + (let ((kwds org-todo-keywords-1)) + (org-mouse-keyword-menu + kwds + `(lambda (kwd) (org-todo kwd)) + (lambda (kwd) (equal state kwd)))))) + +(defun org-mouse-tag-menu () ;todo + "Create the tags menu." + (append + (let ((tags (org-get-tags))) + (org-mouse-keyword-menu + (sort (mapcar 'car (org-get-buffer-tags)) 'string-lessp) + `(lambda (tag) + (org-mouse-set-tags + (sort (if (member tag (quote ,tags)) + (delete tag (quote ,tags)) + (cons tag (quote ,tags))) + 'string-lessp))) + `(lambda (tag) (member tag (quote ,tags))) + )) + '("--" + ["Align Tags Here" (org-set-tags nil t) t] + ["Align Tags in Buffer" (org-set-tags t t) t] + ["Set Tags ..." (org-set-tags) t]))) + + +(defun org-mouse-set-tags (tags) + (save-excursion + ;; remove existing tags first + (beginning-of-line) + (when (org-mouse-re-search-line ":\\(\\([A-Za-z_]+:\\)+\\)") + (replace-match "")) + + ;; set new tags if any + (when tags + (end-of-line) + (insert " :" (mapconcat 'identity tags ":") ":") + (org-set-tags nil t)))) + +(defun org-mouse-insert-checkbox () + (interactive) + (and (org-at-item-p) + (goto-char (match-end 0)) + (unless (org-at-item-checkbox-p) + (delete-horizontal-space) + (insert " [ ] ")))) + +(defun org-mouse-agenda-type (type) + (case type + ('tags "Tags: ") + ('todo "TODO: ") + ('tags-tree "Tags tree: ") + ('todo-tree "TODO tree: ") + ('occur-tree "Occur tree: ") + (t "Agenda command ???"))) + + +(defun org-mouse-list-options-menu (alloptions &optional function) + (let ((options (save-match-data + (split-string (match-string-no-properties 1))))) + (print options) + (loop for name in alloptions + collect + (vector name + `(progn + (replace-match + (mapconcat 'identity + (sort (if (member ',name ',options) + (delete ',name ',options) + (cons ',name ',options)) + 'string-lessp) + " ") + nil nil nil 1) + (when (functionp ',function) (funcall ',function))) + :style 'toggle + :selected (and (member name options) t))))) + +(defun org-mouse-clip-text (text maxlength) + (if (> (length text) maxlength) + (concat (substring text 0 (- maxlength 3)) "...") + text)) + +(defun org-mouse-popup-global-menu () + (popup-menu + `("Main Menu" + ["Show Overview" org-mouse-show-overview t] + ["Show Headlines" org-mouse-show-headlines t] + ["Show All" show-all t] + ["Remove Highlights" org-remove-occur-highlights + :visible org-occur-highlights] + "--" + ["Check Deadlines" + (if (functionp 'org-check-deadlines-and-todos) + (org-check-deadlines-and-todos org-deadline-warning-days) + (org-check-deadlines org-deadline-warning-days)) t] + ["Check TODOs" org-show-todo-tree t] + ("Check Tags" + ,@(org-mouse-keyword-menu + (sort (mapcar 'car (org-get-buffer-tags)) 'string-lessp) + '(lambda (tag) (org-tags-sparse-tree nil tag))) + "--" + ["Custom Tag ..." org-tags-sparse-tree t]) + ["Check Phrase ..." org-occur] + "--" + ["Display Agenda" org-agenda-list t] + ["Display Timeline" org-timeline t] + ["Display TODO List" org-todo-list t] + ("Display Tags" + ,@(org-mouse-keyword-menu + (sort (mapcar 'car (org-get-buffer-tags)) 'string-lessp) + '(lambda (tag) (org-tags-view nil tag))) + "--" + ["Custom Tag ..." org-tags-view t]) + ["Display Calendar" org-goto-calendar t] + "--" + ,@(org-mouse-keyword-menu + (mapcar 'car org-agenda-custom-commands) + '(lambda (key) + (eval `(flet ((read-char-exclusive () (string-to-char ,key))) + (org-agenda nil)))) + nil + '(lambda (key) + (let ((entry (assoc key org-agenda-custom-commands))) + (org-mouse-clip-text + (cond + ((stringp (nth 1 entry)) (nth 1 entry)) + ((stringp (nth 2 entry)) + (concat (org-mouse-agenda-type (nth 1 entry)) + (nth 2 entry))) + (t "Agenda Command '%s'")) + 30)))) + "--" + ["Delete Blank Lines" delete-blank-lines + :visible (org-mouse-empty-line)] + ["Insert Checkbox" org-mouse-insert-checkbox + :visible (and (org-at-item-p) (not (org-at-item-checkbox-p)))] + ["Insert Checkboxes" + (org-mouse-for-each-item 'org-mouse-insert-checkbox) + :visible (and (org-at-item-p) (not (org-at-item-checkbox-p)))] + ["Plain List to Outline" org-mouse-transform-to-outline + :visible (org-at-item-p)]))) + + +(defun org-mouse-get-context (contextlist context) + (let ((contextdata (assq context contextlist))) + (when contextdata + (save-excursion + (goto-char (second contextdata)) + (re-search-forward ".*" (third contextdata)))))) + +(defun org-mouse-for-each-item (funct) + ;; Functions called by `org-apply-on-list' need an argument + (let ((wrap-fun (lambda (c) (funcall funct)))) + (when (org-in-item-p) + (org-apply-on-list wrap-fun nil)))) + +(defun org-mouse-bolp () + "Return true if there only spaces, tabs, and '*' before point. +This means, between the beginning of line and the point." + (save-excursion + (skip-chars-backward " \t*") (bolp))) + +(defun org-mouse-insert-item (text) + (case (org-mouse-line-position) + (:beginning ; insert before + (beginning-of-line) + (looking-at "[ \t]*") + (open-line 1) + (org-indent-to-column (- (match-end 0) (match-beginning 0))) + (insert "+ ")) + + (:middle ; insert after + (end-of-line) + (newline t) + (indent-relative) + (insert "+ ")) + + (:end ; insert text here + (skip-chars-backward " \t") + (kill-region (point) (point-at-eol)) + (unless (org-looking-back org-mouse-punctuation) + (insert (concat org-mouse-punctuation " "))))) + + (insert text) + (beginning-of-line)) + +(defadvice dnd-insert-text (around org-mouse-dnd-insert-text activate) + (if (eq major-mode 'org-mode) + (org-mouse-insert-item text) + ad-do-it)) + +(defadvice dnd-open-file (around org-mouse-dnd-open-file activate) + (if (eq major-mode 'org-mode) + (org-mouse-insert-item uri) + ad-do-it)) + +(defun org-mouse-match-closure (function) + (let ((match (match-data t))) + `(lambda (&rest rest) + (save-match-data + (set-match-data ',match) + (apply ',function rest))))) + +(defun org-mouse-match-todo-keyword () + (save-excursion + (org-back-to-heading) + (if (looking-at outline-regexp) (goto-char (match-end 0))) + (or (looking-at (concat " +" org-todo-regexp " *")) + (looking-at " \\( *\\)")))) + +(defun org-mouse-yank-link (click) + (interactive "e") + ;; Give temporary modes such as isearch a chance to turn off. + (run-hooks 'mouse-leave-buffer-hook) + (mouse-set-point click) + (setq mouse-selection-click-count 0) + (delete-horizontal-space) + (insert-for-yank (concat " [[" (current-kill 0) "]] "))) + +(defun org-mouse-context-menu (&optional event) + (let ((stamp-prefixes (list org-deadline-string org-scheduled-string)) + (contextlist (org-context))) + (flet ((get-context (context) (org-mouse-get-context contextlist context))) + (cond + ((org-mouse-mark-active) + (let ((region-string (buffer-substring (region-beginning) (region-end)))) + (popup-menu + `(nil + ["Sparse Tree" (org-occur ',region-string)] + ["Find in Buffer" (occur ',region-string)] + ["Grep in Current Dir" + (grep (format "grep -rnH -e '%s' *" ',region-string))] + ["Grep in Parent Dir" + (grep (format "grep -rnH -e '%s' ../*" ',region-string))] + "--" + ["Convert to Link" + (progn (save-excursion (goto-char (region-beginning)) (insert "[[")) + (save-excursion (goto-char (region-end)) (insert "]]")))] + ["Insert Link Here" (org-mouse-yank-link ',event)])))) + + ((save-excursion (beginning-of-line) (looking-at "#\\+STARTUP: \\(.*\\)")) + (popup-menu + `(nil + ,@(org-mouse-list-options-menu (mapcar 'car org-startup-options) + 'org-mode-restart)))) + ((or (eolp) + (and (looking-at "\\( \\|\t\\)\\(+:[0-9a-zA-Z_:]+\\)?\\( \\|\t\\)+$") + (org-looking-back " \\|\t"))) + (org-mouse-popup-global-menu)) + ((get-context :checkbox) + (popup-menu + '(nil + ["Toggle" org-toggle-checkbox t] + ["Remove" org-mouse-remove-match-and-spaces t] + "" + ["All Clear" (org-mouse-for-each-item + (lambda () + (when (save-excursion (org-at-item-checkbox-p)) + (replace-match "[ ]"))))] + ["All Set" (org-mouse-for-each-item + (lambda () + (when (save-excursion (org-at-item-checkbox-p)) + (replace-match "[X]"))))] + ["All Toggle" (org-mouse-for-each-item 'org-toggle-checkbox) t] + ["All Remove" (org-mouse-for-each-item + (lambda () + (when (save-excursion (org-at-item-checkbox-p)) + (org-mouse-remove-match-and-spaces))))] + ))) + ((and (org-mouse-looking-at "\\b\\w+" "a-zA-Z0-9_") + (member (match-string 0) org-todo-keywords-1)) + (popup-menu + `(nil + ,@(org-mouse-todo-menu (match-string 0)) + "--" + ["Check TODOs" org-show-todo-tree t] + ["List all TODO keywords" org-todo-list t] + [,(format "List only %s" (match-string 0)) + (org-todo-list (match-string 0)) t] + ))) + ((and (org-mouse-looking-at "\\b[A-Z]+:" "A-Z") + (member (match-string 0) stamp-prefixes)) + (popup-menu + `(nil + ,@(org-mouse-keyword-replace-menu stamp-prefixes) + "--" + ["Check Deadlines" org-check-deadlines t] + ))) + ((org-mouse-looking-at org-mouse-priority-regexp "[]A-Z#") ; priority + (popup-menu `(nil ,@(org-mouse-keyword-replace-menu + (org-mouse-priority-list) 1 "Priority %s" t)))) + ((get-context :link) + (popup-menu + '(nil + ["Open" org-open-at-point t] + ["Open in Emacs" (org-open-at-point t) t] + "--" + ["Copy link" (org-kill-new (match-string 0))] + ["Cut link" + (progn + (kill-region (match-beginning 0) (match-end 0)) + (just-one-space))] + "--" + ["Grep for TODOs" + (grep (format "grep -nH -i 'todo\\|fixme' %s*" (match-string 2)))] +; ["Paste file link" ((insert "file:") (yank))] + ))) + ((org-mouse-looking-at ":\\([A-Za-z0-9_]+\\):" "A-Za-z0-9_" -1) ;tags + (popup-menu + `(nil + [,(format "Display '%s'" (match-string 1)) + (org-tags-view nil ,(match-string 1))] + [,(format "Sparse Tree '%s'" (match-string 1)) + (org-tags-sparse-tree nil ,(match-string 1))] + "--" + ,@(org-mouse-tag-menu)))) + ((org-at-timestamp-p) + (popup-menu + '(nil + ["Show Day" org-open-at-point t] + ["Change Timestamp" org-time-stamp t] + ["Delete Timestamp" (org-mouse-delete-timestamp) t] + ["Compute Time Range" org-evaluate-time-range (org-at-date-range-p)] + "--" + ["Set for Today" org-mouse-timestamp-today] + ["Set for Tomorrow" (org-mouse-timestamp-today 1 'day)] + ["Set in 1 Week" (org-mouse-timestamp-today 7 'day)] + ["Set in 2 Weeks" (org-mouse-timestamp-today 14 'day)] + ["Set in a Month" (org-mouse-timestamp-today 1 'month)] + "--" + ["+ 1 Day" (org-timestamp-change 1 'day)] + ["+ 1 Week" (org-timestamp-change 7 'day)] + ["+ 1 Month" (org-timestamp-change 1 'month)] + "--" + ["- 1 Day" (org-timestamp-change -1 'day)] + ["- 1 Week" (org-timestamp-change -7 'day)] + ["- 1 Month" (org-timestamp-change -1 'month)]))) + ((get-context :table-special) + (let ((mdata (match-data))) + (incf (car mdata) 2) + (store-match-data mdata)) + (message "match: %S" (match-string 0)) + (popup-menu `(nil ,@(org-mouse-keyword-replace-menu + '(" " "!" "^" "_" "$" "#" "*" "'") 0 + (lambda (mark) + (case (string-to-char mark) + (? "( ) Nothing Special") + (?! "(!) Column Names") + (?^ "(^) Field Names Above") + (?_ "(^) Field Names Below") + (?$ "($) Formula Parameters") + (?# "(#) Recalculation: Auto") + (?* "(*) Recalculation: Manual") + (?' "(') Recalculation: None"))) t)))) + ((assq :table contextlist) + (popup-menu + '(nil + ["Align Table" org-ctrl-c-ctrl-c] + ["Blank Field" org-table-blank-field] + ["Edit Field" org-table-edit-field] + "--" + ("Column" + ["Move Column Left" org-metaleft] + ["Move Column Right" org-metaright] + ["Delete Column" org-shiftmetaleft] + ["Insert Column" org-shiftmetaright] + "--" + ["Enable Narrowing" (setq org-table-limit-column-width (not org-table-limit-column-width)) :selected org-table-limit-column-width :style toggle]) + ("Row" + ["Move Row Up" org-metaup] + ["Move Row Down" org-metadown] + ["Delete Row" org-shiftmetaup] + ["Insert Row" org-shiftmetadown] + ["Sort lines in region" org-table-sort-lines (org-at-table-p)] + "--" + ["Insert Hline" org-table-insert-hline]) + ("Rectangle" + ["Copy Rectangle" org-copy-special] + ["Cut Rectangle" org-cut-special] + ["Paste Rectangle" org-paste-special] + ["Fill Rectangle" org-table-wrap-region]) + "--" + ["Set Column Formula" org-table-eval-formula] + ["Set Field Formula" (org-table-eval-formula '(4))] + ["Edit Formulas" org-table-edit-formulas] + "--" + ["Recalculate Line" org-table-recalculate] + ["Recalculate All" (org-table-recalculate '(4))] + ["Iterate All" (org-table-recalculate '(16))] + "--" + ["Toggle Recalculate Mark" org-table-rotate-recalc-marks] + ["Sum Column/Rectangle" org-table-sum + :active (or (org-at-table-p) (org-region-active-p))] + ["Field Info" org-table-field-info] + ["Debug Formulas" + (setq org-table-formula-debug (not org-table-formula-debug)) + :style toggle :selected org-table-formula-debug] + ))) + ((and (assq :headline contextlist) (not (eolp))) + (let ((priority (org-mouse-get-priority t))) + (popup-menu + `("Headline Menu" + ("Tags and Priorities" + ,@(org-mouse-keyword-menu + (org-mouse-priority-list) + '(lambda (keyword) + (org-mouse-set-priority (string-to-char keyword))) + priority "Priority %s") + "--" + ,@(org-mouse-tag-menu)) + ("TODO Status" + ,@(org-mouse-todo-menu (org-get-todo-state))) + ["Show Tags" + (with-current-buffer org-mouse-main-buffer (org-agenda-show-tags)) + :visible (not org-mouse-direct)] + ["Show Priority" + (with-current-buffer org-mouse-main-buffer (org-agenda-show-priority)) + :visible (not org-mouse-direct)] + ,@(if org-mouse-direct '("--") nil) + ["New Heading" org-mouse-insert-heading :visible org-mouse-direct] + ["Set Deadline" + (progn (org-mouse-end-headline) (insert " ") (org-deadline)) + :active (not (save-excursion + (org-mouse-re-search-line org-deadline-regexp)))] + ["Schedule Task" + (progn (org-mouse-end-headline) (insert " ") (org-schedule)) + :active (not (save-excursion + (org-mouse-re-search-line org-scheduled-regexp)))] + ["Insert Timestamp" + (progn (org-mouse-end-headline) (insert " ") (org-time-stamp nil)) t] +; ["Timestamp (inactive)" org-time-stamp-inactive t] + "--" + ["Archive Subtree" org-archive-subtree] + ["Cut Subtree" org-cut-special] + ["Copy Subtree" org-copy-special] + ["Paste Subtree" org-paste-special :visible org-mouse-direct] + ("Sort Children" + ["Alphabetically" (org-sort-entries nil ?a)] + ["Numerically" (org-sort-entries nil ?n)] + ["By Time/Date" (org-sort-entries nil ?t)] + "--" + ["Reverse Alphabetically" (org-sort-entries nil ?A)] + ["Reverse Numerically" (org-sort-entries nil ?N)] + ["Reverse By Time/Date" (org-sort-entries nil ?T)]) + "--" + ["Move Trees" org-mouse-move-tree :active nil] + )))) + (t + (org-mouse-popup-global-menu)))))) + +;; (defun org-mouse-at-regexp (regexp) +;; (save-excursion +;; (let ((point (point)) +;; (bol (progn (beginning-of-line) (point))) +;; (eol (progn (end-of-line) (point)))) +;; (goto-char point) +;; (re-search-backward regexp bol 1) +;; (and (not (eolp)) +;; (progn (forward-char) +;; (re-search-forward regexp eol t)) +;; (<= (match-beginning 0) point))))) + +(defun org-mouse-mark-active () + (and mark-active transient-mark-mode)) + +(defun org-mouse-in-region-p (pos) + (and (org-mouse-mark-active) + (>= pos (region-beginning)) + (< pos (region-end)))) + +(defun org-mouse-down-mouse (event) + (interactive "e") + (setq this-command last-command) + (unless (and (= 1 (event-click-count event)) + (org-mouse-in-region-p (posn-point (event-start event)))) + (mouse-drag-region event))) + +(add-hook 'org-mode-hook + '(lambda () + (setq org-mouse-context-menu-function 'org-mouse-context-menu) + + (when (memq 'context-menu org-mouse-features) + (org-defkey org-mouse-map [mouse-3] nil) + (org-defkey org-mode-map [mouse-3] 'org-mouse-show-context-menu)) + (org-defkey org-mode-map [down-mouse-1] 'org-mouse-down-mouse) + (when (memq 'context-menu org-mouse-features) + (org-defkey org-mouse-map [C-drag-mouse-1] 'org-mouse-move-tree) + (org-defkey org-mouse-map [C-down-mouse-1] 'org-mouse-move-tree-start)) + (when (memq 'yank-link org-mouse-features) + (org-defkey org-mode-map [S-mouse-2] 'org-mouse-yank-link) + (org-defkey org-mode-map [drag-mouse-3] 'org-mouse-yank-link)) + (when (memq 'move-tree org-mouse-features) + (org-defkey org-mouse-map [drag-mouse-3] 'org-mouse-move-tree) + (org-defkey org-mouse-map [down-mouse-3] 'org-mouse-move-tree-start)) + + (when (memq 'activate-stars org-mouse-features) + (font-lock-add-keywords + nil + `((,outline-regexp + 0 `(face org-link mouse-face highlight keymap ,org-mouse-map) + 'prepend)) + t)) + + (when (memq 'activate-bullets org-mouse-features) + (font-lock-add-keywords + nil + `(("^[ \t]*\\([-+*]\\|[0-9]+[.)]\\) +" + (1 `(face org-link keymap ,org-mouse-map mouse-face highlight) + 'prepend))) + t)) + + (when (memq 'activate-checkboxes org-mouse-features) + (font-lock-add-keywords + nil + `(("^[ \t]*\\([-+*]\\|[0-9]+[.)]\\) +\\(\\[[ X]\\]\\)" + (2 `(face bold keymap ,org-mouse-map mouse-face highlight) t))) + t)) + + (defadvice org-open-at-point (around org-mouse-open-at-point activate) + (let ((context (org-context))) + (cond + ((assq :headline-stars context) (org-cycle)) + ((assq :checkbox context) (org-toggle-checkbox)) + ((assq :item-bullet context) + (let ((org-cycle-include-plain-lists t)) (org-cycle))) + (t ad-do-it)))))) + +(defun org-mouse-move-tree-start (event) + (interactive "e") + (message "Same line: promote/demote, (***):move before, (text): make a child")) + + +(defun org-mouse-make-marker (position) + (with-current-buffer (window-buffer (posn-window position)) + (copy-marker (posn-point position)))) + +(defun org-mouse-move-tree (event) + ;; todo: handle movements between different buffers + (interactive "e") + (save-excursion + (let* ((start (org-mouse-make-marker (event-start event))) + (end (org-mouse-make-marker (event-end event))) + (sbuf (marker-buffer start)) + (ebuf (marker-buffer end))) + + (when (and sbuf ebuf) + (set-buffer sbuf) + (goto-char start) + (org-back-to-heading) + (if (and (eq sbuf ebuf) + (equal + (point) + (save-excursion (goto-char end) (org-back-to-heading) (point)))) + ;; if the same line then promote/demote + (if (>= end start) (org-demote-subtree) (org-promote-subtree)) + ;; if different lines then move + (org-cut-subtree) + + (set-buffer ebuf) + (goto-char end) + (org-back-to-heading) + (when (and (eq sbuf ebuf) + (equal + (point) + (save-excursion (goto-char start) + (org-back-to-heading) (point)))) + (outline-end-of-subtree) + (end-of-line) + (if (eobp) (newline) (forward-char))) + + (when (looking-at outline-regexp) + (let ((level (- (match-end 0) (match-beginning 0)))) + (when (> end (match-end 0)) + (outline-end-of-subtree) + (end-of-line) + (if (eobp) (newline) (forward-char)) + (setq level (1+ level))) + (org-paste-subtree level) + (save-excursion + (outline-end-of-subtree) + (when (bolp) (delete-char -1)))))))))) + + +(defun org-mouse-transform-to-outline () + (interactive) + (org-back-to-heading) + (let ((minlevel 1000) + (replace-text (concat (match-string 0) "* "))) + (beginning-of-line 2) + (save-excursion + (while (not (or (eobp) (looking-at outline-regexp))) + (when (looking-at org-mouse-plain-list-regexp) + (setq minlevel (min minlevel (- (match-end 1) (match-beginning 1))))) + (forward-line))) + (while (not (or (eobp) (looking-at outline-regexp))) + (when (and (looking-at org-mouse-plain-list-regexp) + (eq minlevel (- (match-end 1) (match-beginning 1)))) + (replace-match replace-text)) + (forward-line)))) + +(defvar _cmd) ;dynamically scoped from `org-with-remote-undo'. + +(defun org-mouse-do-remotely (command) +; (org-agenda-check-no-diary) + (when (get-text-property (point) 'org-marker) + (let* ((anticol (- (point-at-eol) (point))) + (marker (get-text-property (point) 'org-marker)) + (buffer (marker-buffer marker)) + (pos (marker-position marker)) + (hdmarker (get-text-property (point) 'org-hd-marker)) + (buffer-read-only nil) + (newhead "--- removed ---") + (org-mouse-direct nil) + (org-mouse-main-buffer (current-buffer))) + (when (eq (with-current-buffer buffer major-mode) 'org-mode) + (let ((endmarker (with-current-buffer buffer + (outline-end-of-subtree) + (forward-char 1) + (copy-marker (point))))) + (org-with-remote-undo buffer + (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 + (org-back-to-heading) + (setq marker (copy-marker (point))) + (goto-char (max (point-at-bol) (- (point-at-eol) anticol))) + (funcall command) + (message "_cmd: %S" _cmd) + (message "this-command: %S" this-command) + (unless (eq (marker-position marker) (marker-position endmarker)) + (setq newhead (org-get-heading)))) + + (beginning-of-line 1) + (save-excursion + (org-agenda-change-all-lines newhead hdmarker 'fixface)))) + t)))) + +(defun org-mouse-agenda-context-menu (&optional event) + (or (org-mouse-do-remotely 'org-mouse-context-menu) + (popup-menu + '("Agenda" + ("Agenda Files") + "--" + ["Undo" (progn (message "last command: %S" last-command) (setq this-command 'org-agenda-undo) (org-agenda-undo)) + :visible (if (eq last-command 'org-agenda-undo) + org-agenda-pending-undo-list + org-agenda-undo-list)] + ["Rebuild Buffer" org-agenda-redo t] + ["New Diary Entry" + org-agenda-diary-entry (org-agenda-check-type nil 'agenda 'timeline) t] + "--" + ["Goto Today" org-agenda-goto-today + (org-agenda-check-type nil 'agenda 'timeline) t] + ["Display Calendar" org-agenda-goto-calendar + (org-agenda-check-type nil 'agenda 'timeline) t] + ("Calendar Commands" + ["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]) + "--" + ["Day View" org-agenda-day-view + :active (org-agenda-check-type nil 'agenda) + :style radio :selected (eq org-agenda-current-span 'day)] + ["Week View" org-agenda-week-view + :active (org-agenda-check-type nil 'agenda) + :style radio :selected (eq org-agenda-current-span 'week)] + "--" + ["Show Logbook entries" org-agenda-log-mode + :style toggle :selected org-agenda-show-log + :active (org-agenda-check-type nil 'agenda 'timeline)] + ["Include Diary" org-agenda-toggle-diary + :style toggle :selected org-agenda-include-diary + :active (org-agenda-check-type nil 'agenda)] + ["Use Time Grid" org-agenda-toggle-time-grid + :style toggle :selected org-agenda-use-time-grid + :active (org-agenda-check-type nil 'agenda)] + ["Follow Mode" org-agenda-follow-mode + :style toggle :selected org-agenda-follow-mode] + "--" + ["Quit" org-agenda-quit t] + ["Exit and Release Buffers" org-agenda-exit t] + )))) + +(defun org-mouse-get-gesture (event) + (let ((startxy (posn-x-y (event-start event))) + (endxy (posn-x-y (event-end event)))) + (if (< (car startxy) (car endxy)) :right :left))) + + +; (setq org-agenda-mode-hook nil) +(add-hook 'org-agenda-mode-hook + '(lambda () + (setq org-mouse-context-menu-function 'org-mouse-agenda-context-menu) + (org-defkey org-agenda-mode-map [mouse-3] 'org-mouse-show-context-menu) + (org-defkey org-agenda-mode-map [down-mouse-3] 'org-mouse-move-tree-start) + (org-defkey org-agenda-mode-map [C-mouse-4] 'org-agenda-earlier) + (org-defkey org-agenda-mode-map [C-mouse-5] 'org-agenda-later) + (org-defkey org-agenda-mode-map [drag-mouse-3] + '(lambda (event) (interactive "e") + (case (org-mouse-get-gesture event) + (:left (org-agenda-earlier 1)) + (:right (org-agenda-later 1))))))) + +(provide 'org-mouse) + +;; arch-tag: ff1ae557-3529-41a3-95c6-baaebdcc280f + +;;; org-mouse.el ends here diff --git a/.emacs.d/org-7.4/lisp/org-mouse.elc b/.emacs.d/org-7.4/lisp/org-mouse.elc Binary files differnew file mode 100644 index 0000000..e489016 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-mouse.elc diff --git a/.emacs.d/org-7.4/lisp/org-plot.el b/.emacs.d/org-7.4/lisp/org-plot.el new file mode 100644 index 0000000..374e2d4 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-plot.el @@ -0,0 +1,354 @@ +;;; org-plot.el --- Support for plotting from Org-mode + +;; Copyright (C) 2008, 2009, 2010 Free Software Foundation, Inc. +;; +;; Author: Eric Schulte <schulte dot eric at gmail dot com> +;; Keywords: tables, plotting +;; Homepage: http://orgmode.org +;; Version: 7.4 +;; +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Borrows ideas and a couple of lines of code from org-exp.el. + +;; Thanks to the org-mode mailing list for testing and implementation +;; and feature suggestions + +;;; Code: +(require 'org) +(require 'org-exp) +(require 'org-table) +(eval-when-compile + (require 'cl)) + +(declare-function gnuplot-delchar-or-maybe-eof "ext:gnuplot" (arg)) +(declare-function gnuplot-mode "ext:gnuplot" ()) +(declare-function gnuplot-send-buffer-to-gnuplot "ext:gnuplot" ()) + +(defvar org-plot/gnuplot-default-options + '((:plot-type . 2d) + (:with . lines) + (:ind . 0)) + "Default options to gnuplot used by `org-plot/gnuplot'.") + +(defvar org-plot-timestamp-fmt nil) + +(defun org-plot/add-options-to-plist (p options) + "Parse an OPTIONS line and set values in the property list P. +Returns the resulting property list." + (let (o) + (when options + (let ((op '(("type" . :plot-type) + ("script" . :script) + ("line" . :line) + ("set" . :set) + ("title" . :title) + ("ind" . :ind) + ("deps" . :deps) + ("with" . :with) + ("file" . :file) + ("labels" . :labels) + ("map" . :map) + ("timeind" . :timeind) + ("timefmt" . :timefmt))) + (multiples '("set" "line")) + (regexp ":\\([\"][^\"]+?[\"]\\|[(][^)]+?[)]\\|[^ \t\n\r;,.]*\\)") + (start 0) + o) + (while (setq o (pop op)) + (if (member (car o) multiples) ;; keys with multiple values + (while (string-match + (concat (regexp-quote (car o)) regexp) + options start) + (setq start (match-end 0)) + (setq p (plist-put p (cdr o) + (cons (car (read-from-string + (match-string 1 options))) + (plist-get p (cdr o))))) + p) + (if (string-match (concat (regexp-quote (car o)) regexp) + options) + (setq p (plist-put p (cdr o) + (car (read-from-string + (match-string 1 options))))))))))) + p) + +(defun org-plot/goto-nearest-table () + "Move the point forward to the beginning of nearest table. +Return value is the point at the beginning of the table." + (interactive) (move-beginning-of-line 1) + (while (not (or (org-at-table-p) (< 0 (forward-line 1))))) + (goto-char (org-table-begin))) + +(defun org-plot/collect-options (&optional params) + "Collect options from an org-plot '#+Plot:' line. +Accepts an optional property list PARAMS, to which the options +will be added. Returns the resulting property list." + (interactive) + (let ((line (thing-at-point 'line))) + (if (string-match "#\\+PLOT: +\\(.*\\)$" line) + (org-plot/add-options-to-plist params (match-string 1 line)) + params))) + +(defun org-plot-quote-timestamp-field (s) + "Convert field S from timestamp to Unix time and export to gnuplot." + (format-time-string org-plot-timestamp-fmt (org-time-string-to-time s))) + +(defun org-plot-quote-tsv-field (s) + "Quote field S for export to gnuplot." + (if (string-match org-table-number-regexp s) s + (if (string-match org-ts-regexp3 s) + (org-plot-quote-timestamp-field s) + (concat "\"" (mapconcat 'identity (split-string s "\"") "\"\"") "\"")))) + +(defun org-plot/gnuplot-to-data (table data-file params) + "Export TABLE to DATA-FILE in a format readable by gnuplot. +Pass PARAMS through to `orgtbl-to-generic' when exporting TABLE." + (with-temp-file + data-file + (make-local-variable 'org-plot-timestamp-fmt) + (setq org-plot-timestamp-fmt (or + (plist-get params :timefmt) + "%Y-%m-%d-%H:%M:%S")) + (insert (orgtbl-to-generic + table + (org-combine-plists + '(:sep "\t" :fmt org-plot-quote-tsv-field) + params)))) + nil) + +(defun org-plot/gnuplot-to-grid-data (table data-file params) + "Export the data in TABLE to DATA-FILE for gnuplot. +This means in a format appropriate for grid plotting by gnuplot. +PARAMS specifies which columns of TABLE should be plotted as independent +and dependant variables." + (interactive) + (let* ((ind (- (plist-get params :ind) 1)) + (deps (if (plist-member params :deps) + (mapcar (lambda (val) (- val 1)) (plist-get params :deps)) + (let (collector) + (dotimes (col (length (first table))) + (setf collector (cons col collector))) + collector))) + row-vals (counter 0)) + (when (>= ind 0) ;; collect values of ind col + (setf row-vals (mapcar (lambda (row) (setf counter (+ 1 counter)) + (cons counter (nth ind row))) table))) + (when (or deps (>= ind 0)) ;; remove non-plotting columns + (setf deps (delq ind deps)) + (setf table (mapcar (lambda (row) + (dotimes (col (length row)) + (unless (memq col deps) + (setf (nth col row) nil))) + (delq nil row)) + table))) + ;; write table to gnuplot grid datafile format + (with-temp-file data-file + (let ((num-rows (length table)) (num-cols (length (first table))) + front-edge back-edge) + (flet ((gnuplot-row (col row value) + (setf col (+ 1 col)) (setf row (+ 1 row)) + (format "%f %f %f\n%f %f %f\n" + col (- row 0.5) value ;; lower edge + col (+ row 0.5) value))) ;; upper edge + (dotimes (col num-cols) + (dotimes (row num-rows) + (setf back-edge + (concat back-edge + (gnuplot-row (- col 1) row (string-to-number + (nth col (nth row table)))))) + (setf front-edge + (concat front-edge + (gnuplot-row col row (string-to-number + (nth col (nth row table))))))) + ;; only insert once per row + (insert back-edge) (insert "\n") ;; back edge + (insert front-edge) (insert "\n") ;; front edge + (setf back-edge "") (setf front-edge ""))))) + row-vals)) + +(defun org-plot/gnuplot-script (data-file num-cols params &optional preface) + "Write a gnuplot script to DATA-FILE respecting the options set in PARAMS. +NUM-COLS controls the number of columns plotted in a 2-d plot. +Optional argument PREFACE returns only option parameters in a +manner suitable for prepending to a user-specified script." + (let* ((type (plist-get params :plot-type)) + (with (if (equal type 'grid) + 'pm3d + (plist-get params :with))) + (sets (plist-get params :set)) + (lines (plist-get params :line)) + (map (plist-get params :map)) + (title (plist-get params :title)) + (file (plist-get params :file)) + (ind (plist-get params :ind)) + (time-ind (plist-get params :timeind)) + (timefmt (plist-get params :timefmt)) + (text-ind (plist-get params :textind)) + (deps (if (plist-member params :deps) (plist-get params :deps))) + (col-labels (plist-get params :labels)) + (x-labels (plist-get params :xlabels)) + (y-labels (plist-get params :ylabels)) + (plot-str "'%s' using %s%d%s with %s title '%s'") + (plot-cmd (case type + ('2d "plot") + ('3d "splot") + ('grid "splot"))) + (script "reset") plot-lines) + (flet ((add-to-script (line) (setf script (format "%s\n%s" script line)))) + (when file ;; output file + (add-to-script (format "set term %s" (file-name-extension file))) + (add-to-script (format "set output '%s'" file))) + (case type ;; type + ('2d ()) + ('3d (if map (add-to-script "set map"))) + ('grid (if map + (add-to-script "set pm3d map") + (add-to-script "set pm3d")))) + (when title (add-to-script (format "set title '%s'" title))) ;; title + (when lines (mapc (lambda (el) (add-to-script el)) lines)) ;; line + (when sets ;; set + (mapc (lambda (el) (add-to-script (format "set %s" el))) sets)) + (when x-labels ;; x labels (xtics) + (add-to-script + (format "set xtics (%s)" + (mapconcat (lambda (pair) + (format "\"%s\" %d" (cdr pair) (car pair))) + x-labels ", ")))) + (when y-labels ;; y labels (ytics) + (add-to-script + (format "set ytics (%s)" + (mapconcat (lambda (pair) + (format "\"%s\" %d" (cdr pair) (car pair))) + y-labels ", ")))) + (when time-ind ;; timestamp index + (add-to-script "set xdata time") + (add-to-script (concat "set timefmt \"" + (or timefmt ;; timefmt passed to gnuplot + "%Y-%m-%d-%H:%M:%S") "\""))) + (unless preface + (case type ;; plot command + ('2d (dotimes (col num-cols) + (unless (and (equal type '2d) + (or (and ind (equal (+ 1 col) ind)) + (and deps (not (member (+ 1 col) deps))))) + (setf plot-lines + (cons + (format plot-str data-file + (or (and ind (> ind 0) + (not text-ind) + (format "%d:" ind)) "") + (+ 1 col) + (if text-ind (format ":xticlabel(%d)" ind) "") + with + (or (nth col col-labels) (format "%d" (+ 1 col)))) + plot-lines))))) + ('3d + (setq plot-lines (list (format "'%s' matrix with %s title ''" + data-file with)))) + ('grid + (setq plot-lines (list (format "'%s' with %s title ''" + data-file with))))) + (add-to-script + (concat plot-cmd " " (mapconcat 'identity (reverse plot-lines) ",\\\n ")))) + script))) + +;;----------------------------------------------------------------------------- +;; facade functions +;;;###autoload +(defun org-plot/gnuplot (&optional params) + "Plot table using gnuplot. Gnuplot options can be specified with PARAMS. +If not given options will be taken from the +PLOT +line directly before or after the table." + (interactive) + (require 'gnuplot) + (save-window-excursion + (delete-other-windows) + (when (get-buffer "*gnuplot*") ;; reset *gnuplot* if it already running + (with-current-buffer "*gnuplot*" + (goto-char (point-max)) + (gnuplot-delchar-or-maybe-eof nil))) + (org-plot/goto-nearest-table) + ;; set default options + (mapc + (lambda (pair) + (unless (plist-member params (car pair)) + (setf params (plist-put params (car pair) (cdr pair))))) + org-plot/gnuplot-default-options) + ;; collect table and table information + (let* ((data-file (make-temp-file "org-plot")) + (table (org-table-to-lisp)) + (num-cols (length (if (eq (first table) 'hline) (second table) + (first table))))) + (while (equal 'hline (first table)) (setf table (cdr table))) + (when (equal (second table) 'hline) + (setf params (plist-put params :labels (first table))) ;; headers to labels + (setf table (delq 'hline (cdr table)))) ;; clean non-data from table + ;; collect options + (save-excursion (while (and (equal 0 (forward-line -1)) + (looking-at "[[:space:]]*#\\+")) + (setf params (org-plot/collect-options params)))) + ;; dump table to datafile (very different for grid) + (case (plist-get params :plot-type) + ('2d (org-plot/gnuplot-to-data table data-file params)) + ('3d (org-plot/gnuplot-to-data table data-file params)) + ('grid (let ((y-labels (org-plot/gnuplot-to-grid-data + table data-file params))) + (when y-labels (plist-put params :ylabels y-labels))))) + ;; check for timestamp ind column + (let ((ind (- (plist-get params :ind) 1))) + (when (and (>= ind 0) (equal '2d (plist-get params :plot-type))) + (if (= (length + (delq 0 (mapcar + (lambda (el) + (if (string-match org-ts-regexp3 el) + 0 1)) + (mapcar (lambda (row) (nth ind row)) table)))) 0) + (plist-put params :timeind t) + ;; check for text ind column + (if (or (string= (plist-get params :with) "hist") + (> (length + (delq 0 (mapcar + (lambda (el) + (if (string-match org-table-number-regexp el) + 0 1)) + (mapcar (lambda (row) (nth ind row)) table)))) 0)) + (plist-put params :textind t))))) + ;; write script + (with-temp-buffer + (if (plist-get params :script) ;; user script + (progn (insert + (org-plot/gnuplot-script data-file num-cols params t)) + (insert "\n") + (insert-file-contents (plist-get params :script)) + (goto-char (point-min)) + (while (re-search-forward "$datafile" nil t) + (replace-match data-file nil nil))) + (insert + (org-plot/gnuplot-script data-file num-cols params))) + ;; graph table + (gnuplot-mode) + (gnuplot-send-buffer-to-gnuplot)) + ;; cleanup + (bury-buffer (get-buffer "*gnuplot*")) + (run-with-idle-timer 0.1 nil (lambda () (delete-file data-file)))))) + +(provide 'org-plot) + +;; arch-tag: 5763f7c6-0c75-416d-b070-398ee4ec0eca +;;; org-plot.el ends here diff --git a/.emacs.d/org-7.4/lisp/org-plot.elc b/.emacs.d/org-7.4/lisp/org-plot.elc Binary files differnew file mode 100644 index 0000000..893f1d3 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-plot.elc diff --git a/.emacs.d/org-7.4/lisp/org-protocol.el b/.emacs.d/org-7.4/lisp/org-protocol.el new file mode 100644 index 0000000..5d5059f --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-protocol.el @@ -0,0 +1,708 @@ +;;; org-protocol.el --- Intercept calls from emacsclient to trigger custom actions. +;; +;; Copyright (C) 2008, 2009, 2010 +;; Free Software Foundation, Inc. +;; +;; Author: Bastien Guerry <bzg AT altern DOT org> +;; Author: Daniel M German <dmg AT uvic DOT org> +;; Author: Sebastian Rose <sebastian_rose AT gmx DOT de> +;; Author: Ross Patterson <me AT rpatterson DOT net> +;; Maintainer: Sebastian Rose <sebastian_rose AT gmx DOT de> +;; Keywords: org, emacsclient, wp +;; Version: 7.4 + +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Commentary: +;; +;; Intercept calls from emacsclient to trigger custom actions. +;; +;; This is done by advising `server-visit-files' to scan the list of filenames +;; for `org-protocol-the-protocol' and sub-protocols defined in +;; `org-protocol-protocol-alist' and `org-protocol-protocol-alist-default'. +;; +;; Any application that supports calling external programs with an URL +;; as argument may be used with this functionality. +;; +;; +;; Usage: +;; ------ +;; +;; 1.) Add this to your init file (.emacs probably): +;; +;; (add-to-list 'load-path "/path/to/org-protocol/") +;; (require 'org-protocol) +;; +;; 3.) Ensure emacs-server is up and running. +;; 4.) Try this from the command line (adjust the URL as needed): +;; +;; $ emacsclient \ +;; org-protocol://store-link://http:%2F%2Flocalhost%2Findex.html/The%20title +;; +;; 5.) Optionally add custom sub-protocols and handlers: +;; +;; (setq org-protocol-protocol-alist +;; '(("my-protocol" +;; :protocol "my-protocol" +;; :function my-protocol-handler-function))) +;; +;; A "sub-protocol" will be found in URLs like this: +;; +;; org-protocol://sub-protocol://data +;; +;; If it works, you can now setup other applications for using this feature. +;; +;; +;; As of March 2009 Firefox users follow the steps documented on +;; http://kb.mozillazine.org/Register_protocol, Opera setup is described here: +;; http://www.opera.com/support/kb/view/535/ +;; +;; +;; Documentation +;; ------------- +;; +;; org-protocol.el comes with and installs handlers to open sources of published +;; online content, store and insert the browser's URLs and cite online content +;; by clicking on a bookmark in Firefox, Opera and probably other browsers and +;; applications: +;; +;; * `org-protocol-open-source' uses the sub-protocol \"open-source\" and maps +;; URLs to local filenames defined in `org-protocol-project-alist'. +;; +;; * `org-protocol-store-link' stores an Org-link (if Org-mode is present) and +;; pushes the browsers URL to the `kill-ring' for yanking. This handler is +;; triggered through the sub-protocol \"store-link\". +;; +;; * Call `org-protocol-capture' by using the sub-protocol \"capture\". If +;; Org-mode is loaded, Emacs will pop-up a capture buffer and fill the +;; template with the data provided. I.e. the browser's URL is inserted as an +;; Org-link of which the page title will be the description part. If text +;; was select in the browser, that text will be the body of the entry. +;; +;; * Call `org-protocol-remember' by using the sub-protocol \"remember\". +;; This is provided for backward compatibility. +;; You may read `org-capture' as `org-remember' throughout this file if +;; you still use `org-remember'. +;; +;; You may use the same bookmark URL for all those standard handlers and just +;; adjust the sub-protocol used: +;; +;; location.href='org-protocol://sub-protocol://'+ +;; encodeURIComponent(location.href)+'/'+ +;; encodeURIComponent(document.title)+'/'+ +;; encodeURIComponent(window.getSelection()) +;; +;; The handler for the sub-protocol \"capture\" detects an optional template +;; char that, if present, triggers the use of a special template. +;; Example: +;; +;; location.href='org-protocol://sub-protocol://x/'+ ... +;; +;; use template ?x. +;; +;; Note, that using double slashes is optional from org-protocol.el's point of +;; view because emacsclient squashes the slashes to one. +;; +;; +;; provides: 'org-protocol +;; +;;; Code: + +(require 'org) +(eval-when-compile + (require 'cl)) + +(declare-function org-publish-get-project-from-filename "org-publish" + (filename &optional up)) +(declare-function server-edit "server" (&optional arg)) + + +(defgroup org-protocol nil + "Intercept calls from emacsclient to trigger custom actions. + +This is done by advising `server-visit-files' to scann the list of filenames +for `org-protocol-the-protocol' and sub-procols defined in +`org-protocol-protocol-alist' and `org-protocol-protocol-alist-default'." + :version "22.1" + :group 'convenience + :group 'org) + + +;;; Variables: + +(defconst org-protocol-protocol-alist-default + '(("org-remember" :protocol "remember" :function org-protocol-remember :kill-client t) + ("org-capture" :protocol "capture" :function org-protocol-capture :kill-client t) + ("org-store-link" :protocol "store-link" :function org-protocol-store-link) + ("org-open-source" :protocol "open-source" :function org-protocol-open-source)) + "Default protocols to use. +See `org-protocol-protocol-alist' for a description of this variable.") + + +(defconst org-protocol-the-protocol "org-protocol" + "This is the protocol to detect if org-protocol.el is loaded. +`org-protocol-protocol-alist-default' and `org-protocol-protocol-alist' hold +the sub-protocols that trigger the required action. You will have to define +just one protocol handler OS-wide (MS-Windows) or per application (Linux). +That protocol handler should call emacsclient.") + + +;;; User variables: + +(defcustom org-protocol-reverse-list-of-files t + "* Non-nil means re-reverse the list of filenames passed on the command line. +The filenames passed on the command line are passed to the emacs-server in +reverse order. Set to t (default) to re-reverse the list, i.e. use the +sequence on the command line. If nil, the sequence of the filenames is +unchanged." + :group 'org-protocol + :type 'boolean) + + +(defcustom org-protocol-project-alist nil + "* Map URLs to local filenames for `org-protocol-open-source' (open-source). + +Each element of this list must be of the form: + + (module-name :property value property: value ...) + +where module-name is an arbitrary name. All the values are strings. + +Possible properties are: + + :online-suffix - the suffix to strip from the published URLs + :working-suffix - the replacement for online-suffix + :base-url - the base URL, e.g. http://www.example.com/project/ + Last slash required. + :working-directory - the local working directory. This is, what base-url will + be replaced with. + :redirects - A list of cons cells, each of which maps a regular + expression to match to a path relative to :working-directory. + +Example: + + (setq org-protocol-project-alist + '((\"http://orgmode.org/worg/\" + :online-suffix \".php\" + :working-suffix \".org\" + :base-url \"http://orgmode.org/worg/\" + :working-directory \"/home/user/org/Worg/\") + (\"http://localhost/org-notes/\" + :online-suffix \".html\" + :working-suffix \".org\" + :base-url \"http://localhost/org/\" + :working-directory \"/home/user/org/\" + :rewrites ((\"org/?$\" . \"index.php\"))))) + + The last line tells `org-protocol-open-source' to open + /home/user/org/index.php, if the URL cannot be mapped to an existing + file, and ends with either \"org\" or \"org/\". + +Consider using the interactive functions `org-protocol-create' and +`org-protocol-create-for-org' to help you filling this variable with valid contents." + :group 'org-protocol + :type 'alist) + + +(defcustom org-protocol-protocol-alist nil + "* Register custom handlers for org-protocol. + +Each element of this list must be of the form: + + (module-name :protocol protocol :function func :kill-client nil) + +protocol - protocol to detect in a filename without trailing colon and slashes. + See rfc1738 section 2.1 for more on this. + If you define a protocol \"my-protocol\", `org-protocol-check-filename-for-protocol' + will search filenames for \"org-protocol:/my-protocol:/\" + and trigger your action for every match. `org-protocol' is defined in + `org-protocol-the-protocol'. Double and triple slashes are compressed + to one by emacsclient. + +function - function that handles requests with protocol and takes exactly one + argument: the filename with all protocols stripped. If the function + returns nil, emacsclient and -server do nothing. Any non-nil return + value is considered a valid filename and thus passed to the server. + + `org-protocol.el provides some support for handling those filenames, + if you stay with the conventions used for the standard handlers in + `org-protocol-protocol-alist-default'. See `org-protocol-split-data'. + +kill-client - If t, kill the client immediately, once the sub-protocol is + detected. This is necessary for actions that can be interrupted by + `C-g' to avoid dangling emacsclients. Note, that all other command + line arguments but the this one will be discarded, greedy handlers + still receive the whole list of arguments though. + +Here is an example: + + (setq org-protocol-protocol-alist + '((\"my-protocol\" + :protocol \"my-protocol\" + :function my-protocol-handler-function) + (\"your-protocol\" + :protocol \"your-protocol\" + :function your-protocol-handler-function)))" + :group 'org-protocol + :type '(alist)) + +(defcustom org-protocol-default-template-key nil + "The default org-remember-templates key to use." + :group 'org-protocol + :type 'string) + +;;; Helper functions: + +(defun org-protocol-sanitize-uri (uri) + "emacsclient compresses double and triple slashes. +Slashes are sanitized to double slashes here." + (when (string-match "^\\([a-z]+\\):/" uri) + (let* ((splitparts (split-string uri "/+"))) + (setq uri (concat (car splitparts) "//" (mapconcat 'identity (cdr splitparts) "/"))))) + uri) + + +(defun org-protocol-split-data(data &optional unhexify separator) + "Split, what an org-protocol handler function gets as only argument. +DATA is that one argument. DATA is split at each occurrence of +SEPARATOR (regexp). If no SEPARATOR is specified or SEPARATOR is +nil, assume \"/+\". The results of that splitting are returned +as a list. If UNHEXIFY is non-nil, hex-decode each split part. If +UNHEXIFY is a function, use that function to decode each split +part." + (let* ((sep (or separator "/+")) + (split-parts (split-string data sep))) + (if unhexify + (if (fboundp unhexify) + (mapcar unhexify split-parts) + (mapcar 'org-protocol-unhex-string split-parts)) + split-parts))) + +;; This inline function is needed in org-protocol-unhex-compound to do +;; the right thing to decode UTF-8 char integer values. +(eval-when-compile + (if (>= emacs-major-version 23) + (defsubst org-protocol-char-to-string(c) + "Defsubst to decode UTF-8 character values in emacs 23 and beyond." + (char-to-string c)) + (defsubst org-protocol-char-to-string (c) + "Defsubst to decode UTF-8 character values in emacs 22." + (string (decode-char 'ucs c))))) + +(defun org-protocol-unhex-string(str) + "Unhex hexified unicode strings as returned from the JavaScript function +encodeURIComponent. E.g. `%C3%B6' is the german Umlaut `ü'." + (setq str (or str "")) + (let ((tmp "") + (case-fold-search t)) + (while (string-match "\\(%[0-9a-f][0-9a-f]\\)+" str) + (let* ((start (match-beginning 0)) + (end (match-end 0)) + (hex (match-string 0 str)) + (replacement (org-protocol-unhex-compound (upcase hex)))) + (setq tmp (concat tmp (substring str 0 start) replacement)) + (setq str (substring str end)))) + (setq tmp (concat tmp str)) + tmp)) + + +(defun org-protocol-unhex-compound (hex) + "Unhexify unicode hex-chars. E.g. `%C3%B6' is the German Umlaut `ü'." + (let* ((bytes (remove "" (split-string hex "%"))) + (ret "") + (eat 0) + (sum 0)) + (while bytes + (let* ((b (pop bytes)) + (a (elt b 0)) + (b (elt b 1)) + (c1 (if (> a ?9) (+ 10 (- a ?A)) (- a ?0))) + (c2 (if (> b ?9) (+ 10 (- b ?A)) (- b ?0))) + (val (+ (lsh c1 4) c2)) + (shift + (if (= 0 eat) ;; new byte + (if (>= val 252) 6 + (if (>= val 248) 5 + (if (>= val 240) 4 + (if (>= val 224) 3 + (if (>= val 192) 2 0))))) + 6)) + (xor + (if (= 0 eat) ;; new byte + (if (>= val 252) 252 + (if (>= val 248) 248 + (if (>= val 240) 240 + (if (>= val 224) 224 + (if (>= val 192) 192 0))))) + 128))) + (if (>= val 192) (setq eat shift)) + (setq val (logxor val xor)) + (setq sum (+ (lsh sum shift) val)) + (if (> eat 0) (setq eat (- eat 1))) + (when (= 0 eat) + (setq ret (concat ret (org-protocol-char-to-string sum))) + (setq sum 0)) + )) ;; end (while bytes + ret )) + +(defun org-protocol-flatten-greedy (param-list &optional strip-path replacement) + "Greedy handlers might receive a list like this from emacsclient: + '( (\"/dir/org-protocol:/greedy:/~/path1\" (23 . 12)) (\"/dir/param\") +where \"/dir/\" is the absolute path to emacsclients working directory. This +function transforms it into a flat list utilizing `org-protocol-flatten' and +transforms the elements of that list as follows: + +If strip-path is non-nil, remove the \"/dir/\" prefix from all members of +param-list. + +If replacement is string, replace the \"/dir/\" prefix with it. + +The first parameter, the one that contains the protocols, is always changed. +Everything up to the end of the protocols is stripped. + +Note, that this function will always behave as if +`org-protocol-reverse-list-of-files' was set to t and the returned list will +reflect that. I.e. emacsclients first parameter will be the first one in the +returned list." +(let* ((l (org-protocol-flatten (if org-protocol-reverse-list-of-files + param-list + (reverse param-list)))) + (trigger (car l)) + (len 0) + dir + ret) + (when (string-match "^\\(.*\\)\\(org-protocol:/+[a-zA-z0-9][-_a-zA-z0-9]*:/+\\)\\(.*\\)" trigger) + (setq dir (match-string 1 trigger)) + (setq len (length dir)) + (setcar l (concat dir (match-string 3 trigger)))) + (if strip-path + (progn + (dolist (e l ret) + (setq ret + (append ret + (list + (if (stringp e) + (if (stringp replacement) + (setq e (concat replacement (substring e len))) + (setq e (substring e len))) + e))))) + ret) + l))) + + +(defun org-protocol-flatten (l) + "Greedy handlers might receive a list like this from emacsclient: + '( (\"/dir/org-protocol:/greedy:/~/path1\" (23 . 12)) (\"/dir/param\") +where \"/dir/\" is the absolute path to emacsclients working directory. +This function transforms it into a flat list." + (if (null l) () + (if (listp l) + (append (org-protocol-flatten (car l)) (org-protocol-flatten (cdr l))) + (list l)))) + +;;; Standard protocol handlers: + +(defun org-protocol-store-link (fname) + "Process an org-protocol://store-link:// style url. +Additionally store a browser URL as an org link. Also pushes the +link's URL to the `kill-ring'. + +The location for a browser's bookmark has to look like this: + + javascript:location.href='org-protocol://store-link://'+ \\ + encodeURIComponent(location.href) + encodeURIComponent(document.title)+'/'+ \\ + +Don't use `escape()'! Use `encodeURIComponent()' instead. The title of the page +could contain slashes and the location definitely will. + +The sub-protocol used to reach this function is set in +`org-protocol-protocol-alist'." + (let* ((splitparts (org-protocol-split-data fname t)) + (uri (org-protocol-sanitize-uri (car splitparts))) + (title (cadr splitparts)) + orglink) + (if (boundp 'org-stored-links) + (setq org-stored-links (cons (list uri title) org-stored-links))) + (kill-new uri) + (message "`%s' to insert new org-link, `%s' to insert `%s'" + (substitute-command-keys"\\[org-insert-link]") + (substitute-command-keys"\\[yank]") + uri)) + nil) + +(defun org-protocol-remember (info) + "Process an org-protocol://remember:// style url. + +The location for a browser's bookmark has to look like this: + + javascript:location.href='org-protocol://remember://'+ \\ + encodeURIComponent(location.href)+'/' \\ + encodeURIComponent(document.title)+'/'+ \\ + encodeURIComponent(window.getSelection()) + +See the docs for `org-protocol-capture' for more information." + + (if (and (boundp 'org-stored-links) + (or (fboundp 'org-capture)) + (org-protocol-do-capture info 'org-remember)) + (message "Org-mode not loaded.")) + nil) + +(defun org-protocol-capture (info) + "Process an org-protocol://capture:// style url. + +The sub-protocol used to reach this function is set in +`org-protocol-protocol-alist'. + +This function detects an URL, title and optional text, separated by '/' +The location for a browser's bookmark has to look like this: + + javascript:location.href='org-protocol://capture://'+ \\ + encodeURIComponent(location.href)+'/' \\ + encodeURIComponent(document.title)+'/'+ \\ + encodeURIComponent(window.getSelection()) + +By default, it uses the character `org-protocol-default-template-key', +which should be associated with a template in `org-capture-templates'. +But you may prepend the encoded URL with a character and a slash like so: + + javascript:location.href='org-protocol://capture://b/'+ ... + +Now template ?b will be used." + (if (and (boundp 'org-stored-links) + (or (fboundp 'org-capture)) + (org-protocol-do-capture info 'org-capture)) + (message "Org-mode not loaded.")) + nil) + +(defun org-protocol-do-capture (info capture-func) + "Support `org-capture' and `org-remember' alike. +CAPTURE-FUNC is either the symbol `org-remember' or `org-capture'." + (let* ((parts (org-protocol-split-data info t)) + (template (or (and (= 1 (length (car parts))) (pop parts)) + org-protocol-default-template-key)) + (url (org-protocol-sanitize-uri (car parts))) + (type (if (string-match "^\\([a-z]+\\):" url) + (match-string 1 url))) + (title(or (cadr parts) "")) + (region (or (caddr parts) "")) + (orglink (org-make-link-string + url (if (string-match "[^[:space:]]" title) title url))) + (org-capture-link-is-already-stored t) ;; avoid call to org-store-link + remember-annotation-functions) + (setq org-stored-links + (cons (list url title) org-stored-links)) + (kill-new orglink) + (org-store-link-props :type type + :link url + :description title + :annotation orglink + :initial region) + (raise-frame) + (funcall capture-func nil template))) + + +(defun org-protocol-open-source (fname) + "Process an org-protocol://open-source:// style url. + +Change a filename by mapping URLs to local filenames as set +in `org-protocol-project-alist'. + +The location for a browser's bookmark should look like this: + + javascript:location.href='org-protocol://open-source://'+ \\ + encodeURIComponent(location.href)" + + ;; As we enter this function for a match on our protocol, the return value + ;; defaults to nil. + (let ((result nil) + (f (org-protocol-unhex-string fname))) + (catch 'result + (dolist (prolist org-protocol-project-alist) + (let* ((base-url (plist-get (cdr prolist) :base-url)) + (wsearch (regexp-quote base-url))) + + (when (string-match wsearch f) + (let* ((wdir (plist-get (cdr prolist) :working-directory)) + (strip-suffix (plist-get (cdr prolist) :online-suffix)) + (add-suffix (plist-get (cdr prolist) :working-suffix)) + ;; Strip "[?#].*$" if `f' is a redirect with another + ;; ending than strip-suffix here: + (f1 (substring f 0 (string-match "\\([\\?#].*\\)?$" f))) + (start-pos (+ (string-match wsearch f1) (length base-url))) + (end-pos (string-match + (regexp-quote strip-suffix) f1)) + ;; We have to compare redirects without suffix below: + (f2 (concat wdir (substring f1 start-pos end-pos))) + (the-file (concat f2 add-suffix))) + + ;; Note: the-file may still contain `%C3' et al here because browsers + ;; tend to encode `ä' in URLs to `%25C3' - `%25' being `%'. + ;; So the results may vary. + + ;; -- start redirects -- + (unless (file-exists-p the-file) + (message "File %s does not exist.\nTesting for rewritten URLs." the-file) + (let ((rewrites (plist-get (cdr prolist) :rewrites))) + (when rewrites + (message "Rewrites found: %S" rewrites) + (mapc + (lambda (rewrite) + "Try to match a rewritten URL and map it to a real file." + ;; Compare redirects without suffix: + (if (string-match (car rewrite) f2) + (throw 'result (concat wdir (cdr rewrite))))) + rewrites)))) + ;; -- end of redirects -- + + (if (file-readable-p the-file) + (throw 'result the-file)) + (if (file-exists-p the-file) + (message "%s: permission denied!" the-file) + (message "%s: no such file or directory." the-file)))))) + result))) + + +;;; Core functions: + +(defun org-protocol-check-filename-for-protocol (fname restoffiles client) + "Detect if `org-protocol-the-protocol' and a known sub-protocol is used in fname. +Sub-protocols are registered in `org-protocol-protocol-alist' and +`org-protocol-protocol-alist-default'. +This is, how the matching is done: + + (string-match \"protocol:/+sub-protocol:/+\" ...) + +protocol and sub-protocol are regexp-quoted. + +If a matching protocol is found, the protocol is stripped from fname and the +result is passed to the protocols function as the only parameter. If the +function returns nil, the filename is removed from the list of filenames +passed from emacsclient to the server. +If the function returns a non nil value, that value is passed to the server +as filename." + (let ((sub-protocols (append org-protocol-protocol-alist org-protocol-protocol-alist-default))) + (catch 'fname + (let ((the-protocol (concat (regexp-quote org-protocol-the-protocol) ":/+"))) + (when (string-match the-protocol fname) + (dolist (prolist sub-protocols) + (let ((proto (concat the-protocol (regexp-quote (plist-get (cdr prolist) :protocol)) ":/+"))) + (when (string-match proto fname) + (let* ((func (plist-get (cdr prolist) :function)) + (greedy (plist-get (cdr prolist) :greedy)) + (splitted (split-string fname proto)) + (result (if greedy restoffiles (cadr splitted)))) + (when (plist-get (cdr prolist) :kill-client) + (message "Greedy org-protocol handler. Killing client.") + (server-edit)) + (when (fboundp func) + (unless greedy + (throw 'fname (funcall func result))) + (funcall func result) + (throw 'fname t)))))))) + ;; (message "fname: %s" fname) + fname))) + + +(defadvice server-visit-files (before org-protocol-detect-protocol-server activate) + "Advice server-visit-flist to call `org-protocol-modify-filename-for-protocol'." + (let ((flist (if org-protocol-reverse-list-of-files + (reverse (ad-get-arg 0)) + (ad-get-arg 0))) + (client (ad-get-arg 1))) + (catch 'greedy + (dolist (var flist) + (let ((fname (expand-file-name (car var)))) ;; `\' to `/' on windows. FIXME: could this be done any better? + (setq fname (org-protocol-check-filename-for-protocol fname (member var flist) client)) + (if (eq fname t) ;; greedy? We need the `t' return value. + (progn + (ad-set-arg 0 nil) + (throw 'greedy t)) + (if (stringp fname) ;; probably filename + (setcar var fname) + (ad-set-arg 0 (delq var (ad-get-arg 0)))))) + )))) + +;;; Org specific functions: + +(defun org-protocol-create-for-org () + "Create a org-protocol project for the current file's Org-mode project. +This works, if the file visited is part of a publishing project in +`org-publish-project-alist'. This function calls `org-protocol-create' to do +most of the work." + (interactive) + (require 'org-publish) + (let ((all (or (org-publish-get-project-from-filename buffer-file-name)))) + (if all (org-protocol-create (cdr all)) + (message "Not in an org-project. Did mean %s?" + (substitute-command-keys"\\[org-protocol-create]"))))) + + +(defun org-protocol-create(&optional project-plist) + "Create a new org-protocol project interactively. +An org-protocol project is an entry in `org-protocol-project-alist' +which is used by `org-protocol-open-source'. +Optionally use project-plist to initialize the defaults for this project. If +project-plist is the CDR of an element in `org-publish-project-alist', reuse +:base-directory, :html-extension and :base-extension." + (interactive) + (let ((working-dir (expand-file-name(or (plist-get project-plist :base-directory) default-directory))) + (base-url "http://orgmode.org/worg/") + (strip-suffix (or (plist-get project-plist :html-extension) ".html")) + (working-suffix (if (plist-get project-plist :base-extension) + (concat "." (plist-get project-plist :base-extension)) + ".org")) + + (worglet-buffer nil) + + (insert-default-directory t) + (minibuffer-allow-text-properties nil)) + + (setq base-url (read-string "Base URL of published content: " base-url nil base-url t)) + (if (not (string-match "\\/$" base-url)) + (setq base-url (concat base-url "/"))) + + (setq working-dir + (expand-file-name + (read-directory-name "Local working directory: " working-dir working-dir t))) + (if (not (string-match "\\/$" working-dir)) + (setq working-dir (concat working-dir "/"))) + + (setq strip-suffix + (read-string + (concat "Extension to strip from published URLs ("strip-suffix"): ") + strip-suffix nil strip-suffix t)) + + (setq working-suffix + (read-string + (concat "Extension of editable files ("working-suffix"): ") + working-suffix nil working-suffix t)) + + (when (yes-or-no-p "Save the new org-protocol-project to your init file? ") + (setq org-protocol-project-alist + (cons `(,base-url . (:base-url ,base-url + :working-directory ,working-dir + :online-suffix ,strip-suffix + :working-suffix ,working-suffix)) + org-protocol-project-alist)) + (customize-save-variable 'org-protocol-project-alist org-protocol-project-alist)))) + +(provide 'org-protocol) + +;; arch-tag: b5c5c2ac-77cf-4a94-a649-2163dff95846 +;;; org-protocol.el ends here diff --git a/.emacs.d/org-7.4/lisp/org-protocol.elc b/.emacs.d/org-7.4/lisp/org-protocol.elc Binary files differnew file mode 100644 index 0000000..53d8fff --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-protocol.elc diff --git a/.emacs.d/org-7.4/lisp/org-publish.el b/.emacs.d/org-7.4/lisp/org-publish.el new file mode 100644 index 0000000..bb20cc6 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-publish.el @@ -0,0 +1,1082 @@ +;;; org-publish.el --- publish related org-mode files as a website +;; Copyright (C) 2006, 2007, 2008, 2009, 2010 +;; Free Software Foundation, Inc. + +;; Author: David O'Toole <dto@gnu.org> +;; Maintainer: Carsten Dominik <carsten DOT dominik AT gmail DOT com> +;; Keywords: hypermedia, outlines, wp +;; Version: 7.4 + +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This program allow configurable publishing of related sets of +;; Org-mode files as a complete website. +;; +;; org-publish.el can do the following: +;; +;; + Publish all one's org-files to HTML or PDF +;; + Upload HTML, images, attachments and other files to a web server +;; + Exclude selected private pages from publishing +;; + Publish a clickable sitemap of pages +;; + Manage local timestamps for publishing only changed files +;; + Accept plugin functions to extend range of publishable content +;; +;; Documentation for publishing is in the manual. + +;;; Code: + + +(defun org-publish-sanitize-plist (plist) + (mapcar (lambda (x) + (or (cdr (assq x '((:index-filename . :sitemap-filename) + (:index-title . :sitemap-title) + (:index-function . :sitemap-function) + (:index-style . :sitemap-style) + (:auto-index . :auto-sitemap)))) + x)) + plist)) + +(eval-when-compile + (require 'cl)) +(require 'org) +(require 'org-exp) + +(eval-and-compile + (unless (fboundp 'declare-function) + (defmacro declare-function (fn file &optional arglist fileonly)))) + +(defgroup org-publish nil + "Options for publishing a set of Org-mode and related files." + :tag "Org Publishing" + :group 'org) + +(defcustom org-publish-project-alist nil + "Association list to control publishing behavior. +Each element of the alist is a publishing 'project.' The CAR of +each element is a string, uniquely identifying the project. The +CDR of each element is in one of the following forms: + +1. A well-formed property list with an even number of elements, alternating + keys and values, specifying parameters for the publishing process. + + (:property value :property value ... ) + +2. A meta-project definition, specifying of a list of sub-projects: + + (:components (\"project-1\" \"project-2\" ...)) + +When the CDR of an element of org-publish-project-alist is in +this second form, the elements of the list after :components are +taken to be components of the project, which group together files +requiring different publishing options. When you publish such a +project with \\[org-publish], the components all publish. + +When a property is given a value in org-publish-project-alist, its +setting overrides the value of the corresponding user variable +\(if any) during publishing. However, options set within a file +override everything. + +Most properties are optional, but some should always be set: + + :base-directory Directory containing publishing source files + :base-extension Extension (without the dot!) of source files. + This can be a regular expression. If not given, + \"org\" will be used as default extension. + :publishing-directory Directory (possibly remote) where output + files will be published + +The :exclude property may be used to prevent certain files from +being published. Its value may be a string or regexp matching +file names you don't want to be published. + +The :include property may be used to include extra files. Its +value may be a list of filenames to include. The filenames are +considered relative to the base directory. + +When both :include and :exclude properties are given values, the +exclusion step happens first. + +One special property controls which back-end function to use for +publishing files in the project. This can be used to extend the +set of file types publishable by org-publish, as well as the set +of output formats. + + :publishing-function Function to publish file. The default is + `org-publish-org-to-html', but other + values are possible. May also be a + list of functions, in which case + each function in the list is invoked + in turn. + +Another property allows you to insert code that prepares a +project for publishing. For example, you could call GNU Make on a +certain makefile, to ensure published files are built up to date. + + :preparation-function Function to be called before publishing + this project. This may also be a list + of functions. + :completion-function Function to be called after publishing + this project. This may also be a list + of functions. + +Some properties control details of the Org publishing process, +and are equivalent to the corresponding user variables listed in +the right column. See the documentation for those variables to +learn more about their use and default values. + + :language `org-export-default-language' + :headline-levels `org-export-headline-levels' + :section-numbers `org-export-with-section-numbers' + :table-of-contents `org-export-with-toc' + :emphasize `org-export-with-emphasize' + :sub-superscript `org-export-with-sub-superscripts' + :TeX-macros `org-export-with-TeX-macros' + :fixed-width `org-export-with-fixed-width' + :tables `org-export-with-tables' + :table-auto-headline `org-export-highlight-first-table-line' + :style `org-export-html-style' + :convert-org-links `org-export-html-link-org-files-as-html' + :inline-images `org-export-html-inline-images' + :expand-quoted-html `org-export-html-expand' + :timestamp `org-export-html-with-timestamp' + :publishing-directory `org-export-publishing-directory' + :preamble `org-export-html-preamble' + :postamble `org-export-html-postamble' + :auto-preamble `org-export-html-auto-preamble' + :auto-postamble `org-export-html-auto-postamble' + :author `user-full-name' + :email `user-mail-address' + +The following properties may be used to control publishing of a +sitemap of files or summary page for a given project. + + :auto-sitemap Whether to publish a sitemap during + `org-publish-current-project' or `org-publish-all'. + :sitemap-filename Filename for output of sitemap. Defaults + to 'sitemap.org' (which becomes 'sitemap.html'). + :sitemap-title Title of sitemap page. Defaults to name of file. + :sitemap-function Plugin function to use for generation of sitemap. + Defaults to `org-publish-org-sitemap', which + generates a plain list of links to all files + in the project. + :sitemap-style Can be `list' (sitemap is just an itemized list + of the titles of the files involved) or + `tree' (the directory structure of the source + files is reflected in the sitemap). Defaults to + `tree'. + + If you create a sitemap file, adjust the sorting like this: + + :sitemap-sort-folders Where folders should appear in the sitemap. + Set this to `first' (default) or `last' to + display folders first or last, respectively. + Any other value will mix files and folders. + :sitemap-alphabetically The site map is normally sorted alphabetically. + Set this explicitly to nil to turn off sorting. + :sitemap-ignore-case Should sorting be case-sensitive? Default nil. + +The following properties control the creation of a concept index. + + :makeindex Create a concept index. + +Other properties affecting publication. + + :body-only Set this to 't' to publish only the body of the + documents, excluding everything outside and + including the <body> tags in HTML, or + \begin{document}..\end{document} in LaTeX." + :group 'org-publish + :type 'alist) + +(defcustom org-publish-use-timestamps-flag t + "Non-nil means use timestamp checking to publish only changed files. +When nil, do no timestamp checking and always publish all files." + :group 'org-publish + :type 'boolean) + +(defcustom org-publish-timestamp-directory (convert-standard-filename + "~/.org-timestamps/") + "Name of directory in which to store publishing timestamps." + :group 'org-publish + :type 'directory) + +(defcustom org-publish-list-skipped-files t + "Non-nil means show message about files *not* published." + :group 'org-publish + :type 'boolean) + +(defcustom org-publish-before-export-hook nil + "Hook run before export on the Org file. +The hook may modify the file in arbitrary ways before publishing happens. +The original version of the buffer will be restored after publishing." + :group 'org-publish + :type 'hook) + +(defcustom org-publish-after-export-hook nil + "Hook run after export on the exported buffer. +Any changes made by this hook will be saved." + :group 'org-publish + :type 'hook) + +(defcustom org-publish-sitemap-sort-alphabetically t + "Should sitemaps be sorted alphabetically by default? + +You can overwrite this default per project in your +`org-publish-project-alist', using `:sitemap-alphabetically'." + :group 'org-publish + :type 'boolean) + +(defcustom org-publish-sitemap-sort-folders 'first + "A symbol, denoting if folders are sorted first in sitemaps. +Possible values are `first', `last', and nil. +If `first', folders will be sorted before files. +If `last', folders are sorted to the end after the files. +Any other value will not mix files and folders. + +You can overwrite this default per project in your +`org-publish-project-alist', using `:sitemap-sort-folders'." + :group 'org-publish + :type 'symbol) + +(defcustom org-publish-sitemap-sort-ignore-case nil + "Sort sitemaps case insensitively by default? + +You can overwrite this default per project in your +`org-publish-project-alist', using `:sitemap-ignore-case'." + :group 'org-publish + :type 'boolean) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Timestamp-related functions + +(defun org-publish-timestamp-filename (filename &optional pub-dir pub-func) + "Return path to timestamp file for filename FILENAME." + (setq filename (concat filename "::" (or pub-dir "") "::" + (format "%s" (or pub-func "")))) + (concat "X" (if (fboundp 'sha1) (sha1 filename) (md5 filename)))) + +(defun org-publish-needed-p (filename &optional pub-dir pub-func true-pub-dir) + "Return t if FILENAME should be published in PUB-DIR using PUB-FUNC. +TRUE-PUB-DIR is where the file will truly end up. Currently we are not using +this - maybe it can eventually be used to check if the file is present at +the target location, and how old it is. Right ow we cannot do this, because +we do not know under what file name the file will be stored - the publishing +function can still decide about that independently." + (let ((rtn + (if org-publish-use-timestamps-flag + (org-publish-cache-file-needs-publishing + filename pub-dir pub-func) + ;; don't use timestamps, always return t + t))) + (if rtn + (message "Publishing file %s using `%s'" filename pub-func) + (when org-publish-list-skipped-files + (message "Skipping unmodified file %s" filename))) + rtn)) + +(defun org-publish-update-timestamp (filename &optional pub-dir pub-func) + "Update publishing timestamp for file FILENAME. +If there is no timestamp, create one." + (let ((key (org-publish-timestamp-filename filename pub-dir pub-func)) + (stamp (org-publish-cache-ctime-of-src filename))) + (org-publish-cache-set key stamp))) + +(defun org-publish-remove-all-timestamps () + "Remove all files in the timestamp directory." + (let ((dir org-publish-timestamp-directory) + files) + (when (and (file-exists-p dir) + (file-directory-p dir)) + (mapc 'delete-file (directory-files dir 'full "[^.]\\'")) + (org-publish-reset-cache)))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; + +(defvar org-publish-initial-buffer nil + "The buffer `org-publish' has been called from.") +(defvar org-publish-temp-files nil + "Temporary list of files to be published.") + +;; Here, so you find the variable right before it's used the first time: +(defvar org-publish-cache nil + "This will cache timestamps and titles for files in publishing projects. +Blocks could hash sha1 values here.") + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Compatibility aliases + +;; Delete-dups is not in Emacs <22 +(if (fboundp 'delete-dups) + (defalias 'org-publish-delete-dups 'delete-dups) + (defun org-publish-delete-dups (list) + "Destructively remove `equal' duplicates from LIST. +Store the result in LIST and return it. LIST must be a proper list. +Of several `equal' occurrences of an element in LIST, the first +one is kept. + +This is a compatibility function for Emacsen without `delete-dups'." + ;; Code from `subr.el' in Emacs 22: + (let ((tail list)) + (while tail + (setcdr tail (delete (car tail) (cdr tail))) + (setq tail (cdr tail)))) + list)) + +(declare-function org-publish-delete-dups "org-publish" (list)) +(declare-function find-lisp-find-files "find-lisp" (directory regexp)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Getting project information out of org-publish-project-alist + +(defun org-publish-expand-projects (projects-alist) + "Expand projects in PROJECTS-ALIST. +This splices all the components into the list." + (let ((rest projects-alist) rtn p components) + (while (setq p (pop rest)) + (if (setq components (plist-get (cdr p) :components)) + (setq rest (append + (mapcar (lambda (x) (assoc x org-publish-project-alist)) + components) + rest)) + (push p rtn))) + (nreverse (org-publish-delete-dups (delq nil rtn))))) + + +(defvar sitemap-alphabetically) +(defvar sitemap-sort-folders) +(defvar sitemap-ignore-case) +(defvar sitemap-requested) +(defun org-publish-compare-directory-files (a b) + "Predicate for `sort', that sorts folders-first/last and alphabetically." + (let ((retval t)) + (when (or sitemap-alphabetically sitemap-sort-folders) + ;; First we sort alphabetically: + (when sitemap-alphabetically + (let* ((adir (file-directory-p a)) + (aorg (and (string-match "\\.org$" a) (not adir))) + (bdir (file-directory-p b)) + (borg (and (string-match "\\.org$" b) (not bdir))) + (A (if aorg + (concat (file-name-directory a) + (org-publish-find-title a)) a)) + (B (if borg + (concat (file-name-directory b) + (org-publish-find-title b)) b))) + (setq retval (if sitemap-ignore-case + (not (string-lessp (upcase B) (upcase A))) + (not (string-lessp B A)))))) + + ;; Directory-wise wins: + (when sitemap-sort-folders + ;; a is directory, b not: + (cond + ((and (file-directory-p a) (not (file-directory-p b))) + (setq retval (equal sitemap-sort-folders 'first))) + ;; a is not a directory, but b is: + ((and (not (file-directory-p a)) (file-directory-p b)) + (setq retval (equal sitemap-sort-folders 'last)))))) + retval)) + +(defun org-publish-get-base-files-1 (base-dir &optional recurse match skip-file skip-dir) + "Set `org-publish-temp-files' with files from BASE-DIR directory. +If RECURSE is non-nil, check BASE-DIR recursively. If MATCH is +non-nil, restrict this list to the files matching the regexp +MATCH. If SKIP-FILE is non-nil, skip file matching the regexp +SKIP-FILE. If SKIP-DIR is non-nil, don't check directories +matching the regexp SKIP-DIR when recursing through BASE-DIR." + (mapc (lambda (f) + (let ((fd-p (file-directory-p f)) + (fnd (file-name-nondirectory f))) + (if (and fd-p recurse + (not (string-match "^\\.+$" fnd)) + (if skip-dir (not (string-match skip-dir fnd)) t)) + (org-publish-get-base-files-1 f recurse match skip-file skip-dir) + (unless (or fd-p ;; this is a directory + (and skip-file (string-match skip-file fnd)) + (not (file-exists-p (file-truename f))) + (not (string-match match fnd))) + + (pushnew f org-publish-temp-files))))) + (if sitemap-requested + (sort (directory-files base-dir t (unless recurse match)) + 'org-publish-compare-directory-files) + (directory-files base-dir t (unless recurse match))))) + +(defun org-publish-get-base-files (project &optional exclude-regexp) + "Return a list of all files in PROJECT. +If EXCLUDE-REGEXP is set, this will be used to filter out +matching filenames." + (let* ((project-plist (cdr project)) + (base-dir (file-name-as-directory + (plist-get project-plist :base-directory))) + (include-list (plist-get project-plist :include)) + (recurse (plist-get project-plist :recursive)) + (extension (or (plist-get project-plist :base-extension) "org")) + ;; sitemap-... variables are dynamically scoped for + ;; org-publish-compare-directory-files: + (sitemap-requested + (plist-get project-plist :auto-sitemap)) + (sitemap-sort-folders + (if (plist-member project-plist :sitemap-sort-folders) + (plist-get project-plist :sitemap-sort-folders) + org-publish-sitemap-sort-folders)) + (sitemap-alphabetically + (if (plist-member project-plist :sitemap-alphabetically) + (plist-get project-plist :sitemap-alphabetically) + org-publish-sitemap-sort-alphabetically)) + (sitemap-ignore-case + (if (plist-member project-plist :sitemap-ignore-case) + (plist-get project-plist :sitemap-ignore-case) + org-publish-sitemap-sort-ignore-case)) + (match (if (eq extension 'any) + "^[^\\.]" + (concat "^[^\\.].*\\.\\(" extension "\\)$")))) + ;; Make sure sitemap-sort-folders' has an accepted value + (unless (memq sitemap-sort-folders '(first last)) + (setq sitemap-sort-folders nil)) + + (setq org-publish-temp-files nil) + (org-publish-get-base-files-1 base-dir recurse match + ;; FIXME distinguish exclude regexp + ;; for skip-file and skip-dir? + exclude-regexp exclude-regexp) + (mapc (lambda (f) + (pushnew + (expand-file-name (concat base-dir f)) + org-publish-temp-files)) + include-list) + org-publish-temp-files)) + +(defun org-publish-get-project-from-filename (filename &optional up) + "Return the project that FILENAME belongs to." + (let* ((filename (expand-file-name filename)) + project-name) + + (catch 'p-found + (dolist (prj org-publish-project-alist) + (unless (plist-get (cdr prj) :components) + ;; [[info:org:Selecting%20files]] shows how this is supposed to work: + (let* ((r (plist-get (cdr prj) :recursive)) + (b (expand-file-name (file-name-as-directory + (plist-get (cdr prj) :base-directory)))) + (x (or (plist-get (cdr prj) :base-extension) "org")) + (e (plist-get (cdr prj) :exclude)) + (i (plist-get (cdr prj) :include)) + (xm (concat "^" b (if r ".+" "[^/]+") "\\.\\(" x "\\)$"))) + (when (or + (and + i + (member filename + (mapcar + (lambda (file) (expand-file-name file b)) + i))) + (and + (not (and e (string-match e filename))) + (string-match xm filename))) + (setq project-name (car prj)) + (throw 'p-found project-name)))))) + (when up + (dolist (prj org-publish-project-alist) + (if (member project-name (plist-get (cdr prj) :components)) + (setq project-name (car prj))))) + (assoc project-name org-publish-project-alist))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Pluggable publishing back-end functions + +(defun org-publish-org-to (format plist filename pub-dir) + "Publish an org file to FORMAT. +PLIST is the property list for the given project. +FILENAME is the filename of the org file to be published. +PUB-DIR is the publishing directory." + (require 'org) + (unless (file-exists-p pub-dir) + (make-directory pub-dir t)) + (let ((visiting (find-buffer-visiting filename))) + (save-excursion + (switch-to-buffer (or visiting (find-file filename))) + (let* ((plist (cons :buffer-will-be-killed (cons t plist))) + (init-buf (current-buffer)) + (init-point (point)) + (init-buf-string (buffer-string)) + export-buf-or-file) + ;; run hooks before exporting + (run-hooks 'org-publish-before-export-hook) + ;; export the possibly modified buffer + (setq export-buf-or-file + (funcall (intern (concat "org-export-as-" format)) + (plist-get plist :headline-levels) + nil plist nil + (plist-get plist :body-only) + pub-dir)) + (when (and (bufferp export-buf-or-file) + (buffer-live-p export-buf-or-file)) + (set-buffer export-buf-or-file) + ;; run hooks after export and save export + (progn (run-hooks 'org-publish-after-export-hook) + (if (buffer-modified-p) (save-buffer))) + (kill-buffer export-buf-or-file)) + ;; maybe restore buffer's content + (set-buffer init-buf) + (when (buffer-modified-p init-buf) + (erase-buffer) + (insert init-buf-string) + (save-buffer) + (goto-char init-point)) + (unless visiting + (kill-buffer init-buf)))))) + +(defmacro org-publish-with-aux-preprocess-maybe (&rest body) + "Execute BODY with a modified hook to preprocess for index." + `(let ((org-export-preprocess-after-headline-targets-hook + (if (plist-get project-plist :makeindex) + (cons 'org-publish-aux-preprocess + org-export-preprocess-after-headline-targets-hook) + org-export-preprocess-after-headline-targets-hook))) + ,@body)) + +(defvar project-plist) +(defun org-publish-org-to-latex (plist filename pub-dir) + "Publish an org file to LaTeX. +See `org-publish-org-to' to the list of arguments." + (org-publish-with-aux-preprocess-maybe + (org-publish-org-to "latex" plist filename pub-dir))) + +(defun org-publish-org-to-pdf (plist filename pub-dir) + "Publish an org file to PDF (via LaTeX). +See `org-publish-org-to' to the list of arguments." + (org-publish-with-aux-preprocess-maybe + (org-publish-org-to "pdf" plist filename pub-dir))) + +(defun org-publish-org-to-html (plist filename pub-dir) + "Publish an org file to HTML. +See `org-publish-org-to' to the list of arguments." + (org-publish-with-aux-preprocess-maybe + (org-publish-org-to "html" plist filename pub-dir))) + +(defun org-publish-org-to-org (plist filename pub-dir) + "Publish an org file to HTML. +See `org-publish-org-to' to the list of arguments." + (org-publish-org-to "org" plist filename pub-dir)) + +(defun org-publish-org-to-ascii (plist filename pub-dir) + "Publish an org file to ASCII. +See `org-publish-org-to' to the list of arguments." + (org-publish-with-aux-preprocess-maybe + (org-publish-org-to "ascii" plist filename pub-dir))) + +(defun org-publish-org-to-latin1 (plist filename pub-dir) + "Publish an org file to Latin-1. +See `org-publish-org-to' to the list of arguments." + (org-publish-with-aux-preprocess-maybe + (org-publish-org-to "latin1" plist filename pub-dir))) + +(defun org-publish-org-to-utf8 (plist filename pub-dir) + "Publish an org file to UTF-8. +See `org-publish-org-to' to the list of arguments." + (org-publish-with-aux-preprocess-maybe + (org-publish-org-to "utf8" plist filename pub-dir))) + +(defun org-publish-attachment (plist filename pub-dir) + "Publish a file with no transformation of any kind. +See `org-publish-org-to' to the list of arguments." + ;; make sure eshell/cp code is loaded + (unless (file-directory-p pub-dir) + (make-directory pub-dir t)) + (or (equal (expand-file-name (file-name-directory filename)) + (file-name-as-directory (expand-file-name pub-dir))) + (copy-file filename + (expand-file-name (file-name-nondirectory filename) pub-dir) + t))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Publishing files, sets of files, and indices + +(defun org-publish-file (filename &optional project no-cache) + "Publish file FILENAME from PROJECT. +If NO-CACHE is not nil, do not initialize org-publish-cache and +write it to disk. This is needed, since this function is used to +publish single files, when entire projects are published. +See `org-publish-projects'." + (let* ((project + (or project + (or (org-publish-get-project-from-filename filename) + (error "File %s not part of any known project" + (abbreviate-file-name filename))))) + (project-plist (cdr project)) + (ftname (expand-file-name filename)) + (publishing-function + (or (plist-get project-plist :publishing-function) + 'org-publish-org-to-html)) + (base-dir + (file-name-as-directory + (expand-file-name + (or (plist-get project-plist :base-directory) + (error "Project %s does not have :base-directory defined" + (car project)))))) + (pub-dir + (file-name-as-directory + (file-truename + (or (plist-get project-plist :publishing-directory) + (error "Project %s does not have :publishing-directory defined" + (car project)))))) + tmp-pub-dir) + + (unless no-cache + (org-publish-initialize-cache (car project))) + + (setq tmp-pub-dir + (file-name-directory + (concat pub-dir + (and (string-match (regexp-quote base-dir) ftname) + (substring ftname (match-end 0)))))) + (if (listp publishing-function) + ;; allow chain of publishing functions + (mapc (lambda (f) + (when (org-publish-needed-p filename pub-dir f tmp-pub-dir) + (funcall f project-plist filename tmp-pub-dir) + (org-publish-update-timestamp filename pub-dir f))) + publishing-function) + (when (org-publish-needed-p filename pub-dir publishing-function + tmp-pub-dir) + (funcall publishing-function project-plist filename tmp-pub-dir) + (org-publish-update-timestamp + filename pub-dir publishing-function))) + (unless no-cache (org-publish-write-cache-file)))) + +(defun org-publish-projects (projects) + "Publish all files belonging to the PROJECTS alist. +If :auto-sitemap is set, publish the sitemap too. +If :makeindex is set, also produce a file theindex.org." + (mapc + (lambda (project) + ;; Each project uses it's own cache file: + (org-publish-initialize-cache (car project)) + (let* + ((project-plist (cdr project)) + (exclude-regexp (plist-get project-plist :exclude)) + (sitemap-p (plist-get project-plist :auto-sitemap)) + (sitemap-filename (or (plist-get project-plist :sitemap-filename) + "sitemap.org")) + (sitemap-function (or (plist-get project-plist :sitemap-function) + 'org-publish-org-sitemap)) + (preparation-function (plist-get project-plist :preparation-function)) + (completion-function (plist-get project-plist :completion-function)) + (files (org-publish-get-base-files project exclude-regexp)) file) + (when preparation-function (run-hooks 'preparation-function)) + (if sitemap-p (funcall sitemap-function project sitemap-filename)) + (while (setq file (pop files)) + (org-publish-file file project t)) + (when (plist-get project-plist :makeindex) + (org-publish-index-generate-theindex.inc + (plist-get project-plist :base-directory)) + (org-publish-file (expand-file-name + "theindex.org" + (plist-get project-plist :base-directory)) + project t)) + (when completion-function (run-hooks 'completion-function)) + (org-publish-write-cache-file))) + (org-publish-expand-projects projects))) + +(defun org-publish-org-sitemap (project &optional sitemap-filename) + "Create a sitemap of pages in set defined by PROJECT. +Optionally set the filename of the sitemap with SITEMAP-FILENAME. +Default for SITEMAP-FILENAME is 'sitemap.org'." + (let* ((project-plist (cdr project)) + (dir (file-name-as-directory + (plist-get project-plist :base-directory))) + (localdir (file-name-directory dir)) + (indent-str (make-string 2 ?\ )) + (exclude-regexp (plist-get project-plist :exclude)) + (files (nreverse (org-publish-get-base-files project exclude-regexp))) + (sitemap-filename (concat dir (or sitemap-filename "sitemap.org"))) + (sitemap-title (or (plist-get project-plist :sitemap-title) + (concat "Sitemap for project " (car project)))) + (sitemap-style (or (plist-get project-plist :sitemap-style) + 'tree)) + (visiting (find-buffer-visiting sitemap-filename)) + (ifn (file-name-nondirectory sitemap-filename)) + file sitemap-buffer) + (with-current-buffer (setq sitemap-buffer + (or visiting (find-file sitemap-filename))) + (erase-buffer) + (insert (concat "#+TITLE: " sitemap-title "\n\n")) + (while (setq file (pop files)) + (let ((fn (file-name-nondirectory file)) + (link (file-relative-name file dir)) + (oldlocal localdir)) + ;; sitemap shouldn't list itself + (unless (equal (file-truename sitemap-filename) + (file-truename file)) + (if (eq sitemap-style 'list) + (message "Generating list-style sitemap for %s" sitemap-title) + (message "Generating tree-style sitemap for %s" sitemap-title) + (setq localdir (concat (file-name-as-directory dir) + (file-name-directory link))) + (unless (string= localdir oldlocal) + (if (string= localdir dir) + (setq indent-str (make-string 2 ?\ )) + (let ((subdirs + (split-string + (directory-file-name + (file-name-directory + (file-relative-name localdir dir))) "/")) + (subdir "") + (old-subdirs (split-string + (file-relative-name oldlocal dir) "/"))) + (setq indent-str (make-string 2 ?\ )) + (while (string= (car old-subdirs) (car subdirs)) + (setq indent-str (concat indent-str (make-string 2 ?\ ))) + (pop old-subdirs) + (pop subdirs)) + (dolist (d subdirs) + (setq subdir (concat subdir d "/")) + (insert (concat indent-str " + " d "\n")) + (setq indent-str (make-string + (+ (length indent-str) 2) ?\ ))))))) + ;; This is common to 'flat and 'tree + (insert (concat indent-str " + [[file:" link "][" + (org-publish-find-title file) + "]]\n"))))) + (save-buffer)) + (or visiting (kill-buffer sitemap-buffer)))) + +(defun org-publish-find-title (file) + "Find the title of FILE in project." + (or + (org-publish-cache-get-file-property file :title nil t) + (let* ((visiting (find-buffer-visiting file)) + (buffer (or visiting (find-file-noselect file))) + title) + (with-current-buffer buffer + (let* ((opt-plist (org-combine-plists (org-default-export-plist) + (org-infile-export-plist)))) + (setq title + (or (plist-get opt-plist :title) + (and (not + (plist-get opt-plist :skip-before-1st-heading)) + (org-export-grab-title-from-buffer)) + (file-name-nondirectory (file-name-sans-extension file)))))) + (unless visiting + (kill-buffer buffer)) + (org-publish-cache-set-file-property file :title title) + title))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Interactive publishing functions + +;;;###autoload +(defalias 'org-publish-project 'org-publish) + +;;;###autoload +(defun org-publish (project &optional force) + "Publish PROJECT." + (interactive + (list + (assoc (org-icompleting-read + "Publish project: " + org-publish-project-alist nil t) + org-publish-project-alist) + current-prefix-arg)) + (setq org-publish-initial-buffer (current-buffer)) + (save-window-excursion + (let* ((org-publish-use-timestamps-flag + (if force nil org-publish-use-timestamps-flag))) + (org-publish-projects + (if (stringp project) + ;; If this function is called in batch mode, + ;; project is still a string here. + (list (assoc project org-publish-project-alist)) + (list project)))))) + +;;;###autoload +(defun org-publish-all (&optional force) + "Publish all projects. +With prefix argument, remove all files in the timestamp +directory and force publishing all files." + (interactive "P") + (when force + (org-publish-remove-all-timestamps)) + (save-window-excursion + (let ((org-publish-use-timestamps-flag + (if force nil org-publish-use-timestamps-flag))) + (org-publish-projects org-publish-project-alist)))) + + +;;;###autoload +(defun org-publish-current-file (&optional force) + "Publish the current file. +With prefix argument, force publish the file." + (interactive "P") + (save-window-excursion + (let ((org-publish-use-timestamps-flag + (if force nil org-publish-use-timestamps-flag))) + (org-publish-file (buffer-file-name))))) + +;;;###autoload +(defun org-publish-current-project (&optional force) + "Publish the project associated with the current file. +With a prefix argument, force publishing of all files in +the project." + (interactive "P") + (save-window-excursion + (let ((project (org-publish-get-project-from-filename (buffer-file-name) 'up)) + (org-publish-use-timestamps-flag + (if force nil org-publish-use-timestamps-flag))) + (if (not project) + (error "File %s is not part of any known project" (buffer-file-name))) + ;; FIXME: force is not used here? + (org-publish project)))) + + +;;; Index generation + +(defvar backend) ; dynamically scoped +(defun org-publish-aux-preprocess () + "Find index entries and write them to an .orgx file." + (let ((case-fold-search t) + entry index target) + (goto-char (point-min)) + (while + (and + (re-search-forward "^[ \t]*#\\+index:[ \t]*\\(.*?\\)[ \t]*$" nil t) + (> (match-end 1) (match-beginning 1))) + (setq entry (match-string 1)) + (when (eq backend 'latex) + (replace-match (format "\\index{%s}" entry) t t)) + (save-excursion + (ignore-errors (org-back-to-heading t)) + (setq target (get-text-property (point) 'target)) + (setq target (or (cdr (assoc target org-export-preferred-target-alist)) + (cdr (assoc target org-export-id-target-alist)) + target "")) + (push (cons entry target) index))) + (with-temp-file + (concat (file-name-sans-extension org-current-export-file) ".orgx") + (dolist (entry (nreverse index)) + (insert (format "INDEX: (%s) %s\n" (cdr entry) (car entry))))))) + +(defun org-publish-index-generate-theindex.inc (directory) + "Generate the index from all .orgx files in the current directory and below." + (require 'find-lisp) + (let* ((fulldir (file-name-as-directory + (expand-file-name directory))) + (full-files (find-lisp-find-files directory "\\.orgx\\'")) + (re (concat "\\`" fulldir)) + (files (mapcar (lambda (f) (if (string-match re f) + (substring f (match-end 0)) + f)) + full-files)) + (default-directory directory) + index origfile buf target entry ibuffer + main last-main letter last-letter file sub link tgext) + ;; `files' contains the list of relative file names + (dolist (file files) + (setq origfile (substring file 0 -1)) + (setq buf (find-file-noselect file)) + (with-current-buffer buf + (goto-char (point-min)) + (while (re-search-forward "^INDEX: (\\(.*?\\)) \\(.*\\)" nil t) + (setq target (match-string 1) + entry (match-string 2)) + (push (list entry origfile target) index))) + (kill-buffer buf)) + (setq index (sort index (lambda (a b) (string< (downcase (car a)) + (downcase (car b)))))) + (setq ibuffer (find-file-noselect (expand-file-name "theindex.inc" directory))) + (with-current-buffer ibuffer + (erase-buffer) + (insert "* Index\n") + (setq last-letter nil) + (dolist (idx index) + (setq entry (car idx) file (nth 1 idx) target (nth 2 idx)) + (if (and (stringp target) (string-match "\\S-" target)) + (setq tgext (concat "::#" target)) + (setq tgext "")) + (setq letter (upcase (substring entry 0 1))) + (when (not (equal letter last-letter)) + (insert "** " letter "\n") + (setq last-letter letter)) + (if (string-match "!" entry) + (setq main (substring entry 0 (match-beginning 0)) + sub (substring entry (match-end 0))) + (setq main nil sub nil last-main nil)) + (when (and main (not (equal main last-main))) + (insert " - " main "\n") + (setq last-main main)) + (setq link (concat "[[file:" file tgext "]" + "[" (or sub entry) "]]")) + (if (and main sub) + (insert " - " link "\n") + (insert " - " link "\n"))) + (save-buffer)) + (kill-buffer ibuffer) + + (let ((index-file (expand-file-name "theindex.org" directory))) + (unless (file-exists-p index-file) + (setq ibuffer (find-file-noselect index-file)) + (with-current-buffer ibuffer + (erase-buffer) + (insert "\n\n#+include: \"theindex.inc\"\n\n") + (save-buffer)) + (kill-buffer ibuffer))))) + + +;; Caching functions: + +(defun org-publish-write-cache-file (&optional free-cache) + "Write `org-publish-cache' to file. +If FREE-CACHE, empty the cache." + (unless org-publish-cache + (error "%s" "`org-publish-write-cache-file' called, but no cache present")) + + (let ((cache-file (org-publish-cache-get ":cache-file:"))) + (unless cache-file + (error + "%s" "Cannot find cache-file name in `org-publish-write-cache-file'")) + (with-temp-file cache-file + (let ((print-level nil) + (print-length nil)) + (insert "(setq org-publish-cache (make-hash-table :test 'equal :weakness nil :size 100))\n") + (maphash (lambda (k v) + (insert + (format (concat "(puthash %S " + (if (or (listp v) (symbolp v)) + "'" "") + "%S org-publish-cache)\n") k v))) + org-publish-cache))) + (when free-cache (org-publish-reset-cache)))) + +(defun org-publish-initialize-cache (project-name) + "Initialize the projects cache if not initialized yet and return it." + + (unless project-name + (error "%s%s" "Cannot initialize `org-publish-cache' without projects name" + " in `org-publish-initialize-cache'")) + + (unless (file-exists-p org-publish-timestamp-directory) + (make-directory org-publish-timestamp-directory t)) + (if (not (file-directory-p org-publish-timestamp-directory)) + (error "Org publish timestamp: %s is not a directory" + org-publish-timestamp-directory)) + + (unless (and org-publish-cache + (string= (org-publish-cache-get ":project:") project-name)) + (let* ((cache-file (concat + (expand-file-name org-publish-timestamp-directory) + project-name + ".cache")) + (cexists (file-exists-p cache-file))) + + (when org-publish-cache + (org-publish-reset-cache)) + + (if cexists + (load-file cache-file) + (setq org-publish-cache + (make-hash-table :test 'equal :weakness nil :size 100)) + (org-publish-cache-set ":project:" project-name) + (org-publish-cache-set ":cache-file:" cache-file)) + (unless cexists (org-publish-write-cache-file nil)))) + org-publish-cache) + +(defun org-publish-reset-cache () + "Empty org-publish-cache and reset it nil." + (message "%s" "Resetting org-publish-cache") + (if (hash-table-p org-publish-cache) + (clrhash org-publish-cache)) + (setq org-publish-cache nil)) + +(defun org-publish-cache-file-needs-publishing (filename &optional pub-dir pub-func) + "Check the timestamp of the last publishing of FILENAME. +Return `t', if the file needs publishing" + (unless org-publish-cache + (error "%s" "`org-publish-cache-file-needs-publishing' called, but no cache present")) + (let* ((key (org-publish-timestamp-filename filename pub-dir pub-func)) + (pstamp (org-publish-cache-get key))) + (if (null pstamp) + t + (let ((ctime (org-publish-cache-ctime-of-src filename))) + (< pstamp ctime))))) + +(defun org-publish-cache-set-file-property (filename property value &optional project-name) + "Set the VALUE for a PROPERTY of file FILENAME in publishing cache to VALUE. +Use cache file of PROJECT-NAME. If the entry does not exist, it will be +created. Return VALUE." + ;; Evtl. load the requested cache file: + (if project-name (org-publish-initialize-cache project-name)) + (let ((pl (org-publish-cache-get filename))) + (if pl + (progn + (plist-put pl property value) + value) + (org-publish-cache-get-file-property + filename property value nil project-name)))) + +(defun org-publish-cache-get-file-property + (filename property &optional default no-create project-name) + "Return the value for a PROPERTY of file FILENAME in publishing cache. +Use cache file of PROJECT-NAME. Return the value of that PROPERTY or +DEFAULT, if the value does not yet exist. +If the entry will be created, unless NO-CREATE is not nil." + ;; Evtl. load the requested cache file: + (if project-name (org-publish-initialize-cache project-name)) + (let ((pl (org-publish-cache-get filename)) + (retval nil)) + (if pl + (if (plist-member pl property) + (setq retval (plist-get pl property)) + (setq retval default)) + ;; no pl yet: + (unless no-create + (org-publish-cache-set filename (list property default))) + (setq retval default)) + retval)) + +(defun org-publish-cache-get (key) + "Return the value stored in `org-publish-cache' for key KEY. +Returns nil, if no value or nil is found, or the cache does not +exist." + (unless org-publish-cache + (error "%s" "`org-publish-cache-get' called, but no cache present")) + (gethash key org-publish-cache)) + +(defun org-publish-cache-set (key value) + "Store KEY VALUE pair in `org-publish-cache'. +Returns value on success, else nil." + (unless org-publish-cache + (error "%s" "`org-publish-cache-set' called, but no cache present")) + (puthash key value org-publish-cache)) + +(defun org-publish-cache-ctime-of-src (filename) + "Get the files ctime as integer." + (let ((src-attr (file-attributes filename))) + (+ + (lsh (car (nth 5 src-attr)) 16) + (cadr (nth 5 src-attr))))) + + + +(provide 'org-publish) + +;; arch-tag: 72807f3c-8af0-4a6b-8dca-c3376eb25adb + +;;; org-publish.el ends here diff --git a/.emacs.d/org-7.4/lisp/org-publish.elc b/.emacs.d/org-7.4/lisp/org-publish.elc Binary files differnew file mode 100644 index 0000000..5d7dd48 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-publish.elc diff --git a/.emacs.d/org-7.4/lisp/org-remember.el b/.emacs.d/org-7.4/lisp/org-remember.el new file mode 100644 index 0000000..c6e21ae --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-remember.el @@ -0,0 +1,1155 @@ +;;; org-remember.el --- Fast note taking in Org-mode + +;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010 +;; Free Software Foundation, Inc. + +;; Author: Carsten Dominik <carsten at orgmode dot org> +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; Version: 7.4 +;; +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: + +;; This file contains the system to take fast notes with Org-mode. +;; This system is used together with John Wiegley's `remember.el'. + +;;; Code: + +(eval-when-compile + (require 'cl)) +(require 'org) +(require 'org-datetree) + +(declare-function remember-mode "remember" ()) +(declare-function remember "remember" (&optional initial)) +(declare-function remember-buffer-desc "remember" ()) +(declare-function remember-finalize "remember" ()) +(defvar remember-save-after-remembering) +(defvar remember-register) +(defvar remember-buffer) +(defvar remember-handler-functions) +(defvar remember-annotation-functions) +(defvar org-clock-heading) +(defvar org-clock-heading-for-remember) + +(defgroup org-remember nil + "Options concerning interaction with remember.el." + :tag "Org Remember" + :group 'org) + +(defcustom org-remember-store-without-prompt t + "Non-nil means \\<org-remember-mode-map>\\[org-remember-finalize] \ +stores the remember note without further prompts. +It then uses the file and headline specified by the template or (if the +template does not specify them) by the variables `org-default-notes-file' +and `org-remember-default-headline'. To force prompting anyway, use +\\[universal-argument] \\[org-remember-finalize] to file the note. + +When this variable is nil, \\[org-remember-finalize] gives you the prompts, and +\\[universal-argument] \\[org-remember-finalize] triggers the fasttrack." + :group 'org-remember + :type 'boolean) + +(defcustom org-remember-interactive-interface 'refile + "The interface to be used for interactive filing of remember notes. +This is only used when the interactive mode for selecting a filing +location is used (see the variable `org-remember-store-without-prompt'). +Allowed values are: +outline The interface shows an outline of the relevant file + and the correct heading is found by moving through + the outline or by searching with incremental search. +outline-path-completion Headlines in the current buffer are offered via + completion. +refile Use the refile interface, and offer headlines, + possibly from different buffers." + :group 'org-remember + :type '(choice + (const :tag "Refile" refile) + (const :tag "Outline" outline) + (const :tag "Outline-path-completion" outline-path-completion))) + +(defcustom org-remember-default-headline "" + "The headline that should be the default location in the notes file. +When filing remember notes, the cursor will start at that position. +You can set this on a per-template basis with the variable +`org-remember-templates'." + :group 'org-remember + :type 'string) + +(defcustom org-remember-templates nil + "Templates for the creation of remember buffers. +When nil, just let remember make the buffer. +When non-nil, this is a list of (up to) 6-element lists. In each entry, +the first element is the name of the template, which should be a single +short word. The second element is a character, a unique key to select +this template. The third element is the template. + +The fourth element is optional and can specify a destination file for +remember items created with this template. The default file is given +by `org-default-notes-file'. If the file name is not an absolute path, +it will be interpreted relative to `org-directory'. + +An optional fifth element can specify the headline in that file that should +be offered first when the user is asked to file the entry. The default +headline is given in the variable `org-remember-default-headline'. When +this element is `top' or `bottom', the note will be placed as a level-1 +entry at the beginning or end of the file, respectively. + +An optional sixth element specifies the contexts in which the template +will be offered to the user. This element can be a list of major modes +or a function, and the template will only be offered if `org-remember' +is called from a mode in the list, or if the function returns t. +Templates that specify t or nil for the context will always be added +to the list of selectable templates. + +The template specifies the structure of the remember buffer. It should have +a first line starting with a star, to act as the org-mode headline. +Furthermore, the following %-escapes will be replaced with content: + + %^{PROMPT} prompt the user for a string and replace this sequence with it. + A default value and a completion table can be specified like this: + %^{prompt|default|completion2|completion3|...} + The arrow keys access a prompt-specific history. + %a annotation, normally the link created with `org-store-link' + %A like %a, but prompt for the description part + %i initial content, copied from the active region. If %i is + indented, the entire inserted text will be indented as well. + %t time stamp, date only + %T time stamp with date and time + %u, %U like the above, but inactive time stamps + %^t like %t, but prompt for date. Similarly %^T, %^u, %^U. + You may define a prompt like %^{Please specify birthday}t + %n user name (taken from `user-full-name') + %c current kill ring head + %x content of the X clipboard + %:keyword specific information for certain link types, see below + %^C interactive selection of which kill or clip to use + %^L like %^C, but insert as link + %k title of the currently clocked task + %K link to the currently clocked task + %^g prompt for tags, completing tags in the target file + %^G prompt for tags, completing all tags in all agenda files + %^{PROP}p Prompt the user for a value for property PROP + %[PATHNAME] insert the contents of the file given by PATHNAME + %(SEXP) evaluate elisp `(SEXP)' and replace with the result + %! store this note immediately after completing the template\ + \\<org-remember-mode-map> + (skipping the \\[org-remember-finalize] that normally triggers storing) + %& jump to target location immediately after storing note + %? after completing the template, position cursor here. + +Apart from these general escapes, you can access information specific to the +link type that is created. For example, calling `remember' in emails or gnus +will record the author and the subject of the message, which you can access +with %:fromname and %:subject, respectively. Here is a complete list of what +is recorded for each link type. + +Link type | Available information +-------------------+------------------------------------------------------ +bbdb | %:type %:name %:company +vm, wl, mh, rmail | %:type %:subject %:message-id + | %:from %:fromname %:fromaddress + | %:to %:toname %:toaddress + | %:fromto (either \"to NAME\" or \"from NAME\") +gnus | %:group, for messages also all email fields and + | %:org-date (the Date: header in Org format) +w3, w3m | %:type %:url +info | %:type %:file %:node +calendar | %:type %:date" + :group 'org-remember + :get (lambda (var) ; Make sure all entries have at least 5 elements + (mapcar (lambda (x) + (if (not (stringp (car x))) (setq x (cons "" x))) + (cond ((= (length x) 4) (append x '(nil))) + ((= (length x) 3) (append x '(nil nil))) + (t x))) + (default-value var))) + :type '(repeat + :tag "enabled" + (list :value ("" ?a "\n" nil nil nil) + (string :tag "Name") + (character :tag "Selection Key") + (string :tag "Template") + (choice :tag "Destination file" + (file :tag "Specify") + (function :tag "Function") + (const :tag "Use `org-default-notes-file'" nil)) + (choice :tag "Destin. headline" + (string :tag "Specify") + (function :tag "Function") + (const :tag "Use `org-remember-default-headline'" nil) + (const :tag "At beginning of file" top) + (const :tag "At end of file" bottom) + (const :tag "In a date tree" date-tree)) + (choice :tag "Context" + (const :tag "Use in all contexts" nil) + (const :tag "Use in all contexts" t) + (repeat :tag "Use only if in major mode" + (symbol :tag "Major mode")) + (function :tag "Perform a check against function"))))) + +(defcustom org-remember-delete-empty-lines-at-end t + "Non-nil means clean up final empty lines in remember buffer." + :group 'org-remember + :type 'boolean) + +(defcustom org-remember-before-finalize-hook nil + "Hook that is run right before a remember process is finalized. +The remember buffer is still current when this hook runs." + :group 'org-remember + :type 'hook) + +(defvar org-remember-mode-map (make-sparse-keymap) + "Keymap for `org-remember-mode', a minor mode. +Use this map to set additional keybindings for when Org-mode is used +for a Remember buffer.") +(defvar org-remember-mode-hook nil + "Hook for the minor `org-remember-mode'.") + +(define-minor-mode org-remember-mode + "Minor mode for special key bindings in a remember buffer." + nil " Rem" org-remember-mode-map + (run-hooks 'org-remember-mode-hook)) +(define-key org-remember-mode-map "\C-c\C-c" 'org-remember-finalize) +(define-key org-remember-mode-map "\C-c\C-k" 'org-remember-kill) + +(defcustom org-remember-clock-out-on-exit 'query + "Non-nil means stop the clock when exiting a clocking remember buffer. +This only applies if the clock is running in the remember buffer. If the +clock is not stopped, it continues to run in the storage location. +Instead of nil or t, this may also be the symbol `query' to prompt the +user each time a remember buffer with a running clock is filed away." + :group 'org-remember + :type '(choice + (const :tag "Never" nil) + (const :tag "Always" t) + (const :tag "Query user" query))) + +(defcustom org-remember-backup-directory nil + "Directory where to store all remember buffers, for backup purposes. +After a remember buffer has been stored successfully, the backup file +will be removed. However, if you forget to finish the remember process, +the file will remain there. +See also `org-remember-auto-remove-backup-files'." + :group 'org-remember + :type '(choice + (const :tag "No backups" nil) + (directory :tag "Directory"))) + +(defcustom org-remember-auto-remove-backup-files t + "Non-nil means remove remember backup files after successfully storage. +When remember is finished successfully, with storing the note at the +desired target, remove the backup files related to this remember process +and show a message about remaining backup files, from previous, unfinished +remember sessions. +Backup files will only be made at all, when `org-remember-backup-directory' +is set." + :group 'org-remember + :type 'boolean) + +(defcustom org-remember-warn-about-backups t + "Non-nil means warn about backup files in `org-remember-backup-directory'. + +Set this to nil if you find that you don't need the warning. + +If you cancel remember calls frequently and know when they +contain useful information (because you know that you made an +error or Emacs crashed, for example) nil is more useful. In the +opposite case, the default, t, is more useful." + :group 'org-remember + :type 'boolean) + +(defvar annotation) ; from remember.el, dynamically scoped in `remember-mode' +(defvar initial) ; from remember.el, dynamically scoped in `remember-mode' + +;;;###autoload +(defun org-remember-insinuate () + "Setup remember.el for use with Org-mode." + (org-require-remember) + (setq remember-annotation-functions '(org-remember-annotation)) + (setq remember-handler-functions '(org-remember-handler)) + (add-hook 'remember-mode-hook 'org-remember-apply-template)) + +;;;###autoload +(defun org-remember-annotation () + "Return a link to the current location as an annotation for remember.el. +If you are using Org-mode files as target for data storage with +remember.el, then the annotations should include a link compatible with the +conventions in Org-mode. This function returns such a link." + (org-store-link nil)) + +(defconst org-remember-help +"Select a destination location for the note. +UP/DOWN=headline TAB=cycle visibility [Q]uit RET/<left>/<right>=Store +RET on headline -> Store as sublevel entry to current headline +RET at beg-of-buf -> Append to file as level 2 headline +<left>/<right> -> before/after current headline, same headings level") + +(defvar org-jump-to-target-location nil) +(defvar org-remember-previous-location nil) +(defvar org-remember-reference-date nil) +(defvar org-force-remember-template-char) ;; dynamically scoped + +;; Save the major mode of the buffer we called remember from +(defvar org-select-template-temp-major-mode nil) + +;; Temporary store the buffer where remember was called from +(defvar org-select-template-original-buffer nil) + +(defun org-select-remember-template (&optional use-char) + (when org-remember-templates + (let* ((pre-selected-templates + (mapcar + (lambda (tpl) + (let ((ctxt (nth 5 tpl)) + (mode org-select-template-temp-major-mode) + (buf org-select-template-original-buffer)) + (and (or (not ctxt) (eq ctxt t) + (and (listp ctxt) (memq mode ctxt)) + (and (functionp ctxt) + (with-current-buffer buf + ;; Protect the user-defined function from error + (condition-case nil (funcall ctxt) (error nil))))) + tpl))) + org-remember-templates)) + ;; If no template at this point, add the default templates: + (pre-selected-templates1 + (if (not (delq nil pre-selected-templates)) + (mapcar (lambda(x) (if (not (nth 5 x)) x)) + org-remember-templates) + pre-selected-templates)) + ;; Then unconditionally add template for any contexts + (pre-selected-templates2 + (append (mapcar (lambda(x) (if (eq (nth 5 x) t) x)) + org-remember-templates) + (delq nil pre-selected-templates1))) + (templates (mapcar (lambda (x) + (if (stringp (car x)) + (append (list (nth 1 x) (car x)) (cddr x)) + (append (list (car x) "") (cdr x)))) + (delq nil pre-selected-templates2))) + msg + (char (or use-char + (cond + ((= (length templates) 1) + (caar templates)) + ((and (boundp 'org-force-remember-template-char) + org-force-remember-template-char) + (if (stringp org-force-remember-template-char) + (string-to-char org-force-remember-template-char) + org-force-remember-template-char)) + (t + (setq msg (format + "Select template: %s%s" + (mapconcat + (lambda (x) + (cond + ((not (string-match "\\S-" (nth 1 x))) + (format "[%c]" (car x))) + ((equal (downcase (car x)) + (downcase (aref (nth 1 x) 0))) + (format "[%c]%s" (car x) + (substring (nth 1 x) 1))) + (t (format "[%c]%s" (car x) (nth 1 x))))) + templates " ") + (if (assoc ?C templates) + "" + " [C]customize templates"))) + (let ((inhibit-quit t) char0) + (while (not char0) + (message msg) + (setq char0 (read-char-exclusive)) + (when (and (not (assoc char0 templates)) + (not (equal char0 ?\C-g)) + (not (equal char0 ?C))) + (message "No such template \"%c\"" char0) + (ding) (sit-for 1) + (setq char0 nil))) + (when (equal char0 ?\C-g) + (jump-to-register remember-register) + (kill-buffer remember-buffer) + (error "Abort")) + (when (not (assoc char0 templates)) + (jump-to-register remember-register) + (kill-buffer remember-buffer) + (customize-variable 'org-remember-templates) + (error "Customize templates")) + char0)))))) + (cddr (assoc char templates))))) + +;;;###autoload +(defun org-remember-apply-template (&optional use-char skip-interactive) + "Initialize *remember* buffer with template, invoke `org-mode'. +This function should be placed into `remember-mode-hook' and in fact requires +to be run from that hook to function properly." + (when (and (boundp 'initial) (stringp initial)) + (setq initial (org-no-properties initial)) + (remove-text-properties 0 (length initial) '(read-only t) initial)) + (if org-remember-templates + (let* ((entry (org-select-remember-template use-char)) + (ct (or org-overriding-default-time (org-current-time))) + (dct (decode-time ct)) + (ct1 + (if (< (nth 2 dct) org-extend-today-until) + (encode-time 0 59 23 (1- (nth 3 dct)) (nth 4 dct) (nth 5 dct)) + ct)) + (tpl (car entry)) + (plist-p (if org-store-link-plist t nil)) + (file (if (and (nth 1 entry) + (or (and (stringp (nth 1 entry)) + (string-match "\\S-" (nth 1 entry))) + (functionp (nth 1 entry)))) + (nth 1 entry) + org-default-notes-file)) + (headline (nth 2 entry)) + (v-c (and (> (length kill-ring) 0) (current-kill 0))) + (v-x (or (org-get-x-clipboard 'PRIMARY) + (org-get-x-clipboard 'CLIPBOARD) + (org-get-x-clipboard 'SECONDARY))) + (v-t (format-time-string (car org-time-stamp-formats) ct)) + (v-T (format-time-string (cdr org-time-stamp-formats) ct)) + (v-u (concat "[" (substring v-t 1 -1) "]")) + (v-U (concat "[" (substring v-T 1 -1) "]")) + ;; `initial' and `annotation' are bound in `remember'. + ;; But if the property list has them, we prefer those values + (v-i (or (plist-get org-store-link-plist :initial) + (and (boundp 'initial) initial) + "")) + (v-a (or (plist-get org-store-link-plist :annotation) + (and (boundp 'annotation) annotation) + "")) + ;; Is the link empty? Then we do not want it... + (v-a (if (equal v-a "[[]]") "" v-a)) + (clipboards (remove nil (list v-i + (org-get-x-clipboard 'PRIMARY) + (org-get-x-clipboard 'CLIPBOARD) + (org-get-x-clipboard 'SECONDARY) + v-c))) + (v-A (if (and v-a + (string-match "\\[\\(\\[.*?\\]\\)\\(\\[.*?\\]\\)?\\]" v-a)) + (replace-match "[\\1[%^{Link description}]]" nil nil v-a) + v-a)) + (v-n user-full-name) + (v-k (if (marker-buffer org-clock-marker) + (org-substring-no-properties org-clock-heading))) + (v-K (if (marker-buffer org-clock-marker) + (org-make-link-string + (buffer-file-name (marker-buffer org-clock-marker)) + org-clock-heading))) + v-I + (org-startup-folded nil) + (org-inhibit-startup t) + org-time-was-given org-end-time-was-given x + prompt completions char time pos default histvar) + + (when (functionp file) + (setq file (funcall file))) + (when (functionp headline) + (setq headline (funcall headline))) + (when (and file (not (file-name-absolute-p file))) + (setq file (expand-file-name file org-directory))) + + (setq org-store-link-plist + (plist-put org-store-link-plist :annotation v-a) + org-store-link-plist + (plist-put org-store-link-plist :initial v-i)) + + (unless tpl (setq tpl "") (message "No template") (ding) (sit-for 1)) + (erase-buffer) + (insert (substitute-command-keys + (format +"## %s \"%s\" -> \"* %s\" +## C-u C-c C-c like C-c C-c, and immediately visit note at target location +## C-0 C-c C-c \"%s\" -> \"* %s\" +## %s to select file and header location interactively. +## C-2 C-c C-c as child (C-3: as sibling) of the currently clocked item +## To switch templates, use `\\[org-remember]'. To abort use `C-c C-k'.\n\n" + (if org-remember-store-without-prompt " C-c C-c" " C-1 C-c C-c") + (abbreviate-file-name (or file org-default-notes-file)) + (or headline "") + (or (car org-remember-previous-location) "???") + (or (cdr org-remember-previous-location) "???") + (if org-remember-store-without-prompt "C-1 C-c C-c" " C-c C-c")))) + (insert tpl) + + ;; %[] Insert contents of a file. + (goto-char (point-min)) + (while (re-search-forward "%\\[\\(.+\\)\\]" nil t) + (unless (org-remember-escaped-%) + (let ((start (match-beginning 0)) + (end (match-end 0)) + (filename (expand-file-name (match-string 1)))) + (goto-char start) + (delete-region start end) + (condition-case error + (insert-file-contents filename) + (error (insert (format "%%![Couldn't insert %s: %s]" + filename error))))))) + ;; Simple %-escapes + (goto-char (point-min)) + (while (re-search-forward "%\\([tTuUaiAcxkKI]\\)" nil t) + (unless (org-remember-escaped-%) + (when (and initial (equal (match-string 0) "%i")) + (save-match-data + (let* ((lead (buffer-substring + (point-at-bol) (match-beginning 0)))) + (setq v-i (mapconcat 'identity + (org-split-string initial "\n") + (concat "\n" lead)))))) + (replace-match + (or (eval (intern (concat "v-" (match-string 1)))) "") + t t))) + + ;; %() embedded elisp + (goto-char (point-min)) + (while (re-search-forward "%\\((.+)\\)" nil t) + (unless (org-remember-escaped-%) + (goto-char (match-beginning 0)) + (let ((template-start (point))) + (forward-char 1) + (let ((result + (condition-case error + (eval (read (current-buffer))) + (error (format "%%![Error: %s]" error))))) + (delete-region template-start (point)) + (insert result))))) + + ;; From the property list + (when plist-p + (goto-char (point-min)) + (while (re-search-forward "%\\(:[-a-zA-Z]+\\)" nil t) + (unless (org-remember-escaped-%) + (and (setq x (or (plist-get org-store-link-plist + (intern (match-string 1))) "")) + (replace-match x t t))))) + + ;; Turn on org-mode in the remember buffer, set local variables + (let ((org-inhibit-startup t)) (org-mode) (org-remember-mode 1)) + (if (and file (string-match "\\S-" file) (not (file-directory-p file))) + (org-set-local 'org-default-notes-file file)) + (if headline + (org-set-local 'org-remember-default-headline headline)) + (org-set-local 'org-remember-reference-date + (list (nth 4 dct) (nth 3 dct) (nth 5 dct))) + ;; Interactive template entries + (goto-char (point-min)) + (while (re-search-forward "%^\\({\\([^}]*\\)}\\)?\\([gGtTuUCLp]\\)?" nil t) + (unless (org-remember-escaped-%) + (setq char (if (match-end 3) (match-string 3)) + prompt (if (match-end 2) (match-string 2))) + (goto-char (match-beginning 0)) + (replace-match "") + (setq completions nil default nil) + (when prompt + (setq completions (org-split-string prompt "|") + prompt (pop completions) + default (car completions) + histvar (intern (concat + "org-remember-template-prompt-history::" + (or prompt ""))) + completions (mapcar 'list completions))) + (cond + ((member char '("G" "g")) + (let* ((org-last-tags-completion-table + (org-global-tags-completion-table + (if (equal char "G") (org-agenda-files) (and file (list file))))) + (org-add-colon-after-tag-completion t) + (ins (org-icompleting-read + (if prompt (concat prompt ": ") "Tags: ") + 'org-tags-completion-function nil nil nil + 'org-tags-history))) + (setq ins (mapconcat 'identity + (org-split-string ins (org-re "[^[:alnum:]_@#%]+")) + ":")) + (when (string-match "\\S-" ins) + (or (equal (char-before) ?:) (insert ":")) + (insert ins) + (or (equal (char-after) ?:) (insert ":"))))) + ((equal char "C") + (cond ((= (length clipboards) 1) (insert (car clipboards))) + ((> (length clipboards) 1) + (insert (read-string "Clipboard/kill value: " + (car clipboards) '(clipboards . 1) + (car clipboards)))))) + ((equal char "L") + (cond ((= (length clipboards) 1) + (org-insert-link 0 (car clipboards))) + ((> (length clipboards) 1) + (org-insert-link 0 (read-string "Clipboard/kill value: " + (car clipboards) + '(clipboards . 1) + (car clipboards)))))) + ((equal char "p") + (let* + ((prop (org-substring-no-properties prompt)) + (pall (concat prop "_ALL")) + (allowed + (with-current-buffer + (or (find-buffer-visiting file) + (find-file-noselect file)) + (or (cdr (assoc pall org-file-properties)) + (cdr (assoc pall org-global-properties)) + (cdr (assoc pall org-global-properties-fixed))))) + (existing (with-current-buffer + (or (find-buffer-visiting file) + (find-file-noselect file)) + (mapcar 'list (org-property-values prop)))) + (propprompt (concat "Value for " prop ": ")) + (val (if allowed + (org-completing-read + propprompt + (mapcar 'list (org-split-string allowed "[ \t]+")) + nil 'req-match) + (org-completing-read-no-i propprompt existing nil nil + "" nil "")))) + (org-set-property prop val))) + (char + ;; These are the date/time related ones + (setq org-time-was-given (equal (upcase char) char)) + (setq time (org-read-date (equal (upcase char) "U") t nil + prompt)) + (org-insert-time-stamp time org-time-was-given + (member char '("u" "U")) + nil nil (list org-end-time-was-given))) + (t + (let (org-completion-use-ido) + (insert (org-without-partial-completion + (org-completing-read-no-i + (concat (if prompt prompt "Enter string") + (if default (concat " [" default "]")) + ": ") + completions nil nil nil histvar default)))))))) + + (goto-char (point-min)) + (if (re-search-forward "%\\?" nil t) + (replace-match "") + (and (re-search-forward "^[^#\n]" nil t) (backward-char 1)))) + (let ((org-inhibit-startup t)) (org-mode) (org-remember-mode 1))) + (when (save-excursion + (goto-char (point-min)) + (re-search-forward "%&" nil t)) + (replace-match "") + (org-set-local 'org-jump-to-target-location t)) + (when org-remember-backup-directory + (unless (file-directory-p org-remember-backup-directory) + (make-directory org-remember-backup-directory)) + (org-set-local 'auto-save-file-name-transforms nil) + (setq buffer-file-name + (expand-file-name + (format-time-string "remember-%Y-%m-%d-%H-%M-%S") + org-remember-backup-directory)) + (save-buffer) + (org-set-local 'auto-save-visited-file-name t) + (auto-save-mode 1)) + (when (save-excursion + (goto-char (point-min)) + (re-search-forward "%!" nil t)) + (replace-match "") + (add-hook 'post-command-hook 'org-remember-finish-immediately 'append))) + +(defun org-remember-escaped-% () + (if (equal (char-before (match-beginning 0)) ?\\) + (progn + (delete-region (1- (match-beginning 0)) (match-beginning 0)) + t) + nil)) + + +(defun org-remember-finish-immediately () + "File remember note immediately. +This should be run in `post-command-hook' and will remove itself +from that hook." + (remove-hook 'post-command-hook 'org-remember-finish-immediately) + (org-remember-finalize)) + +(defun org-remember-visit-immediately () + "File remember note immediately. +This should be run in `post-command-hook' and will remove itself +from that hook." + (org-remember '(16)) + (goto-char (or (text-property-any + (point) (save-excursion (org-end-of-subtree t t)) + 'org-position-cursor t) + (point))) + (message "%s" + (format + (substitute-command-keys + "Restore window configuration with \\[jump-to-register] %c") + remember-register))) + +(defvar org-clock-marker) ; Defined in org.el +(defun org-remember-finalize () + "Finalize the remember process." + (interactive) + (unless org-remember-mode + (error "This does not seem to be a remember buffer for Org-mode")) + (run-hooks 'org-remember-before-finalize-hook) + (unless (fboundp 'remember-finalize) + (defalias 'remember-finalize 'remember-buffer)) + (when (and org-clock-marker + (equal (marker-buffer org-clock-marker) (current-buffer))) + ;; the clock is running in this buffer. + (when (and (equal (marker-buffer org-clock-marker) (current-buffer)) + (or (eq org-remember-clock-out-on-exit t) + (and org-remember-clock-out-on-exit + (y-or-n-p "The clock is running in this buffer. Clock out now? ")))) + (let (org-log-note-clock-out) (org-clock-out)))) + (when buffer-file-name + (do-auto-save)) + (remember-finalize)) + +(defun org-remember-kill () + "Abort the current remember process." + (interactive) + (let ((org-note-abort t)) + (org-remember-finalize))) + +;;;###autoload +(defun org-remember (&optional goto org-force-remember-template-char) + "Call `remember'. If this is already a remember buffer, re-apply template. +If there is an active region, make sure remember uses it as initial content +of the remember buffer. + +When called interactively with a \\[universal-argument] \ +prefix argument GOTO, don't remember +anything, just go to the file/headline where the selected template usually +stores its notes. With a double prefix argument \ +\\[universal-argument] \\[universal-argument], go to the last +note stored by remember. + +Lisp programs can set ORG-FORCE-REMEMBER-TEMPLATE-CHAR to a character +associated with a template in `org-remember-templates'." + (interactive "P") + (org-require-remember) + (cond + ((equal goto '(4)) (org-go-to-remember-target)) + ((equal goto '(16)) (org-remember-goto-last-stored)) + (t + ;; set temporary variables that will be needed in + ;; `org-select-remember-template' + (setq org-select-template-temp-major-mode major-mode) + (setq org-select-template-original-buffer (current-buffer)) + (if org-remember-mode + (progn + (when (< (length org-remember-templates) 2) + (error "No other template available")) + (erase-buffer) + (let ((annotation (plist-get org-store-link-plist :annotation)) + (initial (plist-get org-store-link-plist :initial))) + (org-remember-apply-template)) + (message "Press C-c C-c to remember data")) + (if (org-region-active-p) + (org-do-remember (buffer-substring (point) (mark))) + (org-do-remember)))))) + +(defvar org-remember-last-stored-marker (make-marker) + "Marker pointing to the entry most recently stored with `org-remember'.") + +(defun org-remember-goto-last-stored () + "Go to the location where the last remember note was stored." + (interactive) + (org-goto-marker-or-bmk org-remember-last-stored-marker + "org-remember-last-stored") + (message "This is the last note stored by remember")) + +(defun org-go-to-remember-target (&optional template-key) + "Go to the target location of a remember template. +The user is queried for the template." + (interactive) + (let* (org-select-template-temp-major-mode + (entry (org-select-remember-template template-key)) + (file (nth 1 entry)) + (heading (nth 2 entry)) + visiting) + (unless (and file (stringp file) (string-match "\\S-" file)) + (setq file org-default-notes-file)) + (when (and file (not (file-name-absolute-p file))) + (setq file (expand-file-name file org-directory))) + (unless (and heading (stringp heading) (string-match "\\S-" heading)) + (setq heading org-remember-default-headline)) + (setq visiting (org-find-base-buffer-visiting file)) + (if (not visiting) (find-file-noselect file)) + (switch-to-buffer (or visiting (get-file-buffer file))) + (widen) + (goto-char (point-min)) + (if (re-search-forward + (format org-complex-heading-regexp-format (regexp-quote heading)) + nil t) + (goto-char (match-beginning 0)) + (error "Target headline not found: %s" heading)))) + +;; FIXME (bzg): let's clean up of final empty lines happen only once +;; (see the org-remember-delete-empty-lines-at-end option below) +;;;###autoload +(defun org-remember-handler () + "Store stuff from remember.el into an org file. +When the template has specified a file and a headline, the entry is filed +there, or in the location defined by `org-default-notes-file' and +`org-remember-default-headline'. +\\<org-remember-mode-map> +If no defaults have been defined, or if the current prefix argument +is 1 (using C-1 \\[org-remember-finalize] to exit remember), an interactive +process is used to select the target location. + +When the prefix is 0 (i.e. when remember is exited with \ +C-0 \\[org-remember-finalize]), +the entry is filed to the same location as the previous note. + +When the prefix is 2 (i.e. when remember is exited with \ +C-2 \\[org-remember-finalize]), +the entry is filed as a subentry of the entry where the clock is +currently running. + +When \\[universal-argument] has been used as prefix argument, the +note is stored and Emacs moves point to the new location of the +note, so that editing can be continued there (similar to +inserting \"%&\" into the template). + +Before storing the note, the function ensures that the text has an +org-mode-style headline, i.e. a first line that starts with +a \"*\". If not, a headline is constructed from the current date and +some additional data. + +If the variable `org-adapt-indentation' is non-nil, the entire text is +also indented so that it starts in the same column as the headline +\(i.e. after the stars). + +See also the variable `org-reverse-note-order'." + (when (and (equal current-prefix-arg 2) + (not (marker-buffer org-clock-marker))) + (error "No running clock")) + (when (org-bound-and-true-p org-jump-to-target-location) + (let* ((end (min (point-max) (1+ (point)))) + (beg (point))) + (if (= end beg) (setq beg (1- beg))) + (put-text-property beg end 'org-position-cursor t))) + (goto-char (point-min)) + (while (looking-at "^[ \t]*\n\\|^##.*\n") + (replace-match "")) + (when org-remember-delete-empty-lines-at-end + (goto-char (point-max)) + (beginning-of-line 1) + (while (and (looking-at "[ \t]*$\\|##.*") (> (point) 1)) + (delete-region (1- (point)) (point-max)) + (beginning-of-line 1))) + (catch 'quit + (if org-note-abort (throw 'quit t)) + (let* ((visitp (org-bound-and-true-p org-jump-to-target-location)) + (backup-file + (and buffer-file-name + (equal (file-name-directory buffer-file-name) + (file-name-as-directory + (expand-file-name org-remember-backup-directory))) + (string-match "^remember-[0-9]\\{4\\}" + (file-name-nondirectory buffer-file-name)) + buffer-file-name)) + + (dummy + (unless (string-match "\\S-" (buffer-string)) + (message "Nothing to remember") + (and backup-file + (ignore-errors + (delete-file backup-file) + (delete-file (concat backup-file "~")))) + (set-buffer-modified-p nil) + (throw 'quit t))) + (reference-date org-remember-reference-date) + (previousp (and (member current-prefix-arg '((16) 0)) + org-remember-previous-location)) + (clockp (equal current-prefix-arg 2)) + (clocksp (equal current-prefix-arg 3)) + (fastp (org-xor (equal current-prefix-arg 1) + org-remember-store-without-prompt)) + (file (cond + (fastp org-default-notes-file) + ((and (eq org-remember-interactive-interface 'refile) + org-refile-targets) + org-default-notes-file) + ((not previousp) + (org-get-org-file)))) + (heading org-remember-default-headline) + (visiting (and file (org-find-base-buffer-visiting file))) + (org-startup-folded nil) + (org-startup-align-all-tables nil) + (org-goto-start-pos 1) + spos exitcmd level reversed txt text-before-node-creation) + (when (equal current-prefix-arg '(4)) + (setq visitp t)) + (when previousp + (setq file (car org-remember-previous-location) + visiting (and file (org-find-base-buffer-visiting file)) + heading (cdr org-remember-previous-location) + fastp t)) + (when (or clockp clocksp) + (setq file (buffer-file-name (marker-buffer org-clock-marker)) + visiting (and file (org-find-base-buffer-visiting file)) + heading org-clock-heading-for-remember + fastp t)) + (setq current-prefix-arg nil) + ;; Modify text so that it becomes a nice subtree which can be inserted + ;; into an org tree. + (when org-remember-delete-empty-lines-at-end + (goto-char (point-min)) + (if (re-search-forward "[ \t\n]+\\'" nil t) + ;; remove empty lines at end + (replace-match ""))) + (goto-char (point-min)) + (setq text-before-node-creation (buffer-string)) + (unless (looking-at org-outline-regexp) + ;; add a headline + (insert (concat "* " (current-time-string) + " (" (remember-buffer-desc) ")\n")) + (backward-char 1) + (when org-adapt-indentation + (while (re-search-forward "^" nil t) + (insert " ")))) + ;; Delete final empty lines + (when org-remember-delete-empty-lines-at-end + (goto-char (point-min)) + (if (re-search-forward "\n[ \t]*\n[ \t\n]*\\'" nil t) + (replace-match "\n\n") + (if (re-search-forward "[ \t\n]*\\'") + (replace-match "\n")))) + (goto-char (point-min)) + (setq txt (buffer-string)) + (org-save-markers-in-region (point-min) (point-max)) + (set-buffer-modified-p nil) + (when (and (eq org-remember-interactive-interface 'refile) + (not fastp)) + (org-refile nil (or visiting (find-file-noselect file))) + (and visitp (run-with-idle-timer 0.01 nil 'org-remember-visit-immediately)) + (save-excursion + (bookmark-jump "org-refile-last-stored") + (bookmark-set "org-remember-last-stored") + (move-marker org-remember-last-stored-marker (point))) + (throw 'quit t)) + ;; Find the file + (with-current-buffer (or visiting (find-file-noselect file)) + (unless (or (org-mode-p) (member heading '(top bottom))) + (error "Target files for notes must be in Org-mode if not filing to top/bottom")) + (save-excursion + (save-restriction + (widen) + (setq reversed (org-notes-order-reversed-p)) + + ;; Find the default location + (when heading + (cond + ((not (org-mode-p)) + (if (eq heading 'top) + (goto-char (point-min)) + (goto-char (point-max)) + (or (bolp) (newline))) + (insert text-before-node-creation) + (when remember-save-after-remembering + (save-buffer) + (if (not visiting) (kill-buffer (current-buffer)))) + (throw 'quit t)) + ((eq heading 'top) + (goto-char (point-min)) + (or (looking-at org-outline-regexp) + (re-search-forward org-outline-regexp nil t)) + (setq org-goto-start-pos (or (match-beginning 0) (point-min)))) + ((eq heading 'bottom) + (goto-char (point-max)) + (or (bolp) (newline)) + (setq org-goto-start-pos (point))) + ((eq heading 'date-tree) + (org-datetree-find-date-create reference-date) + (setq reversed nil) + (setq org-goto-start-pos (point))) + ((and (stringp heading) (string-match "\\S-" heading)) + (goto-char (point-min)) + (if (re-search-forward + (format org-complex-heading-regexp-format + (regexp-quote heading)) + nil t) + (setq org-goto-start-pos (match-beginning 0)) + (when fastp + (goto-char (point-max)) + (unless (bolp) (newline)) + (insert "* " heading "\n") + (setq org-goto-start-pos (point-at-bol 0))))) + (t (goto-char (point-min)) (setq org-goto-start-pos (point) + heading 'top)))) + + ;; Ask the User for a location, using the appropriate interface + (cond + ((and fastp (memq heading '(top bottom))) + (setq spos org-goto-start-pos + exitcmd (if (eq heading 'top) 'left nil))) + (fastp (setq spos org-goto-start-pos + exitcmd 'return)) + ((eq org-remember-interactive-interface 'outline) + (setq spos (org-get-location (current-buffer) + org-remember-help) + exitcmd (cdr spos) + spos (car spos))) + ((eq org-remember-interactive-interface 'outline-path-completion) + (let ((org-refile-targets '((nil . (:maxlevel . 10)))) + (org-refile-use-outline-path t)) + (setq spos (org-refile-get-location "Heading: ") + exitcmd 'return + spos (nth 3 spos)))) + (t (error "This should not happen"))) + (if (not spos) (throw 'quit nil)) ; return nil to show we did + ; not handle this note + (and visitp (run-with-idle-timer 0.01 nil 'org-remember-visit-immediately)) + (goto-char spos) + (cond ((org-on-heading-p t) + (org-back-to-heading t) + (setq level (funcall outline-level)) + (cond + ((eq exitcmd 'return) + ;; sublevel of current + (setq org-remember-previous-location + (cons (abbreviate-file-name file) + (org-get-heading 'notags))) + (if reversed + (outline-next-heading) + (org-end-of-subtree t) + (if (not (bolp)) + (if (looking-at "[ \t]*\n") + (beginning-of-line 2) + (end-of-line 1) + (insert "\n")))) + (org-paste-subtree (if clocksp + level + (org-get-valid-level level 1)) txt) + (and org-auto-align-tags (org-set-tags nil t)) + (bookmark-set "org-remember-last-stored") + (move-marker org-remember-last-stored-marker (point))) + ((eq exitcmd 'left) + ;; before current + (org-paste-subtree level txt) + (and org-auto-align-tags (org-set-tags nil t)) + (bookmark-set "org-remember-last-stored") + (move-marker org-remember-last-stored-marker (point))) + ((eq exitcmd 'right) + ;; after current + (org-end-of-subtree t) + (org-paste-subtree level txt) + (and org-auto-align-tags (org-set-tags nil t)) + (bookmark-set "org-remember-last-stored") + (move-marker org-remember-last-stored-marker (point))) + (t (error "This should not happen")))) + + ((eq heading 'bottom) + (org-paste-subtree 1 txt) + (and org-auto-align-tags (org-set-tags nil t)) + (bookmark-set "org-remember-last-stored") + (move-marker org-remember-last-stored-marker (point))) + + ((and (bobp) (not reversed)) + ;; Put it at the end, one level below level 1 + (save-restriction + (widen) + (goto-char (point-max)) + (if (not (bolp)) (newline)) + (org-paste-subtree (org-get-valid-level 1 1) txt) + (and org-auto-align-tags (org-set-tags nil t)) + (bookmark-set "org-remember-last-stored") + (move-marker org-remember-last-stored-marker (point)))) + + ((and (bobp) reversed) + ;; Put it at the start, as level 1 + (save-restriction + (widen) + (goto-char (point-min)) + (re-search-forward "^\\*+ " nil t) + (beginning-of-line 1) + (org-paste-subtree 1 txt) + (and org-auto-align-tags (org-set-tags nil t)) + (bookmark-set "org-remember-last-stored") + (move-marker org-remember-last-stored-marker (point)))) + (t + ;; Put it right there, with automatic level determined by + ;; org-paste-subtree or from prefix arg + (org-paste-subtree + (if (numberp current-prefix-arg) current-prefix-arg) + txt) + (and org-auto-align-tags (org-set-tags nil t)) + (bookmark-set "org-remember-last-stored") + (move-marker org-remember-last-stored-marker (point)))) + + (when remember-save-after-remembering + (save-buffer) + (if (and (not visiting) + (not (equal (marker-buffer org-clock-marker) + (current-buffer)))) + (kill-buffer (current-buffer)))) + (when org-remember-auto-remove-backup-files + (when backup-file + (ignore-errors + (delete-file backup-file) + (delete-file (concat backup-file "~")))) + (when org-remember-backup-directory + (let ((n (length + (directory-files + org-remember-backup-directory nil + "^remember-.*[0-9]$")))) + (when (and org-remember-warn-about-backups + (> n 0)) + (message + "%d backup files (unfinished remember calls) in %s" + n org-remember-backup-directory)))))))))) + + t) ;; return t to indicate that we took care of this note. + +(defun org-do-remember (&optional initial) + "Call remember." + (remember initial)) + +(defun org-require-remember () + "Make sure remember is loaded, or install our own emergency version of it." + (condition-case nil + (require 'remember) + (error + ;; Lets install our own micro version of remember + (defvar remember-register ?R) + (defvar remember-mode-hook nil) + (defvar remember-handler-functions nil) + (defvar remember-buffer "*Remember*") + (defvar remember-save-after-remembering t) + (defvar remember-annotation-functions '(buffer-file-name)) + (defun remember-finalize () + (run-hook-with-args-until-success 'remember-handler-functions) + (when (equal remember-buffer (buffer-name)) + (kill-buffer (current-buffer)) + (jump-to-register remember-register))) + (defun remember-mode () + (fundamental-mode) + (setq mode-name "Remember") + (run-hooks 'remember-mode-hook)) + (defun remember (&optional initial) + (window-configuration-to-register remember-register) + (let* ((annotation (run-hook-with-args-until-success + 'remember-annotation-functions))) + (switch-to-buffer-other-window (get-buffer-create remember-buffer)) + (remember-mode))) + (defun remember-buffer-desc () + (buffer-substring (point-min) (save-excursion (goto-char (point-min)) + (point-at-eol))))))) + +(provide 'org-remember) + +;; arch-tag: 497f30d0-4bc3-4097-8622-2d27ac5f2698 + +;;; org-remember.el ends here + diff --git a/.emacs.d/org-7.4/lisp/org-remember.elc b/.emacs.d/org-7.4/lisp/org-remember.elc Binary files differnew file mode 100644 index 0000000..241c526 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-remember.elc diff --git a/.emacs.d/org-7.4/lisp/org-rmail.el b/.emacs.d/org-7.4/lisp/org-rmail.el new file mode 100644 index 0000000..7325868 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-rmail.el @@ -0,0 +1,120 @@ +;;; org-rmail.el --- Support for links to Rmail messages from within Org-mode + +;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010 +;; Free Software Foundation, Inc. + +;; Author: Carsten Dominik <carsten at orgmode dot org> +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; Version: 7.4 +;; +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: + +;; This file implements links to Rmail messages from within Org-mode. +;; Org-mode loads this module by default - if this is not what you want, +;; configure the variable `org-modules'. + +;;; Code: + +(require 'org) + +;; Declare external functions and variables +(declare-function rmail-show-message "rmail" (&optional n no-summary)) +(declare-function rmail-what-message "rmail" ()) +(defvar rmail-current-message) + +;; Install the link type +(org-add-link-type "rmail" 'org-rmail-open) +(add-hook 'org-store-link-functions 'org-rmail-store-link) + +;; Implementation +(defun org-rmail-store-link () + "Store a link to an Rmail folder or message." + (when (or (eq major-mode 'rmail-mode) + (eq major-mode 'rmail-summary-mode)) + (save-window-excursion + (save-restriction + (when (eq major-mode 'rmail-summary-mode) + (rmail-show-message rmail-current-message)) + (when (fboundp 'rmail-narrow-to-non-pruned-header) + (rmail-narrow-to-non-pruned-header)) + (let* ((folder buffer-file-name) + (message-id (mail-fetch-field "message-id")) + (from (mail-fetch-field "from")) + (to (mail-fetch-field "to")) + (subject (mail-fetch-field "subject")) + (date (mail-fetch-field "date")) + (date-ts (and date (format-time-string + (org-time-stamp-format t) + (date-to-time date)))) + (date-ts-ia (and date (format-time-string + (org-time-stamp-format t t) + (date-to-time date)))) + desc link) + (org-store-link-props + :type "rmail" :from from :to to + :subject subject :message-id message-id) + (when date + (org-add-link-props :date date :date-timestamp date-ts + :date-timestamp-inactive date-ts-ia)) + (setq message-id (org-remove-angle-brackets message-id)) + (setq desc (org-email-link-description)) + (setq link (org-make-link "rmail:" folder "#" message-id)) + (org-add-link-props :link link :description desc) + (rmail-show-message rmail-current-message) + link))))) + +(defun org-rmail-open (path) + "Follow an Rmail message link to the specified PATH." + (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-rmail-follow-link folder article))) + +(defun org-rmail-follow-link (folder article) + "Follow an Rmail link to FOLDER and ARTICLE." + (require 'rmail) + (setq article (org-add-angle-brackets article)) + (let (message-number) + (save-excursion + (save-window-excursion + (rmail (if (string= folder "RMAIL") rmail-file-name folder)) + (setq message-number + (save-restriction + (widen) + (goto-char (point-max)) + (if (re-search-backward + (concat "^Message-ID:\\s-+" (regexp-quote + (or article ""))) + nil t) + (rmail-what-message)))))) + (if message-number + (progn + (rmail (if (string= folder "RMAIL") rmail-file-name folder)) + (rmail-show-message message-number) + message-number) + (error "Message not found")))) + +(provide 'org-rmail) + +;; arch-tag: c6cf4a8b-6639-4b7f-821f-bdf10746b173 + +;;; org-rmail.el ends here diff --git a/.emacs.d/org-7.4/lisp/org-rmail.elc b/.emacs.d/org-7.4/lisp/org-rmail.elc Binary files differnew file mode 100644 index 0000000..83a45ec --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-rmail.elc diff --git a/.emacs.d/org-7.4/lisp/org-src.el b/.emacs.d/org-7.4/lisp/org-src.el new file mode 100644 index 0000000..c932b4a --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-src.el @@ -0,0 +1,811 @@ +;;; org-src.el --- Source code examples in Org +;; +;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010 +;; Free Software Foundation, Inc. +;; +;; Author: Carsten Dominik <carsten at orgmode dot org> +;; Bastien Guerry <bzg AT altern DOT org> +;; Dan Davison <davison at stats dot ox dot ac dot uk> +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; Version: 7.4 +;; +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: + +;; This file contains the code dealing with source code examples in Org-mode. + +;;; Code: + +(require 'org-macs) +(require 'org-compat) +(require 'ob-keys) +(require 'ob-comint) +(eval-when-compile + (require 'cl)) + +(declare-function org-do-remove-indentation "org" (&optional n)) +(declare-function org-at-table.el-p "org" ()) +(declare-function org-get-indentation "org" (&optional line)) +(declare-function org-switch-to-buffer-other-window "org" (&rest args)) + +(defcustom org-edit-src-region-extra nil + "Additional regexps to identify regions for editing with `org-edit-src-code'. +For examples see the function `org-edit-src-find-region-and-lang'. +The regular expression identifying the begin marker should end with a newline, +and the regexp marking the end line should start with a newline, to make sure +there are kept outside the narrowed region." + :group 'org-edit-structure + :type '(repeat + (list + (regexp :tag "begin regexp") + (regexp :tag "end regexp") + (choice :tag "language" + (string :tag "specify") + (integer :tag "from match group") + (const :tag "from `lang' element") + (const :tag "from `style' element"))))) + +(defcustom org-coderef-label-format "(ref:%s)" + "The default coderef format. +This format string will be used to search for coderef labels in literal +examples (EXAMPLE and SRC blocks). The format can be overwritten in +an individual literal example with the -l option, like + +#+BEGIN_SRC pascal +n -r -l \"((%s))\" +... +#+END_SRC + +If you want to use this for HTML export, make sure that the format does +not introduce special font-locking, and avoid the HTML special +characters `<', `>', and `&'. The reason for this restriction is that +the labels are searched for only after htmlize has done its job." + :group 'org-edit-structure ; FIXME this is not in the right group + :type 'string) + +(defcustom org-edit-fixed-width-region-mode 'artist-mode + "The mode that should be used to edit fixed-width regions. +These are the regions where each line starts with a colon." + :group 'org-edit-structure + :type '(choice + (const artist-mode) + (const picture-mode) + (const fundamental-mode) + (function :tag "Other (specify)"))) + +(defcustom org-src-preserve-indentation nil + "If non-nil preserve leading whitespace characters on export. +If non-nil leading whitespace characters in source code blocks +are preserved on export, and when switching between the org +buffer and the language mode edit buffer. If this variable is nil +then, after editing with \\[org-edit-src-code], the +minimum (across-lines) number of leading whitespace characters +are removed from all lines, and the code block is uniformly +indented according to the value of `org-edit-src-content-indentation'." + :group 'org-edit-structure + :type 'boolean) + +(defcustom org-edit-src-content-indentation 2 + "Indentation for the content of a source code block. +This should be the number of spaces added to the indentation of the #+begin +line in order to compute the indentation of the block content after +editing it with \\[org-edit-src-code]. Has no effect if +`org-src-preserve-indentation' is non-nil." + :group 'org-edit-structure + :type 'integer) + +(defvar org-src-strip-leading-and-trailing-blank-lines nil + "If non-nil, blank lines are removed when exiting the code edit +buffer.") + +(defcustom org-edit-src-persistent-message t + "Non-nil means show persistent exit help message while editing src examples. +The message is shown in the header-line, which will be created in the +first line of the window showing the editing buffer. +When nil, the message will only be shown intermittently in the echo area." + :group 'org-edit-structure + :type 'boolean) + +(defcustom org-src-window-setup 'reorganize-frame + "How the source code edit buffer should be displayed. +Possible values for this option are: + +current-window Show edit buffer in the current window, keeping all other + windows. +other-window Use `switch-to-buffer-other-window' to display edit buffer. +reorganize-frame Show only two windows on the current frame, the current + window and the edit buffer. When exiting the edit buffer, + return to one window. +other-frame Use `switch-to-buffer-other-frame' to display edit buffer. + Also, when exiting the edit buffer, kill that frame." + :group 'org-edit-structure + :type '(choice + (const current-window) + (const other-frame) + (const other-window) + (const reorganize-frame))) + +(defvar org-src-mode-hook nil + "Hook run after Org switched a source code snippet to its Emacs mode. +This hook will run + +- when editing a source code snippet with \"C-c '\". +- When formatting a source code snippet for export with htmlize. + +You may want to use this hook for example to turn off `outline-minor-mode' +or similar things which you want to have when editing a source code file, +but which mess up the display of a snippet in Org exported files.") + +(defcustom org-src-lang-modes + '(("ocaml" . tuareg) ("elisp" . emacs-lisp) ("ditaa" . artist) + ("asymptote" . asy) ("dot" . fundamental) ("sqlite" . sql) + ("calc" . fundamental)) + "Alist mapping languages to their major mode. +The key is the language name, the value is the string that should +be inserted as the name of the major mode. For many languages this is +simple, but for language where this is not the case, this variable +provides a way to simplify things on the user side. +For example, there is no ocaml-mode in Emacs, but the mode to use is +`tuareg-mode'." + :group 'org-edit-structure + :type '(repeat + (cons + (string "Language name") + (symbol "Major mode")))) + +;;; Editing source examples + +(defvar org-src-mode-map (make-sparse-keymap)) +(define-key org-src-mode-map "\C-c'" 'org-edit-src-exit) + +(defvar org-edit-src-force-single-line nil) +(defvar org-edit-src-from-org-mode nil) +(defvar org-edit-src-allow-write-back-p t) +(defvar org-edit-src-picture nil) +(defvar org-edit-src-beg-marker nil) +(defvar org-edit-src-end-marker nil) +(defvar org-edit-src-overlay nil) +(defvar org-edit-src-block-indentation nil) +(defvar org-edit-src-saved-temp-window-config nil) + +(defvar org-src-ask-before-returning-to-edit-buffer t + "If nil, when org-edit-src code is used on a block that already + has an active edit buffer, it will switch to that edit buffer + immediately; otherwise it will ask whether you want to return + to the existing edit buffer.") + +(defvar org-src-babel-info nil) + +(define-minor-mode org-src-mode + "Minor mode for language major mode buffers generated by org. +This minor mode is turned on in two situations: +- when editing a source code snippet with \"C-c '\". +- When formatting a source code snippet for export with htmlize. +There is a mode hook, and keybindings for `org-edit-src-exit' and +`org-edit-src-save'") + +(defun org-edit-src-code (&optional context code edit-buffer-name quietp) + "Edit the source code example at point. +The example is copied to a separate buffer, and that buffer is +switched to the correct language mode. When done, exit with +\\[org-edit-src-exit]. This will remove the original code in the +Org buffer, and replace it with the edited version. Optional +argument CONTEXT is used by \\[org-edit-src-save] when calling +this function. See \\[org-src-window-setup] to configure the +display of windows containing the Org buffer and the code +buffer." + (interactive) + (unless (eq context 'save) + (setq org-edit-src-saved-temp-window-config (current-window-configuration))) + (let ((mark (and (org-region-active-p) (mark))) + (case-fold-search t) + (info (org-edit-src-find-region-and-lang)) + (babel-info (org-babel-get-src-block-info 'light)) + (org-mode-p (eq major-mode 'org-mode)) + (beg (make-marker)) + (end (make-marker)) + (preserve-indentation org-src-preserve-indentation) + (allow-write-back-p (null code)) + block-nindent total-nindent ovl lang lang-f single lfmt buffer msg + begline markline markcol line col) + (if (not info) + nil + (setq beg (move-marker beg (nth 0 info)) + end (move-marker end (nth 1 info)) + msg (if allow-write-back-p + (substitute-command-keys + "Edit, then exit with C-c ' (C-c and single quote)") + "Exit with C-c ' (C-c and single quote)") + code (or code (buffer-substring-no-properties beg end)) + lang (or (cdr (assoc (nth 2 info) org-src-lang-modes)) + (nth 2 info)) + lang (if (symbolp lang) (symbol-name lang) lang) + single (nth 3 info) + lfmt (nth 4 info) + block-nindent (nth 5 info) + lang-f (intern (concat lang "-mode")) + begline (save-excursion (goto-char beg) (org-current-line))) + (if (and mark (>= mark beg) (<= mark (1+ end))) + (save-excursion (goto-char (min mark end)) + (setq markline (org-current-line) + markcol (current-column)))) + (if (equal lang-f 'table.el-mode) + (setq lang-f (lambda () + (text-mode) + (if (org-bound-and-true-p flyspell-mode) + (flyspell-mode -1)) + (table-recognize) + (org-set-local 'org-edit-src-content-indentation 0)))) + (unless (functionp lang-f) + (error "No such language mode: %s" lang-f)) + (save-excursion + (if (> (point) end) (goto-char end)) + (setq line (org-current-line) + col (current-column))) + (if (and (setq buffer (org-edit-src-find-buffer beg end)) + (if org-src-ask-before-returning-to-edit-buffer + (y-or-n-p "Return to existing edit buffer? [n] will revert changes: ") t)) + (org-src-switch-to-buffer buffer 'return) + (when buffer + (with-current-buffer buffer + (if (boundp 'org-edit-src-overlay) + (delete-overlay org-edit-src-overlay))) + (kill-buffer buffer)) + (setq buffer (generate-new-buffer + (or edit-buffer-name + (org-src-construct-edit-buffer-name (buffer-name) lang)))) + (setq ovl (make-overlay beg end)) + (overlay-put ovl 'edit-buffer buffer) + (overlay-put ovl 'help-echo "Click with mouse-1 to switch to buffer editing this segment") + (overlay-put ovl 'face 'secondary-selection) + (overlay-put ovl + 'keymap + (let ((map (make-sparse-keymap))) + (define-key map [mouse-1] 'org-edit-src-continue) + map)) + (overlay-put ovl :read-only "Leave me alone") + (org-src-switch-to-buffer buffer 'edit) + (if (eq single 'macro-definition) + (setq code (replace-regexp-in-string "\\\\n" "\n" code t t))) + (insert code) + (remove-text-properties (point-min) (point-max) + '(display nil invisible nil intangible nil)) + (unless preserve-indentation + (setq total-nindent (or (org-do-remove-indentation) 0))) + (let ((org-inhibit-startup t)) + (condition-case e + (funcall lang-f) + (error + (error "Language mode `%s' fails with: %S" lang-f (nth 1 e))))) + (set (make-local-variable 'org-edit-src-force-single-line) single) + (set (make-local-variable 'org-edit-src-from-org-mode) org-mode-p) + (set (make-local-variable 'org-edit-src-allow-write-back-p) allow-write-back-p) + (set (make-local-variable 'org-src-preserve-indentation) preserve-indentation) + (when babel-info + (set (make-local-variable 'org-src-babel-info) babel-info)) + (when lfmt + (set (make-local-variable 'org-coderef-label-format) lfmt)) + (when org-mode-p + (goto-char (point-min)) + (while (re-search-forward "^," nil t) + (if (eq (org-current-line) line) (setq total-nindent (1+ total-nindent))) + (replace-match ""))) + (when markline + (org-goto-line (1+ (- markline begline))) + (org-move-to-column + (if preserve-indentation markcol (max 0 (- markcol total-nindent)))) + (push-mark (point) 'no-message t) + (setq deactivate-mark nil)) + (org-goto-line (1+ (- line begline))) + (org-move-to-column + (if preserve-indentation col (max 0 (- col total-nindent)))) + (org-set-local 'org-edit-src-beg-marker beg) + (org-set-local 'org-edit-src-end-marker end) + (org-set-local 'org-edit-src-overlay ovl) + (org-set-local 'org-edit-src-block-indentation block-nindent) + (org-src-mode) + (set-buffer-modified-p nil) + (and org-edit-src-persistent-message + (org-set-local 'header-line-format msg))) + (unless quietp (message "%s" msg)) + t))) + +(defun org-edit-src-continue (e) + (interactive "e") + (mouse-set-point e) + (let ((buf (get-char-property (point) 'edit-buffer))) + (if buf (org-src-switch-to-buffer buf 'continue) + (error "Something is wrong here")))) + +(defun org-src-switch-to-buffer (buffer context) + (case org-src-window-setup + ('current-window + (switch-to-buffer buffer)) + ('other-window + (switch-to-buffer-other-window buffer)) + ('other-frame + (case context + ('exit + (let ((frame (selected-frame))) + (switch-to-buffer-other-frame buffer) + (delete-frame frame))) + ('save + (kill-buffer (current-buffer)) + (switch-to-buffer buffer)) + (t + (switch-to-buffer-other-frame buffer)))) + ('reorganize-frame + (if (eq context 'edit) (delete-other-windows)) + (org-switch-to-buffer-other-window buffer) + (if (eq context 'exit) (delete-other-windows))) + ('switch-invisibly + (set-buffer buffer)) + (t + (message "Invalid value %s for org-src-window-setup" + (symbol-name org-src-window-setup)) + (switch-to-buffer buffer)))) + +(defun org-src-construct-edit-buffer-name (org-buffer-name lang) + "Construct the buffer name for a source editing buffer." + (concat "*Org Src " org-buffer-name "[ " lang " ]*")) + +(defun org-edit-src-find-buffer (beg end) + "Find a source editing buffer that is already editing the region BEG to END." + (catch 'exit + (mapc + (lambda (b) + (with-current-buffer b + (if (and (string-match "\\`*Org Src " (buffer-name)) + (local-variable-p 'org-edit-src-beg-marker (current-buffer)) + (local-variable-p 'org-edit-src-end-marker (current-buffer)) + (equal beg org-edit-src-beg-marker) + (equal end org-edit-src-end-marker)) + (throw 'exit (current-buffer))))) + (buffer-list)) + nil)) + +(defun org-edit-fixed-width-region () + "Edit the fixed-width ascii drawing at point. +This must be a region where each line starts with a colon followed by +a space character. +An new buffer is created and the fixed-width region is copied into it, +and the buffer is switched into `artist-mode' for editing. When done, +exit with \\[org-edit-src-exit]. The edited text will then replace +the fragment in the Org-mode buffer." + (interactive) + (let ((line (org-current-line)) + (col (current-column)) + (case-fold-search t) + (msg (substitute-command-keys + "Edit, then exit with C-c ' (C-c and single quote)")) + (org-mode-p (eq major-mode 'org-mode)) + (beg (make-marker)) + (end (make-marker)) + (preserve-indentation org-src-preserve-indentation) + block-nindent ovl beg1 end1 code begline buffer) + (beginning-of-line 1) + (if (looking-at "[ \t]*[^:\n \t]") + nil + (if (looking-at "[ \t]*\\(\n\\|\\'\\)") + (setq beg1 (point) end1 beg1) + (save-excursion + (if (re-search-backward "^[ \t]*[^: \t]" nil 'move) + (setq beg1 (point-at-bol 2)) + (setq beg1 (point)))) + (save-excursion + (if (re-search-forward "^[ \t]*[^: \t]" nil 'move) + (setq end1 (1- (match-beginning 0))) + (setq end1 (point)))) + (org-goto-line line)) + (setq beg (move-marker beg beg1) + end (move-marker end end1) + code (buffer-substring-no-properties beg end) + begline (save-excursion (goto-char beg) (org-current-line))) + (if (and (setq buffer (org-edit-src-find-buffer beg end)) + (y-or-n-p "Return to existing edit buffer? [n] will revert changes: ")) + (switch-to-buffer buffer) + (when buffer + (with-current-buffer buffer + (if (boundp 'org-edit-src-overlay) + (delete-overlay org-edit-src-overlay))) + (kill-buffer buffer)) + (setq buffer (generate-new-buffer + (org-src-construct-edit-buffer-name + (buffer-name) "Fixed Width"))) + (setq ovl (make-overlay beg end)) + (overlay-put ovl 'face 'secondary-selection) + (overlay-put ovl 'edit-buffer buffer) + (overlay-put ovl 'help-echo "Click with mouse-1 to switch to buffer editing this segment") + (overlay-put ovl 'face 'secondary-selection) + (overlay-put ovl + 'keymap + (let ((map (make-sparse-keymap))) + (define-key map [mouse-1] 'org-edit-src-continue) + map)) + (overlay-put ovl :read-only "Leave me alone") + (switch-to-buffer buffer) + (insert code) + (remove-text-properties (point-min) (point-max) + '(display nil invisible nil intangible nil)) + (setq block-nindent (or (org-do-remove-indentation) 0)) + (cond + ((eq org-edit-fixed-width-region-mode 'artist-mode) + (fundamental-mode) + (artist-mode 1)) + (t (funcall org-edit-fixed-width-region-mode))) + (set (make-local-variable 'org-edit-src-force-single-line) nil) + (set (make-local-variable 'org-edit-src-from-org-mode) org-mode-p) + (set (make-local-variable 'org-edit-src-picture) t) + (goto-char (point-min)) + (while (re-search-forward "^[ \t]*: ?" nil t) + (replace-match "")) + (org-goto-line (1+ (- line begline))) + (org-move-to-column (max 0 (- col block-nindent 2))) + (org-set-local 'org-edit-src-beg-marker beg) + (org-set-local 'org-edit-src-end-marker end) + (org-set-local 'org-edit-src-overlay ovl) + (org-set-local 'org-edit-src-block-indentation block-nindent) + (org-set-local 'org-edit-src-content-indentation 0) + (org-set-local 'org-src-preserve-indentation nil) + (org-src-mode) + (set-buffer-modified-p nil) + (and org-edit-src-persistent-message + (org-set-local 'header-line-format msg))) + (message "%s" msg) + t))) + +(defun org-edit-src-find-region-and-lang () + "Find the region and language for a local edit. +Return a list with beginning and end of the region, a string representing +the language, a switch telling if the content should be in a single line." + (let ((re-list + (append + org-edit-src-region-extra + '( + ("<src\\>[^<]*>[ \t]*\n?" "\n?[ \t]*</src>" lang) + ("<literal\\>[^<]*>[ \t]*\n?" "\n?[ \t]*</literal>" style) + ("<example>[ \t]*\n?" "\n?[ \t]*</example>" "fundamental") + ("<lisp>[ \t]*\n?" "\n?[ \t]*</lisp>" "emacs-lisp") + ("<perl>[ \t]*\n?" "\n?[ \t]*</perl>" "perl") + ("<python>[ \t]*\n?" "\n?[ \t]*</python>" "python") + ("<ruby>[ \t]*\n?" "\n?[ \t]*</ruby>" "ruby") + ("^[ \t]*#\\+begin_src\\( \\([^ \t\n]+\\)\\)?.*\n" "\n[ \t]*#\\+end_src" 2) + ("^[ \t]*#\\+begin_example.*\n" "\n[ \t]*#\\+end_example" "fundamental") + ("^[ \t]*#\\+html:" "\n" "html" single-line) + ("^[ \t]*#\\+begin_html.*\n" "\n[ \t]*#\\+end_html" "html") + ("^[ \t]*#\\+latex:" "\n" "latex" single-line) + ("^[ \t]*#\\+begin_latex.*\n" "\n[ \t]*#\\+end_latex" "latex") + ("^[ \t]*#\\+ascii:" "\n" "fundamental" single-line) + ("^[ \t]*#\\+begin_ascii.*\n" "\n[ \t]*#\\+end_ascii" "fundamental") + ("^[ \t]*#\\+docbook:" "\n" "xml" single-line) + ("^[ \t]*#\\+macro:[ \t]+\\S-+\\( \\|$\\)" + "\n" "fundamental" macro-definition) + ("^[ \t]*#\\+begin_docbook.*\n" "\n[ \t]*#\\+end_docbook" "xml") + ))) + (pos (point)) + re1 re2 single beg end lang lfmt match-re1 ind entry) + (catch 'exit + (while (setq entry (pop re-list)) + (setq re1 (car entry) re2 (nth 1 entry) lang (nth 2 entry) + single (nth 3 entry)) + (save-excursion + (if (or (looking-at re1) + (re-search-backward re1 nil t)) + (progn + (setq match-re1 (match-string 0)) + (setq beg (match-end 0) + lang (org-edit-src-get-lang lang) + lfmt (org-edit-src-get-label-format match-re1) + ind (org-edit-src-get-indentation (match-beginning 0))) + (if (and (re-search-forward re2 nil t) + (>= (match-end 0) pos)) + (throw 'exit (list beg (match-beginning 0) + lang single lfmt ind)))) + (if (or (looking-at re2) + (re-search-forward re2 nil t)) + (progn + (setq end (match-beginning 0)) + (if (and (re-search-backward re1 nil t) + (<= (match-beginning 0) pos)) + (progn + (setq lfmt (org-edit-src-get-label-format + (match-string 0)) + ind (org-edit-src-get-indentation + (match-beginning 0))) + (throw 'exit + (list (match-end 0) end + (org-edit-src-get-lang lang) + single lfmt ind))))))))) + (when (org-at-table.el-p) + (re-search-backward "^[\t]*[^ \t|\\+]" nil t) + (setq beg (1+ (point-at-eol))) + (goto-char beg) + (or (re-search-forward "^[\t]*[^ \t|\\+]" nil t) + (progn (goto-char (point-max)) (newline))) + (setq end (point-at-bol)) + (setq ind (org-edit-src-get-indentation beg)) + (throw 'exit (list beg end 'table.el nil nil ind)))))) + +(defun org-edit-src-get-lang (lang) + "Extract the src language." + (let ((m (match-string 0))) + (cond + ((stringp lang) lang) + ((integerp lang) (match-string lang)) + ((and (eq lang 'lang) + (string-match "\\<lang=\"\\([^ \t\n\"]+\\)\"" m)) + (match-string 1 m)) + ((and (eq lang 'style) + (string-match "\\<style=\"\\([^ \t\n\"]+\\)\"" m)) + (match-string 1 m)) + (t "fundamental")))) + +(defun org-edit-src-get-label-format (s) + "Extract the label format." + (save-match-data + (if (string-match "-l[ \t]+\\\\?\"\\([^\t\r\n\"]+\\)\\\\?\"" s) + (match-string 1 s)))) + +(defun org-edit-src-get-indentation (pos) + "Count leading whitespace characters on line." + (save-match-data + (goto-char pos) + (org-get-indentation))) + +(defun org-edit-src-exit (&optional context) + "Exit special edit and protect problematic lines." + (interactive) + (unless (org-bound-and-true-p org-edit-src-from-org-mode) + (error "This is not a sub-editing buffer, something is wrong")) + (widen) + (let* ((beg org-edit-src-beg-marker) + (end org-edit-src-end-marker) + (ovl org-edit-src-overlay) + (buffer (current-buffer)) + (single (org-bound-and-true-p org-edit-src-force-single-line)) + (macro (eq single 'macro-definition)) + (total-nindent (+ (or org-edit-src-block-indentation 0) + org-edit-src-content-indentation)) + (preserve-indentation org-src-preserve-indentation) + (allow-write-back-p (org-bound-and-true-p org-edit-src-allow-write-back-p)) + (delta 0) code line col indent) + (when allow-write-back-p + (unless preserve-indentation (untabify (point-min) (point-max))) + (if org-src-strip-leading-and-trailing-blank-lines + (save-excursion + (goto-char (point-min)) + (if (looking-at "[ \t\n]*\n") (replace-match "")) + (unless macro + (if (re-search-forward "\n[ \t\n]*\\'" nil t) (replace-match "")))))) + (setq line (if (org-bound-and-true-p org-edit-src-force-single-line) + 1 + (org-current-line)) + col (current-column)) + (when allow-write-back-p + (when single + (goto-char (point-min)) + (if (re-search-forward "\\s-+\\'" nil t) (replace-match "")) + (goto-char (point-min)) + (let ((cnt 0)) + (while (re-search-forward "\n" nil t) + (setq cnt (1+ cnt)) + (replace-match (if macro "\\n" " ") t t)) + (when (and macro (> cnt 0)) + (goto-char (point-max)) (insert "\\n"))) + (goto-char (point-min)) + (if (looking-at "\\s-*") (replace-match " "))) + (when (org-bound-and-true-p org-edit-src-from-org-mode) + (goto-char (point-min)) + (while (re-search-forward + (if (org-mode-p) "^\\(.\\)" "^\\([*]\\|[ \t]*#\\+\\)") nil t) + (if (eq (org-current-line) line) (setq delta (1+ delta))) + (replace-match ",\\1"))) + (when (org-bound-and-true-p org-edit-src-picture) + (setq preserve-indentation nil) + (untabify (point-min) (point-max)) + (goto-char (point-min)) + (while (re-search-forward "^" nil t) + (replace-match ": "))) + (unless (or single preserve-indentation (= total-nindent 0)) + (setq indent (make-string total-nindent ?\ )) + (goto-char (point-min)) + (while (re-search-forward "^" nil t) + (replace-match indent))) + (if (org-bound-and-true-p org-edit-src-picture) + (setq total-nindent (+ total-nindent 2))) + (setq code (buffer-string)) + (set-buffer-modified-p nil)) + (org-src-switch-to-buffer (marker-buffer beg) (or context 'exit)) + (kill-buffer buffer) + (goto-char beg) + (when allow-write-back-p + (delete-region beg end) + (insert code) + (goto-char beg) + (if single (just-one-space))) + (if (memq t (mapcar (lambda (overlay) + (eq (overlay-get overlay 'invisible) + 'org-hide-block)) + (overlays-at (point)))) + ;; Block is hidden; put point at start of block + (beginning-of-line 0) + ;; Block is visible, put point where it was in the code buffer + (org-goto-line (1- (+ (org-current-line) line))) + (org-move-to-column (if preserve-indentation col (+ col total-nindent delta)))) + (move-marker beg nil) + (move-marker end nil)) + (unless (eq context 'save) + (when org-edit-src-saved-temp-window-config + (set-window-configuration org-edit-src-saved-temp-window-config) + (setq org-edit-src-saved-temp-window-config nil)))) + +(defun org-edit-src-save () + "Save parent buffer with current state source-code buffer." + (interactive) + (let ((p (point)) (m (mark)) msg) + (save-window-excursion + (org-edit-src-exit 'save) + (save-buffer) + (setq msg (current-message)) + (if (eq org-src-window-setup 'other-frame) + (let ((org-src-window-setup 'current-window)) + (org-edit-src-code 'save)) + (org-edit-src-code 'save))) + (push-mark m 'nomessage) + (goto-char (min p (point-max))) + (message (or msg "")))) + +(defun org-src-mode-configure-edit-buffer () + (when (org-bound-and-true-p org-edit-src-from-org-mode) + (org-add-hook 'kill-buffer-hook + '(lambda () (delete-overlay org-edit-src-overlay)) nil 'local) + (if (org-bound-and-true-p org-edit-src-allow-write-back-p) + (progn + (setq buffer-offer-save t) + (setq buffer-file-name + (concat (buffer-file-name (marker-buffer org-edit-src-beg-marker)) + "[" (buffer-name) "]")) + (if (featurep 'xemacs) + (progn + (make-variable-buffer-local 'write-contents-hooks) ; needed only for 21.4 + (setq write-contents-hooks '(org-edit-src-save))) + (setq write-contents-functions '(org-edit-src-save)))) + (setq buffer-read-only t)))) + +(org-add-hook 'org-src-mode-hook 'org-src-mode-configure-edit-buffer) + + +(defun org-src-associate-babel-session (info) + "Associate edit buffer with comint session." + (interactive) + (let ((session (cdr (assoc :session (nth 2 info))))) + (and session (not (string= session "none")) + (org-babel-comint-buffer-livep session) + ((lambda (f) (and (fboundp f) (funcall f session))) + (intern (format "org-babel-%s-associate-session" (nth 0 info))))))) + +(defun org-src-babel-configure-edit-buffer () + (when org-src-babel-info + (org-src-associate-babel-session org-src-babel-info))) + +(org-add-hook 'org-src-mode-hook 'org-src-babel-configure-edit-buffer) +(defmacro org-src-do-at-code-block (&rest body) + "Execute a command from an edit buffer in the Org-mode buffer." + `(let ((beg-marker org-edit-src-beg-marker)) + (if beg-marker + (with-current-buffer (marker-buffer beg-marker) + (goto-char (marker-position beg-marker)) + ,@body)))) + +(defun org-src-do-key-sequence-at-code-block (&optional key) + "Execute key sequence at code block in the source Org buffer. +The command bound to KEY in the Org-babel key map is executed +remotely with point temporarily at the start of the code block in +the Org buffer. + +This command is not bound to a key by default, to avoid conflicts +with language major mode bindings. To bind it to C-c @ in all +language major modes, you could use + + (add-hook 'org-src-mode-hook + (lambda () (define-key org-src-mode-map \"\\C-c@\" + 'org-src-do-key-sequence-at-code-block))) + +In that case, for example, C-c @ t issued in code edit buffers +would tangle the current Org code block, C-c @ e would execute +the block and C-c @ h would display the other available +Org-babel commands." + (interactive "kOrg-babel key: ") + (if (equal key (kbd "C-g")) (keyboard-quit) + (org-edit-src-save) + (org-src-do-at-code-block + (call-interactively + (lookup-key org-babel-map key))))) + +(defcustom org-src-tab-acts-natively nil + "If non-nil, the effect of TAB in a code block is as if it were +issued in the language major mode buffer." + :type 'boolean + :group 'org-babel) + +(defun org-src-native-tab-command-maybe () + "Perform language-specific TAB action. +Alter code block according to effect of TAB in the language major +mode." + (and org-src-tab-acts-natively + (let ((org-src-strip-leading-and-trailing-blank-lines nil)) + (org-babel-do-key-sequence-in-edit-buffer (kbd "TAB"))))) + +(add-hook 'org-tab-first-hook 'org-src-native-tab-command-maybe) + +(defun org-src-font-lock-fontify-block (lang start end) + "Fontify code block. +This function is called by emacs automatic fontification, as long +as `org-src-fontify-natively' is non-nil. For manual +fontification of code blocks see `org-src-fontify-block' and +`org-src-fontify-buffer'" + (let* ((lang-mode (org-src-get-lang-mode lang)) + (string (buffer-substring-no-properties start end)) + (modified (buffer-modified-p)) + (org-buffer (current-buffer)) pos next) + (remove-text-properties start end '(face nil)) + (with-current-buffer + (get-buffer-create + (concat " org-src-fontification:" (symbol-name lang-mode))) + (delete-region (point-min) (point-max)) + (insert string) + (unless (eq major-mode lang-mode) (funcall lang-mode)) + (font-lock-fontify-buffer) + (setq pos (point-min)) + (while (setq next (next-single-property-change pos 'face)) + (put-text-property + (+ start (1- pos)) (+ start next) 'face + (get-text-property pos 'face) org-buffer) + (setq pos next))) + (add-text-properties + start end + '(font-lock-fontified t fontified t font-lock-multiline t)) + (set-buffer-modified-p modified)) + t) ;; Tell `org-fontify-meta-lines-and-blocks' that we fontified + +(defun org-src-fontify-block () + "Fontify code block at point." + (interactive) + (save-excursion + (let ((org-src-fontify-natively t) + (info (org-edit-src-find-region-and-lang))) + (font-lock-fontify-region (nth 0 info) (nth 1 info))))) + +(defun org-src-fontify-buffer () + "Fontify all code blocks in the current buffer" + (interactive) + (org-babel-map-src-blocks nil + (org-src-fontify-block))) + +(defun org-src-get-lang-mode (lang) + "Return major mode that should be used for LANG. +LANG is a string, and the returned major mode is a symbol." + (intern + (concat + ((lambda (l) (if (symbolp l) (symbol-name l) l)) + (or (cdr (assoc lang org-src-lang-modes)) lang)) "-mode"))) + +(provide 'org-src) + +;; arch-tag: 6a1fc84f-dec7-47be-a416-64be56bea5d8 +;;; org-src.el ends here diff --git a/.emacs.d/org-7.4/lisp/org-src.elc b/.emacs.d/org-7.4/lisp/org-src.elc Binary files differnew file mode 100644 index 0000000..007e002 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-src.elc diff --git a/.emacs.d/org-7.4/lisp/org-table.el b/.emacs.d/org-7.4/lisp/org-table.el new file mode 100644 index 0000000..116c3fc --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-table.el @@ -0,0 +1,4398 @@ +;;; org-table.el --- The table editor for Org-mode + +;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010 +;; Free Software Foundation, Inc. + +;; Author: Carsten Dominik <carsten at orgmode dot org> +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; Version: 7.4 +;; +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: + +;; This file contains the table editor and spreadsheet for Org-mode. + +;; Watch out: Here we are talking about two different kind of tables. +;; Most of the code is for the tables created with the Org-mode table editor. +;; Sometimes, we talk about tables created and edited with the table.el +;; Emacs package. We call the former org-type tables, and the latter +;; table.el-type tables. + +;;; Code: + +(eval-when-compile + (require 'cl)) +(require 'org) + +(declare-function org-table-clean-before-export "org-exp" + (lines &optional maybe-quoted)) +(declare-function org-format-org-table-html "org-html" (lines &optional splice)) +(defvar orgtbl-mode) ; defined below +(defvar orgtbl-mode-menu) ; defined when orgtbl mode get initialized +(defvar org-export-html-table-tag) ; defined in org-exp.el +(defvar constants-unit-system) + +(defvar orgtbl-after-send-table-hook nil + "Hook for functions attaching to `C-c C-c', if the table is sent. +This can be used to add additional functionality after the table is sent +to the receiver position, othewise, if table is not sent, the functions +are not run.") + +(defcustom orgtbl-optimized (eq org-enable-table-editor 'optimized) + "Non-nil means use the optimized table editor version for `orgtbl-mode'. +In the optimized version, the table editor takes over all simple keys that +normally just insert a character. In tables, the characters are inserted +in a way to minimize disturbing the table structure (i.e. in overwrite mode +for empty fields). Outside tables, the correct binding of the keys is +restored. + +The default for this option is t if the optimized version is also used in +Org-mode. See the variable `org-enable-table-editor' for details. Changing +this variable requires a restart of Emacs to become effective." + :group 'org-table + :type 'boolean) + +(defcustom orgtbl-radio-table-templates + '((latex-mode "% BEGIN RECEIVE ORGTBL %n +% END RECEIVE ORGTBL %n +\\begin{comment} +#+ORGTBL: SEND %n orgtbl-to-latex :splice nil :skip 0 +| | | +\\end{comment}\n") + (texinfo-mode "@c BEGIN RECEIVE ORGTBL %n +@c END RECEIVE ORGTBL %n +@ignore +#+ORGTBL: SEND %n orgtbl-to-html :splice nil :skip 0 +| | | +@end ignore\n") + (html-mode "<!-- BEGIN RECEIVE ORGTBL %n --> +<!-- END RECEIVE ORGTBL %n --> +<!-- +#+ORGTBL: SEND %n orgtbl-to-html :splice nil :skip 0 +| | | +-->\n")) + "Templates for radio tables in different major modes. +All occurrences of %n in a template will be replaced with the name of the +table, obtained by prompting the user." + :group 'org-table + :type '(repeat + (list (symbol :tag "Major mode") + (string :tag "Format")))) + +(defgroup org-table-settings nil + "Settings for tables in Org-mode." + :tag "Org Table Settings" + :group 'org-table) + +(defcustom org-table-default-size "5x2" + "The default size for newly created tables, Columns x Rows." + :group 'org-table-settings + :type 'string) + +(defcustom org-table-number-regexp + "^\\([<>]?[-+^.0-9]*[0-9][-+^.0-9eEdDx()%:]*\\|\\(0[xX]\\)[0-9a-fA-F]+\\|nan\\)$" + "Regular expression for recognizing numbers in table columns. +If a table column contains mostly numbers, it will be aligned to the +right. If not, it will be aligned to the left. + +The default value of this option is a regular expression which allows +anything which looks remotely like a number as used in scientific +context. For example, all of the following will be considered a +number: + 12 12.2 2.4e-08 2x10^12 4.034+-0.02 2.7(10) >3.5 + +Other options offered by the customize interface are more restrictive." + :group 'org-table-settings + :type '(choice + (const :tag "Positive Integers" + "^[0-9]+$") + (const :tag "Integers" + "^[-+]?[0-9]+$") + (const :tag "Floating Point Numbers" + "^[-+]?\\([0-9]*\\.[0-9]+\\|[0-9]+\\.[0-9]*\\)$") + (const :tag "Floating Point Number or Integer" + "^[-+]?\\([0-9]*\\.[0-9]+\\|[0-9]+\\.?[0-9]*\\)$") + (const :tag "Exponential, Floating point, Integer" + "^[-+]?[0-9.]+\\([eEdD][-+0-9]+\\)?$") + (const :tag "Very General Number-Like, including hex" + "^\\([<>]?[-+^.0-9]*[0-9][-+^.0-9eEdDx()%]*\\|\\(0[xX]\\)[0-9a-fA-F]+\\|nan\\)$") + (string :tag "Regexp:"))) + +(defcustom org-table-number-fraction 0.5 + "Fraction of numbers in a column required to make the column align right. +In a column all non-white fields are considered. If at least this +fraction of fields is matched by `org-table-number-fraction', +alignment to the right border applies." + :group 'org-table-settings + :type 'number) + +(defgroup org-table-editing nil + "Behavior of tables during editing in Org-mode." + :tag "Org Table Editing" + :group 'org-table) + +(defcustom org-table-automatic-realign t + "Non-nil means automatically re-align table when pressing TAB or RETURN. +When nil, aligning is only done with \\[org-table-align], or after column +removal/insertion." + :group 'org-table-editing + :type 'boolean) + +(defcustom org-table-auto-blank-field t + "Non-nil means automatically blank table field when starting to type into it. +This only happens when typing immediately after a field motion +command (TAB, S-TAB or RET). +Only relevant when `org-enable-table-editor' is equal to `optimized'." + :group 'org-table-editing + :type 'boolean) + +(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-editing + :type 'boolean) + +(defgroup org-table-calculation nil + "Options concerning tables in Org-mode." + :tag "Org Table Calculation" + :group 'org-table) + +(defcustom org-table-use-standard-references t + "Should org-mode work with table references like B3 instead of @3$2? +Possible values are: +nil never use them +from accept as input, do not present for editing +t: accept as input and present for editing" + :group 'org-table-calculation + :type '(choice + (const :tag "Never, don't even check user input for them" nil) + (const :tag "Always, both as user input, and when editing" t) + (const :tag "Convert user input, don't offer during editing" 'from))) + +(defcustom org-table-copy-increment t + "Non-nil means increment when copying current field with \\[org-table-copy-down]." + :group 'org-table-calculation + :type 'boolean) + +(defcustom org-calc-default-modes + '(calc-internal-prec 12 + calc-float-format (float 8) + calc-angle-mode deg + calc-prefer-frac nil + calc-symbolic-mode nil + calc-date-format (YYYY "-" MM "-" DD " " Www (" " hh ":" mm)) + calc-display-working-message t + ) + "List with Calc mode settings for use in `calc-eval' for table formulas. +The list must contain alternating symbols (Calc modes variables and values). +Don't remove any of the default settings, just change the values. Org-mode +relies on the variables to be present in the list." + :group 'org-table-calculation + :type 'plist) + +(defcustom org-table-formula-evaluate-inline t + "Non-nil means TAB and RET evaluate a formula in current table field. +If the current field starts with an equal sign, it is assumed to be a formula +which should be evaluated as described in the manual and in the documentation +string of the command `org-table-eval-formula'. This feature requires the +Emacs calc package. +When this variable is nil, formula calculation is only available through +the command \\[org-table-eval-formula]." + :group 'org-table-calculation + :type 'boolean) + +(defcustom org-table-formula-use-constants t + "Non-nil means interpret constants in formulas in tables. +A constant looks like `$c' or `$Grav' and will be replaced before evaluation +by the value given in `org-table-formula-constants', or by a value obtained +from the `constants.el' package." + :group 'org-table-calculation + :type 'boolean) + +(defcustom org-table-formula-constants nil + "Alist with constant names and values, for use in table formulas. +The car of each element is a name of a constant, without the `$' before it. +The cdr is the value as a string. For example, if you'd like to use the +speed of light in a formula, you would configure + + (setq org-table-formula-constants '((\"c\" . \"299792458.\"))) + +and then use it in an equation like `$1*$c'. + +Constants can also be defined on a per-file basis using a line like + +#+CONSTANTS: c=299792458. pi=3.14 eps=2.4e-6" + :group 'org-table-calculation + :type '(repeat + (cons (string :tag "name") + (string :tag "value")))) + +(defcustom org-table-allow-automatic-line-recalculation t + "Non-nil means lines marked with |#| or |*| will be recomputed automatically. +Automatically means when TAB or RET or C-c C-c are pressed in the line." + :group 'org-table-calculation + :type 'boolean) + +(defcustom org-table-error-on-row-ref-crossing-hline t + "OBSOLETE VARIABLE, please see `org-table-relative-ref-may-cross-hline'." + :group 'org-table + :type 'boolean) + +(defcustom org-table-relative-ref-may-cross-hline t + "Non-nil means relative formula references may cross hlines. +Here are the allowed values: + +nil Relative references may not cross hlines. They will reference the + field next to the hline instead. Coming from below, the reference + will be to the field below the hline. Coming from above, it will be + to the field above. +t Relative references may cross hlines. +error An attempt to cross a hline will throw an error. + +It is probably good to never set this variable to nil, for the sake of +portability of tables." + :group 'org-table-calculation + :type '(choice + (const :tag "Allow to cross" t) + (const :tag "Stick to hline" nil) + (const :tag "Error on attempt to cross" error))) + +(defgroup org-table-import-export nil + "Options concerning table import and export in Org-mode." + :tag "Org Table Import Export" + :group 'org-table) + +(defcustom org-table-export-default-format "orgtbl-to-tsv" + "Default export parameters for `org-table-export'. +These can be overridden for a specific table by setting the +TABLE_EXPORT_FORMAT property. See the manual section on orgtbl +radio tables for the different export transformations and +available parameters." + :group 'org-table-import-export + :type 'string) + +(defconst org-table-auto-recalculate-regexp "^[ \t]*| *# *\\(|\\|$\\)" + "Detects a table line marked for automatic recalculation.") +(defconst org-table-recalculate-regexp "^[ \t]*| *[#*] *\\(|\\|$\\)" + "Detects a table line marked for automatic recalculation.") +(defconst org-table-calculate-mark-regexp "^[ \t]*| *[!$^_#*] *\\(|\\|$\\)" + "Detects a table line marked for automatic recalculation.") +(defconst org-table-border-regexp "^[ \t]*[^| \t]" + "Searching from within a table (any type) this finds the first line outside the table.") +(defvar org-table-last-highlighted-reference nil) +(defvar org-table-formula-history nil) + +(defvar org-table-column-names nil + "Alist with column names, derived from the `!' line.") +(defvar org-table-column-name-regexp nil + "Regular expression matching the current column names.") +(defvar org-table-local-parameters nil + "Alist with parameter names, derived from the `$' line.") +(defvar org-table-named-field-locations nil + "Alist with locations of named fields.") + +(defvar org-table-current-line-types nil + "Table row types, non-nil only for the duration of a command.") +(defvar org-table-current-begin-line nil + "Table begin line, non-nil only for the duration of a command.") +(defvar org-table-current-begin-pos nil + "Table begin position, non-nil only for the duration of a command.") +(defvar org-table-dlines nil + "Vector of data line line numbers in the current table.") +(defvar org-table-hlines nil + "Vector of hline line numbers in the current table.") + +(defconst org-table-range-regexp + "@\\([-+]?I*[-+]?[0-9]*\\)?\\(\\$[-+]?[0-9]+\\)?\\(\\.\\.@?\\([-+]?I*[-+]?[0-9]*\\)?\\(\\$[-+]?[0-9]+\\)?\\)?" + ;; 1 2 3 4 5 + "Regular expression for matching ranges in formulas.") + +(defconst org-table-range-regexp2 + (concat + "\\(" "@[-0-9I$&]+" "\\|" "[a-zA-Z]\\{1,2\\}\\([0-9]+\\|&\\)" "\\|" "\\$[a-zA-Z0-9]+" "\\)" + "\\.\\." + "\\(" "@?[-0-9I$&]+" "\\|" "[a-zA-Z]\\{1,2\\}\\([0-9]+\\|&\\)" "\\|" "\\$[a-zA-Z0-9]+" "\\)") + "Match a range for reference display.") + +(defun org-table-colgroup-line-p (line) + "Is this a table line colgroup information?" + (save-match-data + (and (string-match "[<>]\\|&[lg]t;" line) + (string-match "\\`[ \t]*|[ \t]*/[ \t]*\\(|[ \t<>0-9|lgt&;]+\\)\\'" + line) + (not (delq + nil + (mapcar + (lambda (s) + (not (member s '("" "<" ">" "<>" "<" ">" "<>")))) + (org-split-string (match-string 1 line) "[ \t]*|[ \t]*"))))))) + +(defun org-table-cookie-line-p (line) + "Is this a table line with only alignment/width cookies?" + (save-match-data + (and (string-match "[<>]\\|&[lg]t;" line) + (or (string-match + "\\`[ \t]*|[ \t]*/[ \t]*\\(|[ \t<>0-9|lrcgt&;]+\\)\\'" line) + (string-match "\\(\\`[ \t<>lrc0-9|gt&;]+\\'\\)" line)) + (not (delq nil (mapcar + (lambda (s) + (not (or (equal s "") + (string-match + "\\`<\\([lrc]?[0-9]+\\|[lrc]\\)>\\'" s) + (string-match + "\\`<\\([lrc]?[0-9]+\\|[lrc]\\)>\\'" + s)))) + (org-split-string (match-string 1 line) + "[ \t]*|[ \t]*"))))))) + +(defconst org-table-translate-regexp + (concat "\\(" "@[-0-9I$]+" "\\|" "[a-zA-Z]\\{1,2\\}\\([0-9]+\\|&\\)" "\\)") + "Match a reference that needs translation, for reference display.") + +(defun org-table-create-with-table.el () + "Use the table.el package to insert a new table. +If there is already a table at point, convert between Org-mode tables +and table.el tables." + (interactive) + (require 'table) + (cond + ((org-at-table.el-p) + (if (y-or-n-p "Convert table to Org-mode table? ") + (org-table-convert))) + ((org-at-table-p) + (when (y-or-n-p "Convert table to table.el table? ") + (org-table-align) + (org-table-convert))) + (t (call-interactively 'table-insert)))) + +(defun org-table-create-or-convert-from-region (arg) + "Convert region to table, or create an empty table. +If there is an active region, convert it to a table, using the function +`org-table-convert-region'. See the documentation of that function +to learn how the prefix argument is interpreted to determine the field +separator. +If there is no such region, create an empty table with `org-table-create'." + (interactive "P") + (if (org-region-active-p) + (org-table-convert-region (region-beginning) (region-end) arg) + (org-table-create arg))) + +(defun org-table-create (&optional size) + "Query for a size and insert a table skeleton. +SIZE is a string Columns x Rows like for example \"3x2\"." + (interactive "P") + (unless size + (setq size (read-string + (concat "Table size Columns x Rows [e.g. " + org-table-default-size "]: ") + "" nil org-table-default-size))) + + (let* ((pos (point)) + (indent (make-string (current-column) ?\ )) + (split (org-split-string size " *x *")) + (rows (string-to-number (nth 1 split))) + (columns (string-to-number (car split))) + (line (concat (apply 'concat indent "|" (make-list columns " |")) + "\n"))) + (if (string-match "^[ \t]*$" (buffer-substring-no-properties + (point-at-bol) (point))) + (beginning-of-line 1) + (newline)) + ;; (mapcar (lambda (x) (insert line)) (make-list rows t)) + (dotimes (i rows) (insert line)) + (goto-char pos) + (if (> rows 1) + ;; Insert a hline after the first row. + (progn + (end-of-line 1) + (insert "\n|-") + (goto-char pos))) + (org-table-align))) + +(defun org-table-convert-region (beg0 end0 &optional separator) + "Convert region to a table. +The region goes from BEG0 to END0, but these borders will be moved +slightly, to make sure a beginning of line in the first line is included. + +SEPARATOR specifies the field separator in the lines. It can have the +following values: + +'(4) Use the comma as a field separator +'(16) Use a TAB as field separator +integer When a number, use that many spaces as field separator +nil When nil, the command tries to be smart and figure out the + separator in the following way: + - when each line contains a TAB, assume TAB-separated material + - when each line contains a comma, assume CSV material + - else, assume one or more SPACE characters as separator." + (interactive "rP") + (let* ((beg (min beg0 end0)) + (end (max beg0 end0)) + re) + (goto-char beg) + (beginning-of-line 1) + (setq beg (move-marker (make-marker) (point))) + (goto-char end) + (if (bolp) (backward-char 1) (end-of-line 1)) + (setq end (move-marker (make-marker) (point))) + ;; Get the right field separator + (unless separator + (goto-char beg) + (setq separator + (cond + ((not (re-search-forward "^[^\n\t]+$" end t)) '(16)) + ((not (re-search-forward "^[^\n,]+$" end t)) '(4)) + (t 1)))) + (goto-char beg) + (if (equal separator '(4)) + (while (< (point) end) + ;; parse the csv stuff + (cond + ((looking-at "^") (insert "| ")) + ((looking-at "[ \t]*$") (replace-match " |") (beginning-of-line 2)) + ((looking-at "[ \t]*\"\\([^\"\n]*\\)\"") + (replace-match "\\1") + (if (looking-at "\"") (insert "\""))) + ((looking-at "[^,\n]+") (goto-char (match-end 0))) + ((looking-at "[ \t]*,") (replace-match " | ")) + (t (beginning-of-line 2)))) + (setq re (cond + ((equal separator '(4)) "^\\|\"?[ \t]*,[ \t]*\"?") + ((equal separator '(16)) "^\\|\t") + ((integerp separator) + (format "^ *\\| *\t *\\| \\{%d,\\}" separator)) + (t (error "This should not happen")))) + (while (re-search-forward re end t) + (replace-match "| " t t))) + (goto-char beg) + (org-table-align))) + +(defun org-table-import (file arg) + "Import FILE as a table. +The file is assumed to be tab-separated. Such files can be produced by most +spreadsheet and database applications. If no tabs (at least one per line) +are found, lines will be split on whitespace into fields." + (interactive "f\nP") + (or (bolp) (newline)) + (let ((beg (point)) + (pm (point-max))) + (insert-file-contents file) + (org-table-convert-region beg (+ (point) (- (point-max) pm)) arg))) + + +(defvar org-table-last-alignment) +(defvar org-table-last-column-widths) +(defun org-table-export (&optional file format) + "Export table to a file, with configurable format. +Such a file can be imported into a spreadsheet program like Excel. +FILE can be the output file name. If not given, it will be taken from +a TABLE_EXPORT_FILE property in the current entry or higher up in the +hierarchy, or the user will be prompted for a file name. +FORMAT can be an export format, of the same kind as it used when +`orgtbl-mode' sends a table in a different format. The default format can +be found in the variable `org-table-export-default-format', but the function +first checks if there is an export format specified in a TABLE_EXPORT_FORMAT +property, locally or anywhere up in the hierarchy." + (interactive) + (unless (org-at-table-p) + (error "No table at point")) + (require 'org-exp) + (org-table-align) ;; make sure we have everything we need + (let* ((beg (org-table-begin)) + (end (org-table-end)) + (txt (buffer-substring-no-properties beg end)) + (file (or file + (condition-case nil + (org-entry-get beg "TABLE_EXPORT_FILE" t) + (error nil)))) + (format (or format + (condition-case nil + (org-entry-get beg "TABLE_EXPORT_FORMAT" t) + (error nil)))) + buf deffmt-readable) + (unless file + (setq file (read-file-name "Export table to: ")) + (unless (or (not (file-exists-p file)) + (y-or-n-p (format "Overwrite file %s? " file))) + (error "Abort"))) + (if (file-directory-p file) + (error "This is a directory path, not a file")) + (if (and (buffer-file-name) + (equal (file-truename file) + (file-truename (buffer-file-name)))) + (error "Please specify a file name that is different from current")) + (unless format + (setq deffmt-readable org-table-export-default-format) + (while (string-match "\t" deffmt-readable) + (setq deffmt-readable (replace-match "\\t" t t deffmt-readable))) + (while (string-match "\n" deffmt-readable) + (setq deffmt-readable (replace-match "\\n" t t deffmt-readable))) + (setq format (org-completing-read + "Format: " + '("orgtbl-to-tsv" "orgtbl-to-csv" + "orgtbl-to-latex" "orgtbl-to-html" + "orgtbl-to-generic" "orgtbl-to-texinfo" + "orgtbl-to-orgtbl") nil nil + deffmt-readable))) + (if (string-match "\\([^ \t\r\n]+\\)\\( +.*\\)?" format) + (let* ((transform (intern (match-string 1 format))) + (params (if (match-end 2) + (read (concat "(" (match-string 2 format) ")")))) + (skip (plist-get params :skip)) + (skipcols (plist-get params :skipcols)) + (lines (nthcdr (or skip 0) (org-split-string txt "[ \t]*\n[ \t]*"))) + (lines (org-table-clean-before-export lines)) + (i0 (if org-table-clean-did-remove-column 2 1)) + (table (mapcar + (lambda (x) + (if (string-match org-table-hline-regexp x) + 'hline + (org-remove-by-index + (org-split-string (org-trim x) "\\s-*|\\s-*") + skipcols i0))) + lines)) + (fun (if (= i0 2) 'cdr 'identity)) + (org-table-last-alignment + (org-remove-by-index (funcall fun org-table-last-alignment) + skipcols i0)) + (org-table-last-column-widths + (org-remove-by-index (funcall fun org-table-last-column-widths) + skipcols i0))) + + (unless (fboundp transform) + (error "No such transformation function %s" transform)) + (setq txt (funcall transform table params)) + + (with-current-buffer (find-file-noselect file) + (setq buf (current-buffer)) + (erase-buffer) + (fundamental-mode) + (insert txt "\n") + (save-buffer)) + (kill-buffer buf) + (message "Export done.")) + (error "TABLE_EXPORT_FORMAT invalid")))) + +(defvar org-table-aligned-begin-marker (make-marker) + "Marker at the beginning of the table last aligned. +Used to check if cursor still is in that table, to minimize realignment.") +(defvar org-table-aligned-end-marker (make-marker) + "Marker at the end of the table last aligned. +Used to check if cursor still is in that table, to minimize realignment.") +(defvar org-table-last-alignment nil + "List of flags for flushright alignment, from the last re-alignment. +This is being used to correctly align a single field after TAB or RET.") +(defvar org-table-last-column-widths nil + "List of max width of fields in each column. +This is being used to correctly align a single field after TAB or RET.") +(defvar org-table-formula-debug nil + "Non-nil means debug table formulas. +When nil, simply write \"#ERROR\" in corrupted fields.") +(make-variable-buffer-local 'org-table-formula-debug) +(defvar org-table-overlay-coordinates nil + "Overlay coordinates after each align of a table.") +(make-variable-buffer-local 'org-table-overlay-coordinates) + +(defvar org-last-recalc-line nil) +(defvar org-table-do-narrow t) ; for dynamic scoping +(defconst org-narrow-column-arrow "=>" + "Used as display property in narrowed table columns.") + +(defun org-table-align () + "Align the table at point by aligning all vertical bars." + (interactive) + (let* ( + ;; Limits of table + (beg (org-table-begin)) + (end (org-table-end)) + ;; Current cursor position + (linepos (org-current-line)) + (colpos (org-table-current-column)) + (winstart (window-start)) + (winstartline (org-current-line (min winstart (1- (point-max))))) + lines (new "") lengths l typenums ty fields maxfields i + column + (indent "") cnt frac + rfmt hfmt + (spaces '(1 . 1)) + (sp1 (car spaces)) + (sp2 (cdr spaces)) + (rfmt1 (concat + (make-string sp2 ?\ ) "%%%s%ds" (make-string sp1 ?\ ) "|")) + (hfmt1 (concat + (make-string sp2 ?-) "%s" (make-string sp1 ?-) "+")) + emptystrings links dates emph raise narrow + falign falign1 fmax f1 len c e space) + (untabify beg end) + (remove-text-properties beg end '(org-cwidth t org-dwidth t display t)) + ;; Check if we have links or dates + (goto-char beg) + (setq links (re-search-forward org-bracket-link-regexp end t)) + (goto-char beg) + (setq emph (and org-hide-emphasis-markers + (re-search-forward org-emph-re end t))) + (goto-char beg) + (setq raise (and org-use-sub-superscripts + (re-search-forward org-match-substring-regexp end t))) + (goto-char beg) + (setq dates (and org-display-custom-times + (re-search-forward org-ts-regexp-both end t))) + ;; Make sure the link properties are right + (when links (goto-char beg) (while (org-activate-bracket-links end))) + ;; Make sure the date properties are right + (when dates (goto-char beg) (while (org-activate-dates end))) + (when emph (goto-char beg) (while (org-do-emphasis-faces end))) + (when raise (goto-char beg) (while (org-raise-scripts end))) + + ;; Check if we are narrowing any columns + (goto-char beg) + (setq narrow (and org-table-do-narrow + org-format-transports-properties-p + (re-search-forward "<[lrc]?[0-9]+>" end t))) + (goto-char beg) + (setq falign (re-search-forward "<[lrc][0-9]*>" end t)) + (goto-char beg) + ;; Get the rows + (setq lines (org-split-string + (buffer-substring beg end) "\n")) + ;; Store the indentation of the first line + (if (string-match "^ *" (car lines)) + (setq indent (make-string (- (match-end 0) (match-beginning 0)) ?\ ))) + ;; Mark the hlines by setting the corresponding element to nil + ;; At the same time, we remove trailing space. + (setq lines (mapcar (lambda (l) + (if (string-match "^ *|-" l) + nil + (if (string-match "[ \t]+$" l) + (substring l 0 (match-beginning 0)) + l))) + lines)) + ;; Get the data fields by splitting the lines. + (setq fields (mapcar + (lambda (l) + (org-split-string l " *| *")) + (delq nil (copy-sequence lines)))) + ;; How many fields in the longest line? + (condition-case nil + (setq maxfields (apply 'max (mapcar 'length fields))) + (error + (kill-region beg end) + (org-table-create org-table-default-size) + (error "Empty table - created default table"))) + ;; A list of empty strings to fill any short rows on output + (setq emptystrings (make-list maxfields "")) + ;; Check for special formatting. + (setq i -1) + (while (< (setq i (1+ i)) maxfields) ;; Loop over all columns + (setq column (mapcar (lambda (x) (or (nth i x) "")) fields)) + ;; Check if there is an explicit width specified + (setq fmax nil) + (when (or narrow falign) + (setq c column fmax nil falign1 nil) + (while c + (setq e (pop c)) + (when (and (stringp e) (string-match "^<\\([lrc]\\)?\\([0-9]+\\)?>$" e)) + (if (match-end 1) (setq falign1 (match-string 1 e))) + (if (and org-table-do-narrow (match-end 2)) + (setq fmax (string-to-number (match-string 2 e)) c nil)))) + ;; Find fields that are wider than fmax, and shorten them + (when fmax + (loop for xx in column do + (when (and (stringp xx) + (> (org-string-width xx) fmax)) + (org-add-props xx nil + 'help-echo + (concat "Clipped table field, use C-c ` to edit. Full value is:\n" (org-no-properties (copy-sequence xx)))) + (setq f1 (min fmax (or (string-match org-bracket-link-regexp xx) fmax))) + (unless (> f1 1) + (error "Cannot narrow field starting with wide link \"%s\"" + (match-string 0 xx))) + (add-text-properties f1 (length xx) (list 'org-cwidth t) xx) + (add-text-properties (- f1 2) f1 + (list 'display org-narrow-column-arrow) + xx))))) + ;; Get the maximum width for each column + (push (apply 'max (or fmax 1) 1 (mapcar 'org-string-width column)) + lengths) + ;; Get the fraction of numbers, to decide about alignment of the column + (if falign1 + (push (equal (downcase falign1) "r") typenums) + (setq cnt 0 frac 0.0) + (loop for x in column do + (if (equal x "") + nil + (setq frac ( / (+ (* frac cnt) + (if (string-match org-table-number-regexp x) 1 0)) + (setq cnt (1+ cnt)))))) + (push (>= frac org-table-number-fraction) typenums))) + (setq lengths (nreverse lengths) typenums (nreverse typenums)) + + ;; Store the alignment of this table, for later editing of single fields + (setq org-table-last-alignment typenums + org-table-last-column-widths lengths) + + ;; With invisible characters, `format' does not get the field width right + ;; So we need to make these fields wide by hand. + (when (or links emph raise) + (loop for i from 0 upto (1- maxfields) do + (setq len (nth i lengths)) + (loop for j from 0 upto (1- (length fields)) do + (setq c (nthcdr i (car (nthcdr j fields)))) + (if (and (stringp (car c)) + (or (text-property-any 0 (length (car c)) + 'invisible 'org-link (car c)) + (text-property-any 0 (length (car c)) + 'org-dwidth t (car c))) + (< (org-string-width (car c)) len)) + (progn + (setq space (make-string (- len (org-string-width (car c))) ?\ )) + (setcar c (if (nth i typenums) + (concat space (car c)) + (concat (car c) space)))))))) + + ;; Compute the formats needed for output of the table + (setq rfmt (concat indent "|") hfmt (concat indent "|")) + (while (setq l (pop lengths)) + (setq ty (if (pop typenums) "" "-")) ; number types flushright + (setq rfmt (concat rfmt (format rfmt1 ty l)) + hfmt (concat hfmt (format hfmt1 (make-string l ?-))))) + (setq rfmt (concat rfmt "\n") + hfmt (concat (substring hfmt 0 -1) "|\n")) + + (setq new (mapconcat + (lambda (l) + (if l (apply 'format rfmt + (append (pop fields) emptystrings)) + hfmt)) + lines "")) + (if (equal (char-before) ?\n) + ;; This hack is for org-indent, to force redisplay of the + ;; line prefix of the first line. Apparently the redisplay + ;; is tied to the newline, which is, I think, a bug. + ;; To force this redisplay, we remove and re-insert the + ;; newline, so that the redisplay engine thinks it belongs + ;; to the changed text. + (progn + (backward-delete-char 1) + (insert "\n"))) + (move-marker org-table-aligned-begin-marker (point)) + (insert new) + ;; Replace the old one + (delete-region (point) end) + (move-marker end nil) + (move-marker org-table-aligned-end-marker (point)) + (when (and orgtbl-mode (not (org-mode-p))) + (goto-char org-table-aligned-begin-marker) + (while (org-hide-wide-columns org-table-aligned-end-marker))) + ;; Try to move to the old location + (org-goto-line winstartline) + (setq winstart (point-at-bol)) + (org-goto-line linepos) + (set-window-start (selected-window) winstart 'noforce) + (org-table-goto-column colpos) + (and org-table-overlay-coordinates (org-table-overlay-coordinates)) + (setq org-table-may-need-update nil) + )) + +(defun org-table-begin (&optional table-type) + "Find the beginning of the table and return its position. +With argument TABLE-TYPE, go to the beginning of a table.el-type table." + (save-excursion + (if (not (re-search-backward + (if table-type org-table-any-border-regexp + org-table-border-regexp) + nil t)) + (progn (goto-char (point-min)) (point)) + (goto-char (match-beginning 0)) + (beginning-of-line 2) + (point)))) + +(defun org-table-end (&optional table-type) + "Find the end of the table and return its position. +With argument TABLE-TYPE, go to the end of a table.el-type table." + (save-excursion + (if (not (re-search-forward + (if table-type org-table-any-border-regexp + org-table-border-regexp) + nil t)) + (goto-char (point-max)) + (goto-char (match-beginning 0))) + (point-marker))) + +(defun org-table-justify-field-maybe (&optional new) + "Justify the current field, text to left, number to right. +Optional argument NEW may specify text to replace the current field content." + (cond + ((and (not new) org-table-may-need-update)) ; Realignment will happen anyway + ((org-at-table-hline-p)) + ((and (not new) + (or (not (equal (marker-buffer org-table-aligned-begin-marker) + (current-buffer))) + (< (point) org-table-aligned-begin-marker) + (>= (point) org-table-aligned-end-marker))) + ;; This is not the same table, force a full re-align + (setq org-table-may-need-update t)) + (t ;; realign the current field, based on previous full realign + (let* ((pos (point)) s + (col (org-table-current-column)) + (num (if (> col 0) (nth (1- col) org-table-last-alignment))) + l f n o e) + (when (> col 0) + (skip-chars-backward "^|\n") + (if (looking-at " *\\([^|\n]*?\\) *\\(|\\|$\\)") + (progn + (setq s (match-string 1) + o (match-string 0) + l (max 1 (- (match-end 0) (match-beginning 0) 3)) + e (not (= (match-beginning 2) (match-end 2)))) + (setq f (format (if num " %%%ds %s" " %%-%ds %s") + l (if e "|" (setq org-table-may-need-update t) "")) + n (format f s)) + (if new + (if (<= (length new) l) ;; FIXME: length -> str-width? + (setq n (format f new)) + (setq n (concat new "|") org-table-may-need-update t))) + (if (equal (string-to-char n) ?-) (setq n (concat " " n))) + (or (equal n o) + (let (org-table-may-need-update) + (replace-match n t t)))) + (setq org-table-may-need-update t)) + (goto-char pos)))))) + +(defun org-table-next-field () + "Go to the next field in the current table, creating new lines as needed. +Before doing so, re-align the table if necessary." + (interactive) + (org-table-maybe-eval-formula) + (org-table-maybe-recalculate-line) + (if (and org-table-automatic-realign + org-table-may-need-update) + (org-table-align)) + (let ((end (org-table-end))) + (if (org-at-table-hline-p) + (end-of-line 1)) + (condition-case nil + (progn + (re-search-forward "|" end) + (if (looking-at "[ \t]*$") + (re-search-forward "|" end)) + (if (and (looking-at "-") + org-table-tab-jumps-over-hlines + (re-search-forward "^[ \t]*|\\([^-]\\)" end t)) + (goto-char (match-beginning 1))) + (if (looking-at "-") + (progn + (beginning-of-line 0) + (org-table-insert-row 'below)) + (if (looking-at " ") (forward-char 1)))) + (error + (org-table-insert-row 'below))))) + +(defun org-table-previous-field () + "Go to the previous field in the table. +Before doing so, re-align the table if necessary." + (interactive) + (org-table-justify-field-maybe) + (org-table-maybe-recalculate-line) + (if (and org-table-automatic-realign + org-table-may-need-update) + (org-table-align)) + (if (org-at-table-hline-p) + (end-of-line 1)) + (condition-case nil + (progn + (re-search-backward "|" (org-table-begin)) + (re-search-backward "|" (org-table-begin))) + (error (error "Cannot move to previous table field"))) + (while (looking-at "|\\(-\\|[ \t]*$\\)") + (re-search-backward "|" (org-table-begin))) + (if (looking-at "| ?") + (goto-char (match-end 0)))) + +(defun org-table-beginning-of-field (&optional n) + "Move to the end of the current table field. +If already at or after the end, move to the end of the next table field. +With numeric argument N, move N-1 fields forward first." + (interactive "p") + (let ((pos (point))) + (while (> n 1) + (setq n (1- n)) + (org-table-previous-field)) + (if (not (re-search-backward "|" (point-at-bol 0) t)) + (error "No more table fields before the current") + (goto-char (match-end 0)) + (and (looking-at " ") (forward-char 1))) + (if (>= (point) pos) (org-table-beginning-of-field 2)))) + +(defun org-table-end-of-field (&optional n) + "Move to the beginning of the current table field. +If already at or before the beginning, move to the beginning of the +previous field. +With numeric argument N, move N-1 fields backward first." + (interactive "p") + (let ((pos (point))) + (while (> n 1) + (setq n (1- n)) + (org-table-next-field)) + (when (re-search-forward "|" (point-at-eol 1) t) + (backward-char 1) + (skip-chars-backward " ") + (if (and (equal (char-before (point)) ?|) (looking-at " ")) + (forward-char 1))) + (if (<= (point) pos) (org-table-end-of-field 2)))) + +(defun org-table-next-row () + "Go to the next row (same column) in the current table. +Before doing so, re-align the table if necessary." + (interactive) + (org-table-maybe-eval-formula) + (org-table-maybe-recalculate-line) + (if (or (looking-at "[ \t]*$") + (save-excursion (skip-chars-backward " \t") (bolp))) + (newline) + (if (and org-table-automatic-realign + org-table-may-need-update) + (org-table-align)) + (let ((col (org-table-current-column))) + (beginning-of-line 2) + (if (or (not (org-at-table-p)) + (org-at-table-hline-p)) + (progn + (beginning-of-line 0) + (org-table-insert-row 'below))) + (org-table-goto-column col) + (skip-chars-backward "^|\n\r") + (if (looking-at " ") (forward-char 1))))) + +(defun org-table-copy-down (n) + "Copy a field down in the current column. +If the field at the cursor is empty, copy into it the content of the nearest +non-empty field above. With argument N, use the Nth non-empty field. +If the current field is not empty, it is copied down to the next row, and +the cursor is moved with it. Therefore, repeating this command causes the +column to be filled row-by-row. +If the variable `org-table-copy-increment' is non-nil and the field is an +integer or a timestamp, it will be incremented while copying. In the case of +a timestamp, if the cursor is on the year, change the year. If it is on the +month or the day, change that. Point will stay on the current date field +in order to easily repeat the interval." + (interactive "p") + (let* ((colpos (org-table-current-column)) + (col (current-column)) + (field (org-table-get-field)) + (non-empty (string-match "[^ \t]" field)) + (beg (org-table-begin)) + (orig-n n) + txt) + (org-table-check-inside-data-field) + (if non-empty + (progn + (setq txt (org-trim field)) + (org-table-next-row) + (org-table-blank-field)) + (save-excursion + (setq txt + (catch 'exit + (while (progn (beginning-of-line 1) + (re-search-backward org-table-dataline-regexp + beg t)) + (org-table-goto-column colpos t) + (if (and (looking-at + "|[ \t]*\\([^| \t][^|]*?\\)[ \t]*|") + (<= (setq n (1- n)) 0)) + (throw 'exit (match-string 1)))))))) + (if txt + (progn + (if (and org-table-copy-increment + (not (equal orig-n 0)) + (string-match "^[0-9]+$" txt) + (< (string-to-number txt) 100000000)) + (setq txt (format "%d" (+ (string-to-number txt) 1)))) + (insert txt) + (org-move-to-column col) + (if (and org-table-copy-increment (org-at-timestamp-p t)) + (org-timestamp-up-day) + (org-table-maybe-recalculate-line)) + (org-table-align) + (org-move-to-column col)) + (error "No non-empty field found")))) + +(defun org-table-check-inside-data-field () + "Is point inside a table data field? +I.e. not on a hline or before the first or after the last column? +This actually throws an error, so it aborts the current command." + (if (or (not (org-at-table-p)) + (= (org-table-current-column) 0) + (org-at-table-hline-p) + (looking-at "[ \t]*$")) + (error "Not in table data field"))) + +(defvar org-table-clip nil + "Clipboard for table regions.") + +(defun org-table-get (line column) + "Get the field in table line LINE, column COLUMN. +If LINE is larger than the number of data lines in the table, the function +returns nil. However, if COLUMN is too large, we will simply return an +empty string. +If LINE is nil, use the current line. +If column is nil, use the current column." + (setq column (or column (org-table-current-column))) + (save-excursion + (and (or (not line) (org-table-goto-line line)) + (org-trim (org-table-get-field column))))) + +(defun org-table-put (line column value &optional align) + "Put VALUE into line LINE, column COLUMN. +When ALIGN is set, also realign the table." + (setq column (or column (org-table-current-column))) + (prog1 (save-excursion + (and (or (not line) (org-table-goto-line line)) + (progn (org-table-goto-column column nil 'force) t) + (org-table-get-field column value))) + (and align (org-table-align)))) + +(defun org-table-current-line () + "Return the index of the current data line." + (let ((pos (point)) (end (org-table-end)) (cnt 0)) + (save-excursion + (goto-char (org-table-begin)) + (while (and (re-search-forward org-table-dataline-regexp end t) + (setq cnt (1+ cnt)) + (< (point-at-eol) pos)))) + cnt)) + +(defun org-table-goto-line (N) + "Go to the Nth data line in the current table. +Return t when the line exists, nil if it does not exist." + (goto-char (org-table-begin)) + (let ((end (org-table-end)) (cnt 0)) + (while (and (re-search-forward org-table-dataline-regexp end t) + (< (setq cnt (1+ cnt)) N))) + (= cnt N))) + +(defun org-table-blank-field () + "Blank the current table field or active region." + (interactive) + (org-table-check-inside-data-field) + (if (and (interactive-p) (org-region-active-p)) + (let (org-table-clip) + (org-table-cut-region (region-beginning) (region-end))) + (skip-chars-backward "^|") + (backward-char 1) + (if (looking-at "|[^|\n]+") + (let* ((pos (match-beginning 0)) + (match (match-string 0)) + (len (org-string-width match))) + (replace-match (concat "|" (make-string (1- len) ?\ ))) + (goto-char (+ 2 pos)) + (substring match 1))))) + +(defun org-table-get-field (&optional n replace) + "Return the value of the field in column N of current row. +N defaults to current field. +If REPLACE is a string, replace field with this value. The return value +is always the old value." + (and n (org-table-goto-column n)) + (skip-chars-backward "^|\n") + (backward-char 1) + (if (looking-at "|[^|\r\n]*") + (let* ((pos (match-beginning 0)) + (val (buffer-substring (1+ pos) (match-end 0)))) + (if replace + (replace-match (concat "|" replace) t t)) + (goto-char (min (point-at-eol) (+ 2 pos))) + val) + (forward-char 1) "")) + +(defun org-table-field-info (arg) + "Show info about the current field, and highlight any reference at point." + (interactive "P") + (org-table-get-specials) + (save-excursion + (let* ((pos (point)) + (col (org-table-current-column)) + (cname (car (rassoc (int-to-string col) org-table-column-names))) + (name (car (rassoc (list (org-current-line) col) + org-table-named-field-locations))) + (eql (org-table-get-stored-formulas)) + (dline (org-table-current-dline)) + (ref (format "@%d$%d" dline col)) + (ref1 (org-table-convert-refs-to-an ref)) + (fequation (or (assoc name eql) (assoc ref eql))) + (cequation (assoc (int-to-string col) eql)) + (eqn (or fequation cequation))) + (goto-char pos) + (condition-case nil + (org-table-show-reference 'local) + (error nil)) + (message "line @%d, col $%s%s, ref @%d$%d or %s%s%s" + dline col + (if cname (concat " or $" cname) "") + dline col ref1 + (if name (concat " or $" name) "") + ;; FIXME: formula info not correct if special table line + (if eqn + (concat ", formula: " + (org-table-formula-to-user + (concat + (if (string-match "^[$@]"(car eqn)) "" "$") + (car eqn) "=" (cdr eqn)))) + ""))))) + +(defun org-table-current-column () + "Find out which column we are in." + (interactive) + (if (interactive-p) (org-table-check-inside-data-field)) + (save-excursion + (let ((cnt 0) (pos (point))) + (beginning-of-line 1) + (while (search-forward "|" pos t) + (setq cnt (1+ cnt))) + (if (interactive-p) (message "In table column %d" cnt)) + cnt))) + +(defun org-table-current-dline () + "Find out what table data line we are in. +Only data lines count for this." + (interactive) + (if (interactive-p) (org-table-check-inside-data-field)) + (save-excursion + (let ((cnt 0) (pos (point))) + (goto-char (org-table-begin)) + (while (<= (point) pos) + (if (looking-at org-table-dataline-regexp) (setq cnt (1+ cnt))) + (beginning-of-line 2)) + (if (interactive-p) (message "This is table line %d" cnt)) + cnt))) + +(defun org-table-goto-column (n &optional on-delim force) + "Move the cursor to the Nth column in the current table line. +With optional argument ON-DELIM, stop with point before the left delimiter +of the field. +If there are less than N fields, just go to after the last delimiter. +However, when FORCE is non-nil, create new columns if necessary." + (interactive "p") + (beginning-of-line 1) + (when (> n 0) + (while (and (> (setq n (1- n)) -1) + (or (search-forward "|" (point-at-eol) t) + (and force + (progn (end-of-line 1) + (skip-chars-backward "^|") + (insert " | ") + t))))) + (when (and force (not (looking-at ".*|"))) + (save-excursion (end-of-line 1) (insert " | "))) + (if on-delim + (backward-char 1) + (if (looking-at " ") (forward-char 1))))) + +(defun org-table-insert-column () + "Insert a new column into the table." + (interactive) + (if (not (org-at-table-p)) + (error "Not at a table")) + (org-table-find-dataline) + (let* ((col (max 1 (org-table-current-column))) + (beg (org-table-begin)) + (end (org-table-end)) + ;; Current cursor position + (linepos (org-current-line)) + (colpos col)) + (goto-char beg) + (while (< (point) end) + (if (org-at-table-hline-p) + nil + (org-table-goto-column col t) + (insert "| ")) + (beginning-of-line 2)) + (move-marker end nil) + (org-goto-line linepos) + (org-table-goto-column colpos) + (org-table-align) + (org-table-fix-formulas "$" nil (1- col) 1) + (org-table-fix-formulas "$LR" nil (1- col) 1))) + +(defun org-table-find-dataline () + "Find a data line in the current table, which is needed for column commands." + (if (and (org-at-table-p) + (not (org-at-table-hline-p))) + t + (let ((col (current-column)) + (end (org-table-end))) + (org-move-to-column col) + (while (and (< (point) end) + (or (not (= (current-column) col)) + (org-at-table-hline-p))) + (beginning-of-line 2) + (org-move-to-column col)) + (if (and (org-at-table-p) + (not (org-at-table-hline-p))) + t + (error + "Please position cursor in a data line for column operations"))))) + +(defun org-table-delete-column () + "Delete a column from the table." + (interactive) + (if (not (org-at-table-p)) + (error "Not at a table")) + (org-table-find-dataline) + (org-table-check-inside-data-field) + (let* ((col (org-table-current-column)) + (beg (org-table-begin)) + (end (org-table-end)) + ;; Current cursor position + (linepos (org-current-line)) + (colpos col)) + (goto-char beg) + (while (< (point) end) + (if (org-at-table-hline-p) + nil + (org-table-goto-column col t) + (and (looking-at "|[^|\n]+|") + (replace-match "|"))) + (beginning-of-line 2)) + (move-marker end nil) + (org-goto-line linepos) + (org-table-goto-column colpos) + (org-table-align) + (org-table-fix-formulas "$" (list (cons (number-to-string col) "INVALID")) + col -1 col) + (org-table-fix-formulas "$LR" (list (cons (number-to-string col) "INVALID")) + col -1 col))) + +(defun org-table-move-column-right () + "Move column to the right." + (interactive) + (org-table-move-column nil)) +(defun org-table-move-column-left () + "Move column to the left." + (interactive) + (org-table-move-column 'left)) + +(defun org-table-move-column (&optional left) + "Move the current column to the right. With arg LEFT, move to the left." + (interactive "P") + (if (not (org-at-table-p)) + (error "Not at a table")) + (org-table-find-dataline) + (org-table-check-inside-data-field) + (let* ((col (org-table-current-column)) + (col1 (if left (1- col) col)) + (beg (org-table-begin)) + (end (org-table-end)) + ;; Current cursor position + (linepos (org-current-line)) + (colpos (if left (1- col) (1+ col)))) + (if (and left (= col 1)) + (error "Cannot move column further left")) + (if (and (not left) (looking-at "[^|\n]*|[^|\n]*$")) + (error "Cannot move column further right")) + (goto-char beg) + (while (< (point) end) + (if (org-at-table-hline-p) + nil + (org-table-goto-column col1 t) + (and (looking-at "|\\([^|\n]+\\)|\\([^|\n]+\\)|") + (replace-match "|\\2|\\1|"))) + (beginning-of-line 2)) + (move-marker end nil) + (org-goto-line linepos) + (org-table-goto-column colpos) + (org-table-align) + (org-table-fix-formulas + "$" (list (cons (number-to-string col) (number-to-string colpos)) + (cons (number-to-string colpos) (number-to-string col)))) + (org-table-fix-formulas + "$LR" (list (cons (number-to-string col) (number-to-string colpos)) + (cons (number-to-string colpos) (number-to-string col)))))) + +(defun org-table-move-row-down () + "Move table row down." + (interactive) + (org-table-move-row nil)) +(defun org-table-move-row-up () + "Move table row up." + (interactive) + (org-table-move-row 'up)) + +(defun org-table-move-row (&optional up) + "Move the current table line down. With arg UP, move it up." + (interactive "P") + (let* ((col (current-column)) + (pos (point)) + (hline1p (save-excursion (beginning-of-line 1) + (looking-at org-table-hline-regexp))) + (dline1 (org-table-current-dline)) + (dline2 (+ dline1 (if up -1 1))) + (tonew (if up 0 2)) + txt hline2p) + (beginning-of-line tonew) + (unless (org-at-table-p) + (goto-char pos) + (error "Cannot move row further")) + (setq hline2p (looking-at org-table-hline-regexp)) + (goto-char pos) + (beginning-of-line 1) + (setq pos (point)) + (setq txt (buffer-substring (point) (1+ (point-at-eol)))) + (delete-region (point) (1+ (point-at-eol))) + (beginning-of-line tonew) + (insert txt) + (beginning-of-line 0) + (org-move-to-column col) + (unless (or hline1p hline2p) + (org-table-fix-formulas + "@" (list (cons (number-to-string dline1) (number-to-string dline2)) + (cons (number-to-string dline2) (number-to-string dline1))))))) + +(defun org-table-insert-row (&optional arg) + "Insert a new row above the current line into the table. +With prefix ARG, insert below the current line." + (interactive "P") + (if (not (org-at-table-p)) + (error "Not at a table")) + (let* ((line (buffer-substring (point-at-bol) (point-at-eol))) + (new (org-table-clean-line line))) + ;; Fix the first field if necessary + (if (string-match "^[ \t]*| *[#$] *|" line) + (setq new (replace-match (match-string 0 line) t t new))) + (beginning-of-line (if arg 2 1)) + (let (org-table-may-need-update) (insert-before-markers new "\n")) + (beginning-of-line 0) + (re-search-forward "| ?" (point-at-eol) t) + (and (or org-table-may-need-update org-table-overlay-coordinates) + (org-table-align)) + (org-table-fix-formulas "@" nil (1- (org-table-current-dline)) 1))) + +(defun org-table-insert-hline (&optional above) + "Insert a horizontal-line below the current line into the table. +With prefix ABOVE, insert above the current line." + (interactive "P") + (if (not (org-at-table-p)) + (error "Not at a table")) + (when (eobp) (insert "\n") (backward-char 1)) + (if (not (string-match "|[ \t]*$" (org-current-line-string))) + (org-table-align)) + (let ((line (org-table-clean-line + (buffer-substring (point-at-bol) (point-at-eol)))) + (col (current-column))) + (while (string-match "|\\( +\\)|" line) + (setq line (replace-match + (concat "+" (make-string (- (match-end 1) (match-beginning 1)) + ?-) "|") t t line))) + (and (string-match "\\+" line) (setq line (replace-match "|" t t line))) + (beginning-of-line (if above 1 2)) + (insert line "\n") + (beginning-of-line (if above 1 -1)) + (org-move-to-column col) + (and org-table-overlay-coordinates (org-table-align)))) + +(defun org-table-hline-and-move (&optional same-column) + "Insert a hline and move to the row below that line." + (interactive "P") + (let ((col (org-table-current-column))) + (org-table-maybe-eval-formula) + (org-table-maybe-recalculate-line) + (org-table-insert-hline) + (end-of-line 2) + (if (looking-at "\n[ \t]*|-") + (progn (insert "\n|") (org-table-align)) + (org-table-next-field)) + (if same-column (org-table-goto-column col)))) + +(defun org-table-clean-line (s) + "Convert a table line S into a string with only \"|\" and space. +In particular, this does handle wide and invisible characters." + (if (string-match "^[ \t]*|-" s) + ;; It's a hline, just map the characters + (setq s (mapconcat (lambda (x) (if (member x '(?| ?+)) "|" " ")) s "")) + (while (string-match "|\\([ \t]*?[^ \t\r\n|][^\r\n|]*\\)|" s) + (setq s (replace-match + (concat "|" (make-string (org-string-width (match-string 1 s)) + ?\ ) "|") + t t s))) + s)) + +(defun org-table-kill-row () + "Delete the current row or horizontal line from the table." + (interactive) + (if (not (org-at-table-p)) + (error "Not at a table")) + (let ((col (current-column)) + (dline (org-table-current-dline))) + (kill-region (point-at-bol) (min (1+ (point-at-eol)) (point-max))) + (if (not (org-at-table-p)) (beginning-of-line 0)) + (org-move-to-column col) + (org-table-fix-formulas "@" (list (cons (number-to-string dline) "INVALID")) + dline -1 dline))) + +(defun org-table-sort-lines (with-case &optional sorting-type) + "Sort table lines according to the column at point. + +The position of point indicates the column to be used for +sorting, and the range of lines is the range between the nearest +horizontal separator lines, or the entire table of no such lines +exist. If point is before the first column, you will be prompted +for the sorting column. If there is an active region, the mark +specifies the first line and the sorting column, while point +should be in the last line to be included into the sorting. + +The command then prompts for the sorting type which can be +alphabetically, numerically, or by time (as given in a time stamp +in the field). Sorting in reverse order is also possible. + +With prefix argument WITH-CASE, alphabetic sorting will be case-sensitive. + +If SORTING-TYPE is specified when this function is called from a Lisp +program, no prompting will take place. SORTING-TYPE must be a character, +any of (?a ?A ?n ?N ?t ?T) where the capital letter indicate that sorting +should be done in reverse order." + (interactive "P") + (let* ((thisline (org-current-line)) + (thiscol (org-table-current-column)) + beg end bcol ecol tend tbeg column lns pos) + (when (equal thiscol 0) + (if (interactive-p) + (setq thiscol + (string-to-number + (read-string "Use column N for sorting: "))) + (setq thiscol 1)) + (org-table-goto-column thiscol)) + (org-table-check-inside-data-field) + (if (org-region-active-p) + (progn + (setq beg (region-beginning) end (region-end)) + (goto-char beg) + (setq column (org-table-current-column) + beg (point-at-bol)) + (goto-char end) + (setq end (point-at-bol 2))) + (setq column (org-table-current-column) + pos (point) + tbeg (org-table-begin) + tend (org-table-end)) + (if (re-search-backward org-table-hline-regexp tbeg t) + (setq beg (point-at-bol 2)) + (goto-char tbeg) + (setq beg (point-at-bol 1))) + (goto-char pos) + (if (re-search-forward org-table-hline-regexp tend t) + (setq end (point-at-bol 1)) + (goto-char tend) + (setq end (point-at-bol)))) + (setq beg (move-marker (make-marker) beg) + end (move-marker (make-marker) end)) + (untabify beg end) + (goto-char beg) + (org-table-goto-column column) + (skip-chars-backward "^|") + (setq bcol (current-column)) + (org-table-goto-column (1+ column)) + (skip-chars-backward "^|") + (setq ecol (1- (current-column))) + (org-table-goto-column column) + (setq lns (mapcar (lambda(x) (cons + (org-sort-remove-invisible + (nth (1- column) + (org-split-string x "[ \t]*|[ \t]*"))) + x)) + (org-split-string (buffer-substring beg end) "\n"))) + (setq lns (org-do-sort lns "Table" with-case sorting-type)) + (delete-region beg end) + (move-marker beg nil) + (move-marker end nil) + (insert (mapconcat 'cdr lns "\n") "\n") + (org-goto-line thisline) + (org-table-goto-column thiscol) + (message "%d lines sorted, based on column %d" (length lns) column))) + + +(defun org-table-cut-region (beg end) + "Copy region in table to the clipboard and blank all relevant fields. +If there is no active region, use just the field at point." + (interactive (list + (if (org-region-active-p) (region-beginning) (point)) + (if (org-region-active-p) (region-end) (point)))) + (org-table-copy-region beg end 'cut)) + +(defun org-table-copy-region (beg end &optional cut) + "Copy rectangular region in table to clipboard. +A special clipboard is used which can only be accessed +with `org-table-paste-rectangle'." + (interactive (list + (if (org-region-active-p) (region-beginning) (point)) + (if (org-region-active-p) (region-end) (point)) + current-prefix-arg)) + (let* (l01 c01 l02 c02 l1 c1 l2 c2 ic1 ic2 + region cols + (rpl (if cut " " nil))) + (goto-char beg) + (org-table-check-inside-data-field) + (setq l01 (org-current-line) + c01 (org-table-current-column)) + (goto-char end) + (org-table-check-inside-data-field) + (setq l02 (org-current-line) + c02 (org-table-current-column)) + (setq l1 (min l01 l02) l2 (max l01 l02) + c1 (min c01 c02) c2 (max c01 c02)) + (catch 'exit + (while t + (catch 'nextline + (if (> l1 l2) (throw 'exit t)) + (org-goto-line l1) + (if (org-at-table-hline-p) (throw 'nextline (setq l1 (1+ l1)))) + (setq cols nil ic1 c1 ic2 c2) + (while (< ic1 (1+ ic2)) + (push (org-table-get-field ic1 rpl) cols) + (setq ic1 (1+ ic1))) + (push (nreverse cols) region) + (setq l1 (1+ l1))))) + (setq org-table-clip (nreverse region)) + (if cut (org-table-align)) + org-table-clip)) + +(defun org-table-paste-rectangle () + "Paste a rectangular region into a table. +The upper right corner ends up in the current field. All involved fields +will be overwritten. If the rectangle does not fit into the present table, +the table is enlarged as needed. The process ignores horizontal separator +lines." + (interactive) + (unless (and org-table-clip (listp org-table-clip)) + (error "First cut/copy a region to paste!")) + (org-table-check-inside-data-field) + (let* ((clip org-table-clip) + (line (org-current-line)) + (col (org-table-current-column)) + (org-enable-table-editor t) + (org-table-automatic-realign nil) + c cols field) + (while (setq cols (pop clip)) + (while (org-at-table-hline-p) (beginning-of-line 2)) + (if (not (org-at-table-p)) + (progn (end-of-line 0) (org-table-next-field))) + (setq c col) + (while (setq field (pop cols)) + (org-table-goto-column c nil 'force) + (org-table-get-field nil field) + (setq c (1+ c))) + (beginning-of-line 2)) + (org-goto-line line) + (org-table-goto-column col) + (org-table-align))) + +(defun org-table-convert () + "Convert from `org-mode' table to table.el and back. +Obviously, this only works within limits. When an Org-mode table is +converted to table.el, all horizontal separator lines get lost, because +table.el uses these as cell boundaries and has no notion of horizontal lines. +A table.el table can be converted to an Org-mode table only if it does not +do row or column spanning. Multiline cells will become multiple cells. +Beware, Org-mode does not test if the table can be successfully converted - it +blindly applies a recipe that works for simple tables." + (interactive) + (require 'table) + (if (org-at-table.el-p) + ;; convert to Org-mode table + (let ((beg (move-marker (make-marker) (org-table-begin t))) + (end (move-marker (make-marker) (org-table-end t)))) + (table-unrecognize-region beg end) + (goto-char beg) + (while (re-search-forward "^\\([ \t]*\\)\\+-.*\n" end t) + (replace-match "")) + (goto-char beg)) + (if (org-at-table-p) + ;; convert to table.el table + (let ((beg (move-marker (make-marker) (org-table-begin))) + (end (move-marker (make-marker) (org-table-end)))) + ;; first, get rid of all horizontal lines + (goto-char beg) + (while (re-search-forward "^\\([ \t]*\\)|-.*\n" end t) + (replace-match "")) + ;; insert a hline before first + (goto-char beg) + (org-table-insert-hline 'above) + (beginning-of-line -1) + ;; insert a hline after each line + (while (progn (beginning-of-line 3) (< (point) end)) + (org-table-insert-hline)) + (goto-char beg) + (setq end (move-marker end (org-table-end))) + ;; replace "+" at beginning and ending of hlines + (while (re-search-forward "^\\([ \t]*\\)|-" end t) + (replace-match "\\1+-")) + (goto-char beg) + (while (re-search-forward "-|[ \t]*$" end t) + (replace-match "-+")) + (goto-char beg))))) + +(defun org-table-wrap-region (arg) + "Wrap several fields in a column like a paragraph. +This is useful if you'd like to spread the contents of a field over several +lines, in order to keep the table compact. + +If there is an active region, and both point and mark are in the same column, +the text in the column is wrapped to minimum width for the given number of +lines. Generally, this makes the table more compact. A prefix ARG may be +used to change the number of desired lines. For example, `C-2 \\[org-table-wrap]' +formats the selected text to two lines. If the region was longer than two +lines, the remaining lines remain empty. A negative prefix argument reduces +the current number of lines by that amount. The wrapped text is pasted back +into the table. If you formatted it to more lines than it was before, fields +further down in the table get overwritten - so you might need to make space in +the table first. + +If there is no region, the current field is split at the cursor position and +the text fragment to the right of the cursor is prepended to the field one +line down. + +If there is no region, but you specify a prefix ARG, the current field gets +blank, and the content is appended to the field above." + (interactive "P") + (org-table-check-inside-data-field) + (if (org-region-active-p) + ;; There is a region: fill as a paragraph + (let* ((beg (region-beginning)) + (cline (save-excursion (goto-char beg) (org-current-line))) + (ccol (save-excursion (goto-char beg) (org-table-current-column))) + nlines) + (org-table-cut-region (region-beginning) (region-end)) + (if (> (length (car org-table-clip)) 1) + (error "Region must be limited to single column")) + (setq nlines (if arg + (if (< arg 1) + (+ (length org-table-clip) arg) + arg) + (length org-table-clip))) + (setq org-table-clip + (mapcar 'list (org-wrap (mapconcat 'car org-table-clip " ") + nil nlines))) + (org-goto-line cline) + (org-table-goto-column ccol) + (org-table-paste-rectangle)) + ;; No region, split the current field at point + (unless (org-get-alist-option org-M-RET-may-split-line 'table) + (skip-chars-forward "^\r\n|")) + (if arg + ;; combine with field above + (let ((s (org-table-blank-field)) + (col (org-table-current-column))) + (beginning-of-line 0) + (while (org-at-table-hline-p) (beginning-of-line 0)) + (org-table-goto-column col) + (skip-chars-forward "^|") + (skip-chars-backward " ") + (insert " " (org-trim s)) + (org-table-align)) + ;; split field + (if (looking-at "\\([^|]+\\)+|") + (let ((s (match-string 1))) + (replace-match " |") + (goto-char (match-beginning 0)) + (org-table-next-row) + (insert (org-trim s) " ") + (org-table-align)) + (org-table-next-row))))) + +(defvar org-field-marker nil) + +(defun org-table-edit-field (arg) + "Edit table field in a different window. +This is mainly useful for fields that contain hidden parts. +When called with a \\[universal-argument] prefix, just make the full field visible so that +it can be edited in place." + (interactive "P") + (if arg + (let ((b (save-excursion (skip-chars-backward "^|") (point))) + (e (save-excursion (skip-chars-forward "^|\r\n") (point)))) + (remove-text-properties b e '(org-cwidth t invisible t + display t intangible t)) + (if (and (boundp 'font-lock-mode) font-lock-mode) + (font-lock-fontify-block))) + (let ((pos (move-marker (make-marker) (point))) + (field (org-table-get-field)) + (cw (current-window-configuration)) + p) + (org-switch-to-buffer-other-window "*Org tmp*") + (erase-buffer) + (insert "#\n# Edit field and finish with C-c C-c\n#\n") + (let ((org-inhibit-startup t)) (org-mode)) + (goto-char (setq p (point-max))) + (insert (org-trim field)) + (remove-text-properties p (point-max) + '(invisible t org-cwidth t display t + intangible t)) + (goto-char p) + (org-set-local 'org-finish-function 'org-table-finish-edit-field) + (org-set-local 'org-window-configuration cw) + (org-set-local 'org-field-marker pos) + (message "Edit and finish with C-c C-c")))) + +(defun org-table-finish-edit-field () + "Finish editing a table data field. +Remove all newline characters, insert the result into the table, realign +the table and kill the editing buffer." + (let ((pos org-field-marker) + (cw org-window-configuration) + (cb (current-buffer)) + text) + (goto-char (point-min)) + (while (re-search-forward "^#.*\n?" nil t) (replace-match "")) + (while (re-search-forward "\\([ \t]*\n[ \t]*\\)+" nil t) + (replace-match " ")) + (setq text (org-trim (buffer-string))) + (set-window-configuration cw) + (kill-buffer cb) + (select-window (get-buffer-window (marker-buffer pos))) + (goto-char pos) + (move-marker pos nil) + (org-table-check-inside-data-field) + (org-table-get-field nil text) + (org-table-align) + (message "New field value inserted"))) + +(defvar org-timecnt) ; dynamically scoped parameter + +(defun org-table-sum (&optional beg end nlast) + "Sum numbers in region of current table column. +The result will be displayed in the echo area, and will be available +as kill to be inserted with \\[yank]. + +If there is an active region, it is interpreted as a rectangle and all +numbers in that rectangle will be summed. If there is no active +region and point is located in a table column, sum all numbers in that +column. + +If at least one number looks like a time HH:MM or HH:MM:SS, all other +numbers are assumed to be times as well (in decimal hours) and the +numbers are added as such. + +If NLAST is a number, only the NLAST fields will actually be summed." + (interactive) + (save-excursion + (let (col (org-timecnt 0) diff h m s org-table-clip) + (cond + ((and beg end)) ; beg and end given explicitly + ((org-region-active-p) + (setq beg (region-beginning) end (region-end))) + (t + (setq col (org-table-current-column)) + (goto-char (org-table-begin)) + (unless (re-search-forward "^[ \t]*|[^-]" nil t) + (error "No table data")) + (org-table-goto-column col) + (setq beg (point)) + (goto-char (org-table-end)) + (unless (re-search-backward "^[ \t]*|[^-]" nil t) + (error "No table data")) + (org-table-goto-column col) + (setq end (point)))) + (let* ((items (apply 'append (org-table-copy-region beg end))) + (items1 (cond ((not nlast) items) + ((>= nlast (length items)) items) + (t (setq items (reverse items)) + (setcdr (nthcdr (1- nlast) items) nil) + (nreverse items)))) + (numbers (delq nil (mapcar 'org-table-get-number-for-summing + items1))) + (res (apply '+ numbers)) + (sres (if (= org-timecnt 0) + (number-to-string res) + (setq diff (* 3600 res) + h (floor (/ diff 3600)) diff (mod diff 3600) + m (floor (/ diff 60)) diff (mod diff 60) + s diff) + (format "%d:%02d:%02d" h m s)))) + (kill-new sres) + (if (interactive-p) + (message "%s" + (substitute-command-keys + (format "Sum of %d items: %-20s (\\[yank] will insert result into buffer)" + (length numbers) sres)))) + sres)))) + +(defun org-table-get-number-for-summing (s) + (let (n) + (if (string-match "^ *|? *" s) + (setq s (replace-match "" nil nil s))) + (if (string-match " *|? *$" s) + (setq s (replace-match "" nil nil s))) + (setq n (string-to-number s)) + (cond + ((and (string-match "0" s) + (string-match "\\`[-+ \t0.edED]+\\'" s)) 0) + ((string-match "\\`[ \t]+\\'" s) nil) + ((string-match "\\`\\([0-9]+\\):\\([0-9]+\\)\\(:\\([0-9]+\\)\\)?\\'" s) + (let ((h (string-to-number (or (match-string 1 s) "0"))) + (m (string-to-number (or (match-string 2 s) "0"))) + (s (string-to-number (or (match-string 4 s) "0")))) + (if (boundp 'org-timecnt) (setq org-timecnt (1+ org-timecnt))) + (* 1.0 (+ h (/ m 60.0) (/ s 3600.0))))) + ((equal n 0) nil) + (t n)))) + +(defun org-table-current-field-formula (&optional key noerror) + "Return the formula active for the current field. +Assumes that specials are in place. +If KEY is given, return the key to this formula. +Otherwise return the formula preceded with \"=\" or \":=\"." + (let* ((name (car (rassoc (list (org-current-line) + (org-table-current-column)) + org-table-named-field-locations))) + (col (org-table-current-column)) + (scol (int-to-string col)) + (ref (format "@%d$%d" (org-table-current-dline) col)) + (stored-list (org-table-get-stored-formulas noerror)) + (ass (or (assoc name stored-list) + (assoc ref stored-list) + (assoc scol stored-list)))) + (if key + (car ass) + (if ass (concat (if (string-match "^[0-9]+$" (car ass)) "=" ":=") + (cdr ass)))))) + +(defun org-table-get-formula (&optional equation named) + "Read a formula from the minibuffer, offer stored formula as default. +When NAMED is non-nil, look for a named equation." + (let* ((stored-list (org-table-get-stored-formulas)) + (name (car (rassoc (list (org-current-line) + (org-table-current-column)) + org-table-named-field-locations))) + (ref (format "@%d$%d" (org-table-current-dline) + (org-table-current-column))) + (refass (assoc ref stored-list)) + (nameass (assoc name stored-list)) + (scol (if named + (if (and name (not (string-match "^LR[0-9]+$" name))) + name + ref) + (int-to-string (org-table-current-column)))) + (dummy (and (or nameass refass) (not named) + (not (y-or-n-p "Replace existing field formula with column formula? " )) + (error "Abort"))) + (name (or name ref)) + (org-table-may-need-update nil) + (stored (cdr (assoc scol stored-list))) + (eq (cond + ((and stored equation (string-match "^ *=? *$" equation)) + stored) + ((stringp equation) + equation) + (t (org-table-formula-from-user + (read-string + (org-table-formula-to-user + (format "%s formula %s%s=" + (if named "Field" "Column") + (if (member (string-to-char scol) '(?$ ?@)) "" "$") + scol)) + (if stored (org-table-formula-to-user stored) "") + 'org-table-formula-history + ))))) + mustsave) + (when (not (string-match "\\S-" eq)) + ;; remove formula + (setq stored-list (delq (assoc scol stored-list) stored-list)) + (org-table-store-formulas stored-list) + (error "Formula removed")) + (if (string-match "^ *=?" eq) (setq eq (replace-match "" t t eq))) + (if (string-match " *$" eq) (setq eq (replace-match "" t t eq))) + (if (and name (not named)) + ;; We set the column equation, delete the named one. + (setq stored-list (delq (assoc name stored-list) stored-list) + mustsave t)) + (if stored + (setcdr (assoc scol stored-list) eq) + (setq stored-list (cons (cons scol eq) stored-list))) + (if (or mustsave (not (equal stored eq))) + (org-table-store-formulas stored-list)) + eq)) + +(defun org-table-store-formulas (alist) + "Store the list of formulas below the current table." + (setq alist (sort alist 'org-table-formula-less-p)) + (save-excursion + (goto-char (org-table-end)) + (if (looking-at "\\([ \t]*\n\\)*[ \t]*#\\+TBLFM:\\(.*\n?\\)") + (progn + ;; don't overwrite TBLFM, we might use text properties to store stuff + (goto-char (match-beginning 2)) + (delete-region (match-beginning 2) (match-end 0))) + (org-indent-line-function) + (insert "#+TBLFM:")) + (insert " " + (mapconcat (lambda (x) + (concat + (if (equal (string-to-char (car x)) ?@) "" "$") + (car x) "=" (cdr x))) + alist "::") + "\n"))) + +(defsubst org-table-formula-make-cmp-string (a) + (when (string-match "^\\(@\\([0-9]+\\)\\)?\\(\\$?\\([0-9]+\\)\\)?\\(\\$?[a-zA-Z0-9]+\\)?" a) + (concat + (if (match-end 2) (format "@%05d" (string-to-number (match-string 2 a))) "") + (if (match-end 4) (format "$%05d" (string-to-number (match-string 4 a))) "") + (if (match-end 5) (concat "@@" (match-string 5 a)))))) + +(defun org-table-formula-less-p (a b) + "Compare two formulas for sorting." + (let ((as (org-table-formula-make-cmp-string (car a))) + (bs (org-table-formula-make-cmp-string (car b)))) + (and as bs (string< as bs)))) + +(defun org-table-get-stored-formulas (&optional noerror) + "Return an alist with the stored formulas directly after current table." + (interactive) + (let (scol eq eq-alist strings string seen) + (save-excursion + (goto-char (org-table-end)) + (when (looking-at "\\([ \t]*\n\\)*[ \t]*#\\+TBLFM: *\\(.*\\)") + (setq strings (org-split-string (match-string 2) " *:: *")) + (while (setq string (pop strings)) + (when (string-match "\\`\\(@[0-9]+\\$[0-9]+\\|\\$\\([a-zA-Z0-9]+\\)\\) *= *\\(.*[^ \t]\\)" string) + (setq scol (if (match-end 2) + (match-string 2 string) + (match-string 1 string)) + eq (match-string 3 string) + eq-alist (cons (cons scol eq) eq-alist)) + (if (member scol seen) + (if noerror + (progn + (message "Double definition `$%s=' in TBLFM line, please fix by hand" scol) + (ding) + (sit-for 2)) + (error "Double definition `$%s=' in TBLFM line, please fix by hand" scol)) + (push scol seen)))))) + (nreverse eq-alist))) + +(defun org-table-fix-formulas (key replace &optional limit delta remove) + "Modify the equations after the table structure has been edited. +KEY is \"@\" or \"$\". REPLACE is an alist of numbers to replace. +For all numbers larger than LIMIT, shift them by DELTA." + (save-excursion + (goto-char (org-table-end)) + (when (looking-at "[ \t]*#\\+TBLFM:") + (let ((re (concat key "\\([0-9]+\\)")) + (re2 + (when remove + (if (or (equal key "$") (equal key "$LR")) + (format "\\(@[0-9]+\\)?%s%d=.*?\\(::\\|$\\)" + (regexp-quote key) remove) + (format "@%d\\$[0-9]+=.*?\\(::\\|$\\)" remove)))) + s n a) + (when remove + (while (re-search-forward re2 (point-at-eol) t) + (unless (save-match-data (org-in-regexp "remote([^)]+?)")) + (replace-match "")))) + (while (re-search-forward re (point-at-eol) t) + (unless (save-match-data (org-in-regexp "remote([^)]+?)")) + (setq s (match-string 1) n (string-to-number s)) + (cond + ((setq a (assoc s replace)) + (replace-match (concat key (cdr a)) t t)) + ((and limit (> n limit)) + (replace-match (concat key (int-to-string (+ n delta))) + t t))))))))) + +(defun org-table-get-specials () + "Get the column names and local parameters for this table." + (save-excursion + (let ((beg (org-table-begin)) (end (org-table-end)) + names name fields fields1 field cnt + c v l line col types dlines hlines last-dline) + (setq org-table-column-names nil + org-table-local-parameters nil + org-table-named-field-locations nil + org-table-current-begin-line nil + org-table-current-begin-pos nil + org-table-current-line-types nil) + (goto-char beg) + (when (re-search-forward "^[ \t]*| *! *\\(|.*\\)" end t) + (setq names (org-split-string (match-string 1) " *| *") + cnt 1) + (while (setq name (pop names)) + (setq cnt (1+ cnt)) + (if (string-match "^[a-zA-Z][a-zA-Z0-9]*$" name) + (push (cons name (int-to-string cnt)) org-table-column-names)))) + (setq org-table-column-names (nreverse org-table-column-names)) + (setq org-table-column-name-regexp + (concat "\\$\\(" (mapconcat 'car org-table-column-names "\\|") "\\)\\>")) + (goto-char beg) + (while (re-search-forward "^[ \t]*| *\\$ *\\(|.*\\)" end t) + (setq fields (org-split-string (match-string 1) " *| *")) + (while (setq field (pop fields)) + (if (string-match "^\\([a-zA-Z][_a-zA-Z0-9]*\\|%\\) *= *\\(.*\\)" field) + (push (cons (match-string 1 field) (match-string 2 field)) + org-table-local-parameters)))) + (goto-char beg) + (while (re-search-forward "^[ \t]*| *\\([_^]\\) *\\(|.*\\)" end t) + (setq c (match-string 1) + fields (org-split-string (match-string 2) " *| *")) + (save-excursion + (beginning-of-line (if (equal c "_") 2 0)) + (setq line (org-current-line) col 1) + (and (looking-at "^[ \t]*|[^|]*\\(|.*\\)") + (setq fields1 (org-split-string (match-string 1) " *| *")))) + (while (and fields1 (setq field (pop fields))) + (setq v (pop fields1) col (1+ col)) + (when (and (stringp field) (stringp v) + (string-match "^[a-zA-Z][a-zA-Z0-9]*$" field)) + (push (cons field v) org-table-local-parameters) + (push (list field line col) org-table-named-field-locations)))) + ;; Analyse the line types + (goto-char beg) + (setq org-table-current-begin-line (org-current-line) + org-table-current-begin-pos (point) + l org-table-current-begin-line) + (while (looking-at "[ \t]*|\\(-\\)?") + (push (if (match-end 1) 'hline 'dline) types) + (if (match-end 1) (push l hlines) (push l dlines)) + (beginning-of-line 2) + (setq l (1+ l))) + (push 'hline types) ;; add an imaginary extra hline to the end + (setq org-table-current-line-types (apply 'vector (nreverse types)) + last-dline (car dlines) + org-table-dlines (apply 'vector (cons nil (nreverse dlines))) + org-table-hlines (apply 'vector (cons nil (nreverse hlines)))) + (org-goto-line last-dline) + (let* ((l last-dline) + (fields (org-split-string + (buffer-substring (point-at-bol) (point-at-eol)) + "[ \t]*|[ \t]*")) + (nfields (length fields)) + al al2) + (loop for i from 1 to nfields do + (push (list (format "LR%d" i) l i) al) + (push (cons (format "LR%d" i) (nth (1- i) fields)) al2)) + (setq org-table-named-field-locations + (append org-table-named-field-locations al)) + (setq org-table-local-parameters + (append org-table-local-parameters al2)))))) + + +(defun org-table-maybe-eval-formula () + "Check if the current field starts with \"=\" or \":=\". +If yes, store the formula and apply it." + ;; We already know we are in a table. Get field will only return a formula + ;; when appropriate. It might return a separator line, but no problem. + (when org-table-formula-evaluate-inline + (let* ((field (org-trim (or (org-table-get-field) ""))) + named eq) + (when (string-match "^:?=\\(.*\\)" field) + (setq named (equal (string-to-char field) ?:) + eq (match-string 1 field)) + (if (or (fboundp 'calc-eval) + (equal (substring eq 0 (min 2 (length eq))) "'(")) + (org-table-eval-formula (if named '(4) nil) + (org-table-formula-from-user eq)) + (error "Calc does not seem to be installed, and is needed to evaluate the formula")))))) + +(defvar org-recalc-commands nil + "List of commands triggering the recalculation of a line. +Will be filled automatically during use.") + +(defvar org-recalc-marks + '((" " . "Unmarked: no special line, no automatic recalculation") + ("#" . "Automatically recalculate this line upon TAB, RET, and C-c C-c in the line") + ("*" . "Recalculate only when entire table is recalculated with `C-u C-c *'") + ("!" . "Column name definition line. Reference in formula as $name.") + ("$" . "Parameter definition line name=value. Reference in formula as $name.") + ("_" . "Names for values in row below this one.") + ("^" . "Names for values in row above this one."))) + +(defun org-table-rotate-recalc-marks (&optional newchar) + "Rotate the recalculation mark in the first column. +If in any row, the first field is not consistent with a mark, +insert a new column for the markers. +When there is an active region, change all the lines in the region, +after prompting for the marking character. +After each change, a message will be displayed indicating the meaning +of the new mark." + (interactive) + (unless (org-at-table-p) (error "Not at a table")) + (let* ((marks (append (mapcar 'car org-recalc-marks) '(" "))) + (beg (org-table-begin)) + (end (org-table-end)) + (l (org-current-line)) + (l1 (if (org-region-active-p) (org-current-line (region-beginning)))) + (l2 (if (org-region-active-p) (org-current-line (region-end)))) + (have-col + (save-excursion + (goto-char beg) + (not (re-search-forward "^[ \t]*|[^-|][^|]*[^#!$*_^| \t][^|]*|" end t)))) + (col (org-table-current-column)) + (forcenew (car (assoc newchar org-recalc-marks))) + epos new) + (when l1 + (message "Change region to what mark? Type # * ! $ or SPC: ") + (setq newchar (char-to-string (read-char-exclusive)) + forcenew (car (assoc newchar org-recalc-marks)))) + (if (and newchar (not forcenew)) + (error "Invalid NEWCHAR `%s' in `org-table-rotate-recalc-marks'" + newchar)) + (if l1 (org-goto-line l1)) + (save-excursion + (beginning-of-line 1) + (unless (looking-at org-table-dataline-regexp) + (error "Not at a table data line"))) + (unless have-col + (org-table-goto-column 1) + (org-table-insert-column) + (org-table-goto-column (1+ col))) + (setq epos (point-at-eol)) + (save-excursion + (beginning-of-line 1) + (org-table-get-field + 1 (if (looking-at "^[ \t]*| *\\([#!$*^_ ]\\) *|") + (concat " " + (setq new (or forcenew + (cadr (member (match-string 1) marks)))) + " ") + " # "))) + (if (and l1 l2) + (progn + (org-goto-line l1) + (while (progn (beginning-of-line 2) (not (= (org-current-line) l2))) + (and (looking-at org-table-dataline-regexp) + (org-table-get-field 1 (concat " " new " ")))) + (org-goto-line l1))) + (if (not (= epos (point-at-eol))) (org-table-align)) + (org-goto-line l) + (and (interactive-p) (message "%s" (cdr (assoc new org-recalc-marks)))))) + +(defun org-table-maybe-recalculate-line () + "Recompute the current line if marked for it, and if we haven't just done it." + (interactive) + (and org-table-allow-automatic-line-recalculation + (not (and (memq last-command org-recalc-commands) + (equal org-last-recalc-line (org-current-line)))) + (save-excursion (beginning-of-line 1) + (looking-at org-table-auto-recalculate-regexp)) + (org-table-recalculate) t)) + +(defvar modes) +(defsubst org-set-calc-mode (var &optional value) + (if (stringp var) + (setq var (assoc var '(("D" calc-angle-mode deg) + ("R" calc-angle-mode rad) + ("F" calc-prefer-frac t) + ("S" calc-symbolic-mode t))) + value (nth 2 var) var (nth 1 var))) + (if (memq var modes) + (setcar (cdr (memq var modes)) value) + (cons var (cons value modes))) + modes) + +(defun org-table-eval-formula (&optional arg equation + suppress-align suppress-const + suppress-store suppress-analysis) + "Replace the table field value at the cursor by the result of a calculation. + +This function makes use of Dave Gillespie's Calc package, in my view the +most exciting program ever written for GNU Emacs. So you need to have Calc +installed in order to use this function. + +In a table, this command replaces the value in the current field with the +result of a formula. It also installs the formula as the \"current\" column +formula, by storing it in a special line below the table. When called +with a `C-u' prefix, the current field must be a named field, and the +formula is installed as valid in only this specific field. + +When called with two `C-u' prefixes, insert the active equation +for the field back into the current field, so that it can be +edited there. This is useful in order to use \\[org-table-show-reference] +to check the referenced fields. + +When called, the command first prompts for a formula, which is read in +the minibuffer. Previously entered formulas are available through the +history list, and the last used formula is offered as a default. +These stored formulas are adapted correctly when moving, inserting, or +deleting columns with the corresponding commands. + +The formula can be any algebraic expression understood by the Calc package. +For details, see the Org-mode manual. + +This function can also be called from Lisp programs and offers +additional arguments: EQUATION can be the formula to apply. If this +argument is given, the user will not be prompted. SUPPRESS-ALIGN is +used to speed-up recursive calls by by-passing unnecessary aligns. +SUPPRESS-CONST suppresses the interpretation of constants in the +formula, assuming that this has been done already outside the function. +SUPPRESS-STORE means the formula should not be stored, either because +it is already stored, or because it is a modified equation that should +not overwrite the stored one." + (interactive "P") + (org-table-check-inside-data-field) + (or suppress-analysis (org-table-get-specials)) + (if (equal arg '(16)) + (let ((eq (org-table-current-field-formula))) + (or eq (error "No equation active for current field")) + (org-table-get-field nil eq) + (org-table-align) + (setq org-table-may-need-update t)) + (let* (fields + (ndown (if (integerp arg) arg 1)) + (org-table-automatic-realign nil) + (case-fold-search nil) + (down (> ndown 1)) + (formula (if (and equation suppress-store) + equation + (org-table-get-formula equation (equal arg '(4))))) + (n0 (org-table-current-column)) + (modes (copy-sequence org-calc-default-modes)) + (numbers nil) ; was a variable, now fixed default + (keep-empty nil) + n form form0 bw fmt x ev orig c lispp literal) + ;; Parse the format string. Since we have a lot of modes, this is + ;; a lot of work. However, I think calc still uses most of the time. + (if (string-match ";" formula) + (let ((tmp (org-split-string formula ";"))) + (setq formula (car tmp) + fmt (concat (cdr (assoc "%" org-table-local-parameters)) + (nth 1 tmp))) + (while (string-match "\\([pnfse]\\)\\(-?[0-9]+\\)" fmt) + (setq c (string-to-char (match-string 1 fmt)) + n (string-to-number (match-string 2 fmt))) + (if (= c ?p) + (setq modes (org-set-calc-mode 'calc-internal-prec n)) + (setq modes (org-set-calc-mode + 'calc-float-format + (list (cdr (assoc c '((?n . float) (?f . fix) + (?s . sci) (?e . eng)))) + n)))) + (setq fmt (replace-match "" t t fmt))) + (if (string-match "[NT]" fmt) + (setq numbers (equal (match-string 0 fmt) "N") + fmt (replace-match "" t t fmt))) + (if (string-match "L" fmt) + (setq literal t + fmt (replace-match "" t t fmt))) + (if (string-match "E" fmt) + (setq keep-empty t + fmt (replace-match "" t t fmt))) + (while (string-match "[DRFS]" fmt) + (setq modes (org-set-calc-mode (match-string 0 fmt))) + (setq fmt (replace-match "" t t fmt))) + (unless (string-match "\\S-" fmt) + (setq fmt nil)))) + (if (and (not suppress-const) org-table-formula-use-constants) + (setq formula (org-table-formula-substitute-names formula))) + (setq orig (or (get-text-property 1 :orig-formula formula) "?")) + (while (> ndown 0) + (setq fields (org-split-string + (org-no-properties + (buffer-substring (point-at-bol) (point-at-eol))) + " *| *")) + (if (eq numbers t) + (setq fields (mapcar + (lambda (x) (number-to-string (string-to-number x))) + fields))) + (setq ndown (1- ndown)) + (setq form (copy-sequence formula) + lispp (and (> (length form) 2)(equal (substring form 0 2) "'("))) + (if (and lispp literal) (setq lispp 'literal)) + + ;; Insert row and column number of formula result field + (while (string-match "[@$]#" form) + (setq form + (replace-match + (format "%d" + (save-match-data + (if (equal (substring form (match-beginning 0) + (1+ (match-beginning 0))) + "@") + (org-table-current-dline) + (org-table-current-column)))) + t t form))) + + ;; Check for old vertical references + (setq form (org-table-rewrite-old-row-references form)) + ;; Insert remote references + (while (string-match "\\<remote([ \t]*\\([-_a-zA-Z0-9]+\\)[ \t]*,[ \t]*\\([^\n)]+\\))" form) + (setq form + (replace-match + (save-match-data + (org-table-make-reference + (org-table-get-remote-range + (match-string 1 form) (match-string 2 form)) + keep-empty numbers lispp)) + t t form))) + ;; Insert complex ranges + (while (and (string-match org-table-range-regexp form) + (> (length (match-string 0 form)) 1)) + (setq form + (replace-match + (save-match-data + (org-table-make-reference + (org-table-get-range (match-string 0 form) nil n0) + keep-empty numbers lispp)) + t t form))) + ;; Insert simple ranges + (while (string-match "\\$\\([0-9]+\\)\\.\\.\\$\\([0-9]+\\)" form) + (setq form + (replace-match + (save-match-data + (org-table-make-reference + (org-sublist + fields (string-to-number (match-string 1 form)) + (string-to-number (match-string 2 form))) + keep-empty numbers lispp)) + t t form))) + (setq form0 form) + ;; Insert the references to fields in same row + (while (string-match "\\$\\([0-9]+\\)" form) + (setq n (string-to-number (match-string 1 form)) + x (nth (1- (if (= n 0) n0 n)) fields)) + (unless x (error "Invalid field specifier \"%s\"" + (match-string 0 form))) + (setq form (replace-match + (save-match-data + (org-table-make-reference x nil numbers lispp)) + t t form))) + + (if lispp + (setq ev (condition-case nil + (eval (eval (read form))) + (error "#ERROR")) + ev (if (numberp ev) (number-to-string ev) ev)) + (or (fboundp 'calc-eval) + (error "Calc does not seem to be installed, and is needed to evaluate the formula")) + (setq ev (calc-eval (cons form modes) + (if numbers 'num)))) + + (when org-table-formula-debug + (with-output-to-temp-buffer "*Substitution History*" + (princ (format "Substitution history of formula +Orig: %s +$xyz-> %s +@r$c-> %s +$1-> %s\n" orig formula form0 form)) + (if (listp ev) + (princ (format " %s^\nError: %s" + (make-string (car ev) ?\-) (nth 1 ev))) + (princ (format "Result: %s\nFormat: %s\nFinal: %s" + ev (or fmt "NONE") + (if fmt (format fmt (string-to-number ev)) ev))))) + (setq bw (get-buffer-window "*Substitution History*")) + (org-fit-window-to-buffer bw) + (unless (and (interactive-p) (not ndown)) + (unless (let (inhibit-redisplay) + (y-or-n-p "Debugging Formula. Continue to next? ")) + (org-table-align) + (error "Abort")) + (delete-window bw) + (message ""))) + (if (listp ev) (setq fmt nil ev "#ERROR")) + (org-table-justify-field-maybe + (if fmt (format fmt (string-to-number ev)) ev)) + (if (and down (> ndown 0) (looking-at ".*\n[ \t]*|[^-]")) + (call-interactively 'org-return) + (setq ndown 0))) + (and down (org-table-maybe-recalculate-line)) + (or suppress-align (and org-table-may-need-update + (org-table-align)))))) + +(defun org-table-put-field-property (prop value) + (save-excursion + (put-text-property (progn (skip-chars-backward "^|") (point)) + (progn (skip-chars-forward "^|") (point)) + prop value))) + +(defun org-table-get-range (desc &optional tbeg col highlight) + "Get a calc vector from a column, according to descriptor DESC. +Optional arguments TBEG and COL can give the beginning of the table and +the current column, to avoid unnecessary parsing. +HIGHLIGHT means just highlight the range." + (if (not (equal (string-to-char desc) ?@)) + (setq desc (concat "@" desc))) + (save-excursion + (or tbeg (setq tbeg (org-table-begin))) + (or col (setq col (org-table-current-column))) + (let ((thisline (org-current-line)) + beg end c1 c2 r1 r2 rangep tmp) + (unless (string-match org-table-range-regexp desc) + (error "Invalid table range specifier `%s'" desc)) + (setq rangep (match-end 3) + r1 (and (match-end 1) (match-string 1 desc)) + r2 (and (match-end 4) (match-string 4 desc)) + c1 (and (match-end 2) (substring (match-string 2 desc) 1)) + c2 (and (match-end 5) (substring (match-string 5 desc) 1))) + + (and c1 (setq c1 (+ (string-to-number c1) + (if (memq (string-to-char c1) '(?- ?+)) col 0)))) + (and c2 (setq c2 (+ (string-to-number c2) + (if (memq (string-to-char c2) '(?- ?+)) col 0)))) + (if (equal r1 "") (setq r1 nil)) + (if (equal r2 "") (setq r2 nil)) + (if r1 (setq r1 (org-table-get-descriptor-line r1))) + (if r2 (setq r2 (org-table-get-descriptor-line r2))) +; (setq r2 (or r2 r1) c2 (or c2 c1)) + (if (not r1) (setq r1 thisline)) + (if (not r2) (setq r2 thisline)) + (if (not c1) (setq c1 col)) + (if (not c2) (setq c2 col)) + (if (or (not rangep) (and (= r1 r2) (= c1 c2))) + ;; just one field + (progn + (org-goto-line r1) + (while (not (looking-at org-table-dataline-regexp)) + (beginning-of-line 2)) + (prog1 (org-trim (org-table-get-field c1)) + (if highlight (org-table-highlight-rectangle (point) (point))))) + ;; A range, return a vector + ;; First sort the numbers to get a regular ractangle + (if (< r2 r1) (setq tmp r1 r1 r2 r2 tmp)) + (if (< c2 c1) (setq tmp c1 c1 c2 c2 tmp)) + (org-goto-line r1) + (while (not (looking-at org-table-dataline-regexp)) + (beginning-of-line 2)) + (org-table-goto-column c1) + (setq beg (point)) + (org-goto-line r2) + (while (not (looking-at org-table-dataline-regexp)) + (beginning-of-line 0)) + (org-table-goto-column c2) + (setq end (point)) + (if highlight + (org-table-highlight-rectangle + beg (progn (skip-chars-forward "^|\n") (point)))) + ;; return string representation of calc vector + (mapcar 'org-trim + (apply 'append (org-table-copy-region beg end))))))) + +(defun org-table-get-descriptor-line (desc &optional cline bline table) + "Analyze descriptor DESC and retrieve the corresponding line number. +The cursor is currently in line CLINE, the table begins in line BLINE, +and TABLE is a vector with line types." + (if (string-match "^[0-9]+$" desc) + (aref org-table-dlines (string-to-number desc)) + (setq cline (or cline (org-current-line)) + bline (or bline org-table-current-begin-line) + table (or table org-table-current-line-types)) + (if (or + (not (string-match "^\\(\\([-+]\\)?\\(I+\\)\\)?\\(\\([-+]\\)?\\([0-9]+\\)\\)?" desc)) + ;; 1 2 3 4 5 6 + (and (not (match-end 3)) (not (match-end 6))) + (and (match-end 3) (match-end 6) (not (match-end 5)))) + (error "Invalid row descriptor `%s'" desc)) + (let* ((hdir (and (match-end 2) (match-string 2 desc))) + (hn (if (match-end 3) (- (match-end 3) (match-beginning 3)) nil)) + (odir (and (match-end 5) (match-string 5 desc))) + (on (if (match-end 6) (string-to-number (match-string 6 desc)))) + (i (- cline bline)) + (rel (and (match-end 6) + (or (and (match-end 1) (not (match-end 3))) + (match-end 5))))) + (if (and hn (not hdir)) + (progn + (setq i 0 hdir "+") + (if (eq (aref table 0) 'hline) (setq hn (1- hn))))) + (if (and (not hn) on (not odir)) + (error "Should never happen");;(aref org-table-dlines on) + (if (and hn (> hn 0)) + (setq i (org-table-find-row-type table i 'hline (equal hdir "-") + nil hn cline desc))) + (if on + (setq i (org-table-find-row-type table i 'dline (equal odir "-") + rel on cline desc))) + (+ bline i))))) + +(defun org-table-find-row-type (table i type backwards relative n cline desc) + "FIXME: Needs more documentation." + (let ((l (length table))) + (while (> n 0) + (while (and (setq i (+ i (if backwards -1 1))) + (>= i 0) (< i l) + (not (eq (aref table i) type)) + (if (and relative (eq (aref table i) 'hline)) + (cond + ((eq org-table-relative-ref-may-cross-hline t) t) + ((eq org-table-relative-ref-may-cross-hline 'error) + (error "Row descriptor %s used in line %d crosses hline" desc cline)) + (t (setq i (- i (if backwards -1 1)) + n 1) + nil)) + t))) + (setq n (1- n))) + (if (or (< i 0) (>= i l)) + (error "Row descriptor %s used in line %d leads outside table" + desc cline) + i))) + +(defun org-table-rewrite-old-row-references (s) + (if (string-match "&[-+0-9I]" s) + (error "Formula contains old &row reference, please rewrite using @-syntax") + s)) + +(defun org-table-make-reference (elements keep-empty numbers lispp) + "Convert list ELEMENTS to something appropriate to insert into formula. +KEEP-EMPTY indicated to keep empty fields, default is to skip them. +NUMBERS indicates that everything should be converted to numbers. +LISPP means to return something appropriate for a Lisp list." + (if (stringp elements) ; just a single val + (if lispp + (if (eq lispp 'literal) + elements + (prin1-to-string (if numbers (string-to-number elements) elements))) + (if (equal elements "") (setq elements "0")) + (if numbers (setq elements (number-to-string (string-to-number elements)))) + (concat "(" elements ")")) + (unless keep-empty + (setq elements + (delq nil + (mapcar (lambda (x) (if (string-match "\\S-" x) x nil)) + elements)))) + (setq elements (or elements '("0"))) + (if lispp + (mapconcat + (lambda (x) + (if (eq lispp 'literal) + x + (prin1-to-string (if numbers (string-to-number x) x)))) + elements " ") + (concat "[" (mapconcat + (lambda (x) + (if numbers (number-to-string (string-to-number x)) x)) + elements + ",") "]")))) + +(defun org-table-recalculate (&optional all noalign) + "Recalculate the current table line by applying all stored formulas. +With prefix arg ALL, do this for all lines in the table. +With the prefix argument ALL is `(16)' \ +\(a double \\[universal-prefix] \\[universal-prefix] prefix), or if +it is the symbol `iterate', recompute the table until it no longer changes. +If NOALIGN is not nil, do not re-align the table after the computations +are done. This is typically used internally to save time, if it is +known that the table will be realigned a little later anyway." + (interactive "P") + (or (memq this-command org-recalc-commands) + (setq org-recalc-commands (cons this-command org-recalc-commands))) + (unless (org-at-table-p) (error "Not at a table")) + (if (or (eq all 'iterate) (equal all '(16))) + (org-table-iterate) + (org-table-get-specials) + (let* ((eqlist (sort (org-table-get-stored-formulas) + (lambda (a b) (string< (car a) (car b))))) + (inhibit-redisplay (not debug-on-error)) + (line-re org-table-dataline-regexp) + (thisline (org-current-line)) + (thiscol (org-table-current-column)) + beg end entry eqlnum eqlname eqlname1 eql (cnt 0) eq a name) + ;; Insert constants in all formulas + (setq eqlist + (mapcar (lambda (x) + (setcdr x (org-table-formula-substitute-names (cdr x))) + x) + eqlist)) + ;; Split the equation list + (while (setq eq (pop eqlist)) + (if (<= (string-to-char (car eq)) ?9) + (push eq eqlnum) + (push eq eqlname))) + (setq eqlnum (nreverse eqlnum) eqlname (nreverse eqlname)) + (if all + (progn + (setq end (move-marker (make-marker) (1+ (org-table-end)))) + (goto-char (setq beg (org-table-begin))) + (if (re-search-forward org-table-calculate-mark-regexp end t) + ;; This is a table with marked lines, compute selected lines + (setq line-re org-table-recalculate-regexp) + ;; Move forward to the first non-header line + (if (and (re-search-forward org-table-dataline-regexp end t) + (re-search-forward org-table-hline-regexp end t) + (re-search-forward org-table-dataline-regexp end t)) + (setq beg (match-beginning 0)) + nil))) ;; just leave beg where it is + (setq beg (point-at-bol) + end (move-marker (make-marker) (1+ (point-at-eol))))) + (goto-char beg) + (and all (message "Re-applying formulas to full table...")) + + ;; First find the named fields, and mark them untouchable + (remove-text-properties beg end '(org-untouchable t)) + (while (setq eq (pop eqlname)) + (setq name (car eq) + a (assoc name org-table-named-field-locations)) + (and (not a) + (string-match "@\\([0-9]+\\)\\$\\([0-9]+\\)" name) + (setq a (list name + (condition-case nil + (aref org-table-dlines + (string-to-number (match-string 1 name))) + (error (error "Invalid row number in %s" + name))) + (string-to-number (match-string 2 name))))) + (when (and a (or all (equal (nth 1 a) thisline))) + (message "Re-applying formula to field: %s" name) + (org-goto-line (nth 1 a)) + (org-table-goto-column (nth 2 a)) + (push (append a (list (cdr eq))) eqlname1) + (org-table-put-field-property :org-untouchable t))) + + ;; Now evaluate the column formulas, but skip fields covered by + ;; field formulas + (goto-char beg) + (while (re-search-forward line-re end t) + (unless (string-match "^ *[_^!$/] *$" (org-table-get-field 1)) + ;; Unprotected line, recalculate + (and all (message "Re-applying formulas to full table...(line %d)" + (setq cnt (1+ cnt)))) + (setq org-last-recalc-line (org-current-line)) + (setq eql eqlnum) + (while (setq entry (pop eql)) + (org-goto-line org-last-recalc-line) + (org-table-goto-column (string-to-number (car entry)) nil 'force) + (unless (get-text-property (point) :org-untouchable) + (org-table-eval-formula nil (cdr entry) + 'noalign 'nocst 'nostore 'noanalysis))))) + + ;; Now evaluate the field formulas + (while (setq eq (pop eqlname1)) + (message "Re-applying formula to field: %s" (car eq)) + (org-goto-line (nth 1 eq)) + (org-table-goto-column (nth 2 eq)) + (org-table-eval-formula nil (nth 3 eq) 'noalign 'nocst + 'nostore 'noanalysis)) + + (org-goto-line thisline) + (org-table-goto-column thiscol) + (remove-text-properties (point-min) (point-max) '(org-untouchable t)) + (or noalign (and org-table-may-need-update (org-table-align)) + (and all (message "Re-applying formulas to %d lines...done" cnt))) + + ;; back to initial position + (message "Re-applying formulas...done") + (org-goto-line thisline) + (org-table-goto-column thiscol) + (or noalign (and org-table-may-need-update (org-table-align)) + (and all (message "Re-applying formulas...done")))))) + +(defun org-table-iterate (&optional arg) + "Recalculate the table until it does not change anymore." + (interactive "P") + (let ((imax (if arg (prefix-numeric-value arg) 10)) + (i 0) + (lasttbl (buffer-substring (org-table-begin) (org-table-end))) + thistbl) + (catch 'exit + (while (< i imax) + (setq i (1+ i)) + (org-table-recalculate 'all) + (setq thistbl (buffer-substring (org-table-begin) (org-table-end))) + (if (not (string= lasttbl thistbl)) + (setq lasttbl thistbl) + (if (> i 1) + (message "Convergence after %d iterations" i) + (message "Table was already stable")) + (throw 'exit t))) + (error "No convergence after %d iterations" i)))) + +(defun org-table-recalculate-buffer-tables () + "Recalculate all tables in the current buffer." + (interactive) + (save-excursion + (save-restriction + (widen) + (org-table-map-tables (lambda () (org-table-recalculate t)) t)))) + +(defun org-table-iterate-buffer-tables () + "Iterate all tables in the buffer, to converge inter-table dependencies." + (interactive) + (let* ((imax 10) + (checksum (md5 (buffer-string))) + + c1 + (i imax)) + (save-excursion + (save-restriction + (widen) + (catch 'exit + (while (> i 0) + (setq i (1- i)) + (org-table-map-tables (lambda () (org-table-recalculate t)) t) + (if (equal checksum (setq c1 (md5 (buffer-string)))) + (progn + (message "Convergence after %d iterations" (- imax i)) + (throw 'exit t)) + (setq checksum c1))) + (error "No convergence after %d iterations" imax)))))) + +(defun org-table-formula-substitute-names (f) + "Replace $const with values in string F." + (let ((start 0) a (f1 f) (pp (/= (string-to-char f) ?'))) + ;; First, check for column names + (while (setq start (string-match org-table-column-name-regexp f start)) + (setq start (1+ start)) + (setq a (assoc (match-string 1 f) org-table-column-names)) + (setq f (replace-match (concat "$" (cdr a)) t t f))) + ;; Parameters and constants + (setq start 0) + (while (setq start (string-match "\\$\\([a-zA-Z][_a-zA-Z0-9]*\\)\\|\\(\\<remote([^)]*)\\)" f start)) + (if (match-end 2) + (setq start (match-end 2)) + (setq start (1+ start)) + (if (setq a (save-match-data + (org-table-get-constant (match-string 1 f)))) + (setq f (replace-match + (concat (if pp "(") a (if pp ")")) t t f))))) + (if org-table-formula-debug + (put-text-property 0 (length f) :orig-formula f1 f)) + f)) + +(defun org-table-get-constant (const) + "Find the value for a parameter or constant in a formula. +Parameters get priority." + (or (cdr (assoc const org-table-local-parameters)) + (cdr (assoc const org-table-formula-constants-local)) + (cdr (assoc const org-table-formula-constants)) + (and (fboundp 'constants-get) (constants-get const)) + (and (string= (substring const 0 (min 5 (length const))) "PROP_") + (org-entry-get nil (substring const 5) 'inherit)) + "#UNDEFINED_NAME")) + +(defvar org-table-fedit-map + (let ((map (make-sparse-keymap))) + (org-defkey map "\C-x\C-s" 'org-table-fedit-finish) + (org-defkey map "\C-c\C-s" 'org-table-fedit-finish) + (org-defkey map "\C-c\C-c" 'org-table-fedit-finish) + (org-defkey map "\C-c'" 'org-table-fedit-finish) + (org-defkey map "\C-c\C-q" 'org-table-fedit-abort) + (org-defkey map "\C-c?" 'org-table-show-reference) + (org-defkey map [(meta shift up)] 'org-table-fedit-line-up) + (org-defkey map [(meta shift down)] 'org-table-fedit-line-down) + (org-defkey map [(shift up)] 'org-table-fedit-ref-up) + (org-defkey map [(shift down)] 'org-table-fedit-ref-down) + (org-defkey map [(shift left)] 'org-table-fedit-ref-left) + (org-defkey map [(shift right)] 'org-table-fedit-ref-right) + (org-defkey map [(meta up)] 'org-table-fedit-scroll-down) + (org-defkey map [(meta down)] 'org-table-fedit-scroll) + (org-defkey map [(meta tab)] 'lisp-complete-symbol) + (org-defkey map "\M-\C-i" 'lisp-complete-symbol) + (org-defkey map [(tab)] 'org-table-fedit-lisp-indent) + (org-defkey map "\C-i" 'org-table-fedit-lisp-indent) + (org-defkey map "\C-c\C-r" 'org-table-fedit-toggle-ref-type) + (org-defkey map "\C-c}" 'org-table-fedit-toggle-coordinates) + map)) + +(easy-menu-define org-table-fedit-menu org-table-fedit-map "Org Edit Formulas Menu" + '("Edit-Formulas" + ["Finish and Install" org-table-fedit-finish t] + ["Finish, Install, and Apply" (org-table-fedit-finish t) :keys "C-u C-c C-c"] + ["Abort" org-table-fedit-abort t] + "--" + ["Pretty-Print Lisp Formula" org-table-fedit-lisp-indent t] + ["Complete Lisp Symbol" lisp-complete-symbol t] + "--" + "Shift Reference at Point" + ["Up" org-table-fedit-ref-up t] + ["Down" org-table-fedit-ref-down t] + ["Left" org-table-fedit-ref-left t] + ["Right" org-table-fedit-ref-right t] + "-" + "Change Test Row for Column Formulas" + ["Up" org-table-fedit-line-up t] + ["Down" org-table-fedit-line-down t] + "--" + ["Scroll Table Window" org-table-fedit-scroll t] + ["Scroll Table Window down" org-table-fedit-scroll-down t] + ["Show Table Grid" org-table-fedit-toggle-coordinates + :style toggle :selected (with-current-buffer (marker-buffer org-pos) + org-table-overlay-coordinates)] + "--" + ["Standard Refs (B3 instead of @3$2)" org-table-fedit-toggle-ref-type + :style toggle :selected org-table-buffer-is-an])) + +(defvar org-pos) + +(defun org-table-edit-formulas () + "Edit the formulas of the current table in a separate buffer." + (interactive) + (when (save-excursion (beginning-of-line 1) (looking-at "[ \t]*#\\+TBLFM")) + (beginning-of-line 0)) + (unless (org-at-table-p) (error "Not at a table")) + (org-table-get-specials) + (let ((key (org-table-current-field-formula 'key 'noerror)) + (eql (sort (org-table-get-stored-formulas 'noerror) + 'org-table-formula-less-p)) + (pos (move-marker (make-marker) (point))) + (startline 1) + (wc (current-window-configuration)) + (sel-win (selected-window)) + (titles '((column . "# Column Formulas\n") + (field . "# Field Formulas\n") + (named . "# Named Field Formulas\n"))) + entry s type title) + (org-switch-to-buffer-other-window "*Edit Formulas*") + (erase-buffer) + ;; Keep global-font-lock-mode from turning on font-lock-mode + (let ((font-lock-global-modes '(not fundamental-mode))) + (fundamental-mode)) + (org-set-local 'font-lock-global-modes (list 'not major-mode)) + (org-set-local 'org-pos pos) + (org-set-local 'org-window-configuration wc) + (org-set-local 'org-selected-window sel-win) + (use-local-map org-table-fedit-map) + (org-add-hook 'post-command-hook 'org-table-fedit-post-command t t) + (easy-menu-add org-table-fedit-menu) + (setq startline (org-current-line)) + (while (setq entry (pop eql)) + (setq type (cond + ((equal (string-to-char (car entry)) ?@) 'field) + ((string-match "^[0-9]" (car entry)) 'column) + (t 'named))) + (when (setq title (assq type titles)) + (or (bobp) (insert "\n")) + (insert (org-add-props (cdr title) nil 'face font-lock-comment-face)) + (setq titles (delq title titles))) + (if (equal key (car entry)) (setq startline (org-current-line))) + (setq s (concat (if (equal (string-to-char (car entry)) ?@) "" "$") + (car entry) " = " (cdr entry) "\n")) + (remove-text-properties 0 (length s) '(face nil) s) + (insert s)) + (if (eq org-table-use-standard-references t) + (org-table-fedit-toggle-ref-type)) + (org-goto-line startline) + (message "Edit formulas, finish with `C-c C-c' or `C-c ' '. See menu for more commands."))) + +(defun org-table-fedit-post-command () + (when (not (memq this-command '(lisp-complete-symbol))) + (let ((win (selected-window))) + (save-excursion + (condition-case nil + (org-table-show-reference) + (error nil)) + (select-window win))))) + +(defun org-table-formula-to-user (s) + "Convert a formula from internal to user representation." + (if (eq org-table-use-standard-references t) + (org-table-convert-refs-to-an s) + s)) + +(defun org-table-formula-from-user (s) + "Convert a formula from user to internal representation." + (if org-table-use-standard-references + (org-table-convert-refs-to-rc s) + s)) + +(defun org-table-convert-refs-to-rc (s) + "Convert spreadsheet references from AB7 to @7$28. +Works for single references, but also for entire formulas and even the +full TBLFM line." + (let ((start 0)) + (while (string-match "\\<\\([a-zA-Z]+\\)\\([0-9]+\\>\\|&\\)\\|\\(;[^\r\n:]+\\|\\<remote([^)]*)\\)" s start) + (cond + ((match-end 3) + ;; format match, just advance + (setq start (match-end 0))) + ((and (> (match-beginning 0) 0) + (equal ?. (aref s (max (1- (match-beginning 0)) 0))) + (not (equal ?. (aref s (max (- (match-beginning 0) 2) 0))))) + ;; 3.e5 or something like this. + (setq start (match-end 0))) + ((or (> (- (match-end 1) (match-beginning 1)) 2) + ;; (member (match-string 1 s) + ;; '("arctan" "exp" "expm" "lnp" "log" "stir")) + ) + ;; function name, just advance + (setq start (match-end 0))) + (t + (setq start (match-beginning 0) + s (replace-match + (if (equal (match-string 2 s) "&") + (format "$%d" (org-letters-to-number (match-string 1 s))) + (format "@%d$%d" + (string-to-number (match-string 2 s)) + (org-letters-to-number (match-string 1 s)))) + t t s))))) + s)) + +(defun org-table-convert-refs-to-an (s) + "Convert spreadsheet references from to @7$28 to AB7. +Works for single references, but also for entire formulas and even the +full TBLFM line." + (while (string-match "@\\([0-9]+\\)\\$\\([0-9]+\\)" s) + (setq s (replace-match + (format "%s%d" + (org-number-to-letters + (string-to-number (match-string 2 s))) + (string-to-number (match-string 1 s))) + t t s))) + (while (string-match "\\(^\\|[^0-9a-zA-Z]\\)\\$\\([0-9]+\\)" s) + (setq s (replace-match (concat "\\1" + (org-number-to-letters + (string-to-number (match-string 2 s))) "&") + t nil s))) + s) + +(defun org-letters-to-number (s) + "Convert a base 26 number represented by letters into an integer. +For example: AB -> 28." + (let ((n 0)) + (setq s (upcase s)) + (while (> (length s) 0) + (setq n (+ (* n 26) (string-to-char s) (- ?A) 1) + s (substring s 1))) + n)) + +(defun org-number-to-letters (n) + "Convert an integer into a base 26 number represented by letters. +For example: 28 -> AB." + (let ((s "")) + (while (> n 0) + (setq s (concat (char-to-string (+ (mod (1- n) 26) ?A)) s) + n (/ (1- n) 26))) + s)) + +(defun org-table-fedit-convert-buffer (function) + "Convert all references in this buffer, using FUNCTION." + (let ((line (org-current-line))) + (goto-char (point-min)) + (while (not (eobp)) + (insert (funcall function (buffer-substring (point) (point-at-eol)))) + (delete-region (point) (point-at-eol)) + (or (eobp) (forward-char 1))) + (org-goto-line line))) + +(defun org-table-fedit-toggle-ref-type () + "Convert all references in the buffer from B3 to @3$2 and back." + (interactive) + (org-set-local 'org-table-buffer-is-an (not org-table-buffer-is-an)) + (org-table-fedit-convert-buffer + (if org-table-buffer-is-an + 'org-table-convert-refs-to-an 'org-table-convert-refs-to-rc)) + (message "Reference type switched to %s" + (if org-table-buffer-is-an "A1 etc" "@row$column"))) + +(defun org-table-fedit-ref-up () + "Shift the reference at point one row/hline up." + (interactive) + (org-table-fedit-shift-reference 'up)) +(defun org-table-fedit-ref-down () + "Shift the reference at point one row/hline down." + (interactive) + (org-table-fedit-shift-reference 'down)) +(defun org-table-fedit-ref-left () + "Shift the reference at point one field to the left." + (interactive) + (org-table-fedit-shift-reference 'left)) +(defun org-table-fedit-ref-right () + "Shift the reference at point one field to the right." + (interactive) + (org-table-fedit-shift-reference 'right)) + +(defun org-table-fedit-shift-reference (dir) + (cond + ((org-at-regexp-p "\\(\\<[a-zA-Z]\\)&") + (if (memq dir '(left right)) + (org-rematch-and-replace 1 (eq dir 'left)) + (error "Cannot shift reference in this direction"))) + ((org-at-regexp-p "\\(\\<[a-zA-Z]\\{1,2\\}\\)\\([0-9]+\\)") + ;; A B3-like reference + (if (memq dir '(up down)) + (org-rematch-and-replace 2 (eq dir 'up)) + (org-rematch-and-replace 1 (eq dir 'left)))) + ((org-at-regexp-p + "\\(@\\|\\.\\.\\)\\([-+]?\\(I+\\>\\|[0-9]+\\)\\)\\(\\$\\([-+]?[0-9]+\\)\\)?") + ;; An internal reference + (if (memq dir '(up down)) + (org-rematch-and-replace 2 (eq dir 'up) (match-end 3)) + (org-rematch-and-replace 5 (eq dir 'left)))))) + +(defun org-rematch-and-replace (n &optional decr hline) + "Re-match the group N, and replace it with the shifted reference." + (or (match-end n) (error "Cannot shift reference in this direction")) + (goto-char (match-beginning n)) + (and (looking-at (regexp-quote (match-string n))) + (replace-match (org-table-shift-refpart (match-string 0) decr hline) + t t))) + +(defun org-table-shift-refpart (ref &optional decr hline) + "Shift a reference part REF. +If DECR is set, decrease the references row/column, else increase. +If HLINE is set, this may be a hline reference, it certainly is not +a translation reference." + (save-match-data + (let* ((sign (string-match "^[-+]" ref)) n) + + (if sign (setq sign (substring ref 0 1) ref (substring ref 1))) + (cond + ((and hline (string-match "^I+" ref)) + (setq n (string-to-number (concat sign (number-to-string (length ref))))) + (setq n (+ n (if decr -1 1))) + (if (= n 0) (setq n (+ n (if decr -1 1)))) + (if sign + (setq sign (if (< n 0) "-" "+") n (abs n)) + (setq n (max 1 n))) + (concat sign (make-string n ?I))) + + ((string-match "^[0-9]+" ref) + (setq n (string-to-number (concat sign ref))) + (setq n (+ n (if decr -1 1))) + (if sign + (concat (if (< n 0) "-" "+") (number-to-string (abs n))) + (number-to-string (max 1 n)))) + + ((string-match "^[a-zA-Z]+" ref) + (org-number-to-letters + (max 1 (+ (org-letters-to-number ref) (if decr -1 1))))) + + (t (error "Cannot shift reference")))))) + +(defun org-table-fedit-toggle-coordinates () + "Toggle the display of coordinates in the referenced table." + (interactive) + (let ((pos (marker-position org-pos))) + (with-current-buffer (marker-buffer org-pos) + (save-excursion + (goto-char pos) + (org-table-toggle-coordinate-overlays))))) + +(defun org-table-fedit-finish (&optional arg) + "Parse the buffer for formula definitions and install them. +With prefix ARG, apply the new formulas to the table." + (interactive "P") + (org-table-remove-rectangle-highlight) + (if org-table-use-standard-references + (progn + (org-table-fedit-convert-buffer 'org-table-convert-refs-to-rc) + (setq org-table-buffer-is-an nil))) + (let ((pos org-pos) (sel-win org-selected-window) eql var form) + (goto-char (point-min)) + (while (re-search-forward + "^\\(@[0-9]+\\$[0-9]+\\|\\$\\([a-zA-Z0-9]+\\)\\) *= *\\(.*\\(\n[ \t]+.*$\\)*\\)" + nil t) + (setq var (if (match-end 2) (match-string 2) (match-string 1)) + form (match-string 3)) + (setq form (org-trim form)) + (when (not (equal form "")) + (while (string-match "[ \t]*\n[ \t]*" form) + (setq form (replace-match " " t t form))) + (when (assoc var eql) + (error "Double formulas for %s" var)) + (push (cons var form) eql))) + (setq org-pos nil) + (set-window-configuration org-window-configuration) + (select-window sel-win) + (goto-char pos) + (unless (org-at-table-p) + (error "Lost table position - cannot install formulas")) + (org-table-store-formulas eql) + (move-marker pos nil) + (kill-buffer "*Edit Formulas*") + (if arg + (org-table-recalculate 'all) + (message "New formulas installed - press C-u C-c C-c to apply.")))) + +(defun org-table-fedit-abort () + "Abort editing formulas, without installing the changes." + (interactive) + (org-table-remove-rectangle-highlight) + (let ((pos org-pos) (sel-win org-selected-window)) + (set-window-configuration org-window-configuration) + (select-window sel-win) + (goto-char pos) + (move-marker pos nil) + (message "Formula editing aborted without installing changes"))) + +(defun org-table-fedit-lisp-indent () + "Pretty-print and re-indent Lisp expressions in the Formula Editor." + (interactive) + (let ((pos (point)) beg end ind) + (beginning-of-line 1) + (cond + ((looking-at "[ \t]") + (goto-char pos) + (call-interactively 'lisp-indent-line)) + ((looking-at "[$&@0-9a-zA-Z]+ *= *[^ \t\n']") (goto-char pos)) + ((not (fboundp 'pp-buffer)) + (error "Cannot pretty-print. Command `pp-buffer' is not available")) + ((looking-at "[$&@0-9a-zA-Z]+ *= *'(") + (goto-char (- (match-end 0) 2)) + (setq beg (point)) + (setq ind (make-string (current-column) ?\ )) + (condition-case nil (forward-sexp 1) + (error + (error "Cannot pretty-print Lisp expression: Unbalanced parenthesis"))) + (setq end (point)) + (save-restriction + (narrow-to-region beg end) + (if (eq last-command this-command) + (progn + (goto-char (point-min)) + (setq this-command nil) + (while (re-search-forward "[ \t]*\n[ \t]*" nil t) + (replace-match " "))) + (pp-buffer) + (untabify (point-min) (point-max)) + (goto-char (1+ (point-min))) + (while (re-search-forward "^." nil t) + (beginning-of-line 1) + (insert ind)) + (goto-char (point-max)) + (backward-delete-char 1))) + (goto-char beg)) + (t nil)))) + +(defvar org-show-positions nil) + +(defun org-table-show-reference (&optional local) + "Show the location/value of the $ expression at point." + (interactive) + (org-table-remove-rectangle-highlight) + (catch 'exit + (let ((pos (if local (point) org-pos)) + (face2 'highlight) + (org-inhibit-highlight-removal t) + (win (selected-window)) + (org-show-positions nil) + var name e what match dest) + (if local (org-table-get-specials)) + (setq what (cond + ((or (org-at-regexp-p org-table-range-regexp2) + (org-at-regexp-p org-table-translate-regexp) + (org-at-regexp-p org-table-range-regexp)) + (setq match + (save-match-data + (org-table-convert-refs-to-rc (match-string 0)))) + 'range) + ((org-at-regexp-p "\\$[a-zA-Z][a-zA-Z0-9]*") 'name) + ((org-at-regexp-p "\\$[0-9]+") 'column) + ((not local) nil) + (t (error "No reference at point"))) + match (and what (or match (match-string 0)))) + (when (and match (not (equal (match-beginning 0) (point-at-bol)))) + (org-table-add-rectangle-overlay (match-beginning 0) (match-end 0) + 'secondary-selection)) + (org-add-hook 'before-change-functions + 'org-table-remove-rectangle-highlight) + (if (eq what 'name) (setq var (substring match 1))) + (when (eq what 'range) + (or (equal (string-to-char match) ?@) (setq match (concat "@" match))) + (setq match (org-table-formula-substitute-names match))) + (unless local + (save-excursion + (end-of-line 1) + (re-search-backward "^\\S-" nil t) + (beginning-of-line 1) + (when (looking-at "\\(\\$[0-9a-zA-Z]+\\|@[0-9]+\\$[0-9]+\\|[a-zA-Z]+\\([0-9]+\\|&\\)\\) *=") + (setq dest + (save-match-data + (org-table-convert-refs-to-rc (match-string 1)))) + (org-table-add-rectangle-overlay + (match-beginning 1) (match-end 1) face2)))) + (if (and (markerp pos) (marker-buffer pos)) + (if (get-buffer-window (marker-buffer pos)) + (select-window (get-buffer-window (marker-buffer pos))) + (org-switch-to-buffer-other-window (get-buffer-window + (marker-buffer pos))))) + (goto-char pos) + (org-table-force-dataline) + (when dest + (setq name (substring dest 1)) + (cond + ((string-match "^\\$[a-zA-Z][a-zA-Z0-9]*" dest) + (setq e (assoc name org-table-named-field-locations)) + (org-goto-line (nth 1 e)) + (org-table-goto-column (nth 2 e))) + ((string-match "^@\\([0-9]+\\)\\$\\([0-9]+\\)" dest) + (let ((l (string-to-number (match-string 1 dest))) + (c (string-to-number (match-string 2 dest)))) + (org-goto-line (aref org-table-dlines l)) + (org-table-goto-column c))) + (t (org-table-goto-column (string-to-number name)))) + (move-marker pos (point)) + (org-table-highlight-rectangle nil nil face2)) + (cond + ((equal dest match)) + ((not match)) + ((eq what 'range) + (condition-case nil + (save-excursion + (org-table-get-range match nil nil 'highlight)) + (error nil))) + ((setq e (assoc var org-table-named-field-locations)) + (org-goto-line (nth 1 e)) + (org-table-goto-column (nth 2 e)) + (org-table-highlight-rectangle (point) (point)) + (message "Named field, column %d of line %d" (nth 2 e) (nth 1 e))) + ((setq e (assoc var org-table-column-names)) + (org-table-goto-column (string-to-number (cdr e))) + (org-table-highlight-rectangle (point) (point)) + (goto-char (org-table-begin)) + (if (re-search-forward (concat "^[ \t]*| *! *.*?| *\\(" var "\\) *|") + (org-table-end) t) + (progn + (goto-char (match-beginning 1)) + (org-table-highlight-rectangle) + (message "Named column (column %s)" (cdr e))) + (error "Column name not found"))) + ((eq what 'column) + ;; column number + (org-table-goto-column (string-to-number (substring match 1))) + (org-table-highlight-rectangle (point) (point)) + (message "Column %s" (substring match 1))) + ((setq e (assoc var org-table-local-parameters)) + (goto-char (org-table-begin)) + (if (re-search-forward (concat "^[ \t]*| *\\$ *.*?| *\\(" var "=\\)") nil t) + (progn + (goto-char (match-beginning 1)) + (org-table-highlight-rectangle) + (message "Local parameter.")) + (error "Parameter not found"))) + (t + (cond + ((not var) (error "No reference at point")) + ((setq e (assoc var org-table-formula-constants-local)) + (message "Local Constant: $%s=%s in #+CONSTANTS line." + var (cdr e))) + ((setq e (assoc var org-table-formula-constants)) + (message "Constant: $%s=%s in `org-table-formula-constants'." + var (cdr e))) + ((setq e (and (fboundp 'constants-get) (constants-get var))) + (message "Constant: $%s=%s, from `constants.el'%s." + var e (format " (%s units)" constants-unit-system))) + (t (error "Undefined name $%s" var))))) + (goto-char pos) + (when (and org-show-positions + (not (memq this-command '(org-table-fedit-scroll + org-table-fedit-scroll-down)))) + (push pos org-show-positions) + (push org-table-current-begin-pos org-show-positions) + (let ((min (apply 'min org-show-positions)) + (max (apply 'max org-show-positions))) + (goto-char min) (recenter 0) + (goto-char max) + (or (pos-visible-in-window-p max) (recenter -1)))) + (select-window win)))) + +(defun org-table-force-dataline () + "Make sure the cursor is in a dataline in a table." + (unless (save-excursion + (beginning-of-line 1) + (looking-at org-table-dataline-regexp)) + (let* ((re org-table-dataline-regexp) + (p1 (save-excursion (re-search-forward re nil 'move))) + (p2 (save-excursion (re-search-backward re nil 'move)))) + (cond ((and p1 p2) + (goto-char (if (< (abs (- p1 (point))) (abs (- p2 (point)))) + p1 p2))) + ((or p1 p2) (goto-char (or p1 p2))) + (t (error "No table dataline around here")))))) + +(defun org-table-fedit-line-up () + "Move cursor one line up in the window showing the table." + (interactive) + (org-table-fedit-move 'previous-line)) + +(defun org-table-fedit-line-down () + "Move cursor one line down in the window showing the table." + (interactive) + (org-table-fedit-move 'next-line)) + +(defun org-table-fedit-move (command) + "Move the cursor in the window showing the table. +Use COMMAND to do the motion, repeat if necessary to end up in a data line." + (let ((org-table-allow-automatic-line-recalculation nil) + (pos org-pos) (win (selected-window)) p) + (select-window (get-buffer-window (marker-buffer org-pos))) + (setq p (point)) + (call-interactively command) + (while (and (org-at-table-p) + (org-at-table-hline-p)) + (call-interactively command)) + (or (org-at-table-p) (goto-char p)) + (move-marker pos (point)) + (select-window win))) + +(defun org-table-fedit-scroll (N) + (interactive "p") + (let ((other-window-scroll-buffer (marker-buffer org-pos))) + (scroll-other-window N))) + +(defun org-table-fedit-scroll-down (N) + (interactive "p") + (org-table-fedit-scroll (- N))) + +(defvar org-table-rectangle-overlays nil) + +(defun org-table-add-rectangle-overlay (beg end &optional face) + "Add a new overlay." + (let ((ov (make-overlay beg end))) + (overlay-put ov 'face (or face 'secondary-selection)) + (push ov org-table-rectangle-overlays))) + +(defun org-table-highlight-rectangle (&optional beg end face) + "Highlight rectangular region in a table." + (setq beg (or beg (point)) end (or end (point))) + (let ((b (min beg end)) + (e (max beg end)) + l1 c1 l2 c2 tmp) + (and (boundp 'org-show-positions) + (setq org-show-positions (cons b (cons e org-show-positions)))) + (goto-char (min beg end)) + (setq l1 (org-current-line) + c1 (org-table-current-column)) + (goto-char (max beg end)) + (setq l2 (org-current-line) + c2 (org-table-current-column)) + (if (> c1 c2) (setq tmp c1 c1 c2 c2 tmp)) + (org-goto-line l1) + (beginning-of-line 1) + (loop for line from l1 to l2 do + (when (looking-at org-table-dataline-regexp) + (org-table-goto-column c1) + (skip-chars-backward "^|\n") (setq beg (point)) + (org-table-goto-column c2) + (skip-chars-forward "^|\n") (setq end (point)) + (org-table-add-rectangle-overlay beg end face)) + (beginning-of-line 2)) + (goto-char b)) + (add-hook 'before-change-functions 'org-table-remove-rectangle-highlight)) + +(defun org-table-remove-rectangle-highlight (&rest ignore) + "Remove the rectangle overlays." + (unless org-inhibit-highlight-removal + (remove-hook 'before-change-functions 'org-table-remove-rectangle-highlight) + (mapc 'delete-overlay org-table-rectangle-overlays) + (setq org-table-rectangle-overlays nil))) + +(defvar org-table-coordinate-overlays nil + "Collects the coordinate grid overlays, so that they can be removed.") +(make-variable-buffer-local 'org-table-coordinate-overlays) + +(defun org-table-overlay-coordinates () + "Add overlays to the table at point, to show row/column coordinates." + (interactive) + (mapc 'delete-overlay org-table-coordinate-overlays) + (setq org-table-coordinate-overlays nil) + (save-excursion + (let ((id 0) (ih 0) hline eol s1 s2 str ic ov beg) + (goto-char (org-table-begin)) + (while (org-at-table-p) + (setq eol (point-at-eol)) + (setq ov (make-overlay (point-at-bol) (1+ (point-at-bol)))) + (push ov org-table-coordinate-overlays) + (setq hline (looking-at org-table-hline-regexp)) + (setq str (if hline (format "I*%-2d" (setq ih (1+ ih))) + (format "%4d" (setq id (1+ id))))) + (org-overlay-before-string ov str 'org-special-keyword 'evaporate) + (when hline + (setq ic 0) + (while (re-search-forward "[+|]\\(-+\\)" eol t) + (setq beg (1+ (match-beginning 0)) + ic (1+ ic) + s1 (concat "$" (int-to-string ic)) + s2 (org-number-to-letters ic) + str (if (eq org-table-use-standard-references t) s2 s1)) + (setq ov (make-overlay beg (+ beg (length str)))) + (push ov org-table-coordinate-overlays) + (org-overlay-display ov str 'org-special-keyword 'evaporate))) + (beginning-of-line 2))))) + +(defun org-table-toggle-coordinate-overlays () + "Toggle the display of Row/Column numbers in tables." + (interactive) + (setq org-table-overlay-coordinates (not org-table-overlay-coordinates)) + (message "Row/Column number display turned %s" + (if org-table-overlay-coordinates "on" "off")) + (if (and (org-at-table-p) org-table-overlay-coordinates) + (org-table-align)) + (unless org-table-overlay-coordinates + (mapc 'delete-overlay org-table-coordinate-overlays) + (setq org-table-coordinate-overlays nil))) + +(defun org-table-toggle-formula-debugger () + "Toggle the formula debugger in tables." + (interactive) + (setq org-table-formula-debug (not org-table-formula-debug)) + (message "Formula debugging has been turned %s" + (if org-table-formula-debug "on" "off"))) + +;;; The orgtbl minor mode + +;; Define a minor mode which can be used in other modes in order to +;; integrate the org-mode table editor. + +;; This is really a hack, because the org-mode table editor uses several +;; keys which normally belong to the major mode, for example the TAB and +;; RET keys. Here is how it works: The minor mode defines all the keys +;; necessary to operate the table editor, but wraps the commands into a +;; function which tests if the cursor is currently inside a table. If that +;; is the case, the table editor command is executed. However, when any of +;; those keys is used outside a table, the function uses `key-binding' to +;; look up if the key has an associated command in another currently active +;; keymap (minor modes, major mode, global), and executes that command. +;; There might be problems if any of the keys used by the table editor is +;; otherwise used as a prefix key. + +;; Another challenge is that the key binding for TAB can be tab or \C-i, +;; likewise the binding for RET can be return or \C-m. Orgtbl-mode +;; addresses this by checking explicitly for both bindings. + +;; The optimized version (see variable `orgtbl-optimized') takes over +;; all keys which are bound to `self-insert-command' in the *global map*. +;; Some modes bind other commands to simple characters, for example +;; AUCTeX binds the double quote to `Tex-insert-quote'. With orgtbl-mode +;; active, this binding is ignored inside tables and replaced with a +;; modified self-insert. + + +(defvar orgtbl-mode-map (make-keymap) + "Keymap for `orgtbl-mode'.") + +;;;###autoload +(defun turn-on-orgtbl () + "Unconditionally turn on `orgtbl-mode'." + (orgtbl-mode 1)) + +(defvar org-old-auto-fill-inhibit-regexp nil + "Local variable used by `orgtbl-mode'.") + +(defconst orgtbl-line-start-regexp + "[ \t]*\\(|\\|#\\+\\(TBLFM\\|ORGTBL\\|TBLNAME\\):\\)" + "Matches a line belonging to an orgtbl.") + +(defconst orgtbl-extra-font-lock-keywords + (list (list (concat "^" orgtbl-line-start-regexp ".*") + 0 (quote 'org-table) 'prepend)) + "Extra `font-lock-keywords' to be added when `orgtbl-mode' is active.") + +;; Install it as a minor mode. +(put 'orgtbl-mode :included t) +(put 'orgtbl-mode :menu-tag "Org Table Mode") + +;;;###autoload +(define-minor-mode orgtbl-mode + "The `org-mode' table editor as a minor mode for use in other modes." + :lighter " OrgTbl" :keymap orgtbl-mode-map + (org-load-modules-maybe) + (cond + ((org-mode-p) + ;; Exit without error, in case some hook functions calls this + ;; by accident in org-mode. + (message "Orgtbl-mode is not useful in org-mode, command ignored")) + (orgtbl-mode + (and (orgtbl-setup) (defun orgtbl-setup () nil)) ;; FIXME: Yuck!?! + ;; Make sure we are first in minor-mode-map-alist + (let ((c (assq 'orgtbl-mode minor-mode-map-alist))) + ;; FIXME: maybe it should use emulation-mode-map-alists? + (and c (setq minor-mode-map-alist + (cons c (delq c minor-mode-map-alist))))) + (org-set-local (quote org-table-may-need-update) t) + (org-add-hook 'before-change-functions 'org-before-change-function + nil 'local) + (org-set-local 'org-old-auto-fill-inhibit-regexp + auto-fill-inhibit-regexp) + (org-set-local 'auto-fill-inhibit-regexp + (if auto-fill-inhibit-regexp + (concat orgtbl-line-start-regexp "\\|" + auto-fill-inhibit-regexp) + orgtbl-line-start-regexp)) + (add-to-invisibility-spec '(org-cwidth)) + (when (fboundp 'font-lock-add-keywords) + (font-lock-add-keywords nil orgtbl-extra-font-lock-keywords) + (org-restart-font-lock)) + (easy-menu-add orgtbl-mode-menu)) + (t + (setq auto-fill-inhibit-regexp org-old-auto-fill-inhibit-regexp) + (org-table-cleanup-narrow-column-properties) + (org-remove-from-invisibility-spec '(org-cwidth)) + (remove-hook 'before-change-functions 'org-before-change-function t) + (when (fboundp 'font-lock-remove-keywords) + (font-lock-remove-keywords nil orgtbl-extra-font-lock-keywords) + (org-restart-font-lock)) + (easy-menu-remove orgtbl-mode-menu) + (force-mode-line-update 'all)))) + +(defun org-table-cleanup-narrow-column-properties () + "Remove all properties related to narrow-column invisibility." + (let ((s 1)) + (while (setq s (text-property-any s (point-max) + 'display org-narrow-column-arrow)) + (remove-text-properties s (1+ s) '(display t))) + (setq s 1) + (while (setq s (text-property-any s (point-max) 'org-cwidth 1)) + (remove-text-properties s (1+ s) '(org-cwidth t))) + (setq s 1) + (while (setq s (text-property-any s (point-max) 'invisible 'org-cwidth)) + (remove-text-properties s (1+ s) '(invisible t))))) + +(defun orgtbl-make-binding (fun n &rest keys) + "Create a function for binding in the table minor mode. +FUN is the command to call inside a table. N is used to create a unique +command name. KEYS are keys that should be checked in for a command +to execute outside of tables." + (eval + (list 'defun + (intern (concat "orgtbl-hijacker-command-" (int-to-string n))) + '(arg) + (concat "In tables, run `" (symbol-name fun) "'.\n" + "Outside of tables, run the binding of `" + (mapconcat (lambda (x) (format "%s" x)) keys "' or `") + "'.") + '(interactive "p") + (list 'if + '(org-at-table-p) + (list 'call-interactively (list 'quote fun)) + (list 'let '(orgtbl-mode) + (list 'call-interactively + (append '(or) + (mapcar (lambda (k) + (list 'key-binding k)) + keys) + '('orgtbl-error)))))))) + +(defun orgtbl-error () + "Error when there is no default binding for a table key." + (interactive) + (error "This key has no function outside tables")) + +(defun orgtbl-setup () + "Setup orgtbl keymaps." + (let ((nfunc 0) + (bindings + '(([(meta shift left)] org-table-delete-column) + ([(meta left)] org-table-move-column-left) + ([(meta right)] org-table-move-column-right) + ([(meta shift right)] org-table-insert-column) + ([(meta shift up)] org-table-kill-row) + ([(meta shift down)] org-table-insert-row) + ([(meta up)] org-table-move-row-up) + ([(meta down)] org-table-move-row-down) + ("\C-c\C-w" org-table-cut-region) + ("\C-c\M-w" org-table-copy-region) + ("\C-c\C-y" org-table-paste-rectangle) + ("\C-c-" org-table-insert-hline) + ("\C-c}" org-table-toggle-coordinate-overlays) + ("\C-c{" org-table-toggle-formula-debugger) + ("\C-m" org-table-next-row) + ([(shift return)] org-table-copy-down) + ("\C-c?" org-table-field-info) + ("\C-c " org-table-blank-field) + ("\C-c+" org-table-sum) + ("\C-c=" org-table-eval-formula) + ("\C-c'" org-table-edit-formulas) + ("\C-c`" org-table-edit-field) + ("\C-c*" org-table-recalculate) + ("\C-c^" org-table-sort-lines) + ("\M-a" org-table-beginning-of-field) + ("\M-e" org-table-end-of-field) + ([(control ?#)] org-table-rotate-recalc-marks))) + elt key fun cmd) + (while (setq elt (pop bindings)) + (setq nfunc (1+ nfunc)) + (setq key (org-key (car elt)) + fun (nth 1 elt) + cmd (orgtbl-make-binding fun nfunc key)) + (org-defkey orgtbl-mode-map key cmd)) + + ;; Special treatment needed for TAB and RET + (org-defkey orgtbl-mode-map [(return)] + (orgtbl-make-binding 'orgtbl-ret 100 [(return)] "\C-m")) + (org-defkey orgtbl-mode-map "\C-m" + (orgtbl-make-binding 'orgtbl-ret 101 "\C-m" [(return)])) + + (org-defkey orgtbl-mode-map [(tab)] + (orgtbl-make-binding 'orgtbl-tab 102 [(tab)] "\C-i")) + (org-defkey orgtbl-mode-map "\C-i" + (orgtbl-make-binding 'orgtbl-tab 103 "\C-i" [(tab)])) + + (org-defkey orgtbl-mode-map [(shift tab)] + (orgtbl-make-binding 'org-table-previous-field 104 + [(shift tab)] [(tab)] "\C-i")) + + + (unless (featurep 'xemacs) + (org-defkey orgtbl-mode-map [S-iso-lefttab] + (orgtbl-make-binding 'org-table-previous-field 107 + [S-iso-lefttab] [backtab] [(shift tab)] + [(tab)] "\C-i"))) + + (org-defkey orgtbl-mode-map [backtab] + (orgtbl-make-binding 'org-table-previous-field 108 + [backtab] [S-iso-lefttab] [(shift tab)] + [(tab)] "\C-i")) + + (org-defkey orgtbl-mode-map "\M-\C-m" + (orgtbl-make-binding 'org-table-wrap-region 105 + "\M-\C-m" [(meta return)])) + (org-defkey orgtbl-mode-map [(meta return)] + (orgtbl-make-binding 'org-table-wrap-region 106 + [(meta return)] "\M-\C-m")) + + (org-defkey orgtbl-mode-map "\C-c\C-c" 'orgtbl-ctrl-c-ctrl-c) + (org-defkey orgtbl-mode-map "\C-c|" 'orgtbl-create-or-convert-from-region) + + (when orgtbl-optimized + ;; If the user wants maximum table support, we need to hijack + ;; some standard editing functions + (org-remap orgtbl-mode-map + 'self-insert-command 'orgtbl-self-insert-command + 'delete-char 'org-delete-char + 'delete-backward-char 'org-delete-backward-char) + (org-defkey orgtbl-mode-map "|" 'org-force-self-insert)) + (easy-menu-define orgtbl-mode-menu orgtbl-mode-map "OrgTbl menu" + '("OrgTbl" + ["Create or convert" org-table-create-or-convert-from-region + :active (not (org-at-table-p)) :keys "C-c |" ] + "--" + ["Align" org-ctrl-c-ctrl-c :active (org-at-table-p) :keys "C-c C-c"] + ["Next Field" org-cycle :active (org-at-table-p) :keys "TAB"] + ["Previous Field" org-shifttab :active (org-at-table-p) :keys "S-TAB"] + ["Next Row" org-return :active (org-at-table-p) :keys "RET"] + "--" + ["Blank Field" org-table-blank-field :active (org-at-table-p) :keys "C-c SPC"] + ["Edit Field" org-table-edit-field :active (org-at-table-p) :keys "C-c ` "] + ["Copy Field from Above" + org-table-copy-down :active (org-at-table-p) :keys "S-RET"] + "--" + ("Column" + ["Move Column Left" org-metaleft :active (org-at-table-p) :keys "M-<left>"] + ["Move Column Right" org-metaright :active (org-at-table-p) :keys "M-<right>"] + ["Delete Column" org-shiftmetaleft :active (org-at-table-p) :keys "M-S-<left>"] + ["Insert Column" org-shiftmetaright :active (org-at-table-p) :keys "M-S-<right>"]) + ("Row" + ["Move Row Up" org-metaup :active (org-at-table-p) :keys "M-<up>"] + ["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 :active (org-at-table-p) :keys "C-c ^"] + "--" + ["Insert Hline" org-table-insert-hline :active (org-at-table-p) :keys "C-c -"]) + ("Rectangle" + ["Copy Rectangle" org-copy-special :active (org-at-table-p)] + ["Cut Rectangle" org-cut-special :active (org-at-table-p)] + ["Paste Rectangle" org-paste-special :active (org-at-table-p)] + ["Fill Rectangle" org-table-wrap-region :active (org-at-table-p)]) + "--" + ("Radio tables" + ["Insert table template" orgtbl-insert-radio-table + (assq major-mode orgtbl-radio-table-templates)] + ["Comment/uncomment table" orgtbl-toggle-comment t]) + "--" + ["Set Column Formula" org-table-eval-formula :active (org-at-table-p) :keys "C-c ="] + ["Set Field Formula" (org-table-eval-formula '(4)) :active (org-at-table-p) :keys "C-u C-c ="] + ["Edit Formulas" org-table-edit-formulas :active (org-at-table-p) :keys "C-c '"] + ["Recalculate line" org-table-recalculate :active (org-at-table-p) :keys "C-c *"] + ["Recalculate all" (org-table-recalculate '(4)) :active (org-at-table-p) :keys "C-u C-c *"] + ["Iterate all" (org-table-recalculate '(16)) :active (org-at-table-p) :keys "C-u C-u C-c *"] + ["Toggle Recalculate Mark" org-table-rotate-recalc-marks :active (org-at-table-p) :keys "C-c #"] + ["Sum Column/Rectangle" org-table-sum + :active (or (org-at-table-p) (org-region-active-p)) :keys "C-c +"] + ["Which Column?" org-table-current-column :active (org-at-table-p) :keys "C-c ?"] + ["Debug Formulas" + org-table-toggle-formula-debugger :active (org-at-table-p) + :keys "C-c {" + :style toggle :selected org-table-formula-debug] + ["Show Col/Row Numbers" + org-table-toggle-coordinate-overlays :active (org-at-table-p) + :keys "C-c }" + :style toggle :selected org-table-overlay-coordinates] + )) + t)) + +(defun orgtbl-ctrl-c-ctrl-c (arg) + "If the cursor is inside a table, realign the table. +If it is a table to be sent away to a receiver, do it. +With prefix arg, also recompute table." + (interactive "P") + (let ((pos (point)) action) + (save-excursion + (beginning-of-line 1) + (setq action (cond ((looking-at "[ \t]*#\\+ORGTBL:.*\n[ \t]*|") (match-end 0)) + ((looking-at "[ \t]*|") pos) + ((looking-at "[ \t]*#\\+TBLFM:") 'recalc)))) + (cond + ((integerp action) + (goto-char action) + (org-table-maybe-eval-formula) + (if arg + (call-interactively 'org-table-recalculate) + (org-table-maybe-recalculate-line)) + (call-interactively 'org-table-align) + (when (orgtbl-send-table 'maybe) + (run-hooks 'orgtbl-after-send-table-hook))) + ((eq action 'recalc) + (save-excursion + (beginning-of-line 1) + (skip-chars-backward " \r\n\t") + (if (org-at-table-p) + (org-call-with-arg 'org-table-recalculate t)))) + (t (let (orgtbl-mode) + (call-interactively (key-binding "\C-c\C-c"))))))) + +(defun orgtbl-create-or-convert-from-region (arg) + "Create table or convert region to table, if no conflicting binding. +This installs the table binding `C-c |', but only if there is no +conflicting binding to this key outside orgtbl-mode." + (interactive "P") + (let* (orgtbl-mode (cmd (key-binding "\C-c|"))) + (if cmd + (call-interactively cmd) + (call-interactively 'org-table-create-or-convert-from-region)))) + +(defun orgtbl-tab (arg) + "Justification and field motion for `orgtbl-mode'." + (interactive "P") + (if arg (org-table-edit-field t) + (org-table-justify-field-maybe) + (org-table-next-field))) + +(defun orgtbl-ret () + "Justification and field motion for `orgtbl-mode'." + (interactive) + (if (bobp) + (newline) + (org-table-justify-field-maybe) + (org-table-next-row))) + +(defun orgtbl-self-insert-command (N) + "Like `self-insert-command', use overwrite-mode for whitespace in tables. +If the cursor is in a table looking at whitespace, the whitespace is +overwritten, and the table is not marked as requiring realignment." + (interactive "p") + (if (and (org-at-table-p) + (or + (and org-table-auto-blank-field + (member last-command + '(orgtbl-hijacker-command-100 + orgtbl-hijacker-command-101 + orgtbl-hijacker-command-102 + orgtbl-hijacker-command-103 + orgtbl-hijacker-command-104 + orgtbl-hijacker-command-105 + yas/expand)) + (org-table-blank-field)) + t) + (eq N 1) + (looking-at "[^|\n]* +|")) + (let (org-table-may-need-update) + (goto-char (1- (match-end 0))) + (delete-backward-char 1) + (goto-char (match-beginning 0)) + (self-insert-command N)) + (setq org-table-may-need-update t) + (let* (orgtbl-mode + a + (cmd (or (key-binding + (or (and (listp function-key-map) + (setq a (assoc last-input-event function-key-map)) + (cdr a)) + (vector last-input-event))) + 'self-insert-command))) + (call-interactively cmd) + (if (and org-self-insert-cluster-for-undo + (eq cmd 'self-insert-command)) + (if (not (eq last-command 'orgtbl-self-insert-command)) + (setq org-self-insert-command-undo-counter 1) + (if (>= org-self-insert-command-undo-counter 20) + (setq org-self-insert-command-undo-counter 1) + (and (> org-self-insert-command-undo-counter 0) + buffer-undo-list + (not (cadr buffer-undo-list)) ; remove nil entry + (setcdr buffer-undo-list (cddr buffer-undo-list))) + (setq org-self-insert-command-undo-counter + (1+ org-self-insert-command-undo-counter)))))))) + +(defvar orgtbl-exp-regexp "^\\([-+]?[0-9][0-9.]*\\)[eE]\\([-+]?[0-9]+\\)$" + "Regular expression matching exponentials as produced by calc.") + +(defun orgtbl-export (table target) + (require 'org-exp) + (let ((func (intern (concat "orgtbl-to-" (symbol-name target)))) + (lines (org-split-string table "[ \t]*\n[ \t]*")) + org-table-last-alignment org-table-last-column-widths + maxcol column) + (if (not (fboundp func)) + (error "Cannot export orgtbl table to %s" target)) + (setq lines (org-table-clean-before-export lines)) + (setq table + (mapcar + (lambda (x) + (if (string-match org-table-hline-regexp x) + 'hline + (org-split-string (org-trim x) "\\s-*|\\s-*"))) + lines)) + (setq maxcol (apply 'max (mapcar (lambda (x) (if (listp x) (length x) 0)) + table))) + (loop for i from (1- maxcol) downto 0 do + (setq column (mapcar (lambda (x) (if (listp x) (nth i x) nil)) table)) + (setq column (delq nil column)) + (push (apply 'max (mapcar 'string-width column)) org-table-last-column-widths) + (push (> (/ (apply '+ (mapcar (lambda (x) (if (string-match org-table-number-regexp x) 1 0)) column)) maxcol) org-table-number-fraction) org-table-last-alignment)) + (funcall func table nil))) + +(defun orgtbl-gather-send-defs () + "Gather a plist of :name, :transform, :params for each destination before +a radio table." + (save-excursion + (goto-char (org-table-begin)) + (let (rtn) + (beginning-of-line 0) + (while (looking-at "[ \t]*#\\+ORGTBL[: \t][ \t]*SEND[ \t]+\\([^ \t\r\n]+\\)[ \t]+\\([^ \t\r\n]+\\)\\([ \t]+.*\\)?") + (let ((name (org-no-properties (match-string 1))) + (transform (intern (match-string 2))) + (params (if (match-end 3) + (read (concat "(" (match-string 3) ")"))))) + (push (list :name name :transform transform :params params) + rtn) + (beginning-of-line 0))) + rtn))) + +(defun orgtbl-send-replace-tbl (name txt) + "Find and replace table NAME with TXT." + (save-excursion + (goto-char (point-min)) + (unless (re-search-forward + (concat "BEGIN RECEIVE ORGTBL +" name "\\([ \t]\\|$\\)") nil t) + (error "Don't know where to insert translated table")) + (goto-char (match-beginning 0)) + (beginning-of-line 2) + (save-excursion + (let ((beg (point))) + (unless (re-search-forward + (concat "END RECEIVE ORGTBL +" name) nil t) + (error "Cannot find end of insertion region")) + (beginning-of-line 1) + (delete-region beg (point)))) + (insert txt "\n"))) + +;;;###autoload +(defun org-table-to-lisp (&optional txt) + "Convert the table at point to a Lisp structure. +The structure will be a list. Each item is either the symbol `hline' +for a horizontal separator line, or a list of field values as strings. +The table is taken from the parameter TXT, or from the buffer at point." + (unless txt + (unless (org-at-table-p) + (error "No table at point"))) + (let* ((txt (or txt + (buffer-substring-no-properties (org-table-begin) + (org-table-end)))) + (lines (org-split-string txt "[ \t]*\n[ \t]*"))) + + (mapcar + (lambda (x) + (if (string-match org-table-hline-regexp x) + 'hline + (org-split-string (org-trim x) "\\s-*|\\s-*"))) + lines))) + +(defun orgtbl-send-table (&optional maybe) + "Send a transformed version of this table to the receiver position. +With argument MAYBE, fail quietly if no transformation is defined for +this table." + (interactive) + (catch 'exit + (unless (org-at-table-p) (error "Not at a table")) + ;; when non-interactive, we assume align has just happened. + (when (interactive-p) (org-table-align)) + (let ((dests (orgtbl-gather-send-defs)) + (txt (buffer-substring-no-properties (org-table-begin) + (org-table-end))) + (ntbl 0)) + (unless dests (if maybe (throw 'exit nil) + (error "Don't know how to transform this table"))) + (dolist (dest dests) + (let* ((name (plist-get dest :name)) + (transform (plist-get dest :transform)) + (params (plist-get dest :params)) + (skip (plist-get params :skip)) + (skipcols (plist-get params :skipcols)) + beg + (lines (org-table-clean-before-export + (nthcdr (or skip 0) + (org-split-string txt "[ \t]*\n[ \t]*")))) + (i0 (if org-table-clean-did-remove-column 2 1)) + (table (mapcar + (lambda (x) + (if (string-match org-table-hline-regexp x) + 'hline + (org-remove-by-index + (org-split-string (org-trim x) "\\s-*|\\s-*") + skipcols i0))) + lines)) + (fun (if (= i0 2) 'cdr 'identity)) + (org-table-last-alignment + (org-remove-by-index (funcall fun org-table-last-alignment) + skipcols i0)) + (org-table-last-column-widths + (org-remove-by-index (funcall fun org-table-last-column-widths) + skipcols i0)) + (txt (if (fboundp transform) + (funcall transform table params) + (error "No such transformation function %s" transform)))) + (orgtbl-send-replace-tbl name txt)) + (setq ntbl (1+ ntbl))) + (message "Table converted and installed at %d receiver location%s" + ntbl (if (> ntbl 1) "s" "")) + (if (> ntbl 0) + ntbl + nil)))) + +(defun org-remove-by-index (list indices &optional i0) + "Remove the elements in LIST with indices in INDICES. +First element has index 0, or I0 if given." + (if (not indices) + list + (if (integerp indices) (setq indices (list indices))) + (setq i0 (1- (or i0 0))) + (delq :rm (mapcar (lambda (x) + (setq i0 (1+ i0)) + (if (memq i0 indices) :rm x)) + list)))) + +(defun orgtbl-toggle-comment () + "Comment or uncomment the orgtbl at point." + (interactive) + (let* ((re1 (concat "^" (regexp-quote comment-start) orgtbl-line-start-regexp)) + (re2 (concat "^" orgtbl-line-start-regexp)) + (commented (save-excursion (beginning-of-line 1) + (cond ((looking-at re1) t) + ((looking-at re2) nil) + (t (error "Not at an org table"))))) + (re (if commented re1 re2)) + beg end) + (save-excursion + (beginning-of-line 1) + (while (looking-at re) (beginning-of-line 0)) + (beginning-of-line 2) + (setq beg (point)) + (while (looking-at re) (beginning-of-line 2)) + (setq end (point))) + (comment-region beg end (if commented '(4) nil)))) + +(defun orgtbl-insert-radio-table () + "Insert a radio table template appropriate for this major mode." + (interactive) + (let* ((e (assq major-mode orgtbl-radio-table-templates)) + (txt (nth 1 e)) + name pos) + (unless e (error "No radio table setup defined for %s" major-mode)) + (setq name (read-string "Table name: ")) + (while (string-match "%n" txt) + (setq txt (replace-match name t t txt))) + (or (bolp) (insert "\n")) + (setq pos (point)) + (insert txt) + (goto-char pos))) + +;; Dynamically bound input and output for table formatting. +(defvar *orgtbl-table* nil + "Carries the current table through formatting routines.") +(defvar *orgtbl-rtn* nil + "Formatting routines push the output lines here.") +;; Formatting parameters for the current table section. +(defvar *orgtbl-hline* nil "Text used for horizontal lines.") +(defvar *orgtbl-sep* nil "Text used as a column separator.") +(defvar *orgtbl-default-fmt* nil "Default format for each entry.") +(defvar *orgtbl-fmt* nil "Format for each entry.") +(defvar *orgtbl-efmt* nil "Format for numbers.") +(defvar *orgtbl-lfmt* nil "Format for an entire line, overrides fmt.") +(defvar *orgtbl-llfmt* nil "Specializes lfmt for the last row.") +(defvar *orgtbl-lstart* nil "Text starting a row.") +(defvar *orgtbl-llstart* nil "Specializes lstart for the last row.") +(defvar *orgtbl-lend* nil "Text ending a row.") +(defvar *orgtbl-llend* nil "Specializes lend for the last row.") + +(defsubst orgtbl-get-fmt (fmt i) + "Retrieve the format from FMT corresponding to the Ith column." + (if (and (not (functionp fmt)) (consp fmt)) + (plist-get fmt i) + fmt)) + +(defsubst orgtbl-apply-fmt (fmt &rest args) + "Apply format FMT to the arguments. NIL FMTs return the first argument." + (cond ((functionp fmt) (apply fmt args)) + (fmt (apply 'format fmt args)) + (args (car args)) + (t args))) + +(defsubst orgtbl-eval-str (str) + "If STR is a function, evaluate it with no arguments." + (if (functionp str) + (funcall str) + str)) + +(defun orgtbl-format-line (line) + "Format LINE as a table row." + (if (eq line 'hline) (if *orgtbl-hline* (push *orgtbl-hline* *orgtbl-rtn*)) + (let* ((i 0) + (line + (mapcar + (lambda (f) + (setq i (1+ i)) + (let* ((efmt (orgtbl-get-fmt *orgtbl-efmt* i)) + (f (if (and efmt (string-match orgtbl-exp-regexp f)) + (orgtbl-apply-fmt efmt (match-string 1 f) + (match-string 2 f)) + f))) + (orgtbl-apply-fmt (or (orgtbl-get-fmt *orgtbl-fmt* i) + *orgtbl-default-fmt*) + f))) + line))) + (push (if *orgtbl-lfmt* + (orgtbl-apply-fmt *orgtbl-lfmt* line) + (concat (orgtbl-eval-str *orgtbl-lstart*) + (mapconcat 'identity line *orgtbl-sep*) + (orgtbl-eval-str *orgtbl-lend*))) + *orgtbl-rtn*)))) + +(defun orgtbl-format-section (section-stopper) + "Format lines until the first occurrence of SECTION-STOPPER." + (let (prevline) + (progn + (while (not (eq (car *orgtbl-table*) section-stopper)) + (if prevline (orgtbl-format-line prevline)) + (setq prevline (pop *orgtbl-table*))) + (if prevline (let ((*orgtbl-lstart* *orgtbl-llstart*) + (*orgtbl-lend* *orgtbl-llend*) + (*orgtbl-lfmt* *orgtbl-llfmt*)) + (orgtbl-format-line prevline)))))) + +(defun orgtbl-to-generic (table params) + "Convert the orgtbl-mode TABLE to some other format. +This generic routine can be used for many standard cases. +TABLE is a list, each entry either the symbol `hline' for a horizontal +separator line, or a list of fields for that line. +PARAMS is a property list of parameters that can influence the conversion. +For the generic converter, some parameters are obligatory: You need to +specify either :lfmt, or all of (:lstart :lend :sep). + +Valid parameters are + +:splice When set to t, return only table body lines, don't wrap + them into :tstart and :tend. Default is nil. When :splice + is non-nil, this also means that the exporter should not look + for and interpret header and footer sections. + +:hline String to be inserted on horizontal separation lines. + May be nil to ignore hlines. + +:sep Separator between two fields +:remove-nil-lines Do not include lines that evaluate to nil. + + +Each in the following group may be either a string or a function +of no arguments returning a string: +:tstart String to start the table. Ignored when :splice is t. +:tend String to end the table. Ignored when :splice is t. +:lstart String to start a new table line. +:llstart String to start the last table line, defaults to :lstart. +:lend String to end a table line +:llend String to end the last table line, defaults to :lend. + +Each in the following group may be a string, a function of one +argument (the field or line) returning a string, or a plist +mapping columns to either of the above: +:lfmt Format for entire line, with enough %s to capture all fields. + If this is present, :lstart, :lend, and :sep are ignored. +:llfmt Format for the entire last line, defaults to :lfmt. +:fmt A format to be used to wrap the field, should contain + %s for the original field value. For example, to wrap + everything in dollars, you could use :fmt \"$%s$\". + This may also be a property list with column numbers and + formats. For example :fmt (2 \"$%s$\" 4 \"%s%%\") + +:hlstart :hllstart :hlend :hllend :hlsep :hlfmt :hllfmt :hfmt + Same as above, specific for the header lines in the table. + All lines before the first hline are treated as header. + If any of these is not present, the data line value is used. + +This may be either a string or a function of two arguments: +:efmt Use this format to print numbers with exponentials. + The format should have %s twice for inserting mantissa + and exponent, for example \"%s\\\\times10^{%s}\". This + may also be a property list with column numbers and + formats. :fmt will still be applied after :efmt. + +In addition to this, the parameters :skip and :skipcols are always handled +directly by `orgtbl-send-table'. See manual." + (interactive) + + (let* ((splicep (plist-get params :splice)) + (hline (plist-get params :hline)) + (remove-nil-linesp (plist-get params :remove-nil-lines)) + (remove-newlines (plist-get params :remove-newlines)) + (*orgtbl-hline* hline) + (*orgtbl-table* table) + (*orgtbl-sep* (plist-get params :sep)) + (*orgtbl-efmt* (plist-get params :efmt)) + (*orgtbl-lstart* (plist-get params :lstart)) + (*orgtbl-llstart* (or (plist-get params :llstart) *orgtbl-lstart*)) + (*orgtbl-lend* (plist-get params :lend)) + (*orgtbl-llend* (or (plist-get params :llend) *orgtbl-lend*)) + (*orgtbl-lfmt* (plist-get params :lfmt)) + (*orgtbl-llfmt* (or (plist-get params :llfmt) *orgtbl-lfmt*)) + (*orgtbl-fmt* (plist-get params :fmt)) + *orgtbl-rtn*) + + ;; Put header + (unless splicep + (when (plist-member params :tstart) + (let ((tstart (orgtbl-eval-str (plist-get params :tstart)))) + (if tstart (push tstart *orgtbl-rtn*))))) + + ;; Do we have a heading section? If so, format it and handle the + ;; trailing hline. + (if (and (not splicep) + (or (consp (car *orgtbl-table*)) + (consp (nth 1 *orgtbl-table*))) + (memq 'hline (cdr *orgtbl-table*))) + (progn + (when (eq 'hline (car *orgtbl-table*)) + ;; there is a hline before the first data line + (and hline (push hline *orgtbl-rtn*)) + (pop *orgtbl-table*)) + (let* ((*orgtbl-lstart* (or (plist-get params :hlstart) + *orgtbl-lstart*)) + (*orgtbl-llstart* (or (plist-get params :hllstart) + *orgtbl-llstart*)) + (*orgtbl-lend* (or (plist-get params :hlend) *orgtbl-lend*)) + (*orgtbl-llend* (or (plist-get params :hllend) + (plist-get params :hlend) *orgtbl-llend*)) + (*orgtbl-lfmt* (or (plist-get params :hlfmt) *orgtbl-lfmt*)) + (*orgtbl-llfmt* (or (plist-get params :hllfmt) + (plist-get params :hlfmt) *orgtbl-llfmt*)) + (*orgtbl-sep* (or (plist-get params :hlsep) *orgtbl-sep*)) + (*orgtbl-fmt* (or (plist-get params :hfmt) *orgtbl-fmt*))) + (orgtbl-format-section 'hline)) + (if hline (push hline *orgtbl-rtn*)) + (pop *orgtbl-table*))) + + ;; Now format the main section. + (orgtbl-format-section nil) + + (unless splicep + (when (plist-member params :tend) + (let ((tend (orgtbl-eval-str (plist-get params :tend)))) + (if tend (push tend *orgtbl-rtn*))))) + + (mapconcat (if remove-newlines + (lambda (tend) + (replace-regexp-in-string "[\n\r\t\f]" "\\\\n" tend)) + 'identity) + (nreverse (if remove-nil-linesp + (remq nil *orgtbl-rtn*) + *orgtbl-rtn*)) "\n"))) + +(defun orgtbl-to-tsv (table params) + "Convert the orgtbl-mode table to TAB separated material." + (orgtbl-to-generic table (org-combine-plists '(:sep "\t") params))) +(defun orgtbl-to-csv (table params) + "Convert the orgtbl-mode table to CSV material. +This does take care of the proper quoting of fields with comma or quotes." + (orgtbl-to-generic table (org-combine-plists + '(:sep "," :fmt org-quote-csv-field) + params))) + +(defun orgtbl-to-latex (table params) + "Convert the orgtbl-mode TABLE to LaTeX. +TABLE is a list, each entry either the symbol `hline' for a horizontal +separator line, or a list of fields for that line. +PARAMS is a property list of parameters that can influence the conversion. +Supports all parameters from `orgtbl-to-generic'. Most important for +LaTeX are: + +:splice When set to t, return only table body lines, don't wrap + them into a tabular environment. Default is nil. + +:fmt A format to be used to wrap the field, should contain %s for the + original field value. For example, to wrap everything in dollars, + use :fmt \"$%s$\". This may also be a property list with column + numbers and formats. For example :fmt (2 \"$%s$\" 4 \"%s%%\") + The format may also be a function that formats its one argument. + +:efmt Format for transforming numbers with exponentials. The format + should have %s twice for inserting mantissa and exponent, for + example \"%s\\\\times10^{%s}\". LaTeX default is \"%s\\\\,(%s)\". + This may also be a property list with column numbers and formats. + The format may also be a function that formats its two arguments. + +:llend If you find too much space below the last line of a table, + pass a value of \"\" for :llend to suppress the final \\\\. + +The general parameters :skip and :skipcols have already been applied when +this function is called." + (let* ((alignment (mapconcat (lambda (x) (if x "r" "l")) + org-table-last-alignment "")) + (params2 + (list + :tstart (concat "\\begin{tabular}{" alignment "}") + :tend "\\end{tabular}" + :lstart "" :lend " \\\\" :sep " & " + :efmt "%s\\,(%s)" :hline "\\hline"))) + (orgtbl-to-generic table (org-combine-plists params2 params)))) + +(defun orgtbl-to-html (table params) + "Convert the orgtbl-mode TABLE to HTML. +TABLE is a list, each entry either the symbol `hline' for a horizontal +separator line, or a list of fields for that line. +PARAMS is a property list of parameters that can influence the conversion. +Currently this function recognizes the following parameters: + +:splice When set to t, return only table body lines, don't wrap + them into a <table> environment. Default is nil. + +The general parameters :skip and :skipcols have already been applied when +this function is called. The function does *not* use `orgtbl-to-generic', +so you cannot specify parameters for it." + (let* ((splicep (plist-get params :splice)) + (html-table-tag org-export-html-table-tag) + html) + ;; Just call the formatter we already have + ;; We need to make text lines for it, so put the fields back together. + (setq html (org-format-org-table-html + (mapcar + (lambda (x) + (if (eq x 'hline) + "|----+----|" + (concat "| " (mapconcat 'org-html-expand x " | ") " |"))) + table) + splicep)) + (if (string-match "\n+\\'" html) + (setq html (replace-match "" t t html))) + html)) + +(defun orgtbl-to-texinfo (table params) + "Convert the orgtbl-mode TABLE to TeXInfo. +TABLE is a list, each entry either the symbol `hline' for a horizontal +separator line, or a list of fields for that line. +PARAMS is a property list of parameters that can influence the conversion. +Supports all parameters from `orgtbl-to-generic'. Most important for +TeXInfo are: + +:splice nil/t When set to t, return only table body lines, don't wrap + them into a multitable environment. Default is nil. + +:fmt fmt A format to be used to wrap the field, should contain + %s for the original field value. For example, to wrap + everything in @kbd{}, you could use :fmt \"@kbd{%s}\". + This may also be a property list with column numbers and + formats. For example :fmt (2 \"@kbd{%s}\" 4 \"@code{%s}\"). + Each format also may be a function that formats its one + argument. + +:cf \"f1 f2..\" The column fractions for the table. By default these + are computed automatically from the width of the columns + under org-mode. + +The general parameters :skip and :skipcols have already been applied when +this function is called." + (let* ((total (float (apply '+ org-table-last-column-widths))) + (colfrac (or (plist-get params :cf) + (mapconcat + (lambda (x) (format "%.3f" (/ (float x) total))) + org-table-last-column-widths " "))) + (params2 + (list + :tstart (concat "@multitable @columnfractions " colfrac) + :tend "@end multitable" + :lstart "@item " :lend "" :sep " @tab " + :hlstart "@headitem "))) + (orgtbl-to-generic table (org-combine-plists params2 params)))) + +(defun orgtbl-to-orgtbl (table params) + "Convert the orgtbl-mode TABLE into another orgtbl-mode table. +Useful when slicing one table into many. The :hline, :sep, +:lstart, and :lend provide orgtbl framing. The default nil :tstart +and :tend suppress strings without splicing; they can be set to +provide ORGTBL directives for the generated table." + (let* ((params2 + (list + :remove-newlines t + :tstart nil :tend nil + :hline "|---" + :sep " | " + :lstart "| " + :lend " |")) + (params (org-combine-plists params2 params))) + (orgtbl-to-generic table params))) + +(defun org-table-get-remote-range (name-or-id form) + "Get a field value or a list of values in a range from table at ID. + +NAME-OR-ID may be the name of a table in the current file as set by +a \"#+TBLNAME:\" directive. The first table following this line +will then be used. Alternatively, it may be an ID referring to +any entry, also in a different file. In this case, the first table +in that entry will be referenced. +FORM is a field or range descriptor like \"@2$3\" or or \"B3\" or +\"@I$2..@II$2\". All the references must be absolute, not relative. + +The return value is either a single string for a single field, or a +list of the fields in the rectangle ." + (save-match-data + (let ((id-loc nil) + org-table-column-names org-table-column-name-regexp + org-table-local-parameters org-table-named-field-locations + org-table-current-line-types org-table-current-begin-line + org-table-current-begin-pos org-table-dlines + org-table-hlines org-table-last-alignment + org-table-last-column-widths org-table-last-alignment + org-table-last-column-widths tbeg + buffer loc) + (setq form (org-table-convert-refs-to-rc form)) + (save-excursion + (save-restriction + (widen) + (save-excursion + (goto-char (point-min)) + (if (re-search-forward + (concat "^[ \t]*#\\+TBLNAME:[ \t]*" (regexp-quote name-or-id) "[ \t]*$") + nil t) + (setq buffer (current-buffer) loc (match-beginning 0)) + (setq id-loc (org-id-find name-or-id 'marker)) + (unless (and id-loc (markerp id-loc)) + (error "Can't find remote table \"%s\"" name-or-id)) + (setq buffer (marker-buffer id-loc) + loc (marker-position id-loc)) + (move-marker id-loc nil))) + (with-current-buffer buffer + (save-excursion + (save-restriction + (widen) + (goto-char loc) + (forward-char 1) + (unless (and (re-search-forward "^\\(\\*+ \\)\\|[ \t]*|" nil t) + (not (match-beginning 1))) + (error "Cannot find a table at NAME or ID %s" name-or-id)) + (setq tbeg (point-at-bol)) + (org-table-get-specials) + (setq form (org-table-formula-substitute-names form)) + (if (and (string-match org-table-range-regexp form) + (> (length (match-string 0 form)) 1)) + (save-match-data + (org-table-get-range (match-string 0 form) tbeg 1)) + form))))))))) + +(provide 'org-table) + +;; arch-tag: 4d21cfdd-0268-440a-84b0-09237a0fe0ef + +;;; org-table.el ends here diff --git a/.emacs.d/org-7.4/lisp/org-table.elc b/.emacs.d/org-7.4/lisp/org-table.elc Binary files differnew file mode 100644 index 0000000..5c38858 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-table.elc diff --git a/.emacs.d/org-7.4/lisp/org-taskjuggler.el b/.emacs.d/org-7.4/lisp/org-taskjuggler.el new file mode 100644 index 0000000..d78e10d --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-taskjuggler.el @@ -0,0 +1,648 @@ +;;; org-taskjuggler.el --- TaskJuggler exporter for org-mode +;; +;; Copyright (C) 2007, 2008, 2009, 2010 Free Software Foundation, Inc. +;; +;; Emacs Lisp Archive Entry +;; Filename: org-taskjuggler.el +;; Version: 7.4 +;; Author: Christian Egli +;; Maintainer: Christian Egli +;; Keywords: org, taskjuggler, project planning +;; Description: Converts an org-mode buffer into a taskjuggler project plan +;; URL: + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;; Commentary: +;; +;; This library implements a TaskJuggler exporter for org-mode. +;; TaskJuggler uses a text format to define projects, tasks and +;; resources, so it is a natural fit for org-mode. It can produce all +;; sorts of reports for tasks or resources in either HTML, CSV or PDF. +;; The current version of TaskJuggler requires KDE but the next +;; version is implemented in Ruby and should therefore run on any +;; platform. +;; +;; The exporter is a bit different from other exporters, such as the +;; HTML and LaTeX exporters for example, in that it does not export +;; all the nodes of a document or strictly follow the order of the +;; nodes in the document. +;; +;; Instead the TaskJuggler exporter looks for a tree that defines the +;; tasks and a optionally tree that defines the resources for this +;; project. It then creates a TaskJuggler file based on these trees +;; and the attributes defined in all the nodes. +;; +;; * Installation +;; +;; Put this file into your load-path and the following line into your +;; ~/.emacs: +;; +;; (require 'org-taskjuggler) +;; +;; The interactive functions are similar to those of the HTML and LaTeX +;; exporters: +;; +;; M-x `org-export-as-taskjuggler' +;; M-x `org-export-as-taskjuggler-and-open' +;; +;; * Tasks +;; +;; Let's illustrate the usage with a small example. Create your tasks +;; as you usually do with org-mode. Assign efforts to each task using +;; properties (it's easiest to do this in the column view). You should +;; end up with something similar to the example by Peter Jones in +;; http://www.contextualdevelopment.com/static/artifacts/articles/2008/project-planning/project-planning.org. +;; Now mark the top node of your tasks with a tag named +;; "taskjuggler_project" (or whatever you customized +;; `org-export-taskjuggler-project-tag' to). You are now ready to +;; export the project plan with `org-export-as-taskjuggler-and-open' +;; which will export the project plan and open a gant chart in +;; TaskJugglerUI. +;; +;; * Resources +;; +;; Next you can define resources and assign those to work on specific +;; tasks. You can group your resources hierarchically. Tag the top +;; node of the resources with "taskjuggler_resource" (or whatever you +;; customized `org-export-taskjuggler-resource-tag' to). You can +;; optionally assign an identifier (named "resource_id") to the +;; resources (using the standard org properties commands) or you can +;; let the exporter generate identifiers automatically (the exporter +;; picks the first word of the headline as the identifier as long as +;; it is unique, see the documentation of +;; `org-taskjuggler-get-unique-id'). Using that identifier you can +;; then allocate resources to tasks. This is again done with the +;; "allocate" property on the tasks. Do this in column view or when on +;; the task type +;; +;; C-c C-x p allocate RET <resource_id> RET +;; +;; Once the allocations are done you can again export to TaskJuggler +;; and check in the Resource Allocation Graph which person is working +;; on what task at what time. +;; +;; * Export of properties +;; +;; The exporter also takes TODO state information into consideration, +;; i.e. if a task is marked as done it will have the corresponding +;; attribute in TaskJuggler ("complete 100"). Also it will export any +;; property on a task resource or resource node which is known to +;; TaskJuggler, such as limits, vacation, shift, booking, efficiency, +;; journalentry, rate for resources or account, start, note, duration, +;; end, journalentry, milestone, reference, responsible, scheduling, +;; etc for tasks. +;; +;; * Dependencies +;; +;; The exporter will handle dependencies that are defined in the tasks +;; either with the ORDERED attribute (see TODO dependencies in the Org +;; mode manual) or with the BLOCKER attribute (see org-depend.el) or +;; alternatively with a depends attribute. Both the BLOCKER and the +;; depends attribute can be either "previous-sibling" or a reference +;; to an identifier (named "task_id") which is defined for another +;; task in the project. BLOCKER and the depends attribute can define +;; multiple dependencies separated by either space or comma. You can +;; also specify optional attributes on the dependency by simply +;; appending it. The following examples should illustrate this: +;; +;; * Training material +;; :PROPERTIES: +;; :task_id: training_material +;; :ORDERED: t +;; :END: +;; ** Markup Guidelines +;; :PROPERTIES: +;; :Effort: 2.0 +;; :END: +;; ** Workflow Guidelines +;; :PROPERTIES: +;; :Effort: 2.0 +;; :END: +;; * Presentation +;; :PROPERTIES: +;; :Effort: 2.0 +;; :BLOCKER: training_material { gapduration 1d } some_other_task +;; :END: +;; +;;;; * TODO +;; - Use SCHEDULED and DEADLINE information (not just start and end +;; properties). +;; - Look at org-file-properties, org-global-properties and +;; org-global-properties-fixed +;; - What about property inheritance and org-property-inherit-p? +;; - Use TYPE_TODO as an way to assign resources +;; - Make sure multiple dependency definitions (i.e. BLOCKER on +;; previous-sibling and on a specific task_id) in multiple +;; attributes are properly exported. +;; +;;; Code: + +(eval-when-compile + (require 'cl)) + +(require 'org) +(require 'org-exp) + +;;; User variables: + +(defgroup org-export-taskjuggler nil + "Options for exporting Org-mode files to TaskJuggler." + :tag "Org Export TaskJuggler" + :group 'org-export) + +(defcustom org-export-taskjuggler-extension ".tjp" + "Extension of TaskJuggler files." + :group 'org-export-taskjuggler + :type 'string) + +(defcustom org-export-taskjuggler-project-tag "taskjuggler_project" + "Tag, property or todo used to find the tree containing all +the tasks for the project." + :group 'org-export-taskjuggler + :type 'string) + +(defcustom org-export-taskjuggler-resource-tag "taskjuggler_resource" + "Tag, property or todo used to find the tree containing all the +resources for the project." + :group 'org-export-taskjuggler + :type 'string) + +(defcustom org-export-taskjuggler-default-project-version "1.0" + "Default version string for the project." + :group 'org-export-taskjuggler + :type 'string) + +(defcustom org-export-taskjuggler-default-project-duration 280 + "Default project duration if no start and end date have been defined +in the root node of the task tree, i.e. the tree that has been marked +with `org-export-taskjuggler-project-tag'" + :group 'org-export-taskjuggler + :type 'integer) + +(defcustom org-export-taskjuggler-default-reports + '("taskreport \"Gantt Chart\" { + headline \"Project Gantt Chart\" + columns hierarchindex, name, start, end, effort, duration, completed, chart + timeformat \"%Y-%m-%d\" + hideresource 1 + loadunit shortauto +}" +"resourcereport \"Resource Graph\" { + headline \"Resource Allocation Graph\" + columns no, name, utilization, freeload, chart + loadunit shortauto + sorttasks startup + hidetask ~isleaf() +}") + "Default reports for the project." + :group 'org-export-taskjuggler + :type '(repeat (string :tag "Report"))) + +(defcustom org-export-taskjuggler-default-global-properties + "shift s40 \"Part time shift\" { + workinghours wed, thu, fri off +} +" + "Default global properties for the project. Here you typically +define global properties such as shifts, accounts, rates, +vacation, macros and flags. Any property that is allowed within +the TaskJuggler file can be inserted. You could for example +include another TaskJuggler file. + +The global properties are inserted after the project declaration +but before any resource and task declarations." + :group 'org-export-taskjuggler + :type '(string :tag "Preamble")) + +;;; Hooks + +(defvar org-export-taskjuggler-final-hook nil + "Hook run at the end of TaskJuggler export, in the new buffer.") + +;;; Autoload functions: + +;; avoid compiler warning about free variable +(defvar org-export-taskjuggler-old-level) + +;;;###autoload +(defun org-export-as-taskjuggler () + "Export parts of the current buffer as a TaskJuggler file. +The exporter looks for a tree with tag, property or todo that +matches `org-export-taskjuggler-project-tag' and takes this as +the tasks for this project. The first node of this tree defines +the project properties such as project name and project period. +If there is a tree with tag, property or todo that matches +`org-export-taskjuggler-resource-tag' this three is taken as +resources for the project. If no resources are specified, a +default resource is created and allocated to the project. Also +the taskjuggler project will be created with default reports as +defined in `org-export-taskjuggler-default-reports'." + (interactive) + + (message "Exporting...") + (setq-default org-done-keywords org-done-keywords) + (let* ((tasks + (org-taskjuggler-resolve-dependencies + (org-taskjuggler-assign-task-ids + (org-map-entries + '(org-taskjuggler-components) + org-export-taskjuggler-project-tag nil 'archive 'comment)))) + (resources + (org-taskjuggler-assign-resource-ids + (org-map-entries + '(org-taskjuggler-components) + org-export-taskjuggler-resource-tag nil 'archive 'comment))) + (filename (expand-file-name + (concat + (file-name-sans-extension + (file-name-nondirectory buffer-file-name)) + org-export-taskjuggler-extension))) + (buffer (find-file-noselect filename)) + (org-export-taskjuggler-old-level 0) + task resource) + (unless tasks + (error "No tasks specified")) + ;; add a default resource + (unless resources + (setq resources + `((("resource_id" . ,(user-login-name)) + ("headline" . ,user-full-name) + ("level" . 1))))) + ;; add a default allocation to the first task if none was given + (unless (assoc "allocate" (car tasks)) + (let ((task (car tasks)) + (resource-id (cdr (assoc "resource_id" (car resources))))) + (setcar tasks (push (cons "allocate" resource-id) task)))) + ;; add a default start date to the first task if none was given + (unless (assoc "start" (car tasks)) + (let ((task (car tasks)) + (time-string (format-time-string "%Y-%m-%d"))) + (setcar tasks (push (cons "start" time-string) task)))) + ;; add a default version if none was given + (unless (assoc "version" (car tasks)) + (let ((task (car tasks)) + (version org-export-taskjuggler-default-project-version)) + (setcar tasks (push (cons "version" version) task)))) + (with-current-buffer buffer + (erase-buffer) + (org-taskjuggler-open-project (car tasks)) + (insert org-export-taskjuggler-default-global-properties) + (insert "\n") + (dolist (resource resources) + (let ((level (cdr (assoc "level" resource)))) + (org-taskjuggler-close-maybe level) + (org-taskjuggler-open-resource resource) + (setq org-export-taskjuggler-old-level level))) + (org-taskjuggler-close-maybe 1) + (setq org-export-taskjuggler-old-level 0) + (dolist (task tasks) + (let ((level (cdr (assoc "level" task)))) + (org-taskjuggler-close-maybe level) + (org-taskjuggler-open-task task) + (setq org-export-taskjuggler-old-level level))) + (org-taskjuggler-close-maybe 1) + (org-taskjuggler-insert-reports) + (save-buffer) + (or (org-export-push-to-kill-ring "TaskJuggler") + (message "Exporting... done")) + (current-buffer)))) + +;;;###autoload +(defun org-export-as-taskjuggler-and-open () + "Export the current buffer as a TaskJuggler file and open it +with the TaskJuggler GUI." + (interactive) + (let* ((file-name (buffer-file-name (org-export-as-taskjuggler))) + (process-name "TaskJugglerUI") + (command (concat process-name " " file-name))) + (start-process-shell-command process-name nil command))) + +(defun org-taskjuggler-parent-is-ordered-p () + "Return true if the parent of the current node has a property +\"ORDERED\". Return nil otherwise." + (save-excursion + (and (org-up-heading-safe) (org-entry-get (point) "ORDERED")))) + +(defun org-taskjuggler-components () + "Return an alist containing all the pertinent information for +the current node such as the headline, the level, todo state +information, all the properties, etc." + (let* ((props (org-entry-properties)) + (components (org-heading-components)) + (level (nth 1 components)) + (headline (nth 4 components)) + (parent-ordered (org-taskjuggler-parent-is-ordered-p))) + (push (cons "level" level) props) + (push (cons "headline" headline) props) + (push (cons "parent-ordered" parent-ordered) props))) + +(defun org-taskjuggler-assign-task-ids (tasks) + "Given a list of tasks return the same list assigning a unique id +and the full path to each task. Taskjuggler takes hierarchical ids. +For that reason we have to make ids locally unique and we have to keep +a path to the current task." + (let ((previous-level 0) + unique-ids unique-id + path + task resolved-tasks tmp) + (dolist (task tasks resolved-tasks) + (let ((level (cdr (assoc "level" task)))) + (cond + ((< previous-level level) + (setq unique-id (org-taskjuggler-get-unique-id task (car unique-ids))) + (dotimes (tmp (- level previous-level)) + (push (list unique-id) unique-ids) + (push unique-id path))) + ((= previous-level level) + (setq unique-id (org-taskjuggler-get-unique-id task (car unique-ids))) + (push unique-id (car unique-ids)) + (setcar path unique-id)) + ((> previous-level level) + (dotimes (tmp (- previous-level level)) + (pop unique-ids) + (pop path)) + (setq unique-id (org-taskjuggler-get-unique-id task (car unique-ids))) + (push unique-id (car unique-ids)) + (setcar path unique-id))) + (push (cons "unique-id" unique-id) task) + (push (cons "path" (mapconcat 'identity (reverse path) ".")) task) + (setq previous-level level) + (setq resolved-tasks (append resolved-tasks (list task))))))) + +(defun org-taskjuggler-assign-resource-ids (resources &optional unique-ids) + "Given a list of resources return the same list, assigning a +unique id to each resource." + (cond + ((null resources) nil) + (t + (let* ((resource (car resources)) + (unique-id (org-taskjuggler-get-unique-id resource unique-ids))) + (push (cons "unique-id" unique-id) resource) + (cons resource + (org-taskjuggler-assign-resource-ids (cdr resources) + (cons unique-id unique-ids))))))) + +(defun org-taskjuggler-resolve-dependencies (tasks) + (let ((previous-level 0) + siblings + task resolved-tasks) + (dolist (task tasks resolved-tasks) + (let* ((level (cdr (assoc "level" task))) + (depends (cdr (assoc "depends" task))) + (parent-ordered (cdr (assoc "parent-ordered" task))) + (blocker (cdr (assoc "BLOCKER" task))) + (blocked-on-previous + (and blocker (string-match "previous-sibling" blocker))) + (dependencies + (org-taskjuggler-resolve-explicit-dependencies + (append + (and depends (org-taskjuggler-tokenize-dependencies depends)) + (and blocker (org-taskjuggler-tokenize-dependencies blocker))) + tasks)) + previous-sibling) + ; update previous sibling info + (cond + ((< previous-level level) + (dotimes (tmp (- level previous-level)) + (push task siblings))) + ((= previous-level level) + (setq previous-sibling (car siblings)) + (setcar siblings task)) + ((> previous-level level) + (dotimes (tmp (- previous-level level)) + (pop siblings)) + (setq previous-sibling (car siblings)) + (setcar siblings task))) + ; insert a dependency on previous sibling if the parent is + ; ordered or if the tasks has a BLOCKER attribute with value "previous-sibling" + (when (or (and previous-sibling parent-ordered) blocked-on-previous) + (push (format "!%s" (cdr (assoc "unique-id" previous-sibling))) dependencies)) + ; store dependency information + (when dependencies + (push (cons "depends" (mapconcat 'identity dependencies ", ")) task)) + (setq previous-level level) + (setq resolved-tasks (append resolved-tasks (list task))))))) + +(defun org-taskjuggler-tokenize-dependencies (dependencies) + "Split a dependency property value DEPENDENCIES into the +individual dependencies and return them as a list while keeping +the optional arguments (such as gapduration) for the +dependencies. A dependency will have to match `[-a-zA-Z0-9_]+'." + (cond + ((string-match "^ *$" dependencies) nil) + ((string-match "^[ \t]*\\([-a-zA-Z0-9_]+\\([ \t]*{[^}]+}\\)?\\)[ \t,]*" dependencies) + (cons + (substring dependencies (match-beginning 1) (match-end 1)) + (org-taskjuggler-tokenize-dependencies (substring dependencies (match-end 0))))) + (t (error (format "invalid dependency id %s" dependencies))))) + +(defun org-taskjuggler-resolve-explicit-dependencies (dependencies tasks) + "For each dependency in DEPENDENCIES try to find a +corresponding task with a matching property \"task_id\" in TASKS. +Return a list containing the resolved links for all DEPENDENCIES +where a matching tasks was found. If the dependency is +\"previous-sibling\" it is ignored (as this is dealt with in +`org-taskjuggler-resolve-dependencies'). If there is no matching +task the dependency is ignored and a warning is displayed ." + (unless (null dependencies) + (let* + ;; the dependency might have optional attributes such as "{ + ;; gapduration 5d }", so only use the first string as id for the + ;; dependency + ((dependency (car dependencies)) + (id (car (split-string dependency))) + (optional-attributes + (mapconcat 'identity (cdr (split-string dependency)) " ")) + (path (org-taskjuggler-find-task-with-id id tasks))) + (cond + ;; ignore previous sibling dependencies + ((equal (car dependencies) "previous-sibling") + (org-taskjuggler-resolve-explicit-dependencies (cdr dependencies) tasks)) + ;; if the id is found in another task use its path + ((not (null path)) + (cons (mapconcat 'identity (list path optional-attributes) " ") + (org-taskjuggler-resolve-explicit-dependencies + (cdr dependencies) tasks))) + ;; warn about dangling dependency but otherwise ignore it + (t (display-warning + 'org-export-taskjuggler + (format "No task with matching property \"task_id\" found for id %s" id)) + (org-taskjuggler-resolve-explicit-dependencies (cdr dependencies) tasks)))))) + +(defun org-taskjuggler-find-task-with-id (id tasks) + "Find ID in tasks. If found return the path of task. Otherwise +return nil." + (let ((task-id (cdr (assoc "task_id" (car tasks)))) + (path (cdr (assoc "path" (car tasks))))) + (cond + ((null tasks) nil) + ((equal task-id id) path) + (t (org-taskjuggler-find-task-with-id id (cdr tasks)))))) + +(defun org-taskjuggler-get-unique-id (item unique-ids) + "Return a unique id for an ITEM which can be a task or a resource. +The id is derived from the headline and made unique against +UNIQUE-IDS. If the (downcased) first token of the headline is not +unique try to add more (downcased) tokens of the headline or +finally add more underscore characters (\"_\")." + (let* ((headline (cdr (assoc "headline" item))) + (parts (split-string headline)) + (id (org-taskjuggler-clean-id (downcase (pop parts))))) + ; try to add more parts of the headline to make it unique + (while (and (member id unique-ids) (car parts)) + (setq id (concat id "_" (org-taskjuggler-clean-id (downcase (pop parts)))))) + ; if its still not unique add "_" + (while (member id unique-ids) + (setq id (concat id "_"))) + id)) + +(defun org-taskjuggler-clean-id (id) + "Clean and return ID to make it acceptable for taskjuggler." + (and id (replace-regexp-in-string "[^a-zA-Z0-9_]" "_" id))) + +(defun org-taskjuggler-open-project (project) + "Insert the beginning of a project declaration. All valid +attributes from the PROJECT alist are inserted. If no end date is +specified it is calculated +`org-export-taskjuggler-default-project-duration' days from now." + (let* ((unique-id (cdr (assoc "unique-id" project))) + (headline (cdr (assoc "headline" project))) + (version (cdr (assoc "version" project))) + (start (cdr (assoc "start" project))) + (end (cdr (assoc "end" project)))) + (insert + (format "project %s \"%s\" \"%s\" %s +%sd {\n }\n" + unique-id headline version start + org-export-taskjuggler-default-project-duration)))) + +(defun org-taskjuggler-filter-and-join (items) + "Filter all nil elements from ITEMS and join the remaining ones +with separator \"\n\"." + (let ((filtered-items (remq nil items))) + (and filtered-items (mapconcat 'identity filtered-items "\n")))) + +(defun org-taskjuggler-get-attributes (item attributes) + "Return all attribute as a single formated string. ITEM is an +alist representing either a resource or a task. ATTRIBUTES is a +list of symbols. Only entries from ITEM are considered that are +listed in ATTRIBUTES." + (org-taskjuggler-filter-and-join + (mapcar + (lambda (attribute) + (org-taskjuggler-filter-and-join + (org-taskjuggler-get-attribute item attribute))) + attributes))) + +(defun org-taskjuggler-get-attribute (item attribute) + "Return a list of strings containing the properly formatted +taskjuggler declaration for a given ATTRIBUTE in ITEM (an alist). +If the ATTRIBUTE is not in ITEM return nil." + (cond + ((null item) nil) + ((equal (symbol-name attribute) (car (car item))) + (cons (format "%s %s" (symbol-name attribute) (cdr (car item))) + (org-taskjuggler-get-attribute (cdr item) attribute))) + (t (org-taskjuggler-get-attribute (cdr item) attribute)))) + +(defun org-taskjuggler-open-resource (resource) + "Insert the beginning of a resource declaration. All valid +attributes from the RESOURCE alist are inserted. If the RESOURCE +defines a property \"resource_id\" it will be used as the id for +this resource. Otherwise it will use the ID property. If neither +is defined it will calculate a unique id for the resource using +`org-taskjuggler-get-unique-id'." + (let ((id (org-taskjuggler-clean-id + (or (cdr (assoc "resource_id" resource)) + (cdr (assoc "ID" resource)) + (cdr (assoc "unique-id" resource))))) + (headline (cdr (assoc "headline" resource))) + (attributes '(limits vacation shift booking efficiency journalentry rate))) + (insert + (concat + "resource " id " \"" headline "\" {\n " + (org-taskjuggler-get-attributes resource attributes) "\n")))) + +(defun org-taskjuggler-clean-effort (effort) + "Translate effort strings into a format acceptable to taskjuggler, +i.e. REAL UNIT. If the effort string is something like 5:30 it +will be assumed to be hours and will be translated into 5.5h. +Otherwise if it contains something like 3.0 it is assumed to be +days and will be translated into 3.0d. Other formats that +taskjuggler supports (like weeks, months and years) are currently +not supported." + (cond + ((null effort) effort) + ((string-match "\\([0-9]+\\):\\([0-9]+\\)" effort) + (let ((hours (string-to-number (match-string 1 effort))) + (minutes (string-to-number (match-string 2 effort)))) + (format "%dh" (+ hours (/ minutes 60.0))))) + ((string-match "\\([0-9]+\\).\\([0-9]+\\)" effort) (concat effort "d")) + (t (error "Not a valid effort (%s)" effort)))) + +(defun org-taskjuggler-get-priority (priority) + "Return a priority between 1 and 1000 based on PRIORITY, an +org-mode priority string." + (max 1 (/ (* 1000 (- org-lowest-priority (string-to-char priority))) + (- org-lowest-priority org-highest-priority)))) + +(defun org-taskjuggler-open-task (task) + (let* ((unique-id (cdr (assoc "unique-id" task))) + (headline (cdr (assoc "headline" task))) + (effort (org-taskjuggler-clean-effort (cdr (assoc org-effort-property task)))) + (depends (cdr (assoc "depends" task))) + (allocate (cdr (assoc "allocate" task))) + (priority-raw (cdr (assoc "PRIORITY" task))) + (priority (and priority-raw (org-taskjuggler-get-priority priority-raw))) + (state (cdr (assoc "TODO" task))) + (complete (or (and (member state org-done-keywords) "100") + (cdr (assoc "complete" task)))) + (parent-ordered (cdr (assoc "parent-ordered" task))) + (previous-sibling (cdr (assoc "previous-sibling" task))) + (attributes + '(account start note duration endbuffer endcredit end + flags journalentry length maxend maxstart milestone + minend minstart period reference responsible + scheduling startbuffer startcredit statusnote))) + (insert + (concat + "task " unique-id " \"" headline "\" {\n" + (if (and parent-ordered previous-sibling) + (format " depends %s\n" previous-sibling) + (and depends (format " depends %s\n" depends))) + (and allocate (format " purge allocations\n allocate %s\n" allocate)) + (and complete (format " complete %s\n" complete)) + (and effort (format " effort %s\n" effort)) + (and priority (format " priority %s\n" priority)) + + (org-taskjuggler-get-attributes task attributes) + "\n")))) + +(defun org-taskjuggler-close-maybe (level) + (while (> org-export-taskjuggler-old-level level) + (insert "}\n") + (setq org-export-taskjuggler-old-level (1- org-export-taskjuggler-old-level))) + (when (= org-export-taskjuggler-old-level level) + (insert "}\n"))) + +(defun org-taskjuggler-insert-reports () + (let (report) + (dolist (report org-export-taskjuggler-default-reports) + (insert report "\n")))) + +(provide 'org-taskjuggler) + +;;; org-taskjuggler.el ends here diff --git a/.emacs.d/org-7.4/lisp/org-taskjuggler.elc b/.emacs.d/org-7.4/lisp/org-taskjuggler.elc Binary files differnew file mode 100644 index 0000000..14368db --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-taskjuggler.elc diff --git a/.emacs.d/org-7.4/lisp/org-timer.el b/.emacs.d/org-7.4/lisp/org-timer.el new file mode 100644 index 0000000..bac1187 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-timer.el @@ -0,0 +1,399 @@ +;;; org-timer.el --- The relative timer code for Org-mode + +;; Copyright (C) 2008, 2009, 2010 Free Software Foundation, Inc. + +;; Author: Carsten Dominik <carsten at orgmode dot org> +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; Version: 7.4 +;; +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: + +;; This file contains the relative timer code for Org-mode + +;;; Code: + +(require 'org) + +(declare-function org-notify "org-clock" (notification &optional play-sound)) +(declare-function org-agenda-error "org-agenda" ()) + +(defvar org-timer-start-time nil + "t=0 for the running timer.") + +(defvar org-timer-pause-time nil + "Time when the timer was paused.") + +(defconst org-timer-re "\\([-+]?[0-9]+\\):\\([0-9]\\{2\\}\\):\\([0-9]\\{2\\}\\)" + "Regular expression used to match timer stamps.") + +(defcustom org-timer-format "%s " + "The format to insert the time of the timer. +This format must contain one instance of \"%s\" which will be replaced by +the value of the relative timer." + :group 'org-time + :type 'string) + +(defcustom org-timer-default-timer 0 + "The default timer when a timer is set. +When 0, the user is prompted for a value." + :group 'org-time + :type 'number) + +(defvar org-timer-start-hook nil + "Hook run after relative timer is started.") + +(defvar org-timer-stop-hook nil + "Hook run before relative timer is stopped.") + +(defvar org-timer-pause-hook nil + "Hook run before relative timer is paused.") + +(defvar org-timer-set-hook nil + "Hook run after countdown timer is set.") + +(defvar org-timer-done-hook nil + "Hook run after countdown timer reaches zero.") + +(defvar org-timer-cancel-hook nil + "Hook run before countdown timer is canceled.") + +;;;###autoload +(defun org-timer-start (&optional offset) + "Set the starting time for the relative timer to now. +When called with prefix argument OFFSET, prompt the user for an offset time, +with the default taken from a timer stamp at point, if any. +If OFFSET is a string or an integer, it is directly taken to be the offset +without user interaction. +When called with a double prefix arg, all timer strings in the active +region will be shifted by a specific amount. You will be prompted for +the amount, with the default to make the first timer string in +the region 0:00:00." + (interactive "P") + (if (equal offset '(16)) + (call-interactively 'org-timer-change-times-in-region) + (let (delta def s) + (if (not offset) + (setq org-timer-start-time (current-time)) + (cond + ((integerp offset) (setq delta offset)) + ((stringp offset) (setq delta (org-timer-hms-to-secs offset))) + (t + (setq def (if (org-in-regexp org-timer-re) + (match-string 0) + "0:00:00") + s (read-string + (format "Restart timer with offset [%s]: " def))) + (unless (string-match "\\S-" s) (setq s def)) + (setq delta (org-timer-hms-to-secs (org-timer-fix-incomplete s))))) + (setq org-timer-start-time + (seconds-to-time + (- (org-float-time) delta)))) + (org-timer-set-mode-line 'on) + (message "Timer start time set to %s, current value is %s" + (format-time-string "%T" org-timer-start-time) + (org-timer-secs-to-hms (or delta 0))) + (run-hooks 'org-timer-start-hook)))) + +(defun org-timer-pause-or-continue (&optional stop) + "Pause or continue the relative timer. +With prefix arg STOP, stop it entirely." + (interactive "P") + (cond + (stop (org-timer-stop)) + ((not org-timer-start-time) (error "No timer is running")) + (org-timer-pause-time + ;; timer is paused, continue + (setq org-timer-start-time + (seconds-to-time + (- + (org-float-time) + (- (org-float-time org-timer-pause-time) + (org-float-time org-timer-start-time)))) + org-timer-pause-time nil) + (org-timer-set-mode-line 'on) + (message "Timer continues at %s" (org-timer-value-string))) + (t + ;; pause timer + (run-hooks 'org-timer-pause-hook) + (setq org-timer-pause-time (current-time)) + (org-timer-set-mode-line 'pause) + (message "Timer paused at %s" (org-timer-value-string))))) + +(defun org-timer-stop () + "Stop the relative timer." + (interactive) + (run-hooks 'org-timer-stop-hook) + (setq org-timer-start-time nil + org-timer-pause-time nil) + (org-timer-set-mode-line 'off)) + +;;;###autoload +(defun org-timer (&optional restart no-insert-p) + "Insert a H:MM:SS string from the timer into the buffer. +The first time this command is used, the timer is started. When used with +a \\[universal-argument] prefix, force restarting the timer. +When used with a double prefix argument \\[universal-argument], change all the timer string +in the region by a fixed amount. This can be used to recalibrate a timer +that was not started at the correct moment. + +If NO-INSERT-P is non-nil, return the string instead of inserting +it in the buffer." + (interactive "P") + (when (or (equal restart '(4)) (not org-timer-start-time)) + (org-timer-start)) + (if no-insert-p + (org-timer-value-string) + (insert (org-timer-value-string)))) + +(defun org-timer-value-string () + (format org-timer-format (org-timer-secs-to-hms (floor (org-timer-seconds))))) + +(defvar org-timer-timer-is-countdown nil) +(defun org-timer-seconds () + (if org-timer-timer-is-countdown + (- (org-float-time org-timer-start-time) + (org-float-time (current-time))) + (- (org-float-time (or org-timer-pause-time (current-time))) + (org-float-time org-timer-start-time)))) + +;;;###autoload +(defun org-timer-change-times-in-region (beg end delta) + "Change all h:mm:ss time in region by a DELTA." + (interactive + "r\nsEnter time difference like \"-1:08:26\". Default is first time to zero: ") + (let ((re "[-+]?[0-9]+:[0-9]\\{2\\}:[0-9]\\{2\\}") p) + (unless (string-match "\\S-" delta) + (save-excursion + (goto-char beg) + (when (re-search-forward re end t) + (setq delta (match-string 0)) + (if (equal (string-to-char delta) ?-) + (setq delta (substring delta 1)) + (setq delta (concat "-" delta)))))) + (setq delta (org-timer-hms-to-secs (org-timer-fix-incomplete delta))) + (when (= delta 0) (error "No change")) + (save-excursion + (goto-char end) + (while (re-search-backward re beg t) + (setq p (point)) + (replace-match + (save-match-data + (org-timer-secs-to-hms (+ (org-timer-hms-to-secs (match-string 0)) delta))) + t t) + (goto-char p))))) + +;;;###autoload +(defun org-timer-item (&optional arg) + "Insert a description-type item with the current timer value." + (interactive "P") + (cond + ;; In a timer list, insert with `org-list-insert-item-generic'. + ((and (org-in-item-p) + (save-excursion (org-beginning-of-item) (org-at-item-timer-p))) + (org-list-insert-item-generic + (point) nil (concat (org-timer (when arg '(4)) t) ":: "))) + ;; In a list of another type, don't break anything: throw an error. + ((org-in-item-p) + (error "This is not a timer list")) + ;; Else, insert the timer correctly indented at bol. + (t + (beginning-of-line) + (org-indent-line-function) + (insert "- ") + (org-timer (when arg '(4))) + (insert ":: ")))) + +(defun org-timer-fix-incomplete (hms) + "If hms is a H:MM:SS string with missing hour or hour and minute, fix it." + (if (string-match "\\(?:\\([0-9]+:\\)?\\([0-9]+:\\)\\)?\\([0-9]+\\)" hms) + (replace-match + (format "%d:%02d:%02d" + (if (match-end 1) (string-to-number (match-string 1 hms)) 0) + (if (match-end 2) (string-to-number (match-string 2 hms)) 0) + (string-to-number (match-string 3 hms))) + t t hms) + (error "Cannot parse HMS string \"%s\"" hms))) + +(defun org-timer-hms-to-secs (hms) + "Convert h:mm:ss string to an integer time. +If the string starts with a minus sign, the integer will be negative." + (if (not (string-match + "\\([-+]?[0-9]+\\):\\([0-9]\\{2\\}\\):\\([0-9]\\{2\\}\\)" + hms)) + 0 + (let* ((h (string-to-number (match-string 1 hms))) + (m (string-to-number (match-string 2 hms))) + (s (string-to-number (match-string 3 hms))) + (sign (equal (substring (match-string 1 hms) 0 1) "-"))) + (setq h (abs h)) + (* (if sign -1 1) (+ s (* 60 (+ m (* 60 h)))))))) + +(defun org-timer-secs-to-hms (s) + "Convert integer S into h:mm:ss. +If the integer is negative, the string will start with \"-\"." + (let (sign m h) + (setq sign (if (< s 0) "-" "") + s (abs s) + m (/ s 60) s (- s (* 60 m)) + h (/ m 60) m (- m (* 60 h))) + (format "%s%d:%02d:%02d" sign h m s))) + +(defvar org-timer-mode-line-timer nil) +(defvar org-timer-mode-line-string nil) + +(defun org-timer-set-mode-line (value) + "Set the mode-line display of the relative timer. +VALUE can be `on', `off', or `pause'." + (or global-mode-string (setq global-mode-string '(""))) + (or (memq 'org-timer-mode-line-string global-mode-string) + (setq global-mode-string + (append global-mode-string '(org-timer-mode-line-string)))) + (cond + ((equal value 'off) + (when org-timer-mode-line-timer + (cancel-timer org-timer-mode-line-timer) + (setq org-timer-mode-line-timer nil)) + (setq global-mode-string + (delq 'org-timer-mode-line-string global-mode-string)) + (force-mode-line-update)) + ((equal value 'pause) + (when org-timer-mode-line-timer + (cancel-timer org-timer-mode-line-timer) + (setq org-timer-mode-line-timer nil))) + ((equal value 'on) + (or global-mode-string (setq global-mode-string '(""))) + (or (memq 'org-timer-mode-line-string global-mode-string) + (setq global-mode-string + (append global-mode-string '(org-timer-mode-line-string)))) + (org-timer-update-mode-line) + (when org-timer-mode-line-timer + (cancel-timer org-timer-mode-line-timer)) + (setq org-timer-mode-line-timer + (run-with-timer 1 1 'org-timer-update-mode-line))))) + +(defun org-timer-update-mode-line () + "Update the timer time in the mode line." + (if org-timer-pause-time + nil + (setq org-timer-mode-line-string + (concat " <" (substring (org-timer-value-string) 0 -1) ">")) + (force-mode-line-update))) + +(defvar org-timer-current-timer nil) +(defun org-timer-cancel-timer () + "Cancel the current timer." + (interactive) + (when (eval org-timer-current-timer) + (run-hooks 'org-timer-cancel-hook) + (cancel-timer org-timer-current-timer) + (setq org-timer-current-timer nil) + (setq org-timer-timer-is-countdown nil) + (org-timer-set-mode-line 'off)) + (message "Last timer canceled")) + +(defun org-timer-show-remaining-time () + "Display the remaining time before the timer ends." + (interactive) + (require 'time) + (if (not org-timer-current-timer) + (message "No timer set") + (let* ((rtime (decode-time + (time-subtract (timer--time org-timer-current-timer) + (current-time)))) + (rsecs (nth 0 rtime)) + (rmins (nth 1 rtime))) + (message "%d minute(s) %d seconds left before next time out" + rmins rsecs)))) + +;;;###autoload +(defun org-timer-set-timer (&optional opt) + "Prompt for a duration and set a timer. + +If `org-timer-default-timer' is not zero, suggest this value as +the default duration for the timer. If a timer is already set, +prompt the user if she wants to replace it. + +Called with a numeric prefix argument, use this numeric value as +the duration of the timer. + +Called with a `C-u' prefix arguments, use `org-timer-default-timer' +without prompting the user for a duration. + +With two `C-u' prefix arguments, use `org-timer-default-timer' +without prompting the user for a duration and automatically +replace any running timer." + (interactive "P") + (let ((minutes (or (and (numberp opt) (number-to-string opt)) + (and (listp opt) (not (null opt)) + (number-to-string org-timer-default-timer)) + (read-from-minibuffer + "How many minutes left? " + (if (not (eq org-timer-default-timer 0)) + (number-to-string org-timer-default-timer)))))) + (if (not (string-match "[0-9]+" minutes)) + (org-timer-show-remaining-time) + (let* ((mins (string-to-number (match-string 0 minutes))) + (secs (* mins 60)) + (hl (cond + ((string-match "Org Agenda" (buffer-name)) + (let* ((marker (or (get-text-property (point) 'org-marker) + (org-agenda-error))) + (hdmarker (or (get-text-property (point) 'org-hd-marker) + marker)) + (pos (marker-position marker))) + (with-current-buffer (marker-buffer marker) + (widen) + (goto-char pos) + (org-show-entry) + (or (ignore-errors (org-get-heading)) + (concat "File:" (file-name-nondirectory (buffer-file-name))))))) + ((eq major-mode 'org-mode) + (or (ignore-errors (org-get-heading)) + (concat "File:" (file-name-nondirectory (buffer-file-name))))) + (t (error "Not in an Org buffer")))) + timer-set) + (if (or (and org-timer-current-timer + (or (equal opt '(16)) + (y-or-n-p "Replace current timer? "))) + (not org-timer-current-timer)) + (progn + (require 'org-clock) + (when org-timer-current-timer + (cancel-timer org-timer-current-timer)) + (setq org-timer-current-timer + (run-with-timer + secs nil `(lambda () + (setq org-timer-current-timer nil) + (org-notify ,(format "%s: time out" hl) t) + (setq org-timer-timer-is-countdown nil) + (org-timer-set-mode-line 'off) + (run-hooks 'org-timer-done-hook)))) + (run-hooks 'org-timer-set-hook) + (setq org-timer-timer-is-countdown t + org-timer-start-time + (time-add (current-time) (seconds-to-time (* mins 60)))) + (org-timer-set-mode-line 'on)) + (message "No timer set")))))) + +(provide 'org-timer) + +;; arch-tag: 97538f8c-3871-4509-8f23-1e7b3ff3d107 + +;;; org-timer.el ends here diff --git a/.emacs.d/org-7.4/lisp/org-timer.elc b/.emacs.d/org-7.4/lisp/org-timer.elc Binary files differnew file mode 100644 index 0000000..ec19659 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-timer.elc diff --git a/.emacs.d/org-7.4/lisp/org-vm.el b/.emacs.d/org-7.4/lisp/org-vm.el new file mode 100644 index 0000000..daef671 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-vm.el @@ -0,0 +1,143 @@ +;;; org-vm.el --- Support for links to VM messages from within Org-mode + +;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010 +;; Free Software Foundation, Inc. + +;; Author: Carsten Dominik <carsten at orgmode dot org> +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; Version: 7.4 +;; +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: +;; This file implements links to VM messages and folders from within Org-mode. +;; Org-mode loads this module by default - if this is not what you want, +;; configure the variable `org-modules'. + +;;; Code: + +(require 'org) + +;; Declare external functions and variables +(declare-function vm-preview-current-message "ext:vm-page" ()) +(declare-function vm-follow-summary-cursor "ext:vm-motion" ()) +(declare-function vm-get-header-contents "ext:vm-summary" + (message header-name-regexp &optional clump-sep)) +(declare-function vm-isearch-narrow "ext:vm-search" ()) +(declare-function vm-isearch-update "ext:vm-search" ()) +(declare-function vm-select-folder-buffer "ext:vm-macro" ()) +(declare-function vm-su-message-id "ext:vm-summary" (m)) +(declare-function vm-su-subject "ext:vm-summary" (m)) +(declare-function vm-summarize "ext:vm-summary" (&optional display raise)) +(defvar vm-message-pointer) +(defvar vm-folder-directory) + +;; Install the link type +(org-add-link-type "vm" 'org-vm-open) +(add-hook 'org-store-link-functions 'org-vm-store-link) + +;; Implementation +(defun org-vm-store-link () + "Store a link to a VM folder or message." + (when (or (eq major-mode 'vm-summary-mode) + (eq major-mode 'vm-presentation-mode)) + (and (eq major-mode 'vm-presentation-mode) (vm-summarize)) + (vm-follow-summary-cursor) + (save-excursion + (vm-select-folder-buffer) + (let* ((message (car vm-message-pointer)) + (folder buffer-file-name) + (subject (vm-su-subject message)) + (to (vm-get-header-contents message "To")) + (from (vm-get-header-contents message "From")) + (message-id (vm-su-message-id message)) + (date (vm-get-header-contents message "Date")) + (date-ts (and date (format-time-string + (org-time-stamp-format t) + (date-to-time date)))) + (date-ts-ia (and date (format-time-string + (org-time-stamp-format t t) + (date-to-time date)))) + desc link) + (org-store-link-props :type "vm" :from from :to to :subject subject + :message-id message-id) + (when date + (org-add-link-props :date date :date-timestamp date-ts + :date-timestamp-inactive date-ts-ia)) + (setq message-id (org-remove-angle-brackets message-id)) + (setq folder (abbreviate-file-name folder)) + (if (and vm-folder-directory + (string-match (concat "^" (regexp-quote vm-folder-directory)) + folder)) + (setq folder (replace-match "" t t folder))) + (setq desc (org-email-link-description)) + (setq link (org-make-link "vm:" folder "#" message-id)) + (org-add-link-props :link link :description desc) + link)))) + +(defun org-vm-open (path) + "Follow a VM message link specified by PATH." + (let (folder article) + (if (not (string-match "\\`\\([^#]+\\)\\(#\\(.*\\)\\)?" path)) + (error "Error in VM link")) + (setq folder (match-string 1 path) + article (match-string 3 path)) + ;; The prefix argument will be interpreted as read-only + (org-vm-follow-link folder article current-prefix-arg))) + +(defun org-vm-follow-link (&optional folder article readonly) + "Follow a VM link to FOLDER and ARTICLE." + (require 'vm) + (setq article (org-add-angle-brackets article)) + (if (string-match "^//\\([a-zA-Z]+@\\)?\\([^:]+\\):\\(.*\\)" folder) + ;; ange-ftp or efs or tramp access + (let ((user (or (match-string 1 folder) (user-login-name))) + (host (match-string 2 folder)) + (file (match-string 3 folder))) + (cond + ((featurep 'tramp) + ;; use tramp to access the file + (if (featurep 'xemacs) + (setq folder (format "[%s@%s]%s" user host file)) + (setq folder (format "/%s@%s:%s" user host file)))) + (t + ;; use ange-ftp or efs + (require (if (featurep 'xemacs) 'efs 'ange-ftp)) + (setq folder (format "/%s@%s:%s" user host file)))))) + (when folder + (funcall (cdr (assq 'vm org-link-frame-setup)) folder readonly) + (sit-for 0.1) + (when article + (require 'vm-search) + (vm-select-folder-buffer) + (widen) + (let ((case-fold-search t)) + (goto-char (point-min)) + (if (not (re-search-forward + (concat "^" "message-id: *" (regexp-quote article)))) + (error "Could not find the specified message in this folder")) + (vm-isearch-update) + (vm-isearch-narrow) + (vm-preview-current-message) + (vm-summarize))))) + +(provide 'org-vm) + +;; arch-tag: cbc3047b-935e-4d2a-96e7-c5b0117aaa6d + +;;; org-vm.el ends here diff --git a/.emacs.d/org-7.4/lisp/org-vm.elc b/.emacs.d/org-7.4/lisp/org-vm.elc Binary files differnew file mode 100644 index 0000000..a8080c1 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-vm.elc diff --git a/.emacs.d/org-7.4/lisp/org-w3m.el b/.emacs.d/org-7.4/lisp/org-w3m.el new file mode 100644 index 0000000..6965ac6 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-w3m.el @@ -0,0 +1,173 @@ +;;; org-w3m.el --- Support from copy and paste from w3m to Org-mode + +;; Copyright (C) 2008, 2009, 2010 Free Software Foundation, Inc. + +;; Author: Andy Stewart <lazycat dot manatee at gmail dot com> +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; Version: 7.4 +;; +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: + +;; This file implements copying HTML content from a w3m buffer and +;; transforming the text on the fly so that it can be pasted into +;; an org-mode buffer with hot links. It will also work for regions +;; in gnus buffers that have been washed with w3m. + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Acknowledgments: + +;; Richard Riley <rileyrgdev at googlemail dot com> +;; +;; The idea of transforming the HTML content with org-mode style is +;; proposed by Richard, I'm just coding it. +;; + +;;; Code: + +(require 'org) + +(defun org-w3m-copy-for-org-mode () + "Copy current buffer content or active region with `org-mode' style links. +This will encode `link-title' and `link-location' with +`org-make-link-string', and insert the transformed test into the kill ring, +so that it can be yanked into an Org-mode buffer with links working correctly." + (interactive) + (let* ((regionp (org-region-active-p)) + (transform-start (point-min)) + (transform-end (point-max)) + return-content + link-location link-title + temp-position out-bound) + (when regionp + (setq transform-start (region-beginning)) + (setq transform-end (region-end)) + ;; Deactivate mark if current mark is activate. + (if (fboundp 'deactivate-mark) (deactivate-mark))) + (message "Transforming links...") + (save-excursion + (goto-char transform-start) + (while (and (not out-bound) ; still inside region to copy + (not (org-w3m-no-next-link-p))) ; no next link current buffer + ;; store current point before jump next anchor + (setq temp-position (point)) + ;; move to next anchor when current point is not at anchor + (or (get-text-property (point) 'w3m-href-anchor) (org-w3m-get-next-link-start)) + (if (<= (point) transform-end) ; if point is inside transform bound + (progn + ;; get content between two links. + (if (> (point) temp-position) + (setq return-content (concat return-content + (buffer-substring + temp-position (point))))) + ;; get link location at current point. + (setq link-location (get-text-property (point) 'w3m-href-anchor)) + ;; get link title at current point. + (setq link-title (buffer-substring (point) + (org-w3m-get-anchor-end))) + ;; concat `org-mode' style url to `return-content'. + (setq return-content (concat return-content + (org-make-link-string + link-location link-title)))) + (goto-char temp-position) ; reset point before jump next anchor + (setq out-bound t) ; for break out `while' loop + )) + ;; add the rest until end of the region to be copied + (if (< (point) transform-end) + (setq return-content + (concat return-content + (buffer-substring (point) transform-end)))) + (org-kill-new return-content) + (message "Transforming links...done, use C-y to insert text into Org-mode file") + (message "Copy with link transformation complete.")))) + +(defun org-w3m-get-anchor-start () + "Move cursor to the start of current anchor. Return point." + ;; get start position of anchor or current point + (goto-char (or (previous-single-property-change (point) 'w3m-anchor-sequence) + (point)))) + +(defun org-w3m-get-anchor-end () + "Move cursor to the end of current anchor. Return point." + ;; get end position of anchor or point + (goto-char (or (next-single-property-change (point) 'w3m-anchor-sequence) + (point)))) + +(defun org-w3m-get-next-link-start () + "Move cursor to the start of next link. Return point." + (catch 'reach + (while (next-single-property-change (point) 'w3m-anchor-sequence) + ;; jump to next anchor + (goto-char (next-single-property-change (point) 'w3m-anchor-sequence)) + (when (get-text-property (point) 'w3m-href-anchor) + ;; return point when current is valid link + (throw 'reach nil)))) + (point)) + +(defun org-w3m-get-prev-link-start () + "Move cursor to the start of previous link. Return point." + (catch 'reach + (while (previous-single-property-change (point) 'w3m-anchor-sequence) + ;; jump to previous anchor + (goto-char (previous-single-property-change (point) 'w3m-anchor-sequence)) + (when (get-text-property (point) 'w3m-href-anchor) + ;; return point when current is valid link + (throw 'reach nil)))) + (point)) + +(defun org-w3m-no-next-link-p () + "Whether there is no next link after the cursor. +Return t if there is no next link; otherwise, return nil." + (save-excursion + (equal (point) (org-w3m-get-next-link-start)))) + +(defun org-w3m-no-prev-link-p () + "Whether there is no previous link after the cursor. +Return t if there is no previous link; otherwise, return nil." + (save-excursion + (equal (point) (org-w3m-get-prev-link-start)))) + +;; Install keys into the w3m keymap +(defvar w3m-mode-map) +(defvar w3m-minor-mode-map) +(when (and (boundp 'w3m-mode-map) + (keymapp w3m-mode-map)) + (define-key w3m-mode-map "\C-c\C-x\M-w" 'org-w3m-copy-for-org-mode) + (define-key w3m-mode-map "\C-c\C-x\C-w" 'org-w3m-copy-for-org-mode)) +(when (and (boundp 'w3m-minor-mode-map) + (keymapp w3m-minor-mode-map)) + (define-key w3m-minor-mode-map "\C-c\C-x\M-w" 'org-w3m-copy-for-org-mode) + (define-key w3m-minor-mode-map "\C-c\C-x\C-w" 'org-w3m-copy-for-org-mode)) +(add-hook + 'w3m-mode-hook + (lambda () + (define-key w3m-mode-map "\C-c\C-x\M-w" 'org-w3m-copy-for-org-mode) + (define-key w3m-mode-map "\C-c\C-x\C-w" 'org-w3m-copy-for-org-mode))) +(add-hook + 'w3m-minor-mode-hook + (lambda () + (define-key w3m-minor-mode-map "\C-c\C-x\M-w" 'org-w3m-copy-for-org-mode) + (define-key w3m-minor-mode-map "\C-c\C-x\C-w" 'org-w3m-copy-for-org-mode))) + +(provide 'org-w3m) + +;; arch-tag: 851d7447-488d-49f0-a14d-46c092e84352 + +;;; org-w3m.el ends here diff --git a/.emacs.d/org-7.4/lisp/org-w3m.elc b/.emacs.d/org-7.4/lisp/org-w3m.elc Binary files differnew file mode 100644 index 0000000..885bb0f --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-w3m.elc diff --git a/.emacs.d/org-7.4/lisp/org-wl.el b/.emacs.d/org-7.4/lisp/org-wl.el new file mode 100644 index 0000000..137bad9 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-wl.el @@ -0,0 +1,315 @@ +;;; org-wl.el --- Support for links to Wanderlust messages from within Org-mode + +;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010 +;; Free Software Foundation, Inc. + +;; Author: Tokuya Kameshima <kames at fa2 dot so-net dot ne dot jp> +;; David Maus <dmaus at ictsoc dot de> +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; Version: 7.4 +;; +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: + +;; This file implements links to Wanderlust messages from within Org-mode. +;; Org-mode loads this module by default - if this is not what you want, +;; configure the variable `org-modules'. + +;;; Code: + +(require 'org) + +(defgroup org-wl nil + "Options concerning the Wanderlust link." + :tag "Org Startup" + :group 'org-link) + +(defcustom org-wl-link-to-refile-destination t + "Create a link to the refile destination if the message is marked as refile." + :group 'org-wl + :type 'boolean) + +(defcustom org-wl-link-remove-filter nil + "Remove filter condition if message is filter folder." + :group 'org-wl + :type 'boolean) + +(defcustom org-wl-shimbun-prefer-web-links nil + "If non-nil create web links for shimbun messages." + :group 'org-wl + :type 'boolean) + +(defcustom org-wl-nntp-prefer-web-links nil + "If non-nil create web links for nntp messages. +When folder name contains string \"gmane\" link to gmane, +googlegroups otherwise." + :type 'boolean + :group 'org-wl) + +(defcustom org-wl-disable-folder-check t + "Disable check for new messages when open a link." + :type 'boolean + :group 'org-wl) + +(defcustom org-wl-namazu-default-index nil + "Default namazu search index." + :type 'directory + :group 'org-wl) + +;; Declare external functions and variables +(declare-function elmo-folder-exists-p "ext:elmo" (folder) t) +(declare-function elmo-message-entity-field "ext:elmo-msgdb" + (entity field &optional type)) +(declare-function elmo-message-field "ext:elmo" + (folder number field &optional type) t) +(declare-function elmo-msgdb-overview-get-entity "ext:elmo" (id msgdb) t) +;; Backward compatibility to old version of wl +(declare-function wl "ext:wl" () t) +(declare-function wl-summary-buffer-msgdb "ext:wl-folder" () t) +(declare-function wl-summary-jump-to-msg-by-message-id "ext:wl-summary" + (&optional id)) +(declare-function wl-summary-jump-to-msg "ext:wl-summary" + (&optional number beg end)) +(declare-function wl-summary-line-from "ext:wl-summary" ()) +(declare-function wl-summary-line-subject "ext:wl-summary" ()) +(declare-function wl-summary-message-number "ext:wl-summary" ()) +(declare-function wl-summary-redisplay "ext:wl-summary" (&optional arg)) +(declare-function wl-summary-registered-temp-mark "ext:wl-action" (number)) +(declare-function wl-folder-goto-folder-subr "ext:wl-folder" + (&optional folder sticky)) +(declare-function wl-folder-get-petname "ext:wl-folder" (name)) +(declare-function wl-folder-get-entity-from-buffer "ext:wl-folder" + (&optional getid)) +(declare-function wl-folder-buffer-group-p "ext:wl-folder") +(defvar wl-init) +(defvar wl-summary-buffer-elmo-folder) +(defvar wl-summary-buffer-folder-name) +(defvar wl-folder-group-regexp) +(defvar wl-auto-check-folder-name) +(defvar elmo-nntp-default-server) + +(defconst org-wl-folder-types + '(("%" . imap) ("-" . nntp) ("+" . mh) ("=" . spool) + ("$" . archive) ("&" . pop) ("@" . shimbun) ("[" . search) + ("*" . multi) ("/" . filter) ("|" . pipe) ("'" . internal)) + "List of folder indicators. See Wanderlust manual, section 3.") + +;; Install the link type +(org-add-link-type "wl" 'org-wl-open) +(add-hook 'org-store-link-functions 'org-wl-store-link) + +;; Implementation + +(defun org-wl-folder-type (folder) + "Return symbol that indicates the type of FOLDER. +FOLDER is the wanderlust folder name. The first character of the +folder name determines the the folder type." + (let* ((indicator (substring folder 0 1)) + (type (cdr (assoc indicator org-wl-folder-types)))) + ;; maybe access or file folder + (when (not type) + (setq type + (cond + ((and (>= (length folder) 5) + (string= (substring folder 0 5) "file:")) + 'file) + ((and (>= (length folder) 7) + (string= (substring folder 0 7) "access:")) + 'access) + (t + nil)))) + type)) + +(defun org-wl-message-field (field entity) + "Return content of FIELD in ENTITY. +FIELD is a symbol of a rfc822 message header field. +ENTITY is a message entity." + (let ((content (elmo-message-entity-field entity field 'string))) + (if (listp content) (car content) content))) + +(defun org-wl-store-link () + "Store a link to a WL message or folder." + (unless (eobp) + (cond + ((memq major-mode '(wl-summary-mode mime-view-mode)) + (org-wl-store-link-message)) + ((eq major-mode 'wl-folder-mode) + (org-wl-store-link-folder)) + (t + nil)))) + +(defun org-wl-store-link-folder () + "Store a link to a WL folder." + (let* ((folder (wl-folder-get-entity-from-buffer)) + (petname (wl-folder-get-petname folder)) + (link (org-make-link "wl:" folder))) + (save-excursion + (beginning-of-line) + (unless (and (wl-folder-buffer-group-p) + (looking-at wl-folder-group-regexp)) + (org-store-link-props :type "wl" :description petname + :link link) + link)))) + +(defun org-wl-store-link-message () + "Store a link to a WL message." + (save-excursion + (let ((buf (if (eq major-mode 'wl-summary-mode) + (current-buffer) + (and (boundp 'wl-message-buffer-cur-summary-buffer) + wl-message-buffer-cur-summary-buffer)))) + (when buf + (with-current-buffer buf + (let* ((msgnum (wl-summary-message-number)) + (mark-info (wl-summary-registered-temp-mark msgnum)) + (folder-name + (if (and org-wl-link-to-refile-destination + mark-info + (equal (nth 1 mark-info) "o")) ; marked as refile + (nth 2 mark-info) + wl-summary-buffer-folder-name)) + (folder-type (org-wl-folder-type folder-name)) + (wl-message-entity + (if (fboundp 'elmo-message-entity) + (elmo-message-entity + wl-summary-buffer-elmo-folder msgnum) + (elmo-msgdb-overview-get-entity + msgnum (wl-summary-buffer-msgdb)))) + (message-id + (org-wl-message-field 'message-id wl-message-entity)) + (message-id-no-brackets + (org-remove-angle-brackets message-id)) + (from (org-wl-message-field 'from wl-message-entity)) + (to (org-wl-message-field 'to wl-message-entity)) + (xref (org-wl-message-field 'xref wl-message-entity)) + (subject (org-wl-message-field 'subject wl-message-entity)) + (date (org-wl-message-field 'date wl-message-entity)) + (date-ts (and date (format-time-string + (org-time-stamp-format t) + (date-to-time date)))) + (date-ts-ia (and date (format-time-string + (org-time-stamp-format t t) + (date-to-time date)))) + desc link) + + ;; remove text properties of subject string to avoid possible bug + ;; when formatting the subject + ;; (Emacs bug #5306, fixed) + (set-text-properties 0 (length subject) nil subject) + + ;; maybe remove filter condition + (when (and (eq folder-type 'filter) org-wl-link-remove-filter) + (while (eq (org-wl-folder-type folder-name) 'filter) + (setq folder-name + (replace-regexp-in-string "^/[^/]+/" "" folder-name)))) + + ;; maybe create http link + (cond + ((and (eq folder-type 'shimbun) + org-wl-shimbun-prefer-web-links xref) + (org-store-link-props :type "http" :link xref :description subject + :from from :to to :message-id message-id + :message-id-no-brackets message-id-no-brackets + :subject subject)) + ((and (eq folder-type 'nntp) org-wl-nntp-prefer-web-links) + (setq link + (format + (if (string-match "gmane\\." folder-name) + "http://mid.gmane.org/%s" + "http://groups.google.com/groups/search?as_umsgid=%s") + (org-fixup-message-id-for-http message-id))) + (org-store-link-props :type "http" :link link :description subject + :from from :to to :message-id message-id + :message-id-no-brackets message-id-no-brackets + :subject subject)) + (t + (org-store-link-props :type "wl" :from from :to to + :subject subject :message-id message-id + :message-id-no-brackets message-id-no-brackets) + (setq desc (org-email-link-description)) + (setq link (org-make-link "wl:" folder-name "#" message-id-no-brackets)) + (org-add-link-props :link link :description desc))) + (when date + (org-add-link-props :date date :date-timestamp date-ts + :date-timestamp-inactive date-ts-ia)) + (or link xref))))))) + +(defun org-wl-open-nntp (path) + "Follow the nntp: link specified by PATH." + (let* ((spec (split-string path "/")) + (server (split-string (nth 2 spec) "@")) + (group (nth 3 spec)) + (article (nth 4 spec))) + (org-wl-open + (concat "-" group ":" (if (cdr server) + (car (split-string (car server) ":")) + "") + (if (string= elmo-nntp-default-server (nth 2 spec)) + "" + (concat "@" (or (cdr server) (car server)))) + (if article (concat "#" article) ""))))) + +(defun org-wl-open (path) + "Follow the WL message link specified by PATH. +When called with one prefix, open message in namazu search folder +with `org-wl-namazu-default-index' as search index. When called +with two prefixes or `org-wl-namazu-default-index' is nil, ask +for namazu index." + (require 'wl) + (let ((wl-auto-check-folder-name + (if org-wl-disable-folder-check + 'none + wl-auto-check-folder-name))) + (unless wl-init (wl)) + ;; XXX: The imap-uw's MH folder names start with "%#". + (if (not (string-match "\\`\\(\\(?:%#\\)?[^#]+\\)\\(#\\(.*\\)\\)?" path)) + (error "Error in Wanderlust link")) + (let ((folder (match-string 1 path)) + (article (match-string 3 path))) + ;; maybe open message in namazu search folder + (when current-prefix-arg + (setq folder (concat "[" article "]" + (if (and (equal current-prefix-arg '(4)) + org-wl-namazu-default-index) + org-wl-namazu-default-index + (read-directory-name "Namazu index: "))))) + (if (not (elmo-folder-exists-p (org-no-warnings + (wl-folder-get-elmo-folder folder)))) + (error "No such folder: %s" folder)) + (let ((old-buf (current-buffer)) + (old-point (point-marker))) + (wl-folder-goto-folder-subr folder) + (with-current-buffer old-buf + ;; XXX: `wl-folder-goto-folder-subr' moves point to the + ;; beginning of the current line. So, restore the point + ;; in the old buffer. + (goto-char old-point)) + (when article + (if (org-string-match-p "@" article) + (wl-summary-jump-to-msg-by-message-id (org-add-angle-brackets + article)) + (or (wl-summary-jump-to-msg (string-to-number article)) + (error "No such message: %s" article))) + (wl-summary-redisplay)))))) + +(provide 'org-wl) + +;; arch-tag: 29b75a0f-ef2e-430b-8abc-acff75bde54a + +;;; org-wl.el ends here diff --git a/.emacs.d/org-7.4/lisp/org-wl.elc b/.emacs.d/org-7.4/lisp/org-wl.elc Binary files differnew file mode 100644 index 0000000..9b25386 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-wl.elc diff --git a/.emacs.d/org-7.4/lisp/org-xoxo.el b/.emacs.d/org-7.4/lisp/org-xoxo.el new file mode 100644 index 0000000..2ce277e --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-xoxo.el @@ -0,0 +1,128 @@ +;;; org-xoxo.el --- XOXO export for Org-mode + +;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010 +;; Free Software Foundation, Inc. + +;; Author: Carsten Dominik <carsten at orgmode dot org> +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; Version: 7.4 +;; +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: +;; XOXO export + +;;; Code: + +(require 'org-exp) + +(defvar org-export-xoxo-final-hook nil + "Hook run after XOXO export, in the new buffer.") + +(defun org-export-as-xoxo-insert-into (buffer &rest output) + (with-current-buffer buffer + (apply 'insert output))) +(put 'org-export-as-xoxo-insert-into 'lisp-indent-function 1) + +;;;###autoload +(defun org-export-as-xoxo (&optional buffer) + "Export the org buffer as XOXO. +The XOXO buffer is named *xoxo-<source buffer name>*" + (interactive (list (current-buffer))) + (run-hooks 'org-export-first-hook) + ;; A quickie abstraction + + ;; Output everything as XOXO + (with-current-buffer (get-buffer buffer) + (let* ((pos (point)) + (opt-plist (org-combine-plists (org-default-export-plist) + (org-infile-export-plist))) + (filename (concat (file-name-as-directory + (org-export-directory :xoxo opt-plist)) + (file-name-sans-extension + (file-name-nondirectory buffer-file-name)) + ".html")) + (out (find-file-noselect filename)) + (last-level 1) + (hanging-li nil)) + (goto-char (point-min)) ;; CD: beginning-of-buffer is not allowed. + ;; Check the output buffer is empty. + (with-current-buffer out (erase-buffer)) + ;; Kick off the output + (org-export-as-xoxo-insert-into out "<ol class='xoxo'>\n") + (while (re-search-forward "^\\(\\*+\\)[ \t]+\\(.+\\)" (point-max) 't) + (let* ((hd (match-string-no-properties 1)) + (level (length hd)) + (text (concat + (match-string-no-properties 2) + (save-excursion + (goto-char (match-end 0)) + (let ((str "")) + (catch 'loop + (while 't + (forward-line) + (if (looking-at "^[ \t]\\(.*\\)") + (setq str (concat str (match-string-no-properties 1))) + (throw 'loop str))))))))) + + ;; Handle level rendering + (cond + ((> level last-level) + (org-export-as-xoxo-insert-into out "\n<ol>\n")) + + ((< level last-level) + (dotimes (- (- last-level level) 1) + (if hanging-li + (org-export-as-xoxo-insert-into out "</li>\n")) + (org-export-as-xoxo-insert-into out "</ol>\n")) + (when hanging-li + (org-export-as-xoxo-insert-into out "</li>\n") + (setq hanging-li nil))) + + ((equal level last-level) + (if hanging-li + (org-export-as-xoxo-insert-into out "</li>\n"))) + ) + + (setq last-level level) + + ;; And output the new li + (setq hanging-li 't) + (if (equal ?+ (elt text 0)) + (org-export-as-xoxo-insert-into out "<li class='" (substring text 1) "'>") + (org-export-as-xoxo-insert-into out "<li>" text)))) + + ;; Finally finish off the ol + (dotimes (- last-level 1) + (if hanging-li + (org-export-as-xoxo-insert-into out "</li>\n")) + (org-export-as-xoxo-insert-into out "</ol>\n")) + + (goto-char pos) + ;; Finish the buffer off and clean it up. + (switch-to-buffer-other-window out) + (indent-region (point-min) (point-max) nil) + (run-hooks 'org-export-xoxo-final-hook) + (save-buffer) + (goto-char (point-min)) + ))) + +(provide 'org-xoxo) + +;; arch-tag: 16e6a31f-f4f5-46f1-af18-48dc89faa702 +;;; org-xoxo.el ends here diff --git a/.emacs.d/org-7.4/lisp/org-xoxo.elc b/.emacs.d/org-7.4/lisp/org-xoxo.elc Binary files differnew file mode 100644 index 0000000..91616a0 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org-xoxo.elc diff --git a/.emacs.d/org-7.4/lisp/org.el b/.emacs.d/org-7.4/lisp/org.el new file mode 100644 index 0000000..eb91968 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org.el @@ -0,0 +1,19647 @@ +;;; org.el --- Outline-based notes management and organizer +;; Carstens outline-mode for keeping track of everything. +;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010 +;; Free Software Foundation, Inc. +;; +;; Author: Carsten Dominik <carsten at orgmode dot org> +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; Version: 7.4 +;; +;; This file is part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: +;; +;; Org-mode is a mode for keeping notes, maintaining ToDo lists, and doing +;; project planning with a fast and effective plain-text system. +;; +;; Org-mode develops organizational tasks around NOTES files that contain +;; information about projects as plain text. Org-mode is implemented on +;; top of outline-mode, which makes it possible to keep the content of +;; large files well structured. Visibility cycling and structure editing +;; help to work with the tree. Tables are easily created with a built-in +;; table editor. Org-mode supports ToDo items, deadlines, time stamps, +;; and scheduling. It dynamically compiles entries into an agenda that +;; utilizes and smoothly integrates much of the Emacs calendar and diary. +;; Plain text URL-like links connect to websites, emails, Usenet +;; messages, BBDB entries, and any files related to the projects. For +;; printing and sharing of notes, an Org-mode file can be exported as a +;; structured ASCII file, as HTML, or (todo and agenda items only) as an +;; iCalendar file. It can also serve as a publishing tool for a set of +;; linked webpages. +;; +;; Installation and Activation +;; --------------------------- +;; See the corresponding sections in the manual at +;; +;; http://orgmode.org/org.html#Installation +;; +;; Documentation +;; ------------- +;; 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. This card can be found +;; in the etc/ directory of Emacs 22. +;; +;; A list of recent changes can be found at +;; http://orgmode.org/Changes.html +;; +;;; Code: + +(defvar org-inhibit-highlight-removal nil) ; dynamically scoped param +(defvar org-table-formula-constants-local nil + "Local version of `org-table-formula-constants'.") +(make-variable-buffer-local 'org-table-formula-constants-local) + +;;;; Require other packages + +(eval-when-compile + (require 'cl) + (require 'gnus-sum)) + +(require 'calendar) + +;; Emacs 22 calendar compatibility: Make sure the new variables are available +(when (fboundp 'defvaralias) + (unless (boundp 'calendar-view-holidays-initially-flag) + (defvaralias 'calendar-view-holidays-initially-flag + 'view-calendar-holidays-initially)) + (unless (boundp 'calendar-view-diary-initially-flag) + (defvaralias 'calendar-view-diary-initially-flag + 'view-diary-entries-initially)) + (unless (boundp 'diary-fancy-buffer) + (defvaralias 'diary-fancy-buffer 'fancy-diary-buffer))) + +(require 'outline) (require 'noutline) +;; Other stuff we need. +(require 'time-date) +(unless (fboundp 'time-subtract) (defalias 'time-subtract 'subtract-time)) +(require 'easymenu) +(require 'overlay) + +(require 'org-macs) +(require 'org-entities) +(require 'org-compat) +(require 'org-faces) +(require 'org-list) +(require 'org-complete) +(require 'org-src) +(require 'org-footnote) + +;; babel +(require 'ob) +(require 'ob-table) +(require 'ob-lob) +(require 'ob-ref) +(require 'ob-tangle) +(require 'ob-comint) +(require 'ob-keys) + +;; load languages based on value of `org-babel-load-languages' +(defvar org-babel-load-languages) +;;;###autoload +(defun org-babel-do-load-languages (sym value) + "Load the languages defined in `org-babel-load-languages'." + (set-default sym value) + (mapc (lambda (pair) + (let ((active (cdr pair)) (lang (symbol-name (car pair)))) + (if active + (progn + (require (intern (concat "ob-" lang)))) + (progn + (funcall 'fmakunbound + (intern (concat "org-babel-execute:" lang))) + (funcall 'fmakunbound + (intern (concat "org-babel-expand-body:" lang))))))) + org-babel-load-languages)) + +(defcustom org-babel-load-languages '((emacs-lisp . t)) + "Languages which can be evaluated in Org-mode buffers. +This list can be used to load support for any of the languages +below, note that each language will depend on a different set of +system executables and/or Emacs modes. When a language is +\"loaded\", then code blocks in that language can be evaluated +with `org-babel-execute-src-block' bound by default to C-c +C-c (note the `org-babel-no-eval-on-ctrl-c-ctrl-c' variable can +be set to remove code block evaluation from the C-c C-c +keybinding. By default only Emacs Lisp (which has no +requirements) is loaded." + :group 'org-babel + :set 'org-babel-do-load-languages + :type '(alist :tag "Babel Languages" + :key-type + (choice + (const :tag "C" C) + (const :tag "R" R) + (const :tag "Asymptote" asymptote) + (const :tag "Calc" calc) + (const :tag "Clojure" clojure) + (const :tag "CSS" css) + (const :tag "Ditaa" ditaa) + (const :tag "Dot" dot) + (const :tag "Emacs Lisp" emacs-lisp) + (const :tag "Gnuplot" gnuplot) + (const :tag "Haskell" haskell) + (const :tag "Javascript" js) + (const :tag "Latex" latex) + (const :tag "Ledger" ledger) + (const :tag "Matlab" matlab) + (const :tag "Mscgen" mscgen) + (const :tag "Ocaml" ocaml) + (const :tag "Octave" octave) + (const :tag "Org" org) + (const :tag "Perl" perl) + (const :tag "PlantUML" plantuml) + (const :tag "Python" python) + (const :tag "Ruby" ruby) + (const :tag "Sass" sass) + (const :tag "Scheme" scheme) + (const :tag "Screen" screen) + (const :tag "Shell Script" sh) + (const :tag "Sql" sql) + (const :tag "Sqlite" sqlite)) + :value-type (boolean :tag "Activate" :value t))) + +;;;; Customization variables +(defcustom org-clone-delete-id nil + "Remove ID property of clones of a subtree. +When non-nil, clones of a subtree don't inherit the ID property. +Otherwise they inherit the ID property with a new unique +identifier." + :type 'boolean + :group 'org-id) + +;;; Version + +(defconst org-version "7.4" + "The version number of the file org.el.") + +(defun org-version (&optional here) + "Show the org-mode version in the echo area. +With prefix arg HERE, insert it at point." + (interactive "P") + (let* ((origin default-directory) + (version org-version) + (git-version) + (dir (concat (file-name-directory (locate-library "org")) "../" ))) + (when (and (file-exists-p (expand-file-name ".git" dir)) + (executable-find "git")) + (unwind-protect + (progn + (cd dir) + (when (eql 0 (shell-command "git describe --abbrev=4 HEAD")) + (with-current-buffer "*Shell Command Output*" + (goto-char (point-min)) + (setq git-version (buffer-substring (point) (point-at-eol)))) + (subst-char-in-string ?- ?. git-version t) + (when (string-match "\\S-" + (shell-command-to-string + "git diff-index --name-only HEAD --")) + (setq git-version (concat git-version ".dirty"))) + (setq version (concat version " (" git-version ")")))) + (cd origin))) + (setq version (format "Org-mode version %s" version)) + (if here (insert version)) + (message version))) + +;;; Compatibility constants + +;;; The custom variables + +(defgroup org nil + "Outline-based notes management and organizer." + :tag "Org" + :group 'outlines + :group 'calendar) + +(defcustom org-mode-hook nil + "Mode hook for Org-mode, run after the mode was turned on." + :group 'org + :type 'hook) + +(defcustom org-load-hook nil + "Hook that is run after org.el has been loaded." + :group 'org + :type 'hook) + +(defvar org-modules) ; defined below +(defvar org-modules-loaded nil + "Have the modules been loaded already?") + +(defun org-load-modules-maybe (&optional force) + "Load all extensions listed in `org-modules'." + (when (or force (not org-modules-loaded)) + (mapc (lambda (ext) + (condition-case nil (require ext) + (error (message "Problems while trying to load feature `%s'" ext)))) + org-modules) + (setq org-modules-loaded t))) + +(defun org-set-modules (var value) + "Set VAR to VALUE and call `org-load-modules-maybe' with the force flag." + (set var value) + (when (featurep 'org) + (org-load-modules-maybe 'force))) + +(when (org-bound-and-true-p org-modules) + (let ((a (member 'org-infojs org-modules))) + (and a (setcar a 'org-jsinfo)))) + +(defcustom org-modules '(org-bbdb org-bibtex org-docview org-gnus org-info org-jsinfo org-irc org-mew org-mhe org-rmail org-vm org-w3m org-wl) + "Modules that should always be loaded together with org.el. +If a description starts with <C>, the file is not part of Emacs +and loading it will require that you have downloaded and properly installed +the org-mode distribution. + +You can also use this system to load external packages (i.e. neither Org +core modules, nor modules from the CONTRIB directory). Just add symbols +to the end of the list. If the package is called org-xyz.el, then you need +to add the symbol `xyz', and the package must have a call to + + (provide 'org-xyz)" + :group 'org + :set 'org-set-modules + :type + '(set :greedy t + (const :tag " bbdb: Links to BBDB entries" org-bbdb) + (const :tag " bibtex: Links to BibTeX entries" org-bibtex) + (const :tag " crypt: Encryption of subtrees" org-crypt) + (const :tag " ctags: Access to Emacs tags with links" org-ctags) + (const :tag " docview: Links to doc-view buffers" org-docview) + (const :tag " gnus: Links to GNUS folders/messages" org-gnus) + (const :tag " id: Global IDs for identifying entries" org-id) + (const :tag " info: Links to Info nodes" org-info) + (const :tag " jsinfo: Set up Sebastian Rose's JavaScript org-info.js" org-jsinfo) + (const :tag " habit: Track your consistency with habits" org-habit) + (const :tag " inlinetask: Tasks independent of outline hierarchy" org-inlinetask) + (const :tag " irc: Links to IRC/ERC chat sessions" org-irc) + (const :tag " mac-message: Links to messages in Apple Mail" org-mac-message) + (const :tag " mew Links to Mew folders/messages" org-mew) + (const :tag " mhe: Links to MHE folders/messages" org-mhe) + (const :tag " protocol: Intercept calls from emacsclient" org-protocol) + (const :tag " rmail: Links to RMAIL folders/messages" org-rmail) + (const :tag " vm: Links to VM folders/messages" org-vm) + (const :tag " wl: Links to Wanderlust folders/messages" org-wl) + (const :tag " w3m: Special cut/paste from w3m to Org-mode." org-w3m) + (const :tag " mouse: Additional mouse support" org-mouse) + (const :tag " TaskJuggler: Export tasks to a TaskJuggler project" org-taskjuggler) + + (const :tag "C annotate-file: Annotate a file with org syntax" org-annotate-file) + (const :tag "C bookmark: Org-mode links to bookmarks" org-bookmark) + (const :tag "C checklist: Extra functions for checklists in repeated tasks" org-checklist) + (const :tag "C choose: Use TODO keywords to mark decisions states" org-choose) + (const :tag "C collector: Collect properties into tables" org-collector) + (const :tag "C depend: TODO dependencies for Org-mode\n\t\t\t(PARTIALLY OBSOLETE, see built-in dependency support))" org-depend) + (const :tag "C elisp-symbol: Org-mode links to emacs-lisp symbols" org-elisp-symbol) + (const :tag "C eval: Include command output as text" org-eval) + (const :tag "C eval-light: Evaluate inbuffer-code on demand" org-eval-light) + (const :tag "C expiry: Expiry mechanism for Org-mode entries" org-expiry) + (const :tag "C exp-bibtex: Export citations using BibTeX" org-exp-bibtex) + (const :tag "C git-link: Provide org links to specific file version" org-git-link) + (const :tag "C interactive-query: Interactive modification of tags query\n\t\t\t(PARTIALLY OBSOLETE, see secondary filtering)" org-interactive-query) + + (const :tag "C invoice: Help manage client invoices in Org-mode" org-invoice) + + (const :tag "C jira: Add a jira:ticket protocol to Org-mode" org-jira) + (const :tag "C learn: SuperMemo's incremental learning algorithm" org-learn) + (const :tag "C mairix: Hook mairix search into Org-mode for different MUAs" org-mairix) + (const :tag "C mac-iCal Imports events from iCal.app to the Emacs diary" org-mac-iCal) + (const :tag "C mac-link-grabber Grab links and URLs from various Mac applications" org-mac-link-grabber) + (const :tag "C man: Support for links to manpages in Org-mode" org-man) + (const :tag "C mtags: Support for muse-like tags" org-mtags) + (const :tag "C panel: Simple routines for us with bad memory" org-panel) + (const :tag "C registry: A registry for Org-mode links" org-registry) + (const :tag "C org2rem: Convert org appointments into reminders" org2rem) + (const :tag "C screen: Visit screen sessions through Org-mode links" org-screen) + (const :tag "C secretary: Team management with org-mode" org-secretary) + (const :tag "C special-blocks: Turn blocks into LaTeX envs and HTML divs" org-special-blocks) + (const :tag "C sqlinsert: Convert Org-mode tables to SQL insertions" orgtbl-sqlinsert) + (const :tag "C toc: Table of contents for Org-mode buffer" org-toc) + (const :tag "C track: Keep up with Org-mode development" org-track) + (const :tag "C velocity Something like Notational Velocity for Org" org-velocity) + (const :tag "C wikinodes: CamelCase wiki-like links" org-wikinodes) + (repeat :tag "External packages" :inline t (symbol :tag "Package")))) + +(defcustom org-support-shift-select nil + "Non-nil means make shift-cursor commands select text when possible. + +In Emacs 23, when `shift-select-mode' is on, shifted cursor keys start +selecting a region, or enlarge regions started in this way. +In Org-mode, in special contexts, these same keys are used for other +purposes, important enough to compete with shift selection. Org tries +to balance these needs by supporting `shift-select-mode' outside these +special contexts, under control of this variable. + +The default of this variable is nil, to avoid confusing behavior. Shifted +cursor keys will then execute Org commands in the following contexts: +- on a headline, changing TODO state (left/right) and priority (up/down) +- on a time stamp, changing the time +- in a plain list item, changing the bullet type +- in a property definition line, switching between allowed values +- in the BEGIN line of a clock table (changing the time block). +Outside these contexts, the commands will throw an error. + +When this variable is t and the cursor is not in a special context, +Org-mode will support shift-selection for making and enlarging regions. +To make this more effective, the bullet cycling will no longer happen +anywhere in an item line, but only if the cursor is exactly on the bullet. + +If you set this variable to the symbol `always', then the keys +will not be special in headlines, property lines, and item lines, to make +shift selection work there as well. If this is what you want, you can +use the following alternative commands: `C-c C-t' and `C-c ,' to +change TODO state and priority, `C-u C-u C-c C-t' can be used to switch +TODO sets, `C-c -' to cycle item bullet types, and properties can be +edited by hand or in column view. + +However, when the cursor is on a timestamp, shift-cursor commands +will still edit the time stamp - this is just too good to give up. + +XEmacs user should have this variable set to nil, because shift-select-mode +is Emacs 23 only." + :group 'org + :type '(choice + (const :tag "Never" nil) + (const :tag "When outside special context" t) + (const :tag "Everywhere except timestamps" always))) + +(defgroup org-startup nil + "Options concerning startup of Org-mode." + :tag "Org Startup" + :group 'org) + +(defcustom org-startup-folded t + "Non-nil means entering Org-mode will switch to OVERVIEW. +This can also be configured on a per-file basis by adding one of +the following lines anywhere in the buffer: + + #+STARTUP: fold (or `overview', this is equivalent) + #+STARTUP: nofold (or `showall', this is equivalent) + #+STARTUP: content + #+STARTUP: showeverything" + :group 'org-startup + :type '(choice + (const :tag "nofold: show all" nil) + (const :tag "fold: overview" t) + (const :tag "content: all headlines" content) + (const :tag "show everything, even drawers" showeverything))) + +(defcustom org-startup-truncated t + "Non-nil means entering Org-mode will set `truncate-lines'. +This is useful since some lines containing links can be very long and +uninteresting. Also tables look terrible when wrapped." + :group 'org-startup + :type 'boolean) + +(defcustom org-startup-indented nil + "Non-nil means turn on `org-indent-mode' on startup. +This can also be configured on a per-file basis by adding one of +the following lines anywhere in the buffer: + + #+STARTUP: indent + #+STARTUP: noindent" + :group 'org-structure + :type '(choice + (const :tag "Not" nil) + (const :tag "Globally (slow on startup in large files)" t))) + +(defcustom org-use-sub-superscripts t + "Non-nil means interpret \"_\" and \"^\" for export. +When this option is turned on, you can use TeX-like syntax for sub- and +superscripts. Several characters after \"_\" or \"^\" will be +considered as a single item - so grouping with {} is normally not +needed. For example, the following things will be parsed as single +sub- or superscripts. + + 10^24 or 10^tau several digits will be considered 1 item. + 10^-12 or 10^-tau a leading sign with digits or a word + x^2-y^3 will be read as x^2 - y^3, because items are + terminated by almost any nonword/nondigit char. + x_{i^2} or x^(2-i) braces or parenthesis do grouping. + +Still, ambiguity is possible - so when in doubt use {} to enclose the +sub/superscript. If you set this variable to the symbol `{}', +the braces are *required* in order to trigger interpretations as +sub/superscript. This can be helpful in documents that need \"_\" +frequently in plain text. + +Not all export backends support this, but HTML does. + +This option can also be set with the +OPTIONS line, e.g. \"^:nil\"." + :group 'org-startup + :group 'org-export-translation + :type '(choice + (const :tag "Always interpret" t) + (const :tag "Only with braces" {}) + (const :tag "Never interpret" nil))) + +(if (fboundp 'defvaralias) + (defvaralias 'org-export-with-sub-superscripts 'org-use-sub-superscripts)) + + +(defcustom org-startup-with-beamer-mode nil + "Non-nil means turn on `org-beamer-mode' on startup. +This can also be configured on a per-file basis by adding one of +the following lines anywhere in the buffer: + + #+STARTUP: beamer" + :group 'org-startup + :type 'boolean) + +(defcustom org-startup-align-all-tables nil + "Non-nil means align all tables when visiting a file. +This is useful when the column width in tables is forced with <N> cookies +in table fields. Such tables will look correct only after the first re-align. +This can also be configured on a per-file basis by adding one of +the following lines anywhere in the buffer: + #+STARTUP: align + #+STARTUP: noalign" + :group 'org-startup + :type 'boolean) + +(defcustom org-startup-with-inline-images nil + "Non-nil means show inline images when loading a new Org file. +This can also be configured on a per-file basis by adding one of +the following lines anywhere in the buffer: + #+STARTUP: inlineimages + #+STARTUP: noinlineimages" + :group 'org-startup + :type 'boolean) + +(defcustom org-insert-mode-line-in-empty-file nil + "Non-nil means insert the first line setting Org-mode in empty files. +When the function `org-mode' is called interactively in an empty file, this +normally means that the file name does not automatically trigger Org-mode. +To ensure that the file will always be in Org-mode in the future, a +line enforcing Org-mode will be inserted into the buffer, if this option +has been set." + :group 'org-startup + :type 'boolean) + +(defcustom org-replace-disputed-keys nil + "Non-nil means use alternative key bindings for some keys. +Org-mode uses S-<cursor> keys for changing timestamps and priorities. +These keys are also used by other packages like shift-selection-mode' +\(built into Emacs 23), `CUA-mode' or `windmove.el'. +If you want to use Org-mode together with one of these other modes, +or more generally if you would like to move some Org-mode commands to +other keys, set this variable and configure the keys with the variable +`org-disputed-keys'. + +This option is only relevant at load-time of Org-mode, and must be set +*before* org.el is loaded. Changing it requires a restart of Emacs to +become effective." + :group 'org-startup + :type 'boolean) + +(defcustom org-use-extra-keys nil + "Non-nil means use extra key sequence definitions for certain commands. +This happens automatically if you run XEmacs or if `window-system' +is nil. This variable lets you do the same manually. You must +set it before loading org. + +Example: on Carbon Emacs 22 running graphically, with an external +keyboard on a Powerbook, the default way of setting M-left might +not work for either Alt or ESC. Setting this variable will make +it work for ESC." + :group 'org-startup + :type 'boolean) + +(if (fboundp 'defvaralias) + (defvaralias 'org-CUA-compatible 'org-replace-disputed-keys)) + +(defcustom org-disputed-keys + '(([(shift up)] . [(meta p)]) + ([(shift down)] . [(meta n)]) + ([(shift left)] . [(meta -)]) + ([(shift right)] . [(meta +)]) + ([(control shift right)] . [(meta shift +)]) + ([(control shift left)] . [(meta shift -)])) + "Keys for which Org-mode and other modes compete. +This is an alist, cars are the default keys, second element specifies +the alternative to use when `org-replace-disputed-keys' is t. + +Keys can be specified in any syntax supported by `define-key'. +The value of this option takes effect only at Org-mode's startup, +therefore you'll have to restart Emacs to apply it after changing." + :group 'org-startup + :type 'alist) + +(defun org-key (key) + "Select key according to `org-replace-disputed-keys' and `org-disputed-keys'. +Or return the original if not disputed. +Also apply the translations defined in `org-xemacs-key-equivalents'." + (when org-replace-disputed-keys + (let* ((nkey (key-description key)) + (x (org-find-if (lambda (x) + (equal (key-description (car x)) nkey)) + org-disputed-keys))) + (setq key (if x (cdr x) key)))) + (when (featurep 'xemacs) + (setq key (or (cdr (assoc key org-xemacs-key-equivalents)) key))) + key) + +(defun org-find-if (predicate seq) + (catch 'exit + (while seq + (if (funcall predicate (car seq)) + (throw 'exit (car seq)) + (pop seq))))) + +(defun org-defkey (keymap key def) + "Define a key, possibly translated, as returned by `org-key'." + (define-key keymap (org-key key) def)) + +(defcustom org-ellipsis nil + "The ellipsis to use in the Org-mode outline. +When nil, just use the standard three dots. When a string, use that instead, +When a face, use the standard 3 dots, but with the specified face. +The change affects only Org-mode (which will then use its own display table). +Changing this requires executing `M-x org-mode' in a buffer to become +effective." + :group 'org-startup + :type '(choice (const :tag "Default" nil) + (face :tag "Face" :value org-warning) + (string :tag "String" :value "...#"))) + +(defvar org-display-table nil + "The display table for org-mode, in case `org-ellipsis' is non-nil.") + +(defgroup org-keywords nil + "Keywords in Org-mode." + :tag "Org Keywords" + :group 'org) + +(defcustom org-deadline-string "DEADLINE:" + "String to mark deadline entries. +A deadline is this string, followed by a time stamp. Should be a word, +terminated by a colon. You can insert a schedule keyword and +a timestamp with \\[org-deadline]. +Changes become only effective after restarting Emacs." + :group 'org-keywords + :type 'string) + +(defcustom org-scheduled-string "SCHEDULED:" + "String to mark scheduled TODO entries. +A schedule is this string, followed by a time stamp. Should be a word, +terminated by a colon. You can insert a schedule keyword and +a timestamp with \\[org-schedule]. +Changes become only effective after restarting Emacs." + :group 'org-keywords + :type 'string) + +(defcustom org-closed-string "CLOSED:" + "String used as the prefix for timestamps logging closing a TODO entry." + :group 'org-keywords + :type 'string) + +(defcustom org-clock-string "CLOCK:" + "String used as prefix for timestamps clocking work hours on an item." + :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 +\\[org-toggle-comment]. +Changes become only effective after restarting Emacs." + :group 'org-keywords + :type 'string) + +(defcustom org-quote-string "QUOTE" + "Entries starting with this keyword will be exported in fixed-width font. +Quoting applies only to the text in the entry following the headline, and does +not extend beyond the next headline, even if that is lower level. +An entry can be toggled between QUOTE and normal with +\\[org-toggle-fixed-width-section]." + :group 'org-keywords + :type 'string) + +(defconst org-repeat-re + "<[0-9]\\{4\\}-[0-9][0-9]-[0-9][0-9] [^>\n]*?\\([.+]?\\+[0-9]+[dwmy]\\(/[0-9]+[dwmy]\\)?\\)" + "Regular expression for specifying repeated events. +After a match, group 1 contains the repeat expression.") + +(defgroup org-structure nil + "Options concerning the general structure of Org-mode files." + :tag "Org Structure" + :group 'org) + +(defgroup org-reveal-location nil + "Options about how to make context of a location visible." + :tag "Org Reveal Location" + :group 'org-structure) + +(defconst org-context-choice + '(choice + (const :tag "Always" t) + (const :tag "Never" nil) + (repeat :greedy t :tag "Individual contexts" + (cons + (choice :tag "Context" + (const agenda) + (const org-goto) + (const occur-tree) + (const tags-tree) + (const link-search) + (const mark-goto) + (const bookmark-jump) + (const isearch) + (const default)) + (boolean)))) + "Contexts for the reveal options.") + +(defcustom org-show-hierarchy-above '((default . t)) + "Non-nil means show full hierarchy when revealing a location. +Org-mode often shows locations in an org-mode file which might have +been invisible before. When this is set, the hierarchy of headings +above the exposed location is shown. +Turning this off for example for sparse trees makes them very compact. +Instead of t, this can also be an alist specifying this option for different +contexts. Valid contexts are + agenda when exposing an entry from the agenda + org-goto when using the command `org-goto' on key C-c C-j + occur-tree when using the command `org-occur' on key C-c / + tags-tree when constructing a sparse tree based on tags matches + link-search when exposing search matches associated with a link + mark-goto when exposing the jump goal of a mark + bookmark-jump when exposing a bookmark location + isearch when exiting from an incremental search + default default for all contexts not set explicitly" + :group 'org-reveal-location + :type org-context-choice) + +(defcustom org-show-following-heading '((default . nil)) + "Non-nil means show following heading when revealing a location. +Org-mode often shows locations in an org-mode file which might have +been invisible before. When this is set, the heading following the +match is shown. +Turning this off for example for sparse trees makes them very compact, +but makes it harder to edit the location of the match. In such a case, +use the command \\[org-reveal] to show more context. +Instead of t, this can also be an alist specifying this option for different +contexts. See `org-show-hierarchy-above' for valid contexts." + :group 'org-reveal-location + :type org-context-choice) + +(defcustom org-show-siblings '((default . nil) (isearch t)) + "Non-nil means show all sibling heading when revealing a location. +Org-mode often shows locations in an org-mode file which might have +been invisible before. When this is set, the sibling of the current entry +heading are all made visible. If `org-show-hierarchy-above' is t, +the same happens on each level of the hierarchy above the current entry. + +By default this is on for the isearch context, off for all other contexts. +Turning this off for example for sparse trees makes them very compact, +but makes it harder to edit the location of the match. In such a case, +use the command \\[org-reveal] to show more context. +Instead of t, this can also be an alist specifying this option for different +contexts. See `org-show-hierarchy-above' for valid contexts." + :group 'org-reveal-location + :type org-context-choice) + +(defcustom org-show-entry-below '((default . nil)) + "Non-nil means show the entry below a headline when revealing a location. +Org-mode often shows locations in an org-mode file which might have +been invisible before. When this is set, the text below the headline that is +exposed is also shown. + +By default this is off for all contexts. +Instead of t, this can also be an alist specifying this option for different +contexts. See `org-show-hierarchy-above' for valid contexts." + :group 'org-reveal-location + :type org-context-choice) + +(defcustom org-indirect-buffer-display 'other-window + "How should indirect tree buffers be displayed? +This applies to indirect buffers created with the commands +\\[org-tree-to-indirect-buffer] and \\[org-agenda-tree-to-indirect-buffer]. +Valid values are: +current-window Display in the current window +other-window Just display in another window. +dedicated-frame Create one new frame, and re-use it each time. +new-frame Make a new frame each time. Note that in this case + previously-made indirect buffers are kept, and you need to + kill these buffers yourself." + :group 'org-structure + :group 'org-agenda-windows + :type '(choice + (const :tag "In current window" current-window) + (const :tag "In current frame, other window" other-window) + (const :tag "Each time a new frame" new-frame) + (const :tag "One dedicated frame" dedicated-frame))) + +(defcustom org-use-speed-commands nil + "Non-nil means activate single letter commands at beginning of a headline. +This may also be a function to test for appropriate locations where speed +commands should be active." + :group 'org-structure + :type '(choice + (const :tag "Never" nil) + (const :tag "At beginning of headline stars" t) + (function))) + +(defcustom org-speed-commands-user nil + "Alist of additional speed commands. +This list will be checked before `org-speed-commands-default' +when the variable `org-use-speed-commands' is non-nil +and when the cursor is at the beginning of a headline. +The car if each entry is a string with a single letter, which must +be assigned to `self-insert-command' in the global map. +The cdr is either a command to be called interactively, a function +to be called, or a form to be evaluated. +An entry that is just a list with a single string will be interpreted +as a descriptive headline that will be added when listing the speed +commands in the Help buffer using the `?' speed command." + :group 'org-structure + :type '(repeat :value ("k" . ignore) + (choice :value ("k" . ignore) + (list :tag "Descriptive Headline" (string :tag "Headline")) + (cons :tag "Letter and Command" + (string :tag "Command letter") + (choice + (function) + (sexp)))))) + +(defgroup org-cycle nil + "Options concerning visibility cycling in Org-mode." + :tag "Org Cycle" + :group 'org-structure) + +(defcustom org-cycle-skip-children-state-if-no-children t + "Non-nil means skip CHILDREN state in entries that don't have any." + :group 'org-cycle + :type 'boolean) + +(defcustom org-cycle-max-level nil + "Maximum level which should still be subject to visibility cycling. +Levels higher than this will, for cycling, be treated as text, not a headline. +When `org-odd-levels-only' is set, a value of N in this variable actually +means 2N-1 stars as the limiting headline. +When nil, cycle all levels. +Note that the limiting level of cycling is also influenced by +`org-inlinetask-min-level'. When `org-cycle-max-level' is not set but +`org-inlinetask-min-level' is, cycling will be limited to levels one less +than its value." + :group 'org-cycle + :type '(choice + (const :tag "No limit" nil) + (integer :tag "Maximum level"))) + +(defcustom org-drawers '("PROPERTIES" "CLOCK" "LOGBOOK") + "Names of drawers. Drawers are not opened by cycling on the headline above. +Drawers only open with a TAB on the drawer line itself. A drawer looks like +this: + :DRAWERNAME: + ..... + :END: +The drawer \"PROPERTIES\" is special for capturing properties through +the property API. + +Drawers can be defined on the per-file basis with a line like: + +#+DRAWERS: HIDDEN STATE PROPERTIES" + :group 'org-structure + :group 'org-cycle + :type '(repeat (string :tag "Drawer Name"))) + +(defcustom org-hide-block-startup nil + "Non-nil means entering Org-mode will fold all blocks. +This can also be set in on a per-file basis with + +#+STARTUP: hideblocks +#+STARTUP: showblocks" + :group 'org-startup + :group 'org-cycle + :type 'boolean) + +(defcustom org-cycle-global-at-bob nil + "Cycle globally if cursor is at beginning of buffer and not at a headline. +This makes it possible to do global cycling without having to use S-TAB or +\\[universal-argument] TAB. For this special case to work, the first line \ +of the buffer +must not be a headline - it may be empty or some other text. When used in +this way, `org-cycle-hook' is disables temporarily, to make sure the +cursor stays at the beginning of the buffer. +When this option is nil, don't do anything special at the beginning +of the buffer." + :group 'org-cycle + :type 'boolean) + +(defcustom org-cycle-level-after-item/entry-creation t + "Non-nil means cycle entry level or item indentation in new empty entries. + +When the cursor is at the end of an empty headline, i.e with only stars +and maybe a TODO keyword, TAB will then switch the entry to become a child, +and then all possible ancestor states, before returning to the original state. +This makes data entry extremely fast: M-RET to create a new headline, +on TAB to make it a child, two or more tabs to make it a (grand-)uncle. + +When the cursor is at the end of an empty plain list item, one TAB will +make it a subitem, two or more tabs will back up to make this an item +higher up in the item hierarchy." + :group 'org-cycle + :type 'boolean) + +(defcustom org-cycle-emulate-tab t + "Where should `org-cycle' emulate TAB. +nil Never +white Only in completely white lines +whitestart Only at the beginning of lines, before the first non-white char +t Everywhere except in headlines +exc-hl-bol Everywhere except at the start of a headline +If TAB is used in a place where it does not emulate TAB, the current subtree +visibility is cycled." + :group 'org-cycle + :type '(choice (const :tag "Never" nil) + (const :tag "Only in completely white lines" white) + (const :tag "Before first char in a line" whitestart) + (const :tag "Everywhere except in headlines" t) + (const :tag "Everywhere except at bol in headlines" exc-hl-bol) + )) + +(defcustom org-cycle-separator-lines 2 + "Number of empty lines needed to keep an empty line between collapsed trees. +If you leave an empty line between the end of a subtree and the following +headline, this empty line is hidden when the subtree is folded. +Org-mode will leave (exactly) one empty line visible if the number of +empty lines is equal or larger to the number given in this variable. +So the default 2 means at least 2 empty lines after the end of a subtree +are needed to produce free space between a collapsed subtree and the +following headline. + +If the number is negative, and the number of empty lines is at least -N, +all empty lines are shown. + +Special case: when 0, never leave empty lines in collapsed view." + :group 'org-cycle + :type 'integer) +(put 'org-cycle-separator-lines 'safe-local-variable 'integerp) + +(defcustom org-pre-cycle-hook nil + "Hook that is run before visibility cycling is happening. +The function(s) in this hook must accept a single argument which indicates +the new state that will be set right after running this hook. The +argument is a symbol. Before a global state change, it can have the values +`overview', `content', or `all'. Before a local state change, it can have +the values `folded', `children', or `subtree'." + :group 'org-cycle + :type 'hook) + +(defcustom org-cycle-hook '(org-cycle-hide-archived-subtrees + org-cycle-hide-drawers + org-cycle-show-empty-lines + org-optimize-window-after-visibility-change) + "Hook that is run after `org-cycle' has changed the buffer visibility. +The function(s) in this hook must accept a single argument which indicates +the new state that was set by the most recent `org-cycle' command. The +argument is a symbol. After a global state change, it can have the values +`overview', `content', or `all'. After a local state change, it can have +the values `folded', `children', or `subtree'." + :group 'org-cycle + :type 'hook) + +(defgroup org-edit-structure nil + "Options concerning structure editing in Org-mode." + :tag "Org Edit Structure" + :group 'org-structure) + +(defcustom org-odd-levels-only nil + "Non-nil means skip even levels and only use odd levels for the outline. +This has the effect that two stars are being added/taken away in +promotion/demotion commands. It also influences how levels are +handled by the exporters. +Changing it requires restart of `font-lock-mode' to become effective +for fontification also in regions already fontified. +You may also set this on a per-file basis by adding one of the following +lines to the buffer: + + #+STARTUP: odd + #+STARTUP: oddeven" + :group 'org-edit-structure + :group 'org-appearance + :type 'boolean) + +(defcustom org-adapt-indentation t + "Non-nil means adapt indentation to outline node level. + +When this variable is set, Org assumes that you write outlines by +indenting text in each node to align with the headline (after the stars). +The following issues are influenced by this variable: + +- When this is set and the *entire* text in an entry is indented, the + indentation is increased by one space in a demotion command, and + decreased by one in a promotion command. If any line in the entry + body starts with text at column 0, indentation is not changed at all. + +- Property drawers and planning information is inserted indented when + this variable s set. When nil, they will not be indented. + +- TAB indents a line relative to context. The lines below a headline + will be indented when this variable is set. + +Note that this is all about true indentation, by adding and removing +space characters. See also `org-indent.el' which does level-dependent +indentation in a virtual way, i.e. at display time in Emacs." + :group 'org-edit-structure + :type 'boolean) + +(defcustom org-special-ctrl-a/e nil + "Non-nil means `C-a' and `C-e' behave specially in headlines and items. + +When t, `C-a' will bring back the cursor to the beginning of the +headline text, i.e. after the stars and after a possible TODO keyword. +In an item, this will be the position after the bullet. +When the cursor is already at that position, another `C-a' will bring +it to the beginning of the line. + +`C-e' will jump to the end of the headline, ignoring the presence of tags +in the headline. A second `C-e' will then jump to the true end of the +line, after any tags. This also means that, when this variable is +non-nil, `C-e' also will never jump beyond the end of the heading of a +folded section, i.e. not after the ellipses. + +When set to the symbol `reversed', the first `C-a' or `C-e' works normally, +going to the true line boundary first. Only a directly following, identical +keypress will bring the cursor to the special positions. + +This may also be a cons cell where the behavior for `C-a' and `C-e' is +set separately." + :group 'org-edit-structure + :type '(choice + (const :tag "off" nil) + (const :tag "on: after stars/bullet and before tags first" t) + (const :tag "reversed: true line boundary first" reversed) + (cons :tag "Set C-a and C-e separately" + (choice :tag "Special C-a" + (const :tag "off" nil) + (const :tag "on: after stars/bullet first" t) + (const :tag "reversed: before stars/bullet first" reversed)) + (choice :tag "Special C-e" + (const :tag "off" nil) + (const :tag "on: before tags first" t) + (const :tag "reversed: after tags first" reversed))))) +(if (fboundp 'defvaralias) + (defvaralias 'org-special-ctrl-a 'org-special-ctrl-a/e)) + +(defcustom org-special-ctrl-k nil + "Non-nil means `C-k' will behave specially in headlines. +When nil, `C-k' will call the default `kill-line' command. +When t, the following will happen while the cursor is in the headline: + +- When the cursor is at the beginning of a headline, kill the entire + line and possible the folded subtree below the line. +- When in the middle of the headline text, kill the headline up to the tags. +- When after the headline text, kill the tags." + :group 'org-edit-structure + :type 'boolean) + +(defcustom org-ctrl-k-protect-subtree nil + "Non-nil means, do not delete a hidden subtree with C-k. +When set to the symbol `error', simply throw an error when C-k is +used to kill (part-of) a headline that has hidden text behind it. +Any other non-nil value will result in a query to the user, if it is +OK to kill that hidden subtree. When nil, kill without remorse." + :group 'org-edit-structure + :type '(choice + (const :tag "Do not protect hidden subtrees" nil) + (const :tag "Protect hidden subtrees with a security query" t) + (const :tag "Never kill a hidden subtree with C-k" error))) + +(defcustom org-yank-folded-subtrees t + "Non-nil means when yanking subtrees, fold them. +If the kill is a single subtree, or a sequence of subtrees, i.e. if +it starts with a heading and all other headings in it are either children +or siblings, then fold all the subtrees. However, do this only if no +text after the yank would be swallowed into a folded tree by this action." + :group 'org-edit-structure + :type 'boolean) + +(defcustom org-yank-adjusted-subtrees nil + "Non-nil means when yanking subtrees, adjust the level. +With this setting, `org-paste-subtree' is used to insert the subtree, see +this function for details." + :group 'org-edit-structure + :type 'boolean) + +(defcustom org-M-RET-may-split-line '((default . t)) + "Non-nil means M-RET will split the line at the cursor position. +When nil, it will go to the end of the line before making a +new line. +You may also set this option in a different way for different +contexts. Valid contexts are: + +headline when creating a new headline +item when creating a new item +table in a table field +default the value to be used for all contexts not explicitly + customized" + :group 'org-structure + :group 'org-table + :type '(choice + (const :tag "Always" t) + (const :tag "Never" nil) + (repeat :greedy t :tag "Individual contexts" + (cons + (choice :tag "Context" + (const headline) + (const item) + (const table) + (const default)) + (boolean))))) + + +(defcustom org-insert-heading-respect-content nil + "Non-nil means insert new headings after the current subtree. +When nil, the new heading is created directly after the current line. +The commands \\[org-insert-heading-respect-content] and +\\[org-insert-todo-heading-respect-content] turn this variable on +for the duration of the command." + :group 'org-structure + :type 'boolean) + +(defcustom org-blank-before-new-entry '((heading . auto) + (plain-list-item . auto)) + "Should `org-insert-heading' leave a blank line before new heading/item? +The value is an alist, with `heading' and `plain-list-item' as car, +and a boolean flag as cdr. The cdr may lso be the symbol `auto', and then +Org will look at the surrounding headings/items and try to make an +intelligent decision wether to insert a blank line or not. + +For plain lists, if the variable `org-empty-line-terminates-plain-lists' is +set, the setting here is ignored and no empty line is inserted, to avoid +breaking the list structure." + :group 'org-edit-structure + :type '(list + (cons (const heading) + (choice (const :tag "Never" nil) + (const :tag "Always" t) + (const :tag "Auto" auto))) + (cons (const plain-list-item) + (choice (const :tag "Never" nil) + (const :tag "Always" t) + (const :tag "Auto" auto))))) + +(defcustom org-insert-heading-hook nil + "Hook being run after inserting a new heading." + :group 'org-edit-structure + :type 'hook) + +(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. +When nil, such lines will be treated like ordinary lines. +See also the QUOTE keyword." + :group 'org-edit-structure + :type 'boolean) + +(defcustom org-goto-auto-isearch t + "Non-nil means typing characters in `org-goto' starts incremental search." + :group 'org-edit-structure + :type 'boolean) + +(defgroup org-sparse-trees nil + "Options concerning sparse trees in Org-mode." + :tag "Org Sparse Trees" + :group 'org-structure) + +(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-sparse-trees + :type 'boolean) + +(defcustom org-remove-highlights-with-change t + "Non-nil means any change to the buffer will remove temporary highlights. +Such highlights are created by `org-occur' and `org-clock-display'. +When nil, `C-c C-c needs to be used to get rid of the highlights. +The highlights created by `org-preview-latex-fragment' always need +`C-c C-c' to be removed." + :group 'org-sparse-trees + :group 'org-time + :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 +as possible." + :group 'org-sparse-trees + :type 'hook) + +(defgroup org-imenu-and-speedbar nil + "Options concerning imenu and speedbar in Org-mode." + :tag "Org Imenu and Speedbar" + :group 'org-structure) + +(defcustom org-imenu-depth 2 + "The maximum level for Imenu access to Org-mode headlines. +This also applied for speedbar access." + :group 'org-imenu-and-speedbar + :type 'integer) + +(defgroup org-table nil + "Options concerning tables in Org-mode." + :tag "Org Table" + :group 'org) + +(defcustom org-enable-table-editor 'optimized + "Non-nil means lines starting with \"|\" are handled by the table editor. +When nil, such lines will be treated like ordinary lines. + +When equal to the symbol `optimized', the table editor will be optimized to +do the following: +- Automatic overwrite mode in front of whitespace in table fields. + This makes the structure of the table stay in tact as long as the edited + field does not exceed the column width. +- Minimize the number of realigns. Normally, the table is aligned each time + TAB or RET are pressed to move to another field. With optimization this + happens only if changes to a field might have changed the column width. +Optimization requires replacing the functions `self-insert-command', +`delete-char', and `backward-delete-char' in Org-mode buffers, with a +slight (in fact: unnoticeable) speed impact for normal typing. Org-mode is +very good at guessing when a re-align will be necessary, but you can always +force one with \\[org-ctrl-c-ctrl-c]. + +If you would like to use the optimized version in Org-mode, but the +un-optimized version in OrgTbl-mode, see the variable `orgtbl-optimized'. + +This variable can be used to turn on and off the table editor during a session, +but in order to toggle optimization, a restart is required. + +See also the variable `org-table-auto-blank-field'." + :group 'org-table + :type '(choice + (const :tag "off" nil) + (const :tag "on" t) + (const :tag "on, optimized" optimized))) + +(defcustom org-self-insert-cluster-for-undo t + "Non-nil means cluster self-insert commands for undo when possible. +If this is set, then, like in the Emacs command loop, 20 consecutive +characters will be undone together. +This is configurable, because there is some impact on typing performance." + :group 'org-table + :type 'boolean) + +(defcustom org-table-tab-recognizes-table.el t + "Non-nil means TAB will automatically notice a table.el table. +When it sees such a table, it moves point into it and - if necessary - +calls `table-recognize-table'." + :group 'org-table-editing + :type 'boolean) + +(defgroup org-link nil + "Options concerning links in Org-mode." + :tag "Org Link" + :group 'org) + +(defvar org-link-abbrev-alist-local nil + "Buffer-local version of `org-link-abbrev-alist', which see. +The value of this is taken from the #+LINK lines.") +(make-variable-buffer-local 'org-link-abbrev-alist-local) + +(defcustom org-link-abbrev-alist nil + "Alist of link abbreviations. +The car of each element is a string, to be replaced at the start of a link. +The cdrs are replacement values, like (\"linkkey\" . REPLACE). Abbreviated +links in Org-mode buffers can have an optional tag after a double colon, e.g. + + [[linkkey:tag][description]] + +The 'linkkey' must be a word word, starting with a letter, followed +by letters, numbers, '-' or '_'. + +If REPLACE is a string, the tag will simply be appended to create the link. +If the string contains \"%s\", the tag will be inserted there. Alternatively, +the placeholder \"%h\" will cause a url-encoded version of the tag to +be inserted at that point (see the function `url-hexify-string'). + +REPLACE may also be a function that will be called with the tag as the +only argument to create the link, which should be returned as a string. + +See the manual for examples." + :group 'org-link + :type '(repeat + (cons + (string :tag "Protocol") + (choice + (string :tag "Format") + (function))))) + +(defcustom org-descriptive-links t + "Non-nil means hide link part and only show description of bracket links. +Bracket links are like [[link][description]]. This variable sets the initial +state in new org-mode buffers. The setting can then be toggled on a +per-buffer basis from the Org->Hyperlinks menu." + :group 'org-link + :type 'boolean) + +(defcustom org-link-file-path-type 'adaptive + "How the path name in file links should be stored. +Valid values are: + +relative Relative to the current directory, i.e. the directory of the file + into which the link is being inserted. +absolute Absolute path, if possible with ~ for home directory. +noabbrev Absolute path, no abbreviation of home directory. +adaptive Use relative path for files in the current directory and sub- + directories of it. For other files, use an absolute path." + :group 'org-link + :type '(choice + (const relative) + (const absolute) + (const noabbrev) + (const adaptive))) + +(defcustom org-activate-links '(bracket angle plain radio tag date footnote) + "Types of links that should be activated in Org-mode files. +This is a list of symbols, each leading to the activation of a certain link +type. In principle, it does not hurt to turn on most link types - there may +be a small gain when turning off unused link types. The types are: + +bracket The recommended [[link][description]] or [[link]] links with hiding. +angle Links in angular brackets that may contain whitespace like + <bbdb:Carsten Dominik>. +plain Plain links in normal text, no whitespace, like http://google.com. +radio Text that is matched by a radio target, see manual for details. +tag Tag settings in a headline (link to tag search). +date Time stamps (link to calendar). +footnote Footnote labels. + +Changing this variable requires a restart of Emacs to become effective." + :group 'org-link + :type '(set :greedy t + (const :tag "Double bracket links" bracket) + (const :tag "Angular bracket links" angle) + (const :tag "Plain text links" plain) + (const :tag "Radio target matches" radio) + (const :tag "Tags" tag) + (const :tag "Timestamps" date) + (const :tag "Footnotes" footnote))) + +(defcustom org-make-link-description-function nil + "Function to use to generate link descriptions from links. +If nil the link location will be used. This function must take +two parameters; the first is the link and the second the +description `org-insert-link' has generated, and should return the +description to use." + :group 'org-link + :type 'function) + +(defgroup org-link-store nil + "Options concerning storing links in Org-mode." + :tag "Org Store Link" + :group 'org-link) + +(defcustom org-email-link-description-format "Email %c: %.30s" + "Format of the description part of a link to an email or usenet message. +The following %-escapes will be replaced by corresponding information: + +%F full \"From\" field +%f name, taken from \"From\" field, address if no name +%T full \"To\" field +%t first name in \"To\" field, address if no name +%c correspondent. Usually \"from NAME\", but if you sent it yourself, it + will be \"to NAME\". See also the variable `org-from-is-user-regexp'. +%s subject +%m message-id. + +You may use normal field width specification between the % and the letter. +This is for example useful to limit the length of the subject. + +Examples: \"%f on: %.30s\", \"Email from %f\", \"Email %c\"" + :group 'org-link-store + :type 'string) + +(defcustom org-from-is-user-regexp + (let (r1 r2) + (when (and user-mail-address (not (string= user-mail-address ""))) + (setq r1 (concat "\\<" (regexp-quote user-mail-address) "\\>"))) + (when (and user-full-name (not (string= user-full-name ""))) + (setq r2 (concat "\\<" (regexp-quote user-full-name) "\\>"))) + (if (and r1 r2) (concat r1 "\\|" r2) (or r1 r2))) + "Regexp matched against the \"From:\" header of an email or usenet message. +It should match if the message is from the user him/herself." + :group 'org-link-store + :type 'regexp) + +(defcustom org-link-to-org-use-id 'create-if-interactive-and-no-custom-id + "Non-nil means storing a link to an Org file will use entry IDs. + +Note that before this variable is even considered, org-id must be loaded, +so please customize `org-modules' and turn it on. + +The variable can have the following values: + +t Create an ID if needed to make a link to the current entry. + +create-if-interactive + If `org-store-link' is called directly (interactively, as a user + command), do create an ID to support the link. But when doing the + job for remember, only use the ID if it already exists. The + purpose of this setting is to avoid proliferation of unwanted + IDs, just because you happen to be in an Org file when you + call `org-remember' that automatically and preemptively + creates a link. If you do want to get an ID link in a remember + template to an entry not having an ID, create it first by + explicitly creating a link to it, using `C-c C-l' first. + +create-if-interactive-and-no-custom-id + Like create-if-interactive, but do not create an ID if there is + a CUSTOM_ID property defined in the entry. This is the default. + +use-existing + Use existing ID, do not create one. + +nil Never use an ID to make a link, instead link using a text search for + the headline text." + :group 'org-link-store + :type '(choice + (const :tag "Create ID to make link" t) + (const :tag "Create if storing link interactively" + create-if-interactive) + (const :tag "Create if storing link interactively and no CUSTOM_ID is present" + create-if-interactive-and-no-custom-id) + (const :tag "Only use existing" use-existing) + (const :tag "Do not use ID to create link" nil))) + +(defcustom org-context-in-file-links t + "Non-nil means file links from `org-store-link' contain context. +A search string will be added to the file name with :: as separator and +used to find the context when the link is activated by the command +`org-open-at-point'. When this option is t, the entire active region +will be placed in the search string of the file link. If set to a +positive integer, only the first n lines of context will be stored. + +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-store + :type '(choice boolean integer)) + +(defcustom org-keep-stored-link-after-insertion nil + "Non-nil means keep link in list for entire session. + +The command `org-store-link' adds a link pointing to the current +location to an internal list. These links accumulate during a session. +The command `org-insert-link' can be used to insert links into any +Org-mode file (offering completion for all stored links). When this +option is nil, every link which has been inserted once using \\[org-insert-link] +will be removed from the list, to make completing the unused links +more efficient." + :group 'org-link-store + :type 'boolean) + +(defgroup org-link-follow nil + "Options concerning following links in Org-mode." + :tag "Org Follow Link" + :group 'org-link) + +(defcustom org-link-translation-function nil + "Function to translate links with different syntax to Org syntax. +This can be used to translate links created for example by the Planner +or emacs-wiki packages to Org syntax. +The function must accept two parameters, a TYPE containing the link +protocol name like \"rmail\" or \"gnus\" as a string, and the linked path, +which is everything after the link protocol. It should return a cons +with possibly modified values of type and path. +Org contains a function for this, so if you set this variable to +`org-translate-link-from-planner', you should be able follow many +links created by planner." + :group 'org-link-follow + :type 'function) + +(defcustom org-follow-link-hook nil + "Hook that is run after a link has been followed." + :group 'org-link-follow + :type 'hook) + +(defcustom org-tab-follows-link nil + "Non-nil means on links TAB will follow the link. +Needs to be set before org.el is loaded. +This really should not be used, it does not make sense, and the +implementation is bad." + :group 'org-link-follow + :type 'boolean) + +(defcustom org-return-follows-link nil + "Non-nil means on links RET will follow the link." + :group 'org-link-follow + :type 'boolean) + +(defcustom org-mouse-1-follows-link + (if (boundp 'mouse-1-click-follows-link) mouse-1-click-follows-link t) + "Non-nil means mouse-1 on a link will follow the link. +A longer mouse click will still set point. Does not work on XEmacs. +Needs to be set before org.el is loaded." + :group 'org-link-follow + :type 'boolean) + +(defcustom org-mark-ring-length 4 + "Number of different positions to be recorded in the ring. +Changing this requires a restart of Emacs to work correctly." + :group 'org-link-follow + :type 'integer) + +(defcustom org-link-search-must-match-exact-headline 'query-to-create + "Non-nil means internal links in Org files must exactly match a headline. +When nil, the link search tries to match a phrase will all words +in the search text." + :group 'org-link-follow + :type '(choice + (const :tag "Use fuzy text search" nil) + (const :tag "Match only exact headline" t) + (const :tag "Match extact headline or query to create it" + query-to-create))) + +(defcustom org-link-frame-setup + '((vm . vm-visit-folder-other-frame) + (gnus . org-gnus-no-new-news) + (file . find-file-other-window) + (wl . wl-other-frame)) + "Setup the frame configuration for following links. +When following a link with Emacs, it may often be useful to display +this link in another window or frame. This variable can be used to +set this up for the different types of links. +For VM, use any of + `vm-visit-folder' + `vm-visit-folder-other-frame' +For Gnus, use any of + `gnus' + `gnus-other-frame' + `org-gnus-no-new-news' +For FILE, use any of + `find-file' + `find-file-other-window' + `find-file-other-frame' +For Wanderlust use any of + `wl' + `wl-other-frame' +For the calendar, use the variable `calendar-setup'. +For BBDB, it is currently only possible to display the matches in +another window." + :group 'org-link-follow + :type '(list + (cons (const vm) + (choice + (const vm-visit-folder) + (const vm-visit-folder-other-window) + (const vm-visit-folder-other-frame))) + (cons (const gnus) + (choice + (const gnus) + (const gnus-other-frame) + (const org-gnus-no-new-news))) + (cons (const file) + (choice + (const find-file) + (const find-file-other-window) + (const find-file-other-frame))) + (cons (const wl) + (choice + (const wl) + (const wl-other-frame))))) + +(defcustom org-display-internal-link-with-indirect-buffer nil + "Non-nil means use indirect buffer to display infile links. +Activating internal links (from one location in a file to another location +in the same file) normally just jumps to the location. When the link is +activated with a \\[universal-argument] prefix (or with mouse-3), the link \ +is displayed in +another window. When this option is set, the other window actually displays +an indirect buffer clone of the current buffer, to avoid any visibility +changes to the current buffer." + :group 'org-link-follow + :type 'boolean) + +(defcustom org-open-non-existing-files nil + "Non-nil means `org-open-file' will open non-existing files. +When nil, an error will be generated. +This variable applies only to external applications because they +might choke on non-existing files. If the link is to a file that +will be opened in Emacs, the variable is ignored." + :group 'org-link-follow + :type 'boolean) + +(defcustom org-open-directory-means-index-dot-org nil + "Non-nil means a link to a directory really means to index.org. +When nil, following a directory link will run dired or open a finder/explorer +window on that directory." + :group 'org-link-follow + :type 'boolean) + +(defcustom org-link-mailto-program '(browse-url "mailto:%a?subject=%s") + "Function and arguments to call for following mailto links. +This is a list with the first element being a Lisp function, and the +remaining elements being arguments to the function. In string arguments, +%a will be replaced by the address, and %s will be replaced by the subject +if one was given like in <mailto:arthur@galaxy.org::this subject>." + :group 'org-link-follow + :type '(choice + (const :tag "browse-url" (browse-url-mail "mailto:%a?subject=%s")) + (const :tag "compose-mail" (compose-mail "%a" "%s")) + (const :tag "message-mail" (message-mail "%a" "%s")) + (cons :tag "other" (function) (repeat :tag "argument" sexp)))) + +(defcustom org-confirm-shell-link-function 'yes-or-no-p + "Non-nil means ask for confirmation before executing shell links. +Shell links can be dangerous: just think about a link + + [[shell:rm -rf ~/*][Google Search]] + +This link would show up in your Org-mode document as \"Google Search\", +but really it would remove your entire home directory. +Therefore we advise against setting this variable to nil. +Just change it to `y-or-n-p' if you want to confirm with a +single keystroke rather than having to type \"yes\"." + :group 'org-link-follow + :type '(choice + (const :tag "with yes-or-no (safer)" yes-or-no-p) + (const :tag "with y-or-n (faster)" y-or-n-p) + (const :tag "no confirmation (dangerous)" nil))) +(put 'org-confirm-shell-link-function + 'safe-local-variable + '(lambda (x) (member x '(yes-or-no-p y-or-n-p)))) + +(defcustom org-confirm-elisp-link-function 'yes-or-no-p + "Non-nil means ask for confirmation before executing Emacs Lisp links. +Elisp links can be dangerous: just think about a link + + [[elisp:(shell-command \"rm -rf ~/*\")][Google Search]] + +This link would show up in your Org-mode document as \"Google Search\", +but really it would remove your entire home directory. +Therefore we advise against setting this variable to nil. +Just change it to `y-or-n-p' if you want to confirm with a +single keystroke rather than having to type \"yes\"." + :group 'org-link-follow + :type '(choice + (const :tag "with yes-or-no (safer)" yes-or-no-p) + (const :tag "with y-or-n (faster)" y-or-n-p) + (const :tag "no confirmation (dangerous)" nil))) +(put 'org-confirm-shell-link-function + 'safe-local-variable + '(lambda (x) (member x '(yes-or-no-p y-or-n-p)))) + +(defconst org-file-apps-defaults-gnu + '((remote . emacs) + (system . mailcap) + (t . mailcap)) + "Default file applications on a UNIX or GNU/Linux system. +See `org-file-apps'.") + +(defconst org-file-apps-defaults-macosx + '((remote . emacs) + (t . "open %s") + (system . "open %s") + ("ps.gz" . "gv %s") + ("eps.gz" . "gv %s") + ("dvi" . "xdvi %s") + ("fig" . "xfig %s")) + "Default file applications on a MacOS X system. +The system \"open\" is known as a default, but we use X11 applications +for some files for which the OS does not have a good default. +See `org-file-apps'.") + +(defconst org-file-apps-defaults-windowsnt + (list + '(remote . emacs) + (cons t + (list (if (featurep 'xemacs) + 'mswindows-shell-execute + 'w32-shell-execute) + "open" 'file)) + (cons 'system + (list (if (featurep 'xemacs) + 'mswindows-shell-execute + 'w32-shell-execute) + "open" 'file))) + "Default file applications on a Windows NT system. +The system \"open\" is used for most files. +See `org-file-apps'.") + +(defcustom org-file-apps + '( + (auto-mode . emacs) + ("\\.mm\\'" . default) + ("\\.x?html?\\'" . default) + ("\\.pdf\\'" . default) + ) + "External applications for opening `file:path' items in a document. +Org-mode uses system defaults for different file types, but +you can use this variable to set the application for a given file +extension. The entries in this list are cons cells where the car identifies +files and the cdr the corresponding command. Possible values for the +file identifier are + \"string\" A string as a file identifier can be interpreted in different + ways, depending on its contents: + + - Alphanumeric characters only: + Match links with this file extension. + Example: (\"pdf\" . \"evince %s\") + to open PDFs with evince. + + - Regular expression: Match links where the + filename matches the regexp. If you want to + use groups here, use shy groups. + + Example: (\"\\.x?html\\'\" . \"firefox %s\") + (\"\\(?:xhtml\\|html\\)\" . \"firefox %s\") + to open *.html and *.xhtml with firefox. + + - Regular expression which contains (non-shy) groups: + Match links where the whole link, including \"::\", and + anything after that, matches the regexp. + In a custom command string, %1, %2, etc. are replaced with + the parts of the link that were matched by the groups. + For backwards compatibility, if a command string is given + that does not use any of the group matches, this case is + handled identically to the second one (i.e. match against + file name only). + In a custom lisp form, you can access the group matches with + (match-string n link). + + Example: (\"\\.pdf::\\(\\d+\\)\\'\" . \"evince -p %1 %s\") + to open [[file:document.pdf::5]] with evince at page 5. + + `directory' Matches a directory + `remote' Matches a remote file, accessible through tramp or efs. + Remote files most likely should be visited through Emacs + because external applications cannot handle such paths. +`auto-mode' Matches files that are matched by any entry in `auto-mode-alist', + so all files Emacs knows how to handle. Using this with + command `emacs' will open most files in Emacs. Beware that this + will also open html files inside Emacs, unless you add + (\"html\" . default) to the list as well. + t Default for files not matched by any of the other options. + `system' The system command to open files, like `open' on Windows + and Mac OS X, and mailcap under GNU/Linux. This is the command + that will be selected if you call `C-c C-o' with a double + \\[universal-argument] \\[universal-argument] prefix. + +Possible values for the command are: + `emacs' The file will be visited by the current Emacs process. + `default' Use the default application for this file type, which is the + association for t in the list, most likely in the system-specific + part. + This can be used to overrule an unwanted setting in the + system-specific variable. + `system' Use the system command for opening files, like \"open\". + This command is specified by the entry whose car is `system'. + Most likely, the system-specific version of this variable + does define this command, but you can overrule/replace it + here. + string A command to be executed by a shell; %s will be replaced + by the path to the file. + sexp A Lisp form which will be evaluated. The file path will + be available in the Lisp variable `file'. +For more examples, see the system specific constants +`org-file-apps-defaults-macosx' +`org-file-apps-defaults-windowsnt' +`org-file-apps-defaults-gnu'." + :group 'org-link-follow + :type '(repeat + (cons (choice :value "" + (string :tag "Extension") + (const :tag "System command to open files" system) + (const :tag "Default for unrecognized files" t) + (const :tag "Remote file" remote) + (const :tag "Links to a directory" directory) + (const :tag "Any files that have Emacs modes" + auto-mode)) + (choice :value "" + (const :tag "Visit with Emacs" emacs) + (const :tag "Use default" default) + (const :tag "Use the system command" system) + (string :tag "Command") + (sexp :tag "Lisp form"))))) + + + +(defgroup org-refile nil + "Options concerning refiling entries in Org-mode." + :tag "Org Refile" + :group 'org) + +(defcustom org-directory "~/org" + "Directory with org files. +This is just a default location to look for Org files. There is no need +at all to put your files into this directory. It is only used in the +following situations: + +1. When a remember template specifies a target file that is not an + absolute path. The path will then be interpreted relative to + `org-directory' +2. When a remember note is filed away in an interactive way (when exiting the + note buffer with `C-1 C-c C-c'. The user is prompted for an org file, + with `org-directory' as the default path." + :group 'org-refile + :group 'org-remember + :type 'directory) + +(defcustom org-default-notes-file (convert-standard-filename "~/.notes") + "Default target for storing notes. +Used as a fall back file for org-remember.el and org-capture.el, for +templates that do not specify a target file." + :group 'org-refile + :group 'org-remember + :type '(choice + (const :tag "Default from remember-data-file" nil) + file)) + +(defcustom org-goto-interface 'outline + "The default interface to be used for `org-goto'. +Allowed values are: +outline The interface shows an outline of the relevant file + and the correct heading is found by moving through + the outline or by searching with incremental search. +outline-path-completion Headlines in the current buffer are offered via + completion. This is the interface also used by + the refile command." + :group 'org-refile + :type '(choice + (const :tag "Outline" outline) + (const :tag "Outline-path-completion" outline-path-completion))) + +(defcustom org-goto-max-level 5 + "Maximum target level when running `org-goto' with refile interface." + :group 'org-refile + :type 'integer) + +(defcustom org-reverse-note-order nil + "Non-nil means store new notes at the beginning of a file or entry. +When nil, new notes will be filed to the end of a file or entry. +This can also be a list with cons cells of regular expressions that +are matched against file names, and values." + :group 'org-remember + :group 'org-refile + :type '(choice + (const :tag "Reverse always" t) + (const :tag "Reverse never" nil) + (repeat :tag "By file name regexp" + (cons regexp boolean)))) + +(defcustom org-log-refile nil + "Information to record when a task is refiled. + +Possible values are: + +nil Don't add anything +time Add a time stamp to the task +note Prompt for a note and add it with template `org-log-note-headings' + +This option can also be set with on a per-file-basis with + + #+STARTUP: nologrefile + #+STARTUP: logrefile + #+STARTUP: lognoterefile + +You can have local logging settings for a subtree by setting the LOGGING +property to one or more of these keywords. + +When bulk-refiling from the agenda, the value `note' is forbidden and +will temporarily be changed to `time'." + :group 'org-refile + :group 'org-progress + :type '(choice + (const :tag "No logging" nil) + (const :tag "Record timestamp" time) + (const :tag "Record timestamp with note." note))) + +(defcustom org-refile-targets nil + "Targets for refiling entries with \\[org-refile]. +This is list of cons cells. Each cell contains: +- a specification of the files to be considered, either a list of files, + or a symbol whose function or variable value will be used to retrieve + a file name or a list of file names. If you use `org-agenda-files' for + that, all agenda files will be scanned for targets. Nil means consider + headings in the current buffer. +- A specification of how to find candidate refile targets. This may be + any of: + - a cons cell (:tag . \"TAG\") to identify refile targets by a tag. + This tag has to be present in all target headlines, inheritance will + not be considered. + - a cons cell (:todo . \"KEYWORD\") to identify refile targets by + todo keyword. + - a cons cell (:regexp . \"REGEXP\") with a regular expression matching + headlines that are refiling targets. + - a cons cell (:level . N). Any headline of level N is considered a target. + Note that, when `org-odd-levels-only' is set, level corresponds to + order in hierarchy, not to the number of stars. + - a cons cell (:maxlevel . N). Any headline with level <= N is a target. + Note that, when `org-odd-levels-only' is set, level corresponds to + order in hierarchy, not to the number of stars. + +You can set the variable `org-refile-target-verify-function' to a function +to verify each headline found by the simple criteria above. + +When this variable is nil, all top-level headlines in the current buffer +are used, equivalent to the value `((nil . (:level . 1))'." + :group 'org-refile + :type '(repeat + (cons + (choice :value org-agenda-files + (const :tag "All agenda files" org-agenda-files) + (const :tag "Current buffer" nil) + (function) (variable) (file)) + (choice :tag "Identify target headline by" + (cons :tag "Specific tag" (const :value :tag) (string)) + (cons :tag "TODO keyword" (const :value :todo) (string)) + (cons :tag "Regular expression" (const :value :regexp) (regexp)) + (cons :tag "Level number" (const :value :level) (integer)) + (cons :tag "Max Level number" (const :value :maxlevel) (integer)))))) + +(defcustom org-refile-target-verify-function nil + "Function to verify if the headline at point should be a refile target. +The function will be called without arguments, with point at the +beginning of the headline. It should return t and leave point +where it is if the headline is a valid target for refiling. + +If the target should not be selected, the function must return nil. +In addition to this, it may move point to a place from where the search +should be continued. For example, the function may decide that the entire +subtree of the current entry should be excluded and move point to the end +of the subtree." + :group 'org-refile + :type 'function) + +(defcustom org-refile-use-cache nil + "Non-nil means cache refile targets to speed up the process. +The cache for a particular file will be updated automatically when +the buffer has been killed, or when any of the marker used for flagging +refile targets no longer points at a live buffer. +If you have added new entries to a buffer that might themselves be targets, +you need to clear the cache manually by pressing `C-0 C-c C-w' or, if you +find that easier, `C-u C-u C-u C-c C-w'." + :group 'org-refile + :type 'boolean) + +(defcustom org-refile-use-outline-path nil + "Non-nil means provide refile targets as paths. +So a level 3 headline will be available as level1/level2/level3. + +When the value is `file', also include the file name (without directory) +into the path. In this case, you can also stop the completion after +the file name, to get entries inserted as top level in the file. + + When `full-file-path', include the full file path." + :group 'org-refile + :type '(choice + (const :tag "Not" nil) + (const :tag "Yes" t) + (const :tag "Start with file name" file) + (const :tag "Start with full file path" full-file-path))) + +(defcustom org-outline-path-complete-in-steps t + "Non-nil means complete the outline path in hierarchical steps. +When Org-mode uses the refile interface to select an outline path +\(see variable `org-refile-use-outline-path'), the completion of +the path can be done is a single go, or if can be done in steps down +the headline hierarchy. Going in steps is probably the best if you +do not use a special completion package like `ido' or `icicles'. +However, when using these packages, going in one step can be very +fast, while still showing the whole path to the entry." + :group 'org-refile + :type 'boolean) + +(defcustom org-refile-allow-creating-parent-nodes nil + "Non-nil means allow to create new nodes as refile targets. +New nodes are then created by adding \"/new node name\" to the completion +of an existing node. When the value of this variable is `confirm', +new node creation must be confirmed by the user (recommended) +When nil, the completion must match an existing entry. + +Note that, if the new heading is not seen by the criteria +listed in `org-refile-targets', multiple instances of the same +heading would be created by trying again to file under the new +heading." + :group 'org-refile + :type '(choice + (const :tag "Never" nil) + (const :tag "Always" t) + (const :tag "Prompt for confirmation" confirm))) + +(defgroup org-todo nil + "Options concerning TODO items in Org-mode." + :tag "Org TODO" + :group 'org) + +(defgroup org-progress nil + "Options concerning Progress logging in Org-mode." + :tag "Org Progress" + :group 'org-time) + +(defvar org-todo-interpretation-widgets + '( + (:tag "Sequence (cycling hits every state)" sequence) + (:tag "Type (cycling directly to DONE)" type)) + "The available interpretation symbols for customizing `org-todo-keywords'. +Interested libraries should add to this list.") + +(defcustom org-todo-keywords '((sequence "TODO" "DONE")) + "List of TODO entry keyword sequences and their interpretation. +\\<org-mode-map>This is a list of sequences. + +Each sequence starts with a symbol, either `sequence' or `type', +indicating if the keywords should be interpreted as a sequence of +action steps, or as different types of TODO items. The first +keywords are states requiring action - these states will select a headline +for inclusion into the global TODO list Org-mode produces. If one of +the \"keywords\" is the vertical bar, \"|\", the remaining keywords +signify that no further action is necessary. If \"|\" is not found, +the last keyword is treated as the only DONE state of the sequence. + +The command \\[org-todo] cycles an entry through these states, and one +additional state where no keyword is present. For details about this +cycling, see the manual. + +TODO keywords and interpretation can also be set on a per-file basis with +the special #+SEQ_TODO and #+TYP_TODO lines. + +Each keyword can optionally specify a character for fast state selection +\(in combination with the variable `org-use-fast-todo-selection') +and specifiers for state change logging, using the same syntax +that is used in the \"#+TODO:\" lines. For example, \"WAIT(w)\" says +that the WAIT state can be selected with the \"w\" key. \"WAIT(w!)\" +indicates to record a time stamp each time this state is selected. + +Each keyword may also specify if a timestamp or a note should be +recorded when entering or leaving the state, by adding additional +characters in the parenthesis after the keyword. This looks like this: +\"WAIT(w@/!)\". \"@\" means to add a note (with time), \"!\" means to +record only the time of the state change. With X and Y being either +\"@\" or \"!\", \"X/Y\" means use X when entering the state, and use +Y when leaving the state if and only if the *target* state does not +define X. You may omit any of the fast-selection key or X or /Y, +so WAIT(w@), WAIT(w/@) and WAIT(@/@) are all valid. + +For backward compatibility, this variable may also be just a list +of keywords - in this case the interpretation (sequence or type) will be +taken from the (otherwise obsolete) variable `org-todo-interpretation'." + :group 'org-todo + :group 'org-keywords + :type '(choice + (repeat :tag "Old syntax, just keywords" + (string :tag "Keyword")) + (repeat :tag "New syntax" + (cons + (choice + :tag "Interpretation" + ;;Quick and dirty way to see + ;;`org-todo-interpretations'. This takes the + ;;place of item arguments + :convert-widget + (lambda (widget) + (widget-put widget + :args (mapcar + #'(lambda (x) + (widget-convert + (cons 'const x))) + org-todo-interpretation-widgets)) + widget)) + (repeat + (string :tag "Keyword")))))) + +(defvar org-todo-keywords-1 nil + "All TODO and DONE keywords active in a buffer.") +(make-variable-buffer-local 'org-todo-keywords-1) +(defvar org-todo-keywords-for-agenda nil) +(defvar org-done-keywords-for-agenda nil) +(defvar org-drawers-for-agenda nil) +(defvar org-todo-keyword-alist-for-agenda nil) +(defvar org-tag-alist-for-agenda nil) +(defvar org-agenda-contributing-files nil) +(defvar org-not-done-keywords nil) +(make-variable-buffer-local 'org-not-done-keywords) +(defvar org-done-keywords nil) +(make-variable-buffer-local 'org-done-keywords) +(defvar org-todo-heads nil) +(make-variable-buffer-local 'org-todo-heads) +(defvar org-todo-sets nil) +(make-variable-buffer-local 'org-todo-sets) +(defvar org-todo-log-states nil) +(make-variable-buffer-local 'org-todo-log-states) +(defvar org-todo-kwd-alist nil) +(make-variable-buffer-local 'org-todo-kwd-alist) +(defvar org-todo-key-alist nil) +(make-variable-buffer-local 'org-todo-key-alist) +(defvar org-todo-key-trigger nil) +(make-variable-buffer-local 'org-todo-key-trigger) + +(defcustom org-todo-interpretation 'sequence + "Controls how TODO keywords are interpreted. +This variable is in principle obsolete and is only used for +backward compatibility, if the interpretation of todo keywords is +not given already in `org-todo-keywords'. See that variable for +more information." + :group 'org-todo + :group 'org-keywords + :type '(choice (const sequence) + (const type))) + +(defcustom org-use-fast-todo-selection t + "Non-nil means use the fast todo selection scheme with C-c C-t. +This variable describes if and under what circumstances the cycling +mechanism for TODO keywords will be replaced by a single-key, direct +selection scheme. + +When nil, fast selection is never used. + +When the symbol `prefix', it will be used when `org-todo' is called with +a prefix argument, i.e. `C-u C-c C-t' in an Org-mode buffer, and `C-u t' +in an agenda buffer. + +When t, fast selection is used by default. In this case, the prefix +argument forces cycling instead. + +In all cases, the special interface is only used if access keys have actually +been assigned by the user, i.e. if keywords in the configuration are followed +by a letter in parenthesis, like TODO(t)." + :group 'org-todo + :type '(choice + (const :tag "Never" nil) + (const :tag "By default" t) + (const :tag "Only with C-u C-c C-t" prefix))) + +(defcustom org-provide-todo-statistics t + "Non-nil means update todo statistics after insert and toggle. +ALL-HEADLINES means update todo statistics by including headlines +with no TODO keyword as well, counting them as not done. +A list of TODO keywords means the same, but skip keywords that are +not in this list. + +When this is set, todo statistics is updated in the parent of the +current entry each time a todo state is changed." + :group 'org-todo + :type '(choice + (const :tag "Yes, only for TODO entries" t) + (const :tag "Yes, including all entries" 'all-headlines) + (repeat :tag "Yes, for TODOs in this list" + (string :tag "TODO keyword")) + (other :tag "No TODO statistics" nil))) + +(defcustom org-hierarchical-todo-statistics t + "Non-nil means TODO statistics covers just direct children. +When nil, all entries in the subtree are considered. +This has only an effect if `org-provide-todo-statistics' is set. +To set this to nil for only a single subtree, use a COOKIE_DATA +property and include the word \"recursive\" into the value." + :group 'org-todo + :type 'boolean) + +(defcustom org-after-todo-state-change-hook nil + "Hook which is run after the state of a TODO item was changed. +The new state (a string with a TODO keyword, or nil) is available in the +Lisp variable `state'." + :group 'org-todo + :type 'hook) + +(defvar org-blocker-hook nil + "Hook for functions that are allowed to block a state change. + +Each function gets as its single argument a property list, see +`org-trigger-hook' for more information about this list. + +If any of the functions in this hook returns nil, the state change +is blocked.") + +(defvar org-trigger-hook nil + "Hook for functions that are triggered by a state change. + +Each function gets as its single argument a property list with at least +the following elements: + + (:type type-of-change :position pos-at-entry-start + :from old-state :to new-state) + +Depending on the type, more properties may be present. + +This mechanism is currently implemented for: + +TODO state changes +------------------ +:type todo-state-change +:from previous state (keyword as a string), or nil, or a symbol + 'todo' or 'done', to indicate the general type of state. +:to new state, like in :from") + +(defcustom org-enforce-todo-dependencies nil + "Non-nil means undone TODO entries will block switching the parent to DONE. +Also, if a parent has an :ORDERED: property, switching an entry to DONE will +be blocked if any prior sibling is not yet done. +Finally, if the parent is blocked because of ordered siblings of its own, +the child will also be blocked. +This variable needs to be set before org.el is loaded, and you need to +restart Emacs after a change to make the change effective. The only way +to change is while Emacs is running is through the customize interface." + :set (lambda (var val) + (set var val) + (if val + (add-hook 'org-blocker-hook + 'org-block-todo-from-children-or-siblings-or-parent) + (remove-hook 'org-blocker-hook + 'org-block-todo-from-children-or-siblings-or-parent))) + :group 'org-todo + :type 'boolean) + +(defcustom org-enforce-todo-checkbox-dependencies nil + "Non-nil means unchecked boxes will block switching the parent to DONE. +When this is nil, checkboxes have no influence on switching TODO states. +When non-nil, you first need to check off all check boxes before the TODO +entry can be switched to DONE. +This variable needs to be set before org.el is loaded, and you need to +restart Emacs after a change to make the change effective. The only way +to change is while Emacs is running is through the customize interface." + :set (lambda (var val) + (set var val) + (if val + (add-hook 'org-blocker-hook + 'org-block-todo-from-checkboxes) + (remove-hook 'org-blocker-hook + 'org-block-todo-from-checkboxes))) + :group 'org-todo + :type 'boolean) + +(defcustom org-treat-insert-todo-heading-as-state-change nil + "Non-nil means inserting a TODO heading is treated as state change. +So when the command \\[org-insert-todo-heading] is used, state change +logging will apply if appropriate. When nil, the new TODO item will +be inserted directly, and no logging will take place." + :group 'org-todo + :type 'boolean) + +(defcustom org-treat-S-cursor-todo-selection-as-state-change t + "Non-nil means switching TODO states with S-cursor counts as state change. +This is the default behavior. However, setting this to nil allows a +convenient way to select a TODO state and bypass any logging associated +with that." + :group 'org-todo + :type 'boolean) + +(defcustom org-todo-state-tags-triggers nil + "Tag changes that should be triggered by TODO state changes. +This is a list. Each entry is + + (state-change (tag . flag) .......) + +State-change can be a string with a state, and empty string to indicate the +state that has no TODO keyword, or it can be one of the symbols `todo' +or `done', meaning any not-done or done state, respectively." + :group 'org-todo + :group 'org-tags + :type '(repeat + (cons (choice :tag "When changing to" + (const :tag "Not-done state" todo) + (const :tag "Done state" done) + (string :tag "State")) + (repeat + (cons :tag "Tag action" + (string :tag "Tag") + (choice (const :tag "Add" t) (const :tag "Remove" nil))))))) + +(defcustom org-log-done nil + "Information to record when a task moves to the DONE state. + +Possible values are: + +nil Don't add anything, just change the keyword +time Add a time stamp to the task +note Prompt for a note and add it with template `org-log-note-headings' + +This option can also be set with on a per-file-basis with + + #+STARTUP: nologdone + #+STARTUP: logdone + #+STARTUP: lognotedone + +You can have local logging settings for a subtree by setting the LOGGING +property to one or more of these keywords." + :group 'org-todo + :group 'org-progress + :type '(choice + (const :tag "No logging" nil) + (const :tag "Record CLOSED timestamp" time) + (const :tag "Record CLOSED timestamp with note." note))) + +;; Normalize old uses of org-log-done. +(cond + ((eq org-log-done t) (setq org-log-done 'time)) + ((and (listp org-log-done) (memq 'done org-log-done)) + (setq org-log-done 'note))) + +(defcustom org-log-reschedule nil + "Information to record when the scheduling date of a tasks is modified. + +Possible values are: + +nil Don't add anything, just change the date +time Add a time stamp to the task +note Prompt for a note and add it with template `org-log-note-headings' + +This option can also be set with on a per-file-basis with + + #+STARTUP: nologreschedule + #+STARTUP: logreschedule + #+STARTUP: lognotereschedule" + :group 'org-todo + :group 'org-progress + :type '(choice + (const :tag "No logging" nil) + (const :tag "Record timestamp" time) + (const :tag "Record timestamp with note." note))) + +(defcustom org-log-redeadline nil + "Information to record when the deadline date of a tasks is modified. + +Possible values are: + +nil Don't add anything, just change the date +time Add a time stamp to the task +note Prompt for a note and add it with template `org-log-note-headings' + +This option can also be set with on a per-file-basis with + + #+STARTUP: nologredeadline + #+STARTUP: logredeadline + #+STARTUP: lognoteredeadline + +You can have local logging settings for a subtree by setting the LOGGING +property to one or more of these keywords." + :group 'org-todo + :group 'org-progress + :type '(choice + (const :tag "No logging" nil) + (const :tag "Record timestamp" time) + (const :tag "Record timestamp with note." note))) + +(defcustom org-log-note-clock-out nil + "Non-nil means record a note when clocking out of an item. +This can also be configured on a per-file basis by adding one of +the following lines anywhere in the buffer: + + #+STARTUP: lognoteclock-out + #+STARTUP: nolognoteclock-out" + :group 'org-todo + :group 'org-progress + :type 'boolean) + +(defcustom org-log-done-with-time t + "Non-nil means the CLOSED time stamp will contain date and time. +When nil, only the date will be recorded." + :group 'org-progress + :type 'boolean) + +(defcustom org-log-note-headings + '((done . "CLOSING NOTE %t") + (state . "State %-12s from %-12S %t") + (note . "Note taken on %t") + (reschedule . "Rescheduled from %S on %t") + (delschedule . "Not scheduled, was %S on %t") + (redeadline . "New deadline from %S on %t") + (deldeadline . "Removed deadline, was %S on %t") + (refile . "Refiled on %t") + (clock-out . "")) + "Headings for notes added to entries. +The value is an alist, with the car being a symbol indicating the note +context, and the cdr is the heading to be used. The heading may also be the +empty string. +%t in the heading will be replaced by a time stamp. +%T will be an active time stamp instead the default inactive one +%s will be replaced by the new TODO state, in double quotes. +%S will be replaced by the old TODO state, in double quotes. +%u will be replaced by the user name. +%U will be replaced by the full user name. + +In fact, it is not a good idea to change the `state' entry, because +agenda log mode depends on the format of these entries." + :group 'org-todo + :group 'org-progress + :type '(list :greedy t + (cons (const :tag "Heading when closing an item" done) string) + (cons (const :tag + "Heading when changing todo state (todo sequence only)" + state) string) + (cons (const :tag "Heading when just taking a note" note) string) + (cons (const :tag "Heading when clocking out" clock-out) string) + (cons (const :tag "Heading when an item is no longer scheduled" delschedule) string) + (cons (const :tag "Heading when rescheduling" reschedule) string) + (cons (const :tag "Heading when changing deadline" redeadline) string) + (cons (const :tag "Heading when deleting a deadline" deldeadline) string) + (cons (const :tag "Heading when refiling" refile) string))) + +(unless (assq 'note org-log-note-headings) + (push '(note . "%t") org-log-note-headings)) + +(defcustom org-log-into-drawer nil + "Non-nil means insert state change notes and time stamps into a drawer. +When nil, state changes notes will be inserted after the headline and +any scheduling and clock lines, but not inside a drawer. + +The value of this variable should be the name of the drawer to use. +LOGBOOK is proposed at the default drawer for this purpose, you can +also set this to a string to define the drawer of your choice. + +A value of t is also allowed, representing \"LOGBOOK\". + +If this variable is set, `org-log-state-notes-insert-after-drawers' +will be ignored. + +You can set the property LOG_INTO_DRAWER to overrule this setting for +a subtree." + :group 'org-todo + :group 'org-progress + :type '(choice + (const :tag "Not into a drawer" nil) + (const :tag "LOGBOOK" t) + (string :tag "Other"))) + +(if (fboundp 'defvaralias) + (defvaralias 'org-log-state-notes-into-drawer 'org-log-into-drawer)) + +(defun org-log-into-drawer () + "Return the value of `org-log-into-drawer', but let properties overrule. +If the current entry has or inherits a LOG_INTO_DRAWER property, it will be +used instead of the default value." + (let ((p (ignore-errors (org-entry-get nil "LOG_INTO_DRAWER" 'inherit)))) + (cond + ((or (not p) (equal p "nil")) org-log-into-drawer) + ((equal p "t") "LOGBOOK") + (t p)))) + +(defcustom org-log-state-notes-insert-after-drawers nil + "Non-nil means insert state change notes after any drawers in entry. +Only the drawers that *immediately* follow the headline and the +deadline/scheduled line are skipped. +When nil, insert notes right after the heading and perhaps the line +with deadline/scheduling if present. + +This variable will have no effect if `org-log-into-drawer' is +set." + :group 'org-todo + :group 'org-progress + :type 'boolean) + +(defcustom org-log-states-order-reversed t + "Non-nil means the latest state note will be directly after heading. +When nil, the state change notes will be ordered according to time." + :group 'org-todo + :group 'org-progress + :type 'boolean) + +(defcustom org-todo-repeat-to-state nil + "The TODO state to which a repeater should return the repeating task. +By default this is the first task in a TODO sequence, or the previous state +in a TODO_TYP set. But you can specify another task here. +alternatively, set the :REPEAT_TO_STATE: property of the entry." + :group 'org-todo + :type '(choice (const :tag "Head of sequence" nil) + (string :tag "Specific state"))) + +(defcustom org-log-repeat 'time + "Non-nil means record moving through the DONE state when triggering repeat. +An auto-repeating task is immediately switched back to TODO when +marked DONE. If you are not logging state changes (by adding \"@\" +or \"!\" to the TODO keyword definition), or set `org-log-done' to +record a closing note, there will be no record of the task moving +through DONE. This variable forces taking a note anyway. + +nil Don't force a record +time Record a time stamp +note Record a note + +This option can also be set with on a per-file-basis with + + #+STARTUP: logrepeat + #+STARTUP: lognoterepeat + #+STARTUP: nologrepeat + +You can have local logging settings for a subtree by setting the LOGGING +property to one or more of these keywords." + :group 'org-todo + :group 'org-progress + :type '(choice + (const :tag "Don't force a record" nil) + (const :tag "Force recording the DONE state" time) + (const :tag "Force recording a note with the DONE state" note))) + + +(defgroup org-priorities nil + "Priorities in Org-mode." + :tag "Org Priorities" + :group 'org-todo) + +(defcustom org-enable-priority-commands t + "Non-nil means priority commands are active. +When nil, these commands will be disabled, so that you never accidentally +set a priority." + :group 'org-priorities + :type 'boolean) + +(defcustom org-highest-priority ?A + "The highest priority of TODO items. A character like ?A, ?B etc. +Must have a smaller ASCII number than `org-lowest-priority'." + :group 'org-priorities + :type 'character) + +(defcustom org-lowest-priority ?C + "The lowest priority of TODO items. A character like ?A, ?B etc. +Must have a larger ASCII number than `org-highest-priority'." + :group 'org-priorities + :type 'character) + +(defcustom org-default-priority ?B + "The default priority of TODO items. +This is the priority an item get if no explicit priority is given." + :group 'org-priorities + :type 'character) + +(defcustom org-priority-start-cycle-with-default t + "Non-nil means start with default priority when starting to cycle. +When this is nil, the first step in the cycle will be (depending on the +command used) one higher or lower that the default priority." + :group 'org-priorities + :type 'boolean) + +(defcustom org-get-priority-function nil + "Function to extract the priority from a string. +The string is normally the headline. If this is nil Org computes the +priority from the priority cookie like [#A] in the headline. It returns +an integer, increasing by 1000 for each priority level. +The user can set a different function here, which should take a string +as an argument and return the numeric priority." + :group 'org-priorities + :type 'function) + +(defgroup org-time nil + "Options concerning time stamps and deadlines in Org-mode." + :tag "Org Time" + :group 'org) + +(defcustom org-insert-labeled-timestamps-at-point nil + "Non-nil means SCHEDULED and DEADLINE timestamps are inserted at point. +When nil, these labeled time stamps are forces into the second line of an +entry, just after the headline. When scheduling from the global TODO list, +the time stamp will always be forced into the second line." + :group 'org-time + :type 'boolean) + +(defconst org-time-stamp-formats '("<%Y-%m-%d %a>" . "<%Y-%m-%d %a %H:%M>") + "Formats for `format-time-string' which are used for time stamps. +It is not recommended to change this constant.") + +(defcustom org-time-stamp-rounding-minutes '(0 5) + "Number of minutes to round time stamps to. +These are two values, the first applies when first creating a time stamp. +The second applies when changing it with the commands `S-up' and `S-down'. +When changing the time stamp, this means that it will change in steps +of N minutes, as given by the second value. + +When a setting is 0 or 1, insert the time unmodified. Useful rounding +numbers should be factors of 60, so for example 5, 10, 15. + +When this is larger than 1, you can still force an exact time stamp by using +a double prefix argument to a time stamp command like `C-c .' or `C-c !', +and by using a prefix arg to `S-up/down' to specify the exact number +of minutes to shift." + :group 'org-time + :get '(lambda (var) ; Make sure both elements are there + (if (integerp (default-value var)) + (list (default-value var) 5) + (default-value var))) + :type '(list + (integer :tag "when inserting times") + (integer :tag "when modifying times"))) + +;; Normalize old customizations of this variable. +(when (integerp org-time-stamp-rounding-minutes) + (setq org-time-stamp-rounding-minutes + (list org-time-stamp-rounding-minutes + org-time-stamp-rounding-minutes))) + +(defcustom org-display-custom-times nil + "Non-nil means overlay custom formats over all time stamps. +The formats are defined through the variable `org-time-stamp-custom-formats'. +To turn this on on a per-file basis, insert anywhere in the file: + #+STARTUP: customtime" + :group 'org-time + :set 'set-default + :type 'sexp) +(make-variable-buffer-local 'org-display-custom-times) + +(defcustom org-time-stamp-custom-formats + '("<%m/%d/%y %a>" . "<%m/%d/%y %a %H:%M>") ; american + "Custom formats for time stamps. See `format-time-string' for the syntax. +These are overlayed over the default ISO format if the variable +`org-display-custom-times' is set. Time like %H:%M should be at the +end of the second format. The custom formats are also honored by export +commands, if custom time display is turned on at the time of export." + :group 'org-time + :type 'sexp) + +(defun org-time-stamp-format (&optional long inactive) + "Get the right format for a time string." + (let ((f (if long (cdr org-time-stamp-formats) + (car org-time-stamp-formats)))) + (if inactive + (concat "[" (substring f 1 -1) "]") + f))) + +(defcustom org-time-clocksum-format "%d:%02d" + "The format string used when creating CLOCKSUM lines. +This is also used when org-mode generates a time duration." + :group 'org-time + :type 'string) + +(defcustom org-time-clocksum-use-fractional nil + "If non-nil, \\[org-clock-display] uses fractional times. +org-mode generates a time duration." + :group 'org-time + :type 'boolean) + +(defcustom org-time-clocksum-fractional-format "%.2f" + "The format string used when creating CLOCKSUM lines, or when +org-mode generates a time duration." + :group 'org-time + :type 'string) + +(defcustom org-deadline-warning-days 14 + "No. of days before expiration during which a deadline becomes active. +This variable governs the display in sparse trees and in the agenda. +When 0 or negative, it means use this number (the absolute value of it) +even if a deadline has a different individual lead time specified. + +Custom commands can set this variable in the options section." + :group 'org-time + :group 'org-agenda-daily/weekly + :type 'integer) + +(defcustom org-read-date-prefer-future t + "Non-nil means assume future for incomplete date input from user. +This affects the following situations: +1. The user gives a month but not a year. + For example, if it is April and you enter \"feb 2\", this will be read + as Feb 2, *next* year. \"May 5\", however, will be this year. +2. The user gives a day, but no month. + For example, if today is the 15th, and you enter \"3\", Org-mode will + read this as the third of *next* month. However, if you enter \"17\", + it will be considered as *this* month. + +If you set this variable to the symbol `time', then also the following +will work: + +3. If the user gives a time, but no day. If the time is before now, + to will be interpreted as tomorrow. + +Currently none of this works for ISO week specifications. + +When this option is nil, the current day, month and year will always be +used as defaults. + +See also `org-agenda-jump-prefer-future'." + :group 'org-time + :type '(choice + (const :tag "Never" nil) + (const :tag "Check month and day" t) + (const :tag "Check month, day, and time" time))) + +(defcustom org-agenda-jump-prefer-future 'org-read-date-prefer-future + "Should the agenda jump command prefer the future for incomplete dates? +The default is to do the same as configured in `org-read-date-prefer-future'. +But you can alse set a deviating value here. +This may t or nil, or the symbol `org-read-date-prefer-future'." + :group 'org-agenda + :group 'org-time + :type '(choice + (const :tag "Use org-read-date-prefer-future" + org-read-date-prefer-future) + (const :tag "Never" nil) + (const :tag "Always" t))) + +(defcustom org-read-date-display-live t + "Non-nil means display current interpretation of date prompt live. +This display will be in an overlay, in the minibuffer." + :group 'org-time + :type 'boolean) + +(defcustom org-read-date-popup-calendar t + "Non-nil means pop up a calendar when prompting for a date. +In the calendar, the date can be selected with mouse-1. However, the +minibuffer will also be active, and you can simply enter the date as well. +When nil, only the minibuffer will be available." + :group 'org-time + :type 'boolean) +(if (fboundp 'defvaralias) + (defvaralias 'org-popup-calendar-for-date-prompt + 'org-read-date-popup-calendar)) + +(defcustom org-read-date-minibuffer-setup-hook nil + "Hook to be used to set up keys for the date/time interface. +Add key definitions to `minibuffer-local-map', which will be a temporary +copy." + :group 'org-time + :type 'hook) + +(defcustom org-extend-today-until 0 + "The hour when your day really ends. Must be an integer. +This has influence for the following applications: +- When switching the agenda to \"today\". It it is still earlier than + the time given here, the day recognized as TODAY is actually yesterday. +- When a date is read from the user and it is still before the time given + here, the current date and time will be assumed to be yesterday, 23:59. + Also, timestamps inserted in remember templates follow this rule. + +IMPORTANT: This is a feature whose implementation is and likely will +remain incomplete. Really, it is only here because past midnight seems to +be the favorite working time of John Wiegley :-)" + :group 'org-time + :type 'integer) + +(defcustom org-edit-timestamp-down-means-later nil + "Non-nil means S-down will increase the time in a time stamp. +When nil, S-up will increase." + :group 'org-time + :type 'boolean) + +(defcustom org-calendar-follow-timestamp-change t + "Non-nil means make the calendar window follow timestamp changes. +When a timestamp is modified and the calendar window is visible, it will be +moved to the new date." + :group 'org-time + :type 'boolean) + +(defgroup org-tags nil + "Options concerning tags in Org-mode." + :tag "Org Tags" + :group 'org) + +(defcustom org-tag-alist nil + "List of tags allowed in Org-mode files. +When this list is nil, Org-mode will base TAG input on what is already in the +buffer. +The value of this variable is an alist, the car of each entry must be a +keyword as a string, the cdr may be a character that is used to select +that tag through the fast-tag-selection interface. +See the manual for details." + :group 'org-tags + :type '(repeat + (choice + (cons (string :tag "Tag name") + (character :tag "Access char")) + (list :tag "Start radio group" + (const :startgroup) + (option (string :tag "Group description"))) + (list :tag "End radio group" + (const :endgroup) + (option (string :tag "Group description"))) + (const :tag "New line" (:newline))))) + +(defcustom org-tag-persistent-alist nil + "List of tags that will always appear in all Org-mode files. +This is in addition to any in buffer settings or customizations +of `org-tag-alist'. +When this list is nil, Org-mode will base TAG input on `org-tag-alist'. +The value of this variable is an alist, the car of each entry must be a +keyword as a string, the cdr may be a character that is used to select +that tag through the fast-tag-selection interface. +See the manual for details. +To disable these tags on a per-file basis, insert anywhere in the file: + #+STARTUP: noptag" + :group 'org-tags + :type '(repeat + (choice + (cons (string :tag "Tag name") + (character :tag "Access char")) + (const :tag "Start radio group" (:startgroup)) + (const :tag "End radio group" (:endgroup)) + (const :tag "New line" (:newline))))) + +(defcustom org-complete-tags-always-offer-all-agenda-tags nil + "If non-nil, always offer completion for all tags of all agenda files. +Instead of customizing this variable directly, you might want to +set it locally for capture buffers, because there no list of +tags in that file can be created dynamically (there are none). + + (add-hook 'org-capture-mode-hook + (lambda () + (set (make-local-variable + 'org-complete-tags-always-offer-all-agenda-tags) + t)))" + :group 'org-tags + :type 'boolean) + +(defvar org-file-tags nil + "List of tags that can be inherited by all entries in the file. +The tags will be inherited if the variable `org-use-tag-inheritance' +says they should be. +This variable is populated from #+FILETAGS lines.") + +(defcustom org-use-fast-tag-selection 'auto + "Non-nil means use fast tag selection scheme. +This is a special interface to select and deselect tags with single keys. +When nil, fast selection is never used. +When the symbol `auto', fast selection is used if and only if selection +characters for tags have been configured, either through the variable +`org-tag-alist' or through a #+TAGS line in the buffer. +When t, fast selection is always used and selection keys are assigned +automatically if necessary." + :group 'org-tags + :type '(choice + (const :tag "Always" t) + (const :tag "Never" nil) + (const :tag "When selection characters are configured" 'auto))) + +(defcustom org-fast-tag-selection-single-key nil + "Non-nil means fast tag selection exits after first change. +When nil, you have to press RET to exit it. +During fast tag selection, you can toggle this flag with `C-c'. +This variable can also have the value `expert'. In this case, the window +displaying the tags menu is not even shown, until you press C-c again." + :group 'org-tags + :type '(choice + (const :tag "No" nil) + (const :tag "Yes" t) + (const :tag "Expert" expert))) + +(defvar org-fast-tag-selection-include-todo nil + "Non-nil means fast tags selection interface will also offer TODO states. +This is an undocumented feature, you should not rely on it.") + +(defcustom org-tags-column (if (featurep 'xemacs) -76 -77) + "The column to which tags should be indented in a headline. +If this number is positive, it specifies the column. If it is negative, +it means that the tags should be flushright to that column. For example, +-80 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 given in a specific line apply there. +This may also be a list of tags that should be inherited, or a regexp that +matches tags that should be inherited. Additional control is possible +with the variable `org-tags-exclude-from-inheritance' which gives an +explicit list of tags to be excluded from inheritance., even if the value of +`org-use-tag-inheritance' would select it for inheritance. + +If this option is t, a match early-on in a tree can lead to a large +number of matches in the subtree when constructing the agenda or creating +a sparse tree. If you only want to see the first match in a tree during +a search, check out the variable `org-tags-match-list-sublevels'." + :group 'org-tags + :type '(choice + (const :tag "Not" nil) + (const :tag "Always" t) + (repeat :tag "Specific tags" (string :tag "Tag")) + (regexp :tag "Tags matched by regexp"))) + +(defcustom org-tags-exclude-from-inheritance nil + "List of tags that should never be inherited. +This is a way to exclude a few tags from inheritance. For way to do +the opposite, to actively allow inheritance for selected tags, +see the variable `org-use-tag-inheritance'." + :group 'org-tags + :type '(repeat (string :tag "Tag"))) + +(defun org-tag-inherit-p (tag) + "Check if TAG is one that should be inherited." + (cond + ((member tag org-tags-exclude-from-inheritance) nil) + ((eq org-use-tag-inheritance t) t) + ((not org-use-tag-inheritance) nil) + ((stringp org-use-tag-inheritance) + (string-match org-use-tag-inheritance tag)) + ((listp org-use-tag-inheritance) + (member tag org-use-tag-inheritance)) + (t (error "Invalid setting of `org-use-tag-inheritance'")))) + +(defcustom org-tags-match-list-sublevels t + "Non-nil means list also sublevels of headlines matching a search. +This variable applies to tags/property searches, and also to stuck +projects because this search is based on a tags match as well. + +When set to the symbol `indented', sublevels are indented with +leading dots. + +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 of a match to be skipped. + +This variable is semi-obsolete and probably should always be true. It +is better to limit inheritance to certain tags using the variables +`org-use-tag-inheritance' and `org-tags-exclude-from-inheritance'." + :group 'org-tags + :type '(choice + (const :tag "No, don't list them" nil) + (const :tag "Yes, do list them" t) + (const :tag "List them, indented with leading dots" indented))) + +(defcustom org-tags-sort-function nil + "When set, tags are sorted using this function as a comparator." + :group 'org-tags + :type '(choice + (const :tag "No sorting" nil) + (const :tag "Alphabetical" string<) + (const :tag "Reverse alphabetical" string>) + (function :tag "Custom function" nil))) + +(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.") +(defvar org-after-tags-change-hook nil + "Hook that is run after the tags in a line have changed.") + +(defgroup org-properties nil + "Options concerning properties in Org-mode." + :tag "Org Properties" + :group 'org) + +(defcustom org-property-format "%-10s %s" + "How property key/value pairs should be formatted by `indent-line'. +When `indent-line' hits a property definition, it will format the line +according to this format, mainly to make sure that the values are +lined-up with respect to each other." + :group 'org-properties + :type 'string) + +(defcustom org-use-property-inheritance nil + "Non-nil means properties apply also for sublevels. + +This setting is chiefly used during property searches. Turning it on can +cause significant overhead when doing a search, which is why it is not +on by default. + +When nil, only the properties directly given in the current entry count. +When t, every property is inherited. The value may also be a list of +properties that should have inheritance, or a regular expression matching +properties that should be inherited. + +However, note that some special properties use inheritance under special +circumstances (not in searches). Examples are CATEGORY, ARCHIVE, COLUMNS, +and the properties ending in \"_ALL\" when they are used as descriptor +for valid values of a property. + +Note for programmers: +When querying an entry with `org-entry-get', you can control if inheritance +should be used. By default, `org-entry-get' looks only at the local +properties. You can request inheritance by setting the inherit argument +to t (to force inheritance) or to `selective' (to respect the setting +in this variable)." + :group 'org-properties + :type '(choice + (const :tag "Not" nil) + (const :tag "Always" t) + (repeat :tag "Specific properties" (string :tag "Property")) + (regexp :tag "Properties matched by regexp"))) + +(defun org-property-inherit-p (property) + "Check if PROPERTY is one that should be inherited." + (cond + ((eq org-use-property-inheritance t) t) + ((not org-use-property-inheritance) nil) + ((stringp org-use-property-inheritance) + (string-match org-use-property-inheritance property)) + ((listp org-use-property-inheritance) + (member property org-use-property-inheritance)) + (t (error "Invalid setting of `org-use-property-inheritance'")))) + +(defcustom org-columns-default-format "%25ITEM %TODO %3PRIORITY %TAGS" + "The default column format, if no other format has been defined. +This variable can be set on the per-file basis by inserting a line + +#+COLUMNS: %25ITEM ....." + :group 'org-properties + :type 'string) + +(defcustom org-columns-ellipses ".." + "The ellipses to be used when a field in column view is truncated. +When this is the empty string, as many characters as possible are shown, +but then there will be no visual indication that the field has been truncated. +When this is a string of length N, the last N characters of a truncated +field are replaced by this string. If the column is narrower than the +ellipses string, only part of the ellipses string will be shown." + :group 'org-properties + :type 'string) + +(defcustom org-columns-modify-value-for-display-function nil + "Function that modifies values for display in column view. +For example, it can be used to cut out a certain part from a time stamp. +The function must take 2 arguments: + +column-title The title of the column (*not* the property name) +value The value that should be modified. + +The function should return the value that should be displayed, +or nil if the normal value should be used." + :group 'org-properties + :type 'function) + +(defcustom org-effort-property "Effort" + "The property that is being used to keep track of effort estimates. +Effort estimates given in this property need to have the format H:MM." + :group 'org-properties + :group 'org-progress + :type '(string :tag "Property")) + +(defconst org-global-properties-fixed + '(("VISIBILITY_ALL" . "folded children content all") + ("CLOCK_MODELINE_TOTAL_ALL" . "current today repeat all auto")) + "List of property/value pairs that can be inherited by any entry. + +These are fixed values, for the preset properties. The user variable +that can be used to add to this list is `org-global-properties'. + +The entries in this list are cons cells where the car is a property +name and cdr is a string with the value. If the value represents +multiple items like an \"_ALL\" property, separate the items by +spaces.") + +(defcustom org-global-properties nil + "List of property/value pairs that can be inherited by any entry. + +This list will be combined with the constant `org-global-properties-fixed'. + +The entries in this list are cons cells where the car is a property +name and cdr is a string with the value. + +You can set buffer-local values for the same purpose in the variable +`org-file-properties' this by adding lines like + +#+PROPERTY: NAME VALUE" + :group 'org-properties + :type '(repeat + (cons (string :tag "Property") + (string :tag "Value")))) + +(defvar org-file-properties nil + "List of property/value pairs that can be inherited by any entry. +Valid for the current buffer. +This variable is populated from #+PROPERTY lines.") +(make-variable-buffer-local 'org-file-properties) + +(defgroup org-agenda nil + "Options concerning agenda views in Org-mode." + :tag "Org Agenda" + :group 'org) + +(defvar org-category nil + "Variable used by org files to set a category for agenda display. +Such files should use a file variable to set it, for example + +# -*- mode: org; org-category: \"ELisp\" + +or contain a special line + +#+CATEGORY: ELisp + +If the file does not specify a category, then file's base name +is used instead.") +(make-variable-buffer-local 'org-category) +(put 'org-category 'safe-local-variable '(lambda (x) (or (symbolp x) (stringp x)))) + +(defcustom org-agenda-files nil + "The files to be used for agenda display. +Entries may be added to this list with \\[org-agenda-file-to-front] and removed with +\\[org-remove-file]. You can also use customize to edit the list. + +If an entry is a directory, all files in that directory that are matched by +`org-agenda-file-regexp' will be part of the file list. + +If the value of the variable is not a list but a single file name, then +the list of agenda files is actually stored and maintained in that file, one +agenda file per line. In this file paths can be given relative to +`org-directory'. Tilde expansion and environment variable substitution +are also made." + :group 'org-agenda + :type '(choice + (repeat :tag "List of files and directories" file) + (file :tag "Store list in a file\n" :value "~/.agenda_files"))) + +(defcustom org-agenda-file-regexp "\\`[^.].*\\.org\\'" + "Regular expression to match files for `org-agenda-files'. +If any element in the list in that variable contains a directory instead +of a normal file, all files in that directory that are matched by this +regular expression will be included." + :group 'org-agenda + :type 'regexp) + +(defcustom org-agenda-text-search-extra-files nil + "List of extra files to be searched by text search commands. +These files will be search in addition to the agenda files by the +commands `org-search-view' (`C-c a s') and `org-occur-in-agenda-files'. +Note that these files will only be searched for text search commands, +not for the other agenda views like todo lists, tag searches or the weekly +agenda. This variable is intended to list notes and possibly archive files +that should also be searched by these two commands. +In fact, if the first element in the list is the symbol `agenda-archives', +than all archive files of all agenda files will be added to the search +scope." + :group 'org-agenda + :type '(set :greedy t + (const :tag "Agenda Archives" agenda-archives) + (repeat :inline t (file)))) + +(if (fboundp 'defvaralias) + (defvaralias 'org-agenda-multi-occur-extra-files + 'org-agenda-text-search-extra-files)) + +(defcustom org-agenda-skip-unavailable-files nil + "Non-nil means to just skip non-reachable files in `org-agenda-files'. +A nil value means to remove them, after a query, from the list." + :group 'org-agenda + :type 'boolean) + +(defcustom org-calendar-to-agenda-key [?c] + "The key to be installed in `calendar-mode-map' for switching to the agenda. +The command `org-calendar-goto-agenda' will be bound to this key. The +default is the character `c' because then `c' can be used to switch back and +forth between agenda and calendar." + :group 'org-agenda + :type 'sexp) + +(defcustom org-calendar-agenda-action-key [?k] + "The key to be installed in `calendar-mode-map' for agenda-action. +The command `org-agenda-action' will be bound to this key. The +default is the character `k' because we use the same key in the agenda." + :group 'org-agenda + :type 'sexp) + +(defcustom org-calendar-insert-diary-entry-key [?i] + "The key to be installed in `calendar-mode-map' for adding diary entries. +This option is irrelevant until `org-agenda-diary-file' has been configured +to point to an Org-mode file. When that is the case, the command +`org-agenda-diary-entry' will be bound to the key given here, by default +`i'. In the calendar, `i' normally adds entries to `diary-file'. So +if you want to continue doing this, you need to change this to a different +key." + :group 'org-agenda + :type 'sexp) + +(defcustom org-agenda-diary-file 'diary-file + "File to which to add new entries with the `i' key in agenda and calendar. +When this is the symbol `diary-file', the functionality in the Emacs +calendar will be used to add entries to the `diary-file'. But when this +points to a file, `org-agenda-diary-entry' will be used instead." + :group 'org-agenda + :type '(choice + (const :tag "The standard Emacs diary file" diary-file) + (file :tag "Special Org file diary entries"))) + +(eval-after-load "calendar" + '(progn + (org-defkey calendar-mode-map org-calendar-to-agenda-key + 'org-calendar-goto-agenda) + (org-defkey calendar-mode-map org-calendar-agenda-action-key + 'org-agenda-action) + (add-hook 'calendar-mode-hook + (lambda () + (unless (eq org-agenda-diary-file 'diary-file) + (define-key calendar-mode-map + org-calendar-insert-diary-entry-key + 'org-agenda-diary-entry)))))) + +(defgroup org-latex nil + "Options for embedding LaTeX code into Org-mode." + :tag "Org LaTeX" + :group 'org) + +(defcustom org-format-latex-options + '(:foreground default :background default :scale 1.0 + :html-foreground "Black" :html-background "Transparent" + :html-scale 1.0 :matchers ("begin" "$1" "$" "$$" "\\(" "\\[")) + "Options for creating images from LaTeX fragments. +This is a property list with the following properties: +:foreground the foreground color for images embedded in Emacs, e.g. \"Black\". + `default' means use the foreground of the default face. +:background the background color, or \"Transparent\". + `default' means use the background of the default face. +:scale a scaling factor for the size of the images, to get more pixels +:html-foreground, :html-background, :html-scale + the same numbers for HTML export. +:matchers a list indicating which matchers should be used to + find LaTeX fragments. Valid members of this list are: + \"begin\" find environments + \"$1\" find single characters surrounded by $.$ + \"$\" find math expressions surrounded by $...$ + \"$$\" find math expressions surrounded by $$....$$ + \"\\(\" find math expressions surrounded by \\(...\\) + \"\\ [\" find math expressions surrounded by \\ [...\\]" + :group 'org-latex + :type 'plist) + +(defcustom org-format-latex-signal-error t + "Non-nil means signal an error when image creation of LaTeX snippets fails. +When nil, just push out a message." + :group 'org-latex + :type 'boolean) + +(defcustom org-format-latex-header "\\documentclass{article} +\\usepackage[usenames]{color} +\\usepackage{amsmath} +\\usepackage[mathscr]{eucal} +\\pagestyle{empty} % do not remove +\[PACKAGES] +\[DEFAULT-PACKAGES] +% The settings below are copied from fullpage.sty +\\setlength{\\textwidth}{\\paperwidth} +\\addtolength{\\textwidth}{-3cm} +\\setlength{\\oddsidemargin}{1.5cm} +\\addtolength{\\oddsidemargin}{-2.54cm} +\\setlength{\\evensidemargin}{\\oddsidemargin} +\\setlength{\\textheight}{\\paperheight} +\\addtolength{\\textheight}{-\\headheight} +\\addtolength{\\textheight}{-\\headsep} +\\addtolength{\\textheight}{-\\footskip} +\\addtolength{\\textheight}{-3cm} +\\setlength{\\topmargin}{1.5cm} +\\addtolength{\\topmargin}{-2.54cm}" + "The document header used for processing LaTeX fragments. +It is imperative that this header make sure that no page number +appears on the page. The package defined in the variables +`org-export-latex-default-packages-alist' and `org-export-latex-packages-alist' +will either replace the placeholder \"[PACKAGES]\" in this header, or they +will be appended." + :group 'org-latex + :type 'string) + +(defvar org-format-latex-header-extra nil) + +(defun org-set-packages-alist (var val) + "Set the packages alist and make sure it has 3 elements per entry." + (set var (mapcar (lambda (x) + (if (and (consp x) (= (length x) 2)) + (list (car x) (nth 1 x) t) + x)) + val))) + +(defun org-get-packages-alist (var) + + "Get the packages alist and make sure it has 3 elements per entry." + (mapcar (lambda (x) + (if (and (consp x) (= (length x) 2)) + (list (car x) (nth 1 x) t) + x)) + (default-value var))) + +;; The following variables are defined here because is it also used +;; when formatting latex fragments. Originally it was part of the +;; LaTeX exporter, which is why the name includes "export". +(defcustom org-export-latex-default-packages-alist + '(("AUTO" "inputenc" t) + ("T1" "fontenc" t) + ("" "fixltx2e" nil) + ("" "graphicx" t) + ("" "longtable" nil) + ("" "float" nil) + ("" "wrapfig" nil) + ("" "soul" t) + ("" "textcomp" t) + ("" "marvosym" t) + ("" "wasysym" t) + ("" "latexsym" t) + ("" "amssymb" t) + ("" "hyperref" nil) + "\\tolerance=1000" + ) + "Alist of default packages to be inserted in the header. +Change this only if one of the packages here causes an incompatibility +with another package you are using. +The packages in this list are needed by one part or another of Org-mode +to function properly. + +- inputenc, fontenc: for basic font and character selection +- textcomp, marvosymb, wasysym, latexsym, amssym: for various symbols used + for interpreting the entities in `org-entities'. You can skip some of these + packages if you don't use any of the symbols in it. +- graphicx: for including images +- float, wrapfig: for figure placement +- longtable: for long tables +- hyperref: for cross references + +Therefore you should not modify this variable unless you know what you +are doing. The one reason to change it anyway is that you might be loading +some other package that conflicts with one of the default packages. +Each cell is of the format \( \"options\" \"package\" snippet-flag\). +If SNIPPET-FLAG is t, the package also needs to be included when +compiling LaTeX snippets into images for inclusion into HTML." + :group 'org-export-latex + :set 'org-set-packages-alist + :get 'org-get-packages-alist + :type '(repeat + (choice + (list :tag "options/package pair" + (string :tag "options") + (string :tag "package") + (boolean :tag "Snippet")) + (string :tag "A line of LaTeX")))) + +(defcustom org-export-latex-packages-alist nil + "Alist of packages to be inserted in every LaTeX header. +These will be inserted after `org-export-latex-default-packages-alist'. +Each cell is of the format \( \"options\" \"package\" snippet-flag \). +SNIPPET-FLAG, when t, indicates that this package is also needed when +turning LaTeX snippets into images for inclusion into HTML. +Make sure that you only list packages here which: +- you want in every file +- do not conflict with the default packages in + `org-export-latex-default-packages-alist' +- do not conflict with the setup in `org-format-latex-header'." + :group 'org-export-latex + :set 'org-set-packages-alist + :get 'org-get-packages-alist + :type '(repeat + (choice + (list :tag "options/package pair" + (string :tag "options") + (string :tag "package") + (boolean :tag "Snippet")) + (string :tag "A line of LaTeX")))) + + +(defgroup org-appearance nil + "Settings for Org-mode appearance." + :tag "Org Appearance" + :group 'org) + +(defcustom org-level-color-stars-only nil + "Non-nil means fontify only the stars in each headline. +When nil, the entire headline is fontified. +Changing it requires restart of `font-lock-mode' to become effective +also in regions already fontified." + :group 'org-appearance + :type 'boolean) + +(defcustom org-hide-leading-stars nil + "Non-nil means hide the first N-1 stars in a headline. +This works by using the face `org-hide' for these stars. This +face is white for a light background, and black for a dark +background. You may have to customize the face `org-hide' to +make this work. +Changing it requires restart of `font-lock-mode' to become effective +also in regions already fontified. +You may also set this on a per-file basis by adding one of the following +lines to the buffer: + + #+STARTUP: hidestars + #+STARTUP: showstars" + :group 'org-appearance + :type 'boolean) + +(defcustom org-hidden-keywords nil + "List of keywords that should be hidden when typed in the org buffer. +For example, add #+TITLE to this list in order to make the +document title appear in the buffer without the initial #+TITLE: +keyword." + :group 'org-appearance + :type '(set (const :tag "#+AUTHOR" author) + (const :tag "#+DATE" date) + (const :tag "#+EMAIL" email) + (const :tag "#+TITLE" title))) + +(defcustom org-fontify-done-headline nil + "Non-nil means change the face of a headline if it is marked DONE. +Normally, only the TODO/DONE keyword indicates the state of a headline. +When this is non-nil, the headline after the keyword is set to the +`org-headline-done' as an additional indication." + :group 'org-appearance + :type 'boolean) + +(defcustom org-fontify-emphasized-text t + "Non-nil means fontify *bold*, /italic/ and _underlined_ text. +Changing this variable requires a restart of Emacs to take effect." + :group 'org-appearance + :type 'boolean) + +(defcustom org-fontify-whole-heading-line nil + "Non-nil means fontify the whole line for headings. +This is useful when setting a background color for the +org-level-* faces." + :group 'org-appearance + :type 'boolean) + +(defcustom org-highlight-latex-fragments-and-specials nil + "Non-nil means fontify what is treated specially by the exporters." + :group 'org-appearance + :type 'boolean) + +(defcustom org-hide-emphasis-markers nil + "Non-nil mean font-lock should hide the emphasis marker characters." + :group 'org-appearance + :type 'boolean) + +(defcustom org-pretty-entities nil + "Non-nil means show entities as UTF8 characters. +When nil, the \\name form remains in the buffer." + :group 'org-appearance + :type 'boolean) + +(defcustom org-pretty-entities-include-sub-superscripts t + "Non-nil means, pretty entity display includes formatting sub/superscripts." + :group 'org-appearance + :type 'boolean) + +(defvar org-emph-re nil + "Regular expression for matching emphasis. +After a match, the match groups contain these elements: +0 The match of the full regular expression, including the characters + before and after the proper match +1 The character before the proper match, or empty at beginning of line +2 The proper match, including the leading and trailing markers +3 The leading marker like * or /, indicating the type of highlighting +4 The text between the emphasis markers, not including the markers +5 The character after the match, empty at the end of a line") +(defvar org-verbatim-re nil + "Regular expression for matching verbatim text.") +(defvar org-emphasis-regexp-components) ; defined just below +(defvar org-emphasis-alist) ; defined just below +(defun org-set-emph-re (var val) + "Set variable and compute the emphasis regular expression." + (set var val) + (when (and (boundp 'org-emphasis-alist) + (boundp 'org-emphasis-regexp-components) + org-emphasis-alist org-emphasis-regexp-components) + (let* ((e org-emphasis-regexp-components) + (pre (car e)) + (post (nth 1 e)) + (border (nth 2 e)) + (body (nth 3 e)) + (nl (nth 4 e)) + (body1 (concat body "*?")) + (markers (mapconcat 'car org-emphasis-alist "")) + (vmarkers (mapconcat + (lambda (x) (if (eq (nth 4 x) 'verbatim) (car x) "")) + org-emphasis-alist ""))) + ;; make sure special characters appear at the right position in the class + (if (string-match "\\^" markers) + (setq markers (concat (replace-match "" t t markers) "^"))) + (if (string-match "-" markers) + (setq markers (concat (replace-match "" t t markers) "-"))) + (if (string-match "\\^" vmarkers) + (setq vmarkers (concat (replace-match "" t t vmarkers) "^"))) + (if (string-match "-" vmarkers) + (setq vmarkers (concat (replace-match "" t t vmarkers) "-"))) + (if (> nl 0) + (setq body1 (concat body1 "\\(?:\n" body "*?\\)\\{0," + (int-to-string nl) "\\}"))) + ;; Make the regexp + (setq org-emph-re + (concat "\\([" pre "]\\|^\\)" + "\\(" + "\\([" markers "]\\)" + "\\(" + "[^" border "]\\|" + "[^" border "]" + body1 + "[^" border "]" + "\\)" + "\\3\\)" + "\\([" post "]\\|$\\)")) + (setq org-verbatim-re + (concat "\\([" pre "]\\|^\\)" + "\\(" + "\\([" vmarkers "]\\)" + "\\(" + "[^" border "]\\|" + "[^" border "]" + body1 + "[^" border "]" + "\\)" + "\\3\\)" + "\\([" post "]\\|$\\)"))))) + +(defcustom org-emphasis-regexp-components + '(" \t('\"{" "- \t.,:!?;'\")}\\" " \t\r\n,\"'" "." 1) + "Components used to build the regular expression for emphasis. +This is a list with five entries. Terminology: In an emphasis string +like \" *strong word* \", we call the initial space PREMATCH, the final +space POSTMATCH, the stars MARKERS, \"s\" and \"d\" are BORDER characters +and \"trong wor\" is the body. The different components in this variable +specify what is allowed/forbidden in each part: + +pre Chars allowed as prematch. Beginning of line will be allowed too. +post Chars allowed as postmatch. End of line will be allowed too. +border The chars *forbidden* as border characters. +body-regexp A regexp like \".\" to match a body character. Don't use + non-shy groups here, and don't allow newline here. +newline The maximum number of newlines allowed in an emphasis exp. + +Use customize to modify this, or restart Emacs after changing it." + :group 'org-appearance + :set 'org-set-emph-re + :type '(list + (sexp :tag "Allowed chars in pre ") + (sexp :tag "Allowed chars in post ") + (sexp :tag "Forbidden chars in border ") + (sexp :tag "Regexp for body ") + (integer :tag "number of newlines allowed") + (option (boolean :tag "Please ignore this button")))) + +(defcustom org-emphasis-alist + `(("*" bold "<b>" "</b>") + ("/" italic "<i>" "</i>") + ("_" underline "<span style=\"text-decoration:underline;\">" "</span>") + ("=" org-code "<code>" "</code>" verbatim) + ("~" org-verbatim "<code>" "</code>" verbatim) + ("+" ,(if (featurep 'xemacs) 'org-table '(:strike-through t)) + "<del>" "</del>") + ) + "Special syntax for emphasized text. +Text starting and ending with a special character will be emphasized, for +example *bold*, _underlined_ and /italic/. This variable sets the marker +characters, the face to be used by font-lock for highlighting in Org-mode +Emacs buffers, and the HTML tags to be used for this. +For LaTeX export, see the variable `org-export-latex-emphasis-alist'. +For DocBook export, see the variable `org-export-docbook-emphasis-alist'. +Use customize to modify this, or restart Emacs after changing it." + :group 'org-appearance + :set 'org-set-emph-re + :type '(repeat + (list + (string :tag "Marker character") + (choice + (face :tag "Font-lock-face") + (plist :tag "Face property list")) + (string :tag "HTML start tag") + (string :tag "HTML end tag") + (option (const verbatim))))) + +(defvar org-protecting-blocks + '("src" "example" "latex" "ascii" "html" "docbook" "ditaa" "dot" "r" "R") + "Blocks that contain text that is quoted, i.e. not processed as Org syntax. +This is needed for font-lock setup.") + +;;; Miscellaneous options + +(defgroup org-completion nil + "Completion in Org-mode." + :tag "Org Completion" + :group 'org) + +(defcustom org-completion-use-ido nil + "Non-nil means use ido completion wherever possible. +Note that `ido-mode' must be active for this variable to be relevant. +If you decide to turn this variable on, you might well want to turn off +`org-outline-path-complete-in-steps'. +See also `org-completion-use-iswitchb'." + :group 'org-completion + :type 'boolean) + +(defcustom org-completion-use-iswitchb nil + "Non-nil means use iswitchb completion wherever possible. +Note that `iswitchb-mode' must be active for this variable to be relevant. +If you decide to turn this variable on, you might well want to turn off +`org-outline-path-complete-in-steps'. +Note that this variable has only an effect if `org-completion-use-ido' is nil." + :group 'org-completion + :type 'boolean) + +(defcustom org-completion-fallback-command 'hippie-expand + "The expansion command called by \\[pcomplete] in normal context. +Normal means, no org-mode-specific context." + :group 'org-completion + :type 'function) + +;;; Functions and variables from their packages +;; Declared here to avoid compiler warnings + +;; XEmacs only +(defvar outline-mode-menu-heading) +(defvar outline-mode-menu-show) +(defvar outline-mode-menu-hide) +(defvar zmacs-regions) ; XEmacs regions + +;; Emacs only +(defvar mark-active) + +;; Various packages +(declare-function calendar-absolute-from-iso "cal-iso" (date)) +(declare-function calendar-forward-day "cal-move" (arg)) +(declare-function calendar-goto-date "cal-move" (date)) +(declare-function calendar-goto-today "cal-move" ()) +(declare-function calendar-iso-from-absolute "cal-iso" (date)) +(defvar calc-embedded-close-formula) +(defvar calc-embedded-open-formula) +(declare-function cdlatex-tab "ext:cdlatex" ()) +(declare-function dired-get-filename "dired" (&optional localp no-error-if-not-filep)) +(defvar font-lock-unfontify-region-function) +(declare-function iswitchb-read-buffer "iswitchb" + (prompt &optional default require-match start matches-set)) +(defvar iswitchb-temp-buflist) +(declare-function org-gnus-follow-link "org-gnus" (&optional group article)) +(defvar org-agenda-tags-todo-honor-ignore-options) +(declare-function org-agenda-skip "org-agenda" ()) +(declare-function + org-format-agenda-item "org-agenda" + (extra txt &optional category tags dotime noprefix remove-re habitp)) +(declare-function org-agenda-new-marker "org-agenda" (&optional pos)) +(declare-function org-agenda-change-all-lines "org-agenda" + (newhead hdmarker &optional fixface just-this)) +(declare-function org-agenda-set-restriction-lock "org-agenda" (&optional type)) +(declare-function org-agenda-maybe-redo "org-agenda" ()) +(declare-function org-agenda-save-markers-for-cut-and-paste "org-agenda" + (beg end)) +(declare-function org-agenda-copy-local-variable "org-agenda" (var)) +(declare-function org-agenda-check-for-timestamp-as-reason-to-ignore-todo-item + "org-agenda" (&optional end)) +(declare-function org-inlinetask-remove-END-maybe "org-inlinetask" ()) +(declare-function org-inlinetask-in-task-p "org-inlinetask" ()) +(declare-function org-inlinetask-goto-beginning "org-inlinetask" ()) +(declare-function org-inlinetask-goto-end "org-inlinetask" ()) +(declare-function org-indent-mode "org-indent" (&optional arg)) +(declare-function parse-time-string "parse-time" (string)) +(declare-function org-attach-reveal "org-attach" (&optional if-exists)) +(declare-function org-export-latex-fix-inputenc "org-latex" ()) +(declare-function orgtbl-send-table "org-table" (&optional maybe)) +(defvar remember-data-file) +(defvar texmathp-why) +(declare-function speedbar-line-directory "speedbar" (&optional depth)) +(declare-function table--at-cell-p "table" (position &optional object at-column)) + +(defvar w3m-current-url) +(defvar w3m-current-title) + +(defvar org-latex-regexps) + +;;; Autoload and prepare some org modules + +;; Some table stuff that needs to be defined here, because it is used +;; by the functions setting up org-mode or checking for table context. + +(defconst org-table-any-line-regexp "^[ \t]*\\(|\\|\\+-[-+]\\)" + "Detect an org-type or table-type table.") +(defconst org-table-line-regexp "^[ \t]*|" + "Detect an org-type table line.") +(defconst org-table-dataline-regexp "^[ \t]*|[^-]" + "Detect an org-type table line.") +(defconst org-table-hline-regexp "^[ \t]*|-" + "Detect an org-type table hline.") +(defconst org-table1-hline-regexp "^[ \t]*\\+-[-+]" + "Detect a table-type table hline.") +(defconst org-table-any-border-regexp "^[ \t]*[^|+ \t]" + "Detect the first line outside a table when searching from within it. +This works for both table types.") + +;; Autoload the functions in org-table.el that are needed by functions here. + +(eval-and-compile + (org-autoload "org-table" + '(org-table-align org-table-begin org-table-blank-field + org-table-convert org-table-convert-region org-table-copy-down + org-table-copy-region org-table-create + org-table-create-or-convert-from-region + org-table-create-with-table.el org-table-current-dline + org-table-cut-region org-table-delete-column org-table-edit-field + org-table-edit-formulas org-table-end org-table-eval-formula + org-table-export org-table-field-info + org-table-get-stored-formulas org-table-goto-column + org-table-hline-and-move org-table-import org-table-insert-column + org-table-insert-hline org-table-insert-row org-table-iterate + org-table-justify-field-maybe org-table-kill-row + org-table-maybe-eval-formula org-table-maybe-recalculate-line + org-table-move-column org-table-move-column-left + org-table-move-column-right org-table-move-row + org-table-move-row-down org-table-move-row-up + org-table-next-field org-table-next-row org-table-paste-rectangle + org-table-previous-field org-table-recalculate + org-table-rotate-recalc-marks org-table-sort-lines org-table-sum + org-table-toggle-coordinate-overlays + org-table-toggle-formula-debugger org-table-wrap-region + orgtbl-mode turn-on-orgtbl org-table-to-lisp + orgtbl-to-generic orgtbl-to-tsv orgtbl-to-csv orgtbl-to-latex + orgtbl-to-orgtbl orgtbl-to-html orgtbl-to-texinfo))) + +(defun org-at-table-p (&optional table-type) + "Return t if the cursor is inside an org-type table. +If TABLE-TYPE is non-nil, also check for table.el-type tables." + (if org-enable-table-editor + (save-excursion + (beginning-of-line 1) + (looking-at (if table-type org-table-any-line-regexp + org-table-line-regexp))) + nil)) +(defsubst org-table-p () (org-at-table-p)) + +(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 + (if (org-at-table.el-p) + (progn + (beginning-of-line 1) + (if (looking-at org-table-dataline-regexp) + nil + (if (looking-at org-table1-hline-regexp) + (progn + (beginning-of-line 2) + (if (looking-at org-table-any-border-regexp) + (beginning-of-line -1))))) + (if (re-search-forward "|" (org-table-end t) t) + (progn + (require 'table) + (if (table--at-cell-p (point)) + t + (message "recognizing table.el table...") + (table-recognize-table) + (message "recognizing table.el table...done"))) + (error "This should not happen")) + t) + nil) + nil)) + +(defun org-at-table-hline-p () + "Return t if the cursor is inside a hline in a table." + (if org-enable-table-editor + (save-excursion + (beginning-of-line 1) + (looking-at org-table-hline-regexp)) + nil)) + +(defvar org-table-clean-did-remove-column nil) + +(defun org-table-map-tables (function &optional quietly) + "Apply FUNCTION to the start of all tables in the buffer." + (save-excursion + (save-restriction + (widen) + (goto-char (point-min)) + (while (re-search-forward org-table-any-line-regexp nil t) + (unless quietly + (message "Mapping tables: %d%%" (/ (* 100.0 (point)) (buffer-size)))) + (beginning-of-line 1) + (when (looking-at org-table-line-regexp) + (save-excursion (funcall function)) + (or (looking-at org-table-line-regexp) + (forward-char 1))) + (re-search-forward org-table-any-border-regexp nil 1)))) + (unless quietly (message "Mapping tables: done"))) + +;; Declare and autoload functions from org-exp.el & Co + +(declare-function org-default-export-plist "org-exp") +(declare-function org-infile-export-plist "org-exp") +(declare-function org-get-current-options "org-exp") +(eval-and-compile + (org-autoload "org-exp" + '(org-export org-export-visible + org-insert-export-options-template + org-table-clean-before-export)) + (org-autoload "org-ascii" + '(org-export-as-ascii org-export-ascii-preprocess + org-export-as-ascii-to-buffer org-replace-region-by-ascii + org-export-region-as-ascii)) + (org-autoload "org-latex" + '(org-export-as-latex-batch org-export-as-latex-to-buffer + org-replace-region-by-latex org-export-region-as-latex + org-export-as-latex org-export-as-pdf + org-export-as-pdf-and-open)) + (org-autoload "org-html" + '(org-export-as-html-and-open + org-export-as-html-batch org-export-as-html-to-buffer + org-replace-region-by-html org-export-region-as-html + org-export-as-html)) + (org-autoload "org-docbook" + '(org-export-as-docbook-batch org-export-as-docbook-to-buffer + org-replace-region-by-docbook org-export-region-as-docbook + org-export-as-docbook-pdf org-export-as-docbook-pdf-and-open + org-export-as-docbook)) + (org-autoload "org-icalendar" + '(org-export-icalendar-this-file + org-export-icalendar-all-agenda-files + org-export-icalendar-combine-agenda-files)) + (org-autoload "org-xoxo" '(org-export-as-xoxo)) + (org-autoload "org-beamer" '(org-beamer-mode org-beamer-sectioning))) + +;; Declare and autoload functions from org-agenda.el + +(eval-and-compile + (org-autoload "org-agenda" + '(org-agenda org-agenda-list org-search-view + org-todo-list org-tags-view org-agenda-list-stuck-projects + org-diary org-agenda-to-appt + org-agenda-check-for-timestamp-as-reason-to-ignore-todo-item))) + +;; Autoload org-remember + +(eval-and-compile + (org-autoload "org-remember" + '(org-remember-insinuate org-remember-annotation + org-remember-apply-template org-remember org-remember-handler))) + +(eval-and-compile + (org-autoload "org-capture" + '(org-capture org-capture-insert-template-here + org-capture-import-remember-templates))) + +;; Autoload org-clock.el + +(declare-function org-clock-save-markers-for-cut-and-paste "org-clock" + (beg end)) +(declare-function org-clock-update-mode-line "org-clock" ()) +(declare-function org-resolve-clocks "org-clock" + (&optional also-non-dangling-p prompt last-valid)) +(defvar org-clock-start-time) +(defvar org-clock-marker (make-marker) + "Marker recording the last clock-in.") +(defvar org-clock-hd-marker (make-marker) + "Marker recording the last clock-in, but the headline position.") +(defvar org-clock-heading "" + "The heading of the current clock entry.") +(defun org-clock-is-active () + "Return non-nil if clock is currently running. +The return value is actually the clock marker." + (marker-buffer org-clock-marker)) + +(eval-and-compile + (org-autoload + "org-clock" + '(org-clock-in org-clock-out org-clock-cancel + org-clock-goto org-clock-sum org-clock-display + org-clock-remove-overlays org-clock-report + org-clocktable-shift org-dblock-write:clocktable + org-get-clocktable org-resolve-clocks))) + +(defun org-clock-update-time-maybe () + "If this is a CLOCK line, update it and return t. +Otherwise, return nil." + (interactive) + (save-excursion + (beginning-of-line 1) + (skip-chars-forward " \t") + (when (looking-at org-clock-string) + (let ((re (concat "[ \t]*" org-clock-string + " *[[<]\\([^]>]+\\)[]>]\\(-+[[<]\\([^]>]+\\)[]>]" + "\\([ \t]*=>.*\\)?\\)?")) + ts te h m s neg) + (cond + ((not (looking-at re)) + nil) + ((not (match-end 2)) + (when (and (equal (marker-buffer org-clock-marker) (current-buffer)) + (> org-clock-marker (point)) + (<= org-clock-marker (point-at-eol))) + ;; The clock is running here + (setq org-clock-start-time + (apply 'encode-time + (org-parse-time-string (match-string 1)))) + (org-clock-update-mode-line))) + (t + (and (match-end 4) (delete-region (match-beginning 4) (match-end 4))) + (end-of-line 1) + (setq ts (match-string 1) + te (match-string 3)) + (setq s (- (org-float-time + (apply 'encode-time (org-parse-time-string te))) + (org-float-time + (apply 'encode-time (org-parse-time-string ts)))) + neg (< s 0) + s (abs s) + h (floor (/ s 3600)) + s (- s (* 3600 h)) + m (floor (/ s 60)) + s (- s (* 60 s))) + (insert " => " (format (if neg "-%d:%02d" "%2d:%02d") h m)) + t)))))) + +(defun org-check-running-clock () + "Check if the current buffer contains the running clock. +If yes, offer to stop it and to save the buffer with the changes." + (when (and (equal (marker-buffer org-clock-marker) (current-buffer)) + (y-or-n-p (format "Clock-out in buffer %s before killing it? " + (buffer-name)))) + (org-clock-out) + (when (y-or-n-p "Save changed buffer?") + (save-buffer)))) + +(defun org-clocktable-try-shift (dir n) + "Check if this line starts a clock table, if yes, shift the time block." + (when (org-match-line "#\\+BEGIN: clocktable\\>") + (org-clocktable-shift dir n))) + +;; Autoload org-timer.el + +(eval-and-compile + (org-autoload + "org-timer" + '(org-timer-start org-timer org-timer-item + org-timer-change-times-in-region + org-timer-set-timer + org-timer-reset-timers + org-timer-show-remaining-time))) + +;; Autoload org-feed.el + +(eval-and-compile + (org-autoload + "org-feed" + '(org-feed-update org-feed-update-all org-feed-goto-inbox))) + + +;; Autoload org-indent.el + +;; Define the variable already here, to make sure we have it. +(defvar org-indent-mode nil + "Non-nil if Org-Indent mode is enabled. +Use the command `org-indent-mode' to change this variable.") + +(eval-and-compile + (org-autoload + "org-indent" + '(org-indent-mode))) + +;; Autoload org-mobile.el + +(eval-and-compile + (org-autoload + "org-mobile" + '(org-mobile-push org-mobile-pull org-mobile-create-sumo-agenda))) + +;; Autoload archiving code +;; The stuff that is needed for cycling and tags has to be defined here. + +(defgroup org-archive nil + "Options concerning archiving in Org-mode." + :tag "Org Archive" + :group 'org-structure) + +(defcustom org-archive-location "%s_archive::" + "The location where subtrees should be archived. + +The value of this variable is a string, consisting of two parts, +separated by a double-colon. The first part is a filename and +the second part is a headline. + +When the filename is omitted, archiving happens in the same file. +%s in the filename will be replaced by the current file +name (without the directory part). Archiving to a different file +is useful to keep archived entries from contributing to the +Org-mode Agenda. + +The archived entries will be filed as subtrees of the specified +headline. When the headline is omitted, the subtrees are simply +filed away at the end of the file, as top-level entries. Also in +the heading you can use %s to represent the file name, this can be +useful when using the same archive for a number of different files. + +Here are a few examples: +\"%s_archive::\" + If the current file is Projects.org, archive in file + Projects.org_archive, as top-level trees. This is the default. + +\"::* Archived Tasks\" + Archive in the current file, under the top-level headline + \"* Archived Tasks\". + +\"~/org/archive.org::\" + Archive in file ~/org/archive.org (absolute path), as top-level trees. + +\"~/org/archive.org::From %s\" + Archive in file ~/org/archive.org (absolute path), under headlines + \"From FILENAME\" where file name is the current file name. + +\"basement::** Finished Tasks\" + Archive in file ./basement (relative path), as level 3 trees + below the level 2 heading \"** Finished Tasks\". + +You may set this option on a per-file basis by adding to the buffer a +line like + +#+ARCHIVE: basement::** Finished Tasks + +You may also define it locally for a subtree by setting an ARCHIVE property +in the entry. If such a property is found in an entry, or anywhere up +the hierarchy, it will be used." + :group 'org-archive + :type 'string) + +(defcustom org-archive-tag "ARCHIVE" + "The tag that marks a subtree as archived. +An archived subtree does not open during visibility cycling, and does +not contribute to the agenda listings. +After changing this, font-lock must be restarted in the relevant buffers to +get the proper fontification." + :group 'org-archive + :group 'org-keywords + :type 'string) + +(defcustom org-agenda-skip-archived-trees t + "Non-nil means the agenda will skip any items located in archived trees. +An archived tree is a tree marked with the tag ARCHIVE. The use of this +variable is no longer recommended, you should leave it at the value t. +Instead, use the key `v' to cycle the archives-mode in the agenda." + :group 'org-archive + :group 'org-agenda-skip + :type 'boolean) + +(defcustom org-columns-skip-archived-trees t + "Non-nil means ignore archived trees when creating column view." + :group 'org-archive + :group 'org-properties + :type 'boolean) + +(defcustom org-cycle-open-archived-trees nil + "Non-nil means `org-cycle' will open archived trees. +An archived tree is a tree marked with the tag ARCHIVE. +When nil, archived trees will stay folded. You can still open them with +normal outline commands like `show-all', but not with the cycling commands." + :group 'org-archive + :group 'org-cycle + :type 'boolean) + +(defcustom org-sparse-tree-open-archived-trees nil + "Non-nil means sparse tree construction shows matches in archived trees. +When nil, matches in these trees are highlighted, but the trees are kept in +collapsed state." + :group 'org-archive + :group 'org-sparse-trees + :type 'boolean) + +(defun org-cycle-hide-archived-subtrees (state) + "Re-hide all archived subtrees after a visibility state change." + (when (and (not org-cycle-open-archived-trees) + (not (memq state '(overview folded)))) + (save-excursion + (let* ((globalp (memq state '(contents all))) + (beg (if globalp (point-min) (point))) + (end (if globalp (point-max) (org-end-of-subtree t)))) + (org-hide-archived-subtrees beg end) + (goto-char beg) + (if (looking-at (concat ".*:" org-archive-tag ":")) + (message "%s" (substitute-command-keys + "Subtree is archived and stays closed. Use \\[org-force-cycle-archived] to cycle it anyway."))))))) + +(defun org-force-cycle-archived () + "Cycle subtree even if it is archived." + (interactive) + (setq this-command 'org-cycle) + (let ((org-cycle-open-archived-trees t)) + (call-interactively 'org-cycle))) + +(defun org-hide-archived-subtrees (beg end) + "Re-hide all archived subtrees after a visibility state change." + (save-excursion + (let* ((re (concat ":" org-archive-tag ":"))) + (goto-char beg) + (while (re-search-forward re end t) + (when (org-on-heading-p) + (org-flag-subtree t) + (org-end-of-subtree t)))))) + +(defun org-flag-subtree (flag) + (save-excursion + (org-back-to-heading t) + (outline-end-of-heading) + (outline-flag-region (point) + (progn (org-end-of-subtree t) (point)) + flag))) + +(defalias 'org-advertized-archive-subtree 'org-archive-subtree) + +(eval-and-compile + (org-autoload "org-archive" + '(org-add-archive-files org-archive-subtree + org-archive-to-archive-sibling org-toggle-archive-tag + org-archive-subtree-default + org-archive-subtree-default-with-confirmation))) + +;; Autoload Column View Code + +(declare-function org-columns-number-to-string "org-colview") +(declare-function org-columns-get-format-and-top-level "org-colview") +(declare-function org-columns-compute "org-colview") + +(org-autoload (if (featurep 'xemacs) "org-colview-xemacs" "org-colview") + '(org-columns-number-to-string org-columns-get-format-and-top-level + org-columns-compute org-agenda-columns org-columns-remove-overlays + org-columns org-insert-columns-dblock org-dblock-write:columnview)) + +;; Autoload ID code + +(declare-function org-id-store-link "org-id") +(declare-function org-id-locations-load "org-id") +(declare-function org-id-locations-save "org-id") +(defvar org-id-track-globally) +(org-autoload "org-id" + '(org-id-get-create org-id-new org-id-copy org-id-get + org-id-get-with-outline-path-completion + org-id-get-with-outline-drilling org-id-store-link + org-id-goto org-id-find org-id-store-link)) + +;; Autoload Plotting Code + +(org-autoload "org-plot" + '(org-plot/gnuplot)) + +;;; Variables for pre-computed regular expressions, all buffer local + +(defvar org-drawer-regexp nil + "Matches first line of a hidden block.") +(make-variable-buffer-local 'org-drawer-regexp) +(defvar org-todo-regexp nil + "Matches any of the TODO state keywords.") +(make-variable-buffer-local 'org-todo-regexp) +(defvar org-not-done-regexp nil + "Matches any of the TODO state keywords except the last one.") +(make-variable-buffer-local 'org-not-done-regexp) +(defvar org-not-done-heading-regexp nil + "Matches a TODO headline that is not done.") +(make-variable-buffer-local 'org-not-done-regexp) +(defvar org-todo-line-regexp nil + "Matches a headline and puts TODO state into group 2 if present.") +(make-variable-buffer-local 'org-todo-line-regexp) +(defvar org-complex-heading-regexp nil + "Matches a headline and puts everything into groups: +group 1: the stars +group 2: The todo keyword, maybe +group 3: Priority cookie +group 4: True headline +group 5: Tags") +(make-variable-buffer-local 'org-complex-heading-regexp) +(defvar org-complex-heading-regexp-format nil + "Printf format to make regexp to match an exact headline. +This regexp will match the headline of any node which hase the exact +headline text that is put into the format, but may have any TODO state, +priority and tags.") +(make-variable-buffer-local 'org-complex-heading-regexp-format) +(defvar org-todo-line-tags-regexp nil + "Matches a headline and puts TODO state into group 2 if present. +Also put tags into group 4 if tags are present.") +(make-variable-buffer-local 'org-todo-line-tags-regexp) +(defvar org-nl-done-regexp nil + "Matches newline followed by a headline with the DONE keyword.") +(make-variable-buffer-local 'org-nl-done-regexp) +(defvar org-looking-at-done-regexp nil + "Matches the DONE keyword a point.") +(make-variable-buffer-local 'org-looking-at-done-regexp) +(defvar org-ds-keyword-length 12 + "Maximum length of the Deadline and SCHEDULED keywords.") +(make-variable-buffer-local 'org-ds-keyword-length) +(defvar org-deadline-regexp nil + "Matches the DEADLINE keyword.") +(make-variable-buffer-local 'org-deadline-regexp) +(defvar org-deadline-time-regexp nil + "Matches the DEADLINE keyword together with a time stamp.") +(make-variable-buffer-local 'org-deadline-time-regexp) +(defvar org-deadline-line-regexp nil + "Matches the DEADLINE keyword and the rest of the line.") +(make-variable-buffer-local 'org-deadline-line-regexp) +(defvar org-scheduled-regexp nil + "Matches the SCHEDULED keyword.") +(make-variable-buffer-local 'org-scheduled-regexp) +(defvar org-scheduled-time-regexp nil + "Matches the SCHEDULED keyword together with a time stamp.") +(make-variable-buffer-local 'org-scheduled-time-regexp) +(defvar org-closed-time-regexp nil + "Matches the CLOSED keyword together with a time stamp.") +(make-variable-buffer-local 'org-closed-time-regexp) + +(defvar org-keyword-time-regexp nil + "Matches any of the 4 keywords, together with the time stamp.") +(make-variable-buffer-local 'org-keyword-time-regexp) +(defvar org-keyword-time-not-clock-regexp nil + "Matches any of the 3 keywords, together with the time stamp.") +(make-variable-buffer-local 'org-keyword-time-not-clock-regexp) +(defvar org-maybe-keyword-time-regexp nil + "Matches a timestamp, possibly preceded by a keyword.") +(make-variable-buffer-local 'org-maybe-keyword-time-regexp) +(defvar org-planning-or-clock-line-re nil + "Matches a line with planning or clock info.") +(make-variable-buffer-local 'org-planning-or-clock-line-re) +(defvar org-all-time-keywords nil + "List of time keywords.") +(make-variable-buffer-local 'org-all-time-keywords) + +(defconst org-plain-time-of-day-regexp + (concat + "\\(\\<[012]?[0-9]" + "\\(\\(:\\([0-5][0-9]\\([AaPp][Mm]\\)?\\)\\)\\|\\([AaPp][Mm]\\)\\)\\>\\)" + "\\(--?" + "\\(\\<[012]?[0-9]" + "\\(\\(:\\([0-5][0-9]\\([AaPp][Mm]\\)?\\)\\)\\|\\([AaPp][Mm]\\)\\)\\>\\)" + "\\)?") + "Regular expression to match a plain time or time range. +Examples: 11:45 or 8am-13:15 or 2:45-2:45pm. After a match, the following +groups carry important information: +0 the full match +1 the first time, range or not +8 the second time, if it is a range.") + +(defconst org-plain-time-extension-regexp + (concat + "\\(\\<[012]?[0-9]" + "\\(\\(:\\([0-5][0-9]\\([AaPp][Mm]\\)?\\)\\)\\|\\([AaPp][Mm]\\)\\)\\>\\)" + "\\+\\([0-9]+\\)\\(:\\([0-5][0-9]\\)\\)?") + "Regular expression to match a time range like 13:30+2:10 = 13:30-15:40. +Examples: 11:45 or 8am-13:15 or 2:45-2:45pm. After a match, the following +groups carry important information: +0 the full match +7 hours of duration +9 minutes of duration") + +(defconst org-stamp-time-of-day-regexp + (concat + "<\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\} +\\sw+ +\\)" + "\\([012][0-9]:[0-5][0-9]\\(-\\([012][0-9]:[0-5][0-9]\\)\\)?[^\n\r>]*?\\)>" + "\\(--?" + "<\\1\\([012][0-9]:[0-5][0-9]\\)>\\)?") + "Regular expression to match a timestamp time or time range. +After a match, the following groups carry important information: +0 the full match +1 date plus weekday, for back referencing to make sure both times are on the same day +2 the first time, range or not +4 the second time, if it is a range.") + +(defconst org-startup-options + '(("fold" org-startup-folded t) + ("overview" org-startup-folded t) + ("nofold" org-startup-folded nil) + ("showall" org-startup-folded nil) + ("showeverything" org-startup-folded showeverything) + ("content" org-startup-folded content) + ("indent" org-startup-indented t) + ("noindent" org-startup-indented nil) + ("hidestars" org-hide-leading-stars t) + ("showstars" org-hide-leading-stars nil) + ("odd" org-odd-levels-only t) + ("oddeven" org-odd-levels-only nil) + ("align" org-startup-align-all-tables t) + ("noalign" org-startup-align-all-tables nil) + ("inlineimages" org-startup-with-inline-images t) + ("noinlineimages" org-startup-with-inline-images nil) + ("customtime" org-display-custom-times t) + ("logdone" org-log-done time) + ("lognotedone" org-log-done note) + ("nologdone" org-log-done nil) + ("lognoteclock-out" org-log-note-clock-out t) + ("nolognoteclock-out" org-log-note-clock-out nil) + ("logrepeat" org-log-repeat state) + ("lognoterepeat" org-log-repeat note) + ("nologrepeat" org-log-repeat nil) + ("logreschedule" org-log-reschedule time) + ("lognotereschedule" org-log-reschedule note) + ("nologreschedule" org-log-reschedule nil) + ("logredeadline" org-log-redeadline time) + ("lognoteredeadline" org-log-redeadline note) + ("nologredeadline" org-log-redeadline nil) + ("logrefile" org-log-refile time) + ("lognoterefile" org-log-refile note) + ("nologrefile" org-log-refile nil) + ("fninline" org-footnote-define-inline t) + ("nofninline" org-footnote-define-inline nil) + ("fnlocal" org-footnote-section nil) + ("fnauto" org-footnote-auto-label t) + ("fnprompt" org-footnote-auto-label nil) + ("fnconfirm" org-footnote-auto-label confirm) + ("fnplain" org-footnote-auto-label plain) + ("fnadjust" org-footnote-auto-adjust t) + ("nofnadjust" org-footnote-auto-adjust nil) + ("constcgs" constants-unit-system cgs) + ("constSI" constants-unit-system SI) + ("noptag" org-tag-persistent-alist nil) + ("hideblocks" org-hide-block-startup t) + ("nohideblocks" org-hide-block-startup nil) + ("beamer" org-startup-with-beamer-mode t) + ("entitiespretty" org-pretty-entities t) + ("entitiesplain" org-pretty-entities nil)) + "Variable associated with STARTUP options for org-mode. +Each element is a list of three items: The startup options as written +in the #+STARTUP line, the corresponding variable, and the value to +set this variable to if the option is found. An optional forth element PUSH +means to push this value onto the list in the variable.") + +(defun org-set-regexps-and-options () + "Precompute regular expressions for current buffer." + (when (org-mode-p) + (org-set-local 'org-todo-kwd-alist nil) + (org-set-local 'org-todo-key-alist nil) + (org-set-local 'org-todo-key-trigger nil) + (org-set-local 'org-todo-keywords-1 nil) + (org-set-local 'org-done-keywords nil) + (org-set-local 'org-todo-heads nil) + (org-set-local 'org-todo-sets nil) + (org-set-local 'org-todo-log-states nil) + (org-set-local 'org-file-properties nil) + (org-set-local 'org-file-tags nil) + (let ((re (org-make-options-regexp + '("CATEGORY" "TODO" "COLUMNS" + "STARTUP" "ARCHIVE" "FILETAGS" "TAGS" "LINK" "PRIORITIES" + "CONSTANTS" "PROPERTY" "DRAWERS" "SETUPFILE" "LATEX_CLASS" + "OPTIONS") + "\\(?:[a-zA-Z][0-9a-zA-Z_]*_TODO\\)")) + (splitre "[ \t]+") + (scripts org-use-sub-superscripts) + kwds kws0 kwsa key log value cat arch tags const links hw dws + tail sep kws1 prio props ftags drawers beamer-p + ext-setup-or-nil setup-contents (start 0)) + (save-excursion + (save-restriction + (widen) + (goto-char (point-min)) + (while (or (and ext-setup-or-nil + (string-match re ext-setup-or-nil start) + (setq start (match-end 0))) + (and (setq ext-setup-or-nil nil start 0) + (re-search-forward re nil t))) + (setq key (upcase (match-string 1 ext-setup-or-nil)) + value (org-match-string-no-properties 2 ext-setup-or-nil)) + (if (stringp value) (setq value (org-trim value))) + (cond + ((equal key "CATEGORY") + (setq cat value)) + ((member key '("SEQ_TODO" "TODO")) + (push (cons 'sequence (org-split-string value splitre)) kwds)) + ((equal key "TYP_TODO") + (push (cons 'type (org-split-string value splitre)) kwds)) + ((string-match "\\`\\([a-zA-Z][0-9a-zA-Z_]*\\)_TODO\\'" key) + ;; general TODO-like setup + (push (cons (intern (downcase (match-string 1 key))) + (org-split-string value splitre)) kwds)) + ((equal key "TAGS") + (setq tags (append tags (if tags '("\\n") nil) + (org-split-string value splitre)))) + ((equal key "COLUMNS") + (org-set-local 'org-columns-default-format value)) + ((equal key "LINK") + (when (string-match "^\\(\\S-+\\)[ \t]+\\(.+\\)" value) + (push (cons (match-string 1 value) + (org-trim (match-string 2 value))) + links))) + ((equal key "PRIORITIES") + (setq prio (org-split-string value " +"))) + ((equal key "PROPERTY") + (when (string-match "\\(\\S-+\\)\\s-+\\(.*\\)" value) + (push (cons (match-string 1 value) (match-string 2 value)) + props))) + ((equal key "FILETAGS") + (when (string-match "\\S-" value) + (setq ftags + (append + ftags + (apply 'append + (mapcar (lambda (x) (org-split-string x ":")) + (org-split-string value))))))) + ((equal key "DRAWERS") + (setq drawers (org-split-string value splitre))) + ((equal key "CONSTANTS") + (setq const (append const (org-split-string value splitre)))) + ((equal key "STARTUP") + (let ((opts (org-split-string value splitre)) + l var val) + (while (setq l (pop opts)) + (when (setq l (assoc l org-startup-options)) + (setq var (nth 1 l) val (nth 2 l)) + (if (not (nth 3 l)) + (set (make-local-variable var) val) + (if (not (listp (symbol-value var))) + (set (make-local-variable var) nil)) + (set (make-local-variable var) (symbol-value var)) + (add-to-list var val)))))) + ((equal key "ARCHIVE") + (setq arch value) + (remove-text-properties 0 (length arch) + '(face t fontified t) arch)) + ((equal key "LATEX_CLASS") + (setq beamer-p (equal value "beamer"))) + ((equal key "OPTIONS") + (if (string-match "\\([ \t]\\|\\`\\)\\^:\\(t\\|nil\\|{}\\)" value) + (setq scripts (read (match-string 2 value))))) + ((equal key "SETUPFILE") + (setq setup-contents (org-file-contents + (expand-file-name + (org-remove-double-quotes value)) + 'noerror)) + (if (not ext-setup-or-nil) + (setq ext-setup-or-nil setup-contents start 0) + (setq ext-setup-or-nil + (concat (substring ext-setup-or-nil 0 start) + "\n" setup-contents "\n" + (substring ext-setup-or-nil start))))) + )))) + (org-set-local 'org-use-sub-superscripts scripts) + (when cat + (org-set-local 'org-category (intern cat)) + (push (cons "CATEGORY" cat) props)) + (when prio + (if (< (length prio) 3) (setq prio '("A" "C" "B"))) + (setq prio (mapcar 'string-to-char prio)) + (org-set-local 'org-highest-priority (nth 0 prio)) + (org-set-local 'org-lowest-priority (nth 1 prio)) + (org-set-local 'org-default-priority (nth 2 prio))) + (and props (org-set-local 'org-file-properties (nreverse props))) + (and ftags (org-set-local 'org-file-tags + (mapcar 'org-add-prop-inherited ftags))) + (and drawers (org-set-local 'org-drawers drawers)) + (and arch (org-set-local 'org-archive-location arch)) + (and links (setq org-link-abbrev-alist-local (nreverse links))) + ;; Process the TODO keywords + (unless kwds + ;; Use the global values as if they had been given locally. + (setq kwds (default-value 'org-todo-keywords)) + (if (stringp (car kwds)) + (setq kwds (list (cons org-todo-interpretation + (default-value 'org-todo-keywords))))) + (setq kwds (reverse kwds))) + (setq kwds (nreverse kwds)) + (let (inter kws kw) + (while (setq kws (pop kwds)) + (let ((kws (or + (run-hook-with-args-until-success + 'org-todo-setup-filter-hook kws) + kws))) + (setq inter (pop kws) sep (member "|" kws) + kws0 (delete "|" (copy-sequence kws)) + kwsa nil + kws1 (mapcar + (lambda (x) + ;; 1 2 + (if (string-match "^\\(.*?\\)\\(?:(\\([^!@/]\\)?.*?)\\)?$" x) + (progn + (setq kw (match-string 1 x) + key (and (match-end 2) (match-string 2 x)) + log (org-extract-log-state-settings x)) + (push (cons kw (and key (string-to-char key))) kwsa) + (and log (push log org-todo-log-states)) + kw) + (error "Invalid TODO keyword %s" x))) + kws0) + kwsa (if kwsa (append '((:startgroup)) + (nreverse kwsa) + '((:endgroup)))) + hw (car kws1) + dws (if sep (org-remove-keyword-keys (cdr sep)) (last kws1)) + tail (list inter hw (car dws) (org-last dws)))) + (add-to-list 'org-todo-heads hw 'append) + (push kws1 org-todo-sets) + (setq org-done-keywords (append org-done-keywords dws nil)) + (setq org-todo-key-alist (append org-todo-key-alist kwsa)) + (mapc (lambda (x) (push (cons x tail) org-todo-kwd-alist)) kws1) + (setq org-todo-keywords-1 (append org-todo-keywords-1 kws1 nil))) + (setq org-todo-sets (nreverse org-todo-sets) + org-todo-kwd-alist (nreverse org-todo-kwd-alist) + org-todo-key-trigger (delq nil (mapcar 'cdr org-todo-key-alist)) + org-todo-key-alist (org-assign-fast-keys org-todo-key-alist))) + ;; Process the constants + (when const + (let (e cst) + (while (setq e (pop const)) + (if (string-match "^\\([a-zA-Z0][_a-zA-Z0-9]*\\)=\\(.*\\)" e) + (push (cons (match-string 1 e) (match-string 2 e)) cst))) + (setq org-table-formula-constants-local cst))) + + ;; Process the tags. + (when tags + (let (e tgs) + (while (setq e (pop tags)) + (cond + ((equal e "{") (push '(:startgroup) tgs)) + ((equal e "}") (push '(:endgroup) tgs)) + ((equal e "\\n") (push '(:newline) tgs)) + ((string-match (org-re "^\\([[:alnum:]_@#%]+\\)(\\(.\\))$") e) + (push (cons (match-string 1 e) + (string-to-char (match-string 2 e))) + tgs)) + (t (push (list e) tgs)))) + (org-set-local 'org-tag-alist nil) + (while (setq e (pop tgs)) + (or (and (stringp (car e)) + (assoc (car e) org-tag-alist)) + (push e org-tag-alist))))) + + ;; Compute the regular expressions and other local variables + (if (not org-done-keywords) + (setq org-done-keywords (and org-todo-keywords-1 + (list (org-last org-todo-keywords-1))))) + (setq org-ds-keyword-length (+ 2 (max (length org-deadline-string) + (length org-scheduled-string) + (length org-clock-string) + (length org-closed-string))) + org-drawer-regexp + (concat "^[ \t]*:\\(" + (mapconcat 'regexp-quote org-drawers "\\|") + "\\):[ \t]*$") + org-not-done-keywords + (org-delete-all org-done-keywords (copy-sequence org-todo-keywords-1)) + org-todo-regexp + (concat "\\<\\(" (mapconcat 'regexp-quote org-todo-keywords-1 + "\\|") "\\)\\>") + org-not-done-regexp + (concat "\\<\\(" + (mapconcat 'regexp-quote org-not-done-keywords "\\|") + "\\)\\>") + org-not-done-heading-regexp + (concat "^\\(\\*+\\)[ \t]+\\(" + (mapconcat 'regexp-quote org-not-done-keywords "\\|") + "\\)\\>") + org-todo-line-regexp + (concat "^\\(\\*+\\)[ \t]+\\(?:\\(" + (mapconcat 'regexp-quote org-todo-keywords-1 "\\|") + "\\)\\>\\)?[ \t]*\\(.*\\)") + org-complex-heading-regexp + (concat "^\\(\\*+\\)[ \t]+\\(?:\\(" + (mapconcat 'regexp-quote org-todo-keywords-1 "\\|") + "\\)\\>\\)?\\(?:[ \t]*\\(\\[#.\\]\\)\\)?[ \t]*\\(.*?\\)" + "\\(?:[ \t]+\\(:[[:alnum:]_@#%:]+:\\)\\)?[ \t]*$") + org-complex-heading-regexp-format + (concat "^\\(\\*+\\)[ \t]+\\(?:\\(" + (mapconcat 'regexp-quote org-todo-keywords-1 "\\|") + "\\)\\>\\)?" + "\\(?:[ \t]*\\(\\[#.\\]\\)\\)?" + "\\(?:[ \t]*\\(?:\\[[0-9%%/]+\\]\\)\\)?" ;; stats cookie + "[ \t]*\\(%s\\)" + "\\(?:[ \t]*\\(?:\\[[0-9%%/]+\\]\\)\\)?" ;; stats cookie + "\\(?:[ \t]+\\(:[[:alnum:]_@#%%:]+:\\)\\)?[ \t]*$") + org-nl-done-regexp + (concat "\n\\*+[ \t]+" + "\\(?:" (mapconcat 'regexp-quote org-done-keywords "\\|") + "\\)" "\\>") + org-todo-line-tags-regexp + (concat "^\\(\\*+\\)[ \t]+\\(?:\\(" + (mapconcat 'regexp-quote org-todo-keywords-1 "\\|") + (org-re + "\\)\\>\\)? *\\(.*?\\([ \t]:[[:alnum:]:_@#%]+:[ \t]*\\)?$\\)")) + org-looking-at-done-regexp + (concat "^" "\\(?:" + (mapconcat 'regexp-quote org-done-keywords "\\|") "\\)" + "\\>") + org-deadline-regexp (concat "\\<" org-deadline-string) + org-deadline-time-regexp + (concat "\\<" org-deadline-string " *<\\([^>]+\\)>") + org-deadline-line-regexp + (concat "\\<\\(" org-deadline-string "\\).*") + org-scheduled-regexp + (concat "\\<" org-scheduled-string) + org-scheduled-time-regexp + (concat "\\<" org-scheduled-string " *<\\([^>]+\\)>") + org-closed-time-regexp + (concat "\\<" org-closed-string " *\\[\\([^]]+\\)\\]") + org-keyword-time-regexp + (concat "\\<\\(" org-scheduled-string + "\\|" org-deadline-string + "\\|" org-closed-string + "\\|" org-clock-string "\\)" + " *[[<]\\([^]>]+\\)[]>]") + org-keyword-time-not-clock-regexp + (concat "\\<\\(" org-scheduled-string + "\\|" org-deadline-string + "\\|" org-closed-string + "\\)" + " *[[<]\\([^]>]+\\)[]>]") + org-maybe-keyword-time-regexp + (concat "\\(\\<\\(" org-scheduled-string + "\\|" org-deadline-string + "\\|" org-closed-string + "\\|" org-clock-string "\\)\\)?" + " *\\([[<][0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\} [^]\r\n>]*?[]>]\\|<%%([^\r\n>]*>\\)") + org-planning-or-clock-line-re + (concat "\\(?:^[ \t]*\\(" org-scheduled-string + "\\|" org-deadline-string + "\\|" org-closed-string "\\|" org-clock-string + "\\)\\>\\)") + org-all-time-keywords + (mapcar (lambda (w) (substring w 0 -1)) + (list org-scheduled-string org-deadline-string + org-clock-string org-closed-string)) + ) + (org-compute-latex-and-specials-regexp) + (org-set-font-lock-defaults)))) + +(defun org-file-contents (file &optional noerror) + "Return the contents of FILE, as a string." + (if (or (not file) + (not (file-readable-p file))) + (if noerror + (progn + (message "Cannot read file \"%s\"" file) + (ding) (sit-for 2) + "") + (error "Cannot read file \"%s\"" file)) + (with-temp-buffer + (insert-file-contents file) + (buffer-string)))) + +(defun org-extract-log-state-settings (x) + "Extract the log state setting from a TODO keyword string. +This will extract info from a string like \"WAIT(w@/!)\"." + (let (kw key log1 log2) + (when (string-match "^\\(.*?\\)\\(?:(\\([^!@/]\\)?\\([!@]\\)?\\(?:/\\([!@]\\)\\)?)\\)?$" x) + (setq kw (match-string 1 x) + key (and (match-end 2) (match-string 2 x)) + log1 (and (match-end 3) (match-string 3 x)) + log2 (and (match-end 4) (match-string 4 x))) + (and (or log1 log2) + (list kw + (and log1 (if (equal log1 "!") 'time 'note)) + (and log2 (if (equal log2 "!") 'time 'note))))))) + +(defun org-remove-keyword-keys (list) + "Remove a pair of parenthesis at the end of each string in LIST." + (mapcar (lambda (x) + (if (string-match "(.*)$" x) + (substring x 0 (match-beginning 0)) + x)) + list)) + +(defun org-assign-fast-keys (alist) + "Assign fast keys to a keyword-key alist. +Respect keys that are already there." + (let (new e (alt ?0)) + (while (setq e (pop alist)) + (if (or (memq (car e) '(:newline :endgroup :startgroup)) + (cdr e)) ;; Key already assigned. + (push e new) + (let ((clist (string-to-list (downcase (car e)))) + (used (append new alist))) + (when (= (car clist) ?@) + (pop clist)) + (while (and clist (rassoc (car clist) used)) + (pop clist)) + (unless clist + (while (rassoc alt used) + (incf alt))) + (push (cons (car e) (or (car clist) alt)) new)))) + (nreverse new))) + +;;; Some variables used in various places + +(defvar org-window-configuration nil + "Used in various places to store a window configuration.") +(defvar org-selected-window nil + "Used in various places to store a window configuration.") +(defvar org-finish-function nil + "Function to be called when `C-c C-c' is used. +This is for getting out of special buffers like remember.") + + +;; FIXME: Occasionally check by commenting these, to make sure +;; no other functions uses these, forgetting to let-bind them. +(defvar entry) +(defvar last-state) +(defvar date) + +;; Defined somewhere in this file, but used before definition. +(defvar org-entities) ;; defined in org-entities.el +(defvar org-struct-menu) +(defvar org-org-menu) +(defvar org-tbl-menu) + +;;;; Define the Org-mode + +(if (and (not (keymapp outline-mode-map)) (featurep 'allout)) + (error "Conflict with outdated version of allout.el. Load org.el before allout.el, or upgrade to newer allout, for example by switching to Emacs 22")) + + +;; We use a before-change function to check if a table might need +;; an update. +(defvar org-table-may-need-update t + "Indicates that a table might need an update. +This variable is set by `org-before-change-function'. +`org-table-align' sets it back to nil.") +(defun org-before-change-function (beg end) + "Every change indicates that a table might need an update." + (setq org-table-may-need-update t)) +(defvar org-mode-map) +(defvar org-inhibit-startup nil) ; Dynamically-scoped param. +(defvar org-inhibit-startup-visibility-stuff nil) ; Dynamically-scoped param. +(defvar org-agenda-keep-modes nil) ; Dynamically-scoped param. +(defvar org-inhibit-logging nil) ; Dynamically-scoped param. +(defvar org-inhibit-blocking nil) ; Dynamically-scoped param. +(defvar org-table-buffer-is-an nil) +(defconst org-outline-regexp "\\*+ ") + +;;;###autoload +(define-derived-mode org-mode outline-mode "Org" + "Outline-based notes management and organizer, alias +\"Carsten's outline-mode for keeping track of everything.\" + +Org-mode develops organizational tasks around a NOTES file which +contains information about projects as plain text. Org-mode is +implemented on top of outline-mode, which is ideal to keep the content +of large files well structured. It supports ToDo items, deadlines and +time stamps, which magically appear in the diary listing of the Emacs +calendar. Tables are easily created with a built-in table editor. +Plain text URL-like links connect to websites, emails (VM), Usenet +messages (Gnus), BBDB entries, and any files related to the project. +For printing and sharing of notes, an Org-mode file (or a part of it) +can be exported as a structured ASCII or HTML file. + +The following commands are available: + +\\{org-mode-map}" + + ;; Get rid of Outline menus, they are not needed + ;; Need to do this here because define-derived-mode sets up + ;; the keymap so late. Still, it is a waste to call this each time + ;; we switch another buffer into org-mode. + (if (featurep 'xemacs) + (when (boundp 'outline-mode-menu-heading) + ;; Assume this is Greg's port, it uses easymenu + (easy-menu-remove outline-mode-menu-heading) + (easy-menu-remove outline-mode-menu-show) + (easy-menu-remove outline-mode-menu-hide)) + (define-key org-mode-map [menu-bar headings] 'undefined) + (define-key org-mode-map [menu-bar hide] 'undefined) + (define-key org-mode-map [menu-bar show] 'undefined)) + + (org-load-modules-maybe) + (easy-menu-add org-org-menu) + (easy-menu-add org-tbl-menu) + (org-install-agenda-files-menu) + (if org-descriptive-links (add-to-invisibility-spec '(org-link))) + (add-to-invisibility-spec '(org-cwidth)) + (add-to-invisibility-spec '(org-hide-block . t)) + (when (featurep 'xemacs) + (org-set-local 'line-move-ignore-invisible t)) + (org-set-local 'outline-regexp org-outline-regexp) + (org-set-local 'outline-level 'org-outline-level) + (when (and org-ellipsis + (fboundp 'set-display-table-slot) (boundp 'buffer-display-table) + (fboundp 'make-glyph-code)) + (unless org-display-table + (setq org-display-table (make-display-table))) + (set-display-table-slot + org-display-table 4 + (vconcat (mapcar + (lambda (c) (make-glyph-code c (and (not (stringp org-ellipsis)) + org-ellipsis))) + (if (stringp org-ellipsis) org-ellipsis "...")))) + (setq buffer-display-table org-display-table)) + (org-set-regexps-and-options) + (when (and org-tag-faces (not org-tags-special-faces-re)) + ;; tag faces set outside customize.... force initialization. + (org-set-tag-faces 'org-tag-faces org-tag-faces)) + ;; Calc embedded + (org-set-local 'calc-embedded-open-mode "# ") + (modify-syntax-entry ?@ "w") + (if org-startup-truncated (setq truncate-lines t)) + (org-set-local 'font-lock-unfontify-region-function + 'org-unfontify-region) + ;; Activate before-change-function + (org-set-local 'org-table-may-need-update t) + (org-add-hook 'before-change-functions 'org-before-change-function nil + 'local) + ;; Check for running clock before killing a buffer + (org-add-hook 'kill-buffer-hook 'org-check-running-clock nil 'local) + ;; Paragraphs and auto-filling + (org-set-autofill-regexps) + (setq indent-line-function 'org-indent-line-function) + (org-update-radio-target-regexp) + ;; Beginning/end of defun + (org-set-local 'beginning-of-defun-function 'org-beginning-of-defun) + (org-set-local 'end-of-defun-function 'org-end-of-defun) + ;; Make sure dependence stuff works reliably, even for users who set it + ;; too late :-( + (if org-enforce-todo-dependencies + (add-hook 'org-blocker-hook + 'org-block-todo-from-children-or-siblings-or-parent) + (remove-hook 'org-blocker-hook + 'org-block-todo-from-children-or-siblings-or-parent)) + (if org-enforce-todo-checkbox-dependencies + (add-hook 'org-blocker-hook + 'org-block-todo-from-checkboxes) + (remove-hook 'org-blocker-hook + 'org-block-todo-from-checkboxes)) + + ;; Comment characters + (org-set-local 'comment-start "#") + (org-set-local 'comment-padding " ") + + ;; Align options lines + (org-set-local + 'align-mode-rules-list + '((org-in-buffer-settings + (regexp . "^#\\+[A-Z_]+:\\(\\s-*\\)\\S-+") + (modes . '(org-mode))))) + + ;; Imenu + (org-set-local 'imenu-create-index-function + 'org-imenu-get-tree) + + ;; Make isearch reveal context + (if (or (featurep 'xemacs) + (not (boundp 'outline-isearch-open-invisible-function))) + ;; Emacs 21 and XEmacs make use of the hook + (org-add-hook 'isearch-mode-end-hook 'org-isearch-end 'append 'local) + ;; Emacs 22 deals with this through a special variable + (org-set-local 'outline-isearch-open-invisible-function + (lambda (&rest ignore) (org-show-context 'isearch)))) + + ;; Turn on org-beamer-mode? + (and org-startup-with-beamer-mode (org-beamer-mode 1)) + + ;; Setup the pcomplete hooks + (set (make-local-variable 'pcomplete-command-completion-function) + 'org-complete-initial) + (set (make-local-variable 'pcomplete-command-name-function) + 'org-command-at-point) + (set (make-local-variable 'pcomplete-default-completion-function) + 'ignore) + (set (make-local-variable 'pcomplete-parse-arguments-function) + 'org-parse-arguments) + (set (make-local-variable 'pcomplete-termination-string) "") + + ;; If empty file that did not turn on org-mode automatically, make it to. + (if (and org-insert-mode-line-in-empty-file + (interactive-p) + (= (point-min) (point-max))) + (insert "# -*- mode: org -*-\n\n")) + (unless org-inhibit-startup + (when org-startup-align-all-tables + (let ((bmp (buffer-modified-p))) + (org-table-map-tables 'org-table-align 'quietly) + (set-buffer-modified-p bmp))) + (when org-startup-with-inline-images + (org-display-inline-images)) + (when org-startup-indented + (require 'org-indent) + (org-indent-mode 1)) + (unless org-inhibit-startup-visibility-stuff + (org-set-startup-visibility)))) + +(when (fboundp 'abbrev-table-put) + (abbrev-table-put org-mode-abbrev-table + :parents (list text-mode-abbrev-table))) + +(put 'org-mode 'flyspell-mode-predicate 'org-mode-flyspell-verify) + +(defun org-current-time () + "Current time, possibly rounded to `org-time-stamp-rounding-minutes'." + (if (> (car org-time-stamp-rounding-minutes) 1) + (let ((r (car org-time-stamp-rounding-minutes)) + (time (decode-time))) + (apply 'encode-time + (append (list 0 (* r (floor (+ .5 (/ (float (nth 1 time)) r))))) + (nthcdr 2 time)))) + (current-time))) + +(defun org-today () + "Return today date, considering `org-extend-today-until'." + (time-to-days + (time-subtract (current-time) + (list 0 (* 3600 org-extend-today-until) 0)))) + +;;;; Font-Lock stuff, including the activators + +(defvar org-mouse-map (make-sparse-keymap)) +(org-defkey org-mouse-map [mouse-2] 'org-open-at-mouse) +(org-defkey org-mouse-map [mouse-3] 'org-find-file-at-mouse) +(when org-mouse-1-follows-link + (org-defkey org-mouse-map [follow-link] 'mouse-face)) +(when org-tab-follows-link + (org-defkey org-mouse-map [(tab)] 'org-open-at-point) + (org-defkey org-mouse-map "\C-i" 'org-open-at-point)) + +(require 'font-lock) + +(defconst org-non-link-chars "]\t\n\r<>") +(defvar org-link-types '("http" "https" "ftp" "mailto" "file" "news" + "shell" "elisp" "doi" "message")) +(defvar org-link-types-re nil + "Matches a link that has a url-like prefix like \"http:\"") +(defvar org-link-re-with-space nil + "Matches a link with spaces, optional angular brackets around it.") +(defvar org-link-re-with-space2 nil + "Matches a link with spaces, optional angular brackets around it.") +(defvar org-link-re-with-space3 nil + "Matches a link with spaces, only for internal part in bracket links.") +(defvar org-angle-link-re nil + "Matches link with angular brackets, spaces are allowed.") +(defvar org-plain-link-re nil + "Matches plain link, without spaces.") +(defvar org-bracket-link-regexp nil + "Matches a link in double brackets.") +(defvar org-bracket-link-analytic-regexp nil + "Regular expression used to analyze links. +Here is what the match groups contain after a match: +1: http: +2: http +3: path +4: [desc] +5: desc") +(defvar org-bracket-link-analytic-regexp++ nil + "Like `org-bracket-link-analytic-regexp', but include coderef internal type.") +(defvar org-any-link-re nil + "Regular expression matching any link.") + +(defcustom org-match-sexp-depth 3 + "Number of stacked braces for sub/superscript matching. +This has to be set before loading org.el to be effective." + :group 'org-export-translation ; ??????????????????????????/ + :type 'integer) + +(defun org-create-multibrace-regexp (left right n) + "Create a regular expression which will match a balanced sexp. +Opening delimiter is LEFT, and closing delimiter is RIGHT, both given +as single character strings. +The regexp returned will match the entire expression including the +delimiters. It will also define a single group which contains the +match except for the outermost delimiters. The maximum depth of +stacked delimiters is N. Escaping delimiters is not possible." + (let* ((nothing (concat "[^" left right "]*?")) + (or "\\|") + (re nothing) + (next (concat "\\(?:" nothing left nothing right "\\)+" nothing))) + (while (> n 1) + (setq n (1- n) + re (concat re or next) + next (concat "\\(?:" nothing left next right "\\)+" nothing))) + (concat left "\\(" re "\\)" right))) + +(defvar org-match-substring-regexp + (concat + "\\([^\\]\\)\\([_^]\\)\\(" + "\\(" (org-create-multibrace-regexp "{" "}" org-match-sexp-depth) "\\)" + "\\|" + "\\(" (org-create-multibrace-regexp "(" ")" org-match-sexp-depth) "\\)" + "\\|" + "\\(\\(?:\\*\\|[-+]?[^-+*!@#$%^_ \t\r\n,:\"?<>~;./{}=()]+\\)\\)\\)") + "The regular expression matching a sub- or superscript.") + +(defvar org-match-substring-with-braces-regexp + (concat + "\\([^\\]\\)\\([_^]\\)\\(" + "\\(" (org-create-multibrace-regexp "{" "}" org-match-sexp-depth) "\\)" + "\\)") + "The regular expression matching a sub- or superscript, forcing braces.") + +(defun org-make-link-regexps () + "Update the link regular expressions. +This should be called after the variable `org-link-types' has changed." + (setq org-link-types-re + (concat + "\\`\\(" (mapconcat 'regexp-quote org-link-types "\\|") "\\):") + org-link-re-with-space + (concat + "<?\\(" (mapconcat 'regexp-quote org-link-types "\\|") "\\):" + "\\([^" org-non-link-chars " ]" + "[^" org-non-link-chars "]*" + "[^" org-non-link-chars " ]\\)>?") + org-link-re-with-space2 + (concat + "<?\\(" (mapconcat 'regexp-quote org-link-types "\\|") "\\):" + "\\([^" org-non-link-chars " ]" + "[^\t\n\r]*" + "[^" org-non-link-chars " ]\\)>?") + org-link-re-with-space3 + (concat + "<?\\(" (mapconcat 'regexp-quote org-link-types "\\|") "\\):" + "\\([^" org-non-link-chars " ]" + "[^\t\n\r]*\\)") + org-angle-link-re + (concat + "<\\(" (mapconcat 'regexp-quote org-link-types "\\|") "\\):" + "\\([^" org-non-link-chars " ]" + "[^" org-non-link-chars "]*" + "\\)>") + org-plain-link-re + (concat + "\\<\\(" (mapconcat 'regexp-quote org-link-types "\\|") "\\):" + (org-re "\\([^ \t\n()<>]+\\(?:([[:word:]0-9_]+)\\|\\([^[:punct:] \t\n]\\|/\\)\\)\\)")) + ;; "\\([^]\t\n\r<>() ]+[^]\t\n\r<>,.;() ]\\)") + org-bracket-link-regexp + "\\[\\[\\([^][]+\\)\\]\\(\\[\\([^][]+\\)\\]\\)?\\]" + org-bracket-link-analytic-regexp + (concat + "\\[\\[" + "\\(\\(" (mapconcat 'regexp-quote org-link-types "\\|") "\\):\\)?" + "\\([^]]+\\)" + "\\]" + "\\(\\[" "\\([^]]+\\)" "\\]\\)?" + "\\]") + org-bracket-link-analytic-regexp++ + (concat + "\\[\\[" + "\\(\\(" (mapconcat 'regexp-quote (cons "coderef" org-link-types) "\\|") "\\):\\)?" + "\\([^]]+\\)" + "\\]" + "\\(\\[" "\\([^]]+\\)" "\\]\\)?" + "\\]") + org-any-link-re + (concat "\\(" org-bracket-link-regexp "\\)\\|\\(" + org-angle-link-re "\\)\\|\\(" + org-plain-link-re "\\)"))) + +(org-make-link-regexps) + +(defconst org-ts-regexp "<\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\} [^\r\n>]*?\\)>" + "Regular expression for fast time stamp matching.") +(defconst org-ts-regexp-both "[[<]\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\} [^\r\n>]*?\\)[]>]" + "Regular expression for fast time stamp matching.") +(defconst org-ts-regexp0 "\\(\\([0-9]\\{4\\}\\)-\\([0-9]\\{2\\}\\)-\\([0-9]\\{2\\}\\) *\\([^]-+0-9>\r\n ]*\\)\\( \\([0-9]\\{2\\}\\):\\([0-9]\\{2\\}\\)\\)?\\)" + "Regular expression matching time strings for analysis. +This one does not require the space after the date, so it can be used +on a string that terminates immediately after the date.") +(defconst org-ts-regexp1 "\\(\\([0-9]\\{4\\}\\)-\\([0-9]\\{2\\}\\)-\\([0-9]\\{2\\}\\) +\\([^]-+0-9>\r\n ]*\\)\\( \\([0-9]\\{2\\}\\):\\([0-9]\\{2\\}\\)\\)?\\)" + "Regular expression matching time strings for analysis.") +(defconst org-ts-regexp2 (concat "<" org-ts-regexp1 "[^>\n]\\{0,16\\}>") + "Regular expression matching time stamps, with groups.") +(defconst org-ts-regexp3 (concat "[[<]" org-ts-regexp1 "[^]>\n]\\{0,16\\}[]>]") + "Regular expression matching time stamps (also [..]), with groups.") +(defconst org-tr-regexp (concat org-ts-regexp "--?-?" org-ts-regexp) + "Regular expression matching a time stamp range.") +(defconst org-tr-regexp-both + (concat org-ts-regexp-both "--?-?" org-ts-regexp-both) + "Regular expression matching a time stamp range.") +(defconst org-tsr-regexp (concat org-ts-regexp "\\(--?-?" + org-ts-regexp "\\)?") + "Regular expression matching a time stamp or time stamp range.") +(defconst org-tsr-regexp-both (concat org-ts-regexp-both "\\(--?-?" + org-ts-regexp-both "\\)?") + "Regular expression matching a time stamp or time stamp range. +The time stamps may be either active or inactive.") + +(defvar org-emph-face nil) + +(defun org-do-emphasis-faces (limit) + "Run through the buffer and add overlays to links." + (let (rtn a) + (while (and (not rtn) (re-search-forward org-emph-re limit t)) + (if (not (= (char-after (match-beginning 3)) + (char-after (match-beginning 4)))) + (progn + (setq rtn t) + (setq a (assoc (match-string 3) org-emphasis-alist)) + (font-lock-prepend-text-property (match-beginning 2) (match-end 2) + 'face + (nth 1 a)) + (and (nth 4 a) + (org-remove-flyspell-overlays-in + (match-beginning 0) (match-end 0))) + (add-text-properties (match-beginning 2) (match-end 2) + '(font-lock-multiline t org-emphasis t)) + (when org-hide-emphasis-markers + (add-text-properties (match-end 4) (match-beginning 5) + '(invisible org-link)) + (add-text-properties (match-beginning 3) (match-end 3) + '(invisible org-link))))) + (backward-char 1)) + rtn)) + +(defun org-emphasize (&optional char) + "Insert or change an emphasis, i.e. a font like bold or italic. +If there is an active region, change that region to a new emphasis. +If there is no region, just insert the marker characters and position +the cursor between them. +CHAR should be either the marker character, or the first character of the +HTML tag associated with that emphasis. If CHAR is a space, the means +to remove the emphasis of the selected region. +If char is not given (for example in an interactive call) it +will be prompted for." + (interactive) + (let ((eal org-emphasis-alist) e det + (erc org-emphasis-regexp-components) + (prompt "") + (string "") beg end move tag c s) + (if (org-region-active-p) + (setq beg (region-beginning) end (region-end) + string (buffer-substring beg end)) + (setq move t)) + + (while (setq e (pop eal)) + (setq tag (car (org-split-string (nth 2 e) "[ <>/]+")) + c (aref tag 0)) + (push (cons c (string-to-char (car e))) det) + (setq prompt (concat prompt (format " [%s%c]%s" (car e) c + (substring tag 1))))) + (setq det (nreverse det)) + (unless char + (message "%s" (concat "Emphasis marker or tag:" prompt)) + (setq char (read-char-exclusive))) + (setq char (or (cdr (assoc char det)) char)) + (if (equal char ?\ ) + (setq s "" move nil) + (unless (assoc (char-to-string char) org-emphasis-alist) + (error "No such emphasis marker: \"%c\"" char)) + (setq s (char-to-string char))) + (while (and (> (length string) 1) + (equal (substring string 0 1) (substring string -1)) + (assoc (substring string 0 1) org-emphasis-alist)) + (setq string (substring string 1 -1))) + (setq string (concat s string s)) + (if beg (delete-region beg end)) + (unless (or (bolp) + (string-match (concat "[" (nth 0 erc) "\n]") + (char-to-string (char-before (point))))) + (insert " ")) + (unless (or (eobp) + (string-match (concat "[" (nth 1 erc) "\n]") + (char-to-string (char-after (point))))) + (insert " ") (backward-char 1)) + (insert string) + (and move (backward-char 1)))) + +(defconst org-nonsticky-props + '(mouse-face highlight keymap invisible intangible help-echo org-linked-text)) + +(defsubst org-rear-nonsticky-at (pos) + (add-text-properties (1- pos) pos (list 'rear-nonsticky org-nonsticky-props))) + +(defun org-activate-plain-links (limit) + "Run through the buffer and add overlays to links." + (catch 'exit + (let (f) + (if (re-search-forward org-plain-link-re limit t) + (progn + (org-remove-flyspell-overlays-in (match-beginning 0) (match-end 0)) + (setq f (get-text-property (match-beginning 0) 'face)) + (if (or (eq f 'org-tag) + (and (listp f) (memq 'org-tag f))) + nil + (add-text-properties (match-beginning 0) (match-end 0) + (list 'mouse-face 'highlight + 'face 'org-link + 'keymap org-mouse-map)) + (org-rear-nonsticky-at (match-end 0))) + t))))) + +(defun org-activate-code (limit) + (if (re-search-forward "^[ \t]*\\(: .*\n?\\)" limit t) + (progn + (org-remove-flyspell-overlays-in (match-beginning 0) (match-end 0)) + (remove-text-properties (match-beginning 0) (match-end 0) + '(display t invisible t intangible t)) + t))) + +(defcustom org-src-fontify-natively nil + "When non-nil, fontify code in code blocks." + :type 'boolean + :group 'org-appearance + :group 'org-babel) + +(defun org-fontify-meta-lines-and-blocks (limit) + "Fontify #+ lines and blocks, in the correct ways." + (let ((case-fold-search t)) + (if (re-search-forward + "^\\([ \t]*#\\+\\(\\([a-zA-Z]+:?\\| \\|$\\)\\(_\\([a-zA-Z]+\\)\\)?\\)[ \t]*\\(\\([^ \t\n]*\\)[ \t]*\\(.*\\)\\)\\)" + limit t) + (let ((beg (match-beginning 0)) + (block-start (match-end 0)) + (block-end nil) + (lang (match-string 7)) + (beg1 (line-beginning-position 2)) + (dc1 (downcase (match-string 2))) + (dc3 (downcase (match-string 3))) + end end1 quoting block-type) + (cond + ((member dc1 '("html:" "ascii:" "latex:" "docbook:")) + ;; a single line of backend-specific content + (org-remove-flyspell-overlays-in (match-beginning 0) (match-end 0)) + (remove-text-properties (match-beginning 0) (match-end 0) + '(display t invisible t intangible t)) + (add-text-properties (match-beginning 1) (match-end 3) + '(font-lock-fontified t face org-meta-line)) + (add-text-properties (match-beginning 6) (+ (match-end 6) 1) + '(font-lock-fontified t face org-block)) + ; for backend-specific code + t) + ((and (match-end 4) (equal dc3 "begin")) + ;; Truly a block + (setq block-type (downcase (match-string 5)) + quoting (member block-type org-protecting-blocks)) + (when (re-search-forward + (concat "^[ \t]*#\\+end" (match-string 4) "\\>.*") + nil t) ;; on purpose, we look further than LIMIT + (setq end (match-end 0) end1 (1- (match-beginning 0))) + (setq block-end (match-beginning 0)) + (when quoting + (remove-text-properties beg end + '(display t invisible t intangible t))) + (add-text-properties + beg end + '(font-lock-fontified t font-lock-multiline t)) + (add-text-properties beg beg1 '(face org-meta-line)) + (add-text-properties end1 (+ end 1) '(face org-meta-line)) + ; for end_src + (cond + ((and lang org-src-fontify-natively) + (org-src-font-lock-fontify-block lang block-start block-end)) + (quoting + (add-text-properties beg1 (+ end1 1) '(face + org-block))) + ; end of source block + ((not org-fontify-quote-and-verse-blocks)) + ((string= block-type "quote") + (add-text-properties beg1 end1 '(face org-quote))) + ((string= block-type "verse") + (add-text-properties beg1 end1 '(face org-verse)))) + t)) + ((member dc1 '("title:" "author:" "email:" "date:")) + (add-text-properties + beg (match-end 3) + (if (member (intern (substring dc1 0 -1)) org-hidden-keywords) + '(font-lock-fontified t invisible t) + '(font-lock-fontified t face org-document-info-keyword))) + (add-text-properties + (match-beginning 6) (match-end 6) + (if (string-equal dc1 "title:") + '(font-lock-fontified t face org-document-title) + '(font-lock-fontified t face org-document-info)))) + ((not (member (char-after beg) '(?\ ?\t))) + ;; just any other in-buffer setting, but not indented + (add-text-properties + beg (match-end 0) + '(font-lock-fontified t face org-meta-line)) + t) + ((or (member dc1 '("begin:" "end:" "caption:" "label:" + "orgtbl:" "tblfm:" "tblname:" "result:" + "results:" "source:" "srcname:" "call:")) + (and (match-end 4) (equal dc3 "attr"))) + (add-text-properties + beg (match-end 0) + '(font-lock-fontified t face org-meta-line)) + t) + ((member dc3 '(" " "")) + (add-text-properties + beg (match-end 0) + '(font-lock-fontified t face font-lock-comment-face))) + (t nil)))))) + +(defun org-activate-angle-links (limit) + "Run through the buffer and add overlays to links." + (if (re-search-forward org-angle-link-re limit t) + (progn + (org-remove-flyspell-overlays-in (match-beginning 0) (match-end 0)) + (add-text-properties (match-beginning 0) (match-end 0) + (list 'mouse-face 'highlight + 'keymap org-mouse-map)) + (org-rear-nonsticky-at (match-end 0)) + t))) + +(defun org-activate-footnote-links (limit) + "Run through the buffer and add overlays to links." + (if (re-search-forward "\\(^\\|[^][]\\)\\(\\[\\([0-9]+\\]\\|fn:[^ \t\r\n:]+?[]:]\\)\\)" + limit t) + (progn + (org-remove-flyspell-overlays-in (match-beginning 0) (match-end 0)) + (add-text-properties (match-beginning 2) (match-end 2) + (list 'mouse-face 'highlight + 'keymap org-mouse-map + 'help-echo + (if (= (point-at-bol) (match-beginning 2)) + "Footnote definition" + "Footnote reference") + )) + (org-rear-nonsticky-at (match-end 2)) + t))) + +(defun org-activate-bracket-links (limit) + "Run through the buffer and add overlays to bracketed links." + (if (re-search-forward org-bracket-link-regexp limit t) + (let* ((help (concat "LINK: " + (org-match-string-no-properties 1))) + ;; FIXME: above we should remove the escapes. + ;; but that requires another match, protecting match data, + ;; a lot of overhead for font-lock. + (ip (org-maybe-intangible + (list 'invisible 'org-link + 'keymap org-mouse-map 'mouse-face 'highlight + 'font-lock-multiline t 'help-echo help))) + (vp (list 'keymap org-mouse-map 'mouse-face 'highlight + 'font-lock-multiline t 'help-echo help))) + ;; We need to remove the invisible property here. Table narrowing + ;; may have made some of this invisible. + (org-remove-flyspell-overlays-in (match-beginning 0) (match-end 0)) + (remove-text-properties (match-beginning 0) (match-end 0) + '(invisible nil)) + (if (match-end 3) + (progn + (add-text-properties (match-beginning 0) (match-beginning 3) ip) + (org-rear-nonsticky-at (match-beginning 3)) + (add-text-properties (match-beginning 3) (match-end 3) vp) + (org-rear-nonsticky-at (match-end 3)) + (add-text-properties (match-end 3) (match-end 0) ip) + (org-rear-nonsticky-at (match-end 0))) + (add-text-properties (match-beginning 0) (match-beginning 1) ip) + (org-rear-nonsticky-at (match-beginning 1)) + (add-text-properties (match-beginning 1) (match-end 1) vp) + (org-rear-nonsticky-at (match-end 1)) + (add-text-properties (match-end 1) (match-end 0) ip) + (org-rear-nonsticky-at (match-end 0))) + t))) + +(defun org-activate-dates (limit) + "Run through the buffer and add overlays to dates." + (if (re-search-forward org-tsr-regexp-both limit t) + (progn + (org-remove-flyspell-overlays-in (match-beginning 0) (match-end 0)) + (add-text-properties (match-beginning 0) (match-end 0) + (list 'mouse-face 'highlight + 'keymap org-mouse-map)) + (org-rear-nonsticky-at (match-end 0)) + (when org-display-custom-times + (if (match-end 3) + (org-display-custom-time (match-beginning 3) (match-end 3))) + (org-display-custom-time (match-beginning 1) (match-end 1))) + t))) + +(defvar org-target-link-regexp nil + "Regular expression matching radio targets in plain text.") +(make-variable-buffer-local 'org-target-link-regexp) +(defvar org-target-regexp "<<\\([^<>\n\r]+\\)>>" + "Regular expression matching a link target.") +(defvar org-radio-target-regexp "<<<\\([^<>\n\r]+\\)>>>" + "Regular expression matching a radio target.") +(defvar org-any-target-regexp "<<<?\\([^<>\n\r]+\\)>>>?" ; FIXME, not exact, would match <<<aaa>> as a radio target. + "Regular expression matching any target.") + +(defun org-activate-target-links (limit) + "Run through the buffer and add overlays to target matches." + (when org-target-link-regexp + (let ((case-fold-search t)) + (if (re-search-forward org-target-link-regexp limit t) + (progn + (org-remove-flyspell-overlays-in (match-beginning 0) (match-end 0)) + (add-text-properties (match-beginning 0) (match-end 0) + (list 'mouse-face 'highlight + 'keymap org-mouse-map + 'help-echo "Radio target link" + 'org-linked-text t)) + (org-rear-nonsticky-at (match-end 0)) + t))))) + +(defun org-update-radio-target-regexp () + "Find all radio targets in this file and update the regular expression." + (interactive) + (when (memq 'radio org-activate-links) + (setq org-target-link-regexp + (org-make-target-link-regexp (org-all-targets 'radio))) + (org-restart-font-lock))) + +(defun org-hide-wide-columns (limit) + (let (s e) + (setq s (text-property-any (point) (or limit (point-max)) + 'org-cwidth t)) + (when s + (setq e (next-single-property-change s 'org-cwidth)) + (add-text-properties s e (org-maybe-intangible '(invisible org-cwidth))) + (goto-char e) + t))) + +(defvar org-latex-and-specials-regexp nil + "Regular expression for highlighting export special stuff.") +(defvar org-match-substring-regexp) +(defvar org-match-substring-with-braces-regexp) + +;; This should be with the exporter code, but we also use if for font-locking +(defconst org-export-html-special-string-regexps + '(("\\\\-" . "­") + ("---\\([^-]\\)" . "—\\1") + ("--\\([^-]\\)" . "–\\1") + ("\\.\\.\\." . "…")) + "Regular expressions for special string conversion.") + + +(defun org-compute-latex-and-specials-regexp () + "Compute regular expression for stuff treated specially by exporters." + (if (not org-highlight-latex-fragments-and-specials) + (org-set-local 'org-latex-and-specials-regexp nil) + (require 'org-exp) + (let* + ((matchers (plist-get org-format-latex-options :matchers)) + (latexs (delq nil (mapcar (lambda (x) (if (member (car x) matchers) x)) + org-latex-regexps))) + (org-export-allow-BIND nil) + (options (org-combine-plists (org-default-export-plist) + (org-infile-export-plist))) + (org-export-with-sub-superscripts (plist-get options :sub-superscript)) + (org-export-with-LaTeX-fragments (plist-get options :LaTeX-fragments)) + (org-export-with-TeX-macros (plist-get options :TeX-macros)) + (org-export-html-expand (plist-get options :expand-quoted-html)) + (org-export-with-special-strings (plist-get options :special-strings)) + (re-sub + (cond + ((equal org-export-with-sub-superscripts '{}) + (list org-match-substring-with-braces-regexp)) + (org-export-with-sub-superscripts + (list org-match-substring-regexp)) + (t nil))) + (re-latex + (if org-export-with-LaTeX-fragments + (mapcar (lambda (x) (nth 1 x)) latexs))) + (re-macros + (if org-export-with-TeX-macros + (list (concat "\\\\" + (regexp-opt + (append + + (delq nil + (mapcar 'car-safe + (append org-entities-user + org-entities))) + (if (boundp 'org-latex-entities) + (mapcar (lambda (x) + (or (car-safe x) x)) + org-latex-entities) + nil)) + 'words))) ; FIXME + )) + ;; (list "\\\\\\(?:[a-zA-Z]+\\)"))) + (re-special (if org-export-with-special-strings + (mapcar (lambda (x) (car x)) + org-export-html-special-string-regexps))) + (re-rest + (delq nil + (list + (if org-export-html-expand "@<[^>\n]+>") + )))) + (org-set-local + 'org-latex-and-specials-regexp + (mapconcat 'identity (append re-latex re-sub re-macros re-special + re-rest) "\\|"))))) + +(defun org-do-latex-and-special-faces (limit) + "Run through the buffer and add overlays to links." + (when org-latex-and-specials-regexp + (let (rtn d) + (while (and (not rtn) (re-search-forward org-latex-and-specials-regexp + limit t)) + (if (not (memq (car-safe (get-text-property (1+ (match-beginning 0)) + 'face)) + '(org-code org-verbatim underline))) + (progn + (setq rtn t + d (cond ((member (char-after (1+ (match-beginning 0))) + '(?_ ?^)) 1) + (t 0))) + (font-lock-prepend-text-property + (+ d (match-beginning 0)) (match-end 0) + 'face 'org-latex-and-export-specials) + (add-text-properties (+ d (match-beginning 0)) (match-end 0) + '(font-lock-multiline t))))) + rtn))) + +(defun org-restart-font-lock () + "Restart `font-lock-mode', to force refontification." + (when (and (boundp 'font-lock-mode) font-lock-mode) + (font-lock-mode -1) + (font-lock-mode 1))) + +(defun org-all-targets (&optional radio) + "Return a list of all targets in this file. +With optional argument RADIO, only find radio targets." + (let ((re (if radio org-radio-target-regexp org-target-regexp)) + rtn) + (save-excursion + (goto-char (point-min)) + (while (re-search-forward re nil t) + (add-to-list 'rtn (downcase (org-match-string-no-properties 1)))) + rtn))) + +(defun org-make-target-link-regexp (targets) + "Make regular expression matching all strings in TARGETS. +The regular expression finds the targets also if there is a line break +between words." + (and targets + (concat + "\\<\\(" + (mapconcat + (lambda (x) + (while (string-match " +" x) + (setq x (replace-match "\\s-+" t t x))) + x) + targets + "\\|") + "\\)\\>"))) + +(defun org-activate-tags (limit) + (if (re-search-forward (org-re "^\\*+.*[ \t]\\(:[[:alnum:]_@#%:]+:\\)[ \r\n]") limit t) + (progn + (org-remove-flyspell-overlays-in (match-beginning 1) (match-end 1)) + (add-text-properties (match-beginning 1) (match-end 1) + (list 'mouse-face 'highlight + 'keymap org-mouse-map)) + (org-rear-nonsticky-at (match-end 1)) + t))) + +(defun org-outline-level () + "Compute the outline level of the heading at point. +This function assumes that the cursor is at the beginning of a line matched +by `outline-regexp'. Otherwise it returns garbage. +If this is called at a normal headline, the level is the number of stars. +Use `org-reduced-level' to remove the effect of `org-odd-levels'. +For plain list items, if they are matched by `outline-regexp', this returns +1000 plus the line indentation." + (save-excursion + (looking-at outline-regexp) + (if (match-beginning 1) + (+ (org-get-string-indentation (match-string 1)) 1000) + (1- (- (match-end 0) (match-beginning 0)))))) + +(defvar org-font-lock-keywords nil) + +(defconst org-property-re (org-re "^[ \t]*\\(:\\([-[:alnum:]_]+\\):\\)[ \t]*\\([^ \t\r\n].*\\)") + "Regular expression matching a property line.") + +(defvar org-font-lock-hook nil + "Functions to be called for special font lock stuff.") + +(defvar org-font-lock-set-keywords-hook nil + "Functions that can manipulate `org-font-lock-extra-keywords'. +This is calles after `org-font-lock-extra-keywords' is defined, but before +it is installed to be used by font lock. This can be useful if something +needs to be inserted at a specific position in the font-lock sequence.") + +(defun org-font-lock-hook (limit) + (run-hook-with-args 'org-font-lock-hook limit)) + +(defun org-set-font-lock-defaults () + (let* ((em org-fontify-emphasized-text) + (lk org-activate-links) + (org-font-lock-extra-keywords + (list + ;; Call the hook + '(org-font-lock-hook) + ;; Headlines + `(,(if org-fontify-whole-heading-line + "^\\(\\**\\)\\(\\* \\)\\(.*\n?\\)" + "^\\(\\**\\)\\(\\* \\)\\(.*\\)") + (1 (org-get-level-face 1)) + (2 (org-get-level-face 2)) + (3 (org-get-level-face 3))) + ;; Table lines + '("^[ \t]*\\(\\(|\\|\\+-[-+]\\).*\\S-\\)" + (1 'org-table t)) + ;; Table internals + '("^[ \t]*|\\(?:.*?|\\)? *\\(:?=[^|\n]*\\)" (1 'org-formula t)) + '("^[ \t]*| *\\([#*]\\) *|" (1 'org-formula t)) + '("^[ \t]*|\\( *\\([$!_^/]\\) *|.*\\)|" (1 'org-formula t)) + '("| *\\(<[lrc]?[0-9]*>\\)" (1 'org-formula t)) + ;; Drawers + (list org-drawer-regexp '(0 'org-special-keyword t)) + (list "^[ \t]*:END:" '(0 'org-special-keyword t)) + ;; Properties + (list org-property-re + '(1 'org-special-keyword t) + '(3 'org-property-value t)) + ;; Links + (if (memq 'tag lk) '(org-activate-tags (1 'org-tag prepend))) + (if (memq 'angle lk) '(org-activate-angle-links (0 'org-link t))) + (if (memq 'plain lk) '(org-activate-plain-links)) + (if (memq 'bracket lk) '(org-activate-bracket-links (0 'org-link t))) + (if (memq 'radio lk) '(org-activate-target-links (0 'org-link t))) + (if (memq 'date lk) '(org-activate-dates (0 'org-date t))) + (if (memq 'footnote lk) '(org-activate-footnote-links + (2 'org-footnote t))) + '("^&?%%(.*\\|<%%([^>\n]*?>" (0 'org-sexp-date t)) + '(org-hide-wide-columns (0 nil append)) + ;; TODO lines + (list (concat "^\\*+[ \t]+" org-todo-regexp "\\([ \t]\\|$\\)") + '(1 (org-get-todo-face 1) t)) + ;; DONE + (if org-fontify-done-headline + (list (concat "^[*]+ +\\<\\(" + (mapconcat 'regexp-quote org-done-keywords "\\|") + "\\)\\(.*\\)") + '(2 'org-headline-done t)) + nil) + ;; Priorities + '(org-font-lock-add-priority-faces) + ;; Tags + '(org-font-lock-add-tag-faces) + ;; Special keywords + (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)) + (list (concat "\\<" org-clock-string) '(0 'org-special-keyword t)) + ;; Emphasis + (if em + (if (featurep 'xemacs) + '(org-do-emphasis-faces (0 nil append)) + '(org-do-emphasis-faces))) + ;; Checkboxes + '("^[ \t]*\\(?:[-+*]\\|[0-9]+[.)]\\)[ \t]+\\(?:\\[@\\(?:start:\\)?[0-9]+\\][ \t]*\\)?\\(\\[[- X]\\]\\)" + 1 'org-checkbox prepend) + (if (cdr (assq 'checkbox org-list-automatic-rules)) + '("\\[\\([0-9]*%\\)\\]\\|\\[\\([0-9]*\\)/\\([0-9]*\\)\\]" + (0 (org-get-checkbox-statistics-face) t))) + ;; Description list items + '("^[ \t]*\\([-+*]\\|[0-9]+[.)]\\)[ \t]+\\(.*? ::\\)" + 2 'bold prepend) + ;; ARCHIVEd headings + (list (concat "^\\*+ \\(.*:" org-archive-tag ":.*\\)") + '(1 'org-archived prepend)) + ;; Specials + '(org-do-latex-and-special-faces) + '(org-fontify-entities) + '(org-raise-scripts) + ;; Code + '(org-activate-code (1 'org-code t)) + ;; COMMENT + (list (concat "^\\*+[ \t]+\\<\\(" org-comment-string + "\\|" org-quote-string "\\)\\>") + '(1 'org-special-keyword t)) + '("^#.*" (0 'font-lock-comment-face t)) + ;; Blocks and meta lines + '(org-fontify-meta-lines-and-blocks) + ))) + (setq org-font-lock-extra-keywords (delq nil org-font-lock-extra-keywords)) + (run-hooks 'org-font-lock-set-keywords-hook) + ;; Now set the full font-lock-keywords + (org-set-local 'org-font-lock-keywords org-font-lock-extra-keywords) + (org-set-local 'font-lock-defaults + '(org-font-lock-keywords t nil nil backward-paragraph)) + (kill-local-variable 'font-lock-keywords) nil)) + +(defun org-toggle-pretty-entities () + "Toggle the composition display of entities as UTF8 characters." + (interactive) + (org-set-local 'org-pretty-entities (not org-pretty-entities)) + (org-restart-font-lock) + (if org-pretty-entities + (message "Entities are displayed as UTF8 characers") + (save-restriction + (widen) + (org-decompose-region (point-min) (point-max)) + (message "Entities are displayed plain")))) + +(defun org-fontify-entities (limit) + "Find an entity to fontify." + (let (ee) + (when org-pretty-entities + (catch 'match + (while (re-search-forward + "\\\\\\([a-zA-Z][a-zA-Z0-9]*\\)\\($\\|[^[:alnum:]\n]\\)" + limit t) + (if (and (not (org-in-indented-comment-line)) + (setq ee (org-entity-get (match-string 1))) + (= (length (nth 6 ee)) 1)) + (progn + (add-text-properties + (match-beginning 0) (match-end 1) + (list 'font-lock-fontified t)) + (compose-region (match-beginning 0) (match-end 1) + (nth 6 ee) nil) + (backward-char 1) + (throw 'match t)))) + nil)))) + +(defun org-fontify-like-in-org-mode (s &optional odd-levels) + "Fontify string S like in Org-mode." + (with-temp-buffer + (insert s) + (let ((org-odd-levels-only odd-levels)) + (org-mode) + (font-lock-fontify-buffer) + (buffer-string)))) + +(defvar org-m nil) +(defvar org-l nil) +(defvar org-f nil) +(defun org-get-level-face (n) + "Get the right face for match N in font-lock matching of headlines." + (setq org-l (- (match-end 2) (match-beginning 1) 1)) + (if org-odd-levels-only (setq org-l (1+ (/ org-l 2)))) + (if org-cycle-level-faces + (setq org-f (nth (% (1- org-l) org-n-level-faces) org-level-faces)) + (setq org-f (nth (1- (min org-l org-n-level-faces)) org-level-faces))) + (cond + ((eq n 1) (if org-hide-leading-stars 'org-hide org-f)) + ((eq n 2) org-f) + (t (if org-level-color-stars-only nil org-f)))) + + +(defun org-get-todo-face (kwd) + "Get the right face for a TODO keyword KWD. +If KWD is a number, get the corresponding match group." + (if (numberp kwd) (setq kwd (match-string kwd))) + (or (org-face-from-face-or-color + 'todo 'org-todo (cdr (assoc kwd org-todo-keyword-faces))) + (and (member kwd org-done-keywords) 'org-done) + 'org-todo)) + +(defun org-face-from-face-or-color (context inherit face-or-color) + "Create a face list that inherits INHERIT, but sets the foreground color. +When FACE-OR-COLOR is not a string, just return it." + (if (stringp face-or-color) + (list :inherit inherit + (cdr (assoc context org-faces-easy-properties)) + face-or-color) + face-or-color)) + +(defun org-font-lock-add-tag-faces (limit) + "Add the special tag faces." + (when (and org-tag-faces org-tags-special-faces-re) + (while (re-search-forward org-tags-special-faces-re limit t) + (add-text-properties (match-beginning 1) (match-end 1) + (list 'face (org-get-tag-face 1) + 'font-lock-fontified t)) + (backward-char 1)))) + +(defun org-font-lock-add-priority-faces (limit) + "Add the special priority faces." + (while (re-search-forward "\\[#\\([A-Z0-9]\\)\\]" limit t) + (add-text-properties + (match-beginning 0) (match-end 0) + (list 'face (or (org-face-from-face-or-color + 'priority 'org-special-keyword + (cdr (assoc (char-after (match-beginning 1)) + org-priority-faces))) + 'org-special-keyword) + 'font-lock-fontified t)))) + +(defun org-get-tag-face (kwd) + "Get the right face for a TODO keyword KWD. +If KWD is a number, get the corresponding match group." + (if (numberp kwd) (setq kwd (match-string kwd))) + (or (org-face-from-face-or-color + 'tag 'org-tag (cdr (assoc kwd org-tag-faces))) + 'org-tag)) + +(defun org-unfontify-region (beg end &optional maybe_loudly) + "Remove fontification and activation overlays from links." + (font-lock-default-unfontify-region beg end) + (let* ((buffer-undo-list t) + (inhibit-read-only t) (inhibit-point-motion-hooks t) + (inhibit-modification-hooks t) + deactivate-mark buffer-file-name buffer-file-truename) + (org-decompose-region beg end) + (remove-text-properties + beg end + (if org-indent-mode + ;; also remove line-prefix and wrap-prefix properties + '(mouse-face t keymap t org-linked-text t + invisible t intangible t + line-prefix t wrap-prefix t + org-no-flyspell t org-emphasis t) + '(mouse-face t keymap t org-linked-text t + invisible t intangible t + org-no-flyspell t org-emphasis t))) + (org-remove-font-lock-display-properties beg end))) + +(defconst org-script-display '(((raise -0.3) (height 0.7)) + ((raise 0.3) (height 0.7)) + ((raise -0.5)) + ((raise 0.5))) + "Display properties for showing superscripts and subscripts.") + +(defun org-remove-font-lock-display-properties (beg end) + "Remove specific display properties that have been added by font lock. +The will remove the raise properties that are used to show superscripts +and subscripts." + (let (next prop) + (while (< beg end) + (setq next (next-single-property-change beg 'display nil end) + prop (get-text-property beg 'display)) + (if (member prop org-script-display) + (put-text-property beg next 'display nil)) + (setq beg next)))) + +(defun org-raise-scripts (limit) + "Add raise properties to sub/superscripts." + (when (and org-pretty-entities org-pretty-entities-include-sub-superscripts) + (if (re-search-forward + (if (eq org-use-sub-superscripts t) + org-match-substring-regexp + org-match-substring-with-braces-regexp) + limit t) + (let* ((pos (point)) table-p comment-p + (mpos (match-beginning 3)) + (emph-p (get-text-property mpos 'org-emphasis)) + (link-p (get-text-property mpos 'mouse-face)) + (keyw-p (eq 'org-special-keyword (get-text-property mpos 'face)))) + (goto-char (point-at-bol)) + (setq table-p (org-looking-at-p org-table-dataline-regexp) + comment-p (org-looking-at-p "[ \t]*#")) + (goto-char pos) + ;; FIXME: Should we go back one character here, for a_b^c + ;; (goto-char (1- pos)) ;???????????????????? + (if (or comment-p emph-p link-p keyw-p) + t + (put-text-property (match-beginning 3) (match-end 0) + 'display + (if (equal (char-after (match-beginning 2)) ?^) + (nth (if table-p 3 1) org-script-display) + (nth (if table-p 2 0) org-script-display))) + (add-text-properties (match-beginning 2) (match-end 2) + (list 'invisible t + 'org-dwidth t 'org-dwidth-n 1)) + (if (and (eq (char-after (match-beginning 3)) ?{) + (eq (char-before (match-end 3)) ?})) + (progn + (add-text-properties + (match-beginning 3) (1+ (match-beginning 3)) + (list 'invisible t 'org-dwidth t 'org-dwidth-n 1)) + (add-text-properties + (1- (match-end 3)) (match-end 3) + (list 'invisible t 'org-dwidth t 'org-dwidth-n 1)))) + t))))) + +;;;; Visibility cycling, including org-goto and indirect buffer + +;;; Cycling + +(defvar org-cycle-global-status nil) +(make-variable-buffer-local 'org-cycle-global-status) +(defvar org-cycle-subtree-status nil) +(make-variable-buffer-local 'org-cycle-subtree-status) + +;;;###autoload + +(defvar org-inlinetask-min-level) + +(defun org-cycle (&optional arg) + "TAB-action and visibility cycling for Org-mode. + +This is the command invoked in Org-mode by the TAB key. Its main purpose +is outline visibility cycling, but it also invokes other actions +in special contexts. + +- When this function is called with a prefix argument, rotate the entire + buffer through 3 states (global cycling) + 1. OVERVIEW: Show only top-level headlines. + 2. CONTENTS: Show all headlines of all levels, but no body text. + 3. SHOW ALL: Show everything. + When called with two `C-u C-u' prefixes, switch to the startup visibility, + determined by the variable `org-startup-folded', and by any VISIBILITY + properties in the buffer. + When called with three `C-u C-u C-u' prefixed, show the entire buffer, + including any drawers. + +- When inside a table, re-align the table and move to the next field. + +- When point is at the beginning of a headline, rotate the subtree started + by this line through 3 different states (local cycling) + 1. FOLDED: Only the main headline is shown. + 2. CHILDREN: The main headline and the direct children are shown. + From this state, you can move to one of the children + and zoom in further. + 3. SUBTREE: Show the entire subtree, including body text. + If there is no subtree, switch directly from CHILDREN to FOLDED. + +- When point is at the beginning of an empty headline and the variable + `org-cycle-level-after-item/entry-creation' is set, cycle the level + of the headline by demoting and promoting it to likely levels. This + speeds up creation document structure by pressing TAB once or several + times right after creating a new headline. + +- When there is a numeric prefix, go up to a heading with level ARG, do + a `show-subtree' and return to the previous cursor position. If ARG + is negative, go up that many levels. + +- When point is not at the beginning of a headline, execute the global + binding for TAB, which is re-indenting the line. See the option + `org-cycle-emulate-tab' for details. + +- Special case: if point is at the beginning of the buffer and there is + no headline in line 1, this function will act as if called with prefix arg + (C-u TAB, same as S-TAB) also when called without prefix arg. + But only if also the variable `org-cycle-global-at-bob' is t." + (interactive "P") + (org-load-modules-maybe) + (unless (or (run-hook-with-args-until-success 'org-tab-first-hook) + (and org-cycle-level-after-item/entry-creation + (or (org-cycle-level) + (org-cycle-item-indentation)))) + (let* ((limit-level + (or org-cycle-max-level + (and (boundp 'org-inlinetask-min-level) + org-inlinetask-min-level + (1- org-inlinetask-min-level)))) + (nstars (and limit-level + (if org-odd-levels-only + (and limit-level (1- (* limit-level 2))) + limit-level))) + (outline-regexp + (cond + ((not (org-mode-p)) outline-regexp) + ((or (eq org-cycle-include-plain-lists 'integrate) + (and org-cycle-include-plain-lists (org-at-item-p))) + (concat "\\(?:\\*" + (if nstars (format "\\{1,%d\\}" nstars) "+") + " \\|\\([ \t]*\\)\\([-+*]\\|[0-9]+[.)]\\) \\)")) + (t (concat "\\*" (if nstars (format "\\{1,%d\\} " nstars) "+ "))))) + (bob-special (and org-cycle-global-at-bob (not arg) (bobp) + (not (looking-at outline-regexp)))) + (org-cycle-hook + (if bob-special + (delq 'org-optimize-window-after-visibility-change + (copy-sequence org-cycle-hook)) + org-cycle-hook)) + (pos (point))) + + (if (or bob-special (equal arg '(4))) + ;; special case: use global cycling + (setq arg t)) + + (cond + + ((equal arg '(16)) + (setq last-command 'dummy) + (org-set-startup-visibility) + (message "Startup visibility, plus VISIBILITY properties")) + + ((equal arg '(64)) + (show-all) + (message "Entire buffer visible, including drawers")) + + ((org-at-table-p 'any) + ;; Enter the table or move to the next field in the table + (if (org-at-table.el-p) + (message "Use C-c ' to edit table.el tables") + (if arg (org-table-edit-field t) + (org-table-justify-field-maybe) + (call-interactively 'org-table-next-field)))) + + ((run-hook-with-args-until-success + 'org-tab-after-check-for-table-hook)) + + ((eq arg t) ;; Global cycling + (org-cycle-internal-global)) + + ((and org-drawers org-drawer-regexp + (save-excursion + (beginning-of-line 1) + (looking-at org-drawer-regexp))) + ;; Toggle block visibility + (org-flag-drawer + (not (get-char-property (match-end 0) 'invisible)))) + + ((integerp arg) + ;; Show-subtree, ARG levels up from here. + (save-excursion + (org-back-to-heading) + (outline-up-heading (if (< arg 0) (- arg) + (- (funcall outline-level) arg))) + (org-show-subtree))) + + ((and (save-excursion (beginning-of-line 1) (looking-at outline-regexp)) + (or (bolp) (not (eq org-cycle-emulate-tab 'exc-hl-bol)))) + + (org-cycle-internal-local)) + + ;; TAB emulation and template completion + (buffer-read-only (org-back-to-heading)) + + ((run-hook-with-args-until-success + 'org-tab-after-check-for-cycling-hook)) + + ((org-try-structure-completion)) + + ((org-try-cdlatex-tab)) + + ((run-hook-with-args-until-success + 'org-tab-before-tab-emulation-hook)) + + ((and (eq org-cycle-emulate-tab 'exc-hl-bol) + (or (not (bolp)) + (not (looking-at outline-regexp)))) + (call-interactively (global-key-binding "\t"))) + + ((if (and (memq org-cycle-emulate-tab '(white whitestart)) + (save-excursion (beginning-of-line 1) (looking-at "[ \t]*")) + (or (and (eq org-cycle-emulate-tab 'white) + (= (match-end 0) (point-at-eol))) + (and (eq org-cycle-emulate-tab 'whitestart) + (>= (match-end 0) pos)))) + t + (eq org-cycle-emulate-tab t)) + (call-interactively (global-key-binding "\t"))) + + (t (save-excursion + (org-back-to-heading) + (org-cycle))))))) + +(defun org-cycle-internal-global () + "Do the global cycling action." + (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 + (run-hook-with-args 'org-pre-cycle-hook 'contents) + (message "CONTENTS...") + (org-content) + (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 + (run-hook-with-args 'org-pre-cycle-hook 'all) + (show-all) + (message "SHOW ALL") + (setq org-cycle-global-status 'all) + (run-hook-with-args 'org-cycle-hook 'all)) + + (t + ;; Default action: go to overview + (run-hook-with-args 'org-pre-cycle-hook 'overview) + (org-overview) + (message "OVERVIEW") + (setq org-cycle-global-status 'overview) + (run-hook-with-args 'org-cycle-hook 'overview)))) + +(defun org-cycle-internal-local () + "Do the local cycling action." + (let ((goal-column 0) eoh eol eos level has-children children-skipped) + ;; First, some boundaries + (save-excursion + (org-back-to-heading) + (setq level (funcall outline-level)) + (save-excursion + (beginning-of-line 2) + (if (or (featurep 'xemacs) (<= emacs-major-version 21)) + ; XEmacs does not have `next-single-char-property-change' + ; I'm not sure about Emacs 21. + (while (and (not (eobp)) ;; this is like `next-line' + (get-char-property (1- (point)) 'invisible)) + (beginning-of-line 2)) + (while (and (not (eobp)) ;; this is like `next-line' + (get-char-property (1- (point)) 'invisible)) + (goto-char (next-single-char-property-change (point) 'invisible)) + (and (eolp) (beginning-of-line 2)))) + (setq eol (point))) + (outline-end-of-heading) (setq eoh (point)) + (save-excursion + (outline-next-heading) + (setq has-children (and (org-at-heading-p t) + (> (funcall outline-level) level)))) + ;; if we're in a list, org-end-of-subtree is in fact org-end-of-item. + (if (org-at-item-p) + (setq eos (if (and (org-end-of-item) (bolp)) + (1- (point)) + (point))) + (org-end-of-subtree t) + (unless (eobp) + (skip-chars-forward " \t\n")) + (setq eos (if (eobp) (point) (1- (point)))))) + ;; Find out what to do next and set `this-command' + (cond + ((= eos eoh) + ;; Nothing is hidden behind this heading + (run-hook-with-args 'org-pre-cycle-hook 'empty) + (message "EMPTY ENTRY") + (setq org-cycle-subtree-status nil) + (save-excursion + (goto-char eos) + (outline-next-heading) + (if (org-invisible-p) (org-flag-heading nil)))) + ((and (or (>= eol eos) + (not (string-match "\\S-" (buffer-substring eol eos)))) + (or has-children + (not (setq children-skipped + org-cycle-skip-children-state-if-no-children)))) + ;; Entire subtree is hidden in one line: children view + (run-hook-with-args 'org-pre-cycle-hook 'children) + (org-show-entry) + (show-children) + (message "CHILDREN") + (save-excursion + (goto-char eos) + (outline-next-heading) + (if (org-invisible-p) (org-flag-heading nil))) + (setq org-cycle-subtree-status 'children) + (run-hook-with-args 'org-cycle-hook 'children)) + ((or children-skipped + (and (eq last-command this-command) + (eq org-cycle-subtree-status 'children))) + ;; We just showed the children, or no children are there, + ;; now show everything. + (run-hook-with-args 'org-pre-cycle-hook 'subtree) + (outline-flag-region eoh eos nil) + (message (if children-skipped "SUBTREE (NO CHILDREN)" "SUBTREE")) + (setq org-cycle-subtree-status 'subtree) + (run-hook-with-args 'org-cycle-hook 'subtree)) + (t + ;; Default action: hide the subtree. + (run-hook-with-args 'org-pre-cycle-hook 'folded) + (outline-flag-region eoh eos t) + (message "FOLDED") + (setq org-cycle-subtree-status 'folded) + (run-hook-with-args 'org-cycle-hook 'folded))))) + +;;;###autoload +(defun org-global-cycle (&optional arg) + "Cycle the global visibility. For details see `org-cycle'. +With \\[universal-argument] prefix arg, switch to startup visibility. +With a numeric prefix, show all headlines up to that level." + (interactive "P") + (let ((org-cycle-include-plain-lists + (if (org-mode-p) org-cycle-include-plain-lists nil))) + (cond + ((integerp arg) + (show-all) + (hide-sublevels arg) + (setq org-cycle-global-status 'contents)) + ((equal arg '(4)) + (org-set-startup-visibility) + (message "Startup visibility, plus VISIBILITY properties.")) + (t + (org-cycle '(4)))))) + +(defun org-set-startup-visibility () + "Set the visibility required by startup options and properties." + (cond + ((eq org-startup-folded t) + (org-cycle '(4))) + ((eq org-startup-folded 'content) + (let ((this-command 'org-cycle) (last-command 'org-cycle)) + (org-cycle '(4)) (org-cycle '(4))))) + (unless (eq org-startup-folded 'showeverything) + (if org-hide-block-startup (org-hide-block-all)) + (org-set-visibility-according-to-property 'no-cleanup) + (org-cycle-hide-archived-subtrees 'all) + (org-cycle-hide-drawers 'all) + (org-cycle-show-empty-lines t))) + +(defun org-set-visibility-according-to-property (&optional no-cleanup) + "Switch subtree visibilities according to :VISIBILITY: property." + (interactive) + (let (org-show-entry-below state) + (save-excursion + (goto-char (point-min)) + (while (re-search-forward + "^[ \t]*:VISIBILITY:[ \t]+\\([a-z]+\\)" + nil t) + (setq state (match-string 1)) + (save-excursion + (org-back-to-heading t) + (hide-subtree) + (org-reveal) + (cond + ((equal state '("fold" "folded")) + (hide-subtree)) + ((equal state "children") + (org-show-hidden-entry) + (show-children)) + ((equal state "content") + (save-excursion + (save-restriction + (org-narrow-to-subtree) + (org-content)))) + ((member state '("all" "showall")) + (show-subtree))))) + (unless no-cleanup + (org-cycle-hide-archived-subtrees 'all) + (org-cycle-hide-drawers 'all) + (org-cycle-show-empty-lines 'all))))) + +(defun org-overview () + "Switch to overview mode, showing only top-level headlines. +Really, this shows all headlines with level equal or greater than the level +of the first headline in the buffer. This is important, because if the +first headline is not level one, then (hide-sublevels 1) gives confusing +results." + (interactive) + (let ((level (save-excursion + (goto-char (point-min)) + (if (re-search-forward (concat "^" outline-regexp) nil t) + (progn + (goto-char (match-beginning 0)) + (funcall outline-level)))))) + (and level (hide-sublevels level)))) + +(defun org-content (&optional arg) + "Show all headlines in the buffer, like a table of contents. +With numerical argument N, show content up to level N." + (interactive "P") + (save-excursion + ;; Visit all headings and show their offspring + (and (integerp arg) (org-overview)) + (goto-char (point-max)) + (catch 'exit + (while (and (progn (condition-case nil + (outline-previous-visible-heading 1) + (error (goto-char (point-min)))) + t) + (looking-at outline-regexp)) + (if (integerp arg) + (show-children (1- arg)) + (show-branches)) + (if (bobp) (throw 'exit nil)))))) + + +(defun org-optimize-window-after-visibility-change (state) + "Adjust the window after a change in outline visibility. +This function is the default value of the hook `org-cycle-hook'." + (when (get-buffer-window (current-buffer)) + (cond + ((eq state 'content) nil) + ((eq state 'all) nil) + ((eq state 'folded) nil) + ((eq state 'children) (or (org-subtree-end-visible-p) (recenter 1))) + ((eq state 'subtree) (or (org-subtree-end-visible-p) (recenter 1)))))) + +(defun org-remove-empty-overlays-at (pos) + "Remove outline overlays that do not contain non-white stuff." + (mapc + (lambda (o) + (and (eq 'outline (overlay-get o 'invisible)) + (not (string-match "\\S-" (buffer-substring (overlay-start o) + (overlay-end o)))) + (delete-overlay o))) + (overlays-at pos))) + +(defun org-clean-visibility-after-subtree-move () + "Fix visibility issues after moving a subtree." + ;; First, find a reasonable region to look at: + ;; Start two siblings above, end three below + (let* ((beg (save-excursion + (and (org-get-last-sibling) + (org-get-last-sibling)) + (point))) + (end (save-excursion + (and (org-get-next-sibling) + (org-get-next-sibling) + (org-get-next-sibling)) + (if (org-at-heading-p) + (point-at-eol) + (point)))) + (level (looking-at "\\*+")) + (re (if level (concat "^" (regexp-quote (match-string 0)) " ")))) + (save-excursion + (save-restriction + (narrow-to-region beg end) + (when re + ;; Properly fold already folded siblings + (goto-char (point-min)) + (while (re-search-forward re nil t) + (if (and (not (org-invisible-p)) + (save-excursion + (goto-char (point-at-eol)) (org-invisible-p))) + (hide-entry)))) + (org-cycle-show-empty-lines 'overview) + (org-cycle-hide-drawers 'overview))))) + +(defun org-cycle-show-empty-lines (state) + "Show empty lines above all visible headlines. +The region to be covered depends on STATE when called through +`org-cycle-hook'. Lisp program can use t for STATE to get the +entire buffer covered. Note that an empty line is only shown if there +are at least `org-cycle-separator-lines' empty lines before the headline." + (when (not (= org-cycle-separator-lines 0)) + (save-excursion + (let* ((n (abs org-cycle-separator-lines)) + (re (cond + ((= n 1) "\\(\n[ \t]*\n\\*+\\) ") + ((= n 2) "^[ \t]*\\(\n[ \t]*\n\\*+\\) ") + (t (let ((ns (number-to-string (- n 2)))) + (concat "^\\(?:[ \t]*\n\\)\\{" ns "," ns "\\}" + "[ \t]*\\(\n[ \t]*\n\\*+\\) "))))) + beg end b e) + (cond + ((memq state '(overview contents t)) + (setq beg (point-min) end (point-max))) + ((memq state '(children folded)) + (setq beg (point) end (progn (org-end-of-subtree t t) + (beginning-of-line 2) + (point))))) + (when beg + (goto-char beg) + (while (re-search-forward re end t) + (unless (get-char-property (match-end 1) 'invisible) + (setq e (match-end 1)) + (if (< org-cycle-separator-lines 0) + (setq b (save-excursion + (goto-char (match-beginning 0)) + (org-back-over-empty-lines) + (if (save-excursion + (goto-char (max (point-min) (1- (point)))) + (org-on-heading-p)) + (1- (point)) + (point)))) + (setq b (match-beginning 1))) + (outline-flag-region b e nil))))))) + ;; Never hide empty lines at the end of the file. + (save-excursion + (goto-char (point-max)) + (outline-previous-heading) + (outline-end-of-heading) + (if (and (looking-at "[ \t\n]+") + (= (match-end 0) (point-max))) + (outline-flag-region (point) (match-end 0) nil)))) + +(defun org-show-empty-lines-in-parent () + "Move to the parent and re-show empty lines before visible headlines." + (save-excursion + (let ((context (if (org-up-heading-safe) 'children 'overview))) + (org-cycle-show-empty-lines context)))) + +(defun org-files-list () + "Return `org-agenda-files' list, plus all open org-mode files. +This is useful for operations that need to scan all of a user's +open and agenda-wise Org files." + (let ((files (mapcar 'expand-file-name (org-agenda-files)))) + (dolist (buf (buffer-list)) + (with-current-buffer buf + (if (and (eq major-mode 'org-mode) (buffer-file-name)) + (let ((file (expand-file-name (buffer-file-name)))) + (unless (member file files) + (push file files)))))) + files)) + +(defsubst org-entry-beginning-position () + "Return the beginning position of the current entry." + (save-excursion (outline-back-to-heading t) (point))) + +(defsubst org-entry-end-position () + "Return the end position of the current entry." + (save-excursion (outline-next-heading) (point))) + +(defun org-cycle-hide-drawers (state) + "Re-hide all drawers after a visibility state change." + (when (and (org-mode-p) + (not (memq state '(overview folded contents)))) + (save-excursion + (let* ((globalp (memq state '(contents all))) + (beg (if globalp (point-min) (point))) + (end (if globalp (point-max) + (if (eq state 'children) + (save-excursion (outline-next-heading) (point)) + (org-end-of-subtree t))))) + (goto-char beg) + (while (re-search-forward org-drawer-regexp end t) + (org-flag-drawer t)))))) + +(defun org-flag-drawer (flag) + (save-excursion + (beginning-of-line 1) + (when (looking-at "^[ \t]*:[a-zA-Z][a-zA-Z0-9]*:") + (let ((b (match-end 0)) + (outline-regexp org-outline-regexp)) + (if (re-search-forward + "^[ \t]*:END:" + (save-excursion (outline-next-heading) (point)) t) + (outline-flag-region b (point-at-eol) flag) + (error ":END: line missing at position %s" b)))))) + +(defun org-subtree-end-visible-p () + "Is the end of the current subtree visible?" + (pos-visible-in-window-p + (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. +Optional argument N means put the headline into the Nth line of the window." + (goto-char (point-min)) + (when (re-search-forward (concat "^\\(" outline-regexp "\\)") nil t) + (beginning-of-line) + (recenter (prefix-numeric-value N)))) + +;;; Saving and restoring visibility + +(defun org-outline-overlay-data (&optional use-markers) + "Return a list of the locations of all outline overlays. +These are overlays with the `invisible' property value `outline'. +The return value is a list of cons cells, with start and stop +positions for each overlay. +If USE-MARKERS is set, return the positions as markers." + (let (beg end) + (save-excursion + (save-restriction + (widen) + (delq nil + (mapcar (lambda (o) + (when (eq (overlay-get o 'invisible) 'outline) + (setq beg (overlay-start o) + end (overlay-end o)) + (and beg end (> end beg) + (if use-markers + (cons (move-marker (make-marker) beg) + (move-marker (make-marker) end)) + (cons beg end))))) + (overlays-in (point-min) (point-max)))))))) + +(defun org-set-outline-overlay-data (data) + "Create visibility overlays for all positions in DATA. +DATA should have been made by `org-outline-overlay-data'." + (let (o) + (save-excursion + (save-restriction + (widen) + (show-all) + (mapc (lambda (c) + (setq o (make-overlay (car c) (cdr c))) + (overlay-put o 'invisible 'outline)) + data))))) + +;;; Folding of blocks + +(defconst org-block-regexp + + "^[ \t]*#\\+begin_\\([^ \n]+\\)\\(\\([^\n]+\\)\\)?\n\\([^\000]+?\\)#\\+end_\\1[ \t]*$" + "Regular expression for hiding blocks.") + +(defvar org-hide-block-overlays nil + "Overlays hiding blocks.") +(make-variable-buffer-local 'org-hide-block-overlays) + +(defun org-block-map (function &optional start end) + "Call FUNCTION at the head of all source blocks in the current buffer. +Optional arguments START and END can be used to limit the range." + (let ((start (or start (point-min))) + (end (or end (point-max)))) + (save-excursion + (goto-char start) + (while (and (< (point) end) (re-search-forward org-block-regexp end t)) + (save-excursion + (save-match-data + (goto-char (match-beginning 0)) + (funcall function))))))) + +(defun org-hide-block-toggle-all () + "Toggle the visibility of all blocks in the current buffer." + (org-block-map #'org-hide-block-toggle)) + +(defun org-hide-block-all () + "Fold all blocks in the current buffer." + (interactive) + (org-show-block-all) + (org-block-map #'org-hide-block-toggle-maybe)) + +(defun org-show-block-all () + "Unfold all blocks in the current buffer." + (interactive) + (mapc 'delete-overlay org-hide-block-overlays) + (setq org-hide-block-overlays nil)) + +(defun org-hide-block-toggle-maybe () + "Toggle visibility of block at point." + (interactive) + (let ((case-fold-search t)) + (if (save-excursion + (beginning-of-line 1) + (looking-at org-block-regexp)) + (progn (org-hide-block-toggle) + t) ;; to signal that we took action + nil))) ;; to signal that we did not + +(defun org-hide-block-toggle (&optional force) + "Toggle the visibility of the current block." + (interactive) + (save-excursion + (beginning-of-line) + (if (re-search-forward org-block-regexp nil t) + (let ((start (- (match-beginning 4) 1)) ;; beginning of body + (end (match-end 0)) ;; end of entire body + ov) + (if (memq t (mapcar (lambda (overlay) + (eq (overlay-get overlay 'invisible) + 'org-hide-block)) + (overlays-at start))) + (if (or (not force) (eq force 'off)) + (mapc (lambda (ov) + (when (member ov org-hide-block-overlays) + (setq org-hide-block-overlays + (delq ov org-hide-block-overlays))) + (when (eq (overlay-get ov 'invisible) + 'org-hide-block) + (delete-overlay ov))) + (overlays-at start))) + (setq ov (make-overlay start end)) + (overlay-put ov 'invisible 'org-hide-block) + ;; make the block accessible to isearch + (overlay-put + ov 'isearch-open-invisible + (lambda (ov) + (when (member ov org-hide-block-overlays) + (setq org-hide-block-overlays + (delq ov org-hide-block-overlays))) + (when (eq (overlay-get ov 'invisible) + 'org-hide-block) + (delete-overlay ov)))) + (push ov org-hide-block-overlays))) + (error "Not looking at a source block")))) + +;; org-tab-after-check-for-cycling-hook +(add-hook 'org-tab-first-hook 'org-hide-block-toggle-maybe) +;; Remove overlays when changing major mode +(add-hook 'org-mode-hook + (lambda () (org-add-hook 'change-major-mode-hook + 'org-show-block-all 'append 'local))) + +;;; Org-goto + +(defvar org-goto-window-configuration nil) +(defvar org-goto-marker nil) +(defvar org-goto-map + (let ((map (make-sparse-keymap))) + (let ((cmds '(isearch-forward isearch-backward kill-ring-save set-mark-command mouse-drag-region universal-argument org-occur)) cmd) + (while (setq cmd (pop cmds)) + (substitute-key-definition cmd cmd map global-map))) + (suppress-keymap map) + (org-defkey map "\C-m" 'org-goto-ret) + (org-defkey map [(return)] 'org-goto-ret) + (org-defkey map [(left)] 'org-goto-left) + (org-defkey map [(right)] 'org-goto-right) + (org-defkey map [(control ?g)] 'org-goto-quit) + (org-defkey map "\C-i" 'org-cycle) + (org-defkey map [(tab)] 'org-cycle) + (org-defkey map [(down)] 'outline-next-visible-heading) + (org-defkey map [(up)] 'outline-previous-visible-heading) + (if org-goto-auto-isearch + (if (fboundp 'define-key-after) + (define-key-after map [t] 'org-goto-local-auto-isearch) + nil) + (org-defkey map "q" 'org-goto-quit) + (org-defkey map "n" 'outline-next-visible-heading) + (org-defkey map "p" 'outline-previous-visible-heading) + (org-defkey map "f" 'outline-forward-same-level) + (org-defkey map "b" 'outline-backward-same-level) + (org-defkey map "u" 'outline-up-heading)) + (org-defkey map "/" 'org-occur) + (org-defkey map "\C-c\C-n" 'outline-next-visible-heading) + (org-defkey map "\C-c\C-p" 'outline-previous-visible-heading) + (org-defkey map "\C-c\C-f" 'outline-forward-same-level) + (org-defkey map "\C-c\C-b" 'outline-backward-same-level) + (org-defkey map "\C-c\C-u" 'outline-up-heading) + map)) + +(defconst org-goto-help +"Browse buffer copy, to find location or copy text. Just type for auto-isearch. +RET=jump to location [Q]uit and return to previous location +\[Up]/[Down]=next/prev headline TAB=cycle visibility [/] org-occur") + +(defvar org-goto-start-pos) ; dynamically scoped parameter + +;; FIXME: Docstring does not mention both interfaces +(defun org-goto (&optional alternative-interface) + "Look up a different location in the current file, keeping current visibility. + +When you want look-up or go to a different location in a document, the +fastest way is often to fold the entire buffer and then dive into the tree. +This method has the disadvantage, that the previous location will be folded, +which may not be what you want. + +This command works around this by showing a copy of the current buffer +in an indirect buffer, in overview mode. You can dive into the tree in +that copy, use org-occur and incremental search to find a location. +When pressing RET or `Q', the command returns to the original buffer in +which the visibility is still unchanged. After RET is will also jump to +the location selected in the indirect buffer and expose the +the headline hierarchy above." + (interactive "P") + (let* ((org-refile-targets `((nil . (:maxlevel . ,org-goto-max-level)))) + (org-refile-use-outline-path t) + (org-refile-target-verify-function nil) + (interface + (if (not alternative-interface) + org-goto-interface + (if (eq org-goto-interface 'outline) + 'outline-path-completion + 'outline))) + (org-goto-start-pos (point)) + (selected-point + (if (eq interface 'outline) + (car (org-get-location (current-buffer) org-goto-help)) + (let ((pa (org-refile-get-location "Goto: "))) + (org-refile-check-position pa) + (nth 3 pa))))) + (if selected-point + (progn + (org-mark-ring-push org-goto-start-pos) + (goto-char selected-point) + (if (or (org-invisible-p) (org-invisible-p2)) + (org-show-context 'org-goto))) + (message "Quit")))) + +(defvar org-goto-selected-point nil) ; dynamically scoped parameter +(defvar org-goto-exit-command nil) ; dynamically scoped parameter +(defvar org-goto-local-auto-isearch-map) ; defined below + +(defun org-get-location (buf help) + "Let the user select a location in the Org-mode buffer BUF. +This function uses a recursive edit. It returns the selected position +or nil." + (let ((isearch-mode-map org-goto-local-auto-isearch-map) + (isearch-hide-immediately nil) + (isearch-search-fun-function + (lambda () 'org-goto-local-search-headings)) + (org-goto-selected-point org-goto-exit-command) + (pop-up-frames nil) + (special-display-buffer-names nil) + (special-display-regexps nil) + (special-display-function nil)) + (save-excursion + (save-window-excursion + (delete-other-windows) + (and (get-buffer "*org-goto*") (kill-buffer "*org-goto*")) + (switch-to-buffer + (condition-case nil + (make-indirect-buffer (current-buffer) "*org-goto*") + (error (make-indirect-buffer (current-buffer) "*org-goto*")))) + (with-output-to-temp-buffer "*Help*" + (princ help)) + (org-fit-window-to-buffer (get-buffer-window "*Help*")) + (setq buffer-read-only nil) + (let ((org-startup-truncated t) + (org-startup-folded nil) + (org-startup-align-all-tables nil)) + (org-mode) + (org-overview)) + (setq buffer-read-only t) + (if (and (boundp 'org-goto-start-pos) + (integer-or-marker-p org-goto-start-pos)) + (let ((org-show-hierarchy-above t) + (org-show-siblings t) + (org-show-following-heading t)) + (goto-char org-goto-start-pos) + (and (org-invisible-p) (org-show-context))) + (goto-char (point-min))) + (let (org-special-ctrl-a/e) (org-beginning-of-line)) + (message "Select location and press RET") + (use-local-map org-goto-map) + (recursive-edit) + )) + (kill-buffer "*org-goto*") + (cons org-goto-selected-point org-goto-exit-command))) + +(defvar org-goto-local-auto-isearch-map (make-sparse-keymap)) +(set-keymap-parent org-goto-local-auto-isearch-map isearch-mode-map) +(define-key org-goto-local-auto-isearch-map "\C-i" 'isearch-other-control-char) +(define-key org-goto-local-auto-isearch-map "\C-m" 'isearch-other-control-char) + +(defun org-goto-local-search-headings (string bound noerror) + "Search and make sure that any matches are in headlines." + (catch 'return + (while (if isearch-forward + (search-forward string bound noerror) + (search-backward string bound noerror)) + (when (let ((context (mapcar 'car (save-match-data (org-context))))) + (and (member :headline context) + (not (member :tags context)))) + (throw 'return (point)))))) + +(defun org-goto-local-auto-isearch () + "Start isearch." + (interactive) + (goto-char (point-min)) + (let ((keys (this-command-keys))) + (when (eq (lookup-key isearch-mode-map keys) 'isearch-printing-char) + (isearch-mode t) + (isearch-process-search-char (string-to-char keys))))) + +(defun org-goto-ret (&optional arg) + "Finish `org-goto' by going to the new location." + (interactive "P") + (setq org-goto-selected-point (point) + org-goto-exit-command 'return) + (throw 'exit nil)) + +(defun org-goto-left () + "Finish `org-goto' by going to the new location." + (interactive) + (if (org-on-heading-p) + (progn + (beginning-of-line 1) + (setq org-goto-selected-point (point) + org-goto-exit-command 'left) + (throw 'exit nil)) + (error "Not on a heading"))) + +(defun org-goto-right () + "Finish `org-goto' by going to the new location." + (interactive) + (if (org-on-heading-p) + (progn + (setq org-goto-selected-point (point) + org-goto-exit-command 'right) + (throw 'exit nil)) + (error "Not on a heading"))) + +(defun org-goto-quit () + "Finish `org-goto' without cursor motion." + (interactive) + (setq org-goto-selected-point nil) + (setq org-goto-exit-command 'quit) + (throw 'exit nil)) + +;;; Indirect buffer display of subtrees + +(defvar org-indirect-dedicated-frame nil + "This is the frame being used for indirect tree display.") +(defvar org-last-indirect-buffer nil) + +(defun org-tree-to-indirect-buffer (&optional arg) + "Create indirect buffer and narrow it to current subtree. +With numerical prefix ARG, go up to this level and then take that tree. +If ARG is negative, go up that many levels. +If `org-indirect-buffer-display' is not `new-frame', the command removes the +indirect buffer previously made with this command, to avoid proliferation of +indirect buffers. However, when you call the command with a \ +\\[universal-argument] prefix, or +when `org-indirect-buffer-display' is `new-frame', the last buffer +is kept so that you can work with several indirect buffers at the same time. +If `org-indirect-buffer-display' is `dedicated-frame', the \ +\\[universal-argument] prefix also +requests that a new frame be made for the new buffer, so that the dedicated +frame is not changed." + (interactive "P") + (let ((cbuf (current-buffer)) + (cwin (selected-window)) + (pos (point)) + beg end level heading ibuf) + (save-excursion + (org-back-to-heading t) + (when (numberp arg) + (setq level (org-outline-level)) + (if (< arg 0) (setq arg (+ level arg))) + (while (> (setq level (org-outline-level)) arg) + (outline-up-heading 1 t))) + (setq beg (point) + heading (org-get-heading)) + (org-end-of-subtree t t) + (if (org-on-heading-p) (backward-char 1)) + (setq end (point))) + (if (and (buffer-live-p org-last-indirect-buffer) + (not (eq org-indirect-buffer-display 'new-frame)) + (not arg)) + (kill-buffer org-last-indirect-buffer)) + (setq ibuf (org-get-indirect-buffer cbuf) + org-last-indirect-buffer ibuf) + (cond + ((or (eq org-indirect-buffer-display 'new-frame) + (and arg (eq org-indirect-buffer-display 'dedicated-frame))) + (select-frame (make-frame)) + (delete-other-windows) + (switch-to-buffer ibuf) + (org-set-frame-title heading)) + ((eq org-indirect-buffer-display 'dedicated-frame) + (raise-frame + (select-frame (or (and org-indirect-dedicated-frame + (frame-live-p org-indirect-dedicated-frame) + org-indirect-dedicated-frame) + (setq org-indirect-dedicated-frame (make-frame))))) + (delete-other-windows) + (switch-to-buffer ibuf) + (org-set-frame-title (concat "Indirect: " heading))) + ((eq org-indirect-buffer-display 'current-window) + (switch-to-buffer ibuf)) + ((eq org-indirect-buffer-display 'other-window) + (pop-to-buffer ibuf)) + (t (error "Invalid value"))) + (if (featurep 'xemacs) + (save-excursion (org-mode) (turn-on-font-lock))) + (narrow-to-region beg end) + (show-all) + (goto-char pos) + (and (window-live-p cwin) (select-window cwin)))) + +(defun org-get-indirect-buffer (&optional buffer) + (setq buffer (or buffer (current-buffer))) + (let ((n 1) (base (buffer-name buffer)) bname) + (while (buffer-live-p + (get-buffer (setq bname (concat base "-" (number-to-string n))))) + (setq n (1+ n))) + (condition-case nil + (make-indirect-buffer buffer bname 'clone) + (error (make-indirect-buffer buffer bname))))) + +(defun org-set-frame-title (title) + "Set the title of the current frame to the string TITLE." + ;; FIXME: how to name a single frame in XEmacs??? + (unless (featurep 'xemacs) + (modify-frame-parameters (selected-frame) (list (cons 'name title))))) + +;;;; Structure editing + +;;; Inserting headlines + +(defun org-previous-line-empty-p () + (save-excursion + (and (not (bobp)) + (or (beginning-of-line 0) t) + (save-match-data + (looking-at "[ \t]*$"))))) + +(defun org-insert-heading (&optional force-heading invisible-ok) + "Insert a new heading or item with same depth at point. +If point is in a plain list and FORCE-HEADING is nil, create a new list item. +If point is at the beginning of a headline, insert a sibling before the +current headline. If point is not at the beginning, split the line, +create the new headline with the text in the current line after point +\(but see also the variable `org-M-RET-may-split-line'). + +When INVISIBLE-OK is set, stop at invisible headlines when going back. +This is important for non-interactive uses of the command." + (interactive "P") + (if (or (= (buffer-size) 0) + (and (not (save-excursion + (and (ignore-errors (org-back-to-heading invisible-ok)) + (org-on-heading-p)))) + (not (org-in-item-p)))) + (progn + (insert "\n* ") + (run-hooks 'org-insert-heading-hook)) + (when (or force-heading (not (org-insert-item))) + (let* ((empty-line-p nil) + (level nil) + (on-heading (org-on-heading-p)) + (head (save-excursion + (condition-case nil + (progn + (org-back-to-heading invisible-ok) + (when (and (not on-heading) + (featurep 'org-inlinetask) + (integerp org-inlinetask-min-level) + (>= (length (match-string 0)) + org-inlinetask-min-level)) + ;; Find a heading level before the inline task + (while (and (setq level (org-up-heading-safe)) + (>= level org-inlinetask-min-level))) + (if (org-on-heading-p) + (org-back-to-heading invisible-ok) + (error "This should not happen"))) + (setq empty-line-p (org-previous-line-empty-p)) + (match-string 0)) + (error "*")))) + (blank-a (cdr (assq 'heading org-blank-before-new-entry))) + (blank (if (eq blank-a 'auto) empty-line-p blank-a)) + pos hide-previous previous-pos) + (cond + ((and (org-on-heading-p) (bolp) + (or (bobp) + (save-excursion (backward-char 1) (not (org-invisible-p))))) + ;; insert before the current line + (open-line (if blank 2 1))) + ((and (bolp) + (not org-insert-heading-respect-content) + (or (bobp) + (save-excursion + (backward-char 1) (not (org-invisible-p))))) + ;; insert right here + nil) + (t + ;; somewhere in the line + (save-excursion + (setq previous-pos (point-at-bol)) + (end-of-line) + (setq hide-previous (org-invisible-p))) + (and org-insert-heading-respect-content (org-show-subtree)) + (let ((split + (and (org-get-alist-option org-M-RET-may-split-line 'headline) + (save-excursion + (let ((p (point))) + (goto-char (point-at-bol)) + (and (looking-at org-complex-heading-regexp) + (> p (match-beginning 4))))))) + tags pos) + (cond + (org-insert-heading-respect-content + (org-end-of-subtree nil t) + (when (featurep 'org-inlinetask) + (while (and (not (eobp)) + (looking-at "\\(\\*+\\)[ \t]+") + (>= (length (match-string 1)) + org-inlinetask-min-level)) + (org-end-of-subtree nil t))) + (or (bolp) (newline)) + (or (org-previous-line-empty-p) + (and blank (newline))) + (open-line 1)) + ((org-on-heading-p) + (when hide-previous + (show-children) + (org-show-entry)) + (looking-at ".*?\\([ \t]+\\(:[[:alnum:]_@#%:]+:\\)\\)?[ \t]*$") + (setq tags (and (match-end 2) (match-string 2))) + (and (match-end 1) + (delete-region (match-beginning 1) (match-end 1))) + (setq pos (point-at-bol)) + (or split (end-of-line 1)) + (delete-horizontal-space) + (if (string-match "\\`\\*+\\'" + (buffer-substring (point-at-bol) (point))) + (insert " ")) + (newline (if blank 2 1)) + (when tags + (save-excursion + (goto-char pos) + (end-of-line 1) + (insert " " tags) + (org-set-tags nil 'align)))) + (t + (or split (end-of-line 1)) + (newline (if blank 2 1))))))) + (insert head) (just-one-space) + (setq pos (point)) + (end-of-line 1) + (unless (= (point) pos) (just-one-space) (backward-delete-char 1)) + (when (and org-insert-heading-respect-content hide-previous) + (save-excursion + (goto-char previous-pos) + (hide-subtree))) + (run-hooks 'org-insert-heading-hook))))) + +(defun org-get-heading (&optional no-tags) + "Return the heading of the current entry, without the stars." + (save-excursion + (org-back-to-heading t) + (if (looking-at + (if no-tags + (org-re "\\*+[ \t]+\\([^\n\r]*?\\)\\([ \t]+:[[:alnum:]:_@#%]+:[ \t]*\\)?$") + "\\*+[ \t]+\\([^\r\n]*\\)")) + (match-string 1) ""))) + +(defun org-heading-components () + "Return the components of the current heading. +This is a list with the following elements: +- the level as an integer +- the reduced level, different if `org-odd-levels-only' is set. +- the TODO keyword, or nil +- the priority character, like ?A, or nil if no priority is given +- the headline text itself, or the tags string if no headline text +- the tags string, or nil." + (save-excursion + (org-back-to-heading t) + (if (let (case-fold-search) (looking-at org-complex-heading-regexp)) + (list (length (match-string 1)) + (org-reduced-level (length (match-string 1))) + (org-match-string-no-properties 2) + (and (match-end 3) (aref (match-string 3) 2)) + (org-match-string-no-properties 4) + (org-match-string-no-properties 5))))) + +(defun org-get-entry () + "Get the entry text, after heading, entire subtree." + (save-excursion + (org-back-to-heading t) + (buffer-substring (point-at-bol 2) (org-end-of-subtree t)))) + +(defun org-insert-heading-after-current () + "Insert a new heading with same level as current, after current subtree." + (interactive) + (org-back-to-heading) + (org-insert-heading) + (org-move-subtree-down) + (end-of-line 1)) + +(defun org-insert-heading-respect-content () + (interactive) + (let ((org-insert-heading-respect-content t)) + (org-insert-heading t))) + +(defun org-insert-todo-heading-respect-content (&optional force-state) + (interactive "P") + (let ((org-insert-heading-respect-content t)) + (org-insert-todo-heading force-state t))) + +(defun org-insert-todo-heading (arg &optional force-heading) + "Insert a new heading with the same level and TODO state as current heading. +If the heading has no TODO state, or if the state is DONE, use the first +state (TODO by default). Also with prefix arg, force first state." + (interactive "P") + (when (or force-heading (not (org-insert-item 'checkbox))) + (org-insert-heading force-heading) + (save-excursion + (org-back-to-heading) + (outline-previous-heading) + (looking-at org-todo-line-regexp)) + (let* + ((new-mark-x + (if (or arg + (not (match-beginning 2)) + (member (match-string 2) org-done-keywords)) + (car org-todo-keywords-1) + (match-string 2))) + (new-mark + (or + (run-hook-with-args-until-success + 'org-todo-get-default-hook new-mark-x nil) + new-mark-x))) + (beginning-of-line 1) + (and (looking-at "\\*+ ") (goto-char (match-end 0)) + (if org-treat-insert-todo-heading-as-state-change + (org-todo new-mark) + (insert new-mark " ")))) + (when org-provide-todo-statistics + (org-update-parent-todo-statistics)))) + +(defun org-insert-subheading (arg) + "Insert a new subheading and demote it. +Works for outline headings and for plain lists alike." + (interactive "P") + (org-insert-heading arg) + (cond + ((org-on-heading-p) (org-do-demote)) + ((org-at-item-p) (org-indent-item)))) + +(defun org-insert-todo-subheading (arg) + "Insert a new subheading with TODO keyword or checkbox and demote it. +Works for outline headings and for plain lists alike." + (interactive "P") + (org-insert-todo-heading arg) + (cond + ((org-on-heading-p) (org-do-demote)) + ((org-at-item-p) (org-indent-item)))) + +;;; Promotion and Demotion + +(defvar org-after-demote-entry-hook nil + "Hook run after an entry has been demoted. +The cursor will be at the beginning of the entry. +When a subtree is being demoted, the hook will be called for each node.") + +(defvar org-after-promote-entry-hook nil + "Hook run after an entry has been promoted. +The cursor will be at the beginning of the entry. +When a subtree is being promoted, the hook will be called for each node.") + +(defun org-promote-subtree () + "Promote the entire subtree. +See also `org-promote'." + (interactive) + (save-excursion + (org-map-tree 'org-promote)) + (org-fix-position-after-promote)) + +(defun org-demote-subtree () + "Demote the entire subtree. See `org-demote'. +See also `org-promote'." + (interactive) + (save-excursion + (org-map-tree 'org-demote)) + (org-fix-position-after-promote)) + + +(defun org-do-promote () + "Promote the current heading higher up the tree. +If the region is active in `transient-mark-mode', promote all headings +in the region." + (interactive) + (save-excursion + (if (org-region-active-p) + (org-map-region 'org-promote (region-beginning) (region-end)) + (org-promote))) + (org-fix-position-after-promote)) + +(defun org-do-demote () + "Demote the current heading lower down the tree. +If the region is active in `transient-mark-mode', demote all headings +in the region." + (interactive) + (save-excursion + (if (org-region-active-p) + (org-map-region 'org-demote (region-beginning) (region-end)) + (org-demote))) + (org-fix-position-after-promote)) + +(defun org-fix-position-after-promote () + "Make sure that after pro/demotion cursor position is right." + (let ((pos (point))) + (when (save-excursion + (beginning-of-line 1) + (looking-at org-todo-line-regexp) + (or (equal pos (match-end 1)) (equal pos (match-end 2)))) + (cond ((eobp) (insert " ")) + ((eolp) (insert " ")) + ((equal (char-after) ?\ ) (forward-char 1)))))) + +(defun org-current-level () + "Return the level of the current entry, or nil if before the first headline. +The level is the number of stars at the beginning of the headline." + (save-excursion + (let ((outline-regexp (org-get-limited-outline-regexp))) + (condition-case nil + (progn + (org-back-to-heading t) + (funcall outline-level)) + (error nil))))) + +(defun org-get-previous-line-level () + "Return the outline depth of the last headline before the current line. +Returns 0 for the first headline in the buffer, and nil if before the +first headline." + (let ((current-level (org-current-level)) + (prev-level (when (> (line-number-at-pos) 1) + (save-excursion + (beginning-of-line 0) + (org-current-level))))) + (cond ((null current-level) nil) ; Before first headline + ((null prev-level) 0) ; At first headline + (prev-level)))) + +(defun org-reduced-level (l) + "Compute the effective level of a heading. +This takes into account the setting of `org-odd-levels-only'." + (if org-odd-levels-only (1+ (floor (/ l 2))) l)) + +(defun org-level-increment () + "Return the number of stars that will be added or removed at a +time to headlines when structure editing, based on the value of +`org-odd-levels-only'." + (if org-odd-levels-only 2 1)) + +(defun org-get-valid-level (level &optional change) + "Rectify a level change under the influence of `org-odd-levels-only' +LEVEL is a current level, CHANGE is by how much the level should be +modified. Even if CHANGE is nil, LEVEL may be returned modified because +even level numbers will become the next higher odd number." + (if org-odd-levels-only + (cond ((or (not change) (= 0 change)) (1+ (* 2 (/ level 2)))) + ((> change 0) (1+ (* 2 (/ (+ level (* 2 change)) 2)))) + ((< change 0) (max 1 (1+ (* 2 (/ (+ level (* 2 change)) 2)))))) + (max 1 (+ level (or change 0))))) + +(if (boundp 'define-obsolete-function-alias) + (if (or (featurep 'xemacs) (< emacs-major-version 23)) + (define-obsolete-function-alias 'org-get-legal-level + 'org-get-valid-level) + (define-obsolete-function-alias 'org-get-legal-level + 'org-get-valid-level "23.1"))) + +(defun org-promote () + "Promote the current heading higher up the tree. +If the region is active in `transient-mark-mode', promote all headings +in the region." + (org-back-to-heading t) + (let* ((level (save-match-data (funcall outline-level))) + (up-head (concat (make-string (org-get-valid-level level -1) ?*) " ")) + (diff (abs (- level (length up-head) -1)))) + (if (= level 1) (error "Cannot promote to level 0. UNDO to recover if necessary")) + (replace-match up-head nil t) + ;; Fixup tag positioning + (and org-auto-align-tags (org-set-tags nil t)) + (if org-adapt-indentation (org-fixup-indentation (- diff))) + (run-hooks 'org-after-promote-entry-hook))) + +(defun org-demote () + "Demote the current heading lower down the tree. +If the region is active in `transient-mark-mode', demote all headings +in the region." + (org-back-to-heading t) + (let* ((level (save-match-data (funcall outline-level))) + (down-head (concat (make-string (org-get-valid-level level 1) ?*) " ")) + (diff (abs (- level (length down-head) -1)))) + (replace-match down-head nil t) + ;; Fixup tag positioning + (and org-auto-align-tags (org-set-tags nil t)) + (if org-adapt-indentation (org-fixup-indentation diff)) + (run-hooks 'org-after-demote-entry-hook))) + +(defun org-cycle-level () + "Cycle the level of an empty headline through possible states. +This goes first to child, then to parent, level, then up the hierarchy. +After top level, it switches back to sibling level." + (interactive) + (let ((org-adapt-indentation nil)) + (when (org-point-at-end-of-empty-headline) + (setq this-command 'org-cycle-level) ; Only needed for caching + (let ((cur-level (org-current-level)) + (prev-level (org-get-previous-line-level))) + (cond + ;; If first headline in file, promote to top-level. + ((= prev-level 0) + (loop repeat (/ (- cur-level 1) (org-level-increment)) + do (org-do-promote))) + ;; If same level as prev, demote one. + ((= prev-level cur-level) + (org-do-demote)) + ;; If parent is top-level, promote to top level if not already. + ((= prev-level 1) + (loop repeat (/ (- cur-level 1) (org-level-increment)) + do (org-do-promote))) + ;; If top-level, return to prev-level. + ((= cur-level 1) + (loop repeat (/ (- prev-level 1) (org-level-increment)) + do (org-do-demote))) + ;; If less than prev-level, promote one. + ((< cur-level prev-level) + (org-do-promote)) + ;; If deeper than prev-level, promote until higher than + ;; prev-level. + ((> cur-level prev-level) + (loop repeat (+ 1 (/ (- cur-level prev-level) (org-level-increment))) + do (org-do-promote)))) + t)))) + +(defun org-map-tree (fun) + "Call FUN for every heading underneath the current one." + (org-back-to-heading) + (let ((level (funcall outline-level))) + (save-excursion + (funcall fun) + (while (and (progn + (outline-next-heading) + (> (funcall outline-level) level)) + (not (eobp))) + (funcall fun))))) + +(defun org-map-region (fun beg end) + "Call FUN for every heading between BEG and END." + (let ((org-ignore-region t)) + (save-excursion + (setq end (copy-marker end)) + (goto-char beg) + (if (and (re-search-forward (concat "^" outline-regexp) nil t) + (< (point) end)) + (funcall fun)) + (while (and (progn + (outline-next-heading) + (< (point) end)) + (not (eobp))) + (funcall fun))))) + +(defun org-fixup-indentation (diff) + "Change the indentation in the current entry by DIFF. +However, if any line in the current entry has no indentation, or if it +would end up with no indentation after the change, nothing at all is done." + (save-excursion + (let ((end (save-excursion (outline-next-heading) + (point-marker))) + (prohibit (if (> diff 0) + "^\\S-" + (concat "^ \\{0," (int-to-string (- diff)) "\\}\\S-"))) + col) + (unless (save-excursion (end-of-line 1) + (re-search-forward prohibit end t)) + (while (and (< (point) end) + (re-search-forward "^[ \t]+" end t)) + (goto-char (match-end 0)) + (setq col (current-column)) + (if (< diff 0) (replace-match "")) + (org-indent-to-column (+ diff col)))) + (move-marker end nil)))) + +(defun org-convert-to-odd-levels () + "Convert an org-mode file with all levels allowed to one with odd levels. +This will leave level 1 alone, convert level 2 to level 3, level 3 to +level 5 etc." + (interactive) + (when (yes-or-no-p "Are you sure you want to globally change levels to odd? ") + (let ((outline-regexp org-outline-regexp) + (outline-level 'org-outline-level) + (org-odd-levels-only nil) n) + (save-excursion + (goto-char (point-min)) + (while (re-search-forward "^\\*\\*+ " nil t) + (setq n (- (length (match-string 0)) 2)) + (while (>= (setq n (1- n)) 0) + (org-demote)) + (end-of-line 1)))))) + +(defun org-convert-to-oddeven-levels () + "Convert an org-mode file with only odd levels to one with odd/even levels. +This promotes level 3 to level 2, level 5 to level 3 etc. If the +file contains a section with an even level, conversion would +destroy the structure of the file. An error is signaled in this +case." + (interactive) + (goto-char (point-min)) + ;; First check if there are no even levels + (when (re-search-forward "^\\(\\*\\*\\)+ " nil t) + (org-show-context t) + (error "Not all levels are odd in this file. Conversion not possible")) + (when (yes-or-no-p "Are you sure you want to globally change levels to odd-even? ") + (let ((outline-regexp org-outline-regexp) + (outline-level 'org-outline-level) + (org-odd-levels-only nil) n) + (save-excursion + (goto-char (point-min)) + (while (re-search-forward "^\\*\\*+ " nil t) + (setq n (/ (1- (length (match-string 0))) 2)) + (while (>= (setq n (1- n)) 0) + (org-promote)) + (end-of-line 1)))))) + +(defun org-tr-level (n) + "Make N odd if required." + (if org-odd-levels-only (1+ (/ n 2)) n)) + +;;; Vertical tree motion, cutting and pasting of subtrees + +(defun org-move-subtree-up (&optional arg) + "Move the current subtree up past ARG headlines of the same level." + (interactive "p") + (org-move-subtree-down (- (prefix-numeric-value arg)))) + +(defun org-move-subtree-down (&optional arg) + "Move the current subtree down past ARG headlines of the same level." + (interactive "p") + (setq arg (prefix-numeric-value arg)) + (let ((movfunc (if (> arg 0) 'org-get-next-sibling + 'org-get-last-sibling)) + (ins-point (make-marker)) + (cnt (abs arg)) + beg beg0 end txt folded ne-beg ne-end ne-ins ins-end) + ;; Select the tree + (org-back-to-heading) + (setq beg0 (point)) + (save-excursion + (setq ne-beg (org-back-over-empty-lines)) + (setq beg (point))) + (save-match-data + (save-excursion (outline-end-of-heading) + (setq folded (org-invisible-p))) + (outline-end-of-subtree)) + (outline-next-heading) + (setq ne-end (org-back-over-empty-lines)) + (setq end (point)) + (goto-char beg0) + (when (and (> arg 0) (org-first-sibling-p) (< ne-end ne-beg)) + ;; include less whitespace + (save-excursion + (goto-char beg) + (forward-line (- ne-beg ne-end)) + (setq beg (point)))) + ;; Find insertion point, with error handling + (while (> cnt 0) + (or (and (funcall movfunc) (looking-at outline-regexp)) + (progn (goto-char beg0) + (error "Cannot move past superior level or buffer limit"))) + (setq cnt (1- cnt))) + (if (> arg 0) + ;; Moving forward - still need to move over subtree + (progn (org-end-of-subtree t t) + (save-excursion + (org-back-over-empty-lines) + (or (bolp) (newline))))) + (setq ne-ins (org-back-over-empty-lines)) + (move-marker ins-point (point)) + (setq txt (buffer-substring beg end)) + (org-save-markers-in-region beg end) + (delete-region beg end) + (org-remove-empty-overlays-at beg) + (or (= beg (point-min)) (outline-flag-region (1- beg) beg nil)) + (or (bobp) (outline-flag-region (1- (point)) (point) nil)) + (and (not (bolp)) (looking-at "\n") (forward-char 1)) + (let ((bbb (point))) + (insert-before-markers txt) + (org-reinstall-markers-in-region bbb) + (move-marker ins-point bbb)) + (or (bolp) (insert "\n")) + (setq ins-end (point)) + (goto-char ins-point) + (org-skip-whitespace) + (when (and (< arg 0) + (org-first-sibling-p) + (> ne-ins ne-beg)) + ;; Move whitespace back to beginning + (save-excursion + (goto-char ins-end) + (let ((kill-whole-line t)) + (kill-line (- ne-ins ne-beg)) (point))) + (insert (make-string (- ne-ins ne-beg) ?\n))) + (move-marker ins-point nil) + (if folded + (hide-subtree) + (org-show-entry) + (show-children) + (org-cycle-hide-drawers 'children)) + (org-clean-visibility-after-subtree-move))) + +(defvar org-subtree-clip "" + "Clipboard for cut and paste of subtrees. +This is actually only a copy of the kill, because we use the normal kill +ring. We need it to check if the kill was created by `org-copy-subtree'.") + +(defvar org-subtree-clip-folded nil + "Was the last copied subtree folded? +This is used to fold the tree back after pasting.") + +(defun org-cut-subtree (&optional n) + "Cut the current subtree into the clipboard. +With prefix arg N, cut this many sequential subtrees. +This is a short-hand for marking the subtree and then cutting it." + (interactive "p") + (org-copy-subtree n 'cut)) + +(defun org-copy-subtree (&optional n cut force-store-markers) + "Cut the current subtree into the clipboard. +With prefix arg N, cut this many sequential subtrees. +This is a short-hand for marking the subtree and then copying it. +If CUT is non-nil, actually cut the subtree. +If FORCE-STORE-MARKERS is non-nil, store the relative locations +of some markers in the region, even if CUT is non-nil. This is +useful if the caller implements cut-and-paste as copy-then-paste-then-cut." + (interactive "p") + (let (beg end folded (beg0 (point))) + (if (interactive-p) + (org-back-to-heading nil) ; take what looks like a subtree + (org-back-to-heading t)) ; take what is really there + (org-back-over-empty-lines) + (setq beg (point)) + (skip-chars-forward " \t\r\n") + (save-match-data + (save-excursion (outline-end-of-heading) + (setq folded (org-invisible-p))) + (condition-case nil + (org-forward-same-level (1- n) t) + (error nil)) + (org-end-of-subtree t t)) + (org-back-over-empty-lines) + (setq end (point)) + (goto-char beg0) + (when (> end beg) + (setq org-subtree-clip-folded folded) + (when (or cut force-store-markers) + (org-save-markers-in-region beg end)) + (if cut (kill-region beg end) (copy-region-as-kill beg end)) + (setq org-subtree-clip (current-kill 0)) + (message "%s: Subtree(s) with %d characters" + (if cut "Cut" "Copied") + (length org-subtree-clip))))) + +(defun org-paste-subtree (&optional level tree for-yank) + "Paste the clipboard as a subtree, with modification of headline level. +The entire subtree is promoted or demoted in order to match a new headline +level. + +If the cursor is at the beginning of a headline, the same level as +that headline is used to paste the tree + +If not, the new level is derived from the *visible* headings +before and after the insertion point, and taken to be the inferior headline +level of the two. So if the previous visible heading is level 3 and the +next is level 4 (or vice versa), level 4 will be used for insertion. +This makes sure that the subtree remains an independent subtree and does +not swallow low level entries. + +You can also force a different level, either by using a numeric prefix +argument, or by inserting the heading marker by hand. For example, if the +cursor is after \"*****\", then the tree will be shifted to level 5. + +If optional TREE is given, use this text instead of the kill ring. + +When FOR-YANK is set, this is called by `org-yank'. In this case, do not +move back over whitespace before inserting, and move point to the end of +the inserted text when done." + (interactive "P") + (setq tree (or tree (and kill-ring (current-kill 0)))) + (unless (org-kill-is-subtree-p tree) + (error "%s" + (substitute-command-keys + "The kill is not a (set of) tree(s) - please use \\[yank] to yank anyway"))) + (let* ((visp (not (org-invisible-p))) + (txt tree) + (^re (concat "^\\(" outline-regexp "\\)")) + (re (concat "\\(" outline-regexp "\\)")) + (^re_ (concat "\\(\\*+\\)[ \t]*")) + + (old-level (if (string-match ^re txt) + (- (match-end 0) (match-beginning 0) 1) + -1)) + (force-level (cond (level (prefix-numeric-value level)) + ((and (looking-at "[ \t]*$") + (string-match + ^re_ (buffer-substring + (point-at-bol) (point)))) + (- (match-end 1) (match-beginning 1))) + ((and (bolp) + (looking-at org-outline-regexp)) + (- (match-end 0) (point) 1)) + (t nil))) + (previous-level (save-excursion + (condition-case nil + (progn + (outline-previous-visible-heading 1) + (if (looking-at re) + (- (match-end 0) (match-beginning 0) 1) + 1)) + (error 1)))) + (next-level (save-excursion + (condition-case nil + (progn + (or (looking-at outline-regexp) + (outline-next-visible-heading 1)) + (if (looking-at re) + (- (match-end 0) (match-beginning 0) 1) + 1)) + (error 1)))) + (new-level (or force-level (max previous-level next-level))) + (shift (if (or (= old-level -1) + (= new-level -1) + (= old-level new-level)) + 0 + (- new-level old-level))) + (delta (if (> shift 0) -1 1)) + (func (if (> shift 0) 'org-demote 'org-promote)) + (org-odd-levels-only nil) + beg end newend) + ;; Remove the forced level indicator + (if force-level + (delete-region (point-at-bol) (point))) + ;; Paste + (beginning-of-line 1) + (unless for-yank (org-back-over-empty-lines)) + (setq beg (point)) + (and (fboundp 'org-id-paste-tracker) (org-id-paste-tracker txt)) + (insert-before-markers txt) + (unless (string-match "\n\\'" txt) (insert "\n")) + (setq newend (point)) + (org-reinstall-markers-in-region beg) + (setq end (point)) + (goto-char beg) + (skip-chars-forward " \t\n\r") + (setq beg (point)) + (if (and (org-invisible-p) visp) + (save-excursion (outline-show-heading))) + ;; Shift if necessary + (unless (= shift 0) + (save-restriction + (narrow-to-region beg end) + (while (not (= shift 0)) + (org-map-region func (point-min) (point-max)) + (setq shift (+ delta shift))) + (goto-char (point-min)) + (setq newend (point-max)))) + (when (or (interactive-p) for-yank) + (message "Clipboard pasted as level %d subtree" new-level)) + (if (and (not for-yank) ; in this case, org-yank will decide about folding + kill-ring + (eq org-subtree-clip (current-kill 0)) + org-subtree-clip-folded) + ;; The tree was folded before it was killed/copied + (hide-subtree)) + (and for-yank (goto-char newend)))) + +(defun org-kill-is-subtree-p (&optional txt) + "Check if the current kill is an outline subtree, or a set of trees. +Returns nil if kill does not start with a headline, or if the first +headline level is not the largest headline level in the tree. +So this will actually accept several entries of equal levels as well, +which is OK for `org-paste-subtree'. +If optional TXT is given, check this string instead of the current kill." + (let* ((kill (or txt (and kill-ring (current-kill 0)) "")) + (start-level (and kill + (string-match (concat "\\`\\([ \t\n\r]*?\n\\)?\\(" + org-outline-regexp "\\)") + kill) + (- (match-end 2) (match-beginning 2) 1))) + (re (concat "^" org-outline-regexp)) + (start (1+ (or (match-beginning 2) -1)))) + (if (not start-level) + (progn + nil) ;; does not even start with a heading + (catch 'exit + (while (setq start (string-match re kill (1+ start))) + (when (< (- (match-end 0) (match-beginning 0) 1) start-level) + (throw 'exit nil))) + t)))) + +(defvar org-markers-to-move nil + "Markers that should be moved with a cut-and-paste operation. +Those markers are stored together with their positions relative to +the start of the region.") + +(defun org-save-markers-in-region (beg end) + "Check markers in region. +If these markers are between BEG and END, record their position relative +to BEG, so that after moving the block of text, we can put the markers back +into place. +This function gets called just before an entry or tree gets cut from the +buffer. After re-insertion, `org-reinstall-markers-in-region' must be +called immediately, to move the markers with the entries." + (setq org-markers-to-move nil) + (when (featurep 'org-clock) + (org-clock-save-markers-for-cut-and-paste beg end)) + (when (featurep 'org-agenda) + (org-agenda-save-markers-for-cut-and-paste beg end))) + +(defun org-check-and-save-marker (marker beg end) + "Check if MARKER is between BEG and END. +If yes, remember the marker and the distance to BEG." + (when (and (marker-buffer marker) + (equal (marker-buffer marker) (current-buffer))) + (if (and (>= marker beg) (< marker end)) + (push (cons marker (- marker beg)) org-markers-to-move)))) + +(defun org-reinstall-markers-in-region (beg) + "Move all remembered markers to their position relative to BEG." + (mapc (lambda (x) + (move-marker (car x) (+ beg (cdr x)))) + org-markers-to-move) + (setq org-markers-to-move nil)) + +(defun org-narrow-to-subtree () + "Narrow buffer to the current subtree." + (interactive) + (save-excursion + (save-match-data + (narrow-to-region + (progn (org-back-to-heading t) (point)) + (progn (org-end-of-subtree t t) + (if (and (org-on-heading-p) (not (eobp))) (backward-char 1)) + (point)))))) + +(eval-when-compile + (defvar org-property-drawer-re)) + +(defvar org-property-start-re) ;; defined below +(defun org-clone-subtree-with-time-shift (n &optional shift) + "Clone the task (subtree) at point N times. +The clones will be inserted as siblings. + +In interactive use, the user will be prompted for the number of +clones to be produced, and for a time SHIFT, which may be a +repeater as used in time stamps, for example `+3d'. + +When a valid repeater is given and the entry contains any time +stamps, the clones will become a sequence in time, with time +stamps in the subtree shifted for each clone produced. If SHIFT +is nil or the empty string, time stamps will be left alone. The +ID property of the original subtree is removed. + +If the original subtree did contain time stamps with a repeater, +the following will happen: +- the repeater will be removed in each clone +- an additional clone will be produced, with the current, unshifted + date(s) in the entry. +- the original entry will be placed *after* all the clones, with + repeater intact. +- the start days in the repeater in the original entry will be shifted + to past the last clone. +I this way you can spell out a number of instances of a repeating task, +and still retain the repeater to cover future instances of the task." + (interactive "nNumber of clones to produce: \nsDate shift per clone (e.g. +1w, empty to copy unchanged): ") + (let (beg end template task idprop + shift-n shift-what doshift nmin nmax (n-no-remove -1)) + (if (not (and (integerp n) (> n 0))) + (error "Invalid number of replications %s" n)) + (if (and (setq doshift (and (stringp shift) (string-match "\\S-" shift))) + (not (string-match "\\`[ \t]*\\+?\\([0-9]+\\)\\([dwmy]\\)[ \t]*\\'" + shift))) + (error "Invalid shift specification %s" shift)) + (when doshift + (setq shift-n (string-to-number (match-string 1 shift)) + shift-what (cdr (assoc (match-string 2 shift) + '(("d" . day) ("w" . week) + ("m" . month) ("y" . year)))))) + (if (eq shift-what 'week) (setq shift-n (* 7 shift-n) shift-what 'day)) + (setq nmin 1 nmax n) + (org-back-to-heading t) + (setq beg (point)) + (setq idprop (org-entry-get nil "ID")) + (org-end-of-subtree t t) + (or (bolp) (insert "\n")) + (setq end (point)) + (setq template (buffer-substring beg end)) + (when (and doshift + (string-match "<[^<>\n]+ \\+[0-9]+[dwmy][^<>\n]*>" template)) + (delete-region beg end) + (setq end beg) + (setq nmin 0 nmax (1+ nmax) n-no-remove nmax)) + (goto-char end) + (loop for n from nmin to nmax do + ;; prepare clone + (with-temp-buffer + (insert template) + (org-mode) + (goto-char (point-min)) + (and idprop (if org-clone-delete-id + (org-entry-delete nil "ID") + (org-id-get-create t))) + (while (re-search-forward org-property-start-re nil t) + (org-remove-empty-drawer-at "PROPERTIES" (point))) + (goto-char (point-min)) + (when doshift + (while (re-search-forward org-ts-regexp-both nil t) + (org-timestamp-change (* n shift-n) shift-what)) + (unless (= n n-no-remove) + (goto-char (point-min)) + (while (re-search-forward org-ts-regexp nil t) + (save-excursion + (goto-char (match-beginning 0)) + (if (looking-at "<[^<>\n]+\\( +\\+[0-9]+[dwmy]\\)") + (delete-region (match-beginning 1) (match-end 1))))))) + (setq task (buffer-string))) + (insert task)) + (goto-char beg))) + +;;; Outline Sorting + +(defun org-sort (with-case) + "Call `org-sort-entries', `org-table-sort-lines' or `org-sort-list'. +Optional argument WITH-CASE means sort case-sensitively. +With a double prefix argument, also remove duplicate entries." + (interactive "P") + (cond + ((org-at-table-p) (org-call-with-arg 'org-table-sort-lines with-case)) + ((org-at-item-p) (org-call-with-arg 'org-sort-list with-case)) + (t + (org-call-with-arg 'org-sort-entries with-case)))) + +(defun org-sort-remove-invisible (s) + (remove-text-properties 0 (length s) org-rm-props s) + (while (string-match org-bracket-link-regexp s) + (setq s (replace-match (if (match-end 2) + (match-string 3 s) + (match-string 1 s)) t t s))) + s) + +(defvar org-priority-regexp) ; defined later in the file + +(defvar org-after-sorting-entries-or-items-hook nil + "Hook that is run after a bunch of entries or items have been sorted. +When children are sorted, the cursor is in the parent line when this +hook gets called. When a region or a plain list is sorted, the cursor +will be in the first entry of the sorted region/list.") + +(defun org-sort-entries + (&optional with-case sorting-type getkey-func compare-func property) + "Sort entries on a certain level of an outline tree. +If there is an active region, the entries in the region are sorted. +Else, if the cursor is before the first entry, sort the top-level items. +Else, the children of the entry at point are sorted. + +Sorting can be alphabetically, numerically, by date/time as given by +a time stamp, by a property or by priority. + +The command prompts for the sorting type unless it has been given to the +function through the SORTING-TYPE argument, which needs to be a character, +\(?n ?N ?a ?A ?t ?T ?s ?S ?d ?D ?p ?P ?r ?R ?f ?F). Here is the +precise meaning of each character: + +n Numerically, by converting the beginning of the entry/item to a number. +a Alphabetically, ignoring the TODO keyword and the priority, if any. +t By date/time, either the first active time stamp in the entry, or, if + none exist, by the first inactive one. +s By the scheduled date/time. +d By deadline date/time. +c By creation time, which is assumed to be the first inactive time stamp + at the beginning of a line. +p By priority according to the cookie. +r By the value of a property. + +Capital letters will reverse the sort order. + +If the SORTING-TYPE is ?f or ?F, then GETKEY-FUNC specifies a function to be +called with point at the beginning of the record. It must return either +a string or a number that should serve as the sorting key for that record. + +Comparing entries ignores case by default. However, with an optional argument +WITH-CASE, the sorting considers case as well." + (interactive "P") + (let ((case-func (if with-case 'identity 'downcase)) + start beg end stars re re2 + txt what tmp) + ;; Find beginning and end of region to sort + (cond + ((org-region-active-p) + ;; we will sort the region + (setq end (region-end) + what "region") + (goto-char (region-beginning)) + (if (not (org-on-heading-p)) (outline-next-heading)) + (setq start (point))) + ((or (org-on-heading-p) + (condition-case nil (progn (org-back-to-heading) t) (error nil))) + ;; we will sort the children of the current headline + (org-back-to-heading) + (setq start (point) + end (progn (org-end-of-subtree t t) + (or (bolp) (insert "\n")) + (org-back-over-empty-lines) + (point)) + what "children") + (goto-char start) + (show-subtree) + (outline-next-heading)) + (t + ;; we will sort the top-level entries in this file + (goto-char (point-min)) + (or (org-on-heading-p) (outline-next-heading)) + (setq start (point)) + (goto-char (point-max)) + (beginning-of-line 1) + (when (looking-at ".*?\\S-") + ;; File ends in a non-white line + (end-of-line 1) + (insert "\n")) + (setq end (point-max)) + (setq what "top-level") + (goto-char start) + (show-all))) + + (setq beg (point)) + (if (>= beg end) (error "Nothing to sort")) + + (looking-at "\\(\\*+\\)") + (setq stars (match-string 1) + re (concat "^" (regexp-quote stars) " +") + re2 (concat "^" (regexp-quote (substring stars 0 -1)) "[^*]") + txt (buffer-substring beg end)) + (if (not (equal (substring txt -1) "\n")) (setq txt (concat txt "\n"))) + (if (and (not (equal stars "*")) (string-match re2 txt)) + (error "Region to sort contains a level above the first entry")) + + (unless sorting-type + (message + "Sort %s: [a]lpha [n]umeric [p]riority p[r]operty todo[o]rder [f]unc + [t]ime [s]cheduled [d]eadline [c]reated + A/N/T/S/D/C/P/O/F means reversed:" + what) + (setq sorting-type (read-char-exclusive)) + + (and (= (downcase sorting-type) ?f) + (setq getkey-func + (org-icompleting-read "Sort using function: " + obarray 'fboundp t nil nil)) + (setq getkey-func (intern getkey-func))) + + (and (= (downcase sorting-type) ?r) + (setq property + (org-icompleting-read "Property: " + (mapcar 'list (org-buffer-property-keys t)) + nil t)))) + + (message "Sorting entries...") + + (save-restriction + (narrow-to-region start end) + (let ((dcst (downcase sorting-type)) + (case-fold-search nil) + (now (current-time))) + (sort-subr + (/= dcst sorting-type) + ;; This function moves to the beginning character of the "record" to + ;; be sorted. + (lambda nil + (if (re-search-forward re nil t) + (goto-char (match-beginning 0)) + (goto-char (point-max)))) + ;; This function moves to the last character of the "record" being + ;; sorted. + (lambda nil + (save-match-data + (condition-case nil + (outline-forward-same-level 1) + (error + (goto-char (point-max)))))) + ;; This function returns the value that gets sorted against. + (lambda nil + (cond + ((= dcst ?n) + (if (looking-at org-complex-heading-regexp) + (string-to-number (match-string 4)) + nil)) + ((= dcst ?a) + (if (looking-at org-complex-heading-regexp) + (funcall case-func (match-string 4)) + nil)) + ((= dcst ?t) + (let ((end (save-excursion (outline-next-heading) (point)))) + (if (or (re-search-forward org-ts-regexp end t) + (re-search-forward org-ts-regexp-both end t)) + (org-time-string-to-seconds (match-string 0)) + (org-float-time now)))) + ((= dcst ?c) + (let ((end (save-excursion (outline-next-heading) (point)))) + (if (re-search-forward + (concat "^[ \t]*\\[" org-ts-regexp1 "\\]") + end t) + (org-time-string-to-seconds (match-string 0)) + (org-float-time now)))) + ((= dcst ?s) + (let ((end (save-excursion (outline-next-heading) (point)))) + (if (re-search-forward org-scheduled-time-regexp end t) + (org-time-string-to-seconds (match-string 1)) + (org-float-time now)))) + ((= dcst ?d) + (let ((end (save-excursion (outline-next-heading) (point)))) + (if (re-search-forward org-deadline-time-regexp end t) + (org-time-string-to-seconds (match-string 1)) + (org-float-time now)))) + ((= dcst ?p) + (if (re-search-forward org-priority-regexp (point-at-eol) t) + (string-to-char (match-string 2)) + org-default-priority)) + ((= dcst ?r) + (or (org-entry-get nil property) "")) + ((= dcst ?o) + (if (looking-at org-complex-heading-regexp) + (- 9999 (length (member (match-string 2) + org-todo-keywords-1))))) + ((= dcst ?f) + (if getkey-func + (progn + (setq tmp (funcall getkey-func)) + (if (stringp tmp) (setq tmp (funcall case-func tmp))) + tmp) + (error "Invalid key function `%s'" getkey-func))) + (t (error "Invalid sorting type `%c'" sorting-type)))) + nil + (cond + ((= dcst ?a) 'string<) + ((= dcst ?f) compare-func) + ((member dcst '(?p ?t ?s ?d ?c)) '<) + (t nil))))) + (run-hooks 'org-after-sorting-entries-or-items-hook) + (message "Sorting entries...done"))) + +(defun org-do-sort (table what &optional with-case sorting-type) + "Sort TABLE of WHAT according to SORTING-TYPE. +The user will be prompted for the SORTING-TYPE if the call to this +function does not specify it. WHAT is only for the prompt, to indicate +what is being sorted. The sorting key will be extracted from +the car of the elements of the table. +If WITH-CASE is non-nil, the sorting will be case-sensitive." + (unless sorting-type + (message + "Sort %s: [a]lphabetic. [n]umeric. [t]ime. A/N/T means reversed:" + what) + (setq sorting-type (read-char-exclusive))) + (let ((dcst (downcase sorting-type)) + extractfun comparefun) + ;; Define the appropriate functions + (cond + ((= dcst ?n) + (setq extractfun 'string-to-number + comparefun (if (= dcst sorting-type) '< '>))) + ((= dcst ?a) + (setq extractfun (if with-case (lambda(x) (org-sort-remove-invisible x)) + (lambda(x) (downcase (org-sort-remove-invisible x)))) + comparefun (if (= dcst sorting-type) + 'string< + (lambda (a b) (and (not (string< a b)) + (not (string= a b))))))) + ((= dcst ?t) + (setq extractfun + (lambda (x) + (if (or (string-match org-ts-regexp x) + (string-match org-ts-regexp-both x)) + (org-float-time + (org-time-string-to-time (match-string 0 x))) + 0)) + comparefun (if (= dcst sorting-type) '< '>))) + (t (error "Invalid sorting type `%c'" sorting-type))) + + (sort (mapcar (lambda (x) (cons (funcall extractfun (car x)) (cdr x))) + table) + (lambda (a b) (funcall comparefun (car a) (car b)))))) + + +;;; The orgstruct minor mode + +;; Define a minor mode which can be used in other modes in order to +;; integrate the org-mode structure editing commands. + +;; This is really a hack, because the org-mode structure commands use +;; keys which normally belong to the major mode. Here is how it +;; works: The minor mode defines all the keys necessary to operate the +;; structure commands, but wraps the commands into a function which +;; tests if the cursor is currently at a headline or a plain list +;; item. If that is the case, the structure command is used, +;; temporarily setting many Org-mode variables like regular +;; expressions for filling etc. However, when any of those keys is +;; used at a different location, function uses `key-binding' to look +;; up if the key has an associated command in another currently active +;; keymap (minor modes, major mode, global), and executes that +;; command. There might be problems if any of the keys is otherwise +;; used as a prefix key. + +;; Another challenge is that the key binding for TAB can be tab or \C-i, +;; likewise the binding for RET can be return or \C-m. Orgtbl-mode +;; addresses this by checking explicitly for both bindings. + +(defvar orgstruct-mode-map (make-sparse-keymap) + "Keymap for the minor `orgstruct-mode'.") + +(defvar org-local-vars nil + "List of local variables, for use by `orgstruct-mode'.") + +;;;###autoload +(define-minor-mode orgstruct-mode + "Toggle the minor mode `orgstruct-mode'. +This mode is for using Org-mode structure commands in other +modes. The following keys behave as if Org-mode were active, if +the cursor is on a headline, or on a plain list item (both as +defined by Org-mode). + +M-up Move entry/item up +M-down Move entry/item down +M-left Promote +M-right Demote +M-S-up Move entry/item up +M-S-down Move entry/item down +M-S-left Promote subtree +M-S-right Demote subtree +M-q Fill paragraph and items like in Org-mode +C-c ^ Sort entries +C-c - Cycle list bullet +TAB Cycle item visibility +M-RET Insert new heading/item +S-M-RET Insert new TODO heading / Checkbox item +C-c C-c Set tags / toggle checkbox" + nil " OrgStruct" nil + (org-load-modules-maybe) + (and (orgstruct-setup) (defun orgstruct-setup () nil))) + +;;;###autoload +(defun turn-on-orgstruct () + "Unconditionally turn on `orgstruct-mode'." + (orgstruct-mode 1)) + +(defun orgstruct++-mode (&optional arg) + "Toggle `orgstruct-mode', the enhanced version of it. +In addition to setting orgstruct-mode, this also exports all indentation +and autofilling variables from org-mode into the buffer. It will also +recognize item context in multiline items. +Note that turning off orgstruct-mode will *not* remove the +indentation/paragraph settings. This can only be done by refreshing the +major mode, for example with \\[normal-mode]." + (interactive "P") + (setq arg (prefix-numeric-value (or arg (if orgstruct-mode -1 1)))) + (if (< arg 1) + (orgstruct-mode -1) + (orgstruct-mode 1) + (let (var val) + (mapc + (lambda (x) + (when (string-match + "^\\(paragraph-\\|auto-fill\\|fill-paragraph\\|adaptive-fill\\|indent-\\)" + (symbol-name (car x))) + (setq var (car x) val (nth 1 x)) + (org-set-local var (if (eq (car-safe val) 'quote) (nth 1 val) val)))) + org-local-vars) + (org-set-local 'orgstruct-is-++ t)))) + +(defvar orgstruct-is-++ nil + "Is `orgstruct-mode' in ++ version in the current-buffer?") +(make-variable-buffer-local 'orgstruct-is-++) + +;;;###autoload +(defun turn-on-orgstruct++ () + "Unconditionally turn on `orgstruct++-mode'." + (orgstruct++-mode 1)) + +(defun orgstruct-error () + "Error when there is no default binding for a structure key." + (interactive) + (error "This key has no function outside structure elements")) + +(defun orgstruct-setup () + "Setup orgstruct keymaps." + (let ((nfunc 0) + (bindings + (list + '([(meta up)] org-metaup) + '([(meta down)] org-metadown) + '([(meta left)] org-metaleft) + '([(meta right)] org-metaright) + '([(meta shift up)] org-shiftmetaup) + '([(meta shift down)] org-shiftmetadown) + '([(meta shift left)] org-shiftmetaleft) + '([(meta shift right)] org-shiftmetaright) + '([?\e (up)] org-metaup) + '([?\e (down)] org-metadown) + '([?\e (left)] org-metaleft) + '([?\e (right)] org-metaright) + '([?\e (shift up)] org-shiftmetaup) + '([?\e (shift down)] org-shiftmetadown) + '([?\e (shift left)] org-shiftmetaleft) + '([?\e (shift right)] org-shiftmetaright) + '([(shift up)] org-shiftup) + '([(shift down)] org-shiftdown) + '([(shift left)] org-shiftleft) + '([(shift right)] org-shiftright) + '("\C-c\C-c" org-ctrl-c-ctrl-c) + '("\M-q" fill-paragraph) + '("\C-c^" org-sort) + '("\C-c-" org-cycle-list-bullet))) + elt key fun cmd) + (while (setq elt (pop bindings)) + (setq nfunc (1+ nfunc)) + (setq key (org-key (car elt)) + fun (nth 1 elt) + cmd (orgstruct-make-binding fun nfunc key)) + (org-defkey orgstruct-mode-map key cmd)) + + ;; Special treatment needed for TAB and RET + (org-defkey orgstruct-mode-map [(tab)] + (orgstruct-make-binding 'org-cycle 102 [(tab)] "\C-i")) + (org-defkey orgstruct-mode-map "\C-i" + (orgstruct-make-binding 'org-cycle 103 "\C-i" [(tab)])) + + (org-defkey orgstruct-mode-map "\M-\C-m" + (orgstruct-make-binding 'org-insert-heading 105 + "\M-\C-m" [(meta return)])) + (org-defkey orgstruct-mode-map [(meta return)] + (orgstruct-make-binding 'org-insert-heading 106 + [(meta return)] "\M-\C-m")) + + (org-defkey orgstruct-mode-map [(shift meta return)] + (orgstruct-make-binding 'org-insert-todo-heading 107 + [(meta return)] "\M-\C-m")) + + (org-defkey orgstruct-mode-map "\e\C-m" + (orgstruct-make-binding 'org-insert-heading 108 + "\e\C-m" [?\e (return)])) + (org-defkey orgstruct-mode-map [?\e (return)] + (orgstruct-make-binding 'org-insert-heading 109 + [?\e (return)] "\e\C-m")) + (org-defkey orgstruct-mode-map [?\e (shift return)] + (orgstruct-make-binding 'org-insert-todo-heading 110 + [?\e (return)] "\e\C-m")) + + (unless org-local-vars + (setq org-local-vars (org-get-local-variables))) + + t)) + +(defun orgstruct-make-binding (fun n &rest keys) + "Create a function for binding in the structure minor mode. +FUN is the command to call inside a table. N is used to create a unique +command name. KEYS are keys that should be checked in for a command +to execute outside of tables." + (eval + (list 'defun + (intern (concat "orgstruct-hijacker-command-" (int-to-string n))) + '(arg) + (concat "In Structure, run `" (symbol-name fun) "'.\n" + "Outside of structure, run the binding of `" + (mapconcat (lambda (x) (format "%s" x)) keys "' or `") + "'.") + '(interactive "p") + (list 'if + `(org-context-p 'headline 'item + (and orgstruct-is-++ + ,(and (memq fun '(org-insert-heading org-insert-todo-heading)) t) + 'item-body)) + (list 'org-run-like-in-org-mode (list 'quote fun)) + (list 'let '(orgstruct-mode) + (list 'call-interactively + (append '(or) + (mapcar (lambda (k) + (list 'key-binding k)) + keys) + '('orgstruct-error)))))))) + +(defun org-context-p (&rest contexts) + "Check if local context is any of CONTEXTS. +Possible values in the list of contexts are `table', `headline', and `item'." + (let ((pos (point))) + (goto-char (point-at-bol)) + (prog1 (or (and (memq 'table contexts) + (looking-at "[ \t]*|")) + (and (memq 'headline contexts) +;;????????? (looking-at "\\*+")) + (looking-at outline-regexp)) + (and (memq 'item contexts) + (looking-at "[ \t]*\\([-+*] \\|[0-9]+[.)] \\)")) + (and (memq 'item-body contexts) + (org-in-item-p))) + (goto-char pos)))) + +(defun org-get-local-variables () + "Return a list of all local variables in an org-mode buffer." + (let (varlist) + (with-current-buffer (get-buffer-create "*Org tmp*") + (erase-buffer) + (org-mode) + (setq varlist (buffer-local-variables))) + (kill-buffer "*Org tmp*") + (delq nil + (mapcar + (lambda (x) + (setq x + (if (symbolp x) + (list x) + (list (car x) (list 'quote (cdr x))))) + (if (string-match + "^\\(org-\\|orgtbl-\\|outline-\\|comment-\\|paragraph-\\|auto-fill\\|fill-paragraph\\|adaptive-fill\\|indent-\\)" + (symbol-name (car x))) + x nil)) + varlist)))) + +;;;###autoload +(defun org-run-like-in-org-mode (cmd) + "Run a command, pretending that the current buffer is in Org-mode. +This will temporarily bind local variables that are typically bound in +Org-mode to the values they have in Org-mode, and then interactively +call CMD." + (org-load-modules-maybe) + (unless org-local-vars + (setq org-local-vars (org-get-local-variables))) + (eval (list 'let org-local-vars + (list 'call-interactively (list 'quote cmd))))) + +;;;; Archiving + +(defun org-get-category (&optional pos) + "Get the category applying to position POS." + (get-text-property (or pos (point)) 'org-category)) + +(defun org-refresh-category-properties () + "Refresh category text properties in the buffer." + (let ((def-cat (cond + ((null org-category) + (if buffer-file-name + (file-name-sans-extension + (file-name-nondirectory buffer-file-name)) + "???")) + ((symbolp org-category) (symbol-name org-category)) + (t org-category))) + beg end cat pos optionp) + (org-unmodified + (save-excursion + (save-restriction + (widen) + (goto-char (point-min)) + (put-text-property (point) (point-max) 'org-category def-cat) + (while (re-search-forward + "^\\(#\\+CATEGORY:\\|[ \t]*:CATEGORY:\\)\\(.*\\)" nil t) + (setq pos (match-end 0) + optionp (equal (char-after (match-beginning 0)) ?#) + cat (org-trim (match-string 2))) + (if optionp + (setq beg (point-at-bol) end (point-max)) + (org-back-to-heading t) + (setq beg (point) end (org-end-of-subtree t t))) + (put-text-property beg end 'org-category cat) + (goto-char pos))))))) + + +;;;; Link Stuff + +;;; Link abbreviations + +(defun org-link-expand-abbrev (link) + "Apply replacements as defined in `org-link-abbrev-alist." + (if (string-match "^\\([a-zA-Z][-_a-zA-Z0-9]*\\)\\(::?\\(.*\\)\\)?$" link) + (let* ((key (match-string 1 link)) + (as (or (assoc key org-link-abbrev-alist-local) + (assoc key org-link-abbrev-alist))) + (tag (and (match-end 2) (match-string 3 link))) + rpl) + (if (not as) + link + (setq rpl (cdr as)) + (cond + ((symbolp rpl) (funcall rpl tag)) + ((string-match "%s" rpl) (replace-match (or tag "") t t rpl)) + ((string-match "%h" rpl) + (replace-match (url-hexify-string (or tag "")) t t rpl)) + (t (concat rpl tag))))) + link)) + +;;; Storing and inserting links + +(defvar org-insert-link-history nil + "Minibuffer history for links inserted with `org-insert-link'.") + +(defvar org-stored-links nil + "Contains the links stored with `org-store-link'.") + +(defvar org-store-link-plist nil + "Plist with info about the most recently link created with `org-store-link'.") + +(defvar org-link-protocols nil + "Link protocols added to Org-mode using `org-add-link-type'.") + +(defvar org-store-link-functions nil + "List of functions that are called to create and store a link. +Each function will be called in turn until one returns a non-nil +value. Each function should check if it is responsible for creating +this link (for example by looking at the major mode). +If not, it must exit and return nil. +If yes, it should return a non-nil value after a calling +`org-store-link-props' with a list of properties and values. +Special properties are: + +:type The link prefix, like \"http\". This must be given. +:link The link, like \"http://www.astro.uva.nl/~dominik\". + This is obligatory as well. +:description Optional default description for the second pair + of brackets in an Org-mode link. The user can still change + this when inserting this link into an Org-mode buffer. + +In addition to these, any additional properties can be specified +and then used in remember templates.") + +(defun org-add-link-type (type &optional follow export) + "Add TYPE to the list of `org-link-types'. +Re-compute all regular expressions depending on `org-link-types' + +FOLLOW and EXPORT are two functions. + +FOLLOW should take the link path as the single argument and do whatever +is necessary to follow the link, for example find a file or display +a mail message. + +EXPORT should format the link path for export to one of the export formats. +It should be a function accepting three arguments: + + path the path of the link, the text after the prefix (like \"http:\") + desc the description of the link, if any, nil if there was no description + format the export format, a symbol like `html' or `latex' or `ascii'.. + +The function may use the FORMAT information to return different values +depending on the format. The return value will be put literally into +the exported file. If the return value is nil, this means Org should +do what it normally does with links which do not have EXPORT defined. + +Org-mode has a built-in default for exporting links. If you are happy with +this default, there is no need to define an export function for the link +type. For a simple example of an export function, see `org-bbdb.el'." + (add-to-list 'org-link-types type t) + (org-make-link-regexps) + (if (assoc type org-link-protocols) + (setcdr (assoc type org-link-protocols) (list follow export)) + (push (list type follow export) org-link-protocols))) + +(defvar org-agenda-buffer-name) + +;;;###autoload +(defun org-store-link (arg) + "\\<org-mode-map>Store an org-link to the current location. +This link is added to `org-stored-links' and can later be inserted +into an org-buffer with \\[org-insert-link]. + +For some link types, a prefix arg is interpreted: +For links to usenet articles, arg negates `org-gnus-prefer-web-links'. +For file links, arg negates `org-context-in-file-links'." + (interactive "P") + (org-load-modules-maybe) + (setq org-store-link-plist nil) ; reset + (let ((outline-regexp (org-get-limited-outline-regexp)) + link cpltxt desc description search txt custom-id agenda-link) + (cond + + ((run-hook-with-args-until-success 'org-store-link-functions) + (setq link (plist-get org-store-link-plist :link) + desc (or (plist-get org-store-link-plist :description) link))) + + ((equal (buffer-name) "*Org Edit Src Example*") + (let (label gc) + (while (or (not label) + (save-excursion + (save-restriction + (widen) + (goto-char (point-min)) + (re-search-forward + (regexp-quote (format org-coderef-label-format label)) + nil t)))) + (when label (message "Label exists already") (sit-for 2)) + (setq label (read-string "Code line label: " label))) + (end-of-line 1) + (setq link (format org-coderef-label-format label)) + (setq gc (- 79 (length link))) + (if (< (current-column) gc) (org-move-to-column gc t) (insert " ")) + (insert link) + (setq link (concat "(" label ")") desc nil))) + + ((equal (org-bound-and-true-p org-agenda-buffer-name) (buffer-name)) + ;; We are in the agenda, link to referenced location + (let ((m (or (get-text-property (point) 'org-hd-marker) + (get-text-property (point) 'org-marker)))) + (when m + (org-with-point-at m + (setq agenda-link + (if (interactive-p) + (call-interactively 'org-store-link) + (org-store-link nil))))))) + + ((eq major-mode 'calendar-mode) + (let ((cd (calendar-cursor-to-date))) + (setq link + (format-time-string + (car org-time-stamp-formats) + (apply 'encode-time + (list 0 0 0 (nth 1 cd) (nth 0 cd) (nth 2 cd) + nil nil nil)))) + (org-store-link-props :type "calendar" :date cd))) + + ((eq major-mode 'w3-mode) + (setq cpltxt (if (and (buffer-name) + (not (string-match "Untitled" (buffer-name)))) + (buffer-name) + (url-view-url t)) + link (org-make-link (url-view-url t))) + (org-store-link-props :type "w3" :url (url-view-url t))) + + ((eq major-mode 'w3m-mode) + (setq cpltxt (or w3m-current-title w3m-current-url) + link (org-make-link w3m-current-url)) + (org-store-link-props :type "w3m" :url (url-view-url t))) + + ((setq search (run-hook-with-args-until-success + 'org-create-file-search-functions)) + (setq link (concat "file:" (abbreviate-file-name buffer-file-name) + "::" search)) + (setq cpltxt (or description link))) + + ((eq major-mode 'image-mode) + (setq cpltxt (concat "file:" + (abbreviate-file-name buffer-file-name)) + link (org-make-link cpltxt)) + (org-store-link-props :type "image" :file buffer-file-name)) + + ((eq major-mode 'dired-mode) + ;; link to the file in the current line + (let ((file (dired-get-filename nil t))) + (setq file (if file + (abbreviate-file-name + (expand-file-name (dired-get-filename nil t))) + ;; otherwise, no file so use current directory. + default-directory)) + (setq cpltxt (concat "file:" file) + link (org-make-link cpltxt)))) + + ((and (buffer-file-name (buffer-base-buffer)) (org-mode-p)) + (setq custom-id (ignore-errors (org-entry-get nil "CUSTOM_ID"))) + (cond + ((org-in-regexp "<<\\(.*?\\)>>") + (setq cpltxt + (concat "file:" + (abbreviate-file-name + (buffer-file-name (buffer-base-buffer))) + "::" (match-string 1)) + link (org-make-link cpltxt))) + ((and (featurep 'org-id) + (or (eq org-link-to-org-use-id t) + (and (eq org-link-to-org-use-id 'create-if-interactive) + (interactive-p)) + (and (eq org-link-to-org-use-id 'create-if-interactive-and-no-custom-id) + (interactive-p) + (not custom-id)) + (and org-link-to-org-use-id + (condition-case nil + (org-entry-get nil "ID") + (error nil))))) + ;; We can make a link using the ID. + (setq link (condition-case nil + (prog1 (org-id-store-link) + (setq desc (plist-get org-store-link-plist + :description))) + (error + ;; probably before first headline, link to file only + (concat "file:" + (abbreviate-file-name + (buffer-file-name (buffer-base-buffer)))))))) + (t + ;; Just link to current headline + (setq cpltxt (concat "file:" + (abbreviate-file-name + (buffer-file-name (buffer-base-buffer))))) + ;; Add a context search string + (when (org-xor org-context-in-file-links arg) + (setq txt (cond + ((org-on-heading-p) nil) + ((org-region-active-p) + (buffer-substring (region-beginning) (region-end))) + (t nil))) + (when (or (null txt) (string-match "\\S-" txt)) + (setq cpltxt + (concat cpltxt "::" + (condition-case nil + (org-make-org-heading-search-string txt) + (error ""))) + desc (or (nth 4 (ignore-errors + (org-heading-components))) "NONE")))) + (if (string-match "::\\'" cpltxt) + (setq cpltxt (substring cpltxt 0 -2))) + (setq link (org-make-link cpltxt))))) + + ((buffer-file-name (buffer-base-buffer)) + ;; Just link to this file here. + (setq cpltxt (concat "file:" + (abbreviate-file-name + (buffer-file-name (buffer-base-buffer))))) + ;; Add a context string + (when (org-xor org-context-in-file-links arg) + (setq txt (if (org-region-active-p) + (buffer-substring (region-beginning) (region-end)) + (buffer-substring (point-at-bol) (point-at-eol)))) + ;; Only use search option if there is some text. + (when (string-match "\\S-" txt) + (setq cpltxt + (concat cpltxt "::" (org-make-org-heading-search-string txt)) + desc "NONE"))) + (setq link (org-make-link cpltxt))) + + ((interactive-p) + (error "Cannot link to a buffer which is not visiting a file")) + + (t (setq link nil))) + + (if (consp link) (setq cpltxt (car link) link (cdr link))) + (setq link (or link cpltxt) + desc (or desc cpltxt)) + (if (equal desc "NONE") (setq desc nil)) + + (if (and (or (interactive-p) executing-kbd-macro) link) + (progn + (setq org-stored-links + (cons (list link desc) org-stored-links)) + (message "Stored: %s" (or desc link)) + (when custom-id + (setq link (concat "file:" (abbreviate-file-name (buffer-file-name)) + "::#" custom-id)) + (setq org-stored-links + (cons (list link desc) org-stored-links)))) + (or agenda-link (and link (org-make-link-string link desc)))))) + +(defun org-store-link-props (&rest plist) + "Store link properties, extract names and addresses." + (let (x adr) + (when (setq x (plist-get plist :from)) + (setq adr (mail-extract-address-components x)) + (setq plist (plist-put plist :fromname (car adr))) + (setq plist (plist-put plist :fromaddress (nth 1 adr)))) + (when (setq x (plist-get plist :to)) + (setq adr (mail-extract-address-components x)) + (setq plist (plist-put plist :toname (car adr))) + (setq plist (plist-put plist :toaddress (nth 1 adr))))) + (let ((from (plist-get plist :from)) + (to (plist-get plist :to))) + (when (and from to org-from-is-user-regexp) + (setq plist + (plist-put plist :fromto + (if (string-match org-from-is-user-regexp from) + (concat "to %t") + (concat "from %f")))))) + (setq org-store-link-plist plist)) + +(defun org-add-link-props (&rest plist) + "Add these properties to the link property list." + (let (key value) + (while plist + (setq key (pop plist) value (pop plist)) + (setq org-store-link-plist + (plist-put org-store-link-plist key value))))) + +(defun org-email-link-description (&optional fmt) + "Return the description part of an email link. +This takes information from `org-store-link-plist' and formats it +according to FMT (default from `org-email-link-description-format')." + (setq fmt (or fmt org-email-link-description-format)) + (let* ((p org-store-link-plist) + (to (plist-get p :toaddress)) + (from (plist-get p :fromaddress)) + (table + (list + (cons "%c" (plist-get p :fromto)) + (cons "%F" (plist-get p :from)) + (cons "%f" (or (plist-get p :fromname) (plist-get p :fromaddress) "?")) + (cons "%T" (plist-get p :to)) + (cons "%t" (or (plist-get p :toname) (plist-get p :toaddress) "?")) + (cons "%s" (plist-get p :subject)) + (cons "%m" (plist-get p :message-id))))) + (when (string-match "%c" fmt) + ;; Check if the user wrote this message + (if (and org-from-is-user-regexp from to + (save-match-data (string-match org-from-is-user-regexp from))) + (setq fmt (replace-match "to %t" t t fmt)) + (setq fmt (replace-match "from %f" t t fmt)))) + (org-replace-escapes fmt table))) + +(defun org-make-org-heading-search-string (&optional string heading) + "Make search string for STRING or current headline." + (interactive) + (let ((s (or string (org-get-heading))) + (lines org-context-in-file-links)) + (unless (and string (not heading)) + ;; We are using a headline, clean up garbage in there. + (if (string-match org-todo-regexp s) + (setq s (replace-match "" t t s))) + (if (string-match (org-re ":[[:alnum:]_@#%:]+:[ \t]*$") s) + (setq s (replace-match "" t t s))) + (setq s (org-trim s)) + (if (string-match (concat "^\\(" org-quote-string "\\|" + org-comment-string "\\)") s) + (setq s (replace-match "" t t s))) + (while (string-match org-ts-regexp s) + (setq s (replace-match "" t t s)))) + (or string (setq s (concat "*" s))) ; Add * for headlines + (when (and string (integerp lines) (> lines 0)) + (let ((slines (org-split-string s "\n"))) + (when (< lines (length slines)) + (setq s (mapconcat + 'identity + (reverse (nthcdr (- (length slines) lines) + (reverse slines))) "\n"))))) + (mapconcat 'identity (org-split-string s "[ \t]+") " "))) + +(defun org-make-link (&rest strings) + "Concatenate STRINGS." + (apply 'concat strings)) + +(defun org-make-link-string (link &optional description) + "Make a link with brackets, consisting of LINK and DESCRIPTION." + (unless (string-match "\\S-" link) + (error "Empty link")) + (when (and description + (stringp description) + (not (string-match "\\S-" description))) + (setq description nil)) + (when (stringp description) + ;; Remove brackets from the description, they are fatal. + (while (string-match "\\[" description) + (setq description (replace-match "{" t t description))) + (while (string-match "\\]" description) + (setq description (replace-match "}" t t description)))) + (when (equal (org-link-escape link) description) + ;; No description needed, it is identical + (setq description nil)) + (when (and (not description) + (not (equal link (org-link-escape link)))) + (setq description (org-extract-attributes link))) + (setq link (if (string-match org-link-types-re link) + (concat (match-string 1 link) + (org-link-escape (substring link (match-end 1)))) + (org-link-escape link))) + (concat "[[" link "]" + (if description (concat "[" description "]") "") + "]")) + +(defconst org-link-escape-chars + '((?\ . "%20") + (?\[ . "%5B") + (?\] . "%5D") + (?\340 . "%E0") ; `a + (?\342 . "%E2") ; ^a + (?\347 . "%E7") ; ,c + (?\350 . "%E8") ; `e + (?\351 . "%E9") ; 'e + (?\352 . "%EA") ; ^e + (?\356 . "%EE") ; ^i + (?\364 . "%F4") ; ^o + (?\371 . "%F9") ; `u + (?\373 . "%FB") ; ^u + (?\; . "%3B") +;; (?? . "%3F") + (?= . "%3D") + (?+ . "%2B") + ) + "Association list of escapes for some characters problematic in links. +This is the list that is used for internal purposes.") + +(defvar org-url-encoding-use-url-hexify nil) + +(defconst org-link-escape-chars-browser + '((?\ . "%20")) ; 32 for the SPC char + "Association list of escapes for some characters problematic in links. +This is the list that is used before handing over to the browser.") + +(defun org-link-escape (text &optional table) + "Escape characters in TEXT that are problematic for links." + (if (and org-url-encoding-use-url-hexify (not table)) + (url-hexify-string text) + (setq table (or table org-link-escape-chars)) + (when text + (let ((re (mapconcat (lambda (x) (regexp-quote + (char-to-string (car x)))) + table "\\|"))) + (while (string-match re text) + (setq text + (replace-match + (cdr (assoc (string-to-char (match-string 0 text)) + table)) + t t text))) + text)))) + +(defun org-link-unescape (text &optional table) + "Reverse the action of `org-link-escape'." + (if (and org-url-encoding-use-url-hexify (not table)) + (url-unhex-string text) + (setq table (or table org-link-escape-chars)) + (when text + (let ((case-fold-search t) + (re (mapconcat (lambda (x) (regexp-quote (downcase (cdr x)))) + table "\\|"))) + (while (string-match re text) + (setq text + (replace-match + (char-to-string (car (rassoc (upcase (match-string 0 text)) + table))) + t t text))) + text)))) + +(defun org-xor (a b) + "Exclusive or." + (if a (not b) b)) + +(defun org-fixup-message-id-for-http (s) + "Replace special characters in a message id, so it can be used in an http query." + (when (string-match "%" s) + (setq s (mapconcat (lambda (c) + (if (eq c ?%) + "%25" + (char-to-string c))) + s ""))) + (while (string-match "<" s) + (setq s (replace-match "%3C" t t s))) + (while (string-match ">" s) + (setq s (replace-match "%3E" t t s))) + (while (string-match "@" s) + (setq s (replace-match "%40" t t s))) + s) + +;;;###autoload +(defun org-insert-link-global () + "Insert a link like Org-mode does. +This command can be called in any mode to insert a link in Org-mode syntax." + (interactive) + (org-load-modules-maybe) + (org-run-like-in-org-mode 'org-insert-link)) + +(defun org-insert-link (&optional complete-file link-location) + "Insert a link. At the prompt, enter the link. + +Completion can be used to insert any of the link protocol prefixes like +http or ftp in use. + +The history can be used to select a link previously stored with +`org-store-link'. When the empty string is entered (i.e. if you just +press RET at the prompt), the link defaults to the most recently +stored link. As SPC triggers completion in the minibuffer, you need to +use M-SPC or C-q SPC to force the insertion of a space character. + +You will also be prompted for a description, and if one is given, it will +be displayed in the buffer instead of the link. + +If there is already a link at point, this command will allow you to edit link +and description parts. + +With a \\[universal-argument] prefix, prompts for a file to link to. The file name can +be selected using completion. The path to the file will be relative to the +current directory if the file is in the current directory or a subdirectory. +Otherwise, the link will be the absolute path as completed in the minibuffer +\(i.e. normally ~/path/to/file). You can configure this behavior using the +option `org-link-file-path-type'. + +With two \\[universal-argument] prefixes, enforce an absolute path even if the file is in +the current directory or below. + +With three \\[universal-argument] prefixes, negate the meaning of +`org-keep-stored-link-after-insertion'. + +If `org-make-link-description-function' is non-nil, this function will be +called with the link target, and the result will be the default +link description. + +If the LINK-LOCATION parameter is non-nil, this value will be +used as the link location instead of reading one interactively." + (interactive "P") + (let* ((wcf (current-window-configuration)) + (region (if (org-region-active-p) + (buffer-substring (region-beginning) (region-end)))) + (remove (and region (list (region-beginning) (region-end)))) + (desc region) + tmphist ; byte-compile incorrectly complains about this + (link link-location) + entry file all-prefixes) + (cond + (link-location) ; specified by arg, just use it. + ((org-in-regexp org-bracket-link-regexp 1) + ;; We do have a link at point, and we are going to edit it. + (setq remove (list (match-beginning 0) (match-end 0))) + (setq desc (if (match-end 3) (org-match-string-no-properties 3))) + (setq link (read-string "Link: " + (org-link-unescape + (org-match-string-no-properties 1))))) + ((or (org-in-regexp org-angle-link-re) + (org-in-regexp org-plain-link-re)) + ;; Convert to bracket link + (setq remove (list (match-beginning 0) (match-end 0)) + link (read-string "Link: " + (org-remove-angle-brackets (match-string 0))))) + ((member complete-file '((4) (16))) + ;; Completing read for file names. + (setq link (org-file-complete-link complete-file))) + (t + ;; Read link, with completion for stored links. + (with-output-to-temp-buffer "*Org Links*" + (princ "Insert a link. +Use TAB to complete link prefixes, then RET for type-specific completion support\n") + (when org-stored-links + (princ "\nStored links are available with <up>/<down> or M-p/n (most recent with RET):\n\n") + (princ (mapconcat + (lambda (x) + (if (nth 1 x) (concat (car x) " (" (nth 1 x) ")") (car x))) + (reverse org-stored-links) "\n")))) + (let ((cw (selected-window))) + (select-window (get-buffer-window "*Org Links*" 'visible)) + (setq truncate-lines t) + (unless (pos-visible-in-window-p (point-max)) + (org-fit-window-to-buffer)) + (and (window-live-p cw) (select-window cw))) + ;; Fake a link history, containing the stored links. + (setq tmphist (append (mapcar 'car org-stored-links) + org-insert-link-history)) + (setq all-prefixes (append (mapcar 'car org-link-abbrev-alist-local) + (mapcar 'car org-link-abbrev-alist) + org-link-types)) + (unwind-protect + (progn + (setq link + (let ((org-completion-use-ido nil) + (org-completion-use-iswitchb nil)) + (org-completing-read + "Link: " + (append + (mapcar (lambda (x) (list (concat x ":"))) + all-prefixes) + (mapcar 'car org-stored-links)) + nil nil nil + 'tmphist + (car (car org-stored-links))))) + (if (not (string-match "\\S-" link)) + (error "No link selected")) + (if (or (member link all-prefixes) + (and (equal ":" (substring link -1)) + (member (substring link 0 -1) all-prefixes) + (setq link (substring link 0 -1)))) + (setq link (org-link-try-special-completion link)))) + (set-window-configuration wcf) + (kill-buffer "*Org Links*")) + (setq entry (assoc link org-stored-links)) + (or entry (push link org-insert-link-history)) + (if (funcall (if (equal complete-file '(64)) 'not 'identity) + (not org-keep-stored-link-after-insertion)) + (setq org-stored-links (delq (assoc link org-stored-links) + org-stored-links))) + (setq desc (or desc (nth 1 entry))))) + + (if (string-match org-plain-link-re link) + ;; URL-like link, normalize the use of angular brackets. + (setq link (org-make-link (org-remove-angle-brackets link)))) + + ;; Check if we are linking to the current file with a search option + ;; If yes, simplify the link by using only the search option. + (when (and buffer-file-name + (string-match "^file:\\(.+?\\)::\\([^>]+\\)" link)) + (let* ((path (match-string 1 link)) + (case-fold-search nil) + (search (match-string 2 link))) + (save-match-data + (if (equal (file-truename buffer-file-name) (file-truename path)) + ;; We are linking to this same file, with a search option + (setq link search))))) + + ;; Check if we can/should use a relative path. If yes, simplify the link + (when (string-match "^\\(file:\\|docview:\\)\\(.*\\)" link) + (let* ((type (match-string 1 link)) + (path (match-string 2 link)) + (origpath path) + (case-fold-search nil)) + (cond + ((or (eq org-link-file-path-type 'absolute) + (equal complete-file '(16))) + (setq path (abbreviate-file-name (expand-file-name path)))) + ((eq org-link-file-path-type 'noabbrev) + (setq path (expand-file-name path))) + ((eq org-link-file-path-type 'relative) + (setq path (file-relative-name path))) + (t + (save-match-data + (if (string-match (concat "^" (regexp-quote + (expand-file-name + (file-name-as-directory + default-directory)))) + (expand-file-name path)) + ;; We are linking a file with relative path name. + (setq path (substring (expand-file-name path) + (match-end 0))) + (setq path (abbreviate-file-name (expand-file-name path))))))) + (setq link (concat type path)) + (if (equal desc origpath) + (setq desc path)))) + + (if org-make-link-description-function + (setq desc (funcall org-make-link-description-function link desc))) + + (setq desc (read-string "Description: " desc)) + (unless (string-match "\\S-" desc) (setq desc nil)) + (if remove (apply 'delete-region remove)) + (insert (org-make-link-string link desc)))) + +(defun org-link-try-special-completion (type) + "If there is completion support for link type TYPE, offer it." + (let ((fun (intern (concat "org-" type "-complete-link")))) + (if (functionp fun) + (funcall fun) + (read-string "Link (no completion support): " (concat type ":"))))) + +(defun org-file-complete-link (&optional arg) + "Create a file link using completion." + (let (file link) + (setq file (read-file-name "File: ")) + (let ((pwd (file-name-as-directory (expand-file-name "."))) + (pwd1 (file-name-as-directory (abbreviate-file-name + (expand-file-name "."))))) + (cond + ((equal arg '(16)) + (setq link (org-make-link + "file:" + (abbreviate-file-name (expand-file-name file))))) + ((string-match (concat "^" (regexp-quote pwd1) "\\(.+\\)") file) + (setq link (org-make-link "file:" (match-string 1 file)))) + ((string-match (concat "^" (regexp-quote pwd) "\\(.+\\)") + (expand-file-name file)) + (setq link (org-make-link + "file:" (match-string 1 (expand-file-name file))))) + (t (setq link (org-make-link "file:" file))))) + link)) + +(defun org-completing-read (&rest args) + "Completing-read with SPACE being a normal character." + (let ((minibuffer-local-completion-map + (copy-keymap minibuffer-local-completion-map))) + (org-defkey minibuffer-local-completion-map " " 'self-insert-command) + (org-defkey minibuffer-local-completion-map "?" 'self-insert-command) + (apply 'org-icompleting-read args))) + +(defun org-completing-read-no-i (&rest args) + (let (org-completion-use-ido org-completion-use-iswitchb) + (apply 'org-completing-read args))) + +(defun org-iswitchb-completing-read (prompt choices &rest args) + "Use iswitch as a completing-read replacement to choose from choices. +PROMPT is a string to prompt with. CHOICES is a list of strings to choose +from." + (let* ((iswitchb-use-virtual-buffers nil) + (iswitchb-make-buflist-hook + (lambda () + (setq iswitchb-temp-buflist choices)))) + (iswitchb-read-buffer prompt))) + +(defun org-icompleting-read (&rest args) + "Completing-read using `ido-mode' or `iswitchb' speedups if available." + (org-without-partial-completion + (if (and org-completion-use-ido + (fboundp 'ido-completing-read) + (boundp 'ido-mode) ido-mode + (listp (second args))) + (let ((ido-enter-matching-directory nil)) + (apply 'ido-completing-read (concat (car args)) + (if (consp (car (nth 1 args))) + (mapcar (lambda (x) (car x)) (nth 1 args)) + (nth 1 args)) + (cddr args))) + (if (and org-completion-use-iswitchb + (boundp 'iswitchb-mode) iswitchb-mode + (listp (second args))) + (apply 'org-iswitchb-completing-read (concat (car args)) + (if (consp (car (nth 1 args))) + (mapcar (lambda (x) (car x)) (nth 1 args)) + (nth 1 args)) + (cddr args)) + (apply 'completing-read args))))) + +(defun org-extract-attributes (s) + "Extract the attributes cookie from a string and set as text property." + (let (a attr (start 0) key value) + (save-match-data + (when (string-match "{{\\([^}]+\\)}}$" s) + (setq a (match-string 1 s) s (substring s 0 (match-beginning 0))) + (while (string-match "\\([a-zA-Z]+\\)=\"\\([^\"]*\\)\"" a start) + (setq key (match-string 1 a) value (match-string 2 a) + start (match-end 0) + attr (plist-put attr (intern key) value)))) + (org-add-props s nil 'org-attr attr)) + s)) + +(defun org-extract-attributes-from-string (tag) + (let (key value attr) + (while (string-match "\\([a-zA-Z]+\\)=\"\\([^\"]*\\)\"\\s-?" tag) + (setq key (match-string 1 tag) value (match-string 2 tag) + tag (replace-match "" t t tag) + attr (plist-put attr (intern key) value))) + (cons tag attr))) + +(defun org-attributes-to-string (plist) + "Format a property list into an HTML attribute list." + (let ((s "") key value) + (while plist + (setq key (pop plist) value (pop plist)) + (and value + (setq s (concat s " " (symbol-name key) "=\"" value "\"")))) + s)) + +;;; Opening/following a link + +(defvar org-link-search-failed nil) + +(defvar org-open-link-functions nil + "Hook for functions finding a plain text link. +These functions must take a single argument, the link content. +They will be called for links that look like [[link text][description]] +when LINK TEXT does not have a protocol like \"http:\" and does not look +like a filename (e.g. \"./blue.png\"). + +These functions will be called *before* Org attempts to resolve the +link by doing text searches in the current buffer - so if you want a +link \"[[target]]\" to still find \"<<target>>\", your function should +handle this as a special case. + +When the function does handle the link, it must return a non-nil value. +If it decides that it is not responsible for this link, it must return +nil to indicate that that Org-mode can continue with other options +like exact and fuzzy text search.") + +(defun org-next-link () + "Move forward to the next link. +If the link is in hidden text, expose it." + (interactive) + (when (and org-link-search-failed (eq this-command last-command)) + (goto-char (point-min)) + (message "Link search wrapped back to beginning of buffer")) + (setq org-link-search-failed nil) + (let* ((pos (point)) + (ct (org-context)) + (a (assoc :link ct))) + (if a (goto-char (nth 2 a))) + (if (re-search-forward org-any-link-re nil t) + (progn + (goto-char (match-beginning 0)) + (if (org-invisible-p) (org-show-context))) + (goto-char pos) + (setq org-link-search-failed t) + (error "No further link found")))) + +(defun org-previous-link () + "Move backward to the previous link. +If the link is in hidden text, expose it." + (interactive) + (when (and org-link-search-failed (eq this-command last-command)) + (goto-char (point-max)) + (message "Link search wrapped back to end of buffer")) + (setq org-link-search-failed nil) + (let* ((pos (point)) + (ct (org-context)) + (a (assoc :link ct))) + (if a (goto-char (nth 1 a))) + (if (re-search-backward org-any-link-re nil t) + (progn + (goto-char (match-beginning 0)) + (if (org-invisible-p) (org-show-context))) + (goto-char pos) + (setq org-link-search-failed t) + (error "No further link found")))) + +(defun org-translate-link (s) + "Translate a link string if a translation function has been defined." + (if (and org-link-translation-function + (fboundp org-link-translation-function) + (string-match "\\([a-zA-Z0-9]+\\):\\(.*\\)" s)) + (progn + (setq s (funcall org-link-translation-function + (match-string 1) (match-string 2))) + (concat (car s) ":" (cdr s))) + s)) + +(defun org-translate-link-from-planner (type path) + "Translate a link from Emacs Planner syntax so that Org can follow it. +This is still an experimental function, your mileage may vary." + (cond + ((member type '("http" "https" "news" "ftp")) + ;; standard Internet links are the same. + nil) + ((and (equal type "irc") (string-match "^//" path)) + ;; Planner has two / at the beginning of an irc link, we have 1. + ;; We should have zero, actually.... + (setq path (substring path 1))) + ((and (equal type "lisp") (string-match "^/" path)) + ;; Planner has a slash, we do not. + (setq type "elisp" path (substring path 1))) + ((string-match "^//\\(.?*\\)/\\(<.*>\\)$" path) + ;; A typical message link. Planner has the id after the final slash, + ;; we separate it with a hash mark + (setq path (concat (match-string 1 path) "#" + (org-remove-angle-brackets (match-string 2 path))))) + ) + (cons type path)) + +(defun org-find-file-at-mouse (ev) + "Open file link or URL at mouse." + (interactive "e") + (mouse-set-point ev) + (org-open-at-point 'in-emacs)) + +(defun org-open-at-mouse (ev) + "Open file link or URL at mouse." + (interactive "e") + (mouse-set-point ev) + (if (eq major-mode 'org-agenda-mode) + (org-agenda-copy-local-variable 'org-link-abbrev-alist-local)) + (org-open-at-point)) + +(defvar org-window-config-before-follow-link nil + "The window configuration before following a link. +This is saved in case the need arises to restore it.") + +(defvar org-open-link-marker (make-marker) + "Marker pointing to the location where `org-open-at-point; was called.") + +;;;###autoload +(defun org-open-at-point-global () + "Follow a link like Org-mode does. +This command can be called in any mode to follow a link that has +Org-mode syntax." + (interactive) + (org-run-like-in-org-mode 'org-open-at-point)) + +;;;###autoload +(defun org-open-link-from-string (s &optional arg reference-buffer) + "Open a link in the string S, as if it was in Org-mode." + (interactive "sLink: \nP") + (let ((reference-buffer (or reference-buffer (current-buffer)))) + (with-temp-buffer + (let ((org-inhibit-startup t)) + (org-mode) + (insert s) + (goto-char (point-min)) + (when reference-buffer + (setq org-link-abbrev-alist-local + (with-current-buffer reference-buffer + org-link-abbrev-alist-local))) + (org-open-at-point arg reference-buffer))))) + +(defvar org-open-at-point-functions nil + "Hook that is run when following a link at point. + +Functions in this hook must return t if they identify and follow +a link at point. If they don't find anything interesting at point, +they must return nil.") + +(defun org-open-at-point (&optional in-emacs reference-buffer) + "Open link at or after point. +If there is no link at point, this function will search forward up to +the end of the current line. +Normally, files will be opened by an appropriate application. If the +optional argument IN-EMACS is non-nil, Emacs will visit the file. +With a double prefix argument, try to open outside of Emacs, in the +application the system uses for this file type." + (interactive "P") + ;; if in a code block, then open the block's results + (unless (call-interactively #'org-babel-open-src-block-result) + (org-load-modules-maybe) + (move-marker org-open-link-marker (point)) + (setq org-window-config-before-follow-link (current-window-configuration)) + (org-remove-occur-highlights nil nil t) + (cond + ((and (org-on-heading-p) + (not (org-in-regexp + (concat org-plain-link-re "\\|" + org-bracket-link-regexp "\\|" + org-angle-link-re "\\|" + "[ \t]:[^ \t\n]+:[ \t]*$"))) + (not (get-text-property (point) 'org-linked-text))) + (or (org-offer-links-in-entry in-emacs) + (progn (require 'org-attach) (org-attach-reveal 'if-exists)))) + ((run-hook-with-args-until-success 'org-open-at-point-functions)) + ((org-at-timestamp-p t) (org-follow-timestamp-link)) + ((and (or (org-footnote-at-reference-p) (org-footnote-at-definition-p)) + (not (org-in-regexp org-bracket-link-regexp))) + (org-footnote-action)) + (t + (let (type path link line search (pos (point))) + (catch 'match + (save-excursion + (skip-chars-forward "^]\n\r") + (when (org-in-regexp org-bracket-link-regexp 1) + (setq link (org-extract-attributes + (org-link-unescape (org-match-string-no-properties 1)))) + (while (string-match " *\n *" link) + (setq link (replace-match " " t t link))) + (setq link (org-link-expand-abbrev link)) + (cond + ((or (file-name-absolute-p link) + (string-match "^\\.\\.?/" link)) + (setq type "file" path link)) + ((string-match org-link-re-with-space3 link) + (setq type (match-string 1 link) path (match-string 2 link))) + (t (setq type "thisfile" path link))) + (throw 'match t))) + + (when (get-text-property (point) 'org-linked-text) + (setq type "thisfile" + pos (if (get-text-property (1+ (point)) 'org-linked-text) + (1+ (point)) (point)) + path (buffer-substring + (previous-single-property-change pos 'org-linked-text) + (next-single-property-change pos 'org-linked-text))) + (throw 'match t)) + + (save-excursion + (when (or (org-in-regexp org-angle-link-re) + (org-in-regexp org-plain-link-re)) + (setq type (match-string 1) path (match-string 2)) + (throw 'match t))) + (save-excursion + (when (org-in-regexp (org-re "\\(:[[:alnum:]_@#%:]+\\):[ \t]*$")) + (setq type "tags" + path (match-string 1)) + (while (string-match ":" path) + (setq path (replace-match "+" t t path))) + (throw 'match t))) + (when (org-in-regexp "<\\([^><\n]+\\)>") + (setq type "tree-match" + path (match-string 1)) + (throw 'match t))) + (unless path + (error "No link found")) + + ;; switch back to reference buffer + ;; needed when if called in a temporary buffer through + ;; org-open-link-from-string + (with-current-buffer (or reference-buffer (current-buffer)) + + ;; Remove any trailing spaces in path + (if (string-match " +\\'" path) + (setq path (replace-match "" t t path))) + (if (and org-link-translation-function + (fboundp org-link-translation-function)) + ;; Check if we need to translate the link + (let ((tmp (funcall org-link-translation-function type path))) + (setq type (car tmp) path (cdr tmp)))) + + (cond + + ((assoc type org-link-protocols) + (funcall (nth 1 (assoc type org-link-protocols)) path)) + + ((equal type "mailto") + (let ((cmd (car org-link-mailto-program)) + (args (cdr org-link-mailto-program)) args1 + (address path) (subject "") a) + (if (string-match "\\(.*\\)::\\(.*\\)" path) + (setq address (match-string 1 path) + subject (org-link-escape (match-string 2 path)))) + (while args + (cond + ((not (stringp (car args))) (push (pop args) args1)) + (t (setq a (pop args)) + (if (string-match "%a" a) + (setq a (replace-match address t t a))) + (if (string-match "%s" a) + (setq a (replace-match subject t t a))) + (push a args1)))) + (apply cmd (nreverse args1)))) + + ((member type '("http" "https" "ftp" "news")) + (browse-url (concat type ":" (org-link-escape + path org-link-escape-chars-browser)))) + + ((string= type "doi") + (browse-url (concat "http://dx.doi.org/" + (org-link-escape + path org-link-escape-chars-browser)))) + + ((member type '("message")) + (browse-url (concat type ":" path))) + + ((string= type "tags") + (org-tags-view in-emacs path)) + + ((string= type "tree-match") + (org-occur (concat "\\[" (regexp-quote path) "\\]"))) + + ((string= type "file") + (if (string-match "::\\([0-9]+\\)\\'" path) + (setq line (string-to-number (match-string 1 path)) + path (substring path 0 (match-beginning 0))) + (if (string-match "::\\(.+\\)\\'" path) + (setq search (match-string 1 path) + path (substring path 0 (match-beginning 0))))) + (if (string-match "[*?{]" (file-name-nondirectory path)) + (dired path) + (org-open-file path in-emacs line search))) + + ((string= type "shell") + (let ((cmd path)) + (if (or (not org-confirm-shell-link-function) + (funcall org-confirm-shell-link-function + (format "Execute \"%s\" in shell? " + (org-add-props cmd nil + 'face 'org-warning)))) + (progn + (message "Executing %s" cmd) + (shell-command cmd)) + (error "Abort")))) + + ((string= type "elisp") + (let ((cmd path)) + (if (or (not org-confirm-elisp-link-function) + (funcall org-confirm-elisp-link-function + (format "Execute \"%s\" as elisp? " + (org-add-props cmd nil + 'face 'org-warning)))) + (message "%s => %s" cmd + (if (equal (string-to-char cmd) ?\() + (eval (read cmd)) + (call-interactively (read cmd)))) + (error "Abort")))) + + ((and (string= type "thisfile") + (run-hook-with-args-until-success + 'org-open-link-functions path))) + + ((string= type "thisfile") + (if in-emacs + (switch-to-buffer-other-window + (org-get-buffer-for-internal-link (current-buffer))) + (org-mark-ring-push)) + (let ((cmd `(org-link-search + ,path + ,(cond ((equal in-emacs '(4)) 'occur) + ((equal in-emacs '(16)) 'org-occur) + (t nil)) + ,pos))) + (condition-case nil (eval cmd) + (error (progn (widen) (eval cmd)))))) + + (t + (browse-url-at-point))))))) + (move-marker org-open-link-marker nil) + (run-hook-with-args 'org-follow-link-hook))) + +(defun org-offer-links-in-entry (&optional nth zero) + "Offer links in the current entry and follow the selected link. +If there is only one link, follow it immediately as well. +If NTH is an integer, immediately pick the NTH link found. +If ZERO is a string, check also this string for a link, and if +there is one, offer it as link number zero." + (let ((re (concat "\\(" org-bracket-link-regexp "\\)\\|" + "\\(" org-angle-link-re "\\)\\|" + "\\(" org-plain-link-re "\\)")) + (cnt ?0) + (in-emacs (if (integerp nth) nil nth)) + have-zero end links link c) + (when (and (stringp zero) (string-match org-bracket-link-regexp zero)) + (push (match-string 0 zero) links) + (setq cnt (1- cnt) have-zero t)) + (save-excursion + (org-back-to-heading t) + (setq end (save-excursion (outline-next-heading) (point))) + (while (re-search-forward re end t) + (push (match-string 0) links)) + (setq links (org-uniquify (reverse links)))) + + (cond + ((null links) + (message "No links")) + ((equal (length links) 1) + (setq link (list (car links)))) + ((and (integerp nth) (>= (length links) (if have-zero (1+ nth) nth))) + (setq link (nth (if have-zero nth (1- nth)) links))) + (t ; we have to select a link + (save-excursion + (save-window-excursion + (delete-other-windows) + (with-output-to-temp-buffer "*Select Link*" + (mapc (lambda (l) + (if (not (string-match org-bracket-link-regexp l)) + (princ (format "[%c] %s\n" (incf cnt) + (org-remove-angle-brackets l))) + (if (match-end 3) + (princ (format "[%c] %s (%s)\n" (incf cnt) + (match-string 3 l) (match-string 1 l))) + (princ (format "[%c] %s\n" (incf cnt) + (match-string 1 l)))))) + links)) + (org-fit-window-to-buffer (get-buffer-window "*Select Link*")) + (message "Select link to open, RET to open all:") + (setq c (read-char-exclusive)) + (and (get-buffer "*Select Link*") (kill-buffer "*Select Link*")))) + (when (equal c ?q) (error "Abort")) + (if (equal c ?\C-m) + (setq link links) + (setq nth (- c ?0)) + (if have-zero (setq nth (1+ nth))) + (unless (and (integerp nth) (>= (length links) nth)) + (error "Invalid link selection")) + (setq link (list (nth (1- nth) links)))))) + (if link + (let ((buf (current-buffer))) + (dolist (l link) + (org-open-link-from-string l in-emacs buf)) + t) + nil))) + +;; Add special file links that specify the way of opening + +(org-add-link-type "file+sys" 'org-open-file-with-system) +(org-add-link-type "file+emacs" 'org-open-file-with-emacs) +(defun org-open-file-with-system (path) + "Open file at PATH using the system way of opening it." + (org-open-file path 'system)) +(defun org-open-file-with-emacs (path) + "Open file at PATH in Emacs." + (org-open-file path 'emacs)) +(defun org-remove-file-link-modifiers () + "Remove the file link modifiers in `file+sys:' and `file+emacs:' links." + (goto-char (point-min)) + (while (re-search-forward "\\<file\\+\\(sys\\|emacs\\):" nil t) + (org-if-unprotected + (replace-match "file:" t t)))) +(eval-after-load "org-exp" + '(add-hook 'org-export-preprocess-before-normalizing-links-hook + 'org-remove-file-link-modifiers)) + +;;;; Time estimates + +(defun org-get-effort (&optional pom) + "Get the effort estimate for the current entry." + (org-entry-get pom org-effort-property)) + +;;; File search + +(defvar org-create-file-search-functions nil + "List of functions to construct the right search string for a file link. +These functions are called in turn with point at the location to +which the link should point. + +A function in the hook should first test if it would like to +handle this file type, for example by checking the `major-mode' +or the file extension. If it decides not to handle this file, it +should just return nil to give other functions a chance. If it +does handle the file, it must return the search string to be used +when following the link. The search string will be part of the +file link, given after a double colon, and `org-open-at-point' +will automatically search for it. If special measures must be +taken to make the search successful, another function should be +added to the companion hook `org-execute-file-search-functions', +which see. + +A function in this hook may also use `setq' to set the variable +`description' to provide a suggestion for the descriptive text to +be used for this link when it gets inserted into an Org-mode +buffer with \\[org-insert-link].") + +(defvar org-execute-file-search-functions nil + "List of functions to execute a file search triggered by a link. + +Functions added to this hook must accept a single argument, the +search string that was part of the file link, the part after the +double colon. The function must first check if it would like to +handle this search, for example by checking the `major-mode' or +the file extension. If it decides not to handle this search, it +should just return nil to give other functions a chance. If it +does handle the search, it must return a non-nil value to keep +other functions from trying. + +Each function can access the current prefix argument through the +variable `current-prefix-argument'. Note that a single prefix is +used to force opening a link in Emacs, so it may be good to only +use a numeric or double prefix to guide the search function. + +In case this is needed, a function in this hook can also restore +the window configuration before `org-open-at-point' was called using: + + (set-window-configuration org-window-config-before-follow-link)") + +(defvar org-link-search-inhibit-query nil) ;; dynamically scoped +(defun org-link-search (s &optional type avoid-pos) + "Search for a link search option. +If S is surrounded by forward slashes, it is interpreted as a +regular expression. In org-mode files, this will create an `org-occur' +sparse tree. In ordinary files, `occur' will be used to list matches. +If the current buffer is in `dired-mode', grep will be used to search +in all files. If AVOID-POS is given, ignore matches near that position." + (let ((case-fold-search t) + (s0 (mapconcat 'identity (org-split-string s "[ \t\r\n]+") " ")) + (markers (concat "\\(?:" (mapconcat (lambda (x) (regexp-quote (car x))) + (append '(("") (" ") ("\t") ("\n")) + org-emphasis-alist) + "\\|") "\\)")) + (pos (point)) + (pre nil) (post nil) + words re0 re1 re2 re3 re4_ re4 re5 re2a re2a_ reall) + (cond + ;; First check if there are any special search functions + ((run-hook-with-args-until-success 'org-execute-file-search-functions s)) + ;; Now try the builtin stuff + ((and (equal (string-to-char s0) ?#) + (> (length s0) 1) + (save-excursion + (goto-char (point-min)) + (and + (re-search-forward + (concat "^[ \t]*:CUSTOM_ID:[ \t]+" (regexp-quote (substring s0 1)) "[ \t]*$") nil t) + (setq type 'dedicated + pos (match-beginning 0)))) + ;; There is an exact target for this + (goto-char pos) + (org-back-to-heading t))) + ((save-excursion + (goto-char (point-min)) + (and + (re-search-forward + (concat "<<" (regexp-quote s0) ">>") nil t) + (setq type 'dedicated + pos (match-beginning 0)))) + ;; There is an exact target for this + (goto-char pos)) + ((and (string-match "^(\\(.*\\))$" s0) + (save-excursion + (goto-char (point-min)) + (and + (re-search-forward + (concat "[^[]" (regexp-quote + (format org-coderef-label-format + (match-string 1 s0)))) + nil t) + (setq type 'dedicated + pos (1+ (match-beginning 0)))))) + ;; There is a coderef target for this + (goto-char pos)) + ((string-match "^/\\(.*\\)/$" s) + ;; A regular expression + (cond + ((org-mode-p) + (org-occur (match-string 1 s))) + ;;((eq major-mode 'dired-mode) + ;; (grep (concat "grep -n -e '" (match-string 1 s) "' *"))) + (t (org-do-occur (match-string 1 s))))) + ((and (org-mode-p) org-link-search-must-match-exact-headline) + (and (equal (string-to-char s) ?*) (setq s (substring s 1))) + (goto-char (point-min)) + (cond + ((let (case-fold-search) + (re-search-forward (format org-complex-heading-regexp-format + (regexp-quote s)) + nil t)) + ;; OK, found a match + (setq type 'dedicated) + (goto-char (match-beginning 0))) + ((and (not org-link-search-inhibit-query) + (eq org-link-search-must-match-exact-headline 'query-to-create) + (y-or-n-p "No match - create this as a new heading? ")) + (goto-char (point-max)) + (or (bolp) (newline)) + (insert "* " s "\n") + (beginning-of-line 0)) + (t + (goto-char pos) + (error "No match")))) + (t + ;; A normal search string + (when (equal (string-to-char s) ?*) + ;; Anchor on headlines, post may include tags. + (setq pre "^\\*+[ \t]+\\(?:\\sw+\\)?[ \t]*" + post (org-re "[ \t]*\\(?:[ \t]+:[[:alnum:]_@#%:+]:[ \t]*\\)?$") + s (substring s 1))) + (remove-text-properties + 0 (length s) + '(face nil mouse-face nil keymap nil fontified nil) s) + ;; Make a series of regular expressions to find a match + (setq words (org-split-string s "[ \n\r\t]+") + + re0 (concat "\\(<<" (regexp-quote s0) ">>\\)") + re2 (concat markers "\\(" (mapconcat 'downcase words "[ \t]+") + "\\)" markers) + re2a_ (concat "\\(" (mapconcat 'downcase words "[ \t\r\n]+") "\\)[ \t\r\n]") + re2a (concat "[ \t\r\n]" re2a_) + re4_ (concat "\\(" (mapconcat 'downcase words "[^a-zA-Z_\r\n]+") "\\)[^a-zA-Z_]") + re4 (concat "[^a-zA-Z_]" re4_) + + re1 (concat pre re2 post) + re3 (concat pre (if pre re4_ re4) post) + re5 (concat pre ".*" re4) + re2 (concat pre re2) + re2a (concat pre (if pre re2a_ re2a)) + re4 (concat pre (if pre re4_ 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)) + (setq type 'fuzzy) + (if (or (and (org-search-not-self 1 re0 nil t) (setq type 'dedicated)) + (org-search-not-self 1 re1 nil t) + (org-search-not-self 1 re2 nil t) + (org-search-not-self 1 re2a nil t) + (org-search-not-self 1 re3 nil t) + (org-search-not-self 1 re4 nil t) + (org-search-not-self 1 re5 nil t) + ) + (goto-char (match-beginning 1)) + (goto-char pos) + (error "No match")))))) + (and (org-mode-p) (org-show-context 'link-search)) + type)) + +(defun org-search-not-self (group &rest args) + "Execute `re-search-forward', but only accept matches that do not +enclose the position of `org-open-link-marker'." + (let ((m org-open-link-marker)) + (catch 'exit + (while (apply 're-search-forward args) + (unless (get-text-property (match-end group) 'intangible) ; Emacs 21 + (goto-char (match-end group)) + (if (and (or (not (eq (marker-buffer m) (current-buffer))) + (> (match-beginning 0) (marker-position m)) + (< (match-end 0) (marker-position m))) + (save-match-data + (or (not (org-in-regexp + org-bracket-link-analytic-regexp 1)) + (not (match-end 4)) ; no description + (and (<= (match-beginning 4) (point)) + (>= (match-end 4) (point)))))) + (throw 'exit (point)))))))) + +(defun org-get-buffer-for-internal-link (buffer) + "Return a buffer to be used for displaying the link target of internal links." + (cond + ((not org-display-internal-link-with-indirect-buffer) + buffer) + ((string-match "(Clone)$" (buffer-name buffer)) + (message "Buffer is already a clone, not making another one") + ;; we also do not modify visibility in this case + buffer) + (t ; make a new indirect buffer for displaying the link + (let* ((bn (buffer-name buffer)) + (ibn (concat bn "(Clone)")) + (ib (or (get-buffer ibn) (make-indirect-buffer buffer ibn 'clone)))) + (with-current-buffer ib (org-overview)) + ib)))) + +(defun org-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 ((inhibit-read-only t)) (delete-region beg end))) + (goto-char (point-min)) + (select-window cwin)))) + +;;; The mark ring for links jumps + +(defvar org-mark-ring nil + "Mark ring for positions before jumps in Org-mode.") +(defvar org-mark-ring-last-goto nil + "Last position in the mark ring used to go back.") +;; Fill and close the ring +(setq org-mark-ring nil org-mark-ring-last-goto nil) ;; in case file is reloaded +(loop for i from 1 to org-mark-ring-length do + (push (make-marker) org-mark-ring)) +(setcdr (nthcdr (1- org-mark-ring-length) org-mark-ring) + org-mark-ring) + +(defun org-mark-ring-push (&optional pos buffer) + "Put the current position or POS into the mark ring and rotate it." + (interactive) + (setq pos (or pos (point))) + (setq org-mark-ring (nthcdr (1- org-mark-ring-length) org-mark-ring)) + (move-marker (car org-mark-ring) + (or pos (point)) + (or buffer (current-buffer))) + (message "%s" + (substitute-command-keys + "Position saved to mark ring, go back with \\[org-mark-ring-goto]."))) + +(defun org-mark-ring-goto (&optional n) + "Jump to the previous position in the mark ring. +With prefix arg N, jump back that many stored positions. When +called several times in succession, walk through the entire ring. +Org-mode commands jumping to a different position in the current file, +or to another Org-mode file, automatically push the old position +onto the ring." + (interactive "p") + (let (p m) + (if (eq last-command this-command) + (setq p (nthcdr n (or org-mark-ring-last-goto org-mark-ring))) + (setq p org-mark-ring)) + (setq org-mark-ring-last-goto p) + (setq m (car p)) + (switch-to-buffer (marker-buffer m)) + (goto-char m) + (if (or (org-invisible-p) (org-invisible-p2)) (org-show-context 'mark-goto)))) + +(defun org-remove-angle-brackets (s) + (if (equal (substring s 0 1) "<") (setq s (substring s 1))) + (if (equal (substring s -1) ">") (setq s (substring s 0 -1))) + s) +(defun org-add-angle-brackets (s) + (if (equal (substring s 0 1) "<") nil (setq s (concat "<" s))) + (if (equal (substring s -1) ">") nil (setq s (concat s ">"))) + s) +(defun org-remove-double-quotes (s) + (if (equal (substring s 0 1) "\"") (setq s (substring s 1))) + (if (equal (substring s -1) "\"") (setq s (substring s 0 -1))) + s) + +;;; Following specific links + +(defun org-follow-timestamp-link () + (cond + ((org-at-date-range-p t) + (let ((org-agenda-start-on-weekday) + (t1 (match-string 1)) + (t2 (match-string 2))) + (setq t1 (time-to-days (org-time-string-to-time t1)) + t2 (time-to-days (org-time-string-to-time t2))) + (org-agenda-list nil t1 (1+ (- t2 t1))))) + ((org-at-timestamp-p t) + (org-agenda-list nil (time-to-days (org-time-string-to-time + (substring (match-string 1) 0 10))) + 1)) + (t (error "This should not happen")))) + + +;;; Following file links +(defvar org-wait nil) +(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 prefix argument IN-EMACS, Emacs will visit the file. +With a double \\[universal-argument] \\[universal-argument] \ +prefix arg, Org tries to avoid opening in Emacs +and to use an external application to 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 be +opened in Emacs, unless an entry from org-file-apps that makes +use of groups in a regexp matches. +If the file does not exist, an error is thrown." + (let* ((file (if (equal path "") + buffer-file-name + (substitute-in-file-name (expand-file-name path)))) + (file-apps (append org-file-apps (org-default-apps))) + (apps (org-remove-if + 'org-file-apps-entry-match-against-dlink-p file-apps)) + (apps-dlink (org-remove-if-not + 'org-file-apps-entry-match-against-dlink-p file-apps)) + (remp (and (assq 'remote apps) (org-file-remote-p file))) + (dirp (if remp nil (file-directory-p file))) + (file (if (and dirp org-open-directory-means-index-dot-org) + (concat (file-name-as-directory file) "index.org") + file)) + (a-m-a-p (assq 'auto-mode apps)) + (dfile (downcase file)) + ;; reconstruct the original file: link from the PATH, LINE and SEARCH args + (link (cond ((and (eq line nil) + (eq search nil)) + file) + (line + (concat file "::" (number-to-string line))) + (search + (concat file "::" search)))) + (dlink (downcase link)) + (old-buffer (current-buffer)) + (old-pos (point)) + (old-mode major-mode) + ext cmd link-match-data) + (if (string-match "^.*\\.\\([a-zA-Z0-9]+\\.gz\\)$" dfile) + (setq ext (match-string 1 dfile)) + (if (string-match "^.*\\.\\([a-zA-Z0-9]+\\)$" dfile) + (setq ext (match-string 1 dfile)))) + (cond + ((member in-emacs '((16) system)) + (setq cmd (cdr (assoc 'system apps)))) + (in-emacs (setq cmd 'emacs)) + (t + (setq cmd (or (and remp (cdr (assoc 'remote apps))) + (and dirp (cdr (assoc 'directory apps))) + ; first, try matching against apps-dlink + ; if we get a match here, store the match data for later + (let ((match (assoc-default dlink apps-dlink + 'string-match))) + (if match + (progn (setq link-match-data (match-data)) + match) + (progn (setq in-emacs (or in-emacs line search)) + nil))) ; if we have no match in apps-dlink, + ; always open the file in emacs if line or search + ; is given (for backwards compatibility) + (assoc-default dfile (org-apps-regexp-alist apps a-m-a-p) + 'string-match) + (cdr (assoc ext apps)) + (cdr (assoc t apps)))))) + (when (eq cmd 'system) + (setq cmd (cdr (assoc 'system apps)))) + (when (eq cmd 'default) + (setq cmd (cdr (assoc t apps)))) + (when (eq cmd 'mailcap) + (require 'mailcap) + (mailcap-parse-mailcaps) + (let* ((mime-type (mailcap-extension-to-mime (or ext ""))) + (command (mailcap-mime-info mime-type))) + (if (stringp command) + (setq cmd command) + (setq cmd 'emacs)))) + (if (and (not (eq cmd 'emacs)) ; Emacs has no problems with non-ex files + (not (file-exists-p file)) + (not org-open-non-existing-files)) + (error "No such file: %s" file)) + (cond + ((and (stringp cmd) (not (string-match "^\\s-*$" cmd))) + ;; Remove quotes around the file name - we'll use shell-quote-argument. + (while (string-match "['\"]%s['\"]" cmd) + (setq cmd (replace-match "%s" t t cmd))) + (while (string-match "%s" cmd) + (setq cmd (replace-match + (save-match-data + (shell-quote-argument + (convert-standard-filename file))) + t t cmd))) + + ;; Replace "%1", "%2" etc. in command with group matches from regex + (save-match-data + (let ((match-index 1) + (number-of-groups (- (/ (length link-match-data) 2) 1))) + (set-match-data link-match-data) + (while (<= match-index number-of-groups) + (let ((regex (concat "%" (number-to-string match-index))) + (replace-with (match-string match-index dlink))) + (while (string-match regex cmd) + (setq cmd (replace-match replace-with t t cmd)))) + (setq match-index (+ match-index 1))))) + + (save-window-excursion + (start-process-shell-command cmd nil cmd) + (and (boundp 'org-wait) (numberp org-wait) (sit-for org-wait)) + )) + ((or (stringp cmd) + (eq cmd 'emacs)) + (funcall (cdr (assq 'file org-link-frame-setup)) file) + (widen) + (if line (org-goto-line line) + (if search (org-link-search search)))) + ((consp cmd) + (let ((file (convert-standard-filename file))) + (save-match-data + (set-match-data link-match-data) + (eval cmd)))) + (t (funcall (cdr (assq 'file org-link-frame-setup)) file))) + (and (org-mode-p) (eq old-mode 'org-mode) + (or (not (equal old-buffer (current-buffer))) + (not (equal old-pos (point)))) + (org-mark-ring-push old-pos old-buffer)))) + +(defun org-file-apps-entry-match-against-dlink-p (entry) + "This function returns non-nil if `entry' uses a regular +expression which should be matched against the whole link by +org-open-file. + +It assumes that is the case when the entry uses a regular +expression which has at least one grouping construct and the +action is either a lisp form or a command string containing +'%1', i.e. using at least one subexpression match as a +parameter." + (let ((selector (car entry)) + (action (cdr entry))) + (if (stringp selector) + (and (> (regexp-opt-depth selector) 0) + (or (and (stringp action) + (string-match "%[0-9]" action)) + (consp action))) + nil))) + +(defun org-default-apps () + "Return the default applications for this operating system." + (cond + ((eq system-type 'darwin) + org-file-apps-defaults-macosx) + ((eq system-type 'windows-nt) + org-file-apps-defaults-windowsnt) + (t org-file-apps-defaults-gnu))) + +(defun org-apps-regexp-alist (list &optional add-auto-mode) + "Convert extensions to regular expressions in the cars of LIST. +Also, weed out any non-string entries, because the return value is used +only for regexp matching. +When ADD-AUTO-MODE is set, make all matches in `auto-mode-alist' +point to the symbol `emacs', indicating that the file should +be opened in Emacs." + (append + (delq nil + (mapcar (lambda (x) + (if (not (stringp (car x))) + nil + (if (string-match "\\W" (car x)) + x + (cons (concat "\\." (car x) "\\'") (cdr x))))) + list)) + (if add-auto-mode + (mapcar (lambda (x) (cons (car x) 'emacs)) auto-mode-alist)))) + +(defvar ange-ftp-name-format) ; to silence the XEmacs compiler. +(defun org-file-remote-p (file) + "Test whether FILE specifies a location on a remote system. +Return non-nil if the location is indeed remote. + +For example, the filename \"/user@host:/foo\" specifies a location +on the system \"/user@host:\"." + (cond ((fboundp 'file-remote-p) + (file-remote-p file)) + ((fboundp 'tramp-handle-file-remote-p) + (tramp-handle-file-remote-p file)) + ((and (boundp 'ange-ftp-name-format) + (string-match (car ange-ftp-name-format) file)) + t) + (t nil))) + + +;;;; Refiling + +(defun org-get-org-file () + "Read a filename, with default directory `org-directory'." + (let ((default (or org-default-notes-file remember-data-file))) + (read-file-name (format "File name [%s]: " default) + (file-name-as-directory org-directory) + default))) + +(defun org-notes-order-reversed-p () + "Check if the current file should receive notes in reversed order." + (cond + ((not org-reverse-note-order) nil) + ((eq t org-reverse-note-order) t) + ((not (listp org-reverse-note-order)) nil) + (t (catch 'exit + (let ((all org-reverse-note-order) + entry) + (while (setq entry (pop all)) + (if (string-match (car entry) buffer-file-name) + (throw 'exit (cdr entry)))) + nil))))) + +(defvar org-refile-target-table nil + "The list of refile targets, created by `org-refile'.") + +(defvar org-agenda-new-buffers nil + "Buffers created to visit agenda files.") + +(defvar org-refile-cache nil + "Cache for refile targets.") + + +(defvar org-refile-markers nil + "All the markers used for caching refile locations.") + +(defun org-refile-marker (pos) + "Get a new refile marker, but only if caching is in use." + (if (not org-refile-use-cache) + pos + (let ((m (make-marker))) + (move-marker m pos) + (push m org-refile-markers) + m))) + +(defun org-refile-cache-clear () + "Clear the refile cache and disable all the markers." + (mapc (lambda (m) (move-marker m nil)) org-refile-markers) + (setq org-refile-markers nil) + (setq org-refile-cache nil) + (message "Refile cache has been cleared")) + +(defun org-refile-cache-check-set (set) + "Check if all the markers in the cache still have live buffers." + (let (marker) + (catch 'exit + (while (and set (setq marker (nth 3 (pop set)))) + ;; if org-refile-use-outline-path is 'file, marker may be nil + (when (and marker (null (marker-buffer marker))) + (message "not found") (sit-for 3) + (throw 'exit nil))) + t))) + +(defun org-refile-cache-put (set &rest identifiers) + "Push the refile targets SET into the cache, under IDENTIFIERS." + (let* ((key (sha1 (prin1-to-string identifiers))) + (entry (assoc key org-refile-cache))) + (if entry + (setcdr entry set) + (push (cons key set) org-refile-cache)))) + +(defun org-refile-cache-get (&rest identifiers) + "Retrieve the cached value for refile targets given by IDENTIFIERS." + (cond + ((not org-refile-cache) nil) + ((not org-refile-use-cache) (org-refile-cache-clear) nil) + (t + (let ((set (cdr (assoc (sha1 (prin1-to-string identifiers)) + org-refile-cache)))) + (and set (org-refile-cache-check-set set) set))))) + +(defun org-get-refile-targets (&optional default-buffer) + "Produce a table with refile targets." + (let ((case-fold-search nil) + ;; otherwise org confuses "TODO" as a kw and "Todo" as a word + (entries (or org-refile-targets '((nil . (:level . 1))))) + targets tgs txt re files f desc descre fast-path-p level pos0) + (message "Getting targets...") + (with-current-buffer (or default-buffer (current-buffer)) + (while (setq entry (pop entries)) + (setq files (car entry) desc (cdr entry)) + (setq fast-path-p nil) + (cond + ((null files) (setq files (list (current-buffer)))) + ((eq files 'org-agenda-files) + (setq files (org-agenda-files 'unrestricted))) + ((and (symbolp files) (fboundp files)) + (setq files (funcall files))) + ((and (symbolp files) (boundp files)) + (setq files (symbol-value files)))) + (if (stringp files) (setq files (list files))) + (cond + ((eq (car desc) :tag) + (setq descre (concat "^\\*+[ \t]+.*?:" (regexp-quote (cdr desc)) ":"))) + ((eq (car desc) :todo) + (setq descre (concat "^\\*+[ \t]+" (regexp-quote (cdr desc)) "[ \t]"))) + ((eq (car desc) :regexp) + (setq descre (cdr desc))) + ((eq (car desc) :level) + (setq descre (concat "^\\*\\{" (number-to-string + (if org-odd-levels-only + (1- (* 2 (cdr desc))) + (cdr desc))) + "\\}[ \t]"))) + ((eq (car desc) :maxlevel) + (setq fast-path-p t) + (setq descre (concat "^\\*\\{1," (number-to-string + (if org-odd-levels-only + (1- (* 2 (cdr desc))) + (cdr desc))) + "\\}[ \t]"))) + (t (error "Bad refiling target description %s" desc))) + (while (setq f (pop files)) + (with-current-buffer + (if (bufferp f) f (org-get-agenda-file-buffer f)) + (or + (setq tgs (org-refile-cache-get (buffer-file-name) descre)) + (progn + (if (bufferp f) (setq f (buffer-file-name + (buffer-base-buffer f)))) + (setq f (and f (expand-file-name f))) + (if (eq org-refile-use-outline-path 'file) + (push (list (file-name-nondirectory f) f nil nil) tgs)) + (save-excursion + (save-restriction + (widen) + (goto-char (point-min)) + (while (re-search-forward descre nil t) + (goto-char (setq pos0 (point-at-bol))) + (catch 'next + (when org-refile-target-verify-function + (save-match-data + (or (funcall org-refile-target-verify-function) + (throw 'next t)))) + (when (looking-at org-complex-heading-regexp) + (setq level (org-reduced-level + (- (match-end 1) (match-beginning 1))) + txt (org-link-display-format (match-string 4)) + txt (replace-regexp-in-string "\\( *\[[0-9]+/?[0-9]*%?\]\\)+$" "" txt) + re (format org-complex-heading-regexp-format + (regexp-quote (match-string 4)))) + (when org-refile-use-outline-path + (setq txt (mapconcat + 'org-protect-slash + (append + (if (eq org-refile-use-outline-path + 'file) + (list (file-name-nondirectory + (buffer-file-name + (buffer-base-buffer)))) + (if (eq org-refile-use-outline-path + 'full-file-path) + (list (buffer-file-name + (buffer-base-buffer))))) + (org-get-outline-path fast-path-p + level txt) + (list txt)) + "/"))) + (push (list txt f re (org-refile-marker (point))) + tgs))) + (when (= (point) pos0) + ;; verification function has not moved point + (goto-char (point-at-eol)))))))) + (when org-refile-use-cache + (org-refile-cache-put tgs (buffer-file-name) descre)) + (setq targets (append tgs targets)) + )))) + (message "Getting targets...done") + (nreverse targets))) + +(defun org-protect-slash (s) + (while (string-match "/" s) + (setq s (replace-match "\\" t t s))) + s) + +(defvar org-olpa (make-vector 20 nil)) + +(defun org-get-outline-path (&optional fastp level heading) + "Return the outline path to the current entry, as a list. + +The parameters FASTP, LEVEL, and HEADING are for use by a scanner +routine which makes outline path derivations for an entire file, +avoiding backtracing. Refile target collection makes use of that." + (if fastp + (progn + (if (> level 19) + (error "Outline path failure, more than 19 levels")) + (loop for i from level upto 19 do + (aset org-olpa i nil)) + (prog1 + (delq nil (append org-olpa nil)) + (aset org-olpa level heading))) + (let (rtn case-fold-search) + (save-excursion + (save-restriction + (widen) + (while (org-up-heading-safe) + (when (looking-at org-complex-heading-regexp) + (push (org-match-string-no-properties 4) rtn))) + rtn))))) + +(defun org-format-outline-path (path &optional width prefix) + "Format the outline path PATH for display. +Width is the maximum number of characters that is available. +Prefix is a prefix to be included in the returned string, +such as the file name." + (setq width (or width 79)) + (if prefix (setq width (- width (length prefix)))) + (if (not path) + (or prefix "") + (let* ((nsteps (length path)) + (total-width (+ nsteps (apply '+ (mapcar 'length path)))) + (maxwidth (if (<= total-width width) + 10000 ;; everything fits + ;; we need to shorten the level headings + (/ (- width nsteps) nsteps))) + (org-odd-levels-only nil) + (n 0) + (total (1+ (length prefix)))) + (setq maxwidth (max maxwidth 10)) + (concat prefix + (mapconcat + (lambda (h) + (setq n (1+ n)) + (if (and (= n nsteps) (< maxwidth 10000)) + (setq maxwidth (- total-width total))) + (if (< (length h) maxwidth) + (progn (setq total (+ total (length h) 1)) h) + (setq h (substring h 0 (- maxwidth 2)) + total (+ total maxwidth 1)) + (if (string-match "[ \t]+\\'" h) + (setq h (substring h 0 (match-beginning 0)))) + (setq h (concat h ".."))) + (org-add-props h nil 'face + (nth (% (1- n) org-n-level-faces) + org-level-faces)) + h) + path "/"))))) + +(defun org-display-outline-path (&optional file current) + "Display the current outline path in the echo area." + (interactive "P") + (let* ((bfn (buffer-file-name (buffer-base-buffer))) + (case-fold-search nil) + (path (and (org-mode-p) (org-get-outline-path)))) + (if current (setq path (append path + (save-excursion + (org-back-to-heading t) + (if (looking-at org-complex-heading-regexp) + (list (match-string 4))))))) + (message "%s" + (org-format-outline-path + path + (1- (frame-width)) + (and file bfn (concat (file-name-nondirectory bfn) "/")))))) + +(defvar org-refile-history nil + "History for refiling operations.") + +(defvar org-after-refile-insert-hook nil + "Hook run after `org-refile' has inserted its stuff at the new location. +Note that this is still *before* the stuff will be removed from +the *old* location.") + +(defvar org-capture-last-stored-marker) +(defun org-refile (&optional goto default-buffer rfloc) + "Move the entry at point to another heading. +The list of target headings is compiled using the information in +`org-refile-targets', which see. This list is created before each use +and will therefore always be up-to-date. + +At the target location, the entry is filed as a subitem of the target heading. +Depending on `org-reverse-note-order', the new subitem will either be the +first or the last subitem. + +If there is an active region, all entries in that region will be moved. +However, the region must fulfill the requirement that the first heading +is the first one sets the top-level of the moved text - at most siblings +below it are allowed. + +With prefix arg GOTO, the command will only visit the target location, +not actually move anything. +With a double prefix arg \\[universal-argument] \\[universal-argument], \ +go to the location where the last refiling +operation has put the subtree. +With a prefix argument of `2', refile to the running clock. + +RFLOC can be a refile location obtained in a different way. + +See also `org-refile-use-outline-path' and `org-completion-use-ido'. + +If you are using target caching (see `org-refile-use-cache'), +You have to clear the target cache in order to find new targets. +This can be done with a 0 prefix: `C-0 C-c C-w'" + (interactive "P") + (if (member goto '(0 (64))) + (org-refile-cache-clear) + (let* ((cbuf (current-buffer)) + (regionp (org-region-active-p)) + (region-start (and regionp (region-beginning))) + (region-end (and regionp (region-end))) + (region-length (and regionp (- region-end region-start))) + (filename (buffer-file-name (buffer-base-buffer cbuf))) + pos it nbuf file re level reversed) + (setq last-command nil) + (when regionp + (goto-char region-start) + (or (bolp) (goto-char (point-at-bol))) + (setq region-start (point)) + (unless (org-kill-is-subtree-p + (buffer-substring region-start region-end)) + (error "The region is not a (sequence of) subtree(s)"))) + (if (equal goto '(16)) + (org-refile-goto-last-stored) + (when (or + (and (equal goto 2) + org-clock-hd-marker (marker-buffer org-clock-hd-marker) + (prog1 + (setq it (list (or org-clock-heading "running clock") + (buffer-file-name + (marker-buffer org-clock-hd-marker)) + "" + (marker-position org-clock-hd-marker))) + (setq goto nil))) + (setq it (or rfloc + (save-excursion + (org-refile-get-location + (if goto "Goto: " "Refile to: ") default-buffer + org-refile-allow-creating-parent-nodes))))) + (setq file (nth 1 it) + re (nth 2 it) + pos (nth 3 it)) + (if (and (not goto) + pos + (equal (buffer-file-name) file) + (if regionp + (and (>= pos region-start) + (<= pos region-end)) + (and (>= pos (point)) + (< pos (save-excursion + (org-end-of-subtree t t)))))) + (error "Cannot refile to position inside the tree or region")) + + (setq nbuf (or (find-buffer-visiting file) + (find-file-noselect file))) + (if goto + (progn + (switch-to-buffer nbuf) + (goto-char pos) + (org-show-context 'org-goto)) + (if regionp + (progn + (org-kill-new (buffer-substring region-start region-end)) + (org-save-markers-in-region region-start region-end)) + (org-copy-subtree 1 nil t)) + (with-current-buffer (setq nbuf (or (find-buffer-visiting file) + (find-file-noselect file))) + (setq reversed (org-notes-order-reversed-p)) + (save-excursion + (save-restriction + (widen) + (if pos + (progn + (goto-char pos) + (looking-at outline-regexp) + (setq level (org-get-valid-level (funcall outline-level) 1)) + (goto-char + (if reversed + (or (outline-next-heading) (point-max)) + (or (save-excursion (org-get-next-sibling)) + (org-end-of-subtree t t) + (point-max))))) + (setq level 1) + (if (not reversed) + (goto-char (point-max)) + (goto-char (point-min)) + (or (outline-next-heading) (goto-char (point-max))))) + (if (not (bolp)) (newline)) + (org-paste-subtree level) + (when org-log-refile + (org-add-log-setup 'refile nil nil 'findpos + org-log-refile) + (unless (eq org-log-refile 'note) + (save-excursion (org-add-log-note)))) + (and org-auto-align-tags (org-set-tags nil t)) + (bookmark-set "org-refile-last-stored") + ;; If we are refiling for capture, make sure that the + ;; last-capture pointers point here + (when (org-bound-and-true-p org-refile-for-capture) + (bookmark-set "org-capture-last-stored-marker") + (move-marker org-capture-last-stored-marker (point))) + (if (fboundp 'deactivate-mark) (deactivate-mark)) + (run-hooks 'org-after-refile-insert-hook)))) + (if regionp + (delete-region (point) (+ (point) region-length)) + (org-cut-subtree)) + (when (featurep 'org-inlinetask) + (org-inlinetask-remove-END-maybe)) + (setq org-markers-to-move nil) + (message "Refiled to \"%s\" in file %s" (car it) file))))))) + +(defun org-refile-goto-last-stored () + "Go to the location where the last refile was stored." + (interactive) + (bookmark-jump "org-refile-last-stored") + (message "This is the location of the last refile")) + +(defun org-refile-get-location (&optional prompt default-buffer new-nodes) + "Prompt the user for a refile location, using PROMPT." + (let ((org-refile-targets org-refile-targets) + (org-refile-use-outline-path org-refile-use-outline-path)) + (setq org-refile-target-table (org-get-refile-targets default-buffer))) + (unless org-refile-target-table + (error "No refile targets")) + (let* ((cbuf (current-buffer)) + (partial-completion-mode nil) + (cfn (buffer-file-name (buffer-base-buffer cbuf))) + (cfunc (if (and org-refile-use-outline-path + org-outline-path-complete-in-steps) + 'org-olpath-completing-read + 'org-icompleting-read)) + (extra (if org-refile-use-outline-path "/" "")) + (filename (and cfn (expand-file-name cfn))) + (tbl (mapcar + (lambda (x) + (if (and (not (member org-refile-use-outline-path + '(file full-file-path))) + (not (equal filename (nth 1 x)))) + (cons (concat (car x) extra " (" + (file-name-nondirectory (nth 1 x)) ")") + (cdr x)) + (cons (concat (car x) extra) (cdr x)))) + org-refile-target-table)) + (completion-ignore-case t) + pa answ parent-target child parent old-hist) + (setq old-hist org-refile-history) + (setq answ (funcall cfunc prompt tbl nil (not new-nodes) + nil 'org-refile-history)) + (setq pa (or (assoc answ tbl) (assoc (concat answ "/") tbl))) + (org-refile-check-position pa) + (if pa + (progn + (when (or (not org-refile-history) + (not (eq old-hist org-refile-history)) + (not (equal (car pa) (car org-refile-history)))) + (setq org-refile-history + (cons (car pa) (if (assoc (car org-refile-history) tbl) + org-refile-history + (cdr org-refile-history)))) + (if (equal (car org-refile-history) (nth 1 org-refile-history)) + (pop org-refile-history))) + pa) + (if (string-match "\\`\\(.*\\)/\\([^/]+\\)\\'" answ) + (progn + (setq parent (match-string 1 answ) + child (match-string 2 answ)) + (setq parent-target (or (assoc parent tbl) + (assoc (concat parent "/") tbl))) + (when (and parent-target + (or (eq new-nodes t) + (and (eq new-nodes 'confirm) + (y-or-n-p (format "Create new node \"%s\"? " + child))))) + (org-refile-new-child parent-target child))) + (error "Invalid target location"))))) + +(defun org-refile-check-position (refile-pointer) + "Check if the refile pointer matches the readline to which it points." + (let* ((file (nth 1 refile-pointer)) + (re (nth 2 refile-pointer)) + (pos (nth 3 refile-pointer)) + buffer) + (when (org-string-nw-p re) + (setq buffer (if (markerp pos) + (marker-buffer pos) + (or (find-buffer-visiting file) + (find-file-noselect file)))) + (with-current-buffer buffer + (save-excursion + (save-restriction + (widen) + (goto-char pos) + (beginning-of-line 1) + (unless (org-looking-at-p re) + (error "Invalid refile position, please rebuild the cache")))))))) + +(defun org-refile-new-child (parent-target child) + "Use refile target PARENT-TARGET to add new CHILD below it." + (unless parent-target + (error "Cannot find parent for new node")) + (let ((file (nth 1 parent-target)) + (pos (nth 3 parent-target)) + level) + (with-current-buffer (or (find-buffer-visiting file) + (find-file-noselect file)) + (save-excursion + (save-restriction + (widen) + (if pos + (goto-char pos) + (goto-char (point-max)) + (if (not (bolp)) (newline))) + (when (looking-at outline-regexp) + (setq level (funcall outline-level)) + (org-end-of-subtree t t)) + (org-back-over-empty-lines) + (insert "\n" (make-string + (if pos (org-get-valid-level level 1) 1) ?*) + " " child "\n") + (beginning-of-line 0) + (list (concat (car parent-target) "/" child) file "" (point))))))) + +(defun org-olpath-completing-read (prompt collection &rest args) + "Read an outline path like a file name." + (let ((thetable collection) + (org-completion-use-ido nil) ; does not work with ido. + (org-completion-use-iswitchb nil)) ; or iswitchb + (apply + 'org-icompleting-read prompt + (lambda (string predicate &optional flag) + (let (rtn r f (l (length string))) + (cond + ((eq flag nil) + ;; try completion + (try-completion string thetable)) + ((eq flag t) + ;; all-completions + (setq rtn (all-completions string thetable predicate)) + (mapcar + (lambda (x) + (setq r (substring x l)) + (if (string-match " ([^)]*)$" x) + (setq f (match-string 0 x)) + (setq f "")) + (if (string-match "/" r) + (concat string (substring r 0 (match-end 0)) f) + x)) + rtn)) + ((eq flag 'lambda) + ;; exact match? + (assoc string thetable))) + )) + args))) + +;;;; Dynamic blocks + +(defun org-find-dblock (name) + "Find the first dynamic block with name NAME in the buffer. +If not found, stay at current position and return nil." + (let (pos) + (save-excursion + (goto-char (point-min)) + (setq pos (and (re-search-forward (concat "^#\\+BEGIN:[ \t]+" name "\\>") + nil t) + (match-beginning 0)))) + (if pos (goto-char pos)) + pos)) + +(defconst org-dblock-start-re + "^[ \t]*#\\+BEGIN:[ \t]+\\(\\S-+\\)\\([ \t]+\\(.*\\)\\)?" + "Matches the start line of a dynamic block, with parameters.") + +(defconst org-dblock-end-re "^[ \t]*#\\+END\\([: \t\r\n]\\|$\\)" + "Matches the end of a dynamic block.") + +(defun org-create-dblock (plist) + "Create a dynamic block section, with parameters taken from PLIST. +PLIST must contain a :name entry which is used as name of the block." + (when (string-match "\\S-" (buffer-substring (point-at-bol) (point-at-eol))) + (end-of-line 1) + (newline)) + (let ((col (current-column)) + (name (plist-get plist :name))) + (insert "#+BEGIN: " name) + (while plist + (if (eq (car plist) :name) + (setq plist (cddr plist)) + (insert " " (prin1-to-string (pop plist))))) + (insert "\n\n" (make-string col ?\ ) "#+END:\n") + (beginning-of-line -2))) + +(defun org-prepare-dblock () + "Prepare dynamic block for refresh. +This empties the block, puts the cursor at the insert position and returns +the property list including an extra property :name with the block name." + (unless (looking-at org-dblock-start-re) + (error "Not at a dynamic block")) + (let* ((begdel (1+ (match-end 0))) + (name (org-no-properties (match-string 1))) + (params (append (list :name name) + (read (concat "(" (match-string 3) ")"))))) + (save-excursion + (beginning-of-line 1) + (skip-chars-forward " \t") + (setq params (plist-put params :indentation-column (current-column)))) + (unless (re-search-forward org-dblock-end-re nil t) + (error "Dynamic block not terminated")) + (setq params + (append params + (list :content (buffer-substring + begdel (match-beginning 0))))) + (delete-region begdel (match-beginning 0)) + (goto-char begdel) + (open-line 1) + params)) + +(defun org-map-dblocks (&optional command) + "Apply COMMAND to all dynamic blocks in the current buffer. +If COMMAND is not given, use `org-update-dblock'." + (let ((cmd (or command 'org-update-dblock))) + (save-excursion + (goto-char (point-min)) + (while (re-search-forward org-dblock-start-re nil t) + (goto-char (match-beginning 0)) + (save-excursion + (condition-case nil + (funcall cmd) + (error (message "Error during update of dynamic block")))) + (unless (re-search-forward org-dblock-end-re nil t) + (error "Dynamic block not terminated")))))) + +(defun org-dblock-update (&optional arg) + "User command for updating dynamic blocks. +Update the dynamic block at point. With prefix ARG, update all dynamic +blocks in the buffer." + (interactive "P") + (if arg + (org-update-all-dblocks) + (or (looking-at org-dblock-start-re) + (org-beginning-of-dblock)) + (org-update-dblock))) + +(defun org-update-dblock () + "Update the dynamic block at point. +This means to empty the block, parse for parameters and then call +the correct writing function." + (interactive) + (save-window-excursion + (let* ((pos (point)) + (line (org-current-line)) + (params (org-prepare-dblock)) + (name (plist-get params :name)) + (indent (plist-get params :indentation-column)) + (cmd (intern (concat "org-dblock-write:" name)))) + (message "Updating dynamic block `%s' at line %d..." name line) + (funcall cmd params) + (message "Updating dynamic block `%s' at line %d...done" name line) + (goto-char pos) + (when (and indent (> indent 0)) + (setq indent (make-string indent ?\ )) + (save-excursion + (org-beginning-of-dblock) + (forward-line 1) + (while (not (looking-at org-dblock-end-re)) + (insert indent) + (beginning-of-line 2)) + (when (looking-at org-dblock-end-re) + (and (looking-at "[ \t]+") + (replace-match "")) + (insert indent))))))) + +(defun org-beginning-of-dblock () + "Find the beginning of the dynamic block at point. +Error if there is no such block at point." + (let ((pos (point)) + beg) + (end-of-line 1) + (if (and (re-search-backward org-dblock-start-re nil t) + (setq beg (match-beginning 0)) + (re-search-forward org-dblock-end-re nil t) + (> (match-end 0) pos)) + (goto-char beg) + (goto-char pos) + (error "Not in a dynamic block")))) + +(defun org-update-all-dblocks () + "Update all dynamic blocks in the buffer. +This function can be used in a hook." + (interactive) + (when (org-mode-p) + (org-map-dblocks 'org-update-dblock))) + + +;;;; Completion + +(defconst org-additional-option-like-keywords + '("BEGIN_HTML" "END_HTML" "HTML:" "ATTR_HTML:" + "BEGIN_DocBook" "END_DocBook" "DocBook:" "ATTR_DocBook:" + "BEGIN_LaTeX" "END_LaTeX" "LaTeX:" "LATEX_HEADER:" + "LATEX_CLASS:" "LATEX_CLASS_OPTIONS:" "ATTR_LaTeX:" + "BEGIN:" "END:" + "ORGTBL" "TBLFM:" "TBLNAME:" + "BEGIN_EXAMPLE" "END_EXAMPLE" + "BEGIN_QUOTE" "END_QUOTE" + "BEGIN_VERSE" "END_VERSE" + "BEGIN_CENTER" "END_CENTER" + "BEGIN_SRC" "END_SRC" + "BEGIN_RESULT" "END_RESULT" + "SOURCE:" "SRCNAME:" "FUNCTION:" + "RESULTS:" + "HEADER:" "HEADERS:" + "BABEL:" + "CATEGORY:" "COLUMNS:" "PROPERTY:" + "CAPTION:" "LABEL:" + "SETUPFILE:" + "INCLUDE:" + "BIND:" + "MACRO:")) + +(defcustom org-structure-template-alist + '( + ("s" "#+begin_src ?\n\n#+end_src" + "<src lang=\"?\">\n\n</src>") + ("e" "#+begin_example\n?\n#+end_example" + "<example>\n?\n</example>") + ("q" "#+begin_quote\n?\n#+end_quote" + "<quote>\n?\n</quote>") + ("v" "#+begin_verse\n?\n#+end_verse" + "<verse>\n?\n/verse>") + ("c" "#+begin_center\n?\n#+end_center" + "<center>\n?\n/center>") + ("l" "#+begin_latex\n?\n#+end_latex" + "<literal style=\"latex\">\n?\n</literal>") + ("L" "#+latex: " + "<literal style=\"latex\">?</literal>") + ("h" "#+begin_html\n?\n#+end_html" + "<literal style=\"html\">\n?\n</literal>") + ("H" "#+html: " + "<literal style=\"html\">?</literal>") + ("a" "#+begin_ascii\n?\n#+end_ascii") + ("A" "#+ascii: ") + ("i" "#+include %file ?" + "<include file=%file markup=\"?\">") + ) + "Structure completion elements. +This is a list of abbreviation keys and values. The value gets inserted +if you type `<' followed by the key and then press the completion key, +usually `M-TAB'. %file will be replaced by a file name after prompting +for the file using completion. +There are two templates for each key, the first uses the original Org syntax, +the second uses Emacs Muse-like syntax tags. These Muse-like tags become +the default when the /org-mtags.el/ module has been loaded. See also the +variable `org-mtags-prefer-muse-templates'. +This is an experimental feature, it is undecided if it is going to stay in." + :group 'org-completion + :type '(repeat + (string :tag "Key") + (string :tag "Template") + (string :tag "Muse Template"))) + +(defun org-try-structure-completion () + "Try to complete a structure template before point. +This looks for strings like \"<e\" on an otherwise empty line and +expands them." + (let ((l (buffer-substring (point-at-bol) (point))) + a) + (when (and (looking-at "[ \t]*$") + (string-match "^[ \t]*<\\([a-z]+\\)$"l) + (setq a (assoc (match-string 1 l) org-structure-template-alist))) + (org-complete-expand-structure-template (+ -1 (point-at-bol) + (match-beginning 1)) a) + t))) + +(defun org-complete-expand-structure-template (start cell) + "Expand a structure template." + (let* ((musep (org-bound-and-true-p org-mtags-prefer-muse-templates)) + (rpl (nth (if musep 2 1) cell)) + (ind "")) + (delete-region start (point)) + (when (string-match "\\`#\\+" rpl) + (cond + ((bolp)) + ((not (string-match "\\S-" (buffer-substring (point-at-bol) (point)))) + (setq ind (buffer-substring (point-at-bol) (point)))) + (t (newline)))) + (setq start (point)) + (if (string-match "%file" rpl) + (setq rpl (replace-match + (concat + "\"" + (save-match-data + (abbreviate-file-name (read-file-name "Include file: "))) + "\"") + t t rpl))) + (setq rpl (mapconcat 'identity (split-string rpl "\n") + (concat "\n" ind))) + (insert rpl) + (if (re-search-backward "\\?" start t) (delete-char 1)))) + +;;;; TODO, DEADLINE, Comments + +(defun org-toggle-comment () + "Change the COMMENT state of an entry." + (interactive) + (save-excursion + (org-back-to-heading) + (let (case-fold-search) + (if (looking-at (concat outline-regexp + "\\( *\\<" org-comment-string "\\>[ \t]*\\)")) + (replace-match "" t t nil 1) + (if (looking-at outline-regexp) + (progn + (goto-char (match-end 0)) + (insert org-comment-string " "))))))) + +(defvar org-last-todo-state-is-todo nil + "This is non-nil when the last TODO state change led to a TODO state. +If the last change removed the TODO tag or switched to DONE, then +this is nil.") + +(defvar org-setting-tags nil) ; dynamically skipped + +(defvar org-todo-setup-filter-hook nil + "Hook for functions that pre-filter todo specs. +Each function takes a todo spec and returns either nil or the spec +transformed into canonical form." ) + +(defvar org-todo-get-default-hook nil + "Hook for functions that get a default item for todo. +Each function takes arguments (NEW-MARK OLD-MARK) and returns either +nil or a string to be used for the todo mark." ) + +(defvar org-agenda-headline-snapshot-before-repeat) + +(defun org-todo (&optional arg) + "Change the TODO state of an item. +The state of an item is given by a keyword at the start of the heading, +like + *** TODO Write paper + *** DONE Call mom + +The different keywords are specified in the variable `org-todo-keywords'. +By default the available states are \"TODO\" and \"DONE\". +So for this example: when the item starts with TODO, it is changed to DONE. +When it starts with DONE, the DONE is removed. And when neither TODO nor +DONE are present, add TODO at the beginning of the heading. + +With \\[universal-argument] prefix arg, use completion to determine the new \ +state. +With numeric prefix arg, switch to that state. +With a double \\[universal-argument] prefix, switch to the next set of TODO \ +keywords (nextset). +With a triple \\[universal-argument] prefix, circumvent any state blocking. + +For calling through lisp, arg is also interpreted in the following way: +'none -> empty state +\"\"(empty string) -> switch to empty state +'done -> switch to DONE +'nextset -> switch to the next set of keywords +'previousset -> switch to the previous set of keywords +\"WAITING\" -> switch to the specified keyword, but only if it + really is a member of `org-todo-keywords'." + (interactive "P") + (if (equal arg '(16)) (setq arg 'nextset)) + (let ((org-blocker-hook org-blocker-hook) + (case-fold-search nil)) + (when (equal arg '(64)) + (setq arg nil org-blocker-hook nil)) + (when (and org-blocker-hook + (or org-inhibit-blocking + (org-entry-get nil "NOBLOCKING"))) + (setq org-blocker-hook nil)) + (save-excursion + (catch 'exit + (org-back-to-heading t) + (if (looking-at outline-regexp) (goto-char (1- (match-end 0)))) + (or (looking-at (concat " +" org-todo-regexp "\\( +\\|$\\)")) + (looking-at " *")) + (let* ((match-data (match-data)) + (startpos (point-at-bol)) + (logging (save-match-data (org-entry-get nil "LOGGING" t t))) + (org-log-done org-log-done) + (org-log-repeat org-log-repeat) + (org-todo-log-states org-todo-log-states) + (this (match-string 1)) + (hl-pos (match-beginning 0)) + (head (org-get-todo-sequence-head this)) + (ass (assoc head org-todo-kwd-alist)) + (interpret (nth 1 ass)) + (done-word (nth 3 ass)) + (final-done-word (nth 4 ass)) + (last-state (or this "")) + (completion-ignore-case t) + (member (member this org-todo-keywords-1)) + (tail (cdr member)) + (state (cond + ((and org-todo-key-trigger + (or (and (equal arg '(4)) + (eq org-use-fast-todo-selection 'prefix)) + (and (not arg) org-use-fast-todo-selection + (not (eq org-use-fast-todo-selection + 'prefix))))) + ;; Use fast selection + (org-fast-todo-selection)) + ((and (equal arg '(4)) + (or (not org-use-fast-todo-selection) + (not org-todo-key-trigger))) + ;; Read a state with completion + (org-icompleting-read + "State: " (mapcar (lambda(x) (list x)) + org-todo-keywords-1) + nil t)) + ((eq arg 'right) + (if this + (if tail (car tail) nil) + (car org-todo-keywords-1))) + ((eq arg 'left) + (if (equal member org-todo-keywords-1) + nil + (if this + (nth (- (length org-todo-keywords-1) + (length tail) 2) + org-todo-keywords-1) + (org-last org-todo-keywords-1)))) + ((and (eq org-use-fast-todo-selection t) (equal arg '(4)) + (setq arg nil))) ; hack to fall back to cycling + (arg + ;; user or caller requests a specific state + (cond + ((equal arg "") nil) + ((eq arg 'none) nil) + ((eq arg 'done) (or done-word (car org-done-keywords))) + ((eq arg 'nextset) + (or (car (cdr (member head org-todo-heads))) + (car org-todo-heads))) + ((eq arg 'previousset) + (let ((org-todo-heads (reverse org-todo-heads))) + (or (car (cdr (member head org-todo-heads))) + (car org-todo-heads)))) + ((car (member arg org-todo-keywords-1))) + ((stringp arg) + (error "State `%s' not valid in this file" arg)) + ((nth (1- (prefix-numeric-value arg)) + org-todo-keywords-1)))) + ((null member) (or head (car org-todo-keywords-1))) + ((equal this final-done-word) nil) ;; -> make empty + ((null tail) nil) ;; -> first entry + ((memq interpret '(type priority)) + (if (eq this-command last-command) + (car tail) + (if (> (length tail) 0) + (or done-word (car org-done-keywords)) + nil))) + (t + (car tail)))) + (state (or + (run-hook-with-args-until-success + 'org-todo-get-default-hook state last-state) + state)) + (next (if state (concat " " state " ") " ")) + (change-plist (list :type 'todo-state-change :from this :to state + :position startpos)) + dolog now-done-p) + (when org-blocker-hook + (setq org-last-todo-state-is-todo + (not (member this org-done-keywords))) + (unless (save-excursion + (save-match-data + (run-hook-with-args-until-failure + 'org-blocker-hook change-plist))) + (if (interactive-p) + (error "TODO state change from %s to %s blocked" this state) + ;; fail silently + (message "TODO state change from %s to %s blocked" this state) + (throw 'exit nil)))) + (store-match-data match-data) + (replace-match next t t) + (unless (pos-visible-in-window-p hl-pos) + (message "TODO state changed to %s" (org-trim next))) + (unless head + (setq head (org-get-todo-sequence-head state) + ass (assoc head org-todo-kwd-alist) + interpret (nth 1 ass) + done-word (nth 3 ass) + final-done-word (nth 4 ass))) + (when (memq arg '(nextset previousset)) + (message "Keyword-Set %d/%d: %s" + (- (length org-todo-sets) -1 + (length (memq (assoc state org-todo-sets) org-todo-sets))) + (length org-todo-sets) + (mapconcat 'identity (assoc state org-todo-sets) " "))) + (setq org-last-todo-state-is-todo + (not (member state org-done-keywords))) + (setq now-done-p (and (member state org-done-keywords) + (not (member this org-done-keywords)))) + (and logging (org-local-logging logging)) + (when (and (or org-todo-log-states org-log-done) + (not (eq org-inhibit-logging t)) + (not (memq arg '(nextset previousset)))) + ;; we need to look at recording a time and note + (setq dolog (or (nth 1 (assoc state org-todo-log-states)) + (nth 2 (assoc this org-todo-log-states)))) + (if (and (eq dolog 'note) (eq org-inhibit-logging 'note)) + (setq dolog 'time)) + (when (and state + (member state org-not-done-keywords) + (not (member this org-not-done-keywords))) + ;; This is now a todo state and was not one before + ;; If there was a CLOSED time stamp, get rid of it. + (org-add-planning-info nil nil 'closed)) + (when (and now-done-p org-log-done) + ;; It is now done, and it was not done before + (org-add-planning-info 'closed (org-current-time)) + (if (and (not dolog) (eq 'note org-log-done)) + (org-add-log-setup 'done state this 'findpos 'note))) + (when (and state dolog) + ;; This is a non-nil state, and we need to log it + (org-add-log-setup 'state state this 'findpos dolog))) + ;; Fixup tag positioning + (org-todo-trigger-tag-changes state) + (and org-auto-align-tags (not org-setting-tags) (org-set-tags nil t)) + (when org-provide-todo-statistics + (org-update-parent-todo-statistics)) + (run-hooks 'org-after-todo-state-change-hook) + (if (and arg (not (member state org-done-keywords))) + (setq head (org-get-todo-sequence-head state))) + (put-text-property (point-at-bol) (point-at-eol) 'org-todo-head head) + ;; Do we need to trigger a repeat? + (when now-done-p + (when (boundp 'org-agenda-headline-snapshot-before-repeat) + ;; This is for the agenda, take a snapshot of the headline. + (save-match-data + (setq org-agenda-headline-snapshot-before-repeat + (org-get-heading)))) + (org-auto-repeat-maybe state)) + ;; Fixup cursor location if close to the keyword + (if (and (outline-on-heading-p) + (not (bolp)) + (save-excursion (beginning-of-line 1) + (looking-at org-todo-line-regexp)) + (< (point) (+ 2 (or (match-end 2) (match-end 1))))) + (progn + (goto-char (or (match-end 2) (match-end 1))) + (and (looking-at " ") (just-one-space)))) + (when org-trigger-hook + (save-excursion + (run-hook-with-args 'org-trigger-hook change-plist)))))))) + +(defun org-block-todo-from-children-or-siblings-or-parent (change-plist) + "Block turning an entry into a TODO, using the hierarchy. +This checks whether the current task should be blocked from state +changes. Such blocking occurs when: + + 1. The task has children which are not all in a completed state. + + 2. A task has a parent with the property :ORDERED:, and there + are siblings prior to the current task with incomplete + status. + + 3. The parent of the task is blocked because it has siblings that should + be done first, or is child of a block grandparent TODO entry." + + (if (not org-enforce-todo-dependencies) + t ; if locally turned off don't block + (catch 'dont-block + ;; If this is not a todo state change, or if this entry is already DONE, + ;; do not block + (when (or (not (eq (plist-get change-plist :type) 'todo-state-change)) + (member (plist-get change-plist :from) + (cons 'done org-done-keywords)) + (member (plist-get change-plist :to) + (cons 'todo org-not-done-keywords)) + (not (plist-get change-plist :to))) + (throw 'dont-block t)) + ;; If this task has children, and any are undone, it's blocked + (save-excursion + (org-back-to-heading t) + (let ((this-level (funcall outline-level))) + (outline-next-heading) + (let ((child-level (funcall outline-level))) + (while (and (not (eobp)) + (> child-level this-level)) + ;; this todo has children, check whether they are all + ;; completed + (if (and (not (org-entry-is-done-p)) + (org-entry-is-todo-p)) + (throw 'dont-block nil)) + (outline-next-heading) + (setq child-level (funcall outline-level)))))) + ;; Otherwise, if the task's parent has the :ORDERED: property, and + ;; any previous siblings are undone, it's blocked + (save-excursion + (org-back-to-heading t) + (let* ((pos (point)) + (parent-pos (and (org-up-heading-safe) (point)))) + (if (not parent-pos) (throw 'dont-block t)) ; no parent + (when (and (org-not-nil (org-entry-get (point) "ORDERED")) + (forward-line 1) + (re-search-forward org-not-done-heading-regexp pos t)) + (throw 'dont-block nil)) ; block, there is an older sibling not done. + ;; Search further up the hierarchy, to see if an anchestor is blocked + (while t + (goto-char parent-pos) + (if (not (looking-at org-not-done-heading-regexp)) + (throw 'dont-block t)) ; do not block, parent is not a TODO + (setq pos (point)) + (setq parent-pos (and (org-up-heading-safe) (point))) + (if (not parent-pos) (throw 'dont-block t)) ; no parent + (when (and (org-not-nil (org-entry-get (point) "ORDERED")) + (forward-line 1) + (re-search-forward org-not-done-heading-regexp pos t)) + (throw 'dont-block nil)))))))) ; block, older sibling not done. + +(defcustom org-track-ordered-property-with-tag nil + "Should the ORDERED property also be shown as a tag? +The ORDERED property decides if an entry should require subtasks to be +completed in sequence. Since a property is not very visible, setting +this option means that toggling the ORDERED property with the command +`org-toggle-ordered-property' will also toggle a tag ORDERED. That tag is +not relevant for the behavior, but it makes things more visible. + +Note that toggling the tag with tags commands will not change the property +and therefore not influence behavior! + +This can be t, meaning the tag ORDERED should be used, It can also be a +string to select a different tag for this task." + :group 'org-todo + :type '(choice + (const :tag "No tracking" nil) + (const :tag "Track with ORDERED tag" t) + (string :tag "Use other tag"))) + +(defun org-toggle-ordered-property () + "Toggle the ORDERED property of the current entry. +For better visibility, you can track the value of this property with a tag. +See variable `org-track-ordered-property-with-tag'." + (interactive) + (let* ((t1 org-track-ordered-property-with-tag) + (tag (and t1 (if (stringp t1) t1 "ORDERED")))) + (save-excursion + (org-back-to-heading) + (if (org-entry-get nil "ORDERED") + (progn + (org-delete-property "ORDERED") + (and tag (org-toggle-tag tag 'off)) + (message "Subtasks can be completed in arbitrary order")) + (org-entry-put nil "ORDERED" "t") + (and tag (org-toggle-tag tag 'on)) + (message "Subtasks must be completed in sequence"))))) + +(defvar org-blocked-by-checkboxes) ; dynamically scoped +(defun org-block-todo-from-checkboxes (change-plist) + "Block turning an entry into a TODO, using checkboxes. +This checks whether the current task should be blocked from state +changes because there are unchecked boxes in this entry." + (if (not org-enforce-todo-checkbox-dependencies) + t ; if locally turned off don't block + (catch 'dont-block + ;; If this is not a todo state change, or if this entry is already DONE, + ;; do not block + (when (or (not (eq (plist-get change-plist :type) 'todo-state-change)) + (member (plist-get change-plist :from) + (cons 'done org-done-keywords)) + (member (plist-get change-plist :to) + (cons 'todo org-not-done-keywords)) + (not (plist-get change-plist :to))) + (throw 'dont-block t)) + ;; If this task has checkboxes that are not checked, it's blocked + (save-excursion + (org-back-to-heading t) + (let ((beg (point)) end) + (outline-next-heading) + (setq end (point)) + (goto-char beg) + (if (re-search-forward "^[ \t]*\\([-+*]\\|[0-9]+[.)]\\)[ \t]+\\[[- ]\\]" + end t) + (progn + (if (boundp 'org-blocked-by-checkboxes) + (setq org-blocked-by-checkboxes t)) + (throw 'dont-block nil))))) + t))) ; do not block + +(defun org-entry-blocked-p () + "Is the current entry blocked?" + (if (org-entry-get nil "NOBLOCKING") + nil ;; Never block this entry + (not + (run-hook-with-args-until-failure + 'org-blocker-hook + (list :type 'todo-state-change + :position (point) + :from 'todo + :to 'done))))) + +(defun org-update-statistics-cookies (all) + "Update the statistics cookie, either from TODO or from checkboxes. +This should be called with the cursor in a line with a statistics cookie." + (interactive "P") + (if all + (progn + (org-update-checkbox-count 'all) + (org-map-entries 'org-update-parent-todo-statistics)) + (if (not (org-on-heading-p)) + (org-update-checkbox-count) + (let ((pos (move-marker (make-marker) (point))) + end l1 l2) + (ignore-errors (org-back-to-heading t)) + (if (not (org-on-heading-p)) + (org-update-checkbox-count) + (setq l1 (org-outline-level)) + (setq end (save-excursion + (outline-next-heading) + (if (org-on-heading-p) (setq l2 (org-outline-level))) + (point))) + (if (and (save-excursion + (re-search-forward + "^[ \t]*\\([-+*]\\|[0-9]+[.)]\\) \\[[- X]\\]" end t)) + (not (save-excursion (re-search-forward + ":COOKIE_DATA:.*\\<todo\\>" end t)))) + (org-update-checkbox-count) + (if (and l2 (> l2 l1)) + (progn + (goto-char end) + (org-update-parent-todo-statistics)) + (goto-char pos) + (beginning-of-line 1) + (while (re-search-forward + "\\(\\(\\[[0-9]*%\\]\\)\\|\\(\\[[0-9]*/[0-9]*\\]\\)\\)" + (point-at-eol) t) + (replace-match (if (match-end 2) "[100%]" "[0/0]") t t))))) + (goto-char pos) + (move-marker pos nil))))) + +(defvar org-entry-property-inherited-from) ;; defined below +(defun org-update-parent-todo-statistics () + "Update any statistics cookie in the parent of the current headline. +When `org-hierarchical-todo-statistics' is nil, statistics will cover +the entire subtree and this will travel up the hierarchy and update +statistics everywhere." + (interactive) + (let* ((lim 0) prop + (recursive (or (not org-hierarchical-todo-statistics) + (string-match + "\\<recursive\\>" + (or (setq prop (org-entry-get + nil "COOKIE_DATA" 'inherit)) "")))) + (lim (or (and prop (marker-position + org-entry-property-inherited-from)) + lim)) + (first t) + (box-re "\\(\\(\\[[0-9]*%\\]\\)\\|\\(\\[[0-9]*/[0-9]*\\]\\)\\)") + level ltoggle l1 new ndel + (cnt-all 0) (cnt-done 0) is-percent kwd cookie-present) + (catch 'exit + (save-excursion + (beginning-of-line 1) + (if (org-at-heading-p) + (setq ltoggle (funcall outline-level)) + (error "This should not happen")) + (while (and (setq level (org-up-heading-safe)) + (or recursive first) + (>= (point) lim)) + (setq first nil cookie-present nil) + (unless (and level + (not (string-match + "\\<checkbox\\>" + (downcase + (or (org-entry-get + nil "COOKIE_DATA") + ""))))) + (throw 'exit nil)) + (while (re-search-forward box-re (point-at-eol) t) + (setq cnt-all 0 cnt-done 0 cookie-present t) + (setq is-percent (match-end 2)) + (save-match-data + (unless (outline-next-heading) (throw 'exit nil)) + (while (and (looking-at org-complex-heading-regexp) + (> (setq l1 (length (match-string 1))) level)) + (setq kwd (and (or recursive (= l1 ltoggle)) + (match-string 2))) + (if (or (eq org-provide-todo-statistics 'all-headlines) + (and (listp org-provide-todo-statistics) + (or (member kwd org-provide-todo-statistics) + (member kwd org-done-keywords)))) + (setq cnt-all (1+ cnt-all)) + (if (eq org-provide-todo-statistics t) + (and kwd (setq cnt-all (1+ cnt-all))))) + (and (member kwd org-done-keywords) + (setq cnt-done (1+ cnt-done))) + (outline-next-heading))) + (setq new + (if is-percent + (format "[%d%%]" (/ (* 100 cnt-done) (max 1 cnt-all))) + (format "[%d/%d]" cnt-done cnt-all)) + ndel (- (match-end 0) (match-beginning 0))) + (goto-char (match-beginning 0)) + (insert new) + (delete-region (point) (+ (point) ndel))) + (when cookie-present + (run-hook-with-args 'org-after-todo-statistics-hook + cnt-done (- cnt-all cnt-done)))))) + (run-hooks 'org-todo-statistics-hook))) + +(defvar org-after-todo-statistics-hook nil + "Hook that is called after a TODO statistics cookie has been updated. +Each function is called with two arguments: the number of not-done entries +and the number of done entries. + +For example, the following function, when added to this hook, will switch +an entry to DONE when all children are done, and back to TODO when new +entries are set to a TODO status. Note that this hook is only called +when there is a statistics cookie in the headline! + + (defun org-summary-todo (n-done n-not-done) + \"Switch entry to DONE when all subentries are done, to TODO otherwise.\" + (let (org-log-done org-log-states) ; turn off logging + (org-todo (if (= n-not-done 0) \"DONE\" \"TODO\")))) +") + +(defvar org-todo-statistics-hook nil + "Hook that is run whenever Org thinks TODO statistics should be updated. +This hook runs even if there is no statistics cookie present, in which case +`org-after-todo-statistics-hook' would not run.") + +(defun org-todo-trigger-tag-changes (state) + "Apply the changes defined in `org-todo-state-tags-triggers'." + (let ((l org-todo-state-tags-triggers) + changes) + (when (or (not state) (equal state "")) + (setq changes (append changes (cdr (assoc "" l))))) + (when (and (stringp state) (> (length state) 0)) + (setq changes (append changes (cdr (assoc state l))))) + (when (member state org-not-done-keywords) + (setq changes (append changes (cdr (assoc 'todo l))))) + (when (member state org-done-keywords) + (setq changes (append changes (cdr (assoc 'done l))))) + (dolist (c changes) + (org-toggle-tag (car c) (if (cdr c) 'on 'off))))) + +(defun org-local-logging (value) + "Get logging settings from a property VALUE." + (let* (words w a) + ;; directly set the variables, they are already local. + (setq org-log-done nil + org-log-repeat nil + org-todo-log-states nil) + (setq words (org-split-string value)) + (while (setq w (pop words)) + (cond + ((setq a (assoc w org-startup-options)) + (and (member (nth 1 a) '(org-log-done org-log-repeat)) + (set (nth 1 a) (nth 2 a)))) + ((setq a (org-extract-log-state-settings w)) + (and (member (car a) org-todo-keywords-1) + (push a org-todo-log-states))))))) + +(defun org-get-todo-sequence-head (kwd) + "Return the head of the TODO sequence to which KWD belongs. +If KWD is not set, check if there is a text property remembering the +right sequence." + (let (p) + (cond + ((not kwd) + (or (get-text-property (point-at-bol) 'org-todo-head) + (progn + (setq p (next-single-property-change (point-at-bol) 'org-todo-head + nil (point-at-eol))) + (get-text-property p 'org-todo-head)))) + ((not (member kwd org-todo-keywords-1)) + (car org-todo-keywords-1)) + (t (nth 2 (assoc kwd org-todo-kwd-alist)))))) + +(defun org-fast-todo-selection () + "Fast TODO keyword selection with single keys. +Returns the new TODO keyword, or nil if no state change should occur." + (let* ((fulltable org-todo-key-alist) + (done-keywords org-done-keywords) ;; needed for the faces. + (maxlen (apply 'max (mapcar + (lambda (x) + (if (stringp (car x)) (string-width (car x)) 0)) + fulltable))) + (expert nil) + (fwidth (+ maxlen 3 1 3)) + (ncol (/ (- (window-width) 4) fwidth)) + tg cnt e c tbl + groups ingroup) + (save-excursion + (save-window-excursion + (if expert + (set-buffer (get-buffer-create " *Org todo*")) + (org-switch-to-buffer-other-window (get-buffer-create " *Org todo*"))) + (erase-buffer) + (org-set-local 'org-done-keywords done-keywords) + (setq tbl fulltable cnt 0) + (while (setq e (pop tbl)) + (cond + ((equal e '(:startgroup)) + (push '() groups) (setq ingroup t) + (when (not (= cnt 0)) + (setq cnt 0) + (insert "\n")) + (insert "{ ")) + ((equal e '(:endgroup)) + (setq ingroup nil cnt 0) + (insert "}\n")) + ((equal e '(:newline)) + (when (not (= cnt 0)) + (setq cnt 0) + (insert "\n") + (setq e (car tbl)) + (while (equal (car tbl) '(:newline)) + (insert "\n") + (setq tbl (cdr tbl))))) + (t + (setq tg (car e) c (cdr e)) + (if ingroup (push tg (car groups))) + (setq tg (org-add-props tg nil 'face + (org-get-todo-face tg))) + (if (and (= cnt 0) (not ingroup)) (insert " ")) + (insert "[" c "] " tg (make-string + (- fwidth 4 (length tg)) ?\ )) + (when (= (setq cnt (1+ cnt)) ncol) + (insert "\n") + (if ingroup (insert " ")) + (setq cnt 0))))) + (insert "\n") + (goto-char (point-min)) + (if (not expert) (org-fit-window-to-buffer)) + (message "[a-z..]:Set [SPC]:clear") + (setq c (let ((inhibit-quit t)) (read-char-exclusive))) + (cond + ((or (= c ?\C-g) + (and (= c ?q) (not (rassoc c fulltable)))) + (setq quit-flag t)) + ((= c ?\ ) nil) + ((setq e (rassoc c fulltable) tg (car e)) + tg) + (t (setq quit-flag t))))))) + +(defun org-entry-is-todo-p () + (member (org-get-todo-state) org-not-done-keywords)) + +(defun org-entry-is-done-p () + (member (org-get-todo-state) org-done-keywords)) + +(defun org-get-todo-state () + (save-excursion + (org-back-to-heading t) + (and (looking-at org-todo-line-regexp) + (match-end 2) + (match-string 2)))) + +(defun org-at-date-range-p (&optional inactive-ok) + "Is the cursor inside a date range?" + (interactive) + (save-excursion + (catch 'exit + (let ((pos (point))) + (skip-chars-backward "^[<\r\n") + (skip-chars-backward "<[") + (and (looking-at (if inactive-ok org-tr-regexp-both org-tr-regexp)) + (>= (match-end 0) pos) + (throw 'exit t)) + (skip-chars-backward "^<[\r\n") + (skip-chars-backward "<[") + (and (looking-at (if inactive-ok org-tr-regexp-both org-tr-regexp)) + (>= (match-end 0) pos) + (throw 'exit t))) + nil))) + +(defun org-get-repeat (&optional tagline) + "Check if there is a deadline/schedule with repeater in this entry." + (save-match-data + (save-excursion + (org-back-to-heading t) + (and (re-search-forward (if tagline + (concat tagline "\\s-*" org-repeat-re) + org-repeat-re) + (org-entry-end-position) t) + (match-string-no-properties 1))))) + +(defvar org-last-changed-timestamp) +(defvar org-last-inserted-timestamp) +(defvar org-log-post-message) +(defvar org-log-note-purpose) +(defvar org-log-note-how) +(defvar org-log-note-extra) +(defun org-auto-repeat-maybe (done-word) + "Check if the current headline contains a repeated deadline/schedule. +If yes, set TODO state back to what it was and change the base date +of repeating deadline/scheduled time stamps to new date. +This function is run automatically after each state change to a DONE state." + ;; last-state is dynamically scoped into this function + (let* ((repeat (org-get-repeat)) + (aa (assoc last-state org-todo-kwd-alist)) + (interpret (nth 1 aa)) + (head (nth 2 aa)) + (whata '(("d" . day) ("m" . month) ("y" . year))) + (msg "Entry repeats: ") + (org-log-done nil) + (org-todo-log-states nil) + re type n what ts time to-state) + (when repeat + (if (eq org-log-repeat t) (setq org-log-repeat 'state)) + (setq to-state (or (org-entry-get nil "REPEAT_TO_STATE") + org-todo-repeat-to-state)) + (unless (and to-state (member to-state org-todo-keywords-1)) + (setq to-state (if (eq interpret 'type) last-state head))) + (org-todo to-state) + (when (or org-log-repeat (org-entry-get nil "CLOCK")) + (org-entry-put nil "LAST_REPEAT" (format-time-string + (org-time-stamp-format t t)))) + (when org-log-repeat + (if (or (memq 'org-add-log-note (default-value 'post-command-hook)) + (memq 'org-add-log-note post-command-hook)) + ;; OK, we are already setup for some record + (if (eq org-log-repeat 'note) + ;; make sure we take a note, not only a time stamp + (setq org-log-note-how 'note)) + ;; Set up for taking a record + (org-add-log-setup 'state (or done-word (car org-done-keywords)) + last-state + 'findpos org-log-repeat))) + (org-back-to-heading t) + (org-add-planning-info nil nil 'closed) + (setq re (concat "\\(" org-scheduled-time-regexp "\\)\\|\\(" + org-deadline-time-regexp "\\)\\|\\(" + org-ts-regexp "\\)")) + (while (re-search-forward + re (save-excursion (outline-next-heading) (point)) t) + (setq type (if (match-end 1) org-scheduled-string + (if (match-end 3) org-deadline-string "Plain:")) + ts (match-string (if (match-end 2) 2 (if (match-end 4) 4 0)))) + (when (string-match "\\([.+]\\)?\\(\\+[0-9]+\\)\\([dwmy]\\)" ts) + (setq n (string-to-number (match-string 2 ts)) + what (match-string 3 ts)) + (if (equal what "w") (setq n (* n 7) what "d")) + ;; Preparation, see if we need to modify the start date for the change + (when (match-end 1) + (setq time (save-match-data (org-time-string-to-time ts))) + (cond + ((equal (match-string 1 ts) ".") + ;; Shift starting date to today + (org-timestamp-change + (- (time-to-days (current-time)) (time-to-days time)) + 'day)) + ((equal (match-string 1 ts) "+") + (let ((nshiftmax 10) (nshift 0)) + (while (or (= nshift 0) + (<= (time-to-days time) + (time-to-days (current-time)))) + (when (= (incf nshift) nshiftmax) + (or (y-or-n-p (message "%d repeater intervals were not enough to shift date past today. Continue? " nshift)) + (error "Abort"))) + (org-timestamp-change n (cdr (assoc what whata))) + (org-at-timestamp-p t) + (setq ts (match-string 1)) + (setq time (save-match-data (org-time-string-to-time ts))))) + (org-timestamp-change (- n) (cdr (assoc what whata))) + ;; rematch, so that we have everything in place for the real shift + (org-at-timestamp-p t) + (setq ts (match-string 1)) + (string-match "\\([.+]\\)?\\(\\+[0-9]+\\)\\([dwmy]\\)" ts)))) + (org-timestamp-change n (cdr (assoc what whata))) + (setq msg (concat msg type " " org-last-changed-timestamp " ")))) + (setq org-log-post-message msg) + (message "%s" msg)))) + +(defun org-show-todo-tree (arg) + "Make a compact tree which shows all headlines marked with TODO. +The tree will show the lines where the regexp matches, and all higher +headlines above the match. +With a \\[universal-argument] prefix, prompt for a regexp to match. +With a numeric prefix N, construct a sparse tree for the Nth element +of `org-todo-keywords-1'." + (interactive "P") + (let ((case-fold-search nil) + (kwd-re + (cond ((null arg) org-not-done-regexp) + ((equal arg '(4)) + (let ((kwd (org-icompleting-read "Keyword (or KWD1|KWD2|...): " + (mapcar 'list org-todo-keywords-1)))) + (concat "\\(" + (mapconcat 'identity (org-split-string kwd "|") "\\|") + "\\)\\>"))) + ((<= (prefix-numeric-value arg) (length org-todo-keywords-1)) + (regexp-quote (nth (1- (prefix-numeric-value arg)) + org-todo-keywords-1))) + (t (error "Invalid prefix argument: %s" arg))))) + (message "%d TODO entries found" + (org-occur (concat "^" outline-regexp " *" kwd-re ))))) + +(defun org-deadline (&optional remove time) + "Insert the \"DEADLINE:\" string with a timestamp to make a deadline. +With argument REMOVE, remove any deadline from the item. +When TIME is set, it should be an internal time specification, and the +scheduling will use the corresponding date." + (interactive "P") + (let* ((old-date (org-entry-get nil "DEADLINE")) + (repeater (and old-date + (string-match "\\([.+]+[0-9]+[dwmy]\\) ?" old-date) + (match-string 1 old-date)))) + (if remove + (progn + (when (and old-date org-log-redeadline) + (org-add-log-setup 'deldeadline nil old-date 'findpos + org-log-redeadline)) + (org-remove-timestamp-with-keyword org-deadline-string) + (message "Item no longer has a deadline.")) + (org-add-planning-info 'deadline time 'closed) + (when (and old-date org-log-redeadline + (not (equal old-date + (substring org-last-inserted-timestamp 1 -1)))) + (org-add-log-setup 'redeadline nil old-date 'findpos + org-log-redeadline)) + (when repeater + (save-excursion + (org-back-to-heading t) + (when (re-search-forward (concat org-deadline-string " " + org-last-inserted-timestamp) + (save-excursion + (outline-next-heading) (point)) t) + (goto-char (1- (match-end 0))) + (insert " " repeater) + (setq org-last-inserted-timestamp + (concat (substring org-last-inserted-timestamp 0 -1) + " " repeater + (substring org-last-inserted-timestamp -1)))))) + (message "Deadline on %s" org-last-inserted-timestamp)))) + +(defun org-schedule (&optional remove time) + "Insert the SCHEDULED: string with a timestamp to schedule a TODO item. +With argument REMOVE, remove any scheduling date from the item. +When TIME is set, it should be an internal time specification, and the +scheduling will use the corresponding date." + (interactive "P") + (let* ((old-date (org-entry-get nil "SCHEDULED")) + (repeater (and old-date + (string-match "\\([.+]+[0-9]+[dwmy]\\) ?" old-date) + (match-string 1 old-date)))) + (if remove + (progn + (when (and old-date org-log-reschedule) + (org-add-log-setup 'delschedule nil old-date 'findpos + org-log-reschedule)) + (org-remove-timestamp-with-keyword org-scheduled-string) + (message "Item is no longer scheduled.")) + (org-add-planning-info 'scheduled time 'closed) + (when (and old-date org-log-reschedule + (not (equal old-date + (substring org-last-inserted-timestamp 1 -1)))) + (org-add-log-setup 'reschedule nil old-date 'findpos + org-log-reschedule)) + (when repeater + (save-excursion + (org-back-to-heading t) + (when (re-search-forward (concat org-scheduled-string " " + org-last-inserted-timestamp) + (save-excursion + (outline-next-heading) (point)) t) + (goto-char (1- (match-end 0))) + (insert " " repeater) + (setq org-last-inserted-timestamp + (concat (substring org-last-inserted-timestamp 0 -1) + " " repeater + (substring org-last-inserted-timestamp -1)))))) + (message "Scheduled to %s" org-last-inserted-timestamp)))) + +(defun org-get-scheduled-time (pom &optional inherit) + "Get the scheduled time as a time tuple, of a format suitable +for calling org-schedule with, or if there is no scheduling, +returns nil." + (let ((time (org-entry-get pom "SCHEDULED" inherit))) + (when time + (apply 'encode-time (org-parse-time-string time))))) + +(defun org-get-deadline-time (pom &optional inherit) + "Get the deadline as a time tuple, of a format suitable for +calling org-deadline with, or if there is no scheduling, returns +nil." + (let ((time (org-entry-get pom "DEADLINE" inherit))) + (when time + (apply 'encode-time (org-parse-time-string time))))) + +(defun org-remove-timestamp-with-keyword (keyword) + "Remove all time stamps with KEYWORD in the current entry." + (let ((re (concat "\\<" (regexp-quote keyword) " +<[^>\n]+>[ \t]*")) + beg) + (save-excursion + (org-back-to-heading t) + (setq beg (point)) + (outline-next-heading) + (while (re-search-backward re beg t) + (replace-match "") + (if (and (string-match "\\S-" (buffer-substring (point-at-bol) (point))) + (equal (char-before) ?\ )) + (backward-delete-char 1) + (if (string-match "^[ \t]*$" (buffer-substring + (point-at-bol) (point-at-eol))) + (delete-region (point-at-bol) + (min (point-max) (1+ (point-at-eol)))))))))) + +(defun org-add-planning-info (what &optional time &rest remove) + "Insert new timestamp with keyword in the line directly after the headline. +WHAT indicates what kind of time stamp to add. TIME indicated the time to use. +If non is given, the user is prompted for a date. +REMOVE indicates what kind of entries to remove. An old WHAT entry will also +be removed." + (interactive) + (let (org-time-was-given org-end-time-was-given ts + end default-time default-input) + + (catch 'exit + (when (and (not time) (memq what '(scheduled deadline))) + ;; Try to get a default date/time from existing timestamp + (save-excursion + (org-back-to-heading t) + (setq end (save-excursion (outline-next-heading) (point))) + (when (re-search-forward (if (eq what 'scheduled) + org-scheduled-time-regexp + org-deadline-time-regexp) + end t) + (setq ts (match-string 1) + default-time + (apply 'encode-time (org-parse-time-string ts)) + default-input (and ts (org-get-compact-tod ts)))))) + (when what + ;; If necessary, get the time from the user + (setq time (or time (org-read-date nil 'to-time nil nil + default-time default-input)))) + + (when (and org-insert-labeled-timestamps-at-point + (member what '(scheduled deadline))) + (insert + (if (eq what 'scheduled) org-scheduled-string org-deadline-string) " ") + (org-insert-time-stamp time org-time-was-given + nil nil nil (list org-end-time-was-given)) + (setq what nil)) + (save-excursion + (save-restriction + (let (col list elt ts buffer-invisibility-spec) + (org-back-to-heading t) + (looking-at (concat outline-regexp "\\( *\\)[^\r\n]*")) + (goto-char (match-end 1)) + (setq col (current-column)) + (goto-char (match-end 0)) + (if (eobp) (insert "\n") (forward-char 1)) + (when (and (not what) + (not (looking-at + (concat "[ \t]*" + org-keyword-time-not-clock-regexp)))) + ;; Nothing to add, nothing to remove...... :-) + (throw 'exit nil)) + (if (and (not (looking-at outline-regexp)) + (looking-at (concat "[^\r\n]*?" org-keyword-time-regexp + "[^\r\n]*")) + (not (equal (match-string 1) org-clock-string))) + (narrow-to-region (match-beginning 0) (match-end 0)) + (insert-before-markers "\n") + (backward-char 1) + (narrow-to-region (point) (point)) + (and org-adapt-indentation (org-indent-to-column col))) + ;; Check if we have to remove something. + (setq list (cons what remove)) + (while list + (setq elt (pop list)) + (goto-char (point-min)) + (when (or (and (eq elt 'scheduled) + (re-search-forward org-scheduled-time-regexp nil t)) + (and (eq elt 'deadline) + (re-search-forward org-deadline-time-regexp nil t)) + (and (eq elt 'closed) + (re-search-forward org-closed-time-regexp nil t))) + (replace-match "") + (if (looking-at "--+<[^>]+>") (replace-match "")) + (skip-chars-backward " ") + (if (looking-at " +") (replace-match "")))) + (goto-char (point-max)) + (and org-adapt-indentation (bolp) (org-indent-to-column col)) + (when what + (insert + (if (not (or (bolp) (eq (char-before) ?\ ))) " " "") + (cond ((eq what 'scheduled) org-scheduled-string) + ((eq what 'deadline) org-deadline-string) + ((eq what 'closed) org-closed-string)) + " ") + (setq ts (org-insert-time-stamp + time + (or org-time-was-given + (and (eq what 'closed) org-log-done-with-time)) + (eq what 'closed) + nil nil (list org-end-time-was-given))) + (end-of-line 1)) + (goto-char (point-min)) + (widen) + (if (and (looking-at "[ \t]*\n") + (equal (char-before) ?\n)) + (delete-region (1- (point)) (point-at-eol))) + ts)))))) + +(defvar org-log-note-marker (make-marker)) +(defvar org-log-note-purpose nil) +(defvar org-log-note-state nil) +(defvar org-log-note-previous-state nil) +(defvar org-log-note-how nil) +(defvar org-log-note-extra nil) +(defvar org-log-note-window-configuration nil) +(defvar org-log-note-return-to (make-marker)) +(defvar org-log-post-message nil + "Message to be displayed after a log note has been stored. +The auto-repeater uses this.") + +(defun org-add-note () + "Add a note to the current entry. +This is done in the same way as adding a state change note." + (interactive) + (org-add-log-setup 'note nil nil 'findpos nil)) + +(defvar org-property-end-re) +(defun org-add-log-setup (&optional purpose state prev-state + findpos how extra) + "Set up the post command hook to take a note. +If this is about to TODO state change, the new state is expected in STATE. +When FINDPOS is non-nil, find the correct position for the note in +the current entry. If not, assume that it can be inserted at point. +HOW is an indicator what kind of note should be created. +EXTRA is additional text that will be inserted into the notes buffer." + (let* ((org-log-into-drawer (org-log-into-drawer)) + (drawer (cond ((stringp org-log-into-drawer) + org-log-into-drawer) + (org-log-into-drawer "LOGBOOK") + (t nil)))) + (save-restriction + (save-excursion + (when findpos + (org-back-to-heading t) + (narrow-to-region (point) (save-excursion + (outline-next-heading) (point))) + (looking-at (concat outline-regexp "\\( *\\)[^\r\n]*" + "\\(\n[^\r\n]*?" org-keyword-time-not-clock-regexp + "[^\r\n]*\\)?")) + (goto-char (match-end 0)) + (cond + (drawer + (if (re-search-forward (concat "^[ \t]*:" drawer ":[ \t]*$") + nil t) + (progn + (goto-char (match-end 0)) + (or org-log-states-order-reversed + (and (re-search-forward org-property-end-re nil t) + (goto-char (1- (match-beginning 0)))))) + (insert "\n:" drawer ":\n:END:") + (beginning-of-line 0) + (org-indent-line-function) + (beginning-of-line 2) + (org-indent-line-function) + (end-of-line 0))) + ((and org-log-state-notes-insert-after-drawers + (save-excursion + (forward-line) (looking-at org-drawer-regexp))) + (forward-line) + (while (looking-at org-drawer-regexp) + (goto-char (match-end 0)) + (re-search-forward org-property-end-re (point-max) t) + (forward-line)) + (forward-line -1))) + (unless org-log-states-order-reversed + (and (= (char-after) ?\n) (forward-char 1)) + (org-skip-over-state-notes) + (skip-chars-backward " \t\n\r"))) + (move-marker org-log-note-marker (point)) + (setq org-log-note-purpose purpose + org-log-note-state state + org-log-note-previous-state prev-state + org-log-note-how how + org-log-note-extra extra) + (add-hook 'post-command-hook 'org-add-log-note 'append))))) + +(defun org-skip-over-state-notes () + "Skip past the list of State notes in an entry." + (if (looking-at "\n[ \t]*- State") (forward-char 1)) + (when (org-in-item-p) + (let ((limit (org-list-bottom-point))) + (while (looking-at "[ \t]*- State") + (goto-char (or (org-get-next-item (point) limit) + (org-get-end-of-item limit))))))) + +(defun org-add-log-note (&optional purpose) + "Pop up a window for taking a note, and add this note later at point." + (remove-hook 'post-command-hook 'org-add-log-note) + (setq org-log-note-window-configuration (current-window-configuration)) + (delete-other-windows) + (move-marker org-log-note-return-to (point)) + (switch-to-buffer (marker-buffer org-log-note-marker)) + (goto-char org-log-note-marker) + (org-switch-to-buffer-other-window "*Org Note*") + (erase-buffer) + (if (memq org-log-note-how '(time state)) + (let (current-prefix-arg) (org-store-log-note)) + (let ((org-inhibit-startup t)) (org-mode)) + (insert (format "# Insert note for %s. +# Finish with C-c C-c, or cancel with C-c C-k.\n\n" + (cond + ((eq org-log-note-purpose 'clock-out) "stopped clock") + ((eq org-log-note-purpose 'done) "closed todo item") + ((eq org-log-note-purpose 'state) + (format "state change from \"%s\" to \"%s\"" + (or org-log-note-previous-state "") + (or org-log-note-state ""))) + ((eq org-log-note-purpose 'reschedule) + "rescheduling") + ((eq org-log-note-purpose 'delschedule) + "no longer scheduled") + ((eq org-log-note-purpose 'redeadline) + "changing deadline") + ((eq org-log-note-purpose 'deldeadline) + "removing deadline") + ((eq org-log-note-purpose 'refile) + "refiling") + ((eq org-log-note-purpose 'note) + "this entry") + (t (error "This should not happen"))))) + (if org-log-note-extra (insert org-log-note-extra)) + (org-set-local 'org-finish-function 'org-store-log-note))) + +(defvar org-note-abort nil) ; dynamically scoped +(defun org-store-log-note () + "Finish taking a log note, and insert it to where it belongs." + (let ((txt (buffer-string)) + (note (cdr (assq org-log-note-purpose org-log-note-headings))) + lines ind bul) + (kill-buffer (current-buffer)) + (while (string-match "\\`#.*\n[ \t\n]*" txt) + (setq txt (replace-match "" t t txt))) + (if (string-match "\\s-+\\'" txt) + (setq txt (replace-match "" t t txt))) + (setq lines (org-split-string txt "\n")) + (when (and note (string-match "\\S-" note)) + (setq note + (org-replace-escapes + note + (list (cons "%u" (user-login-name)) + (cons "%U" user-full-name) + (cons "%t" (format-time-string + (org-time-stamp-format 'long 'inactive) + (current-time))) + (cons "%T" (format-time-string + (org-time-stamp-format 'long nil) + (current-time))) + (cons "%s" (if org-log-note-state + (concat "\"" org-log-note-state "\"") + "")) + (cons "%S" (if org-log-note-previous-state + (concat "\"" org-log-note-previous-state "\"") + "\"\""))))) + (if lines (setq note (concat note " \\\\"))) + (push note lines)) + (when (or current-prefix-arg org-note-abort) + (when org-log-into-drawer + (org-remove-empty-drawer-at + (if (stringp org-log-into-drawer) org-log-into-drawer "LOGBOOK") + org-log-note-marker)) + (setq lines nil)) + (when lines + (with-current-buffer (marker-buffer org-log-note-marker) + (save-excursion + (goto-char org-log-note-marker) + (move-marker org-log-note-marker nil) + (end-of-line 1) + (if (not (bolp)) (let ((inhibit-read-only t)) (insert "\n"))) + (setq ind (save-excursion + (if (org-in-item-p) + (progn + (goto-char (org-list-top-point)) + (org-get-indentation)) + (skip-chars-backward " \r\t\n") + (cond + ((and (org-at-heading-p) + org-adapt-indentation) + (1+ (org-current-level))) + ((org-at-heading-p) 0) + (t (org-get-indentation)))))) + (setq bul (org-list-bullet-string "-")) + (org-indent-line-to ind) + (insert bul (pop lines)) + (let ((ind-body (+ (length bul) ind))) + (while lines + (insert "\n") + (org-indent-line-to ind-body) + (insert (pop lines)))) + (message "Note stored") + (org-back-to-heading t) + (org-cycle-hide-drawers 'children))))) + (set-window-configuration org-log-note-window-configuration) + (with-current-buffer (marker-buffer org-log-note-return-to) + (goto-char org-log-note-return-to)) + (move-marker org-log-note-return-to nil) + (and org-log-post-message (message "%s" org-log-post-message))) + +(defun org-remove-empty-drawer-at (drawer pos) + "Remove an empty drawer DRAWER at position POS. +POS may also be a marker." + (with-current-buffer (if (markerp pos) (marker-buffer pos) (current-buffer)) + (save-excursion + (save-restriction + (widen) + (goto-char pos) + (if (org-in-regexp + (concat "^[ \t]*:" drawer ":[ \t]*\n[ \t]*:END:[ \t]*\n?") 2) + (replace-match "")))))) + +(defun org-sparse-tree (&optional arg) + "Create a sparse tree, prompt for the details. +This command can create sparse trees. You first need to select the type +of match used to create the tree: + +t Show all TODO entries. +T Show entries with a specific TODO keyword. +m Show entries selected by a tags/property match. +p Enter a property name and its value (both with completion on existing + names/values) and show entries with that property. +r Show entries matching a regular expression (`/' can be used as well) +d Show deadlines due within `org-deadline-warning-days'. +b Show deadlines and scheduled items before a date. +a Show deadlines and scheduled items after a date." + (interactive "P") + (let (ans kwd value) + (message "Sparse tree: [r]egexp [/]regexp [t]odo [T]odo-kwd [m]atch [p]roperty\n [d]eadlines [b]efore-date [a]fter-date") + (setq ans (read-char-exclusive)) + (cond + ((equal ans ?d) + (call-interactively 'org-check-deadlines)) + ((equal ans ?b) + (call-interactively 'org-check-before-date)) + ((equal ans ?a) + (call-interactively 'org-check-after-date)) + ((equal ans ?t) + (org-show-todo-tree nil)) + ((equal ans ?T) + (org-show-todo-tree '(4))) + ((member ans '(?T ?m)) + (call-interactively 'org-match-sparse-tree)) + ((member ans '(?p ?P)) + (setq kwd (org-icompleting-read "Property: " + (mapcar 'list (org-buffer-property-keys)))) + (setq value (org-icompleting-read "Value: " + (mapcar 'list (org-property-values kwd)))) + (unless (string-match "\\`{.*}\\'" value) + (setq value (concat "\"" value "\""))) + (org-match-sparse-tree arg (concat kwd "=" value))) + ((member ans '(?r ?R ?/)) + (call-interactively 'org-occur)) + (t (error "No such sparse tree command \"%c\"" ans))))) + +(defvar org-occur-highlights nil + "List of overlays used for occur matches.") +(make-variable-buffer-local 'org-occur-highlights) +(defvar org-occur-parameters nil + "Parameters of the active org-occur calls. +This is a list, each call to org-occur pushes as cons cell, +containing the regular expression and the callback, onto the list. +The list can contain several entries if `org-occur' has been called +several time with the KEEP-PREVIOUS argument. Otherwise, this list +will only contain one set of parameters. When the highlights are +removed (for example with `C-c C-c', or with the next edit (depending +on `org-remove-highlights-with-change'), this variable is emptied +as well.") +(make-variable-buffer-local 'org-occur-parameters) + +(defun org-occur (regexp &optional keep-previous callback) + "Make a compact tree which shows all matches of REGEXP. +The tree will show the lines where the regexp matches, and all higher +headlines above the match. It will also show the heading after the match, +to make sure editing the matching entry is easy. +If KEEP-PREVIOUS is non-nil, highlighting and exposing done by a previous +call to `org-occur' will be kept, to allow stacking of calls to this +command. +If CALLBACK is non-nil, it is a function which is called to confirm +that the match should indeed be shown." + (interactive "sRegexp: \nP") + (when (equal regexp "") + (error "Regexp cannot be empty")) + (unless keep-previous + (org-remove-occur-highlights nil nil t)) + (push (cons regexp callback) org-occur-parameters) + (let ((cnt 0)) + (save-excursion + (goto-char (point-min)) + (if (or (not keep-previous) ; do not want to keep + (not org-occur-highlights)) ; no previous matches + ;; hide everything + (org-overview)) + (while (re-search-forward regexp nil t) + (when (or (not callback) + (save-match-data (funcall callback))) + (setq cnt (1+ cnt)) + (when org-highlight-sparse-tree-matches + (org-highlight-new-match (match-beginning 0) (match-end 0))) + (org-show-context 'occur-tree)))) + (when org-remove-highlights-with-change + (org-add-hook 'before-change-functions 'org-remove-occur-highlights + nil 'local)) + (unless org-sparse-tree-open-archived-trees + (org-hide-archived-subtrees (point-min) (point-max))) + (run-hooks 'org-occur-hook) + (if (interactive-p) + (message "%d match(es) for regexp %s" cnt regexp)) + cnt)) + +(defun org-show-context (&optional key) + "Make sure point and context are visible. +How much context is shown depends upon the variables +`org-show-hierarchy-above', `org-show-following-heading'. and +`org-show-siblings'." + (let ((heading-p (org-on-heading-p t)) + (hierarchy-p (org-get-alist-option org-show-hierarchy-above key)) + (following-p (org-get-alist-option org-show-following-heading key)) + (entry-p (org-get-alist-option org-show-entry-below key)) + (siblings-p (org-get-alist-option org-show-siblings key))) + (catch 'exit + ;; Show heading or entry text + (if (and heading-p (not entry-p)) + (org-flag-heading nil) ; only show the heading + (and (or entry-p (org-invisible-p) (org-invisible-p2)) + (org-show-hidden-entry))) ; show entire entry + (when following-p + ;; Show next sibling, or heading below text + (save-excursion + (and (if heading-p (org-goto-sibling) (outline-next-heading)) + (org-flag-heading nil)))) + (when siblings-p (org-show-siblings)) + (when hierarchy-p + ;; show all higher headings, possibly with siblings + (save-excursion + (while (and (condition-case nil + (progn (org-up-heading-all 1) t) + (error nil)) + (not (bobp))) + (org-flag-heading nil) + (when siblings-p (org-show-siblings)))))))) + +(defvar org-reveal-start-hook nil + "Hook run before revealing a location.") + +(defun org-reveal (&optional siblings) + "Show current entry, hierarchy above it, and the following headline. +This can be used to show a consistent set of context around locations +exposed with `org-show-hierarchy-above' or `org-show-following-heading' +not t for the search context. + +With optional argument SIBLINGS, on each level of the hierarchy all +siblings are shown. This repairs the tree structure to what it would +look like when opened with hierarchical calls to `org-cycle'. +With double optional argument \\[universal-argument] \\[universal-argument], \ +go to the parent and show the +entire tree." + (interactive "P") + (run-hooks 'org-reveal-start-hook) + (let ((org-show-hierarchy-above t) + (org-show-following-heading t) + (org-show-siblings (if siblings t org-show-siblings))) + (org-show-context nil)) + (when (equal siblings '(16)) + (save-excursion + (when (org-up-heading-safe) + (org-show-subtree) + (run-hook-with-args 'org-cycle-hook 'subtree))))) + +(defun org-highlight-new-match (beg end) + "Highlight from BEG to END and mark the highlight is an occur headline." + (let ((ov (make-overlay beg end))) + (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) + (unless org-inhibit-highlight-removal + (mapc 'delete-overlay org-occur-highlights) + (setq org-occur-highlights nil) + (setq org-occur-parameters nil) + (unless noremove + (remove-hook 'before-change-functions + 'org-remove-occur-highlights 'local)))) + +;;;; Priorities + +(defvar org-priority-regexp ".*?\\(\\[#\\([A-Z0-9]\\)\\] ?\\)" + "Regular expression matching the priority indicator.") + +(defvar org-remove-priority-next-time nil) + +(defun org-priority-up () + "Increase the priority of the current item." + (interactive) + (org-priority 'up)) + +(defun org-priority-down () + "Decrease the priority of the current item." + (interactive) + (org-priority 'down)) + +(defun org-priority (&optional action) + "Change the priority of an item by ARG. +ACTION can be `set', `up', `down', or a character." + (interactive) + (unless org-enable-priority-commands + (error "Priority commands are disabled")) + (setq action (or action 'set)) + (let (current new news have remove) + (save-excursion + (org-back-to-heading t) + (if (looking-at org-priority-regexp) + (setq current (string-to-char (match-string 2)) + have t) + (setq current org-default-priority)) + (cond + ((eq action 'remove) + (setq remove t new ?\ )) + ((or (eq action 'set) + (if (featurep 'xemacs) (characterp action) (integerp action))) + (if (not (eq action 'set)) + (setq new action) + (message "Priority %c-%c, SPC to remove: " + org-highest-priority org-lowest-priority) + (save-match-data + (setq new (read-char-exclusive)))) + (if (and (= (upcase org-highest-priority) org-highest-priority) + (= (upcase org-lowest-priority) org-lowest-priority)) + (setq new (upcase new))) + (cond ((equal new ?\ ) (setq remove t)) + ((or (< (upcase new) org-highest-priority) (> (upcase new) org-lowest-priority)) + (error "Priority must be between `%c' and `%c'" + org-highest-priority org-lowest-priority)))) + ((eq action 'up) + (if (and (not have) (eq last-command this-command)) + (setq new org-lowest-priority) + (setq new (if (and org-priority-start-cycle-with-default (not have)) + org-default-priority (1- current))))) + ((eq action 'down) + (if (and (not have) (eq last-command this-command)) + (setq new org-highest-priority) + (setq new (if (and org-priority-start-cycle-with-default (not have)) + org-default-priority (1+ current))))) + (t (error "Invalid action"))) + (if (or (< (upcase new) org-highest-priority) + (> (upcase new) org-lowest-priority)) + (setq remove t)) + (setq news (format "%c" new)) + (if have + (if remove + (replace-match "" t t nil 1) + (replace-match news t t nil 2)) + (if remove + (error "No priority cookie found in line") + (let ((case-fold-search nil)) + (looking-at org-todo-line-regexp)) + (if (match-end 2) + (progn + (goto-char (match-end 2)) + (insert " [#" news "]")) + (goto-char (match-beginning 3)) + (insert "[#" news "] ")))) + (org-preserve-lc (org-set-tags nil 'align))) + (if remove + (message "Priority removed") + (message "Priority of current item set to %s" news)))) + +(defun org-get-priority (s) + "Find priority cookie and return priority." + (if (functionp org-get-priority-function) + (funcall org-get-priority-function) + (save-match-data + (if (not (string-match org-priority-regexp s)) + (* 1000 (- org-lowest-priority org-default-priority)) + (* 1000 (- org-lowest-priority + (string-to-char (match-string 2 s)))))))) + +;;;; Tags + +(defvar org-agenda-archives-mode) +(defvar org-map-continue-from nil + "Position from where mapping should continue. +Can be set by the action argument to `org-scan-tag's and `org-map-entries'.") + +(defvar org-scanner-tags nil + "The current tag list while the tags scanner is running.") +(defvar org-trust-scanner-tags nil + "Should `org-get-tags-at' use the tags fro the scanner. +This is for internal dynamical scoping only. +When this is non-nil, the function `org-get-tags-at' will return the value +of `org-scanner-tags' instead of building the list by itself. This +can lead to large speed-ups when the tags scanner is used in a file with +many entries, and when the list of tags is retrieved, for example to +obtain a list of properties. Building the tags list for each entry in such +a file becomes an N^2 operation - but with this variable set, it scales +as N.") + +(defun org-scan-tags (action matcher &optional todo-only) + "Scan headline tags with inheritance and produce output ACTION. + +ACTION can be `sparse-tree' to produce a sparse tree in the current buffer, +or `agenda' to produce an entry list for an agenda view. It can also be +a Lisp form or a function that should be called at each matched headline, in +this case the return value is a list of all return values from these calls. + +MATCHER is a Lisp form to be evaluated, testing if a given set of tags +qualifies a headline for inclusion. When TODO-ONLY is non-nil, +only lines with a TODO keyword are included in the output." + (require 'org-agenda) + (let* ((re (concat "^" outline-regexp " *\\(\\<\\(" + (mapconcat 'regexp-quote org-todo-keywords-1 "\\|") + (org-re + "\\>\\)\\)? *\\(.*?\\)\\(:[[:alnum:]_@#%:]+:\\)?[ \t]*$"))) + (props (list 'face 'default + 'done-face 'org-agenda-done + 'undone-face 'default + 'mouse-face 'highlight + 'org-not-done-regexp org-not-done-regexp + 'org-todo-regexp org-todo-regexp + 'help-echo + (format "mouse-2 or RET jump to org file %s" + (abbreviate-file-name + (or (buffer-file-name (buffer-base-buffer)) + (buffer-name (buffer-base-buffer))))))) + (case-fold-search nil) + (org-map-continue-from nil) + lspos tags tags-list + (tags-alist (list (cons 0 org-file-tags))) + (llast 0) rtn rtn1 level category i txt + todo marker entry priority) + (when (not (or (member action '(agenda sparse-tree)) (functionp action))) + (setq action (list 'lambda nil action))) + (save-excursion + (goto-char (point-min)) + (when (eq action 'sparse-tree) + (org-overview) + (org-remove-occur-highlights)) + (while (re-search-forward re nil t) + (catch :skip + (setq todo (if (match-end 1) (org-match-string-no-properties 2)) + tags (if (match-end 4) (org-match-string-no-properties 4))) + (goto-char (setq lspos (match-beginning 0))) + (setq level (org-reduced-level (funcall outline-level)) + category (org-get-category)) + (setq i llast llast level) + ;; remove tag lists from same and sublevels + (while (>= i level) + (when (setq entry (assoc i tags-alist)) + (setq tags-alist (delete entry tags-alist))) + (setq i (1- i))) + ;; add the next tags + (when tags + (setq tags (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 (reverse tags-alist))) + tags) + org-scanner-tags tags-list) + (when org-use-tag-inheritance + (setcdr (car tags-alist) + (mapcar (lambda (x) + (setq x (copy-sequence x)) + (org-add-prop-inherited x)) + (cdar tags-alist)))) + (when (and tags org-use-tag-inheritance + (or (not (eq t org-use-tag-inheritance)) + org-tags-exclude-from-inheritance)) + ;; selective inheritance, remove uninherited ones + (setcdr (car tags-alist) + (org-remove-uniherited-tags (cdar tags-alist)))) + (when (and (or (not todo-only) + (and (member todo org-not-done-keywords) + (or (not org-agenda-tags-todo-honor-ignore-options) + (not (org-agenda-check-for-timestamp-as-reason-to-ignore-todo-item))))) + (let ((case-fold-search t)) (eval matcher)) + (or + (not (member org-archive-tag tags-list)) + ;; we have an archive tag, should we use this anyway? + (or (not org-agenda-skip-archived-trees) + (and (eq action 'agenda) org-agenda-archives-mode)))) + (unless (eq action 'sparse-tree) (org-agenda-skip)) + + ;; select this headline + + (cond + ((eq action 'sparse-tree) + (and org-highlight-sparse-tree-matches + (org-get-heading) (match-end 0) + (org-highlight-new-match + (match-beginning 0) (match-beginning 1))) + (org-show-context 'tags-tree)) + ((eq action 'agenda) + (setq txt (org-format-agenda-item + "" + (concat + (if (eq org-tags-match-list-sublevels 'indented) + (make-string (1- level) ?.) "") + (org-get-heading)) + category + tags-list + ) + priority (org-get-priority txt)) + (goto-char lspos) + (setq marker (org-agenda-new-marker)) + (org-add-props txt props + 'org-marker marker 'org-hd-marker marker 'org-category category + 'todo-state todo + 'priority priority 'type "tagsmatch") + (push txt rtn)) + ((functionp action) + (setq org-map-continue-from nil) + (save-excursion + (setq rtn1 (funcall action)) + (push rtn1 rtn))) + (t (error "Invalid action"))) + + ;; if we are to skip sublevels, jump to end of subtree + (unless org-tags-match-list-sublevels + (org-end-of-subtree t) + (backward-char 1)))) + ;; Get the correct position from where to continue + (if org-map-continue-from + (goto-char org-map-continue-from) + (and (= (point) lspos) (end-of-line 1))))) + (when (and (eq action 'sparse-tree) + (not org-sparse-tree-open-archived-trees)) + (org-hide-archived-subtrees (point-min) (point-max))) + (nreverse rtn))) + +(defun org-remove-uniherited-tags (tags) + "Remove all tags that are not inherited from the list TAGS." + (cond + ((eq org-use-tag-inheritance t) + (if org-tags-exclude-from-inheritance + (org-delete-all org-tags-exclude-from-inheritance tags) + tags)) + ((not org-use-tag-inheritance) nil) + ((stringp org-use-tag-inheritance) + (delq nil (mapcar + (lambda (x) + (if (and (string-match org-use-tag-inheritance x) + (not (member x org-tags-exclude-from-inheritance))) + x nil)) + tags))) + ((listp org-use-tag-inheritance) + (delq nil (mapcar + (lambda (x) + (if (member x org-use-tag-inheritance) x nil)) + tags))))) + +(defvar todo-only) ;; dynamically scoped + +(defun org-match-sparse-tree (&optional todo-only match) + "Create a sparse tree according to tags string MATCH. +MATCH can contain positive and negative selection of tags, like +\"+WORK+URGENT-WITHBOSS\". +If optional argument TODO-ONLY is non-nil, only select lines that are +also TODO lines." + (interactive "P") + (org-prepare-agenda-buffers (list (current-buffer))) + (org-scan-tags 'sparse-tree (cdr (org-make-tags-matcher match)) todo-only)) + +(defalias 'org-tags-sparse-tree 'org-match-sparse-tree) + +(defvar org-cached-props nil) +(defun org-cached-entry-get (pom property) + (if (or (eq t org-use-property-inheritance) + (and (stringp org-use-property-inheritance) + (string-match org-use-property-inheritance property)) + (and (listp org-use-property-inheritance) + (member property org-use-property-inheritance))) + ;; Caching is not possible, check it directly + (org-entry-get pom property 'inherit) + ;; Get all properties, so that we can do complicated checks easily + (cdr (assoc property (or org-cached-props + (setq org-cached-props + (org-entry-properties pom))))))) + +(defun org-global-tags-completion-table (&optional files) + "Return the list of all tags in all agenda buffer/files." + (save-excursion + (org-uniquify + (delq nil + (apply 'append + (mapcar + (lambda (file) + (set-buffer (find-file-noselect file)) + (append (org-get-buffer-tags) + (mapcar (lambda (x) (if (stringp (car-safe x)) + (list (car-safe x)) nil)) + org-tag-alist))) + (if (and files (car files)) + files + (org-agenda-files)))))))) + +(defun org-make-tags-matcher (match) + "Create the TAGS//TODO matcher form for the selection string MATCH." + ;; todo-only is scoped dynamically into this function, and the function + ;; may change it if the matcher asks for it. + (unless match + ;; Get a new match request, with completion + (let ((org-last-tags-completion-table + (org-global-tags-completion-table))) + (setq match (org-completing-read-no-i + "Match: " 'org-tags-completion-function nil nil nil + 'org-tags-history)))) + + ;; Parse the string and create a lisp form + (let ((match0 match) + (re (org-re "^&?\\([-+:]\\)?\\({[^}]+}\\|LEVEL\\([<=>]\\{1,2\\}\\)\\([0-9]+\\)\\|\\(\\(?:[[:alnum:]_]+\\(?:\\\\-\\)*\\)+\\)\\([<>=]\\{1,2\\}\\)\\({[^}]+}\\|\"[^\"]*\"\\|-?[.0-9]+\\(?:[eE][-+]?[0-9]+\\)?\\)\\|[[:alnum:]_@#%]+\\)")) + minus tag mm + tagsmatch todomatch tagsmatcher todomatcher kwd matcher + orterms term orlist re-p str-p level-p level-op time-p + prop-p pn pv po gv rest) + (if (string-match "/+" match) + ;; match contains also a todo-matching request + (progn + (setq tagsmatch (substring match 0 (match-beginning 0)) + todomatch (substring match (match-end 0))) + (if (string-match "^!" todomatch) + (setq todo-only t todomatch (substring todomatch 1))) + (if (string-match "^\\s-*$" todomatch) + (setq todomatch nil))) + ;; only matching tags + (setq tagsmatch match todomatch nil)) + + ;; Make the tags matcher + (if (or (not tagsmatch) (not (string-match "\\S-" tagsmatch))) + (setq tagsmatcher t) + (setq orterms (org-split-string tagsmatch "|") orlist nil) + (while (setq term (pop orterms)) + (while (and (equal (substring term -1) "\\") orterms) + (setq term (concat term "|" (pop orterms)))) ; repair bad split + (while (string-match re term) + (setq rest (substring term (match-end 0)) + minus (and (match-end 1) + (equal (match-string 1 term) "-")) + tag (save-match-data (replace-regexp-in-string + "\\\\-" "-" + (match-string 2 term))) + re-p (equal (string-to-char tag) ?{) + level-p (match-end 4) + prop-p (match-end 5) + mm (cond + (re-p `(org-match-any-p ,(substring tag 1 -1) tags-list)) + (level-p + (setq level-op (org-op-to-function (match-string 3 term))) + `(,level-op level ,(string-to-number + (match-string 4 term)))) + (prop-p + (setq pn (match-string 5 term) + po (match-string 6 term) + pv (match-string 7 term) + re-p (equal (string-to-char pv) ?{) + str-p (equal (string-to-char pv) ?\") + time-p (save-match-data + (string-match "^\"[[<].*[]>]\"$" pv)) + pv (if (or re-p str-p) (substring pv 1 -1) pv)) + (if time-p (setq pv (org-matcher-time pv))) + (setq po (org-op-to-function po (if time-p 'time str-p))) + (cond + ((equal pn "CATEGORY") + (setq gv '(get-text-property (point) 'org-category))) + ((equal pn "TODO") + (setq gv 'todo)) + (t + (setq gv `(org-cached-entry-get nil ,pn)))) + (if re-p + (if (eq po 'org<>) + `(not (string-match ,pv (or ,gv ""))) + `(string-match ,pv (or ,gv ""))) + (if str-p + `(,po (or ,gv "") ,pv) + `(,po (string-to-number (or ,gv "")) + ,(string-to-number pv) )))) + (t `(member ,tag tags-list))) + mm (if minus (list 'not mm) mm) + term rest) + (push mm tagsmatcher)) + (push (if (> (length tagsmatcher) 1) + (cons 'and tagsmatcher) + (car tagsmatcher)) + orlist) + (setq tagsmatcher nil)) + (setq tagsmatcher (if (> (length orlist) 1) (cons 'or orlist) (car orlist))) + (setq tagsmatcher + (list 'progn '(setq org-cached-props nil) tagsmatcher))) + ;; Make the todo matcher + (if (or (not todomatch) (not (string-match "\\S-" todomatch))) + (setq todomatcher t) + (setq orterms (org-split-string todomatch "|") orlist nil) + (while (setq term (pop orterms)) + (while (string-match re term) + (setq minus (and (match-end 1) + (equal (match-string 1 term) "-")) + kwd (match-string 2 term) + re-p (equal (string-to-char kwd) ?{) + term (substring term (match-end 0)) + mm (if re-p + `(string-match ,(substring kwd 1 -1) todo) + (list 'equal 'todo kwd)) + mm (if minus (list 'not mm) mm)) + (push mm todomatcher)) + (push (if (> (length todomatcher) 1) + (cons 'and todomatcher) + (car todomatcher)) + orlist) + (setq todomatcher nil)) + (setq todomatcher (if (> (length orlist) 1) + (cons 'or orlist) (car orlist)))) + + ;; Return the string and lisp forms of the matcher + (setq matcher (if todomatcher + (list 'and tagsmatcher todomatcher) + tagsmatcher)) + (cons match0 matcher))) + +(defun org-op-to-function (op &optional stringp) + "Turn an operator into the appropriate function." + (setq op + (cond + ((equal op "<" ) '(< string< org-time<)) + ((equal op ">" ) '(> org-string> org-time>)) + ((member op '("<=" "=<")) '(<= org-string<= org-time<=)) + ((member op '(">=" "=>")) '(>= org-string>= org-time>=)) + ((member op '("=" "==")) '(= string= org-time=)) + ((member op '("<>" "!=")) '(org<> org-string<> org-time<>)))) + (nth (if (eq stringp 'time) 2 (if stringp 1 0)) op)) + +(defun org<> (a b) (not (= a b))) +(defun org-string<= (a b) (or (string= a b) (string< a b))) +(defun org-string>= (a b) (not (string< a b))) +(defun org-string> (a b) (and (not (string= a b)) (not (string< a b)))) +(defun org-string<> (a b) (not (string= a b))) +(defun org-time= (a b) (setq a (org-2ft a) b (org-2ft b)) (and (> a 0) (> b 0) (= a b))) +(defun org-time< (a b) (setq a (org-2ft a) b (org-2ft b)) (and (> a 0) (> b 0) (< a b))) +(defun org-time<= (a b) (setq a (org-2ft a) b (org-2ft b)) (and (> a 0) (> b 0) (<= a b))) +(defun org-time> (a b) (setq a (org-2ft a) b (org-2ft b)) (and (> a 0) (> b 0) (> a b))) +(defun org-time>= (a b) (setq a (org-2ft a) b (org-2ft b)) (and (> a 0) (> b 0) (>= a b))) +(defun org-time<> (a b) (setq a (org-2ft a) b (org-2ft b)) (and (> a 0) (> b 0) (org<> a b))) +(defun org-2ft (s) + "Convert S to a floating point time. +If S is already a number, just return it. If it is a string, parse +it as a time string and apply `float-time' to it. If S is nil, just return 0." + (cond + ((numberp s) s) + ((stringp s) + (condition-case nil + (float-time (apply 'encode-time (org-parse-time-string s))) + (error 0.))) + (t 0.))) + +(defun org-time-today () + "Time in seconds today at 0:00. +Returns the float number of seconds since the beginning of the +epoch to the beginning of today (00:00)." + (float-time (apply 'encode-time + (append '(0 0 0) (nthcdr 3 (decode-time)))))) + +(defun org-matcher-time (s) + "Interpret a time comparison value." + (save-match-data + (cond + ((string= s "<now>") (float-time)) + ((string= s "<today>") (org-time-today)) + ((string= s "<tomorrow>") (+ 86400.0 (org-time-today))) + ((string= s "<yesterday>") (- (org-time-today) 86400.0)) + ((string-match "^<\\([-+][0-9]+\\)\\([dwmy]\\)>$" s) + (+ (org-time-today) + (* (string-to-number (match-string 1 s)) + (cdr (assoc (match-string 2 s) + '(("d" . 86400.0) ("w" . 604800.0) + ("m" . 2678400.0) ("y" . 31557600.0))))))) + (t (org-2ft s))))) + +(defun org-match-any-p (re list) + "Does re match any element of list?" + (setq list (mapcar (lambda (x) (string-match re x)) list)) + (delq nil list)) + +(defvar org-add-colon-after-tag-completion nil) ;; dynamically scoped param +(defvar org-tags-overlay (make-overlay 1 1)) +(org-detach-overlay org-tags-overlay) + +(defun org-get-local-tags-at (&optional pos) + "Get a list of tags defined in the current headline." + (org-get-tags-at pos 'local)) + +(defun org-get-local-tags () + "Get a list of tags defined in the current headline." + (org-get-tags-at nil 'local)) + +(defun org-get-tags-at (&optional pos local) + "Get a list of all headline tags applicable at POS. +POS defaults to point. If tags are inherited, the list contains +the targets in the same sequence as the headlines appear, i.e. +the tags of the current headline come last. +When LOCAL is non-nil, only return tags from the current headline, +ignore inherited ones." + (interactive) + (if (and org-trust-scanner-tags + (or (not pos) (equal pos (point))) + (not local)) + org-scanner-tags + (let (tags ltags lastpos parent) + (save-excursion + (save-restriction + (widen) + (goto-char (or pos (point))) + (save-match-data + (catch 'done + (condition-case nil + (progn + (org-back-to-heading t) + (while (not (equal lastpos (point))) + (setq lastpos (point)) + (when (looking-at + (org-re "[^\r\n]+?:\\([[:alnum:]_@#%:]+\\):[ \t]*$")) + (setq ltags (org-split-string + (org-match-string-no-properties 1) ":")) + (when parent + (setq ltags (mapcar 'org-add-prop-inherited ltags))) + (setq tags (append + (if parent + (org-remove-uniherited-tags ltags) + ltags) + tags))) + (or org-use-tag-inheritance (throw 'done t)) + (if local (throw 'done t)) + (or (org-up-heading-safe) (error nil)) + (setq parent t))) + (error nil))))) + (append (org-remove-uniherited-tags org-file-tags) tags))))) + +(defun org-add-prop-inherited (s) + (add-text-properties 0 (length s) '(inherited t) s) + s) + +(defun org-toggle-tag (tag &optional onoff) + "Toggle the tag TAG for the current line. +If ONOFF is `on' or `off', don't toggle but set to this state." + (let (res current) + (save-excursion + (org-back-to-heading t) + (if (re-search-forward (org-re "[ \t]:\\([[:alnum:]_@#%:]+\\):[ \t]*$") + (point-at-eol) t) + (progn + (setq current (match-string 1)) + (replace-match "")) + (setq current "")) + (setq current (nreverse (org-split-string current ":"))) + (cond + ((eq onoff 'on) + (setq res t) + (or (member tag current) (push tag current))) + ((eq onoff 'off) + (or (not (member tag current)) (setq current (delete tag current)))) + (t (if (member tag current) + (setq current (delete tag current)) + (setq res t) + (push tag current)))) + (end-of-line 1) + (if current + (progn + (insert " :" (mapconcat 'identity (nreverse current) ":") ":") + (org-set-tags nil t)) + (delete-horizontal-space)) + (run-hooks 'org-after-tags-change-hook)) + res)) + +(defun org-align-tags-here (to-col) + ;; Assumes that this is a headline + (let ((pos (point)) (col (current-column)) ncol tags-l p) + (beginning-of-line 1) + (if (and (looking-at (org-re ".*?\\([ \t]+\\)\\(:[[:alnum:]_@#%:]+:\\)[ \t]*$")) + (< pos (match-beginning 2))) + (progn + (setq tags-l (- (match-end 2) (match-beginning 2))) + (goto-char (match-beginning 1)) + (insert " ") + (delete-region (point) (1+ (match-beginning 2))) + (setq ncol (max (1+ (current-column)) + (1+ col) + (if (> to-col 0) + to-col + (- (abs to-col) tags-l)))) + (setq p (point)) + (insert (make-string (- ncol (current-column)) ?\ )) + (setq ncol (current-column)) + (when indent-tabs-mode (tabify p (point-at-eol))) + (org-move-to-column (min ncol col) t)) + (goto-char pos)))) + +(defun org-set-tags-command (&optional arg just-align) + "Call the set-tags command for the current entry." + (interactive "P") + (if (org-on-heading-p) + (org-set-tags arg just-align) + (save-excursion + (org-back-to-heading t) + (org-set-tags arg just-align)))) + +(defun org-set-tags-to (data) + "Set the tags of the current entry to DATA, replacing the current tags. +DATA may be a tags string like :aa:bb:cc:, or a list of tags. +If DATA is nil or the empty string, any tags will be removed." + (interactive "sTags: ") + (setq data + (cond + ((eq data nil) "") + ((equal data "") "") + ((stringp data) + (concat ":" (mapconcat 'identity (org-split-string data ":+") ":") + ":")) + ((listp data) + (concat ":" (mapconcat 'identity data ":") ":")) + (t nil))) + (when data + (save-excursion + (org-back-to-heading t) + (when (looking-at org-complex-heading-regexp) + (if (match-end 5) + (progn + (goto-char (match-beginning 5)) + (insert data) + (delete-region (point) (point-at-eol)) + (org-set-tags nil 'align)) + (goto-char (point-at-eol)) + (insert " " data) + (org-set-tags nil 'align))) + (beginning-of-line 1) + (if (looking-at ".*?\\([ \t]+\\)$") + (delete-region (match-beginning 1) (match-end 1)))))) + +(defun org-align-all-tags () + "Align the tags i all headings." + (interactive) + (save-excursion + (or (ignore-errors (org-back-to-heading t)) + (outline-next-heading)) + (if (org-on-heading-p) + (org-set-tags t) + (message "No headings")))) + +(defvar org-indent-indentation-per-level) +(defun org-set-tags (&optional arg just-align) + "Set the tags for the current headline. +With prefix ARG, realign all tags in headings in the current buffer." + (interactive "P") + (let* ((re (concat "^" outline-regexp)) + (current (org-get-tags-string)) + (col (current-column)) + (org-setting-tags t) + table current-tags inherited-tags ; computed below when needed + tags p0 c0 c1 rpl di tc level) + (if arg + (save-excursion + (goto-char (point-min)) + (let ((buffer-invisibility-spec (org-inhibit-invisibility))) + (while (re-search-forward re nil t) + (org-set-tags nil t) + (end-of-line 1))) + (message "All tags realigned to column %d" org-tags-column)) + (if just-align + (setq tags current) + ;; Get a new set of tags from the user + (save-excursion + (setq table (append org-tag-persistent-alist + (or org-tag-alist (org-get-buffer-tags)) + (and + org-complete-tags-always-offer-all-agenda-tags + (org-global-tags-completion-table + (org-agenda-files)))) + org-last-tags-completion-table table + current-tags (org-split-string current ":") + inherited-tags (nreverse + (nthcdr (length current-tags) + (nreverse (org-get-tags-at)))) + tags + (if (or (eq t org-use-fast-tag-selection) + (and org-use-fast-tag-selection + (delq nil (mapcar 'cdr table)))) + (org-fast-tag-selection + current-tags inherited-tags table + (if org-fast-tag-selection-include-todo + org-todo-key-alist)) + (let ((org-add-colon-after-tag-completion t)) + (org-trim + (org-without-partial-completion + (org-icompleting-read "Tags: " + 'org-tags-completion-function + nil nil current 'org-tags-history))))))) + (while (string-match "[-+&]+" tags) + ;; No boolean logic, just a list + (setq tags (replace-match ":" t t tags)))) + + (setq tags (replace-regexp-in-string "[ ,]" ":" tags)) + + (if org-tags-sort-function + (setq tags (mapconcat 'identity + (sort (org-split-string + tags (org-re "[^[:alnum:]_@#%]+")) + org-tags-sort-function) ":"))) + + (if (string-match "\\`[\t ]*\\'" tags) + (setq tags "") + (unless (string-match ":$" tags) (setq tags (concat tags ":"))) + (unless (string-match "^:" tags) (setq tags (concat ":" tags)))) + + ;; Insert new tags at the correct column + (beginning-of-line 1) + (setq level (or (and (looking-at org-outline-regexp) + (- (match-end 0) (point) 1)) + 1)) + (cond + ((and (equal current "") (equal tags ""))) + ((re-search-forward + (concat "\\([ \t]*" (regexp-quote current) "\\)[ \t]*$") + (point-at-eol) t) + (if (equal tags "") + (setq rpl "") + (goto-char (match-beginning 0)) + (setq c0 (current-column) + ;; compute offset for the case of org-indent-mode active + di (if org-indent-mode + (* (1- org-indent-indentation-per-level) (1- level)) + 0) + p0 (if (equal (char-before) ?*) (1+ (point)) (point)) + tc (+ org-tags-column (if (> org-tags-column 0) (- di) di)) + c1 (max (1+ c0) (if (> tc 0) tc (- (- tc) (length tags)))) + rpl (concat (make-string (max 0 (- c1 c0)) ?\ ) tags))) + (replace-match rpl t t) + (and (not (featurep 'xemacs)) c0 indent-tabs-mode (tabify p0 (point))) + tags) + (t (error "Tags alignment failed"))) + (org-move-to-column col) + (unless just-align + (run-hooks 'org-after-tags-change-hook))))) + +(defun org-change-tag-in-region (beg end tag off) + "Add or remove TAG for each entry in the region. +This works in the agenda, and also in an org-mode buffer." + (interactive + (list (region-beginning) (region-end) + (let ((org-last-tags-completion-table + (if (org-mode-p) + (org-get-buffer-tags) + (org-global-tags-completion-table)))) + (org-icompleting-read + "Tag: " 'org-tags-completion-function nil nil nil + 'org-tags-history)) + (progn + (message "[s]et or [r]emove? ") + (equal (read-char-exclusive) ?r)))) + (if (fboundp 'deactivate-mark) (deactivate-mark)) + (let ((agendap (equal major-mode 'org-agenda-mode)) + l1 l2 m buf pos newhead (cnt 0)) + (goto-char end) + (setq l2 (1- (org-current-line))) + (goto-char beg) + (setq l1 (org-current-line)) + (loop for l from l1 to l2 do + (org-goto-line l) + (setq m (get-text-property (point) 'org-hd-marker)) + (when (or (and (org-mode-p) (org-on-heading-p)) + (and agendap m)) + (setq buf (if agendap (marker-buffer m) (current-buffer)) + pos (if agendap m (point))) + (with-current-buffer buf + (save-excursion + (save-restriction + (goto-char pos) + (setq cnt (1+ cnt)) + (org-toggle-tag tag (if off 'off 'on)) + (setq newhead (org-get-heading))))) + (and agendap (org-agenda-change-all-lines newhead m)))) + (message "Tag :%s: %s in %d headings" tag (if off "removed" "set") cnt))) + +(defun org-tags-completion-function (string predicate &optional flag) + (let (s1 s2 rtn (ctable org-last-tags-completion-table) + (confirm (lambda (x) (stringp (car x))))) + (if (string-match "^\\(.*[-+:&,|]\\)\\([^-+:&,|]*\\)$" string) + (setq s1 (match-string 1 string) + s2 (match-string 2 string)) + (setq s1 "" s2 string)) + (cond + ((eq flag nil) + ;; try completion + (setq rtn (try-completion s2 ctable confirm)) + (if (stringp rtn) + (setq rtn + (concat s1 s2 (substring rtn (length s2)) + (if (and org-add-colon-after-tag-completion + (assoc rtn ctable)) + ":" "")))) + rtn) + ((eq flag t) + ;; all-completions + (all-completions s2 ctable confirm) + ) + ((eq flag 'lambda) + ;; exact match? + (assoc s2 ctable))) + )) + +(defun org-fast-tag-insert (kwd tags face &optional end) + "Insert KDW, and the TAGS, the latter with face FACE. Also insert END." + (insert (format "%-12s" (concat kwd ":")) + (org-add-props (mapconcat 'identity tags " ") nil 'face face) + (or end ""))) + +(defun org-fast-tag-show-exit (flag) + (save-excursion + (org-goto-line 3) + (if (re-search-forward "[ \t]+Next change exits" (point-at-eol) t) + (replace-match "")) + (when flag + (end-of-line 1) + (org-move-to-column (- (window-width) 19) t) + (insert (org-add-props " Next change exits" nil 'face 'org-warning))))) + +(defun org-set-current-tags-overlay (current prefix) + (let ((s (concat ":" (mapconcat 'identity current ":") ":"))) + (if (featurep 'xemacs) + (org-overlay-display org-tags-overlay (concat prefix s) + 'secondary-selection) + (put-text-property 0 (length s) 'face '(secondary-selection org-tag) s) + (org-overlay-display org-tags-overlay (concat prefix s))))) + +(defvar org-last-tag-selection-key nil) +(defun org-fast-tag-selection (current inherited table &optional todo-table) + "Fast tag selection with single keys. +CURRENT is the current list of tags in the headline, INHERITED is the +list of inherited tags, and TABLE is an alist of tags and corresponding keys, +possibly with grouping information. TODO-TABLE is a similar table with +TODO keywords, should these have keys assigned to them. +If the keys are nil, a-z are automatically assigned. +Returns the new tags string, or nil to not change the current settings." + (let* ((fulltable (append table todo-table)) + (maxlen (apply 'max (mapcar + (lambda (x) + (if (stringp (car x)) (string-width (car x)) 0)) + fulltable))) + (buf (current-buffer)) + (expert (eq org-fast-tag-selection-single-key 'expert)) + (buffer-tags nil) + (fwidth (+ maxlen 3 1 3)) + (ncol (/ (- (window-width) 4) fwidth)) + (i-face 'org-done) + (c-face 'org-todo) + tg cnt e c char c1 c2 ntable tbl rtn + ov-start ov-end ov-prefix + (exit-after-next org-fast-tag-selection-single-key) + (done-keywords org-done-keywords) + groups ingroup) + (save-excursion + (beginning-of-line 1) + (if (looking-at + (org-re ".*[ \t]\\(:[[:alnum:]_@#%:]+:\\)[ \t]*$")) + (setq ov-start (match-beginning 1) + ov-end (match-end 1) + ov-prefix "") + (setq ov-start (1- (point-at-eol)) + ov-end (1+ ov-start)) + (skip-chars-forward "^\n\r") + (setq ov-prefix + (concat + (buffer-substring (1- (point)) (point)) + (if (> (current-column) org-tags-column) + " " + (make-string (- org-tags-column (current-column)) ?\ )))))) + (move-overlay org-tags-overlay ov-start ov-end) + (save-window-excursion + (if expert + (set-buffer (get-buffer-create " *Org tags*")) + (delete-other-windows) + (split-window-vertically) + (org-switch-to-buffer-other-window (get-buffer-create " *Org tags*"))) + (erase-buffer) + (org-set-local 'org-done-keywords done-keywords) + (org-fast-tag-insert "Inherited" inherited i-face "\n") + (org-fast-tag-insert "Current" current c-face "\n\n") + (org-fast-tag-show-exit exit-after-next) + (org-set-current-tags-overlay current ov-prefix) + (setq tbl fulltable char ?a cnt 0) + (while (setq e (pop tbl)) + (cond + ((equal (car e) :startgroup) + (push '() groups) (setq ingroup t) + (when (not (= cnt 0)) + (setq cnt 0) + (insert "\n")) + (insert (if (cdr e) (format "%s: " (cdr e)) "") "{ ")) + ((equal (car e) :endgroup) + (setq ingroup nil cnt 0) + (insert "}" (if (cdr e) (format " (%s) " (cdr e)) "") "\n")) + ((equal e '(:newline)) + (when (not (= cnt 0)) + (setq cnt 0) + (insert "\n") + (setq e (car tbl)) + (while (equal (car tbl) '(:newline)) + (insert "\n") + (setq tbl (cdr tbl))))) + (t + (setq tg (copy-sequence (car e)) c2 nil) + (if (cdr e) + (setq c (cdr e)) + ;; automatically assign a character. + (setq c1 (string-to-char + (downcase (substring + tg (if (= (string-to-char tg) ?@) 1 0))))) + (if (or (rassoc c1 ntable) (rassoc c1 table)) + (while (or (rassoc char ntable) (rassoc char table)) + (setq char (1+ char))) + (setq c2 c1)) + (setq c (or c2 char))) + (if ingroup (push tg (car groups))) + (setq tg (org-add-props tg nil 'face + (cond + ((not (assoc tg table)) + (org-get-todo-face tg)) + ((member tg current) c-face) + ((member tg inherited) i-face) + (t nil)))) + (if (and (= cnt 0) (not ingroup)) (insert " ")) + (insert "[" c "] " tg (make-string + (- fwidth 4 (length tg)) ?\ )) + (push (cons tg c) ntable) + (when (= (setq cnt (1+ cnt)) ncol) + (insert "\n") + (if ingroup (insert " ")) + (setq cnt 0))))) + (setq ntable (nreverse ntable)) + (insert "\n") + (goto-char (point-min)) + (if (not expert) (org-fit-window-to-buffer)) + (setq rtn + (catch 'exit + (while t + (message "[a-z..]:Toggle [SPC]:clear [RET]:accept [TAB]:free [!] %sgroups%s" + (if (not groups) "no " "") + (if expert " [C-c]:window" (if exit-after-next " [C-c]:single" " [C-c]:multi"))) + (setq c (let ((inhibit-quit t)) (read-char-exclusive))) + (setq org-last-tag-selection-key c) + (cond + ((= c ?\r) (throw 'exit t)) + ((= c ?!) + (setq groups (not groups)) + (goto-char (point-min)) + (while (re-search-forward "[{}]" nil t) (replace-match " "))) + ((= c ?\C-c) + (if (not expert) + (org-fast-tag-show-exit + (setq exit-after-next (not exit-after-next))) + (setq expert nil) + (delete-other-windows) + (split-window-vertically) + (org-switch-to-buffer-other-window " *Org tags*") + (org-fit-window-to-buffer))) + ((or (= c ?\C-g) + (and (= c ?q) (not (rassoc c ntable)))) + (org-detach-overlay org-tags-overlay) + (setq quit-flag t)) + ((= c ?\ ) + (setq current nil) + (if exit-after-next (setq exit-after-next 'now))) + ((= c ?\t) + (condition-case nil + (setq tg (org-icompleting-read + "Tag: " + (or buffer-tags + (with-current-buffer buf + (org-get-buffer-tags))))) + (quit (setq tg ""))) + (when (string-match "\\S-" tg) + (add-to-list 'buffer-tags (list tg)) + (if (member tg current) + (setq current (delete tg current)) + (push tg current))) + (if exit-after-next (setq exit-after-next 'now))) + ((setq e (rassoc c todo-table) tg (car e)) + (with-current-buffer buf + (save-excursion (org-todo tg))) + (if exit-after-next (setq exit-after-next 'now))) + ((setq e (rassoc c ntable) tg (car e)) + (if (member tg current) + (setq current (delete tg current)) + (loop for g in groups do + (if (member tg g) + (mapc (lambda (x) + (setq current (delete x current))) + g))) + (push tg current)) + (if exit-after-next (setq exit-after-next 'now)))) + + ;; Create a sorted list + (setq current + (sort current + (lambda (a b) + (assoc b (cdr (memq (assoc a ntable) ntable)))))) + (if (eq exit-after-next 'now) (throw 'exit t)) + (goto-char (point-min)) + (beginning-of-line 2) + (delete-region (point) (point-at-eol)) + (org-fast-tag-insert "Current" current c-face) + (org-set-current-tags-overlay current ov-prefix) + (while (re-search-forward + (org-re "\\[.\\] \\([[:alnum:]_@#%]+\\)") nil t) + (setq tg (match-string 1)) + (add-text-properties + (match-beginning 1) (match-end 1) + (list 'face + (cond + ((member tg current) c-face) + ((member tg inherited) i-face) + (t (get-text-property (match-beginning 1) 'face)))))) + (goto-char (point-min))))) + (org-detach-overlay org-tags-overlay) + (if rtn + (mapconcat 'identity current ":") + nil)))) + +(defun org-get-tags-string () + "Get the TAGS string in the current headline." + (unless (org-on-heading-p t) + (error "Not on a heading")) + (save-excursion + (beginning-of-line 1) + (if (looking-at (org-re ".*[ \t]\\(:[[:alnum:]_@#%:]+:\\)[ \t]*$")) + (org-match-string-no-properties 1) + ""))) + +(defun org-get-tags () + "Get the list of tags specified in the current headline." + (org-split-string (org-get-tags-string) ":")) + +(defun org-get-buffer-tags () + "Get a table of all tags used in the buffer, for completion." + (let (tags) + (save-excursion + (goto-char (point-min)) + (while (re-search-forward + (org-re "[ \t]:\\([[:alnum:]_@#%:]+\\):[ \t\r\n]") nil t) + (when (equal (char-after (point-at-bol 0)) ?*) + (mapc (lambda (x) (add-to-list 'tags x)) + (org-split-string (org-match-string-no-properties 1) ":"))))) + (mapc (lambda (s) (add-to-list 'tags s)) org-file-tags) + (mapcar 'list tags))) + +;;;; The mapping API + +;;;###autoload +(defun org-map-entries (func &optional match scope &rest skip) + "Call FUNC at each headline selected by MATCH in SCOPE. + +FUNC is a function or a lisp form. The function will be called without +arguments, with the cursor positioned at the beginning of the headline. +The return values of all calls to the function will be collected and +returned as a list. + +The call to FUNC will be wrapped into a save-excursion form, so FUNC +does not need to preserve point. After evaluation, the cursor will be +moved to the end of the line (presumably of the headline of the +processed entry) and search continues from there. Under some +circumstances, this may not produce the wanted results. For example, +if you have removed (e.g. archived) the current (sub)tree it could +mean that the next entry will be skipped entirely. In such cases, you +can specify the position from where search should continue by making +FUNC set the variable `org-map-continue-from' to the desired buffer +position. + +MATCH is a tags/property/todo match as it is used in the agenda tags view. +Only headlines that are matched by this query will be considered during +the iteration. When MATCH is nil or t, all headlines will be +visited by the iteration. + +SCOPE determines the scope of this command. It can be any of: + +nil The current buffer, respecting the restriction if any +tree The subtree started with the entry at point +file The current buffer, without restriction +file-with-archives + The current buffer, and any archives associated with it +agenda All agenda files +agenda-with-archives + All agenda files with any archive files associated with them +\(file1 file2 ...) + If this is a list, all files in the list will be scanned + +The remaining args are treated as settings for the skipping facilities of +the scanner. The following items can be given here: + + archive skip trees with the archive tag. + comment skip trees with the COMMENT keyword + function or Emacs Lisp form: + will be used as value for `org-agenda-skip-function', so whenever + the function returns t, FUNC will not be called for that + entry and search will continue from the point where the + function leaves it. + +If your function needs to retrieve the tags including inherited tags +at the *current* entry, you can use the value of the variable +`org-scanner-tags' which will be much faster than getting the value +with `org-get-tags-at'. If your function gets properties with +`org-entry-properties' at the *current* entry, bind `org-trust-scanner-tags' +to t around the call to `org-entry-properties' to get the same speedup. +Note that if your function moves around to retrieve tags and properties at +a *different* entry, you cannot use these techniques." + (let* ((org-agenda-archives-mode nil) ; just to make sure + (org-agenda-skip-archived-trees (memq 'archive skip)) + (org-agenda-skip-comment-trees (memq 'comment skip)) + (org-agenda-skip-function + (car (org-delete-all '(comment archive) skip))) + (org-tags-match-list-sublevels t) + matcher file res + org-todo-keywords-for-agenda + org-done-keywords-for-agenda + org-todo-keyword-alist-for-agenda + org-drawers-for-agenda + org-tag-alist-for-agenda) + + (cond + ((eq match t) (setq matcher t)) + ((eq match nil) (setq matcher t)) + (t (setq matcher (if match (cdr (org-make-tags-matcher match)) t)))) + + (save-excursion + (save-restriction + (when (eq scope 'tree) + (org-back-to-heading t) + (org-narrow-to-subtree) + (setq scope nil)) + + (if (not scope) + (progn + (org-prepare-agenda-buffers + (list (buffer-file-name (current-buffer)))) + (setq res (org-scan-tags func matcher))) + ;; Get the right scope + (cond + ((and scope (listp scope) (symbolp (car scope))) + (setq scope (eval scope))) + ((eq scope 'agenda) + (setq scope (org-agenda-files t))) + ((eq scope 'agenda-with-archives) + (setq scope (org-agenda-files t)) + (setq scope (org-add-archive-files scope))) + ((eq scope 'file) + (setq scope (list (buffer-file-name)))) + ((eq scope 'file-with-archives) + (setq scope (org-add-archive-files (list (buffer-file-name)))))) + (org-prepare-agenda-buffers scope) + (while (setq file (pop scope)) + (with-current-buffer (org-find-base-buffer-visiting file) + (save-excursion + (save-restriction + (widen) + (goto-char (point-min)) + (setq res (append res (org-scan-tags func matcher)))))))))) + res)) + +;;;; Properties + +;;; Setting and retrieving properties + +(defconst org-special-properties + '("TODO" "TAGS" "ALLTAGS" "DEADLINE" "SCHEDULED" "CLOCK" "CLOSED" "PRIORITY" + "TIMESTAMP" "TIMESTAMP_IA" "BLOCKED") + "The special properties valid in Org-mode. + +These are properties that are not defined in the property drawer, +but in some other way.") + +(defconst org-default-properties + '("ARCHIVE" "CATEGORY" "SUMMARY" "DESCRIPTION" "CUSTOM_ID" + "LOCATION" "LOGGING" "COLUMNS" "VISIBILITY" + "TABLE_EXPORT_FORMAT" "TABLE_EXPORT_FILE" + "EXPORT_FILE_NAME" "EXPORT_TITLE" "EXPORT_AUTHOR" "EXPORT_DATE" + "ORDERED" "NOBLOCKING" "COOKIE_DATA" "LOG_INTO_DRAWER" "REPEAT_TO_STATE" + "CLOCK_MODELINE_TOTAL" "STYLE" "HTML_CONTAINER_CLASS") + "Some properties that are used by Org-mode for various purposes. +Being in this list makes sure that they are offered for completion.") + +(defconst org-property-start-re "^[ \t]*:PROPERTIES:[ \t]*$" + "Regular expression matching the first line of a property drawer.") + +(defconst org-property-end-re "^[ \t]*:END:[ \t]*$" + "Regular expression matching the last line of a property drawer.") + +(defconst org-clock-drawer-start-re "^[ \t]*:CLOCK:[ \t]*$" + "Regular expression matching the first line of a property drawer.") + +(defconst org-clock-drawer-end-re "^[ \t]*:END:[ \t]*$" + "Regular expression matching the first line of a property drawer.") + +(defconst org-property-drawer-re + (concat "\\(" org-property-start-re "\\)[^\000]*\\(" + org-property-end-re "\\)\n?") + "Matches an entire property drawer.") + +(defconst org-clock-drawer-re + (concat "\\(" org-clock-drawer-start-re "\\)[^\000]*\\(" + org-property-end-re "\\)\n?") + "Matches an entire clock drawer.") + +(defun org-property-action () + "Do an action on properties." + (interactive) + (let (c) + (org-at-property-p) + (message "Property Action: [s]et [d]elete [D]elete globally [c]ompute") + (setq c (read-char-exclusive)) + (cond + ((equal c ?s) + (call-interactively 'org-set-property)) + ((equal c ?d) + (call-interactively 'org-delete-property)) + ((equal c ?D) + (call-interactively 'org-delete-property-globally)) + ((equal c ?c) + (call-interactively 'org-compute-property-at-point)) + (t (error "No such property action %c" c))))) + +(defun org-set-effort (&optional value) + "Set the effort property of the current entry. +With numerical prefix arg, use the nth allowed value, 0 stands for the 10th +allowed value." + (interactive "P") + (if (equal value 0) (setq value 10)) + (let* ((completion-ignore-case t) + (prop org-effort-property) + (cur (org-entry-get nil prop)) + (allowed (org-property-get-allowed-values nil prop 'table)) + (existing (mapcar 'list (org-property-values prop))) + rpl + (val (cond + ((stringp value) value) + ((and allowed (integerp value)) + (or (car (nth (1- value) allowed)) + (car (org-last allowed)))) + (allowed + (message "Select 1-9,0, [RET%s]: %s" + (if cur (concat "=" cur) "") + (mapconcat 'car allowed " ")) + (setq rpl (read-char-exclusive)) + (if (equal rpl ?\r) + cur + (setq rpl (- rpl ?0)) + (if (equal rpl 0) (setq rpl 10)) + (if (and (> rpl 0) (<= rpl (length allowed))) + (car (nth (1- rpl) allowed)) + (org-completing-read "Effort: " allowed nil)))) + (t + (let (org-completion-use-ido org-completion-use-iswitchb) + (org-completing-read + (concat "Effort " (if (and cur (string-match "\\S-" cur)) + (concat "[" cur "]") "") + ": ") + existing nil nil "" nil cur)))))) + (unless (equal (org-entry-get nil prop) val) + (org-entry-put nil prop val)) + (message "%s is now %s" prop val))) + +(defun org-at-property-p () + "Is cursor inside a property drawer?" + (save-excursion + (beginning-of-line 1) + (when (looking-at (org-re "^[ \t]*\\(:\\([[:alpha:]][[:alnum:]_-]*\\):\\)[ \t]*\\(.*\\)")) + (save-match-data ;; Used by calling procedures + (let ((p (point)) + (range (unless (org-before-first-heading-p) + (org-get-property-block)))) + (and range (<= (car range) p) (< p (cdr range)))))))) + +(defun org-get-property-block (&optional beg end force) + "Return the (beg . end) range of the body of the property drawer. +BEG and END can be beginning and end of subtree, if not given +they will be found. +If the drawer does not exist and FORCE is non-nil, create the drawer." + (catch 'exit + (save-excursion + (let* ((beg (or beg (progn (org-back-to-heading t) (point)))) + (end (or end (progn (outline-next-heading) (point))))) + (goto-char beg) + (if (re-search-forward org-property-start-re end t) + (setq beg (1+ (match-end 0))) + (if force + (save-excursion + (org-insert-property-drawer) + (setq end (progn (outline-next-heading) (point)))) + (throw 'exit nil)) + (goto-char beg) + (if (re-search-forward org-property-start-re end t) + (setq beg (1+ (match-end 0))))) + (if (re-search-forward org-property-end-re end t) + (setq end (match-beginning 0)) + (or force (throw 'exit nil)) + (goto-char beg) + (setq end beg) + (org-indent-line-function) + (insert ":END:\n")) + (cons beg end))))) + +(defun org-entry-properties (&optional pom which specific) + "Get all properties of the entry at point-or-marker POM. +This includes the TODO keyword, the tags, time strings for deadline, +scheduled, and clocking, and any additional properties defined in the +entry. The return value is an alist, keys may occur multiple times +if the property key was used several times. +POM may also be nil, in which case the current entry is used. +If WHICH is nil or `all', get all properties. If WHICH is +`special' or `standard', only get that subclass. If WHICH +is a string only get exactly this property. SPECIFIC can be a string, the +specific property we are interested in. Specifying it can speed +things up because then unnecessary parsing is avoided." + (setq which (or which 'all)) + (org-with-point-at pom + (let ((clockstr (substring org-clock-string 0 -1)) + (excluded '("TODO" "TAGS" "ALLTAGS" "PRIORITY" "BLOCKED")) + (case-fold-search nil) + beg end range props sum-props key key1 value string clocksum) + (save-excursion + (when (condition-case nil + (and (org-mode-p) (org-back-to-heading t)) + (error nil)) + (setq beg (point)) + (setq sum-props (get-text-property (point) 'org-summaries)) + (setq clocksum (get-text-property (point) :org-clock-minutes)) + (outline-next-heading) + (setq end (point)) + (when (memq which '(all special)) + ;; Get the special properties, like TODO and tags + (goto-char beg) + (when (and (or (not specific) (string= specific "TODO")) + (looking-at org-todo-line-regexp) (match-end 2)) + (push (cons "TODO" (org-match-string-no-properties 2)) props)) + (when (and (or (not specific) (string= specific "PRIORITY")) + (looking-at org-priority-regexp)) + (push (cons "PRIORITY" (org-match-string-no-properties 2)) props)) + (when (and (or (not specific) (string= specific "TAGS")) + (setq value (org-get-tags-string)) + (string-match "\\S-" value)) + (push (cons "TAGS" value) props)) + (when (and (or (not specific) (string= specific "ALLTAGS")) + (setq value (org-get-tags-at))) + (push (cons "ALLTAGS" (concat ":" (mapconcat 'identity value ":") + ":")) + props)) + (when (or (not specific) (string= specific "BLOCKED")) + (push (cons "BLOCKED" (if (org-entry-blocked-p) "t" "")) props)) + (when (or (not specific) + (member specific + '("SCHEDULED" "DEADLINE" "CLOCK" "CLOSED" + "TIMESTAMP" "TIMESTAMP_IA"))) + (while (re-search-forward org-maybe-keyword-time-regexp end t) + (setq key (if (match-end 1) + (substring (org-match-string-no-properties 1) + 0 -1)) + string (if (equal key clockstr) + (org-no-properties + (org-trim + (buffer-substring + (match-beginning 3) (goto-char + (point-at-eol))))) + (substring (org-match-string-no-properties 3) + 1 -1))) + ;; Get the correct property name from the key. This is + ;; necessary if the user has configured time keywords. + (setq key1 (concat key ":")) + (cond + ((not key) + (setq key + (if (= (char-after (match-beginning 3)) ?\[) + "TIMESTAMP_IA" "TIMESTAMP"))) + ((equal key1 org-scheduled-string) (setq key "SCHEDULED")) + ((equal key1 org-deadline-string) (setq key "DEADLINE")) + ((equal key1 org-closed-string) (setq key "CLOSED")) + ((equal key1 org-clock-string) (setq key "CLOCK"))) + (when (or (equal key "CLOCK") (not (assoc key props))) + (push (cons key string) props)))) + ) + + (when (memq which '(all standard)) + ;; Get the standard properties, like :PROP: ... + (setq range (org-get-property-block beg end)) + (when range + (goto-char (car range)) + (while (re-search-forward + (org-re "^[ \t]*:\\([[:alpha:]][[:alnum:]_-]*\\):[ \t]*\\(\\S-.*\\)?") + (cdr range) t) + (setq key (org-match-string-no-properties 1) + value (org-trim (or (org-match-string-no-properties 2) ""))) + (unless (member key excluded) + (push (cons key (or value "")) props))))) + (if clocksum + (push (cons "CLOCKSUM" + (org-columns-number-to-string (/ (float clocksum) 60.) + 'add_times)) + props)) + (unless (assoc "CATEGORY" props) + (setq value (or (org-get-category) + (progn (org-refresh-category-properties) + (org-get-category)))) + (push (cons "CATEGORY" value) props)) + (append sum-props (nreverse props))))))) + +(defun org-entry-get (pom property &optional inherit literal-nil) + "Get value of PROPERTY for entry at point-or-marker POM. +If INHERIT is non-nil and the entry does not have the property, +then also check higher levels of the hierarchy. +If INHERIT is the symbol `selective', use inheritance only if the setting +in `org-use-property-inheritance' selects PROPERTY for inheritance. +If the property is present but empty, the return value is the empty string. +If the property is not present at all, nil is returned. + +If LITERAL-NIL is set, return the string value \"nil\" as a string, +do not interpret it as the list atom nil. This is used for inheritance +when a \"nil\" value can supersede a non-nil value higher up the hierarchy." + (org-with-point-at pom + (if (and inherit (if (eq inherit 'selective) + (org-property-inherit-p property) + t)) + (org-entry-get-with-inheritance property literal-nil) + (if (member property org-special-properties) + ;; We need a special property. Use `org-entry-properties' to + ;; retrieve it, but specify the wanted property + (cdr (assoc property (org-entry-properties nil 'special property))) + (let ((range (org-get-property-block))) + (if (and range + (goto-char (car range)) + (re-search-forward + (concat "^[ \t]*:" property ":[ \t]*\\(.*[^ \t\r\n\f\v]\\)?") + (cdr range) t)) + ;; Found the property, return it. + (if (match-end 1) + (if literal-nil + (org-match-string-no-properties 1) + (org-not-nil (org-match-string-no-properties 1))) + ""))))))) + +(defun org-property-or-variable-value (var &optional inherit) + "Check if there is a property fixing the value of VAR. +If yes, return this value. If not, return the current value of the variable." + (let ((prop (org-entry-get nil (symbol-name var) inherit))) + (if (and prop (stringp prop) (string-match "\\S-" prop)) + (read prop) + (symbol-value var)))) + +(defun org-entry-delete (pom property) + "Delete the property PROPERTY from entry at point-or-marker POM." + (org-with-point-at pom + (if (member property org-special-properties) + nil ; cannot delete these properties. + (let ((range (org-get-property-block))) + (if (and range + (goto-char (car range)) + (re-search-forward + (concat "^[ \t]*:" property ":[ \t]*\\(.*[^ \t\r\n\f\v]\\)") + (cdr range) t)) + (progn + (delete-region (match-beginning 0) (1+ (point-at-eol))) + t) + nil))))) + +;; Multi-values properties are properties that contain multiple values +;; These values are assumed to be single words, separated by whitespace. +(defun org-entry-add-to-multivalued-property (pom property value) + "Add VALUE to the words in the PROPERTY in entry at point-or-marker POM." + (let* ((old (org-entry-get pom property)) + (values (and old (org-split-string old "[ \t]")))) + (setq value (org-entry-protect-space value)) + (unless (member value values) + (setq values (cons value values)) + (org-entry-put pom property + (mapconcat 'identity values " "))))) + +(defun org-entry-remove-from-multivalued-property (pom property value) + "Remove VALUE from words in the PROPERTY in entry at point-or-marker POM." + (let* ((old (org-entry-get pom property)) + (values (and old (org-split-string old "[ \t]")))) + (setq value (org-entry-protect-space value)) + (when (member value values) + (setq values (delete value values)) + (org-entry-put pom property + (mapconcat 'identity values " "))))) + +(defun org-entry-member-in-multivalued-property (pom property value) + "Is VALUE one of the words in the PROPERTY in entry at point-or-marker POM?" + (let* ((old (org-entry-get pom property)) + (values (and old (org-split-string old "[ \t]")))) + (setq value (org-entry-protect-space value)) + (member value values))) + +(defun org-entry-get-multivalued-property (pom property) + "Return a list of values in a multivalued property." + (let* ((value (org-entry-get pom property)) + (values (and value (org-split-string value "[ \t]")))) + (mapcar 'org-entry-restore-space values))) + +(defun org-entry-put-multivalued-property (pom property &rest values) + "Set multivalued PROPERTY at point-or-marker POM to VALUES. +VALUES should be a list of strings. Spaces will be protected." + (org-entry-put pom property + (mapconcat 'org-entry-protect-space values " ")) + (let* ((value (org-entry-get pom property)) + (values (and value (org-split-string value "[ \t]")))) + (mapcar 'org-entry-restore-space values))) + +(defun org-entry-protect-space (s) + "Protect spaces and newline in string S." + (while (string-match " " s) + (setq s (replace-match "%20" t t s))) + (while (string-match "\n" s) + (setq s (replace-match "%0A" t t s))) + s) + +(defun org-entry-restore-space (s) + "Restore spaces and newline in string S." + (while (string-match "%20" s) + (setq s (replace-match " " t t s))) + (while (string-match "%0A" s) + (setq s (replace-match "\n" t t s))) + s) + +(defvar org-entry-property-inherited-from (make-marker) + "Marker pointing to the entry from where a property was inherited. +Each call to `org-entry-get-with-inheritance' will set this marker to the +location of the entry where the inheritance search matched. If there was +no match, the marker will point nowhere. +Note that also `org-entry-get' calls this function, if the INHERIT flag +is set.") + +(defun org-entry-get-with-inheritance (property &optional literal-nil) + "Get entry property, and search higher levels if not present. +The search will stop at the first ancestor which has the property defined. +If the value found is \"nil\", return nil to show that the property +should be considered as undefined (this is the meaning of nil here). +However, if LITERAL-NIL is set, return the string value \"nil\" instead." + (move-marker org-entry-property-inherited-from nil) + (let (tmp) + (save-excursion + (save-restriction + (widen) + (catch 'ex + (while t + (when (setq tmp (org-entry-get nil property nil 'literal-nil)) + (org-back-to-heading t) + (move-marker org-entry-property-inherited-from (point)) + (throw 'ex tmp)) + (or (org-up-heading-safe) (throw 'ex nil))))) + (setq tmp (or tmp + (cdr (assoc property org-file-properties)) + (cdr (assoc property org-global-properties)) + (cdr (assoc property org-global-properties-fixed)))) + (if literal-nil tmp (org-not-nil tmp))))) + +(defvar org-property-changed-functions nil + "Hook called when the value of a property has changed. +Each hook function should accept two arguments, the name of the property +and the new value.") + +(defun org-entry-put (pom property value) + "Set PROPERTY to VALUE for entry at point-or-marker POM." + (org-with-point-at pom + (org-back-to-heading t) + (let ((beg (point)) (end (save-excursion (outline-next-heading) (point))) + range) + (cond + ((equal property "TODO") + (when (and (stringp value) (string-match "\\S-" value) + (not (member value org-todo-keywords-1))) + (error "\"%s\" is not a valid TODO state" value)) + (if (or (not value) + (not (string-match "\\S-" value))) + (setq value 'none)) + (org-todo value) + (org-set-tags nil 'align)) + ((equal property "PRIORITY") + (org-priority (if (and value (stringp value) (string-match "\\S-" value)) + (string-to-char value) ?\ )) + (org-set-tags nil 'align)) + ((equal property "SCHEDULED") + (if (re-search-forward org-scheduled-time-regexp end t) + (cond + ((eq value 'earlier) (org-timestamp-change -1 'day)) + ((eq value 'later) (org-timestamp-change 1 'day)) + (t (call-interactively 'org-schedule))) + (call-interactively 'org-schedule))) + ((equal property "DEADLINE") + (if (re-search-forward org-deadline-time-regexp end t) + (cond + ((eq value 'earlier) (org-timestamp-change -1 'day)) + ((eq value 'later) (org-timestamp-change 1 'day)) + (t (call-interactively 'org-deadline))) + (call-interactively 'org-deadline))) + ((member property org-special-properties) + (error "The %s property can not yet be set with `org-entry-put'" + property)) + (t ; a non-special property + (let ((buffer-invisibility-spec (org-inhibit-invisibility))) ; Emacs 21 + (setq range (org-get-property-block beg end 'force)) + (goto-char (car range)) + (if (re-search-forward + (concat "^[ \t]*:" property ":\\(.*\\)") (cdr range) t) + (progn + (delete-region (match-beginning 1) (match-end 1)) + (goto-char (match-beginning 1))) + (goto-char (cdr range)) + (insert "\n") + (backward-char 1) + (org-indent-line-function) + (insert ":" property ":")) + (and value (insert " " value)) + (org-indent-line-function))))) + (run-hook-with-args 'org-property-changed-functions property value))) + +(defun org-buffer-property-keys (&optional include-specials include-defaults include-columns) + "Get all property keys in the current buffer. +With INCLUDE-SPECIALS, also list the special properties that reflect things +like tags and TODO state. +With INCLUDE-DEFAULTS, also include properties that has special meaning +internally: ARCHIVE, CATEGORY, SUMMARY, DESCRIPTION, LOCATION, and LOGGING. +With INCLUDE-COLUMNS, also include property names given in COLUMN +formats in the current buffer." + (let (rtn range cfmt s p) + (save-excursion + (save-restriction + (widen) + (goto-char (point-min)) + (while (re-search-forward org-property-start-re nil t) + (setq range (org-get-property-block)) + (goto-char (car range)) + (while (re-search-forward + (org-re "^[ \t]*:\\([-[:alnum:]_]+\\):") + (cdr range) t) + (add-to-list 'rtn (org-match-string-no-properties 1))) + (outline-next-heading)))) + + (when include-specials + (setq rtn (append org-special-properties rtn))) + + (when include-defaults + (mapc (lambda (x) (add-to-list 'rtn x)) org-default-properties) + (add-to-list 'rtn org-effort-property)) + + (when include-columns + (save-excursion + (save-restriction + (widen) + (goto-char (point-min)) + (while (re-search-forward + "^\\(#\\+COLUMNS:\\|[ \t]*:COLUMNS:\\)[ \t]*\\(.*\\)" + nil t) + (setq cfmt (match-string 2) s 0) + (while (string-match (org-re "%[0-9]*\\([-[:alnum:]_]+\\)") + cfmt s) + (setq s (match-end 0) + p (match-string 1 cfmt)) + (unless (or (equal p "ITEM") + (member p org-special-properties)) + (add-to-list 'rtn (match-string 1 cfmt)))))))) + + (sort rtn (lambda (a b) (string< (upcase a) (upcase b)))))) + +(defun org-property-values (key) + "Return a list of all values of property KEY." + (save-excursion + (save-restriction + (widen) + (goto-char (point-min)) + (let ((re (concat "^[ \t]*:" key ":[ \t]*\\(\\S-.*\\)")) + values) + (while (re-search-forward re nil t) + (add-to-list 'values (org-trim (match-string 1)))) + (delete "" values))))) + +(defun org-insert-property-drawer () + "Insert a property drawer into the current entry." + (interactive) + (org-back-to-heading t) + (looking-at outline-regexp) + (let ((indent (if org-adapt-indentation + (- (match-end 0)(match-beginning 0)) + 0)) + (beg (point)) + (re (concat "^[ \t]*" org-keyword-time-regexp)) + end hiddenp) + (outline-next-heading) + (setq end (point)) + (goto-char beg) + (while (re-search-forward re end t)) + (setq hiddenp (org-invisible-p)) + (end-of-line 1) + (and (equal (char-after) ?\n) (forward-char 1)) + (while (looking-at "^[ \t]*\\(:CLOCK:\\|:LOGBOOK:\\|CLOCK:\\|:END:\\)") + (if (member (match-string 1) '("CLOCK:" ":END:")) + ;; just skip this line + (beginning-of-line 2) + ;; Drawer start, find the end + (re-search-forward "^\\*+ \\|^[ \t]*:END:" nil t) + (beginning-of-line 1))) + (org-skip-over-state-notes) + (skip-chars-backward " \t\n\r") + (if (eq (char-before) ?*) (forward-char 1)) + (let ((inhibit-read-only t)) (insert "\n:PROPERTIES:\n:END:")) + (beginning-of-line 0) + (org-indent-to-column indent) + (beginning-of-line 2) + (org-indent-to-column indent) + (beginning-of-line 0) + (if hiddenp + (save-excursion + (org-back-to-heading t) + (hide-entry)) + (org-flag-drawer t)))) + +(defun org-set-property (property value) + "In the current entry, set PROPERTY to VALUE. +When called interactively, this will prompt for a property name, offering +completion on existing and default properties. And then it will prompt +for a value, offering completion either on allowed values (via an inherited +xxx_ALL property) or on existing values in other instances of this property +in the current file." + (interactive + (let* ((completion-ignore-case t) + (keys (org-buffer-property-keys nil t t)) + (prop0 (org-icompleting-read "Property: " (mapcar 'list keys))) + (prop (if (member prop0 keys) + prop0 + (or (cdr (assoc (downcase prop0) + (mapcar (lambda (x) (cons (downcase x) x)) + keys))) + prop0))) + (cur (org-entry-get nil prop)) + (prompt (concat prop " value" + (if (and cur (string-match "\\S-" cur)) + (concat " [" cur "]") "") ": ")) + (allowed (org-property-get-allowed-values nil prop 'table)) + (existing (mapcar 'list (org-property-values prop))) + (val (if allowed + (org-completing-read prompt allowed nil + (not (get-text-property 0 'org-unrestricted + (caar allowed)))) + (let (org-completion-use-ido org-completion-use-iswitchb) + (org-completing-read prompt existing nil nil "" nil cur))))) + (list prop (if (equal val "") cur val)))) + (unless (equal (org-entry-get nil property) value) + (org-entry-put nil property value))) + +(defun org-delete-property (property) + "In the current entry, delete PROPERTY." + (interactive + (let* ((completion-ignore-case t) + (prop (org-icompleting-read "Property: " + (org-entry-properties nil 'standard)))) + (list prop))) + (message "Property %s %s" property + (if (org-entry-delete nil property) + "deleted" + "was not present in the entry"))) + +(defun org-delete-property-globally (property) + "Remove PROPERTY globally, from all entries." + (interactive + (let* ((completion-ignore-case t) + (prop (org-icompleting-read + "Globally remove property: " + (mapcar 'list (org-buffer-property-keys))))) + (list prop))) + (save-excursion + (save-restriction + (widen) + (goto-char (point-min)) + (let ((cnt 0)) + (while (re-search-forward + (concat "^[ \t]*:" (regexp-quote property) ":.*\n?") + nil t) + (setq cnt (1+ cnt)) + (replace-match "")) + (message "Property \"%s\" removed from %d entries" property cnt))))) + +(defvar org-columns-current-fmt-compiled) ; defined in org-colview.el + +(defun org-compute-property-at-point () + "Compute the property at point. +This looks for an enclosing column format, extracts the operator and +then applies it to the property in the column format's scope." + (interactive) + (unless (org-at-property-p) + (error "Not at a property")) + (let ((prop (org-match-string-no-properties 2))) + (org-columns-get-format-and-top-level) + (unless (nth 3 (assoc prop org-columns-current-fmt-compiled)) + (error "No operator defined for property %s" prop)) + (org-columns-compute prop))) + +(defvar org-property-allowed-value-functions nil + "Hook for functions supplying allowed values for a specific property. +The functions must take a single argument, the name of the property, and +return a flat list of allowed values. If \":ETC\" is one of +the values, this means that these values are intended as defaults for +completion, but that other values should be allowed too. +The functions must return nil if they are not responsible for this +property.") + +(defun org-property-get-allowed-values (pom property &optional table) + "Get allowed values for the property PROPERTY. +When TABLE is non-nil, return an alist that can directly be used for +completion." + (let (vals) + (cond + ((equal property "TODO") + (setq vals (org-with-point-at pom + (append org-todo-keywords-1 '(""))))) + ((equal property "PRIORITY") + (let ((n org-lowest-priority)) + (while (>= n org-highest-priority) + (push (char-to-string n) vals) + (setq n (1- n))))) + ((member property org-special-properties)) + ((setq vals (run-hook-with-args-until-success + 'org-property-allowed-value-functions property))) + (t + (setq vals (org-entry-get pom (concat property "_ALL") 'inherit)) + (when (and vals (string-match "\\S-" vals)) + (setq vals (car (read-from-string (concat "(" vals ")")))) + (setq vals (mapcar (lambda (x) + (cond ((stringp x) x) + ((numberp x) (number-to-string x)) + ((symbolp x) (symbol-name x)) + (t "???"))) + vals))))) + (when (member ":ETC" vals) + (setq vals (remove ":ETC" vals)) + (org-add-props (car vals) '(org-unrestricted t))) + (if table (mapcar 'list vals) vals))) + +(defun org-property-previous-allowed-value (&optional previous) + "Switch to the next allowed value for this property." + (interactive) + (org-property-next-allowed-value t)) + +(defun org-property-next-allowed-value (&optional previous) + "Switch to the next allowed value for this property." + (interactive) + (unless (org-at-property-p) + (error "Not at a property")) + (let* ((key (match-string 2)) + (value (match-string 3)) + (allowed (or (org-property-get-allowed-values (point) key) + (and (member value '("[ ]" "[-]" "[X]")) + '("[ ]" "[X]")))) + nval) + (unless allowed + (error "Allowed values for this property have not been defined")) + (if previous (setq allowed (reverse allowed))) + (if (member value allowed) + (setq nval (car (cdr (member value allowed))))) + (setq nval (or nval (car allowed))) + (if (equal nval value) + (error "Only one allowed value for this property")) + (org-at-property-p) + (replace-match (concat " :" key ": " nval) t t) + (org-indent-line-function) + (beginning-of-line 1) + (skip-chars-forward " \t") + (run-hook-with-args 'org-property-changed-functions key nval))) + +(defun org-find-olp (path &optional this-buffer) + "Return a marker pointing to the entry at outline path OLP. +If anything goes wrong, throw an error. +You can wrap this call to catch the error like this: + + (condition-case msg + (org-mobile-locate-entry (match-string 4)) + (error (nth 1 msg))) + +The return value will then be either a string with the error message, +or a marker if everything is OK. + +If THIS-BUFFER is set, the outline path does not contain a file, +only headings." + (let* ((file (if this-buffer buffer-file-name (pop path))) + (buffer (if this-buffer (current-buffer) (find-file-noselect file))) + (level 1) + (lmin 1) + (lmax 1) + limit re end found pos heading cnt) + (unless buffer (error "File not found :%s" file)) + (with-current-buffer buffer + (save-excursion + (save-restriction + (widen) + (setq limit (point-max)) + (goto-char (point-min)) + (while (setq heading (pop path)) + (setq re (format org-complex-heading-regexp-format + (regexp-quote heading))) + (setq cnt 0 pos (point)) + (while (re-search-forward re end t) + (setq level (- (match-end 1) (match-beginning 1))) + (if (and (>= level lmin) (<= level lmax)) + (setq found (match-beginning 0) cnt (1+ cnt)))) + (when (= cnt 0) (error "Heading not found on level %d: %s" + lmax heading)) + (when (> cnt 1) (error "Heading not unique on level %d: %s" + lmax heading)) + (goto-char found) + (setq lmin (1+ level) lmax (+ lmin (if org-odd-levels-only 1 0))) + (setq end (save-excursion (org-end-of-subtree t t)))) + (when (org-on-heading-p) + (move-marker (make-marker) (point)))))))) + +(defun org-find-exact-headline-in-buffer (heading &optional buffer pos-only) + "Find node HEADING in BUFFER. +Return a marker to the heading if it was found, or nil if not. +If POS-ONLY is set, return just the position instead of a marker. + +The heading text must match exact, but it may have a TODO keyword, +a priority cookie and tags in the standard locations." + (with-current-buffer (or buffer (current-buffer)) + (save-excursion + (save-restriction + (widen) + (goto-char (point-min)) + (let (case-fold-search) + (if (re-search-forward + (format org-complex-heading-regexp-format + (regexp-quote heading)) nil t) + (if pos-only + (match-beginning 0) + (move-marker (make-marker) (match-beginning 0))))))))) + +(defun org-find-exact-heading-in-directory (heading &optional dir) + "Find Org node headline HEADING in all .org files in directory DIR. +When the target headline is found, return a marker to this location." + (let ((files (directory-files (or dir default-directory) + nil "\\`[^.#].*\\.org\\'")) + file visiting m buffer) + (catch 'found + (while (setq file (pop files)) + (message "trying %s" file) + (setq visiting (org-find-base-buffer-visiting file)) + (setq buffer (or visiting (find-file-noselect file))) + (setq m (org-find-exact-headline-in-buffer + heading buffer)) + (when (and (not m) (not visiting)) (kill-buffer buffer)) + (and m (throw 'found m)))))) + +(defun org-find-entry-with-id (ident) + "Locate the entry that contains the ID property with exact value IDENT. +IDENT can be a string, a symbol or a number, this function will search for +the string representation of it. +Return the position where this entry starts, or nil if there is no such entry." + (interactive "sID: ") + (let ((id (cond + ((stringp ident) ident) + ((symbol-name ident) (symbol-name ident)) + ((numberp ident) (number-to-string ident)) + (t (error "IDENT %s must be a string, symbol or number" ident)))) + (case-fold-search nil)) + (save-excursion + (save-restriction + (widen) + (goto-char (point-min)) + (when (re-search-forward + (concat "^[ \t]*:ID:[ \t]+" (regexp-quote id) "[ \t]*$") + nil t) + (org-back-to-heading t) + (point)))))) + +;;;; Timestamps + +(defvar org-last-changed-timestamp nil) +(defvar org-last-inserted-timestamp nil + "The last time stamp inserted with `org-insert-time-stamp'.") +(defvar org-time-was-given) ; dynamically scoped parameter +(defvar org-end-time-was-given) ; dynamically scoped parameter +(defvar org-ts-what) ; dynamically scoped parameter + +(defun org-time-stamp (arg &optional inactive) + "Prompt for a date/time and insert a time stamp. +If the user specifies a time like HH:MM, or if this command is called +with a prefix argument, the time stamp will contain date and time. +Otherwise, only the date will be included. All parts of a date not +specified by the user will be filled in from the current date/time. +So if you press just return without typing anything, the time stamp +will represent the current date/time. If there is already a timestamp +at the cursor, it will be modified." + (interactive "P") + (let* ((ts nil) + (default-time + ;; Default time is either today, or, when entering a range, + ;; the range start. + (if (or (and (org-at-timestamp-p t) (setq ts (match-string 0))) + (save-excursion + (re-search-backward + (concat org-ts-regexp "--?-?\\=") ; 1-3 minuses + (- (point) 20) t))) + (apply 'encode-time (org-parse-time-string (match-string 1))) + (current-time))) + (default-input (and ts (org-get-compact-tod ts))) + org-time-was-given org-end-time-was-given time) + (cond + ((and (org-at-timestamp-p t) + (memq last-command '(org-time-stamp org-time-stamp-inactive)) + (memq this-command '(org-time-stamp org-time-stamp-inactive))) + (insert "--") + (setq time (let ((this-command this-command)) + (org-read-date arg 'totime nil nil + default-time default-input))) + (org-insert-time-stamp time (or org-time-was-given arg) inactive)) + ((org-at-timestamp-p t) + (setq time (let ((this-command this-command)) + (org-read-date arg 'totime nil nil default-time default-input))) + (when (org-at-timestamp-p t) ; just to get the match data +; (setq inactive (eq (char-after (match-beginning 0)) ?\[)) + (replace-match "") + (setq org-last-changed-timestamp + (org-insert-time-stamp + time (or org-time-was-given arg) + inactive nil nil (list org-end-time-was-given)))) + (message "Timestamp updated")) + (t + (setq time (let ((this-command this-command)) + (org-read-date arg 'totime nil nil default-time default-input))) + (org-insert-time-stamp time (or org-time-was-given arg) inactive + nil nil (list org-end-time-was-given)))))) + +;; FIXME: can we use this for something else, like computing time differences? +(defun org-get-compact-tod (s) + (when (string-match "\\(\\([012]?[0-9]\\):\\([0-5][0-9]\\)\\)\\(-\\(\\([012]?[0-9]\\):\\([0-5][0-9]\\)\\)\\)?" s) + (let* ((t1 (match-string 1 s)) + (h1 (string-to-number (match-string 2 s))) + (m1 (string-to-number (match-string 3 s))) + (t2 (and (match-end 4) (match-string 5 s))) + (h2 (and t2 (string-to-number (match-string 6 s)))) + (m2 (and t2 (string-to-number (match-string 7 s)))) + dh dm) + (if (not t2) + t1 + (setq dh (- h2 h1) dm (- m2 m1)) + (if (< dm 0) (setq dm (+ dm 60) dh (1- dh))) + (concat t1 "+" (number-to-string dh) + (if (/= 0 dm) (concat ":" (number-to-string dm)))))))) + +(defun org-time-stamp-inactive (&optional arg) + "Insert an inactive time stamp. +An inactive time stamp is enclosed in square brackets instead of angle +brackets. It is inactive in the sense that it does not trigger agenda entries, +does not link to the calendar and cannot be changed with the S-cursor keys. +So these are more for recording a certain time/date." + (interactive "P") + (org-time-stamp arg 'inactive)) + +(defvar org-date-ovl (make-overlay 1 1)) +(overlay-put org-date-ovl 'face 'org-warning) +(org-detach-overlay org-date-ovl) + +(defvar org-ans1) ; dynamically scoped parameter +(defvar org-ans2) ; dynamically scoped parameter + +(defvar org-plain-time-of-day-regexp) ; defined below + +(defvar org-overriding-default-time nil) ; dynamically scoped +(defvar org-read-date-overlay nil) +(defvar org-dcst nil) ; dynamically scoped +(defvar org-read-date-history nil) +(defvar org-read-date-final-answer nil) + +(defun org-read-date (&optional with-time to-time from-string prompt + default-time default-input) + "Read a date, possibly a time, and make things smooth for the user. +The prompt will suggest to enter an ISO date, but you can also enter anything +which will at least partially be understood by `parse-time-string'. +Unrecognized parts of the date will default to the current day, month, year, +hour and minute. If this command is called to replace a timestamp at point, +of to enter the second timestamp of a range, the default time is taken +from the existing stamp. Furthermore, the command prefers the future, +so if you are giving a date where the year is not given, and the day-month +combination is already past in the current year, it will assume you +mean next year. For details, see the manual. A few examples: + + 3-2-5 --> 2003-02-05 + feb 15 --> currentyear-02-15 + 2/15 --> currentyear-02-15 + sep 12 9 --> 2009-09-12 + 12:45 --> today 12:45 + 22 sept 0:34 --> currentyear-09-22 0:34 + 12 --> currentyear-currentmonth-12 + Fri --> nearest Friday (today or later) + etc. + +Furthermore you can specify a relative date by giving, as the *first* thing +in the input: a plus/minus sign, a number and a letter [dwmy] to indicate +change in days weeks, months, years. +With a single plus or minus, the date is relative to today. With a double +plus or minus, it is relative to the date in DEFAULT-TIME. E.g. + +4d --> four days from today + +4 --> same as above + +2w --> two weeks from today + ++5 --> five days from default date + +The function understands only English month and weekday abbreviations, +but this can be configured with the variables `parse-time-months' and +`parse-time-weekdays'. + +While prompting, a calendar is popped up - you can also select the +date with the mouse (button 1). The calendar shows a period of three +months. To scroll it to other months, use the keys `>' and `<'. +If you don't like the calendar, turn it off with + \(setq org-read-date-popup-calendar nil) + +With optional argument TO-TIME, the date will immediately be converted +to an internal time. +With an optional argument WITH-TIME, the prompt will suggest to also +insert a time. Note that when WITH-TIME is not set, you can still +enter a time, and this function will inform the calling routine about +this change. The calling routine may then choose to change the format +used to insert the time stamp into the buffer to include the time. +With optional argument FROM-STRING, read from this string instead from +the user. PROMPT can overwrite the default prompt. DEFAULT-TIME is +the time/date that is used for everything that is not specified by the +user." + (require 'parse-time) + (let* ((org-time-stamp-rounding-minutes + (if (equal with-time '(16)) '(0 0) org-time-stamp-rounding-minutes)) + (org-dcst org-display-custom-times) + (ct (org-current-time)) + (def (or org-overriding-default-time default-time ct)) + (defdecode (decode-time def)) + (dummy (progn + (when (< (nth 2 defdecode) org-extend-today-until) + (setcar (nthcdr 2 defdecode) -1) + (setcar (nthcdr 1 defdecode) 59) + (setq def (apply 'encode-time defdecode) + defdecode (decode-time def))))) + (calendar-frame-setup nil) + (calendar-setup nil) + (calendar-move-hook nil) + (calendar-view-diary-initially-flag nil) + (calendar-view-holidays-initially-flag nil) + (timestr (format-time-string + (if with-time "%Y-%m-%d %H:%M" "%Y-%m-%d") def)) + (prompt (concat (if prompt (concat prompt " ") "") + (format "Date+time [%s]: " timestr))) + ans (org-ans0 "") org-ans1 org-ans2 final) + + (cond + (from-string (setq ans from-string)) + (org-read-date-popup-calendar + (save-excursion + (save-window-excursion + (calendar) + (calendar-forward-day (- (time-to-days def) + (calendar-absolute-from-gregorian + (calendar-current-date)))) + (org-eval-in-calendar nil t) + (let* ((old-map (current-local-map)) + (map (copy-keymap calendar-mode-map)) + (minibuffer-local-map (copy-keymap minibuffer-local-map))) + (org-defkey map (kbd "RET") 'org-calendar-select) + (org-defkey map [mouse-1] 'org-calendar-select-mouse) + (org-defkey map [mouse-2] 'org-calendar-select-mouse) + (org-defkey minibuffer-local-map [(meta shift left)] + (lambda () (interactive) + (org-eval-in-calendar '(calendar-backward-month 1)))) + (org-defkey minibuffer-local-map [(meta shift right)] + (lambda () (interactive) + (org-eval-in-calendar '(calendar-forward-month 1)))) + (org-defkey minibuffer-local-map [(meta shift up)] + (lambda () (interactive) + (org-eval-in-calendar '(calendar-backward-year 1)))) + (org-defkey minibuffer-local-map [(meta shift down)] + (lambda () (interactive) + (org-eval-in-calendar '(calendar-forward-year 1)))) + (org-defkey minibuffer-local-map [?\e (shift left)] + (lambda () (interactive) + (org-eval-in-calendar '(calendar-backward-month 1)))) + (org-defkey minibuffer-local-map [?\e (shift right)] + (lambda () (interactive) + (org-eval-in-calendar '(calendar-forward-month 1)))) + (org-defkey minibuffer-local-map [?\e (shift up)] + (lambda () (interactive) + (org-eval-in-calendar '(calendar-backward-year 1)))) + (org-defkey minibuffer-local-map [?\e (shift down)] + (lambda () (interactive) + (org-eval-in-calendar '(calendar-forward-year 1)))) + (org-defkey minibuffer-local-map [(shift up)] + (lambda () (interactive) + (org-eval-in-calendar '(calendar-backward-week 1)))) + (org-defkey minibuffer-local-map [(shift down)] + (lambda () (interactive) + (org-eval-in-calendar '(calendar-forward-week 1)))) + (org-defkey minibuffer-local-map [(shift left)] + (lambda () (interactive) + (org-eval-in-calendar '(calendar-backward-day 1)))) + (org-defkey minibuffer-local-map [(shift right)] + (lambda () (interactive) + (org-eval-in-calendar '(calendar-forward-day 1)))) + (org-defkey minibuffer-local-map ">" + (lambda () (interactive) + (org-eval-in-calendar '(scroll-calendar-left 1)))) + (org-defkey minibuffer-local-map "<" + (lambda () (interactive) + (org-eval-in-calendar '(scroll-calendar-right 1)))) + (org-defkey minibuffer-local-map "\C-v" + (lambda () (interactive) + (org-eval-in-calendar + '(calendar-scroll-left-three-months 1)))) + (org-defkey minibuffer-local-map "\M-v" + (lambda () (interactive) + (org-eval-in-calendar + '(calendar-scroll-right-three-months 1)))) + (run-hooks 'org-read-date-minibuffer-setup-hook) + (unwind-protect + (progn + (use-local-map map) + (add-hook 'post-command-hook 'org-read-date-display) + (setq org-ans0 (read-string prompt default-input + 'org-read-date-history nil)) + ;; org-ans0: from prompt + ;; org-ans1: from mouse click + ;; org-ans2: from calendar motion + (setq ans (concat org-ans0 " " (or org-ans1 org-ans2)))) + (remove-hook 'post-command-hook 'org-read-date-display) + (use-local-map old-map) + (when org-read-date-overlay + (delete-overlay org-read-date-overlay) + (setq org-read-date-overlay nil))))))) + + (t ; Naked prompt only + (unwind-protect + (setq ans (read-string prompt default-input + 'org-read-date-history timestr)) + (when org-read-date-overlay + (delete-overlay org-read-date-overlay) + (setq org-read-date-overlay nil))))) + + (setq final (org-read-date-analyze ans def defdecode)) + + ;; One round trip to get rid of 34th of August and stuff like that.... + (setq final (decode-time (apply 'encode-time final))) + + (setq org-read-date-final-answer ans) + + (if to-time + (apply 'encode-time final) + (if (and (boundp 'org-time-was-given) org-time-was-given) + (format "%04d-%02d-%02d %02d:%02d" + (nth 5 final) (nth 4 final) (nth 3 final) + (nth 2 final) (nth 1 final)) + (format "%04d-%02d-%02d" (nth 5 final) (nth 4 final) (nth 3 final)))))) + +(defvar def) +(defvar defdecode) +(defvar with-time) +(defvar org-read-date-analyze-futurep nil) +(defun org-read-date-display () + "Display the current date prompt interpretation in the minibuffer." + (when org-read-date-display-live + (when org-read-date-overlay + (delete-overlay org-read-date-overlay)) + (let ((p (point))) + (end-of-line 1) + (while (not (equal (buffer-substring + (max (point-min) (- (point) 4)) (point)) + " ")) + (insert " ")) + (goto-char p)) + (let* ((ans (concat (buffer-substring (point-at-bol) (point-max)) + " " (or org-ans1 org-ans2))) + (org-end-time-was-given nil) + (f (org-read-date-analyze ans def defdecode)) + (fmts (if org-dcst + org-time-stamp-custom-formats + org-time-stamp-formats)) + (fmt (if (or with-time + (and (boundp 'org-time-was-given) org-time-was-given)) + (cdr fmts) + (car fmts))) + (txt (concat "=> " (format-time-string fmt (apply 'encode-time f))))) + (when (and org-end-time-was-given + (string-match org-plain-time-of-day-regexp txt)) + (setq txt (concat (substring txt 0 (match-end 0)) "-" + org-end-time-was-given + (substring txt (match-end 0))))) + (when org-read-date-analyze-futurep + (setq txt (concat txt " (=>F)"))) + (setq org-read-date-overlay + (make-overlay (1- (point-at-eol)) (point-at-eol))) + (org-overlay-display org-read-date-overlay txt 'secondary-selection)))) + +(defun org-read-date-analyze (ans def defdecode) + "Analyze the combined answer of the date prompt." + ;; FIXME: cleanup and comment + (let ((nowdecode (decode-time (current-time))) + delta deltan deltaw deltadef year month day + hour minute second wday pm h2 m2 tl wday1 + iso-year iso-weekday iso-week iso-year iso-date futurep kill-year) + (setq org-read-date-analyze-futurep nil) + (when (string-match "\\`[ \t]*\\.[ \t]*\\'" ans) + (setq ans "+0")) + + (when (setq delta (org-read-date-get-relative ans (current-time) def)) + (setq ans (replace-match "" t t ans) + deltan (car delta) + deltaw (nth 1 delta) + deltadef (nth 2 delta))) + + ;; Check if there is an iso week date in there + ;; If yes, store the info and postpone interpreting it until the rest + ;; of the parsing is done + (when (string-match "\\<\\(?:\\([0-9]+\\)-\\)?[wW]\\([0-9]\\{1,2\\}\\)\\(?:-\\([0-6]\\)\\)?\\([ \t]\\|$\\)" ans) + (setq iso-year (if (match-end 1) + (org-small-year-to-year + (string-to-number (match-string 1 ans)))) + iso-weekday (if (match-end 3) + (string-to-number (match-string 3 ans))) + iso-week (string-to-number (match-string 2 ans))) + (setq ans (replace-match "" t t ans))) + + ;; Help matching ISO dates with single digit month or day, like 2006-8-11. + (when (string-match + "^ *\\(\\([0-9]+\\)-\\)?\\([0-1]?[0-9]\\)-\\([0-3]?[0-9]\\)\\([^-0-9]\\|$\\)" ans) + (setq year (if (match-end 2) + (string-to-number (match-string 2 ans)) + (progn (setq kill-year t) + (string-to-number (format-time-string "%Y")))) + month (string-to-number (match-string 3 ans)) + day (string-to-number (match-string 4 ans))) + (if (< year 100) (setq year (+ 2000 year))) + (setq ans (replace-match (format "%04d-%02d-%02d\\5" year month day) + t nil ans))) + ;; Help matching american dates, like 5/30 or 5/30/7 + (when (string-match + "^ *\\(0?[1-9]\\|1[012]\\)/\\(0?[1-9]\\|[12][0-9]\\|3[01]\\)\\(/\\([0-9]+\\)\\)?\\([^/0-9]\\|$\\)" ans) + (setq year (if (match-end 4) + (string-to-number (match-string 4 ans)) + (progn (setq kill-year t) + (string-to-number (format-time-string "%Y")))) + month (string-to-number (match-string 1 ans)) + day (string-to-number (match-string 2 ans))) + (if (< year 100) (setq year (+ 2000 year))) + (setq ans (replace-match (format "%04d-%02d-%02d\\5" year month day) + t nil ans))) + ;; Help matching am/pm times, because `parse-time-string' does not do that. + ;; If there is a time with am/pm, and *no* time without it, we convert + ;; so that matching will be successful. + (loop for i from 1 to 2 do ; twice, for end time as well + (when (and (not (string-match "\\(\\`\\|[^+]\\)[012]?[0-9]:[0-9][0-9]\\([ \t\n]\\|$\\)" ans)) + (string-match "\\([012]?[0-9]\\)\\(:\\([0-5][0-9]\\)\\)?\\(am\\|AM\\|pm\\|PM\\)\\>" ans)) + (setq hour (string-to-number (match-string 1 ans)) + minute (if (match-end 3) + (string-to-number (match-string 3 ans)) + 0) + pm (equal ?p + (string-to-char (downcase (match-string 4 ans))))) + (if (and (= hour 12) (not pm)) + (setq hour 0) + (if (and pm (< hour 12)) (setq hour (+ 12 hour)))) + (setq ans (replace-match (format "%02d:%02d" hour minute) + t t ans)))) + + ;; Check if a time range is given as a duration + (when (string-match "\\([012]?[0-9]\\):\\([0-6][0-9]\\)\\+\\([012]?[0-9]\\)\\(:\\([0-5][0-9]\\)\\)?" ans) + (setq hour (string-to-number (match-string 1 ans)) + h2 (+ hour (string-to-number (match-string 3 ans))) + minute (string-to-number (match-string 2 ans)) + m2 (+ minute (if (match-end 5) (string-to-number + (match-string 5 ans))0))) + (if (>= m2 60) (setq h2 (1+ h2) m2 (- m2 60))) + (setq ans (replace-match (format "%02d:%02d-%02d:%02d" hour minute h2 m2) + t t ans))) + + ;; Check if there is a time range + (when (boundp 'org-end-time-was-given) + (setq org-time-was-given nil) + (when (and (string-match org-plain-time-of-day-regexp ans) + (match-end 8)) + (setq org-end-time-was-given (match-string 8 ans)) + (setq ans (concat (substring ans 0 (match-beginning 7)) + (substring ans (match-end 7)))))) + + (setq tl (parse-time-string ans) + day (or (nth 3 tl) (nth 3 defdecode)) + month (or (nth 4 tl) + (if (and org-read-date-prefer-future + (nth 3 tl) (< (nth 3 tl) (nth 3 nowdecode))) + (prog1 (1+ (nth 4 nowdecode)) (setq futurep t)) + (nth 4 defdecode))) + year (or (and (not kill-year) (nth 5 tl)) + (if (and org-read-date-prefer-future + (nth 4 tl) (< (nth 4 tl) (nth 4 nowdecode))) + (prog1 (1+ (nth 5 nowdecode)) (setq futurep t)) + (nth 5 defdecode))) + hour (or (nth 2 tl) (nth 2 defdecode)) + minute (or (nth 1 tl) (nth 1 defdecode)) + second (or (nth 0 tl) 0) + wday (nth 6 tl)) + + (when (and (eq org-read-date-prefer-future 'time) + (not (nth 3 tl)) (not (nth 4 tl)) (not (nth 5 tl)) + (equal day (nth 3 nowdecode)) + (equal month (nth 4 nowdecode)) + (equal year (nth 5 nowdecode)) + (nth 2 tl) + (or (< (nth 2 tl) (nth 2 nowdecode)) + (and (= (nth 2 tl) (nth 2 nowdecode)) + (nth 1 tl) + (< (nth 1 tl) (nth 1 nowdecode))))) + (setq day (1+ day) + futurep t)) + + ;; Special date definitions below + (cond + (iso-week + ;; There was an iso week + (require 'cal-iso) + (setq futurep nil) + (setq year (or iso-year year) + day (or iso-weekday wday 1) + wday nil ; to make sure that the trigger below does not match + iso-date (calendar-gregorian-from-absolute + (calendar-absolute-from-iso + (list iso-week day year)))) +; FIXME: Should we also push ISO weeks into the future? +; (when (and org-read-date-prefer-future +; (not iso-year) +; (< (calendar-absolute-from-gregorian iso-date) +; (time-to-days (current-time)))) +; (setq year (1+ year) +; iso-date (calendar-gregorian-from-absolute +; (calendar-absolute-from-iso +; (list iso-week day year))))) + (setq month (car iso-date) + year (nth 2 iso-date) + day (nth 1 iso-date))) + (deltan + (setq futurep nil) + (unless deltadef + (let ((now (decode-time (current-time)))) + (setq day (nth 3 now) month (nth 4 now) year (nth 5 now)))) + (cond ((member deltaw '("d" "")) (setq day (+ day deltan))) + ((equal deltaw "w") (setq day (+ day (* 7 deltan)))) + ((equal deltaw "m") (setq month (+ month deltan))) + ((equal deltaw "y") (setq year (+ year deltan))))) + ((and wday (not (nth 3 tl))) + (setq futurep nil) + ;; Weekday was given, but no day, so pick that day in the week + ;; on or after the derived date. + (setq wday1 (nth 6 (decode-time (encode-time 0 0 0 day month year)))) + (unless (equal wday wday1) + (setq day (+ day (% (- wday wday1 -7) 7)))))) + (if (and (boundp 'org-time-was-given) + (nth 2 tl)) + (setq org-time-was-given t)) + (if (< year 100) (setq year (+ 2000 year))) + (if (< year 1970) (setq year (nth 5 defdecode))) ; not representable + (setq org-read-date-analyze-futurep futurep) + (list second minute hour day month year))) + +(defvar parse-time-weekdays) + +(defun org-read-date-get-relative (s today default) + "Check string S for special relative date string. +TODAY and DEFAULT are internal times, for today and for a default. +Return shift list (N what def-flag) +WHAT is \"d\", \"w\", \"m\", or \"y\" for day, week, month, year. +N is the number of WHATs to shift. +DEF-FLAG is t when a double ++ or -- indicates shift relative to + the DEFAULT date rather than TODAY." + (when (and + (string-match + (concat + "\\`[ \t]*\\([-+]\\{0,2\\}\\)" + "\\([0-9]+\\)?" + "\\([dwmy]\\|\\(" (mapconcat 'car parse-time-weekdays "\\|") "\\)\\)?" + "\\([ \t]\\|$\\)") s) + (or (> (match-end 1) (match-beginning 1)) (match-end 4))) + (let* ((dir (if (> (match-end 1) (match-beginning 1)) + (string-to-char (substring (match-string 1 s) -1)) + ?+)) + (rel (and (match-end 1) (= 2 (- (match-end 1) (match-beginning 1))))) + (n (if (match-end 2) (string-to-number (match-string 2 s)) 1)) + (what (if (match-end 3) (match-string 3 s) "d")) + (wday1 (cdr (assoc (downcase what) parse-time-weekdays))) + (date (if rel default today)) + (wday (nth 6 (decode-time date))) + delta) + (if wday1 + (progn + (setq delta (mod (+ 7 (- wday1 wday)) 7)) + (if (= dir ?-) (setq delta (- delta 7))) + (if (> n 1) (setq delta (+ delta (* (1- n) (if (= dir ?-) -7 7))))) + (list delta "d" rel)) + (list (* n (if (= dir ?-) -1 1)) what rel))))) + +(defun org-order-calendar-date-args (arg1 arg2 arg3) + "Turn a user-specified date into the internal representation. +The internal representation needed by the calendar is (month day year). +This is a wrapper to handle the brain-dead convention in calendar that +user function argument order change dependent on argument order." + (if (boundp 'calendar-date-style) + (cond + ((eq calendar-date-style 'american) + (list arg1 arg2 arg3)) + ((eq calendar-date-style 'european) + (list arg2 arg1 arg3)) + ((eq calendar-date-style 'iso) + (list arg2 arg3 arg1))) + (with-no-warnings ;; european-calendar-style is obsolete as of version 23.1 + (if (org-bound-and-true-p european-calendar-style) + (list arg2 arg1 arg3) + (list arg1 arg2 arg3))))) + +(defun org-eval-in-calendar (form &optional keepdate) + "Eval FORM in the calendar window and return to current window. +Also, store the cursor date in variable org-ans2." + (let ((sf (selected-frame)) + (sw (selected-window))) + (select-window (get-buffer-window "*Calendar*" t)) + (eval form) + (when (and (not keepdate) (calendar-cursor-to-date)) + (let* ((date (calendar-cursor-to-date)) + (time (encode-time 0 0 0 (nth 1 date) (nth 0 date) (nth 2 date)))) + (setq org-ans2 (format-time-string "%Y-%m-%d" time)))) + (move-overlay org-date-ovl (1- (point)) (1+ (point)) (current-buffer)) + (select-window sw) + (org-select-frame-set-input-focus sf))) + +(defun org-calendar-select () + "Return to `org-read-date' with the date currently selected. +This is used by `org-read-date' in a temporary keymap for the calendar buffer." + (interactive) + (when (calendar-cursor-to-date) + (let* ((date (calendar-cursor-to-date)) + (time (encode-time 0 0 0 (nth 1 date) (nth 0 date) (nth 2 date)))) + (setq org-ans1 (format-time-string "%Y-%m-%d" time))) + (if (active-minibuffer-window) (exit-minibuffer)))) + +(defun org-insert-time-stamp (time &optional with-hm inactive pre post extra) + "Insert a date stamp for the date given by the internal TIME. +WITH-HM means use the stamp format that includes the time of the day. +INACTIVE means use square brackets instead of angular ones, so that the +stamp will not contribute to the agenda. +PRE and POST are optional strings to be inserted before and after the +stamp. +The command returns the inserted time stamp." + (let ((fmt (funcall (if with-hm 'cdr 'car) org-time-stamp-formats)) + stamp) + (if inactive (setq fmt (concat "[" (substring fmt 1 -1) "]"))) + (insert-before-markers (or pre "")) + (when (listp extra) + (setq extra (car extra)) + (if (and (stringp extra) + (string-match "\\([0-9]+\\):\\([0-9]+\\)" extra)) + (setq extra (format "-%02d:%02d" + (string-to-number (match-string 1 extra)) + (string-to-number (match-string 2 extra)))) + (setq extra nil))) + (when extra + (setq fmt (concat (substring fmt 0 -1) extra (substring fmt -1)))) + (insert-before-markers (setq stamp (format-time-string fmt time))) + (insert-before-markers (or post "")) + (setq org-last-inserted-timestamp stamp))) + +(defun org-toggle-time-stamp-overlays () + "Toggle the use of custom time stamp formats." + (interactive) + (setq org-display-custom-times (not org-display-custom-times)) + (unless org-display-custom-times + (let ((p (point-min)) (bmp (buffer-modified-p))) + (while (setq p (next-single-property-change p 'display)) + (if (and (get-text-property p 'display) + (eq (get-text-property p 'face) 'org-date)) + (remove-text-properties + p (setq p (next-single-property-change p 'display)) + '(display t)))) + (set-buffer-modified-p bmp))) + (if (featurep 'xemacs) + (remove-text-properties (point-min) (point-max) '(end-glyph t))) + (org-restart-font-lock) + (setq org-table-may-need-update t) + (if org-display-custom-times + (message "Time stamps are overlayed with custom format") + (message "Time stamp overlays removed"))) + +(defun org-display-custom-time (beg end) + "Overlay modified time stamp format over timestamp between BEG and END." + (let* ((ts (buffer-substring beg end)) + t1 w1 with-hm tf time str w2 (off 0)) + (save-match-data + (setq t1 (org-parse-time-string ts t)) + (if (string-match "\\(-[0-9]+:[0-9]+\\)?\\( [.+]?\\+[0-9]+[dwmy]\\(/[0-9]+[dwmy]\\)?\\)?\\'" ts) + (setq off (- (match-end 0) (match-beginning 0))))) + (setq end (- end off)) + (setq w1 (- end beg) + with-hm (and (nth 1 t1) (nth 2 t1)) + tf (funcall (if with-hm 'cdr 'car) org-time-stamp-custom-formats) + time (org-fix-decoded-time t1) + str (org-add-props + (format-time-string + (substring tf 1 -1) (apply 'encode-time time)) + nil 'mouse-face 'highlight) + w2 (length str)) + (if (not (= w2 w1)) + (add-text-properties (1+ beg) (+ 2 beg) + (list 'org-dwidth t 'org-dwidth-n (- w1 w2)))) + (if (featurep 'xemacs) + (progn + (put-text-property beg end 'invisible t) + (put-text-property beg end 'end-glyph (make-glyph str))) + (put-text-property beg end 'display str)))) + +(defun org-translate-time (string) + "Translate all timestamps in STRING to custom format. +But do this only if the variable `org-display-custom-times' is set." + (when org-display-custom-times + (save-match-data + (let* ((start 0) + (re org-ts-regexp-both) + t1 with-hm inactive tf time str beg end) + (while (setq start (string-match re string start)) + (setq beg (match-beginning 0) + end (match-end 0) + t1 (save-match-data + (org-parse-time-string (substring string beg end) t)) + with-hm (and (nth 1 t1) (nth 2 t1)) + inactive (equal (substring string beg (1+ beg)) "[") + tf (funcall (if with-hm 'cdr 'car) + org-time-stamp-custom-formats) + time (org-fix-decoded-time t1) + str (format-time-string + (concat + (if inactive "[" "<") (substring tf 1 -1) + (if inactive "]" ">")) + (apply 'encode-time time)) + string (replace-match str t t string) + start (+ start (length str))))))) + string) + +(defun org-fix-decoded-time (time) + "Set 0 instead of nil for the first 6 elements of time. +Don't touch the rest." + (let ((n 0)) + (mapcar (lambda (x) (if (< (setq n (1+ n)) 7) (or x 0) x)) time))) + +(defun org-days-to-time (timestamp-string) + "Difference between TIMESTAMP-STRING and now in days." + (- (time-to-days (org-time-string-to-time timestamp-string)) + (time-to-days (current-time)))) + +(defun org-deadline-close (timestamp-string &optional ndays) + "Is the time in TIMESTAMP-STRING close to the current date?" + (setq ndays (or ndays (org-get-wdays timestamp-string))) + (and (< (org-days-to-time timestamp-string) ndays) + (not (org-entry-is-done-p)))) + +(defun org-get-wdays (ts) + "Get the deadline lead time appropriate for timestring TS." + (cond + ((<= org-deadline-warning-days 0) + ;; 0 or negative, enforce this value no matter what + (- org-deadline-warning-days)) + ((string-match "-\\([0-9]+\\)\\([dwmy]\\)\\(\\'\\|>\\| \\)" ts) + ;; lead time is specified. + (floor (* (string-to-number (match-string 1 ts)) + (cdr (assoc (match-string 2 ts) + '(("d" . 1) ("w" . 7) + ("m" . 30.4) ("y" . 365.25))))))) + ;; go for the default. + (t org-deadline-warning-days))) + +(defun org-calendar-select-mouse (ev) + "Return to `org-read-date' with the date currently selected. +This is used by `org-read-date' in a temporary keymap for the calendar buffer." + (interactive "e") + (mouse-set-point ev) + (when (calendar-cursor-to-date) + (let* ((date (calendar-cursor-to-date)) + (time (encode-time 0 0 0 (nth 1 date) (nth 0 date) (nth 2 date)))) + (setq org-ans1 (format-time-string "%Y-%m-%d" time))) + (if (active-minibuffer-window) (exit-minibuffer)))) + +(defun org-check-deadlines (ndays) + "Check if there are any deadlines due or past due. +A deadline is considered due if it happens within `org-deadline-warning-days' +days from today's date. If the deadline appears in an entry marked DONE, +it is not shown. The prefix arg NDAYS can be used to test that many +days. If the prefix is a raw \\[universal-argument] prefix, all deadlines are shown." + (interactive "P") + (let* ((org-warn-days + (cond + ((equal ndays '(4)) 100000) + (ndays (prefix-numeric-value ndays)) + (t (abs org-deadline-warning-days)))) + (case-fold-search nil) + (regexp (concat "\\<" org-deadline-string " *<\\([^>]+\\)>")) + (callback + (lambda () (org-deadline-close (match-string 1) org-warn-days)))) + + (message "%d deadlines past-due or due within %d days" + (org-occur regexp nil callback) + org-warn-days))) + +(defun org-check-before-date (date) + "Check if there are deadlines or scheduled entries before DATE." + (interactive (list (org-read-date))) + (let ((case-fold-search nil) + (regexp (concat "\\<\\(" org-deadline-string + "\\|" org-scheduled-string + "\\) *<\\([^>]+\\)>")) + (callback + (lambda () (time-less-p + (org-time-string-to-time (match-string 2)) + (org-time-string-to-time date))))) + (message "%d entries before %s" + (org-occur regexp nil callback) date))) + +(defun org-check-after-date (date) + "Check if there are deadlines or scheduled entries after DATE." + (interactive (list (org-read-date))) + (let ((case-fold-search nil) + (regexp (concat "\\<\\(" org-deadline-string + "\\|" org-scheduled-string + "\\) *<\\([^>]+\\)>")) + (callback + (lambda () (not + (time-less-p + (org-time-string-to-time (match-string 2)) + (org-time-string-to-time date)))))) + (message "%d entries after %s" + (org-occur regexp nil callback) date))) + +(defun org-evaluate-time-range (&optional to-buffer) + "Evaluate a time range by computing the difference between start and end. +Normally the result is just printed in the echo area, but with prefix arg +TO-BUFFER, the result is inserted just after the date stamp into the buffer. +If the time range is actually in a table, the result is inserted into the +next column. +For time difference computation, a year is assumed to be exactly 365 +days in order to avoid rounding problems." + (interactive "P") + (or + (org-clock-update-time-maybe) + (save-excursion + (unless (org-at-date-range-p t) + (goto-char (point-at-bol)) + (re-search-forward org-tr-regexp-both (point-at-eol) t)) + (if (not (org-at-date-range-p t)) + (error "Not at a time-stamp range, and none found in current line"))) + (let* ((ts1 (match-string 1)) + (ts2 (match-string 2)) + (havetime (or (> (length ts1) 15) (> (length ts2) 15))) + (match-end (match-end 0)) + (time1 (org-time-string-to-time ts1)) + (time2 (org-time-string-to-time ts2)) + (t1 (org-float-time time1)) + (t2 (org-float-time time2)) + (diff (abs (- t2 t1))) + (negative (< (- t2 t1) 0)) + ;; (ys (floor (* 365 24 60 60))) + (ds (* 24 60 60)) + (hs (* 60 60)) + (fy "%dy %dd %02d:%02d") + (fy1 "%dy %dd") + (fd "%dd %02d:%02d") + (fd1 "%dd") + (fh "%02d:%02d") + y d h m align) + (if havetime + (setq ; y (floor (/ diff ys)) diff (mod diff ys) + y 0 + d (floor (/ diff ds)) diff (mod diff ds) + h (floor (/ diff hs)) diff (mod diff hs) + m (floor (/ diff 60))) + (setq ; y (floor (/ diff ys)) diff (mod diff ys) + y 0 + d (floor (+ (/ diff ds) 0.5)) + h 0 m 0)) + (if (not to-buffer) + (message "%s" (org-make-tdiff-string y d h m)) + (if (org-at-table-p) + (progn + (goto-char match-end) + (setq align t) + (and (looking-at " *|") (goto-char (match-end 0)))) + (goto-char match-end)) + (if (looking-at + "\\( *-? *[0-9]+y\\)?\\( *[0-9]+d\\)? *[0-9][0-9]:[0-9][0-9]") + (replace-match "")) + (if negative (insert " -")) + (if (> y 0) (insert " " (format (if havetime fy fy1) y d h m)) + (if (> d 0) (insert " " (format (if havetime fd fd1) d h m)) + (insert " " (format fh h m)))) + (if align (org-table-align)) + (message "Time difference inserted"))))) + +(defun org-make-tdiff-string (y d h m) + (let ((fmt "") + (l nil)) + (if (> y 0) (setq fmt (concat fmt "%d year" (if (> y 1) "s" "") " ") + l (push y l))) + (if (> d 0) (setq fmt (concat fmt "%d day" (if (> d 1) "s" "") " ") + l (push d l))) + (if (> h 0) (setq fmt (concat fmt "%d hour" (if (> h 1) "s" "") " ") + l (push h l))) + (if (> m 0) (setq fmt (concat fmt "%d minute" (if (> m 1) "s" "") " ") + l (push m l))) + (apply 'format fmt (nreverse l)))) + +(defun org-time-string-to-time (s) + (apply 'encode-time (org-parse-time-string s))) +(defun org-time-string-to-seconds (s) + (org-float-time (org-time-string-to-time s))) + +(defun org-time-string-to-absolute (s &optional daynr prefer show-all) + "Convert a time stamp to an absolute day number. +If there is a specifier for a cyclic time stamp, get the closest date to +DAYNR. +PREFER and SHOW-ALL are passed through to `org-closest-date'. +the variable date is bound by the calendar when this is called." + (cond + ((and daynr (string-match "\\`%%\\((.*)\\)" s)) + (if (org-diary-sexp-entry (match-string 1 s) "" date) + daynr + (+ daynr 1000))) + ((and daynr (string-match "\\+[0-9]+[dwmy]" s)) + (org-closest-date s (if (and (boundp 'daynr) (integerp daynr)) daynr + (time-to-days (current-time))) (match-string 0 s) + prefer show-all)) + (t (time-to-days (apply 'encode-time (org-parse-time-string s)))))) + +(defun org-days-to-iso-week (days) + "Return the iso week number." + (require 'cal-iso) + (car (calendar-iso-from-absolute days))) + +(defun org-small-year-to-year (year) + "Convert 2-digit years into 4-digit years. +38-99 are mapped into 1938-1999. 1-37 are mapped into 2001-2007. +The year 2000 cannot be abbreviated. Any year larger than 99 +is returned unchanged." + (if (< year 38) + (setq year (+ 2000 year)) + (if (< year 100) + (setq year (+ 1900 year)))) + year) + +(defun org-time-from-absolute (d) + "Return the time corresponding to date D. +D may be an absolute day number, or a calendar-type list (month day year)." + (if (numberp d) (setq d (calendar-gregorian-from-absolute d))) + (encode-time 0 0 0 (nth 1 d) (car d) (nth 2 d))) + +(defun org-calendar-holiday () + "List of holidays, for Diary display in Org-mode." + (require 'holidays) + (let ((hl (funcall + (if (fboundp 'calendar-check-holidays) + 'calendar-check-holidays 'check-calendar-holidays) date))) + (if hl (mapconcat 'identity hl "; ")))) + +(defun org-diary-sexp-entry (sexp entry date) + "Process a SEXP diary ENTRY for DATE." + (require 'diary-lib) + (let ((result (if calendar-debug-sexp + (let ((stack-trace-on-error t)) + (eval (car (read-from-string sexp)))) + (condition-case nil + (eval (car (read-from-string sexp))) + (error + (beep) + (message "Bad sexp at line %d in %s: %s" + (org-current-line) + (buffer-file-name) sexp) + (sleep-for 2)))))) + (cond ((stringp result) (split-string result "; ")) + ((and (consp result) + (not (consp (cdr result))) + (stringp (cdr result))) (cdr result)) + ((and (consp result) + (stringp (car result))) result) + (result entry) + (t nil)))) + +(defun org-diary-to-ical-string (frombuf) + "Get iCalendar entries from diary entries in buffer FROMBUF. +This uses the icalendar.el library." + (let* ((tmpdir (if (featurep 'xemacs) + (temp-directory) + temporary-file-directory)) + (tmpfile (make-temp-name + (expand-file-name "orgics" tmpdir))) + buf rtn b e) + (with-current-buffer frombuf + (icalendar-export-region (point-min) (point-max) tmpfile) + (setq buf (find-buffer-visiting tmpfile)) + (set-buffer buf) + (goto-char (point-min)) + (if (re-search-forward "^BEGIN:VEVENT" nil t) + (setq b (match-beginning 0))) + (goto-char (point-max)) + (if (re-search-backward "^END:VEVENT" nil t) + (setq e (match-end 0))) + (setq rtn (if (and b e) (concat (buffer-substring b e) "\n") ""))) + (kill-buffer buf) + (delete-file tmpfile) + rtn)) + +(defun org-closest-date (start current change prefer show-all) + "Find the date closest to CURRENT that is consistent with START and CHANGE. +When PREFER is `past' return a date that is either CURRENT or past. +When PREFER is `future', return a date that is either CURRENT or future. +When SHOW-ALL is nil, only return the current occurrence of a time stamp." + ;; Make the proper lists from the dates + (catch 'exit + (let ((a1 '(("d" . day) ("w" . week) ("m" . month) ("y" . year))) + dn dw sday cday n1 n2 n0 + d m y y1 y2 date1 date2 nmonths nm ny m2) + + (setq start (org-date-to-gregorian start) + current (org-date-to-gregorian + (if show-all + current + (time-to-days (current-time)))) + sday (calendar-absolute-from-gregorian start) + cday (calendar-absolute-from-gregorian current)) + + (if (<= cday sday) (throw 'exit sday)) + + (if (string-match "\\(\\+[0-9]+\\)\\([dwmy]\\)" change) + (setq dn (string-to-number (match-string 1 change)) + dw (cdr (assoc (match-string 2 change) a1))) + (error "Invalid change specifier: %s" change)) + (if (eq dw 'week) (setq dw 'day dn (* 7 dn))) + (cond + ((eq dw 'day) + (setq n1 (+ sday (* dn (floor (/ (- cday sday) dn)))) + n2 (+ n1 dn))) + ((eq dw 'year) + (setq d (nth 1 start) m (car start) y1 (nth 2 start) y2 (nth 2 current)) + (setq y1 (+ (* (floor (/ (- y2 y1) dn)) dn) y1)) + (setq date1 (list m d y1) + n1 (calendar-absolute-from-gregorian date1) + date2 (list m d (+ y1 (* (if (< n1 cday) 1 -1) dn))) + n2 (calendar-absolute-from-gregorian date2))) + ((eq dw 'month) + ;; approx number of month between the two dates + (setq nmonths (floor (/ (- cday sday) 30.436875))) + ;; How often does dn fit in there? + (setq d (nth 1 start) m (car start) y (nth 2 start) + nm (* dn (max 0 (1- (floor (/ nmonths dn))))) + m (+ m nm) + ny (floor (/ m 12)) + y (+ y ny) + m (- m (* ny 12))) + (while (> m 12) (setq m (- m 12) y (1+ y))) + (setq n1 (calendar-absolute-from-gregorian (list m d y))) + (setq m2 (+ m dn) y2 y) + (if (> m2 12) (setq y2 (1+ y2) m2 (- m2 12))) + (setq n2 (calendar-absolute-from-gregorian (list m2 d y2))) + (while (<= n2 cday) + (setq n1 n2 m m2 y y2) + (setq m2 (+ m dn) y2 y) + (if (> m2 12) (setq y2 (1+ y2) m2 (- m2 12))) + (setq n2 (calendar-absolute-from-gregorian (list m2 d y2)))))) + ;; Make sure n1 is the earlier date + (setq n0 n1 n1 (min n1 n2) n2 (max n0 n2)) + (if show-all + (cond + ((eq prefer 'past) (if (= cday n2) n2 n1)) + ((eq prefer 'future) (if (= cday n1) n1 n2)) + (t (if (> (abs (- cday n1)) (abs (- cday n2))) n2 n1))) + (cond + ((eq prefer 'past) (if (= cday n2) n2 n1)) + ((eq prefer 'future) (if (= cday n1) n1 n2)) + (t (if (= cday n1) n1 n2))))))) + +(defun org-date-to-gregorian (date) + "Turn any specification of DATE into a Gregorian date for the calendar." + (cond ((integerp date) (calendar-gregorian-from-absolute date)) + ((and (listp date) (= (length date) 3)) date) + ((stringp date) + (setq date (org-parse-time-string date)) + (list (nth 4 date) (nth 3 date) (nth 5 date))) + ((listp date) + (list (nth 4 date) (nth 3 date) (nth 5 date))))) + +(defun org-parse-time-string (s &optional nodefault) + "Parse the standard Org-mode time string. +This should be a lot faster than the normal `parse-time-string'. +If time is not given, defaults to 0:00. However, with optional NODEFAULT, +hour and minute fields will be nil if not given." + (if (string-match org-ts-regexp0 s) + (list 0 + (if (or (match-beginning 8) (not nodefault)) + (string-to-number (or (match-string 8 s) "0"))) + (if (or (match-beginning 7) (not nodefault)) + (string-to-number (or (match-string 7 s) "0"))) + (string-to-number (match-string 4 s)) + (string-to-number (match-string 3 s)) + (string-to-number (match-string 2 s)) + nil nil nil) + (error "Not a standard Org-mode time string: %s" s))) + +(defun org-timestamp-up (&optional arg) + "Increase the date item at the cursor by one. +If the cursor is on the year, change the year. If it is on the month or +the day, change that. +With prefix ARG, change by that many units." + (interactive "p") + (org-timestamp-change (prefix-numeric-value arg) nil 'updown)) + +(defun org-timestamp-down (&optional arg) + "Decrease the date item at the cursor by one. +If the cursor is on the year, change the year. If it is on the month or +the day, change that. +With prefix ARG, change by that many units." + (interactive "p") + (org-timestamp-change (- (prefix-numeric-value arg)) nil 'updown)) + +(defun org-timestamp-up-day (&optional arg) + "Increase the date in the time stamp by one day. +With prefix ARG, change that many days." + (interactive "p") + (if (and (not (org-at-timestamp-p t)) + (org-on-heading-p)) + (org-todo 'up) + (org-timestamp-change (prefix-numeric-value arg) 'day 'updown))) + +(defun org-timestamp-down-day (&optional arg) + "Decrease the date in the time stamp by one day. +With prefix ARG, change that many days." + (interactive "p") + (if (and (not (org-at-timestamp-p t)) + (org-on-heading-p)) + (org-todo 'down) + (org-timestamp-change (- (prefix-numeric-value arg)) 'day) 'updown)) + +(defun org-at-timestamp-p (&optional inactive-ok) + "Determine if the cursor is in or at a timestamp." + (interactive) + (let* ((tsr (if inactive-ok org-ts-regexp3 org-ts-regexp2)) + (pos (point)) + (ans (or (looking-at tsr) + (save-excursion + (skip-chars-backward "^[<\n\r\t") + (if (> (point) (point-min)) (backward-char 1)) + (and (looking-at tsr) + (> (- (match-end 0) pos) -1)))))) + (and ans + (boundp 'org-ts-what) + (setq org-ts-what + (cond + ((= pos (match-beginning 0)) 'bracket) + ((= pos (1- (match-end 0))) 'bracket) + ((org-pos-in-match-range pos 2) 'year) + ((org-pos-in-match-range pos 3) 'month) + ((org-pos-in-match-range pos 7) 'hour) + ((org-pos-in-match-range pos 8) 'minute) + ((or (org-pos-in-match-range pos 4) + (org-pos-in-match-range pos 5)) 'day) + ((and (> pos (or (match-end 8) (match-end 5))) + (< pos (match-end 0))) + (- pos (or (match-end 8) (match-end 5)))) + (t 'day)))) + ans)) + +(defun org-toggle-timestamp-type () + "Toggle the type (<active> or [inactive]) of a time stamp." + (interactive) + (when (org-at-timestamp-p t) + (let ((beg (match-beginning 0)) (end (match-end 0)) + (map '((?\[ . "<") (?\] . ">") (?< . "[") (?> . "]")))) + (save-excursion + (goto-char beg) + (while (re-search-forward "[][<>]" end t) + (replace-match (cdr (assoc (char-after (match-beginning 0)) map)) + t t))) + (message "Timestamp is now %sactive" + (if (equal (char-after beg) ?<) "" "in"))))) + +(defun org-timestamp-change (n &optional what updown) + "Change the date in the time stamp at point. +The date will be changed by N times WHAT. WHAT can be `day', `month', +`year', `minute', `second'. If WHAT is not given, the cursor position +in the timestamp determines what will be changed." + (let ((pos (point)) + with-hm inactive + (dm (max (nth 1 org-time-stamp-rounding-minutes) 1)) + org-ts-what + extra rem + ts time time0) + (if (not (org-at-timestamp-p t)) + (error "Not at a timestamp")) + (if (and (not what) (eq org-ts-what 'bracket)) + (org-toggle-timestamp-type) + (if (and (not what) (not (eq org-ts-what 'day)) + org-display-custom-times + (get-text-property (point) 'display) + (not (get-text-property (1- (point)) 'display))) + (setq org-ts-what 'day)) + (setq org-ts-what (or what org-ts-what) + inactive (= (char-after (match-beginning 0)) ?\[) + ts (match-string 0)) + (replace-match "") + (if (string-match + "\\(\\(-[012][0-9]:[0-5][0-9]\\)?\\( +[.+]?[-+][0-9]+[dwmy]\\(/[0-9]+[dwmy]\\)?\\)*\\)[]>]" + ts) + (setq extra (match-string 1 ts))) + (if (string-match "^.\\{10\\}.*?[0-9]+:[0-9][0-9]" ts) + (setq with-hm t)) + (setq time0 (org-parse-time-string ts)) + (when (and updown + (eq org-ts-what 'minute) + (not current-prefix-arg)) + ;; This looks like s-up and s-down. Change by one rounding step. + (setq n (* dm (cond ((> n 0) 1) ((< n 0) -1) (t 0)))) + (when (not (= 0 (setq rem (% (nth 1 time0) dm)))) + (setcar (cdr time0) (+ (nth 1 time0) + (if (> n 0) (- rem) (- dm rem)))))) + (setq time + (encode-time (or (car time0) 0) + (+ (if (eq org-ts-what 'minute) n 0) (nth 1 time0)) + (+ (if (eq org-ts-what 'hour) n 0) (nth 2 time0)) + (+ (if (eq org-ts-what 'day) n 0) (nth 3 time0)) + (+ (if (eq org-ts-what 'month) n 0) (nth 4 time0)) + (+ (if (eq org-ts-what 'year) n 0) (nth 5 time0)) + (nthcdr 6 time0))) + (when (and (member org-ts-what '(hour minute)) + extra + (string-match "-\\([012][0-9]\\):\\([0-5][0-9]\\)" extra)) + (setq extra (org-modify-ts-extra + extra + (if (eq org-ts-what 'hour) 2 5) + n dm))) + (when (integerp org-ts-what) + (setq extra (org-modify-ts-extra extra org-ts-what n dm))) + (if (eq what 'calendar) + (let ((cal-date (org-get-date-from-calendar))) + (setcar (nthcdr 4 time0) (nth 0 cal-date)) ; month + (setcar (nthcdr 3 time0) (nth 1 cal-date)) ; day + (setcar (nthcdr 5 time0) (nth 2 cal-date)) ; year + (setcar time0 (or (car time0) 0)) + (setcar (nthcdr 1 time0) (or (nth 1 time0) 0)) + (setcar (nthcdr 2 time0) (or (nth 2 time0) 0)) + (setq time (apply 'encode-time time0)))) + (setq org-last-changed-timestamp + (org-insert-time-stamp time with-hm inactive nil nil extra)) + (org-clock-update-time-maybe) + (goto-char pos) + ;; Try to recenter the calendar window, if any + (if (and org-calendar-follow-timestamp-change + (get-buffer-window "*Calendar*" t) + (memq org-ts-what '(day month year))) + (org-recenter-calendar (time-to-days time)))))) + +(defun org-modify-ts-extra (s pos n dm) + "Change the different parts of the lead-time and repeat fields in timestamp." + (let ((idx '(("d" . 0) ("w" . 1) ("m" . 2) ("y" . 3) ("d" . -1) ("y" . 4))) + ng h m new rem) + (when (string-match "\\(-\\([012][0-9]\\):\\([0-5][0-9]\\)\\)?\\( +\\+\\([0-9]+\\)\\([dmwy]\\)\\)?\\( +-\\([0-9]+\\)\\([dmwy]\\)\\)?" s) + (cond + ((or (org-pos-in-match-range pos 2) + (org-pos-in-match-range pos 3)) + (setq m (string-to-number (match-string 3 s)) + h (string-to-number (match-string 2 s))) + (if (org-pos-in-match-range pos 2) + (setq h (+ h n)) + (setq n (* dm (org-no-warnings (signum n)))) + (when (not (= 0 (setq rem (% m dm)))) + (setq m (+ m (if (> n 0) (- rem) (- dm rem))))) + (setq m (+ m n))) + (if (< m 0) (setq m (+ m 60) h (1- h))) + (if (> m 59) (setq m (- m 60) h (1+ h))) + (setq h (min 24 (max 0 h))) + (setq ng 1 new (format "-%02d:%02d" h m))) + ((org-pos-in-match-range pos 6) + (setq ng 6 new (car (rassoc (+ n (cdr (assoc (match-string 6 s) idx))) idx)))) + ((org-pos-in-match-range pos 5) + (setq ng 5 new (format "%d" (max 1 (+ n (string-to-number (match-string 5 s))))))) + + ((org-pos-in-match-range pos 9) + (setq ng 9 new (car (rassoc (+ n (cdr (assoc (match-string 9 s) idx))) idx)))) + ((org-pos-in-match-range pos 8) + (setq ng 8 new (format "%d" (max 0 (+ n (string-to-number (match-string 8 s)))))))) + + (when ng + (setq s (concat + (substring s 0 (match-beginning ng)) + new + (substring s (match-end ng)))))) + s)) + +(defun org-recenter-calendar (date) + "If the calendar is visible, recenter it to DATE." + (let* ((win (selected-window)) + (cwin (get-buffer-window "*Calendar*" t)) + (calendar-move-hook nil)) + (when cwin + (select-window cwin) + (calendar-goto-date (if (listp date) date + (calendar-gregorian-from-absolute date))) + (select-window win)))) + +(defun org-goto-calendar (&optional arg) + "Go to the Emacs calendar at the current date. +If there is a time stamp in the current line, go to that date. +A prefix ARG can be used to force the current date." + (interactive "P") + (let ((tsr org-ts-regexp) diff + (calendar-move-hook nil) + (calendar-view-holidays-initially-flag nil) + (calendar-view-diary-initially-flag nil)) + (if (or (org-at-timestamp-p) + (save-excursion + (beginning-of-line 1) + (looking-at (concat ".*" tsr)))) + (let ((d1 (time-to-days (current-time))) + (d2 (time-to-days + (org-time-string-to-time (match-string 1))))) + (setq diff (- d2 d1)))) + (calendar) + (calendar-goto-today) + (if (and diff (not arg)) (calendar-forward-day diff)))) + +(defun org-get-date-from-calendar () + "Return a list (month day year) of date at point in calendar." + (with-current-buffer "*Calendar*" + (save-match-data + (calendar-cursor-to-date)))) + +(defun org-date-from-calendar () + "Insert time stamp corresponding to cursor date in *Calendar* buffer. +If there is already a time stamp at the cursor position, update it." + (interactive) + (if (org-at-timestamp-p t) + (org-timestamp-change 0 'calendar) + (let ((cal-date (org-get-date-from-calendar))) + (org-insert-time-stamp + (encode-time 0 0 0 (nth 1 cal-date) (car cal-date) (nth 2 cal-date)))))) + +(defun org-minutes-to-hh:mm-string (m) + "Compute H:MM from a number of minutes." + (let ((h (/ m 60))) + (setq m (- m (* 60 h))) + (format org-time-clocksum-format h m))) + +(defun org-hh:mm-string-to-minutes (s) + "Convert a string H:MM to a number of minutes. +If the string is just a number, interpret it as minutes. +In fact, the first hh:mm or number in the string will be taken, +there can be extra stuff in the string. +If no number is found, the return value is 0." + (cond + ((string-match "\\([0-9]+\\):\\([0-9]+\\)" s) + (+ (* (string-to-number (match-string 1 s)) 60) + (string-to-number (match-string 2 s)))) + ((string-match "\\([0-9]+\\)" s) + (string-to-number (match-string 1 s))) + (t 0))) + +;;;; Files + +(defun org-save-all-org-buffers () + "Save all Org-mode buffers without user confirmation." + (interactive) + (message "Saving all Org-mode buffers...") + (save-some-buffers t 'org-mode-p) + (when (featurep 'org-id) (org-id-locations-save)) + (message "Saving all Org-mode buffers... done")) + +(defun org-revert-all-org-buffers () + "Revert all Org-mode buffers. +Prompt for confirmation when there are unsaved changes. +Be sure you know what you are doing before letting this function +overwrite your changes. + +This function is useful in a setup where one tracks org files +with a version control system, to revert on one machine after pulling +changes from another. I believe the procedure must be like this: + +1. M-x org-save-all-org-buffers +2. Pull changes from the other machine, resolve conflicts +3. M-x org-revert-all-org-buffers" + (interactive) + (unless (yes-or-no-p "Revert all Org buffers from their files? ") + (error "Abort")) + (save-excursion + (save-window-excursion + (mapc + (lambda (b) + (when (and (with-current-buffer b (org-mode-p)) + (with-current-buffer b buffer-file-name)) + (switch-to-buffer b) + (revert-buffer t 'no-confirm))) + (buffer-list)) + (when (and (featurep 'org-id) org-id-track-globally) + (org-id-locations-load))))) + +;;;; Agenda files + +;;;###autoload +(defun org-switchb (&optional arg) + "Switch between Org buffers. +With a prefix argument, restrict available to files. +With two prefix arguments, restrict available buffers to agenda files. + +Defaults to `iswitchb' for buffer name completion. +Set `org-completion-use-ido' to make it use ido instead." + (interactive "P") + (let ((blist (cond ((equal arg '(4)) (org-buffer-list 'files)) + ((equal arg '(16)) (org-buffer-list 'agenda)) + (t (org-buffer-list)))) + (org-completion-use-iswitchb org-completion-use-iswitchb) + (org-completion-use-ido org-completion-use-ido)) + (unless (or org-completion-use-ido org-completion-use-iswitchb) + (setq org-completion-use-iswitchb t)) + (switch-to-buffer + (org-icompleting-read "Org buffer: " + (mapcar 'list (mapcar 'buffer-name blist)) + nil t)))) + +;;; Define some older names previously used for this functionality +;;;###autoload +(defalias 'org-ido-switchb 'org-switchb) +;;;###autoload +(defalias 'org-iswitchb 'org-switchb) + +(defun org-buffer-list (&optional predicate exclude-tmp) + "Return a list of Org buffers. +PREDICATE can be `export', `files' or `agenda'. + +export restrict the list to Export buffers. +files restrict the list to buffers visiting Org files. +agenda restrict the list to buffers visiting agenda files. + +If EXCLUDE-TMP is non-nil, ignore temporary buffers." + (let* ((bfn nil) + (agenda-files (and (eq predicate 'agenda) + (mapcar 'file-truename (org-agenda-files t)))) + (filter + (cond + ((eq predicate 'files) + (lambda (b) (with-current-buffer b (eq major-mode 'org-mode)))) + ((eq predicate 'export) + (lambda (b) (string-match "\*Org .*Export" (buffer-name b)))) + ((eq predicate 'agenda) + (lambda (b) + (with-current-buffer b + (and (eq major-mode 'org-mode) + (setq bfn (buffer-file-name b)) + (member (file-truename bfn) agenda-files))))) + (t (lambda (b) (with-current-buffer b + (or (eq major-mode 'org-mode) + (string-match "\*Org .*Export" + (buffer-name b))))))))) + (delq nil + (mapcar + (lambda(b) + (if (and (funcall filter b) + (or (not exclude-tmp) + (not (string-match "tmp" (buffer-name b))))) + b + nil)) + (buffer-list))))) + +(defun org-agenda-files (&optional unrestricted archives) + "Get the list of agenda files. +Optional UNRESTRICTED means return the full list even if a restriction +is currently in place. +When ARCHIVES is t, include all archive files that are really being +used by the agenda files. If ARCHIVE is `ifmode', do this only if +`org-agenda-archives-mode' is t." + (let ((files + (cond + ((and (not unrestricted) (get 'org-agenda-files 'org-restrict))) + ((stringp org-agenda-files) (org-read-agenda-file-list)) + ((listp org-agenda-files) org-agenda-files) + (t (error "Invalid value of `org-agenda-files'"))))) + (setq files (apply 'append + (mapcar (lambda (f) + (if (file-directory-p f) + (directory-files + f t org-agenda-file-regexp) + (list f))) + files))) + (when org-agenda-skip-unavailable-files + (setq files (delq nil + (mapcar (function + (lambda (file) + (and (file-readable-p file) file))) + files)))) + (when (or (eq archives t) + (and (eq archives 'ifmode) (eq org-agenda-archives-mode t))) + (setq files (org-add-archive-files files))) + files)) + +(defun org-agenda-file-p (&optional file) + "Return non-nil, if FILE is an agenda file. +If FILE is omitted, use the file associated with the current +buffer." + (member (or file (buffer-file-name)) + (org-agenda-files t))) + +(defun org-edit-agenda-file-list () + "Edit the list of agenda files. +Depending on setup, this either uses customize to edit the variable +`org-agenda-files', or it visits the file that is holding the list. In the +latter case, the buffer is set up in a way that saving it automatically kills +the buffer and restores the previous window configuration." + (interactive) + (if (stringp org-agenda-files) + (let ((cw (current-window-configuration))) + (find-file org-agenda-files) + (org-set-local 'org-window-configuration cw) + (org-add-hook 'after-save-hook + (lambda () + (set-window-configuration + (prog1 org-window-configuration + (kill-buffer (current-buffer)))) + (org-install-agenda-files-menu) + (message "New agenda file list installed")) + nil 'local) + (message "%s" (substitute-command-keys + "Edit list and finish with \\[save-buffer]"))) + (customize-variable 'org-agenda-files))) + +(defun org-store-new-agenda-file-list (list) + "Set new value for the agenda file list and save it correctly." + (if (stringp org-agenda-files) + (let ((fe (org-read-agenda-file-list t)) b u) + (while (setq b (find-buffer-visiting org-agenda-files)) + (kill-buffer b)) + (with-temp-file org-agenda-files + (insert + (mapconcat + (lambda (f) ;; Keep un-expanded entries. + (if (setq u (assoc f fe)) + (cdr u) + f)) + list "\n") + "\n"))) + (let ((org-mode-hook nil) (org-inhibit-startup t) + (org-insert-mode-line-in-empty-file nil)) + (setq org-agenda-files list) + (customize-save-variable 'org-agenda-files org-agenda-files)))) + +(defun org-read-agenda-file-list (&optional pair-with-expansion) + "Read the list of agenda files from a file. +If PAIR-WITH-EXPANSION is t return pairs with un-expanded +filenames, used by `org-store-new-agenda-file-list' to write back +un-expanded file names." + (when (file-directory-p org-agenda-files) + (error "`org-agenda-files' cannot be a single directory")) + (when (stringp org-agenda-files) + (with-temp-buffer + (insert-file-contents org-agenda-files) + (mapcar + (lambda (f) + (let ((e (expand-file-name (substitute-in-file-name f) + org-directory))) + (if pair-with-expansion + (cons e f) + e))) + (org-split-string (buffer-string) "[ \t\r\n]*?[\r\n][ \t\r\n]*"))))) + +;;;###autoload +(defun org-cycle-agenda-files () + "Cycle through the files in `org-agenda-files'. +If the current buffer visits an agenda file, find the next one in the list. +If the current buffer does not, find the first agenda file." + (interactive) + (let* ((fs (org-agenda-files t)) + (files (append fs (list (car fs)))) + (tcf (if buffer-file-name (file-truename buffer-file-name))) + file) + (unless files (error "No agenda files")) + (catch 'exit + (while (setq file (pop files)) + (if (equal (file-truename file) tcf) + (when (car files) + (find-file (car files)) + (throw 'exit t)))) + (find-file (car fs))) + (if (buffer-base-buffer) (switch-to-buffer (buffer-base-buffer))))) + +(defun org-agenda-file-to-front (&optional to-end) + "Move/add the current file to the top of the agenda file list. +If the file is not present in the list, it is added to the front. If it is +present, it is moved there. With optional argument TO-END, add/move to the +end of the list." + (interactive "P") + (let ((org-agenda-skip-unavailable-files nil) + (file-alist (mapcar (lambda (x) + (cons (file-truename x) x)) + (org-agenda-files t))) + (ctf (file-truename buffer-file-name)) + x had) + (setq x (assoc ctf file-alist) had x) + + (if (not x) (setq x (cons ctf (abbreviate-file-name buffer-file-name)))) + (if to-end + (setq file-alist (append (delq x file-alist) (list x))) + (setq file-alist (cons x (delq x file-alist)))) + (org-store-new-agenda-file-list (mapcar 'cdr file-alist)) + (org-install-agenda-files-menu) + (message "File %s to %s of agenda file list" + (if had "moved" "added") (if to-end "end" "front")))) + +(defun org-remove-file (&optional file) + "Remove current file from the list of files in variable `org-agenda-files'. +These are the files which are being checked for agenda entries. +Optional argument FILE means use this file instead of the current." + (interactive) + (let* ((org-agenda-skip-unavailable-files nil) + (file (or file buffer-file-name)) + (true-file (file-truename file)) + (afile (abbreviate-file-name file)) + (files (delq nil (mapcar + (lambda (x) + (if (equal true-file + (file-truename x)) + nil x)) + (org-agenda-files t))))) + (if (not (= (length files) (length (org-agenda-files t)))) + (progn + (org-store-new-agenda-file-list files) + (org-install-agenda-files-menu) + (message "Removed file: %s" afile)) + (message "File was not in list: %s (not removed)" afile)))) + +(defun org-file-menu-entry (file) + (vector file (list 'find-file file) t)) + +(defun org-check-agenda-file (file) + "Make sure FILE exists. If not, ask user what to do." + (when (not (file-exists-p file)) + (message "non-existent agenda file %s. [R]emove from list or [A]bort?" + (abbreviate-file-name file)) + (let ((r (downcase (read-char-exclusive)))) + (cond + ((equal r ?r) + (org-remove-file file) + (throw 'nextfile t)) + (t (error "Abort")))))) + +(defun org-get-agenda-file-buffer (file) + "Get a buffer visiting FILE. If the buffer needs to be created, add +it to the list of buffers which might be released later." + (let ((buf (org-find-base-buffer-visiting file))) + (if buf + buf ; just return it + ;; Make a new buffer and remember it + (setq buf (find-file-noselect file)) + (if buf (push buf org-agenda-new-buffers)) + buf))) + +(defun org-release-buffers (blist) + "Release all buffers in list, asking the user for confirmation when needed. +When a buffer is unmodified, it is just killed. When modified, it is saved +\(if the user agrees) and then killed." + (let (buf file) + (while (setq buf (pop blist)) + (setq file (buffer-file-name buf)) + (when (and (buffer-modified-p buf) + file + (y-or-n-p (format "Save file %s? " file))) + (with-current-buffer buf (save-buffer))) + (kill-buffer buf)))) + +(defun org-prepare-agenda-buffers (files) + "Create buffers for all agenda files, protect archived trees and comments." + (interactive) + (let ((pa '(:org-archived t)) + (pc '(:org-comment t)) + (pall '(:org-archived t :org-comment t)) + (inhibit-read-only t) + (rea (concat ":" org-archive-tag ":")) + bmp file re) + (save-excursion + (save-restriction + (while (setq file (pop files)) + (catch 'nextfile + (if (bufferp file) + (set-buffer file) + (org-check-agenda-file file) + (set-buffer (org-get-agenda-file-buffer file))) + (widen) + (setq bmp (buffer-modified-p)) + (org-refresh-category-properties) + (setq org-todo-keywords-for-agenda + (append org-todo-keywords-for-agenda org-todo-keywords-1)) + (setq org-done-keywords-for-agenda + (append org-done-keywords-for-agenda org-done-keywords)) + (setq org-todo-keyword-alist-for-agenda + (append org-todo-keyword-alist-for-agenda org-todo-key-alist)) + (setq org-drawers-for-agenda + (append org-drawers-for-agenda org-drawers)) + (setq org-tag-alist-for-agenda + (append org-tag-alist-for-agenda org-tag-alist)) + + (save-excursion + (remove-text-properties (point-min) (point-max) pall) + (when org-agenda-skip-archived-trees + (goto-char (point-min)) + (while (re-search-forward rea nil t) + (if (org-on-heading-p t) + (add-text-properties (point-at-bol) (org-end-of-subtree t) pa)))) + (goto-char (point-min)) + (setq re (concat "^\\*+ +" org-comment-string "\\>")) + (while (re-search-forward re nil t) + (add-text-properties + (match-beginning 0) (org-end-of-subtree t) pc))) + (set-buffer-modified-p bmp))))) + (setq org-todo-keywords-for-agenda + (org-uniquify org-todo-keywords-for-agenda)) + (setq org-todo-keyword-alist-for-agenda + (org-uniquify org-todo-keyword-alist-for-agenda) + org-tag-alist-for-agenda (org-uniquify org-tag-alist-for-agenda)))) + +;;;; Embedded LaTeX + +(defvar org-cdlatex-mode-map (make-sparse-keymap) + "Keymap for the minor `org-cdlatex-mode'.") + +(org-defkey org-cdlatex-mode-map "_" 'org-cdlatex-underscore-caret) +(org-defkey org-cdlatex-mode-map "^" 'org-cdlatex-underscore-caret) +(org-defkey org-cdlatex-mode-map "`" 'cdlatex-math-symbol) +(org-defkey org-cdlatex-mode-map "'" 'org-cdlatex-math-modify) +(org-defkey org-cdlatex-mode-map "\C-c{" 'cdlatex-environment) + +(defvar org-cdlatex-texmathp-advice-is-done nil + "Flag remembering if we have applied the advice to texmathp already.") + +(define-minor-mode org-cdlatex-mode + "Toggle the minor `org-cdlatex-mode'. +This mode supports entering LaTeX environment and math in LaTeX fragments +in Org-mode. +\\{org-cdlatex-mode-map}" + nil " OCDL" nil + (when org-cdlatex-mode (require 'cdlatex)) + (unless org-cdlatex-texmathp-advice-is-done + (setq org-cdlatex-texmathp-advice-is-done t) + (defadvice texmathp (around org-math-always-on activate) + "Always return t in org-mode buffers. +This is because we want to insert math symbols without dollars even outside +the LaTeX math segments. If Orgmode thinks that point is actually inside +an embedded LaTeX fragment, let texmathp do its job. +\\[org-cdlatex-mode-map]" + (interactive) + (let (p) + (cond + ((not (org-mode-p)) ad-do-it) + ((eq this-command 'cdlatex-math-symbol) + (setq ad-return-value t + texmathp-why '("cdlatex-math-symbol in org-mode" . 0))) + (t + (let ((p (org-inside-LaTeX-fragment-p))) + (if (and p (member (car p) (plist-get org-format-latex-options :matchers))) + (setq ad-return-value t + texmathp-why '("Org-mode embedded math" . 0)) + (if p ad-do-it))))))))) + +(defun turn-on-org-cdlatex () + "Unconditionally turn on `org-cdlatex-mode'." + (org-cdlatex-mode 1)) + +(defun org-inside-LaTeX-fragment-p () + "Test if point is inside a LaTeX fragment. +I.e. after a \\begin, \\(, \\[, $, or $$, without the corresponding closing +sequence appearing also before point. +Even though the matchers for math are configurable, this function assumes +that \\begin, \\(, \\[, and $$ are always used. Only the single dollar +delimiters are skipped when they have been removed by customization. +The return value is nil, or a cons cell with the delimiter and +and the position of this delimiter. + +This function does a reasonably good job, but can locally be fooled by +for example currency specifications. For example it will assume being in +inline math after \"$22.34\". The LaTeX fragment formatter will only format +fragments that are properly closed, but during editing, we have to live +with the uncertainty caused by missing closing delimiters. This function +looks only before point, not after." + (catch 'exit + (let ((pos (point)) + (dodollar (member "$" (plist-get org-format-latex-options :matchers))) + (lim (progn + (re-search-backward (concat "^\\(" paragraph-start "\\)") nil t) + (point))) + dd-on str (start 0) m re) + (goto-char pos) + (when dodollar + (setq str (concat (buffer-substring lim (point)) "\000 X$.") + re (nth 1 (assoc "$" org-latex-regexps))) + (while (string-match re str start) + (cond + ((= (match-end 0) (length str)) + (throw 'exit (cons "$" (+ lim (match-beginning 0) 1)))) + ((= (match-end 0) (- (length str) 5)) + (throw 'exit nil)) + (t (setq start (match-end 0)))))) + (when (setq m (re-search-backward "\\(\\\\begin{[^}]*}\\|\\\\(\\|\\\\\\[\\)\\|\\(\\\\end{[^}]*}\\|\\\\)\\|\\\\\\]\\)\\|\\(\\$\\$\\)" lim t)) + (goto-char pos) + (and (match-beginning 1) (throw 'exit (cons (match-string 1) m))) + (and (match-beginning 2) (throw 'exit nil)) + ;; count $$ + (while (re-search-backward "\\$\\$" lim t) + (setq dd-on (not dd-on))) + (goto-char pos) + (if dd-on (cons "$$" m)))))) + +(defun org-inside-latex-macro-p () + "Is point inside a LaTeX macro or its arguments?" + (save-match-data + (org-in-regexp + "\\\\[a-zA-Z]+\\*?\\(\\(\\[[^][\n{}]*\\]\\)\\|\\({[^{}\n]*}\\)\\)*"))) + +(defun org-try-cdlatex-tab () + "Check if it makes sense to execute `cdlatex-tab', and do it if yes. +It makes sense to do so if `org-cdlatex-mode' is active and if the cursor is + - inside a LaTeX fragment, or + - after the first word in a line, where an abbreviation expansion could + insert a LaTeX environment." + (when org-cdlatex-mode + (cond + ((save-excursion + (skip-chars-backward "a-zA-Z0-9*") + (skip-chars-backward " \t") + (bolp)) + (cdlatex-tab) t) + ((org-inside-LaTeX-fragment-p) + (cdlatex-tab) t) + (t nil)))) + +(defun org-cdlatex-underscore-caret (&optional arg) + "Execute `cdlatex-sub-superscript' in LaTeX fragments. +Revert to the normal definition outside of these fragments." + (interactive "P") + (if (org-inside-LaTeX-fragment-p) + (call-interactively 'cdlatex-sub-superscript) + (let (org-cdlatex-mode) + (call-interactively (key-binding (vector last-input-event)))))) + +(defun org-cdlatex-math-modify (&optional arg) + "Execute `cdlatex-math-modify' in LaTeX fragments. +Revert to the normal definition outside of these fragments." + (interactive "P") + (if (org-inside-LaTeX-fragment-p) + (call-interactively 'cdlatex-math-modify) + (let (org-cdlatex-mode) + (call-interactively (key-binding (vector last-input-event)))))) + +(defvar org-latex-fragment-image-overlays nil + "List of overlays carrying the images of latex fragments.") +(make-variable-buffer-local 'org-latex-fragment-image-overlays) + +(defun org-remove-latex-fragment-image-overlays () + "Remove all overlays with LaTeX fragment images in current buffer." + (mapc 'delete-overlay org-latex-fragment-image-overlays) + (setq org-latex-fragment-image-overlays nil)) + +(defun org-preview-latex-fragment (&optional subtree) + "Preview the LaTeX fragment at point, or all locally or globally. +If the cursor is in a LaTeX fragment, create the image and overlay +it over the source code. If there is no fragment at point, display +all fragments in the current text, from one headline to the next. With +prefix SUBTREE, display all fragments in the current subtree. With a +double prefix arg \\[universal-argument] \\[universal-argument], or when \ +the cursor is before the first headline, +display all fragments in the buffer. +The images can be removed again with \\[org-ctrl-c-ctrl-c]." + (interactive "P") + (org-remove-latex-fragment-image-overlays) + (save-excursion + (save-restriction + (let (beg end at msg) + (cond + ((or (equal subtree '(16)) + (not (save-excursion + (re-search-backward (concat "^" outline-regexp) nil t)))) + (setq beg (point-min) end (point-max) + msg "Creating images for buffer...%s")) + ((equal subtree '(4)) + (org-back-to-heading) + (setq beg (point) end (org-end-of-subtree t) + msg "Creating images for subtree...%s")) + (t + (if (setq at (org-inside-LaTeX-fragment-p)) + (goto-char (max (point-min) (- (cdr at) 2))) + (org-back-to-heading)) + (setq beg (point) end (progn (outline-next-heading) (point)) + msg (if at "Creating image...%s" + "Creating images for entry...%s")))) + (message msg "") + (narrow-to-region beg end) + (goto-char beg) + (org-format-latex + (concat "ltxpng/" (file-name-sans-extension + (file-name-nondirectory + buffer-file-name))) + default-directory 'overlays msg at 'forbuffer 'dvipng) + (message msg "done. Use `C-c C-c' to remove images."))))) + +(defvar org-latex-regexps + '(("begin" "^[ \t]*\\(\\\\begin{\\([a-zA-Z0-9\\*]+\\)[^\000]+?\\\\end{\\2}\\)" 1 t) + ;; ("$" "\\([ (]\\|^\\)\\(\\(\\([$]\\)\\([^ \r\n,.$].*?\\(\n.*?\\)\\{0,5\\}[^ \r\n,.$]\\)\\4\\)\\)\\([ .,?;:'\")]\\|$\\)" 2 nil) + ;; \000 in the following regex is needed for org-inside-LaTeX-fragment-p + ("$1" "\\([^$]\\)\\(\\$[^ \r\n,;.$]\\$\\)\\([- .,?;:'\")\000]\\|$\\)" 2 nil) + ("$" "\\([^$]\\)\\(\\(\\$\\([^ \r\n,;.$][^$\n\r]*?\\(\n[^$\n\r]*?\\)\\{0,2\\}[^ \r\n,.$]\\)\\$\\)\\)\\([- .,?;:'\")\000]\\|$\\)" 2 nil) + ("\\(" "\\\\([^\000]*?\\\\)" 0 nil) + ("\\[" "\\\\\\[[^\000]*?\\\\\\]" 0 nil) + ("$$" "\\$\\$[^\000]*?\\$\\$" 0 nil)) + "Regular expressions for matching embedded LaTeX.") + +(defvar org-export-have-math nil) ;; dynamic scoping +(defun org-format-latex (prefix &optional dir overlays msg at + forbuffer processing-type) + "Replace LaTeX fragments with links to an image, and produce images. +Some of the options can be changed using the variable +`org-format-latex-options'." + (if (and overlays (fboundp 'clear-image-cache)) (clear-image-cache)) + (let* ((prefixnodir (file-name-nondirectory prefix)) + (absprefix (expand-file-name prefix dir)) + (todir (file-name-directory absprefix)) + (opt org-format-latex-options) + (matchers (plist-get opt :matchers)) + (re-list org-latex-regexps) + (org-format-latex-header-extra + (plist-get (org-infile-export-plist) :latex-header-extra)) + (cnt 0) txt hash link beg end re e checkdir + executables-checked string + m n block linkfile movefile ov) + ;; Check the different regular expressions + (while (setq e (pop re-list)) + (setq m (car e) re (nth 1 e) n (nth 2 e) + block (if (nth 3 e) "\n\n" "")) + (when (member m matchers) + (goto-char (point-min)) + (while (re-search-forward re nil t) + (when (and (or (not at) (equal (cdr at) (match-beginning n))) + (not (get-text-property (match-beginning n) + 'org-protected)) + (or (not overlays) + (not (eq (get-char-property (match-beginning n) + 'org-overlay-type) + 'org-latex-overlay)))) + (setq org-export-have-math t) + (cond + ((eq processing-type 'verbatim) + ;; Leave the text verbatim, just protect it + (add-text-properties (match-beginning n) (match-end n) + '(org-protected t))) + ((eq processing-type 'mathjax) + ;; Prepare for MathJax processing + (setq string (match-string n)) + (if (member m '("$" "$1")) + (save-excursion + (delete-region (match-beginning n) (match-end n)) + (goto-char (match-beginning n)) + (insert (org-add-props (concat "\\(" (substring string 1 -1) + "\\)") + '(org-protected t)))) + (add-text-properties (match-beginning n) (match-end n) + '(org-protected t)))) + ((or (eq processing-type 'dvipng) t) + ;; Process to an image + (setq txt (match-string n) + beg (match-beginning n) end (match-end n) + cnt (1+ cnt)) + (let (print-length print-level) ; make sure full list is printed + (setq hash (sha1 (prin1-to-string + (list org-format-latex-header + org-format-latex-header-extra + org-export-latex-default-packages-alist + org-export-latex-packages-alist + org-format-latex-options + forbuffer txt))) + linkfile (format "%s_%s.png" prefix hash) + movefile (format "%s_%s.png" absprefix hash))) + (setq link (concat block "[[file:" linkfile "]]" block)) + (if msg (message msg cnt)) + (goto-char beg) + (unless checkdir ; make sure the directory exists + (setq checkdir t) + (or (file-directory-p todir) (make-directory todir t))) + + (unless executables-checked + (org-check-external-command + "latex" "needed to convert LaTeX fragments to images") + (org-check-external-command + "dvipng" "needed to convert LaTeX fragments to images") + (setq executables-checked t)) + + (unless (file-exists-p movefile) + (org-create-formula-image + txt movefile opt forbuffer)) + (if overlays + (progn + (mapc (lambda (o) + (if (eq (overlay-get o 'org-overlay-type) + 'org-latex-overlay) + (delete-overlay o))) + (overlays-in beg end)) + (setq ov (make-overlay beg end)) + (overlay-put ov 'org-overlay-type 'org-latex-overlay) + (if (featurep 'xemacs) + (progn + (overlay-put ov 'invisible t) + (overlay-put + ov 'end-glyph + (make-glyph (vector 'png :file movefile)))) + (overlay-put + ov 'display + (list 'image :type 'png :file movefile :ascent 'center))) + (push ov org-latex-fragment-image-overlays) + (goto-char end)) + (delete-region beg end) + (insert (org-add-props link + (list 'org-latex-src + (replace-regexp-in-string + "\"" "" txt))))))))))))) + +;; This function borrows from Ganesh Swami's latex2png.el +(defun org-create-formula-image (string tofile options buffer) + "This calls dvipng." + (require 'org-latex) + (let* ((tmpdir (if (featurep 'xemacs) + (temp-directory) + temporary-file-directory)) + (texfilebase (make-temp-name + (expand-file-name "orgtex" tmpdir))) + (texfile (concat texfilebase ".tex")) + (dvifile (concat texfilebase ".dvi")) + (pngfile (concat texfilebase ".png")) + (fnh (if (featurep 'xemacs) + (font-height (get-face-font 'default)) + (face-attribute 'default :height nil))) + (scale (or (plist-get options (if buffer :scale :html-scale)) 1.0)) + (dpi (number-to-string (* scale (floor (* 0.9 (if buffer fnh 140.)))))) + (fg (or (plist-get options (if buffer :foreground :html-foreground)) + "Black")) + (bg (or (plist-get options (if buffer :background :html-background)) + "Transparent"))) + (if (eq fg 'default) (setq fg (org-dvipng-color :foreground))) + (if (eq bg 'default) (setq bg (org-dvipng-color :background))) + (with-temp-file texfile + (insert (org-splice-latex-header + org-format-latex-header + org-export-latex-default-packages-alist + org-export-latex-packages-alist t + org-format-latex-header-extra)) + (insert "\n\\begin{document}\n" string "\n\\end{document}\n") + (require 'org-latex) + (org-export-latex-fix-inputenc)) + (let ((dir default-directory)) + (condition-case nil + (progn + (cd tmpdir) + (call-process "latex" nil nil nil texfile)) + (error nil)) + (cd dir)) + (if (not (file-exists-p dvifile)) + (progn (message "Failed to create dvi file from %s" texfile) nil) + (condition-case nil + (call-process "dvipng" nil nil nil + "-fg" fg "-bg" bg + "-D" dpi + ;;"-x" scale "-y" scale + "-T" "tight" + "-o" pngfile + dvifile) + (error nil)) + (if (not (file-exists-p pngfile)) + (if org-format-latex-signal-error + (error "Failed to create png file from %s" texfile) + (message "Failed to create png file from %s" texfile) + nil) + ;; Use the requested file name and clean up + (copy-file pngfile tofile 'replace) + (loop for e in '(".dvi" ".tex" ".aux" ".log" ".png") do + (delete-file (concat texfilebase e))) + pngfile)))) + +(defun org-splice-latex-header (tpl def-pkg pkg snippets-p &optional extra) + "Fill a LaTeX header template TPL. +In the template, the following place holders will be recognized: + + [DEFAULT-PACKAGES] \\usepackage statements for DEF-PKG + [NO-DEFAULT-PACKAGES] do not include DEF-PKG + [PACKAGES] \\usepackage statements for PKG + [NO-PACKAGES] do not include PKG + [EXTRA] the string EXTRA + [NO-EXTRA] do not include EXTRA + +For backward compatibility, if both the positive and the negative place +holder is missing, the positive one (without the \"NO-\") will be +assumed to be present at the end of the template. +DEF-PKG and PKG are assumed to be alists of options/packagename lists. +EXTRA is a string. +SNIPPETS-P indicates if this is run to create snippet images for HTML." + (let (rpl (end "")) + (if (string-match "^[ \t]*\\[\\(NO-\\)?DEFAULT-PACKAGES\\][ \t]*\n?" tpl) + (setq rpl (if (or (match-end 1) (not def-pkg)) + "" (org-latex-packages-to-string def-pkg snippets-p t)) + tpl (replace-match rpl t t tpl)) + (if def-pkg (setq end (org-latex-packages-to-string def-pkg snippets-p)))) + + (if (string-match "\\[\\(NO-\\)?PACKAGES\\][ \t]*\n?" tpl) + (setq rpl (if (or (match-end 1) (not pkg)) + "" (org-latex-packages-to-string pkg snippets-p t)) + tpl (replace-match rpl t t tpl)) + (if pkg (setq end + (concat end "\n" + (org-latex-packages-to-string pkg snippets-p))))) + + (if (string-match "\\[\\(NO-\\)?EXTRA\\][ \t]*\n?" tpl) + (setq rpl (if (or (match-end 1) (not extra)) + "" (concat extra "\n")) + tpl (replace-match rpl t t tpl)) + (if (and extra (string-match "\\S-" extra)) + (setq end (concat end "\n" extra)))) + + (if (string-match "\\S-" end) + (concat tpl "\n" end) + tpl))) + +(defun org-latex-packages-to-string (pkg &optional snippets-p newline) + "Turn an alist of packages into a string with the \\usepackage macros." + (setq pkg (mapconcat (lambda(p) + (cond + ((stringp p) p) + ((and snippets-p (>= (length p) 3) (not (nth 2 p))) + (format "%% Package %s omitted" (cadr p))) + ((equal "" (car p)) + (format "\\usepackage{%s}" (cadr p))) + (t + (format "\\usepackage[%s]{%s}" + (car p) (cadr p))))) + pkg + "\n")) + (if newline (concat pkg "\n") pkg)) + +(defun org-dvipng-color (attr) + "Return an rgb color specification for dvipng." + (apply 'format "rgb %s %s %s" + (mapcar 'org-normalize-color + (color-values (face-attribute 'default attr nil))))) + +(defun org-normalize-color (value) + "Return string to be used as color value for an RGB component." + (format "%g" (/ value 65535.0))) + +;; Image display + + +(defvar org-inline-image-overlays nil) +(make-variable-buffer-local 'org-inline-image-overlays) + +(defun org-toggle-inline-images (&optional include-linked) + "Toggle the display of inline images. +INCLUDE-LINKED is passed to `org-display-inline-images'." + (interactive "P") + (if org-inline-image-overlays + (progn + (org-remove-inline-images) + (message "Inline image display turned off")) + (org-display-inline-images include-linked) + (if org-inline-image-overlays + (message "%d images displayed inline" + (length org-inline-image-overlays)) + (message "No images to display inline")))) + +(defun org-display-inline-images (&optional include-linked refresh beg end) + "Display inline images. +Normally only links without a description part are inlined, because this +is how it will work for export. When INCLUDE-LINKED is set, also links +with a description part will be inlined. This can be nice for a quick +look at those images, but it does not reflect what exported files will look +like. +When REFRESH is set, refresh existing images between BEG and END. +This will create new image displays only if necessary. +BEG and END default to the buffer boundaries." + (interactive "P") + (unless refresh + (org-remove-inline-images) + (clear-image-cache)) + (save-excursion + (save-restriction + (widen) + (setq beg (or beg (point-min)) end (or end (point-max))) + (goto-char (point-min)) + (let ((re (concat "\\[\\[\\(\\(file:\\)\\|\\([./~]\\)\\)\\([^]\n]+?" + (substring (org-image-file-name-regexp) 0 -2) + "\\)\\]" (if include-linked "" "\\]"))) + old file ov img) + (while (re-search-forward re end t) + (setq old (get-char-property-and-overlay (match-beginning 1) + 'org-image-overlay)) + (setq file (expand-file-name + (concat (or (match-string 3) "") (match-string 4)))) + (when (file-exists-p file) + (if (and (car-safe old) refresh) + (image-refresh (overlay-get (cdr old) 'display)) + (setq img (save-match-data (create-image file))) + (when img + (setq ov (make-overlay (match-beginning 0) (match-end 0))) + (overlay-put ov 'display img) + (overlay-put ov 'face 'default) + (overlay-put ov 'org-image-overlay t) + (overlay-put ov 'modification-hooks + (list 'org-display-inline-modification-hook)) + (push ov org-inline-image-overlays))))))))) + +(defun org-display-inline-modification-hook (ov after beg end &optional len) + "Remove inline-display overlay if a corresponding region is modified." + (let ((inhibit-modification-hooks t)) + (when (and ov after) + (delete ov org-inline-image-overlays) + (delete-overlay ov)))) + +(defun org-remove-inline-images () + "Remove inline display of images." + (interactive) + (mapc 'delete-overlay org-inline-image-overlays) + (setq org-inline-image-overlays nil)) + +;;;; Key bindings + +;; Make `C-c C-x' a prefix key +(org-defkey org-mode-map "\C-c\C-x" (make-sparse-keymap)) + +;; TAB key with modifiers +(org-defkey org-mode-map "\C-i" 'org-cycle) +(org-defkey org-mode-map [(tab)] 'org-cycle) +(org-defkey org-mode-map [(control tab)] 'org-force-cycle-archived) +(org-defkey org-mode-map [(meta tab)] 'pcomplete) +(org-defkey org-mode-map "\M-\t" 'pcomplete) +(org-defkey org-mode-map "\M-\C-i" 'pcomplete) +;; The following line is necessary under Suse GNU/Linux +(unless (featurep 'xemacs) + (org-defkey org-mode-map [S-iso-lefttab] 'org-shifttab)) +(org-defkey org-mode-map [(shift tab)] 'org-shifttab) +(define-key org-mode-map [backtab] 'org-shifttab) + +(org-defkey org-mode-map [(shift return)] 'org-table-copy-down) +(org-defkey org-mode-map [(meta shift return)] 'org-insert-todo-heading) +(org-defkey org-mode-map [(meta return)] 'org-meta-return) + +;; Cursor keys with modifiers +(org-defkey org-mode-map [(meta left)] 'org-metaleft) +(org-defkey org-mode-map [(meta right)] 'org-metaright) +(org-defkey org-mode-map [(meta up)] 'org-metaup) +(org-defkey org-mode-map [(meta down)] 'org-metadown) + +(org-defkey org-mode-map [(meta shift left)] 'org-shiftmetaleft) +(org-defkey org-mode-map [(meta shift right)] 'org-shiftmetaright) +(org-defkey org-mode-map [(meta shift up)] 'org-shiftmetaup) +(org-defkey org-mode-map [(meta shift down)] 'org-shiftmetadown) + +(org-defkey org-mode-map [(shift up)] 'org-shiftup) +(org-defkey org-mode-map [(shift down)] 'org-shiftdown) +(org-defkey org-mode-map [(shift left)] 'org-shiftleft) +(org-defkey org-mode-map [(shift right)] 'org-shiftright) + +(org-defkey org-mode-map [(control shift right)] 'org-shiftcontrolright) +(org-defkey org-mode-map [(control shift left)] 'org-shiftcontrolleft) + +;; Babel keys +(define-key org-mode-map org-babel-key-prefix org-babel-map) +(mapc (lambda (pair) + (define-key org-babel-map (car pair) (cdr pair))) + org-babel-key-bindings) + +;;; Extra keys for tty access. +;; We only set them when really needed because otherwise the +;; menus don't show the simple keys + +(when (or org-use-extra-keys + (featurep 'xemacs) ;; because XEmacs supports multi-device stuff + (not window-system)) + (org-defkey org-mode-map "\C-c\C-xc" 'org-table-copy-down) + (org-defkey org-mode-map "\C-c\C-xM" 'org-insert-todo-heading) + (org-defkey org-mode-map "\C-c\C-xm" 'org-meta-return) + (org-defkey org-mode-map [?\e (return)] 'org-meta-return) + (org-defkey org-mode-map [?\e (left)] 'org-metaleft) + (org-defkey org-mode-map "\C-c\C-xl" 'org-metaleft) + (org-defkey org-mode-map [?\e (right)] 'org-metaright) + (org-defkey org-mode-map "\C-c\C-xr" 'org-metaright) + (org-defkey org-mode-map [?\e (up)] 'org-metaup) + (org-defkey org-mode-map "\C-c\C-xu" 'org-metaup) + (org-defkey org-mode-map [?\e (down)] 'org-metadown) + (org-defkey org-mode-map "\C-c\C-xd" 'org-metadown) + (org-defkey org-mode-map "\C-c\C-xL" 'org-shiftmetaleft) + (org-defkey org-mode-map "\C-c\C-xR" 'org-shiftmetaright) + (org-defkey org-mode-map "\C-c\C-xU" 'org-shiftmetaup) + (org-defkey org-mode-map "\C-c\C-xD" 'org-shiftmetadown) + (org-defkey org-mode-map [?\C-c (up)] 'org-shiftup) + (org-defkey org-mode-map [?\C-c (down)] 'org-shiftdown) + (org-defkey org-mode-map [?\C-c (left)] 'org-shiftleft) + (org-defkey org-mode-map [?\C-c (right)] 'org-shiftright) + (org-defkey org-mode-map [?\C-c ?\C-x (right)] 'org-shiftcontrolright) + (org-defkey org-mode-map [?\C-c ?\C-x (left)] 'org-shiftcontrolleft) + (org-defkey org-mode-map [?\e (tab)] 'pcomplete) + (org-defkey org-mode-map [?\e (shift return)] 'org-insert-todo-heading) + (org-defkey org-mode-map [?\e (shift left)] 'org-shiftmetaleft) + (org-defkey org-mode-map [?\e (shift right)] 'org-shiftmetaright) + (org-defkey org-mode-map [?\e (shift up)] 'org-shiftmetaup) + (org-defkey org-mode-map [?\e (shift down)] 'org-shiftmetadown)) + + ;; All the other keys + +(org-defkey org-mode-map "\C-c\C-a" 'show-all) ; in case allout messed up. +(org-defkey org-mode-map "\C-c\C-r" 'org-reveal) +(if (boundp 'narrow-map) + (org-defkey narrow-map "s" 'org-narrow-to-subtree) + (org-defkey org-mode-map "\C-xns" 'org-narrow-to-subtree)) +(org-defkey org-mode-map "\C-c\C-f" 'org-forward-same-level) +(org-defkey org-mode-map "\C-c\C-b" 'org-backward-same-level) +(org-defkey org-mode-map "\C-c$" 'org-archive-subtree) +(org-defkey org-mode-map "\C-c\C-x\C-s" 'org-advertized-archive-subtree) +(org-defkey org-mode-map "\C-c\C-x\C-a" 'org-archive-subtree-default) +(org-defkey org-mode-map "\C-c\C-xa" 'org-toggle-archive-tag) +(org-defkey org-mode-map "\C-c\C-xA" 'org-archive-to-archive-sibling) +(org-defkey org-mode-map "\C-c\C-xb" 'org-tree-to-indirect-buffer) +(org-defkey org-mode-map "\C-c\C-j" 'org-goto) +(org-defkey org-mode-map "\C-c\C-t" 'org-todo) +(org-defkey org-mode-map "\C-c\C-q" 'org-set-tags-command) +(org-defkey org-mode-map "\C-c\C-s" 'org-schedule) +(org-defkey org-mode-map "\C-c\C-d" 'org-deadline) +(org-defkey org-mode-map "\C-c;" 'org-toggle-comment) +(org-defkey org-mode-map "\C-c\C-w" 'org-refile) +(org-defkey org-mode-map "\C-c/" 'org-sparse-tree) ; Minor-mode reserved +(org-defkey org-mode-map "\C-c\\" 'org-match-sparse-tree) ; Minor-mode res. +(org-defkey org-mode-map "\C-c\C-m" 'org-ctrl-c-ret) +(org-defkey org-mode-map "\M-\C-m" 'org-insert-heading) +(org-defkey org-mode-map "\C-c\C-xc" 'org-clone-subtree-with-time-shift) +(org-defkey org-mode-map [(control return)] 'org-insert-heading-respect-content) +(org-defkey org-mode-map [(shift control return)] 'org-insert-todo-heading-respect-content) +(org-defkey org-mode-map "\C-c\C-x\C-n" 'org-next-link) +(org-defkey org-mode-map "\C-c\C-x\C-p" 'org-previous-link) +(org-defkey org-mode-map "\C-c\C-l" 'org-insert-link) +(org-defkey org-mode-map "\C-c\C-o" 'org-open-at-point) +(org-defkey org-mode-map "\C-c%" 'org-mark-ring-push) +(org-defkey org-mode-map "\C-c&" 'org-mark-ring-goto) +(org-defkey org-mode-map "\C-c\C-z" 'org-add-note) ; Alternative binding +(org-defkey org-mode-map "\C-c." 'org-time-stamp) ; Minor-mode reserved +(org-defkey org-mode-map "\C-c!" 'org-time-stamp-inactive) ; Minor-mode r. +(org-defkey org-mode-map "\C-c," 'org-priority) ; Minor-mode reserved +(org-defkey org-mode-map "\C-c\C-y" 'org-evaluate-time-range) +(org-defkey org-mode-map "\C-c>" 'org-goto-calendar) +(org-defkey org-mode-map "\C-c<" 'org-date-from-calendar) +(org-defkey org-mode-map [(control ?,)] 'org-cycle-agenda-files) +(org-defkey org-mode-map [(control ?\')] 'org-cycle-agenda-files) +(org-defkey org-mode-map "\C-c[" 'org-agenda-file-to-front) +(org-defkey org-mode-map "\C-c]" 'org-remove-file) +(org-defkey org-mode-map "\C-c\C-x<" 'org-agenda-set-restriction-lock) +(org-defkey org-mode-map "\C-c\C-x>" 'org-agenda-remove-restriction-lock) +(org-defkey org-mode-map "\C-c-" 'org-ctrl-c-minus) +(org-defkey org-mode-map "\C-c*" 'org-ctrl-c-star) +(org-defkey org-mode-map "\C-c^" 'org-sort) +(org-defkey org-mode-map "\C-c\C-c" 'org-ctrl-c-ctrl-c) +(org-defkey org-mode-map "\C-c\C-k" 'org-kill-note-or-show-branches) +(org-defkey org-mode-map "\C-c#" 'org-update-statistics-cookies) +(org-defkey org-mode-map "\C-m" 'org-return) +(org-defkey org-mode-map "\C-j" 'org-return-indent) +(org-defkey org-mode-map "\C-c?" 'org-table-field-info) +(org-defkey org-mode-map "\C-c " 'org-table-blank-field) +(org-defkey org-mode-map "\C-c+" 'org-table-sum) +(org-defkey org-mode-map "\C-c=" 'org-table-eval-formula) +(org-defkey org-mode-map "\C-c'" 'org-edit-special) +(org-defkey org-mode-map "\C-c`" 'org-table-edit-field) +(org-defkey org-mode-map "\C-c|" 'org-table-create-or-convert-from-region) +(org-defkey org-mode-map [(control ?#)] 'org-table-rotate-recalc-marks) +(org-defkey org-mode-map "\C-c~" 'org-table-create-with-table.el) +(org-defkey org-mode-map "\C-c\C-a" 'org-attach) +(org-defkey org-mode-map "\C-c}" 'org-table-toggle-coordinate-overlays) +(org-defkey org-mode-map "\C-c{" 'org-table-toggle-formula-debugger) +(org-defkey org-mode-map "\C-c\C-e" 'org-export) +(org-defkey org-mode-map "\C-c:" 'org-toggle-fixed-width-section) +(org-defkey org-mode-map "\C-c\C-x\C-f" 'org-emphasize) +(org-defkey org-mode-map "\C-c\C-xf" 'org-footnote-action) +(org-defkey org-mode-map "\C-c\C-x\C-mg" 'org-mobile-pull) +(org-defkey org-mode-map "\C-c\C-x\C-mp" 'org-mobile-push) +(org-defkey org-mode-map "\C-c@" 'org-mark-subtree) +(org-defkey org-mode-map [?\C-c (control ?*)] 'org-list-make-subtree) +;;(org-defkey org-mode-map [?\C-c (control ?-)] 'org-list-make-list-from-subtree) + +(org-defkey org-mode-map "\C-c\C-x\C-k" 'org-mark-entry-for-agenda-action) +(org-defkey org-mode-map "\C-c\C-x\C-w" 'org-cut-special) +(org-defkey org-mode-map "\C-c\C-x\M-w" 'org-copy-special) +(org-defkey org-mode-map "\C-c\C-x\C-y" 'org-paste-special) + +(org-defkey org-mode-map "\C-c\C-x\C-t" 'org-toggle-time-stamp-overlays) +(org-defkey org-mode-map "\C-c\C-x\C-i" 'org-clock-in) +(org-defkey org-mode-map "\C-c\C-x\C-o" 'org-clock-out) +(org-defkey org-mode-map "\C-c\C-x\C-j" 'org-clock-goto) +(org-defkey org-mode-map "\C-c\C-x\C-x" 'org-clock-cancel) +(org-defkey org-mode-map "\C-c\C-x\C-d" 'org-clock-display) +(org-defkey org-mode-map "\C-c\C-x\C-r" 'org-clock-report) +(org-defkey org-mode-map "\C-c\C-x\C-u" 'org-dblock-update) +(org-defkey org-mode-map "\C-c\C-x\C-l" 'org-preview-latex-fragment) +(org-defkey org-mode-map "\C-c\C-x\C-v" 'org-toggle-inline-images) +(org-defkey org-mode-map "\C-c\C-x\\" 'org-toggle-pretty-entities) +(org-defkey org-mode-map "\C-c\C-x\C-b" 'org-toggle-checkbox) +(org-defkey org-mode-map "\C-c\C-xp" 'org-set-property) +(org-defkey org-mode-map "\C-c\C-xe" 'org-set-effort) +(org-defkey org-mode-map "\C-c\C-xo" 'org-toggle-ordered-property) +(org-defkey org-mode-map "\C-c\C-xi" 'org-insert-columns-dblock) +(org-defkey org-mode-map [(control ?c) (control ?x) ?\;] 'org-timer-set-timer) +(org-defkey org-mode-map [(control ?c) (control ?x) ?\:] 'org-timer-cancel-timer) + +(org-defkey org-mode-map "\C-c\C-x." 'org-timer) +(org-defkey org-mode-map "\C-c\C-x-" 'org-timer-item) +(org-defkey org-mode-map "\C-c\C-x0" 'org-timer-start) +(org-defkey org-mode-map "\C-c\C-x_" 'org-timer-stop) +(org-defkey org-mode-map "\C-c\C-x," 'org-timer-pause-or-continue) + +(define-key org-mode-map "\C-c\C-x\C-c" 'org-columns) + +(define-key org-mode-map "\C-c\C-x!" 'org-reload) + +(define-key org-mode-map "\C-c\C-xg" 'org-feed-update-all) +(define-key org-mode-map "\C-c\C-xG" 'org-feed-goto-inbox) + +(define-key org-mode-map "\C-c\C-x[" 'org-reftex-citation) + + +(when (featurep 'xemacs) + (org-defkey org-mode-map 'button3 'popup-mode-menu)) + + +(defconst org-speed-commands-default + '( + ("Outline Navigation") + ("n" . (org-speed-move-safe 'outline-next-visible-heading)) + ("p" . (org-speed-move-safe 'outline-previous-visible-heading)) + ("f" . (org-speed-move-safe 'org-forward-same-level)) + ("b" . (org-speed-move-safe 'org-backward-same-level)) + ("u" . (org-speed-move-safe 'outline-up-heading)) + ("j" . org-goto) + ("g" . (org-refile t)) + ("Outline Visibility") + ("c" . org-cycle) + ("C" . org-shifttab) + (" " . org-display-outline-path) + ("Outline Structure Editing") + ("U" . org-shiftmetaup) + ("D" . org-shiftmetadown) + ("r" . org-metaright) + ("l" . org-metaleft) + ("R" . org-shiftmetaright) + ("L" . org-shiftmetaleft) + ("i" . (progn (forward-char 1) (call-interactively + 'org-insert-heading-respect-content))) + ("^" . org-sort) + ("w" . org-refile) + ("a" . org-archive-subtree-default-with-confirmation) + ("." . org-mark-subtree) + ("Clock Commands") + ("I" . org-clock-in) + ("O" . org-clock-out) + ("Meta Data Editing") + ("t" . org-todo) + ("0" . (org-priority ?\ )) + ("1" . (org-priority ?A)) + ("2" . (org-priority ?B)) + ("3" . (org-priority ?C)) + (";" . org-set-tags-command) + ("e" . org-set-effort) + ("Agenda Views etc") + ("v" . org-agenda) + ("/" . org-sparse-tree) + ("Misc") + ("o" . org-open-at-point) + ("?" . org-speed-command-help) + ("<" . (org-agenda-set-restriction-lock 'subtree)) + (">" . (org-agenda-remove-restriction-lock)) + ) + "The default speed commands.") + +(defun org-print-speed-command (e) + (if (> (length (car e)) 1) + (progn + (princ "\n") + (princ (car e)) + (princ "\n") + (princ (make-string (length (car e)) ?-)) + (princ "\n")) + (princ (car e)) + (princ " ") + (if (symbolp (cdr e)) + (princ (symbol-name (cdr e))) + (prin1 (cdr e))) + (princ "\n"))) + +(defun org-speed-command-help () + "Show the available speed commands." + (interactive) + (if (not org-use-speed-commands) + (error "Speed commands are not activated, customize `org-use-speed-commands'") + (with-output-to-temp-buffer "*Help*" + (princ "User-defined Speed commands\n===========================\n") + (mapc 'org-print-speed-command org-speed-commands-user) + (princ "\n") + (princ "Built-in Speed commands\n=======================\n") + (mapc 'org-print-speed-command org-speed-commands-default)) + (with-current-buffer "*Help*" + (setq truncate-lines t)))) + +(defun org-speed-move-safe (cmd) + "Execute CMD, but make sure that the cursor always ends up in a headline. +If not, return to the original position and throw an error." + (interactive) + (let ((pos (point))) + (call-interactively cmd) + (unless (and (bolp) (org-on-heading-p)) + (goto-char pos) + (error "Boundary reached while executing %s" cmd)))) + +(defvar org-self-insert-command-undo-counter 0) + +(defvar org-table-auto-blank-field) ; defined in org-table.el +(defvar org-speed-command nil) + +(defun org-speed-command-default-hook (keys) + "Hook for activating single-letter speed commands. +`org-speed-commands-default' specifies a minimal command set. Use +`org-speed-commands-user' for further customization." + (when (or (and (bolp) (looking-at outline-regexp)) + (and (functionp org-use-speed-commands) + (funcall org-use-speed-commands))) + (cdr (assoc keys (append org-speed-commands-user + org-speed-commands-default))))) + +(defun org-babel-speed-command-hook (keys) + "Hook for activating single-letter code block commands." + (when (and (bolp) (looking-at org-babel-src-block-regexp)) + (cdr (assoc keys org-babel-key-bindings)))) + +(defcustom org-speed-command-hook + '(org-speed-command-default-hook org-babel-speed-command-hook) + "Hook for activating speed commands at strategic locations. +Hook functions are called in sequence until a valid handler is +found. + +Each hook takes a single argument, a user-pressed command key +which is also a `self-insert-command' from the global map. + +Within the hook, examine the cursor position and the command key +and return nil or a valid handler as appropriate. Handler could +be one of an interactive command, a function, or a form. + +Set `org-use-speed-commands' to non-nil value to enable this +hook. The default setting is `org-speed-command-default-hook'." + :group 'org-structure + :type 'hook) + +(defun org-self-insert-command (N) + "Like `self-insert-command', use overwrite-mode for whitespace in tables. +If the cursor is in a table looking at whitespace, the whitespace is +overwritten, and the table is not marked as requiring realignment." + (interactive "p") + (cond + ((and org-use-speed-commands + (setq org-speed-command + (run-hook-with-args-until-success + 'org-speed-command-hook (this-command-keys)))) + (cond + ((commandp org-speed-command) + (setq this-command org-speed-command) + (call-interactively org-speed-command)) + ((functionp org-speed-command) + (funcall org-speed-command)) + ((and org-speed-command (listp org-speed-command)) + (eval org-speed-command)) + (t (let (org-use-speed-commands) + (call-interactively 'org-self-insert-command))))) + ((and + (org-table-p) + (progn + ;; check if we blank the field, and if that triggers align + (and (featurep 'org-table) org-table-auto-blank-field + (member last-command + '(org-cycle org-return org-shifttab org-ctrl-c-ctrl-c yas/expand)) + (if (or (equal (char-after) ?\ ) (looking-at "[^|\n]* |")) + ;; got extra space, this field does not determine column width + (let (org-table-may-need-update) (org-table-blank-field)) + ;; no extra space, this field may determine column width + (org-table-blank-field))) + t) + (eq N 1) + (looking-at "[^|\n]* |")) + (let (org-table-may-need-update) + (goto-char (1- (match-end 0))) + (delete-backward-char 1) + (goto-char (match-beginning 0)) + (self-insert-command N))) + (t + (setq org-table-may-need-update t) + (self-insert-command N) + (org-fix-tags-on-the-fly) + (if org-self-insert-cluster-for-undo + (if (not (eq last-command 'org-self-insert-command)) + (setq org-self-insert-command-undo-counter 1) + (if (>= org-self-insert-command-undo-counter 20) + (setq org-self-insert-command-undo-counter 1) + (and (> org-self-insert-command-undo-counter 0) + buffer-undo-list + (not (cadr buffer-undo-list)) ; remove nil entry + (setcdr buffer-undo-list (cddr buffer-undo-list))) + (setq org-self-insert-command-undo-counter + (1+ org-self-insert-command-undo-counter)))))))) + +(defun org-fix-tags-on-the-fly () + (when (and (equal (char-after (point-at-bol)) ?*) + (org-on-heading-p)) + (org-align-tags-here org-tags-column))) + +(defun org-delete-backward-char (N) + "Like `delete-backward-char', insert whitespace at field end in tables. +When deleting backwards, in tables this function will insert whitespace in +front of the next \"|\" separator, to keep the table aligned. The table will +still be marked for re-alignment if the field did fill the entire column, +because, in this case the deletion might narrow the column." + (interactive "p") + (if (and (org-table-p) + (eq N 1) + (string-match "|" (buffer-substring (point-at-bol) (point))) + (looking-at ".*?|")) + (let ((pos (point)) + (noalign (looking-at "[^|\n\r]* |")) + (c org-table-may-need-update)) + (backward-delete-char N) + (if (not overwrite-mode) + (progn + (skip-chars-forward "^|") + (insert " ") + (goto-char (1- pos)))) + ;; noalign: if there were two spaces at the end, this field + ;; does not determine the width of the column. + (if noalign (setq org-table-may-need-update c))) + (backward-delete-char N) + (org-fix-tags-on-the-fly))) + +(defun org-delete-char (N) + "Like `delete-char', but insert whitespace at field end in tables. +When deleting characters, in tables this function will insert whitespace in +front of the next \"|\" separator, to keep the table aligned. The table will +still be marked for re-alignment if the field did fill the entire column, +because, in this case the deletion might narrow the column." + (interactive "p") + (if (and (org-table-p) + (not (bolp)) + (not (= (char-after) ?|)) + (eq N 1)) + (if (looking-at ".*?|") + (let ((pos (point)) + (noalign (looking-at "[^|\n\r]* |")) + (c org-table-may-need-update)) + (replace-match (concat + (substring (match-string 0) 1 -1) + " |")) + (goto-char pos) + ;; noalign: if there were two spaces at the end, this field + ;; does not determine the width of the column. + (if noalign (setq org-table-may-need-update c))) + (delete-char N)) + (delete-char N) + (org-fix-tags-on-the-fly))) + +;; Make `delete-selection-mode' work with org-mode and orgtbl-mode +(put 'org-self-insert-command 'delete-selection t) +(put 'orgtbl-self-insert-command 'delete-selection t) +(put 'org-delete-char 'delete-selection 'supersede) +(put 'org-delete-backward-char 'delete-selection 'supersede) +(put 'org-yank 'delete-selection 'yank) + +;; Make `flyspell-mode' delay after some commands +(put 'org-self-insert-command 'flyspell-delayed t) +(put 'orgtbl-self-insert-command 'flyspell-delayed t) +(put 'org-delete-char 'flyspell-delayed t) +(put 'org-delete-backward-char 'flyspell-delayed t) + +;; Make pabbrev-mode expand after org-mode commands +(put 'org-self-insert-command 'pabbrev-expand-after-command t) +(put 'orgtbl-self-insert-command 'pabbrev-expand-after-command t) + +;; How to do this: Measure non-white length of current string +;; If equal to column width, we should realign. + +(defun org-remap (map &rest commands) + "In MAP, remap the functions given in COMMANDS. +COMMANDS is a list of alternating OLDDEF NEWDEF command names." + (let (new old) + (while commands + (setq old (pop commands) new (pop commands)) + (if (fboundp 'command-remapping) + (org-defkey 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 + (org-remap org-mode-map + 'self-insert-command 'org-self-insert-command + 'delete-char 'org-delete-char + 'delete-backward-char 'org-delete-backward-char) + (org-defkey org-mode-map "|" 'org-force-self-insert)) + +(defvar org-ctrl-c-ctrl-c-hook nil + "Hook for functions attaching themselves to `C-c C-c'. +This can be used to add additional functionality to the C-c C-c key which +executes context-dependent commands. +Each function will be called with no arguments. The function must check +if the context is appropriate for it to act. If yes, it should do its +thing and then return a non-nil value. If the context is wrong, +just do nothing and return nil.") + +(defvar org-tab-first-hook nil + "Hook for functions to attach themselves to TAB. +See `org-ctrl-c-ctrl-c-hook' for more information. +This hook runs as the first action when TAB is pressed, even before +`org-cycle' messes around with the `outline-regexp' to cater for +inline tasks and plain list item folding. +If any function in this hook returns t, any other actions that +would have been caused by TAB (such as table field motion or visibility +cycling) will not occur.") + +(defvar org-tab-after-check-for-table-hook nil + "Hook for functions to attach themselves to TAB. +See `org-ctrl-c-ctrl-c-hook' for more information. +This hook runs after it has been established that the cursor is not in a +table, but before checking if the cursor is in a headline or if global cycling +should be done. +If any function in this hook returns t, not other actions like visibility +cycling will be done.") + +(defvar org-tab-after-check-for-cycling-hook nil + "Hook for functions to attach themselves to TAB. +See `org-ctrl-c-ctrl-c-hook' for more information. +This hook runs after it has been established that not table field motion and +not visibility should be done because of current context. This is probably +the place where a package like yasnippets can hook in.") + +(defvar org-tab-before-tab-emulation-hook nil + "Hook for functions to attach themselves to TAB. +See `org-ctrl-c-ctrl-c-hook' for more information. +This hook runs after every other options for TAB have been exhausted, but +before indentation and \t insertion takes place.") + +(defvar org-metaleft-hook nil + "Hook for functions attaching themselves to `M-left'. +See `org-ctrl-c-ctrl-c-hook' for more information.") +(defvar org-metaright-hook nil + "Hook for functions attaching themselves to `M-right'. +See `org-ctrl-c-ctrl-c-hook' for more information.") +(defvar org-metaup-hook nil + "Hook for functions attaching themselves to `M-up'. +See `org-ctrl-c-ctrl-c-hook' for more information.") +(defvar org-metadown-hook nil + "Hook for functions attaching themselves to `M-down'. +See `org-ctrl-c-ctrl-c-hook' for more information.") +(defvar org-shiftmetaleft-hook nil + "Hook for functions attaching themselves to `M-S-left'. +See `org-ctrl-c-ctrl-c-hook' for more information.") +(defvar org-shiftmetaright-hook nil + "Hook for functions attaching themselves to `M-S-right'. +See `org-ctrl-c-ctrl-c-hook' for more information.") +(defvar org-shiftmetaup-hook nil + "Hook for functions attaching themselves to `M-S-up'. +See `org-ctrl-c-ctrl-c-hook' for more information.") +(defvar org-shiftmetadown-hook nil + "Hook for functions attaching themselves to `M-S-down'. +See `org-ctrl-c-ctrl-c-hook' for more information.") +(defvar org-metareturn-hook nil + "Hook for functions attaching themselves to `M-RET'. +See `org-ctrl-c-ctrl-c-hook' for more information.") +(defvar org-shiftup-hook nil + "Hook for functions attaching themselves to `S-up'. +See `org-ctrl-c-ctrl-c-hook' for more information.") +(defvar org-shiftup-final-hook nil + "Hook for functions attaching themselves to `S-up'. +This one runs after all other options except shift-select have been excluded. +See `org-ctrl-c-ctrl-c-hook' for more information.") +(defvar org-shiftdown-hook nil + "Hook for functions attaching themselves to `S-down'. +See `org-ctrl-c-ctrl-c-hook' for more information.") +(defvar org-shiftdown-final-hook nil + "Hook for functions attaching themselves to `S-down'. +This one runs after all other options except shift-select have been excluded. +See `org-ctrl-c-ctrl-c-hook' for more information.") +(defvar org-shiftleft-hook nil + "Hook for functions attaching themselves to `S-left'. +See `org-ctrl-c-ctrl-c-hook' for more information.") +(defvar org-shiftleft-final-hook nil + "Hook for functions attaching themselves to `S-left'. +This one runs after all other options except shift-select have been excluded. +See `org-ctrl-c-ctrl-c-hook' for more information.") +(defvar org-shiftright-hook nil + "Hook for functions attaching themselves to `S-right'. +See `org-ctrl-c-ctrl-c-hook' for more information.") +(defvar org-shiftright-final-hook nil + "Hook for functions attaching themselves to `S-right'. +This one runs after all other options except shift-select have been excluded. +See `org-ctrl-c-ctrl-c-hook' for more information.") + +(defun org-modifier-cursor-error () + "Throw an error, a modified cursor command was applied in wrong context." + (error "This command is active in special context like tables, headlines or items")) + +(defun org-shiftselect-error () + "Throw an error because Shift-Cursor command was applied in wrong context." + (if (and (boundp 'shift-select-mode) shift-select-mode) + (error "To use shift-selection with Org-mode, customize `org-support-shift-select'") + (error "This command works only in special context like headlines or timestamps"))) + +(defun org-call-for-shift-select (cmd) + (let ((this-command-keys-shift-translated t)) + (call-interactively cmd))) + +(defun org-shifttab (&optional arg) + "Global visibility cycling or move to previous table field. +Calls `org-cycle' with argument t, or `org-table-previous-field', depending +on context. +See the individual commands for more information." + (interactive "P") + (cond + ((org-at-table-p) (call-interactively 'org-table-previous-field)) + ((integerp arg) + (let ((arg2 (if org-odd-levels-only (1- (* 2 arg)) arg))) + (message "Content view to level: %d" arg) + (org-content (prefix-numeric-value arg2)) + (setq org-cycle-global-status 'overview))) + (t (call-interactively 'org-global-cycle)))) + +(defun org-shiftmetaleft () + "Promote subtree or delete table column. +Calls `org-promote-subtree', `org-outdent-item', +or `org-table-delete-column', depending on context. +See the individual commands for more information." + (interactive) + (cond + ((run-hook-with-args-until-success 'org-shiftmetaleft-hook)) + ((org-at-table-p) (call-interactively 'org-table-delete-column)) + ((org-on-heading-p) (call-interactively 'org-promote-subtree)) + ((org-at-item-p) (call-interactively 'org-outdent-item-tree)) + (t (org-modifier-cursor-error)))) + +(defun org-shiftmetaright () + "Demote subtree or insert table column. +Calls `org-demote-subtree', `org-indent-item', +or `org-table-insert-column', depending on context. +See the individual commands for more information." + (interactive) + (cond + ((run-hook-with-args-until-success 'org-shiftmetaright-hook)) + ((org-at-table-p) (call-interactively 'org-table-insert-column)) + ((org-on-heading-p) (call-interactively 'org-demote-subtree)) + ((org-at-item-p) (call-interactively 'org-indent-item-tree)) + (t (org-modifier-cursor-error)))) + +(defun org-shiftmetaup (&optional arg) + "Move subtree up or kill table row. +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 + ((run-hook-with-args-until-success 'org-shiftmetaup-hook)) + ((org-at-table-p) (call-interactively 'org-table-kill-row)) + ((org-on-heading-p) (call-interactively 'org-move-subtree-up)) + ((org-at-item-p) (call-interactively 'org-move-item-up)) + (t (org-modifier-cursor-error)))) + +(defun org-shiftmetadown (&optional arg) + "Move subtree down or insert table row. +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 + ((run-hook-with-args-until-success 'org-shiftmetadown-hook)) + ((org-at-table-p) (call-interactively 'org-table-insert-row)) + ((org-on-heading-p) (call-interactively 'org-move-subtree-down)) + ((org-at-item-p) (call-interactively 'org-move-item-down)) + (t (org-modifier-cursor-error)))) + +(defsubst org-hidden-tree-error () + (error + "Hidden subtree, open with TAB or use subtree command M-S-<left>/<right>")) + +(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 + ((run-hook-with-args-until-success 'org-metaleft-hook)) + ((org-at-table-p) (org-call-with-arg 'org-table-move-column 'left)) + ((or (org-on-heading-p) + (and (org-region-active-p) + (save-excursion + (goto-char (region-beginning)) + (org-on-heading-p)))) + (when (org-check-for-hidden 'headlines) (org-hidden-tree-error)) + (call-interactively 'org-do-promote)) + ((or (org-at-item-p) + (and (org-region-active-p) + (save-excursion + (goto-char (region-beginning)) + (org-at-item-p)))) + (when (org-check-for-hidden 'items) (org-hidden-tree-error)) + (call-interactively 'org-outdent-item)) + (t (call-interactively 'backward-word)))) + +(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 + ((run-hook-with-args-until-success 'org-metaright-hook)) + ((org-at-table-p) (call-interactively 'org-table-move-column)) + ((or (org-on-heading-p) + (and (org-region-active-p) + (save-excursion + (goto-char (region-beginning)) + (org-on-heading-p)))) + (when (org-check-for-hidden 'headlines) (org-hidden-tree-error)) + (call-interactively 'org-do-demote)) + ((or (org-at-item-p) + (and (org-region-active-p) + (save-excursion + (goto-char (region-beginning)) + (org-at-item-p)))) + (when (org-check-for-hidden 'items) (org-hidden-tree-error)) + (call-interactively 'org-indent-item)) + (t (call-interactively 'forward-word)))) + +(defun org-check-for-hidden (what) + "Check if there are hidden headlines/items in the current visual line. +WHAT can be either `headlines' or `items'. If the current line is +an outline or item heading and it has a folded subtree below it, +this function returns t, nil otherwise." + (let ((re (cond + ((eq what 'headlines) (concat "^" org-outline-regexp)) + ((eq what 'items) (concat "^" (org-item-re t))) + (t (error "This should not happen")))) + beg end) + (save-excursion + (catch 'exit + (unless (org-region-active-p) + (setq beg (point-at-bol)) + (beginning-of-line 2) + (while (and (not (eobp)) ;; this is like `next-line' + (get-char-property (1- (point)) 'invisible)) + (beginning-of-line 2)) + (setq end (point)) + (goto-char beg) + (goto-char (point-at-eol)) + (setq end (max end (point))) + (while (re-search-forward re end t) + (if (get-char-property (match-beginning 0) 'invisible) + (throw 'exit t)))) + nil)))) + +(defun org-metaup (&optional arg) + "Move subtree up or move table row up. +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 + ((run-hook-with-args-until-success 'org-metaup-hook)) + ((org-at-table-p) (org-call-with-arg 'org-table-move-row 'up)) + ((org-on-heading-p) (call-interactively 'org-move-subtree-up)) + ((org-at-item-p) (call-interactively 'org-move-item-up)) + (t (transpose-lines 1) (beginning-of-line -1)))) + +(defun org-metadown (&optional arg) + "Move subtree down or move table row down. +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 + ((run-hook-with-args-until-success 'org-metadown-hook)) + ((org-at-table-p) (call-interactively 'org-table-move-row)) + ((org-on-heading-p) (call-interactively 'org-move-subtree-down)) + ((org-at-item-p) (call-interactively 'org-move-item-down)) + (t (beginning-of-line 2) (transpose-lines 1) (beginning-of-line 0)))) + +(defun org-shiftup (&optional arg) + "Increase item in timestamp or increase priority of current headline. +Calls `org-timestamp-up' or `org-priority-up', or `org-previous-item', +depending on context. See the individual commands for more information." + (interactive "P") + (cond + ((run-hook-with-args-until-success 'org-shiftup-hook)) + ((and org-support-shift-select (org-region-active-p)) + (org-call-for-shift-select 'previous-line)) + ((org-at-timestamp-p t) + (call-interactively (if org-edit-timestamp-down-means-later + 'org-timestamp-down 'org-timestamp-up))) + ((and (not (eq org-support-shift-select 'always)) + org-enable-priority-commands + (org-on-heading-p)) + (call-interactively 'org-priority-up)) + ((and (not org-support-shift-select) (org-at-item-p)) + (call-interactively 'org-previous-item)) + ((org-clocktable-try-shift 'up arg)) + ((run-hook-with-args-until-success 'org-shiftup-final-hook)) + (org-support-shift-select + (org-call-for-shift-select 'previous-line)) + (t (org-shiftselect-error)))) + +(defun org-shiftdown (&optional arg) + "Decrease item in timestamp or decrease priority of current headline. +Calls `org-timestamp-down' or `org-priority-down', or `org-next-item' +depending on context. See the individual commands for more information." + (interactive "P") + (cond + ((run-hook-with-args-until-success 'org-shiftdown-hook)) + ((and org-support-shift-select (org-region-active-p)) + (org-call-for-shift-select 'next-line)) + ((org-at-timestamp-p t) + (call-interactively (if org-edit-timestamp-down-means-later + 'org-timestamp-up 'org-timestamp-down))) + ((and (not (eq org-support-shift-select 'always)) + org-enable-priority-commands + (org-on-heading-p)) + (call-interactively 'org-priority-down)) + ((and (not org-support-shift-select) (org-at-item-p)) + (call-interactively 'org-next-item)) + ((org-clocktable-try-shift 'down arg)) + ((run-hook-with-args-until-success 'org-shiftdown-final-hook)) + (org-support-shift-select + (org-call-for-shift-select 'next-line)) + (t (org-shiftselect-error)))) + +(defun org-shiftright (&optional arg) + "Cycle the thing at point or in the current line, depending on context. +Depending on context, this does one of the following: + +- switch a timestamp at point one day into the future +- on a headline, switch to the next TODO keyword. +- on an item, switch entire list to the next bullet type +- on a property line, switch to the next allowed value +- on a clocktable definition line, move time block into the future" + (interactive "P") + (cond + ((run-hook-with-args-until-success 'org-shiftright-hook)) + ((and org-support-shift-select (org-region-active-p)) + (org-call-for-shift-select 'forward-char)) + ((org-at-timestamp-p t) (call-interactively 'org-timestamp-up-day)) + ((and (not (eq org-support-shift-select 'always)) + (org-on-heading-p)) + (let ((org-inhibit-logging + (not org-treat-S-cursor-todo-selection-as-state-change)) + (org-inhibit-blocking + (not org-treat-S-cursor-todo-selection-as-state-change))) + (org-call-with-arg 'org-todo 'right))) + ((or (and org-support-shift-select + (not (eq org-support-shift-select 'always)) + (org-at-item-bullet-p)) + (and (not org-support-shift-select) (org-at-item-p))) + (org-call-with-arg 'org-cycle-list-bullet nil)) + ((and (not (eq org-support-shift-select 'always)) + (org-at-property-p)) + (call-interactively 'org-property-next-allowed-value)) + ((org-clocktable-try-shift 'right arg)) + ((run-hook-with-args-until-success 'org-shiftright-final-hook)) + (org-support-shift-select + (org-call-for-shift-select 'forward-char)) + (t (org-shiftselect-error)))) + +(defun org-shiftleft (&optional arg) + "Cycle the thing at point or in the current line, depending on context. +Depending on context, this does one of the following: + +- switch a timestamp at point one day into the past +- on a headline, switch to the previous TODO keyword. +- on an item, switch entire list to the previous bullet type +- on a property line, switch to the previous allowed value +- on a clocktable definition line, move time block into the past" + (interactive "P") + (cond + ((run-hook-with-args-until-success 'org-shiftleft-hook)) + ((and org-support-shift-select (org-region-active-p)) + (org-call-for-shift-select 'backward-char)) + ((org-at-timestamp-p t) (call-interactively 'org-timestamp-down-day)) + ((and (not (eq org-support-shift-select 'always)) + (org-on-heading-p)) + (let ((org-inhibit-logging + (not org-treat-S-cursor-todo-selection-as-state-change)) + (org-inhibit-blocking + (not org-treat-S-cursor-todo-selection-as-state-change))) + (org-call-with-arg 'org-todo 'left))) + ((or (and org-support-shift-select + (not (eq org-support-shift-select 'always)) + (org-at-item-bullet-p)) + (and (not org-support-shift-select) (org-at-item-p))) + (org-call-with-arg 'org-cycle-list-bullet 'previous)) + ((and (not (eq org-support-shift-select 'always)) + (org-at-property-p)) + (call-interactively 'org-property-previous-allowed-value)) + ((org-clocktable-try-shift 'left arg)) + ((run-hook-with-args-until-success 'org-shiftleft-final-hook)) + (org-support-shift-select + (org-call-for-shift-select 'backward-char)) + (t (org-shiftselect-error)))) + +(defun org-shiftcontrolright () + "Switch to next TODO set." + (interactive) + (cond + ((and org-support-shift-select (org-region-active-p)) + (org-call-for-shift-select 'forward-word)) + ((and (not (eq org-support-shift-select 'always)) + (org-on-heading-p)) + (org-call-with-arg 'org-todo 'nextset)) + (org-support-shift-select + (org-call-for-shift-select 'forward-word)) + (t (org-shiftselect-error)))) + +(defun org-shiftcontrolleft () + "Switch to previous TODO set." + (interactive) + (cond + ((and org-support-shift-select (org-region-active-p)) + (org-call-for-shift-select 'backward-word)) + ((and (not (eq org-support-shift-select 'always)) + (org-on-heading-p)) + (org-call-with-arg 'org-todo 'previousset)) + (org-support-shift-select + (org-call-for-shift-select 'backward-word)) + (t (org-shiftselect-error)))) + +(defun org-ctrl-c-ret () + "Call `org-table-hline-and-move' or `org-insert-heading' dep. on context." + (interactive) + (cond + ((org-at-table-p) (call-interactively 'org-table-hline-and-move)) + (t (call-interactively 'org-insert-heading)))) + +(defun org-copy-special () + "Copy region in table or copy current subtree. +Calls `org-table-copy' or `org-copy-subtree', depending on context. +See the individual commands for more information." + (interactive) + (call-interactively + (if (org-at-table-p) 'org-table-copy-region 'org-copy-subtree))) + +(defun org-cut-special () + "Cut region in table or cut current subtree. +Calls `org-table-copy' or `org-cut-subtree', depending on context. +See the individual commands for more information." + (interactive) + (call-interactively + (if (org-at-table-p) 'org-table-cut-region 'org-cut-subtree))) + +(defun org-paste-special (arg) + "Paste rectangular region into table, or past subtree relative to level. +Calls `org-table-paste-rectangle' or `org-paste-subtree', depending on context. +See the individual commands for more information." + (interactive "P") + (if (org-at-table-p) + (org-table-paste-rectangle) + (org-paste-subtree arg))) + +(defun org-edit-special (&optional arg) + "Call a special editor for the stuff at point. +When at a table, call the formula editor with `org-table-edit-formulas'. +When at the first line of an src example, call `org-edit-src-code'. +When in an #+include line, visit the include file. Otherwise call +`ffap' to visit the file at point." + (interactive) + ;; possibly prep session before editing source + (when arg + (let* ((info (org-babel-get-src-block-info)) + (lang (nth 0 info)) + (params (nth 2 info)) + (session (cdr (assoc :session params)))) + (when (and info session) ;; we are in a source-code block with a session + (funcall + (intern (concat "org-babel-prep-session:" lang)) session params)))) + (cond ;; proceed with `org-edit-special' + ((save-excursion + (beginning-of-line 1) + (looking-at "\\(?:#\\+\\(?:setupfile\\|include\\):?[ \t]+\"?\\|[ \t]*<include\\>.*?file=\"\\)\\([^\"\n>]+\\)")) + (find-file (org-trim (match-string 1)))) + ((org-edit-src-code)) + ((org-edit-fixed-width-region)) + ((org-at-table.el-p) + (org-edit-src-code)) + ((or (org-at-table-p) + (save-excursion + (beginning-of-line 1) + (looking-at "[ \t]*#\\+TBLFM:"))) + (call-interactively 'org-table-edit-formulas)) + (t (call-interactively 'ffap)))) + +(defun org-ctrl-c-ctrl-c (&optional arg) + "Set tags in headline, or update according to changed information at point. + +This command does many different things, depending on context: + +- If a function in `org-ctrl-c-ctrl-c-hook' recognizes this location, + this is what we do. + +- If the cursor is on a statistics cookie, update it. + +- If the cursor is in a headline, prompt for tags and insert them + into the current line, aligned to `org-tags-column'. When 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 inside a table, realign the table. This command + works even if the automatic table editor has been turned off. + +- If the cursor is on a #+TBLFM line, re-apply the formulas to + the entire table. + +- If the cursor is at a footnote reference or definition, jump to + the corresponding definition or references, respectively. + +- If the cursor is a the beginning of a dynamic block, update it. + +- If the current buffer is a capture buffer, close note and file it. + +- If the cursor is on a <<<target>>>, update radio targets and + corresponding links in this buffer. + +- If the cursor is on a numbered item in a plain list, renumber the + ordered list. + +- If the cursor is on a checkbox, toggle it. + +- If the cursor is on a code block, evaluate it. The variable + `org-confirm-babel-evaluate' can be used to control prompting + before code block evaluation, by default every code block + evaluation requires confirmation. Code block evaluation can be + inhibited by setting `org-babel-no-eval-on-ctrl-c-ctrl-c'." + (interactive "P") + (let ((org-enable-table-editor t)) + (cond + ((or (and (boundp 'org-clock-overlays) org-clock-overlays) + org-occur-highlights + org-latex-fragment-image-overlays) + (and (boundp 'org-clock-overlays) (org-clock-remove-overlays)) + (org-remove-occur-highlights) + (org-remove-latex-fragment-image-overlays) + (message "Temporary highlights/overlays removed from current buffer")) + ((and (local-variable-p 'org-finish-function (current-buffer)) + (fboundp org-finish-function)) + (funcall org-finish-function)) + ((run-hook-with-args-until-success 'org-ctrl-c-ctrl-c-hook)) + ((or (looking-at org-property-start-re) + (org-at-property-p)) + (call-interactively 'org-property-action)) + ((org-on-target-p) (call-interactively 'org-update-radio-target-regexp)) + ((and (org-in-regexp "\\[\\([0-9]*%\\|[0-9]*/[0-9]*\\)\\]") + (or (org-on-heading-p) (org-at-item-p))) + (call-interactively 'org-update-statistics-cookies)) + ((org-on-heading-p) (call-interactively 'org-set-tags)) + ((org-at-table.el-p) + (message "Use C-c ' to edit table.el tables")) + ((org-at-table-p) + (org-table-maybe-eval-formula) + (if arg + (call-interactively 'org-table-recalculate) + (org-table-maybe-recalculate-line)) + (call-interactively 'org-table-align) + (orgtbl-send-table 'maybe)) + ((or (org-footnote-at-reference-p) + (org-footnote-at-definition-p)) + (call-interactively 'org-footnote-action)) + ((org-at-item-checkbox-p) + (call-interactively 'org-list-repair) + (call-interactively 'org-toggle-checkbox) + (org-list-send-list 'maybe)) + ((org-at-item-p) + (call-interactively 'org-list-repair) + (when arg (call-interactively 'org-toggle-checkbox)) + (org-list-send-list 'maybe)) + ((save-excursion (beginning-of-line 1) (looking-at org-dblock-start-re)) + ;; Dynamic block + (beginning-of-line 1) + (save-excursion (org-update-dblock))) + ((save-excursion + (beginning-of-line 1) + (looking-at "[ \t]*#\\+\\([A-Z]+\\)")) + (cond + ((equal (match-string 1) "TBLFM") + ;; Recalculate the table before this line + (save-excursion + (beginning-of-line 1) + (skip-chars-backward " \r\n\t") + (if (org-at-table-p) + (org-call-with-arg 'org-table-recalculate (or arg t))))) + (t + (let ((org-inhibit-startup-visibility-stuff t) + (org-startup-align-all-tables nil)) + (org-save-outline-visibility 'use-markers (org-mode-restart))) + (message "Local setup has been refreshed")))) + ((org-clock-update-time-maybe)) + (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. +Also updates the keyword regular expressions." + (interactive) + (org-mode) + (message "Org-mode restarted")) + +(defun org-kill-note-or-show-branches () + "If this is a Note buffer, abort storing the note. Else call `show-branches'." + (interactive) + (if (not org-finish-function) + (progn + (hide-subtree) + (call-interactively 'show-branches)) + (let ((org-note-abort t)) + (funcall org-finish-function)))) + +(defun org-return (&optional indent) + "Goto next table row or insert a newline. +Calls `org-table-next-row' or `newline', depending on context. +See the individual commands for more information." + (interactive) + (cond + ((bobp) (if indent (newline-and-indent) (newline))) + ((org-at-table-p) + (org-table-justify-field-maybe) + (call-interactively 'org-table-next-row)) + ((and org-return-follows-link + (eq (get-text-property (point) 'face) 'org-link)) + (call-interactively 'org-open-at-point)) + ((and (org-at-heading-p) + (looking-at + (org-re "\\([ \t]+\\(:[[:alnum:]_@#%:]+:\\)\\)[ \t]*$"))) + (org-show-entry) + (end-of-line 1) + (newline)) + (t (if indent (newline-and-indent) (newline))))) + +(defun org-return-indent () + "Goto next table row or insert a newline and indent. +Calls `org-table-next-row' or `newline-and-indent', depending on +context. See the individual commands for more information." + (interactive) + (org-return t)) + +(defun org-ctrl-c-star () + "Compute table, or change heading status of lines. +Calls `org-table-recalculate' or `org-toggle-heading', +depending on context." + (interactive) + (cond + ((org-at-table-p) + (call-interactively 'org-table-recalculate)) + (t + ;; Convert all lines in region to list items + (call-interactively 'org-toggle-heading)))) + +(defun org-ctrl-c-minus () + "Insert separator line in table or modify bullet status of line. +Also turns a plain line or a region of lines into list items. +Calls `org-table-insert-hline', `org-toggle-item', or +`org-cycle-list-bullet', depending on context." + (interactive) + (cond + ((org-at-table-p) + (call-interactively 'org-table-insert-hline)) + ((org-region-active-p) + (call-interactively 'org-toggle-item)) + ((org-in-item-p) + (call-interactively 'org-cycle-list-bullet)) + (t + (call-interactively 'org-toggle-item)))) + +(defun org-toggle-item () + "Convert headings or normal lines to items, items to normal lines. +If there is no active region, only the current line is considered. + +If the first line in the region is a headline, convert all headlines to items. + +If the first line in the region is an item, convert all items to normal lines. + +If the first line is normal text, add an item bullet to each line." + (interactive) + (let (l2 l beg end) + (if (org-region-active-p) + (setq beg (region-beginning) end (region-end)) + (setq beg (point-at-bol) + end (min (1+ (point-at-eol)) (point-max)))) + (save-excursion + (goto-char end) + (setq l2 (org-current-line)) + (goto-char beg) + (beginning-of-line 1) + (setq l (1- (org-current-line))) + (if (org-at-item-p) + ;; We already have items, de-itemize + (while (< (setq l (1+ l)) l2) + (when (org-at-item-p) + (skip-chars-forward " \t") + (delete-region (point) (match-end 0))) + (beginning-of-line 2)) + (if (org-on-heading-p) + ;; Headings, convert to items + (while (< (setq l (1+ l)) l2) + (if (looking-at org-outline-regexp) + (replace-match (org-list-bullet-string "-") t t)) + (beginning-of-line 2)) + ;; normal lines, turn them into items + (while (< (setq l (1+ l)) l2) + (unless (org-at-item-p) + (if (looking-at "\\([ \t]*\\)\\(\\S-\\)") + (replace-match + (concat "\\1" (org-list-bullet-string "-") "\\2")))) + (beginning-of-line 2))))))) + +(defun org-toggle-heading (&optional nstars) + "Convert headings to normal text, or items or text to headings. +If there is no active region, only the current line is considered. + +If the first line is a heading, remove the stars from all headlines +in the region. + +If the first line is a plain list item, turn all plain list items +into headings. + +If the first line is a normal line, turn each and every line in the +region into a heading. + +When converting a line into a heading, the number of stars is chosen +such that the lines become children of the current entry. However, +when a prefix argument is given, its value determines the number of +stars to add." + (interactive "P") + (let (l2 l itemp beg end) + (if (org-region-active-p) + (setq beg (region-beginning) end (region-end)) + (setq beg (point-at-bol) + end (min (1+ (point-at-eol)) (point-max)))) + (save-excursion + (goto-char end) + (setq l2 (org-current-line)) + (goto-char beg) + (beginning-of-line 1) + (setq l (1- (org-current-line))) + (if (org-on-heading-p) + ;; We already have headlines, de-star them + (while (< (setq l (1+ l)) l2) + (when (org-on-heading-p t) + (and (looking-at outline-regexp) (replace-match ""))) + (beginning-of-line 2)) + (setq itemp (org-at-item-p)) + (let* ((stars + (if nstars + (make-string (prefix-numeric-value current-prefix-arg) + ?*) + (save-excursion + (if (re-search-backward org-complex-heading-regexp nil t) + (match-string 1) "")))) + (add-stars (cond (nstars "") + ((equal stars "") "*") + (org-odd-levels-only "**") + (t "*"))) + (rpl (concat stars add-stars " "))) + (while (< (setq l (1+ l)) l2) + (if itemp + (and (org-at-item-p) (replace-match rpl t t)) + (unless (org-on-heading-p) + (if (looking-at "\\([ \t]*\\)\\(\\S-\\)") + (replace-match (concat rpl (match-string 2)))))) + (beginning-of-line 2))))))) + +(defun org-meta-return (&optional arg) + "Insert a new heading or wrap a region in a table. +Calls `org-insert-heading' or `org-table-wrap-region', depending on context. +See the individual commands for more information." + (interactive "P") + (cond + ((run-hook-with-args-until-success 'org-metareturn-hook)) + ((org-at-table-p) + (call-interactively 'org-table-wrap-region)) + (t (call-interactively 'org-insert-heading)))) + +;;; Menu entries + +;; Define the Org-mode menus +(easy-menu-define org-tbl-menu org-mode-map "Tbl menu" + '("Tbl" + ["Align" org-ctrl-c-ctrl-c :active (org-at-table-p)] + ["Next Field" org-cycle (org-at-table-p)] + ["Previous Field" org-shifttab (org-at-table-p)] + ["Next Row" org-return (org-at-table-p)] + "--" + ["Blank Field" org-table-blank-field (org-at-table-p)] + ["Edit Field" org-table-edit-field (org-at-table-p)] + ["Copy Field from Above" org-table-copy-down (org-at-table-p)] + "--" + ("Column" + ["Move Column Left" org-metaleft (org-at-table-p)] + ["Move Column Right" org-metaright (org-at-table-p)] + ["Delete Column" org-shiftmetaleft (org-at-table-p)] + ["Insert Column" org-shiftmetaright (org-at-table-p)]) + ("Row" + ["Move Row Up" org-metaup (org-at-table-p)] + ["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-ctrl-c-minus (org-at-table-p)]) + ("Rectangle" + ["Copy Rectangle" org-copy-special (org-at-table-p)] + ["Cut Rectangle" org-cut-special (org-at-table-p)] + ["Paste Rectangle" org-paste-special (org-at-table-p)] + ["Fill Rectangle" org-table-wrap-region (org-at-table-p)]) + "--" + ("Calculate" + ["Set Column Formula" org-table-eval-formula (org-at-table-p)] + ["Set Field Formula" (org-table-eval-formula '(4)) :active (org-at-table-p) :keys "C-u C-c ="] + ["Edit Formulas" org-edit-special (org-at-table-p)] + "--" + ["Recalculate line" org-table-recalculate (org-at-table-p)] + ["Recalculate all" (lambda () (interactive) (org-table-recalculate '(4))) :active (org-at-table-p) :keys "C-u C-c *"] + ["Iterate all" (lambda () (interactive) (org-table-recalculate '(16))) :active (org-at-table-p) :keys "C-u C-u C-c *"] + "--" + ["Toggle Recalculate Mark" org-table-rotate-recalc-marks (org-at-table-p)] + "--" + ["Sum Column/Rectangle" org-table-sum + (or (org-at-table-p) (org-region-active-p))] + ["Which Column?" org-table-current-column (org-at-table-p)]) + ["Debug Formulas" + org-table-toggle-formula-debugger + :style toggle :selected (org-bound-and-true-p org-table-formula-debug)] + ["Show Col/Row Numbers" + org-table-toggle-coordinate-overlays + :style toggle + :selected (org-bound-and-true-p org-table-overlay-coordinates)] + "--" + ["Create" org-table-create (and (not (org-at-table-p)) + org-enable-table-editor)] + ["Convert Region" org-table-convert-region (not (org-at-table-p 'any))] + ["Import from File" org-table-import (not (org-at-table-p))] + ["Export to File" org-table-export (org-at-table-p)] + "--" + ["Create/Convert from/to table.el" org-table-create-with-table.el t])) + +(easy-menu-define org-org-menu org-mode-map "Org menu" + '("Org" + ("Show/Hide" + ["Cycle Visibility" org-cycle :active (or (bobp) (outline-on-heading-p))] + ["Cycle Global Visibility" org-shifttab :active (not (org-at-table-p))] + ["Sparse Tree..." org-sparse-tree t] + ["Reveal Context" org-reveal t] + ["Show All" show-all t] + "--" + ["Subtree to indirect buffer" org-tree-to-indirect-buffer t]) + "--" + ["New Heading" org-insert-heading t] + ("Navigate Headings" + ["Up" outline-up-heading t] + ["Next" outline-next-visible-heading t] + ["Previous" outline-previous-visible-heading t] + ["Next Same Level" outline-forward-same-level t] + ["Previous Same Level" outline-backward-same-level t] + "--" + ["Jump" org-goto t]) + ("Edit Structure" + ["Move Subtree Up" org-shiftmetaup (not (org-at-table-p))] + ["Move Subtree Down" org-shiftmetadown (not (org-at-table-p))] + "--" + ["Copy Subtree" org-copy-special (not (org-at-table-p))] + ["Cut Subtree" org-cut-special (not (org-at-table-p))] + ["Paste Subtree" org-paste-special (not (org-at-table-p))] + "--" + ["Clone subtree, shift time" org-clone-subtree-with-time-shift t] + "--" + ["Promote Heading" org-metaleft (not (org-at-table-p))] + ["Promote Subtree" org-shiftmetaleft (not (org-at-table-p))] + ["Demote Heading" org-metaright (not (org-at-table-p))] + ["Demote Subtree" org-shiftmetaright (not (org-at-table-p))] + "--" + ["Sort Region/Children" org-sort (not (org-at-table-p))] + "--" + ["Convert to odd levels" org-convert-to-odd-levels t] + ["Convert to odd/even levels" org-convert-to-oddeven-levels t]) + ("Editing" + ["Emphasis..." org-emphasize t] + ["Edit Source Example" org-edit-special t] + "--" + ["Footnote new/jump" org-footnote-action t] + ["Footnote extra" (org-footnote-action t) :active t :keys "C-u C-c C-x f"]) + ("Archive" + ["Archive (default method)" org-archive-subtree-default t] + "--" + ["Move Subtree to Archive file" org-advertized-archive-subtree t] + ["Toggle ARCHIVE tag" org-toggle-archive-tag t] + ["Move subtree to Archive sibling" org-archive-to-archive-sibling t] + ) + "--" + ("Hyperlinks" + ["Store Link (Global)" org-store-link t] + ["Find existing link to here" org-occur-link-in-agenda-files t] + ["Insert Link" org-insert-link t] + ["Follow Link" org-open-at-point t] + "--" + ["Next link" org-next-link t] + ["Previous link" org-previous-link t] + "--" + ["Descriptive Links" + (progn (add-to-invisibility-spec '(org-link)) (org-restart-font-lock)) + :style radio + :selected (member '(org-link) buffer-invisibility-spec)] + ["Literal Links" + (progn + (org-remove-from-invisibility-spec '(org-link)) (org-restart-font-lock)) + :style radio + :selected (not (member '(org-link) buffer-invisibility-spec))]) + "--" + ("TODO Lists" + ["TODO/DONE/-" org-todo t] + ("Select keyword" + ["Next keyword" org-shiftright (org-on-heading-p)] + ["Previous keyword" org-shiftleft (org-on-heading-p)] + ["Complete Keyword" pcomplete (assq :todo-keyword (org-context))] + ["Next keyword set" org-shiftcontrolright (and (> (length org-todo-sets) 1) (org-on-heading-p))] + ["Previous keyword set" org-shiftcontrolright (and (> (length org-todo-sets) 1) (org-on-heading-p))]) + ["Show TODO Tree" org-show-todo-tree :active t :keys "C-c / t"] + ["Global TODO list" org-todo-list :active t :keys "C-c a t"] + "--" + ["Enforce dependencies" (customize-variable 'org-enforce-todo-dependencies) + :selected org-enforce-todo-dependencies :style toggle :active t] + "Settings for tree at point" + ["Do Children sequentially" org-toggle-ordered-property :style radio + :selected (ignore-errors (org-entry-get nil "ORDERED")) + :active org-enforce-todo-dependencies :keys "C-c C-x o"] + ["Do Children parallel" org-toggle-ordered-property :style radio + :selected (ignore-errors (not (org-entry-get nil "ORDERED"))) + :active org-enforce-todo-dependencies :keys "C-c C-x o"] + "--" + ["Set Priority" org-priority t] + ["Priority Up" org-shiftup t] + ["Priority Down" org-shiftdown t] + "--" + ["Get news from all feeds" org-feed-update-all t] + ["Go to the inbox of a feed..." org-feed-goto-inbox t] + ["Customize feeds" (customize-variable 'org-feed-alist) t]) + ("TAGS and Properties" + ["Set Tags" org-set-tags-command t] + ["Change tag in region" org-change-tag-in-region (org-region-active-p)] + "--" + ["Set property" org-set-property t] + ["Column view of properties" org-columns t] + ["Insert Column View DBlock" org-insert-columns-dblock t]) + ("Dates and Scheduling" + ["Timestamp" org-time-stamp t] + ["Timestamp (inactive)" org-time-stamp-inactive t] + ("Change Date" + ["1 Day Later" org-shiftright t] + ["1 Day Earlier" org-shiftleft t] + ["1 ... Later" org-shiftup t] + ["1 ... Earlier" org-shiftdown t]) + ["Compute Time Range" org-evaluate-time-range t] + ["Schedule Item" org-schedule t] + ["Deadline" org-deadline t] + "--" + ["Custom time format" org-toggle-time-stamp-overlays + :style radio :selected org-display-custom-times] + "--" + ["Goto Calendar" org-goto-calendar t] + ["Date from Calendar" org-date-from-calendar t] + "--" + ["Start/Restart Timer" org-timer-start t] + ["Pause/Continue Timer" org-timer-pause-or-continue t] + ["Stop Timer" org-timer-pause-or-continue :active t :keys "C-u C-c C-x ,"] + ["Insert Timer String" org-timer t] + ["Insert Timer Item" org-timer-item t]) + ("Logging work" + ["Clock in" org-clock-in :active t :keys "C-c C-x C-i"] + ["Switch task" (lambda () (interactive) (org-clock-in '(4))) :active t :keys "C-u C-c C-x C-i"] + ["Clock out" org-clock-out t] + ["Clock cancel" org-clock-cancel t] + "--" + ["Mark as default task" org-clock-mark-default-task t] + ["Clock in, mark as default" (lambda () (interactive) (org-clock-in '(16))) :active t :keys "C-u C-u C-c C-x C-i"] + ["Goto running clock" org-clock-goto t] + "--" + ["Display times" org-clock-display t] + ["Create clock table" org-clock-report t] + "--" + ["Record DONE time" + (progn (setq org-log-done (not org-log-done)) + (message "Switching to %s will %s record a timestamp" + (car org-done-keywords) + (if org-log-done "automatically" "not"))) + :style toggle :selected org-log-done]) + "--" + ["Agenda Command..." org-agenda t] + ["Set Restriction Lock" org-agenda-set-restriction-lock t] + ("File List for Agenda") + ("Special views current file" + ["TODO Tree" org-show-todo-tree t] + ["Check Deadlines" org-check-deadlines t] + ["Timeline" org-timeline t] + ["Tags/Property tree" org-match-sparse-tree t]) + "--" + ["Export/Publish..." org-export t] + ("LaTeX" + ["Org CDLaTeX mode" org-cdlatex-mode :style toggle + :selected org-cdlatex-mode] + ["Insert Environment" cdlatex-environment (fboundp 'cdlatex-environment)] + ["Insert math symbol" cdlatex-math-symbol (fboundp 'cdlatex-math-symbol)] + ["Modify math symbol" org-cdlatex-math-modify + (org-inside-LaTeX-fragment-p)] + ["Insert citation" org-reftex-citation t] + "--" + ["Template for BEAMER" org-insert-beamer-options-template t]) + "--" + ("MobileOrg" + ["Push Files and Views" org-mobile-push t] + ["Get Captured and Flagged" org-mobile-pull t] + ["Find FLAGGED Tasks" (org-agenda nil "?") :active t :keys "C-c a ?"] + "--" + ["Setup" (progn (require 'org-mobile) (customize-group 'org-mobile)) t]) + "--" + ("Documentation" + ["Show Version" org-version t] + ["Info Documentation" org-info t]) + ("Customize" + ["Browse Org Group" org-customize t] + "--" + ["Expand This Menu" org-create-customize-menu + (fboundp 'customize-menu-create)]) + ["Send bug report" org-submit-bug-report t] + "--" + ("Refresh/Reload" + ["Refresh setup current buffer" org-mode-restart t] + ["Reload Org (after update)" org-reload t] + ["Reload Org uncompiled" (org-reload t) :active t :keys "C-u C-c C-x r"]) + )) + +(defun org-info (&optional node) + "Read documentation for Org-mode in the info system. +With optional NODE, go directly to that node." + (interactive) + (info (format "(org)%s" (or node "")))) + +;;;###autoload +(defun org-submit-bug-report () + "Submit a bug report on Org-mode via mail. + +Don't hesitate to report any problems or inaccurate documentation. + +If you don't have setup sending mail from (X)Emacs, please copy the +output buffer into your mail program, as it gives us important +information about your Org-mode version and configuration." + (interactive) + (require 'reporter) + (org-load-modules-maybe) + (org-require-autoloaded-modules) + (let ((reporter-prompt-for-summary-p "Bug report subject: ")) + (reporter-submit-bug-report + "emacs-orgmode@gnu.org" + (org-version) + (let (list) + (save-window-excursion + (switch-to-buffer (get-buffer-create "*Warn about privacy*")) + (delete-other-windows) + (erase-buffer) + (insert "You are about to submit a bug report to the Org-mode mailing list. + +We would like to add your full Org-mode and Outline configuration to the +bug report. This greatly simplifies the work of the maintainer and +other experts on the mailing list. + +HOWEVER, some variables you have customized may contain private +information. The names of customers, colleagues, or friends, might +appear in the form of file names, tags, todo states, or search strings. +If you answer yes to the prompt, you might want to check and remove +such private information before sending the email.") + (add-text-properties (point-min) (point-max) '(face org-warning)) + (when (yes-or-no-p "Include your Org-mode configuration ") + (mapatoms + (lambda (v) + (and (boundp v) + (string-match "\\`\\(org-\\|outline-\\)" (symbol-name v)) + (or (and (symbol-value v) + (string-match "\\(-hook\\|-function\\)\\'" (symbol-name v))) + (and + (get v 'custom-type) (get v 'standard-value) + (not (equal (symbol-value v) (eval (car (get v 'standard-value))))))) + (push v list))))) + (kill-buffer (get-buffer "*Warn about privacy*")) + list)) + nil nil + "Remember to cover the basics, that is, what you expected to happen and +what in fact did happen. You don't know how to make a good report? See + + http://orgmode.org/manual/Feedback.html#Feedback + +Your bug report will be posted to the Org-mode mailing list. +------------------------------------------------------------------------") + (save-excursion + (if (re-search-backward "^\\(Subject: \\)Org-mode version \\(.*?\\);[ \t]*\\(.*\\)" nil t) + (replace-match "\\1Bug: \\3 [\\2]"))))) + + +(defun org-install-agenda-files-menu () + (let ((bl (buffer-list))) + (save-excursion + (while bl + (set-buffer (pop bl)) + (if (org-mode-p) (setq bl nil))) + (when (org-mode-p) + (easy-menu-change + '("Org") "File List for Agenda" + (append + (list + ["Edit File List" (org-edit-agenda-file-list) 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] + ["Occur in all agenda files" org-occur-in-agenda-files t] + "--") + (mapcar 'org-file-menu-entry (org-agenda-files t)))))))) + +;;;; Documentation + +;;;###autoload +(defun org-require-autoloaded-modules () + (interactive) + (mapc 'require + '(org-agenda org-archive org-ascii org-attach org-clock org-colview + org-docbook org-exp org-html org-icalendar + org-id org-latex + org-publish org-remember org-table + org-timer org-xoxo))) + +;;;###autoload +(defun org-reload (&optional uncompiled) + "Reload all org lisp files. +With prefix arg UNCOMPILED, load the uncompiled versions." + (interactive "P") + (require 'find-func) + (let* ((file-re "^\\(org\\|orgtbl\\)\\(\\.el\\|-.*\\.el\\)") + (dir-org (file-name-directory (org-find-library-name "org"))) + (dir-org-contrib (ignore-errors + (file-name-directory + (org-find-library-name "org-contribdir")))) + (babel-files + (mapcar (lambda (el) (concat "ob" (when el (format "-%s" el)) ".el")) + (append (list nil "comint" "eval" "exp" "keys" + "lob" "ref" "table" "tangle") + (delq nil + (mapcar + (lambda (lang) + (when (cdr lang) (symbol-name (car lang)))) + org-babel-load-languages))))) + (files + (append (directory-files dir-org t file-re) + babel-files + (and dir-org-contrib + (directory-files dir-org-contrib t file-re)))) + (remove-re (concat (if (featurep 'xemacs) + "org-colview" "org-colview-xemacs") + "\\'"))) + (setq files (mapcar 'file-name-sans-extension files)) + (setq files (mapcar + (lambda (x) (if (string-match remove-re x) nil x)) + files)) + (setq files (delq nil files)) + (mapc + (lambda (f) + (when (featurep (intern (file-name-nondirectory f))) + (if (and (not uncompiled) + (file-exists-p (concat f ".elc"))) + (load (concat f ".elc") nil nil t) + (load (concat f ".el") nil nil t)))) + files)) + (org-version)) + +;;;###autoload +(defun org-customize () + "Call the customize function with org as argument." + (interactive) + (org-load-modules-maybe) + (org-require-autoloaded-modules) + (customize-browse 'org)) + +(defun org-create-customize-menu () + "Create a full customization menu for Org-mode, insert it into the menu." + (interactive) + (org-load-modules-maybe) + (org-require-autoloaded-modules) + (if (fboundp 'customize-menu-create) + (progn + (easy-menu-change + '("Org") "Customize" + `(["Browse Org group" org-customize t] + "--" + ,(customize-menu-create 'org) + ["Set" Custom-set t] + ["Save" Custom-save t] + ["Reset to Current" Custom-reset-current t] + ["Reset to Saved" Custom-reset-saved t] + ["Reset to Standard Settings" Custom-reset-standard t])) + (message "\"Org\"-menu now contains full customization menu")) + (error "Cannot expand menu (outdated version of cus-edit.el)"))) + +;;;; Miscellaneous stuff + +;;; Generally useful functions + +(defun org-get-at-bol (property) + "Get text property PROPERTY at beginning of line." + (get-text-property (point-at-bol) property)) + +(defun org-find-text-property-in-string (prop s) + "Return the first non-nil value of property PROP in string S." + (or (get-text-property 0 prop s) + (get-text-property (or (next-single-property-change 0 prop s) 0) + prop s))) + +(defun org-display-warning (message) ;; Copied from Emacs-Muse + "Display the given MESSAGE as a warning." + (if (fboundp 'display-warning) + (display-warning 'org message + (if (featurep 'xemacs) 'warning :warning)) + (let ((buf (get-buffer-create "*Org warnings*"))) + (with-current-buffer buf + (goto-char (point-max)) + (insert "Warning (Org): " message) + (unless (bolp) + (newline))) + (display-buffer buf) + (sit-for 0)))) + +(defun org-in-commented-line () + "Is point in a line starting with `#'?" + (equal (char-after (point-at-bol)) ?#)) + +(defun org-in-indented-comment-line () + "Is point in a line starting with `#' after some white space?" + (save-excursion + (save-match-data + (goto-char (point-at-bol)) + (looking-at "[ \t]*#")))) + +(defun org-in-verbatim-emphasis () + (save-match-data + (and (org-in-regexp org-emph-re 2) (member (match-string 3) '("=" "~"))))) + +(defun org-goto-marker-or-bmk (marker &optional bookmark) + "Go to MARKER, widen if necessary. When marker is not live, try BOOKMARK." + (if (and marker (marker-buffer marker) + (buffer-live-p (marker-buffer marker))) + (progn + (switch-to-buffer (marker-buffer marker)) + (if (or (> marker (point-max)) (< marker (point-min))) + (widen)) + (goto-char marker) + (org-show-context 'org-goto)) + (if bookmark + (bookmark-jump bookmark) + (error "Cannot find location")))) + +(defun org-quote-csv-field (s) + "Quote field for inclusion in CSV material." + (if (string-match "[\",]" s) + (concat "\"" (mapconcat 'identity (split-string s "\"") "\"\"") "\"") + s)) + +(defun org-plist-delete (plist property) + "Delete PROPERTY from PLIST. +This is in contrast to merely setting it to 0." + (let (p) + (while plist + (if (not (eq property (car plist))) + (setq p (plist-put p (car plist) (nth 1 plist)))) + (setq plist (cddr plist))) + p)) + +(defun org-force-self-insert (N) + "Needed to enforce self-insert under remapping." + (interactive "p") + (self-insert-command N)) + +(defun org-string-width (s) + "Compute width of string, ignoring invisible characters. +This ignores character with invisibility property `org-link', and also +characters with property `org-cwidth', because these will become invisible +upon the next fontification round." + (let (b l) + (when (or (eq t buffer-invisibility-spec) + (assq 'org-link buffer-invisibility-spec)) + (while (setq b (text-property-any 0 (length s) + 'invisible 'org-link s)) + (setq s (concat (substring s 0 b) + (substring s (or (next-single-property-change + b 'invisible s) (length s))))))) + (while (setq b (text-property-any 0 (length s) 'org-cwidth t s)) + (setq s (concat (substring s 0 b) + (substring s (or (next-single-property-change + b 'org-cwidth s) (length s)))))) + (setq l (string-width s) b -1) + (while (setq b (text-property-any (1+ b) (length s) 'org-dwidth t s)) + (setq l (- l (get-text-property b 'org-dwidth-n s)))) + l)) + +(defun org-shorten-string (s maxlength) + "Shorten string S so tht it is no longer than MAXLENGTH characters. +If the string is shorter or has length MAXLENGTH, just return the +original string. If it is longer, the functions finds a space in the +string, breaks this string off at that locations and adds three dots +as ellipsis. Including the ellipsis, the string will not be longer +than MAXLENGTH. If finding a good breaking point in the string does +not work, the string is just chopped off in the middle of a word +if necessary." + (if (<= (length s) maxlength) + s + (let* ((n (max (- maxlength 4) 1)) + (re (concat "\\`\\(.\\{1," (int-to-string n) "\\}[^ ]\\)\\([ ]\\|\\'\\)"))) + (if (string-match re s) + (concat (match-string 1 s) "...") + (concat (substring s 0 (max (- maxlength 3) 0)) "..."))))) + +(defun org-get-indentation (&optional line) + "Get the indentation of the current line, interpreting tabs. +When LINE is given, assume it represents a line and compute its indentation." + (if line + (if (string-match "^ *" (org-remove-tabs line)) + (match-end 0)) + (save-excursion + (beginning-of-line 1) + (skip-chars-forward " \t") + (current-column)))) + +(defun org-remove-tabs (s &optional width) + "Replace tabulators in S with spaces. +Assumes that s is a single line, starting in column 0." + (setq width (or width tab-width)) + (while (string-match "\t" s) + (setq s (replace-match + (make-string + (- (* width (/ (+ (match-beginning 0) width) width)) + (match-beginning 0)) ?\ ) + t t s))) + s) + +(defun org-fix-indentation (line ind) + "Fix indentation in LINE. +IND is a cons cell with target and minimum indentation. +If the current indentation in LINE is smaller than the minimum, +leave it alone. If it is larger than ind, set it to the target." + (let* ((l (org-remove-tabs line)) + (i (org-get-indentation l)) + (i1 (car ind)) (i2 (cdr ind))) + (if (>= i i2) (setq l (substring line i2))) + (if (> i1 0) + (concat (make-string i1 ?\ ) l) + l))) + +(defun org-remove-indentation (code &optional n) + "Remove the maximum common indentation from the lines in CODE. +N may optionally be the number of spaces to remove." + (with-temp-buffer + (insert code) + (org-do-remove-indentation n) + (buffer-string))) + +(defun org-do-remove-indentation (&optional n) + "Remove the maximum common indentation from the buffer." + (untabify (point-min) (point-max)) + (let ((min 10000) re) + (if n + (setq min n) + (goto-char (point-min)) + (while (re-search-forward "^ *[^ \n]" nil t) + (setq min (min min (1- (- (match-end 0) (match-beginning 0))))))) + (unless (or (= min 0) (= min 10000)) + (setq re (format "^ \\{%d\\}" min)) + (goto-char (point-min)) + (while (re-search-forward re nil t) + (replace-match "") + (end-of-line 1)) + min))) + +(defun org-fill-template (template alist) + "Find each %key of ALIST in TEMPLATE and replace it." + (let ((case-fold-search nil) + entry key value) + (setq alist (sort (copy-sequence alist) + (lambda (a b) (< (length (car a)) (length (car b)))))) + (while (setq entry (pop alist)) + (setq template + (replace-regexp-in-string + (concat "%" (regexp-quote (car entry))) + (cdr entry) template t t))) + template)) + +(defun org-base-buffer (buffer) + "Return the base buffer of BUFFER, if it has one. Else return the buffer." + (if (not buffer) + buffer + (or (buffer-base-buffer buffer) + buffer))) + +(defun org-trim (s) + "Remove whitespace at beginning and end of string." + (if (string-match "\\`[ \t\n\r]+" s) (setq s (replace-match "" t t s))) + (if (string-match "[ \t\n\r]+\\'" s) (setq s (replace-match "" t t s))) + s) + +(defun org-wrap (string &optional width lines) + "Wrap string to either a number of lines, or a width in characters. +If WIDTH is non-nil, the string is wrapped to that width, however many lines +that costs. If there is a word longer than WIDTH, the text is actually +wrapped to the length of that word. +IF WIDTH is nil and LINES is non-nil, the string is forced into at most that +many lines, whatever width that takes. +The return value is a list of lines, without newlines at the end." + (let* ((words (org-split-string string "[ \t\n]+")) + (maxword (apply 'max (mapcar 'org-string-width words))) + w ll) + (cond (width + (org-do-wrap words (max maxword width))) + (lines + (setq w maxword) + (setq ll (org-do-wrap words maxword)) + (if (<= (length ll) lines) + ll + (setq ll words) + (while (> (length ll) lines) + (setq w (1+ w)) + (setq ll (org-do-wrap words w))) + ll)) + (t (error "Cannot wrap this"))))) + +(defun org-do-wrap (words width) + "Create lines of maximum width WIDTH (in characters) from word list WORDS." + (let (lines line) + (while words + (setq line (pop words)) + (while (and words (< (+ (length line) (length (car words))) width)) + (setq line (concat line " " (pop words)))) + (setq lines (push line lines))) + (nreverse lines))) + +(defun org-split-string (string &optional separators) + "Splits STRING into substrings at SEPARATORS. +No empty strings are returned if there are matches at the beginning +and end of string." + (let ((rexp (or separators "[ \f\t\n\r\v]+")) + (start 0) + notfirst + (list nil)) + (while (and (string-match rexp string + (if (and notfirst + (= start (match-beginning 0)) + (< start (length string))) + (1+ start) start)) + (< (match-beginning 0) (length string))) + (setq notfirst t) + (or (eq (match-beginning 0) 0) + (and (eq (match-beginning 0) (match-end 0)) + (eq (match-beginning 0) start)) + (setq list + (cons (substring string start (match-beginning 0)) + list))) + (setq start (match-end 0))) + (or (eq start (length string)) + (setq list + (cons (substring string start) + list))) + (nreverse list))) + +(defun org-quote-vert (s) + "Replace \"|\" with \"\\vert\"." + (while (string-match "|" s) + (setq s (replace-match "\\vert" t t s))) + s) + +(defun org-uuidgen-p (s) + "Is S an ID created by UUIDGEN?" + (string-match "\\`[0-9a-f]\\{8\\}-[0-9a-f]\\{4\\}-[0-9a-f]\\{4\\}-[0-9a-f]\\{4\\}-[0-9a-f]\\{12\\}\\'" (downcase s))) + +(defun org-context () + "Return a list of contexts of the current cursor position. +If several contexts apply, all are returned. +Each context entry is a list with a symbol naming the context, and +two positions indicating start and end of the context. Possible +contexts are: + +:headline anywhere in a headline +:headline-stars on the leading stars in a headline +:todo-keyword on a TODO keyword (including DONE) in a headline +:tags on the TAGS in a headline +:priority on the priority cookie in a headline +:item on the first line of a plain list item +:item-bullet on the bullet/number of a plain list item +:checkbox on the checkbox in a plain list item +:table in an org-mode table +:table-special on a special filed in a table +:table-table in a table.el table +:link on a hyperlink +:keyword on a keyword: SCHEDULED, DEADLINE, CLOSE,COMMENT, QUOTE. +:target on a <<target>> +:radio-target on a <<<radio-target>>> +:latex-fragment on a LaTeX fragment +:latex-preview on a LaTeX fragment with overlayed preview image + +This function expects the position to be visible because it uses font-lock +faces as a help to recognize the following contexts: :table-special, :link, +and :keyword." + (let* ((f (get-text-property (point) 'face)) + (faces (if (listp f) f (list f))) + (p (point)) clist o) + ;; First the large context + (cond + ((org-on-heading-p t) + (push (list :headline (point-at-bol) (point-at-eol)) clist) + (when (progn + (beginning-of-line 1) + (looking-at org-todo-line-tags-regexp)) + (push (org-point-in-group p 1 :headline-stars) clist) + (push (org-point-in-group p 2 :todo-keyword) clist) + (push (org-point-in-group p 4 :tags) clist)) + (goto-char p) + (skip-chars-backward "^[\n\r \t") (or (bobp) (backward-char 1)) + (if (looking-at "\\[#[A-Z0-9]\\]") + (push (org-point-in-group p 0 :priority) clist))) + + ((org-at-item-p) + (push (org-point-in-group p 2 :item-bullet) clist) + (push (list :item (point-at-bol) + (save-excursion (org-end-of-item) (point))) + clist) + (and (org-at-item-checkbox-p) + (push (org-point-in-group p 0 :checkbox) clist))) + + ((org-at-table-p) + (push (list :table (org-table-begin) (org-table-end)) clist) + (if (memq 'org-formula faces) + (push (list :table-special + (previous-single-property-change p 'face) + (next-single-property-change p 'face)) clist))) + ((org-at-table-p 'any) + (push (list :table-table) clist))) + (goto-char p) + + ;; Now the small context + (cond + ((org-at-timestamp-p) + (push (org-point-in-group p 0 :timestamp) clist)) + ((memq 'org-link faces) + (push (list :link + (previous-single-property-change p 'face) + (next-single-property-change p 'face)) clist)) + ((memq 'org-special-keyword faces) + (push (list :keyword + (previous-single-property-change p 'face) + (next-single-property-change p 'face)) clist)) + ((org-on-target-p) + (push (org-point-in-group p 0 :target) clist) + (goto-char (1- (match-beginning 0))) + (if (looking-at org-radio-target-regexp) + (push (org-point-in-group p 0 :radio-target) clist)) + (goto-char p)) + ((setq o (car (delq nil + (mapcar + (lambda (x) + (if (memq x org-latex-fragment-image-overlays) x)) + (overlays-at (point)))))) + (push (list :latex-fragment + (overlay-start o) (overlay-end o)) clist) + (push (list :latex-preview + (overlay-start o) (overlay-end o)) clist)) + ((org-inside-LaTeX-fragment-p) + ;; FIXME: positions wrong. + (push (list :latex-fragment (point) (point)) clist))) + + (setq clist (nreverse (delq nil clist))) + clist)) + +;; FIXME: Compare with at-regexp-p Do we need both? +(defun org-in-regexp (re &optional nlines visually) + "Check if point is inside a match of regexp. +Normally only the current line is checked, but you can include NLINES extra +lines both before and after point into the search. +If VISUALLY is set, require that the cursor is not after the match but +really on, so that the block visually is on the match." + (catch 'exit + (let ((pos (point)) + (eol (point-at-eol (+ 1 (or nlines 0)))) + (inc (if visually 1 0))) + (save-excursion + (beginning-of-line (- 1 (or nlines 0))) + (while (re-search-forward re eol t) + (if (and (<= (match-beginning 0) pos) + (>= (+ inc (match-end 0)) pos)) + (throw 'exit (cons (match-beginning 0) (match-end 0))))))))) + +(defun org-at-regexp-p (regexp) + "Is point inside a match of REGEXP in the current line?" + (catch 'exit + (save-excursion + (let ((pos (point)) (end (point-at-eol))) + (beginning-of-line 1) + (while (re-search-forward regexp end t) + (if (and (<= (match-beginning 0) pos) + (>= (match-end 0) pos)) + (throw 'exit t))) + nil)))) + +(defun org-in-regexps-block-p (start-re end-re &optional bound) + "Return t if the current point is between matches of START-RE and END-RE. +This will also return t if point is on one of the two matches or +in an unfinished block. END-RE can be a string or a form +returning a string. + +An optional third argument bounds the search for START-RE. It +defaults to previous heading or `point-min'." + (let ((pos (point)) + (limit (or bound (save-excursion (outline-previous-heading))))) + (save-excursion + ;; we're on a block when point is on start-re... + (or (org-at-regexp-p start-re) + ;; ... or start-re can be found above... + (and (re-search-backward start-re limit t) + ;; ... but no end-re between start-re and point. + (not (re-search-forward (eval end-re) pos t))))))) + +(defun org-occur-in-agenda-files (regexp &optional nlines) + "Call `multi-occur' with buffers for all agenda files." + (interactive "sOrg-files matching: \np") + (let* ((files (org-agenda-files)) + (tnames (mapcar 'file-truename files)) + (extra org-agenda-text-search-extra-files) + f) + (when (eq (car extra) 'agenda-archives) + (setq extra (cdr extra)) + (setq files (org-add-archive-files files))) + (while (setq f (pop extra)) + (unless (member (file-truename f) tnames) + (add-to-list 'files f 'append) + (add-to-list 'tnames (file-truename f) 'append))) + (multi-occur + (mapcar (lambda (x) + (with-current-buffer + (or (get-file-buffer x) (find-file-noselect x)) + (widen) + (current-buffer))) + files) + regexp))) + +(if (boundp 'occur-mode-find-occurrence-hook) + ;; Emacs 23 + (add-hook 'occur-mode-find-occurrence-hook + (lambda () + (when (org-mode-p) + (org-reveal)))) + ;; Emacs 22 + (defadvice occur-mode-goto-occurrence + (after org-occur-reveal activate) + (and (org-mode-p) (org-reveal))) + (defadvice occur-mode-goto-occurrence-other-window + (after org-occur-reveal activate) + (and (org-mode-p) (org-reveal))) + (defadvice occur-mode-display-occurrence + (after org-occur-reveal activate) + (when (org-mode-p) + (let ((pos (occur-mode-find-occurrence))) + (with-current-buffer (marker-buffer pos) + (save-excursion + (goto-char pos) + (org-reveal))))))) + +(defun org-occur-link-in-agenda-files () + "Create a link and search for it in the agendas. +The link is not stored in `org-stored-links', it is just created +for the search purpose." + (interactive) + (let ((link (condition-case nil + (org-store-link nil) + (error "Unable to create a link to here")))) + (org-occur-in-agenda-files (regexp-quote link)))) + +(defun org-uniquify (list) + "Remove duplicate elements from LIST." + (let (res) + (mapc (lambda (x) (add-to-list 'res x 'append)) list) + res)) + +(defun org-delete-all (elts list) + "Remove all elements in ELTS from LIST." + (while elts + (setq list (delete (pop elts) list))) + list) + +(defun org-count (cl-item cl-seq) + "Count the number of occurrences of ITEM in SEQ. +Taken from `count' in cl-seq.el with all keyword arguments removed." + (let ((cl-end (length cl-seq)) (cl-start 0) (cl-count 0) cl-x) + (when (consp cl-seq) (setq cl-seq (nthcdr cl-start cl-seq))) + (while (< cl-start cl-end) + (setq cl-x (if (consp cl-seq) (pop cl-seq) (aref cl-seq cl-start))) + (if (equal cl-item cl-x) (setq cl-count (1+ cl-count))) + (setq cl-start (1+ cl-start))) + cl-count)) + +(defun org-remove-if (predicate seq) + "Remove everything from SEQ that fulfills PREDICATE." + (let (res e) + (while seq + (setq e (pop seq)) + (if (not (funcall predicate e)) (push e res))) + (nreverse res))) + +(defun org-remove-if-not (predicate seq) + "Remove everything from SEQ that does not fulfill PREDICATE." + (let (res e) + (while seq + (setq e (pop seq)) + (if (funcall predicate e) (push e res))) + (nreverse res))) + +(defun org-back-over-empty-lines () + "Move backwards over whitespace, to the beginning of the first empty line. +Returns the number of empty lines passed." + (let ((pos (point))) + (skip-chars-backward " \t\n\r") + (beginning-of-line 2) + (goto-char (min (point) pos)) + (count-lines (point) pos))) + +(defun org-skip-whitespace () + (skip-chars-forward " \t\n\r")) + +(defun org-point-in-group (point group &optional context) + "Check if POINT is in match-group GROUP. +If CONTEXT is non-nil, return a list with CONTEXT and the boundaries of the +match. If the match group does not exist or point is not inside it, +return nil." + (and (match-beginning group) + (>= point (match-beginning group)) + (<= point (match-end group)) + (if context + (list context (match-beginning group) (match-end group)) + t))) + +(defun org-switch-to-buffer-other-window (&rest args) + "Switch to buffer in a second window on the current frame. +In particular, do not allow pop-up frames. +Returns the newly created buffer." + (let (pop-up-frames special-display-buffer-names special-display-regexps + special-display-function) + (apply 'switch-to-buffer-other-window args))) + +(defun org-combine-plists (&rest plists) + "Create a single property list from all plists in PLISTS. +The process starts by copying the first list, and then setting properties +from the other lists. Settings in the last list are the most significant +ones and overrule settings in the other lists." + (let ((rtn (copy-sequence (pop plists))) + p v ls) + (while plists + (setq ls (pop plists)) + (while ls + (setq p (pop ls) v (pop ls)) + (setq rtn (plist-put rtn p v)))) + rtn)) + +(defun org-move-line-down (arg) + "Move the current line down. With prefix argument, move it past ARG lines." + (interactive "p") + (let ((col (current-column)) + beg end pos) + (beginning-of-line 1) (setq beg (point)) + (beginning-of-line 2) (setq end (point)) + (beginning-of-line (+ 1 arg)) + (setq pos (move-marker (make-marker) (point))) + (insert (delete-and-extract-region beg end)) + (goto-char pos) + (org-move-to-column col))) + +(defun org-move-line-up (arg) + "Move the current line up. With prefix argument, move it past ARG lines." + (interactive "p") + (let ((col (current-column)) + beg end pos) + (beginning-of-line 1) (setq beg (point)) + (beginning-of-line 2) (setq end (point)) + (beginning-of-line (- arg)) + (setq pos (move-marker (make-marker) (point))) + (insert (delete-and-extract-region beg end)) + (goto-char pos) + (org-move-to-column col))) + +(defun org-replace-escapes (string table) + "Replace %-escapes in STRING with values in TABLE. +TABLE is an association list with keys like \"%a\" and string values. +The sequences in STRING may contain normal field width and padding information, +for example \"%-5s\". Replacements happen in the sequence given by TABLE, +so values can contain further %-escapes if they are define later in TABLE." + (let ((tbl (copy-alist table)) + (case-fold-search nil) + (pchg 0) + e re rpl) + (while (setq e (pop tbl)) + (setq re (concat "%-?[0-9.]*" (substring (car e) 1))) + (when (and (cdr e) (string-match re (cdr e))) + (let ((sref (substring (cdr e) (match-beginning 0) (match-end 0))) + (safe "SREF")) + (add-text-properties 0 3 (list 'sref sref) safe) + (setcdr e (replace-match safe t t (cdr e))))) + (while (string-match re string) + (setq rpl (format (concat (substring (match-string 0 string) 0 -1) "s") + (cdr e))) + (setq string (replace-match rpl t t string)))) + (while (setq pchg (next-property-change pchg string)) + (let ((sref (get-text-property pchg 'sref string))) + (when (and sref (string-match "SREF" string pchg)) + (setq string (replace-match sref t t string))))) + string)) + +(defun org-sublist (list start end) + "Return a section of LIST, from START to END. +Counting starts at 1." + (let (rtn (c start)) + (setq list (nthcdr (1- start) list)) + (while (and list (<= c end)) + (push (pop list) rtn) + (setq c (1+ c))) + (nreverse rtn))) + +(defun org-find-base-buffer-visiting (file) + "Like `find-buffer-visiting' but always return the base buffer and +not an indirect buffer." + (let ((buf (or (get-file-buffer file) + (find-buffer-visiting file)))) + (if buf + (or (buffer-base-buffer buf) buf) + nil))) + +(defun org-image-file-name-regexp (&optional extensions) + "Return regexp matching the file names of images. +If EXTENSIONS is given, only match these." + (if (and (not extensions) (fboundp 'image-file-name-regexp)) + (image-file-name-regexp) + (let ((image-file-name-extensions + (or extensions + '("png" "jpeg" "jpg" "gif" "tiff" "tif" + "xbm" "xpm" "pbm" "pgm" "ppm")))) + (concat "\\." + (regexp-opt (nconc (mapcar 'upcase + image-file-name-extensions) + image-file-name-extensions) + t) + "\\'")))) + +(defun org-file-image-p (file &optional extensions) + "Return non-nil if FILE is an image." + (save-match-data + (string-match (org-image-file-name-regexp extensions) file))) + +(defun org-get-cursor-date () + "Return the date at cursor in as a time. +This works in the calendar and in the agenda, anywhere else it just +returns the current time." + (let (date day defd) + (cond + ((eq major-mode 'calendar-mode) + (setq date (calendar-cursor-to-date) + defd (encode-time 0 0 0 (nth 1 date) (nth 0 date) (nth 2 date)))) + ((eq major-mode 'org-agenda-mode) + (setq day (get-text-property (point) 'day)) + (if day + (setq date (calendar-gregorian-from-absolute day) + defd (encode-time 0 0 0 (nth 1 date) (nth 0 date) + (nth 2 date)))))) + (or defd (current-time)))) + +(defvar org-agenda-action-marker (make-marker) + "Marker pointing to the entry for the next agenda action.") + +(defun org-mark-entry-for-agenda-action () + "Mark the current entry as target of an agenda action. +Agenda actions are actions executed from the agenda with the key `k', +which make use of the date at the cursor." + (interactive) + (move-marker org-agenda-action-marker + (save-excursion (org-back-to-heading t) (point)) + (current-buffer)) + (message + "Entry marked for action; press `k' at desired date in agenda or calendar")) + +(defun org-mark-subtree () + "Mark the current subtree. +This puts point at the start of the current subtree, and mark at the end. + +If point is in an inline task, mark that task instead." + (interactive) + (let ((inline-task-p + (and (featurep 'org-inlinetask) + (org-inlinetask-in-task-p))) + (beg)) + ;; Get beginning of subtree + (cond + (inline-task-p (org-inlinetask-goto-beginning)) + ((org-at-heading-p) (beginning-of-line)) + (t (let ((outline-regexp (org-get-limited-outline-regexp))) + (outline-previous-visible-heading 1)))) + (setq beg (point)) + ;; Get end of it + (if inline-task-p + (org-inlinetask-goto-end) + (org-end-of-subtree)) + ;; Mark zone + (push-mark (point) nil t) + (goto-char beg))) + +;;; Paragraph filling stuff. +;; We want this to be just right, so use the full arsenal. + +(defun org-indent-line-function () + "Indent line depending on context." + (interactive) + (let* ((pos (point)) + (itemp (org-at-item-p)) + (case-fold-search t) + (org-drawer-regexp (or org-drawer-regexp "\000")) + (inline-task-p (and (featurep 'org-inlinetask) + (org-inlinetask-in-task-p))) + column bpos bcol tpos tcol) + (beginning-of-line 1) + (cond + ;; Comments + ((looking-at "# ") (setq column 0)) + ;; Headings + ((looking-at "\\*+ ") (setq column 0)) + ;; Literal examples + ((looking-at "[ \t]*:[ \t]") + (setq column (org-get-indentation))) ; do nothing + ;; Drawers + ((and (looking-at "[ \t]*:END:") + (save-excursion (re-search-backward org-drawer-regexp nil t))) + (save-excursion + (goto-char (1- (match-beginning 1))) + (setq column (current-column)))) + ;; Special blocks + ((and (looking-at "[ \t]*#\\+end_\\([a-z]+\\)") + (save-excursion + (re-search-backward + (concat "^[ \t]*#\\+begin_" (downcase (match-string 1))) nil t))) + (setq column (org-get-indentation (match-string 0)))) + ((and (not (looking-at "[ \t]*#\\+begin_")) + (org-in-regexps-block-p "^[ \t]*#\\+begin_" "[ \t]*#\\+end_")) + (save-excursion + (re-search-backward "^[ \t]*#\\+begin_\\([a-z]+\\)" nil t)) + (setq column + (if (equal (downcase (match-string 1)) "src") + ;; src blocks: let `org-edit-src-exit' handle them + (org-get-indentation) + (org-get-indentation (match-string 0))))) + ;; Lists + ((org-in-item-p) + (org-beginning-of-item) + (looking-at "[ \t]*\\(\\S-+\\)[ \t]*\\(\\(:?\\[@\\(:?start:\\)?[0-9]+\\][ \t]*\\)?\\[[- X]\\][ \t]*\\|.*? :: \\)?") + (setq bpos (match-beginning 1) tpos (match-end 0) + bcol (progn (goto-char bpos) (current-column)) + tcol (progn (goto-char tpos) (current-column))) + (if (> tcol (+ bcol org-description-max-indent)) + (setq tcol (+ bcol 5))) + (goto-char pos) + (setq column (if itemp (org-get-indentation) tcol))) + ;; This line has nothing special, look at the previous relevant + ;; line to compute indentation + (t + (beginning-of-line 0) + (while (and (not (bobp)) + (not (looking-at org-drawer-regexp)) + ;; skip comments, verbatim, empty lines, tables, + ;; inline tasks, lists, drawers and blocks + (or (and (looking-at "[ \t]*:END:") + (re-search-backward org-drawer-regexp nil t)) + (and (looking-at "[ \t]*#\\+end_") + (re-search-backward "[ \t]*#\\+begin_"nil t)) + (looking-at "[ \t]*[\n:#|]") + (and (org-in-item-p) (goto-char (org-list-top-point))) + (and (not inline-task-p) + (featurep 'org-inlinetask) + (org-inlinetask-in-task-p) + (or (org-inlinetask-goto-beginning) t)))) + (beginning-of-line 0)) + (cond + ;; There was an heading above. + ((looking-at "\\*+[ \t]+") + (if (not org-adapt-indentation) + (setq column 0) + (goto-char (match-end 0)) + (setq column (current-column)))) + ;; A drawer had started and is unfinished + ((looking-at org-drawer-regexp) + (goto-char (1- (match-beginning 1))) + (setq column (current-column))) + ;; Else, nothing noticeable found: get indentation and go on. + (t (setq column (org-get-indentation)))))) + ;; Now apply indentation and move cursor accordingly + (goto-char pos) + (if (<= (current-column) (current-indentation)) + (org-indent-line-to column) + (save-excursion (org-indent-line-to column))) + ;; Special polishing for properties, see `org-property-format' + (setq column (current-column)) + (beginning-of-line 1) + (if (looking-at + "\\([ \t]+\\)\\(:[-_0-9a-zA-Z]+:\\)[ \t]*\\(\\S-.*\\(\\S-\\|$\\)\\)") + (replace-match (concat (match-string 1) + (format org-property-format + (match-string 2) (match-string 3))) + t t)) + (org-move-to-column column))) + +(defvar org-adaptive-fill-regexp-backup adaptive-fill-regexp + "Variable to store copy of `adaptive-fill-regexp'. +Since `adaptive-fill-regexp' is set to never match, we need to +store a backup of its value before entering `org-mode' so that +the functionality can be provided as a fall-back.") + +(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. + (org-set-local 'comment-start-skip "^#+[ \t]*") + (org-set-local 'paragraph-separate "\f\\|\\*+ \\|[ ]*$\\|[ \t]*[:|#]") + ;; The paragraph starter includes hand-formatted lists. + (org-set-local + 'paragraph-start + (concat + "\f" "\\|" + "[ ]*$" "\\|" + "\\*+ " "\\|" + "[ \t]*#" "\\|" + "[ \t]*\\([-+*][ \t]+\\|[0-9]+[.)][ \t]+\\)" "\\|" + "[ \t]*[:|]" "\\|" + "\\$\\$" "\\|" + "\\\\\\(begin\\|end\\|[][]\\)")) + ;; Inhibit auto-fill for headers, tables and fixed-width lines. + ;; But only if the user has not turned off tables or fixed-width regions + (org-set-local + 'auto-fill-inhibit-regexp + (concat "\\*+ \\|#\\+" + "\\|[ \t]*" org-keyword-time-regexp + (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. + (org-set-local 'fill-paragraph-function 'org-fill-paragraph) + ;; Adaptive filling: To get full control, first make sure that + ;; `adaptive-fill-regexp' never matches. Then install our own matcher. + (unless (local-variable-p 'adaptive-fill-regexp (current-buffer)) + (org-set-local 'org-adaptive-fill-regexp-backup + adaptive-fill-regexp)) + (org-set-local 'adaptive-fill-regexp "\000") + (org-set-local 'adaptive-fill-function + 'org-adaptive-fill-function) + (org-set-local + 'align-mode-rules-list + '((org-in-buffer-settings + (regexp . "^#\\+[A-Z_]+:\\(\\s-*\\)\\S-+") + (modes . '(org-mode)))))) + +(defun org-fill-paragraph (&optional justify) + "Re-align a table, pass through to fill-paragraph if no table." + (let ((table-p (org-at-table-p)) + (table.el-p (org-at-table.el-p))) + (cond ((and (equal (char-after (point-at-bol)) ?*) + (save-excursion (goto-char (point-at-bol)) + (looking-at outline-regexp))) + t) ; skip headlines + (table.el-p t) ; skip table.el tables + (table-p (org-table-align) t) ; align org-mode tables + (t nil)))) ; call paragraph-fill + +;; For reference, this is the default value of adaptive-fill-regexp +;; "[ \t]*\\([-|#;>*]+[ \t]*\\|(?[0-9]+[.)][ \t]*\\)*" + +(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." + (cond + ;; Comment line + ((looking-at "#[ \t]+") + (match-string-no-properties 0)) + ;; Description list + ((looking-at "[ \t]*\\([-*+] .*? :: \\)") + (save-excursion + (if (> (match-end 1) (+ (match-beginning 1) + org-description-max-indent)) + (goto-char (+ (match-beginning 1) 5)) + (goto-char (match-end 0))) + (make-string (current-column) ?\ ))) + ;; Ordered or unordered list + ((looking-at "[ \t]*\\([-*+] \\|[0-9]+[.)] ?\\)") + (save-excursion + (goto-char (match-end 0)) + (make-string (current-column) ?\ ))) + ;; Other text + ((looking-at org-adaptive-fill-regexp-backup) + (match-string-no-properties 0)))) + +;;; Other stuff. + +(defun org-toggle-fixed-width-section (arg) + "Toggle the fixed-width export. +If there is no active region, the QUOTE keyword at the current headline is +inserted or removed. When present, it causes the text between this headline +and the next to be exported as fixed-width text, and unmodified. +If there is an active region, this command adds or removes a colon as the +first character of this line. If the first character of a line is a colon, +this line is also exported in fixed-width font." + (interactive "P") + (let* ((cc 0) + (regionp (org-region-active-p)) + (beg (if regionp (region-beginning) (point))) + (end (if regionp (region-end))) + (nlines (or arg (if (and beg end) (count-lines beg end) 1))) + (case-fold-search nil) + (re "[ \t]*\\(: \\)") + off) + (if regionp + (save-excursion + (goto-char beg) + (setq cc (current-column)) + (beginning-of-line 1) + (setq off (looking-at re)) + (while (> nlines 0) + (setq nlines (1- nlines)) + (beginning-of-line 1) + (cond + (arg + (org-move-to-column cc t) + (insert ": \n") + (forward-line -1)) + ((and off (looking-at re)) + (replace-match "" t t nil 1)) + ((not off) (org-move-to-column cc t) (insert ": "))) + (forward-line 1))) + (save-excursion + (org-back-to-heading) + (if (looking-at (concat outline-regexp + "\\( *\\<" org-quote-string "\\>[ \t]*\\)")) + (replace-match "" t t nil 1) + (if (looking-at outline-regexp) + (progn + (goto-char (match-end 0)) + (insert org-quote-string " ")))))))) + +(defun org-reftex-citation () + "Use reftex-citation to insert a citation into the buffer. +This looks for a line like + +#+BIBLIOGRAPHY: foo plain option:-d + +and derives from it that foo.bib is the bibliography file relevant +for this document. It then installs the necessary environment for RefTeX +to work in this buffer and calls `reftex-citation' to insert a citation +into the buffer. + +Export of such citations to both LaTeX and HTML is handled by the contributed +package org-exp-bibtex by Taru Karttunen." + (interactive) + (let ((reftex-docstruct-symbol 'rds) + (reftex-cite-format "\\cite{%l}") + rds bib) + (save-excursion + (save-restriction + (widen) + (let ((case-fold-search t) + (re "^#\\+bibliography:[ \t]+\\([^ \t\n]+\\)")) + (if (not (save-excursion + (or (re-search-forward re nil t) + (re-search-backward re nil t)))) + (error "No bibliography defined in file") + (setq bib (concat (match-string 1) ".bib") + rds (list (list 'bib bib))))))) + (call-interactively 'reftex-citation))) + +;;;; Functions extending outline functionality + +(defun org-beginning-of-line (&optional arg) + "Go to the beginning of the current line. If that is invisible, continue +to a visible line beginning. This makes the function of C-a more intuitive. +If this is a headline, and `org-special-ctrl-a/e' is set, ignore tags on the +first attempt, and only move to after the tags when the cursor is already +beyond the end of the headline." + (interactive "P") + (let ((pos (point)) + (special (if (consp org-special-ctrl-a/e) + (car org-special-ctrl-a/e) + org-special-ctrl-a/e)) + refpos) + (if (org-bound-and-true-p line-move-visual) + (beginning-of-visual-line 1) + (beginning-of-line 1)) + (if (and arg (fboundp 'move-beginning-of-line)) + (call-interactively 'move-beginning-of-line) + (if (bobp) + nil + (backward-char 1) + (if (org-truely-invisible-p) + (while (and (not (bobp)) (org-truely-invisible-p)) + (backward-char 1) + (beginning-of-line 1)) + (forward-char 1)))) + (when special + (cond + ((and (looking-at org-complex-heading-regexp) + (= (char-after (match-end 1)) ?\ )) + (setq refpos (min (1+ (or (match-end 3) (match-end 2) (match-end 1))) + (point-at-eol))) + (goto-char + (if (eq special t) + (cond ((> pos refpos) refpos) + ((= pos (point)) refpos) + (t (point))) + (cond ((> pos (point)) (point)) + ((not (eq last-command this-command)) (point)) + (t refpos))))) + ((org-at-item-p) + (goto-char + (if (eq special t) + (cond ((> pos (match-end 4)) (match-end 4)) + ((= pos (point)) (match-end 4)) + (t (point))) + (cond ((> pos (point)) (point)) + ((not (eq last-command this-command)) (point)) + (t (match-end 4)))))))) + (org-no-warnings + (and (featurep 'xemacs) (setq zmacs-region-stays t))))) + +(defun org-end-of-line (&optional arg) + "Go to the end of the line. +If this is a headline, and `org-special-ctrl-a/e' is set, ignore tags on the +first attempt, and only move to after the tags when the cursor is already +beyond the end of the headline." + (interactive "P") + (let ((special (if (consp org-special-ctrl-a/e) + (cdr org-special-ctrl-a/e) + org-special-ctrl-a/e))) + (if (or (not special) + (not (org-on-heading-p)) + arg) + (call-interactively + (cond ((org-bound-and-true-p line-move-visual) 'end-of-visual-line) + ((fboundp 'move-end-of-line) 'move-end-of-line) + (t 'end-of-line))) + (let ((pos (point))) + (beginning-of-line 1) + (if (looking-at (org-re ".*?\\(?:\\([ \t]*\\)\\(:[[:alnum:]_@#%:]+:\\)?[ \t]*\\)?$")) + (if (eq special t) + (if (or (< pos (match-beginning 1)) + (= pos (match-end 0))) + (goto-char (match-beginning 1)) + (goto-char (match-end 0))) + (if (or (< pos (match-end 0)) (not (eq this-command last-command))) + (goto-char (match-end 0)) + (goto-char (match-beginning 1)))) + (call-interactively (if (fboundp 'move-end-of-line) + 'move-end-of-line + 'end-of-line))))) + (org-no-warnings + (and (featurep 'xemacs) (setq zmacs-region-stays t))))) + +(define-key org-mode-map "\C-a" 'org-beginning-of-line) +(define-key org-mode-map "\C-e" 'org-end-of-line) + +(defun org-backward-sentence (&optional arg) + "Go to beginning of sentence, or beginning of table field. +This will call `backward-sentence' or `org-table-beginning-of-field', +depending on context." + (interactive "P") + (cond + ((org-at-table-p) (call-interactively 'org-table-beginning-of-field)) + (t (call-interactively 'backward-sentence)))) + +(defun org-forward-sentence (&optional arg) + "Go to end of sentence, or end of table field. +This will call `forward-sentence' or `org-table-end-of-field', +depending on context." + (interactive "P") + (cond + ((org-at-table-p) (call-interactively 'org-table-end-of-field)) + (t (call-interactively 'forward-sentence)))) + +(define-key org-mode-map "\M-a" 'org-backward-sentence) +(define-key org-mode-map "\M-e" 'org-forward-sentence) + +(defun org-kill-line (&optional arg) + "Kill line, to tags or end of line." + (interactive "P") + (cond + ((or (not org-special-ctrl-k) + (bolp) + (not (org-on-heading-p))) + (if (and (get-char-property (min (point-max) (point-at-eol)) 'invisible) + org-ctrl-k-protect-subtree) + (if (or (eq org-ctrl-k-protect-subtree 'error) + (not (y-or-n-p "Kill hidden subtree along with headline? "))) + (error "C-k aborted - would kill hidden subtree"))) + (call-interactively 'kill-line)) + ((looking-at (org-re ".*?\\S-\\([ \t]+\\(:[[:alnum:]_@#%:]+:\\)\\)[ \t]*$")) + (kill-region (point) (match-beginning 1)) + (org-set-tags nil t)) + (t (kill-region (point) (point-at-eol))))) + +(define-key org-mode-map "\C-k" 'org-kill-line) + +(defun org-yank (&optional arg) + "Yank. If the kill is a subtree, treat it specially. +This command will look at the current kill and check if is a single +subtree, or a series of subtrees[1]. If it passes the test, and if the +cursor is at the beginning of a line or after the stars of a currently +empty headline, then the yank is handled specially. How exactly depends +on the value of the following variables, both set by default. + +org-yank-folded-subtrees + When set, the subtree(s) will be folded after insertion, but only + if doing so would now swallow text after the yanked text. + +org-yank-adjusted-subtrees + When set, the subtree will be promoted or demoted in order to + fit into the local outline tree structure, which means that the level + will be adjusted so that it becomes the smaller one of the two + *visible* surrounding headings. + +Any prefix to this command will cause `yank' to be called directly with +no special treatment. In particular, a simple \\[universal-argument] prefix \ +will just +plainly yank the text as it is. + +\[1] The test checks if the first non-white line is a heading + and if there are no other headings with fewer stars." + (interactive "P") + (org-yank-generic 'yank arg)) + +(defun org-yank-generic (command arg) + "Perform some yank-like command. + +This function implements the behavior described in the `org-yank' +documentation. However, it has been generalized to work for any +interactive command with similar behavior." + + ;; pretend to be command COMMAND + (setq this-command command) + + (if arg + (call-interactively command) + + (let ((subtreep ; is kill a subtree, and the yank position appropriate? + (and (org-kill-is-subtree-p) + (or (bolp) + (and (looking-at "[ \t]*$") + (string-match + "\\`\\*+\\'" + (buffer-substring (point-at-bol) (point))))))) + swallowp) + (cond + ((and subtreep org-yank-folded-subtrees) + (let ((beg (point)) + end) + (if (and subtreep org-yank-adjusted-subtrees) + (org-paste-subtree nil nil 'for-yank) + (call-interactively command)) + + (setq end (point)) + (goto-char beg) + (when (and (bolp) subtreep + (not (setq swallowp + (org-yank-folding-would-swallow-text beg end)))) + (or (looking-at outline-regexp) + (re-search-forward (concat "^" outline-regexp) end t)) + (while (and (< (point) end) (looking-at outline-regexp)) + (hide-subtree) + (org-cycle-show-empty-lines 'folded) + (condition-case nil + (outline-forward-same-level 1) + (error (goto-char end))))) + (when swallowp + (message + "Inserted text not folded because that would swallow text")) + + (goto-char end) + (skip-chars-forward " \t\n\r") + (beginning-of-line 1) + (push-mark beg 'nomsg))) + ((and subtreep org-yank-adjusted-subtrees) + (let ((beg (point-at-bol))) + (org-paste-subtree nil nil 'for-yank) + (push-mark beg 'nomsg))) + (t + (call-interactively command)))))) + +(defun org-yank-folding-would-swallow-text (beg end) + "Would hide-subtree at BEG swallow any text after END?" + (let (level) + (save-excursion + (goto-char beg) + (when (or (looking-at outline-regexp) + (re-search-forward (concat "^" outline-regexp) end t)) + (setq level (org-outline-level))) + (goto-char end) + (skip-chars-forward " \t\r\n\v\f") + (if (or (eobp) + (and (bolp) (looking-at org-outline-regexp) + (<= (org-outline-level) level))) + nil ; Nothing would be swallowed + t)))) ; something would swallow + +(define-key org-mode-map "\C-y" 'org-yank) + +(defun org-invisible-p () + "Check if point is at a character currently not visible." + ;; Early versions of noutline don't have `outline-invisible-p'. + (if (fboundp 'outline-invisible-p) + (outline-invisible-p) + (get-char-property (point) 'invisible))) + +(defun org-truely-invisible-p () + "Check if point is at a character currently not visible. +This version does not only check the character property, but also +`visible-mode'." + ;; Early versions of noutline don't have `outline-invisible-p'. + (if (org-bound-and-true-p visible-mode) + nil + (if (fboundp 'outline-invisible-p) + (outline-invisible-p) + (get-char-property (point) 'invisible)))) + +(defun org-invisible-p2 () + "Check if point is at a character currently not visible." + (save-excursion + (if (and (eolp) (not (bobp))) (backward-char 1)) + ;; Early versions of noutline don't have `outline-invisible-p'. + (if (fboundp 'outline-invisible-p) + (outline-invisible-p) + (get-char-property (point) 'invisible)))) + +(defun org-back-to-heading (&optional invisible-ok) + "Call `outline-back-to-heading', but provide a better error message." + (condition-case nil + (outline-back-to-heading invisible-ok) + (error (error "Before first headline at position %d in buffer %s" + (point) (current-buffer))))) + +(defun org-beginning-of-defun () + "Go to the beginning of the subtree, i.e. back to the heading." + (org-back-to-heading)) +(defun org-end-of-defun () + "Go to the end of the subtree." + (org-end-of-subtree nil t)) + +(defun org-before-first-heading-p () + "Before first heading?" + (save-excursion + (null (re-search-backward "^\\*+ " nil t)))) + +(defun org-on-heading-p (&optional ignored) + (outline-on-heading-p t)) +(defun org-at-heading-p (&optional ignored) + (outline-on-heading-p t)) + +(defun org-point-at-end-of-empty-headline () + "If point is at the end of an empty headline, return t, else nil. +If the heading only contains a TODO keyword, it is still still considered +empty." + (and (looking-at "[ \t]*$") + (save-excursion + (beginning-of-line 1) + (looking-at (concat "^\\(\\*+\\)[ \t]+\\(" org-todo-regexp + "\\)?[ \t]*$"))))) +(defun org-at-heading-or-item-p () + (or (org-on-heading-p) (org-at-item-p))) + +(defun org-on-target-p () + (or (org-in-regexp org-radio-target-regexp) + (org-in-regexp org-target-regexp))) + +(defun org-up-heading-all (arg) + "Move to the heading line of which the present line is a subheading. +This function considers both visible and invisible heading lines. +With argument, move up ARG levels." + (if (fboundp 'outline-up-heading-all) + (outline-up-heading-all arg) ; emacs 21 version of outline.el + (outline-up-heading arg t))) ; emacs 22 version of outline.el + +(defun org-up-heading-safe () + "Move to the heading line of which the present line is a subheading. +This version will not throw an error. It will return the level of the +headline found, or nil if no higher level is found. + +Also, this function will be a lot faster than `outline-up-heading', +because it relies on stars being the outline starters. This can really +make a significant difference in outlines with very many siblings." + (let (start-level re) + (org-back-to-heading t) + (setq start-level (funcall outline-level)) + (if (equal start-level 1) + nil + (setq re (concat "^\\*\\{1," (number-to-string (1- start-level)) "\\} ")) + (if (re-search-backward re nil t) + (funcall outline-level))))) + +(defun org-first-sibling-p () + "Is this heading the first child of its parents?" + (interactive) + (let ((re (concat "^" outline-regexp)) + level l) + (unless (org-at-heading-p t) + (error "Not at a heading")) + (setq level (funcall outline-level)) + (save-excursion + (if (not (re-search-backward re nil t)) + t + (setq l (funcall outline-level)) + (< l level))))) + +(defun org-goto-sibling (&optional previous) + "Goto the next sibling, even if it is invisible. +When PREVIOUS is set, go to the previous sibling instead. Returns t +when a sibling was found. When none is found, return nil and don't +move point." + (let ((fun (if previous 're-search-backward 're-search-forward)) + (pos (point)) + (re (concat "^" outline-regexp)) + level l) + (when (condition-case nil (org-back-to-heading t) (error nil)) + (setq level (funcall outline-level)) + (catch 'exit + (or previous (forward-char 1)) + (while (funcall fun re nil t) + (setq l (funcall outline-level)) + (when (< l level) (goto-char pos) (throw 'exit nil)) + (when (= l level) (goto-char (match-beginning 0)) (throw 'exit t))) + (goto-char pos) + nil)))) + +(defun org-show-siblings () + "Show all siblings of the current headline." + (save-excursion + (while (org-goto-sibling) (org-flag-heading nil))) + (save-excursion + (while (org-goto-sibling 'previous) + (org-flag-heading nil)))) + +(defun org-goto-first-child () + "Goto the first child, even if it is invisible. +Return t when a child was found. Otherwise don't move point and +return nil." + (let (level (pos (point)) (re (concat "^" outline-regexp))) + (when (condition-case nil (org-back-to-heading t) (error nil)) + (setq level (outline-level)) + (forward-char 1) + (if (and (re-search-forward re nil t) (> (outline-level) level)) + (progn (goto-char (match-beginning 0)) t) + (goto-char pos) nil)))) + +(defun org-show-hidden-entry () + "Show an entry where even the heading is hidden." + (save-excursion + (org-show-entry))) + +(defun org-flag-heading (flag &optional entry) + "Flag the current heading. FLAG non-nil means make invisible. +When ENTRY is non-nil, show the entire entry." + (save-excursion + (org-back-to-heading t) + ;; Check if we should show the entire entry + (if entry + (progn + (org-show-entry) + (save-excursion + (and (outline-next-heading) + (org-flag-heading nil)))) + (outline-flag-region (max (point-min) (1- (point))) + (save-excursion (outline-end-of-heading) (point)) + flag)))) + +(defun org-get-next-sibling () + "Move to next heading of the same level, and return point. +If there is no such heading, return nil. +This is like outline-next-sibling, but invisible headings are ok." + (let ((level (funcall outline-level))) + (outline-next-heading) + (while (and (not (eobp)) (> (funcall outline-level) level)) + (outline-next-heading)) + (if (or (eobp) (< (funcall outline-level) level)) + nil + (point)))) + +(defun org-get-last-sibling () + "Move to previous heading of the same level, and return point. +If there is no such heading, return nil." + (let ((opoint (point)) + (level (funcall outline-level))) + (outline-previous-heading) + (when (and (/= (point) opoint) (outline-on-heading-p t)) + (while (and (> (funcall outline-level) level) + (not (bobp))) + (outline-previous-heading)) + (if (< (funcall outline-level) level) + nil + (point))))) + +(defun org-end-of-subtree (&optional invisible-OK to-heading) + ;; This contains 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. + ;; Furthermore, when used inside Org, finding the end of a large subtree + ;; with many children and grandchildren etc, this can be much faster + ;; than the outline version. + (org-back-to-heading invisible-OK) + (let ((first t) + (level (funcall outline-level))) + (if (and (org-mode-p) (< level 1000)) + ;; A true heading (not a plain list item), in Org-mode + ;; This means we can easily find the end by looking + ;; only for the right number of stars. Using a regexp to do + ;; this is so much faster than using a Lisp loop. + (let ((re (concat "^\\*\\{1," (int-to-string level) "\\} "))) + (forward-char 1) + (and (re-search-forward re nil 'move) (beginning-of-line 1))) + ;; something else, do it the slow way + (while (and (not (eobp)) + (or first (> (funcall outline-level) level))) + (setq first nil) + (outline-next-heading))) + (unless to-heading + (if (memq (preceding-char) '(?\n ?\^M)) + (progn + ;; Go to end of line before heading + (forward-char -1) + (if (memq (preceding-char) '(?\n ?\^M)) + ;; leave blank line before heading + (forward-char -1)))))) + (point)) + +(defadvice outline-end-of-subtree (around prefer-org-version activate compile) + "Use Org version in org-mode, for dramatic speed-up." + (if (eq major-mode 'org-mode) + (progn + (org-end-of-subtree nil t) + (unless (eobp) (backward-char 1))) + ad-do-it)) + +(defun org-forward-same-level (arg &optional invisible-ok) + "Move forward to the arg'th subheading at same level as this one. +Stop at the first and last subheadings of a superior heading. +Normally this only looks at visible headings, but when INVISIBLE-OK is non-nil +it wil also look at invisible ones." + (interactive "p") + (org-back-to-heading invisible-ok) + (org-on-heading-p) + (let* ((level (- (match-end 0) (match-beginning 0) 1)) + (re (format "^\\*\\{1,%d\\} " level)) + l) + (forward-char 1) + (while (> arg 0) + (while (and (re-search-forward re nil 'move) + (setq l (- (match-end 0) (match-beginning 0) 1)) + (= l level) + (not invisible-ok) + (progn (backward-char 1) (org-invisible-p))) + (if (< l level) (setq arg 1))) + (setq arg (1- arg))) + (beginning-of-line 1))) + +(defun org-backward-same-level (arg &optional invisible-ok) + "Move backward to the arg'th subheading at same level as this one. +Stop at the first and last subheadings of a superior heading." + (interactive "p") + (org-back-to-heading) + (org-on-heading-p) + (let* ((level (- (match-end 0) (match-beginning 0) 1)) + (re (format "^\\*\\{1,%d\\} " level)) + l) + (while (> arg 0) + (while (and (re-search-backward re nil 'move) + (setq l (- (match-end 0) (match-beginning 0) 1)) + (= l level) + (not invisible-ok) + (org-invisible-p)) + (if (< l level) (setq arg 1))) + (setq arg (1- arg))))) + +(defun org-show-subtree () + "Show everything after this heading at deeper levels." + (outline-flag-region + (point) + (save-excursion + (org-end-of-subtree t t)) + nil)) + +(defun org-show-entry () + "Show the body directly following this heading. +Show the heading too, if it is currently invisible." + (interactive) + (save-excursion + (condition-case nil + (progn + (org-back-to-heading t) + (outline-flag-region + (max (point-min) (1- (point))) + (save-excursion + (if (re-search-forward + (concat "[\r\n]\\(" outline-regexp "\\)") nil t) + (match-beginning 1) + (point-max))) + nil) + (org-cycle-hide-drawers 'children)) + (error nil)))) + +(defun org-make-options-regexp (kwds &optional extra) + "Make a regular expression for keyword lines." + (concat + "^" + "#?[ \t]*\\+\\(" + (mapconcat 'regexp-quote kwds "\\|") + (if extra (concat "\\|" extra)) + "\\):[ \t]*" + "\\(.*\\)")) + +;; Make isearch reveal the necessary context +(defun org-isearch-end () + "Reveal context after isearch exits." + (when isearch-success ; only if search was successful + (if (featurep 'xemacs) + ;; Under XEmacs, the hook is run in the correct place, + ;; we directly show the context. + (org-show-context 'isearch) + ;; In Emacs the hook runs *before* restoring the overlays. + ;; So we have to use a one-time post-command-hook to do this. + ;; (Emacs 22 has a special variable, see function `org-mode') + (unless (and (boundp 'isearch-mode-end-hook-quit) + isearch-mode-end-hook-quit) + ;; Only when the isearch was not quitted. + (org-add-hook 'post-command-hook 'org-isearch-post-command + 'append 'local))))) + +(defun org-isearch-post-command () + "Remove self from hook, and show context." + (remove-hook 'post-command-hook 'org-isearch-post-command 'local) + (org-show-context 'isearch)) + + +;;;; Integration with and fixes for other packages + +;;; Imenu support + +(defvar org-imenu-markers nil + "All markers currently used by Imenu.") +(make-variable-buffer-local 'org-imenu-markers) + +(defun org-imenu-new-marker (&optional pos) + "Return a new marker for use by Imenu, and remember the marker." + (let ((m (make-marker))) + (move-marker m (or pos (point))) + (push m org-imenu-markers) + m)) + +(defun org-imenu-get-tree () + "Produce the index for Imenu." + (mapc (lambda (x) (move-marker x nil)) org-imenu-markers) + (setq org-imenu-markers nil) + (let* ((n org-imenu-depth) + (re (concat "^" outline-regexp)) + (subs (make-vector (1+ n) nil)) + (last-level 0) + m level head) + (save-excursion + (save-restriction + (widen) + (goto-char (point-max)) + (while (re-search-backward re nil t) + (setq level (org-reduced-level (funcall outline-level))) + (when (<= level n) + (looking-at org-complex-heading-regexp) + (setq head (org-link-display-format + (org-match-string-no-properties 4)) + m (org-imenu-new-marker)) + (org-add-props head nil 'org-imenu-marker m 'org-imenu t) + (if (>= level last-level) + (push (cons head m) (aref subs level)) + (push (cons head (aref subs (1+ level))) (aref subs level)) + (loop for i from (1+ level) to n do (aset subs i nil))) + (setq last-level level))))) + (aref subs 1))) + +(eval-after-load "imenu" + '(progn + (add-hook 'imenu-after-jump-hook + (lambda () + (if (eq major-mode 'org-mode) + (org-show-context 'org-goto)))))) + +(defun org-link-display-format (link) + "Replace a link with either the description, or the link target +if no description is present" + (save-match-data + (if (string-match org-bracket-link-analytic-regexp link) + (replace-match (if (match-end 5) + (match-string 5 link) + (concat (match-string 1 link) + (match-string 3 link))) + nil t link) + link))) + +;; Speedbar support + +(defvar org-speedbar-restriction-lock-overlay (make-overlay 1 1) + "Overlay marking the agenda restriction line in speedbar.") +(overlay-put org-speedbar-restriction-lock-overlay + 'face 'org-agenda-restriction-lock) +(overlay-put org-speedbar-restriction-lock-overlay + 'help-echo "Agendas are currently limited to this item.") +(org-detach-overlay org-speedbar-restriction-lock-overlay) + +(defun org-speedbar-set-agenda-restriction () + "Restrict future agenda commands to the location at point in speedbar. +To get rid of the restriction, use \\[org-agenda-remove-restriction-lock]." + (interactive) + (require 'org-agenda) + (let (p m tp np dir txt) + (cond + ((setq p (text-property-any (point-at-bol) (point-at-eol) + 'org-imenu t)) + (setq m (get-text-property p 'org-imenu-marker)) + (with-current-buffer (marker-buffer m) + (goto-char m) + (org-agenda-set-restriction-lock 'subtree))) + ((setq p (text-property-any (point-at-bol) (point-at-eol) + 'speedbar-function 'speedbar-find-file)) + (setq tp (previous-single-property-change + (1+ p) 'speedbar-function) + np (next-single-property-change + tp 'speedbar-function) + dir (speedbar-line-directory) + txt (buffer-substring-no-properties (or tp (point-min)) + (or np (point-max)))) + (with-current-buffer (find-file-noselect + (let ((default-directory dir)) + (expand-file-name txt))) + (unless (org-mode-p) + (error "Cannot restrict to non-Org-mode file")) + (org-agenda-set-restriction-lock 'file))) + (t (error "Don't know how to restrict Org-mode's agenda"))) + (move-overlay org-speedbar-restriction-lock-overlay + (point-at-bol) (point-at-eol)) + (setq current-prefix-arg nil) + (org-agenda-maybe-redo))) + +(eval-after-load "speedbar" + '(progn + (speedbar-add-supported-extension ".org") + (define-key speedbar-file-key-map "<" 'org-speedbar-set-agenda-restriction) + (define-key speedbar-file-key-map "\C-c\C-x<" 'org-speedbar-set-agenda-restriction) + (define-key speedbar-file-key-map ">" 'org-agenda-remove-restriction-lock) + (define-key speedbar-file-key-map "\C-c\C-x>" 'org-agenda-remove-restriction-lock) + (add-hook 'speedbar-visiting-tag-hook + (lambda () (and (org-mode-p) (org-show-context 'org-goto)))))) + +;;; Fixes and Hacks for problems with other packages + +;; Make flyspell not check words in links, to not mess up our keymap +(defun org-mode-flyspell-verify () + "Don't let flyspell put overlays at active buttons." + (and (not (get-text-property (max (1- (point)) (point-min)) 'keymap)) + (not (get-text-property (max (1- (point)) (point-min)) 'org-no-flyspell)))) + +(defun org-remove-flyspell-overlays-in (beg end) + "Remove flyspell overlays in region." + (and (org-bound-and-true-p flyspell-mode) + (fboundp 'flyspell-delete-region-overlays) + (flyspell-delete-region-overlays beg end)) + (add-text-properties beg end '(org-no-flyspell t))) + +;; Make `bookmark-jump' shows the jump location if it was hidden. +(eval-after-load "bookmark" + '(if (boundp 'bookmark-after-jump-hook) + ;; We can use the hook + (add-hook 'bookmark-after-jump-hook 'org-bookmark-jump-unhide) + ;; Hook not available, use advice + (defadvice bookmark-jump (after org-make-visible activate) + "Make the position visible." + (org-bookmark-jump-unhide)))) + +;; Make sure saveplace shows the location if it was hidden +(eval-after-load "saveplace" + '(defadvice save-place-find-file-hook (after org-make-visible activate) + "Make the position visible." + (org-bookmark-jump-unhide))) + +;; Make sure ecb shows the location if it was hidden +(eval-after-load "ecb" + '(defadvice ecb-method-clicked (after esf/org-show-context activate) + "Make hierarchy visible when jumping into location from ECB tree buffer." + (if (eq major-mode 'org-mode) + (org-show-context)))) + +(defun org-bookmark-jump-unhide () + "Unhide the current position, to show the bookmark location." + (and (org-mode-p) + (or (org-invisible-p) + (save-excursion (goto-char (max (point-min) (1- (point)))) + (org-invisible-p))) + (org-show-context 'bookmark-jump))) + +;; Make session.el ignore our circular variable +(eval-after-load "session" + '(add-to-list 'session-globals-exclude 'org-mark-ring)) + +;;;; Experimental code + +(defun org-closed-in-range () + "Sparse tree of items closed in a certain time range. +Still experimental, may disappear in the future." + (interactive) + ;; Get the time interval from the user. + (let* ((time1 (org-float-time + (org-read-date nil 'to-time nil "Starting date: "))) + (time2 (org-float-time + (org-read-date nil 'to-time nil "End date:"))) + ;; callback function + (callback (lambda () + (let ((time + (org-float-time + (apply 'encode-time + (org-parse-time-string + (match-string 1)))))) + ;; check if time in interval + (and (>= time time1) (<= time time2)))))) + ;; make tree, check each match with the callback + (org-occur "CLOSED: +\\[\\(.*?\\)\\]" nil callback))) + +;;;; Finish up + +(provide 'org) + +(run-hooks 'org-load-hook) + +;; arch-tag: e77da1a7-acc7-4336-b19e-efa25af3f9fd + +;;; org.el ends here diff --git a/.emacs.d/org-7.4/lisp/org.elc b/.emacs.d/org-7.4/lisp/org.elc Binary files differnew file mode 100644 index 0000000..de0a100 --- /dev/null +++ b/.emacs.d/org-7.4/lisp/org.elc |