diff options
Diffstat (limited to 'contrib/lisp')
48 files changed, 3018 insertions, 4325 deletions
diff --git a/contrib/lisp/htmlize.el b/contrib/lisp/htmlize.el index 3bf5949..8358830 100644 --- a/contrib/lisp/htmlize.el +++ b/contrib/lisp/htmlize.el @@ -943,18 +943,7 @@ If no rgb.txt file is found, return nil." ;; frame parameters. (let* ((function (if fg #'face-foreground #'face-background)) color) - (if (>= emacs-major-version 22) - ;; For GNU Emacs 22+ set INHERIT to get the inherited values. - (setq color (funcall function face nil t)) - (setq color (funcall function face)) - ;; For GNU Emacs 21 (which has `face-attribute'): if the color - ;; is nil, recursively check for the face's parent. - (when (and (null color) - (fboundp 'face-attribute) - (face-attribute face :inherit) - (not (eq (face-attribute face :inherit) 'unspecified))) - (setq color (htmlize-face-color-internal - (face-attribute face :inherit) fg)))) + (setq color (funcall function face nil t)) (when (and (eq face 'default) (null color)) (setq color (cdr (assq (if fg 'foreground-color 'background-color) (frame-parameters))))) @@ -1132,17 +1121,7 @@ If no rgb.txt file is found, return nil." (face-underline-p face))) ;; GNU Emacs (dolist (attr '(:weight :slant :underline :overline :strike-through)) - (let ((value (if (>= emacs-major-version 22) - ;; Use the INHERIT arg in GNU Emacs 22. - (face-attribute face attr nil t) - ;; Otherwise, fake it. - (let ((face face)) - (while (and (eq (face-attribute face attr) - 'unspecified) - (not (eq (face-attribute face :inherit) - 'unspecified))) - (setq face (face-attribute face :inherit))) - (face-attribute face attr))))) + (let ((value (face-attribute face attr nil t))) (when (and value (not (eq value 'unspecified))) (htmlize-face-emacs21-attr fstruct attr value)))) (let ((size (htmlize-face-size face))) diff --git a/contrib/lisp/ob-csharp.el b/contrib/lisp/ob-csharp.el new file mode 100644 index 0000000..5ecac23 --- /dev/null +++ b/contrib/lisp/ob-csharp.el @@ -0,0 +1,83 @@ +;;; ob-csharp.el --- org-babel functions for csharp evaluation + +;; Copyright (C) 2011-2015 Free Software Foundation, Inc. + +;; Author: thomas "at" friendlyvillagers.com based on ob-java.el by Eric Schulte +;; Keywords: literate programming, reproducible research +;; Homepage: http://orgmode.org + +;; This file is not 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: + +;; Currently this only supports the external compilation and execution +;; of csharp code blocks (i.e., no session support). + +;;; Code: +(require 'ob) + +(defvar org-babel-tangle-lang-exts) +(add-to-list 'org-babel-tangle-lang-exts '("csharp" . "cs")) + +(defcustom org-babel-csharp-command "mono" + "Name of the csharp command. +May be either a command in the path, like mono +or an absolute path name, like /usr/local/bin/mono +parameters may be used, like mono -verbose" + :group 'org-babel + :version "24.3" + :type 'string) + +(defcustom org-babel-csharp-compiler "mcs" + "Name of the csharp compiler. +May be either a command in the path, like mcs +or an absolute path name, like /usr/local/bin/mcs +parameters may be used, like mcs -warnaserror+" + :group 'org-babel + :version "24.3" + :type 'string) + +(defun org-babel-execute:csharp (body params) + (let* ((full-body (org-babel-expand-body:generic body params)) + (cmpflag (or (cdr (assq :cmpflag params)) "")) + (cmdline (or (cdr (assq :cmdline params)) "")) + (src-file (org-babel-temp-file "csharp-src-" ".cs")) + (exe-file (concat (file-name-sans-extension src-file) ".exe")) + (compile + (progn (with-temp-file src-file (insert full-body)) + (org-babel-eval + (concat org-babel-csharp-compiler " " cmpflag " " src-file) "")))) + (let ((results (org-babel-eval (concat org-babel-csharp-command " " cmdline " " exe-file) ""))) + (org-babel-reassemble-table + (org-babel-result-cond (cdr (assq :result-params params)) + (org-babel-read results) + (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-pick-name + (cdr (assq :colname-names params)) (cdr (assq :colnames params))) + (org-babel-pick-name + (cdr (assq :rowname-names params)) (cdr (assq :rownames params))))))) + +(defun org-babel-prep-session:csharp (session params) + "Return an error because csharp does not support sessions." + (error "Sessions are not supported for CSharp")) + +(provide 'ob-csharp) + + + +;;; ob-csharp.el ends here diff --git a/contrib/lisp/ob-eukleides.el b/contrib/lisp/ob-eukleides.el index 67f3bf4..e4fc298 100644 --- a/contrib/lisp/ob-eukleides.el +++ b/contrib/lisp/ob-eukleides.el @@ -58,12 +58,12 @@ (defun org-babel-execute:eukleides (body params) "Execute a block of eukleides 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)) + (let* ((result-params (split-string (or (cdr (assq :results params)) ""))) + (out-file (or (cdr (assq :file params)) (error "Eukleides requires a \":file\" header argument"))) - (cmdline (cdr (assoc :cmdline params))) + (cmdline (cdr (assq :cmdline params))) (in-file (org-babel-temp-file "eukleides-")) - (java (or (cdr (assoc :java params)) "")) + (java (or (cdr (assq :java params)) "")) (cmd (if (not org-eukleides-path) (error "`org-eukleides-path' is not set") (concat (expand-file-name org-eukleides-path) diff --git a/contrib/lisp/ob-fomus.el b/contrib/lisp/ob-fomus.el index 1db32e4..30f292f 100644 --- a/contrib/lisp/ob-fomus.el +++ b/contrib/lisp/ob-fomus.el @@ -48,7 +48,7 @@ (defun org-babel-expand-body:fomus (body params) "Expand BODY according to PARAMS, return the expanded body." - (let ((vars (mapcar #'cdr (org-babel-get-header params :var)))) + (let ((vars (org-babel--get-vars params))) (mapc (lambda (pair) (let ((name (symbol-name (car pair))) @@ -64,10 +64,10 @@ (defun org-babel-execute:fomus (body params) "Execute a block of Fomus 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 (cdr (assoc :cmdline params))) - (cmd (or (cdr (assoc :cmd params)) "fomus")) + (let* ((result-params (cdr (assq :result-params params))) + (out-file (cdr (assq :file params))) + (cmdline (cdr (assq :cmdline params))) + (cmd (or (cdr (assq :cmd params)) "fomus")) (in-file (org-babel-temp-file "fomus-" ".fms"))) (with-temp-file in-file (insert (org-babel-expand-body:fomus body params))) diff --git a/contrib/lisp/ob-julia.el b/contrib/lisp/ob-julia.el index 4d8deb2..41c8b5a 100644 --- a/contrib/lisp/ob-julia.el +++ b/contrib/lisp/ob-julia.el @@ -30,7 +30,7 @@ ;;; Code: (require 'ob) -(eval-when-compile (require 'cl)) +(require 'cl-lib) (declare-function orgtbl-to-csv "org-table" (table params)) (declare-function julia "ext:ess-julia" (&optional start-args)) @@ -38,7 +38,6 @@ (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)) -(declare-function org-remove-if-not "org" (predicate seq)) (defconst org-babel-header-args:julia '((width . :any) @@ -62,7 +61,7 @@ (defvar ess-local-process-name) ; dynamically scoped (defun org-babel-edit-prep:julia (info) - (let ((session (cdr (assoc :session (nth 2 info))))) + (let ((session (cdr (assq :session (nth 2 info))))) (when (and session (string-match "^\\*\\(.+?\\)\\*$" session)) (save-match-data (org-babel-julia-initiate-session session nil))))) @@ -83,12 +82,12 @@ "Execute a block of julia code. This function is called by `org-babel-execute-src-block'." (save-excursion - (let* ((result-params (cdr (assoc :result-params params))) - (result-type (cdr (assoc :result-type params))) + (let* ((result-params (cdr (assq :result-params params))) + (result-type (cdr (assq :result-type params))) (session (org-babel-julia-initiate-session - (cdr (assoc :session params)) params)) - (colnames-p (cdr (assoc :colnames params))) - (rownames-p (cdr (assoc :rownames params))) + (cdr (assq :session params)) params)) + (colnames-p (cdr (assq :colnames params))) + (rownames-p (cdr (assq :rownames params))) (graphics-file (org-babel-julia-graphical-output-file params)) (full-body (org-babel-expand-body:julia body params graphics-file)) (result @@ -96,10 +95,10 @@ This function is called by `org-babel-execute-src-block'." session full-body result-type result-params (or (equal "yes" colnames-p) (org-babel-pick-name - (cdr (assoc :colname-names params)) colnames-p)) + (cdr (assq :colname-names params)) colnames-p)) (or (equal "yes" rownames-p) (org-babel-pick-name - (cdr (assoc :rowname-names params)) rownames-p))))) + (cdr (assq :rowname-names params)) rownames-p))))) (if graphics-file nil result)))) (defun org-babel-prep-session:julia (session params) @@ -125,20 +124,20 @@ This function is called by `org-babel-execute-src-block'." (defun org-babel-variable-assignments:julia (params) "Return list of julia statements assigning the block's variables." - (let ((vars (mapcar #'cdr (org-babel-get-header params :var)))) + (let ((vars (org-babel--get-vars params))) (mapcar (lambda (pair) (org-babel-julia-assign-elisp (car pair) (cdr pair) - (equal "yes" (cdr (assoc :colnames params))) - (equal "yes" (cdr (assoc :rownames params))))) + (equal "yes" (cdr (assq :colnames params))) + (equal "yes" (cdr (assq :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))))))) + (cdr (nth i (cdr (assq :colname-names params)))) + (cdr (nth i (cdr (assq :rowname-names params))))))) (org-number-sequence 0 (1- (length vars))))))) (defun org-babel-julia-quote-csv-field (s) @@ -150,9 +149,9 @@ This function is called by `org-babel-execute-src-block'." (defun org-babel-julia-assign-elisp (name value colnames-p rownames-p) "Construct julia code assigning the elisp VALUE to a variable named NAME." (if (listp value) - (let ((max (apply #'max (mapcar #'length (org-remove-if-not + (let ((max (apply #'max (mapcar #'length (cl-remove-if-not #'sequencep value)))) - (min (apply #'min (mapcar #'length (org-remove-if-not + (min (apply #'min (mapcar #'length (cl-remove-if-not #'sequencep value)))) (transition-file (org-babel-temp-file "julia-import-"))) ;; ensure VALUE has an orgtbl structure (depth of at least 2) @@ -179,7 +178,7 @@ This function is called by `org-babel-execute-src-block'." (let ((session (or session "*julia*")) (ess-ask-for-ess-directory (and (and (boundp 'ess-ask-for-ess-directory) ess-ask-for-ess-directory) - (not (cdr (assoc :dir params)))))) + (not (cdr (assq :dir params)))))) (if (org-babel-comint-buffer-livep session) session (save-window-excursion @@ -229,7 +228,7 @@ current code buffer." 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 + (cl-case result-type (value (let ((tmp-file (org-babel-temp-file "julia-"))) (org-babel-eval org-babel-julia-command @@ -251,7 +250,7 @@ last statement in BODY, as elisp." 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 + (cl-case result-type (value (with-temp-buffer (insert (org-babel-chomp body)) diff --git a/contrib/lisp/ob-mathematica.el b/contrib/lisp/ob-mathematica.el index a796741..cb35dec 100644 --- a/contrib/lisp/ob-mathematica.el +++ b/contrib/lisp/ob-mathematica.el @@ -14,6 +14,9 @@ (require 'ob-ref) (require 'ob-comint) (require 'ob-eval) + +(declare-function org-trim "org" (s &optional keep-lead)) + ;; Optionally require mma.el for font lock, etc (require 'mma nil 'noerror) (add-to-list 'org-src-lang-modes '("mathematica" . "mma")) @@ -31,7 +34,7 @@ (defun org-babel-expand-body:mathematica (body params) "Expand BODY according to PARAMS, return the expanded body." - (let ((vars (mapcar #'cdr (org-babel-get-header params :var)))) + (let ((vars (org-babel--get-vars params))) (concat (mapconcat ;; define any variables (lambda (pair) @@ -43,11 +46,11 @@ (defun org-babel-execute:mathematica (body params) "Execute a block of Mathematica code with org-babel. This function is called by `org-babel-execute-src-block'" - (let* ((result-params (cdr (assoc :result-params params))) + (let* ((result-params (cdr (assq :result-params params))) (full-body (org-babel-expand-body:mathematica body params)) (tmp-script-file (org-babel-temp-file "mathematica-")) (cmd org-babel-mathematica-command)) - ;; actually execute the source-code block + ;; actually execute the source-code block (with-temp-file tmp-script-file (insert full-body)) ;; (with-temp-file "/tmp/dbg" (insert full-body)) ((lambda (raw) @@ -56,7 +59,7 @@ called by `org-babel-execute-src-block'" (and (member "output" result-params) (not (member "table" result-params)))) raw - (org-babel-script-escape (org-babel-trim raw)))) + (org-babel-script-escape (org-trim raw)))) (org-babel-eval (concat cmd " " tmp-script-file) "")))) (defun org-babel-prep-session:mathematica (session params) @@ -76,4 +79,3 @@ specifying a variable of the same value." (format "%S" var))) (provide 'ob-mathematica) - diff --git a/contrib/lisp/ob-mathomatic.el b/contrib/lisp/ob-mathomatic.el index 0ec1a5f..fc08d9f 100644 --- a/contrib/lisp/ob-mathomatic.el +++ b/contrib/lisp/ob-mathomatic.el @@ -49,45 +49,45 @@ (defun org-babel-mathomatic-expand (body params) "Expand a block of Mathomatic code according to its header arguments." - (let ((vars (mapcar #'cdr (org-babel-get-header params :var)))) - (mapconcat 'identity - (list - ;; graphic output - (let ((graphic-file (org-babel-mathomatic-graphical-output-file params))) - (if graphic-file - (cond - ((string-match ".\.eps$" graphic-file) - (format ;; Need to add command to send to file. - "set plot set terminal postscript eps\\;set output %S " - graphic-file)) - ((string-match ".\.ps$" graphic-file) - (format ;; Need to add command to send to file. - "set plot set terminal postscript\\;set output %S " - graphic-file)) - - ((string-match ".\.pic$" graphic-file) - (format ;; Need to add command to send to file. - "set plot set terminal gpic\\;set output %S " - graphic-file)) - (t - (format ;; Need to add command to send to file. - "set plot set terminal png\\;set output %S " - graphic-file))) - "")) - ;; variables - (mapconcat 'org-babel-mathomatic-var-to-mathomatic vars "\n") - ;; body - body - "") - "\n"))) + (let ((vars (org-babel--get-vars params))) + (mapconcat 'identity + (list + ;; graphic output + (let ((graphic-file (org-babel-mathomatic-graphical-output-file params))) + (if graphic-file + (cond + ((string-match ".\.eps$" graphic-file) + (format ;; Need to add command to send to file. + "set plot set terminal postscript eps\\;set output %S " + graphic-file)) + ((string-match ".\.ps$" graphic-file) + (format ;; Need to add command to send to file. + "set plot set terminal postscript\\;set output %S " + graphic-file)) + + ((string-match ".\.pic$" graphic-file) + (format ;; Need to add command to send to file. + "set plot set terminal gpic\\;set output %S " + graphic-file)) + (t + (format ;; Need to add command to send to file. + "set plot set terminal png\\;set output %S " + graphic-file))) + "")) + ;; variables + (mapconcat 'org-babel-mathomatic-var-to-mathomatic vars "\n") + ;; body + body + "") + "\n"))) (defun org-babel-execute:mathomatic (body params) "Execute a block of Mathomatic entries with org-babel. This function is called by `org-babel-execute-src-block'." (message "executing Mathomatic source code block") - (let ((result-params (split-string (or (cdr (assoc :results params)) ""))) + (let ((result-params (split-string (or (cdr (assq :results params)) ""))) (result - (let* ((cmdline (or (cdr (assoc :cmdline params)) "")) + (let* ((cmdline (or (cdr (assq :cmdline params)) "")) (in-file (org-babel-temp-file "mathomatic-" ".math")) (cmd (format "%s -t -c -q %s %s" org-babel-mathomatic-command in-file cmdline))) diff --git a/contrib/lisp/ob-oz.el b/contrib/lisp/ob-oz.el index fc778f5..9beadeb 100644 --- a/contrib/lisp/ob-oz.el +++ b/contrib/lisp/ob-oz.el @@ -197,7 +197,7 @@ StartOzServer.oz is located.") result)) (defun org-babel-expand-body:oz (body params) - (let ((vars (mapcar #'cdr (org-babel-get-header params :var)))) + (let ((vars (org-babel--get-vars params))) (if vars ;; prepend code to define all arguments passed to the code block (let ((var-string (mapcar (lambda (pair) @@ -214,7 +214,7 @@ StartOzServer.oz is located.") (defun org-babel-execute:oz (body params) "Execute a block of Oz code with org-babel. This function is called by `org-babel-execute-src-block' via multiple-value-bind." - (let* ((result-params (cdr (assoc :result-params params))) + (let* ((result-params (cdr (assq :result-params params))) (full-body (org-babel-expand-body:oz body params)) (wait-time (plist-get params :wait-time))) ;; actually execute the source-code block @@ -227,10 +227,10 @@ called by `org-babel-execute-src-block' via multiple-value-bind." (message "Org-babel: executing Oz expression") (oz-send-string-expression full-body (or wait-time 1))) (t (error "either 'output' or 'results' must be members of :results"))) - (org-babel-pick-name (cdr (assoc :colname-names params)) - (cdr (assoc :colnames params))) - (org-babel-pick-name (cdr (assoc :roname-names params)) - (cdr (assoc :rownames params)))))) + (org-babel-pick-name (cdr (assq :colname-names params)) + (cdr (assq :colnames params))) + (org-babel-pick-name (cdr (assq :roname-names params)) + (cdr (assq :rownames params)))))) ;; This function should be used to assign any variables in params in ;; the context of the session environment. diff --git a/contrib/lisp/ob-stata.el b/contrib/lisp/ob-stata.el index 29aa88d..d8cf52a 100644 --- a/contrib/lisp/ob-stata.el +++ b/contrib/lisp/ob-stata.el @@ -42,7 +42,7 @@ ;;; Code: (require 'ob) -(eval-when-compile (require 'cl)) +(require 'cl-lib) (declare-function orgtbl-to-csv "org-table" (table params)) (declare-function stata "ext:ess-stata" (&optional start-args)) @@ -50,7 +50,6 @@ (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)) -(declare-function org-remove-if-not "org" (predicate seq)) (defconst org-babel-header-args:stata '((width . :any) @@ -77,7 +76,7 @@ (defvar ess-local-process-name) ; dynamically scoped (defun org-babel-edit-prep:stata (info) - (let ((session (cdr (assoc :session (nth 2 info))))) + (let ((session (cdr (assq :session (nth 2 info))))) (when (and session (string-match "^\\*\\(.+?\\)\\*$" session)) (save-match-data (org-babel-stata-initiate-session session nil))))) @@ -98,12 +97,12 @@ "Execute a block of stata code. This function is called by `org-babel-execute-src-block'." (save-excursion - (let* ((result-params (cdr (assoc :result-params params))) - (result-type (cdr (assoc :result-type params))) + (let* ((result-params (cdr (assq :result-params params))) + (result-type (cdr (assq :result-type params))) (session (org-babel-stata-initiate-session - (cdr (assoc :session params)) params)) - (colnames-p (cdr (assoc :colnames params))) - (rownames-p (cdr (assoc :rownames params))) + (cdr (assq :session params)) params)) + (colnames-p (cdr (assq :colnames params))) + (rownames-p (cdr (assq :rownames params))) (graphics-file (org-babel-stata-graphical-output-file params)) (full-body (org-babel-expand-body:stata body params graphics-file)) (result @@ -111,10 +110,10 @@ This function is called by `org-babel-execute-src-block'." session full-body result-type result-params (or (equal "yes" colnames-p) (org-babel-pick-name - (cdr (assoc :colname-names params)) colnames-p)) + (cdr (assq :colname-names params)) colnames-p)) (or (equal "yes" rownames-p) (org-babel-pick-name - (cdr (assoc :rowname-names params)) rownames-p))))) + (cdr (assq :rowname-names params)) rownames-p))))) (if graphics-file nil result)))) (defun org-babel-prep-session:stata (session params) @@ -140,20 +139,20 @@ This function is called by `org-babel-execute-src-block'." (defun org-babel-variable-assignments:stata (params) "Return list of stata statements assigning the block's variables." - (let ((vars (mapcar #'cdr (org-babel-get-header params :var)))) + (let ((vars (org-babel--get-vars params))) (mapcar (lambda (pair) (org-babel-stata-assign-elisp (car pair) (cdr pair) - (equal "yes" (cdr (assoc :colnames params))) - (equal "yes" (cdr (assoc :rownames params))))) + (equal "yes" (cdr (assq :colnames params))) + (equal "yes" (cdr (assq :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))))))) + (cdr (nth i (cdr (assq :colname-names params)))) + (cdr (nth i (cdr (assq :rowname-names params))))))) (org-number-sequence 0 (1- (length vars))))))) (defun org-babel-stata-quote-csv-field (s) @@ -165,9 +164,9 @@ This function is called by `org-babel-execute-src-block'." (defun org-babel-stata-assign-elisp (name value colnames-p rownames-p) "Construct stata code assigning the elisp VALUE to a variable named NAME." (if (listp value) - (let ((max (apply #'max (mapcar #'length (org-remove-if-not + (let ((max (apply #'max (mapcar #'length (cl-remove-if-not #'sequencep value)))) - (min (apply #'min (mapcar #'length (org-remove-if-not + (min (apply #'min (mapcar #'length (cl-remove-if-not #'sequencep value)))) (transition-file (org-babel-temp-file "stata-import-"))) ;; ensure VALUE has an orgtbl structure (depth of at least 2) @@ -194,7 +193,7 @@ This function is called by `org-babel-execute-src-block'." (let ((session (or session "*stata*")) (ess-ask-for-ess-directory (and (and (boundp 'ess-ask-for-ess-directory) ess-ask-for-ess-directory) - (not (cdr (assoc :dir params)))))) + (not (cdr (assq :dir params)))))) (if (org-babel-comint-buffer-livep session) session (save-window-excursion @@ -240,7 +239,7 @@ current code buffer." 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 + (cl-case result-type (value (let ((tmp-file (org-babel-temp-file "stata-"))) (org-babel-eval org-babel-stata-command @@ -262,7 +261,7 @@ last statement in BODY, as elisp." 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 + (cl-case result-type (value (with-temp-buffer (insert (org-babel-chomp body)) diff --git a/contrib/lisp/ob-tcl.el b/contrib/lisp/ob-tcl.el index 7f75c4a..5373069 100644 --- a/contrib/lisp/ob-tcl.el +++ b/contrib/lisp/ob-tcl.el @@ -47,18 +47,18 @@ (defun org-babel-execute:tcl (body params) "Execute a block of Tcl 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))) + (let* ((session (cdr (assq :session params))) + (result-params (cdr (assq :result-params params))) + (result-type (cdr (assq :result-type params))) (full-body (org-babel-expand-body:generic body params (org-babel-variable-assignments:tcl params))) (session (org-babel-tcl-initiate-session session))) (org-babel-reassemble-table (org-babel-tcl-evaluate session full-body result-type) (org-babel-pick-name - (cdr (assoc :colname-names params)) (cdr (assoc :colnames params))) + (cdr (assq :colname-names params)) (cdr (assq :colnames params))) (org-babel-pick-name - (cdr (assoc :rowname-names params)) (cdr (assoc :rownames params)))))) + (cdr (assq :rowname-names params)) (cdr (assq :rownames params)))))) (defun org-babel-prep-session:tcl (session params) "Prepare SESSION according to the header arguments in PARAMS." @@ -71,7 +71,7 @@ This function is called by `org-babel-execute-src-block'." (format "set %s %s" (car pair) (org-babel-tcl-var-to-tcl (cdr pair)))) - (mapcar #'cdr (org-babel-get-header params :var)))) + (org-babel--get-vars params))) ;; helper functions diff --git a/contrib/lisp/ob-vbnet.el b/contrib/lisp/ob-vbnet.el new file mode 100644 index 0000000..8b27494 --- /dev/null +++ b/contrib/lisp/ob-vbnet.el @@ -0,0 +1,84 @@ +;;; ob-vbnet.el --- org-babel functions for VB.Net evaluation + +;; Copyright (C) 2011-2015 Free Software Foundation, Inc. + +;; Author: thomas "at" friendlyvillagers.com based on ob-java.el by Eric Schulte +;; Keywords: literate programming, reproducible research +;; Homepage: http://orgmode.org + +;; This file is not 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: + +;; Currently this only supports the external compilation and execution +;; of VB.Net code blocks (i.e., no session support). + +;;; Code: +(require 'ob) + +(defvar org-babel-tangle-lang-exts) +(add-to-list 'org-babel-tangle-lang-exts '("vbnet" . "vb")) + +(defcustom org-babel-vbnet-command "mono" + "Name of the mono command. +May be either a command in the path, like mono +or an absolute path name, like /usr/local/bin/mono +parameters may be used, like mono -verbose" + :group 'org-babel + :version "24.3" + :type 'string) + +(defcustom org-babel-vbnet-compiler "vbnc" + "Name of the VB.Net compiler. +May be either a command in the path, like vbnc +or an absolute path name, like /usr/local/bin/vbnc +parameters may be used, like vbnc /warnaserror+" + :group 'org-babel + :version "24.3" + :type 'string) + +(defun org-babel-execute:vbnet (body params) + (let* ((full-body (org-babel-expand-body:generic body params)) + (cmpflag (or (cdr (assq :cmpflag params)) "")) + (cmdline (or (cdr (assq :cmdline params)) "")) + (src-file (org-babel-temp-file "vbnet-src-" ".vb")) + (exe-file (concat (file-name-sans-extension src-file) ".exe")) + (compile + (progn (with-temp-file src-file (insert full-body)) + (org-babel-eval + (concat org-babel-vbnet-compiler " " cmpflag " " src-file) + "")))) + (let ((results (org-babel-eval (concat org-babel-vbnet-command " " cmdline " " exe-file) ""))) + (org-babel-reassemble-table + (org-babel-result-cond (cdr (assq :result-params params)) + (org-babel-read results) + (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-pick-name + (cdr (assq :colname-names params)) (cdr (assq :colnames params))) + (org-babel-pick-name + (cdr (assq :rowname-names params)) (cdr (assq :rownames params))))))) + +(defun org-babel-prep-session:vbnet (session params) + "Return an error because vbnet does not support sessions." + (error "Sessions are not supported for VB.Net")) + +(provide 'ob-vbnet) + + + +;;; ob-vbnet.el ends here diff --git a/contrib/lisp/org-bibtex-extras.el b/contrib/lisp/org-bibtex-extras.el index 7b0a89d..587aa67 100644 --- a/contrib/lisp/org-bibtex-extras.el +++ b/contrib/lisp/org-bibtex-extras.el @@ -61,6 +61,8 @@ ;;; Code: (require 'org-bibtex) +(declare-function org-trim "org" (s &optional keep-lead)) + (defcustom obe-bibtex-file nil "File holding bibtex entries.") (defcustom obe-html-link-base nil @@ -91,7 +93,7 @@ For example, to point to your `obe-bibtex-file' use the following. (replace-match (save-match-data (mapconcat (lambda (c) (format "[[%s#%s][%s]]" obe-html-link-base c c)) - (mapcar #'org-babel-trim + (mapcar #'org-trim (split-string (match-string 1) ",")) ", ")))))) (defun obe-meta-to-json (meta &optional fields) @@ -111,12 +113,12 @@ For example, to point to your `obe-bibtex-file' use the following. (add (remove-duplicates (col field) :test #'string=))) ;; build the links in the graph (dolist (citation meta) - (let ((dest (id (cdr (assoc :title citation))))) - (dolist (author (mapcar #'id (cdr (assoc :authors citation)))) + (let ((dest (id (cdr (assq :title citation))))) + (dolist (author (mapcar #'id (cdr (assq :authors citation)))) (when author (push (cons author dest) links))) - (let ((jid (id (cdr (assoc :journal citation))))) + (let ((jid (id (cdr (assq :journal citation))))) (when jid (push (cons jid dest) links))) - (let ((cid (id (cdr (assoc :category citation))))) + (let ((cid (id (cdr (assq :category citation))))) (when cid (push (cons cid dest) links))))) ;; build the json string (format "{\"nodes\":[%s],\"links\":[%s]}" diff --git a/contrib/lisp/org-bookmark.el b/contrib/lisp/org-bookmark.el index 40c7cd0..f042467 100644 --- a/contrib/lisp/org-bookmark.el +++ b/contrib/lisp/org-bookmark.el @@ -47,8 +47,9 @@ Otherwise prompt the user for the right bookmark to use." :group 'org-bookmark :type 'boolean) -(org-add-link-type "bookmark" 'org-bookmark-open) -(add-hook 'org-store-link-functions 'org-bookmark-store-link) +(org-link-set-parameters "bookmark" + :follow #'org-bookmark-open + :store #'org-bookmark-store-link) (defun org-bookmark-open (bookmark) "Visit the bookmark BOOKMARK." diff --git a/contrib/lisp/org-colview-xemacs.el b/contrib/lisp/org-colview-xemacs.el deleted file mode 100644 index a27275e..0000000 --- a/contrib/lisp/org-colview-xemacs.el +++ /dev/null @@ -1,1714 +0,0 @@ -;;; org-colview-xemacs.el --- Column View in Org-mode, XEmacs-specific version - -;; Copyright (C) 2004-2015 -;; Carsten Dominik - -;; Author: Carsten Dominik <carsten at orgmode dot org> -;; Keywords: outlines, hypermedia, calendar, wp -;; Homepage: http://orgmode.org -;; -;; This file is part of Org mode, it is not part of GNU Emacs. -;; -;; 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 of the License, 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. 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" ()) - - -;;; 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)))) - (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 (- (point) - (or (text-property-any (point-at-bol) (point-at-eol) 'org-heading t) - (point)))) - (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 (assoc-string property props t) - width (or (cdr (assoc-string property - org-columns-current-maxwidths - t)) - (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") - (org-columns-compact-links val)) - ((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-string property - org-columns-current-maxwidths - t)) - (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.") - -;;;###autoload -(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-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) - -(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 (derived-mode-p 'org-mode) - (nth 3 (assoc-string key org-columns-current-fmt-compiled t))) - (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-at-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-string key - org-columns-current-fmt-compiled - t)) - '(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-string key org-columns-current-fmt-compiled t)) - (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))) - -;;;###autoload -(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 org-outline-regexp-bol 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-string prop - org-columns-current-fmt-compiled - t))) - 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-string (car entry) - org-columns-current-maxwidths - t))))) - (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-at-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 - (let ((prop (car x))) - (mapcar - (lambda (y) - (length (or (cdr (assoc-string prop (cdr y) t)) - " "))) - 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-string - property - (get-text-property - (point-at-bol) 'org-summaries) - t))) - (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)))) - -;;;###autoload -(defun org-columns-compute (property) - "Sum the values of property PROPERTY hierarchically, for the entire buffer." - (interactive) - (let* ((re org-outline-regexp-bol) - (lmax 30) ; Does anyone use deeper levels??? - (lvals (make-vector lmax nil)) - (lflag (make-vector lmax nil)) - (level 0) - (ass (assoc-string property org-columns-current-fmt-compiled t)) - (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)) - (let ((old (assoc-string property sum-alist t))) - (if old (setcdr old 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 (derived-mode-p 'org-mode) - (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))) - -;;;###autoload -(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 (format org-heading-keyword-regexp-format - org-comment-string)) - (re-archive (concat ".*:" org-archive-tag ":")) - (n (length title)) row tbl) - (goto-char (point-min)) - - (while (re-search-forward org-heading-regexp 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 (point-marker)) - (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)) - (case-fold-search t) - 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-string org-effort-property p t))) - (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-clocksum-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-string prop x t))) - (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-string - (car fm) - org-columns-current-fmt-compiled - t)) - (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/contrib/lisp/org-contacts.el b/contrib/lisp/org-contacts.el index edc09fe..2cadd1d 100644 --- a/contrib/lisp/org-contacts.el +++ b/contrib/lisp/org-contacts.el @@ -52,9 +52,7 @@ ;; ;;; Code: -(eval-when-compile - (require 'cl)) - +(require 'cl-lib) (require 'org) (require 'gnus-util) (require 'gnus-art) @@ -161,12 +159,14 @@ The following replacements are available: :group 'org-contacts) (defcustom org-contacts-matcher - (mapconcat 'identity (list org-contacts-email-property - org-contacts-alias-property - org-contacts-tel-property - org-contacts-address-property - org-contacts-birthday-property) - "<>\"\"|") + (mapconcat #'identity + (mapcar (lambda (x) (concat x "<>\"\"")) + (list org-contacts-email-property + org-contacts-alias-property + org-contacts-tel-property + org-contacts-address-property + org-contacts-birthday-property)) + "|") "Matching rule for finding heading that are contacts. This can be a tag name, or a property check." :type 'string @@ -232,7 +232,7 @@ A regexp matching strings of whitespace, `,' and `;'.") (defun org-contacts-db-need-update-p () "Determine whether `org-contacts-db' needs to be refreshed." (or (null org-contacts-last-update) - (org-find-if (lambda (file) + (cl-find-if (lambda (file) (or (time-less-p org-contacts-last-update (elt (file-attributes file) 5)))) (org-contacts-files)) @@ -252,9 +252,8 @@ to dead or no buffer." (defun org-contacts-db () "Return the latest Org Contacts Database." - (let* (todo-only - (contacts-matcher - (cdr (org-make-tags-matcher org-contacts-matcher))) + (let* ((org--matcher-tags-todo-only nil) + (contacts-matcher (cdr (org-make-tags-matcher org-contacts-matcher))) result) (when (org-contacts-db-need-update-p) (let ((progress-reporter @@ -288,10 +287,9 @@ to dead or no buffer." (error "File %s is not in `org-mode'" file)) (setf result (append result - (org-scan-tags - 'org-contacts-at-point - contacts-matcher - todo-only))))) + (org-scan-tags 'org-contacts-at-point + contacts-matcher + org--matcher-tags-todo-only))))) (progress-reporter-update progress-reporter (setq i (1+ i)))) (setf org-contacts-db result org-contacts-last-update (current-time)) @@ -316,22 +314,22 @@ cell corresponding to the contact properties. (null prop-match) (null tags-match)) (org-contacts-db) - (loop for contact in (org-contacts-db) - if (or - (and name-match - (org-string-match-p name-match - (first contact))) - (and prop-match - (org-find-if (lambda (prop) - (and (string= (car prop-match) (car prop)) - (org-string-match-p (cdr prop-match) (cdr prop)))) - (caddr contact))) - (and tags-match - (org-find-if (lambda (tag) - (org-string-match-p tags-match tag)) - (org-split-string - (or (cdr (assoc-string "ALLTAGS" (caddr contact))) "") ":")))) - collect contact))) + (cl-loop for contact in (org-contacts-db) + if (or + (and name-match + (string-match-p name-match + (first contact))) + (and prop-match + (cl-find-if (lambda (prop) + (and (string= (car prop-match) (car prop)) + (string-match-p (cdr prop-match) (cdr prop)))) + (caddr contact))) + (and tags-match + (cl-find-if (lambda (tag) + (string-match-p tags-match tag)) + (org-split-string + (or (cdr (assoc-string "ALLTAGS" (caddr contact))) "") ":")))) + collect contact))) (when (not (fboundp 'completion-table-case-fold)) ;; That function is new in Emacs 24... @@ -344,34 +342,34 @@ cell corresponding to the contact properties. "Custom implementation of `try-completion'. This version works only with list and alist and it looks at all prefixes rather than just the beginning of the string." - (loop with regexp = (concat "\\b" (regexp-quote to-match)) - with ret = nil - with ret-start = nil - with ret-end = nil - - for el in collection - for string = (if (listp el) (car el) el) - - for start = (when (or (null predicate) (funcall predicate string)) - (string-match regexp string)) - - if start - do (let ((end (match-end 0)) - (len (length string))) - (if (= end len) - (return t) - (destructuring-bind (string start end) - (if (null ret) - (values string start end) - (org-contacts-common-substring - ret ret-start ret-end - string start end)) - (setf ret string - ret-start start - ret-end end)))) - - finally (return - (replace-regexp-in-string "\\`[ \t\n]*" "" ret)))) + (cl-loop with regexp = (concat "\\b" (regexp-quote to-match)) + with ret = nil + with ret-start = nil + with ret-end = nil + + for el in collection + for string = (if (listp el) (car el) el) + + for start = (when (or (null predicate) (funcall predicate string)) + (string-match regexp string)) + + if start + do (let ((end (match-end 0)) + (len (length string))) + (if (= end len) + (cl-return t) + (cl-destructuring-bind (string start end) + (if (null ret) + (values string start end) + (org-contacts-common-substring + ret ret-start ret-end + string start end)) + (setf ret string + ret-start start + ret-end end)))) + + finally (cl-return + (replace-regexp-in-string "\\`[ \t\n]*" "" ret)))) (defun org-contacts-compare-strings (s1 start1 end1 s2 start2 end2 &optional ignore-case) "Compare the contents of two strings, using `compare-strings'. @@ -430,22 +428,22 @@ This function returns a list whose contains: "Custom version of `all-completions'. This version works only with list and alist and it looks at all prefixes rather than just the beginning of the string." - (loop with regexp = (concat "\\b" (regexp-quote to-match)) - for el in collection - for string = (if (listp el) (car el) el) - for match? = (when (and (or (null predicate) (funcall predicate string))) - (string-match regexp string)) - if match? - collect (progn - (let ((end (match-end 0))) - (org-no-properties string) - (when (< end (length string)) - ;; Here we add a text property that will be used - ;; later to highlight the character right after - ;; the common part between each addresses. - ;; See `org-contacts-display-sort-function'. - (put-text-property end (1+ end) 'org-contacts-prefix 't string))) - string))) + (cl-loop with regexp = (concat "\\b" (regexp-quote to-match)) + for el in collection + for string = (if (listp el) (car el) el) + for match? = (when (and (or (null predicate) (funcall predicate string))) + (string-match regexp string)) + if match? + collect (progn + (let ((end (match-end 0))) + (org-no-properties string) + (when (< end (length string)) + ;; Here we add a text property that will be used + ;; later to highlight the character right after + ;; the common part between each addresses. + ;; See `org-contacts-display-sort-function'. + (put-text-property end (1+ end) 'org-contacts-prefix 't string))) + string))) (defun org-contacts-make-collection-prefix (collection) "Make a collection function from COLLECTION which will match on prefixes." @@ -460,7 +458,7 @@ prefixes rather than just the beginning of the string." ((eq flag 'lambda) (org-contacts-test-completion-prefix string collection predicate)) ((and (listp flag) (eq (car flag) 'boundaries)) - (destructuring-bind (to-ignore &rest suffix) + (cl-destructuring-bind (to-ignore &rest suffix) flag (org-contacts-boundaries-prefix string collection predicate suffix))) ((eq flag 'metadata) @@ -471,31 +469,28 @@ prefixes rather than just the beginning of the string." (defun org-contacts-display-sort-function (completions) "Sort function for contacts display." (mapcar (lambda (string) - (loop with len = (1- (length string)) - for i upfrom 0 to len - if (memq 'org-contacts-prefix - (text-properties-at i string)) - do (set-text-properties - i (1+ i) - (list 'font-lock-face - (if (char-equal (aref string i) - (string-to-char " ")) - ;; Spaces can't be bold. - 'underline - 'bold)) string) - else - do (set-text-properties i (1+ i) nil string) - finally (return string))) + (cl-loop with len = (1- (length string)) + for i upfrom 0 to len + if (memq 'org-contacts-prefix + (text-properties-at i string)) + do (set-text-properties + i (1+ i) + (list 'font-lock-face + (if (char-equal (aref string i) + (string-to-char " ")) + ;; Spaces can't be bold. + 'underline + 'bold)) string) + else + do (set-text-properties i (1+ i) nil string) + finally (cl-return string))) completions)) (defun org-contacts-test-completion-prefix (string collection predicate) - ;; Prevents `org-find-if' from redefining `predicate' and going into - ;; an infinite loop. - (lexical-let ((predicate predicate)) - (org-find-if (lambda (el) - (and (or (null predicate) (funcall predicate el)) - (string= string el))) - collection))) + (cl-find-if (lambda (el) + (and (or (null predicate) (funcall predicate el)) + (string= string el))) + collection)) (defun org-contacts-boundaries-prefix (string collection predicate suffix) (list* 'boundaries (completion-boundaries string collection predicate suffix))) @@ -510,7 +505,7 @@ prefixes rather than just the beginning of the string." A group FOO is composed of contacts with the tag FOO." (let* ((completion-ignore-case org-contacts-completion-ignore-case) - (group-completion-p (org-string-match-p + (group-completion-p (string-match-p (concat "^" org-contacts-group-prefix) string))) (when group-completion-p (let ((completion-list @@ -520,9 +515,9 @@ A group FOO is composed of contacts with the tag FOO." (propertize (concat org-contacts-group-prefix group) 'org-contacts-group group)) (org-uniquify - (loop for contact in (org-contacts-filter) - nconc (org-split-string - (or (cdr (assoc-string "ALLTAGS" (caddr contact))) "") ":"))))))) + (cl-loop for contact in (org-contacts-filter) + nconc (org-split-string + (or (cdr (assoc-string "ALLTAGS" (caddr contact))) "") ":"))))))) (list start end (if (= (length completion-list) 1) ;; We've found the correct group, returns the address @@ -530,21 +525,21 @@ A group FOO is composed of contacts with the tag FOO." (car completion-list)))) (lambda (string pred &optional to-ignore) (mapconcat 'identity - (loop for contact in (org-contacts-filter - nil - tag) - ;; The contact name is always the car of the assoc-list - ;; returned by `org-contacts-filter'. - for contact-name = (car contact) - ;; Grab the first email of the contact - for email = (org-contacts-strip-link - (or (car (org-contacts-split-property - (or - (cdr (assoc-string org-contacts-email-property - (caddr contact))) - ""))) "")) - ;; If the user has an email address, append USER <EMAIL>. - if email collect (org-contacts-format-email contact-name email)) + (cl-loop for contact in (org-contacts-filter + nil + tag) + ;; The contact name is always the car of the assoc-list + ;; returned by `org-contacts-filter'. + for contact-name = (car contact) + ;; Grab the first email of the contact + for email = (org-contacts-strip-link + (or (car (org-contacts-split-property + (or + (cdr (assoc-string org-contacts-email-property + (cl-caddr contact))) + ""))) "")) + ;; If the user has an email address, append USER <EMAIL>. + if email collect (org-contacts-format-email contact-name email)) ", "))) ;; We haven't found the correct group (completion-table-case-fold completion-list @@ -559,30 +554,30 @@ with BAR. See (org) Matching tags and properties for a complete description." (let* ((completion-ignore-case org-contacts-completion-ignore-case) - (completion-p (org-string-match-p + (completion-p (string-match-p (concat "^" org-contacts-tags-props-prefix) string))) (when completion-p (let ((result (mapconcat 'identity - (loop for contact in (org-contacts-db) - for contact-name = (car contact) - for email = (org-contacts-strip-link (or (car (org-contacts-split-property - (or - (cdr (assoc-string org-contacts-email-property - (caddr contact))) - ""))) "")) - for tags = (cdr (assoc "TAGS" (nth 2 contact))) - for tags-list = (if tags - (split-string (substring (cdr (assoc "TAGS" (nth 2 contact))) 1 -1) ":") - '()) - for marker = (second contact) - if (with-current-buffer (marker-buffer marker) - (save-excursion - (goto-char marker) - (let (todo-only) - (eval (cdr (org-make-tags-matcher (subseq string 1))))))) - collect (org-contacts-format-email contact-name email)) + (cl-loop for contact in (org-contacts-db) + for contact-name = (car contact) + for email = (org-contacts-strip-link (or (car (org-contacts-split-property + (or + (cdr (assoc-string org-contacts-email-property + (cl-caddr contact))) + ""))) "")) + for tags = (cdr (assoc "TAGS" (nth 2 contact))) + for tags-list = (if tags + (split-string (substring (cdr (assoc "TAGS" (nth 2 contact))) 1 -1) ":") + '()) + for marker = (nth 1 contact) + if (with-current-buffer (marker-buffer marker) + (save-excursion + (goto-char marker) + (let (todo-only) + (eval (cdr (org-make-tags-matcher (cl-subseq string 1))))))) + collect (org-contacts-format-email contact-name email)) ","))) (when (not (string= "" result)) ;; return (start end function) @@ -593,37 +588,37 @@ description." (defun org-contacts-remove-ignored-property-values (ignore-list list) "Remove all ignore-list's elements from list and you can use regular expressions in the ignore list." - (org-remove-if (lambda (el) - (org-find-if (lambda (x) - (string-match-p x el)) - ignore-list)) - list)) + (cl-remove-if (lambda (el) + (cl-find-if (lambda (x) + (string-match-p x el)) + ignore-list)) + list)) (defun org-contacts-complete-name (start end string) "Complete text at START with a user name and email." (let* ((completion-ignore-case org-contacts-completion-ignore-case) (completion-list - (loop for contact in (org-contacts-filter) - ;; The contact name is always the car of the assoc-list - ;; returned by `org-contacts-filter'. - for contact-name = (car contact) - - ;; Build the list of the email addresses which has - ;; been expired - for ignore-list = (org-contacts-split-property - (or (cdr (assoc-string org-contacts-ignore-property - (caddr contact))) "")) - ;; Build the list of the user email addresses. - for email-list = (org-contacts-remove-ignored-property-values - ignore-list - (org-contacts-split-property - (or (cdr (assoc-string org-contacts-email-property - (caddr contact))) ""))) - ;; If the user has email addresses… - if email-list - ;; … append a list of USER <EMAIL>. - nconc (loop for email in email-list - collect (org-contacts-format-email contact-name (org-contacts-strip-link email))))) + (cl-loop for contact in (org-contacts-filter) + ;; The contact name is always the car of the assoc-list + ;; returned by `org-contacts-filter'. + for contact-name = (car contact) + + ;; Build the list of the email addresses which has + ;; been expired + for ignore-list = (org-contacts-split-property + (or (cdr (assoc-string org-contacts-ignore-property + (nth 2 contact))) "")) + ;; Build the list of the user email addresses. + for email-list = (org-contacts-remove-ignored-property-values + ignore-list + (org-contacts-split-property + (or (cdr (assoc-string org-contacts-email-property + (nth 2 contact))) ""))) + ;; If the user has email addresses… + if email-list + ;; … append a list of USER <EMAIL>. + nconc (cl-loop for email in email-list + collect (org-contacts-format-email contact-name (org-contacts-strip-link email))))) (completion-list (org-contacts-all-completions-prefix string (org-uniquify completion-list)))) @@ -662,13 +657,13 @@ description." (let* ((address (org-contacts-gnus-get-name-email)) (name (car address)) (email (cadr address))) - (cadar (or (org-contacts-filter - nil - nil - (cons org-contacts-email-property (concat "\\b" (regexp-quote email) "\\b"))) - (when name - (org-contacts-filter - (concat "^" name "$"))))))) + (cl-cadar (or (org-contacts-filter + nil + nil + (cons org-contacts-email-property (concat "\\b" (regexp-quote email) "\\b"))) + (when name + (org-contacts-filter + (concat "^" name "$"))))))) (defun org-contacts-gnus-article-from-goto () "Go to contact in the From address of current Gnus message." @@ -677,14 +672,9 @@ description." (when marker (switch-to-buffer-other-window (marker-buffer marker)) (goto-char marker) - (when (eq major-mode 'org-mode) - (org-show-context 'agenda) - (save-excursion - (and (outline-next-heading) - ;; show the next heading - (org-flag-heading nil))))))) + (when (eq major-mode 'org-mode) (org-show-context 'agenda))))) -(org-no-warnings (defvar date)) ;; unprefixed, from calendar.el +(with-no-warnings (defvar date)) ;; unprefixed, from calendar.el (defun org-contacts-anniversaries (&optional field format) "Compute FIELD anniversary for each contact, returning FORMAT. Default FIELD value is \"BIRTHDAY\". @@ -698,23 +688,23 @@ Format is a string matching the following format specification: (let ((calendar-date-style 'american) (entry "")) (unless format (setq format org-contacts-birthday-format)) - (loop for contact in (org-contacts-filter) - for anniv = (let ((anniv (cdr (assoc-string - (or field org-contacts-birthday-property) - (caddr contact))))) - (when anniv - (calendar-gregorian-from-absolute - (org-time-string-to-absolute anniv)))) - ;; Use `diary-anniversary' to compute anniversary. - if (and anniv (apply 'diary-anniversary anniv)) - collect (format-spec format - `((?l . ,(org-with-point-at (cadr contact) (org-store-link nil))) - (?h . ,(car contact)) - (?y . ,(- (calendar-extract-year date) - (calendar-extract-year anniv))) - (?Y . ,(let ((years (- (calendar-extract-year date) - (calendar-extract-year anniv)))) - (format "%d%s" years (diary-ordinal-suffix years))))))))) + (cl-loop for contact in (org-contacts-filter) + for anniv = (let ((anniv (cdr (assoc-string + (or field org-contacts-birthday-property) + (nth 2 contact))))) + (when anniv + (calendar-gregorian-from-absolute + (org-time-string-to-absolute anniv)))) + ;; Use `diary-anniversary' to compute anniversary. + if (and anniv (apply 'diary-anniversary anniv)) + collect (format-spec format + `((?l . ,(org-with-point-at (cadr contact) (org-store-link nil))) + (?h . ,(car contact)) + (?y . ,(- (calendar-extract-year date) + (calendar-extract-year anniv))) + (?Y . ,(let ((years (- (calendar-extract-year date) + (calendar-extract-year anniv)))) + (format "%d%s" years (diary-ordinal-suffix years))))))))) (defun org-completing-read-date (prompt collection &optional predicate require-match initial-input @@ -995,7 +985,7 @@ to do our best." (defun org-contacts-vcard-format (contact) "Formats CONTACT in VCard 3.0 format." - (let* ((properties (caddr contact)) + (let* ((properties (nth 2 contact)) (name (org-contacts-vcard-escape (car contact))) (n (org-contacts-vcard-encode-name name)) (email (cdr (assoc-string org-contacts-email-property properties))) @@ -1054,15 +1044,15 @@ passed to `org-contacts-export-as-vcard-internal'." (interactive "P") (when (called-interactively-p 'any) (cl-psetf name - (when name - (read-string "Contact name: " - (first (org-contacts-at-point)))) - file - (when (equal name '(16)) - (read-file-name "File: " nil org-contacts-vcard-file)) - to-buffer - (when (equal name '(64)) - (read-buffer "Buffer: ")))) + (when name + (read-string "Contact name: " + (nth 0 (org-contacts-at-point)))) + file + (when (equal name '(16)) + (read-file-name "File: " nil org-contacts-vcard-file)) + to-buffer + (when (equal name '(64)) + (read-buffer "Buffer: ")))) (org-contacts-export-as-vcard-internal name file to-buffer)) (defun org-contacts-export-as-vcard-internal (&optional name file to-buffer) @@ -1094,9 +1084,9 @@ Requires google-maps-el." (error "`org-contacts-show-map' requires `google-maps-el'")) (google-maps-static-show :markers - (loop + (cl-loop for contact in (org-contacts-filter name) - for addr = (cdr (assoc-string org-contacts-address-property (caddr contact))) + for addr = (cdr (assoc-string org-contacts-address-property (nth 2 contact))) if addr collect (cons (list addr) (list :label (string-to-char (car contact))))))) @@ -1115,6 +1105,10 @@ link string and return the pure link target." (setq colonpos (string-match ":" link)) (if startpos (substring link (1+ colonpos)) link))))) +;; Add the link type supported by org-contacts-strip-link +;; so everything is in order for its use in Org files +(org-link-set-parameters "tel") + (defun org-contacts-split-property (string &optional separators omit-nulls) "Custom version of `split-string'. Split a property STRING into sub-strings bounded by matches diff --git a/contrib/lisp/org-download.el b/contrib/lisp/org-download.el deleted file mode 100644 index cbf335b..0000000 --- a/contrib/lisp/org-download.el +++ /dev/null @@ -1,392 +0,0 @@ -;;; org-download.el --- Image drag-and-drop for Emacs org-mode - -;; Copyright (C) 2014-2016 Free Software Foundation, Inc. - -;; Author: Oleh Krehel -;; Keywords: images, screenshots, download -;; Homepage: http://orgmode.org - -;; This file is not 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 extension facilitates moving images from point A to point B. -;; -;; Point A (the source) can be: -;; 1. An image inside your browser that you can drag to Emacs. -;; 2. An image on your file system that you can drag to Emacs. -;; 3. A local or remote image address in kill-ring. -;; Use the `org-download-yank' command for this. -;; Remember that you can use "0 w" in `dired' to get an address. -;; 4. An screenshot taken using `gnome-screenshot' or `scrot' or `gm'. -;; Use the `org-download-screenshot' command for this. -;; Customize the backend with `org-download-screenshot-method'. -;; -;; Point B (the target) is an Emacs `org-mode' buffer where the inline -;; link will be inserted. Several customization options will determine -;; where exactly on the file system the file will be stored. -;; -;; They are: -;; `org-download-method': -;; a. 'attach => use `org-mode' attachment machinery -;; b. 'directory => construct the directory in two stages: -;; 1. first part of the folder name is: -;; * either "." (current folder) -;; * or `org-download-image-dir' (if it's not nil). -;; `org-download-image-dir' becomes buffer-local when set, -;; so each file can customize this value, e.g with: -;; # -*- mode: Org; org-download-image-dir: "~/Pictures/foo"; -*- -;; 2. second part is: -;; * `org-download-heading-lvl' is nil => "" -;; * `org-download-heading-lvl' is n => the name of current -;; heading with level n. Level count starts with 0, -;; i.e. * is 0, ** is 1, *** is 2 etc. -;; `org-download-heading-lvl' becomes buffer-local when set, -;; so each file can customize this value, e.g with: -;; # -*- mode: Org; org-download-heading-lvl: nil; -*- -;; -;; `org-download-timestamp': -;; optionally add a timestamp to the file name. -;; -;; Customize `org-download-backend' to choose between `url-retrieve' -;; (the default) or `wget' or `curl'. -;; -;;; Code: - - -(eval-when-compile - (require 'cl)) -(require 'url-parse) -(require 'url-http) - -(defgroup org-download nil - "Image drag-and-drop for org-mode." - :group 'org - :prefix "org-download-") - -(defcustom org-download-method 'directory - "The way images should be stored." - :type '(choice - (const :tag "Directory" directory) - (const :tag "Attachment" attach)) - :group 'org-download) - -(defcustom org-download-image-dir nil - "If set, images will be stored in this directory instead of \".\". -See `org-download--dir-1' for more info." - :type '(choice - (const :tag "Default" nil) - (string :tag "Directory")) - :group 'org-download) -(make-variable-buffer-local 'org-download-image-dir) - -(defcustom org-download-heading-lvl 0 - "Heading level to be used in `org-download--dir-2'." - :group 'org-download) -(make-variable-buffer-local 'org-download-heading-lvl) - -(defcustom org-download-backend t - "Method to use for downloading." - :type '(choice - (const :tag "wget" "wget \"%s\" -O \"%s\"") - (const :tag "curl" "curl \"%s\" -o \"%s\"") - (const :tag "url-retrieve" t)) - :group 'org-download) - -(defcustom org-download-timestamp "_%Y-%m-%d_%H:%M:%S" - "This `format-time-string'-style string will be appended to the file name. -Set this to \"\" if you don't want time stamps." - :type 'string - :group 'org-download) - -(defcustom org-download-img-regex-list - '("<img +src=\"" "<img +\\(class=\"[^\"]+\"\\)? *src=\"") - "This regex is used to unalias links that look like images. -The html to which the links points will be searched for these -regexes, one by one, until one succeeds. The found image address -will be used." - :group 'org-download) - -(defcustom org-download-screenshot-method "gnome-screenshot -a -f %s" - "The tool to capture screenshots." - :type '(choice - (const :tag "gnome-screenshot" "gnome-screenshot -a -f %s") - (const :tag "scrot" "scrot -s %s") - (const :tag "gm" "gm import %s")) - :group 'org-download) - -(defcustom org-download-image-width 0 - "When non-zero add #+attr_html: :width tag to the image." - :type 'integer - :group 'org-download) - -(defun org-download-get-heading (lvl) - "Return the heading of the current entry's LVL level parent." - (save-excursion - (let ((cur-lvl (org-current-level))) - (if cur-lvl - (progn - (unless (= cur-lvl 1) - (org-up-heading-all (- (1- (org-current-level)) lvl))) - (substring-no-properties - (org-get-heading))) - "")))) - -(defun org-download--dir-1 () - "Return the first part of the directory path for `org-download--dir'. -It's `org-download-image-dir', unless it's nil. Then it's \".\"." - (or org-download-image-dir ".")) - -(defun org-download--dir-2 () - "Return the second part of the directory path for `org-download--dir'. -Unless `org-download-heading-lvl' is nil, it's the name of the current -`org-download-heading-lvl'-leveled heading. Otherwise it's \"\"." - (and org-download-heading-lvl - (org-download-get-heading - org-download-heading-lvl))) - -(defun org-download--dir () - "Return the directory path for image storage. - -The path is composed from `org-download--dir-1' and `org-download--dir-2'. -The directory is created if it didn't exist before." - (let* ((part1 (org-download--dir-1)) - (part2 (org-download--dir-2)) - (dir (if part2 - (format "%s/%s" part1 part2) - part1))) - (unless (file-exists-p dir) - (make-directory dir t)) - dir)) - -(defun org-download--fullname (link) - "Return the file name where LINK will be saved to. - -It's affected by `org-download-timestamp' and `org-download--dir'." - (let ((filename - (file-name-nondirectory - (car (url-path-and-query - (url-generic-parse-url link))))) - (dir (org-download--dir))) - (when (string-match ".*?\\.\\(?:png\\|jpg\\)\\(.*\\)$" filename) - (setq filename (replace-match "" nil nil filename 1))) - (abbreviate-file-name - (expand-file-name - (format "%s%s.%s" - (file-name-sans-extension filename) - (format-time-string org-download-timestamp) - (file-name-extension filename)) - dir)))) - -(defun org-download--image (link filename) - "Save LINK to FILENAME asynchronously and show inline images in current buffer." - (when (string-match "^file://\\(.*\\)" link) - (setq link (url-unhex-string (match-string 1 link)))) - (cond ((and (not (file-remote-p link)) - (file-exists-p link)) - (org-download--image/command "cp \"%s\" \"%s\"" link filename)) - ((eq org-download-backend t) - (org-download--image/url-retrieve link filename)) - (t - (org-download--image/command org-download-backend link filename)))) - -(defun org-download--image/command (command link filename) - "Using COMMAND, save LINK to FILENAME. -COMMAND is a format-style string with two slots for LINK and FILENAME." - (require 'async) - (async-start - `(lambda() (shell-command - ,(format command link - (expand-file-name filename)))) - (lexical-let ((cur-buf (current-buffer))) - (lambda(x) - (with-current-buffer cur-buf - (org-display-inline-images)))))) - -(defun org-download--image/url-retrieve (link filename) - "Save LINK to FILENAME using `url-retrieve'." - (url-retrieve - link - (lambda (status filename buffer) - ;; Write current buffer to FILENAME - ;; and update inline images in BUFFER - (let ((err (plist-get status :error))) - (if err (error - "\"%s\" %s" link - (downcase (nth 2 (assq (nth 2 err) url-http-codes)))))) - (delete-region - (point-min) - (progn - (re-search-forward "\n\n" nil 'move) - (point))) - (let ((coding-system-for-write 'no-conversion)) - (write-region nil nil filename nil nil nil 'confirm)) - (with-current-buffer buffer - (org-display-inline-images))) - (list - (expand-file-name filename) - (current-buffer)) - nil t)) - -(defun org-download-yank () - "Call `org-download-image' with current kill." - (interactive) - (org-download-image (current-kill 0))) - -(defun org-download-screenshot () - "Capture screenshot and insert the resulting file. -The screenshot tool is determined by `org-download-screenshot-method'." - (interactive) - (let ((link "/tmp/screenshot.png")) - (shell-command (format org-download-screenshot-method link)) - (org-download-image link))) - -(defun org-download-image (link) - "Save image at address LINK to `org-download--dir'." - (interactive "sUrl: ") - (unless (image-type-from-file-name link) - (with-current-buffer - (url-retrieve-synchronously link t) - (let ((regexes org-download-img-regex-list) - lnk) - (while (and (not lnk) regexes) - (goto-char (point-min)) - (when (re-search-forward (pop regexes) nil t) - (backward-char) - (setq lnk (read (current-buffer))))) - (if lnk - (setq link lnk) - (error "link %s does not point to an image; unaliasing failed" link))))) - (let ((filename - (if (eq org-download-method 'attach) - (let ((org-download-image-dir (progn (require 'org-attach) - (org-attach-dir t))) - org-download-heading-lvl) - (org-download--fullname link)) - (org-download--fullname link)))) - (when (image-type-from-file-name filename) - (org-download--image link filename) - (when (eq org-download-method 'attach) - (org-attach-attach filename nil 'none)) - (if (looking-back "^[ \t]+") - (delete-region (match-beginning 0) (match-end 0)) - (newline)) - (insert - (format "#+DOWNLOADED: %s @ %s\n%s [[%s]]" - link - (format-time-string "%Y-%m-%d %H:%M:%S") - (if (= org-download-image-width 0) - "" - (format - "#+attr_html: :width %dpx\n" org-download-image-width)) - filename)) - (org-display-inline-images)))) - -(defun org-download--at-comment-p () - "Check if current line begins with #+DOWLOADED:." - (save-excursion - (move-beginning-of-line nil) - (looking-at "#\\+DOWNLOADED:"))) - -(defun org-download-delete () - "Delete inline image link on current line, and the file that it points to." - (interactive) - (cond ((org-download--at-comment-p) - (delete-region (line-beginning-position) - (line-end-position)) - (org-download--delete (line-beginning-position) - nil - 1)) - ((region-active-p) - (org-download--delete (region-beginning) - (region-end)) - (delete-region (region-beginning) - (region-end))) - - (t (org-download--delete (line-beginning-position) - (line-end-position))))) - -(defun org-download--delete (beg end &optional times) - "Delete inline image links and the files they point to between BEG and END. - -When TIMES isn't nil, delete only TIMES links." - (unless times - (setq times most-positive-fixnum)) - (save-excursion - (goto-char beg) - (while (and (>= (decf times) 0) - (re-search-forward "\\[\\[\\([^]]*\\)\\]\\]" end t)) - (let ((str (match-string-no-properties 1))) - (delete-region beg - (match-end 0)) - (when (file-exists-p str) - (delete-file str)))))) - -(defun org-download-dnd (uri action) - "When in `org-mode' and URI points to image, download it. -Otherwise, pass URI and ACTION back to dnd dispatch." - (cond ((eq major-mode 'org-mode) - ;; probably shouldn't redirect - (unless (org-download-image uri) - (message "not an image URL"))) - ((eq major-mode 'dired-mode) - (org-download-dired uri)) - ;; redirect to someone else - (t - (let ((dnd-protocol-alist - (rassq-delete-all - 'org-download-dnd - (copy-alist dnd-protocol-alist)))) - (dnd-handle-one-url nil action uri))))) - -(defun org-download-dired (uri) - "Download URI to current directory." - (raise-frame) - (let ((filename (file-name-nondirectory - (car (url-path-and-query - (url-generic-parse-url uri)))))) - (message "Downloading %s to %s ..." - filename - (expand-file-name filename)) - (url-retrieve - uri - (lambda (status filename) - (let ((err (plist-get status :error))) - (if err (error - "\"%s\" %s" uri - (downcase (nth 2 (assq (nth 2 err) url-http-codes)))))) - (let ((coding-system-for-write 'no-conversion)) - (write-region nil nil filename nil nil nil 'confirm))) - (list - (expand-file-name filename)) - t t))) - -(defun org-download-enable () - "Enable org-download." - (unless (eq (cdr (assoc "^\\(https?\\|ftp\\|file\\|nfs\\)://" dnd-protocol-alist)) - 'org-download-dnd) - (setq dnd-protocol-alist - `(("^\\(https?\\|ftp\\|file\\|nfs\\)://" . org-download-dnd) ,@dnd-protocol-alist)))) - -(defun org-download-disable () - "Disable org-download." - (rassq-delete-all 'org-download-dnd dnd-protocol-alist)) - -(org-download-enable) - -(provide 'org-download) - -;;; org-download.el ends here diff --git a/contrib/lisp/org-ebib.el b/contrib/lisp/org-ebib.el index 2136a13..4ed5e50 100644 --- a/contrib/lisp/org-ebib.el +++ b/contrib/lisp/org-ebib.el @@ -22,9 +22,9 @@ (require 'org) -(org-add-link-type "ebib" 'org-ebib-open) - -(add-hook 'org-store-link-functions 'org-ebib-store-link) +(org-link-set-parameters "ebib" + :follow #'org-ebib-open + :store #'org-ebib-store-link) (defun org-ebib-open (key) "Open Ebib and jump to KEY." diff --git a/contrib/lisp/org-effectiveness.el b/contrib/lisp/org-effectiveness.el index b1e5a35..8d179fc 100644 --- a/contrib/lisp/org-effectiveness.el +++ b/contrib/lisp/org-effectiveness.el @@ -34,7 +34,7 @@ (require 'org) (defcustom org-effectiveness-max-todo 50 - "This variable is useful to advice to the user about + "This variable is useful to advice to the user about many TODO pending" :type 'integer :group 'org-effectiveness) @@ -42,9 +42,10 @@ many TODO pending" (defun org-effectiveness-advice() "Advicing about a possible excess of TODOS" (interactive) - (goto-char (point-min)) - (if (< org-effectiveness-max-todo (count-matches "* TODO")) - (message "An excess of TODOS!"))) + (save-excursion + (goto-char (point-min)) + (if (< org-effectiveness-max-todo (count-matches "* TODO")) + (message "An excess of TODOS!")))) ;; Check advice starting an org file (add-hook 'org-mode-hook 'org-effectiveness-advice) @@ -59,10 +60,10 @@ many TODO pending" (defun org-effectiveness-count-todo() "Print a message with the number of todo tasks in the current buffer" (interactive) - (save-excursion + (save-excursion (goto-char (point-min)) (message "Number of TODO: %d" (count-matches "* TODO")))) - + (defun org-effectiveness-count-done() "Print a message with the number of done tasks in the current buffer" (interactive) @@ -77,6 +78,13 @@ many TODO pending" (goto-char (point-min)) (message "Number of Canceled: %d" (count-matches "* CANCEL+ED")))) +(defun org-effectiveness-count-task() + "Print a message with the number of tasks and subtasks in the current buffer" + (interactive) + (save-excursion + (goto-char (point-min)) + (message "Number of tasks: %d" (count-matches "^*")))) + (defun org-effectiveness() "Returns the effectiveness in the current org buffer" (interactive) @@ -89,25 +97,41 @@ many TODO pending" (setq effectiveness (* 100 (/ done (+ done canc))))) (message "Effectiveness: %f" effectiveness)))) + (defun org-effectiveness-keywords-in-date(keyword date) (interactive "sKeyword: \nsDate: " keyword date) (setq count (count-matches (concat keyword ".*\n.*" date))) (message (concat "%sS: %d" keyword count))) -(defun org-effectiveness-dones-in-date(date) - (interactive "sGive me a date: " date) - (setq count (count-matches (concat "DONE.*\n.*" date))) - (message "DONES: %d" count)) +(defun org-effectiveness-dones-in-date(date &optional notmessage) + (interactive "sGive me a date: " date) + (save-excursion + (goto-char (point-min)) + (let ((count (count-matches (concat "DONE.*\n.*" date)))) + (if (eq notmessage 1) + (message "%d" count) + (message "DONES: %d " count))))) -(defun org-effectivenes-todos-in-date(date) - (interactive "sGive me a date: " date) - (setq count (count-matches (concat "TODO.*\n.*" date))) - (message "TODOS: %d" count)) +(defun org-effectiveness-todos-in-date(date) + (interactive "sGive me a date: " date) + (save-excursion + (goto-char (point-min)) + (setq count (count-matches (concat "TODO.*\n.*" date))) + (message "TODOS: %d" count))) (defun org-effectiveness-canceled-in-date(date) - (interactive "sGive me a date: " date) - (setq count (count-matches (concat "CANCEL+ED.*\n.*" date))) - (message "CANCELEDS: %d" count)) + (interactive "sGive me a date: " date) + (save-excursion + (goto-char (point-min)) + (setq count (count-matches (concat "CANCEL+ED.*\n.*" date))) + (message "CANCELEDS: %d" count))) + +(defun org-effectiveness-ntasks-in-date(date &optional notmessage) + (interactive "sGive me a date: " date) + (save-excursion + (goto-char (point-min)) + (let ((tasks (float (count-matches (concat "^*.*\n.*" date))))) + (message "%d" tasks)))) (defun org-effectiveness-in-date(date &optional notmessage) (interactive "sGive me a date: " date) @@ -130,14 +154,14 @@ many TODO pending" (defun org-effectiveness-plot(startdate enddate &optional save) (interactive "sGive me the start date: \nsGive me the end date: " startdate enddate) (setq dates (org-effectiveness-check-dates startdate enddate)) - (setq syear (cadr (assoc 'startyear dates))) - (setq smonth (cadr (assoc 'startmonth dates))) - (setq eyear (cadr (assoc 'endyear dates))) - (setq emonth (assoc 'endmonth dates)) + (setq syear (cadr (assq 'startyear dates))) + (setq smonth (cadr (assq 'startmonth dates))) + (setq eyear (cadr (assq 'endyear dates))) + (setq emonth (assq 'endmonth dates)) ;; Checking the format of the dates - (if (not (string-match "[0-9][0-9][0-9][0-9]-[0-9][0-9]" startdate)) + (if (not (string-match "[0-9][0-9][0-9][0-9]-[0-9][0-9]" startdate)) (message "The start date must have the next format YYYY-MM")) - (if (not (string-match "[0-9][0-9][0-9][0-9]-[0-9][0-9]" enddate)) + (if (not (string-match "[0-9][0-9][0-9][0-9]-[0-9][0-9]" enddate)) (message "The end date must have the next format YYYY-MM")) ;; Checking if startdate < enddate (if (string-match "^[0-9][0-9][0-9][0-9]" startdate) @@ -152,19 +176,19 @@ many TODO pending" (message "The start date must be before that end date")) (if (and (= startyear endyear) (> startmonth endmonth)) (message "The start date must be before that end date")) -;; Create a file +;; Create a file (let ((month startmonth) (year startyear) (str "")) - (while (or (> endyear year) (and (= endyear year) (>= endmonth month))) + (while (or (> endyear year) (and (= endyear year) (>= endmonth month))) (setq str (concat str (number-to-string year) "-" (org-effectiveness-month-to-string month) " " (org-effectiveness-in-date (concat (number-to-string year) "-" (org-effectiveness-month-to-string month)) 1) "\n")) (if (= month 12) - (progn + (progn (setq year (+ 1 year)) (setq month 1)) (setq month (+ 1 month)))) (write-region str nil "/tmp/org-effectiveness")) -;; Create the bar graph +;; Create the bar graph (if (eq save t) (setq strplot "/usr/bin/gnuplot -e 'set term png; set output \"/tmp/org-effectiveness.png\"; plot \"/tmp/org-effectiveness\" using 2:xticlabels(1) with histograms' -p") (setq strplot "/usr/bin/gnuplot -e 'plot \"/tmp/org-effectiveness\" using 2:xticlabels(1) with histograms' -p")) @@ -221,9 +245,9 @@ many TODO pending" (defun org-effectiveness-check-dates (startdate enddate) "Generate a list with ((startyear startmonth) (endyear endmonth))" (setq str nil) - (if (not (string-match "[0-9][0-9][0-9][0-9]-[0-9][0-9]" startdate)) + (if (not (string-match "[0-9][0-9][0-9][0-9]-[0-9][0-9]" startdate)) (setq str "The start date must have the next format YYYY-MM")) - (if (not (string-match "[0-9][0-9][0-9][0-9]-[0-9][0-9]" enddate)) + (if (not (string-match "[0-9][0-9][0-9][0-9]-[0-9][0-9]" enddate)) (setq str "The end date must have the next format YYYY-MM")) ;; Checking if startdate < enddate (if (string-match "^[0-9][0-9][0-9][0-9]" startdate) @@ -246,12 +270,12 @@ many TODO pending" (defun org-effectiveness-plot-ascii (startdate enddate) (interactive "sGive me the start date: \nsGive me the end date: " startdate enddate) (setq dates (org-effectiveness-check-dates startdate enddate)) - (let ((syear (cadr (assoc 'startyear dates))) - (smonth (cadr (assoc 'startmonth dates))) - (year (cadr (assoc 'startyear dates))) - (month (cadr (assoc 'startmonth dates))) - (emonth (cadr (assoc 'endmonth dates))) - (eyear (cadr (assoc 'endyear dates))) + (let ((syear (cadr (assq 'startyear dates))) + (smonth (cadr (assq 'startmonth dates))) + (year (cadr (assq 'startyear dates))) + (month (cadr (assq 'startmonth dates))) + (emonth (cadr (assq 'endmonth dates))) + (eyear (cadr (assq 'endyear dates))) (buffer (current-buffer)) (str "")) (while (or (> eyear year) (and (= eyear year) (>= emonth month))) @@ -260,22 +284,70 @@ many TODO pending" (org-effectiveness-ascii-bar (string-to-number str) (format "%s-%s" year month)) (switch-to-buffer buffer) (if (eq month 12) - (progn + (progn + (setq year (+ 1 year)) + (setq month 1)) + (setq month (+ 1 month))))) + (switch-to-buffer "*org-effectiveness*")) + + +(defun org-effectiveness-plot-ascii-ntasks (startdate enddate) + (interactive "sGive me the start date: \nsGive me the end date: " startdate enddate) + (setq dates (org-effectiveness-check-dates startdate enddate)) + (let ((syear (cadr (assq 'startyear dates))) + (smonth (cadr (assq 'startmonth dates))) + (year (cadr (assq 'startyear dates))) + (month (cadr (assq 'startmonth dates))) + (emonth (cadr (assq 'endmonth dates))) + (eyear (cadr (assq 'endyear dates))) + (buffer (current-buffer)) + (str "")) + (while (or (> eyear year) (and (= eyear year) (>= emonth month))) + (setq str (org-effectiveness-ntasks-in-date (concat (number-to-string year) "-" (org-effectiveness-month-to-string month)) 1)) + (switch-to-buffer "*org-effectiveness*") + (org-effectiveness-ascii-bar (string-to-number str) (format "%s-%s" year month)) + (switch-to-buffer buffer) + (if (eq month 12) + (progn (setq year (+ 1 year)) (setq month 1)) (setq month (+ 1 month))))) (switch-to-buffer "*org-effectiveness*")) +(defun org-effectiveness-plot-ascii-dones (startdate enddate) + (interactive "sGive me the start date: \nsGive me the end date: " startdate enddate) + (setq dates (org-effectiveness-check-dates startdate enddate)) + (let ((syear (cadr (assq 'startyear dates))) + (smonth (cadr (assq 'startmonth dates))) + (year (cadr (assq 'startyear dates))) + (month (cadr (assq 'startmonth dates))) + (emonth (cadr (assq 'endmonth dates))) + (eyear (cadr (assq 'endyear dates))) + (buffer (current-buffer)) + (str "")) + (while (or (> eyear year) (and (= eyear year) (>= emonth month))) + (setq str (org-effectiveness-dones-in-date (concat (number-to-string year) "-" (org-effectiveness-month-to-string month)) 1)) + (switch-to-buffer "*org-effectiveness*") + (org-effectiveness-ascii-bar (string-to-number str) (format "%s-%s" year month)) + (switch-to-buffer buffer) + (if (eq month 12) + (progn + (setq year (+ 1 year)) + (setq month 1)) + (setq month (+ 1 month))))) + (switch-to-buffer "*org-effectiveness*")) + + (defun org-effectiveness-plot-html (startdate enddate) "Print html bars about the effectiveness in a buffer" (interactive "sGive me the start date: \nsGive me the end date: " startdate enddate) (setq dates (org-effectiveness-check-dates startdate enddate)) - (let ((syear (cadr (assoc 'startyear dates))) - (smonth (cadr (assoc 'startmonth dates))) - (year (cadr (assoc 'startyear dates))) - (month (cadr (assoc 'startmonth dates))) - (emonth (cadr (assoc 'endmonth dates))) - (eyear (cadr (assoc 'endyear dates))) + (let ((syear (cadr (assq 'startyear dates))) + (smonth (cadr (assq 'startmonth dates))) + (year (cadr (assq 'startyear dates))) + (month (cadr (assq 'startmonth dates))) + (emonth (cadr (assq 'endmonth dates))) + (eyear (cadr (assq 'endyear dates))) (buffer (current-buffer)) (str "")) (switch-to-buffer "*org-effectiveness-html*") @@ -287,7 +359,7 @@ many TODO pending" (switch-to-buffer buffer) (format "%s-%s" year month) (if (eq month 12) - (progn + (progn (setq year (+ 1 year)) (setq month 1)) (setq month (+ 1 month)))) @@ -295,4 +367,3 @@ many TODO pending" (insert "</body></html>"))) (provide 'org-effectiveness) - diff --git a/contrib/lisp/org-eldoc.el b/contrib/lisp/org-eldoc.el index 5583cb8..046918d 100644 --- a/contrib/lisp/org-eldoc.el +++ b/contrib/lisp/org-eldoc.el @@ -38,6 +38,10 @@ (require 'ob-core) (require 'eldoc) +(declare-function org-element-at-point "org-element" ()) +(declare-function org-element-property "org-element" (property element)) +(declare-function org-element-type "org-element" (element)) + (defgroup org-eldoc nil "" :group 'org) (defcustom org-eldoc-breadcrumb-separator "/" @@ -70,7 +74,7 @@ (save-match-data (when (looking-at "^[ \t]*#\\+\\(begin\\|end\\)_src") (setq info (org-babel-get-src-block-info 'light) - lang (propertize (nth 0 info) 'face 'font-lock-string-face) + lang (propertize (or (nth 0 info) "no lang") 'face 'font-lock-string-face) hdr-args (nth 2 info)) (concat lang @@ -87,13 +91,17 @@ (defun org-eldoc-get-src-lang () "Return value of lang for the current block if in block body and nil otherwise." - (let ((case-fold-search t)) - (save-match-data - (when (org-between-regexps-p ".*#\\+begin_src" - ".*#\\+end_src") - (save-excursion - (goto-char (org-babel-where-is-src-block-head)) - (car (org-babel-parse-src-block-match))))))) + (let ((element (save-match-data (org-element-at-point)))) + (and (eq (org-element-type element) 'src-block) + (>= (line-beginning-position) + (org-element-property :post-affiliated element)) + (<= + (line-end-position) + (org-with-wide-buffer + (goto-char (org-element-property :end element)) + (skip-chars-backward " \t\n") + (line-end-position))) + (org-element-property :language element)))) (defvar org-eldoc-local-functions-cache (make-hash-table :size 40 :test 'equal) "Cache of major-mode's eldoc-documentation-functions, @@ -147,7 +155,7 @@ (string= lang "golang")) (when (require 'go-eldoc nil t) (go-eldoc--documentation-function))) (t (let ((doc-fun (org-eldoc-get-mode-local-documentation-function lang))) - (when (fboundp doc-fun) (funcall doc-fun)))))))) + (when (functionp doc-fun) (funcall doc-fun)))))))) ;;;###autoload (defun org-eldoc-load () diff --git a/contrib/lisp/org-elisp-symbol.el b/contrib/lisp/org-elisp-symbol.el index cdf868b..7c98962 100644 --- a/contrib/lisp/org-elisp-symbol.el +++ b/contrib/lisp/org-elisp-symbol.el @@ -78,8 +78,9 @@ (require 'org) -(org-add-link-type "elisp-symbol" 'org-elisp-symbol-open) -(add-hook 'org-store-link-functions 'org-elisp-symbol-store-link) +(org-link-set-parameters "elisp-symbol" + :follow #'org-elisp-symbol-open + :store #'org-elisp-symbol-store-link) (defun org-elisp-symbol-open (path) "Visit the emacs-lisp elisp-symbol at PATH." diff --git a/contrib/lisp/org-eww.el b/contrib/lisp/org-eww.el deleted file mode 100644 index 20ec9d4..0000000 --- a/contrib/lisp/org-eww.el +++ /dev/null @@ -1,171 +0,0 @@ -;;; org-eww.el --- Store url and kill from Eww mode for Org - -;; Copyright (C) 2014-2016 Free Software Foundation, Inc. - -;; Author: Marco Wahl <marcowahlsoft>a<gmailcom> -;; Keywords: link, eww -;; Homepage: http://orgmode.org -;; -;; This file is not part of GNU Emacs. -;; -;; 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 of the License, 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. If not, see <http://www.gnu.org/licenses/>. - - -;;; Commentary: - -;; When this module is active `org-store-link' (often on key C-c l) in -;; a eww buffer stores a link to the current url of the eww buffer. - -;; In an eww buffer function `org-eww-copy-for-org-mode' kills either -;; a region or the whole buffer if no region is set and transforms the -;; text on the fly so that it can be pasted into an org-mode buffer -;; with hot links. - -;; C-c C-x C-w (and also C-c C-x M-w) trigger -;; `org-eww-copy-for-org-mode'. - -;; Hint: A lot of code of this module comes from module org-w3m which -;; has been written by Andy Steward based on the idea of Richard -;; Riley. Thanks! - -;; Potential: Since the code for w3m and eww is so similar one could -;; try to refactor. - - -;;; Code: -(require 'org) - - -;; Store Org-link in eww-mode buffer -(add-hook 'org-store-link-functions 'org-eww-store-link) -(defun org-eww-store-link () - "Store a link to the url of a eww buffer." - (when (eq major-mode 'eww-mode) - (org-store-link-props - :type "eww" - :link (if (< emacs-major-version 25) - eww-current-url - (eww-current-url)) - :url (url-view-url t) - :description (if (< emacs-major-version 25) - (or eww-current-title eww-current-url) - (or (plist-get eww-data :title) - (eww-current-url)))))) - - -;; Some auxiliary functions concerning links in eww buffers -(defun org-eww-goto-next-url-property-change () - "Move cursor to the start of next link if exists. Else no -move. Return point." - (goto-char - (or (next-single-property-change (point) 'shr-url) - (point)))) - -(defun org-eww-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 - (and (eq (point) (org-eww-goto-next-url-property-change)) t))) - -(defun org-eww-url-below-point () - "Return the url below point if there is an url; otherwise, return nil." - (get-text-property (point) 'shr-url)) - - -(defun org-eww-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. - -Further lines starting with a star get quoted with a comma to keep -the structure of the org file." - (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-eww-no-next-link-p))) ; there is a next link - ;; store current point before jump next anchor - (setq temp-position (point)) - ;; move to next anchor when current point is not at anchor - (or (org-eww-url-below-point) - (org-eww-goto-next-url-property-change)) - (assert (org-eww-url-below-point) t - "program logic error: point must have an url below but it hasn't") - (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 (org-eww-url-below-point)) - ;; get link title at current point. - (setq link-title - (buffer-substring - (point) - (org-eww-goto-next-url-property-change))) - ;; 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)))) - ;; quote lines starting with * - (org-kill-new - (with-temp-buffer - (insert return-content) - (goto-char 0) - (replace-regexp "^\*" ",*") - (buffer-string))) - (message "Transforming links...done, use C-y to insert text into Org-mode file")))) - - -;; Additional keys for eww-mode - -(defun org-eww-extend-eww-keymap () - (define-key eww-mode-map "\C-c\C-x\M-w" 'org-eww-copy-for-org-mode) - (define-key eww-mode-map "\C-c\C-x\C-w" 'org-eww-copy-for-org-mode)) - -(when (and (boundp 'eww-mode-map) - (keymapp eww-mode-map)) ; eww is already up. - (org-eww-extend-eww-keymap)) - -(add-hook - 'eww-mode-hook - (lambda () (org-eww-extend-eww-keymap))) - - -(provide 'org-eww) - -;;; org-eww.el ends here diff --git a/contrib/lisp/org-expiry.el b/contrib/lisp/org-expiry.el index 396f016..45f59a2 100644 --- a/contrib/lisp/org-expiry.el +++ b/contrib/lisp/org-expiry.el @@ -186,7 +186,7 @@ restart `org-mode' if necessary." ;; need this to refresh org-mode hooks (when (eq major-mode 'org-mode) (org-mode) - (if (org-called-interactively-p) + (if (called-interactively-p 'any) (message "Org-expiry insinuated, `org-mode' restarted."))))) (defun org-expiry-deinsinuate (&optional arg) @@ -207,7 +207,7 @@ and restart `org-mode' if necessary." ;; need this to refresh org-mode hooks (when (eq major-mode 'org-mode) (org-mode) - (if (org-called-interactively-p) + (if (called-interactively-p 'any) (message "Org-expiry de-insinuated, `org-mode' restarted."))))) ;;; org-expiry-expired-p: @@ -239,7 +239,7 @@ If FORCE is non-nil, don't require confirmation from the user. Otherwise rely on `org-expiry-confirm-flag' to decide." (interactive "P") (save-excursion - (when (org-called-interactively-p) (org-reveal)) + (when (called-interactively-p) (org-reveal)) (when (org-expiry-expired-p) (org-back-to-heading) (looking-at org-complex-heading-regexp) @@ -253,7 +253,7 @@ Otherwise rely on `org-expiry-confirm-flag' to decide." (not (interactive))) (and org-expiry-confirm-flag (y-or-n-p (format "Entry expired by %d days. Process? " d)))) - (funcall 'org-expiry-handler-function)) + (funcall org-expiry-handler-function)) (delete-overlay ov))))) (defun org-expiry-process-entries (beg end) @@ -271,7 +271,7 @@ The expiry process will run the function defined by (while (and (outline-next-heading) (< (point) end)) (when (org-expiry-expired-p) (setq expired (1+ expired)) - (if (if (org-called-interactively-p) + (if (if (called-interactively-p 'any) (call-interactively 'org-expiry-process-entry) (org-expiry-process-entry)) (setq processed (1+ processed))))) @@ -339,7 +339,7 @@ and insert today's date." (save-excursion (if (org-expiry-expired-p) (org-archive-subtree) - (if (org-called-interactively-p) + (if (called-interactively-p 'any) (message "Entry at point is not expired."))))) (defun org-expiry-add-keyword (&optional keyword) @@ -350,7 +350,7 @@ and insert today's date." (save-excursion (if (org-expiry-expired-p) (org-todo keyword) - (if (org-called-interactively-p) + (if (called-interactively-p 'any) (message "Entry at point is not expired.")))) (error "\"%s\" is not a to-do keyword in this buffer" keyword))) diff --git a/contrib/lisp/org-git-link.el b/contrib/lisp/org-git-link.el index ad0ce71..9d3ff32 100644 --- a/contrib/lisp/org-git-link.el +++ b/contrib/lisp/org-git-link.el @@ -69,7 +69,7 @@ ;; org link functions ;; bare git link -(org-add-link-type "gitbare" 'org-gitbare-open) +(org-link-set-parameters "gitbare" :follow #'org-gitbare-open) (defun org-gitbare-open (str) (let* ((strlist (org-git-split-string str)) @@ -92,7 +92,7 @@ (setq buffer-read-only t))) ;; user friendly link -(org-add-link-type "git" 'org-git-open) +(org-link-set-parameters "git" :follow #'org-git-open :store #'org-git-store-link) (defun org-git-open (str) (let* ((strlist (org-git-split-string str)) @@ -135,10 +135,8 @@ (eval-and-compile - (if (featurep 'xemacs) - (defalias 'org-git-gitrepos-p 'org-git-find-gitdir) - (defalias 'org-git-gitrepos-p 'org-git-find-gitdir - "Return non-nil if path is in git repository"))) + (defalias 'org-git-gitrepos-p 'org-git-find-gitdir + "Return non-nil if path is in git repository")) ;; splitting the link string @@ -192,8 +190,6 @@ than two double colons, str2 and/or str3 may be set the empty string." :type "git" :link (org-git-create-git-link file line)))))) -(add-hook 'org-store-link-functions 'org-git-store-link) - (defun org-git-insert-link-interactively (file searchstring &optional description) (interactive "FFile: \nsSearch string: \nsDescription: ") (insert (org-make-link-string (concat "git:" file "::" searchstring) description))) diff --git a/contrib/lisp/org-index.el b/contrib/lisp/org-index.el index aee0bac..31b675e 100644 --- a/contrib/lisp/org-index.el +++ b/contrib/lisp/org-index.el @@ -1,9 +1,9 @@ -;;; org-index.el --- A personal index for org and beyond +;;; org-index.el --- A personal adaptive index for org ;; Copyright (C) 2011-2016 Free Software Foundation, Inc. ;; Author: Marc Ihm <org-index@2484.de> -;; Version: 4.2.1 +;; Version: 5.1.3 ;; Keywords: outlines index ;; This file is not part of GNU Emacs. @@ -27,88 +27,113 @@ ;; Purpose: ;; -;; Fast search for selected org headings and things outside of org. +;; Fast search for selected org nodes and things outside of org. ;; -;; This package creates and updates an index table of headings or -;; keywords, references and ids, where each line points to a heading -;; within org or references something outside. This table is sorted by -;; usage count, so that frequently used lines appear among the first -;; search results. +;; org-index creates and updates an index table with keywords; each line +;; either points to a heading in org, references something outside or +;; carries a snippet of text to yank. When searching the index, the set +;; of matching lines is updated with every keystroke; results are sorted +;; by usage count and date, so that frequently used entries appear first +;; in the list of results. ;; -;; References are essentially small numbers (e.g. 'R237' or '--455--'), as -;; created by this package; they are well suited to be used outside of -;; org, e.g. in folder names, issue trackers or on printed documents. +;; References are decorated numbers (e.g. 'R237' or '--455--'); they are +;; well suited to be used outside of org, e.g. in folder names, ticket +;; systems or on printed documents. ;; -;; On first invocation org-index will guide you to create a dedicated node -;; for its index table and its configuration flags. +;; On first invocation org-index will assist you in creating the index +;; table. ;; -;; For basic usage, subcommands 'add' and 'occur' are most important. +;; To start using your index, invoke subcommands 'add', 'ref' and 'yank' +;; to create entries and 'occur' to find them. ;; ;; ;; Setup: ;; +;; - Place this file in a directory from your load-path, +;; e.g. org-mode/contrib/lisp. +;; ;; - Add these lines to your .emacs: ;; ;; (require 'org-index) -;; (org-index-default-keybindings) ; optional +;; (global-set-key (kbd "C-c i") 'org-index-dispatch) ; this is optional ;; ;; - Restart your Emacs to make these lines effective. ;; -;; - Invoke `org-index', which will assist in creating your index -;; table. The variable org-index-id will be persisted within your -;; customization file (typically .emacs). +;; - Invoke `org-index'; on first run it will assist in creating your +;; index table. +;; +;; - Optionally invoke `M-x org-customize' to tune some settings (choose +;; group org-index). +;; ;; +;; Further information: ;; -;; Further reading: +;; - Watch the screencast at http://2484.de/org-index.html. ;; -;; See the documentation of `org-index', which can also be read -;; by invoking `org-index' and choosing the help-command. +;; - See the documentation of `org-index', which can also be read by +;; invoking `org-index' and choosing the command help or '?'. ;; ;; ;; Updates: ;; -;; The latest tested version of this file can always be found at: +;; The latest published version of this file can always be found at: +;; +;; http://orgmode.org/w/?p=org-mode.git;a=blob_plain;f=contrib/lisp/org-index.el;hb=HEAD +;; +;; Development version under: ;; -;; http://orgmode.org/cgit.cgi/org-mode.git/plain/contrib/lisp/org-index.el +;; https://github.com/marcIhm/org-index ;;; Change Log: +;; [2016-08-26 Fr] Version 5.1.3 +;; - Offering help during query for subcommands +;; - Removed org-index-default-keybindings +;; - Renamed subcommand multi-occur to find-ref +;; - Subcommands add and need no longer be invoked from heading +;; - Many Bugfixes +;; +;; [2015-12-29 Tu] Version 5.0.2 +;; - New commands yank, column and edit +;; - New column tags +;; - All columns are now required +;; - References are now optional +;; - Subcommand enter has been renamed to index +;; - Subcommands kill and edit can be invoked from an occur buffer +;; - Many Bugfixes +;; - Added link to screencast +;; +;; [2015-08-20 Th] Version 4.3.0 +;; - Configuration is done now via standard customize +;; - New sorting strategy 'mixed' +;; - Silenced some compiler warnings +;; ;; [2015-03-18 We] Version 4.2.1 ;; - No garbage in kill-ring ;; - No recentering after add ;; ;; [2015-03-08 Su] Version 4.2.0 ;; - Reference numbers for subcommands can be passed as a prefix argument -;; - Renamed subcommand 'point' to 'ping' ;; - New variable org-index-default-keybindings-list with a list of ;; default keybindings for org-index-default-keybindings ;; - Added new column level ;; - removed flags get-category-on-add and get-heading-on-add ;; -;; [2015-03-05 Th] Version 4.1.1 and 4.1.2 -;; - org-mark-ring is now used more consistently -;; - Bugfix when going to a heading by ref -;; -;; [2015-02-26 Th] Version 4.0.0 and 4.1.0: +;; [2015-02-26 Th] to [2015-03-05 Th] Version 4.0.0 to 4.1.2 ;; - Removed command "leave"; rather go back with org-mark-ring-goto -;; - Property "org-index-ref" is no longer used or needed ;; - Renamed column "link" to "id" ;; - Added maintainance options to find duplicate rows, to check ids, ;; update index or remove property org-index-ref from nodes -;; - New command point ;; - Shortened versin history ;; -;; [2014-12-07 Sa] to [2015-01-31 Sa] Version 3.0.0 to 3.2.0: +;; [2014-12-08 Mo] to [2015-01-31 Sa] Version 3.0.0 to 3.2.0: ;; - Complete sorting of index only occurs in idle-timer ;; - New command "maintain" with some subcommands ;; - Rewrote command "occur" with overlays in an indirect buffer -;; - introduced variable org-index-version ;; - Command "add" updates index, if node is already present ;; - New commands "add" and "delete" to easily add and remove ;; the current node to or from your index. ;; - New command "example" to create an example index. -;; - Moved flags to a list within the same node as the index table; -;; this breaks compatibility to prior versions of the package. ;; - Several new flags that are explained within index node. ;; - Removed commands "reuse", "missing", "put", "goto", ;; "update", "link", "fill", "unhighlight" @@ -139,97 +164,150 @@ ;;; Code: (require 'org-table) -(require 'cl) +(require 'cl-lib) +(require 'widget) + +;; Version of this package +(defvar org-index-version "5.1.3" "Version of `org-index', format is major.minor.bugfix, where \"major\" are incompatible changes and \"minor\" are new features.") + +;; customizable options +(defgroup org-index nil + "Options concerning the optional index for org." + :tag "Org Index" + :group 'org) (defcustom org-index-id nil "Id of the Org-mode node, which contains the index table." - :group 'org :group 'org-index) -;; Version of this package -(defvar org-index-version "4.2.1" "Version of `org-index', format is major.minor.bugfix, where \"major\" is a change in index-table and \"minor\" are new features.") +(defcustom org-index-sort-by 'mixed + "Strategy for sorting index table (and whence entries in occur). +Valid values are: + +last-access Sort index by date and time of last access; show + more recent entries first. +count Sort by usage count; more often used entries first. +mixed First, show all index entries, which have been + used today; sort them by last access. Then show + older entries sorted by usage count." + :group 'org-index + :set (lambda (s v) + (set-default s v) + (if (and org-index-id + org-index--buffer + (functionp 'org-index--sort-silent)) + (org-index--sort-silent))) + :initialize 'custom-initialize-default + :type '(choice + (const last-accessed) + (const count) + (const mixed))) + +(defcustom org-index-yank-after-add 'ref + "Specifies which column should be yanked after adding a new index row. +Valid values are some columns of index table." + :group 'org-index + :type '(choice + (const ref) + (const category) + (const keywords))) + +(defcustom org-index-point-on-add 'keywords + "Specifies in which column point will land when adding a new index row. +Valid values are some columns of index table." + :group 'org-index + :type '(choice + (const category) + (const keywords))) + +(defcustom org-index-copy-heading-to-keywords t + "When adding a new node to index: Copy heading to keywords-column ?" + :group 'org-index + :type '(choice (const :tag "Yes" t) + (const :tag "No" nil))) + +(defcustom org-index-strip-ref-and-date-from-heading t + "When adding a node to index: strip leading ref or timestamps ? + +This can be useful, if you have the habit of adding refs and +dates to the start of your headings; then, if you change your +heading and want to update your index, you do not need to remove +those pieces." + :group 'org-index + :type '(choice (const :tag "Yes" t) + (const :tag "No" nil))) + +(defcustom org-index-edit-on-add '(category keywords) + "List of columns to edit when adding a new row." + :group 'org-index + :type '(repeat (choice + (const category) + (const keywords)))) + +(defcustom org-index-edit-on-yank '(yank keywords) + "List of columns to edit when adding new text to yank." + :group 'org-index + :type '(repeat (choice + (const yank) + (const category) + (const keywords)))) + +(defcustom org-index-edit-on-ref '(category keywords) + "List of columns to edit when adding new ref." + :group 'org-index + :type '(repeat (choice + (const category) + (const keywords)))) ;; Variables to hold the configuration of the index table -(defvar org-index--maxref nil "Maximum number from reference table (e.g. '153').") -(defvar org-index--head nil "Any header before number (e.g. 'R').") +(defvar org-index--maxrefnum nil "Maximum number from reference table, e.g. 153.") +(defvar org-index--nextref nil "Next reference, that can be used, e.g. 'R154'.") +(defvar org-index--head nil "Header before number (e.g. 'R').") (defvar org-index--tail nil "Tail after number (e.g. '}' or ')'.") (defvar org-index--numcols nil "Number of columns in index table.") (defvar org-index--ref-regex nil "Regular expression to match a reference.") (defvar org-index--ref-format nil "Format, that can print a reference.") (defvar org-index--columns nil "Columns of index-table.") -(defvar org-index--special-columns nil "Columns with flags, that may appear only once.") -(defvar org-index--flagged-columns nil "Columns with flags, that may appear multiple times.") (defvar org-index--buffer nil "Buffer of index table.") (defvar org-index--point nil "Position at start of headline of index table.") (defvar org-index--below-hline nil "Position of first cell in first line below hline.") +(defvar org-index--saved-positions nil "Saved positions within current buffer and index buffer; filled by ‘org-index--save-positions’.") (defvar org-index--headings nil "Headlines of index-table as a string.") (defvar org-index--headings-visible nil "Visible part of headlines of index-table as a string.") -(defvar org-index--keymap nil "Keymap for shortcuts for some commands of `org-index'. Filled and activated by `org-index-default-keybings'.") ;; Variables to hold context and state -(defvar org-index--last-ref nil "Last reference created or visited.") +(defvar org-index--last-fingerprint nil "Fingerprint of last line created.") (defvar org-index--category-before nil "Category of node before.") (defvar org-index--active-region nil "Active region, initially. I.e. what has been marked.") (defvar org-index--below-cursor nil "Word below cursor.") -(defvar org-index--within-node nil "True, if we are within node of the index table.") +(defvar org-index--within-index-node nil "True, if we are within node of the index table.") +(defvar org-index--within-occur nil "True, if we are within the occur-buffer.") (defvar org-index--message-text nil "Text that was issued as an explanation; helpful for regression tests.") (defvar org-index--occur-help-text nil "Text for help in occur buffer.") (defvar org-index--occur-help-overlay nil "Overlay for help in occur buffer.") (defvar org-index--occur-stack nil "Stack with overlays for hiding lines.") (defvar org-index--occur-tail-overlay nil "Overlay to cover invisible lines.") +(defvar org-index--occur-lines-collected 0 "Number of lines collected in occur buffer; helpful for tests.") (defvar org-index--last-sort nil "Last column, the index has been sorted after.") (defvar org-index--sort-timer nil "Timer to sort index in correct order.") (defvar org-index--aligned nil "Remember for this Emacs session, if table has been aligned at least once.") +(defvar org-index--edit-widgets nil "List of widgets used to edit.") +(defvar org-index--context-index nil "Position and line used for index in edit buffer.") +(defvar org-index--context-occur nil "Position and line used for occur in edit buffer.") +(defvar org-index--context-node nil "Buffer and position for node in edit buffer.") +(defvar org-index--short-help-buffer-name "*org-index commands*" "Name of buffer to display short help.") +(defvar org-index--display-short-help nil "True, if short help should be displayed.") +(defvar org-index--short-help-displayed nil "True, if short help message has been displayed.") +(defvar org-index--minibuffer-saved-key nil "Temporarily save entry of minibuffer keymap.") ;; static information for this program package -(defconst org-index--commands '(occur add delete head ping enter ref help example sort multi-occur highlight maintain) "List of commands available.") -(defconst org-index--required-flags '(sort) "Flags that are required.") -(defconst org-index--single-flags '(sort point-on-add yank-after-add shift-ref-and-date-on-add) "Flags, that may only appear once; these can appear as special-columns.") -(defconst org-index--multiple-flags '(edit-on-add) "Flags, that might appear multiple times.") -(defconst org-index--all-flags (append org-index--single-flags org-index--multiple-flags) "All flags.") -(defconst org-index--required-headings '(ref id created last-accessed count) "All required headings.") -(defconst org-index--valid-headings (append org-index--required-headings '(keywords category level)) "All valid headings.") +(defconst org-index--commands '(occur add kill head ping index ref yank column edit help short-help example sort find-ref highlight maintain) "List of commands available.") +(defconst org-index--valid-headings '(ref id created last-accessed count keywords category level yank tags) "All valid headings.") (defconst org-index--occur-buffer-name "*org-index-occur*" "Name of occur buffer.") +(defconst org-index--edit-buffer-name "*org-index-edit*" "Name of edit buffer.") (defconst org-index--sort-idle-delay 300 "Delay in seconds after which buffer will sorted.") -(defvar org-index-default-keybindings-list '(("a" . 'add) ("i " . nil) ("o" . 'occur) ("a" . 'add) ("d" . 'delete) ("h" . 'head) ("e" . 'enter) ("p." . 'ping) ("r" . 'ref) ("?" . 'help)) "One-letter short cuts for selected subcommands of `org-index', put in effect by `org-index-default-keybindings'") -(defconst org-index--sample-flags -" - - columns-and-flags :: associate columns of index table with flags. Do not remove. - - ref - - yank-after-add - - category - - edit-on-add - - keywords - - edit-on-add - - point-on-add - - count - - sort - - last-accessed - - created - - id - - all-columns-explained :: All columns of the index table and their meaning. - - ref :: The reference number; will be generated automatically. - - id :: id of the node, that this line represents - - created :: When has this entry been created ? - - last-accessed :: When has this entry been accessed last ? - - count :: How many times has this entry been picked ? - - keywords :: Optional column, suggested to keep a list of keywords, - which may match your input during occur. While adding a line to your index, - this column will be filled with the nodes heading. - - category :: (optional) column to store the category of newly added nodes. - - level :: Nesting level of node - - Any name starting with a dot (`.') :: No predefined meaning, - depends on its flags. - - all-flags-explained :: All flags, that can be associated with columns. - - sort :: Sort whole table according to this column. - - yank-after-add :: This column will be yanked after picking this line during - occur. - - edit-on-add :: This field will be presented for editing, when adding - a new line to your index. - - point-on-add :: Point will land here, when adding a new line, e.g. with - command ref. - - shift-ref-and-date-on-add :: Remove leading reference and timestamp on add." -"A sample string of flags.") +(defvar org-index--short-help-text nil "Cache for result of `org-index--get-short-help-text.") +(defvar org-index--shortcut-chars nil "Cache for result of `org-index--get-shortcut-chars.") (defmacro org-index--on (column value &rest body) @@ -241,511 +319,559 @@ if VALUE cannot be found." (foundvar (make-symbol "found")) (retvar (make-symbol "ret"))) `(save-current-buffer - (set-buffer org-index--buffer) - (setq ,pointvar (point)) - (setq ,foundvar nil) - (setq ,retvar nil) + (let ((,pointvar (point)) + ,foundvar + ,retvar) + + (set-buffer org-index--buffer) + + (setq ,foundvar (org-index--go ,column ,value)) + (when ,foundvar + (setq ,retvar (progn ,@body))) + + (goto-char ,pointvar) - (setq ,foundvar (org-index--go ,column ,value)) - (when ,foundvar - (setq ,retvar (progn ,@body))) - - (goto-char ,pointvar) - - ,retvar))) + ,retvar)))) (defun org-index (&optional command search-ref arg) - "Fast search for selected org headings and things outside of org. + "Fast search-index for selected org nodes and things outside of org. -This package creates and updates an index table of headings or -keywords, references and ids, where each line points to a heading -within org or references something outside. This table is sorted by -usage count, so that frequently used lines appear among the first -search results. +org-index creates and updates an index table with keywords; each line +either points to a heading in org, references something outside or +carries a snippet of text to yank. The index table is searched for +keywords through an incremental occur; results are sorted by usage +count and date, so that frequently used entries appear first among +the results. -References are essentially small numbers (e.g. 'R237' or '--455--'), as -created by this package; they are well suited to be used outside of -org, e.g. in folder names, issue trackers or on printed documents. +References are decorated numbers (e.g. 'R237' or '--455--'); they are +well suited to be used outside of org, e.g. in folder names, ticket +systems or on printed documents. -On first invocation `org-index' will guide you to create a dedicated node -for its index table and its configuration flags. +On first invocation org-index will help to create a dedicated node +for its index table. -For basic usage, subcommands 'add' and 'occur' are most important. +To start building up your index, use subcommands 'add', 'ref' and +'yank' to create entries and use 'occur' to find them. -This is version 4.2.1 of org-index.el. -\\<org-mode-map> -The function `org-index' operates on a dedicated table, the index -table, which lives within its own Org-mode node. The table and -its containing node will be created, when you first invoke -`org-index'. The node also contains a commented list, describing -the columns of the index table and their associated flags. The -node is found through its id, which is stored within the variable -`org-index-id'. +This is version 5.1.3 of org-index.el. The function `org-index' is the only interactive function of this package and its main entry point; it will present you with a list of subcommands to choose from: - occur: Incremental search, that shows matching lines from the - index table. It is updated after every keystroke. You may - enter a list of words seperated by space or comma (`,'), to - select lines that contain all of the given words. +\(Note the one-letter shortcuts, e.g. [o]; used like 'C-c i o'.) - add: Add the current node to your index, so that it can be - found through the subcommand \"occur\". Update index, - if node has already been present. + occur: [o] Incrementally show matching lines from index. + Result is updated after every keystroke. You may enter a + list of words seperated by space or comma (`,'), to select + lines that contain all of the given words. - delete: Delete the current node from your index. + add: [a] Add the current node to index. + So that (e.g.) it can be found through the subcommand + 'occur'. Update index, if node is already present. - head: Ask for a reference number and search for this heading. + kill: [k] Kill (delete) the current node from index. + Can be invoked from index, from occur or from a headline. - enter: Enter index table and maybe go to a specific reference; - use `org-mark-ring-goto' (\\[org-mark-ring-goto]) to go back. + head: [h] Search for heading, by ref or from index line. + If invoked from within index table, go to associated + node (if any), otherwise ask for ref to search. - ping: Echo line from index table for current node or first of - its ancestor from index. + index: [i] Enter index table and maybe go to a specific reference. + Use `org-mark-ring-goto' (\\[org-mark-ring-goto]) to go back. - ref: Create a new reference. + ping: [p] Echo line from index table for current node. + If current node is not in index, than search among its + parents. - help: Show this text. + ref: [r] Create a new index line with a reference. + This line will not be associated with a node. - example: Create a temporary index, that will not be saved, but - may serve as an example. + yank: [y] Store a new string, that can be yanked from occur. + The index line will not be associated with a node. - sort: Sort lines in index, in region or buffer by contained - reference, or sort index by count, reference or last access. + column: [c] From within index table: read char and jump to column. + Shortcut for column movement; stays within one index line. - multi-occur: Apply Emacs standard `multi-occur' operation on all - `org-mode' buffers to search for the given reference. + edit: [e] Present current line in edit buffer. + Can be invoked from index, from occur or from a headline. - highlight: Highlight or unhiglight references in active region or buffer. - Call with prefix argument (`C-u') to remove highlights. + help: Show complete help text of org-index. - maintain: Offers some choices to check, update or fix your index. + short-help: [?] Show one-line description of each subcommand. + I.e. show this list but only first sentence each. + + example: Create an example index, that will not be saved. + May serve as an example. + + sort: Sort lines in index, in region or buffer. + Region or buffer can be sorted by contained reference; Index + by count, reference or last access. + + find-ref: Search for given reference in all org-buffers. + A wrapper to employ emacs standard `multi-occur' function; + asks for reference. + + highlight: Highlight or unhighlight all references. + Operates on active region or whole buffer. Call with prefix + argument (`C-u') to remove highlights. + + maintain: Index maintainance. + Offers some choices to check, update or fix your index. If you invoke `org-index' for the first time, an assistant will be -invoked, that helps you to create your own, commented index. +invoked, that helps you to create your own index. -Use `org-index-default-keybindings' to establish convenient -keyboard shortcuts. +Invoke `org-customize' to tweak the behaviour of org-index. -See the commented list of flags within your index node for ways to -modify the behaviour of org-index. +Optionally bind `org-index-dispatch' to a key, e.g. 'C-c i' in +the global keymap to invoke the most important subcommands with +a single key. A numeric prefix argument is used as a reference number for commands, that need one (e.g. 'head'). -Optional arguments for use from elisp: COMMAND is a symbol naming -the command to execute. SEARCH-REF specifies a reference to -search for, if needed. ARG allows passing in a prefix argument -as in interactive calls." +Use from elisp: Optional argument COMMAND is a symbol naming the +command to execute. SEARCH-REF specifies a reference to search +for, if needed. ARG allows passing in a prefix argument as in +interactive calls." (interactive "i\ni\nP") (let (search-id ; id to search for + search-fingerprint ; fingerprint to search for sort-what ; sort what ? kill-new-text ; text that will be appended to kill ring message-text) ; text that will be issued as an explanation + (catch 'new-index - ;; - ;; Initialize and parse - ;; + ;; + ;; Initialize and parse + ;; - ;; creates index table, if necessary - (org-index--verify-id) + ;; creates index table, if necessary + (org-index--verify-id) - ;; Get configuration of index table - (org-index--parse-table) + ;; Get configuration of index table + (org-index--parse-table) - ;; store context information - (org-index--retrieve-context) - - - ;; - ;; Arrange for proper sorting of index - ;; - - ;; lets assume, that it has been sorted this way (we try hard to make sure) - (unless org-index--last-sort (setq org-index--last-sort (org-index--special-column 'sort))) - ;; rearrange for index beeing sorted into default sort order after 300 secs of idle time - (unless org-index--sort-timer - (setq org-index--sort-timer - (run-with-idle-timer org-index--sort-idle-delay t 'org-index--sort-silent))) - - - ;; - ;; Find out, what we are supposed to do - ;; - - ;; check or read command - (if command - (unless (memq command org-index--commands) - (error "Unknown command '%s' passed as argument, valid choices are any of these symbols: %s" - command (mapconcat 'symbol-name org-index--commands ","))) - (setq command (intern (org-completing-read - "Please choose: " - (mapcar 'symbol-name org-index--commands))))) - - - ;; - ;; Get search string, if required; process possible sources one after - ;; another (lisp argument, prefix argumen, user input). - ;; - - ;; Try prefix, if no lisp argument given - (if (and (not search-ref) - (numberp arg)) - (setq search-ref (format "%s%d%s" org-index--head arg org-index--tail))) - - ;; These actions really need a search string and may even prompt for it - (when (memq command '(enter head multi-occur)) - - ;; search from surrounding text ? - (unless search-ref - (if org-index--within-node - - (if (org-at-table-p) - (setq search-ref (org-index--get-or-set-field 'ref))) - - (if (and org-index--below-cursor - (string-match (concat "\\(" org-index--ref-regex "\\)") - org-index--below-cursor)) - (setq search-ref (match-string 1 org-index--below-cursor))))) - - ;; If we still do not have a search string, ask user explicitly - (unless search-ref - (if (eq command 'enter) - (let ((r (org-index--read-search-for-enter))) - (setq search-ref (car r)) - (setq search-id (cdr r))) - (setq search-ref (read-from-minibuffer "Search reference number: ")))) - - ;; Clean up search string - (when search-ref - (setq search-ref (org-trim search-ref)) - (if (string-match "^[0-9]+$" search-ref) - (setq search-ref (concat org-index--head search-ref org-index--tail))) - (if (string= search-ref "") (setq search-ref nil))) + ;; store context information + (org-index--retrieve-context) - (if (and (not search-ref) - (not (eq command 'enter))) - (error "Command %s needs a reference number" command))) - - - ;; - ;; Command sort needs to know in advance, what to sort for - ;; - - (when (eq command 'sort) - (setq sort-what (intern (org-completing-read "You may sort:\n - index : your index table by various columns\n - region : the active region by contained reference\n - buffer : the whole current buffer\nPlease choose what to sort: " (list "index" "region" "buffer") nil t)))) - - - ;; - ;; Enter table - ;; - - ;; Arrange for beeing able to return - (when (and (memq command '(occur head enter ref example sort maintain)) - (not (string= (buffer-name) org-index--occur-buffer-name))) - (org-mark-ring-push)) - - ;; These commands will leave user in index table after they are finished - (when (or (memq command '(enter ref maintain)) - (and (eq command 'sort) - (eq sort-what 'index))) - (pop-to-buffer-same-window org-index--buffer) - (goto-char org-index--point) - (org-index--unfold-buffer)) + ;; + ;; Arrange for proper sorting of index + ;; + ;; lets assume, that it has been sorted this way (we try hard to make sure) + (unless org-index--last-sort (setq org-index--last-sort org-index-sort-by)) + ;; rearrange for index beeing sorted into default sort order after 300 secs of idle time + (unless org-index--sort-timer + (setq org-index--sort-timer + (run-with-idle-timer org-index--sort-idle-delay t 'org-index--sort-silent))) - ;; - ;; Actually do, what is requested - ;; - (cond + ;; + ;; Find out, what we are supposed to do + ;; + ;; Check or read command + (if (and command (not (eq command 'short-help))) + (unless (memq command org-index--commands) + (error "Unknown command '%s' passed as argument, valid choices are any of these symbols: %s" + command (mapconcat 'symbol-name org-index--commands ","))) - ((eq command 'help) + ;; read command; if requested display help in read-loop + (setq org-index--display-short-help (eq command 'short-help)) + (setq command (org-index--read-command)) + (setq org-index--display-short-help nil)) - ;; bring up help-buffer for this function - (describe-function 'org-index)) + ;; + ;; Get search string, if required; process possible sources one after + ;; another (lisp argument, prefix argument, user input). + ;; + + ;; Try prefix, if no lisp argument given + (if (and (not search-ref) + (numberp arg)) + (setq search-ref (format "%s%d%s" org-index--head arg org-index--tail))) + + ;; These actions really need a search string and may even prompt for it + (when (memq command '(index head find-ref)) + + ;; search from surrounding text ? + (unless search-ref + (if org-index--within-index-node + + (if (org-at-table-p) + (setq search-ref (org-index--get-or-set-field 'ref))) + + (if (and org-index--below-cursor + (string-match (concat "\\(" org-index--ref-regex "\\)") + org-index--below-cursor)) + (setq search-ref (match-string 1 org-index--below-cursor))))) + + ;; If we still do not have a search string, ask user explicitly + (unless search-ref + (if (eq command 'index) + (let ((r (org-index--read-search-for-index))) + (setq search-ref (first r)) + (setq search-id (second r)) + (setq search-fingerprint (third r))) + (unless (and (eq command 'head) + org-index--within-index-node + (org-at-table-p)) + (setq search-ref (read-from-minibuffer "Search reference number: "))))) + + ;; Clean up search string + (when search-ref + (setq search-ref (org-trim search-ref)) + (if (string-match "^[0-9]+$" search-ref) + (setq search-ref (concat org-index--head search-ref org-index--tail))) + (if (string= search-ref "") (setq search-ref nil))) + + (if (and (not search-ref) + (not (eq command 'index)) + (not (and (eq command 'head) + org-index--within-index-node + (org-at-table-p)))) + (error "Command %s needs a reference number" command))) + + + ;; + ;; Command sort needs to know in advance, what to sort for + ;; + + (when (eq command 'sort) + (setq sort-what (intern (org-completing-read "You may sort:\n - index : your index table by various columns\n - region : the active region by contained reference\n - buffer : the whole current buffer\nPlease choose what to sort: " (list "index" "region" "buffer") nil t)))) + + + ;; + ;; Enter table + ;; + + ;; Arrange for beeing able to return + (when (and (memq command '(occur head index example sort maintain)) + (not (string= (buffer-name) org-index--occur-buffer-name))) + (org-mark-ring-push)) + + ;; These commands will leave user in index table after they are finished + (when (or (memq command '(index maintain)) + (and (eq command 'sort) + (eq sort-what 'index))) + + (pop-to-buffer-same-window org-index--buffer) + (goto-char org-index--point) + (org-index--unfold-buffer)) + + + ;; + ;; Actually do, what is requested + ;; + (cond - ((eq command 'multi-occur) + ((eq command 'help) - ;; Construct list of all org-buffers - (let (buff org-buffers) - (dolist (buff (buffer-list)) - (set-buffer buff) - (if (string= major-mode "org-mode") - (setq org-buffers (cons buff org-buffers)))) + ;; bring up help-buffer for this function + (describe-function 'org-index)) - ;; Do multi-occur - (multi-occur org-buffers (org-index--make-guarded-search search-ref)) - ;; Present results - (if (get-buffer "*Occur*") - (progn - (setq message-text (format "multi-occur for '%s'" search-ref)) - (other-window 1) - (toggle-truncate-lines 1)) - (setq message-text (format "Did not find '%s'" search-ref))))) + ((eq command 'short-help) + (org-index--display-short-help)) - ((eq command 'add) - (let ((r (org-index--do-add-or-update))) - (setq message-text (car r)) - (setq kill-new-text (cdr r)))) + ((eq command 'find-ref) + ;; Construct list of all org-buffers + (let (org-buffers) + (dolist (buff (buffer-list)) + (set-buffer buff) + (if (string= major-mode "org-mode") + (setq org-buffers (cons buff org-buffers)))) - ((eq command 'delete) + ;; Do multi-occur + (multi-occur org-buffers (org-index--make-guarded-search search-ref)) - (setq message-text (org-index--do-delete))) + ;; Present results + (if (get-buffer "*Occur*") + (progn + (setq message-text (format "Found '%s'" search-ref)) + (other-window 1) + (toggle-truncate-lines 1)) + (setq message-text (format "Did not find '%s'" search-ref))))) - ((eq command 'head) + ((eq command 'add) - (if (and org-index--within-node - (org-at-table-p)) - (setq search-id (org-index--get-or-set-field 'id))) + (let ((r (org-index--do-add-or-update (if (equal arg '(4)) t nil) + (if (numberp arg) arg nil)))) + (setq message-text (car r)) + (setq kill-new-text (cdr r)))) - (setq search-id (or search-id (org-index--id-from-ref search-ref))) - (setq message-text - (if search-id - (org-index--do-head search-ref search-id) - (message "Current line has no id.")))) + ((eq command 'kill) + (setq message-text (org-index--do-kill))) - ((eq command 'enter) - (goto-char org-index--below-hline) + ((eq command 'head) - (setq message-text + (if (and org-index--within-index-node + (org-at-table-p)) + (setq search-id (org-index--get-or-set-field 'id))) - (if search-ref - (if (org-index--go 'ref search-ref) - (progn - (org-index--update-current-line) - (org-table-goto-column (org-index--column-num 'ref)) - (format "Found index line '%s'" search-ref)) - (format "Did not find index line with reference '%s'" search-ref)) + (if (and (not search-id) search-ref) + (setq search-id (org-index--id-from-ref search-ref))) + (setq message-text (if search-id - (if (org-index--go 'id search-id) + (org-index--find-id search-id) + "Current line has no id"))) + + + ((eq command 'index) + + (goto-char org-index--below-hline) + + (setq message-text + + (if search-ref + (if (org-index--go 'ref search-ref) (progn (org-index--update-current-line) (org-table-goto-column (org-index--column-num 'ref)) - (format "Found index line '%s'" (org-index--get-or-set-field 'ref))) - (format "Did not find index line with id '%s'" search-id)) + (format "Found index line '%s'" search-ref)) + (format "Did not find index line with reference '%s'" search-ref)) - ;; simply go into table - (setq message-text "At index table")))) + (if search-id + (if (org-index--go 'id search-id) + (progn + (org-index--update-current-line) + (org-table-goto-column (org-index--column-num 'ref)) + (format "Found index line '%s'" (org-index--get-or-set-field 'ref))) + (format "Did not find index line with id '%s'" search-id)) - (recenter)) + (if search-fingerprint + (if (org-index--go 'fingerprint org-index--last-fingerprint) + (progn + (org-index--update-current-line) + (beginning-of-line) + (format "Found latest index line")) + (format "Did not find index line")) + ;; simply go into table + "At index table")))) - ((eq command 'ping) + (recenter)) - (let ((moved-up 0) id info reached-top) - (unless (string= major-mode "org-mode") (error "No node at point")) - ;; take id from current node or reference - (setq id (if search-ref - (org-index--id-from-ref search-ref) - (org-id-get))) + ((eq command 'ping) - ;; move up until we find a node in index - (save-excursion - (outline-back-to-heading) - (while (not (or info - reached-top)) - (if id - (setq info (org-index--on 'id id - (mapcar (lambda (x) (org-index--get-or-set-field x)) - (list 'ref 'count 'created 'last-accessed 'category 'keywords 'ref))))) + (let ((moved-up 0) id info reached-top) - (setq reached-top (= (org-outline-level) 1)) + (unless (string= major-mode "org-mode") (error "No node at point")) + ;; take id from current node or reference + (setq id (if search-ref + (org-index--id-from-ref search-ref) + (org-id-get))) - (unless (or info - reached-top) - (outline-up-heading 1 t) - (incf moved-up)) + ;; move up until we find a node in index + (save-excursion + (outline-back-to-heading) + (while (not (or info + reached-top)) + (if id + (setq info (org-index--on 'id id + (mapcar (lambda (x) (org-index--get-or-set-field x)) + (list 'ref 'count 'created 'last-accessed 'category 'keywords 'ref))))) - (setq id (org-id-get)))) - - (if info - (progn - (setq message-text - (apply 'format - (append (list "'%s'%shas been accessed %s times between %s and %s; category is '%s', keywords are '%s'" - (pop info) - (if (> moved-up 0) (format " (parent node, %d level up) " moved-up) " ")) - info))) - (setq kill-new-text (car (last info)))) - (setq message-text "Neither this node nor any of its parents is part of index")))) - - - ((eq command 'occur) - - (set-buffer org-index--buffer) - (org-index--do-occur)) - - - ((eq command 'ref) - - (let (new) - - ;; add a new row - (setq new (org-index--create-new-line)) - - ;; fill special columns with standard values - (org-table-goto-column (org-index--column-num 'ref)) - (insert new) - (setq org-index--last-ref new) - - ;; goto point-field or first empty one or first field - (if (org-index--special-column 'point-on-add) - (org-table-goto-column (org-index--column-num (org-index--special-column 'point-on-add))) - (unless (catch 'empty - (dotimes (col org-index--numcols) - (org-table-goto-column (+ col 1)) - (if (string= (org-trim (org-table-get-field)) "") - (throw 'empty t)))) - ;; none found, goto first - (org-table-goto-column 1))) - - (if org-index--active-region (setq kill-new-text org-index--active-region)) - (setq message-text (format "Adding a new row with ref '%s'" new)))) - - - ((eq command 'sort) - - (let ((columns (list "ref" "count" "created" "last-accessed" "id")) - sort groups-and-counts) - - (cond - ((eq sort-what 'index) - (setq sort - (intern - (org-icompleting-read - "Please choose column to sort index table: " - (append (copy-list columns) (list "group-by")) - nil t nil nil (symbol-name (org-index--special-column 'sort))))) - - (when (eq sort 'group-by) - (setq sort - (intern - (org-icompleting-read - "Please choose column to group index table by: " - columns - nil t nil nil (symbol-name (org-index--special-column 'sort))))) - (setq groups-and-counts (org-index--collect-sort-groups sort))) - - (org-index--do-sort-index sort (first groups-and-counts)) - (org-table-goto-column (org-index--column-num sort)) - ;; When saving index, it should again be sorted correctly - (with-current-buffer org-index--buffer - (add-hook 'before-save-hook 'org-index--sort-silent t)) - - (setq message-text - (format - (concat "Your index has been sorted temporarily by %s and will be sorted again by %s after %d seconds of idle time" - (if groups-and-counts - "; %d groups with equal %s and a total of %d lines have been found" - "")) - (symbol-name sort) - (org-index--special-column 'sort) - org-index--sort-idle-delay - (second groups-and-counts) - (symbol-name sort) - (third groups-and-counts)))) - - ((memq sort-what '(region buffer)) - (org-index--do-sort-lines sort-what) - (setq message-text (format "Sorted %s by contained references" sort-what)))))) - - - ((eq command 'highlight) - - (let ((where "buffer")) - (save-excursion - (save-restriction - (when (and transient-mark-mode - mark-active) - (narrow-to-region (region-beginning) (region-end)) - (setq where "region")) - - (if arg - (progn - (unhighlight-regexp org-index--ref-regex) - (setq message-text (format "Removed highlights for references in %s" where))) - (highlight-regexp org-index--ref-regex 'isearch) - (setq message-text (format "Highlighted references in %s" where))))))) + (setq reached-top (= (org-outline-level) 1)) + (unless (or info + reached-top) + (outline-up-heading 1 t) + (cl-incf moved-up)) - ((eq command 'maintain) - (setq message-text (org-index--do-maintain))) + (setq id (org-id-get)))) - - ((eq command 'example) + (if info + (progn + (setq message-text + (apply 'format + (append (list "'%s'%shas been accessed %s times between %s and %s; category is '%s', keywords are '%s'" + (pop info) + (if (> moved-up 0) (format " (parent node, %d level up) " moved-up) " ")) + info))) + (setq kill-new-text (car (last info)))) + (setq message-text "Neither this node nor any of its parents is part of index")))) - (if (y-or-n-p "This assistant will help you to create a temporary index with detailed comments.\nDo you want to proceed ? ") - (org-index--create-index t))) + ((eq command 'occur) - (t (error "Unknown subcommand '%s'" command))) + (set-buffer org-index--buffer) + (org-index--do-occur)) - ;; tell, what we have done and what can be yanked - (if kill-new-text (setq kill-new-text - (substring-no-properties kill-new-text))) - (if (string= kill-new-text "") (setq kill-new-text nil)) - (let ((m (concat - message-text - (if (and message-text kill-new-text) - " and r" - (if kill-new-text "R" "")) - (if kill-new-text (format "eady to yank '%s'." kill-new-text) (if message-text "." ""))))) - (unless (string= m "") - (message m) - (setq org-index--message-text m))) - (if kill-new-text (kill-new kill-new-text)))) + ((eq command 'ref) + (let (args) -(defun org-index-default-keybindings (&optional prefix) - "Set default keybindings for `org-index'. + (setq args (org-index--collect-values-from-user org-index-edit-on-ref)) + (setq args (plist-put args 'category "yank")) + (setq args (plist-put args 'ref org-index--nextref)) + (apply 'org-index--do-new-line args) -Invoke subcommands of org index with a single key -sequence. Establish the common prefix key 'C-c i' which should be -followed by the first letter of a subcommand. + (setq kill-new-text org-index--nextref) -The ist of letters and subcommands is specified in within -`org-index-default-keybindings-list'. - -See `org-index' for a description of all subcommands. + (setq message-text (format "Added new row with ref '%s'" org-index--nextref)))) -Optional argument PREFIX specifies common prefix, defaults to 'C-c i'" - (interactive) - (define-prefix-command 'org-index--keymap) - ;; prefix command - (global-set-key (kbd (or prefix "C-c i")) 'org-index--keymap) - ;; loop over subcommands - (mapcar - (lambda (x) - ;; loop over letters, that invoke the same subcommand - (mapcar (lambda (c) - (define-key org-index--keymap (kbd (char-to-string c)) - `(lambda (arg) (interactive "P") - (message nil) - (org-index ,(cdr x) nil arg)))) - (car x))) - org-index-default-keybindings-list)) + ((eq command 'yank) + + (let (args) + + (setq args (org-index--collect-values-from-user org-index-edit-on-yank)) + (if (plist-get args 'yank) + (plist-put args 'yank (replace-regexp-in-string "|" "\\vert" (plist-get args 'yank) nil 'literal))) + (setq args (plist-put args 'category "yank")) + (apply 'org-index--do-new-line args) + + (setq message-text "Added new row with text to yank"))) + + + ((eq command 'column) + + (if (and org-index--within-index-node + (org-at-table-p)) + (let (char col num) + (setq char (read-char "Please specify, which column to go to (r=ref, k=keywords, c=category, y=yank): ")) + (unless (memq char (list ?r ?k ?c ?y)) + (error (format "Invalid char '%c', cannot goto this column" char))) + (setq col (cdr (assoc char '((?r . ref) (?k . keywords) (?c . category) (?y . yank))))) + (setq num (org-index--column-num col)) + (if num + (progn + (org-table-goto-column num) + (setq message-text (format "At column %s" (symbol-name col)))) + + (error (format "Column '%s' is not present" col)))) + (error "Need to be in index table to go to a specific column"))) + + + ((eq command 'edit) + + (setq message-text (org-index--do-edit))) + + + ((eq command 'sort) + + (let ((sorts (list "count" "last-accessed" "mixed" "id" "ref")) + sort groups-and-counts) + + (cond + ((eq sort-what 'index) + (setq sort + (intern + (completing-read + "Please choose column to sort index table: " + (cl-copy-list sorts) + nil t nil nil (symbol-name org-index-sort-by)))) + + (org-index--do-sort-index sort) + (org-table-goto-column (org-index--column-num (if (eq sort 'mixed) 'last-access sort))) + ;; When saving index, it should again be sorted correctly + (with-current-buffer org-index--buffer + (add-hook 'before-save-hook 'org-index--sort-silent t)) + + (setq message-text + (format + (concat "Your index has been sorted temporarily by %s and will be sorted again by %s after %d seconds of idle time" + (if groups-and-counts + "; %d groups with equal %s and a total of %d lines have been found" + "")) + (symbol-name sort) + org-index-sort-by + org-index--sort-idle-delay + (second groups-and-counts) + (symbol-name sort) + (third groups-and-counts)))) + + ((memq sort-what '(region buffer)) + (org-index--do-sort-lines sort-what) + (setq message-text (format "Sorted %s by contained references" sort-what)))))) + + + ((eq command 'highlight) + + (let ((where "buffer")) + (save-excursion + (save-restriction + (when (and transient-mark-mode + mark-active) + (narrow-to-region (region-beginning) (region-end)) + (setq where "region")) + + (if arg + (progn + (unhighlight-regexp org-index--ref-regex) + (setq message-text (format "Removed highlights for references in %s" where))) + (highlight-regexp org-index--ref-regex 'isearch) + (setq message-text (format "Highlighted references in %s" where))))))) + + + ((eq command 'maintain) + (setq message-text (org-index--do-maintain))) + + + ((eq command 'example) + + (if (y-or-n-p "This assistant will help you to create a temporary index with detailed comments.\nDo you want to proceed ? ") + (org-index--create-index t))) + + + ((not command) (setq message-text "No command given")) + + + (t (error "Unknown subcommand '%s'" command))) + + + ;; tell, what we have done and what can be yanked + (if kill-new-text (setq kill-new-text + (substring-no-properties kill-new-text))) + (if (string= kill-new-text "") (setq kill-new-text nil)) + (let ((m (concat + message-text + (if (and message-text kill-new-text) + " and r" + (if kill-new-text "R" "")) + (if kill-new-text (format "eady to yank '%s'." kill-new-text) (if message-text "." ""))))) + (unless (string= m "") + (message m) + (setq org-index--message-text m))) + (if kill-new-text (kill-new kill-new-text))))) + + +(defun org-index-dispatch (&optional arg) + "Read additional chars and call subcommands of `org-index'. +Can be bound in global keyboard map as central entry point. +Optional argument ARG is passed on." + (interactive "P") + (let (char command) + (if (sit-for 1) + (message "org-index (? for detailed prompt) -")) + (setq char (key-description (read-key-sequence nil))) + (if (string= char "C-g") (keyboard-quit)) + (if (string= char "SPC") (setq char "?")) + (setq command (cdr (assoc char (org-index--get-shortcut-chars)))) + (unless command + (message "No subcommand for '%s'; switching to detailed prompt" char) + (sit-for 1) + (setq command 'short-help)) + (org-index command nil arg))) (defun org-index-new-line (&rest keys-values) @@ -762,60 +888,317 @@ Example: Optional argument KEYS-VALUES specifies content of new line." - (org-index--verify-id) - (org-index--parse-table) + (let ((ref (plist-get keys-values 'ref))) + (org-index--verify-id) + (org-index--parse-table) + (if (not (memq ref '(t nil))) + (error "Column 'ref' accepts only 't' or 'nil'")) + (when ref + (setq ref org-index--nextref) + (setq keys-values (plist-put keys-values 'ref ref))) + + (apply 'org-index--do-new-line keys-values) + ref)) + + +(defun org-index--read-command (&optional with-short-help) + "Read subcommand for ‘org-index’ from minibuffer. +Optional argument WITH-SHORT-HELP displays help screen upfront." + (let (minibuffer-scroll-window + minibuffer-setup-fun + command) + (setq org-index--short-help-displayed nil) + (add-hook 'minibuffer-setup-hook 'org-index--minibuffer-setup-function) + (add-hook 'minibuffer-exit-hook 'org-index--minibuffer-exit-function) + (unwind-protect + (setq command + (intern + (completing-read + (concat + "Please choose" + (if org-index--display-short-help "" " (? for short help)") + ": ") + (mapcar 'symbol-name org-index--commands) nil t))) + (remove-hook 'minibuffer-setup-hook 'org-index--minibuffer-setup-function) + (remove-hook 'minibuffer-exit-hook 'org-index--minibuffer-exit-function) + (when org-index--short-help-displayed + (quit-windows-on org-index--short-help-buffer-name))) + command)) + + +(defun org-index--minibuffer-setup-function () + "Prepare minibuffer for `org-index--read-command'." + (setq org-index--minibuffer-saved-key (local-key-binding (kbd "?"))) + (local-set-key (kbd "?") 'org-index--display-short-help) + (if org-index--display-short-help (org-index--display-short-help))) + + +(defun org-index--minibuffer-exit-function () + "Restore minibuffer after `org-index--read-command'." + (local-set-key (kbd "?") org-index--minibuffer-saved-key) + (setq org-index--minibuffer-saved-key nil)) + + +(defun org-index--display-short-help () + "Helper function to show help in minibuffer." + (interactive) + + (with-temp-buffer-window + org-index--short-help-buffer-name nil nil + (setq org-index--short-help-displayed t) + (princ "Short help; all subcommands of `org-index', shortcuts in []\n") + (princ (org-index--get-short-help-text))) + (with-current-buffer org-index--short-help-buffer-name + (let ((inhibit-read-only t) + height-before height-after win) + (setq win (get-buffer-window)) + (setq height-before (window-height win)) + (shrink-window-if-larger-than-buffer win) + (setq height-after (window-height win)) + (goto-char (point-min)) + (end-of-line) + (insert + (if (> height-before height-after) + "." + (concat ", " + (substitute-command-keys "\\[scroll-other-window]") + " to scroll:"))) + (goto-char (point-min))))) + + +(defun org-index--get-short-help-text () + "Extract text for short help message from long help." + (or org-index--short-help-text + (with-temp-buffer + (insert (documentation 'org-index)) + (goto-char (point-min)) + (search-forward (concat " " (symbol-name (first org-index--commands)) ": ")) + (forward-line 0) + (kill-region (point-min) (point)) + (search-forward (concat " " (symbol-name (car (last org-index--commands))) ": ")) + (forward-line 1) + (kill-region (point) (point-max)) + (keep-lines "^ [-a-z]+:" (point-min) (point-max)) + (align-regexp (point-min) (point-max) "\\(\\s-*\\):") + (goto-char (point-min)) + (while (re-search-forward "\\. *$" nil t) + (replace-match "" nil nil)) + (goto-char (point-min)) + (re-search-forward "short-help") + (end-of-line) + (insert " (this text)") + (goto-char (point-min)) + (unless (= (line-number-at-pos (point-max)) (1+ (length org-index--commands))) + (error "Internal error, unable to properly extract one-line descriptions of subcommands")) + (setq org-index--short-help-text (buffer-string))))) + + +(defun org-index--get-shortcut-chars () + "Collect shortcut chars from short help message." + (or org-index--shortcut-chars + (with-temp-buffer + (insert (org-index--get-short-help-text)) + (goto-char (point-min)) + (while (< (point) (point-max)) + (when (looking-at "^ \\([-a-z]+\\) +: +\\[\\([a-z?]\\)\\] ") + (setq org-index--shortcut-chars + (cons (cons (match-string 2) (intern (match-string 1))) + org-index--shortcut-chars))) + (forward-line 1)) + (unless (> (length org-index--shortcut-chars) 0) + (error "Internal error, did not find shortcut chars")) + org-index--shortcut-chars))) + + +(defun org-index--do-edit () + "Perform command edit." + (let ((maxlen 0) cols-vals buffer-keymap field-keymap keywords-pos val) + + (setq org-index--context-node nil) + (setq org-index--context-occur nil) + + ;; change to index, if whithin occur + (if org-index--within-occur + (let ((pos (get-text-property (point) 'org-index-lbp))) + (org-index--occur-test-stale pos) + (setq org-index--context-occur (cons (point) (org-index--line-in-canonical-form))) + (set-buffer org-index--buffer) + (goto-char pos)) + + ;; change to index, if still not within + (if (not org-index--within-index-node) + (let ((id (org-id-get))) + (setq org-index--context-node (cons (current-buffer) (point))) + (set-buffer org-index--buffer) + (unless (and id (org-index--go 'id id)) + (setq org-index--context-node nil) + (error "This node is not in index"))))) + + ;; retrieve current content of index line + (dolist (col (mapcar 'car (reverse org-index--columns))) + (if (> (length (symbol-name col)) maxlen) + (setq maxlen (length (symbol-name col)))) + (setq val (org-index--get-or-set-field col)) + (if (and val (eq col 'yank)) (setq val (replace-regexp-in-string (regexp-quote "\\vert") "|" val nil 'literal))) + (setq cols-vals (cons (cons col val) + cols-vals))) + + ;; we need two different keymaps + (setq buffer-keymap (make-sparse-keymap)) + (set-keymap-parent buffer-keymap widget-keymap) + (define-key buffer-keymap (kbd "C-c C-c") 'org-index--edit-c-c-c-c) + (define-key buffer-keymap (kbd "C-c C-k") 'org-index--edit-c-c-c-k) + + (setq field-keymap (make-sparse-keymap)) + (set-keymap-parent field-keymap widget-field-keymap) + (define-key field-keymap (kbd "C-c C-c") 'org-index--edit-c-c-c-c) + (define-key field-keymap (kbd "C-c C-k") 'org-index--edit-c-c-c-k) + + ;; prepare buffer + (setq org-index--context-index (cons (point) (org-index--line-in-canonical-form))) + (if (get-buffer org-index--edit-buffer-name) (kill-buffer org-index--edit-buffer-name)) + (switch-to-buffer (get-buffer-create org-index--edit-buffer-name)) + + ;; create and fill widgets + (setq org-index--edit-widgets nil) + (widget-insert "Edit this line from index; type C-c C-c when done, C-c C-k to abort.\n\n") + (dolist (col-val cols-vals) + (if (eq (car col-val) 'keywords) (setq keywords-pos (point))) + (setq org-index--edit-widgets (cons + (cons (car col-val) + (widget-create 'editable-field + :format (format (format "%%%ds: %%%%v" maxlen) (symbol-name (car col-val))) + :keymap field-keymap + (or (cdr col-val) ""))) + org-index--edit-widgets))) + + (widget-setup) + (goto-char keywords-pos) + (beginning-of-line) + (forward-char (+ maxlen 2)) + (use-local-map buffer-keymap) + "Editing a single line from index")) + + +(defun org-index--edit-c-c-c-c () + "Function to invoked on C-c C-c in Edit buffer." + (interactive) - (car (apply 'org-index--do-new-line keys-values))) + (let ((obuf (get-buffer org-index--occur-buffer-name)) + val line) + + ;; Time might have passed + (org-index--refresh-parse-table) + + (with-current-buffer org-index--buffer + + ;; check, if buffer has become stale + (save-excursion + (goto-char (car org-index--context-index)) + (unless (string= (cdr org-index--context-index) + (org-index--line-in-canonical-form)) + (switch-to-buffer org-index--edit-buffer-name) + (error "Index table has changed: Cannot find line, that this buffer is editing"))) + + (pop-to-buffer-same-window org-index--buffer) + (goto-char (car org-index--context-index)) + + ;; write back line to index + (dolist (col-widget org-index--edit-widgets) + (setq val (widget-value (cdr col-widget))) + (if (eq (car col-widget) 'yank) (setq val (replace-regexp-in-string "|" (regexp-quote "\\vert") val))) + (org-index--get-or-set-field (car col-widget) val)) + + (setq line (org-index--align-and-fontify-current-line)) + (beginning-of-line)) + + ;; write line to occur if appropriate + (if org-index--context-occur + (if obuf + (if (string= (cdr org-index--context-index) + (cdr org-index--context-occur)) + (progn + (pop-to-buffer-same-window obuf) + (goto-char (car org-index--context-occur)) + (beginning-of-line) + (let ((inhibit-read-only t)) + (delete-region (line-beginning-position) (line-end-position)) + (insert line) + (put-text-property (line-beginning-position) (line-end-position) + 'org-index-lbp (cdr org-index--context-index)))) + (error "Occur buffer and index buffer do not match any longer")) + (message "Occur buffer has gone, cannot switch back.")) + (setq org-index--context-occur nil)) + + ;; return to node, if invoked from there + (when org-index--context-node + (pop-to-buffer-same-window (car org-index--context-node)) + (goto-char (cdr org-index--context-node))) + + ;; clean up + (kill-buffer org-index--edit-buffer-name) + (setq org-index--context-index nil) + (setq org-index--edit-widgets nil) + (beginning-of-line) + (message "Index line has been edited."))) + + +(defun org-index--edit-c-c-c-k () + "Function invoked on C-c C-k in Edit buffer." + (interactive) + (kill-buffer org-index--edit-buffer-name) + (setq org-index--context-index nil) + (setq org-index--edit-widgets nil) + (beginning-of-line) + (message "Edit aborted.")) (defun org-index--do-new-line (&rest keys-values) "Do the work for `org-index-new-line'. Optional argument KEYS-VALUES specifies content of new line." - (save-excursion - (org-index--retrieve-context) - (with-current-buffer org-index--buffer - (goto-char org-index--point) + (org-index--retrieve-context) + (with-current-buffer org-index--buffer + (goto-char org-index--point) - ;; check arguments early; they might come from lisp-user + ;; check arguments early; they might come from userland + (let ((kvs keys-values) + k v) + (while kvs + (setq k (car kvs)) + (setq v (cadr kvs)) + (if (or (not (symbolp k)) + (and (symbolp v) (not (eq v t)) (not (eq v nil)))) + (error "Arguments must be alternation of key and value")) + (unless (org-index--column-num k) + (error "Unknown column or column not defined in table: '%s'" (symbol-name k))) + (setq kvs (cddr kvs)))) + + (let (yank) + ;; create new line + (org-index--create-new-line) + + ;; fill columns (let ((kvs keys-values) k v) (while kvs (setq k (car kvs)) (setq v (cadr kvs)) - (if (eq k 'ref) - (unless (memq v '(t nil)) - (error "Column 'ref' accepts only \"t\" or \"nil\"")) - (if (or (not (symbolp k)) - (and (symbolp v) (not (eq v t)) (not (eq v nil)))) - (error "Arguments must be alternation of key and value"))) - (unless (org-index--column-num k) - (error "Unknown column or column not defined in table: '%s'" (symbol-name k))) + (org-table-goto-column (org-index--column-num k)) + (insert (org-trim (or v ""))) (setq kvs (cddr kvs)))) - (let (ref yank) - ;; create new line - (setq ref (org-index--create-new-line)) - (plist-put keys-values 'ref ref) + ;; align and fontify line + (org-index--promote-current-line) + (org-index--align-and-fontify-current-line) - ;; fill columns - (let ((kvs keys-values) - k v n) - (while kvs - (setq k (car kvs)) - (setq v (cadr kvs)) - (org-table-goto-column (org-index--column-num k)) - (insert (org-trim v)) - (setq kvs (cddr kvs)))) + ;; remember fingerprint to be able to return + (setq org-index--last-fingerprint (org-index--get-or-set-field 'fingerprint)) - ;; align and fontify line - (org-index--promote-current-line) - (org-index--align-and-fontify-current-line) - - ;; get column to yank - (setq yank (org-index--get-or-set-field (org-index--special-column 'yank-after-add))) + ;; get column to yank + (setq yank (org-index--get-or-set-field org-index-yank-after-add)) - (cons ref yank))))) + yank))) (defun org-index-get-line (column value) @@ -839,7 +1222,7 @@ argument VALUE specifies the value to search for." (unless value (error "Need a value to search for")) - + (org-index--verify-id) (org-index--parse-table) @@ -860,18 +1243,6 @@ Argument COLUMN and VALUE specify line to get." content)) -(defun org-index--delete-line (id) - "Delete a line specified by ID." - (let (content) - (org-index--on - 'id id - (let ((start (line-beginning-position))) - (beginning-of-line) - (forward-line) - (delete-region start (point)) - t)))) - - (defun org-index--ref-from-id (id) "Get reference from line ID." (org-index--on 'id id (org-index--get-or-set-field 'ref))) @@ -882,27 +1253,35 @@ Argument COLUMN and VALUE specify line to get." (org-index--on 'ref ref (org-index--get-or-set-field 'id))) -(defun org-index--read-search-for-enter () - "Special input routine for command enter." - ;; Accept single char commands or switch to reading a sequence of digits - (let (char prompt search-ref search-id) - - ;; start with short prompt but give more help on next iteration - (setq prompt "Please specify, where to go in index (0-9.,space,backspace,return or ? for help): ") - - ;; read one character - (while (not (memq char (append (number-sequence ?0 ?9) (list ?\d ?\b ?\r ?\j ?\s ?.)))) - (setq char (read-char prompt)) - (setq prompt "Go to index table and specific position. Digits specify a reference number to got to, <space> goes to top of index, <backspace> or <delete> to last line created and <return> or `.' to index line of current node. Please choose: ")) - - (if (memq char (number-sequence ?0 ?9)) - ;; read rest of digits - (setq search-ref (read-from-minibuffer "Search reference number: " (char-to-string char)))) - ;; decode single chars - (if (memq char '(?\r ?\n ?.)) (setq search-id (org-id-get))) - (if (memq char '(?\d ?\b)) (setq search-ref (number-to-string org-index--maxref))) - - (cons search-ref search-id))) +(defun org-index--get-fingerprint () + "Get fingerprint of current line." + (replace-regexp-in-string + "\\s " "" + (mapconcat (lambda (x) (org-index--get-or-set-field x)) '(id ref yank keywords created) ""))) + + +(defun org-index--read-search-for-index () + "Special input routine for command index." + + ;; Accept single char commands or switch to reading a sequence of digits + (let (char prompt search-ref search-id search-fingerprint) + + ;; start with short prompt but give more help on next iteration + (setq prompt "Please specify, where to go in index (0-9,.,space,backspace,return or ? for short help) - ") + + ;; read one character + (while (not (memq char (append (number-sequence ?0 ?9) (list ?\d ?\b ?\r ?\j ?\s ?.)))) + (setq char (read-char prompt)) + (setq prompt "Go to specific position in index table. Digits specify a reference number, <space> goes to top of index, <backspace> or <delete> to last line created and <return> or `.' to index line of current node. Please choose - ")) + + (if (memq char (number-sequence ?0 ?9)) + ;; read rest of digits + (setq search-ref (read-from-minibuffer "Search reference number: " (char-to-string char)))) + ;; decode single chars + (if (memq char '(?\r ?\n ?.)) (setq search-id (org-id-get))) + (if (memq char '(?\d ?\b)) (setq search-fingerprint org-index--last-fingerprint)) + + (list search-ref search-id search-fingerprint))) (defun org-index--verify-id () @@ -911,9 +1290,10 @@ Argument COLUMN and VALUE specify line to get." ;; Check id (unless org-index-id (let ((answer (org-completing-read "Cannot find an index (org-index-id is not set). You may:\n - read-help : to learn more about org-index\n - create-index : invoke an assistant to create an initial index\nPlease choose: " (list "read-help" "create-index") nil t nil nil "read-help"))) - (if (string= "create-index" answer) + (if (string= answer "create-index") (org-index--create-missing-index "Variable org-index-id is not set, so probably no index table has been created yet.") - (describe-function 'org-index)))) + (describe-function 'org-index) + (throw 'new-index nil)))) ;; Find node (let (marker) @@ -943,8 +1323,9 @@ Argument COLUMN and VALUE specify line to get." (beginning-of-line) (org-get-category (point) t))) - ;; Find out, if we are within index table or not - (setq org-index--within-node (string= (org-id-get) org-index-id))) + ;; Find out, if we are within index table or occur buffer + (setq org-index--within-index-node (string= (org-id-get) org-index-id)) + (setq org-index--within-occur (string= (buffer-name) org-index--occur-buffer-name))) (defun org-index--parse-table () @@ -958,7 +1339,7 @@ Argument COLUMN and VALUE specify line to get." (with-current-buffer org-index--buffer - (setq org-index--maxref 0) + (setq org-index--maxrefnum 0) (setq initial-point (point)) (org-index--go-below-hline) @@ -974,9 +1355,8 @@ Argument COLUMN and VALUE specify line to get." (org-index--go-below-hline) (setq org-index--aligned t) (set-buffer-modified-p is-modified))) - + (org-index--go-below-hline) - (setq org-index--below-hline (point-marker)) (beginning-of-line) ;; get headings to display during occur @@ -1001,7 +1381,6 @@ Argument COLUMN and VALUE specify line to get." ;; parse list of flags (goto-char org-index--point) - (org-index--parse-flags) ;; Retrieve any decorations around the number within the first nonempty ref-field (goto-char org-index--below-hline) @@ -1025,41 +1404,54 @@ Argument COLUMN and VALUE specify line to get." (regexp-quote org-index--tail))) (setq org-index--ref-format (concat org-index--head "%d" org-index--tail)) + ;; check if the table still seems to be sorted mixed + (goto-char org-index--below-hline) + (when (eq org-index-sort-by 'mixed) + (org-index--go-below-hline) + (if (string< (org-index--get-or-set-field 'last-accessed) + (org-index--get-mixed-time)) + (org-index--do-sort-index org-index-sort-by))) + ;; Go through table to find maximum number and do some checking - (let ((ref 0)) + (let ((refnum 0)) (while (org-at-table-p) (setq ref-field (org-index--get-or-set-field 'ref)) (setq id-field (org-index--get-or-set-field 'id)) - (when (and (not ref-field) - (not id-field)) - (kill-whole-line) - (message "Removing line from index-table with both ref and id empty")) - (if ref-field (if (string-match org-index--ref-regex ref-field) ;; grab number - (setq ref (string-to-number (match-string 1 ref-field))) + (setq refnum (string-to-number (match-string 1 ref-field))) (kill-whole-line) (message "Removing line from index-table whose ref does not contain a number"))) ;; check, if higher ref - (if (> ref org-index--maxref) (setq org-index--maxref ref)) + (if (> refnum org-index--maxrefnum) (setq org-index--maxrefnum refnum)) (forward-line 1))) + (setq org-index--nextref (format "%s%d%s" org-index--head (1+ org-index--maxrefnum) org-index--tail)) ;; go back to initial position (goto-char initial-point)))) +(defun org-index--refresh-parse-table () + "Fast refresh of selected results of parsing index table." + + (setq org-index--point (marker-position (org-id-find org-index-id 'marker))) + (with-current-buffer org-index--buffer + (save-excursion + (org-index--go-below-hline)))) + + (defun org-index--do-maintain () "Choose among and perform some tasks to maintain index." (let ((check-what) (max-mini-window-height 1.0) message-text) - (setq check-what (intern (org-completing-read "These checks and fixes are available:\n - statistics : compute statistics about index table\n - check : check ids by visiting their nodes\n - duplicates : check index for duplicate rows (any column)\n - clean : remove obsolete property org-index-id\n - update : update content of index lines, with an id \nPlease choose: " (list "statistics" "check" "duplicates" "clean" "update") nil t nil nil "statistics"))) + (setq check-what (intern (org-completing-read "These checks and fixes are available:\n - statistics : compute statistics about index table\n - check : check ids by visiting their nodes\n - duplicates : check index for duplicate rows (ref or id)\n - clean : remove obsolete property org-index-id\n - update : update content of index lines, with an id \nPlease choose: " (list "statistics" "check" "duplicates" "clean" "update") nil t nil nil "statistics"))) (message nil) - + (cond ((eq check-what 'check) (setq message-text (or (org-index--check-ids) @@ -1069,43 +1461,53 @@ Argument COLUMN and VALUE specify line to get." (setq message-text (org-index--do-statistics))) ((eq check-what 'duplicates) - (setq message-text "Finding duplcates can be done by sorting your index appropriately: Choose 'group-by' and select a column; rows will then be sorted together, if they have the same value within the coosen column.")) + (setq message-text (org-index--find-duplicates))) ((eq check-what 'clean) (let ((lines 0)) (org-map-entries (lambda () (when (org-entry-get (point) "org-index-ref") - (incf lines) + (cl-incf lines) (org-entry-delete (point) "org-index-ref"))) nil 'agenda) (setq message-text (format "Removed property 'org-index-ref' from %d lines" lines)))) - + ((eq check-what 'update) - (if (y-or-n-p "Updating your index will overwrite certain columns with content from the associated heading and category. If unsure, you may try this for a single, already existing line of your index by doing `add' from within your index. Are you SURE to proceed for ALL INDEX LINES ? ") + (if (y-or-n-p "Updating your index will overwrite certain columns with content from the associated heading and category. If unsure, you may try this for a single, already existing line of your index by invoking `add'. Are you SURE to proceed for ALL INDEX LINES ? ") (setq message-text (org-index--update-all-lines)) (setq message-text "Canceled.")))) message-text)) -(defun org-index--do-sort-index (sort &optional groups) - "Sort index table according to SORT, optinally with GROUPS." +(defun org-index--get-mixed-time () + "Get timestamp for sorting order mixed." + (format-time-string + (org-time-stamp-format t t) + (apply 'encode-time (append '(0 0 0) (nthcdr 3 (decode-time)))))) + + +(defun org-index--do-sort-index (sort) + "Sort index table according to SORT." (let ((is-modified (buffer-modified-p)) top bottom - ref-field - count-field) + mixed-time) (unless buffer-read-only - (message "Sorting table for %s..." (symbol-name sort)) + (message "Sorting index table for %s..." (symbol-name sort)) (undo-boundary) (let ((message-log-max nil)) ; we have just issued a message, dont need those of sort-subr + ;; if needed for mixed sort + (if (eq sort 'mixed) + (setq mixed-time (org-index--get-mixed-time))) + ;; get boundaries of table - (goto-char org-index--below-hline) + (org-index--go-below-hline) (forward-line 0) (setq top (point)) (while (org-at-table-p) (forward-line)) @@ -1116,11 +1518,12 @@ Argument COLUMN and VALUE specify line to get." (org-table-goto-column 1) (and (not (org-index--get-or-set-field 'ref)) - (not (org-index--get-or-set-field 'id)))) + (not (org-index--get-or-set-field 'id)) + (not (org-index--get-or-set-field 'yank)))) (org-table-kill-row)) (forward-line 1) (setq bottom (point)) - + ;; sort lines (save-restriction (narrow-to-region top bottom) @@ -1129,11 +1532,7 @@ Argument COLUMN and VALUE specify line to get." 'forward-line 'end-of-line (lambda () - (concat - (if groups - (format "%06d-" (cdr (assoc (org-index--get-or-set-field sort) groups))) - "") - (org-index--get-sort-key sort t))) + (org-index--get-sort-key sort t mixed-time)) nil 'string<) (goto-char (point-min)) @@ -1144,30 +1543,6 @@ Argument COLUMN and VALUE specify line to get." (setq org-index--last-sort sort)))) -(defun org-index--collect-sort-groups (sort) - "Collect groups to SORT for." - (let ((count-groups 0) (count-lines 0) - groups key key-value) - - (org-index--on - nil nil - (while (org-at-table-p) - (setq key (org-index--get-or-set-field sort)) - (setq key-value (assoc key groups)) - (if key-value - (progn - (incf (cdr key-value))) - (setq groups (cons (cons key 1) groups))) - (forward-line))) - - (mapc (lambda (x) (when (> (cdr x) 1) - (incf count-groups) - (incf count-lines (cdr x)))) - groups) - - (list groups count-groups count-lines))) - - (defun org-index--do-sort-lines (what) "Sort lines in WHAT according to contained reference." (save-restriction @@ -1193,8 +1568,7 @@ Argument COLUMN and VALUE specify line to get." (defun org-index--go-below-hline () "Move below hline in index-table." - (let ((count 0) - (errstring (format "index table within node %s" org-index-id))) + (let ((errstring (format "index table within node %s" org-index-id))) (goto-char org-index--point) @@ -1222,15 +1596,15 @@ Argument COLUMN and VALUE specify line to get." (unless (org-at-table-p) (org-index--report-index-error "Cannot find a hline within %s" errstring)) - (org-table-goto-column 1))) + (org-table-goto-column 1) + (setq org-index--below-hline (point)))) (defun org-index--parse-headings () "Parse headings of index table." - (let (field ;; field content - field-symbol ;; and as a symbol - found) + (let (field ;; field content + field-symbol) ;; and as a symbol (setq org-index--columns nil) @@ -1243,21 +1617,7 @@ Argument COLUMN and VALUE specify line to get." (error "Heading of column cannot be empty")) (if (and (not (string= (substring field 0 1) ".")) (not (member (intern field) org-index--valid-headings))) - - (if (string= field "link") - ;; Ask user to migrate his index to new version (since [2015-02-11 Mi]) - (progn - ;; pop to index buffer - (pop-to-buffer-same-window org-index--buffer) - (goto-char org-index--below-hline) - (org-reveal t) - ;; go to column - (while (org-at-table-p) - (forward-line -1)) - (forward-line) - (org-table-goto-column (+ 1 col)) - (error "Column 'link' should be named 'id' with recent versions of org-index,\nplease adjust your table (cursor is already positioned right)")) - (error "Column name '%s' is not a valid heading (custom headings may start with a dot, e.g. '.foo')" field))) + (error "Column name '%s' is not a valid heading (custom headings may start with a dot, e.g. '.foo')" field)) (setq field-symbol (intern field)) @@ -1274,142 +1634,13 @@ Argument COLUMN and VALUE specify line to get." (mapc (lambda (head) (unless (cdr (assoc head org-index--columns)) (org-index--report-index-error "No column has heading '%s'" head))) - org-index--required-headings)) - - -(defun org-index--parse-flags () - "Parse list of flags in index table." - - (let (parent parent-is-comment child) - - ;; reset configuration variables - (setq org-index--special-columns nil) - (setq org-index--flagged-columns nil) - - (org-index--goto-list "columns-and-flags" t) - (forward-line 1) - - ;; outer loop over columns - (while (and (setq parent (org-index--parse-list-item)) - parent - (> (cdr (assoc :indent parent)) 0)) - - (setq parent-is-comment (member (cdr (assoc :text parent)) '("all-columns-explained" "all-flags-explained"))) - - ;; check, that we have a valid heading - (unless (or parent-is-comment - (assoc (cdr (assoc :sym parent)) org-index--columns)) - (when (string= "link" (cdr (assoc :text parent))) - (pop-to-buffer-same-window org-index--buffer) - (org-reveal t) - (error "Flag 'link' should be named 'id' with recent versions of org-index,\nplease adjust this flag (cursor is already positioned right)")) - (org-index--report-index-error "'%s' appears within flags, but not as a index column. " (cdr (assoc :text parent)))) - - ;; inner loop over children - (while (and (forward-line 1) - (setq child (org-index--parse-list-item)) - child - (> (cdr (assoc :indent child)) - (cdr (assoc :indent parent)))) - - (unless parent-is-comment - ;; check, that we have a valid flag - (unless (memq (cdr (assoc :sym child)) org-index--all-flags) - (org-index--report-index-error "'%s' is not a valid flag" (cdr (assoc :text child)))) - - ;; process flag with respect to current index-column - (if (memq (cdr (assoc :sym child)) org-index--single-flags) - ;; Check, that none of org-index--single-flags appears twice - (if (assoc (cdr (assoc :sym child)) org-index--special-columns) - (org-index--report-index-error - "More than one column is marked with flag '%s'" (cdr (assoc :text child))) - ;; add it to list - (setq org-index--special-columns (cons (cons (cdr (assoc :sym child)) (cdr (assoc :sym parent))) - org-index--special-columns)))) - - ;; all flags are stored in org-index--flagged-columns - (let ((l (assoc (cdr (assoc :sym child)) org-index--flagged-columns))) ;; list of flag and columns, that carry this flag - (unless l - ;; no list of columns with this flag is present, create one - (setq org-index--flagged-columns - (cons (cons (cdr (assoc :sym child)) nil) - org-index--flagged-columns)) - (setq l (car org-index--flagged-columns))) - ;; prepend this column to list of columns with this flag - (setcdr l (cons (cdr (assoc :sym parent)) (cdr l))))))) - - ;; check, that all needed flags have been specified - (mapc (lambda (x) - (unless (assoc x org-index--special-columns) - (org-index--report-index-error "Required flag '%s' does not appear" (substring (symbol-name x) 1)))) - org-index--required-flags))) - - -(defun org-index--goto-list (name &optional required non-top) - "Goto list NAME (maybe NON-TOP Level) in index node, err if REQUIRED list is not present." - (goto-char org-index--point) - - ;; go to heading of node - (while (not (org-at-heading-p)) (forward-line -1)) - (forward-line 1) - - ;; go to named list - (while (and (not (let ((item (org-index--parse-list-item))) - (if item - (and (or non-top (= (cdr (assoc :indent item)) 0)) ;; accept only toplevel ? - (string= (cdr (assoc :text item)) name)) ;; with requested name - nil))) - (not (org-at-table-p)) - (not (org-at-heading-p)) - (not (eobp))) - (forward-line 1)) - - (if (org-at-item-p) - t - (if required - (org-index--report-index-error "Could not find required list '%s'" name) - nil))) - - -(defun org-index--parse-list-item () - "Parse a list item into an assoc array (indent, checkbox, text, value)." - - ;; matche full list-item, maybe with checkbox and double-colon - (if (looking-at org-list-full-item-re) - - ;; retrieve interesting parts of list item from match data - (let (indent checkbox text value next-line) - - (setq indent - (- (save-excursion (goto-char (match-beginning 1)) (current-column)) ; first column - (save-match-data (org-current-level)) ; indent-level - 1)) - (setq checkbox (match-string 3)) - (setq text (match-string 4)) - (set (if text 'value 'text) (buffer-substring (match-end 0) (line-end-position))) ; regexp did not capture this - - ;; peek ahead, if item continues on next line - (forward-line 1) - (if (looking-at org-list-full-item-re) - (forward-line -1) ; already at next item; go back - (setq next-line (buffer-substring (line-beginning-position) (line-end-position)))) - - ;; clean up strings - (mapc (lambda (x) - (if (stringp (symbol-value x)) - (set x (org-trim (substring-no-properties (symbol-value x)))))) - '(text value next-line)) - - (if next-line (setq text (concat text " " next-line))) ; append next line if - - (list (cons :indent indent) (cons :text text) (cons :value value) (cons :sym (intern text)))) - nil)) + org-index--valid-headings)) (defun org-index--create-missing-index (&rest reasons) "Create a new empty index table with detailed explanation. Argument REASONS explains why." - (org-index--ask-before-create-index "Cannot find your index table: " + (org-index--ask-before-create-index "Cannot find index table: " "new permanent" "." reasons) (org-index--create-index)) @@ -1435,7 +1666,7 @@ Argument COLUMN and VALUE specify line to get." (setq reason (apply 'format reasons)) - (setq prompt (concat explanation reason "\n\n" + (setq prompt (concat explanation reason "\n" "However, this assistant can help you to create a " type " index with detailed comments" for-what "\n\n" "Do you want to proceed ?")) @@ -1468,10 +1699,12 @@ specify flag TEMPORARY for th new table temporary, maybe COMPARE it with existin (setq buffer (get-buffer (org-completing-read "Please choose the buffer, where the new node for the index table should be created; the new node will be inserted at its end.\n\nBuffer: " (mapcar 'buffer-name (org-buffer-list)))))) - (setq title (read-from-minibuffer "Please enter the title of the index node: ")) + (setq title (read-from-minibuffer "Please enter the title of the index node (leave empty for default 'index'): ")) + (if (string= title "") (setq title "index")) (while (progn - (setq firstref (read-from-minibuffer "Please enter your first reference-number. This is a number preceeded by some non-digit chars and optionally followed by some more non-digit chars, e.g. 'R1', '-1-' or '#1#' (and your initial number does not need to be '1'). The format of your reference-numbers only needs to make sense for yourself, so that you can spot it easily in your texts or write it on a piece of paper; it should however not already appear to frequently within your existing notes, to avoid too many false hits when searching.\n\nPlease choose: ")) + (setq firstref (read-from-minibuffer "Please enter your first reference-number. This is an integer number preceeded by some and optionally followed by some non-numeric chars; e.g. 'R1', '-1-' or '#1#' (and your initial number does not need to be '1'). The format of your reference-numbers only needs to make sense for yourself, so that you can spot it easily in your texts or write it on a piece of paper; it should however not already appear frequently within your existing notes, to avoid too many false hits when searching.\n\nPlease choose (leave empty for default 'R1'): ")) + (if (string= firstref "") (setq firstref "R1")) (let (desc) (when (string-match "[[:blank:]]" firstref) (setq desc "Contains whitespace")) @@ -1498,28 +1731,26 @@ specify flag TEMPORARY for th new table temporary, maybe COMPARE it with existin (if temporary (insert " Below you find your temporary index table, which WILL NOT LAST LONGER - THAN YOUR CURRENT EMACS SESSION. + THAN YOUR CURRENT EMACS SESSION; please use it only for evaluation. ") (insert " Below you find your initial index table, which will grow over time. ")) - (insert " - You may start using it by adding some lines. Just move to - another heading, invoke `org-index' and choose the command - 'add'. After adding a few nodes, try the command 'occur' - to search among them. + (insert " You may start using it by adding some lines. Just + move to another heading within org, invoke `org-index' and + choose the command 'add'. After adding a few nodes, try the + command 'occur' to search among them. To gain further insight you may invoke the subcommand 'help', or - read the description of `org-index'. + (same content) read the help of `org-index'. - Within the index table below, dhe sequence of columns does not - matter. You may reorder them in any way you please. Columns are - found by their heading. You may also add your own columns, - which should start with a dot (e.g. '.custom'). + Within the index table below, the sequence of columns does not + matter. You may reorder them in any way you like. You may also + add your own columns, which should start with a dot + (e.g. '.my-column'). - Following this explanations you will find the item-list - `columns-and-flags', which influences the behaviour of - `org-index'. See the explanations which are part of this list. + Invoke `org-customize' to tweak the behaviour of org-index + (see the group org-index). This node needs not be a top level node; its name is completely at your choice; it is found through its ID only. @@ -1531,18 +1762,15 @@ specify flag TEMPORARY for th new table temporary, maybe COMPARE it with existin (setq id (org-id-get-create)) (insert (format " -%s - - | ref | category | keywords | count | last-accessed | created | id | - | | | | | | | <4> | - |-----+-----------+----------+-------+---------------+---------+------| - | %s | | %s | | | %s | %s | + | ref | category | keywords | tags | count | level | last-accessed | created | id | yank | + | | | | | | | | | <4> | <4> | + |-----+----------+----------+------+-------+-------+---------------+---------+-----+------| + | %s | | %s | | | | | %s | %s | | " - org-index--sample-flags firstref - "This node" + title (with-temp-buffer (org-insert-time-stamp nil nil t)) id)) @@ -1577,8 +1805,10 @@ specify flag TEMPORARY for th new table temporary, maybe COMPARE it with existin (org-id-goto id) (org-index--unfold-buffer) (if compare - (error "Please compare your existing index (upper window) and a temporary new one (lower window) to fix your index") - (message "This is your new temporary index."))) + (progn + (message "Please compare your existing index (upper window) and a temporary new one (lower window) to fix your index") + (throw 'new-index nil)) + (message "This is your new temporary index, use command add to populate, occur to search."))) (progn ;; Only show the new index (pop-to-buffer-same-window buffer) @@ -1588,12 +1818,14 @@ specify flag TEMPORARY for th new table temporary, maybe COMPARE it with existin (if (y-or-n-p "This is your new index table. It is already set for this Emacs session, so you may try it out. Do you want to save its id to make it available for future Emacs sessions too ? ") (progn (customize-save-variable 'org-index-id id) - (error "Saved org-index-id '%s' to %s" id (or custom-file - user-init-file))) + (message "Saved org-index-id '%s' to %s." id (or custom-file + user-init-file)) + (throw 'new-index nil)) (let (sq) (setq sq (format "(setq org-index-id \"%s\")" id)) (kill-new sq) - (error "Did not make the id of this new index permanent; you may want to put\n\n %s\n\ninto your own initialization; it is copied already, just yank it" sq)))))))) + (message "Did not make the id of this new index permanent; you may want to put\n\n %s\n\ninto your own initialization; it is copied already, just yank it." sq) + (throw 'new-index nil)))))))) (defun org-index--unfold-buffer () @@ -1604,31 +1836,31 @@ specify flag TEMPORARY for th new table temporary, maybe COMPARE it with existin (save-excursion (org-back-to-heading) (forward-line) ;; on property drawer - (org-cycle) - (org-index--goto-list "columns-and-flags") (org-cycle))) -(defun org-index--update-line (&optional ref-or-id) - "Update columns count and last-accessed in line REF-OR-ID." +(defun org-index--update-line (&optional ref-or-id-or-pos) + "Update columns count and last-accessed in line REF-OR-ID-OR-POS." - (let ((newcount 0) - initial) + (let (initial) (with-current-buffer org-index--buffer (unless buffer-read-only ;; search reference or id, if given (or assume, that we are already positioned right) - (when ref-or-id + (when ref-or-id-or-pos (setq initial (point)) (goto-char org-index--below-hline) (while (and (org-at-table-p) - (not (or (string= ref-or-id (org-index--get-or-set-field 'ref)) - (string= ref-or-id (org-index--get-or-set-field 'id))))) + (not (if (integerp ref-or-id-or-pos) + (and (>= ref-or-id-or-pos (line-beginning-position)) + (< ref-or-id-or-pos (line-end-position))) + (or (string= ref-or-id-or-pos (org-index--get-or-set-field 'ref)) + (string= ref-or-id-or-pos (org-index--get-or-set-field 'id)))))) (forward-line))) (if (not (org-at-table-p)) - (error "Did not find reference or id '%s'" ref-or-id) + (error "Did not find reference or id '%s'" ref-or-id-or-pos) (org-index--update-current-line)) (if initial (goto-char initial)))))) @@ -1655,27 +1887,43 @@ specify flag TEMPORARY for th new table temporary, maybe COMPARE it with existin (org-index--align-and-fontify-current-line))) -(defun org-index--align-and-fontify-current-line () - "Make current line blend well among others." - (let ((line (substring-no-properties (delete-and-extract-region (line-beginning-position) (line-end-position))))) - ;; create minimum table with fixed-width columns to align and fontiry new line +(defun org-index--align-and-fontify-current-line (&optional num) + "Make current line (or NUM lines) blend well among others." + (let (lines) + ;; get current content + (unless num (setq num 1)) + (setq lines (delete-and-extract-region (line-beginning-position) (line-end-position num))) + ;; create minimum table with fixed-width columns to align and fontify new line (insert (with-temp-buffer (org-set-font-lock-defaults) (insert org-index--headings-visible) - (goto-char (point-min)) ;; fill columns, so that aligning cannot shrink them + (goto-char (point-min)) (search-forward "|") - (replace-string " " "." nil (point) (line-end-position)) - (replace-string ".|." " | " nil (line-beginning-position) (line-end-position)) - (replace-string "|." "| " nil (line-beginning-position) (line-end-position)) + (while (search-forward " " (line-end-position) t) + (replace-match "." nil t)) + (goto-char (point-min)) + (while (search-forward ".|." (line-end-position) t) + (replace-match " | " nil t)) + (goto-char (point-min)) + (while (search-forward "|." (line-end-position) t) + (replace-match "| " nil t)) (goto-char (point-max)) - (insert line) + (insert lines) (forward-line 0) + (let ((start (point))) + (while (re-search-forward "^\s +|-" nil t) + (replace-match "| -")) + (goto-char start)) + (org-mode) (org-table-align) (font-lock-fontify-region (point-min) (point-max)) (goto-char (point-max)) - (forward-line -1) - (buffer-substring (line-beginning-position) (line-end-position)))))) + (if (eq -1 (skip-chars-backward "\n")) + (delete-char 1)) + (forward-line (- 1 num)) + (buffer-substring (line-beginning-position) (line-end-position num)))) + lines)) (defun org-index--promote-current-line () @@ -1694,7 +1942,7 @@ specify flag TEMPORARY for th new table temporary, maybe COMPARE it with existin (not (org-at-table-hline-p)) (string< (org-index--get-sort-key) key)) - (incf to-skip) + (cl-incf to-skip) (forward-line -1)) (forward-line 1) @@ -1704,8 +1952,8 @@ specify flag TEMPORARY for th new table temporary, maybe COMPARE it with existin (forward-line -1)))) -(defun org-index--get-sort-key (&optional sort with-ref) - "Get value for sorting from column SORT, optional WITH-REF." +(defun org-index--get-sort-key (&optional sort with-ref mixed-time) + "Get value for sorting from column SORT, optional WITH-REF; if mixes use MIXED-TIME." (let (ref ref-field key) @@ -1717,24 +1965,28 @@ specify flag TEMPORARY for th new table temporary, maybe COMPARE it with existin ;; get reference with leading zeroes, so it can be ;; sorted as text (setq ref-field (org-index--get-or-set-field 'ref)) - (string-match org-index--ref-regex ref-field) - (setq ref (format - "%06d" - (string-to-number - (or (match-string 1 ref-field) - "0"))))) + (if ref-field + (progn + (string-match org-index--ref-regex ref-field) + (setq ref (format + "%06d" + (string-to-number + (match-string 1 ref-field))))) + (setq ref "000000"))) (setq key (cond ((eq sort 'count) (format "%08d" (string-to-number (or (org-index--get-or-set-field 'count) "")))) + ((eq sort 'mixed) + (let ((last-accessed (org-index--get-or-set-field 'last-accessed))) + (unless mixed-time (setq mixed-time (org-index--get-mixed-time))) + (concat + (if (string< mixed-time last-accessed) last-accessed mixed-time) + (format "%08d" (string-to-number (or (org-index--get-or-set-field 'count) "")))))) ((eq sort 'ref) ref) - ((eq sort 'id) - (org-index--get-or-set-field sort)) - ((eq sort 'last-accessed) - (org-index--get-or-set-field sort)) - ((eq sort 'created) + ((memq sort '(id last-accessed created)) (org-index--get-or-set-field sort)) (t (error "This is a bug: unmatched case '%s'" sort)))) @@ -1747,7 +1999,11 @@ specify flag TEMPORARY for th new table temporary, maybe COMPARE it with existin "Retrieve field KEY from index table or set it to VALUE." (let (field) (save-excursion - (setq field (org-trim (org-table-get-field (cdr (assoc key org-index--columns)) value))) + (if (eq key 'fingerprint) + (progn + (if value (error "Internal error, pseudo-column fingerprint cannot be set")) + (setq field (org-index--get-fingerprint))) + (setq field (org-trim (org-table-get-field (cdr (assoc key org-index--columns)) value)))) (if (string= field "") (setq field nil)) (org-no-properties field)))) @@ -1760,68 +2016,112 @@ specify flag TEMPORARY for th new table temporary, maybe COMPARE it with existin (cdr (assoc key org-index--columns)))) -(defun org-index--special-column (key) - "Return column (not a number) for special column KEY." - (cdr (assoc key org-index--special-columns))) +(defun org-index--make-guarded-search (ref &optional dont-quote) + "Make robust search string from REF; DONT-QUOTE it, if requested." + (concat "\\_<" (if dont-quote ref (regexp-quote ref)) "\\_>")) + + +(defun org-index--find-duplicates () + "Find duplicate references or ids in index table." + (let (ref-duplicates id-duplicates) + (setq ref-duplicates (org-index--find-duplicates-helper 'ref)) + (setq id-duplicates (org-index--find-duplicates-helper 'id)) + (goto-char org-index--below-hline) + (if (or ref-duplicates id-duplicates) + (progn + ;; show results + (pop-to-buffer-same-window + (get-buffer-create "*org-index-duplicates*")) + (when ref-duplicates + (insert "These references appear more than once:\n") + (mapc (lambda (x) (insert " " x "\n")) ref-duplicates) + (insert "\n\n")) + (when id-duplicates + (insert "These ids appear more than once:\n") + (mapc (lambda (x) (insert " " x "\n")) id-duplicates)) + + "Some references or ids are duplicates") + "No duplicate references or ids found"))) + + +(defun org-index--find-duplicates-helper (column) + "Helper for `org-index--find-duplicates': Go through table and count given COLUMN." + (let (counts duplicates field found) + + ;; go through table + (goto-char org-index--below-hline) + (while (org-at-table-p) -(defun org-index--flag-p (flag column) - "Check if COLUMN has FLAG set." - (unless (memq flag org-index--all-flags) - (error (format "Internal error: unknown flag %s" (symbol-name flag)))) - (memq column (assoc flag org-index--flagged-columns))) + ;; get column + (setq field (org-index--get-or-set-field column)) + ;; and increment + (setq found (assoc field counts)) + (if found + (cl-incf (cdr found)) + (setq counts (cons (cons field 1) counts))) -(defun org-index--make-guarded-search (ref &optional dont-quote) - "Make robust search string from REF; DONT-QUOTE it, if requested." - (concat "\\_<" (if dont-quote ref (regexp-quote ref)) "\\_>")) + (forward-line)) + + (mapc (lambda (x) (if (and (> (cdr x) 1) + (car x)) + (setq duplicates (cons (car x) duplicates)))) counts) + + duplicates)) (defun org-index--do-statistics () "Compute statistics about index table." - (let ((total 0) - ref-field ref min max message) - + (let ((total-lines 0) (total-refs 0) + ref ref-field min max message) - ;; go through table and remove all refs, that we see + ;; go through table (goto-char org-index--below-hline) (while (org-at-table-p) - ;; get ref-field and number + ;; get ref (setq ref-field (org-index--get-or-set-field 'ref)) - (if (and ref-field - (string-match org-index--ref-regex ref-field)) - (setq ref (string-to-number (match-string 1 ref-field)))) - ;; record min and max - (if (or (not min) (< ref min)) (setq min ref)) - (if (or (not max) (> ref max)) (setq max ref)) + (when ref-field + (string-match org-index--ref-regex ref-field) + (setq ref (string-to-number (match-string 1 ref-field))) + + ;; record min and max + (if (or (not min) (< ref min)) (setq min ref)) + (if (or (not max) (> ref max)) (setq max ref)) + + (setq total-refs (1+ total-refs))) ;; count - (setq total (1+ total)) + (setq total-lines (1+ total-lines)) (forward-line)) - (setq message (format "First reference is %s, last %s; %d values in between, %d of them are used (%d percent)" - (format org-index--ref-format min) - (format org-index--ref-format max) - (1+ (- max min)) - total - (truncate (* 100 (/ (float total) (1+ (- max min))))) - -)) + (setq message (format "%d Lines in index table. First reference is %s, last %s; %d of them are used (%d percent)" + total-lines + (format org-index--ref-format min) + (format org-index--ref-format max) + total-refs + (truncate (* 100 (/ (float total-refs) (1+ (- max min))))))) (goto-char org-index--below-hline) message)) -(defun org-index--do-add-or-update () - "For current node or current line in index, add a new line to index table or update existing." +(defun org-index--do-add-or-update (&optional create-ref tag-with-ref) + "For current node or current line in index, add or update in index table. +CREATE-REF and TAG-WITH-REF if given." - (let* (id ref args yank ref-and-yank) + (let* (id id-from-index ref args yank ret) - ;; do the same things from within index and from outside - (if org-index--within-node + (org-index--save-positions) + (unless (or org-index--within-index-node + org-index--within-occur) + (org-back-to-heading)) + + ;; try to do the same things from within index and from outside + (if org-index--within-index-node (progn (unless (org-at-table-p) @@ -1830,34 +2130,59 @@ specify flag TEMPORARY for th new table temporary, maybe COMPARE it with existin (setq id (org-index--get-or-set-field 'id)) (setq ref (org-index--get-or-set-field 'ref)) (setq args (org-index--collect-values-for-add-update-remote id)) - (org-index--write-fields-for-add-update args) - (setq yank (org-index--get-or-set-field (org-index--special-column 'yank-after-add))) - - (cons (format "Updated index line %s" ref) yank)) + (org-index--write-fields args) + (setq yank (org-index--get-or-set-field org-index-yank-after-add)) - (unless (org-at-heading-p) - (error "Not at headline")) + (setq ret + (if ref + (cons (format "Updated index line %s" ref) yank) + (cons "Updated index line" nil)))) (setq id (org-id-get-create)) + (org-index--refresh-parse-table) + (setq id-from-index (org-index--on 'id id id)) (setq ref (org-index--on 'id id (org-index--get-or-set-field 'ref))) - (setq args (org-index--collect-values-for-add-update id ref)) - (if ref - ;; already have a ref, find it in index and update fields - (let ((kvs args) - found-and-message) + (if tag-with-ref + (org-toggle-tag (format "%s%d%s" org-index--head tag-with-ref org-index--tail) 'on)) + (setq args (org-index--collect-values-for-add-update id)) + + (when (and create-ref + (not ref)) + (setq ref org-index--nextref) + (setq args (plist-put args 'ref ref))) + + + (if id-from-index + ;; already have an id in index, find it and update fields + (progn (org-index--on - 'ref ref - (org-index--write-fields-for-add-update args) - (setq yank (org-index--get-or-set-field (org-index--special-column 'yank-after-add)))) - - (cons (format "Updated index line %s" ref) yank)) + 'id id + (org-index--write-fields args) + (setq yank (org-index--get-or-set-field org-index-yank-after-add))) + + (setq ret + (if ref + (cons (format "Updated index line %s" ref) yank) + (cons "Updated index line" nil)))) - ;; no ref here, create new line in index - (setq ref-and-yank (apply 'org-index--do-new-line args)) + ;; no id here, create new line in index + (if ref (setq ref (plist-put args 'ref org-index--nextref))) + (setq yank (apply 'org-index--do-new-line args)) - (cons (format "Added index line %s" (car ref-and-yank)) (concat (cdr ref-and-yank) " ")))))) + (setq ret + (if ref + (cons + (format "Added new index line %s" ref) + (concat yank " ")) + (cons + "Added new index line" + nil))))) + + (org-index--restore-positions) + + ret)) (defun org-index--check-ids () @@ -1865,7 +2190,7 @@ specify flag TEMPORARY for th new table temporary, maybe COMPARE it with existin (let ((lines 0) id ids marker) - + (goto-char org-index--below-hline) (catch 'problem @@ -1877,7 +2202,7 @@ specify flag TEMPORARY for th new table temporary, maybe COMPARE it with existin (when (member id ids) (org-table-goto-column (org-index--column-num 'id)) (throw 'problem "This id appears twice in index; please use command 'maintain' to check for duplicate ids")) - (incf lines) + (cl-incf lines) (setq ids (cons id ids)) ;; check, if id is valid @@ -1891,13 +2216,13 @@ specify flag TEMPORARY for th new table temporary, maybe COMPARE it with existin (goto-char org-index--below-hline) nil))) - + (defun org-index--update-all-lines () "Update all lines of index at once." (let ((lines 0) id ref kvs) - + ;; check for double ids (or (org-index--check-ids) @@ -1905,13 +2230,13 @@ specify flag TEMPORARY for th new table temporary, maybe COMPARE it with existin (progn (goto-char org-index--below-hline) (while (org-at-table-p) - + ;; update single line (when (setq id (org-index--get-or-set-field 'id)) (setq ref (org-index--get-or-set-field 'ref)) (setq kvs (org-index--collect-values-for-add-update-remote id)) - (org-index--write-fields-for-add-update kvs) - (incf lines)) + (org-index--write-fields kvs) + (cl-incf lines)) (forward-line)) (goto-char org-index--below-hline) @@ -1921,44 +2246,48 @@ specify flag TEMPORARY for th new table temporary, maybe COMPARE it with existin (defun org-index--collect-values-for-add-update (id &optional silent category) "Collect values for adding or updating line specified by ID, do not ask if SILENT, use CATEGORY, if given." - - (let ((args (list 'ref t 'id id)) + + (let ((args (list 'id id)) content) - - (dolist (col-num org-index--columns) - + + (dolist (col (mapcar 'car org-index--columns)) + (setq content "") - - (if (eq (car col-num) 'keywords) - (setq content (nth 4 (org-heading-components)))) - - (if (eq (car col-num) 'category) - (setq content (or category org-index--category-before))) - - (if (eq (car col-num) 'level) - (setq content (number-to-string (org-outline-level)))) - - ;; Shift ref and timestamp ? - (if (org-index--flag-p 'shift-ref-and-date-on-add (car col-num)) - (dotimes (i 2) - (if (or (string-match (concat "^\\s-*" org-index--ref-regex) content) - (string-match (concat org-ts-regexp-both) content)) - (setq content (substring content (match-end 0)))))) - - (if (and (not silent) ; do not edit, if heading has already been added - (org-index--flag-p 'edit-on-add (car col-num))) - (setq content (read-from-minibuffer - (format "Edit text for column '%s': " (symbol-name (car col-num))) - content))) - - (if (not (string= content "")) - (setq args (append (list (car col-num) content) args)))) + + (cond + ((eq col 'keywords) + (if org-index-copy-heading-to-keywords + (setq content (nth 4 (org-heading-components)))) + + ;; Shift ref and timestamp ? + (if org-index-strip-ref-and-date-from-heading + (dotimes (i 2) + (if (or (string-match (concat "^\\s-*" org-index--ref-regex) content) + (string-match (concat "^\\s-*" org-ts-regexp-both) content)) + (setq content (substring content (match-end 0))))))) + + ((eq col 'category) + (setq content (or category org-index--category-before))) + + ((eq col 'level) + (setq content (number-to-string (org-outline-level)))) + + ((eq col 'tags) + (setq content (org-get-tags-string)))) + + (unless (string= content "") + (setq args (plist-put args col content)))) + + (if (not silent) + (let ((args-edited (org-index--collect-values-from-user org-index-edit-on-add args))) + (setq args (append args-edited args)))) + args)) (defun org-index--collect-values-for-add-update-remote (id) "Wrap `org-index--collect-values-for-add-update' by prior moving to remote node identified by ID." - + (let (marker point args) (setq marker (org-id-find id t)) @@ -1972,43 +2301,158 @@ specify flag TEMPORARY for th new table temporary, maybe COMPARE it with existin args)) -(defun org-index--write-fields-for-add-update (kvs) +(defun org-index--collect-values-from-user (cols &optional defaults) + "Collect values for adding a new yank-line. +Argument COLS gives list of columns to edit. +Optional argument DEFAULTS gives default values." + + (let (content args) + + (dolist (col cols) + + (setq content "") + + (setq content (read-from-minibuffer + (format "Enter text for column '%s': " (symbol-name col)) + (plist-get col defaults))) + + (unless (string= content "") + (setq args (plist-put args col content)))) + args)) + + +(defun org-index--write-fields (kvs) "Update current line with values from KVS (keys-values)." (while kvs - (unless (eq (car kvs) 'ref) - (org-index--get-or-set-field (car kvs) (org-trim (cadr kvs)))) + (org-index--get-or-set-field (car kvs) (org-trim (cadr kvs))) (setq kvs (cddr kvs)))) -(defun org-index--do-delete () - "Perform command delete." +(defun org-index--do-kill () + "Perform command kill from within occur, index or node." - (unless (org-at-heading-p) - (error "Not at headline")) + (let (id ref chars-deleted-index text-deleted-from pos-in-index) - (let* ((id (org-entry-get (point) "ID")) - (ref (org-index--ref-from-id id))) + (org-index--save-positions) + (unless (or org-index--within-index-node + org-index--within-occur) + (org-back-to-heading)) - ;; maybe delete from heading - (if ref - (save-excursion - (end-of-line) - (let ((end (point))) - (beginning-of-line) - (when (search-forward ref end t) - (delete-char (- (length ref))) - (just-one-space))))) + ;; Collect information: What should be deleted ? + (if (or org-index--within-occur + org-index--within-index-node) - ;; delete from index table - (if (org-index--delete-line id) - (format "Deleted index line %s" ref) - (format "Did not find id %s in index" id)))) + (progn + (if org-index--within-index-node + ;; In index + (setq pos-in-index (point)) + ;; In occur + (setq pos-in-index (get-text-property (point) 'org-index-lbp)) + (org-index--occur-test-stale pos-in-index) + (set-buffer org-index--buffer) + (goto-char pos-in-index)) + ;; In Index (maybe moved there) + (setq id (org-index--get-or-set-field 'id)) + (setq ref (org-index--get-or-set-field 'ref))) + + ;; At a headline + (setq id (org-entry-get (point) "ID")) + (setq ref (org-index--ref-from-id id)) + (setq pos-in-index (org-index--on 'id id (point))) + (unless pos-in-index (error "This node is not in index"))) + + ;; Remark: Current buffer is not certain here, but we have all the information to delete + + ;; Delete from node + (when id + (let ((m (org-id-find id 'marker))) + (set-buffer (marker-buffer m)) + (goto-char m) + (move-marker m nil) + (unless (string= (org-id-get) id) + (error "Could not find node with id %s" id))) + + (org-index--delete-any-ref-from-tags) + (if ref (org-index--delete-ref-from-heading ref)) + (setq text-deleted-from (cons "node" text-deleted-from))) + + ;; Delete from index + (set-buffer org-index--buffer) + (unless pos-in-index "Internal error, pos-in-index should be defined here") + (goto-char pos-in-index) + (setq chars-deleted-index (length (delete-and-extract-region (line-beginning-position) (line-beginning-position 2)))) + (setq text-deleted-from (cons "index" text-deleted-from)) + + ;; Delete from occur only if we started there, accept that it will be stale otherwise + (if org-index--within-occur + (let ((inhibit-read-only t)) + (set-buffer org-index--occur-buffer-name) + (delete-region (line-beginning-position) (line-beginning-position 2)) + ;; correct positions + (while (org-at-table-p) + (put-text-property (line-beginning-position) (line-end-position) 'org-index-lbp + (- (get-text-property (point) 'org-index-lbp) chars-deleted-index)) + (forward-line)) + (setq text-deleted-from (cons "occur" text-deleted-from)))) + + (org-index--restore-positions) + (concat "Deleted from: " (mapconcat 'identity (sort text-deleted-from 'string<) ",")))) + + +(defun org-index--save-positions () + "Save current buffer and positions in index- and current buffer; not in occur-buffer." + + (let (cur-buf cur-mrk idx-pnt idx-mrk) + (setq cur-buf (current-buffer)) + (setq cur-mrk (point-marker)) + (set-buffer org-index--buffer) + (if (string= (org-id-get) org-index-id) + (setq idx-pnt (point)) + (setq idx-mrk (point-marker))) + (set-buffer cur-buf) + (setq org-index--saved-positions (list cur-buf cur-mrk idx-pnt idx-mrk)))) + + +(defun org-index--restore-positions () + "Restore positions as saved by `org-index--save-positions'." + + (cl-multiple-value-bind + (cur-buf cur-mrk idx-pnt idx-mrk buf) + org-index--saved-positions + (setq buf (current-buffer)) + (set-buffer cur-buf) + (goto-char cur-mrk) + (set-buffer org-index--buffer) + (goto-char (or idx-pnt idx-mrk)) + (set-buffer buf)) + (setq org-index--saved-positions nil)) + + +(defun org-index--delete-ref-from-heading (ref) + "Delete given REF from current heading." + (save-excursion + (end-of-line) + (let ((end (point))) + (beginning-of-line) + (when (search-forward ref end t) + (delete-char (- (length ref))) + (just-one-space))))) + + +(defun org-index--delete-any-ref-from-tags () + "Delete any reference from list of tags." + (let (new-tags) + (mapc (lambda (tag) + (unless (string-match org-index--ref-regex tag) + (setq new-tags (cons tag new-tags) ))) + (org-get-tags)) + (org-set-tags-to new-tags))) (defun org-index--go (&optional column value) "Position cursor on index line where COLUMN equals VALUE. Return t or nil, leave point on line or at top of table, needs to be in buffer initially." - (let (found text) + (let (found) (unless (eq (current-buffer) org-index--buffer) (error "This is a bug: Not in index buffer")) @@ -2031,11 +2475,9 @@ Return t or nil, leave point on line or at top of table, needs to be in buffer i nil))) -(defun org-index--do-head (ref id &optional other) +(defun org-index--find-id (id &optional other) "Perform command head: Find node with REF or ID and present it. If OTHER in separate window." - - (setq org-index--last-ref ref) (let (message marker) @@ -2044,25 +2486,27 @@ If OTHER in separate window." (if marker (progn (org-index--update-line id) - (let (cb) - (if other - (progn - (setq cb (current-buffer)) - (pop-to-buffer (marker-buffer marker))) - (pop-to-buffer-same-window (marker-buffer marker))) - - (goto-char marker) - (org-reveal t) - (org-show-entry) - (recenter)) - (setq message (format "Found headline %s" ref))) - (setq message (format "Did not find headline %s" ref))))) + (if other + (progn + (pop-to-buffer (marker-buffer marker))) + (pop-to-buffer-same-window (marker-buffer marker))) + + (goto-char marker) + (org-reveal t) + (org-show-entry) + (recenter) + (unless (string= (org-id-get) id) + (setq message (format "Could not go to node with id %s (narrowed ?)" id))) + (setq message "Found headline")) + (setq message (format "Did not find node with %s" id))) + message)) (defun org-index--do-occur () "Perform command occur." (let ((word "") ; last word to search for growing and shrinking on keystrokes (prompt "Search for: ") + (these-commands " NOTE: If you invoke the org-index subcommands edit or kill from within the occur buffer, the index is updated accordingly.") (lines-wanted (window-body-height)) (lines-found 0) ; number of lines found words ; list words that should match @@ -2070,22 +2514,24 @@ If OTHER in separate window." begin ; position of first line narrow ; start of narrowed buffer help-text ; cons with help text short and long - key-help ; for keys with special function search-text ; description of text to search for done ; true, if loop is done in-c-backspace ; true, while processing C-backspace - show-headings ; true, if headings should be shown help-overlay ; Overlay with help text last-point ; Last position before end of search - key ; input from user - key-sequence) ; as a sequence + initial-frame ; Frame when starting occur + key ; input from user in various forms + key-sequence + key-sequence-raw) + - ;; make and show buffer (if (get-buffer org-index--occur-buffer-name) (kill-buffer org-index--occur-buffer-name)) (setq occur-buffer (make-indirect-buffer org-index--buffer org-index--occur-buffer-name)) (pop-to-buffer-same-window occur-buffer) + (setq initial-frame (selected-frame)) + ;; avoid modifying direct buffer (setq buffer-read-only t) (toggle-truncate-lines 1) @@ -2095,9 +2541,9 @@ If OTHER in separate window." ;; reset stack and overlays (setq org-index--occur-stack nil) (setq org-index--occur-tail-overlay nil) - + ;; narrow to table rows and one line before - (goto-char (marker-position org-index--below-hline)) + (goto-char org-index--below-hline) (forward-line 0) (setq begin (point)) (forward-line -1) @@ -2110,17 +2556,20 @@ If OTHER in separate window." ;; initialize help text (setq help-text (cons - "Incremental occur; `?' toggles help and headlines.\n" (concat - (org-index--wrap - (concat - "Normal keys add to search word; <space> or <comma> start additional word; <backspace> erases last char, <C-backspace> last word; <return> jumps to heading, <tab> jumps to heading in other window; all other keys end search.\n")) + (propertize "Incremental occur" 'face 'org-todo) + (propertize "; ? toggles help and headlines.\n" 'face 'org-agenda-dimmed-todo-face)) + (concat + (propertize + (org-index--wrap + (concat + "Normal keys add to search word; <space> or <comma> start additional word; <backspace> erases last char, <C-backspace> last word; <return> jumps to heading, <tab> jumps to heading in other window, <S-return> jumps to matching line in index; all other keys end search." these-commands "\n")) + 'face 'org-agenda-dimmed-todo-face) org-index--headings))) - + ;; insert overlays for help text and to cover unsearched lines (setq help-overlay (make-overlay (point-min) begin)) (overlay-put help-overlay 'display (car help-text)) - (overlay-put help-overlay 'face 'org-agenda-dimmed-todo-face) (setq org-index--occur-tail-overlay (make-overlay (point-max) (point-max))) (overlay-put org-index--occur-tail-overlay 'invisible t) @@ -2129,14 +2578,25 @@ If OTHER in separate window." (if in-c-backspace (setq key "<backspace>") (setq search-text (mapconcat 'identity (reverse (cons word words)) ",")) - ;; read key - (setq key-sequence - (vector (read-key - (format "%s%s%s" - prompt - search-text - (if (string= search-text "") "" " "))))) - (setq key (key-description key-sequence))) + (message "foo") + + ;; read key, if selected frame has not changed + (if (eq initial-frame (selected-frame)) + (progn + (setq key-sequence + (let ((echo-keystrokes 0) + (full-prompt (format "%s%s%s" + prompt + search-text + (if (string= search-text "") "" " ")))) + (read-key-sequence full-prompt nil nil t t))) + (setq key (key-description key-sequence)) + (setq key-sequence-raw (this-single-command-raw-keys))) + (setq done t) + (setq key-sequence nil) + (setq key nil) + (setq key-sequence-raw nil))) + (cond @@ -2168,11 +2628,11 @@ If OTHER in separate window." ;; free top list of overlays and remove list (setq lines-found (or (org-index--unhide) lines-wanted)) (move-overlay org-index--occur-tail-overlay - (if org-index--occur-stack (cdr (assoc :end-of-visible (car org-index--occur-stack))) + (if org-index--occur-stack (cdr (assq :end-of-visible (car org-index--occur-stack))) (point-max)) (point-max)) - - + + ;; highlight shorter word (unless (= (length word) 0) (highlight-regexp (regexp-quote word) 'isearch)) @@ -2184,8 +2644,9 @@ If OTHER in separate window." ((member key (list "SPC" ",")) ; space or comma: enter an additional search word ;; push current word and clear, no need to change display - (setq words (cons word words)) - (setq word "")) + (unless (string= word "") + (setq words (cons word words)) + (setq word ""))) ((string= key "?") ; question mark: toggle display of headlines and help @@ -2201,17 +2662,17 @@ If OTHER in separate window." ;; add to word (setq word (concat word key)) - + ;; make overlays to hide lines, that do not match longer word any more (goto-char begin) (setq lines-found (org-index--hide-with-overlays (cons word words) lines-wanted)) (move-overlay org-index--occur-tail-overlay - (if org-index--occur-stack (cdr (assoc :end-of-visible (car org-index--occur-stack))) + (if org-index--occur-stack (cdr (assq :end-of-visible (car org-index--occur-stack))) (point-max)) (point-max)) - + (goto-char begin) - + ;; highlight longer word (highlight-regexp (regexp-quote word) 'isearch) @@ -2224,18 +2685,18 @@ If OTHER in separate window." ;; put back input event, that caused the loop to end (unless (string= key "C-g") - (setq unread-command-events (listify-key-sequence key-sequence)) + (setq unread-command-events (listify-key-sequence key-sequence-raw)) (message key)) - + ;; postprocessing (setq last-point (point)) - + ;; For performance reasons do not show matching lines for rest of table. So no code here. - + ;; make permanent copy ;; copy visible lines (let ((lines-collected 0) - keymap line all-lines end-of-head) + keymap line all-lines all-lines-lbp header-lines lbp) (setq cursor-type t) (goto-char begin) @@ -2247,51 +2708,67 @@ If OTHER in separate window." (while (and (invisible-p (point)) (not (eobp))) (goto-char (1+ (overlay-end (car (overlays-at (point))))))) - (setq line (buffer-substring (line-beginning-position) (line-end-position))) + (setq lbp (line-beginning-position)) + (setq line (buffer-substring-no-properties lbp (line-end-position))) (unless (string= line "") - (incf lines-collected) + (cl-incf lines-collected) (setq all-lines (cons (concat line "\n") - all-lines))) + all-lines)) + (setq all-lines-lbp (cons lbp all-lines-lbp))) (forward-line 1)) - + (kill-buffer org-index--occur-buffer-name) ; cannot keep this buffer; might become stale soon ;; create new buffer (setq occur-buffer (get-buffer-create org-index--occur-buffer-name)) (pop-to-buffer-same-window occur-buffer) (insert org-index--headings) - (setq end-of-head (point)) + (setq header-lines (line-number-at-pos)) ;; insert into new buffer (save-excursion (apply 'insert (reverse all-lines)) (if (= lines-collected lines-wanted) (insert "\n(more lines omitted)\n"))) - + (setq org-index--occur-lines-collected lines-collected) + (org-mode) (setq truncate-lines t) - (if (org-at-table-p) (org-table-align)) - (font-lock-fontify-buffer) + (if all-lines (org-index--align-and-fontify-current-line (length all-lines))) + (font-lock-ensure) + (font-lock-flush) + (when all-lines-lbp + (while (not (org-at-table-p)) + (forward-line -1)) + (while all-lines-lbp + (put-text-property (line-beginning-position) (line-end-position) 'org-index-lbp (car all-lines-lbp)) + (setq all-lines-lbp (cdr all-lines-lbp)) + (forward-line -1))) ;; prepare help text - (setq org-index--occur-help-overlay (make-overlay (point-min) end-of-head)) + (goto-char (point-min)) + (forward-line (1- header-lines)) + (setq org-index--occur-help-overlay (make-overlay (point-min) (point))) (setq org-index--occur-help-text (cons (org-index--wrap - (concat "Search is done; `?' toggles help and headlines.\n")) + (propertize "Search is done; ? toggles help and headlines.\n" 'face 'org-agenda-dimmed-todo-face)) (concat - (org-index--wrap (format (concat "Search is done. " - (if (< lines-collected lines-wanted) - " Showing all %d matches for " - " Showing one window of matches for ") - "\"" search-text - "\". <return> jumps to heading, <tab> jumps to heading in other window, <S-return> to matching line in index, <space> increments count.\n" ) - (length all-lines))) + (org-index--wrap + (propertize + (format + (concat "Search is done." + (if (< lines-collected lines-wanted) + " Showing all %d matches for " + " Showing one window of matches for ") + "\"" search-text + "\". <return> jumps to heading, <tab> jumps to heading in other window, <S-return> jumps to matching line in index, <space> increments count.\n" these-commands "\n") + (length all-lines)) + 'face 'org-agenda-dimmed-todo-face)) org-index--headings))) - + (overlay-put org-index--occur-help-overlay 'display (car org-index--occur-help-text)) - (overlay-put org-index--occur-help-overlay 'face 'org-agenda-dimmed-todo-face) ;; highlight words (setq case-fold-search t) @@ -2307,15 +2784,16 @@ If OTHER in separate window." (mapc (lambda (x) (define-key keymap (kbd x) (lambda () (interactive) - (message "%s" (org-index--occur-to-head))))) + (message "%s" (org-index--occur-action))))) (list "<return>" "RET")) (define-key keymap (kbd "<tab>") (lambda () (interactive) - (message (org-index--occur-to-head t)))) - + (message (org-index--occur-action t)))) + (define-key keymap (kbd "SPC") (lambda () (interactive) + (org-index--refresh-parse-table) ;; increment in index (let ((ref (org-index--get-or-set-field 'ref)) count) @@ -2329,19 +2807,44 @@ If OTHER in separate window." (let ((inhibit-read-only t)) (org-index--get-or-set-field 'count (number-to-string count))) (message "Incremented count to %d" count)))) - + (define-key keymap (kbd "<S-return>") (lambda () (interactive) - (org-index 'enter (org-index--get-or-set-field 'ref)))) - + (let ((pos (get-text-property (point) 'org-index-lbp))) + (org-index--refresh-parse-table) + (org-index--occur-test-stale pos) + (pop-to-buffer org-index--buffer) + (goto-char pos) + (org-reveal t) + (org-index--update-current-line) + (beginning-of-line)))) + (define-key keymap (kbd "?") (lambda () (interactive) + (org-index--refresh-parse-table) (setq-local org-index--occur-help-text (cons (cdr org-index--occur-help-text) (car org-index--occur-help-text))) (overlay-put org-index--occur-help-overlay 'display (car org-index--occur-help-text)))) - + (use-local-map keymap)))) +(defun org-index--occur-test-stale (pos) + "Test, if current line in occur buffer has become stale at POS." + (let (here there) + (org-index--refresh-parse-table) + (setq here (org-index--line-in-canonical-form)) + (with-current-buffer org-index--buffer + (goto-char pos) + (setq there (org-index--line-in-canonical-form))) + (unless (string= here there) + (error "Occur buffer has become stale")))) + + +(defun org-index--line-in-canonical-form () + "Return current line in its canonical form." + (org-trim (substring-no-properties (replace-regexp-in-string "\s +" " " (buffer-substring (line-beginning-position) (line-beginning-position 2)))))) + + (defun org-index--wrap (text) "Wrap TEXT at fill column." (with-temp-buffer @@ -2350,13 +2853,27 @@ If OTHER in separate window." (buffer-string))) -(defun org-index--occur-to-head (&optional other) - "Helper for `org-index--occur', find heading with ref or id; if OTHER, in other window." - (let ((ref (org-index--get-or-set-field 'ref)) - (id (org-index--get-or-set-field 'id))) - (if id - (org-index--do-head ref id other) - (message "Current line has no id.")))) +(defun org-index--occur-action (&optional other) + "Helper for `org-index--occur', find heading with ref or id; if OTHER, in other window; or copy yank column." + (if (org-at-table-p) + (let ((id (org-index--get-or-set-field 'id)) + (ref (org-index--get-or-set-field 'ref)) + (yank (org-index--get-or-set-field 'yank))) + (if id + (org-index--find-id id other) + (if ref + (progn + (org-mark-ring-goto) + (format "Found reference %s (no node is associated)" ref)) + (if yank + (progn + (org-index--update-line (get-text-property (point) 'org-index-lbp)) + (setq yank (replace-regexp-in-string (regexp-quote "\\vert") "|" yank nil 'literal)) + (kill-new yank) + (org-mark-ring-goto) + (format "Copied '%s' (no node is associated)" yank)) + (error "Internal error, this line contains neither id, nor reference, nor text to yank"))))) + (message "Not at table"))) (defun org-index--hide-with-overlays (words lines-wanted) @@ -2398,8 +2915,8 @@ If OTHER in separate window." (when matched (forward-line 1) (setq end-of-visible (point)) - (incf lines-found))) - + (cl-incf lines-found))) + ;; put new list on top of stack (setq org-index--occur-stack (cons (list (cons :overlays overlays) @@ -2416,11 +2933,11 @@ If OTHER in separate window." ;; delete overlays and make visible again (mapc (lambda (y) (delete-overlay y)) - (cdr (assoc :overlays (car org-index--occur-stack)))) + (cdr (assq :overlays (car org-index--occur-stack)))) ;; remove from stack (setq org-index--occur-stack (cdr org-index--occur-stack)) ;; return number of lines, that are now visible - (if org-index--occur-stack (cdr (assoc :lines (car org-index--occur-stack)))))) + (if org-index--occur-stack (cdr (assq :lines (car org-index--occur-stack)))))) (defun org-index--test-words (words) @@ -2429,7 +2946,7 @@ If OTHER in separate window." (setq line (downcase (buffer-substring (line-beginning-position) (line-beginning-position 2)))) (catch 'not-found (dolist (w words) - (or (search w line) + (or (cl-search w line) (throw 'not-found nil))) t))) @@ -2437,29 +2954,21 @@ If OTHER in separate window." (defun org-index--create-new-line () "Do the common work for `org-index-new-line' and `org-index'." - (let (new) - - ;; construct new reference - (unless new - (setq new (format "%s%d%s" org-index--head (1+ org-index--maxref) org-index--tail))) - - ;; insert ref or id as last or first line, depending on sort-column - (goto-char org-index--below-hline) - (if (eq (org-index--special-column 'sort) 'count) - (progn - (while (org-at-table-p) - (forward-line)) - (forward-line -1) - (org-table-insert-row t)) - (org-table-insert-row)) - - ;; insert some of the standard values - (org-table-goto-column (org-index--column-num 'created)) - (org-insert-time-stamp nil nil t) - (org-table-goto-column (org-index--column-num 'count)) - (insert "1") + ;; insert ref or id as last or first line, depending on sort-column + (goto-char org-index--below-hline) + (if (eq org-index-sort-by 'count) + (progn + (while (org-at-table-p) + (forward-line)) + (forward-line -1) + (org-table-insert-row t)) + (org-table-insert-row)) - new)) + ;; insert some of the standard values + (org-table-goto-column (org-index--column-num 'created)) + (org-insert-time-stamp nil nil t) + (org-table-goto-column (org-index--column-num 'count)) + (insert "1")) (defun org-index--sort-silent () @@ -2468,13 +2977,13 @@ If OTHER in separate window." (org-index--verify-id) (org-index--parse-table) (org-index--on nil nil - (org-index--do-sort-index (org-index--special-column 'sort)) + (org-index--do-sort-index org-index-sort-by) (org-table-align) (remove-hook 'before-save-hook 'org-index--sort-silent)))) (defun org-index--copy-visible (beg end) - "Copy the visible parts of the region without adding it to kill-ring; copy of `org-copy-visible'" + "Copy the visible parts of the region between BEG and END without adding it to `kill-ring'; copy of `org-copy-visible'." (let (snippets s) (save-excursion (save-restriction diff --git a/contrib/lisp/org-interactive-query.el b/contrib/lisp/org-interactive-query.el index 42ff7fd..928c801 100644 --- a/contrib/lisp/org-interactive-query.el +++ b/contrib/lisp/org-interactive-query.el @@ -81,7 +81,7 @@ not change the current one." (split-window-vertically) (org-switch-to-buffer-other-window (get-buffer-create " *Org tags*"))) (erase-buffer) - (org-set-local 'org-done-keywords done-keywords) + (setq-local org-done-keywords done-keywords) (insert "Query: " current "\n") (org-agenda-query-op-line op) (insert "\n\n") diff --git a/contrib/lisp/org-invoice.el b/contrib/lisp/org-invoice.el index c1340a7..4c83d2e 100644 --- a/contrib/lisp/org-invoice.el +++ b/contrib/lisp/org-invoice.el @@ -176,8 +176,8 @@ looks like tree2, where the level is 2." "Return a list where the car is the min level, and the cdr the max." (let ((max 0) min level) (dolist (info ls) - (when (cdr (assoc 'date info)) - (setq level (cdr (assoc 'level info))) + (when (cdr (assq 'date info)) + (setq level (cdr (assq 'level info))) (when (or (not min) (< level min)) (setq min level)) (when (> level max) (setq max level)))) (cons (or min 0) max))) @@ -186,11 +186,11 @@ looks like tree2, where the level is 2." "Reorganize the given list by dates." (let ((min-max (org-invoice-level-min-max ls)) new) (dolist (info ls) - (let* ((date (cdr (assoc 'date info))) - (work (cdr (assoc 'work info))) - (price (cdr (assoc 'price info))) - (long-date (cdr (assoc 'long-date info))) - (level (cdr (assoc 'level info))) + (let* ((date (cdr (assq 'date info))) + (work (cdr (assq 'work info))) + (price (cdr (assq 'price info))) + (long-date (cdr (assq 'long-date info))) + (level (cdr (assq 'level info))) (bucket (cdr (assoc date new)))) (if (and (/= (car min-max) (cdr min-max)) (= (car min-max) level) @@ -208,19 +208,19 @@ looks like tree2, where the level is 2." (push (cons date bucket) new) (setq bucket (cdr (assoc date new)))) (when (and date bucket) - (setcdr (assoc 'total-work (car bucket)) - (+ work (cdr (assoc 'total-work (car bucket))))) - (setcdr (assoc 'price (car bucket)) - (+ price (cdr (assoc 'price (car bucket))))) + (setcdr (assq 'total-work (car bucket)) + (+ work (cdr (assq 'total-work (car bucket))))) + (setcdr (assq 'price (car bucket)) + (+ price (cdr (assq 'price (car bucket))))) (nconc bucket (list info)))))) (nreverse new))) (defun org-invoice-info-to-table (info) "Create a single org table row from the given info alist." - (let ((title (cdr (assoc 'title info))) - (total (cdr (assoc 'total-work info))) - (work (cdr (assoc 'work info))) - (price (cdr (assoc 'price info))) + (let ((title (cdr (assq 'title info))) + (total (cdr (assq 'total-work info))) + (work (cdr (assq 'work info))) + (price (cdr (assq 'price info))) (with-price (plist-get org-invoice-table-params :price))) (unless total (setq diff --git a/contrib/lisp/org-link-edit.el b/contrib/lisp/org-link-edit.el index e69de29..431c934 100644 --- a/contrib/lisp/org-link-edit.el +++ b/contrib/lisp/org-link-edit.el @@ -0,0 +1,327 @@ +;;; org-link-edit.el --- Slurp and barf with Org links -*- lexical-binding: t; -*- + +;; Copyright (C) 2015 Kyle Meyer <kyle@kyleam.com> + +;; Author: Kyle Meyer <kyle@kyleam.com> +;; URL: https://github.com/kyleam/org-link-edit +;; Keywords: convenience +;; Version: 1.0.1 +;; Package-Requires: ((cl-lib "0.5") (org "8.2")) + +;; 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 of the License, 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. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Org Link Edit provides Paredit-inspired slurping and barfing +;; commands for Org link descriptions. +;; +;; There are four commands, all which operate when point is on an Org +;; link. +;; +;; - org-link-edit-forward-slurp +;; - org-link-edit-backward-slurp +;; - org-link-edit-forward-barf +;; - org-link-edit-backward-barf +;; +;; Org Link Edit doesn't bind these commands to any keys. Finding +;; good keys for these commands is difficult because, while it's +;; convenient to be able to quickly repeat these commands, they won't +;; be used frequently enough to be worthy of a short, repeat-friendly +;; binding. Using Hydra [1] provides a nice solution to this. After +;; an initial key sequence, any of the commands will be repeatable +;; with a single key. (Plus, you get a nice interface that displays +;; the key for each command.) Below is one example of how you could +;; configure this. +;; +;; (define-key org-mode-map YOUR-KEY +;; (defhydra hydra-org-link-edit () +;; "Org Link Edit" +;; ("j" org-link-edit-forward-slurp "forward slurp") +;; ("k" org-link-edit-forward-barf "forward barf") +;; ("u" org-link-edit-backward-slurp "backward slurp") +;; ("i" org-link-edit-backward-barf "backward barf") +;; ("q" nil "cancel"))) +;; +;; [1] https://github.com/abo-abo/hydra + +;;; Code: + +(require 'org) +(require 'org-element) +(require 'cl-lib) + +(defun org-link-edit--get-link-data () + "Return list with information about the link at point. +The list includes +- the position at the start of the link +- the position at the end of the link +- the link text +- the link description (nil when on a plain link)" + (let ((el (org-element-context))) + ;; Don't use `org-element-lineage' because it isn't available + ;; until Org version 8.3. + (while (and el (not (memq (car el) '(link)))) + (setq el (org-element-property :parent el))) + (unless (eq (car el) 'link) + (user-error "Point is not on a link")) + (save-excursion + (goto-char (org-element-property :begin el)) + (cond + ;; Use match-{beginning,end} because match-end is consistently + ;; positioned after ]], while the :end property is positioned + ;; at the next word on the line, if one is present. + ((looking-at org-bracket-link-regexp) + (list (match-beginning 0) + (match-end 0) + (org-link-unescape (match-string-no-properties 1)) + (or (and (match-end 3) + (match-string-no-properties 3)) + ""))) + ((looking-at org-plain-link-re) + (list (match-beginning 0) + (match-end 0) + (org-link-unescape (match-string-no-properties 0)) + nil)) + (t + (error "What am I looking at?")))))) + +(defun org-link-edit--forward-blob (n &optional no-punctuation) + "Move forward N blobs (backward if N is negative). + +A block of non-whitespace characters is a blob. If +NO-PUNCTUATION is non-nil, trailing punctuation characters are +not considered part of the blob when going in the forward +direction. + +If the edge of the buffer is reached before completing the +movement, return nil. Otherwise, return t." + (let* ((forward-p (> n 0)) + (nblobs (abs n)) + (skip-func (if forward-p 'skip-syntax-forward 'skip-syntax-backward)) + skip-func-retval) + (while (/= nblobs 0) + (funcall skip-func " ") + (setq skip-func-retval (funcall skip-func "^ ")) + (setq nblobs (1- nblobs))) + (when (and forward-p no-punctuation) + (let ((punc-tail-offset (save-excursion (skip-syntax-backward ".")))) + ;; Don't consider trailing punctuation as part of the blob + ;; unless the whole blob consists of punctuation. + (unless (= skip-func-retval (- punc-tail-offset)) + (goto-char (+ (point) punc-tail-offset))))) + (/= skip-func-retval 0))) + +;;;###autoload +(defun org-link-edit-forward-slurp (&optional n) + "Slurp N trailing blobs into link's description. + + The \[\[http://orgmode.org/\]\[Org mode\]\] site + + | + v + + The \[\[http://orgmode.org/\]\[Org mode site\]\] + +A blob is a block of non-whitespace characters. When slurping +forward, trailing punctuation characters are not considered part +of a blob. + +After slurping, return the slurped text and move point to the +beginning of the link. + +If N is negative, slurp leading blobs instead of trailing blobs." + (interactive "p") + (setq n (or n 1)) + (cond + ((= n 0)) + ((< n 0) + (org-link-edit-backward-slurp (- n))) + (t + (cl-multiple-value-bind (beg end link desc) (org-link-edit--get-link-data) + (goto-char (save-excursion + (goto-char end) + (or (org-link-edit--forward-blob n 'no-punctuation) + (user-error "Not enough blobs after the link")) + (point))) + (let ((slurped (buffer-substring-no-properties end (point)))) + (setq slurped (replace-regexp-in-string "\n+" " " slurped)) + (when (and (= (length desc) 0) + (string-match "^\\s-+\\(.*\\)" slurped)) + (setq slurped (match-string 1 slurped))) + (setq desc (concat desc slurped) + end (+ end (length slurped))) + (delete-region beg (point)) + (insert (org-make-link-string link desc)) + (goto-char beg) + slurped))))) + +;;;###autoload +(defun org-link-edit-backward-slurp (&optional n) + "Slurp N leading blobs into link's description. + + The \[\[http://orgmode.org/\]\[Org mode\]\] site + + | + v + + \[\[http://orgmode.org/\]\[The Org mode\]\] site + +A blob is a block of non-whitespace characters. + +After slurping, return the slurped text and move point to the +beginning of the link. + +If N is negative, slurp trailing blobs instead of leading blobs." + (interactive "p") + (setq n (or n 1)) + (cond + ((= n 0)) + ((< n 0) + (org-link-edit-forward-slurp (- n))) + (t + (cl-multiple-value-bind (beg end link desc) (org-link-edit--get-link-data) + (goto-char (save-excursion + (goto-char beg) + (or (org-link-edit--forward-blob (- n)) + (user-error "Not enough blobs before the link")) + (point))) + (let ((slurped (buffer-substring-no-properties (point) beg))) + (when (and (= (length desc) 0) + (string-match "\\(.*\\)\\s-+$" slurped)) + (setq slurped (match-string 1 slurped))) + (setq slurped (replace-regexp-in-string "\n+" " " slurped)) + (setq desc (concat slurped desc) + beg (- beg (length slurped))) + (delete-region (point) end) + (insert (org-make-link-string link desc)) + (goto-char beg) + slurped))))) + +(defun org-link-edit--split-first-blobs (string n) + "Split STRING into (N first blobs . other) cons cell. +'N first blobs' contains all text from the start of STRING up to +the start of the N+1 blob. 'other' includes the remaining text +of STRING. If the number of blobs in STRING is fewer than N, +'other' is nil." + (when (< n 0) (user-error "N cannot be negative")) + (with-temp-buffer + (insert string) + (goto-char (point-min)) + (with-syntax-table org-mode-syntax-table + (let ((within-bound (org-link-edit--forward-blob n))) + (skip-syntax-forward " ") + (cons (buffer-substring 1 (point)) + (and within-bound + (buffer-substring (point) (point-max)))))))) + +(defun org-link-edit--split-last-blobs (string n) + "Split STRING into (other . N last blobs) cons cell. +'N last blobs' contains all text from the end of STRING back to +the end of the N+1 last blob. 'other' includes the remaining +text of STRING. If the number of blobs in STRING is fewer than +N, 'other' is nil." + (when (< n 0) (user-error "N cannot be negative")) + (with-temp-buffer + (insert string) + (goto-char (point-max)) + (with-syntax-table org-mode-syntax-table + (let ((within-bound (org-link-edit--forward-blob (- n)))) + (skip-syntax-backward " ") + (cons (and within-bound + (buffer-substring 1 (point))) + (buffer-substring (point) (point-max))))))) + +;;;###autoload +(defun org-link-edit-forward-barf (&optional n) + "Barf N trailing blobs from link's description. + + The \[\[http://orgmode.org/\]\[Org mode\]\] site + + | + v + + The \[\[http://orgmode.org/\]\[Org\]\] mode site + +A blob is a block of non-whitespace characters. + +After barfing, return the barfed text and move point to the +beginning of the link. + +If N is negative, barf leading blobs instead of trailing blobs." + (interactive "p") + (setq n (or n 1)) + (cond + ((= n 0)) + ((< n 0) + (org-link-edit-backward-barf (- n))) + (t + (cl-multiple-value-bind (beg end link desc) (org-link-edit--get-link-data) + (when (= (length desc) 0) + (user-error "Link has no description")) + (pcase-let ((`(,new-desc . ,barfed) (org-link-edit--split-last-blobs + desc n))) + (unless new-desc (user-error "Not enough blobs in description")) + (delete-region beg end) + (insert (org-make-link-string link new-desc)) + (if (string= new-desc "") + ;; Two brackets are dropped when an empty description is + ;; passed to `org-make-link-string'. + (progn (goto-char (- end (+ 2 (length desc)))) + (setq barfed (concat " " barfed))) + (goto-char (- end (- (length desc) (length new-desc))))) + (insert barfed) + (goto-char beg) + barfed))))) + +;;;###autoload +(defun org-link-edit-backward-barf (&optional n) + "Barf N leading blobs from link's description. + + The \[\[http://orgmode.org/\]\[Org mode\]\] site + + | + v + + The Org \[\[http://orgmode.org/\]\[mode\]\] site + +A blob is a block of non-whitespace characters. + +After barfing, return the barfed text and move point to the +beginning of the link. + +If N is negative, barf trailing blobs instead of leading blobs." + (interactive "p") + (setq n (or n 1)) + (cond + ((= n 0)) + ((< n 0) + (org-link-edit-forward-barf (- n))) + (t + (cl-multiple-value-bind (beg end link desc) (org-link-edit--get-link-data) + (when (= (length desc) 0) + (user-error "Link has no description")) + (pcase-let ((`(,barfed . ,new-desc) (org-link-edit--split-first-blobs + desc n))) + (unless new-desc (user-error "Not enough blobs in description")) + (delete-region beg end) + (insert (org-make-link-string link new-desc)) + (when (string= new-desc "") + (setq barfed (concat barfed " "))) + (goto-char beg) + (insert barfed) + (goto-char (+ beg (length barfed))) + barfed))))) + +(provide 'org-link-edit) +;;; org-link-edit.el ends here diff --git a/contrib/lisp/org-mac-link.el b/contrib/lisp/org-mac-link.el index 56d67e1..ae2def3 100644 --- a/contrib/lisp/org-mac-link.el +++ b/contrib/lisp/org-mac-link.el @@ -18,6 +18,18 @@ ;; Author: Mike McLean <mike.mclean@pobox.com> ;; Add support for Microsoft Outlook for Mac as Org mode links ;; +;; Version: 1.3 +;; Author: Alan Schmitt <alan.schmitt@polytechnique.org> +;; Consistently use `org-mac-paste-applescript-links' +;; +;; Version 1.4 +;; Author: Mike McLean <mike.mclean@pobox.com> +;; Make the path to Microsoft Outlook a `defcustom' +;; +;; Version 1.5 +;; Author: Mike McLean <mike.mclean@pobox.com> +;; Add Support for Evernote +;; ;; This file is not part of GNU Emacs. ;; ;; This program is free software; you can redistribute it and/or modify @@ -58,6 +70,7 @@ ;; Skim.app - Grab a link to the selected page in the topmost pdf document ;; Microsoft Outlook.app - Grab a link to the selected message in the message list ;; DEVONthink Pro Office.app - Grab a link to the selected DEVONthink item(s); open DEVONthink item by reference +;; Evernote.app - Grab a link to the selected Evernote item(s); open Evernote item by ID ;; ;; ;; Installation: @@ -109,6 +122,12 @@ :group 'org-mac-link :type 'boolean) +(defcustom org-mac-outlook-path "/Applications/Microsoft Outlook.app" + "The path to the installed copy of Microsoft Outlook.app. Do not escape spaces as the AppleScript call will quote this string." + :tag "Path to Microsoft Outlook" + :group 'org-mac-link + :type 'string) + (defcustom org-mac-grab-devonthink-app-p t "Add menu option [d]EVONthink to grab links from DEVONthink Pro Office.app." :tag "Grab DEVONthink Pro Office.app links" @@ -165,6 +184,12 @@ :group 'org-mac-link :type 'boolean) +(defcustom org-mac-grab-Acrobat-app-p t + "Add menu option [A]crobat to grab page links from Acrobat.app." + :tag "Grab Acrobat.app page links" + :group 'org-mac-link + :type 'boolean) + (defgroup org-mac-flagged-mail nil "Options foring linking to flagged Mail.app messages." :tag "Org Mail.app" @@ -175,6 +200,23 @@ :group 'org-mac-flagged-mail :type 'string) +(defcustom org-mac-grab-Evernote-app-p + (< 0 (length (shell-command-to-string + "mdfind kMDItemCFBundleIdentifier == 'com.evernote.Evernote'"))) + "Add menu option [e]vernote to grab note links from Evernote.app." + :tag "Grab Evernote.app note links" + :group 'org-mac-link + :type 'boolean) + +(defcustom org-mac-evernote-path (replace-regexp-in-string (rx (* (any " \t\n")) eos) + "" + (shell-command-to-string + "mdfind kMDItemCFBundleIdentifier == 'com.evernote.Evernote'")) + "The path to the installed copy of Evernote.app. Do not escape spaces as the AppleScript call will quote this string." + :tag "Path to Evernote" + :group 'org-mac-link + :type 'string) + ;; In mac.c, removed in Emacs 23. (declare-function do-applescript "org-mac-message" (script)) @@ -206,13 +248,15 @@ When done, go grab the link, and insert it at point." ("f" "irefox" org-mac-firefox-insert-frontmost-url ,org-mac-grab-Firefox-app-p) ("v" "imperator" org-mac-vimperator-insert-frontmost-url ,org-mac-grab-Firefox+Vimperator-p) ("c" "hrome" org-mac-chrome-insert-frontmost-url ,org-mac-grab-Chrome-app-p) + ("e" "evernote" org-mac-evernote-note-insert-selected ,org-mac-grab-Evernote-app-p) ("t" "ogether" org-mac-together-insert-selected ,org-mac-grab-Together-app-p) - ("S" "kim" org-mac-skim-insert-page ,org-mac-grab-Skim-app-p))) + ("S" "kim" org-mac-skim-insert-page ,org-mac-grab-Skim-app-p) + ("A" "crobat" org-mac-acrobat-insert-page ,org-mac-grab-Acrobat-app-p))) (menu-string (make-string 0 ?x)) input) ;; Create the menu string for the keymap - (mapc '(lambda (descriptor) + (mapc (lambda (descriptor) (when (elt descriptor 3) (setf menu-string (concat menu-string "[" (elt descriptor 0) "]" @@ -223,7 +267,7 @@ When done, go grab the link, and insert it at point." ;; Prompt the user, and grab the link (message menu-string) (setq input (read-char-exclusive)) - (mapc '(lambda (descriptor) + (mapc (lambda (descriptor) (let ((key (elt (elt descriptor 0) 0)) (active (elt descriptor 3)) (grab-function (elt descriptor 2))) @@ -299,15 +343,7 @@ The links are of the form <link>::split::<name>." (defun org-mac-firefox-get-frontmost-url () (interactive) (message "Applescript: Getting Firefox url...") - (let* ((url-and-title (org-as-mac-firefox-get-frontmost-url)) - (split-link (split-string url-and-title "::split::")) - (URL (car split-link)) - (description (cadr split-link)) - (org-link)) - (when (not (string= URL "")) - (setq org-link (org-make-link-string URL description))) - (kill-new org-link) - org-link)) + (org-mac-paste-applescript-links (org-as-mac-firefox-get-frontmost-url))) (defun org-mac-firefox-insert-frontmost-url () (interactive) @@ -345,15 +381,7 @@ The links are of the form <link>::split::<name>." (defun org-mac-vimperator-get-frontmost-url () (interactive) (message "Applescript: Getting Vimperator url...") - (let* ((url-and-title (org-as-mac-vimperator-get-frontmost-url)) - (split-link (split-string url-and-title "::split::")) - (URL (car split-link)) - (description (cadr split-link)) - (org-link)) - (when (not (string= URL "")) - (setq org-link (org-make-link-string URL description))) - (kill-new org-link) - org-link)) + (org-mac-paste-applescript-links (org-as-mac-vimperator-get-frontmost-url))) (defun org-mac-vimperator-insert-frontmost-url () (interactive) @@ -383,15 +411,7 @@ The links are of the form <link>::split::<name>." (defun org-mac-chrome-get-frontmost-url () (interactive) (message "Applescript: Getting Chrome url...") - (let* ((url-and-title (org-as-mac-chrome-get-frontmost-url)) - (split-link (split-string url-and-title "::split::")) - (URL (car split-link)) - (description (cadr split-link)) - (org-link)) - (when (not (string= URL "")) - (setq org-link (org-make-link-string URL description))) - (kill-new org-link) - org-link)) + (org-mac-paste-applescript-links (org-as-mac-chrome-get-frontmost-url))) (defun org-mac-chrome-insert-frontmost-url () (interactive) @@ -422,8 +442,7 @@ The links are of the form <link>::split::<name>." ;; Handle links from together.app - -(org-add-link-type "x-together-item" 'org-mac-together-item-open) +(org-link-set-parameters "x-together-item" :follow #'org-mac-together-item-open) (defun org-mac-together-item-open (uid) "Open UID, which is a reference to an item in Together." @@ -478,8 +497,7 @@ The links are of the form <link>::split::<name>." ;; Handle links from AddressBook.app - -(org-add-link-type "addressbook" 'org-mac-addressbook-item-open) +(org-link-set-parameters "addressbook" :follow #'org-mac-addressbook-item-open) (defun org-mac-addressbook-item-open (uid) "Open UID, which is a reference to an item in the addressbook." @@ -512,7 +530,7 @@ The links are of the form <link>::split::<name>." ;; ;; Original code & idea by Christopher Suckling (org-mac-protocol) -(org-add-link-type "skim" 'org-mac-skim-open) +(org-link-set-parameters "skim" :follow #'org-mac-skim-open) (defun org-mac-skim-open (uri) "Visit page of pdf in Skim" @@ -557,30 +575,73 @@ The links are of the form <link>::split::<name>." (defun org-mac-skim-get-page () (interactive) (message "Applescript: Getting Skim page link...") - (let* ((link-and-descr (as-get-skim-page-link)) - (split-link (split-string link-and-descr "::split::")) - (link (car split-link)) - (description (cadr split-link)) - (org-link)) - (when (not (string= link "")) - (setq org-link (org-make-link-string link description))) - (kill-new org-link) - org-link)) + (org-mac-paste-applescript-links (as-get-skim-page-link))) (defun org-mac-skim-insert-page () (interactive) (insert (org-mac-skim-get-page))) +;; Handle links from Adobe Acrobat Pro.app +;; +;; Original code & idea by Christopher Suckling (org-mac-protocol) +;; +;; The URI format is path_to_pdf_file::page_number + +(org-link-set-parameters "acrobat" :follow #'org-mac-acrobat-open) + +(defun org-mac-acrobat-open (uri) + "Visit page of pdf in Acrobat" + (let* ((page (when (string-match "::\\(.+\\)\\'" uri) + (match-string 1 uri))) + (document (substring uri 0 (match-beginning 0)))) + (do-applescript + (concat + "tell application \"Adobe Acrobat Pro\"\n" + " activate\n" + " set theDoc to \"" document "\"\n" + " set thePage to " page "\n" + " open theDoc\n" + " tell PDF Window 1\n" + " goto page thePage\n" + " end tell\n" + "end tell")))) + +;; The applescript returns link in the format +;; "adobe:path_to_pdf_file::page_number::split::document_title, p.page_label" + +(defun org-mac-as-get-acrobat-page-link () + (do-applescript + (concat + "tell application \"Adobe Acrobat Pro\"\n" + " set theDoc to active doc\n" + " set theWindow to (PDF Window 1 of theDoc)\n" + " set thePath to (file alias of theDoc)\n" + " set theTitle to (name of theWindow)\n" + " set thePage to (page number of theWindow)\n" + " set theLabel to (label text of (page thePage of theWindow))\n" + "end tell\n" + "set theResult to \"acrobat:\" & thePath & \"::\" & thePage & \"::split::\" & theTitle & \", p.\" & theLabel\n" + "return theResult as string\n"))) + +(defun org-mac-acrobat-get-page () + (interactive) + (message "Applescript: Getting Acrobat page link...") + (org-mac-paste-applescript-links (org-mac-as-get-acrobat-page-link))) + +(defun org-mac-acrobat-insert-page () + (interactive) + (insert (org-mac-acrobat-get-page))) + ;; Handle links from Microsoft Outlook.app -(org-add-link-type "mac-outlook" 'org-mac-outlook-message-open) +(org-link-set-parameters "mac-outlook" :follow #'org-mac-outlook-message-open) (defun org-mac-outlook-message-open (msgid) "Open a message in Outlook" (do-applescript (concat - "tell application \"/Applications/Microsoft Office 2011/Microsoft Outlook.app\"\n" + "tell application \"" org-mac-outlook-path "\"\n" (format "open message id %s\n" (substring-no-properties msgid)) "activate\n" "end tell"))) @@ -589,7 +650,7 @@ The links are of the form <link>::split::<name>." "AppleScript to create links to selected messages in Microsoft Outlook.app." (do-applescript (concat - "tell application \"/Applications/Microsoft Office 2011/Microsoft Outlook.app\"\n" + "tell application \"" org-mac-outlook-path "\"\n" "set msgCount to count current messages\n" "if (msgCount < 1) then\n" "return\n" @@ -640,27 +701,12 @@ 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 "Org Mac Outlook: searching mailboxes...") - (let* ((as-link-list - (if (string= select-or-flag "s") - (org-as-get-selected-outlook-mail) - (if (string= select-or-flag "f") - (org-sh-get-flagged-outlook-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)) + (org-mac-paste-applescript-links + (if (string= select-or-flag "s") + (org-as-get-selected-outlook-mail) + (if (string= select-or-flag "f") + (org-sh-get-flagged-outlook-mail) + (error "Please select \"s\" or \"f\""))))) (defun org-mac-outlook-message-insert-selected () "Insert a link to the messages currently selected in Microsoft Outlook.app. @@ -695,11 +741,60 @@ after heading." (insert "\n") (org-insert-heading nil t) (insert org-heading "\n" (org-mac-outlook-message-get-links "f")))))) + +;; Handle links from Evernote.app + +(org-link-set-parameters "mac-evernote" :follow #'org-mac-evernote-note-open) + +(defun org-mac-evernote-note-open (noteid) + "Open a note in Evernote" + (do-applescript + (concat + "tell application \"" org-mac-evernote-path "\"\n" + " set theNotes to get every note of every notebook where its local id is \"" (substring-no-properties noteid) "\"\n" + " repeat with _note in theNotes\n" + " if length of _note is not 0 then\n" + " set _selectedNote to _note\n" + " end if\n" + " end repeat\n" + " open note window with item 1 of _selectedNote\n" + " activate\n" + "end tell"))) + +(defun org-as-get-selected-evernote-notes () + "AppleScript to create links to selected notes in Evernote.app." + (do-applescript + (concat + "tell application \"" org-mac-evernote-path "\"\n" + " set noteCount to count selection\n" + " if (noteCount < 1) then\n" + " return\n" + " end if\n" + " set theLinkList to {}\n" + " set theSelection to selection\n" + " repeat with theNote in theSelection\n" + " set theTitle to title of theNote\n" + " set theID to local id of theNote\n" + " set theURL to \"mac-evernote:\" & theID\n" + " set theLink to theURL & \"::split::\" & theTitle & \"\n\"\n" + " copy theLink to end of theLinkList\n" + " end repeat\n" + " return theLinkList as string\n" + "end tell\n"))) + +(defun org-mac-evernote-note-insert-selected () + "Insert a link to the notes currently selected in Evernote.app. +This will use AppleScript to get the note id and the title of the +note(s) in Evernote.app and make a link out of it/them." + (interactive) + (message "Org Mac Evernote: searching notes...") +(insert (org-mac-paste-applescript-links + (org-as-get-selected-evernote-notes)))) ;; Handle links from DEVONthink Pro Office.app -(org-add-link-type "x-devonthink-item" 'org-devonthink-item-open) +(org-link-set-parameters "x-devonthink-item" :follow #'org-devonthink-item-open) (defun org-devonthink-item-open (uid) "Open UID, which is a reference to an item in DEVONthink Pro Office." @@ -734,25 +829,7 @@ selected items in DEVONthink Pro Office.app and make links out of it/them. This function will push the Org-syntax text to the kill ring, and also return it." (message "Org Mac DEVONthink: looking for selected items...") - (let* ((as-link-list (org-as-get-selected-devonthink-item)) - (link-list (if as-link-list - (mapcar - (lambda (x) (if (string-match "\\`\"\\(.*\\)\"\\'" x) - (setq x (match-string 1 x))) - x) - (split-string as-link-list "[\r\n]+")) - nil)) - orglink-list) - (while link-list - (let* ((current-item (pop link-list))) - (message "current item: %s" current-item) - (when (and current-item (not (string= current-item ""))) - (let* ((split-link (split-string current-item "::split::")) - (orglink (org-make-link-string - (url-encode-url (car split-link)) - (cadr split-link)))) - (push orglink orglink-list))))) - (kill-new (mapconcat 'identity orglink-list "\n")))) + (org-mac-paste-applescript-links (org-as-get-selected-devonthink-item))) (defun org-mac-devonthink-item-insert-selected () "Insert a link to the item(s) currently selected in DEVONthink Pro Office. @@ -764,7 +841,7 @@ selected items in DEVONthink Pro Office and make link(s) out of it/them." ;; Handle links from Mail.app -(org-add-link-type "message" 'org-mac-message-open) +(org-link-set-parameters "message" :follow #'org-mac-message-open) (defun org-mac-message-open (message-id) "Visit the message with MESSAGE-ID. diff --git a/contrib/lisp/org-mairix.el b/contrib/lisp/org-mairix.el index a19719e..84c2dfd 100644 --- a/contrib/lisp/org-mairix.el +++ b/contrib/lisp/org-mairix.el @@ -82,8 +82,9 @@ correctly, you should not need to change this. ;;; The hooks to integrate mairix into org -(org-add-link-type "mairix" 'org-mairix-open) -(add-hook 'org-store-link-functions 'org-mairix-store-gnus-link) +(org-link-set-parameters "mairix" + :follow #'org-mairix-open + :store #'org-mairix-store-gnus-link) ;;; Generic org-mairix functions @@ -93,7 +94,7 @@ correctly, you should not need to change this. (if org-mairix-threaded-links "t:") (if org-mairix-augmented-links "a:") "@@" - (org-remove-angle-brackets message-id))) + (org-unbracket-string "<" ">" message-id))) (defun org-store-mairix-link-props (&rest plist) "Take a property list describing a mail, and add mairix link diff --git a/contrib/lisp/org-man.el b/contrib/lisp/org-man.el index a9db83d..1ccd942 100644 --- a/contrib/lisp/org-man.el +++ b/contrib/lisp/org-man.el @@ -25,8 +25,10 @@ (require 'org) -(org-add-link-type "man" 'org-man-open 'org-man-export) -(add-hook 'org-store-link-functions 'org-man-store-link) +(org-link-set-parameters "man" + :follow #'org-man-open + :export #'org-man-export + :store #'org-man-store-link) (defcustom org-man-command 'man "The Emacs command to be used to display a man page." diff --git a/contrib/lisp/org-mew.el b/contrib/lisp/org-mew.el index 8f7f609..2c2bdcc 100644 --- a/contrib/lisp/org-mew.el +++ b/contrib/lisp/org-mew.el @@ -148,8 +148,7 @@ with \"t\" key." (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) +(org-link-set-parameters "mew" :follow #'org-mew-open :store #'org-mew-store-link) ;; Implementation (defun org-mew-store-link () @@ -167,20 +166,11 @@ with \"t\" key." (from (mew-header-get-value "From:")) (to (mew-header-get-value "To:")) (date (mew-header-get-value "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)))) (subject (mew-header-get-value "Subject:")) desc link) - (org-store-link-props :type "mew" :from from :to to + (org-store-link-props :type "mew" :from from :to to :date date :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 message-id (org-unbracket-string "<" ">" message-id)) (setq desc (org-email-link-description)) (setq link (concat "mew:" folder-name "#" message-id)) (org-add-link-props :link link :description desc) @@ -290,12 +280,12 @@ the subject and the group number to extract. You can get rid of (setq subject (mew-header-get-value "Subject:")) (setq message-id (mew-header-get-value "Message-Id:")) (setq references (mew-header-get-value "References:"))) - (setq id-list (mapcar (lambda (id) (org-remove-angle-brackets id)) + (setq id-list (mapcar (lambda (id) (org-unbracket-string "<" ">" id)) (mew-idstr-to-id-list references))) (if last-reference-only (setq id-list (last id-list)) (if message-id - (setq id-list (cons (org-remove-angle-brackets message-id) + (setq id-list (cons (org-unbracket-string "<" ">" message-id) id-list)))) (when (and by-subject (stringp subject)) (catch 'matched diff --git a/contrib/lisp/org-mime.el b/contrib/lisp/org-mime.el index 682f635..2ced42e 100644 --- a/contrib/lisp/org-mime.el +++ b/contrib/lisp/org-mime.el @@ -57,6 +57,7 @@ (declare-function org-export-string-as "ox" (string backend &optional body-only ext-plist)) +(declare-function org-trim "org" (s &optional keep-lead)) (defcustom org-mime-use-property-inheritance nil "Non-nil means al MAIL_ properties apply also for sublevels." @@ -173,7 +174,7 @@ and images in a multipart/related part." "--" "}-<<alternative>>\n")) ('vm "?"))) -(defun org-mime-replace-images (str current-file) +(defun org-mime-replace-images (str) "Replace images in html files with cid links." (let (html-images) (cons @@ -185,7 +186,7 @@ and images in a multipart/related part." (let* ((url (and (string-match "src=\"\\([^\"]+\\)\"" text) (match-string 1 text))) (path (expand-file-name - url (file-name-directory current-file))) + url temporary-file-directory)) (ext (file-name-extension path)) (id (replace-regexp-in-string "[\/\\\\]" "_" path))) (add-to-list 'html-images @@ -212,8 +213,6 @@ otherwise export the entire body." (point-max))) (raw-body (concat org-mime-default-header (buffer-substring html-start html-end))) - (tmp-file (make-temp-name (expand-file-name - "mail" temporary-file-directory))) (body (org-export-string-as raw-body 'org t)) ;; because we probably don't want to export a huge style file (org-export-htmlize-output-type 'inline-css) @@ -224,7 +223,7 @@ otherwise export the entire body." ;; to hold attachments for inline html images (html-and-images (org-mime-replace-images - (org-export-string-as raw-body 'html t) tmp-file)) + (org-export-string-as raw-body 'html t))) (html-images (unless arg (cdr html-and-images))) (html (org-mime-apply-html-hook (if arg @@ -304,7 +303,7 @@ otherwise export the entire body." ((eq fmt 'org) (require 'ox-org) (insert (org-export-string-as - (org-babel-trim (funcall bhook body 'org)) 'org t))) + (org-trim (funcall bhook body 'org)) 'org t))) ((eq fmt 'ascii) (require 'ox-ascii) (insert (org-export-string-as @@ -317,12 +316,12 @@ otherwise export the entire body." (org-export-htmlize-output-type 'inline-css) (html-and-images (org-mime-replace-images - (org-export-string-as (funcall bhook body 'html) 'html t) file)) + (org-export-string-as (funcall bhook body 'html) 'html t))) (images (cdr html-and-images)) (html (org-mime-apply-html-hook (car html-and-images)))) (insert (org-mime-multipart (org-export-string-as - (org-babel-trim + (org-trim (funcall bhook body (if (eq fmt 'html) 'org 'ascii))) (if (eq fmt 'html) 'org 'ascii) t) html) diff --git a/contrib/lisp/org-notify.el b/contrib/lisp/org-notify.el index 91b34d3..d0acdec 100644 --- a/contrib/lisp/org-notify.el +++ b/contrib/lisp/org-notify.el @@ -130,7 +130,7 @@ simple timestamp string." (pr :file (nth org-notify-parse-file (org-agenda-files 'unrestricted))) (pr :timestamp deadline) (pr :uid (md5 (concat heading deadline))) (pr :deadline (- (org-time-string-to-seconds deadline) - (org-float-time)))) + (float-time)))) result))) (defun org-notify-todo-list () @@ -165,7 +165,7 @@ forgotten tasks." (dolist (prms (plist-get org-notify-map (td :notify))) (when (< deadline (org-notify-string->seconds (prm :time))) (let ((period (org-notify-string->seconds (prm :period))) - (last-run (prm last-run-sym)) (now (org-float-time)) + (last-run (prm last-run-sym)) (now (float-time)) (actions (prm :actions)) diff plist) (when (or (not last-run) (and period (< period (setq diff (- now last-run))) diff --git a/contrib/lisp/org-notmuch.el b/contrib/lisp/org-notmuch.el index 712ec5a..65d7550 100644 --- a/contrib/lisp/org-notmuch.el +++ b/contrib/lisp/org-notmuch.el @@ -65,21 +65,23 @@ Should accept a notmuch search string as the sole argument." ;; Install the link type -(org-add-link-type "notmuch" 'org-notmuch-open) -(add-hook 'org-store-link-functions 'org-notmuch-store-link) +(org-link-set-parameters "notmuch" + :follow #'org-notmuch-open + :store #'org-notmuch-store-link) (defun org-notmuch-store-link () "Store a link to a notmuch search or message." (when (eq major-mode 'notmuch-show-mode) - (let* ((message-id (notmuch-show-get-prop :id)) + (let* ((message-id (notmuch-show-get-message-id t)) (subject (notmuch-show-get-subject)) (to (notmuch-show-get-to)) (from (notmuch-show-get-from)) + (date (org-trim (notmuch-show-get-date))) desc link) - (org-store-link-props :type "notmuch" :from from :to to + (org-store-link-props :type "notmuch" :from from :to to :date date :subject subject :message-id message-id) (setq desc (org-email-link-description)) - (setq link (concat "notmuch:" "id:" message-id)) + (setq link (concat "notmuch:id:" message-id)) (org-add-link-props :link link :description desc) link))) @@ -92,13 +94,13 @@ Should accept a notmuch search string as the sole argument." Can link to more than one message, if so all matching messages are shown." (require 'notmuch) - (notmuch-show (org-link-unescape search))) - + (notmuch-show search)) -(org-add-link-type "notmuch-search" 'org-notmuch-search-open) -(add-hook 'org-store-link-functions 'org-notmuch-search-store-link) +(org-link-set-parameters "notmuch-search" + :follow #'org-notmuch-search-open + :store #'org-notmuch-search-store-link) (defun org-notmuch-search-store-link () "Store a link to a notmuch search or message." diff --git a/contrib/lisp/org-screenshot.el b/contrib/lisp/org-screenshot.el index d44063a..3716020 100644 --- a/contrib/lisp/org-screenshot.el +++ b/contrib/lisp/org-screenshot.el @@ -338,8 +338,8 @@ by most recent first" org-screenshot-rotation-index -1 org-screenshot-file-list (let ((files (directory-files org-screenshot-image-directory - t (org-image-file-name-regexp) t))) - (mapcar 'file-name-nondirectory + t (image-file-name-regexp) t))) + (mapcar 'file-name-nondirectory (sort files (lambda (file1 file2) (let ((mtime1 (nth 5 (file-attributes file1))) @@ -364,7 +364,7 @@ other direction" (link-re ;; taken from `org-display-inline-images' (concat "\\[\\[\\(\\(file:\\)\\|\\([./~]\\)\\)\\([^]\n]+?" - (substring (org-image-file-name-regexp) 0 -2) + (substring (image-file-name-regexp) 0 -2) "\\)\\]")) newfile oldfile) (save-excursion @@ -496,7 +496,7 @@ entered, at which point event will be unread" (let ((files-in-buffer) dired-buffer had-any - (image-re (org-image-file-name-regexp)) + (image-re (image-file-name-regexp)) beg end) (save-excursion (save-restriction @@ -504,7 +504,7 @@ entered, at which point event will be unread" (setq beg (or beg (point-min)) end (or end (point-max))) (goto-char beg) (let ((re (concat "\\[\\[\\(\\(file:\\)\\|\\([./~]\\)\\)\\([^]\n]+?" - (substring (org-image-file-name-regexp) 0 -2) + (substring (image-file-name-regexp) 0 -2) "\\)\\]")) (case-fold-search t) old file ov img type attrwidth width) diff --git a/contrib/lisp/org-toc.el b/contrib/lisp/org-toc.el index b82952e..a692d85 100644 --- a/contrib/lisp/org-toc.el +++ b/contrib/lisp/org-toc.el @@ -197,7 +197,7 @@ specified, then make `org-toc-recenter' use this value." (setq ov (make-overlay beg end))) ;; change the folding status of this headline (cond ((or (null status) (eq status 'folded)) - (show-children) + (org-show-children) (message "CHILDREN") (overlay-put ov 'status 'children)) ((eq status 'children) @@ -441,7 +441,7 @@ current table of contents to it." (setq ov (make-overlay (match-beginning 0) (match-end 0)))) (cond ((eq (cdr hlcfg0) 'children) - (show-children) + (org-show-children) (message "CHILDREN") (overlay-put ov 'status 'children)) ((eq (cdr hlcfg0) 'branches) diff --git a/contrib/lisp/org-vm.el b/contrib/lisp/org-vm.el index 18d1be6..070d2f8 100644 --- a/contrib/lisp/org-vm.el +++ b/contrib/lisp/org-vm.el @@ -55,9 +55,8 @@ (defvar vm-folder-directory) ;; Install the link type -(org-add-link-type "vm" 'org-vm-open) -(org-add-link-type "vm-imap" 'org-vm-imap-open) -(add-hook 'org-store-link-functions 'org-vm-store-link) +(org-link-set-parameters "vm" :follow #'org-vm-open :store #'org-vm-store-link) +(org-link-set-parameters "vm-imap" :follow #'org-vm-imap-open) ;; Implementation (defun org-vm-store-link () @@ -77,12 +76,6 @@ (message-id (vm-su-message-id message)) (link-type (if (vm-imap-folder-p) "vm-imap" "vm")) (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)))) folder desc link) (if (vm-imap-folder-p) (let ((spec (vm-imap-find-spec-for-buffer (current-buffer)))) @@ -93,12 +86,9 @@ (string-match (concat "^" (regexp-quote vm-folder-directory)) folder)) (setq folder (replace-match "" t t folder))))) - (setq message-id (org-remove-angle-brackets message-id)) + (setq message-id (org-unbracket-string "<" ">" message-id)) (org-store-link-props :type link-type :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)) + :message-id message-id :date date) (setq desc (org-email-link-description)) (setq link (concat (concat link-type ":") folder "#" message-id)) (org-add-link-props :link link :description desc) @@ -126,12 +116,10 @@ (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)))) + (setq folder (format "/%s@%s:%s" user host file))) (t ;; use ange-ftp or efs - (require (if (featurep 'xemacs) 'efs 'ange-ftp)) + (require 'ange-ftp) (setq folder (format "/%s@%s:%s" user host file)))))) (when folder (funcall (cdr (assq 'vm org-link-frame-setup)) folder readonly) diff --git a/contrib/lisp/org-wikinodes.el b/contrib/lisp/org-wikinodes.el index 428cb6c..02c170d 100644 --- a/contrib/lisp/org-wikinodes.el +++ b/contrib/lisp/org-wikinodes.el @@ -203,7 +203,7 @@ setting of `org-wikinodes-create-targets'." (widen) (goto-char (point-min)) (while (re-search-forward re nil t) - (push (org-match-string-no-properties 4) targets)))) + (push (match-string-no-properties 4) targets)))) (nreverse targets))) (defun org-wikinodes-get-links-for-directory (dir) diff --git a/contrib/lisp/org-wl.el b/contrib/lisp/org-wl.el index 9d7eb44..01eee13 100644 --- a/contrib/lisp/org-wl.el +++ b/contrib/lisp/org-wl.el @@ -109,8 +109,7 @@ googlegroups otherwise." "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) +(org-link-set-parameters "wl" :follow #'org-wl-open :store #'org-wl-store-link) ;; Implementation @@ -192,18 +191,12 @@ ENTITY is a message entity." (message-id (org-wl-message-field 'message-id wl-message-entity)) (message-id-no-brackets - (org-remove-angle-brackets message-id)) + (org-unbracket-string "<" ">" 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 @@ -243,9 +236,7 @@ ENTITY is a message entity." (setq desc (org-email-link-description)) (setq link (concat "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)) + (org-add-link-props :date date) (or link xref))))))) (defun org-wl-open-nntp (path) @@ -287,8 +278,8 @@ for namazu index." 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)))) + (if (not (elmo-folder-exists-p (with-no-warnings + (wl-folder-get-elmo-folder folder)))) (error "No such folder: %s" folder)) (let ((old-buf (current-buffer)) (old-point (point-marker))) @@ -299,7 +290,7 @@ for namazu index." ;; in the old buffer. (goto-char old-point)) (when article - (if (org-string-match-p "@" article) + (if (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)) diff --git a/contrib/lisp/ox-bibtex.el b/contrib/lisp/ox-bibtex.el index 9d548bb..56dec38 100644 --- a/contrib/lisp/ox-bibtex.el +++ b/contrib/lisp/ox-bibtex.el @@ -92,7 +92,7 @@ ;; Initialization -(eval-when-compile (require 'cl)) +(require 'cl-lib) ;;; Internal Functions @@ -136,7 +136,7 @@ contains a list of strings to be passed as options to (defun org-bibtex-citation-p (object) "Non-nil when OBJECT is a citation." - (case (org-element-type object) + (cl-case (org-element-type object) (link (equal (org-element-property :type object) "cite")) (latex-fragment (string-match "\\`\\\\cite{" (org-element-property :value object))))) @@ -159,9 +159,7 @@ to `org-bibtex-citation-p' predicate." (defun org-bibtex-goto-citation (&optional citation) "Visit a citation given its ID." (interactive) - (let ((citation (or citation - (org-icompleting-read "Citation: " - (obe-citations))))) + (let ((citation (or citation (completing-read "Citation: " (obe-citations))))) (find-file (or org-bibtex-file (error "`org-bibtex-file' has not been configured"))) (goto-char (point-min)) @@ -169,7 +167,7 @@ to `org-bibtex-citation-p' predicate." (outline-previous-visible-heading 1) t))) -(let ((jump-fn (car (org-remove-if-not #'fboundp '(ebib org-bibtex-goto-citation))))) +(let ((jump-fn (car (cl-remove-if-not #'fboundp '(ebib org-bibtex-goto-citation))))) (org-add-link-type "cite" jump-fn)) @@ -305,7 +303,7 @@ the HTML and ASCII backends." next) (while (and (setq next (org-export-get-next-element object info)) (or (and (stringp next) - (not (org-string-match-p "\\S-" next))) + (not (string-match-p "\\S-" next))) (org-bibtex-citation-p next))) (unless (stringp next) (push (org-bibtex-get-citation-key next) keys)) diff --git a/contrib/lisp/ox-confluence.el b/contrib/lisp/ox-confluence.el index 9b96d5f..48bc5ea 100644 --- a/contrib/lisp/ox-confluence.el +++ b/contrib/lisp/ox-confluence.el @@ -47,6 +47,7 @@ (italic . org-confluence-italic) (item . org-confluence-item) (link . org-confluence-link) + (paragraph . org-confluence-paragraph) (property-drawer . org-confluence-property-drawer) (section . org-confluence-section) (src-block . org-confluence-src-block) @@ -57,6 +58,11 @@ (template . org-confluence-template) (underline . org-confluence-underline))) +(defcustom org-confluence-lang-alist + '(("sh" . "bash")) + "Map from org-babel language name to confluence wiki language name" + :type '(alist :key-type string :value-type string)) + ;; All the functions we use (defun org-confluence-bold (bold contents info) (format "*%s*" contents)) @@ -101,6 +107,12 @@ raw-link)) "]"))) +(defun org-confluence-paragraph (paragraph contents info) + "Transcode PARAGRAPH element for Confluence. +CONTENTS is the paragraph contents. INFO is a plist used as +a communication channel." + contents) + (defun org-confluence-property-drawer (property-drawer contents info) (and (org-string-nw-p contents) (format "\{\{%s\}\}" contents))) @@ -111,8 +123,7 @@ (defun org-confluence-src-block (src-block contents info) ;; FIXME: provide a user-controlled variable for theme (let* ((lang (org-element-property :language src-block)) - (language (if (string= lang "sh") "bash" ;; FIXME: provide a mapping of some sort - lang)) + (language (or (cdr (assoc lang org-confluence-lang-alist)) lang)) (content (org-export-format-code-default src-block info))) (org-confluence--block language "Emacs" content))) diff --git a/contrib/lisp/ox-extra.el b/contrib/lisp/ox-extra.el index e6d45cc..85dae47 100644 --- a/contrib/lisp/ox-extra.el +++ b/contrib/lisp/ox-extra.el @@ -37,9 +37,9 @@ ;; for export. These blocks should be tagged with #+header: :header ;; yes. For example: ;; #+header: :header yes -;; #+begin_latex +;; #+begin_export latex ;; ... -;; #+end_latex +;; #+end_export ;; - `ignore-headlines' -- allow a headline (but not its children) to ;; be ignored. Any headline tagged with the 'ignore' tag will be diff --git a/contrib/lisp/ox-freemind.el b/contrib/lisp/ox-freemind.el index 3e4b6ae..85323a2 100644 --- a/contrib/lisp/ox-freemind.el +++ b/contrib/lisp/ox-freemind.el @@ -43,7 +43,6 @@ ;;; Define Back-End (org-export-define-derived-backend 'freemind 'html - :export-block "FREEMIND" :menu-entry '(?f "Export to Freemind Mindmap" ((?f "As Freemind Mindmap file" org-freemind-export-to-freemind) diff --git a/contrib/lisp/ox-gfm.el b/contrib/lisp/ox-gfm.el deleted file mode 100644 index f7acc94..0000000 --- a/contrib/lisp/ox-gfm.el +++ /dev/null @@ -1,193 +0,0 @@ -;;; ox-gfm.el --- Github Flavored Markdown Back-End for Org Export Engine - -;; Copyright (C) 2014 Lars Tveito - -;; Author: Lars Tveito -;; Keywords: org, wp, markdown, github - -;; This file is not 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 Markdown back-end (github flavor) for Org -;; exporter, based on the `md' back-end. - -;;; Code: - -(require 'ox-md) - - - -;;; User-Configurable Variables - -(defgroup org-export-gfm nil - "Options specific to Markdown export back-end." - :tag "Org Github Flavored Markdown" - :group 'org-export - :version "24.4" - :package-version '(Org . "8.0")) - -(defcustom org-gfm-lang '(("emacs-lisp" . "lisp") ("elisp" . "lisp")) - "Alist of languages that are not recognized by Github, to - languages that are. Emacs lisp is a good example of this, where - we can use lisp as a nice replacement." - :group 'org-export-gfm) - - - -;;; Define Back-End - -(org-export-define-derived-backend 'gfm 'md - :export-block '("GFM" "GITHUB FLAVORED MARKDOWN") - :filters-alist '((:filter-parse-tree . org-md-separate-elements)) - :menu-entry - '(?g "Export to Github Flavored Markdown" - ((?G "To temporary buffer" - (lambda (a s v b) (org-gfm-export-as-markdown a s v))) - (?g "To file" (lambda (a s v b) (org-gfm-export-to-markdown a s v))) - (?o "To file and open" - (lambda (a s v b) - (if a (org-gfm-export-to-markdown t s v) - (org-open-file (org-gfm-export-to-markdown nil s v))))))) - :translate-alist '((inner-template . org-gfm-inner-template) - (strike-through . org-gfm-strike-through) - (src-block . org-gfm-src-block))) - - - -;;; Transcode Functions - -;;;; Src Block - -(defun org-gfm-src-block (src-block contents info) - "Transcode SRC-BLOCK element into Github Flavored Markdown -format. CONTENTS is nil. INFO is a plist used as a communication -channel." - (let* ((lang (org-element-property :language src-block)) - (lang (or (assoc-default lang org-gfm-lang) lang)) - (code (org-export-format-code-default src-block info)) - (prefix (concat "```" lang "\n")) - (suffix "```")) - (concat prefix code suffix))) - - -;;;; Strike-Through - -(defun org-html-strike-through (strike-through contents info) - "Transcode STRIKE-THROUGH from Org to Markdown (GFM). -CONTENTS is the text with strike-through markup. INFO is a plist -holding contextual information." - (format "~~%s~~" contents)) - -;;;; Table of contents - -(defun org-gfm-format-toc (headline) - "Return an appropriate table of contents entry for HEADLINE. INFO is a -plist used as a communication channel." - (let* ((title (org-export-data - (org-export-get-alt-title headline info) info)) - (level (1- (org-element-property :level headline))) - (indent (concat (make-string (* level 2) ? ))) - (ref-str (replace-regexp-in-string " " "-" (downcase title)))) - (concat indent "- [" title "]" "(#" ref-str ")"))) - - -;;;; Template - -(defun org-gfm-inner-template (contents info) - "Return body of document after converting it to Markdown syntax. -CONTENTS is the transcoded contents string. INFO is a plist -holding export options." - (let* ((depth (plist-get info :with-toc)) - (headlines (and depth (org-export-collect-headlines info depth))) - (toc-string (or (mapconcat 'org-gfm-format-toc headlines "\n") "")) - (toc-tail (if headlines "\n\n" ""))) - (concat toc-string toc-tail contents))) - - - -;;; Interactive function - -;;;###autoload -(defun org-gfm-export-as-markdown (&optional async subtreep visible-only) - "Export current buffer to a Github Flavored Markdown buffer. - -If narrowing is active in the current buffer, only export its -narrowed part. - -If a region is active, export that region. - -A non-nil optional argument ASYNC means the process should happen -asynchronously. The resulting buffer should be accessible -through the `org-export-stack' interface. - -When optional argument SUBTREEP is non-nil, export the sub-tree -at point, extracting information from the headline properties -first. - -When optional argument VISIBLE-ONLY is non-nil, don't export -contents of hidden elements. - -Export is done in a buffer named \"*Org GFM Export*\", which will -be displayed when `org-export-show-temporary-export-buffer' is -non-nil." - (interactive) - (org-export-to-buffer 'gfm "*Org GFM Export*" - async subtreep visible-only nil nil (lambda () (text-mode)))) - - -;;;###autoload -(defun org-gfm-convert-region-to-md () - "Assume the current region has org-mode syntax, and convert it -to Github Flavored Markdown. This can be used in any buffer. -For example, you can write an itemized list in org-mode syntax in -a Markdown buffer and use this command to convert it." - (interactive) - (org-export-replace-region-by 'gfm)) - - -;;;###autoload -(defun org-gfm-export-to-markdown (&optional async subtreep visible-only) - "Export current buffer to a Github Flavored Markdown file. - -If narrowing is active in the current buffer, only export its -narrowed part. - -If a region is active, export that region. - -A non-nil optional argument ASYNC means the process should happen -asynchronously. The resulting file should be accessible through -the `org-export-stack' interface. - -When optional argument SUBTREEP is non-nil, export the sub-tree -at point, extracting information from the headline properties -first. - -When optional argument VISIBLE-ONLY is non-nil, don't export -contents of hidden elements. - -Return output file's name." - (interactive) - (let ((outfile (org-export-output-file-name ".md" subtreep))) - (org-export-to-file 'gfm outfile async subtreep visible-only))) - -(provide 'ox-gfm) - -;; Local variables: -;; generated-autoload-file: "org-loaddefs.el" -;; End: - -;;; ox-gfm.el ends here diff --git a/contrib/lisp/ox-groff.el b/contrib/lisp/ox-groff.el index 6489ee7..c83d44d 100644 --- a/contrib/lisp/ox-groff.el +++ b/contrib/lisp/ox-groff.el @@ -92,7 +92,6 @@ (underline . org-groff-underline) (verbatim . org-groff-verbatim) (verse-block . org-groff-verse-block)) - :export-block "GROFF" :menu-entry '(?g "Export to GROFF" ((?g "As GROFF file" org-groff-export-to-groff) @@ -1066,9 +1065,7 @@ contextual information." (let* ((code (org-element-property :value inline-src-block))) (cond (org-groff-source-highlight - (let* ((tmpdir (if (featurep 'xemacs) - temp-directory - temporary-file-directory)) + (let* ((tmpdir temporary-file-directory) (in-file (make-temp-name (expand-file-name "srchilite" tmpdir))) (out-file (make-temp-name @@ -1489,9 +1486,7 @@ contextual information." (custom-env (and lang (cadr (assq (intern lang) org-groff-custom-lang-environments)))) - (num-start (case (org-element-property :number-lines src-block) - (continued (org-export-get-loc src-block info)) - (new 0))) + (num-start (org-export-get-loc src-block info)) (retain-labels (org-element-property :retain-labels src-block)) (caption (and (not (org-export-read-attribute :attr_groff src-block :disable-caption)) @@ -1507,9 +1502,7 @@ contextual information." ;; Case 2. Source fontification. (org-groff-source-highlight - (let* ((tmpdir (if (featurep 'xemacs) - temp-directory - temporary-file-directory)) + (let* ((tmpdir temporary-file-directory) (in-file (make-temp-name (expand-file-name "srchilite" tmpdir))) (out-file (make-temp-name @@ -1903,6 +1896,7 @@ Return PDF file name or an error if it couldn't be produced." (let* ((base-name (file-name-sans-extension (file-name-nondirectory file))) (full-name (file-truename file)) (out-dir (file-name-directory file)) + (time (current-time)) ;; Properly set working directory for compilation. (default-directory (if (file-name-absolute-p file) (file-name-directory full-name) @@ -1937,7 +1931,12 @@ Return PDF file name or an error if it couldn't be produced." (let ((pdffile (concat out-dir base-name ".pdf"))) ;; Check for process failure. Provide collected errors if ;; possible. - (if (not (file-exists-p pdffile)) + (if (or (not (file-exists-p pdffile)) + ;; Only compare times up to whole seconds as some + ;; filesystems (e.g. HFS+) do not retain any finer + ;; granularity. + (time-less-p (cl-subseq (nth 5 (file-attributes pdffile)) 0 2) + (cl-subseq time 0 2))) (error (concat (format "PDF file %s wasn't produced" pdffile) (when errors (concat ": " errors)))) ;; Else remove log files, when specified, and signal end of diff --git a/contrib/lisp/ox-koma-letter.el b/contrib/lisp/ox-koma-letter.el index 48d4ead..801ab7d 100644 --- a/contrib/lisp/ox-koma-letter.el +++ b/contrib/lisp/ox-koma-letter.el @@ -41,13 +41,14 @@ ;; - PHONE_NUMBER: see `org-koma-letter-phone-number', ;; - SIGNATURE: see `org-koma-letter-signature', ;; - PLACE: see `org-koma-letter-place', +;; - LOCATION: see `org-koma-letter-location', ;; - TO_ADDRESS: If unspecified this is set to "\mbox{}". ;; -;; TO_ADDRESS and FROM_ADDRESS can also be specified using heading -;; with the special tags specified in -;; `org-koma-letter-special-tags-in-letter', namely "to" and "from". -;; LaTeX line breaks are not necessary if using these headings. If -;; both a headline and a keyword specify a to or from address the +;; TO_ADDRESS, FROM_ADDRESS, LOCATION, CLOSING, and SIGNATURE can also +;; be specified using "special headings" with the special tags +;; specified in `org-koma-letter-special-tags-in-letter'. LaTeX line +;; breaks are not necessary for TO_ADDRESS, FROM_ADDRESS and LOCATION. +;; If both a headline and a keyword specify a to or from address the ;; value is determined in accordance with ;; `org-koma-letter-prefer-special-headings'. ;; @@ -58,6 +59,7 @@ ;; - phone (see `org-koma-letter-use-phone') ;; - email (see `org-koma-letter-use-email') ;; - place (see `org-koma-letter-use-place') +;; - location (see `org-koma-letter-use-location') ;; - subject, a list of format options ;; (see `org-koma-letter-subject-format') ;; - after-closing-order, a list of the ordering of headings with @@ -80,9 +82,9 @@ ;; `org-koma-letter-special-tags-after-closing' used as macros and the ;; content of the headline is the argument. ;; -;; Headlines with two and from may also be used rather than the -;; keyword approach described above. If both a keyword and a headline -;; with information is present precedence is determined by +;; Headlines with to and from may also be used rather than the keyword +;; approach described above. If both a keyword and a headline with +;; information is present precedence is determined by ;; `org-koma-letter-prefer-special-headings'. ;; ;; You need an appropriate association in `org-latex-classes' in order @@ -188,17 +190,35 @@ This option can also be set with the PLACE keyword." :group 'org-export-koma-letter :type 'string) +(defcustom org-koma-letter-location "" + "Sender's extension field, as a string. + +This option can also be set with the LOCATION keyword. +Moreover, when: + (1) Either `org-koma-letter-prefer-special-headings' is non-nil + or there is no LOCATION keyword or the LOCATION keyword is + empty; + (2) the letter contains a headline with the special + tag \"location\"; +then the location will be set as the content of the location +special heading. + +The location field is typically printed right of the address +field (See Figure 4.9. in the English manual of 2015-10-03)." + :group 'org-export-koma-letter + :type 'string) + (defcustom org-koma-letter-opening "" "Letter's opening, as a string. This option can also be set with the OPENING keyword. Moreover, when: - (1) this value is the empty string; - (2) there's no OPENING keyword or it is empty; - (3) `org-koma-letter-headline-is-opening-maybe' is non-nil; - (4) the letter contains a headline without a special + (1) Either `org-koma-letter-prefer-special-headings' is non-nil + or the CLOSING keyword is empty + (2) `org-koma-letter-headline-is-opening-maybe' is non-nil; + (3) the letter contains a headline without a special tag (e.g. \"to\" or \"ps\"); -then the opening will be implicitly set as the headline title." +then the opening will be implicitly set as the untagged headline title." :group 'org-export-koma-letter :type 'string) @@ -206,12 +226,13 @@ then the opening will be implicitly set as the headline title." "Letter's closing, as a string. This option can also be set with the CLOSING keyword. Moreover, when: - (1) there's no CLOSING keyword or it is empty; + (1) Either `org-koma-letter-prefer-special-headings' is non-nil + or the CLOSING keyword is empty; (2) `org-koma-letter-headline-is-opening-maybe' is non-nil; (3) the letter contains a headline with the special - tag closing; + tag \"closing\"; then the opening will be set as the title of the closing special -heading." +heading title." :group 'org-export-koma-letter :type 'string) @@ -219,12 +240,15 @@ heading." "Signature, as a string. This option can also be set with the SIGNATURE keyword. Moreover, when: - (1) there's no CLOSING keyword or it is empty; + (1) Either `org-koma-letter-prefer-special-headings' is non-nil + or there is no CLOSING keyword or the CLOSING keyword is empty; (2) `org-koma-letter-headline-is-opening-maybe' is non-nil; (3) the letter contains a headline with the special - tag closing; + tag \"closing\"; then the signature will be set as the content of the -closing special heading." +closing special heading. + +Note if the content is empty the signature will not be set." :group 'org-export-koma-letter :type 'string) @@ -359,9 +383,9 @@ The value must be a member of `org-latex-classes'." :type 'string) (defcustom org-koma-letter-headline-is-opening-maybe t - "Non-nil means a headline may be used as an opening. -A headline is only used if #+OPENING is not set. See also -`org-koma-letter-opening'." + "Non-nil means a headline may be used as an opening and closing. +See also `org-koma-letter-opening' and +`org-koma-letter-closing'." :group 'org-export-koma-letter :type 'boolean) @@ -372,14 +396,17 @@ e.g. \"title-subject:t\"." :group 'org-export-koma-letter :type 'boolean) -(defconst org-koma-letter-special-tags-in-letter '(to from closing) +(defconst org-koma-letter-special-tags-in-letter '(to from closing location) "Header tags related to the letter itself.") -(defconst org-koma-letter-special-tags-after-closing '(ps encl cc) - "Header tags to be inserted after closing.") +(defconst org-koma-letter-special-tags-after-closing '(after_closing ps encl cc) + "Header tags to be inserted in the letter after closing.") + +(defconst org-koma-letter-special-tags-as-macro '(ps encl cc) + "Header tags to be inserted as macros") (defconst org-koma-letter-special-tags-after-letter '(after_letter) - "Header tags to be inserted after closing.") + "Header tags to be inserted after the letter.") (defvar org-koma-letter-special-contents nil "Holds special content temporarily.") @@ -402,20 +429,18 @@ e.g. \"title-subject:t\"." (:email "EMAIL" nil (org-koma-letter--get-value org-koma-letter-email) t) (:to-address "TO_ADDRESS" nil nil newline) (:place "PLACE" nil org-koma-letter-place) + (:location "LOCATION" nil org-koma-letter-location) (:subject "SUBJECT" nil nil parse) (:opening "OPENING" nil org-koma-letter-opening parse) (:closing "CLOSING" nil org-koma-letter-closing parse) (:signature "SIGNATURE" nil org-koma-letter-signature newline) - (:special-headings nil "special-headings" - org-koma-letter-prefer-special-headings) - (:special-tags nil nil (append - org-koma-letter-special-tags-in-letter - org-koma-letter-special-tags-after-closing - org-koma-letter-special-tags-after-letter)) - (:with-after-closing nil "after-closing-order" - org-koma-letter-special-tags-after-closing) - (:with-after-letter nil "after-letter-order" - org-koma-letter-special-tags-after-letter) + (:special-headings nil "special-headings" org-koma-letter-prefer-special-headings) + (:special-tags-as-macro nil nil org-koma-letter-special-tags-as-macro) + (:special-tags-in-letter nil nil org-koma-letter-special-tags-in-letter) + (:special-tags-after-closing nil "after-closing-order" + org-koma-letter-special-tags-after-closing) + (:special-tags-after-letter nil "after-letter-order" + org-koma-letter-special-tags-after-letter) (:with-backaddress nil "backaddress" org-koma-letter-use-backaddress) (:with-email nil "email" org-koma-letter-use-email) (:with-foldmarks nil "foldmarks" org-koma-letter-use-foldmarks) @@ -428,9 +453,11 @@ e.g. \"title-subject:t\"." ;; They are used to prioritize in-buffer settings over "lco" ;; files. See `org-koma-letter-template'. (:inbuffer-author "AUTHOR" nil 'koma-letter:empty) + (:inbuffer-from "FROM" nil 'koma-letter:empty) (:inbuffer-email "EMAIL" nil 'koma-letter:empty) (:inbuffer-phone-number "PHONE_NUMBER" nil 'koma-letter:empty) (:inbuffer-place "PLACE" nil 'koma-letter:empty) + (:inbuffer-location "LOCATION" nil 'koma-letter:empty) (:inbuffer-signature "SIGNATURE" nil 'koma-letter:empty) (:inbuffer-with-backaddress nil "backaddress" 'koma-letter:empty) (:inbuffer-with-email nil "email" 'koma-letter:empty) @@ -438,10 +465,10 @@ e.g. \"title-subject:t\"." (:inbuffer-with-phone nil "phone" 'koma-letter:empty) (:inbuffer-with-place nil "place" 'koma-letter:empty)) :translate-alist '((export-block . org-koma-letter-export-block) - (export-snippet . org-koma-letter-export-snippet) - (headline . org-koma-letter-headline) - (keyword . org-koma-letter-keyword) - (template . org-koma-letter-template)) + (export-snippet . org-koma-letter-export-snippet) + (headline . org-koma-letter-headline) + (keyword . org-koma-letter-keyword) + (template . org-koma-letter-template)) :menu-entry '(?k "Export with KOMA Scrlttr2" ((?L "As LaTeX buffer" org-koma-letter-export-as-latex) @@ -466,8 +493,9 @@ e.g. \"title-subject:t\"." (defun org-koma-letter--get-tagged-contents (key) "Get contents from a headline tagged with KEY. The contents is stored in `org-koma-letter-special-contents'." - (cdr (assoc-string (org-koma-letter--get-value key) - org-koma-letter-special-contents))) + (let ((value (cdr (assoc-string (org-koma-letter--get-value key) + org-koma-letter-special-contents)))) + (when value (org-string-nw-p (org-trim value))))) (defun org-koma-letter--get-value (value) "Turn value into a string whenever possible. @@ -479,46 +507,31 @@ return a string or nil." ((symbolp value) (symbol-name value)) (t value)))) -(defun org-koma-letter--special-contents-as-macro - (keywords &optional keep-newlines no-tag) +(defun org-koma-letter--special-contents-inline (keywords info) "Process KEYWORDS members of `org-koma-letter-special-contents'. KEYWORDS is a list of symbols. Return them as a string to be formatted. The function is used for inserting content of special headings -such as PS. - -If KEEP-NEWLINES is non-nil leading and trailing newlines are not -removed. If NO-TAG is non-nil the content in -`org-koma-letter-special-contents' are not wrapped in a macro -named whatever the members of KEYWORDS are called." +such as the one tagged with PS. +" (mapconcat (lambda (keyword) (let* ((name (org-koma-letter--get-value keyword)) - (value (org-koma-letter--get-tagged-contents name))) + (value (org-koma-letter--get-tagged-contents name)) + (macrop (memq keyword (plist-get info :special-tags-as-macro)))) (cond ((not value) nil) - (no-tag (if keep-newlines value (org-trim value))) - (t (format "\\%s{%s}\n" - name - (if keep-newlines value (org-trim value))))))) + (macrop (format "\\%s{%s}\n" name value)) + (t value)))) keywords - "")) + "\n")) -(defun org-koma-letter--determine-to-and-from (info key) - "Given INFO determine KEY for the letter. -KEY should be `to' or `from'. -`ox-koma-letter' allows two ways to specify TO and FROM. If both -are present return the preferred one as determined by -`org-koma-letter-prefer-special-headings'." - (let ((option (org-string-nw-p - (plist-get info (if (eq key 'to) :to-address :from-address)))) - (headline (org-koma-letter--get-tagged-contents key))) - (replace-regexp-in-string - "\n" "\\\\\\\\\n" - (org-trim - (if (plist-get info :special-headings) (or headline option "") - (or option headline "")))))) +(defun org-koma-letter--add-latex-newlines (string) + "Replace regular newlines with LaTeX newlines (i.e. `\\\\')" + (let ((str (org-trim string))) + (when (org-string-nw-p str) + (replace-regexp-in-string "\n" "\\\\\\\\\n" str)))) @@ -576,12 +589,35 @@ appropriate place." "Non-nil if HEADLINE is a special headline. INFO is a plist holding contextual information. Return first special tag headline." - (let ((special-tags (plist-get info :special-tags))) + (let ((special-tags (append + (plist-get info :special-tags-in-letter) + (plist-get info :special-tags-after-closing) + (plist-get info :special-tags-after-letter)))) (catch 'exit (dolist (tag (org-export-get-tags headline info)) (let ((tag (assoc-string tag special-tags))) (when tag (throw 'exit tag))))))) +(defun org-koma-letter--keyword-or-headline (plist-key pred info) + "Return the correct version of opening or closing. +PLIST-KEY should be a key in info, typically :opening +or :closing. PRED is a predicate run on headline to determine +which title to use which takes two arguments, a headline element +and an info plist. INFO is a plist holding contextual +information. Return the preferred candidate for the exported of +PLIST-KEY." + (let* ((keyword-candidate (plist-get info plist-key)) + (headline-candidate (when (and (plist-get info :with-headline-opening) + (or (plist-get info :special-headings) + (not keyword-candidate))) + (org-element-map (plist-get info :parse-tree) + 'headline + (lambda (head) + (when (funcall pred head info) + (org-element-property :title head))) + info t)))) + (org-export-data (or headline-candidate keyword-candidate "") info))) + ;;;; Template (defun org-koma-letter-template (contents info) @@ -592,8 +628,10 @@ holding export options." ;; Time-stamp. (and (plist-get info :time-stamp-file) (format-time-string "%% Created %Y-%m-%d %a %H:%M\n")) + ;; LaTeX compiler + (org-latex--insert-compiler info) ;; Document class and packages. - (org-latex--make-header info) + (org-latex--make-preamble info) ;; Settings. They can come from three locations, in increasing ;; order of precedence: global variables, LCO files and in-buffer ;; settings. Thus, we first insert settings coming from global @@ -604,10 +642,6 @@ holding export options." (org-split-string (or (plist-get info :lco) "") " ") "") (org-koma-letter--build-settings 'buffer info) - ;; From address. - (let ((from-address (org-koma-letter--determine-to-and-from info 'from))) - (when (org-string-nw-p from-address) - (format "\\setkomavar{fromaddress}{%s}\n" from-address))) ;; Date. (format "\\date{%s}\n" (org-export-data (org-export-get-date info) info)) ;; Hyperref, document start, and subject and title. @@ -643,40 +677,33 @@ holding export options." (when title (format "\\setkomavar{title}{%s}\n" title)) (when (or (org-string-nw-p title) (org-string-nw-p subject)) "\n"))) ;; Letter start. - (format "\\begin{letter}{%%\n%s}\n\n" - (org-koma-letter--determine-to-and-from info 'to)) + (let ((keyword-val (plist-get info :to-address)) + (heading-val (org-koma-letter--get-tagged-contents 'to))) + (format "\\begin{letter}{%%\n%s}\n\n" + (org-koma-letter--add-latex-newlines + (or (if (plist-get info :special-headings) + (or heading-val keyword-val) + (or keyword-val heading-val)) + "\\\\mbox{}")))) ;; Opening. (format "\\opening{%s}\n\n" - (org-export-data - (or (org-string-nw-p (plist-get info :opening)) - (when (plist-get info :with-headline-opening) - (org-element-map (plist-get info :parse-tree) 'headline - (lambda (head) - (unless (org-koma-letter--special-tag head info) - (org-element-property :title head))) - info t)) - "") + (org-koma-letter--keyword-or-headline + :opening (lambda (h i) (not (org-koma-letter--special-tag h i))) info)) ;; Letter body. contents ;; Closing. - (format "\n\\closing{%s}\n" - (org-export-data - (or (org-string-nw-p (plist-get info :closing)) - (when (plist-get info :with-headline-opening) - (org-element-map (plist-get info :parse-tree) 'headline - (lambda (head) - (when (eq (org-koma-letter--special-tag head info) - 'closing) - (org-element-property :title head))) - info t))) + (format "\\closing{%s}\n" + (org-koma-letter--keyword-or-headline + :closing (lambda (h i) (eq (org-koma-letter--special-tag h i) + 'closing)) info)) - (org-koma-letter--special-contents-as-macro - (plist-get info :with-after-closing)) + (org-koma-letter--special-contents-inline + (plist-get info :special-tags-after-closing) info) ;; Letter end. "\n\\end{letter}\n" - (org-koma-letter--special-contents-as-macro - (plist-get info :with-after-letter) t t) + (org-koma-letter--special-contents-inline + (plist-get info :special-tags-after-letter) info) ;; Document end. "\n\\end{document}")) @@ -684,14 +711,24 @@ holding export options." "Build settings string according to type. SCOPE is either `global' or `buffer'. INFO is a plist used as a communication channel." - (let ((check-scope - (function - ;; Non-nil value when SETTING was defined in SCOPE. - (lambda (setting) - (let ((property (intern (format ":inbuffer-%s" setting)))) - (if (eq scope 'global) - (eq (plist-get info property) 'koma-letter:empty) - (not (eq (plist-get info property) 'koma-letter:empty)))))))) + (let* ((check-scope + (function + ;; Non-nil value when SETTING was defined in SCOPE. + (lambda (setting) + (let ((property (intern (format ":inbuffer-%s" setting)))) + (if (eq scope 'global) + (eq (plist-get info property) 'koma-letter:empty) + (not (eq (plist-get info property) 'koma-letter:empty))))))) + (heading-or-key-value + (function + (lambda (heading key &optional scoped) + (let* ((heading-val + (org-koma-letter--get-tagged-contents heading)) + (key-val (org-string-nw-p (plist-get info key))) + (scopedp (funcall check-scope (or scoped heading)))) + (and (or (and key-val scopedp) heading-val) + (not (and (eq scope 'global) heading-val)) + (if scopedp key-val heading-val))))))) (concat ;; Name. (let ((author (plist-get info :author))) @@ -699,6 +736,11 @@ a communication channel." (funcall check-scope 'author) (format "\\setkomavar{fromname}{%s}\n" (org-export-data author info)))) + ;; From. + (let ((from (funcall heading-or-key-value 'from :from-address))) + (and from + (format "\\setkomavar{fromaddress}{%s}\n" + (org-koma-letter--add-latex-newlines from)))) ;; Email. (let ((email (plist-get info :email))) (and email @@ -742,6 +784,10 @@ a communication channel." (format "\\setkomavar{place}{%s}\n" (if (plist-get info :with-place) (plist-get info :place) "")))) + ;; Location. + (let ((location (funcall heading-or-key-value 'location :location))) + (and location + (format "\\setkomavar{location}{%s}\n" location))) ;; Folding marks. (and (funcall check-scope 'with-foldmarks) (let ((foldmarks (plist-get info :with-foldmarks))) diff --git a/contrib/lisp/ox-rss.el b/contrib/lisp/ox-rss.el index 4cdfe0e..a3ba274 100644 --- a/contrib/lisp/ox-rss.el +++ b/contrib/lisp/ox-rss.el @@ -31,10 +31,11 @@ ;; `org-rss-export-as-rss' (temporary buffer) and `org-rss-export-to-rss' ;; (as a ".xml" file). ;; -;; This backend understands two new option keywords: +;; This backend understands three new option keywords: ;; ;; #+RSS_EXTENSION: xml ;; #+RSS_IMAGE_URL: http://myblog.org/mypicture.jpg +;; #+RSS_FEED_URL: http://myblog.org/feeds/blog.xml ;; ;; It uses #+HTML_LINK_HOME: to set the base url of the feed. ;; @@ -127,6 +128,7 @@ When nil, Org will create ids using `org-icalendar-create-uid'." (:with-toc nil nil nil) ;; Never include HTML's toc (:rss-extension "RSS_EXTENSION" nil org-rss-extension) (:rss-image-url "RSS_IMAGE_URL" nil org-rss-image-url) + (:rss-feed-url "RSS_FEED_URL" nil nil t) (:rss-categories nil nil org-rss-categories)) :filters-alist '((:filter-final-output . org-rss-final-function)) :translate-alist '((headline . org-rss-headline) @@ -226,59 +228,61 @@ Return output file name." "Transcode HEADLINE element into RSS format. CONTENTS is the headline contents. INFO is a plist used as a communication channel." - (unless (or (org-element-property :footnote-section-p headline) - ;; Only consider first-level headlines - (> (org-export-get-relative-level headline info) 1)) - (let* ((author (and (plist-get info :with-author) - (let ((auth (plist-get info :author))) - (and auth (org-export-data auth info))))) - (htmlext (plist-get info :html-extension)) - (hl-number (org-export-get-headline-number headline info)) - (hl-home (file-name-as-directory (plist-get info :html-link-home))) - (hl-pdir (plist-get info :publishing-directory)) - (hl-perm (org-element-property :RSS_PERMALINK headline)) - (anchor (org-export-get-reference headline info)) - (category (org-rss-plain-text - (or (org-element-property :CATEGORY headline) "") info)) - (pubdate0 (org-element-property :PUBDATE headline)) - (pubdate (let ((system-time-locale "C")) - (if pubdate0 - (format-time-string - "%a, %d %b %Y %H:%M:%S %z" - (org-time-string-to-time pubdate0))))) - (title (or (org-element-property :RSS_TITLE headline) - (replace-regexp-in-string - org-bracket-link-regexp - (lambda (m) (or (match-string 3 m) - (match-string 1 m))) - (org-element-property :raw-value headline)))) - (publink - (or (and hl-perm (concat (or hl-home hl-pdir) hl-perm)) - (concat - (or hl-home hl-pdir) - (file-name-nondirectory - (file-name-sans-extension - (plist-get info :input-file))) "." htmlext "#" anchor))) - (guid (if org-rss-use-entry-url-as-guid - publink - (org-rss-plain-text - (or (org-element-property :ID headline) - (org-element-property :CUSTOM_ID headline) - publink) - info)))) - (if (not pubdate0) "" ;; Skip entries with no PUBDATE prop - (format - (concat - "<item>\n" - "<title>%s</title>\n" - "<link>%s</link>\n" - "<author>%s</author>\n" - "<guid isPermaLink=\"false\">%s</guid>\n" - "<pubDate>%s</pubDate>\n" - (org-rss-build-categories headline info) "\n" - "<description><![CDATA[%s]]></description>\n" - "</item>\n") - title publink author guid pubdate contents))))) + (if (> (org-export-get-relative-level headline info) 1) + (org-export-data-with-backend headline 'html info) + (unless (org-element-property :footnote-section-p headline) + (let* ((email (org-export-data (plist-get info :email) info)) + (author (and (plist-get info :with-author) + (let ((auth (plist-get info :author))) + (and auth (org-export-data auth info))))) + (htmlext (plist-get info :html-extension)) + (hl-number (org-export-get-headline-number headline info)) + (hl-home (file-name-as-directory (plist-get info :html-link-home))) + (hl-pdir (plist-get info :publishing-directory)) + (hl-perm (org-element-property :RSS_PERMALINK headline)) + (anchor (org-export-get-reference headline info)) + (category (org-rss-plain-text + (or (org-element-property :CATEGORY headline) "") info)) + (pubdate0 (org-element-property :PUBDATE headline)) + (pubdate (let ((system-time-locale "C")) + (if pubdate0 + (format-time-string + "%a, %d %b %Y %H:%M:%S %z" + (org-time-string-to-time pubdate0))))) + (title (org-rss-plain-text + (or (org-element-property :RSS_TITLE headline) + (replace-regexp-in-string + org-bracket-link-regexp + (lambda (m) (or (match-string 3 m) + (match-string 1 m))) + (org-element-property :raw-value headline))) info)) + (publink + (or (and hl-perm (concat (or hl-home hl-pdir) hl-perm)) + (concat + (or hl-home hl-pdir) + (file-name-nondirectory + (file-name-sans-extension + (plist-get info :input-file))) "." htmlext "#" anchor))) + (guid (if org-rss-use-entry-url-as-guid + publink + (org-rss-plain-text + (or (org-element-property :ID headline) + (org-element-property :CUSTOM_ID headline) + publink) + info)))) + (if (not pubdate0) "" ;; Skip entries with no PUBDATE prop + (format + (concat + "<item>\n" + "<title>%s</title>\n" + "<link>%s</link>\n" + "<author>%s (%s)</author>\n" + "<guid isPermaLink=\"false\">%s</guid>\n" + "<pubDate>%s</pubDate>\n" + (org-rss-build-categories headline info) "\n" + "<description><![CDATA[%s]]></description>\n" + "</item>\n") + title publink email author guid pubdate contents)))))) (defun org-rss-build-categories (headline info) "Build categories for the RSS item." @@ -316,7 +320,7 @@ as a communication channel." (defun org-rss-build-channel-info (info) "Build the RSS channel information." (let* ((system-time-locale "C") - (title (plist-get info :title)) + (title (org-export-data (plist-get info :title) info)) (email (org-export-data (plist-get info :email) info)) (author (and (plist-get info :with-author) (let ((auth (plist-get info :author))) @@ -331,10 +335,11 @@ as a communication channel." (image (url-encode-url (plist-get info :rss-image-url))) (ifile (plist-get info :input-file)) (publink - (concat (file-name-as-directory blogurl) - (file-name-nondirectory - (file-name-sans-extension ifile)) - "." rssext))) + (or (plist-get info :rss-feed-url) + (concat (file-name-as-directory blogurl) + (file-name-nondirectory + (file-name-sans-extension ifile)) + "." rssext)))) (format "\n<title>%s</title> <atom:link href=\"%s\" rel=\"self\" type=\"application/rss+xml\" /> diff --git a/contrib/lisp/ox-taskjuggler.el b/contrib/lisp/ox-taskjuggler.el index 664a0ea..133d8a3 100644 --- a/contrib/lisp/ox-taskjuggler.el +++ b/contrib/lisp/ox-taskjuggler.el @@ -603,7 +603,7 @@ doesn't include leading \"depends\"." (let ((id (org-element-property :TASK_ID dep))) (and id (string-match (concat id " +\\({.*?}\\)") dep-str) - (org-match-string-no-properties 1 dep-str)))) + (match-string-no-properties 1 dep-str)))) path) ;; Compute number of exclamation marks by looking for the ;; common ancestor between TASK and DEP. |