summaryrefslogtreecommitdiff
path: root/contrib/lisp
diff options
context:
space:
mode:
Diffstat (limited to 'contrib/lisp')
-rw-r--r--contrib/lisp/ob-eukleides.el2
-rw-r--r--contrib/lisp/ob-mathematica.el79
-rw-r--r--contrib/lisp/ob-oz.el2
-rw-r--r--contrib/lisp/ob-stata.el313
-rw-r--r--contrib/lisp/ob-tcl.el4
-rw-r--r--contrib/lisp/org-annotate-file.el114
-rw-r--r--contrib/lisp/org-bibtex-extras.el24
-rw-r--r--contrib/lisp/org-collector.el8
-rw-r--r--contrib/lisp/org-colview-xemacs.el101
-rw-r--r--contrib/lisp/org-contacts.el153
-rw-r--r--contrib/lisp/org-download.el392
-rw-r--r--contrib/lisp/org-drill.el942
-rw-r--r--contrib/lisp/org-ebib.el47
-rw-r--r--contrib/lisp/org-effectiveness.el298
-rw-r--r--contrib/lisp/org-eldoc.el165
-rw-r--r--contrib/lisp/org-eww.el171
-rw-r--r--contrib/lisp/org-expiry.el5
-rwxr-xr-xcontrib/lisp/org-favtable.el1701
-rw-r--r--contrib/lisp/org-git-link.el27
-rw-r--r--contrib/lisp/org-index.el2497
-rw-r--r--contrib/lisp/org-jira.el64
-rw-r--r--contrib/lisp/org-license.el540
-rw-r--r--contrib/lisp/org-mac-link.el613
-rw-r--r--contrib/lisp/org-mew.el4
-rw-r--r--contrib/lisp/org-mime.el123
-rw-r--r--contrib/lisp/org-mtags.el255
-rw-r--r--contrib/lisp/org-notmuch.el36
-rw-r--r--contrib/lisp/org-passwords.el384
-rw-r--r--contrib/lisp/org-toc.el4
-rw-r--r--contrib/lisp/org-velocity.el309
-rw-r--r--contrib/lisp/org-wikinodes.el18
-rw-r--r--contrib/lisp/ox-bibtex.el357
-rw-r--r--contrib/lisp/ox-confluence.el30
-rw-r--r--contrib/lisp/ox-deck.el21
-rw-r--r--contrib/lisp/ox-extra.el190
-rw-r--r--contrib/lisp/ox-freemind.el2
-rw-r--r--contrib/lisp/ox-gfm.el193
-rw-r--r--contrib/lisp/ox-groff.el66
-rw-r--r--contrib/lisp/ox-koma-letter.el671
-rw-r--r--contrib/lisp/ox-rss.el75
-rw-r--r--contrib/lisp/ox-s5.el10
-rw-r--r--contrib/lisp/ox-taskjuggler.el61
42 files changed, 7587 insertions, 3484 deletions
diff --git a/contrib/lisp/ob-eukleides.el b/contrib/lisp/ob-eukleides.el
index c8ce881..cb5bb84 100644
--- a/contrib/lisp/ob-eukleides.el
+++ b/contrib/lisp/ob-eukleides.el
@@ -81,7 +81,7 @@ This function is called by `org-babel-execute-src-block'."
(shell-command (format org-eukleides-eps-to-raster
(concat (file-name-sans-extension out-file) ".eps")
(concat (file-name-sans-extension out-file) ".png")))
- (error "Conversion to PNG not supported. use a file with an EPS name")))
+ (error "Conversion to PNG not supported. Use a file with an EPS name")))
(with-temp-file in-file (insert body))
(message "%s" cmd) (org-babel-eval cmd "")
diff --git a/contrib/lisp/ob-mathematica.el b/contrib/lisp/ob-mathematica.el
new file mode 100644
index 0000000..a796741
--- /dev/null
+++ b/contrib/lisp/ob-mathematica.el
@@ -0,0 +1,79 @@
+;;; ob-mathematica.el --- org-babel functions for Mathematica evaluation
+
+;; Copyright (C) 2014 Yi Wang
+
+;; Authors: Yi Wang
+;; Keywords: literate programming, reproducible research
+;; Homepage: https://github.com/tririver/wy-els/blob/master/ob-mathematica.el
+;; Distributed under the GNU GPL v2 or later
+
+;; Org-Babel support for evaluating Mathematica source code.
+
+;;; Code:
+(require 'ob)
+(require 'ob-ref)
+(require 'ob-comint)
+(require 'ob-eval)
+;; Optionally require mma.el for font lock, etc
+(require 'mma nil 'noerror)
+(add-to-list 'org-src-lang-modes '("mathematica" . "mma"))
+
+(defvar org-babel-tangle-lang-exts)
+(add-to-list 'org-babel-tangle-lang-exts '("mathematica" . "m"))
+
+(defvar org-babel-default-header-args:mathematica '())
+
+(defvar org-babel-mathematica-command "MathematicaScript -script"
+ "Name of the command for executing Mathematica code.")
+
+(defvar org-babel-mathematica-command-alt "math -noprompt"
+ "Name of the command for executing Mathematica code.")
+
+(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))))
+ (concat
+ (mapconcat ;; define any variables
+ (lambda (pair)
+ (format "%s=%s;"
+ (car pair)
+ (org-babel-mathematica-var-to-mathematica (cdr pair))))
+ vars "\n") "\nPrint[\n" body "\n]\n")))
+
+(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)))
+ (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
+ (with-temp-file tmp-script-file (insert full-body))
+ ;; (with-temp-file "/tmp/dbg" (insert full-body))
+ ((lambda (raw)
+ (if (or (member "code" result-params)
+ (member "pp" result-params)
+ (and (member "output" result-params)
+ (not (member "table" result-params))))
+ raw
+ (org-babel-script-escape (org-babel-trim raw))))
+ (org-babel-eval (concat cmd " " tmp-script-file) ""))))
+
+(defun org-babel-prep-session:mathematica (session params)
+ "This function does nothing so far"
+ (error "Currently no support for sessions"))
+
+(defun org-babel-prep-session:mathematica (session body params)
+ "This function does nothing so far"
+ (error "Currently no support for sessions"))
+
+(defun org-babel-mathematica-var-to-mathematica (var)
+ "Convert an elisp value to a Mathematica variable.
+Convert an elisp value, VAR, into a string of Mathematica source code
+specifying a variable of the same value."
+ (if (listp var)
+ (concat "{" (mapconcat #'org-babel-mathematica-var-to-mathematica var ", ") "}")
+ (format "%S" var)))
+
+(provide 'ob-mathematica)
+
diff --git a/contrib/lisp/ob-oz.el b/contrib/lisp/ob-oz.el
index 3531d95..fc778f5 100644
--- a/contrib/lisp/ob-oz.el
+++ b/contrib/lisp/ob-oz.el
@@ -226,7 +226,7 @@ called by `org-babel-execute-src-block' via multiple-value-bind."
((member "value" result-params)
(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.")))
+ (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))
diff --git a/contrib/lisp/ob-stata.el b/contrib/lisp/ob-stata.el
new file mode 100644
index 0000000..29aa88d
--- /dev/null
+++ b/contrib/lisp/ob-stata.el
@@ -0,0 +1,313 @@
+;;; ob-stata.el --- org-babel functions for stata code evaluation
+
+;; Copyright (C) 2014 Ista Zahn
+;; Author: Ista Zahn istazahn@gmail.com
+;; G. Jay Kerns
+;; Eric Schulte
+;; Dan Davison
+
+
+;; 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, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+
+;;; Commentary:
+
+;; The file provides Org-Babel support for evaluating stata code.
+;; It is basically result of find-and-replace "stata" for "julia"
+;; in ob-julia.el by G. Jay Kerns. Only ":results output" works: the
+;; header args must include ":results output" (this is the default).
+;; Note that I'm not sure ':results value' makes sense or is useful
+;; but I have left all the value-processing stuff inherited from
+;; ob-julia and ob-R. ':results graphics' would be nice, but I have
+;; not tried to implement it.
+;; --Ista, 07/30/2014
+
+;;; Requirements:
+;; Stata: http://stata.com
+;; ESS: http://ess.r-project.org
+
+;;; Code:
+(require 'ob)
+(eval-when-compile (require 'cl))
+
+(declare-function orgtbl-to-csv "org-table" (table params))
+(declare-function stata "ext:ess-stata" (&optional start-args))
+(declare-function inferior-ess-send-input "ext:ess-inf" ())
+(declare-function ess-make-buffer-current "ext:ess-inf" ())
+(declare-function ess-eval-buffer "ext:ess-inf" (vis))
+(declare-function org-number-sequence "org-compat" (from &optional to inc))
+(declare-function org-remove-if-not "org" (predicate seq))
+
+(defconst org-babel-header-args:stata
+ '((width . :any)
+ (horizontal . :any)
+ (results . ((file list vector table scalar verbatim)
+ (raw org html latex code pp wrap)
+ (replace silent append prepend)
+ ;; NOTE: not sure 'value' makes sense in stata
+ ;; we may want to remove it from the list
+ (output value graphics))))
+ "stata-specific header arguments.")
+
+(add-to-list 'org-babel-tangle-lang-exts '("stata" . "do"))
+
+;; only ':results output' currently works, so make that the default
+(defvar org-babel-default-header-args:stata '((:results . "output")))
+
+(defcustom org-babel-stata-command inferior-STA-program-name
+ "Name of command to use for executing stata code."
+ :group 'org-babel
+ :version "24.4"
+ :package-version '(Org . "8.3")
+ :type 'string)
+
+(defvar ess-local-process-name) ; dynamically scoped
+(defun org-babel-edit-prep:stata (info)
+ (let ((session (cdr (assoc :session (nth 2 info)))))
+ (when (and session (string-match "^\\*\\(.+?\\)\\*$" session))
+ (save-match-data (org-babel-stata-initiate-session session nil)))))
+
+(defun org-babel-expand-body:stata (body params &optional graphics-file)
+ "Expand BODY according to PARAMS, return the expanded body."
+ (let ((graphics-file
+ (or graphics-file (org-babel-stata-graphical-output-file params))))
+ (mapconcat
+ #'identity
+ ((lambda (inside)
+ (if graphics-file
+ inside
+ inside))
+ (append (org-babel-variable-assignments:stata params)
+ (list body))) "\n")))
+
+(defun org-babel-execute:stata (body params)
+ "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)))
+ (session (org-babel-stata-initiate-session
+ (cdr (assoc :session params)) params))
+ (colnames-p (cdr (assoc :colnames params)))
+ (rownames-p (cdr (assoc :rownames params)))
+ (graphics-file (org-babel-stata-graphical-output-file params))
+ (full-body (org-babel-expand-body:stata body params graphics-file))
+ (result
+ (org-babel-stata-evaluate
+ session full-body result-type result-params
+ (or (equal "yes" colnames-p)
+ (org-babel-pick-name
+ (cdr (assoc :colname-names params)) colnames-p))
+ (or (equal "yes" rownames-p)
+ (org-babel-pick-name
+ (cdr (assoc :rowname-names params)) rownames-p)))))
+ (if graphics-file nil result))))
+
+(defun org-babel-prep-session:stata (session params)
+ "Prepare SESSION according to the header arguments specified in PARAMS."
+ (let* ((session (org-babel-stata-initiate-session session params))
+ (var-lines (org-babel-variable-assignments:stata params)))
+ (org-babel-comint-in-buffer session
+ (mapc (lambda (var)
+ (end-of-line 1) (insert var) (comint-send-input nil t)
+ (org-babel-comint-wait-for-output session)) var-lines))
+ session))
+
+(defun org-babel-load-session:stata (session body params)
+ "Load BODY into SESSION."
+ (save-window-excursion
+ (let ((buffer (org-babel-prep-session:stata session params)))
+ (with-current-buffer buffer
+ (goto-char (process-mark (get-buffer-process (current-buffer))))
+ (insert (org-babel-chomp body)))
+ buffer)))
+
+;; helper functions
+
+(defun org-babel-variable-assignments:stata (params)
+ "Return list of stata statements assigning the block's variables."
+ (let ((vars (mapcar #'cdr (org-babel-get-header params :var))))
+ (mapcar
+ (lambda (pair)
+ (org-babel-stata-assign-elisp
+ (car pair) (cdr pair)
+ (equal "yes" (cdr (assoc :colnames params)))
+ (equal "yes" (cdr (assoc :rownames params)))))
+ (mapcar
+ (lambda (i)
+ (cons (car (nth i vars))
+ (org-babel-reassemble-table
+ (cdr (nth i vars))
+ (cdr (nth i (cdr (assoc :colname-names params))))
+ (cdr (nth i (cdr (assoc :rowname-names params)))))))
+ (org-number-sequence 0 (1- (length vars)))))))
+
+(defun org-babel-stata-quote-csv-field (s)
+ "Quote field S for export to stata."
+ (if (stringp s)
+ (concat "\"" (mapconcat 'identity (split-string s "\"") "\"\"") "\"")
+ (format "%S" s)))
+
+(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
+ #'sequencep value))))
+ (min (apply #'min (mapcar #'length (org-remove-if-not
+ #'sequencep value))))
+ (transition-file (org-babel-temp-file "stata-import-")))
+ ;; ensure VALUE has an orgtbl structure (depth of at least 2)
+ (unless (listp (car value)) (setq value (list value)))
+ (with-temp-file transition-file
+ (insert
+ (orgtbl-to-csv value '(:fmt org-babel-stata-quote-csv-field))
+ "\n"))
+ (let ((file (org-babel-process-file-name transition-file 'noquote))
+ (header (if (or (eq (nth 1 value) 'hline) colnames-p)
+ "TRUE" "FALSE"))
+ (row-names (if rownames-p "1" "NULL")))
+ (if (= max min)
+ (format "%s = insheet using \"%s\"" name file)
+ (format "%s = insheet using \"%s\""
+ name file))))
+ (format "%s = %s" name (org-babel-stata-quote-csv-field value))))
+
+(defvar ess-ask-for-ess-directory) ; dynamically scoped
+
+(defun org-babel-stata-initiate-session (session params)
+ "If there is not a current stata process then create one."
+ (unless (string= session "none")
+ (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))))))
+ (if (org-babel-comint-buffer-livep session)
+ session
+ (save-window-excursion
+ (require 'ess) (stata)
+ (rename-buffer
+ (if (bufferp session)
+ (buffer-name session)
+ (if (stringp session)
+ session
+ (buffer-name))))
+ (current-buffer))))))
+
+(defun org-babel-stata-associate-session (session)
+ "Associate stata code buffer with a stata session.
+Make SESSION be the inferior ESS process associated with the
+current code buffer."
+ (setq ess-local-process-name
+ (process-name (get-buffer-process session)))
+ (ess-make-buffer-current))
+
+(defun org-babel-stata-graphical-output-file (params)
+ "Name of file to which stata should send graphical output."
+ (and (member "graphics" (cdr (assq :result-params params)))
+ (cdr (assq :file params))))
+
+(defvar org-babel-stata-eoe-indicator "display \"org_babel_stata_eoe\"")
+(defvar org-babel-stata-eoe-output "org_babel_stata_eoe")
+
+(defvar org-babel-stata-write-object-command "outsheet using \"%s\"")
+
+(defun org-babel-stata-evaluate
+ (session body result-type result-params column-names-p row-names-p)
+ "Evaluate stata code in BODY."
+ (if session
+ (org-babel-stata-evaluate-session
+ session body result-type result-params column-names-p row-names-p)
+ (org-babel-stata-evaluate-external-process
+ body result-type result-params column-names-p row-names-p)))
+
+(defun org-babel-stata-evaluate-external-process
+ (body result-type result-params column-names-p row-names-p)
+ "Evaluate BODY in external stata process.
+If RESULT-TYPE equals 'output then return standard output as a
+string. If RESULT-TYPE equals 'value then return the value of the
+last statement in BODY, as elisp."
+ (case result-type
+ (value
+ (let ((tmp-file (org-babel-temp-file "stata-")))
+ (org-babel-eval org-babel-stata-command
+ (format org-babel-stata-write-object-command
+ (org-babel-process-file-name tmp-file 'noquote)
+ (format "begin\n%s\nend" body)))
+ (org-babel-stata-process-value-result
+ (org-babel-result-cond result-params
+ (with-temp-buffer
+ (insert-file-contents tmp-file)
+ (buffer-string))
+ (org-babel-import-elisp-from-file tmp-file '(4)))
+ column-names-p)))
+ (output (org-babel-eval org-babel-stata-command body))))
+
+(defun org-babel-stata-evaluate-session
+ (session body result-type result-params column-names-p row-names-p)
+ "Evaluate BODY in SESSION.
+If RESULT-TYPE equals 'output then return standard output as a
+string. If RESULT-TYPE equals 'value then return the value of the
+last statement in BODY, as elisp."
+ (case result-type
+ (value
+ (with-temp-buffer
+ (insert (org-babel-chomp body))
+ (let ((ess-local-process-name
+ (process-name (get-buffer-process session)))
+ (ess-eval-visibly-p nil))
+ (ess-eval-buffer nil)))
+ (let ((tmp-file (org-babel-temp-file "stata-")))
+ (org-babel-comint-eval-invisibly-and-wait-for-file
+ session tmp-file
+ (format org-babel-stata-write-object-command
+ (org-babel-process-file-name tmp-file 'noquote) "ans"))
+ (org-babel-stata-process-value-result
+ (org-babel-result-cond result-params
+ (with-temp-buffer
+ (insert-file-contents tmp-file)
+ (buffer-string))
+ (org-babel-import-elisp-from-file tmp-file '(4)))
+ column-names-p)))
+ (output
+ (mapconcat
+ #'org-babel-chomp
+ (butlast
+ (delq nil
+ (mapcar
+ (lambda (line) (when (> (length line) 0) line))
+ (mapcar
+ (lambda (line) ;; cleanup extra prompts left in output
+ (if (string-match
+ "^\\([ ]*[>+\\.][ ]?\\)+\\([[0-9]+\\|[ ]\\)" line)
+ (substring line (match-end 1))
+ line))
+ (org-babel-comint-with-output (session org-babel-stata-eoe-output)
+ (insert (mapconcat #'org-babel-chomp
+ (list body org-babel-stata-eoe-indicator)
+ "\n"))
+ (inferior-ess-send-input)))))) "\n"))))
+
+(defun org-babel-stata-process-value-result (result column-names-p)
+ "stata-specific processing of return value.
+Insert hline if column names in output have been requested."
+ (if column-names-p
+ (cons (car result) (cons 'hline (cdr result)))
+ result))
+
+(provide 'ob-stata)
+
+;;; ob-stata.el ends here
diff --git a/contrib/lisp/ob-tcl.el b/contrib/lisp/ob-tcl.el
index 50afe5a..d66357d 100644
--- a/contrib/lisp/ob-tcl.el
+++ b/contrib/lisp/ob-tcl.el
@@ -62,7 +62,7 @@ This function is called by `org-babel-execute-src-block'."
(defun org-babel-prep-session:tcl (session params)
"Prepare SESSION according to the header arguments in PARAMS."
- (error "Sessions are not supported for Tcl."))
+ (error "Sessions are not supported for Tcl"))
(defun org-babel-variable-assignments:tcl (params)
"Return list of tcl statements assigning the block's variables."
@@ -111,7 +111,7 @@ close $o
If RESULT-TYPE equals 'output then return a list of the outputs
of the statements in BODY, if RESULT-TYPE equals 'value then
return the value of the last statement in BODY, as elisp."
- (when session (error "Sessions are not supported for Tcl."))
+ (when session (error "Sessions are not supported for Tcl"))
(case result-type
(output (org-babel-eval org-babel-tcl-command body))
(value (let ((tmp-file (org-babel-temp-file "tcl-")))
diff --git a/contrib/lisp/org-annotate-file.el b/contrib/lisp/org-annotate-file.el
index 05cc45f..b8e8bd9 100644
--- a/contrib/lisp/org-annotate-file.el
+++ b/contrib/lisp/org-annotate-file.el
@@ -25,7 +25,7 @@
;;; Commentary:
;; This is yet another implementation to allow the annotation of a
-;; file without modification of the file itself. The annotation is in
+;; file without modification of the file itself. The annotation is in
;; org syntax so you can use all of the org features you are used to.
;; To use you might put the following in your .emacs:
@@ -47,30 +47,41 @@
;; and next time you hit C-c C-l you will hit those notes again.
;;
;; To put a subheading with a text search for the current line set
-;; `org-annotate-file-add-search` to non-nil value. Then when you hit
+;; `org-annotate-file-add-search` to non-nil value. Then when you hit
;; C-c C-l (on the above line for example) you will get:
;; * ~/org-annotate-file.el
-;; ** `org-annotate-file-add-search` to non-nil value. Then whe...
+;; ** `org-annotate-file-add-search` to non-nil value. Then whe...
;; Note that both of the above will be links.
-(require 'org)
-
-(defvar org-annotate-file-storage-file "~/.org-annotate-file.org"
- "File in which to keep annotations.")
+;;; Code:
-(defvar org-annotate-file-add-search nil
- "If non-nil then add a link as a second level to the actual
-location in the file")
-
-(defvar org-annotate-file-always-open t
- "non-nil means always expand the full tree when you visit
-`org-annotate-file-storage-file'.")
+(require 'org)
-(defun org-annotate-file-elipsify-desc (string &optional after)
- "Strip starting and ending whitespace and replace any chars
-that appear after the value in `after' with '...'"
+(defgroup org-annotate-file nil
+ "Org Annotate"
+ :group 'org)
+
+(defcustom org-annotate-file-storage-file "~/.org-annotate-file.org"
+ "File in which to keep annotations."
+ :group 'org-annotate-file
+ :type 'file)
+
+(defcustom org-annotate-file-add-search nil
+ "If non-nil, add a link as a second level to the actual file location."
+ :group 'org-annotate-file
+ :type 'boolean)
+
+(defcustom org-annotate-file-always-open t
+ "If non-nil, always expand the full tree when visiting the annotation file."
+ :group 'org-annotate-file
+ :type 'boolean)
+
+(defun org-annotate-file-ellipsify-desc (string &optional after)
+ "Return shortened STRING with appended ellipsis.
+Trim whitespace at beginning and end of STRING and replace any
+ characters that appear after the occurrence of AFTER with '...'"
(let* ((after (number-to-string (or after 30)))
(replace-map (list (cons "^[ \t]*" "")
(cons "[ \t]*$" "")
@@ -82,46 +93,61 @@ that appear after the value in `after' with '...'"
replace-map)
string))
+;;;###autoload
(defun org-annotate-file ()
- "Put a section for the current file into your annotation file"
+ "Visit `org-annotate-file-storage-file` and add a new annotation section.
+The annotation is opened at the new section which will be referencing
+the point in the current file."
(interactive)
(unless (buffer-file-name)
- (error "This buffer has no associated file"))
- (org-annotate-file-show-section))
-
-(defun org-annotate-file-show-section (&optional buffer)
- "Visit the buffer named `org-annotate-file-storage-file' and
-show the relevant section"
- (let* ((filename (abbreviate-file-name (or buffer (buffer-file-name))))
- (line (buffer-substring-no-properties (point-at-bol) (point-at-eol)))
- (link (org-make-link-string (concat "file:" filename) filename))
+ (error "This buffer has no associated file!"))
+ (switch-to-buffer
+ (org-annotate-file-show-section org-annotate-file-storage-file)))
+
+;;;###autoload
+(defun org-annotate-file-show-section (storage-file &optional annotated-buffer)
+ "Add or show annotation entry in STORAGE-FILE and return the buffer.
+The annotation will link to ANNOTATED-BUFFER if specified,
+ otherwise the current buffer is used."
+ (let ((filename (abbreviate-file-name (or annotated-buffer
+ (buffer-file-name))))
+ (line (buffer-substring-no-properties (point-at-bol) (point-at-eol)))
+ (annotation-buffer (find-file-noselect storage-file)))
+ (with-current-buffer annotation-buffer
+ (org-annotate-file-annotate filename line))
+ annotation-buffer))
+
+(defun org-annotate-file-annotate (filename line)
+ "Add annotation for FILENAME at LINE using current buffer."
+ (let* ((link (org-make-link-string (concat "file:" filename) filename))
(search-link (org-make-link-string
(concat "file:" filename "::" line)
- (org-annotate-file-elipsify-desc line))))
- (with-current-buffer (find-file org-annotate-file-storage-file)
- (unless (eq major-mode 'org-mode)
- (org-mode))
- (goto-char (point-min))
- (widen)
- (when org-annotate-file-always-open
- (show-all))
+ (org-annotate-file-ellipsify-desc line))))
+ (unless (eq major-mode 'org-mode)
+ (org-mode))
+ (goto-char (point-min))
+ (widen)
+ (when org-annotate-file-always-open
+ (show-all))
+ (unless (search-forward-regexp
+ (concat "^* " (regexp-quote link)) nil t)
+ (org-annotate-file-add-upper-level link))
+ (beginning-of-line)
+ (org-narrow-to-subtree)
+ ;; deal with a '::' search if need be
+ (when org-annotate-file-add-search
(unless (search-forward-regexp
- (concat "^* " (regexp-quote link)) nil t)
- (org-annotate-file-add-upper-level link))
- (beginning-of-line)
- (org-narrow-to-subtree)
- ;; deal with a '::' search if need be
- (when org-annotate-file-add-search
- (unless (search-forward-regexp
- (concat "^** " (regexp-quote search-link)) nil t)
- (org-annotate-file-add-second-level search-link))))))
+ (concat "^** " (regexp-quote search-link)) nil t)
+ (org-annotate-file-add-second-level search-link)))))
(defun org-annotate-file-add-upper-level (link)
+ "Add and link heading to LINK."
(goto-char (point-min))
(call-interactively 'org-insert-heading)
(insert link))
(defun org-annotate-file-add-second-level (link)
+ "Add and link subheading to LINK."
(goto-char (point-at-eol))
(call-interactively 'org-insert-subheading)
(insert link))
diff --git a/contrib/lisp/org-bibtex-extras.el b/contrib/lisp/org-bibtex-extras.el
index d392d2d..5f05039 100644
--- a/contrib/lisp/org-bibtex-extras.el
+++ b/contrib/lisp/org-bibtex-extras.el
@@ -75,25 +75,14 @@ For example, to point to your `obe-bibtex-file' use the following.
"Return all citations from `obe-bibtex-file'."
(or obe-citations
(save-window-excursion
- (find-file obe-bibtex-file)
+ (find-file (or obe-bibtex-file
+ (error "`obe-bibtex-file' has not been configured")))
(goto-char (point-min))
(while (re-search-forward " :CUSTOM_ID: \\(.+\\)$" nil t)
(push (org-no-properties (match-string 1))
obe-citations))
obe-citations)))
-(defun obe-goto-citation (&optional citation)
- "Visit a citation given its ID."
- (interactive)
- (let ((citation (or citation
- (org-icompleting-read "Citation: "
- (obe-citations)))))
- (find-file obe-bibtex-file)
- (goto-char (point-min))
- (when (re-search-forward (format " :CUSTOM_ID: %s" citation) nil t)
- (outline-previous-visible-heading 1)
- t)))
-
(defun obe-html-export-citations ()
"Convert all \\cite{...} citations in the current file into HTML links."
(save-excursion
@@ -105,15 +94,6 @@ For example, to point to your `obe-bibtex-file' use the following.
(mapcar #'org-babel-trim
(split-string (match-string 1) ",")) ", "))))))
-(defun obe-get-meta-data (citation)
- "Collect meta-data for CITATION."
- (save-excursion
- (when (obe-goto-citation citation)
- (let ((pt (point)))
- `((:authors . ,(split-string (org-entry-get pt "AUTHOR") " and " t))
- (:title . ,(org-no-properties (org-get-heading 1 1)))
- (:journal . ,(org-entry-get pt "JOURNAL")))))))
-
(defun obe-meta-to-json (meta &optional fields)
"Turn a list of META data from citations into a string of json."
(let ((counter 1) nodes links)
diff --git a/contrib/lisp/org-collector.el b/contrib/lisp/org-collector.el
index 7f3b344..5894707 100644
--- a/contrib/lisp/org-collector.el
+++ b/contrib/lisp/org-collector.el
@@ -121,6 +121,7 @@ preceeding the dblock, then update the contents of the dblock."
(scope (plist-get params :scope))
(noquote (plist-get params :noquote))
(colnames (plist-get params :colnames))
+ (defaultval (plist-get params :defaultval))
(content-lines (org-split-string (plist-get params :content) "\n"))
id table line pos)
(save-excursion
@@ -133,9 +134,10 @@ preceeding the dblock, then update the contents of the dblock."
(t (error "Cannot find entry with :ID: %s" id))))
(unless (eq id 'global) (org-narrow-to-subtree))
(setq stringformat (if noquote "%s" "%S"))
- (setq table (org-propview-to-table
- (org-propview-collect cols stringformat conds match scope inherit
- (if colnames colnames cols)) stringformat))
+ (let ((org-propview-default-value (if defaultval defaultval org-propview-default-value)))
+ (setq table (org-propview-to-table
+ (org-propview-collect cols stringformat conds match scope inherit
+ (if colnames colnames cols)) stringformat)))
(widen))
(setq pos (point))
(when content-lines
diff --git a/contrib/lisp/org-colview-xemacs.el b/contrib/lisp/org-colview-xemacs.el
index 67a2aad..a27275e 100644
--- a/contrib/lisp/org-colview-xemacs.el
+++ b/contrib/lisp/org-colview-xemacs.el
@@ -1,6 +1,6 @@
;;; org-colview-xemacs.el --- Column View in Org-mode, XEmacs-specific version
-;; Copyright (C) 2004-2014
+;; Copyright (C) 2004-2015
;; Carsten Dominik
;; Author: Carsten Dominik <carsten at orgmode dot org>
@@ -303,10 +303,6 @@ This is the compiled version of the format.")
(beginning-of-line 1)
(and (looking-at "\\(\\**\\)\\(\\* \\)")
(org-get-level-face 2))))
- (item (save-match-data
- (org-remove-tabs
- (buffer-substring-no-properties
- (point-at-bol) (point-at-eol)))))
(color (if (featurep 'xemacs)
(save-excursion
(beginning-of-line 1)
@@ -335,10 +331,10 @@ This is the compiled version of the format.")
(while (setq column (pop fmt))
(setq property (car column)
title (nth 1 column)
- ass (if (equal property "ITEM")
- (cons "ITEM" item)
- (assoc property props))
- width (or (cdr (assoc property org-columns-current-maxwidths))
+ 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 | ")
@@ -351,9 +347,7 @@ This is the compiled version of the format.")
(funcall org-columns-modify-value-for-display-function
title val))
((equal property "ITEM")
- (if (derived-mode-p 'org-mode)
- (org-columns-cleanup-item
- val org-columns-current-fmt-compiled)))
+ (org-columns-compact-links val))
((and calc (functionp calc)
(not (string= val ""))
(not (get-text-property 0 'org-computed val)))
@@ -438,7 +432,9 @@ This is the compiled version of the format.")
(while (setq column (pop fmt))
(setq property (car column)
str (or (nth 1 column) property)
- width (or (cdr (assoc property org-columns-current-maxwidths))
+ width (or (cdr (assoc-string property
+ org-columns-current-maxwidths
+ t))
(nth 2 column)
(length str))
widths (push width widths)
@@ -503,26 +499,6 @@ This is the compiled version of the format.")
(current-buffer))
(setq truncate-lines org-colview-initial-truncate-line-value)))))
-
-(defun org-columns-cleanup-item (item fmt)
- "Remove from ITEM what is a column in the format FMT."
- (if (not org-complex-heading-regexp)
- item
- (when (string-match org-complex-heading-regexp item)
- (setq item
- (concat
- (org-add-props (match-string 1 item) nil
- 'org-whitespace (* 2 (1- (org-reduced-level (- (match-end 1) (match-beginning 1))))))
- (and (match-end 2) (not (assoc "TODO" fmt)) (concat " " (match-string 2 item)))
- (and (match-end 3) (not (assoc "PRIORITY" fmt)) (concat " " (match-string 3 item)))
- " " (save-match-data (org-columns-compact-links (or (match-string 4 item) "")))
- (and (match-end 5) (not (assoc "TAGS" fmt)) (concat " " (match-string 5 item)))))
- (add-text-properties
- 0 (1+ (match-end 1))
- (list 'org-whitespace (* 2 (1- (org-reduced-level (- (match-end 1) (match-beginning 1))))))
- item)
- item)))
-
(defun org-columns-compact-links (s)
"Replace [[link][desc]] with [desc] or [link]."
(while (string-match org-bracket-link-regexp s)
@@ -657,7 +633,7 @@ Where possible, use the standard interface for changing this line."
(org-columns-display-here)))
(org-move-to-column col)
(if (and (derived-mode-p 'org-mode)
- (nth 3 (assoc key org-columns-current-fmt-compiled)))
+ (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????
@@ -736,7 +712,9 @@ an integer, select that value."
org-columns-overlays)))
(allowed (or (org-property-get-allowed-values pom key)
(and (memq
- (nth 4 (assoc key org-columns-current-fmt-compiled))
+ (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)))
@@ -785,7 +763,7 @@ an integer, select that value."
(org-columns-eval '(org-entry-put pom key nval)))
(org-columns-display-here)))
(org-move-to-column col)
- (and (nth 3 (assoc key org-columns-current-fmt-compiled))
+ (and (nth 3 (assoc-string key org-columns-current-fmt-compiled t))
(org-columns-update key))))))
(defun org-colview-construct-allowed-dates (s)
@@ -924,7 +902,9 @@ interactive function `org-columns-new'.
"Insert a new column, to the left of the current column."
(interactive)
(let ((n (org-columns-current-column))
- (editp (and prop (assoc prop org-columns-current-fmt-compiled)))
+ (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))
@@ -980,7 +960,9 @@ interactive function `org-columns-new'.
(let* ((n (org-columns-current-column))
(entry (nth n org-columns-current-fmt-compiled))
(width (or (nth 2 entry)
- (cdr (assoc (car entry) org-columns-current-maxwidths)))))
+ (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)
@@ -1052,11 +1034,14 @@ Don't set this, this is meant for dynamic scoping.")
(push (cons (match-string 1 s) 1) rtn)
(setq start (match-end 0)))
(mapc (lambda (x)
- (setcdr x (apply 'max
+ (setcdr x
+ (apply 'max
+ (let ((prop (car x)))
(mapcar
(lambda (y)
- (length (or (cdr (assoc (car x) (cdr y))) " ")))
- cache))))
+ (length (or (cdr (assoc-string prop (cdr y) t))
+ " ")))
+ cache)))))
rtn)
rtn))
@@ -1081,9 +1066,11 @@ Don't set this, this is meant for dynamic scoping.")
(when (equal (overlay-get ov 'org-columns-key) property)
(setq pos (overlay-start ov))
(goto-char pos)
- (when (setq val (cdr (assoc property
- (get-text-property
- (point-at-bol) 'org-summaries))))
+ (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)
@@ -1098,11 +1085,11 @@ Don't set this, this is meant for dynamic scoping.")
"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???
+ (lmax 30) ; Does anyone use deeper levels???
(lvals (make-vector lmax nil))
(lflag (make-vector lmax nil))
(level 0)
- (ass (assoc property org-columns-current-fmt-compiled))
+ (ass (assoc-string property org-columns-current-fmt-compiled t))
(format (nth 4 ass))
(printf (nth 5 ass))
(fun (nth 6 ass))
@@ -1131,12 +1118,12 @@ Don't set this, this is meant for dynamic scoping.")
str1 (org-add-props (copy-sequence str) nil 'org-computed t 'face 'bold)
useval (if flag str1 (if valflag val ""))
sum-alist (get-text-property sumpos 'org-summaries))
- (if (assoc property sum-alist)
- (setcdr (assoc property sum-alist) useval)
- (push (cons property useval) sum-alist)
- (org-unmodified
- (add-text-properties sumpos (1+ sumpos)
- (list 'org-summaries sum-alist))))
+ (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
@@ -1553,7 +1540,7 @@ and tailing newline characters."
(org-get-at-bol 'org-marker)))
(setq p (org-entry-properties m))
- (when (or (not (setq a (assoc org-effort-property p)))
+ (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
@@ -1617,7 +1604,7 @@ This will add overlays to the date lines, to show the summary for each day."
(t ;; do the summary
(setq lsum nil)
(dolist (x entries)
- (setq v (cdr (assoc prop x)))
+ (setq v (cdr (assoc-string prop x t)))
(if v
(push
(funcall
@@ -1667,8 +1654,10 @@ This will add overlays to the date lines, to show the summary for each day."
(if (equal (car fm) "CLOCKSUM")
(org-clock-sum)
(when (and (nth 4 fm)
- (setq a (assoc (car fm)
- org-columns-current-fmt-compiled))
+ (setq a (assoc-string
+ (car fm)
+ org-columns-current-fmt-compiled
+ t))
(equal (nth 4 a) (nth 4 fm)))
(org-columns-compute (car fm)))))))))))
diff --git a/contrib/lisp/org-contacts.el b/contrib/lisp/org-contacts.el
index 0bc9cd7..edc09fe 100644
--- a/contrib/lisp/org-contacts.el
+++ b/contrib/lisp/org-contacts.el
@@ -155,6 +155,11 @@ The following replacements are available:
:type 'string
:group 'org-contacts)
+(defcustom org-contacts-tags-props-prefix "#"
+ "Tags and properties prefix."
+ :type 'string
+ :group 'org-contacts)
+
(defcustom org-contacts-matcher
(mapconcat 'identity (list org-contacts-email-property
org-contacts-alias-property
@@ -183,6 +188,12 @@ This overrides `org-email-link-description-format' if set."
:group 'org-contacts
:type 'boolean)
+(defcustom org-contacts-complete-functions
+ '(org-contacts-complete-group org-contacts-complete-tags-props org-contacts-complete-name)
+ "List of functions used to complete contacts in `message-mode'."
+ :group 'org-contacts
+ :type 'hook)
+
;; Decalre external functions and variables
(declare-function org-reverse-string "org")
(declare-function diary-ordinal-suffix "ext:diary-lib")
@@ -244,30 +255,56 @@ to dead or no buffer."
(let* (todo-only
(contacts-matcher
(cdr (org-make-tags-matcher org-contacts-matcher)))
- markers result)
+ result)
(when (org-contacts-db-need-update-p)
(let ((progress-reporter
(make-progress-reporter "Updating Org Contacts Database..." 0 (length org-contacts-files)))
(i 0))
(dolist (file (org-contacts-files))
- (org-check-agenda-file file)
- (with-current-buffer (org-get-agenda-file-buffer file)
- (unless (eq major-mode 'org-mode)
- (error "File %s is no in `org-mode'" file))
- (org-scan-tags
- '(add-to-list 'markers (set-marker (make-marker) (point)))
- contacts-matcher
- todo-only))
+ (if (catch 'nextfile
+ ;; if file doesn't exist and the user agrees to removing it
+ ;; from org-agendas-list, 'nextfile is thrown. Catch it here
+ ;; and skip processing the file.
+ ;;
+ ;; TODO: suppose that the user has set an org-contacts-files
+ ;; list that contains an element that doesn't exist in the
+ ;; file system: in that case, the org-agenda-files list could
+ ;; be updated (and saved to the customizations of the user) if
+ ;; it contained the same file even though the org-agenda-files
+ ;; list wasn't actually used. I don't think it is normal that
+ ;; org-contacts updates org-agenda-files in this case, but
+ ;; short of duplicating org-check-agenda-files and
+ ;; org-remove-files, I don't know how to avoid it.
+ ;;
+ ;; A side effect of the TODO is that the faulty
+ ;; org-contacts-files list never gets updated and thus the
+ ;; user is always queried about the missing files when
+ ;; org-contacts-db-need-update-p returns true.
+ (org-check-agenda-file file))
+ (message "Skipped %s removed from org-agenda-files list."
+ (abbreviate-file-name file))
+ (with-current-buffer (org-get-agenda-file-buffer file)
+ (unless (eq major-mode 'org-mode)
+ (error "File %s is not in `org-mode'" file))
+ (setf result
+ (append result
+ (org-scan-tags
+ 'org-contacts-at-point
+ contacts-matcher
+ todo-only)))))
(progress-reporter-update progress-reporter (setq i (1+ i))))
- (dolist (marker markers result)
- (org-with-point-at marker
- (add-to-list 'result
- (list (org-get-heading t) marker (org-entry-properties marker 'all)))))
(setf org-contacts-db result
org-contacts-last-update (current-time))
- (progress-reporter-done progress-reporter)))
+ (progress-reporter-done progress-reporter)))
org-contacts-db))
+(defun org-contacts-at-point (&optional pom)
+ "Return the contacts at point-or-marker POM or current position
+if nil."
+ (setq pom (or pom (point)))
+ (org-with-point-at pom
+ (list (org-get-heading t) (set-marker (make-marker) pom) (org-entry-properties pom 'all))))
+
(defun org-contacts-filter (&optional name-match tags-match prop-match)
"Search for a contact matching any of NAME-MATCH, TAGS-MATCH, PROP-MATCH.
If all match values are nil, return all contacts.
@@ -500,11 +537,12 @@ A group FOO is composed of contacts with the tag FOO."
;; returned by `org-contacts-filter'.
for contact-name = (car contact)
;; Grab the first email of the contact
- for email = (org-contacts-strip-link (car (org-contacts-split-property
- (or
- (cdr (assoc-string org-contacts-email-property
- (caddr 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))
", ")))
@@ -512,6 +550,45 @@ A group FOO is composed of contacts with the tag FOO."
(completion-table-case-fold completion-list
(not org-contacts-completion-ignore-case))))))))
+(defun org-contacts-complete-tags-props (start end string)
+ "Insert emails that match the tags expression.
+
+For example: FOO-BAR will match entries tagged with FOO but not
+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
+ (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))
+ ",")))
+ (when (not (string= "" result))
+ ;; return (start end function)
+ (lexical-let* ((to-return result))
+ (list start end
+ (lambda (string pred &optional to-ignore) to-return))))))))
(defun org-contacts-remove-ignored-property-values (ignore-list list)
"Remove all ignore-list's elements from list and you can use
@@ -570,8 +647,8 @@ A group FOO is composed of contacts with the tag FOO."
(goto-char (match-end 0))
(point))))
(string (buffer-substring start end)))
- (or (org-contacts-complete-group start end string)
- (org-contacts-complete-name start end string))))))
+ (run-hook-with-args-until-success
+ 'org-contacts-complete-functions start end string)))))
(defun org-contacts-gnus-get-name-email ()
"Get name and email address from Gnus message."
@@ -826,7 +903,7 @@ address."
(setq email (org-contacts-strip-link email))
(org-contacts-check-mail-address email)
(compose-mail (org-contacts-format-email (org-get-heading t) email)))))
- (error (format "This contact has no mail address set (no %s property)."
+ (error (format "This contact has no mail address set (no %s property)"
org-contacts-email-property)))))))
(defun org-contacts-get-icon (&optional pom)
@@ -946,7 +1023,7 @@ to do our best."
(setq phones-list (org-contacts-remove-ignored-property-values ignore-list (org-contacts-split-property tel)))
(setq result "")
(while phones-list
- (setq result (concat result "TEL:" (org-contacts-strip-link (car phones-list)) "\n"))
+ (setq result (concat result "TEL:" (org-link-unescape (org-contacts-strip-link (car phones-list))) "\n"))
(setq phones-list (cdr phones-list)))
result))
(when bday
@@ -960,11 +1037,39 @@ to do our best."
"END:VCARD\n\n")))
(defun org-contacts-export-as-vcard (&optional name file to-buffer)
+ "Export org contacts to V-Card 3.0.
+
+By default, all contacts are exported to `org-contacts-vcard-file'.
+
+When NAME is \\[universal-argument], prompts for a contact name.
+
+When NAME is \\[universal-argument] \\[universal-argument],
+prompts for a contact name and a file name where to export.
+
+When NAME is \\[universal-argument] \\[universal-argument]
+\\[universal-argument], prompts for a contact name and a buffer where to export.
+
+If the function is not called interactively, all parameters are
+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: "))))
+ (org-contacts-export-as-vcard-internal name file to-buffer))
+
+(defun org-contacts-export-as-vcard-internal (&optional name file to-buffer)
"Export all contacts matching NAME as VCard 3.0.
If TO-BUFFER is nil, the content is written to FILE or
`org-contacts-vcard-file'. If TO-BUFFER is non-nil, the buffer
is created and the VCard is written into that buffer."
- (interactive) ; TODO ask for name?
(let* ((filename (or file org-contacts-vcard-file))
(buffer (if to-buffer
(get-buffer-create to-buffer)
diff --git a/contrib/lisp/org-download.el b/contrib/lisp/org-download.el
new file mode 100644
index 0000000..6bff649
--- /dev/null
+++ b/contrib/lisp/org-download.el
@@ -0,0 +1,392 @@
+;;; org-download.el --- Image drag-and-drop for Emacs org-mode
+
+;; Copyright (C) 2014-2015 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-drill.el b/contrib/lisp/org-drill.el
index 4387161..a78b806 100644
--- a/contrib/lisp/org-drill.el
+++ b/contrib/lisp/org-drill.el
@@ -1,73 +1,91 @@
;; -*- coding: utf-8-unix -*-
;;; org-drill.el - Self-testing using spaced repetition
;;;
-;; Author: Paul Sexton <eeeickythump@gmail.com>
-;; Version: 2.3.7
-;; Repository at http://bitbucket.org/eeeickythump/org-drill/
-;;
-;; 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, 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 and synopsis:
+;;; Copyright (C) 2010-2015 Paul Sexton
;;;
-;; Uses the SuperMemo spaced repetition algorithms to conduct interactive
-;; "drill sessions", where the material to be remembered is presented to the
-;; student in random order. The student rates his or her recall of each item,
-;; and this information is used to schedule the item for later revision.
-;;
-;; Each drill session can be restricted to topics in the current buffer
-;; (default), one or several files, all agenda files, or a subtree. A single
-;; topic can also be drilled.
-;;
-;; Different "card types" can be defined, which present their information to
-;; the student in different ways.
-;;
-;; See the file README.org for more detailed documentation.
-;;
-;;; Code:
+;;; Author: Paul Sexton <eeeickythump@gmail.com>
+;;; Version: 2.4.7
+;;; Keywords: flashcards, memory, learning, memorization
+;;; Repository at http://bitbucket.org/eeeickythump/org-drill/
+;;;
+;;; 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 distaributed 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/>.
+;;;
+;;;
+;;; Synopsis
+;;; ========
+;;;
+;;; Uses the SuperMemo spaced repetition algorithms to conduct interactive
+;;; "drill sessions", where the material to be remembered is presented to the
+;;; student in random order. The student rates his or her recall of each item,
+;;; and this information is used to schedule the item for later revision.
+;;;
+;;; Each drill session can be restricted to topics in the current buffer
+;;; (default), one or several files, all agenda files, or a subtree. A single
+;;; topic can also be drilled.
+;;;
+;;; Different "card types" can be defined, which present their information to
+;;; the student in different ways.
+;;;
+;;; See the file README.org for more detailed documentation.
+
(eval-when-compile (require 'cl))
(eval-when-compile (require 'hi-lock))
+(require 'cl-lib)
+(require 'hi-lock)
(require 'org)
(require 'org-id)
(require 'org-learn)
+(require 'savehist)
+
(defgroup org-drill nil
"Options concerning interactive drill sessions in Org mode (org-drill)."
:tag "Org-Drill"
:group 'org-link)
-(defcustom org-drill-question-tag "drill"
+
+
+(defcustom org-drill-question-tag
+ "drill"
"Tag which topics must possess in order to be identified as review topics
by `org-drill'."
:group 'org-drill
:type 'string)
-(defcustom org-drill-maximum-items-per-session 30
+
+(defcustom org-drill-maximum-items-per-session
+ 30
"Each drill session will present at most this many topics for review.
Nil means unlimited."
:group 'org-drill
:type '(choice integer (const nil)))
-(defcustom org-drill-maximum-duration 20
+
+
+(defcustom org-drill-maximum-duration
+ 20
"Maximum duration of a drill session, in minutes.
Nil means unlimited."
:group 'org-drill
:type '(choice integer (const nil)))
-(defcustom org-drill-failure-quality 2
+
+(defcustom org-drill-failure-quality
+ 2
"If the quality of recall for an item is this number or lower,
it is regarded as an unambiguous failure, and the repetition
interval for the card is reset to 0 days. If the quality is higher
@@ -81,7 +99,9 @@ really sensible."
:group 'org-drill
:type '(choice (const 2) (const 1)))
-(defcustom org-drill-forgetting-index 10
+
+(defcustom org-drill-forgetting-index
+ 10
"What percentage of items do you consider it is 'acceptable' to
forget each drill session? The default is 10%. A warning message
is displayed at the end of the session if the percentage forgotten
@@ -89,13 +109,17 @@ climbs above this number."
:group 'org-drill
:type 'integer)
-(defcustom org-drill-leech-failure-threshold 15
+
+(defcustom org-drill-leech-failure-threshold
+ 15
"If an item is forgotten more than this many times, it is tagged
as a 'leech' item."
:group 'org-drill
:type '(choice integer (const nil)))
-(defcustom org-drill-leech-method 'skip
+
+(defcustom org-drill-leech-method
+ 'skip
"How should 'leech items' be handled during drill sessions?
Possible values:
- nil :: Leech items are treated the same as normal items.
@@ -106,60 +130,87 @@ Possible values:
:group 'org-drill
:type '(choice (const warn) (const skip) (const nil)))
+
(defface org-drill-visible-cloze-face
'((t (:foreground "darkseagreen")))
"The face used to hide the contents of cloze phrases."
:group 'org-drill)
+
(defface org-drill-visible-cloze-hint-face
'((t (:foreground "dark slate blue")))
"The face used to hide the contents of cloze phrases."
:group 'org-drill)
+
(defface org-drill-hidden-cloze-face
'((t (:foreground "deep sky blue" :background "blue")))
"The face used to hide the contents of cloze phrases."
:group 'org-drill)
-(defcustom org-drill-use-visible-cloze-face-p nil
+
+(defcustom org-drill-use-visible-cloze-face-p
+ nil
"Use a special face to highlight cloze-deleted text in org mode
buffers?"
:group 'org-drill
:type 'boolean)
-(defcustom org-drill-hide-item-headings-p nil
+
+(defcustom org-drill-hide-item-headings-p
+ nil
"Conceal the contents of the main heading of each item during drill
sessions? You may want to enable this behaviour if item headings or tags
contain information that could 'give away' the answer."
:group 'org-drill
:type 'boolean)
-(defcustom org-drill-new-count-color "royal blue"
+
+(defcustom org-drill-new-count-color
+ "royal blue"
"Foreground colour used to display the count of remaining new items
during a drill session."
:group 'org-drill
:type 'color)
-(defcustom org-drill-mature-count-color "green"
+(defcustom org-drill-mature-count-color
+ "green"
"Foreground colour used to display the count of remaining mature items
during a drill session. Mature items are due for review, but are not new."
:group 'org-drill
:type 'color)
-(defcustom org-drill-failed-count-color "red"
+(defcustom org-drill-failed-count-color
+ "red"
"Foreground colour used to display the count of remaining failed items
during a drill session."
:group 'org-drill
:type 'color)
-(defcustom org-drill-done-count-color "sienna"
+(defcustom org-drill-done-count-color
+ "sienna"
"Foreground colour used to display the count of reviewed items
during a drill session."
:group 'org-drill
:type 'color)
+(defcustom org-drill-left-cloze-delimiter
+ "["
+ "String used within org buffers to delimit cloze deletions."
+ :group 'org-drill
+ :type 'string)
+
+(defcustom org-drill-right-cloze-delimiter
+ "]"
+ "String used within org buffers to delimit cloze deletions."
+ :group 'org-drill
+ :type 'string)
+
+
(setplist 'org-drill-cloze-overlay-defaults
- '(display "[...]"
+ `(display ,(format "%s...%s"
+ org-drill-left-cloze-delimiter
+ org-drill-right-cloze-delimiter)
face org-drill-hidden-cloze-face
window t))
@@ -171,21 +222,54 @@ during a drill session."
face default
window t))
+(add-hook 'org-font-lock-set-keywords-hook 'org-drill-add-cloze-fontification)
+
+
(defvar org-drill-hint-separator "||"
"String which, if it occurs within a cloze expression, signifies that the
rest of the expression after the string is a `hint', to be displayed instead of
the hidden cloze during a test.")
-(defvar org-drill-cloze-regexp
- (concat "\\(\\[[[:cntrl:][:graph:][:space:]]+?\\)\\(\\|"
+(defun org-drill--compute-cloze-regexp ()
+ (concat "\\("
+ (regexp-quote org-drill-left-cloze-delimiter)
+ "[[:cntrl:][:graph:][:space:]]+?\\)\\(\\|"
(regexp-quote org-drill-hint-separator)
- ".+?\\)\\(\\]\\)"))
+ ".+?\\)\\("
+ (regexp-quote org-drill-right-cloze-delimiter)
+ "\\)"))
+
+(defun org-drill--compute-cloze-keywords ()
+ (list (list (org-drill--compute-cloze-regexp)
+ (copy-list '(1 'org-drill-visible-cloze-face nil))
+ (copy-list '(2 'org-drill-visible-cloze-hint-face t))
+ (copy-list '(3 'org-drill-visible-cloze-face nil))
+ )))
+
+(defvar-local org-drill-cloze-regexp
+ (org-drill--compute-cloze-regexp))
+
+
+(defvar-local org-drill-cloze-keywords
+ (org-drill--compute-cloze-keywords))
+
+
+;; Variables defining what keys can be pressed during drill sessions to quit the
+;; session, edit the item, etc.
+(defvar org-drill--quit-key ?q
+ "If this character is pressed during a drill session, quit the session.")
+(defvar org-drill--edit-key ?e
+ "If this character is pressed during a drill session, suspend the session
+with the cursor at the current item..")
+(defvar org-drill--help-key ??
+ "If this character is pressed during a drill session, show help.")
+(defvar org-drill--skip-key ?s
+ "If this character is pressed during a drill session, skip to the next
+item.")
+(defvar org-drill--tags-key ?t
+ "If this character is pressed during a drill session, edit the tags for
+the current item.")
-(defvar org-drill-cloze-keywords
- `((,org-drill-cloze-regexp
- (1 'org-drill-visible-cloze-face nil)
- (2 'org-drill-visible-cloze-hint-face t)
- (3 'org-drill-visible-cloze-face nil))))
(defcustom org-drill-card-type-alist
'((nil org-drill-present-simple-card)
@@ -234,7 +318,9 @@ even if their bodies are empty."
:type '(alist :key-type (choice string (const nil))
:value-type function))
-(defcustom org-drill-scope 'file
+
+(defcustom org-drill-scope
+ 'file
"The scope in which to search for drill items when conducting a
drill session. This can be any of:
@@ -265,13 +351,25 @@ directory All files with the extension '.org' in the same
(const :tag "All files with the extension '.org' in the same directory as the current file (includes the current file if it is an .org file.)" directory)
(repeat :tag "List of files to scan for drill items." file)))
-(defcustom org-drill-save-buffers-after-drill-sessions-p t
+
+(defcustom org-drill-match
+ nil
+ "If non-nil, a string specifying a tags/property/TODO query. During
+drill sessions, only items that match this query will be considered."
+ :group 'org-drill
+ :type '(choice (const nil) string))
+
+
+(defcustom org-drill-save-buffers-after-drill-sessions-p
+ t
"If non-nil, prompt to save all modified buffers after a drill session
finishes."
:group 'org-drill
:type 'boolean)
-(defcustom org-drill-spaced-repetition-algorithm 'sm5
+
+(defcustom org-drill-spaced-repetition-algorithm
+ 'sm5
"Which SuperMemo spaced repetition algorithm to use for scheduling items.
Available choices are:
- SM2 :: the SM2 algorithm, used in SuperMemo 2.0
@@ -286,26 +384,53 @@ Available choices are:
:group 'org-drill
:type '(choice (const sm2) (const sm5) (const simple8)))
-(defcustom org-drill-optimal-factor-matrix nil
+
+(defcustom org-drill-optimal-factor-matrix
+ nil
+ "Obsolete and will be removed in future. The SM5 optimal factor
+matrix data is now stored in the variable
+`org-drill-sm5-optimal-factor-matrix'."
+ :group 'org-drill
+ :type 'sexp)
+
+
+(defvar org-drill-sm5-optimal-factor-matrix
+ nil
"DO NOT CHANGE THE VALUE OF THIS VARIABLE.
-Persistent matrix of optimal factors, used by the SuperMemo SM5 algorithm.
-The matrix is saved (using the 'customize' facility) at the end of each
-drill session.
+Persistent matrix of optimal factors, used by the SuperMemo SM5
+algorithm. The matrix is saved at the end of each drill session.
Over time, values in the matrix will adapt to the individual user's
-pace of learning."
- :group 'org-drill
- :type 'sexp)
+pace of learning.")
+
+
+(add-to-list 'savehist-additional-variables
+ 'org-drill-sm5-optimal-factor-matrix)
+(unless savehist-mode
+ (savehist-mode 1))
+
+
+(defun org-drill--transfer-optimal-factor-matrix ()
+ (if (and org-drill-optimal-factor-matrix
+ (null org-drill-sm5-optimal-factor-matrix))
+ (setq org-drill-sm5-optimal-factor-matrix
+ org-drill-optimal-factor-matrix)))
+
+(add-hook 'after-init-hook 'org-drill--transfer-optimal-factor-matrix)
+
-(defcustom org-drill-sm5-initial-interval 4.0
+(defcustom org-drill-sm5-initial-interval
+ 4.0
"In the SM5 algorithm, the initial interval after the first
successful presentation of an item is always 4 days. If you wish to change
this, you can do so here."
:group 'org-drill
:type 'float)
-(defcustom org-drill-add-random-noise-to-intervals-p nil
+
+(defcustom org-drill-add-random-noise-to-intervals-p
+ nil
"If true, the number of days until an item's next repetition
will vary slightly from the interval calculated by the SM2
algorithm. The variation is very small when the interval is
@@ -313,7 +438,9 @@ small, but scales up with the interval."
:group 'org-drill
:type 'boolean)
-(defcustom org-drill-adjust-intervals-for-early-and-late-repetitions-p nil
+
+(defcustom org-drill-adjust-intervals-for-early-and-late-repetitions-p
+ nil
"If true, when the student successfully reviews an item 1 or more days
before or after the scheduled review date, this will affect that date of
the item's next scheduled review, according to the algorithm presented at
@@ -328,7 +455,9 @@ is used."
:group 'org-drill
:type 'boolean)
-(defcustom org-drill-cloze-text-weight 4
+
+(defcustom org-drill-cloze-text-weight
+ 4
"For card types 'hide1_firstmore', 'show1_lastmore' and 'show1_firstless',
this number determines how often the 'less favoured' situation
should arise. It will occur 1 in every N trials, where N is the
@@ -347,12 +476,15 @@ all weighted card types are treated as their unweighted equivalents."
:group 'org-drill
:type '(choice integer (const nil)))
-(defcustom org-drill-cram-hours 12
+
+(defcustom org-drill-cram-hours
+ 12
"When in cram mode, items are considered due for review if
they were reviewed at least this many hours ago."
:group 'org-drill
:type 'integer)
+
;;; NEW items have never been presented in a drill session before.
;;; MATURE items HAVE been presented at least once before.
;;; - YOUNG mature items were scheduled no more than
@@ -365,13 +497,17 @@ they were reviewed at least this many hours ago."
;;; LAST-INTERVAL * (ORG-DRILL-OVERDUE-INTERVAL-FACTOR - 1) days,
;;; regardless of young/old status.
-(defcustom org-drill-days-before-old 10
+
+(defcustom org-drill-days-before-old
+ 10
"When an item's inter-repetition interval rises above this value in days,
it is no longer considered a 'young' (recently learned) item."
:group 'org-drill
:type 'integer)
-(defcustom org-drill-overdue-interval-factor 1.2
+
+(defcustom org-drill-overdue-interval-factor
+ 1.2
"An item is considered overdue if its scheduled review date is
more than (ORG-DRILL-OVERDUE-INTERVAL-FACTOR - 1) * LAST-INTERVAL
days in the past. For example, a value of 1.2 means an additional
@@ -383,7 +519,9 @@ should never be less than 1.0."
:group 'org-drill
:type 'float)
-(defcustom org-drill-learn-fraction 0.5
+
+(defcustom org-drill-learn-fraction
+ 0.5
"Fraction between 0 and 1 that governs how quickly the spaces
between successive repetitions increase, for all items. The
default value is 0.5. Higher values make spaces increase more
@@ -393,6 +531,7 @@ exponential effect on inter-repetition spacing."
:group 'org-drill
:type 'float)
+
(defvar drill-answer nil
"Global variable that can be bound to a correct answer when an
item is being presented. If this variable is non-nil, the default
@@ -403,6 +542,7 @@ This variable is useful for card types that compute their answers
-- for example, a card type that asks the student to translate a
random number to another language. ")
+
(defvar *org-drill-session-qualities* nil)
(defvar *org-drill-start-time* 0)
(defvar *org-drill-new-entries* nil)
@@ -431,9 +571,16 @@ for review unless they were already reviewed in the recent past?")
'("LEARN_DATA" "DRILL_LAST_INTERVAL" "DRILL_REPEATS_SINCE_FAIL"
"DRILL_TOTAL_REPEATS" "DRILL_FAILURE_COUNT" "DRILL_AVERAGE_QUALITY"
"DRILL_EASE" "DRILL_LAST_QUALITY" "DRILL_LAST_REVIEWED"))
+(defvar org-drill--lapse-very-overdue-entries-p nil
+ "If non-nil, entries more than 90 days overdue are regarded as 'lapsed'.
+This means that when the item is eventually re-tested it will be
+treated as 'failed' (quality 2) for rescheduling purposes,
+regardless of whether the test was successful.")
+
;;; Make the above settings safe as file-local variables.
+
(put 'org-drill-question-tag 'safe-local-variable 'stringp)
(put 'org-drill-maximum-items-per-session 'safe-local-variable
'(lambda (val) (or (integerp val) (null val))))
@@ -458,15 +605,22 @@ for review unless they were already reviewed in the recent past?")
(put 'org-drill-overdue-interval-factor 'safe-local-variable 'floatp)
(put 'org-drill-scope 'safe-local-variable
'(lambda (val) (or (symbolp val) (listp val))))
+(put 'org-drill-match 'safe-local-variable
+ '(lambda (val) (or (stringp val) (null val))))
(put 'org-drill-save-buffers-after-drill-sessions-p 'safe-local-variable 'booleanp)
(put 'org-drill-cloze-text-weight 'safe-local-variable
'(lambda (val) (or (null val) (integerp val))))
+(put 'org-drill-left-cloze-delimiter 'safe-local-variable 'stringp)
+(put 'org-drill-right-cloze-delimiter 'safe-local-variable 'stringp)
+
;;;; Utilities ================================================================
+
(defun free-marker (m)
(set-marker m nil))
+
(defmacro pop-random (place)
(let ((idx (gensym)))
`(if (null ,place)
@@ -476,18 +630,20 @@ for review unless they were already reviewed in the recent past?")
(setq ,place (append (subseq ,place 0 ,idx)
(subseq ,place (1+ ,idx)))))))))
+
(defmacro push-end (val place)
"Add VAL to the end of the sequence stored in PLACE. Return the new
value."
`(setq ,place (append ,place (list ,val))))
+
(defun shuffle-list (list)
"Randomly permute the elements of LIST (all permutations equally likely)."
;; Adapted from 'shuffle-vector' in cookie1.el
(let ((i 0)
- j
- temp
- (len (length list)))
+ j
+ temp
+ (len (length list)))
(while (< i len)
(setq j (+ i (random* (- len i))))
(setq temp (nth i list))
@@ -496,28 +652,43 @@ value."
(setq i (1+ i))))
list)
+
(defun round-float (floatnum fix)
"Round the floating point number FLOATNUM to FIX decimal places.
Example: (round-float 3.56755765 3) -> 3.568"
(let ((n (expt 10 fix)))
(/ (float (round (* floatnum n))) n)))
+
(defun command-keybinding-to-string (cmd)
"Return a human-readable description of the key/keys to which the command
CMD is bound, or nil if it is not bound to a key."
(let ((key (where-is-internal cmd overriding-local-map t)))
(if key (key-description key))))
+
(defun time-to-inactive-org-timestamp (time)
(format-time-string
(concat "[" (substring (cdr org-time-stamp-formats) 1 -1) "]")
time))
-(defun org-map-drill-entries (func &optional scope &rest skip)
+
+(defun time-to-active-org-timestamp (time)
+ (format-time-string
+ (concat "<" (substring (cdr org-time-stamp-formats) 1 -1) ">")
+ time))
+
+
+(defun org-map-drill-entries (func &optional scope drill-match &rest skip)
"Like `org-map-entries', but only drill entries are processed."
- (let ((org-drill-scope (or scope org-drill-scope)))
+ (let ((org-drill-scope (or scope org-drill-scope))
+ (org-drill-match (or drill-match org-drill-match)))
(apply 'org-map-entries func
- (concat "+" org-drill-question-tag)
+ (concat "+" org-drill-question-tag
+ (if (and (stringp org-drill-match)
+ (not (member '(?+ ?- ?|) (elt org-drill-match 0))))
+ "+" "")
+ (or org-drill-match ""))
(case org-drill-scope
(file nil)
(file-no-restriction 'file)
@@ -527,6 +698,7 @@ CMD is bound, or nil if it is not bound to a key."
(t org-drill-scope))
skip)))
+
(defmacro with-hidden-cloze-text (&rest body)
`(progn
(org-drill-hide-clozed-text)
@@ -535,6 +707,7 @@ CMD is bound, or nil if it is not bound to a key."
,@body)
(org-drill-unhide-clozed-text))))
+
(defmacro with-hidden-cloze-hints (&rest body)
`(progn
(org-drill-hide-cloze-hints)
@@ -543,6 +716,7 @@ CMD is bound, or nil if it is not bound to a key."
,@body)
(org-drill-unhide-text))))
+
(defmacro with-hidden-comments (&rest body)
`(progn
(if org-drill-hide-item-headings-p
@@ -553,6 +727,7 @@ CMD is bound, or nil if it is not bound to a key."
,@body)
(org-drill-unhide-text))))
+
(defun org-drill-days-since-last-review ()
"Nil means a last review date has not yet been stored for
the item.
@@ -566,6 +741,7 @@ this should never happen."
(time-to-days (apply 'encode-time
(org-parse-time-string datestr)))))))
+
(defun org-drill-hours-since-last-review ()
"Like `org-drill-days-since-last-review', but return value is
in hours rather than days."
@@ -577,6 +753,7 @@ in hours rather than days."
(org-parse-time-string datestr))))
(* 60 60))))))
+
(defun org-drill-entry-p (&optional marker)
"Is MARKER, or the point, in a 'drill item'? This will return nil if
the point is inside a subheading of a drill item -- to handle that
@@ -586,10 +763,12 @@ situation use `org-part-of-drill-entry-p'."
(org-drill-goto-entry marker))
(member org-drill-question-tag (org-get-local-tags))))
+
(defun org-drill-goto-entry (marker)
(switch-to-buffer (marker-buffer marker))
(goto-char marker))
+
(defun org-part-of-drill-entry-p ()
"Is the current entry either the main heading of a 'drill item',
or a subheading within a drill item?"
@@ -597,6 +776,7 @@ or a subheading within a drill item?"
;; Does this heading INHERIT the drill tag
(member org-drill-question-tag (org-get-tags-at))))
+
(defun org-drill-goto-drill-entry-heading ()
"Move the point to the heading which holds the :drill: tag for this
drill entry."
@@ -608,11 +788,14 @@ drill entry."
(unless (org-up-heading-safe)
(error "Cannot find a parent heading that is marked as a drill entry"))))
+
+
(defun org-drill-entry-leech-p ()
"Is the current entry a 'leech item'?"
(and (org-drill-entry-p)
(member "leech" (org-get-local-tags))))
+
;; (defun org-drill-entry-due-p ()
;; (cond
;; (*org-drill-cram-mode*
@@ -630,6 +813,7 @@ drill entry."
;; (- (time-to-days (current-time))
;; (time-to-days item-time))))))))))
+
(defun org-drill-entry-days-overdue ()
"Returns:
- NIL if the item is not to be regarded as scheduled for review at all.
@@ -659,6 +843,7 @@ drill entry."
(- (time-to-days (current-time))
(time-to-days item-time))))))))
+
(defun org-drill-entry-overdue-p (&optional days-overdue last-interval)
"Returns true if entry that is scheduled DAYS-OVERDUE dasy in the past,
and whose last inter-repetition interval was LAST-INTERVAL, should be
@@ -674,28 +859,34 @@ from the entry at point."
(> (/ (+ days-overdue last-interval 1.0) last-interval)
org-drill-overdue-interval-factor)))
+
+
(defun org-drill-entry-due-p ()
(let ((due (org-drill-entry-days-overdue)))
(and (not (null due))
(not (minusp due)))))
+
(defun org-drill-entry-new-p ()
(and (org-drill-entry-p)
(let ((item-time (org-get-scheduled-time (point))))
(null item-time))))
+
(defun org-drill-entry-last-quality (&optional default)
(let ((quality (org-entry-get (point) "DRILL_LAST_QUALITY")))
(if quality
(string-to-number quality)
default)))
+
(defun org-drill-entry-failure-count ()
(let ((quality (org-entry-get (point) "DRILL_FAILURE_COUNT")))
(if quality
(string-to-number quality)
0)))
+
(defun org-drill-entry-average-quality (&optional default)
(let ((val (org-entry-get (point) "DRILL_AVERAGE_QUALITY")))
(if val
@@ -726,16 +917,17 @@ from the entry at point."
(string-to-number val)
default)))
+
;;; From http://www.supermemo.com/english/ol/sm5.htm
(defun org-drill-random-dispersal-factor ()
"Returns a random number between 0.5 and 1.5."
(let ((a 0.047)
(b 0.092)
(p (- (random* 1.0) 0.5)))
- (flet ((sign (n)
- (cond ((zerop n) 0)
- ((plusp n) 1)
- (t -1))))
+ (cl-flet ((sign (n)
+ (cond ((zerop n) 0)
+ ((plusp n) 1)
+ (t -1))))
(/ (+ 100 (* (* (/ -1 b) (log (- 1 (* (/ b a ) (abs p)))))
(sign p)))
100.0))))
@@ -748,9 +940,10 @@ from the entry at point."
(- variation)
mean))
+
(defun org-drill-early-interval-factor (optimal-factor
- optimal-interval
- days-ahead)
+ optimal-interval
+ days-ahead)
"Arguments:
- OPTIMAL-FACTOR: interval-factor if the item had been tested
exactly when it was supposed to be.
@@ -767,6 +960,7 @@ in the matrix."
(- optimal-factor
(* delta-ofmax (/ days-ahead (+ days-ahead (* 0.6 optimal-interval)))))))
+
(defun org-drill-get-item-data ()
"Returns a list of 6 items, containing all the stored recall
data for the item at point:
@@ -804,6 +998,7 @@ in the matrix."
(t ; virgin item
(list 0 0 0 0 nil nil)))))
+
(defun org-drill-store-item-data (last-interval repeats failures
total-repeats meanq
ease)
@@ -819,8 +1014,11 @@ in the matrix."
(org-set-property "DRILL_EASE"
(number-to-string (round-float ease 3))))
+
+
;;; SM2 Algorithm =============================================================
+
(defun determine-next-interval-sm2 (last-interval n ef quality
failures meanq total-repeats)
"Arguments:
@@ -840,7 +1038,7 @@ Returns a list: (INTERVAL REPEATS EF FAILURES MEAN TOTAL-REPEATS OFMATRIX), wher
;; When an item is failed, its interval is reset to 0,
;; but its EF is unchanged
(list -1 1 ef (1+ failures) meanq (1+ total-repeats)
- org-drill-optimal-factor-matrix)
+ org-drill-sm5-optimal-factor-matrix)
;; else:
(let* ((next-ef (modify-e-factor ef quality))
(interval
@@ -864,11 +1062,13 @@ Returns a list: (INTERVAL REPEATS EF FAILURES MEAN TOTAL-REPEATS OFMATRIX), wher
(1+ n)
next-ef
failures meanq (1+ total-repeats)
- org-drill-optimal-factor-matrix))))
+ org-drill-sm5-optimal-factor-matrix))))
;;; SM5 Algorithm =============================================================
+
+
(defun initial-optimal-factor-sm5 (n ef)
(if (= 1 n)
org-drill-sm5-initial-interval
@@ -877,17 +1077,19 @@ Returns a list: (INTERVAL REPEATS EF FAILURES MEAN TOTAL-REPEATS OFMATRIX), wher
(defun get-optimal-factor-sm5 (n ef of-matrix)
(let ((factors (assoc n of-matrix)))
(or (and factors
- (let ((ef-of (assoc ef (cdr factors))))
- (and ef-of (cdr ef-of))))
- (initial-optimal-factor-sm5 n ef))))
+ (let ((ef-of (assoc ef (cdr factors))))
+ (and ef-of (cdr ef-of))))
+ (initial-optimal-factor-sm5 n ef))))
+
(defun inter-repetition-interval-sm5 (last-interval n ef &optional of-matrix)
(let ((of (get-optimal-factor-sm5 n ef (or of-matrix
- org-drill-optimal-factor-matrix))))
+ org-drill-sm5-optimal-factor-matrix))))
(if (= 1 n)
- of
+ of
(* of last-interval))))
+
(defun determine-next-interval-sm5 (last-interval n ef quality
failures meanq total-repeats
of-matrix &optional delta-days)
@@ -896,12 +1098,14 @@ Returns a list: (INTERVAL REPEATS EF FAILURES MEAN TOTAL-REPEATS OFMATRIX), wher
(assert (> n 0))
(assert (and (>= quality 0) (<= quality 5)))
(unless of-matrix
- (setq of-matrix org-drill-optimal-factor-matrix))
+ (setq of-matrix org-drill-sm5-optimal-factor-matrix))
(setq of-matrix (cl-copy-tree of-matrix))
+
(setq meanq (if meanq
(/ (+ quality (* meanq total-repeats 1.0))
(1+ total-repeats))
quality))
+
(let ((next-ef (modify-e-factor ef quality))
(old-ef ef)
(new-of (modify-of (get-optimal-factor-sm5 n ef of-matrix)
@@ -914,10 +1118,13 @@ Returns a list: (INTERVAL REPEATS EF FAILURES MEAN TOTAL-REPEATS OFMATRIX), wher
(inter-repetition-interval-sm5
last-interval n ef of-matrix)
delta-days)))
+
(setq of-matrix
(set-optimal-factor n next-ef of-matrix
(round-float new-of 3))) ; round OF to 3 d.p.
+
(setq ef next-ef)
+
(cond
;; "Failed" -- reset repetitions to 0,
((<= quality org-drill-failure-quality)
@@ -942,8 +1149,10 @@ Returns a list: (INTERVAL REPEATS EF FAILURES MEAN TOTAL-REPEATS OFMATRIX), wher
(1+ total-repeats)
of-matrix)))))
+
;;; Simple8 Algorithm =========================================================
+
(defun org-drill-simple8-first-interval (failures)
"Arguments:
- FAILURES: integer >= 0. The total number of times the item has
@@ -953,6 +1162,7 @@ Returns the optimal FIRST interval for an item which has previously been
forgotten on FAILURES occasions."
(* 2.4849 (exp (* -0.057 failures))))
+
(defun org-drill-simple8-interval-factor (ease repetition)
"Arguments:
- EASE: floating point number >= 1.2. Corresponds to `AF' in SM8 algorithm.
@@ -963,6 +1173,7 @@ The factor by which the last interval should be
multiplied to give the next interval. Corresponds to `RF' or `OF'."
(+ 1.2 (* (- ease 1.2) (expt org-drill-learn-fraction (log repetition 2)))))
+
(defun org-drill-simple8-quality->ease (quality)
"Returns the ease (`AF' in the SM8 algorithm) which corresponds
to a mean item quality of QUALITY."
@@ -972,6 +1183,7 @@ to a mean item quality of QUALITY."
(* -1.2403 quality)
1.4515))
+
(defun determine-next-interval-simple8 (last-interval repeats quality
failures meanq totaln
&optional delta-days)
@@ -1038,7 +1250,11 @@ See the documentation for `org-drill-get-item-data' for a description of these."
(org-drill-simple8-quality->ease meanq)
failures
meanq
- totaln)))
+ totaln
+ )))
+
+
+
;;; Essentially copied from `org-learn.el', but modified to
;;; optionally call the SM2 or simple8 functions.
@@ -1046,9 +1262,9 @@ See the documentation for `org-drill-get-item-data' for a description of these."
"If DAYS-AHEAD is supplied it must be a positive integer. The
item will be scheduled exactly this many days into the future."
(let ((delta-days (- (time-to-days (current-time))
- (time-to-days (or (org-get-scheduled-time (point))
- (current-time)))))
- (ofmatrix org-drill-optimal-factor-matrix)
+ (time-to-days (or (org-get-scheduled-time (point))
+ (current-time)))))
+ (ofmatrix org-drill-sm5-optimal-factor-matrix)
;; Entries can have weights, 1 by default. Intervals are divided by the
;; item's weight, so an item with a weight of 2 will have all intervals
;; halved, meaning you will end up reviewing it twice as often.
@@ -1087,11 +1303,11 @@ item will be scheduled exactly this many days into the future."
total-repeats meanq ease)
(if (eql 'sm5 org-drill-spaced-repetition-algorithm)
- (setq org-drill-optimal-factor-matrix new-ofmatrix))
+ (setq org-drill-sm5-optimal-factor-matrix new-ofmatrix))
(cond
((= 0 days-ahead)
- (org-schedule t))
+ (org-schedule '(4)))
((minusp days-ahead)
(org-schedule nil (current-time)))
(t
@@ -1117,7 +1333,7 @@ of QUALITY."
(sm5 (determine-next-interval-sm5 last-interval repetitions
ease quality failures
meanq total-repeats
- org-drill-optimal-factor-matrix))
+ org-drill-sm5-optimal-factor-matrix))
(sm2 (determine-next-interval-sm2 last-interval repetitions
ease quality failures
meanq total-repeats))
@@ -1147,11 +1363,19 @@ of QUALITY."
"Returns quality rating (0-5), or nil if the user quit."
(let ((ch nil)
(input nil)
- (next-review-dates (org-drill-hypothetical-next-review-dates)))
+ (next-review-dates (org-drill-hypothetical-next-review-dates))
+ (key-prompt (format "(0-5, %c=help, %c=edit, %c=tags, %c=quit)"
+ org-drill--help-key
+ org-drill--edit-key
+ org-drill--tags-key
+ org-drill--quit-key)))
(save-excursion
- (while (not (memq ch '(?q ?e ?0 ?1 ?2 ?3 ?4 ?5)))
+ (while (not (memq ch (list org-drill--quit-key
+ org-drill--edit-key
+ 7 ; C-g
+ ?0 ?1 ?2 ?3 ?4 ?5)))
(setq input (read-key-sequence
- (if (eq ch ??)
+ (if (eq ch org-drill--help-key)
(format "0-2 Means you have forgotten the item.
3-5 Means you have remembered the item.
@@ -1162,11 +1386,12 @@ of QUALITY."
4 - After a little bit of thought you remembered. (+%s days)
5 - You remembered the item really easily. (+%s days)
-How well did you do? (0-5, ?=help, e=edit, t=tags, q=quit)"
+How well did you do? %s"
(round (nth 3 next-review-dates))
(round (nth 4 next-review-dates))
- (round (nth 5 next-review-dates)))
- "How well did you do? (0-5, ?=help, e=edit, t=tags, q=quit)")))
+ (round (nth 5 next-review-dates))
+ key-prompt)
+ (format "How well did you do? %s" key-prompt))))
(cond
((stringp input)
(setq ch (elt input 0)))
@@ -1183,7 +1408,7 @@ How well did you do? (0-5, ?=help, e=edit, t=tags, q=quit)"
(case (car (elt input 0))
(wheel-up (ignore-errors (mwheel-scroll (elt input 0))))
(wheel-down (ignore-errors (mwheel-scroll (elt input 0)))))))
- (if (eql ch ?t)
+ (if (eql ch org-drill--tags-key)
(org-set-tags-command))))
(cond
((and (>= ch ?0) (<= ch ?5))
@@ -1191,8 +1416,9 @@ How well did you do? (0-5, ?=help, e=edit, t=tags, q=quit)"
(failures (org-drill-entry-failure-count)))
(unless *org-drill-cram-mode*
(save-excursion
- (org-drill-smart-reschedule quality
- (nth quality next-review-dates)))
+ (let ((quality (if (org-drill--entry-lapsed-p) 2 quality)))
+ (org-drill-smart-reschedule quality
+ (nth quality next-review-dates))))
(push quality *org-drill-session-qualities*)
(cond
((<= quality org-drill-failure-quality)
@@ -1213,11 +1439,12 @@ How well did you do? (0-5, ?=help, e=edit, t=tags, q=quit)"
(org-set-property "DRILL_LAST_REVIEWED"
(time-to-inactive-org-timestamp (current-time))))
quality))
- ((= ch ?e)
+ ((= ch org-drill--edit-key)
'edit)
(t
nil))))
+
;; (defun org-drill-hide-all-subheadings-except (heading-list)
;; "Returns a list containing the position of each immediate subheading of
;; the current topic."
@@ -1238,6 +1465,8 @@ How well did you do? (0-5, ?=help, e=edit, t=tags, q=quit)"
;; "" 'tree))
;; (reverse drill-sections)))
+
+
(defun org-drill-hide-subheadings-if (test)
"TEST is a function taking no arguments. TEST will be called for each
of the immediate subheadings of the current drill item, with the point
@@ -1260,11 +1489,13 @@ the current topic."
"" 'tree))
(reverse drill-sections)))
+
(defun org-drill-hide-all-subheadings-except (heading-list)
(org-drill-hide-subheadings-if
(lambda () (let ((drill-heading (org-get-heading t)))
(not (member drill-heading heading-list))))))
+
(defun org-drill-presentation-prompt (&rest fmt-and-args)
(let* ((item-start-time (current-time))
(input nil)
@@ -1279,8 +1510,12 @@ the current topic."
(apply 'format
(first fmt-and-args)
(rest fmt-and-args))
- (concat "Press key for answer, "
- "e=edit, t=tags, s=skip, q=quit."))))
+ (format (concat "Press key for answer, "
+ "%c=edit, %c=tags, %c=skip, %c=quit.")
+ org-drill--edit-key
+ org-drill--tags-key
+ org-drill--skip-key
+ org-drill--quit-key))))
(setq prompt
(format "%s %s %s %s %s %s"
(propertize
@@ -1326,7 +1561,7 @@ You seem to be having a lot of trouble memorising this item.
Consider reformulating the item to make it easier to remember.\n"
'face '(:foreground "red"))
prompt)))
- (while (memq ch '(nil ?t))
+ (while (memq ch '(nil org-drill--tags-key))
(setq ch nil)
(while (not (input-pending-p))
(let ((elapsed (time-subtract (current-time) item-start-time)))
@@ -1337,30 +1572,34 @@ Consider reformulating the item to make it easier to remember.\n"
(sit-for 1)))
(setq input (read-key-sequence nil))
(if (stringp input) (setq ch (elt input 0)))
- (if (eql ch ?t)
+ (if (eql ch org-drill--tags-key)
(org-set-tags-command)))
(case ch
- (?q nil)
- (?e 'edit)
- (?s 'skip)
+ (org-drill--quit-key nil)
+ (org-drill--edit-key 'edit)
+ (org-drill--skip-key 'skip)
(otherwise t))))
+
(defun org-pos-in-regexp (pos regexp &optional nlines)
(save-excursion
(goto-char pos)
(org-in-regexp regexp nlines)))
+
(defun org-drill-hide-region (beg end &optional text)
"Hide the buffer region between BEG and END with an 'invisible text'
visual overlay, or with the string TEXT if it is supplied."
(let ((ovl (make-overlay beg end)))
(overlay-put ovl 'category
'org-drill-hidden-text-overlay)
+ (overlay-put ovl 'priority 9999)
(when (stringp text)
(overlay-put ovl 'invisible nil)
(overlay-put ovl 'face 'default)
(overlay-put ovl 'display text))))
+
(defun org-drill-hide-heading-at-point (&optional text)
(unless (org-at-heading-p)
(error "Point is not on a heading."))
@@ -1369,11 +1608,13 @@ visual overlay, or with the string TEXT if it is supplied."
(end-of-line)
(org-drill-hide-region beg (point) text))))
+
(defun org-drill-hide-comments ()
(save-excursion
(while (re-search-forward "^#.*$" nil t)
(org-drill-hide-region (match-beginning 0) (match-end 0)))))
+
(defun org-drill-unhide-text ()
;; This will also unhide the item's heading.
(save-excursion
@@ -1381,16 +1622,23 @@ visual overlay, or with the string TEXT if it is supplied."
(when (eql 'org-drill-hidden-text-overlay (overlay-get ovl 'category))
(delete-overlay ovl)))))
+
(defun org-drill-hide-clozed-text ()
(save-excursion
(while (re-search-forward org-drill-cloze-regexp nil t)
- ;; Don't hide org links, partly because they might contain inline
- ;; images which we want to keep visible
+ ;; Don't hide:
+ ;; - org links, partly because they might contain inline
+ ;; images which we want to keep visible.
+ ;; - LaTeX math fragments
+ ;; - the contents of SRC blocks
(unless (save-match-data
- (org-pos-in-regexp (match-beginning 0)
- org-bracket-link-regexp 1))
+ (or (org-pos-in-regexp (match-beginning 0)
+ org-bracket-link-regexp 1)
+ (org-in-src-block-p)
+ (org-inside-LaTeX-fragment-p)))
(org-drill-hide-matched-cloze-text)))))
+
(defun org-drill-hide-matched-cloze-text ()
"Hide the current match with a 'cloze' visual overlay."
(let ((ovl (make-overlay (match-beginning 0) (match-end 0)))
@@ -1398,6 +1646,7 @@ visual overlay, or with the string TEXT if it is supplied."
(match-string 0))))
(overlay-put ovl 'category
'org-drill-cloze-overlay-defaults)
+ (overlay-put ovl 'priority 9999)
(when (and hint-sep-pos
(> hint-sep-pos 1))
(let ((hint (substring-no-properties
@@ -1411,6 +1660,7 @@ visual overlay, or with the string TEXT if it is supplied."
(format (if (string-match-p (regexp-quote "...") hint) "[%s]" "[%s...]")
hint))))))
+
(defun org-drill-hide-cloze-hints ()
(save-excursion
(while (re-search-forward org-drill-cloze-regexp nil t)
@@ -1420,6 +1670,7 @@ visual overlay, or with the string TEXT if it is supplied."
(null (match-beginning 2))) ; hint subexpression matched
(org-drill-hide-region (match-beginning 2) (match-end 2))))))
+
(defmacro with-replaced-entry-text (text &rest body)
"During the execution of BODY, the entire text of the current entry is
concealed by an overlay that displays the string TEXT."
@@ -1430,6 +1681,7 @@ concealed by an overlay that displays the string TEXT."
,@body)
(org-drill-unreplace-entry-text))))
+
(defmacro with-replaced-entry-text-multi (replacements &rest body)
"During the execution of BODY, the entire text of the current entry is
concealed by an overlay that displays the overlays in REPLACEMENTS."
@@ -1440,6 +1692,7 @@ concealed by an overlay that displays the overlays in REPLACEMENTS."
,@body)
(org-drill-unreplace-entry-text))))
+
(defun org-drill-replace-entry-text (text &optional multi-p)
"Make an overlay that conceals the entire text of the item, not
including properties or the contents of subheadings. The overlay shows
@@ -1458,16 +1711,19 @@ Note: does not actually alter the item."
(save-excursion
(outline-next-heading)
(point)))))
+ (overlay-put ovl 'priority 9999)
(overlay-put ovl 'category
'org-drill-replaced-text-overlay)
(overlay-put ovl 'display text)))))
+
(defun org-drill-unreplace-entry-text ()
(save-excursion
(dolist (ovl (overlays-in (point-min) (point-max)))
(when (eql 'org-drill-replaced-text-overlay (overlay-get ovl 'category))
(delete-overlay ovl)))))
+
(defun org-drill-replace-entry-text-multi (replacements)
"Make overlays that conceal the entire text of the item, not
including properties or the contents of subheadings. The overlay shows
@@ -1484,10 +1740,12 @@ Note: does not actually alter the item."
(if (= i (1- (length replacements)))
p-max
(+ p-min (* 2 i) 1))))
+ (overlay-put ovl 'priority 9999)
(overlay-put ovl 'category
'org-drill-replaced-text-overlay)
(overlay-put ovl 'display (nth i replacements)))))
+
(defmacro with-replaced-entry-heading (heading &rest body)
`(progn
(org-drill-replace-entry-heading ,heading)
@@ -1496,18 +1754,21 @@ Note: does not actually alter the item."
,@body)
(org-drill-unhide-text))))
+
(defun org-drill-replace-entry-heading (heading)
"Make an overlay that conceals the heading of the item. The overlay shows
the string TEXT.
Note: does not actually alter the item."
(org-drill-hide-heading-at-point heading))
+
(defun org-drill-unhide-clozed-text ()
(save-excursion
(dolist (ovl (overlays-in (point-min) (point-max)))
(when (eql 'org-drill-cloze-overlay-defaults (overlay-get ovl 'category))
(delete-overlay ovl)))))
+
(defun org-drill-get-entry-text (&optional keep-properties-p)
(let ((text (org-agenda-get-some-entry-text (point-marker) 100)))
(if keep-properties-p
@@ -1524,12 +1785,15 @@ Note: does not actually alter the item."
(org-back-to-heading t)
(let ((lim (save-excursion
(outline-next-heading) (point))))
- (org-end-of-meta-data-and-drawers)
+ (if (fboundp 'org-end-of-meta-data-and-drawers)
+ (org-end-of-meta-data-and-drawers) ; function removed Feb 2015
+ (org-end-of-meta-data t))
(or (>= (point) lim)
(null (re-search-forward "[[:graph:]]" lim t))))))
(defun org-drill-entry-empty-p () (org-entry-empty-p))
+
;;; Presentation functions ====================================================
;;
;; Each of these is called with point on topic heading. Each needs to show the
@@ -1539,17 +1803,20 @@ Note: does not actually alter the item."
;; topic, and should return t if the user chose to see the answer and rate their
;; recall, nil if they chose to quit.
+
(defun org-drill-present-simple-card ()
(with-hidden-comments
(with-hidden-cloze-hints
(with-hidden-cloze-text
(org-drill-hide-all-subheadings-except nil)
+ (org-drill--show-latex-fragments) ; overlay all LaTeX fragments with images
(ignore-errors
(org-display-inline-images t))
(org-cycle-hide-drawers 'all)
(prog1 (org-drill-presentation-prompt)
(org-drill-hide-subheadings-if 'org-drill-entry-p))))))
+
(defun org-drill-present-default-answer (reschedule-fn)
(cond
(drill-answer
@@ -1561,12 +1828,21 @@ Note: does not actually alter the item."
(t
(org-drill-hide-subheadings-if 'org-drill-entry-p)
(org-drill-unhide-clozed-text)
+ (org-drill--show-latex-fragments)
(ignore-errors
(org-display-inline-images t))
(org-cycle-hide-drawers 'all)
(with-hidden-cloze-hints
(funcall reschedule-fn)))))
+
+(defun org-drill--show-latex-fragments ()
+ (org-remove-latex-fragment-image-overlays)
+ (if (fboundp 'org-toggle-latex-fragment)
+ (org-toggle-latex-fragment '(4))
+ (org-preview-latex-fragment '(4))))
+
+
(defun org-drill-present-two-sided-card ()
(with-hidden-comments
(with-hidden-cloze-hints
@@ -1577,12 +1853,15 @@ Note: does not actually alter the item."
(goto-char (nth (random* (min 2 (length drill-sections)))
drill-sections))
(org-show-subtree)))
+ (org-drill--show-latex-fragments)
(ignore-errors
(org-display-inline-images t))
(org-cycle-hide-drawers 'all)
(prog1 (org-drill-presentation-prompt)
(org-drill-hide-subheadings-if 'org-drill-entry-p)))))))
+
+
(defun org-drill-present-multi-sided-card ()
(with-hidden-comments
(with-hidden-cloze-hints
@@ -1592,12 +1871,14 @@ Note: does not actually alter the item."
(save-excursion
(goto-char (nth (random* (length drill-sections)) drill-sections))
(org-show-subtree)))
+ (org-drill--show-latex-fragments)
(ignore-errors
(org-display-inline-images t))
(org-cycle-hide-drawers 'all)
(prog1 (org-drill-presentation-prompt)
(org-drill-hide-subheadings-if 'org-drill-entry-p)))))))
+
(defun org-drill-present-multicloze-hide-n (number-to-hide
&optional
force-show-first
@@ -1632,7 +1913,8 @@ items if FORCE-SHOW-FIRST or FORCE-SHOW-LAST is non-nil)."
(let ((in-regexp? (save-match-data
(org-pos-in-regexp (match-beginning 0)
org-bracket-link-regexp 1))))
- (unless in-regexp?
+ (unless (or in-regexp?
+ (org-inside-LaTeX-fragment-p))
(incf match-count)))))
(if (minusp number-to-hide)
(setq number-to-hide (+ match-count number-to-hide)))
@@ -1659,8 +1941,9 @@ items if FORCE-SHOW-FIRST or FORCE-SHOW-LAST is non-nil)."
(setq cnt 0)
(while (re-search-forward org-drill-cloze-regexp item-end t)
(unless (save-match-data
- (org-pos-in-regexp (match-beginning 0)
- org-bracket-link-regexp 1))
+ (or (org-pos-in-regexp (match-beginning 0)
+ org-bracket-link-regexp 1)
+ (org-inside-LaTeX-fragment-p)))
(incf cnt)
(if (memq cnt match-nums)
(org-drill-hide-matched-cloze-text)))))))
@@ -1670,6 +1953,7 @@ items if FORCE-SHOW-FIRST or FORCE-SHOW-LAST is non-nil)."
;; while (org-pos-in-regexp (match-beginning 0)
;; org-bracket-link-regexp 1))
;; (org-drill-hide-matched-cloze-text)))))
+ (org-drill--show-latex-fragments)
(ignore-errors
(org-display-inline-images t))
(org-cycle-hide-drawers 'all)
@@ -1677,6 +1961,7 @@ items if FORCE-SHOW-FIRST or FORCE-SHOW-LAST is non-nil)."
(org-drill-hide-subheadings-if 'org-drill-entry-p)
(org-drill-unhide-clozed-text))))))
+
(defun org-drill-present-multicloze-hide-nth (to-hide)
"Hide the TO-HIDE'th piece of clozed text. 1 is the first piece. If
TO-HIDE is negative, count backwards, so -1 means the last item, -2
@@ -1698,7 +1983,8 @@ the second to last, etc."
(let ((in-regexp? (save-match-data
(org-pos-in-regexp (match-beginning 0)
org-bracket-link-regexp 1))))
- (unless in-regexp?
+ (unless (or in-regexp?
+ (org-inside-LaTeX-fragment-p))
(incf match-count)))))
(if (minusp to-hide)
(setq to-hide (+ 1 to-hide match-count)))
@@ -1712,11 +1998,16 @@ the second to last, etc."
(setq cnt 0)
(while (re-search-forward org-drill-cloze-regexp item-end t)
(unless (save-match-data
- (org-pos-in-regexp (match-beginning 0)
- org-bracket-link-regexp 1))
+ ;; Don't consider this a cloze region if it is part of an
+ ;; org link, or if it occurs inside a LaTeX math
+ ;; fragment
+ (or (org-pos-in-regexp (match-beginning 0)
+ org-bracket-link-regexp 1)
+ (org-inside-LaTeX-fragment-p)))
(incf cnt)
(if (= cnt to-hide)
(org-drill-hide-matched-cloze-text)))))))
+ (org-drill--show-latex-fragments)
(ignore-errors
(org-display-inline-images t))
(org-cycle-hide-drawers 'all)
@@ -1724,24 +2015,29 @@ the second to last, etc."
(org-drill-hide-subheadings-if 'org-drill-entry-p)
(org-drill-unhide-clozed-text))))))
+
(defun org-drill-present-multicloze-hide1 ()
"Hides one of the pieces of text that are marked for cloze deletion,
chosen at random."
(org-drill-present-multicloze-hide-n 1))
+
(defun org-drill-present-multicloze-hide2 ()
"Hides two of the pieces of text that are marked for cloze deletion,
chosen at random."
(org-drill-present-multicloze-hide-n 2))
+
(defun org-drill-present-multicloze-hide-first ()
"Hides the first piece of text that is marked for cloze deletion."
(org-drill-present-multicloze-hide-nth 1))
+
(defun org-drill-present-multicloze-hide-last ()
"Hides the last piece of text that is marked for cloze deletion."
(org-drill-present-multicloze-hide-nth -1))
+
(defun org-drill-present-multicloze-hide1-firstmore ()
"Commonly, hides the FIRST piece of text that is marked for
cloze deletion. Uncommonly, hide one of the other pieces of text,
@@ -1771,6 +2067,7 @@ the value of `org-drill-cloze-text-weight'."
;; Commonly, hide first item
(org-drill-present-multicloze-hide-first))))
+
(defun org-drill-present-multicloze-show1-lastmore ()
"Commonly, hides all pieces except the last. Uncommonly, shows
any random piece. The effect is similar to 'show1cloze' except
@@ -1795,6 +2092,7 @@ the value of `org-drill-cloze-text-weight'."
;; Commonly, show the LAST item
(org-drill-present-multicloze-hide-n -1 nil t))))
+
(defun org-drill-present-multicloze-show1-firstless ()
"Commonly, hides all pieces except one, where the shown piece
is guaranteed NOT to be the first piece. Uncommonly, shows any
@@ -1820,49 +2118,19 @@ the value of `org-drill-cloze-text-weight'."
;; Commonly, show any item, except the first
(org-drill-present-multicloze-hide-n -1 nil nil t))))
+
(defun org-drill-present-multicloze-show1 ()
"Similar to `org-drill-present-multicloze-hide1', but hides all
the pieces of text that are marked for cloze deletion, except for one
piece which is chosen at random."
(org-drill-present-multicloze-hide-n -1))
+
(defun org-drill-present-multicloze-show2 ()
"Similar to `org-drill-present-multicloze-show1', but reveals two
pieces rather than one."
(org-drill-present-multicloze-hide-n -2))
-;; (defun org-drill-present-multicloze-show1 ()
-;; "Similar to `org-drill-present-multicloze-hide1', but hides all
-;; the pieces of text that are marked for cloze deletion, except for one
-;; piece which is chosen at random."
-;; (with-hidden-comments
-;; (with-hidden-cloze-hints
-;; (let ((item-end nil)
-;; (match-count 0)
-;; (body-start (or (cdr (org-get-property-block))
-;; (point))))
-;; (org-drill-hide-all-subheadings-except nil)
-;; (save-excursion
-;; (outline-next-heading)
-;; (setq item-end (point)))
-;; (save-excursion
-;; (goto-char body-start)
-;; (while (re-search-forward org-drill-cloze-regexp item-end t)
-;; (incf match-count)))
-;; (when (plusp match-count)
-;; (let ((match-to-hide (random* match-count)))
-;; (save-excursion
-;; (goto-char body-start)
-;; (dotimes (n match-count)
-;; (re-search-forward org-drill-cloze-regexp
-;; item-end t)
-;; (unless (= n match-to-hide)
-;; (org-drill-hide-matched-cloze-text))))))
-;; (org-display-inline-images t)
-;; (org-cycle-hide-drawers 'all)
-;; (prog1 (org-drill-presentation-prompt)
-;; (org-drill-hide-subheadings-if 'org-drill-entry-p)
-;; (org-drill-unhide-clozed-text))))))
(defun org-drill-present-card-using-text (question &optional answer)
"Present the string QUESTION as the only visible content of the card.
@@ -1878,6 +2146,7 @@ If ANSWER is supplied, set the global variable `drill-answer' to its value."
(prog1 (org-drill-presentation-prompt)
(org-drill-hide-subheadings-if 'org-drill-entry-p)))))
+
(defun org-drill-present-card-using-multiple-overlays (replacements &optional answer)
"TEXTS is a list of valid values for the 'display' text property.
Present these overlays, in sequence, as the only
@@ -1894,6 +2163,7 @@ If ANSWER is supplied, set the global variable `drill-answer' to its value."
(prog1 (org-drill-presentation-prompt)
(org-drill-hide-subheadings-if 'org-drill-entry-p)))))
+
(defun org-drill-entry ()
"Present the current topic for interactive review, as in `org-drill'.
Review will occur regardless of whether the topic is due for review or whether
@@ -1911,7 +2181,7 @@ See `org-drill' for more details."
;; (error "Point is not inside a drill entry"))
;;(unless (org-at-heading-p)
;; (org-back-to-heading))
- (let ((card-type (org-entry-get (point) "DRILL_CARD_TYPE"))
+ (let ((card-type (org-entry-get (point) "DRILL_CARD_TYPE" t))
(answer-fn 'org-drill-present-default-answer)
(present-empty-cards nil)
(cont nil)
@@ -1932,26 +2202,29 @@ See `org-drill' for more details."
'org-drill-present-default-answer)
present-empty-cards (third presentation-fn)
presentation-fn (first presentation-fn)))
- (cond
- ((null presentation-fn)
- (message "%s:%d: Unrecognised card type '%s', skipping..."
- (buffer-name) (point) card-type)
- (sit-for 0.5)
- 'skip)
- (t
- (setq cont (funcall presentation-fn))
- (cond
- ((not cont)
- (message "Quit")
- nil)
- ((eql cont 'edit)
- 'edit)
- ((eql cont 'skip)
- 'skip)
- (t
- (save-excursion
- (funcall answer-fn
- (lambda () (org-drill-reschedule)))))))))))))
+ (prog1
+ (cond
+ ((null presentation-fn)
+ (message "%s:%d: Unrecognised card type '%s', skipping..."
+ (buffer-name) (point) card-type)
+ (sit-for 0.5)
+ 'skip)
+ (t
+ (setq cont (funcall presentation-fn))
+ (cond
+ ((not cont)
+ (message "Quit")
+ nil)
+ ((eql cont 'edit)
+ 'edit)
+ ((eql cont 'skip)
+ 'skip)
+ (t
+ (save-excursion
+ (funcall answer-fn
+ (lambda () (org-drill-reschedule))))))))
+ (org-remove-latex-fragment-image-overlays)))))))
+
(defun org-drill-entries-pending-p ()
(or *org-drill-again-entries*
@@ -1965,6 +2238,7 @@ See `org-drill' for more details."
*org-drill-overdue-entries*
*org-drill-again-entries*))))
+
(defun org-drill-pending-entry-count ()
(+ (if (markerp *org-drill-current-item*) 1 0)
(length *org-drill-new-entries*)
@@ -1974,6 +2248,7 @@ See `org-drill' for more details."
(length *org-drill-overdue-entries*)
(length *org-drill-again-entries*)))
+
(defun org-drill-maximum-duration-reached-p ()
"Returns true if the current drill session has continued past its
maximum duration."
@@ -1983,6 +2258,7 @@ maximum duration."
(> (- (float-time (current-time)) *org-drill-start-time*)
(* org-drill-maximum-duration 60))))
+
(defun org-drill-maximum-item-count-reached-p ()
"Returns true if the current drill session has reached the
maximum number of items."
@@ -1991,6 +2267,7 @@ maximum number of items."
(>= (length *org-drill-done-entries*)
org-drill-maximum-items-per-session)))
+
(defun org-drill-pop-next-pending-entry ()
(block org-drill-pop-next-pending-entry
(let ((m nil))
@@ -2038,6 +2315,7 @@ maximum number of items."
(return-from org-drill-pop-next-pending-entry nil)))))
m)))
+
(defun org-drill-entries (&optional resuming-p)
"Returns nil, t, or a list of markers representing entries that were
'failed' and need to be presented again before the session ends.
@@ -2090,6 +2368,8 @@ RESUMING-P is true if we are resuming a suspended drill session."
(push m *org-drill-done-entries*)))
(setq *org-drill-current-item* nil))))))))))
+
+
(defun org-drill-final-report ()
(let ((pass-percent
(round (* 100 (count-if (lambda (qual)
@@ -2176,7 +2456,10 @@ order to make items appear more frequently over time."
*org-drill-overdue-entry-count*
(round (* 100 *org-drill-overdue-entry-count*)
(+ *org-drill-dormant-entry-count*
- *org-drill-due-entry-count*)))))))
+ *org-drill-due-entry-count*)))
+ ))))
+
+
(defun org-drill-free-markers (markers)
"MARKERS is a list of markers, all of which will be freed (set to
@@ -2194,17 +2477,57 @@ all the markers used by Org-Drill will be freed."
(free-marker m)))
+;;; overdue-data is a list of entries, each entry has the form (POS DUE AGE)
+;;; where POS is a marker pointing to the start of the entry, and
+;;; DUE is a number indicating how many days ago the entry was due.
+;;; AGE is the number of days elapsed since item creation (nil if unknown).
+;;; if age > lapse threshold (default 90), sort by age (oldest first)
+;;; if age < lapse threshold, sort by due (biggest first)
+
+
(defun org-drill-order-overdue-entries (overdue-data)
- (setq *org-drill-overdue-entries*
- (mapcar 'car
- (sort (shuffle-list overdue-data)
- (lambda (a b) (> (cdr a) (cdr b)))))))
+ (let* ((lapsed-days (if org-drill--lapse-very-overdue-entries-p
+ 90 most-positive-fixnum))
+ (not-lapsed (remove-if (lambda (a) (> (or (second a) 0) lapsed-days))
+ overdue-data))
+ (lapsed (remove-if-not (lambda (a) (> (or (second a) 0)
+ lapsed-days)) overdue-data)))
+ (setq *org-drill-overdue-entries*
+ (mapcar 'first
+ (append
+ (sort (shuffle-list not-lapsed)
+ (lambda (a b) (> (second a) (second b))))
+ (sort lapsed
+ (lambda (a b) (> (third a) (third b)))))))))
+
+
+(defun org-drill--entry-lapsed-p ()
+ (let ((lapsed-days 90))
+ (and org-drill--lapse-very-overdue-entries-p
+ (> (or (org-drill-entry-days-overdue) 0) lapsed-days))))
+
+
+
+
+(defun org-drill-entry-days-since-creation (&optional use-last-interval-p)
+ "If USE-LAST-INTERVAL-P is non-nil, and DATE_ADDED is missing, use the
+value of DRILL_LAST_INTERVAL instead (as the item's age must be at least
+that many days)."
+ (let ((timestamp (org-entry-get (point) "DATE_ADDED")))
+ (cond
+ (timestamp
+ (- (org-time-stamp-to-now timestamp)))
+ (use-last-interval-p
+ (+ (or (org-drill-entry-days-overdue) 0)
+ (read (or (org-entry-get (point) "DRILL_LAST_INTERVAL") "0"))))
+ (t nil))))
(defun org-drill-entry-status ()
- "Returns a list (STATUS DUE) where DUE is the number of days overdue,
-zero being due today, -1 being scheduled 1 day in the future. STATUS is
-one of the following values:
+ "Returns a list (STATUS DUE AGE) where DUE is the number of days overdue,
+zero being due today, -1 being scheduled 1 day in the future.
+AGE is the number of days elapsed since the item was created (nil if unknown).
+STATUS is one of the following values:
- nil, if the item is not a drill entry, or has an empty body
- :unscheduled
- :future
@@ -2218,6 +2541,7 @@ one of the following values:
(unless (org-at-heading-p)
(org-back-to-heading))
(let ((due (org-drill-entry-days-overdue))
+ (age (org-drill-entry-days-since-creation t))
(last-int (org-drill-entry-last-interval 1)))
(list
(cond
@@ -2256,7 +2580,7 @@ one of the following values:
:young)
(t
:old))
- due))))
+ due age))))
(defun org-drill-progress-message (collected scanned)
@@ -2265,14 +2589,58 @@ one of the following values:
(sym1 (if (oddp (floor scanned (* 50 meter-width))) ?| ?.))
(sym2 (if (eql sym1 ?.) ?| ?.)))
(message "Collecting due drill items:%4d %s%s"
- collected
- (make-string (% (ceiling scanned 50) meter-width)
- sym2)
- (make-string (- meter-width (% (ceiling scanned 50) meter-width))
- sym1)))))
-
-
-(defun org-drill (&optional scope resume-p)
+ collected
+ (make-string (% (ceiling scanned 50) meter-width)
+ sym2)
+ (make-string (- meter-width (% (ceiling scanned 50) meter-width))
+ sym1)))))
+
+
+(defun org-map-drill-entry-function ()
+ (org-drill-progress-message
+ (+ (length *org-drill-new-entries*)
+ (length *org-drill-overdue-entries*)
+ (length *org-drill-young-mature-entries*)
+ (length *org-drill-old-mature-entries*)
+ (length *org-drill-failed-entries*))
+ (incf cnt))
+ (cond
+ ((not (org-drill-entry-p))
+ nil) ; skip
+ (t
+ (when (and (not warned-about-id-creation)
+ (null (org-id-get)))
+ (message (concat "Creating unique IDs for items "
+ "(slow, but only happens once)"))
+ (sit-for 0.5)
+ (setq warned-about-id-creation t))
+ (org-id-get-create) ; ensure drill entry has unique ID
+ (destructuring-bind (status due age)
+ (org-drill-entry-status)
+ (case status
+ (:unscheduled
+ (incf *org-drill-dormant-entry-count*))
+ ;; (:tomorrow
+ ;; (incf *org-drill-dormant-entry-count*)
+ ;; (incf *org-drill-due-tomorrow-count*))
+ (:future
+ (incf *org-drill-dormant-entry-count*)
+ (if (eq -1 due)
+ (incf *org-drill-due-tomorrow-count*)))
+ (:new
+ (push (point-marker) *org-drill-new-entries*))
+ (:failed
+ (push (point-marker) *org-drill-failed-entries*))
+ (:young
+ (push (point-marker) *org-drill-young-mature-entries*))
+ (:overdue
+ (push (list (point-marker) due age) overdue-data))
+ (:old
+ (push (point-marker) *org-drill-old-mature-entries*))
+ )))))
+
+
+(defun org-drill (&optional scope drill-match resume-p)
"Begin an interactive 'drill session'. The user is asked to
review a series of topics (headers). Each topic is initially
presented as a 'question', often with part of the topic content
@@ -2300,10 +2668,24 @@ SCOPE determines the scope in which to search for
questions. It accepts the same values as `org-drill-scope',
which see.
+DRILL-MATCH, if supplied, is a string specifying a tags/property/
+todo query. Only items matching the query will be considered.
+It accepts the same values as `org-drill-match', which see.
+
If RESUME-P is non-nil, resume a suspended drill session rather
than starting a new one."
(interactive)
+ ;; Check org version. Org 7.9.3f introduced a backwards-incompatible change
+ ;; to the arguments accepted by `org-schedule'. At the time of writing there
+ ;; are still lots of people using versions of org older than this.
+ (let ((majorv (first (mapcar 'string-to-number (split-string (org-release) "[.]")))))
+ (if (and (< majorv 8)
+ (not (string-match-p "universal prefix argument" (documentation 'org-schedule))))
+ (read-char-exclusive
+ (format "Warning: org-drill requires org mode 7.9.3f or newer. Scheduling of failed cards will not
+work correctly with older versions of org mode. Your org mode version (%s) appears to be older than
+7.9.3f. Please consider installing a more recent version of org mode." (org-release)))))
(let ((end-pos nil)
(overdue-data nil)
(cnt 0))
@@ -2331,48 +2713,8 @@ than starting a new one."
(let ((org-trust-scanner-tags t)
(warned-about-id-creation nil))
(org-map-drill-entries
- (lambda ()
- (org-drill-progress-message
- (+ (length *org-drill-new-entries*)
- (length *org-drill-overdue-entries*)
- (length *org-drill-young-mature-entries*)
- (length *org-drill-old-mature-entries*)
- (length *org-drill-failed-entries*))
- (incf cnt))
- (cond
- ((not (org-drill-entry-p))
- nil) ; skip
- (t
- (when (and (not warned-about-id-creation)
- (null (org-id-get)))
- (message (concat "Creating unique IDs for items "
- "(slow, but only happens once)"))
- (sit-for 0.5)
- (setq warned-about-id-creation t))
- (org-id-get-create) ; ensure drill entry has unique ID
- (destructuring-bind (status due) (org-drill-entry-status)
- (case status
- (:unscheduled
- (incf *org-drill-dormant-entry-count*))
- ;; (:tomorrow
- ;; (incf *org-drill-dormant-entry-count*)
- ;; (incf *org-drill-due-tomorrow-count*))
- (:future
- (incf *org-drill-dormant-entry-count*)
- (if (eq -1 due)
- (incf *org-drill-due-tomorrow-count*)))
- (:new
- (push (point-marker) *org-drill-new-entries*))
- (:failed
- (push (point-marker) *org-drill-failed-entries*))
- (:young
- (push (point-marker) *org-drill-young-mature-entries*))
- (:overdue
- (push (cons (point-marker) due) overdue-data))
- (:old
- (push (point-marker) *org-drill-old-mature-entries*))
- )))))
- scope)
+ 'org-map-drill-entry-function
+ scope drill-match)
(org-drill-order-overdue-entries overdue-data)
(setq *org-drill-overdue-entry-count*
(length *org-drill-overdue-entries*))))
@@ -2409,23 +2751,22 @@ than starting a new one."
(org-drill-save-optimal-factor-matrix))
(if org-drill-save-buffers-after-drill-sessions-p
(save-some-buffers))
- (message "Drill session finished!")))))
+ (message "Drill session finished!")
+ ))))
(defun org-drill-save-optimal-factor-matrix ()
- (message "Saving optimal factor matrix...")
- (customize-save-variable 'org-drill-optimal-factor-matrix
- org-drill-optimal-factor-matrix))
+ (savehist-autosave))
-(defun org-drill-cram (&optional scope)
+(defun org-drill-cram (&optional scope drill-match)
"Run an interactive drill session in 'cram mode'. In cram mode,
all drill items are considered to be due for review, unless they
have been reviewed within the last `org-drill-cram-hours'
hours."
(interactive)
(setq *org-drill-cram-mode* t)
- (org-drill scope))
+ (org-drill scope drill-match))
(defun org-drill-tree ()
@@ -2442,7 +2783,7 @@ files in the same directory as the current file."
(org-drill 'directory))
-(defun org-drill-again (&optional scope)
+(defun org-drill-again (&optional scope drill-match)
"Run a new drill session, but try to use leftover due items that
were not reviewed during the last session, rather than scanning for
unreviewed items. If there are no leftover items in memory, a full
@@ -2457,9 +2798,9 @@ scan will be performed."
(setq *org-drill-start-time* (float-time (current-time))
*org-drill-done-entries* nil
*org-drill-current-item* nil)
- (org-drill scope t))
+ (org-drill scope drill-match t))
(t
- (org-drill scope))))
+ (org-drill scope drill-match))))
@@ -2469,7 +2810,7 @@ exiting them with the `edit' or `quit' options."
(interactive)
(cond
((org-drill-entries-pending-p)
- (org-drill nil t))
+ (org-drill nil nil t))
((and (plusp (org-drill-pending-entry-count))
;; Current drill session is finished, but there are still
;; more items which need to be reviewed.
@@ -2482,10 +2823,18 @@ need reviewing. Start a new drill session? "
(message "You have finished the drill session."))))
+(defun org-drill-relearn-item ()
+ "Make the current item due for revision, and set its last interval to 0.
+Makes the item behave as if it has been failed, without actually recording a
+failure. This command can be used to 'reset' repetitions for an item."
+ (interactive)
+ (org-drill-smart-reschedule 4 0))
+
+
(defun org-drill-strip-entry-data ()
(dolist (prop org-drill-scheduling-properties)
(org-delete-property prop))
- (org-schedule t))
+ (org-schedule '(4)))
(defun org-drill-strip-all-data (&optional scope)
@@ -2503,22 +2852,41 @@ values as `org-drill-scope'."
;; `org-delete-property-globally', which is faster.
(dolist (prop org-drill-scheduling-properties)
(org-delete-property-globally prop))
- (org-map-drill-entries (lambda () (org-schedule t)) scope))
+ (org-map-drill-entries (lambda () (org-schedule '(4))) scope))
(t
(org-map-drill-entries 'org-drill-strip-entry-data scope)))
(message "Done.")))
-
(defun org-drill-add-cloze-fontification ()
+ ;; Compute local versions of the regexp for cloze deletions, in case
+ ;; the left and right delimiters are redefined locally.
+ (setq-local org-drill-cloze-regexp (org-drill--compute-cloze-regexp))
+ (setq-local org-drill-cloze-keywords (org-drill--compute-cloze-keywords))
(when org-drill-use-visible-cloze-face-p
- (font-lock-add-keywords 'org-mode
- org-drill-cloze-keywords
- nil)))
-
-(add-hook 'org-mode-hook 'org-drill-add-cloze-fontification)
-
-(org-drill-add-cloze-fontification)
+ (add-to-list 'org-font-lock-extra-keywords
+ (first org-drill-cloze-keywords))))
+
+
+;; Can't add to org-mode-hook, because local variables won't have been loaded
+;; yet.
+
+;; (defun org-drill-add-cloze-fontification ()
+;; (when (eql major-mode 'org-mode)
+;; ;; Compute local versions of the regexp for cloze deletions, in case
+;; ;; the left and right delimiters are redefined locally.
+;; (setq-local org-drill-cloze-regexp (org-drill--compute-cloze-regexp))
+;; (setq-local org-drill-cloze-keywords (org-drill--compute-cloze-keywords))
+;; (when org-drill-use-visible-cloze-face-p
+;; (font-lock-add-keywords nil ;'org-mode
+;; org-drill-cloze-keywords
+;; nil))))
+
+;; XXX
+;; (add-hook 'hack-local-variables-hook
+;; 'org-drill-add-cloze-fontification)
+;;
+;; (org-drill-add-cloze-fontification)
;;; Synching card collections =================================================
@@ -2534,18 +2902,18 @@ the tag 'imported'."
(save-excursion
(let ((src (current-buffer))
(m nil))
- (flet ((paste-tree-here (&optional level)
- (org-paste-subtree level)
- (org-drill-strip-entry-data)
- (org-toggle-tag "imported" 'on)
- (org-map-drill-entries
- (lambda ()
- (let ((id (org-id-get)))
- (org-drill-strip-entry-data)
- (unless (gethash id *org-drill-dest-id-table*)
- (puthash id (point-marker)
- *org-drill-dest-id-table*))))
- 'tree)))
+ (cl-flet ((paste-tree-here (&optional level)
+ (org-paste-subtree level)
+ (org-drill-strip-entry-data)
+ (org-toggle-tag "imported" 'on)
+ (org-map-drill-entries
+ (lambda ()
+ (let ((id (org-id-get)))
+ (org-drill-strip-entry-data)
+ (unless (gethash id *org-drill-dest-id-table*)
+ (puthash id (point-marker)
+ *org-drill-dest-id-table*))))
+ 'tree)))
(unless path
(setq path (org-get-outline-path)))
(org-copy-subtree)
@@ -2569,7 +2937,9 @@ the tag 'imported'."
(outline-next-heading)
(newline)
(forward-line -1)
- (paste-tree-here (1+ (or (org-current-level) 0))))))))
+ (paste-tree-here (1+ (or (org-current-level) 0)))
+ )))))
+
(defun org-drill-merge-buffers (src &optional dest ignore-new-items-p)
@@ -2662,12 +3032,15 @@ copy them across."
(free-marker m))
*org-drill-dest-id-table*))))
+
+
;;; Card types for learning languages =========================================
;;; Get spell-number.el from:
;;; http://www.emacswiki.org/emacs/spell-number.el
(autoload 'spelln-integer-in-words "spell-number")
+
;;; `conjugate' card type =====================================================
;;; See spanish.org for usage
@@ -2730,15 +3103,15 @@ the name of the tense.")
(defun org-drill-present-verb-conjugation ()
"Present a drill entry whose card type is 'conjugate'."
- (flet ((tense-and-mood-to-string
- (tense mood)
- (cond
- ((and tense mood)
- (format "%s tense, %s mood" tense mood))
- (tense
- (format "%s tense" tense))
- (mood
- (format "%s mood" mood)))))
+ (cl-flet ((tense-and-mood-to-string
+ (tense mood)
+ (cond
+ ((and tense mood)
+ (format "%s tense, %s mood" tense mood))
+ (tense
+ (format "%s tense" tense))
+ (mood
+ (format "%s mood" mood)))))
(destructuring-bind (infinitive inf-hint translation tense mood)
(org-drill-get-verb-conjugation-info)
(org-drill-present-card-using-text
@@ -2919,6 +3292,7 @@ returns its return value."
'face highlight-face))
(spelln-integer-in-language drilled-number language))))))))
+
;; (defun org-drill-show-answer-translate-number (reschedule-fn)
;; (let* ((language (read (org-entry-get (point) "DRILL_LANGUAGE" t)))
;; (highlight-face 'font-lock-warning-face)
diff --git a/contrib/lisp/org-ebib.el b/contrib/lisp/org-ebib.el
new file mode 100644
index 0000000..2136a13
--- /dev/null
+++ b/contrib/lisp/org-ebib.el
@@ -0,0 +1,47 @@
+;;; org-ebib.el - Support for links to Ebib's entries in Org
+;;
+;; Author: Grégoire Jadi <daimrod@gmail.com>
+;;
+;; This file is not yet 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, 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:
+
+(require 'org)
+
+(org-add-link-type "ebib" 'org-ebib-open)
+
+(add-hook 'org-store-link-functions 'org-ebib-store-link)
+
+(defun org-ebib-open (key)
+ "Open Ebib and jump to KEY."
+ (ebib nil key))
+
+(defun org-ebib-store-link ()
+ "Store a key to an Ebib entry."
+ (when (memq major-mode '(ebib-index-mode ebib-entry-mode))
+ ;; This is an Ebib entry
+ (let* ((key (ebib-cur-entry-key))
+ (link (concat "ebib:" key))
+ (description (ignore-errors (ebib-db-get-field-value 'title key ebib-cur-db))))
+ (org-store-link-props
+ :type "ebib"
+ :link link
+ :description description))))
+
+(provide 'org-ebib)
+
+;;; org-ebib.el ends here
diff --git a/contrib/lisp/org-effectiveness.el b/contrib/lisp/org-effectiveness.el
new file mode 100644
index 0000000..0d830ab
--- /dev/null
+++ b/contrib/lisp/org-effectiveness.el
@@ -0,0 +1,298 @@
+;;; org-effectiveness.el --- Measuring the personal effectiveness
+
+;; Copyright (C) 2013 Free Software Foundation, Inc.
+
+;; Author: David Arroyo Menéndez <davidam@es.gnu.org>
+;; Keywords: effectiveness, plot
+;; Homepage: http://orgmode.org
+;;
+;; This file is not part of GNU Emacs, yet.
+;;
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;; Commentary:
+
+;; This file implements functions to measure the effectiveness in org.
+;; Org-mode doesn't load this module by default - if this is not what
+;; you want, configure the variable `org-modules'. Thanks to #emacs-es
+;; irc channel for your support.
+
+;;; Code:
+
+(require 'org)
+
+(defcustom org-effectiveness-max-todo 50
+ "This variable is useful to advice to the user about
+many TODO pending"
+ :type 'integer
+ :group 'org-effectiveness)
+
+(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!")))
+
+;; Check advice starting an org file
+(add-hook 'org-mode-hook 'org-effectiveness-advice)
+
+(defun org-effectiveness-count-keyword(keyword)
+ "Print a message with the number of keyword outline in the current buffer"
+ (interactive "sKeyword: ")
+ (save-excursion
+ (goto-char (point-min))
+ (message "Number of %s: %d" keyword (count-matches (concat "* " keyword)))))
+
+(defun org-effectiveness-count-todo()
+ "Print a message with the number of todo tasks in the current buffer"
+ (interactive)
+ (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)
+ (save-excursion
+ (goto-char (point-min))
+ (message "Number of DONE: %d" (count-matches "* DONE"))))
+
+(defun org-effectiveness-count-canceled()
+ "Print a message with the number of canceled tasks in the current buffer"
+ (interactive)
+ (save-excursion
+ (goto-char (point-min))
+ (message "Number of Canceled: %d" (count-matches "* CANCEL+ED"))))
+
+(defun org-effectiveness()
+ "Returns the effectiveness in the current org buffer"
+ (interactive)
+ (save-excursion
+ (goto-char (point-min))
+ (let ((done (float (count-matches "* DONE.*\n.*")))
+ (canc (float (count-matches "* CANCEL+ED.*\n.*"))))
+ (if (and (= done canc) (zerop done))
+ (setq effectiveness 0)
+ (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-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-canceled-in-date(date)
+ (interactive "sGive me a date: " date)
+ (setq count (count-matches (concat "CANCEL+ED.*\n.*" date)))
+ (message "CANCELEDS: %d" count))
+
+(defun org-effectiveness-in-date(date &optional notmessage)
+ (interactive "sGive me a date: " date)
+ (save-excursion
+ (goto-char (point-min))
+ (let ((done (float (count-matches (concat "* DONE.*\n.*" date))))
+ (canc (float (count-matches (concat "* CANCEL+ED.*\n.*" date)))))
+ (if (and (= done canc) (zerop done))
+ (setq effectiveness 0)
+ (setq effectiveness (* 100 (/ done (+ done canc)))))
+ (if (eq notmessage 1)
+ (message "%d" effectiveness)
+ (message "Effectiveness: %d " effectiveness)))))
+
+(defun org-effectiveness-month-to-string (m)
+ (if (< m 10)
+ (concat "0" (number-to-string m))
+ (number-to-string m)))
+
+(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))
+;; Checking the format of the dates
+ (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))
+ (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)
+ (setq startyear (string-to-number (match-string 0 startdate))))
+ (if (string-match "[0-9][0-9]$" startdate)
+ (setq startmonth (string-to-number (match-string 0 startdate))))
+ (if (string-match "^[0-9][0-9][0-9][0-9]" enddate)
+ (setq endyear (string-to-number (match-string 0 enddate))))
+ (if (string-match "[0-9][0-9]$" enddate)
+ (setq endmonth (string-to-number (match-string 0 enddate))))
+ (if (> startyear endyear)
+ (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
+ (let ((month startmonth)
+ (year startyear)
+ (str ""))
+ (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
+ (setq year (+ 1 year))
+ (setq month 1))
+ (setq month (+ 1 month))))
+ (write-region str nil "/tmp/org-effectiveness"))
+;; 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"))
+ (if (file-exists-p "/usr/bin/gnuplot")
+ (call-process "/bin/bash" nil t nil "-c" strplot)
+ (message "gnuplot is not installed")))
+
+(defun org-effectiveness-plot-save(startdate enddate &optional save)
+ (interactive "sGive me the start date: \nsGive me the end date: " startdate enddate)
+ (org-effectiveness-plot startdate enddate t))
+
+;; (defun org-effectiveness-plot(startdate enddate)
+
+
+(defun org-effectiveness-ascii-bar(n &optional label)
+ "Print a bar with the percentage from 0 to 100 printed in ascii"
+ (interactive "nPercentage: \nsLabel: ")
+ (if (or (< n 0) (> n 100))
+ (message "The percentage must be between 0 to 100")
+ (let ((x 0)
+ (y 0)
+ (z 0))
+ (insert (format "\n### %s ###" label))
+ (insert "\n-")
+ (while (< x n)
+ (insert "-")
+ (setq x (+ x 1)))
+ (insert "+\n")
+ (insert (format "%d" n))
+ (if (> n 10)
+ (setq y (+ y 1)))
+ (while (< y n)
+ (insert " ")
+ (setq y (+ y 1)))
+ (insert "|\n")
+ (insert "-")
+ (while (< z n)
+ (insert "-")
+ (setq z (+ z 1)))
+ (insert "+"))))
+
+(defun org-effectiveness-html-bar(n &optional label)
+ "Print a bar with the percentage from 0 to 100 printed in html"
+ (interactive "nPercentage: \nsLabel: ")
+ (if (or (< n 0) (> n 100))
+ (message "The percentage must be between 0 to 100")
+ (let ((x 0)
+ (y 0)
+ (z 0))
+ (insert (format "\n<div class='percentage-%d'>%d</div>" n n))
+)))
+
+
+(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))
+ (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))
+ (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)
+ (setq startyear (string-to-number (match-string 0 startdate))))
+ (if (string-match "[0-9][0-9]$" startdate)
+ (setq startmonth (string-to-number (match-string 0 startdate))))
+ (if (string-match "^[0-9][0-9][0-9][0-9]" enddate)
+ (setq endyear (string-to-number (match-string 0 enddate))))
+ (if (string-match "[0-9][0-9]$" enddate)
+ (setq endmonth (string-to-number (match-string 0 enddate))))
+ (if (> startyear endyear)
+ (setq str "The start date must be before that end date"))
+ (if (and (= startyear endyear) (> startmonth endmonth))
+ (setq str "The start date must be before that end date"))
+ (if str
+ (message str)
+;; (list (list startyear startmonth) (list endyear endmonth))))
+ (list (list 'startyear startyear) (list 'startmonth startmonth) (list 'endyear endyear) (list 'endmonth endmonth))))
+
+(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)))
+ (buffer (current-buffer))
+ (str ""))
+ (while (or (> eyear year) (and (= eyear year) (>= emonth month)))
+ (setq str (org-effectiveness-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)))
+ (buffer (current-buffer))
+ (str ""))
+ (switch-to-buffer "*org-effectiveness-html*")
+ (insert "<html><head><title>Graphbar</title><meta http-equiv='Content-type' content='text/html; charset=utf-8'><link rel='stylesheet' type='text/css' href='graphbar.css' title='graphbar'></head><body>")
+ (while (or (> eyear year) (and (= eyear year) (>= emonth month)))
+ (setq str (org-effectiveness-in-date (concat (number-to-string year) "-" (org-effectiveness-month-to-string month)) 1))
+ (switch-to-buffer "*org-effectiveness-html*")
+ (org-effectiveness-html-bar (string-to-number str) (format "%s-%s" year month))
+ (switch-to-buffer buffer)
+ (format "%s-%s" year month)
+ (if (eq month 12)
+ (progn
+ (setq year (+ 1 year))
+ (setq month 1))
+ (setq month (+ 1 month))))
+ (switch-to-buffer "*org-effectiveness-html*")
+ (insert "</body></html>")))
+
+(provide 'org-effectiveness)
+
diff --git a/contrib/lisp/org-eldoc.el b/contrib/lisp/org-eldoc.el
new file mode 100644
index 0000000..c970b27
--- /dev/null
+++ b/contrib/lisp/org-eldoc.el
@@ -0,0 +1,165 @@
+;;; org-eldoc.el --- display org header and src block info using eldoc
+
+;; Copyright (c) 2014 Free Software Foundation, Inc.
+
+;; Author: Łukasz Gruner <lukasz@gruner.lu>
+;; Maintainer: Łukasz Gruner <lukasz@gruner.lu>
+;; Version: 6
+;; Package-Requires: ((org "8"))
+;; URL: https://bitbucket.org/ukaszg/org-eldoc
+;; Created: 25/05/2014
+;; Keywords: eldoc, outline, breadcrumb, org, babel, minibuffer
+
+;; This file is not part of 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:
+
+;;; Changelog:
+
+;; As of 01/11/14 switching license to GPL3 to allow submission to org-mode.
+;; 08/11/14 switch code to automatically define eldoc-documentation-function, but don't autostart eldoc-mode.
+
+;;; Code:
+
+(require 'org)
+(require 'ob-core)
+(require 'eldoc)
+
+(defgroup org-eldoc nil "" :group 'org)
+
+(defcustom org-eldoc-breadcrumb-separator "/"
+ "Breadcrumb separator."
+ :group 'org-eldoc
+ :type 'string)
+
+(defcustom org-eldoc-test-buffer-name " *Org-eldoc test buffer*"
+ "Name of the buffer used while testing for mode-local variable values."
+ :group 'org-eldoc
+ :type 'string)
+
+(defun org-eldoc-get-breadcrumb ()
+ "Return breadcrumb if on a headline or nil."
+ (let ((case-fold-search t) cur)
+ (save-excursion
+ (beginning-of-line)
+ (save-match-data
+ (when (looking-at org-complex-heading-regexp)
+ (setq cur (match-string 4))
+ (org-format-outline-path
+ (append (org-get-outline-path) (list cur))
+ (frame-width) "" org-eldoc-breadcrumb-separator))))))
+
+(defun org-eldoc-get-src-header ()
+ "Returns lang and list of header properties if on src definition line and nil otherwise."
+ (let ((case-fold-search t) info lang hdr-args)
+ (save-excursion
+ (beginning-of-line)
+ (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)
+ hdr-args (nth 2 info))
+ (concat
+ lang
+ ": "
+ (mapconcat
+ (lambda (elem)
+ (when (and (cdr elem) (not (string= "" (cdr elem))))
+ (concat
+ (propertize (symbol-name (car elem)) 'face 'org-list-dt)
+ " "
+ (propertize (cdr elem) 'face 'org-verbatim)
+ " ")))
+ hdr-args " ")))))))
+
+(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)))))))
+
+(defvar org-eldoc-local-functions-cache (make-hash-table :size 40 :test 'equal)
+ "Cache of major-mode's eldoc-documentation-functions,
+ used by \\[org-eldoc-get-mode-local-documentation-function].")
+
+(defun org-eldoc-get-mode-local-documentation-function (lang)
+ "Check if LANG-mode sets eldoc-documentation-function and return its value."
+ (let ((cached-func (gethash lang org-eldoc-local-functions-cache 'empty))
+ (mode-func (intern-soft (format "%s-mode" lang)))
+ doc-func)
+ (if (eq 'empty cached-func)
+ (when (fboundp mode-func)
+ (with-temp-buffer
+ (funcall mode-func)
+ (setq doc-func (and eldoc-documentation-function
+ (symbol-value 'eldoc-documentation-function)))
+ (puthash lang doc-func org-eldoc-local-functions-cache))
+ doc-func)
+ cached-func)))
+
+(declare-function c-eldoc-print-current-symbol-info "c-eldoc" ())
+(declare-function css-eldoc-function "css-eldoc" ())
+(declare-function php-eldoc-function "php-eldoc" ())
+(declare-function go-eldoc--documentation-function "go-eldoc" ())
+
+(defun org-eldoc-documentation-function ()
+ "Return breadcrumbs when on a headline, args for src block header-line,
+ calls other documentation functions depending on lang when inside src body."
+ (or
+ (org-eldoc-get-breadcrumb)
+ (org-eldoc-get-src-header)
+ (let ((lang (org-eldoc-get-src-lang)))
+ (cond ((or
+ (string= lang "emacs-lisp")
+ (string= lang "elisp")) (if (fboundp 'elisp-eldoc-documentation-function)
+ (elisp-eldoc-documentation-function)
+ (let (eldoc-documentation-function)
+ (eldoc-print-current-symbol-info))))
+ ((or
+ (string= lang "c") ;; http://github.com/nflath/c-eldoc
+ (string= lang "C")) (when (require 'c-eldoc nil t)
+ (c-eldoc-print-current-symbol-info)))
+ ;; https://github.com/zenozeng/css-eldoc
+ ((string= lang "css") (when (require 'css-eldoc nil t)
+ (css-eldoc-function)))
+ ;; https://github.com/zenozeng/php-eldoc
+ ((string= lang "php") (when (require 'php-eldoc nil t)
+ (php-eldoc-function)))
+ ((or
+ (string= lang "go")
+ (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))))))))
+
+;;;###autoload
+(defun org-eldoc-load ()
+ "Set up org-eldoc documentation function."
+ (interactive)
+ (setq-local eldoc-documentation-function #'org-eldoc-documentation-function))
+
+;;;###autoload
+(add-hook 'org-mode-hook #'org-eldoc-load)
+
+(provide 'org-eldoc)
+
+;; -*- coding: utf-8-emacs; -*-
+
+;;; org-eldoc.el ends here
diff --git a/contrib/lisp/org-eww.el b/contrib/lisp/org-eww.el
new file mode 100644
index 0000000..a6973e9
--- /dev/null
+++ b/contrib/lisp/org-eww.el
@@ -0,0 +1,171 @@
+;;; org-eww.el --- Store url and kill from Eww mode for Org
+
+;; Copyright (C) 2014, 2015 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 d58043f..1506c3b 100644
--- a/contrib/lisp/org-expiry.el
+++ b/contrib/lisp/org-expiry.el
@@ -218,11 +218,12 @@ Return nil if the entry is not expired. Otherwise return the
amount of time between today and the expiry date.
If there is no creation date, use `org-expiry-created-date'.
-If there is no expiry date, use `org-expiry-expiry-date'."
+If there is no expiry date, use `org-expiry-wait'."
(let* ((ex-prop org-expiry-expiry-property-name)
(cr-prop org-expiry-created-property-name)
(ct (current-time))
- (cr (org-read-date nil t (or (org-entry-get (point) cr-prop t) "+0d")))
+ (cr (org-read-date nil t (or (org-entry-get (point) cr-prop t)
+ org-expiry-created-date)))
(ex-field (or (org-entry-get (point) ex-prop t) org-expiry-wait))
(ex (if (string-match "^[ \t]?[+-]" ex-field)
(time-add cr (time-subtract (org-read-date nil t ex-field) ct))
diff --git a/contrib/lisp/org-favtable.el b/contrib/lisp/org-favtable.el
deleted file mode 100755
index 3a6bb88..0000000
--- a/contrib/lisp/org-favtable.el
+++ /dev/null
@@ -1,1701 +0,0 @@
-;;; org-favtable.el --- Lookup table of favorite references and links
-
-;; Copyright (C) 2011-2014 Free Software Foundation, Inc.
-
-;; Author: Marc-Oliver Ihm <org-favtable@ferntreffer.de>
-;; Keywords: hypermedia, matching
-;; Requires: org
-;; Download: http://orgmode.org/worg/code/elisp/org-favtable.el
-;; Version: 2.2.0
-
-;; This file is not part of GNU Emacs.
-
-;;; License:
-
-;; This program is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 3, or (at your option)
-;; any later version.
-;;
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
-
-;;; Commentary:
-
-;; Purpose:
-;;
-;; Mark and find your favorite things and locations in org easily: Create
-;; and update a lookup table of your references and links. Often used
-;; entries bubble to the top and entering some keywords displays only the
-;; matching entries. That way the right entry one can be picked easily.
-;;
-;; References are essentially small numbers (e.g. "R237" or "-455-"),
-;; which are created by this package; they are well suited to be used
-;; outside of org. Links are just normal org-mode links.
-;;
-;;
-;; Setup:
-;;
-;; - Add these lines to your .emacs:
-;;
-;; (require 'org-favtable)
-;; ;; Good enough to start, but later you should probably
-;; ;; change this id, as will be explained below
-;; (setq org-favtable-id "00e26bef-1929-4110-b8b4-7eb9c9ab1fd4")
-;; ;; Optionally assign a key. Pick your own favorite.
-;; (global-set-key (kbd "C-+") 'org-favtable)
-;;
-;; - Just invoke `org-favtable', which will explain how to complete your
-;; setup by creating the necessary table of favorites.
-;;
-;;
-;; Further reading:
-;;
-;; Invoke `org-favtable' and pick one of its help options. You may also
-;; read the documentation of `org-favtable-id' for setup instructions, of
-;; `org-favtable' for regular usage and of `org-favtable--commands' for a
-;; list of available commands.
-;;
-
-;;; Change Log:
-
-;; [2013-02-28 Th] Version 2.2.0:
-;; - Allowed shortcuts like "h237" for command "head" with argument "237"
-;; - Integrated with org-mark-ring-goto
-;;
-;; [2013-01-25 Fr] Version 2.1.0:
-;; - Added full support for links
-;; - New commands "missing" and "statistics"
-;; - Renamed the package from "org-reftable" to "org-favtable"
-;; - Additional columns are required (e.g. "link"). Error messages will
-;; guide you
-;;
-;; [2012-12-07 Fr] Version 2.0.0:
-;; - The format of the table of favorites has changed ! You need to bring
-;; your existing table into the new format by hand (which however is
-;; easy and explained below)
-;; - Reference table can be sorted after usage count or date of last access
-;; - Ask user explicitly, which command to invoke
-;; - Renamed the package from "org-refer-by-number" to "org-reftable"
-
-;; [2012-09-22 Sa] Version 1.5.0:
-;; - New command "sort" to sort a buffer or region by reference number
-;; - New commands "highlight" and "unhighlight" to mark references
-
-;; [2012-07-13 Fr] Version 1.4.0:
-;; - New command "head" to find a headline with a reference number
-
-;; [2012-04-28 Sa] Version 1.3.0:
-;; - New commands occur and multi-occur
-;; - All commands can now be invoked explicitly
-;; - New documentation
-;; - Many bugfixes
-
-;; [2011-12-10 Sa] Version 1.2.0:
-;; - Fixed a bug, which lead to a loss of newly created reference numbers
-;; - Introduced single and double prefix arguments
-;; - Started this Change Log
-
-;;; Code:
-
-(require 'org-table)
-(require 'cl)
-
-(defvar org-favtable--version "2.2.0")
-(defvar org-favtable--preferred-command nil)
-
-(defvar org-favtable--commands '(occur head ref link enter leave goto + help reorder fill sort update highlight unhighlight missing statistics)
- "List of commands known to org-favtable:
-
-Commands known:
-
- occur: If you supply a keyword (text): Apply emacs standard
- occur operation on the table of favorites; ask for a
- string (keyword) to select lines. Occur will only show you
- lines which contain the given keyword, so you can easily find
- the right one. You may supply a list of words seperated by
- comma (\",\"), to select lines that contain any or all of the
- given words.
-
- If you supply a reference number: Apply emacs standard
- multi-occur operation all org-mode buffers to search for a
- specific reference.
-
- You may also read the note at the end of this help on saving
- the keystroke RET to accept this frequent default command.
-
- head: If invoked outside the table of favorites, ask for a
- reference number and search for a heading containing it. If
- invoked within favtable dont ask; rather use the reference or
- link from the current line.
-
- ref: Create a new reference, copy any previously selected text.
- If already within reftable, fill in ref-column.
-
- link: Create a new line in reftable with a link to the current node.
- Do not populate the ref column; this can later be populated by
- calling the \"fill\" command from within the reftable.
-
- leave: Leave the table of favorites. If the last command has
- been \"ref\", the new reference is copied and ready to yank.
- This \"org-mark-ring-goto\" and can be called several times
- in succession.
-
- enter: Just enter the node with the table of favorites.
-
- goto: Search for a specific reference within the table of
- favorites.
-
- help: Show this list of commands.
-
- +: Show all commands including the less frequently used ones
- given below. If \"+\" is followd by enough letters of such a
- command (e.g. \"+fi\"), then this command is invoked
- directly.
-
- reorder: Temporarily reorder the table of favorites, e.g. by
- count, reference or last access.
-
- fill: If either ref or link is missing, fill it.
-
- sort: Sort a set of lines (either the active region or the
- whole buffer) by the references found in each line.
-
- update: For the given reference, update the line in the
- favtable.
-
- highlight: Highlight references in region or buffer.
-
- unhighlight: Remove highlights.
-
- missing : Search for missing reference numbers (which do not
- appear in the reference table). If requested, add additional
- lines for them, so that the command \"new\" is able to reuse
- them.
-
- statistics : Show some statistics (e.g. minimum and maximum
- reference) about favtable.
-
-
-
-Two ways to save keystrokes:
-
-When prompting for a command, org-favtable puts the most likely
-one (e.g. \"occur\" or \"ref\") at the front of the list, so that
-you may just type RET.
-
-If this command needs additional input (like e.g. \"occur\"), you
-may supply this input right away, although you are still beeing
-prompted for the command. So do an occur for the string \"foo\",
-you can just enter \"foo\" without even entering \"occur\".
-
-
-Another way to save keystrokes applies if you want to choose a
-command, that requrires a reference number (and would normally
-prompt for it): In that case you may just enter enough characters
-from your command, so that it appears first in the list of
-matches; then immediately enter the number of the reference you
-are searching for. So the input \"h237\" would execute the
-command \"head\" for reference \"237\" right away.
-
-")
-
-(defvar org-favtable--commands-some '(occur head ref link leave enter goto + help))
-
-(defvar org-favtable--columns nil)
-
-(defvar org-favtable-id nil
- "Id of the Org-mode node, which contains the favorite table.
-
-Read below, on how to set up things. See the help options
-\"usage\" and \"commands\" for normal usage after setup.
-
-Setup requires two steps:
-
- - Adjust your .emacs initialization file
-
- - Create a suitable org-mode node
-
-
-Here are the lines, you need to add to your .emacs:
-
- (require 'org-favtable)
- ;; Good enough to start, but later you should probably
- ;; change this id, as will be explained below
- (setq org-favtable-id \"00e26bef-1929-4110-b8b4-7eb9c9ab1fd4\")
- ;; Optionally assign a key. Pick your own favorite.
- (global-set-key (kbd \"C-+\") 'org-favtable)
-
-Do not forget to restart emacs to make these lines effective.
-
-
-As a second step you need to create the org-mode node, where your
-reference numbers and links will be stored. It may look like
-this:
-
- * org-favtable
- :PROPERTIES:
- :ID: 00e26bef-1929-4110-b8b4-7eb9c9ab1fd4
- :END:
-
-
- | | | Comment, description, details | | | |
- | ref | link | ;c | count;s | created | last-accessed |
- | | <4> | <30> | | | |
- |-----+------+--------------------------------+---------+---------+---------------|
- | R1 | | My first reference | | | |
-
-
-You may just copy this node into one of your org-files. Many
-things however can or should be adjusted:
-
- - The node needs not be a top level node.
-
- - Its name is completely at you choice. The node is found
- through its ID.
-
- - There are three lines of headings above the first hline. The
- first one is ignored by org-favtable, and you can use them to
- give meaningful names to columns; the second line contains
- configuration information for org-favtable; please read
- further below for its format. The third line is optional and
- may contain width-informations (e.g. <30>) only.
-
- - The sequence of columns does not matter. You may reorder them
- any way you like; e.g. make the comment-column the last
- columns within the table. Columns ar found by their name,
- which appears in the second heading-line.
-
- - You can add further columns or even remove the
- \"Comment\"-column. All other columns from the
- example (e.g. \"ref\", \"link\", \"count\", \"created\" and
- \"last-accessed\") are required.
-
- - Your references need not start at \"R1\"; However, having an
- initial row is required (it serves as a template for subsequent
- references).
-
- - Your reference need not have the form \"R1\"; you may just as
- well choose any text, that contains a single number,
- e.g. \"reference-{1}\" or \"#7\" or \"++17++\" or \"-344-\". The
- function `org-favtable' will inspect your first reference and
- create all subsequent references in the same way.
-
- - You may want to change the ID-Property of the node above and
- create a new one, which is unique (and not just a copy of
- mine). You need to change it in the lines copied to your .emacs
- too. However, this is not strictly required to make things
- work, so you may do this later, after trying out this package.
-
-
-Optionally you may tweak the second header line to adjust
-`org-favtable' a bit. In the example above it looks like this
- (with spaces collapsed):
-
-
- | ref | link | ;c | count;s | created | last-accessed |
-
-
-The different fields have different meanings:
-
- - ref : This denotes the column which contains you references
-
- - link : Column for org-mode links, which can be used to access
- locations within your files.
-
- - ;c : The flag \"c\" (\"c\" for \"copy\") denotes this column
- as the one beeing copied on command \"leave\". In the example
- above, it is also the comment-column.
-
- - count;s : this is the column which counts, how many time this
- line has been accessed (which is the key-feature of this
- package). The flag \"s\" stands for \"sort\", so the table is
- sorted after this column. You may also sort after columns
- \"ref\" or \"last-accessed\".
-
- - created : Date when this line was created.
-
- - last-accessed : Date and time, when this line was last accessed.
-
-
-After this two-step setup process you may invoke `org-favtable'
-to create a new favorite. Read the help option \"usage\" for
-instructions on normal usage, read the help option \"commands\"
-for help on single commands.
-
-")
-
-
-(defvar org-favtable--text-to-yank nil)
-(defvar org-favtable--last-action nil)
-(defvar org-favtable--occur-buffer nil)
-(defvar org-favtable--ref-regex nil)
-(defvar org-favtable--ref-format nil)
-
-
-
-(defun org-favtable (&optional what search search-is-link)
- "Mark and find your favorite items and org-locations easily:
-Create and update a lookup table of your favorite references and
-links. Often used entries automatically bubble to the top of the
-table; entering some keywords narrows it to just the matching
-entries; that way the right one can be picked easily.
-
-References are essentially small numbers (e.g. \"R237\" or
-\"-455-\"), as created by this package; links are normal org-mode
-links. Within org-favtable, both are denoted as favorites.
-
-
-Read below for a detailed description of this function. See the
-help option \"setup\" or read the documentation of
-`org-favtable-id' for setup instructions.
-
-The function `org-favtable' operates on a dedicated table (called
-the table or favorites or favtable, for short) within a special
-Org-mode node. The node has to be created as part of your initial
-setup. Each line of the favorite table contains:
-
- - A reference (optional)
-
- - A link (optional)
-
- - A number; counting, how often each reference has been
- used. This number is updated automatically and the table can
- be sorted according to it, so that most frequently used
- references appear at the top of the table and can be spotted
- easily.
-
- - Its respective creation date
-
- - Date and time of last access. This column can alternatively be
- used to sort the table.
-
-To be useful, your table of favorites should probably contain a
-column with comments too, which allows lines to be selected by
-keywords.
-
-The table of favorites is found through the id of the containing
-node; this id should be stored within `org-favtable-id' (see there
-for details).
-
-
-The function `org-favtable' is the only interactive function of
-this package and its sole entry point; it offers several commands
-to create, find and look up these favorites (references and
-links). All of them are explained within org-favtable's help.
-
-
-Finally, org-favtable can also be invoked from elisp; the two
-optional arguments accepted are:
-
- search : string to search for
- what : symbol of the command to invoke
- search-is-link : t, if argument search is actually a link
-
-An example would be:
-
- (org-favtable \"237\" 'head) ;; find heading with ref 237
-
-"
-
- (interactive "P")
-
- (let (within-node ; True, if we are within node with favtable
- result-is-visible ; True, if node or occur is visible in any window
- ref-node-buffer-and-point ; cons with buffer and point of favorites node
- below-cursor ; word below cursor
- active-region ; active region (if any)
- link-id ; link of starting node, if required
- guarded-search ; with guard against additional digits
- search-is-ref ; true, if search is a reference
- commands ; currently active set of selectable commands
- what-adjusted ; True, if we had to adjust what
- what-input ; Input on what question (need not necessary be "what")
- reorder-once ; Column to use for single time sorting
- parts ; Parts of a typical reference number (which
- ; need not be a plain number); these are:
- head ; Any header before number (e.g. "R")
- maxref ; Maximum number from reference table (e.g. "153")
- tail ; Tail after number (e.g. "}" or "")
- ref-regex ; Regular expression to match a reference
- has-reuse ; True, if table contains a line for reuse
- numcols ; Number of columns in favtable
- kill-new-text ; Text that will be appended to kill ring
- message-text ; Text that will be issued as an explanation,
- ; what we have done
- initial-ref-or-link ; Initial position in reftable
- )
-
- ;;
- ;; Examine current buffer and location, before turning to favtable
- ;;
-
- ;; Get the content of the active region or the word under cursor
- (if (and transient-mark-mode
- mark-active)
- (setq active-region (buffer-substring (region-beginning) (region-end))))
- (setq below-cursor (thing-at-point 'symbol))
-
-
- ;; Find out, if we are within favable or not
- (setq within-node (string= (org-id-get) org-favtable-id))
-
- ;; Find out, if point in any window is within node with favtable
- (mapc (lambda (x) (with-current-buffer (window-buffer x)
- (when (or
- (string= (org-id-get) org-favtable-id)
- (eq (window-buffer x)
- org-favtable--occur-buffer))
- (setq result-is-visible t))))
- (window-list))
-
-
-
- ;;
- ;; Get decoration of references and highest reference from favtable
- ;;
-
-
- ;; Save initial ref or link
- (if (and within-node
- (org-at-table-p))
- (setq initial-ref-or-link
- (or (org-favtable--get-field 'ref)
- (org-favtable--get-field 'link))))
-
- ;; Find node
- (setq ref-node-buffer-and-point (org-favtable--id-find))
- (unless ref-node-buffer-and-point
- (org-favtable--report-setup-error
- (format "Cannot find node with id \"%s\"" org-favtable-id)))
-
- ;; Get configuration of reftable; catch errors
- (let ((error-message
- (catch 'content-error
-
- (with-current-buffer (car ref-node-buffer-and-point)
- (save-excursion
- (unless (string= (org-id-get) org-favtable-id)
- (goto-char (cdr ref-node-buffer-and-point)))
-
- ;; parse table while still within buffer
- (setq parts (org-favtable--parse-and-adjust-table)))
-
- nil))))
- (when error-message
- (org-pop-to-buffer-same-window (car ref-node-buffer-and-point))
- (org-reveal)
- (error error-message)))
-
- ;; Give names to parts of configuration
- (setq head (nth 0 parts))
- (setq maxref (nth 1 parts))
- (setq tail (nth 2 parts))
- (setq numcols (nth 3 parts))
- (setq ref-regex (nth 4 parts))
- (setq has-reuse (nth 5 parts))
- (setq org-favtable--ref-regex ref-regex)
- (setq org-favtable--ref-format (concat head "%d" tail))
-
- ;;
- ;; Find out, what we are supposed to do
- ;;
-
- (if (equal what '(4)) (setq what 'leave))
-
- ;; Set preferred action, that will be the default choice
- (setq org-favtable--preferred-command
- (if within-node
- (if (memq org-favtable--last-action '(ref link))
- 'leave
- 'occur)
- (if active-region
- 'ref
- (if (and below-cursor (string-match ref-regex below-cursor))
- 'occur
- nil))))
-
- ;; Ask user, what to do
- (unless what
- (setq commands (copy-list org-favtable--commands-some))
- (while (progn
- (setq what-input
- (org-icompleting-read
- "Please choose: "
- (mapcar 'symbol-name
- ;; Construct unique list of commands with
- ;; preferred one at front
- (delq nil (delete-dups
- (append
- (list org-favtable--preferred-command)
- commands))))
- nil nil))
-
-
- ;; if input starts with "+", any command (not only some) may follow
- ;; this allows input like "+sort" to be accepted
- (when (string= (substring what-input 0 1) "+")
- ;; make all commands available for selection
- (setq commands (copy-list org-favtable--commands))
- (unless (string= what-input "+")
- ;; not just "+", use following string
- (setq what-input (substring what-input 1))
-
- (let ((completions
- ;; get list of possible completions for what-input
- (all-completions what-input (mapcar 'symbol-name commands))))
- ;; use it, if unambigously
- (if (= (length completions) 1)
- (setq what-input (car completions))))))
-
-
- ;; if input ends in digits, save them away and do completions on head of input
- ;; this allows input like "h224" to be accepted
- (when (string-match "^\\([^0-9+]\\)\\([0-9]+\\)\\s *$" what-input)
- ;; use first match as input, even if ambigously
- (setq org-favtable--preferred-command
- (intern (first (all-completions (match-string 1 what-input)
- (mapcar 'symbol-name commands)))))
- ;; use digits as argument to commands
- (setq what-input (format org-favtable--ref-format
- (string-to-number (match-string 2 what-input)))))
-
- (setq what (intern what-input))
-
- ;; user is not required to input one of the commands; if
- ;; not, take the first one and use the original input for
- ;; next question
- (if (memq what commands)
- ;; input matched one element of list, dont need original
- ;; input any more
- (setq what-input nil)
- ;; what-input will be used for next question, use first
- ;; command for what
- (setq what (or org-favtable--preferred-command
- (first commands)))
- ;; remove any trailing dot, that user might have added to
- ;; disambiguate his input
- (if (equal (substring what-input -1) ".")
- ;; but do this only, if dot was really necessary to
- ;; disambiguate
- (let ((shortened-what-input (substring what-input 0 -1)))
- (unless (test-completion shortened-what-input
- (mapcar 'symbol-name
- commands))
- (setq what-input shortened-what-input)))))
-
- ;; ask for reorder in loop, because we have to ask for
- ;; what right again
- (if (eq what 'reorder)
- (setq reorder-once
- (intern
- (org-icompleting-read
- "Please choose column to reorder reftable once: "
- (mapcar 'symbol-name '(ref count last-accessed))
- nil t))))
-
- ;; maybe ask initial question again
- (memq what '(reorder +)))))
-
-
- ;;
- ;; Get search, if required
- ;;
-
- ;; These actions need a search string:
- (when (memq what '(goto occur head update))
-
- ;; Maybe we've got a search string from the arguments
- (unless search
- (let (search-from-table
- search-from-cursor)
-
- ;; Search string can come from several sources:
- ;; From ref column of table
- (when within-node
- (setq search-from-table (org-favtable--get-field 'ref)))
- ;; From string below cursor
- (when (and (not within-node)
- below-cursor
- (string-match (concat "\\(" ref-regex "\\)")
- below-cursor))
- (setq search-from-cursor (match-string 1 below-cursor)))
-
- ;; Depending on requested action, get search from one of the sources above
- (cond ((eq what 'goto)
- (setq search (or what-input search-from-cursor)))
- ((memq what '(head occur))
- (setq search (or what-input search-from-table search-from-cursor))))))
-
-
- ;; If we still do not have a search string, ask user explicitly
- (unless search
-
- (if what-input
- (setq search what-input)
- (setq search (read-from-minibuffer
- (cond ((memq what '(occur head))
- "Text or reference number to search for: ")
- ((eq what 'goto)
- "Reference number to search for, or enter \".\" for id of current node: ")
- ((eq what 'update)
- "Reference number to update: ")))))
-
- (if (string-match "^\\s *[0-9]+\\s *$" search)
- (setq search (format "%s%s%s" head (org-trim search) tail))))
-
- ;; Clean up and examine search string
- (if search (setq search (org-trim search)))
- (if (string= search "") (setq search nil))
- (setq search-is-ref (string-match ref-regex search))
-
- ;; Check for special case
- (when (and (memq what '(head goto))
- (string= search "."))
- (setq search (org-id-get))
- (setq search-is-link t))
-
- (when search-is-ref
- (setq guarded-search (org-favtable--make-guarded-search search)))
-
- ;;
- ;; Do some sanity checking before really starting
- ;;
-
- ;; Correct requested action, if nothing to search
- (when (and (not search)
- (memq what '(search occur head)))
- (setq what 'enter)
- (setq what-adjusted t))
-
- ;; For a proper reference as input, we do multi-occur
- (if (and (string-match ref-regex search)
- (eq what 'occur))
- (setq what 'multi-occur))
-
- ;; Check for invalid combinations of arguments; try to be helpful
- (when (and (memq what '(head goto))
- (not search-is-link)
- (not search-is-ref))
- (error "Can do '%s' only for a reference or link (not '%s'), try 'occur' to search for text" what search)))
-
-
- ;;
- ;; Prepare
- ;;
-
- ;; Get link if required before moving in
- (if (eq what 'link)
- (setq link-id (org-id-get-create)))
-
- ;; Move into table, if outside
- (when (memq what '(enter ref link goto occur multi-occur missing statistics))
-
- ;; Support orgmode-standard of going back (buffer and position)
- (org-mark-ring-push)
-
- ;; Switch to favtable
- (org-pop-to-buffer-same-window (car ref-node-buffer-and-point))
- (goto-char (cdr ref-node-buffer-and-point))
- (show-subtree)
- (org-show-context)
-
- ;; sort favtable
- (org-favtable--sort-table reorder-once))
-
- ;; Goto back to initial ref, because reformatting of table above might
- ;; have moved point
- (when initial-ref-or-link
- (while (and (org-at-table-p)
- (not (or
- (string= initial-ref-or-link (org-favtable--get-field 'ref))
- (string= initial-ref-or-link (org-favtable--get-field 'link)))))
- (forward-line))
- ;; did not find ref, go back to top
- (if (not (org-at-table-p)) (goto-char top)))
-
-
- ;;
- ;; Actually do, what is requested
- ;;
-
- (cond
-
-
- ((eq what 'help)
-
- (let ((help-what
- ;; which sort of help ?
- (intern
- (concat
- "help-"
- (org-icompleting-read
- "Help on: "
- (mapcar 'symbol-name '(commands usage setup version example))
- nil t)))))
-
- ;; help is taken from docstring of functions or variables
- (cond ((eq help-what 'help-commands)
- (org-favtable--show-help 'org-favtable--commands))
- ((eq help-what 'help-usage)
- (org-favtable--show-help 'org-favtable))
- ((eq help-what 'help-setup)
- (org-favtable--show-help 'org-favtable-id))
- ((eq help-what 'help-version)
- (org-favtable-version)))))
-
-
- ((eq what 'multi-occur)
-
- ;; Conveniently position cursor on number to search for
- (org-favtable--goto-top)
- (let (found (initial (point)))
- (while (and (not found)
- (forward-line)
- (org-at-table-p))
- (save-excursion
- (setq found (string= search
- (org-favtable--get-field 'ref)))))
- (if found
- (org-favtable--update-line nil)
- (goto-char initial)))
-
- ;; 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))))
-
- ;; Do multi-occur
- (multi-occur org-buffers guarded-search)
- (if (get-buffer "*Occur*")
- (progn
- (setq message-text (format "multi-occur for '%s'" search))
- (setq org-favtable--occur-buffer (get-buffer "*Occur*"))
- (other-window 1)
- (toggle-truncate-lines 1))
- (setq message-text (format "Did not find '%s'" search)))))
-
-
- ((eq what 'head)
-
- (let (link)
- ;; link either from table or passed in as argument
-
- ;; try to get link
- (if search-is-link
- (setq link (org-trim search))
- (if (and within-node
- (org-at-table-p))
- (setq link (org-favtable--get-field 'link))))
-
- ;; use link if available
- (if (and link
- (not (string= link "")))
- (progn
- (org-id-goto link)
- (org-favtable--update-line search)
- (setq message-text "Followed link"))
-
- (message (format "Scanning headlines for '%s' ..." search))
- (let (buffer point)
- (if (catch 'found
- (progn
- ;; loop over all headlines, stop on first match
- (org-map-entries
- (lambda ()
- (when (looking-at (concat ".*" guarded-search))
- ;; remember location and bail out
- (setq buffer (current-buffer))
- (setq point (point))
- (throw 'found t)))
- nil 'agenda)
- nil))
-
- (progn
- (org-favtable--update-line search)
- (setq message-text (format "Found '%s'" search))
- (org-pop-to-buffer-same-window buffer)
- (goto-char point)
- (org-reveal))
- (setq message-text (format "Did not find '%s'" search)))))))
-
-
- ((eq what 'leave)
-
- (when result-is-visible
-
- ;; If we are within the occur-buffer, switch over to get current line
- (if (and (string= (buffer-name) "*Occur*")
- (eq org-favtable--last-action 'occur))
- (occur-mode-goto-occurrence)))
-
- (setq kill-new-text org-favtable--text-to-yank)
- (setq org-favtable--text-to-yank nil)
-
- ;; If "leave" has been called two times in succession, make
- ;; org-mark-ring-goto believe it has been called two times too
- (if (eq org-favtable--last-action 'leave)
- (let ((this-command nil) (last-command nil))
- (org-mark-ring-goto 1))
- (org-mark-ring-goto 0)))
-
-
- ((eq what 'goto)
-
- ;; Go downward in table to requested reference
- (let (found (initial (point)))
- (org-favtable--goto-top)
- (while (and (not found)
- (forward-line)
- (org-at-table-p))
- (save-excursion
- (setq found
- (string= search
- (org-favtable--get-field
- (if search-is-link 'link 'ref))))))
- (if found
- (progn
- (setq message-text (format "Found '%s'" search))
- (org-favtable--update-line nil)
- (org-table-goto-column (org-favtable--column-num 'ref))
- (if (looking-back " ") (backward-char))
- ;; remember string to copy
- (setq org-favtable--text-to-yank
- (org-trim (org-table-get-field (org-favtable--column-num 'copy)))))
- (setq message-text (format "Did not find '%s'" search))
- (goto-char initial)
- (forward-line)
- (setq what 'missed))))
-
-
- ((eq what 'occur)
-
- ;; search for string: occur
- (let (search-regexp
- all-or-any
- (search-words (split-string search "," t)))
-
- (if (< (length search-words) 2)
- ;; only one word to search; use it as is
- (setq search-regexp search)
- ;; construct regexp to match any of the words (maybe throw out some matches later)
- (setq search-regexp
- (mapconcat (lambda (x) (concat "\\(" x "\\)")) search-words "\\|"))
- (setq all-or-any
- (intern
- (org-icompleting-read
- "Two or more words have been specified; show lines, that match: " '("all" "any")))))
-
- (save-restriction
- (org-narrow-to-subtree)
- (occur search-regexp)
- (widen)
- (if (get-buffer "*Occur*")
- (with-current-buffer "*Occur*"
-
- ;; install helpful keyboard-shortcuts within occur-buffer
- (let ((keymap (make-sparse-keymap)))
- (set-keymap-parent keymap occur-mode-map)
-
- (define-key keymap (kbd "RET")
- (lambda () (interactive)
- (org-favtable--occur-helper 'head)))
-
- (define-key keymap (kbd "<C-return>")
- (lambda () (interactive)
- (org-favtable--occur-helper 'multi-occur)))
-
- (define-key keymap (kbd "<M-return>")
- (lambda () (interactive)
- (org-favtable--occur-helper 'goto)))
-
- (define-key keymap (kbd "<C-M-return>")
- (lambda () (interactive)
- (org-favtable--occur-helper 'update)))
-
- (use-local-map keymap))
-
- ;; Brush up occur buffer
- (other-window 1)
- (toggle-truncate-lines 1)
- (let ((inhibit-read-only t))
- ;; insert some help text
- (insert (substitute-command-keys
- "Type RET to find heading, C-RET for multi-occur, M-RET to go to occurence and C-M-RET to update line in reftable.\n\n"))
- (forward-line 1)
-
- ;; when matching all of multiple words, remove all lines that do not match one of the words
- (when (eq all-or-any 'all)
- (mapc (lambda (x) (keep-lines x)) search-words))
-
- ;; replace description from occur
- (when all-or-any
- (forward-line -1)
- (kill-line)
- (let ((count (- (count-lines (point) (point-max)) 1)))
- (insert (format "%d %s for %s of %s"
- count
- (if (= count 1) "match" "matches")
- all-or-any
- search)))
- (forward-line)
- (beginning-of-line))
-
- ;; Record link or reference for each line in
- ;; occur-buffer, that is linked into reftable. Because if
- ;; we later realign the reftable and then reuse the occur
- ;; buffer, the original links might point nowehere.
- (save-excursion
- (while (not (eq (point) (point-max)))
- (let ((beg (line-beginning-position))
- (end (line-end-position))
- pos ref link)
-
- ;; occur has saved the position into a special property
- (setq pos (get-text-property (point) 'occur-target))
- (when pos
- ;; but this property might soon point nowhere; so retrieve ref-or-link instead
- (with-current-buffer (marker-buffer pos)
- (goto-char pos)
- (setq ref (org-favtable--get-field 'ref))
- (setq link (org-favtable--get-field 'link))))
- ;; save as text property
- (put-text-property beg end 'org-favtable--ref ref)
- (put-text-property beg end 'org-favtable--link link))
- (forward-line))))
-
- (setq message-text
- (format "Occur for '%s'" search)))
- (setq message-text
- (format "Did not find any matches for '%s'" search))))))
-
-
- ((memq what '(ref link))
-
- ;; add a new row (or reuse existing one)
- (let (new)
-
- (when (eq what 'ref)
- ;; go through table to find first entry to be reused
- (when has-reuse
- (org-favtable--goto-top)
- ;; go through table
- (while (and (org-at-table-p)
- (not new))
- (when (string=
- (org-favtable--get-field 'count)
- ":reuse:")
- (setq new (org-favtable--get-field 'ref))
- (if new (org-table-kill-row)))
- (forward-line)))
-
- ;; no ref to reuse; construct new reference
- (unless new
- (setq new (format "%s%d%s" head (1+ maxref) tail)))
-
- ;; remember for org-mark-ring-goto
- (setq org-favtable--text-to-yank new))
-
- ;; insert ref or link as very first row
- (org-favtable--goto-top)
- (org-table-insert-row)
-
- ;; fill special columns with standard values
- (when (eq what 'ref)
- (org-table-goto-column (org-favtable--column-num 'ref))
- (insert new))
- (when (eq what 'link)
- (org-table-goto-column (org-favtable--column-num 'link))
- (insert link-id))
- (org-table-goto-column (org-favtable--column-num 'created))
- (org-insert-time-stamp nil nil t)
-
- ;; goto first empty field
- (unless (catch 'empty
- (dotimes (col 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))
-
- (org-table-align)
- (if active-region (setq kill-new-text active-region))
- (if (eq what 'ref)
- (setq message-text (format "Adding a new row with ref '%s'" new))
- (setq message-text (format "Adding a new row linked to '%s'" link-id)))))
-
-
- ((eq what 'enter)
-
- ;; simply go into table
- (org-favtable--goto-top)
- (show-subtree)
- (recenter)
- (if what-adjusted
- (setq message-text "Nothing to search for; at favtable")
- (setq message-text "At favtable")))
-
-
- ((eq what 'fill)
-
- ;; check, if within reftable
- (unless (and within-node
- (org-at-table-p))
- (error "Not within table of favorites"))
-
- ;; applies to missing refs and missing links alike
- (let ((ref (org-favtable--get-field 'ref))
- (link (org-favtable--get-field 'link)))
-
- (if (and (not ref)
- (not link))
- ;; have already checked this during parse, check here anyway
- (error "Columns ref and link are both empty in this line"))
-
- ;; fill in new ref
- (if (not ref)
- (progn
- (setq kill-new-text (format "%s%d%s" head (1+ maxref) tail))
- (org-favtable--get-field 'ref kill-new-text)
- ;; remember for org-mark-ring-goto
- (setq org-favtable--text-to-yank kill-new-text)
- (org-id-goto link)
- (setq message-text "Filled reftable field with new reference"))
-
- ;; fill in new link
- (if (not link)
- (progn
- (setq guarded-search (org-favtable--make-guarded-search ref))
- (message (format "Scanning headlines for '%s' ..." ref))
- (let (link)
- (if (catch 'found
- (org-map-entries
- (lambda ()
- (when (looking-at (concat ".*" guarded-search))
- (setq link (org-id-get-create))
- (throw 'found t)))
- nil 'agenda)
- nil)
-
- (progn
- (org-favtable--get-field 'link link)
- (setq message-text "Inserted link"))
-
- (setq message-text (format "Did not find reference '%s'" ref)))))
-
- ;; nothing is missing
- (setq message-text "Columns 'ref' and 'link' are already filled; nothing to do")))))
-
-
- ((eq what 'sort)
-
- ;; sort lines according to contained reference
- (let (begin end where)
- (catch 'aborted
- ;; either active region or whole buffer
- (if (and transient-mark-mode
- mark-active)
- ;; sort only region
- (progn
- (setq begin (region-beginning))
- (setq end (region-end))
- (setq where "region"))
- ;; sort whole buffer
- (setq begin (point-min))
- (setq end (point-max))
- (setq where "whole buffer")
- ;; make sure
- (unless (y-or-n-p "Sort whole buffer ")
- (setq message-text "Sort aborted")
- (throw 'aborted nil)))
-
- (save-excursion
- (save-restriction
- (goto-char (point-min))
- (narrow-to-region begin end)
- (sort-subr nil 'forward-line 'end-of-line
- (lambda ()
- (if (looking-at (concat ".*"
- (org-favtable--make-guarded-search ref-regex 'dont-quote)))
- (string-to-number (match-string 1))
- 0))))
- (highlight-regexp ref-regex)
- (setq message-text (format "Sorted %s from character %d to %d, %d lines"
- where begin end
- (count-lines begin end)))))))
-
-
- ((eq what 'update)
-
- ;; simply update line in reftable
- (save-excursion
- (let ((ref-or-link (if search-is-link "link" "reference")))
- (beginning-of-line)
- (if (org-favtable--update-line search)
- (setq message-text (format "Updated %s '%s'" ref-or-link search))
- (setq message-text (format "Did not find %s '%s'" ref-or-link search))))))
-
-
- ((eq what 'parse)
-
- ;; Just parse the reftable, which is already done, so nothing to do
- )
-
-
- ((memq what '(highlight unhighlight))
-
- (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 (eq what 'highlight)
- (progn
- (highlight-regexp ref-regex)
- (setq message-text (format "Highlighted references in %s" where)))
- (unhighlight-regexp ref-regex)
- (setq message-text (format "Removed highlights for references in %s" where)))))))
-
-
- ((memq what '(missing statistics))
-
- (org-favtable--goto-top)
- (let (missing
- ref-field
- ref
- min
- max
- (total 0))
-
- ;; start with list of all references
- (setq missing (mapcar (lambda (x) (format "%s%d%s" head x tail))
- (number-sequence 1 maxref)))
-
- ;; go through table and remove all refs, that we see
- (while (and (forward-line)
- (org-at-table-p))
-
- ;; get ref-field and number
- (setq ref-field (org-favtable--get-field 'ref))
- (if (and ref-field
- (string-match ref-regex ref-field))
- (setq ref (string-to-number (match-string 1 ref-field))))
-
- ;; remove existing refs from list
- (if ref-field (setq missing (delete ref-field missing)))
-
- ;; record min and max
- (if (or (not min) (< ref min)) (setq min ref))
- (if (or (not max) (> ref max)) (setq max ref))
-
- ;; count
- (setq total (1+ total)))
-
- ;; insert them, if requested
- (forward-line -1)
- (if (eq what 'statistics)
-
- (setq message-text (format "Found %d references from %s to %s. %d references below highest do not appear in table. "
- total
- (format org-favtable--format min)
- (format org-favtable--format max)
- (length missing)))
-
- (if (y-or-n-p (format "Found %d missing references; do you wish to append them to the table of favorites"
- (length missing)))
- (let (type)
- (setq type (org-icompleting-read
- "Insert new lines for reuse by command \"new\" or just as missing ? " '("reuse" "missing")))
- (mapc (lambda (x)
- (let (org-table-may-need-update) (org-table-insert-row t))
- (org-favtable--get-field 'ref x)
- (org-favtable--get-field 'count (format ":%s:" type)))
- missing)
- (org-table-align)
- (setq message-text (format "Inserted %d new lines for missing refernces" (length missing))))
- (setq message-text (format "%d missing references." (length missing)))))))
-
-
- (t (error "This is a bug: unmatched case '%s'" what)))
-
-
- ;; remember what we have done for next time
- (setq org-favtable--last-action what)
-
- ;; 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) ""))))
- (unless (string= m "") (message m)))
- (if kill-new-text (kill-new kill-new-text))))
-
-
-
-(defun org-favtable--parse-and-adjust-table ()
-
- (let ((maxref 0)
- top
- bottom
- ref-field
- link-field
- parts
- numcols
- head
- tail
- ref-regex
- has-reuse
- initial-point)
-
- (setq initial-point (point))
- (org-favtable--goto-top)
- (setq top (point))
-
- (goto-char top)
-
- ;; count columns
- (org-table-goto-column 100)
- (setq numcols (- (org-table-current-column) 1))
-
- ;; get contents of columns
- (forward-line -2)
- (unless (org-at-table-p)
- (org-favtable--report-setup-error
- "Table of favorites starts with a hline" t))
-
- ;; check for optional line consisting solely of width specifications
- (beginning-of-line)
- (if (looking-at "\\s *|\\(\\(\\s *|\\)\\|\\(\\s *<[0-9]+>\\s *|\\)\\)+\\s *$")
- (forward-line -1))
- (org-table-goto-column 1)
-
- (setq org-favtable--columns (org-favtable--parse-headings numcols))
-
- ;; Go beyond end of table
- (while (org-at-table-p) (forward-line 1))
-
- ;; Kill all empty rows at bottom
- (while (progn
- (forward-line -1)
- (org-table-goto-column 1)
- (and
- (not (org-favtable--get-field 'ref))
- (not (org-favtable--get-field 'link))))
- (org-table-kill-row))
- (forward-line)
- (setq bottom (point))
- (forward-line -1)
-
- ;; Retrieve any decorations around the number within the first nonempty ref-field
- (goto-char top)
- (while (and (org-at-table-p)
- (not (setq ref-field (org-favtable--get-field 'ref))))
- (forward-line))
-
- ;; Some Checking
- (unless ref-field
- (org-favtable--report-setup-error
- "No line of reference column contains a number" t))
-
- (unless (string-match "^\\([^0-9]*\\)\\([0-9]+\\)\\([^0-9]*\\)$" ref-field)
- (org-favtable--report-setup-error
- (format "First reference in table table of favorites ('%s') does not contain a number" ref-field) t))
-
-
- ;; These are the decorations used within the first ref of favtable
- (setq head (match-string 1 ref-field))
- (setq tail (match-string 3 ref-field))
- (setq ref-regex (concat (regexp-quote head)
- "\\([0-9]+\\)"
- (regexp-quote tail)))
-
- ;; Go through table to find maximum number and do some checking
- (let ((ref 0))
-
- (while (org-at-table-p)
-
- (setq ref-field (org-favtable--get-field 'ref))
- (setq link-field (org-favtable--get-field 'link))
-
- (if (and (not ref-field)
- (not link-field))
- (throw 'content-error "Columns ref and link are both empty in this line"))
-
- (if ref-field
- (if (string-match ref-regex ref-field)
- ;; grab number
- (setq ref (string-to-number (match-string 1 ref-field)))
- (throw 'content-error "Column ref does not contain a number")))
-
- ;; check, if higher ref
- (if (> ref maxref) (setq maxref ref))
-
- ;; check if ref is ment for reuse
- (if (string= (org-favtable--get-field 'count) ":reuse:")
- (setq has-reuse 1))
-
- (forward-line 1)))
-
- ;; sort used to be here
-
- (setq parts (list head maxref tail numcols ref-regex has-reuse))
-
- ;; go back to top of table
- (goto-char top)
-
- parts))
-
-
-
-(defun org-favtable--sort-table (sort-column)
-
- (unless sort-column (setq sort-column (org-favtable--column-num 'sort)))
-
- (let (top
- bottom
- ref-field
- count-field
- count-special)
-
-
- ;; get boundaries of table
- (org-favtable--goto-top)
- (forward-line 0)
- (setq top (point))
- (while (org-at-table-p) (forward-line))
- (setq bottom (point))
-
- (save-restriction
- (narrow-to-region top bottom)
- (goto-char top)
- (sort-subr t
- 'forward-line
- 'end-of-line
- (lambda ()
- (let (ref
- (ref-field (or (org-favtable--get-field 'ref) ""))
- (count-field (or (org-favtable--get-field 'count) ""))
- (count-special 0))
-
- ;; get reference with leading zeroes, so it can be
- ;; sorted as text
- (string-match org-favtable--ref-regex ref-field)
- (setq ref (format
- "%06d"
- (string-to-number
- (or (match-string 1 ref-field)
- "0"))))
-
- ;; find out, if special token in count-column
- (setq count-special (format "%d"
- (- 2
- (length (member count-field '(":missing:" ":reuse:"))))))
-
- ;; Construct different sort-keys according to
- ;; requested sort column; prepend count-special to
- ;; sort special entries at bottom of table, append ref
- ;; as a secondary sort key
- (cond
-
- ((eq sort-column 'count)
- (concat count-special
- (format
- "%08d"
- (string-to-number (or (org-favtable--get-field 'count)
- "")))
- ref))
-
- ((eq sort-column 'last-accessed)
- (concat count-special
- (org-favtable--get-field 'last-accessed)
- " "
- ref))
-
- ((eq sort-column 'ref)
- (concat count-special
- ref))
-
- (t (error "This is a bug: unmatched case '%s'" sort-column)))))
-
- nil 'string<)))
-
- ;; align table
- (org-table-align))
-
-
-(defun org-favtable--goto-top ()
-
- ;; go to heading of node
- (while (not (org-at-heading-p)) (forward-line -1))
- (forward-line 1)
- ;; go to table within node, but make sure we do not get into another node
- (while (and (not (org-at-heading-p))
- (not (org-at-table-p))
- (not (eq (point) (point-max))))
- (forward-line 1))
-
- ;; check, if there really is a table
- (unless (org-at-table-p)
- (org-favtable--report-setup-error
- (format "Cannot find favtable within node %s" org-favtable-id) t))
-
- ;; go to first hline
- (while (and (not (org-at-table-hline-p))
- (org-at-table-p))
- (forward-line 1))
-
- ;; and check
- (unless (org-at-table-hline-p)
- (org-favtable--report-setup-error
- "Cannot find hline within table of favorites" t))
-
- (forward-line 1)
- (org-table-goto-column 1))
-
-
-
-(defun org-favtable--id-find ()
- "Find org-favtable-id"
- (let ((marker (org-id-find org-favtable-id 'marker))
- marker-and-buffer)
-
- (if marker
- (progn
- (setq marker-and-buffer (cons (marker-buffer marker) (marker-position marker)))
- (move-marker marker nil)
- marker-and-buffer)
- nil)))
-
-
-
-(defun org-favtable--parse-headings (numcols)
-
- (let (columns)
-
- ;; Associate names of special columns with column-numbers
- (setq columns (copy-tree '((ref . 0) (link . 0) (created . 0) (last-accessed . 0)
- (count . 0) (sort . nil) (copy . nil))))
-
- ;; For each column
- (dotimes (col numcols)
- (let* (field-flags ;; raw heading, consisting of file name and maybe
- ;; flags (seperated by ";")
- field ;; field name only
- field-symbol ;; and as a symbol
- flags ;; flags from field-flags
- found)
-
- ;; parse field-flags into field and flags
- (setq field-flags (org-trim (org-table-get-field (+ col 1))))
- (if (string-match "^\\([^;]*\\);\\([a-z]+\\)$" field-flags)
- (progn
- (setq field (downcase (or (match-string 1 field-flags) "")))
- ;; get flags as list of characters
- (setq flags (mapcar 'string-to-char
- (split-string
- (downcase (match-string 2 field-flags))
- "" t))))
- ;; no flags
- (setq field field-flags))
-
- (unless (string= field "") (setq field-symbol (intern (downcase field))))
-
- ;; Check, that no flags appear twice
- (mapc (lambda (x)
- (when (memq (car x) flags)
- (if (cdr (assoc (cdr x) columns))
- (org-favtable--report-setup-error
- (format "More than one heading is marked with flag '%c'" (car x)) t))))
- '((?s . sort)
- (?c . copy)))
-
- ;; Process flags
- (if (memq ?s flags)
- (setcdr (assoc 'sort columns) field-symbol))
- (if (memq ?c flags)
- (setcdr (assoc 'copy columns) (+ col 1)))
-
- ;; Store columns in alist
- (setq found (assoc field-symbol columns))
- (when found
- (if (> (cdr found) 0)
- (org-favtable--report-setup-error
- (format "'%s' appears two times as column heading" (downcase field)) t))
- (setcdr found (+ col 1)))))
-
- ;; check if all necessary informations have been specified
- (mapc (lambda (col)
- (unless (> (cdr (assoc col columns)) 0)
- (org-favtable--report-setup-error
- (format "column '%s' has not been set" col) t)))
- '(ref link count created last-accessed))
-
- ;; use ref as a default sort-column
- (unless (cdr (assoc 'sort columns))
- (setcdr (assoc 'sort columns) 'ref))
- columns))
-
-
-
-(defun org-favtable--report-setup-error (text &optional switch-to-node)
-
- (when switch-to-node
- (org-id-goto org-favtable-id)
- (delete-other-windows))
-
- (when (y-or-n-p (concat
- text
- ";\n"
- "the correct setup is explained in the documentation of 'org-favtable-id'.\n"
- "Do you want to read it ? "))
- (org-favtable--show-help 'org-favtable-id))
-
- (error "")
- (setq org-favtable--last-action 'leave))
-
-
-
-(defun org-favtable--show-help (function-or-variable)
-
- (let ((isfun (functionp function-or-variable)))
- ;; bring up help-buffer for function or variable
- (if isfun
- (describe-function function-or-variable)
- (describe-variable function-or-variable))
-
-
- ;; clean up help-buffer
- (pop-to-buffer "*Help*")
- (let ((inhibit-read-only t))
- (goto-char (point-min))
- (while (progn
- (kill-line 1)
- (not (looking-at
- (if isfun
- "("
- "Documentation:")))))
- (kill-line (if isfun 2 3))
- (goto-char (point-max))
- (kill-line -2)
- (goto-char (point-min)))))
-
-
-
-(defun org-favtable--update-line (ref-or-link)
-
- (let (initial
- found
- count-field
- (ref-node-buffer-and-point (org-favtable--id-find)))
-
- (with-current-buffer (car ref-node-buffer-and-point)
-
- ;; search reference or link, if given (or assume, that we are already positioned right)
- (when ref-or-link
- (setq initial (point))
- (goto-char (cdr ref-node-buffer-and-point))
- (org-favtable--goto-top)
- (while (and (org-at-table-p)
- (not (or (string= ref-or-link (org-favtable--get-field 'ref))
- (string= ref-or-link (org-favtable--get-field 'link)))))
- (forward-line)))
-
- (if (not (org-at-table-p))
- (error "Did not find reference or link '%s'" ref-or-link)
- (setq count-field (org-favtable--get-field 'count))
-
- ;; update count field only if number or empty; leave :missing: and :reuse: as is
- (if (or (not count-field)
- (string-match "^[0-9]+$" count-field))
- (org-favtable--get-field 'count
- (number-to-string
- (+ 1 (string-to-number (or count-field "0"))))))
-
- ;; update timestamp
- (org-table-goto-column (org-favtable--column-num 'last-accessed))
- (org-table-blank-field)
- (org-insert-time-stamp nil t t)
-
- (setq found t))
-
- (if initial (goto-char initial))
-
- found)))
-
-
-
-(defun org-favtable--occur-helper (action)
- (let ((line-beg (line-beginning-position))
- key search link ref)
-
- ;; extract reference or link from text property (as put there before)
- (setq ref (get-text-property line-beg 'org-favtable--ref))
- (if (string= ref "") (setq ref nil))
- (setq link (get-text-property line-beg 'org-favtable--link))
- (if (string= link "") (setq link nil))
-
- (org-favtable action
- (or link ref) ;; prefer link
- (if link t nil))))
-
-
-(defun org-favtable--get-field (key &optional value)
- (let (field)
- (setq field (org-trim (org-table-get-field (cdr (assoc key org-favtable--columns)) value)))
- (if (string= field "") (setq field nil))
-
- field))
-
-
-(defun org-favtable--column-num (key)
- (cdr (assoc key org-favtable--columns)))
-
-
-(defun org-favtable-version ()
- "Show version of org-favtable" (interactive)
- (message "org-favtable %s" org-favtable--version))
-
-
-(defun org-favtable--make-guarded-search (ref &optional dont-quote)
- (concat "\\b" (if dont-quote ref (regexp-quote ref)) "\\b"))
-
-
-(defun org-favtable-get-ref-regex-format ()
- "return cons-cell with regular expression and format for references"
- (unless org-favtable--ref-regex
- (org-favtable 'parse))
- (cons (org-favtable--make-guarded-search org-favtable--ref-regex 'dont-quote) org-favtable--ref-format))
-
-
-(defadvice org-mark-ring-goto (after org-favtable--advice-text-to-yank activate)
- "Make text from the favtable available for yank."
- (when org-favtable--text-to-yank
- (kill-new org-favtable--text-to-yank)
- (message (format "Ready to yank '%s'" org-favtable--text-to-yank))
- (setq org-favtable--text-to-yank nil)))
-
-
-(provide 'org-favtable)
-
-;; Local Variables:
-;; fill-column: 75
-;; comment-column: 50
-;; End:
-
-;;; org-favtable.el ends here
diff --git a/contrib/lisp/org-git-link.el b/contrib/lisp/org-git-link.el
index 7d95bbb..ad0ce71 100644
--- a/contrib/lisp/org-git-link.el
+++ b/contrib/lisp/org-git-link.el
@@ -98,10 +98,12 @@
(let* ((strlist (org-git-split-string str))
(filepath (first strlist))
(commit (second strlist))
+ (line (third strlist))
(dirlist (org-git-find-gitdir (file-truename filepath)))
(gitdir (first dirlist))
(relpath (second dirlist)))
- (org-git-open-file-internal gitdir (concat commit ":" relpath))))
+ (org-git-open-file-internal gitdir (concat commit ":" relpath))
+ (when line (goto-line (string-to-int line)))))
;; Utility functions (file names etc)
@@ -141,16 +143,19 @@
;; splitting the link string
;; Both link open functions are called with a string of
-;; consisting of two parts separated by a double colon (::).
+;; consisting of three parts separated by a double colon (::).
(defun org-git-split-string (str)
- "Given a string of the form \"str1::str2\", return a list of
- two substrings \'(\"str1\" \"str2\"). If the double colon is mising, take str2 to be the empty string."
+ "Given a string of the form \"str1::str2::str3\", return a list of
+ three substrings \'(\"str1\" \"str2\" \"str3\"). If there are less
+than two double colons, str2 and/or str3 may be set the empty string."
(let ((strlist (split-string str "::")))
(cond ((= 1 (length strlist))
- (list (car strlist) ""))
+ (list (car strlist) "" ""))
((= 2 (length strlist))
+ (append strlist (list "")))
+ ((= 3 (length strlist))
strlist)
- (t (error "org-git-split-string: only one :: allowed: %s" str)))))
+ (t (error "org-git-split-string: only one or two :: allowed: %s" str)))))
;; finding the file name part of a commit
(defun org-git-link-filename (str)
@@ -168,22 +173,24 @@
(concat branch "@{" timestring "}"))
-(defun org-git-create-git-link (file)
+(defun org-git-create-git-link (file &optional line)
"Create git link part to file at specific time"
(interactive "FFile: ")
(let* ((gitdir (first (org-git-find-gitdir (file-truename file))))
(branchname (org-git-get-current-branch gitdir))
(timestring (format-time-string "%Y-%m-%d" (current-time))))
- (concat "git:" file "::" (org-git-create-searchstring branchname timestring))))
+ (concat "git:" file "::" (org-git-create-searchstring branchname timestring)
+ (if line (format "::%s" line) ""))))
(defun org-git-store-link ()
"Store git link to current file."
(when (buffer-file-name)
- (let ((file (abbreviate-file-name (buffer-file-name))))
+ (let ((file (abbreviate-file-name (buffer-file-name)))
+ (line (line-number-at-pos)))
(when (org-git-gitrepos-p file)
(org-store-link-props
:type "git"
- :link (org-git-create-git-link file))))))
+ :link (org-git-create-git-link file line))))))
(add-hook 'org-store-link-functions 'org-git-store-link)
diff --git a/contrib/lisp/org-index.el b/contrib/lisp/org-index.el
new file mode 100644
index 0000000..26edc85
--- /dev/null
+++ b/contrib/lisp/org-index.el
@@ -0,0 +1,2497 @@
+;;; org-index.el --- A personal index for org and beyond
+
+;; Copyright (C) 2011-2015 Free Software Foundation, Inc.
+
+;; Author: Marc Ihm <org-index@2484.de>
+;; Version: 4.2.1
+;; Keywords: outlines index
+
+;; This file is not part of GNU Emacs.
+
+;;; License:
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 3, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Purpose:
+;;
+;; Fast search for selected org headings 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.
+;;
+;; 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.
+;;
+;; On first invocation org-index will guide you to create a dedicated node
+;; for its index table and its configuration flags.
+;;
+;; For basic usage, subcommands 'add' and 'occur' are most important.
+;;
+;;
+;; Setup:
+;;
+;; - Add these lines to your .emacs:
+;;
+;; (require 'org-index)
+;; (org-index-default-keybindings) ; 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).
+;;
+;;
+;; Further reading:
+;;
+;; See the documentation of `org-index', which can also be read
+;; by invoking `org-index' and choosing the help-command.
+;;
+;;
+;; Updates:
+;;
+;; The latest tested version of this file can always be found at:
+;;
+;; http://orgmode.org/w/org-mode.git?p=org-mode.git;a=blob_plain;f=contrib/lisp/org-index.el;hb=HEAD
+
+;;; Change Log:
+
+;; [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:
+;; - 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:
+;; - 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"
+;; - New function `org-index-default-keybindings'
+;;
+;; [2012-12-07 Fr] to [2014-04-26 Sa] Version 2.0.0 to 2.4.3:
+;; - New functions org-index-new-line and org-index-get-line
+;; offer access to org-index from other lisp programs
+;; - Regression tests with ert
+;; - Renamed from "org-favtable" to "org-index"
+;; - Added an assistant to set up the index table
+;; - occur is now incremental, searching as you type
+;; - Integrated with org-mark-ring-goto
+;; - Added full support for ids
+;; - Renamed the package from "org-reftable" to "org-favtable"
+;; - Additional columns are required (e.g. "link"). Error messages will
+;; guide you
+;; - Ask user explicitly, which command to invoke
+;; - Renamed the package from "org-refer-by-number" to "org-reftable"
+;;
+;; [2011-12-10 Sa] to [2012-09-22 Sa] Version Version 1.2.0 to 1.5.0:
+;; - New command "sort" to sort a buffer or region by reference number
+;; - New commands "highlight" and "unhighlight" to mark references
+;; - New command "head" to find a headline with a reference number
+;; - New commands occur and multi-occur
+;; - Started this Change Log
+
+;;; Code:
+
+(require 'org-table)
+(require 'cl)
+
+(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.")
+
+;; 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--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--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--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--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--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.")
+
+;; 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--occur-buffer-name "*org-index-occur*" "Name of occur 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.")
+
+
+(defmacro org-index--on (column value &rest body)
+ "Execute the forms in BODY with point on index line whose COLUMN is VALUE.
+The value returned is the value of the last form in BODY or nil,
+if VALUE cannot be found."
+ (declare (indent 2) (debug t))
+ (let ((pointvar (make-symbol "point")) ; avoid clash with same-named variables in body
+ (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)
+
+ (setq ,foundvar (org-index--go ,column ,value))
+ (when ,foundvar
+ (setq ,retvar (progn ,@body)))
+
+ (goto-char ,pointvar)
+
+ ,retvar)))
+
+
+(defun org-index (&optional command search-ref arg)
+ "Fast search for selected org headings 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.
+
+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.
+
+On first invocation `org-index' will guide you to create a dedicated node
+for its index table and its configuration flags.
+
+For basic usage, subcommands 'add' and 'occur' are most important.
+
+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'.
+
+
+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.
+
+ 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.
+
+ delete: Delete the current node from your index.
+
+ head: Ask for a reference number and search for this heading.
+
+ enter: Enter index table and maybe go to a specific reference;
+ use `org-mark-ring-goto' (\\[org-mark-ring-goto]) to go back.
+
+ ping: Echo line from index table for current node or first of
+ its ancestor from index.
+
+ ref: Create a new reference.
+
+ help: Show this text.
+
+ example: Create a temporary index, that will not be saved, but
+ may serve as an example.
+
+ sort: Sort lines in index, in region or buffer by contained
+ reference, or sort index by count, reference or last access.
+
+ multi-occur: Apply Emacs standard `multi-occur' operation on all
+ `org-mode' buffers to search for the given reference.
+
+ highlight: Highlight or unhiglight references in active region or buffer.
+ Call with prefix argument (`C-u') to remove highlights.
+
+ maintain: 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.
+
+Use `org-index-default-keybindings' to establish convenient
+keyboard shortcuts.
+
+See the commented list of flags within your index node for ways to
+modify the behaviour of org-index.
+
+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."
+
+ (interactive "i\ni\nP")
+
+ (let (search-id ; id 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
+
+
+ ;;
+ ;; Initialize and parse
+ ;;
+
+ ;; creates index table, if necessary
+ (org-index--verify-id)
+
+ ;; 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)))
+
+ (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))
+
+
+ ;;
+ ;; Actually do, what is requested
+ ;;
+
+ (cond
+
+
+ ((eq command 'help)
+
+ ;; bring up help-buffer for this function
+ (describe-function 'org-index))
+
+
+ ((eq command 'multi-occur)
+
+ ;; 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))))
+
+ ;; 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 'add)
+
+ (let ((r (org-index--do-add-or-update)))
+ (setq message-text (car r))
+ (setq kill-new-text (cdr r))))
+
+
+ ((eq command 'delete)
+
+ (setq message-text (org-index--do-delete)))
+
+
+ ((eq command 'head)
+
+ (if (and org-index--within-node
+ (org-at-table-p))
+ (setq search-id (org-index--get-or-set-field 'id)))
+
+ (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 'enter)
+
+ (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'" search-ref))
+ (format "Did not find index line with reference '%s'" search-ref))
+
+ (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))
+
+ ;; simply go into table
+ (setq message-text "At index table"))))
+
+ (recenter))
+
+
+ ((eq command 'ping)
+
+ (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)))
+
+ ;; 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 reached-top (= (org-outline-level) 1))
+
+ (unless (or info
+ reached-top)
+ (outline-up-heading 1 t)
+ (incf moved-up))
+
+ (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)))))))
+
+
+ ((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)))
+
+
+ (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-default-keybindings (&optional prefix)
+ "Set default keybindings for `org-index'.
+
+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.
+
+The ist of letters and subcommands is specified in within
+`org-index-default-keybindings-list'.
+
+See `org-index' for a description of all subcommands.
+
+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))
+
+
+(defun org-index-new-line (&rest keys-values)
+ "Create a new line within the index table, returning its reference.
+
+The function takes a varying number of argument pairs; each pair
+is a symbol for an existing column heading followed by its value.
+The return value is the new reference.
+
+Example:
+
+ (message \"Created reference %s\"
+ (org-index-new-line 'keywords \"foo bar\" 'category \"baz\"))
+
+Optional argument KEYS-VALUES specifies content of new line."
+
+ (org-index--verify-id)
+ (org-index--parse-table)
+
+ (car (apply 'org-index--do-new-line keys-values)))
+
+
+(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)
+
+ ;; check arguments early; they might come from lisp-user
+ (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)))
+ (setq kvs (cddr kvs))))
+
+ (let (ref yank)
+ ;; create new line
+ (setq ref (org-index--create-new-line))
+ (plist-put keys-values 'ref ref)
+
+ ;; 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))))
+
+ ;; 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)))
+
+ (cons ref yank)))))
+
+
+(defun org-index-get-line (column value)
+ "Retrieve an existing line within the index table by ref or id.
+Return its contents as a property list.
+
+The function `plist-get' may be used to retrieve specific elements
+from the result.
+
+Example:
+
+ (plist-get (org-index-get-line 'ref \"R12\") 'count)
+
+retrieves the value of the count-column for reference number 12.
+
+Argument COLUMN is a symbol, either ref or id,
+argument VALUE specifies the value to search for."
+ ;; check arguments
+ (unless (memq column '(ref id))
+ (error "Argument column can only be 'ref' or 'id'"))
+
+ (unless value
+ (error "Need a value to search for"))
+
+ (org-index--verify-id)
+ (org-index--parse-table)
+
+ (org-index--get-line column value))
+
+
+(defun org-index--get-line (column value)
+ "Find a line by ID, return its contents.
+Argument COLUMN and VALUE specify line to get."
+ (let (content)
+ (org-index--on
+ column value
+ (mapc (lambda (x)
+ (if (and (numberp (cdr x))
+ (> (cdr x) 0))
+ (setq content (cons (car x) (cons (or (org-index--get-or-set-field (car x)) "") content)))))
+ (reverse org-index--columns)))
+ 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)))
+
+
+(defun org-index--id-from-ref (ref)
+ "Get id from line REF."
+ (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--verify-id ()
+ "Check, that we have a valid id."
+
+ ;; 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)
+ (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))))
+
+ ;; Find node
+ (let (marker)
+ (setq marker (org-id-find org-index-id 'marker))
+ (unless marker (org-index--create-missing-index "Cannot find the node with id \"%s\" (as specified by variable org-index-id)." org-index-id))
+ ; Try again with new node
+ (setq marker (org-id-find org-index-id 'marker))
+ (unless marker (error "Could not create node"))
+ (setq org-index--buffer (marker-buffer marker)
+ org-index--point (marker-position marker))
+ (move-marker marker nil)))
+
+
+(defun org-index--retrieve-context ()
+ "Collect context information before starting with command."
+
+ ;; Get the content of the active region or the word under cursor
+ (setq org-index--active-region
+ (if (and transient-mark-mode mark-active)
+ (buffer-substring (region-beginning) (region-end))
+ nil))
+ (setq org-index--below-cursor (thing-at-point 'symbol))
+
+ ;; get category of current node
+ (setq org-index--category-before
+ (save-excursion ; workaround: org-get-category does not give category when at end of buffer
+ (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)))
+
+
+(defun org-index--parse-table ()
+ "Parse content of index table."
+
+ (let (ref-field
+ id-field
+ initial-point
+ end-of-headings
+ start-of-headings)
+
+ (with-current-buffer org-index--buffer
+
+ (setq org-index--maxref 0)
+ (setq initial-point (point))
+
+ (org-index--go-below-hline)
+
+ ;; align and fontify table once for this emacs session
+ (unless org-index--aligned
+ (org-table-align) ; needs to happen before fontification to be effective ?
+ (let ((is-modified (buffer-modified-p))
+ (below (point)))
+ (while (org-at-table-p)
+ (forward-line))
+ (font-lock-fontify-region below (point))
+ (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
+ (setq end-of-headings (point))
+ (while (org-at-table-p) (forward-line -1))
+ (forward-line)
+ (setq start-of-headings (point))
+ (setq org-index--headings-visible (substring-no-properties (org-index--copy-visible start-of-headings end-of-headings)))
+ (setq org-index--headings (buffer-substring start-of-headings end-of-headings))
+
+ ;; count columns
+ (org-table-goto-column 100)
+ (setq org-index--numcols (- (org-table-current-column) 1))
+
+ ;; go to top of table
+ (while (org-at-table-p)
+ (forward-line -1))
+ (forward-line)
+
+ ;; parse line of headings
+ (org-index--parse-headings)
+
+ ;; 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)
+ (while (and (org-at-table-p)
+ (not (setq ref-field (org-index--get-or-set-field 'ref))))
+ (forward-line))
+
+ ;; Some Checking
+ (unless ref-field
+ (org-index--report-index-error "Reference column is empty"))
+
+ (unless (string-match "^\\([^0-9]*\\)\\([0-9]+\\)\\([^0-9]*\\)$" ref-field)
+ (org-index--report-index-error
+ "First reference in index table ('%s') does not contain a number" ref-field))
+
+ ;; These are the decorations used within the first ref of index
+ (setq org-index--head (match-string 1 ref-field))
+ (setq org-index--tail (match-string 3 ref-field))
+ (setq org-index--ref-regex (concat (regexp-quote org-index--head)
+ "\\([0-9]+\\)"
+ (regexp-quote org-index--tail)))
+ (setq org-index--ref-format (concat org-index--head "%d" org-index--tail))
+
+ ;; Go through table to find maximum number and do some checking
+ (let ((ref 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)))
+ (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))
+
+ (forward-line 1)))
+
+ ;; go back to initial position
+ (goto-char initial-point))))
+
+
+(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")))
+ (message nil)
+
+ (cond
+ ((eq check-what 'check)
+ (setq message-text (or (org-index--check-ids)
+ "No problems found")))
+
+ ((eq check-what 'statistics)
+ (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."))
+
+ ((eq check-what 'clean)
+ (let ((lines 0))
+ (org-map-entries
+ (lambda ()
+ (when (org-entry-get (point) "org-index-ref")
+ (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 ? ")
+ (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."
+
+ (let ((is-modified (buffer-modified-p))
+ top
+ bottom
+ ref-field
+ count-field)
+
+ (unless buffer-read-only
+
+ (message "Sorting 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
+
+ ;; get boundaries of table
+ (goto-char org-index--below-hline)
+ (forward-line 0)
+ (setq top (point))
+ (while (org-at-table-p) (forward-line))
+
+ ;; kill all empty rows at bottom
+ (while (progn
+ (forward-line -1)
+ (org-table-goto-column 1)
+ (and
+ (not (org-index--get-or-set-field 'ref))
+ (not (org-index--get-or-set-field 'id))))
+ (org-table-kill-row))
+ (forward-line 1)
+ (setq bottom (point))
+
+ ;; sort lines
+ (save-restriction
+ (narrow-to-region top bottom)
+ (goto-char top)
+ (sort-subr t
+ '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)))
+ nil
+ 'string<)
+ (goto-char (point-min))
+
+ ;; restore modification state
+ (set-buffer-modified-p is-modified)))
+
+ (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
+ (cond
+ ((eq what 'region)
+ (if (region-active-p)
+ (narrow-to-region (region-beginning) (region-end))
+ (error "No active region, cannot sort")))
+ ((eq what 'buffer)
+ (unless (y-or-n-p "Sort whole current buffer ? ")
+ (error "Canceled"))
+ (narrow-to-region (point-min) (point-max))))
+
+ (goto-char (point-min))
+ (sort-subr nil 'forward-line 'end-of-line
+ (lambda ()
+ (if (looking-at (concat ".*"
+ (org-index--make-guarded-search org-index--ref-regex 'dont-quote)))
+ (string-to-number (match-string 1))
+ 0)))))
+
+
+(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)))
+
+ (goto-char org-index--point)
+
+ ;; go to heading of node
+ (while (not (org-at-heading-p)) (forward-line -1))
+ (forward-line 1)
+
+ ;; go to first table, but make sure we do not get into another node
+ (while (and (not (org-at-table-p))
+ (not (org-at-heading-p))
+ (not (eobp)))
+ (forward-line))
+
+ ;; check, if there really is a table
+ (unless (org-at-table-p)
+ (org-index--create-missing-index "Cannot find %s." errstring))
+
+ ;; go just after hline
+ (while (and (not (org-at-table-hline-p))
+ (org-at-table-p))
+ (forward-line))
+ (forward-line)
+
+ ;; and check
+ (unless (org-at-table-p)
+ (org-index--report-index-error "Cannot find a hline within %s" errstring))
+
+ (org-table-goto-column 1)))
+
+
+(defun org-index--parse-headings ()
+ "Parse headings of index table."
+
+ (let (field ;; field content
+ field-symbol ;; and as a symbol
+ found)
+
+ (setq org-index--columns nil)
+
+ ;; For each column
+ (dotimes (col org-index--numcols)
+
+ (setq field (substring-no-properties (downcase (org-trim (org-table-get-field (+ col 1))))))
+
+ (if (string= field "")
+ (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)))
+
+ (setq field-symbol (intern field))
+
+ ;; check if heading has already appeared
+ (if (assoc field-symbol org-index--columns)
+ (org-index--report-index-error
+ "'%s' appears two times as column heading" (downcase field))
+ ;; add it to list at front, reverse later
+ (setq org-index--columns (cons (cons field-symbol (+ col 1)) org-index--columns)))))
+
+ (setq org-index--columns (reverse org-index--columns))
+
+ ;; check if all necessary headings have appeared
+ (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))
+
+
+(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: "
+ "new permanent" "."
+ reasons)
+ (org-index--create-index))
+
+
+(defun org-index--report-index-error (&rest reasons)
+ "Report an error (explained by REASONS) with the existing index and offer to create a valid one to compare with."
+
+ (when org-index--buffer
+ (pop-to-buffer-same-window org-index--buffer)
+ (goto-char org-index--below-hline)
+ (org-reveal t))
+ (org-index--ask-before-create-index "The existing index contains this error: "
+ "temporary" ", to compare with."
+ reasons)
+ (org-index--create-index t t))
+
+
+(defun org-index--ask-before-create-index (explanation type for-what reasons)
+ ; checkdoc-params: (explanation type for-what reasons)
+ "Ask the user before creating an index or throw error. Arguments specify bits of issued message."
+ (let (reason prompt)
+
+ (setq reason (apply 'format reasons))
+
+ (setq prompt (concat explanation reason "\n\n"
+ "However, this assistant can help you to create a "
+ type " index with detailed comments" for-what "\n\n"
+ "Do you want to proceed ?"))
+
+ (unless (let ((max-mini-window-height 1.0))
+ (y-or-n-p prompt))
+ (error (concat explanation reason)))))
+
+
+(defun org-index--create-index (&optional temporary compare)
+ "Create a new empty index table with detailed explanation.
+specify flag TEMPORARY for th new table temporary, maybe COMPARE it with existing index."
+ (let (buffer
+ title
+ firstref
+ id)
+
+ (if temporary
+ (let ((file-name (concat temporary-file-directory "org-index--example-index.org"))
+ (buffer-name "*org-index-example-index*"))
+ (setq buffer (get-buffer-create buffer-name))
+ (with-current-buffer buffer
+ ;; but it needs a file for its index to be found
+ (unless (string= (buffer-file-name) file-name)
+ (set-visited-file-name file-name))
+ (rename-buffer buffer-name) ; name is change by line above
+
+ (erase-buffer)
+ (org-mode)))
+
+ (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: "))
+
+ (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: "))
+ (let (desc)
+ (when (string-match "[[:blank:]]" firstref)
+ (setq desc "Contains whitespace"))
+ (when (string-match "[[:cntrl:]]" firstref)
+ (setq desc "Contains control characters"))
+ (unless (string-match "^[^0-9]+[0-9]+[^0-9]*$" firstref)
+ ;; firstref not okay, report details
+ (setq desc
+ (cond ((string= firstref "") "is empty")
+ ((not (string-match "^[^0-9]+" firstref)) "starts with a digit")
+ ((not (string-match "^[^0-9]+[0-9]+" firstref)) "does not contain a number")
+ ((not (string-match "^[^0-9]+[0-9]+[^0-9]*$" firstref)) "contains more than one sequence of digits")
+
+ )))
+ (if desc
+ (progn
+ (read-from-minibuffer (format "Your input '%s' does not meet the requirements because it %s.\nPlease hit RET and try again: " firstref desc))
+ t)
+ nil))))
+
+ (with-current-buffer buffer
+ (goto-char (point-max))
+ (insert (format "* %s %s\n" firstref title))
+ (if temporary
+ (insert "
+ Below you find your temporary index table, which WILL NOT LAST LONGER
+ THAN YOUR CURRENT EMACS SESSION.
+")
+ (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.
+
+ To gain further insight you may invoke the subcommand 'help', or
+ read the description 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').
+
+ 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.
+
+ This node needs not be a top level node; its name is completely
+ at your choice; it is found through its ID only.
+")
+ (unless temporary
+ (insert "
+ Remark: These lines of explanation can be removed at any time.
+"))
+
+ (setq id (org-id-get-create))
+ (insert (format "
+%s
+
+
+ | ref | category | keywords | count | last-accessed | created | id |
+ | | | | | | | <4> |
+ |-----+-----------+----------+-------+---------------+---------+------|
+ | %s | | %s | | | %s | %s |
+
+"
+ org-index--sample-flags
+ firstref
+ "This node"
+ (with-temp-buffer (org-insert-time-stamp nil nil t))
+ id))
+
+ ;; make sure, that node can be found
+ (org-id-add-location id (buffer-file-name))
+ (setq buffer-save-without-query t)
+ (basic-save-buffer)
+
+ (while (not (org-at-table-p)) (forward-line -1))
+ (unless buffer-read-only (org-table-align))
+ (while (not (org-at-heading-p)) (forward-line -1))
+
+ ;; read back some info about new index
+ (let ((org-index-id id))
+ (org-index--verify-id))
+
+ ;; remember at least for this session
+ (setq org-index-id id)
+
+ ;; present results to user
+ (if temporary
+ (progn
+ ;; Present existing and temporary index together
+ (when compare
+ (pop-to-buffer-same-window org-index--buffer)
+ (goto-char org-index--point)
+ (org-index--unfold-buffer)
+ (delete-other-windows)
+ (select-window (split-window-vertically)))
+ ;; show new index
+ (pop-to-buffer-same-window buffer)
+ (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
+ ;; Only show the new index
+ (pop-to-buffer-same-window buffer)
+ (delete-other-windows)
+ (org-id-goto id)
+ (org-index--unfold-buffer)
+ (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)))
+ (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))))))))
+
+
+(defun org-index--unfold-buffer ()
+ "Helper function to unfold buffer."
+ (org-show-context)
+ (org-show-subtree)
+ (recenter 1)
+ (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."
+
+ (let ((newcount 0)
+ 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
+ (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)))))
+ (forward-line)))
+
+ (if (not (org-at-table-p))
+ (error "Did not find reference or id '%s'" ref-or-id)
+ (org-index--update-current-line))
+
+ (if initial (goto-char initial))))))
+
+
+(defun org-index--update-current-line ()
+ "Update current lines columns count and last-accessed."
+ (let (newcount (count-field (org-index--get-or-set-field 'count)))
+
+ ;; update count field only if number or empty
+ (when (or (not count-field)
+ (string-match "^[0-9]+$" count-field))
+ (setq newcount (+ 1 (string-to-number (or count-field "0"))))
+ (org-index--get-or-set-field 'count
+ (number-to-string newcount)))
+
+ ;; update timestamp
+ (org-table-goto-column (org-index--column-num 'last-accessed))
+ (org-table-blank-field)
+ (org-insert-time-stamp nil t t)
+
+ ;; move line according to new content
+ (org-index--promote-current-line)
+ (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
+ (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
+ (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))
+ (goto-char (point-max))
+ (insert line)
+ (forward-line 0)
+ (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))))))
+
+
+(defun org-index--promote-current-line ()
+ "Move current line up in table according to changed sort fields."
+ (let (begin end key
+ (to-skip 0))
+
+ (forward-line 0) ; stay at beginning of line
+
+ (setq key (org-index--get-sort-key))
+ (setq begin (point))
+ (setq end (line-beginning-position 2))
+
+ (forward-line -1)
+ (while (and (org-at-table-p)
+ (not (org-at-table-hline-p))
+ (string< (org-index--get-sort-key) key))
+
+ (incf to-skip)
+ (forward-line -1))
+ (forward-line 1)
+
+ ;; insert line at new position
+ (when (> to-skip 0)
+ (insert (delete-and-extract-region begin end))
+ (forward-line -1))))
+
+
+(defun org-index--get-sort-key (&optional sort with-ref)
+ "Get value for sorting from column SORT, optional WITH-REF."
+ (let (ref
+ ref-field
+ key)
+
+ (unless sort (setq sort org-index--last-sort)) ; use default value
+
+ (when (or with-ref
+ (eq sort 'ref))
+ ;; 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")))))
+
+ (setq key
+ (cond
+ ((eq sort 'count)
+ (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)
+ (org-index--get-or-set-field sort))
+ (t (error "This is a bug: unmatched case '%s'" sort))))
+
+ (if with-ref (setq key (concat key ref)))
+
+ key))
+
+
+(defun org-index--get-or-set-field (key &optional value)
+ "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 (string= field "") (setq field nil))
+
+ (org-no-properties field))))
+
+
+(defun org-index--column-num (key)
+ "Return number of column KEY."
+ (if (numberp key)
+ key
+ (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--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)))
+
+
+(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--do-statistics ()
+ "Compute statistics about index table."
+ (let ((total 0)
+ ref-field ref min max message)
+
+
+ ;; go through table and remove all refs, that we see
+ (goto-char org-index--below-hline)
+ (while (org-at-table-p)
+
+ ;; get ref-field and number
+ (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))
+
+ ;; count
+ (setq total (1+ total))
+
+ (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)))))
+
+))
+
+ (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."
+
+ (let* (id ref args yank ref-and-yank)
+
+ ;; do the same things from within index and from outside
+ (if org-index--within-node
+
+ (progn
+ (unless (org-at-table-p)
+ (error "Within index node but not on table"))
+
+ (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))
+
+ (unless (org-at-heading-p)
+ (error "Not at headline"))
+
+ (setq id (org-id-get-create))
+ (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)
+
+ (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))
+
+ ;; no ref here, create new line in index
+ (setq ref-and-yank (apply 'org-index--do-new-line args))
+
+ (cons (format "Added index line %s" (car ref-and-yank)) (concat (cdr ref-and-yank) " "))))))
+
+
+(defun org-index--check-ids ()
+ "Check, that ids really point to a node."
+
+ (let ((lines 0)
+ id ids marker)
+
+ (goto-char org-index--below-hline)
+
+ (catch 'problem
+ (while (org-at-table-p)
+
+ (when (setq id (org-index--get-or-set-field 'id))
+
+ ;; check for double ids
+ (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)
+ (setq ids (cons id ids))
+
+ ;; check, if id is valid
+ (setq marker (org-id-find id t))
+ (unless marker
+ (org-table-goto-column (org-index--column-num 'id))
+ (throw 'problem "This id cannot be found")))
+
+ (forward-line))
+
+ (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)
+
+ (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))
+ (forward-line))
+
+ (goto-char org-index--below-hline)
+ (org-table-align)
+ (format "Updated %d lines" lines)))))
+
+
+(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))
+ content)
+
+ (dolist (col-num 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))))
+ 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))
+ ;; enter buffer and collect information
+ (with-current-buffer (marker-buffer marker)
+ (setq point (point))
+ (goto-char marker)
+ (setq args (org-index--collect-values-for-add-update id t (org-get-category (point) t)))
+ (goto-char point))
+
+ args))
+
+
+(defun org-index--write-fields-for-add-update (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))))
+ (setq kvs (cddr kvs))))
+
+
+(defun org-index--do-delete ()
+ "Perform command delete."
+
+ (unless (org-at-heading-p)
+ (error "Not at headline"))
+
+ (let* ((id (org-entry-get (point) "ID"))
+ (ref (org-index--ref-from-id id)))
+
+ ;; 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)))))
+
+ ;; 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))))
+
+
+(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)
+
+ (unless (eq (current-buffer) org-index--buffer)
+ (error "This is a bug: Not in index buffer"))
+
+ ;; loop over lines
+ (goto-char org-index--below-hline)
+ (if column
+ (progn
+ (forward-line -1)
+ (while (and (not found)
+ (forward-line)
+ (org-at-table-p))
+ (setq found (string= value (org-index--get-or-set-field column)))))
+ (setq found t))
+
+ ;; return value
+ (if found
+ t
+ (goto-char org-index--below-hline)
+ nil)))
+
+
+(defun org-index--do-head (ref 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)
+
+ (setq marker (org-id-find id t))
+
+ (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)))))
+
+
+(defun org-index--do-occur ()
+ "Perform command occur."
+ (let ((word "") ; last word to search for growing and shrinking on keystrokes
+ (prompt "Search for: ")
+ (lines-wanted (window-body-height))
+ (lines-found 0) ; number of lines found
+ words ; list words that should match
+ occur-buffer
+ 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
+
+
+ ;; 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)
+ ;; avoid modifying direct buffer
+ (setq buffer-read-only t)
+ (toggle-truncate-lines 1)
+ (setq font-lock-keywords-case-fold-search t)
+ (setq case-fold-search t)
+
+ ;; 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))
+ (forward-line 0)
+ (setq begin (point))
+ (forward-line -1)
+ (setq narrow (point))
+ (while (org-at-table-p)
+ (forward-line))
+ (narrow-to-region narrow (point))
+ (goto-char (point-min))
+ (forward-line)
+
+ ;; 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"))
+ 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)
+
+ (while (not done)
+
+ (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)))
+
+ (cond
+
+
+ ((string= key "<C-backspace>")
+ (setq in-c-backspace t))
+
+
+ ((member key (list "<backspace>" "DEL")) ; erase last char
+
+ (if (= (length word) 0)
+
+ ;; nothing more to delete from current word; try next
+ (progn
+ (setq word (car words))
+ (setq words (cdr words))
+ (setq in-c-backspace nil))
+
+ ;; unhighlight longer match
+ (unhighlight-regexp (regexp-quote word))
+
+ ;; some chars are left; shorten word
+ (setq word (substring word 0 -1))
+ (when (= (length word) 0) ; when nothing left, use next word from list
+ (setq word (car words))
+ (setq words (cdr words))
+ (setq in-c-backspace nil))
+
+ ;; 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)))
+ (point-max))
+ (point-max))
+
+
+ ;; highlight shorter word
+ (unless (= (length word) 0)
+ (highlight-regexp (regexp-quote word) 'isearch))
+
+ ;; make sure, point is still visible
+ (goto-char begin)))
+
+
+ ((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 ""))
+
+
+ ((string= key "?") ; question mark: toggle display of headlines and help
+ (setq help-text (cons (cdr help-text) (car help-text)))
+ (overlay-put help-overlay 'display (car help-text)))
+
+ ((and (= (length key) 1)
+ (aref printable-chars (elt key 0))) ; any printable char: add to current search word
+
+ ;; unhighlight short word
+ (unless (= (length word) 0)
+ (unhighlight-regexp (regexp-quote word)))
+
+ ;; 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)))
+ (point-max))
+ (point-max))
+
+ (goto-char begin)
+
+ ;; highlight longer word
+ (highlight-regexp (regexp-quote word) 'isearch)
+
+ ;; make sure, point is on a visible line
+ (line-move -1 t)
+ (line-move 1 t))
+
+ ;; anything else terminates loop
+ (t (setq done t))))
+
+ ;; put back input event, that caused the loop to end
+ (unless (string= key "C-g")
+ (setq unread-command-events (listify-key-sequence key-sequence))
+ (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)
+
+ (setq cursor-type t)
+ (goto-char begin)
+
+ ;; collect all visible lines
+ (while (and (not (eobp))
+ (< lines-collected lines-wanted))
+ ;; skip over invisible lines
+ (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)))
+ (unless (string= line "")
+ (incf lines-collected)
+ (setq all-lines (cons (concat line
+ "\n")
+ all-lines)))
+ (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))
+
+ ;; insert into new buffer
+ (save-excursion
+ (apply 'insert (reverse all-lines))
+ (if (= lines-collected lines-wanted)
+ (insert "\n(more lines omitted)\n")))
+
+ (org-mode)
+ (setq truncate-lines t)
+ (if (org-at-table-p) (org-table-align))
+ (font-lock-fontify-buffer)
+
+ ;; prepare help text
+ (setq org-index--occur-help-overlay (make-overlay (point-min) end-of-head))
+ (setq org-index--occur-help-text
+ (cons
+ (org-index--wrap
+ (concat "Search is done; `?' toggles help and headlines.\n"))
+ (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--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)
+ (setq font-lock-keywords-case-fold-search t)
+ (mapc (lambda (w) (unless (or (not w) (string= w "")) (highlight-regexp (regexp-quote w) 'isearch)))
+ (cons word words))
+
+ (setq buffer-read-only t)
+
+ ;; install keyboard-shortcuts
+ (setq keymap (make-sparse-keymap))
+ (set-keymap-parent keymap org-mode-map)
+
+ (mapc (lambda (x) (define-key keymap (kbd x)
+ (lambda () (interactive)
+ (message "%s" (org-index--occur-to-head)))))
+ (list "<return>" "RET"))
+
+ (define-key keymap (kbd "<tab>")
+ (lambda () (interactive)
+ (message (org-index--occur-to-head t))))
+
+ (define-key keymap (kbd "SPC")
+ (lambda () (interactive)
+ ;; increment in index
+ (let ((ref (org-index--get-or-set-field 'ref))
+ count)
+ (org-index--on
+ 'ref ref
+ (setq count (+ 1 (string-to-number (org-index--get-or-set-field 'count))))
+ (org-index--get-or-set-field 'count (number-to-string count))
+ (org-index--promote-current-line)
+ (org-index--align-and-fontify-current-line))
+ ;; increment in this buffer
+ (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))))
+
+ (define-key keymap (kbd "?")
+ (lambda () (interactive)
+ (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--wrap (text)
+ "Wrap TEXT at fill column."
+ (with-temp-buffer
+ (insert text)
+ (fill-region (point-min) (point-max) nil t)
+ (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--hide-with-overlays (words lines-wanted)
+ "Hide text that is currently visible and does not match WORDS by creating overlays; leave LINES-WANTED lines visible."
+ (let ((lines-found 0)
+ (end-of-visible (point))
+ overlay overlays start matched)
+
+ ;; main loop
+ (while (and (not (eobp))
+ (< lines-found lines-wanted))
+
+ ;; skip invisible lines
+ (while (and (not (eobp))
+ (and
+ (invisible-p (point))
+ (< (point) (overlay-start org-index--occur-tail-overlay))))
+ (goto-char (overlay-end (car (overlays-at (point))))))
+
+ ;; find stretch of lines, that are currently visible but should be invisible now
+ (setq matched nil)
+ (setq start (point))
+ (while (and (not (eobp))
+ (not
+ (and
+ (invisible-p (point))
+ (< (point) (overlay-start org-index--occur-tail-overlay))))
+ (not (and (org-index--test-words words)
+ (setq matched t)))) ; for its side effect
+ (forward-line 1))
+
+ ;; create overlay to hide this stretch
+ (when (< start (point)) ; avoid creating an empty overlay
+ (setq overlay (make-overlay start (point)))
+ (overlay-put overlay 'invisible t)
+ (setq overlays (cons overlay overlays)))
+
+ ;; skip and count line, that matched
+ (when matched
+ (forward-line 1)
+ (setq end-of-visible (point))
+ (incf lines-found)))
+
+ ;; put new list on top of stack
+ (setq org-index--occur-stack
+ (cons (list (cons :overlays overlays)
+ (cons :end-of-visible end-of-visible)
+ (cons :lines lines-found))
+ org-index--occur-stack))
+
+ lines-found))
+
+
+(defun org-index--unhide ()
+ "Unhide text that does has been hidden by `org-index--hide-with-overlays'."
+ (when org-index--occur-stack
+ ;; delete overlays and make visible again
+ (mapc (lambda (y)
+ (delete-overlay y))
+ (cdr (assoc :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))))))
+
+
+(defun org-index--test-words (words)
+ "Test current line for match against WORDS."
+ (let (line)
+ (setq line (downcase (buffer-substring (line-beginning-position) (line-beginning-position 2))))
+ (catch 'not-found
+ (dolist (w words)
+ (or (search w line)
+ (throw 'not-found nil)))
+ t)))
+
+
+(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")
+
+ new))
+
+
+(defun org-index--sort-silent ()
+ "Sort index for default column to remove any effects of temporary sorting."
+ (save-excursion
+ (org-index--verify-id)
+ (org-index--parse-table)
+ (org-index--on nil nil
+ (org-index--do-sort-index (org-index--special-column 'sort))
+ (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'"
+ (let (snippets s)
+ (save-excursion
+ (save-restriction
+ (narrow-to-region beg end)
+ (setq s (goto-char (point-min)))
+ (while (not (= (point) (point-max)))
+ (goto-char (org-find-invisible))
+ (push (buffer-substring s (point)) snippets)
+ (setq s (goto-char (org-find-visible))))))
+ (apply 'concat (nreverse snippets))))
+
+
+(provide 'org-index)
+
+;; Local Variables:
+;; fill-column: 75
+;; comment-column: 50
+;; End:
+
+;;; org-index.el ends here
diff --git a/contrib/lisp/org-jira.el b/contrib/lisp/org-jira.el
deleted file mode 100644
index 43edd08..0000000
--- a/contrib/lisp/org-jira.el
+++ /dev/null
@@ -1,64 +0,0 @@
-;;; org-jira.el --- add a jira:ticket protocol to Org
-(defconst org-jira-version "0.1")
-;; Copyright (C) 2008-2014 Jonathan Arkell.
-;; Author: Jonathan Arkell <jonnay@jonnay.net>
-
-;; 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 version 2.
-
-;; 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:
-;; This adds a jira protocol to org mode.
-
-;;; Commands:
-;;
-;; Below are complete command list:
-;;
-;;
-;;; Customizable Options:
-;;
-;; Below are customizable option list:
-;;
-
-;; I had initially planned on adding bi-directional linking, so you
-;; could store links from a jira ticket. I also wanted to import
-;; tickets assigned to you as a task. However, I am no longer working
-;; with JIRA, so this is now abandonware.
-
-;;; Installation:
-;; Put org-jira.el somewhere in your load-path.
-;; (Use M-x show-variable RET load-path to see what your load path is.)
-;; Add this to your emacs init file, preferably after you load org mode.
-;(require 'org-jira)
-
-;;; TODO:
-;; - bi-directional links
-;; - deeper importing, like tasks...?
-
-;;; CHANGELOG:
-;; v 0.2 - ran through checkdoc
-;; - Abandoned.
-;; v 0.1 - Initial release
-
-(require 'jira)
-
-(org-add-link-type "jira" 'org-jira-open)
-
-(defun org-jira-open (path)
- "Open a Jira Link from PATH."
- (jira-show-issue path))
-
-
-(provide 'org-jira)
-
-;;; org-jira.el ends here
diff --git a/contrib/lisp/org-license.el b/contrib/lisp/org-license.el
new file mode 100644
index 0000000..426b148
--- /dev/null
+++ b/contrib/lisp/org-license.el
@@ -0,0 +1,540 @@
+;;; org-license.el --- Add a license to your org files
+
+;; Copyright (C) 2013 Free Software Foundation, Inc.
+
+;; Author: David Arroyo Menéndez <davidam@es.gnu.org>
+;; Keywords: licenses, creative commons
+;; Homepage: http://orgmode.org
+;;
+;; This file is not part of GNU Emacs, yet.
+;;
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;; Commentary:
+
+;; This file implements functions to add a license fast in org files.
+;; Org-mode doesn't load this module by default - if this is not what
+;; you want, configure the variable `org-modules'. Thanks to #emacs-es
+;; irc channel for your support.
+
+;;; Code:
+
+;;
+;;
+;; You can download the images from http://www.davidam/img/licenses.tar.gz
+;;
+;;; CHANGELOG:
+;; v 0.2 - add public domain functions
+;; v 0.1 - Initial release
+
+
+(defvar org-license-images-directory "")
+
+(defun org-license-cc-by (language)
+ (interactive "MLanguage ( br | ca | de | en | es | eo | eu | fi | fr | gl | it | jp | nl | pt ): " language)
+ (cond ((equal language "br")
+ (setq org-license-cc-url "https://creativecommons.org/licenses/by/3.0/br/deed.pt_BR")
+ (insert (concat "* Licença
+Este texto é disponibilizado nos termos da licença [[" org-license-cc-url "][Atribuição 3.0 Brasil]]\n")))
+ ((equal language "ca")
+ (setq org-license-cc-url "https://creativecommons.org/licenses/by/3.0/es/deed.ca")
+ (insert (concat "* Licència
+El text està disponible sota la [[" org-license-cc-url "][Reconeixement 3.0 Espanya]]\n")))
+ ((equal language "de")
+ (setq org-license-cc-url "https://creativecommons.org/licenses/by/3.0/de/deed.de")
+ (insert (concat "* Lizenz
+Dieses Werk bzw. Inhalt steht unter einer [[" org-license-cc-url "][Lizenz Creative Commons Namensnennung 3.0 Deutschland]]\n")))
+ ((equal language "eo")
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by/3.0/eo/deed.eo")
+ (insert (concat "* Licenco
+Ĉi tiu verko estas disponebla laŭ la permesilo [[" org-license-cc-url "][Krea Komunaĵo Atribuite 3.0 Neadaptita]]\n")))
+ ((equal language "es")
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by/3.0/es/deed.es")
+ (insert (concat "* Licencia
+Este documento está bajo una [[" org-license-cc-url "][Licencia Creative Commons Atribución 3.0 España]]\n")))
+ ((equal language "eu")
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by/3.0/es/deed.eu")
+ (insert (concat "* Licenzua
+Testua [[" org-license-cc-url "][Aitortu 3.0 Espainia]] lizentziari jarraituz erabil daiteke\n")))
+ ((equal language "fi")
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by/1.0/fi/deed.fi")
+ (insert (concat "* Lisenssi
+Teksti on saatavilla [[" org-license-cc-url "][Nimeä 1.0 Suomi]] lisenssillä\n")))
+ ((equal language "fr")
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by/3.0/fr/deed.fr")
+ (insert (concat "* Licence
+Ce(tte) œuvre est mise à disposition selon les termes de la [[" org-license-cc-url "][Licence Creative Commons Attribution 3.0 France]]\n")))
+ ((equal language "gl")
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by/3.0/es/deed.gl")
+ (insert (concat "* Licenza
+Todo o texto está dispoñible baixo a [[" org-license-cc-url "][licenza Creative Commons recoñecemento compartir igual 3.0]].\n")))
+ ((equal language "it")
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by/3.0/it/deed.it")
+ (insert (concat "* Licenza
+Quest'opera e distribuita con Licenza [[" org-license-cc-url "][Licenza Creative Commons Attribuzione 3.0 Italia]]\n")))
+ ((equal language "jp")
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by/2.1/jp/deed.en")
+ (insert (concat "* ライセンス
+この文書は [[" org-license-cc-url "][Creative Commons Attribution 2.1 ]] ライセンスの下である\n")))
+ ((equal language "nl")
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by/3.0/nl/deed.nl")
+ (insert (concat "* Licentie
+Dit werk is valt onder een [[" org-license-cc-url "][Creative Commons Naamsvermelding 3.0 Nederland]]\n")))
+ ((equal language "pt")
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by/3.0/pt/deed.pt")
+ (insert (concat "* Licença
+Este texto é disponibilizado nos termos da licença [[" org-license-cc-url "][Atribuição 3.0 Portugal]]\n")))
+ (t
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by/4.0/deed")
+ (concat (insert "* License
+This document is under a [[" org-license-cc-url "][Creative Commons Attribution 4.0 International]]\n"))))
+ (if (string= "" org-license-images-directory)
+ (insert (concat "\n[[" org-license-cc-url "][file:http://i.creativecommons.org/l/by/3.0/80x15.png]]\n"))
+ (insert (concat "\n[[" org-license-cc-url "][file:" org-license-images-directory "/by/3.0/80x15.png]]\n"))))
+
+(defun org-license-cc-by-sa (language)
+ (interactive "MLanguage ( br | ca | de | en | es | eu | fi | fr | it | jp | nl | pt ): " language)
+ (cond ((equal language "br")
+ (setq org-license-cc-url "https://creativecommons.org/licenses/by-sa/3.0/br/deed.pt_BR")
+ (concat (insert "* Licença
+Este texto é disponibilizado nos termos da licença [[" org-license-cc-url "][Atribuição Compartil ha Igual 3.0 Brasil]]\n")))
+ ((equal language "ca")
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by-sa/3.0/es/deed.ca")
+ (insert (concat "* Licència
+El text està disponible sota la [[" org-license-cc-url "][Reconeixement-CompartirIgual 3.0 Espanya]]\n")))
+ ((equal language "de")
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by-sa/3.0/de/deed.de")
+ (insert (concat "* Lizenz
+Dieses Werk bzw. Inhalt steht unter einer [[" org-license-cc-url "][Namensnennung - Weitergabe unter gleichen Bedingungen 3.0 Deutschland]]\n")))
+ ((equal language "es")
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by-sa/3.0/es/deed.es")
+ (concat (insert "* Licencia
+Este documento está bajo una [[" org-license-cc-url "][Licencia Creative Commons Atribución Compartir por Igual 3.0 España]]\n")))
+ ((equal language "eu")
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by-sa/3.0/es/deed.eu")
+ (concat (insert "* Licenzua
+Testua [[" org-license-cc-url "][Aitortu-PartekatuBerdin 3.0 Espainia]] lizentziari jarraituz erabil daiteke\n")))
+ ((equal language "fi")
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by-sa/1.0/fi/deed.fi")
+ (insert (concat "* Lisenssi
+Teksti on saatavilla [[" org-license-cc-url "][Nimeä-JaaSamoin 1.0 Suomi]] lisenssillä\n")))
+ ((equal language "fr")
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by-sa/3.0/fr/deed.fr")
+ (concat (insert "* Licence
+Ce(tte) œuvre est mise à disposition selon les termes de la [[" org-license-cc-url "][Licence Creative Commons Attribution - Partage dans les Mêmes Conditions 3.0 France]]\n")))
+ ((equal language "gl")
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by-sa/3.0/es/deed.gl")
+ (insert (concat "* Licenza
+Todo o texto está dispoñible baixo a [[" org-license-cc-url "][licenza Creative Commons recoñecemento compartir igual 3.0]].\n")))
+ ((equal language "it")
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by-sa/3.0/it/deed.it")
+ (insert (concat "* Licenza
+Quest'opera e distribuita con Licenza [[" org-license-cc-url "][Licenza Creative Commons Attribuzione - Condividi allo stesso modo 3.0 Italia]]\n")))
+ ((equal language "jp")
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by-sa/2.1/jp/deed.en")
+ (insert (concat "* ライセンス
+この文書は、[[" org-license-cc-url "][Creative Commons Attribution 2.1 ]] ライセンスの下である\n")))
+ ((equal language "nl")
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by-sa/3.0/nl/deed.nl")
+ (insert (concat "* Licentie
+Dit werk is valt onder een [[" org-license-cc-url "][Creative Commons Naamsvermelding Gelijk Delen 3.0 Nederland]]\n")))
+ ((equal language "pt")
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by-sa/3.0/pt/deed.pt")
+ (insert (concat "* Licença
+Este texto é disponibilizado nos termos da licença [[" org-license-cc-url "][Atribuição-CompartilhaIgual 3.0 Portugal]]\n")))
+ (t
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by-sa/4.0/deed")
+ (insert (concat "* License
+This document is under a [[" org-license-cc-url "][Creative Commons Attribution-ShareAlike 4.0 International]]\n"))))
+ (if (string= "" org-license-images-directory)
+ (insert (concat "\n[[" org-license-cc-url "][file:http://i.creativecommons.org/l/by-sa/3.0/80x15.png]]\n"))
+ (insert (concat "\n[[" org-license-cc-url "][file:" org-license-images-directory "/by-sa/3.0/80x15.png]]\n"))))
+
+(defun org-license-cc-by-nd (language)
+ (interactive "MLanguage ( br | ca | de | en | es | eu | fi | fr | it | pt ): " language)
+ (cond ((equal language "br")
+ (setq org-license-cc-url "https://creativecommons.org/licenses/by-nd/3.0/br/deed.pt_BR")
+ (insert (concat "* Licença
+Este texto é disponibilizado nos termos da licença [[" org-license-cc-url "][Atribuição Compartil ha Igual 3.0 Brasil]]\n")))
+ ((equal language "ca")
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by-nd/3.0/es/deed.ca")
+ (insert (concat "* Licència
+El text està disponible sota la [[" org-license-cc-url "][Reconeixement-SenseObraDerivada 3.0 Espanya]]\n")))
+ ((equal language "de")
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by-nd/3.0/de/deed.de")
+ (insert (concat "* Lizenz
+Dieses Werk bzw. Inhalt steht unter einer [[" org-license-cc-url "][Namensnennung-Keine Bearbeitung 3.0 Deutschland]]\n")))
+ ((equal language "es")
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by-nd/3.0/es/deed.es")
+ (insert (concat "* Licencia
+Este documento está bajo una [[" org-license-cc-url "][Licencia Creative Commons Atribución-SinDerivadas 3.0]]\n")))
+ ((equal language "eu")
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by-nd/3.0/es/deed.eu")
+ (insert (concat "* Licenzua
+Testua [[" org-license-cc-url "][Aitortu-LanEratorririkGabe 3.0 Espainia]] lizentziari jarraituz erabil daiteke\n")))
+ ((equal language "fi")
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by-nd/1.0/fi/deed.fi")
+ (insert (concat "* Lisenssi
+Teksti on saatavilla [[" org-license-cc-url "][Nimeä-JaaSamoin 1.0 Suomi]] lisenssillä\n")))
+ ((equal language "fr")
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by-nd/3.0/fr/deed.fr")
+ (insert (concat "* Licence
+Ce(tte) œuvre est mise à disposition selon les termes de la [[" org-license-cc-url "][Licence Creative Commons Attribution - Pas de Modification 3.0 France]]\n")))
+ ((equal language "gl")
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by-nd/3.0/es/deed.gl")
+ (insert (concat "* Licenza
+Todo o texto está dispoñible baixo a [[" org-license-cc-url "][licenza Creative Commons recoñecemento compartir igual 3.0]].\n")))
+ ((equal language "it")
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by-nd/3.0/it/deed.it")
+ (insert (concat "* Licenza
+Quest'opera e distribuita con Licenza [[" org-license-cc-url "][Licenza Creative Commons Attribuzione - Non opere derivate 3.0 Italia]]\n")))
+ ((equal language "jp")
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by-nd/2.1/jp/deed.en")
+ (insert (concat "* ライセンス
+この文書は、[[" org-license-cc-url "][Creative Commons No Derivatives 2.1]] ライセンスの下である\n")))
+ ((equal language "nl")
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by-nd/3.0/nl/deed.nl")
+ (insert (concat "* Licentie
+Dit werk is valt onder een [[" org-license-cc-url "][Creative Commons Naamsvermelding GeenAfgeleideWerken 3.0 Nederland]]\n")))
+ ((equal language "pt")
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by-nd/3.0/pt/deed.pt")
+ (insert (concat "* Licença
+Este texto é disponibilizado nos termos da licença [[" org-license-cc-url "][Atribuição Sem Derivados 3.0 Portugal]]\n")))
+ (t
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by-nd/4.0/deed")
+ (insert (concat "* License
+This document is under a [[" org-license-cc-url "][Creative Commons No Derivatives 4.0 International]]\n"))))
+ (if (string= "" org-license-images-directory)
+ (insert (concat "\n[[" org-license-cc-url "][file:http://i.creativecommons.org/l/by-nd/3.0/80x15.png]]\n"))
+ (insert (concat "\n[[" org-license-cc-url "][file:" org-license-images-directory "/by-nd/3.0/80x15.png]]\n"))))
+
+
+(defun org-license-cc-by-nc (language)
+ (interactive "MLanguage ( br | ca | de | en | es | eu | fi | fr | it | jp | nl | pt ): " language)
+ (cond ((equal language "br")
+ (setq org-license-cc-url "https://creativecommons.org/licenses/by-nc/3.0/br/deed.pt_BR")
+ (insert (concat "* Licença
+Este texto é disponibilizado nos termos da licença [[" org-license-cc-url "][Atribuição Não Comercial 3.0 Brasil]]\n")))
+ ((equal language "ca")
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc/3.0/es/deed.ca")
+ (insert (concat "* Licència
+El text està disponible sota la [[" org-license-cc-url "][Reconeixement-NoComercial 3.0 Espanya]]\n")))
+ ((equal language "de")
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc/3.0/de/deed.de")
+ (insert (concat "* Lizenz
+Dieses Werk bzw. Inhalt steht unter einer [[" org-license-cc-url "][Namensnennung-Nicht-kommerziell 3.0 Deutschland]]\n")))
+ ((equal language "es")
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc/3.0/es/deed.es")
+ (insert (concat "* Licencia
+Este documento está bajo una [[" org-license-cc-url "][Licencia Creative Commons Reconocimiento-NoComercial 3.0]]\n")))
+ ((equal language "eu")
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc/3.0/es/deed.eu")
+ (insert "* Licenzua
+Testua [[" org-license-cc-url "][Aitortu-EzKomertziala 3.0 Espainia]] lizentziari jarraituz erabil daiteke\n"))
+ ((equal language "fi")
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc/1.0/fi/deed.fi")
+ (insert (concat "* Lisenssi
+Teksti on saatavilla [[" org-license-cc-url "][Nimeä-Epäkaupallinen 1.0 Suomi]] lisenssillä\n")))
+ ((equal language "fr")
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc/3.0/fr/deed.fr")
+ (insert (concat "* Licence
+Ce(tte) œuvre est mise à disposition selon les termes de la [[" org-license-cc-url "][Licence Creative Commons Attribution - Pas d'Utilisation Commerciale 3.0 France]]\n")))
+ ((equal language "gl")
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc/3.0/es/deed.gl")
+ (insert (concat "* Licenza
+Todo o texto está dispoñible baixo a [[" org-license-cc-url "][licenza Creative Commons recoñecemento compartir igual 3.0]].\n")))
+ ((equal language "it")
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc/3.0/it/deed.it")
+ (insert (concat "* Licenza
+Quest'opera e distribuita con Licenza [[" org-license-cc-url "][Licenza Creative Commons Attribuzione - Non commerciale 3.0 Italia]]\n")))
+ ((equal language "jp")
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc/2.1/jp/deed.en")
+ (insert (concat "* ライセンス
+この文書は、[[" org-license-cc-url "][Creative Commons Attribution-NonCommercial 2.1 ]] ライセンスの下である\n")))
+ ((equal language "nl")
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc/3.0/nl/deed.nl")
+ (insert (concat "* Licentie
+Dit werk is valt onder een [[" org-license-cc-url "][Creative Commons Naamsvermelding NietCommercieel 3.0 Nederland 3.0 Nederland]]\n")))
+ ((equal language "pt")
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc/3.0/pt/deed.pt")
+ (insert (concat "* Licença
+Este texto é disponibilizado nos termos da licença [[" org-license-cc-url "][Atribuição Não Comercial 3.0 Portugal]]\n")))
+ (t
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc/4.0/deed")
+ (insert (concat "* License
+This document is under a [[" org-license-cc-url "][Creative Commons Attribution-NonCommercial 4.0 International]]\n"))))
+ (if (string= "" org-license-images-directory)
+ (insert (concat "\n[[" org-license-cc-url "][file:http://i.creativecommons.org/l/by-nc/3.0/80x15.png]]\n"))
+ (insert (concat "\n[[" org-license-cc-url "][file:" org-license-images-directory "/by-nc/3.0/80x15.png]]\n"))))
+
+(defun org-license-cc-by-nc-sa (language)
+ (interactive "MLanguage ( br | ca | de | en | es | eu | fi | fr | gl | it | jp | nl | pt ): " language)
+ (cond ((equal language "br")
+ (setq org-license-cc-url "https://creativecommons.org/licenses/by-nc-sa/3.0/br/deed.pt_BR")
+ (insert (concat "* Licença
+Este texto é disponibilizado nos termos da licença [[" org-license-cc-url "][Atribuição Não Comercial - Compartil ha Igual 3.0 Brasil]]\n")))
+ ((equal language "ca")
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc-sa/3.0/es/deed.ca")
+ (insert (concat "* Licència
+El text està disponible sota la [[" org-license-cc-url "][Reconeixement-NoComercial 3.0 Espanya]]\n")))
+ ((equal language "de")
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc-sa/3.0/de/deed.de")
+ (insert (concat "* Lizenz
+Dieses Werk bzw. Inhalt steht unter einer [[" org-license-cc-url "][Namensnennung - Weitergabe unter gleichen Bedingungen 3.0 Deutschland]]\n")))
+ ((equal language "es")
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc-sa/3.0/es/deed.es")
+ (insert (concat "* Licencia
+Este documento está bajo una [[" org-license-cc-url "][Licencia Creative Commons Reconocimiento-NoComercial 3.0]]\n")))
+ ((equal language "eu")
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc-sa/3.0/es/deed.eu")
+ (insert "* Licenzua
+Testua [[" org-license-cc-url "][Aitortu-EzKomertziala-PartekatuBerdin 3.0 Espainia]] lizentziari jarraituz erabil daiteke\n"))
+ ((equal language "fi")
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc-sa/1.0/fi/deed.fi")
+ (insert (concat "* Lisenssi
+Teksti on saatavilla [[" org-license-cc-url "][Nimeä-Epäkaupallinen-JaaSamoin 1.0 Suomi]] lisenssillä\n")))
+ ((equal language "fr")
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc-sa/3.0/fr/deed.fr")
+ (insert (concat "* Licence
+Ce(tte) œuvre est mise à disposition selon les termes de la [[" org-license-cc-url "][Licence Creative Commons Attribution - Pas d’Utilisation Commerciale - Partage dans les Mêmes Conditions 3.0 France]]\n")))
+ ((equal language "gl")
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc-sa/3.0/es/deed.gl")
+ (insert (concat "* Licenza
+Todo o texto está dispoñible baixo a [[" org-license-cc-url "][licenza Creative Commons recoñecemento compartir igual 3.0]].\n")))
+ ((equal language "it")
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc-sa/3.0/it/deed.it")
+ (insert (concat "* Licenza
+Quest'opera e distribuita con Licenza [[" org-license-cc-url "][Licenza Creative Commons Attribuzione - Non opere derivate 3.0 Italia]]\n")))
+ ((equal language "jp")
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc-sa/2.1/jp/deed.en")
+ (insert (concat "* ライセンス
+この文書は、[[" org-license-cc-url "][License Creative Commons Attribution Non Commercial Share Alike 2.1 ]] ライセンスの下である\n")))
+ ((equal language "nl")
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc-sa/3.0/nl/deed.nl")
+ (insert (concat "* Licentie
+Dit werk is valt onder een [[" org-license-cc-url "][Creative Commons Naamsvermelding NietCommercieel GelijkDelen 3.0 Nederland]]\n")))
+ ((equal language "pt")
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc/3.0/pt/deed.pt")
+ (insert (concat "* Licença
+Este texto é disponibilizado nos termos da licença [[" org-license-cc-url "][Atribuição NãoComercial Compartil ha Igual 3.0 Portugal]]\n")))
+ (t
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc-sa/4.0/deed")
+ (insert (concat "* License
+This document is under a [[" org-license-cc-url "][License Creative Commons Attribution Non Commercial Share Alike 4.0 International]]\n"))))
+ (if (string= "" org-license-images-directory)
+ (insert (concat "\n[[" org-license-cc-url "][file:http://i.creativecommons.org/l/by-nc-sa/3.0/80x15.png]]\n"))
+ (insert (concat "\n[[" org-license-cc-url "][file:" org-license-images-directory "/by-nc-sa/3.0/80x15.png]]\n"))))
+
+(defun org-license-cc-by-nc-nd (language)
+ (interactive "MLanguage ( br | ca | de | en | es | eu | fi | fr | gl | it | pt ): " language)
+ (cond ((equal language "br")
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc-nd/3.0/pt/deed.pt")
+ (insert (concat "* Licença
+Este texto é disponibilizado nos termos da licença [[" org-license-cc-url "][Atribuição Não Comercial Sem Derivados 3.0 Brasil]]\n")))
+ ((equal language "ca")
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc-nd/3.0/es/deed.ca")
+ (insert (concat "* Licència
+El text està disponible sota la [[" org-license-cc-url "][Reconeixement-NoComercial-SenseObraDerivada 3.0 Espanya]]\n")))
+ ((equal language "de")
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc-nd/3.0/de/deed.de")
+ (insert (concat "* Lizenz
+Dieses Werk bzw. Inhalt steht unter einer [[" org-license-cc-url "][Namensnennung-NichtKommerziell-KeineBearbeitung 3.0 Deutschland]]\n")))
+ ((equal language "es")
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc-nd/3.0/es/deed.es")
+ (insert (concat "* Licencia
+Este documento está bajo una [[" org-license-cc-url "][Licencia Creative Commons Reconocimiento-NoComercial-SinObraDerivada 3.0]]\n")))
+ ((equal language "eu")
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc-nd/3.0/es/deed.eu")
+ (insert (concat "* Licenzua
+Testua [[" org-license-cc-url "][Aitortu-LanEratorririkGabe 3.0 Espainia]] lizentziari jarraituz erabil daiteke\n")))
+ ((equal language "fi")
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc-nd/1.0/fi/deed.fi")
+ (insert (concat "* Lisenssi
+Teksti on saatavilla [[" org-license-cc-url "][Nimeä-Ei muutoksia-Epäkaupallinen 1.0 Suomi]] lisenssillä\n")))
+ ((equal language "fr")
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc-nd/3.0/fr/deed.fr")
+ (insert (concat "* Licence
+Ce(tte) œuvre est mise à disposition selon les termes de la [[" org-license-cc-url "][Licence Creative Commons Attribution - Pas de Modification 3.0 France]]\n")))
+ ((equal language "gl")
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc-nd/3.0/es/deed.gl")
+ (insert (concat "* Licenza
+Todo o texto está dispoñible baixo a [[" org-license-cc-url "][licenza Creative Commons recoñecemento compartir igual 3.0]].\n")))
+ ((equal language "it")
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc-nd/3.0/it/deed.it")
+ (insert (concat "* Licenza
+Quest'opera e distribuita con Licenza [[" org-license-cc-url "][Licenza Creative Commons Attribuzione - Non opere derivate 3.0 Italia]]\n")))
+ ((equal language "jp")
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc-nd/2.1/jp/deed.en")
+ (insert (concat "* ライセンス
+この文書は [[" org-license-cc-url "][License Creative Commons Attribution Non Commercial - No Derivs 2.1]] ライセンスの下である\n")))
+ ((equal language "nl")
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc-nd/3.0/nl/deed.nl")
+ (insert (concat "* Licentie
+Dit werk is valt onder een [[" org-license-cc-url "][Creative Commons Naamsvermelding NietCommercieel GeenAfgeleideWerken 3.0 Nederland]]\n")))
+ ((equal language "pt")
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc-nd/3.0/pt/deed.pt")
+ (insert (concat "* Licença
+Este texto é disponibilizado nos termos da licença [[" org-license-cc-url "][Atribuição Não Comercial Sem Derivados 3.0 Portugal]]\n")))
+ (t
+ (setq org-license-cc-url "http://creativecommons.org/licenses/by-nc-nd/4.0/deed")
+ (insert (concat "* License
+This document is under a [[" org-license-cc-url "][License Creative Commons Attribution-NonCommercial-NoDerivatives 4.0 International]]\n"))))
+ (if (string= "" org-license-images-directory)
+ (insert (concat "\n[[" org-license-cc-url "][file:http://i.creativecommons.org/l/by-nc-nd/3.0/80x15.png]]\n"))
+ (insert (concat "\n[[" org-license-cc-url "][file:" org-license-images-directory "/by-nc-nd/3.0/80x15.png]]\n"))))
+
+(defun org-license-gfdl (language)
+ (interactive "MLanguage (es | en): " language)
+ (cond ((equal language "es")
+ (insert "* Licencia
+Copyright (C) " (format-time-string "%Y") " " user-full-name
+"\n Se permite copiar, distribuir y/o modificar este documento
+ bajo los términos de la GNU Free Documentation License, Version 1.3
+ o cualquier versión publicada por la Free Software Foundation;
+ sin Secciones Invariantes y sin Textos de Portada o Contraportada.
+ Una copia de la licencia está incluida en [[https://www.gnu.org/copyleft/fdl.html][GNU Free Documentation License]].\n"))
+ (t (insert (concat "* License
+Copyright (C) " (format-time-string "%Y") " " user-full-name
+"\n Permission is granted to copy, distribute and/or modify this document
+ under the terms of the GNU Free Documentation License, Version 1.3
+ or any later version published by the Free Software Foundation;
+ with no Invariant Sections, no Front-Cover Texts, and no Back-Cover Texts.
+ A copy of the license is included in [[https://www.gnu.org/copyleft/fdl.html][GNU Free Documentation License]].\n"))))
+ (if (string= "" org-license-images-directory)
+ (insert "\n[[https://www.gnu.org/copyleft/fdl.html][file:https://upload.wikimedia.org/wikipedia/commons/thumb/4/42/GFDL_Logo.svg/200px-GFDL_Logo.svg.png]]\n")
+ (insert (concat "\n[[https://www.gnu.org/copyleft/fdl.html][file:" org-license-images-directory "/gfdl/gfdl.png]]\n"))))
+
+(defun org-license-publicdomain-zero (language)
+ (interactive "MLanguage ( en | es ): " language)
+ (setq org-license-pd-url "http://creativecommons.org/publicdomain/zero/1.0/")
+ (setq org-license-pd-file "zero/1.0/80x15.png")
+ (if (equal language "es")
+ (insert (concat "* Licencia
+Este documento está bajo una licencia [[" org-license-pd-url "][Public Domain Zero]]\n"))
+ (insert (concat "* License
+This documento is under a [[" org-license-pd-url "][Public Domain Zero]] license\n")))
+ (if (string= "" org-license-images-directory)
+ (insert (concat "\n[[" org-license-pd-url "][file:http://i.creativecommons.org/p/zero/1.0/80x15.png]]\n"))
+ (insert (concat "\n[[" org-license-pd-url "][file:" org-license-images-directory org-license-pd-file "]]\n"))))
+
+(defun org-license-publicdomain-mark (language)
+ (interactive "MLanguage ( en | es ): " language)
+ (setq org-license-pd-url "http://creativecommons.org/publicdomain/mark/1.0/")
+ (setq org-license-pd-file "mark/1.0/80x15.png")
+ (if (equal language "es")
+ (insert (concat "* Licencia
+Este documento está bajo una licencia [[" org-license-pd-url "][Etiqueta de Dominio Público 1.0]]\n"))
+ (insert (concat "* License
+This documento is under a [[" org-license-pd-url "][Public Domain Mark]] license\n")))
+ (if (string= "" org-license-images-directory)
+ (insert (concat "\n[[" org-license-pd-url "][file:http://i.creativecommons.org/p/mark/1.0/80x15.png]]\n"))
+ (insert (concat "\n[[" org-license-pd-url "][file:" org-license-images-directory org-license-pd-file "]]\n"))))
+
+(defun org-license-print-all ()
+"Print all combinations of licenses and languages, it's useful to find bugs"
+ (interactive)
+ (org-license-gfdl "es")
+ (org-license-gfdl "en")
+ (org-license-publicdomain-mark "es")
+ (org-license-publicdomain-mark "en")
+ (org-license-publicdomain-zero "es")
+ (org-license-publicdomain-zero "en")
+ (org-license-cc-by "br")
+ (org-license-cc-by "ca")
+ (org-license-cc-by "de")
+ (org-license-cc-by "es")
+ (org-license-cc-by "en")
+ (org-license-cc-by "eo")
+ (org-license-cc-by "eu")
+ (org-license-cc-by "fi")
+ (org-license-cc-by "fr")
+ (org-license-cc-by "gl")
+ (org-license-cc-by "it")
+ (org-license-cc-by "jp")
+ (org-license-cc-by "nl")
+ (org-license-cc-by "pt")
+ (org-license-cc-by-sa "br")
+ (org-license-cc-by-sa "ca")
+ (org-license-cc-by-sa "de")
+ (org-license-cc-by-sa "es")
+ (org-license-cc-by-sa "en")
+;; (org-license-cc-by-sa "eo")
+ (org-license-cc-by-sa "eu")
+ (org-license-cc-by-sa "fi")
+ (org-license-cc-by-sa "fr")
+ (org-license-cc-by-sa "gl")
+ (org-license-cc-by-sa "it")
+ (org-license-cc-by-sa "jp")
+ (org-license-cc-by-sa "nl")
+ (org-license-cc-by-sa "pt")
+ (org-license-cc-by-nd "br")
+ (org-license-cc-by-nd "ca")
+ (org-license-cc-by-nd "de")
+ (org-license-cc-by-nd "es")
+ (org-license-cc-by-nd "en")
+;; (org-license-cc-by-nd "eo")
+ (org-license-cc-by-nd "eu")
+ (org-license-cc-by-nd "fi")
+ (org-license-cc-by-nd "fr")
+ (org-license-cc-by-nd "gl")
+ (org-license-cc-by-nd "it")
+ (org-license-cc-by-nd "jp")
+ (org-license-cc-by-nd "nl")
+ (org-license-cc-by-nd "pt")
+ (org-license-cc-by-nc "br")
+ (org-license-cc-by-nc "ca")
+ (org-license-cc-by-nc "de")
+ (org-license-cc-by-nc "es")
+ (org-license-cc-by-nc "en")
+;; (org-license-cc-by-nc "eo")
+ (org-license-cc-by-nc "eu")
+ (org-license-cc-by-nc "fi")
+ (org-license-cc-by-nc "fr")
+ (org-license-cc-by-nc "gl")
+ (org-license-cc-by-nc "it")
+ (org-license-cc-by-nc "jp")
+ (org-license-cc-by-nc "nl")
+ (org-license-cc-by-nc "pt")
+ (org-license-cc-by-nc-sa "br")
+ (org-license-cc-by-nc-sa "ca")
+ (org-license-cc-by-nc-sa "de")
+ (org-license-cc-by-nc-sa "es")
+ (org-license-cc-by-nc-sa "en")
+;; (org-license-cc-by-nc-sa "eo")
+ (org-license-cc-by-nc-sa "eu")
+ (org-license-cc-by-nc-sa "fi")
+ (org-license-cc-by-nc-sa "fr")
+ (org-license-cc-by-nc-sa "gl")
+ (org-license-cc-by-nc-sa "it")
+ (org-license-cc-by-nc-sa "jp")
+ (org-license-cc-by-nc-sa "nl")
+ (org-license-cc-by-nc-sa "pt")
+ (org-license-cc-by-nc-nd "br")
+ (org-license-cc-by-nc-nd "ca")
+ (org-license-cc-by-nc-nd "de")
+ (org-license-cc-by-nc-nd "es")
+ (org-license-cc-by-nc-nd "en")
+;; (org-license-cc-by-nc-nd "eo")
+ (org-license-cc-by-nc-nd "eu")
+ (org-license-cc-by-nc-nd "fi")
+ (org-license-cc-by-nc-nd "fr")
+ (org-license-cc-by-nc-nd "gl")
+ (org-license-cc-by-nc-nd "it")
+ (org-license-cc-by-nc-nd "jp")
+ (org-license-cc-by-nc-nd "nl")
+ (org-license-cc-by-nc-nd "pt")
+)
+
+
diff --git a/contrib/lisp/org-mac-link.el b/contrib/lisp/org-mac-link.el
index fef6692..c991dfa 100644
--- a/contrib/lisp/org-mac-link.el
+++ b/contrib/lisp/org-mac-link.el
@@ -1,13 +1,13 @@
-;;; org-mac-link.el --- Grab links and url from various mac
-;; Application and insert them as links into org-mode documents
+;;; org-mac-link.el --- Insert org-mode links to items selected in various Mac apps
;;
;; Copyright (c) 2010-2014 Free Software Foundation, Inc.
;;
-;; Authors:
-;; Anthony Lander <anthony.lander@gmail.com>
-;; John Wiegley <johnw@gnu.org>
-;; Christopher Suckling <suckling at gmail dot com>
-;; Daniil Frumin <difrumin@gmail.com>
+;; Author: Anthony Lander <anthony.lander@gmail.com>
+;; John Wiegley <johnw@gnu.org>
+;; Christopher Suckling <suckling at gmail dot com>
+;; Daniil Frumin <difrumin@gmail.com>
+;; Alan Schmitt <alan.schmitt@polytechnique.org>
+;; Mike McLean <mike.mclean@pobox.com>
;;
;;
;; Version: 1.1
@@ -57,6 +57,7 @@
;; Together.app - Grab links to the selected items in the library list
;; 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
;;
;;
;; Installation:
@@ -86,61 +87,66 @@
(require 'org)
(defgroup org-mac-link nil
- "Options concerning grabbing links from external Mac
-applications and inserting them in org documents"
+ "Options for grabbing links from Mac applications."
:tag "Org Mac link"
:group 'org-link)
(defcustom org-mac-grab-Finder-app-p t
- "Enable menu option [F]inder to grab links from the Finder"
+ "Add menu option [F]inder to grab links from the Finder."
:tag "Grab Finder.app links"
:group 'org-mac-link
:type 'boolean)
(defcustom org-mac-grab-Mail-app-p t
- "Enable menu option [m]ail to grab links from Mail.app"
+ "Add menu option [m]ail to grab links from Mail.app."
:tag "Grab Mail.app links"
:group 'org-mac-link
:type 'boolean)
(defcustom org-mac-grab-Outlook-app-p t
- "Enable menu option [o]utlook to grab links from Microsoft Outlook.app"
+ "Add menu option [o]utlook to grab links from Microsoft Outlook.app."
:tag "Grab Microsoft Outlook.app links"
:group 'org-mac-link
:type 'boolean)
+(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"
+ :group 'org-mac-link
+ :type 'boolean)
+
(defcustom org-mac-grab-Addressbook-app-p t
- "Enable menu option [a]ddressbook to grab links from AddressBook.app"
+ "Add menu option [a]ddressbook to grab links from AddressBook.app."
:tag "Grab AddressBook.app links"
:group 'org-mac-link
:type 'boolean)
(defcustom org-mac-grab-Safari-app-p t
- "Enable menu option [s]afari to grab links from Safari.app"
+ "Add menu option [s]afari to grab links from Safari.app."
:tag "Grab Safari.app links"
:group 'org-mac-link
:type 'boolean)
(defcustom org-mac-grab-Firefox-app-p t
- "Enable menu option [f]irefox to grab links from Firefox.app"
+ "Add menu option [f]irefox to grab links from Firefox.app."
:tag "Grab Firefox.app links"
:group 'org-mac-link
:type 'boolean)
(defcustom org-mac-grab-Firefox+Vimperator-p nil
- "Enable menu option [v]imperator to grab links from Firefox.app running the Vimperator plugin"
+ "Add menu option [v]imperator to grab links from Firefox.app running the Vimperator plugin."
:tag "Grab Vimperator/Firefox.app links"
:group 'org-mac-link
:type 'boolean)
(defcustom org-mac-grab-Chrome-app-p t
- "Enable menu option [f]irefox to grab links from Google Chrome.app"
+ "Add menu option [c]hrome to grab links from Google Chrome.app."
:tag "Grab Google Chrome.app links"
:group 'org-mac-link
:type 'boolean)
(defcustom org-mac-grab-Together-app-p nil
- "Enable menu option [t]ogether to grab links from Together.app"
+ "Add menu option [t]ogether to grab links from Together.app."
:tag "Grab Together.app links"
:group 'org-mac-link
:type 'boolean)
@@ -148,23 +154,23 @@ applications and inserting them in org documents"
(defcustom org-mac-grab-Skim-app-p
(< 0 (length (shell-command-to-string
"mdfind kMDItemCFBundleIdentifier == 'net.sourceforge.skim-app.skim'")))
- "Enable menu option [S]kim to grab page links from Skim.app"
+ "Add menu option [S]kim to grab page links from Skim.app."
:tag "Grab Skim.app page links"
:group 'org-mac-link
:type 'boolean)
(defcustom org-mac-Skim-highlight-selection-p nil
- "Highlight (using notes) the selection (if present) when grabbing the a link from Skim.app"
+ "Highlight the active selection when grabbing a link from Skim.app."
:tag "Highlight selection in Skim.app"
:group 'org-mac-link
:type 'boolean)
(defgroup org-mac-flagged-mail nil
- "Options concerning linking to flagged Mail.app messages."
+ "Options foring linking to flagged Mail.app messages."
:tag "Org Mail.app"
:group 'org-link)
-(defcustom org-mac-mail-account "customize"
+(defcustom org-mac-mail-account nil
"The Mail.app account in which to search for flagged messages."
:group 'org-mac-flagged-mail
:type 'string)
@@ -185,27 +191,32 @@ applications and inserting them in org documents"
(setq return (shell-command-to-string cmd))
(concat "\"" (org-trim return) "\""))))
-
(defun org-mac-grab-link ()
- "Prompt the user for an application to grab a link from, then go grab the link, and insert it at point"
+ "Prompt for an application to grab a link from.
+When done, go grab the link, and insert it at point."
(interactive)
- (let* ((descriptors `(("F" "inder" org-mac-finder-insert-selected ,org-mac-grab-Finder-app-p)
- ("m" "ail" org-mac-message-insert-selected ,org-mac-grab-Mail-app-p)
- ("o" "utlook" org-mac-outlook-message-insert-selected ,org-mac-grab-Outlook-app-p)
- ("a" "ddressbook" org-mac-addressbook-insert-selected ,org-mac-grab-Addressbook-app-p)
- ("s" "afari" org-mac-safari-insert-frontmost-url ,org-mac-grab-Safari-app-p)
- ("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)
- ("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)))
+ (let* ((descriptors
+ `(("F" "inder" org-mac-finder-insert-selected ,org-mac-grab-Finder-app-p)
+ ("m" "ail" org-mac-message-insert-selected ,org-mac-grab-Mail-app-p)
+ ("d" "EVONthink Pro Office" org-mac-devonthink-item-insert-selected
+ ,org-mac-grab-devonthink-app-p)
+ ("o" "utlook" org-mac-outlook-message-insert-selected ,org-mac-grab-Outlook-app-p)
+ ("a" "ddressbook" org-mac-addressbook-insert-selected ,org-mac-grab-Addressbook-app-p)
+ ("s" "afari" org-mac-safari-insert-frontmost-url ,org-mac-grab-Safari-app-p)
+ ("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)
+ ("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)))
(menu-string (make-string 0 ?x))
input)
;; Create the menu string for the keymap
(mapc '(lambda (descriptor)
(when (elt descriptor 3)
- (setf menu-string (concat menu-string "[" (elt descriptor 0) "]" (elt descriptor 1) " "))))
+ (setf menu-string (concat menu-string
+ "[" (elt descriptor 0) "]"
+ (elt descriptor 1) " "))))
descriptors)
(setf (elt menu-string (- (length menu-string) 1)) ?:)
@@ -221,12 +232,17 @@ applications and inserting them in org documents"
descriptors)))
(defun org-mac-paste-applescript-links (as-link-list)
- "Paste in a list of links from an applescript handler. The
- links are of the form <link>::split::<name>"
- (let* ((link-list
- (mapcar
- (lambda (x) (if (string-match "\\`\"\\(.*\\)\"\\'" x) (setq x (match-string 1 x))) x)
- (split-string as-link-list "[\r\n]+")))
+ "Paste in a list of links from an applescript handler.
+The links are of the form <link>::split::<name>."
+ (let* ((noquote-as-link-list
+ (if (string-prefix-p "\"" as-link-list)
+ (substring as-link-list 1 -1)
+ as-link-list))
+ (link-list
+ (mapcar (lambda (x) (if (string-match "\\`\"\\(.*\\)\"\\'" x)
+ (setq x (match-string 1 x)))
+ x)
+ (split-string noquote-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::"))
@@ -240,7 +256,6 @@ applications and inserting them in org documents"
rtn))
-
;; Handle links from Firefox.app
;;
;; This code allows you to grab the current active url from the main
@@ -257,27 +272,28 @@ applications and inserting them in org documents"
;; seems that it is always the last active window).
(defun org-as-mac-firefox-get-frontmost-url ()
- (let ((result (do-applescript
- (concat
- "set oldClipboard to the clipboard\n"
- "set frontmostApplication to path to frontmost application\n"
- "tell application \"Firefox\"\n"
- " activate\n"
- " delay 0.15\n"
- " tell application \"System Events\"\n"
- " keystroke \"l\" using {command down}\n"
- " keystroke \"a\" using {command down}\n"
- " keystroke \"c\" using {command down}\n"
- " end tell\n"
- " delay 0.15\n"
- " set theUrl to the clipboard\n"
- " set the clipboard to oldClipboard\n"
- " set theResult to (get theUrl) & \"::split::\" & (get name of window 1)\n"
- "end tell\n"
- "activate application (frontmostApplication as text)\n"
- "set links to {}\n"
- "copy theResult to the end of links\n"
- "return links as string\n"))))
+ (let ((result
+ (do-applescript
+ (concat
+ "set oldClipboard to the clipboard\n"
+ "set frontmostApplication to path to frontmost application\n"
+ "tell application \"Firefox\"\n"
+ " activate\n"
+ " delay 0.15\n"
+ " tell application \"System Events\"\n"
+ " keystroke \"l\" using {command down}\n"
+ " keystroke \"a\" using {command down}\n"
+ " keystroke \"c\" using {command down}\n"
+ " end tell\n"
+ " delay 0.15\n"
+ " set theUrl to the clipboard\n"
+ " set the clipboard to oldClipboard\n"
+ " set theResult to (get theUrl) & \"::split::\" & (get name of window 1)\n"
+ "end tell\n"
+ "activate application (frontmostApplication as text)\n"
+ "set links to {}\n"
+ "copy theResult to the end of links\n"
+ "return links as string\n"))))
(car (split-string result "[\r\n]+" t))))
(defun org-mac-firefox-get-frontmost-url ()
@@ -303,27 +319,28 @@ applications and inserting them in org documents"
;; Firefox
(defun org-as-mac-vimperator-get-frontmost-url ()
- (let ((result (do-applescript
- (concat
- "set oldClipboard to the clipboard\n"
- "set frontmostApplication to path to frontmost application\n"
- "tell application \"Firefox\"\n"
- " activate\n"
- " delay 0.15\n"
- " tell application \"System Events\"\n"
- " keystroke \"y\"\n"
- " end tell\n"
- " delay 0.15\n"
- " set theUrl to the clipboard\n"
- " set the clipboard to oldClipboard\n"
- " set theResult to (get theUrl) & \"::split::\" & (get name of window 1)\n"
- "end tell\n"
- "activate application (frontmostApplication as text)\n"
- "set links to {}\n"
- "copy theResult to the end of links\n"
- "return links as string\n"))))
- (replace-regexp-in-string "\s+-\s+Vimperator" "" (car (split-string result "[\r\n]+" t)))))
-
+ (let ((result
+ (do-applescript
+ (concat
+ "set oldClipboard to the clipboard\n"
+ "set frontmostApplication to path to frontmost application\n"
+ "tell application \"Firefox\"\n"
+ " activate\n"
+ " delay 0.15\n"
+ " tell application \"System Events\"\n"
+ " keystroke \"y\"\n"
+ " end tell\n"
+ " delay 0.15\n"
+ " set theUrl to the clipboard\n"
+ " set the clipboard to oldClipboard\n"
+ " set theResult to (get theUrl) & \"::split::\" & (get name of window 1)\n"
+ "end tell\n"
+ "activate application (frontmostApplication as text)\n"
+ "set links to {}\n"
+ "copy theResult to the end of links\n"
+ "return links as string\n"))))
+ (replace-regexp-in-string
+ "\s+-\s+Vimperator" "" (car (split-string result "[\r\n]+" t)))))
(defun org-mac-vimperator-get-frontmost-url ()
(interactive)
@@ -348,27 +365,20 @@ applications and inserting them in org documents"
;; Firefox because Chrome doesn't publish an Applescript dictionary
(defun org-as-mac-chrome-get-frontmost-url ()
- (let ((result (do-applescript
- (concat
- "set oldClipboard to the clipboard\n"
- "set frontmostApplication to path to frontmost application\n"
- "tell application \"Google Chrome\"\n"
- " activate\n"
- " delay 0.15\n"
- " tell application \"System Events\"\n"
- " keystroke \"l\" using command down\n"
- " keystroke \"c\" using command down\n"
- " end tell\n"
- " delay 0.15\n"
- " set theUrl to the clipboard\n"
- " set the clipboard to oldClipboard\n"
- " set theResult to (get theUrl) & \"::split::\" & (get name of window 1)\n"
- "end tell\n"
- "activate application (frontmostApplication as text)\n"
- "set links to {}\n"
- "copy theResult to the end of links\n"
- "return links as string\n"))))
- (substring (car (split-string result "[\r\n]+" t)) 1 -1)))
+ (let ((result
+ (do-applescript
+ (concat
+ "set frontmostApplication to path to frontmost application\n"
+ "tell application \"Google Chrome\"\n"
+ " set theUrl to get URL of active tab of first window\n"
+ " set theResult to (get theUrl) & \"::split::\" & (get name of window 1)\n"
+ "end tell\n"
+ "activate application (frontmostApplication as text)\n"
+ "set links to {}\n"
+ "copy theResult to the end of links\n"
+ "return links as string\n"))))
+ (replace-regexp-in-string
+ "^\"\\|\"$" "" (car (split-string result "[\r\n]+" t)))))
(defun org-mac-chrome-get-frontmost-url ()
(interactive)
@@ -392,57 +402,45 @@ applications and inserting them in org documents"
;; Grab the frontmost url from Safari.
(defun org-as-mac-safari-get-frontmost-url ()
- (let ((result (do-applescript
- (concat
- "tell application \"Safari\"\n"
- " set theUrl to URL of document 1\n"
- " set theName to the name of the document 1\n"
- " return theUrl & \"::split::\" & theName & \"\n\"\n"
- "end tell\n"))))
- (car (split-string result "[\r\n]+" t))))
+ (do-applescript
+ (concat
+ "tell application \"Safari\"\n"
+ " set theUrl to URL of document 1\n"
+ " set theName to the name of the document 1\n"
+ " return theUrl & \"::split::\" & theName & \"\n\"\n"
+ "end tell\n")))
(defun org-mac-safari-get-frontmost-url ()
(interactive)
(message "Applescript: Getting Safari url...")
- (let* ((url-and-title (org-as-mac-safari-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-safari-get-frontmost-url)))
(defun org-mac-safari-insert-frontmost-url ()
(interactive)
(insert (org-mac-safari-get-frontmost-url)))
-;;
-;;
;; Handle links from together.app
-;;
-;;
(org-add-link-type "x-together-item" 'org-mac-together-item-open)
(defun org-mac-together-item-open (uid)
- "Open the given uid, which is a reference to an item in Together"
+ "Open UID, which is a reference to an item in Together."
(shell-command (concat "open -a Together \"x-together-item:" uid "\"")))
(defun as-get-selected-together-items ()
(do-applescript
- (concat
- "tell application \"Together\"\n"
- " set theLinkList to {}\n"
- " set theSelection to selected items\n"
- " repeat with theItem in theSelection\n"
- " set theLink to (get item link of theItem) & \"::split::\" & (get name of theItem) & \"\n\"\n"
- " copy theLink to end of theLinkList\n"
- " end repeat\n"
- " return theLinkList as string\n"
- "end tell")))
+ (concat
+ "tell application \"Together\"\n"
+ " set theLinkList to {}\n"
+ " set theSelection to selected items\n"
+ " repeat with theItem in theSelection\n"
+ " set theLink to (get item link of theItem) & \"::split::\" & (get name of theItem) & \"\n\"\n"
+ " copy theLink to end of theLinkList\n"
+ " end repeat\n"
+ " return theLinkList as string\n"
+ "end tell")))
(defun org-mac-together-get-selected ()
(interactive)
@@ -452,26 +450,22 @@ applications and inserting them in org documents"
(defun org-mac-together-insert-selected ()
(interactive)
(insert (org-mac-together-get-selected)))
-
-;;
-;;
+
;; Handle links from Finder.app
-;;
-;;
(defun as-get-selected-finder-items ()
(do-applescript
- (concat
- "tell application \"Finder\"\n"
- " set theSelection to the selection\n"
- " set links to {}\n"
- " repeat with theItem in theSelection\n"
- " set theLink to \"file://\" & (POSIX path of (theItem as string)) & \"::split::\" & (get the name of theItem) & \"\n\"\n"
- " copy theLink to the end of links\n"
- " end repeat\n"
- " return links as string\n"
- "end tell\n")))
+ (concat
+ "tell application \"Finder\"\n"
+ " set theSelection to the selection\n"
+ " set links to {}\n"
+ " repeat with theItem in theSelection\n"
+ " set theLink to \"file://\" & (POSIX path of (theItem as string)) & \"::split::\" & (get the name of theItem) & \"\n\"\n"
+ " copy theLink to the end of links\n"
+ " end repeat\n"
+ " return links as string\n"
+ "end tell\n")))
(defun org-mac-finder-item-get-selected ()
(interactive)
@@ -483,30 +477,26 @@ applications and inserting them in org documents"
(insert (org-mac-finder-item-get-selected)))
-;;
-;;
;; Handle links from AddressBook.app
-;;
-;;
(org-add-link-type "addressbook" 'org-mac-addressbook-item-open)
(defun org-mac-addressbook-item-open (uid)
- "Open the given uid, which is a reference to an item in Together"
+ "Open UID, which is a reference to an item in the addressbook."
(shell-command (concat "open \"addressbook:" uid "\"")))
(defun as-get-selected-addressbook-items ()
(do-applescript
- (concat
- "tell application \"Address Book\"\n"
- " set theSelection to the selection\n"
- " set links to {}\n"
- " repeat with theItem in theSelection\n"
- " set theLink to \"addressbook://\" & (the id of theItem) & \"::split::\" & (the name of theItem) & \"\n\"\n"
- " copy theLink to the end of links\n"
- " end repeat\n"
- " return links as string\n"
- "end tell\n")))
+ (concat
+ "tell application \"Address Book\"\n"
+ " set theSelection to the selection\n"
+ " set links to {}\n"
+ " repeat with theItem in theSelection\n"
+ " set theLink to \"addressbook://\" & (the id of theItem) & \"::split::\" & (the name of theItem) & \"\n\"\n"
+ " copy theLink to the end of links\n"
+ " end repeat\n"
+ " return links as string\n"
+ "end tell\n")))
(defun org-mac-addressbook-item-get-selected ()
(interactive)
@@ -517,8 +507,7 @@ applications and inserting them in org documents"
(interactive)
(insert (org-mac-addressbook-item-get-selected)))
-;;
-;;
+
;; Handle links from Skim.app
;;
;; Original code & idea by Christopher Suckling (org-mac-protocol)
@@ -531,40 +520,39 @@ applications and inserting them in org documents"
(match-string 1 uri)))
(document (substring uri 0 (match-beginning 0))))
(do-applescript
- (concat
- "tell application \"Skim\"\n"
- "activate\n"
- "set theDoc to \"" document "\"\n"
- "set thePage to " page "\n"
- "open theDoc\n"
- "go document 1 to page thePage of document 1\n"
- "end tell"))))
-
+ (concat
+ "tell application \"Skim\"\n"
+ "activate\n"
+ "set theDoc to \"" document "\"\n"
+ "set thePage to " page "\n"
+ "open theDoc\n"
+ "go document 1 to page thePage of document 1\n"
+ "end tell"))))
(defun as-get-skim-page-link ()
(do-applescript
+ (concat
+ "tell application \"Skim\"\n"
+ "set theDoc to front document\n"
+ "set theTitle to (name of theDoc)\n"
+ "set thePath to (path of theDoc)\n"
+ "set thePage to (get index for current page of theDoc)\n"
+ "set theSelection to selection of theDoc\n"
+ "set theContent to contents of (get text for theSelection)\n"
+ "if theContent is missing value then\n"
+ " set theContent to theTitle & \", p. \" & thePage\n"
+ (when org-mac-Skim-highlight-selection-p
(concat
- "tell application \"Skim\"\n"
- "set theDoc to front document\n"
- "set theTitle to (name of theDoc)\n"
- "set thePath to (path of theDoc)\n"
- "set thePage to (get index for current page of theDoc)\n"
- "set theSelection to selection of theDoc\n"
- "set theContent to contents of (get text for theSelection)\n"
- "if theContent is missing value then\n"
- " set theContent to theTitle & \", p. \" & thePage\n"
- (when org-mac-Skim-highlight-selection-p
- (concat
- "else\n"
- " tell theDoc\n"
- " set theNote to make note with properties {type:highlight note, selection:theSelection}\n"
- " set text of theNote to (get text for theSelection)\n"
- " end tell\n"))
- "end if\n"
- "set theLink to \"skim://\" & thePath & \"::\" & thePage & "
- "\"::split::\" & theContent\n"
- "end tell\n"
- "return theLink as string\n")))
+ "else\n"
+ " tell theDoc\n"
+ " set theNote to make note with properties {type:highlight note, selection:theSelection}\n"
+ " set text of theNote to (get text for theSelection)\n"
+ " end tell\n"))
+ "end if\n"
+ "set theLink to \"skim://\" & thePath & \"::\" & thePage & "
+ "\"::split::\" & theContent\n"
+ "end tell\n"
+ "return theLink as string\n")))
(defun org-mac-skim-get-page ()
(interactive)
@@ -583,29 +571,25 @@ applications and inserting them in org documents"
(interactive)
(insert (org-mac-skim-get-page)))
-
-;;
-;;
;; Handle links from Microsoft Outlook.app
-;;
(org-add-link-type "mac-outlook" 'org-mac-outlook-message-open)
(defun org-mac-outlook-message-open (msgid)
- "Open a message in outlook"
- (let* ((record-id-string (format "mdfind com_microsoft_outlook_recordID==%s" msgid))
- (found-message (replace-regexp-in-string "\n$" ""
- (shell-command-to-string record-id-string))))
- (if (string= found-message "")
- (message "org-mac-link: error could not find Outlook message %s" (substring-no-properties msgid))
- (shell-command (format "open \"`mdfind com_microsoft_outlook_recordID==%s`\"" msgid)))))
+ "Open a message in Outlook"
+ (do-applescript
+ (concat
+ "tell application \"/Applications/Microsoft Office 2011/Microsoft Outlook.app\"\n"
+ (format "open message id %s\n" (substring-no-properties msgid))
+ "activate\n"
+ "end tell")))
(defun org-as-get-selected-outlook-mail ()
"AppleScript to create links to selected messages in Microsoft Outlook.app."
(do-applescript
(concat
- "tell application \"Microsoft Outlook\"\n"
+ "tell application \"/Applications/Microsoft Office 2011/Microsoft Outlook.app\"\n"
"set msgCount to count current messages\n"
"if (msgCount < 1) then\n"
"return\n"
@@ -680,16 +664,18 @@ The Org-syntax text will be pushed to the kill ring, and also returned."
(defun org-mac-outlook-message-insert-selected ()
"Insert a link to the messages currently selected in Microsoft Outlook.app.
-This will use AppleScript to get the message-id and the subject of the
-active mail in Microsoft Outlook.app and make a link out of it."
+This will use AppleScript to get the message-id and the subject
+of the active mail in Microsoft Outlook.app and make a link out
+of it."
(interactive)
(insert (org-mac-outlook-message-get-links "s")))
(defun org-mac-outlook-message-insert-flagged (org-buffer org-heading)
"Asks for an org buffer and a heading within it, and replace message links.
-If heading exists, delete all mac-outlook:// links within heading's first
-level. If heading doesn't exist, create it at point-max. Insert
-list of mac-outlook:// links to flagged mail after heading."
+If heading exists, delete all mac-outlook:// links within
+heading's first level. If heading doesn't exist, create it at
+point-max. Insert list of mac-outlook:// links to flagged mail
+after heading."
(interactive "bBuffer in which to insert links: \nsHeading after which to insert links: ")
(with-current-buffer org-buffer
(goto-char (point-min))
@@ -710,17 +696,78 @@ list of mac-outlook:// links to flagged mail after heading."
(org-insert-heading nil t)
(insert org-heading "\n" (org-mac-outlook-message-get-links "f"))))))
+
+;; Handle links from DEVONthink Pro Office.app
+
+(org-add-link-type "x-devonthink-item" 'org-devonthink-item-open)
+
+(defun org-devonthink-item-open (uid)
+ "Open UID, which is a reference to an item in DEVONthink Pro Office."
+ (shell-command (concat "open \"x-devonthink-item:" uid "\"")))
+
+(defun org-as-get-selected-devonthink-item ()
+ "AppleScript to create links to selected items in DEVONthink Pro Office.app."
+ (do-applescript
+ (concat
+ "set theLinkList to {}\n"
+ "tell application \"DEVONthink Pro\"\n"
+ "set selectedRecords to selection\n"
+ "set selectionCount to count of selectedRecords\n"
+ "if (selectionCount < 1) then\n"
+ "return\n"
+ "end if\n"
+ "repeat with theRecord in selectedRecords\n"
+ "set theID to uuid of theRecord\n"
+ "set theURL to \"x-devonthink-item:\" & theID\n"
+ "set theSubject to name of theRecord\n"
+ "set theLink to theURL & \"::split::\" & theSubject & \"\n\"\n"
+ "copy theLink to end of theLinkList\n"
+ "end repeat\n"
+ "end tell\n"
+ "return theLinkList as string"
+ )))
+
+(defun org-mac-devonthink-get-links ()
+ "Create links to the item(s) currently selected in DEVONthink Pro Office.
+This will use AppleScript to get the `uuid' and the `name' of the
+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"))))
+
+(defun org-mac-devonthink-item-insert-selected ()
+ "Insert a link to the item(s) currently selected in DEVONthink Pro Office.
+This will use AppleScript to get the `uuid'(s) and the name(s) of the
+selected items in DEVONthink Pro Office and make link(s) out of it/them."
+ (interactive)
+ (insert (org-mac-devonthink-get-links)))
-;;
-;;
;; Handle links from Mail.app
-;;
(org-add-link-type "message" 'org-mac-message-open)
(defun org-mac-message-open (message-id)
- "Visit the message with the given MESSAGE-ID.
+ "Visit the message with MESSAGE-ID.
This will use the command `open' with the message URL."
(start-process (concat "open message:" message-id) nil
"open" (concat "message://<" (substring message-id 2) ">")))
@@ -728,67 +775,43 @@ This will use the command `open' with the message URL."
(defun org-as-get-selected-mail ()
"AppleScript to create links to selected messages in Mail.app."
(do-applescript
- (concat
- "tell application \"Mail\"\n"
- "set theLinkList to {}\n"
- "set theSelection to selection\n"
- "repeat with theMessage in theSelection\n"
- "set theID to message id of theMessage\n"
- "set theSubject to subject of theMessage\n"
- "set theLink to \"message://\" & theID & \"::split::\" & theSubject & \"\n\"\n"
- "copy theLink to end of theLinkList\n"
- "end repeat\n"
- "return theLinkList as string\n"
- "end tell")))
+ (concat
+ "tell application \"Mail\"\n"
+ "set theLinkList to {}\n"
+ "set theSelection to selection\n"
+ "repeat with theMessage in theSelection\n"
+ "set theID to message id of theMessage\n"
+ "set theSubject to subject of theMessage\n"
+ "set theLink to \"message://\" & theID & \"::split::\" & theSubject\n"
+ "if (theLinkList is not equal to {}) then\n"
+ "set theLink to \"\n\" & theLink\n"
+ "end if\n"
+ "copy theLink to end of theLinkList\n"
+ "end repeat\n"
+ "return theLinkList as string\n"
+ "end tell")))
(defun org-as-get-flagged-mail ()
"AppleScript to create links to flagged messages in Mail.app."
+ (unless org-mac-mail-account
+ (error "You must set org-mac-mail-account"))
(do-applescript
- (concat
- ;; Is Growl installed?
- "tell application \"System Events\"\n"
- "set growlHelpers to the name of every process whose creator type contains \"GRRR\"\n"
- "if (count of growlHelpers) > 0 then\n"
- "set growlHelperApp to item 1 of growlHelpers\n"
- "else\n"
- "set growlHelperApp to \"\"\n"
- "end if\n"
- "end tell\n"
-
- ;; Get links
- "tell application \"Mail\"\n"
- "set theMailboxes to every mailbox of account \"" org-mac-mail-account "\"\n"
- "set theLinkList to {}\n"
- "repeat with aMailbox in theMailboxes\n"
- "set theSelection to (every message in aMailbox whose flagged status = true)\n"
- "repeat with theMessage in theSelection\n"
- "set theID to message id of theMessage\n"
- "set theSubject to subject of theMessage\n"
- "set theLink to \"message://\" & theID & \"::split::\" & theSubject & \"\n\"\n"
- "copy theLink to end of theLinkList\n"
-
- ;; Report progress through Growl
- ;; This "double tell" idiom is described in detail at
- ;; http://macscripter.net/viewtopic.php?id=24570 The
- ;; script compiler needs static knowledge of the
- ;; growlHelperApp. Hmm, since we're compiling
- ;; on-the-fly here, this is likely to be way less
- ;; portable than I'd hoped. It'll work when the name
- ;; is still "GrowlHelperApp", though.
- "if growlHelperApp is not \"\" then\n"
- "tell application \"GrowlHelperApp\"\n"
- "tell application growlHelperApp\n"
- "set the allNotificationsList to {\"FlaggedMail\"}\n"
- "set the enabledNotificationsList to allNotificationsList\n"
- "register as application \"FlaggedMail\" all notifications allNotificationsList default notifications enabledNotificationsList icon of application \"Mail\"\n"
- "notify with name \"FlaggedMail\" title \"Importing flagged message\" description theSubject application name \"FlaggedMail\"\n"
- "end tell\n"
- "end tell\n"
- "end if\n"
- "end repeat\n"
- "end repeat\n"
- "return theLinkList as string\n"
- "end tell")))
+ (concat
+ ;; Get links
+ "tell application \"Mail\"\n"
+ "set theMailboxes to every mailbox of account \"" org-mac-mail-account "\"\n"
+ "set theLinkList to {}\n"
+ "repeat with aMailbox in theMailboxes\n"
+ "set theSelection to (every message in aMailbox whose flagged status = true)\n"
+ "repeat with theMessage in theSelection\n"
+ "set theID to message id of theMessage\n"
+ "set theSubject to subject of theMessage\n"
+ "set theLink to \"message://\" & theID & \"::split::\" & theSubject & \"\n\"\n"
+ "copy theLink to end of theLinkList\n"
+ "end repeat\n"
+ "end repeat\n"
+ "return theLinkList as string\n"
+ "end tell")))
(defun org-mac-message-get-links (&optional select-or-flag)
"Create links to the messages currently selected or flagged in Mail.app.
@@ -800,27 +823,11 @@ The Org-syntax text will be pushed to the kill ring, and also returned."
(interactive "sLink to (s)elected or (f)lagged messages: ")
(setq select-or-flag (or select-or-flag "s"))
(message "AppleScript: searching mailboxes...")
- (let* ((as-link-list
- (if (string= select-or-flag "s")
- (org-as-get-selected-mail)
- (if (string= select-or-flag "f")
- (org-as-get-flagged-mail)
- (error "Please select \"s\" or \"f\""))))
- (link-list
- (mapcar
- (lambda (x) (if (string-match "\\`\"\\(.*\\)\"\\'" x) (setq x (match-string 1 x))) x)
- (split-string as-link-list "[\r\n]+")))
- split-link URL description orglink orglink-insert rtn orglink-list)
- (while link-list
- (setq split-link (split-string (pop link-list) "::split::"))
- (setq URL (car split-link))
- (setq description (cadr split-link))
- (when (not (string= URL ""))
- (setq orglink (org-make-link-string URL description))
- (push orglink orglink-list)))
- (setq rtn (mapconcat 'identity orglink-list "\n"))
- (kill-new rtn)
- rtn))
+ (org-mac-paste-applescript-links
+ (cond
+ ((string= select-or-flag "s") (org-as-get-selected-mail))
+ ((string= select-or-flag "f") (org-as-get-flagged-mail))
+ (t (error "Please select \"s\" or \"f\"")))))
(defun org-mac-message-insert-selected ()
"Insert a link to the messages currently selected in Mail.app.
@@ -851,11 +858,11 @@ list of message:// links to flagged mail after heading."
(delete-region (match-beginning 0) (match-end 0)))
(insert "\n" (org-mac-message-get-links "f")))
(flush-lines "^$" (point) (outline-next-heading)))
- (insert "\n" (org-mac-message-get-links "f")))
- (goto-char (point-max))
- (insert "\n")
- (org-insert-heading nil t)
- (insert org-heading "\n" (org-mac-message-get-links "f"))))))
+ (insert "\n" (org-mac-message-get-links "f")))
+ (goto-char (point-max))
+ (insert "\n")
+ (org-insert-heading nil t)
+ (insert org-heading "\n" (org-mac-message-get-links "f"))))))
(provide 'org-mac-link)
diff --git a/contrib/lisp/org-mew.el b/contrib/lisp/org-mew.el
index 4482375..eb0afc0 100644
--- a/contrib/lisp/org-mew.el
+++ b/contrib/lisp/org-mew.el
@@ -308,7 +308,7 @@ the subject and the group number to extract. You can get rid of
org-mew-subject-alist))
(setq id-list (cons subject id-list)))
(cond ((null id-list)
- (error "No message ID to search."))
+ (error "No message ID to search"))
((equal (length id-list) 1)
(org-search-view nil (car id-list)))
(t
@@ -342,7 +342,7 @@ asks you to select the capture template."
(mew-message-goto-summary))
(let ((mew-mark-afterstep-spec '((?o 0 0 0 0 0 0 0))))
(mew-summary-refile)))
- (error "No refile folder selected."))
+ (error "No refile folder selected"))
(let* ((org-mew-link-to-refile-destination t)
(folder-name (org-mew-folder-name))
(keys (if arg
diff --git a/contrib/lisp/org-mime.el b/contrib/lisp/org-mime.el
index 44bf91b..078ebef 100644
--- a/contrib/lisp/org-mime.el
+++ b/contrib/lisp/org-mime.el
@@ -1,6 +1,6 @@
;;; org-mime.el --- org html export for text/html MIME emails
-;; Copyright (C) 2010-2014 Eric Schulte
+;; Copyright (C) 2010-2015 Eric Schulte
;; Author: Eric Schulte
;; Keywords: mime, mail, email, html
@@ -111,7 +111,7 @@
;; example hook, for setting a dark background in <pre style="background-color: #EEE;"> elements
(defun org-mime-change-element-style (element style)
"Set new default htlm style for <ELEMENT> elements in exported html."
- (while (re-search-forward (format "<%s" element) nil t)
+ (while (re-search-forward (format "<%s\\>" element) nil t)
(replace-match (format "<%s style=\"%s\"" element style))))
(defun org-mime-change-class-style (class style)
@@ -194,10 +194,10 @@ and images in a multipart/related part."
str)
html-images)))
-(defun org-mime-htmlize (arg)
- "Export a portion of an email body composed using `mml-mode' to
-html using `org-mode'. If called with an active region only
-export that region, otherwise export the entire body."
+(defun org-mime-htmlize (&optional arg)
+ "Export to HTML an email body composed using `mml-mode'.
+If called with an active region only export that region,
+otherwise export the entire body."
(interactive "P")
(require 'ox-org)
(require 'ox-html)
@@ -252,22 +252,22 @@ export that region, otherwise export the entire body."
(save-restriction
(org-narrow-to-subtree)
(run-hooks 'org-mime-send-subtree-hook)
- (flet ((mp (p) (org-entry-get nil p org-mime-use-property-inheritance)))
- (let* ((file (buffer-file-name (current-buffer)))
- (subject (or (mp "MAIL_SUBJECT") (nth 4 (org-heading-components))))
- (to (mp "MAIL_TO"))
- (cc (mp "MAIL_CC"))
- (bcc (mp "MAIL_BCC"))
- (body (buffer-substring
- (save-excursion (goto-char (point-min))
- (forward-line 1)
- (when (looking-at "[ \t]*:PROPERTIES:")
- (re-search-forward ":END:" nil)
- (forward-char))
- (point))
- (point-max))))
- (org-mime-compose body (or fmt 'org) file to subject
- `((cc . ,cc) (bcc . ,bcc)))))))
+ (let* ((mp (lambda (p) (org-entry-get nil p org-mime-use-property-inheritance)))
+ (file (buffer-file-name (current-buffer)))
+ (subject (or (funcall mp "MAIL_SUBJECT") (nth 4 (org-heading-components))))
+ (to (funcall mp "MAIL_TO"))
+ (cc (funcall mp "MAIL_CC"))
+ (bcc (funcall mp "MAIL_BCC"))
+ (body (buffer-substring
+ (save-excursion (goto-char (point-min))
+ (forward-line 1)
+ (when (looking-at "[ \t]*:PROPERTIES:")
+ (re-search-forward ":END:" nil)
+ (forward-char))
+ (point))
+ (point-max))))
+ (org-mime-compose body (or fmt 'org) file to subject
+ `((cc . ,cc) (bcc . ,bcc))))))
(defun org-mime-send-buffer (&optional fmt)
(run-hooks 'org-mime-send-buffer-hook)
@@ -287,45 +287,46 @@ export that region, otherwise export the entire body."
(require 'message)
(message-mail to subject headers nil)
(message-goto-body)
- (flet ((bhook (body fmt)
- (let ((hook (intern (concat "org-mime-pre-"
- (symbol-name fmt)
- "-hook"))))
- (if (> (eval `(length ,hook)) 0)
- (with-temp-buffer
- (insert body)
- (goto-char (point-min))
- (eval `(run-hooks ',hook))
- (buffer-string))
- body))))
- (let ((fmt (if (symbolp fmt) fmt (intern fmt))))
- (cond
- ((eq fmt 'org)
- (require 'ox-org)
- (insert (org-export-string-as
- (org-babel-trim (bhook body 'org)) 'org t)))
- ((eq fmt 'ascii)
- (require 'ox-ascii)
- (insert (org-export-string-as
- (concat "#+Title:\n" (bhook body 'ascii)) 'ascii t)))
- ((or (eq fmt 'html) (eq fmt 'html-ascii))
- (require 'ox-ascii)
- (require 'ox-org)
- (let* ((org-link-file-path-type 'absolute)
- ;; we probably don't want to export a huge style file
- (org-export-htmlize-output-type 'inline-css)
- (html-and-images
- (org-mime-replace-images
- (org-export-string-as (bhook body 'html) 'html t) file))
- (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
- (bhook body (if (eq fmt 'html) 'org 'ascii)))
- (if (eq fmt 'html) 'org 'ascii) t)
- html)
- (mapconcat 'identity images "\n"))))))))
+ (let ((bhook
+ (lambda (body fmt)
+ (let ((hook (intern (concat "org-mime-pre-"
+ (symbol-name fmt)
+ "-hook"))))
+ (if (> (eval `(length ,hook)) 0)
+ (with-temp-buffer
+ (insert body)
+ (goto-char (point-min))
+ (eval `(run-hooks ',hook))
+ (buffer-string))
+ body))))
+ (fmt (if (symbolp fmt) fmt (intern fmt))))
+ (cond
+ ((eq fmt 'org)
+ (require 'ox-org)
+ (insert (org-export-string-as
+ (org-babel-trim (funcall bhook body 'org)) 'org t)))
+ ((eq fmt 'ascii)
+ (require 'ox-ascii)
+ (insert (org-export-string-as
+ (concat "#+Title:\n" (funcall bhook body 'ascii)) 'ascii t)))
+ ((or (eq fmt 'html) (eq fmt 'html-ascii))
+ (require 'ox-ascii)
+ (require 'ox-org)
+ (let* ((org-link-file-path-type 'absolute)
+ ;; we probably don't want to export a huge style file
+ (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))
+ (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
+ (funcall bhook body (if (eq fmt 'html) 'org 'ascii)))
+ (if (eq fmt 'html) 'org 'ascii) t)
+ html)
+ (mapconcat 'identity images "\n")))))))
(defun org-mime-org-buffer-htmlize ()
"Create an email buffer containing the current org-mode file
diff --git a/contrib/lisp/org-mtags.el b/contrib/lisp/org-mtags.el
deleted file mode 100644
index 5342184..0000000
--- a/contrib/lisp/org-mtags.el
+++ /dev/null
@@ -1,255 +0,0 @@
-;;; org-mtags.el --- Muse-like tags in Org-mode
-
-;; Copyright (C) 2008-2014 Free Software Foundation, Inc.
-;;
-;; Author: Carsten Dominik <carsten at orgmode dot org>
-;; Keywords: outlines, hypermedia, calendar, wp
-;; Homepage: http://orgmode.org
-;; Version: 0.01
-;;
-;; This file is not yet 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, 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:
-;;
-;; This modules implements some of the formatting tags available in
-;; Emacs Muse. This is not a way if adding new functionality, but just
-;; a different way to write some formatting directives. The advantage is
-;; that files written in this way can be read by Muse reasonably well,
-;; and that this provides an alternative way of writing formatting
-;; directives in Org, a way that some might find more pleasant to type
-;; and look at that the Org's #+BEGIN..#+END notation.
-
-;; The goal of this development is to make it easier for people to
-;; move between both worlds as they see fit for different tasks.
-
-;; The following muse tags will be translated during export into their
-;; native Org equivalents:
-;;
-;; <br>
-;; Needs to be at the end of a line. Will be translated to "\\".
-;;
-;; <example switches="-n -r">
-;; Needs to be on a line by itself, similarly the </example> tag.
-;; Will be translated into Org's #+BEGIN_EXAMPLE construct.
-;;
-;; <quote>
-;; Needs to be on a line by itself, similarly the </quote> tag.
-;; Will be translated into Org's #+BEGIN_QUOTE construct.
-;;
-;; <comment>
-;; Needs to be on a line by itself, similarly the </comment> tag.
-;; Will be translated into Org's #+BEGIN_COMMENT construct.
-;;
-;; <verse>
-;; Needs to be on a line by itself, similarly the </verse> tag.
-;; Will be translated into Org's #+BEGIN_VERSE construct.
-;;
-;; <contents>
-;; This gets translated into "[TABLE-OF-CONTENTS]". It will not
-;; trigger the production of a table of contents - that is done
-;; in Org with the "#+OPTIONS: toc:t" setting. But it will define
-;; the location where the TOC will be placed.
-;;
-;; <literal style="STYLE"> ;; only latex, html, and docbook supported
-;; in Org.
-;; Needs to be on a line by itself, similarly the </literal> tag.
-;;
-;; <src lang="LANG" switches="-n -r">
-;; Needs to be on a line by itself, similarly the </src> tag.
-;; Will be translated into Org's BEGIN_SRC construct.
-;;
-;; <include file="FILE" markup="MARKUP" lang="LANG"
-;; prefix="str" prefix1="str" switches="-n -r">
-;; Needs to be on a line by itself.
-;; Will be translated into Org's #+INCLUDE construct.
-;;
-;; The lisp/perl/ruby/python tags can be implemented using the
-;; `org-eval.el' module, which see.
-
-(require 'org)
-
-;;; Customization
-
-(defgroup org-mtags nil
- "Options concerning Muse tags in Org mode."
- :tag "Org Muse Tags"
- :group 'org)
-
-(defface org-mtags ; similar to shadow
- (org-compatible-face 'shadow
- '((((class color grayscale) (min-colors 88) (background light))
- (:foreground "grey50"))
- (((class color grayscale) (min-colors 88) (background dark))
- (:foreground "grey70"))
- (((class color) (min-colors 8) (background light))
- (:foreground "green"))
- (((class color) (min-colors 8) (background dark))
- (:foreground "yellow"))))
- "Face for Muse-like tags in Org."
- :group 'org-mtags
- :group 'org-faces)
-
-(defcustom org-mtags-prefer-muse-templates t
- "Non-nil means prefere Muse tags for structure elements.
-This is relevane when expanding the templates defined in the variable
-`org-structure-templates'."
- :group 'org-mtags
- :type 'boolean)
-
-(defconst org-mtags-supported-tags
- '("example" "quote" "comment" "verse" "contents" "literal" "src" "include")
- "The tags that are supported by org-mtags.el for conversion.
-In addition to this list, the <br> tag is supported as well.")
-
-(defconst org-mtags-fontification-re
- (concat
- "^[ \t]*</?\\("
- (mapconcat 'identity org-mtags-supported-tags "\\|")
- "\\)\\>[^>]*>\\|<br>[ \t]*$")
- "Regular expression used for fontifying muse tags.")
-
-(defun org-mtags-replace ()
- "Replace Muse-like tags with the appropriate Org constructs.
-The is done in the entire buffer."
- (interactive) ;; FIXME
- (let ((re (concat "^[ \t]*\\(</?\\("
- (mapconcat 'identity org-mtags-supported-tags "\\|")
- "\\)\\>\\)"))
- info tag rpl style markup lang file prefix prefix1 switches)
- ;; First, do the <br> tag
- (goto-char (point-min))
- (while (re-search-forward "<br>[ \t]*$" nil t)
- (replace-match "\\\\" t t))
- ;; Now, all the other tags
- (goto-char (point-min))
- (while (re-search-forward re nil t)
- (goto-char (match-beginning 1))
- (setq info (org-mtags-get-tag-and-attributes))
- (if (not info)
- (end-of-line 1)
- (setq tag (plist-get info :tag))
- (cond
- ((equal tag "contents")
- (setq rpl "[TABLE-OF-CONTENTS]")
- ;; FIXME: also trigger TOC in options-plist?????
- )
- ((member tag '("quote" "comment" "verse"))
- (if (plist-get info :closing)
- (setq rpl (format "#+END_%s" (upcase tag)))
- (setq rpl (format "#+BEGIN_%s" (upcase tag)))))
- ((equal tag "literal")
- (setq style (plist-get info :style))
- (and style (setq style (downcase style)))
- (if (plist-get info :closing)
- (setq rpl (cond
- ((member style '("latex"))
- "#+END_LaTeX")
- ((member style '("html"))
- "#+END_HTML")
- ((member style '("docbook"))
- "#+END_DOCBOOK")
- ((member style '("ascii"))
- "#+END_ASCII")))
- (setq rpl (cond
- ((member style '("latex"))
- "#+BEGIN_LaTeX")
- ((member style '("html"))
- "#+BEGIN_HTML")
- ((member style '("ascii"))
- "#+BEGIN_ASCII")))))
- ((equal tag "example")
- (if (plist-get info :closing)
- (setq rpl "#+END_EXAMPLE")
- (setq rpl "#+BEGIN_EXAMPLE")
- (when (setq switches (plist-get info :switches))
- (setq rpl (concat rpl " " switches)))))
- ((equal tag "src")
- (if (plist-get info :closing)
- (setq rpl "#+END_SRC")
- (setq rpl "#+BEGIN_SRC")
- (when (setq lang (plist-get info :lang))
- (setq rpl (concat rpl " " lang))
- (when (setq switches (plist-get info :switches))
- (setq rpl (concat rpl " " switches))))))
- ((equal tag "include")
- (setq file (plist-get info :file)
- markup (downcase (plist-get info :markup))
- lang (plist-get info :lang)
- prefix (plist-get info :prefix)
- prefix1 (plist-get info :prefix1)
- switches (plist-get info :switches))
- (setq rpl "#+INCLUDE")
- (setq rpl (concat rpl " " (prin1-to-string file)))
- (when markup
- (setq rpl (concat rpl " " markup))
- (when (and (equal markup "src") lang)
- (setq rpl (concat rpl " " lang))))
- (when prefix
- (setq rpl (concat rpl " :prefix " (prin1-to-string prefix))))
- (when prefix1
- (setq rpl (concat rpl " :prefix1 " (prin1-to-string prefix1))))
- (when switches
- (setq rpl (concat rpl " " switches)))))
- (when rpl
- (goto-char (plist-get info :match-beginning))
- (delete-region (point-at-bol) (plist-get info :match-end))
- (insert rpl))))))
-
-(defun org-mtags-get-tag-and-attributes ()
- "Parse a Muse-like tag at point ant rturn the information about it.
-The return value is a property list which contains all the attributes
-with string values. In addition, it reutnrs the following properties:
-
-:tag The tag as a string.
-:match-beginning The beginning of the match, just before \"<\".
-:match-end The end of the match, just after \">\".
-:closing t when the tag starts with \"</\"."
- (when (looking-at "<\\(/\\)?\\([a-zA-Z]+\\>\\)\\([^>]*\\)>")
- (let ((start 0)
- tag rest prop attributes endp val)
- (setq tag (org-match-string-no-properties 2)
- endp (match-end 1)
- rest (and (match-end 3)
- (org-match-string-no-properties 3))
- attributes (list :tag tag
- :match-beginning (match-beginning 0)
- :match-end (match-end 0)
- :closing endp))
- (when rest
- (while (string-match "\\([a-zA-Z]+\\)=\\([^ \t\n>]+\\|\"[^>]+\"\\)"
- rest start)
- (setq start (match-end 0)
- prop (org-match-string-no-properties 1 rest)
- val (org-remove-double-quotes
- (org-match-string-no-properties 2 rest)))
- (setq attributes (plist-put attributes
- (intern (concat ":" prop)) val))))
- attributes)))
-
-(defun org-mtags-fontify-tags (limit)
- "Fontify the muse-like tags."
- (while (re-search-forward org-mtags-fontification-re limit t)
- (add-text-properties (match-beginning 0) (match-end 0)
- '(face org-mtags font-lock-multiline t
- font-lock-fontified t))))
-
-(add-hook 'org-export-preprocess-hook 'org-mtags-replace)
-(add-hook 'org-font-lock-hook 'org-mtags-fontify-tags)
-
-(provide 'org-mtags)
-
-;;; org-mtags.el ends here
diff --git a/contrib/lisp/org-notmuch.el b/contrib/lisp/org-notmuch.el
index 2ab5c17..712ec5a 100644
--- a/contrib/lisp/org-notmuch.el
+++ b/contrib/lisp/org-notmuch.el
@@ -41,6 +41,29 @@
(require 'org)
+;; customisable notmuch open functions
+(defcustom org-notmuch-open-function
+ 'org-notmuch-follow-link
+ "Function used to follow notmuch links.
+
+Should accept a notmuch search string as the sole argument."
+ :group 'org-notmuch
+ :version "24.4"
+ :package-version '(Org . "8.0")
+ :type 'function)
+
+(defcustom org-notmuch-search-open-function
+ 'org-notmuch-search-follow-link
+ "Function used to follow notmuch-search links.
+
+Should accept a notmuch search string as the sole argument."
+ :group 'org-notmuch
+ :version "24.4"
+ :package-version '(Org . "8.0")
+ :type 'function)
+
+
+
;; Install the link type
(org-add-link-type "notmuch" 'org-notmuch-open)
(add-hook 'org-store-link-functions 'org-notmuch-store-link)
@@ -62,7 +85,7 @@
(defun org-notmuch-open (path)
"Follow a notmuch message link specified by PATH."
- (org-notmuch-follow-link path))
+ (funcall org-notmuch-open-function path))
(defun org-notmuch-follow-link (search)
"Follow a notmuch link to SEARCH.
@@ -90,14 +113,21 @@ Can link to more than one message, if so all matching messages are shown."
(defun org-notmuch-search-open (path)
"Follow a notmuch message link specified by PATH."
- (message path)
- (org-notmuch-search-follow-link path))
+ (message "%s" path)
+ (funcall org-notmuch-search-open-function path))
(defun org-notmuch-search-follow-link (search)
"Follow a notmuch link by displaying SEARCH in notmuch-search mode."
(require 'notmuch)
(notmuch-search (org-link-unescape search)))
+
+
+(defun org-notmuch-tree-follow-link (search)
+ "Follow a notmuch link by displaying SEARCH in notmuch-tree mode."
+ (require 'notmuch)
+ (notmuch-tree (org-link-unescape search)))
+
(provide 'org-notmuch)
;;; org-notmuch.el ends here
diff --git a/contrib/lisp/org-passwords.el b/contrib/lisp/org-passwords.el
new file mode 100644
index 0000000..4ebd5a6
--- /dev/null
+++ b/contrib/lisp/org-passwords.el
@@ -0,0 +1,384 @@
+;;; org-passwords.el --- org derived mode for managing passwords
+
+;; Author: Jorge A. Alfaro-Murillo <jorge.alfaro-murillo@yale.edu>
+;; Created: December 26, 2012
+;; Keywords: passwords, password
+
+;; 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:
+
+;; This file contains the code for managing your passwords with
+;; Org-mode. It is part of org/contrib (see http://orgmode.org/). If
+;; you want to contribute with development, or have a problem, do it
+;; here: https://bitbucket.org/alfaromurillo/org-passwords.el
+
+;; A basic setup needs to indicate a passwords file, and a dictionary
+;; for the random words:
+
+;; (require 'org-passwords)
+;; (setq org-passwords-file "~/documents/passwords.gpg")
+;; (setq org-passwords-random-words-dictionary "/etc/dictionaries-common/words")
+
+;; Basic usage:
+
+;; `M-x org-passwords' opens the passwords file in
+;; `org-passwords-mode'.
+
+;; `M-x org-passwords-generate-password' generates a random string
+;; of numbers, lowercase letters and uppercase letters.
+
+;; `C-u M-x org-passwords-generate-password' generates a random
+;; string of numbers, lowercase letters, uppercase letters and
+;; symbols.
+
+;; `M-x org-passwords-random-words' concatenates random words from
+;; the dictionary defined by `org-passwords-random-words-dictionary'
+;; into a string, each word separated by the string defined in
+;; `org-passwords-random-words-separator'.
+
+;; `C-u M-x org-passwords-random-words' does the same as above, and
+;; also makes substitutions according to
+;; `org-passwords-random-words-substitutions'.
+
+;; It is also useful to set up keybindings for the functions
+;; `org-passwords-copy-username', `org-passwords-copy-password' and
+;; `org-passwords-open-url' in the `org-passwords-mode', to easily
+;; make the passwords and usernames available to the facility for
+;; pasting text of the window system (clipboard on X and MS-Windows,
+;; pasteboard on Nextstep/Mac OS, etc.), without inserting them in the
+;; kill-ring. You can set for example:
+
+;; (eval-after-load "org-passwords"
+;; '(progn
+;; (define-key org-passwords-mode-map
+;; (kbd "C-c u")
+;; 'org-passwords-copy-username)
+;; (define-key org-passwords-mode-map
+;; (kbd "C-c p")
+;; 'org-passwords-copy-password)
+;; (kbd "C-c o")
+;; 'org-passwords-open-url)))
+
+;; Finally, to enter new passwords, you can use `org-capture' and a
+;; minimal template like:
+
+;; ("p" "password" entry (file "~/documents/passwords.gpg")
+;; "* %^{Title}\n %^{URL}p %^{USERNAME}p %^{PASSWORD}p")
+
+;; When asked for the password you can then call either
+;; `org-passwords-generate-password' or `org-passwords-random-words'.
+;; Be sure to enable recursive minibuffers to call those functions
+;; from the minibuffer:
+
+;; (setq enable-recursive-minibuffers t)
+
+;;; Code:
+
+(require 'org)
+
+;;;###autoload
+(define-derived-mode org-passwords-mode org-mode
+ "org-passwords-mode"
+ "Mode for storing passwords"
+ nil)
+
+(defgroup org-passwords nil
+ "Options for password management."
+ :group 'org)
+
+(defcustom org-passwords-password-property "PASSWORD"
+ "Name of the property for password entry."
+ :type 'string
+ :group 'org-passwords)
+
+(defcustom org-passwords-username-property "USERNAME"
+ "Name of the property for user name entry."
+ :type 'string
+ :group 'org-passwords)
+
+(defcustom org-passwords-url-property "URL"
+ "Name of the property for URL entry."
+ :type 'string
+ :group 'org-passwords)
+
+(defcustom org-passwords-file nil
+ "Default file name for the file that contains the passwords."
+ :type 'file
+ :group 'org-passwords)
+
+(defcustom org-passwords-time-opened "1 min"
+ "Time that the password file will remain open. It has to be a
+string, a number followed by units."
+ :type 'str
+ :group 'org-passwords)
+
+(defcustom org-passwords-default-password-size "20"
+ "Default number of characters to use in
+org-passwords-generate-password. It has to be a string."
+ :type 'str
+ :group 'org-passwords)
+
+(defcustom org-passwords-random-words-dictionary nil
+ "Default file name for the file that contains a dictionary of
+words for `org-passwords-random-words'. Each non-empty line in
+the file is considered a word."
+ :type 'file
+ :group 'org-passwords)
+
+(defcustom org-passwords-default-random-words-number "5"
+ "Default number of words to use in org-passwords-random-words.
+It has to be a string."
+ :type 'str
+ :group 'org-passwords)
+
+(defvar org-passwords-random-words-separator "-"
+ "A string to separate words in `org-passwords-random-words'.")
+
+(defvar org-passwords-random-words-substitutions
+ '(("a" . "@")
+ ("e" . "3")
+ ("o" . "0"))
+"A list of substitutions to be made with
+`org-passwords-random-words' if it is called with
+`universal-argument'. Each element is pair of
+strings (SUBSTITUTE-THIS . BY-THIS).")
+
+(defun org-passwords-copy-password ()
+ "Makes the password available to other programs. Puts the
+password of the entry at the location of the cursor in the
+facility for pasting text of the window system (clipboard on X
+and MS-Windows, pasteboard on Nextstep/Mac OS, etc.), without
+putting it in the kill ring."
+ (interactive)
+ (funcall interprogram-cut-function
+ (org-entry-get (point)
+ org-passwords-password-property)))
+
+(defun org-passwords-copy-username ()
+ "Makes the password available to other programs. Puts the
+username of the entry at the location of the cursor in the
+facility for pasting text of the window system (clipboard on X
+and MS-Windows, pasteboard on Nextstep/Mac OS, etc.), without
+putting it in the kill ring."
+ (interactive)
+ (funcall interprogram-cut-function
+ (org-entry-get (point)
+ org-passwords-username-property
+ t)))
+
+(defun org-passwords-open-url ()
+ "Browse the URL associated with the entry at the location of
+the cursor."
+ (interactive)
+ (browse-url (org-entry-get (point)
+ org-passwords-url-property
+ t)))
+
+;;;###autoload
+(defun org-passwords (&optional arg)
+ "Open the password file. Open the password file defined by the
+variable `org-password-file' in read-only mode and kill that
+buffer later according to the value of the variable
+`org-passwords-time-opened'. It also adds the `org-password-file'
+to the auto-mode-alist so that it is opened with its mode being
+`org-passwords-mode'.
+
+With prefix arg ARG, the command does not set up a timer to kill the buffer.
+
+With a double prefix arg \\[universal-argument] \\[universal-argument], open the file for editing.
+"
+ (interactive "P")
+ (if org-passwords-file
+ (progn
+ (add-to-list 'auto-mode-alist
+ (cons
+ (regexp-quote
+ (expand-file-name org-passwords-file))
+ 'org-passwords-mode))
+ (if (equal arg '(4))
+ (find-file-read-only org-passwords-file)
+ (if (equal arg '(16))
+ (find-file org-passwords-file)
+ (progn
+ (find-file-read-only org-passwords-file)
+ (org-passwords-set-up-kill-password-buffer)))))
+ (minibuffer-message "No default password file defined. Set the variable `org-password-file'.")))
+
+(defun org-passwords-set-up-kill-password-buffer ()
+ (run-at-time org-passwords-time-opened
+ nil
+ '(lambda ()
+ (if (get-file-buffer org-passwords-file)
+ (kill-buffer
+ (get-file-buffer org-passwords-file))))))
+
+;;; Password generator
+
+;; Set random number seed from current time and pid. Otherwise
+;; `random' gives the same results every time emacs restarts.
+(random t)
+
+(defun org-passwords-generate-password (arg)
+ "Ask a number of characters and insert a password of that size.
+Password has a random string of numbers, lowercase letters, and
+uppercase letters. Argument ARG include symbols."
+ (interactive "P")
+ (let ((number-of-chars
+ (read-from-minibuffer
+ (concat "Number of characters (default "
+ org-passwords-default-password-size
+ "): ")
+ nil
+ nil
+ t
+ nil
+ org-passwords-default-password-size)))
+ (if arg
+ (insert (org-passwords-generate-password-with-symbols "" number-of-chars))
+ (insert (org-passwords-generate-password-without-symbols "" number-of-chars)))))
+
+(defun org-passwords-generate-password-with-symbols (previous-string nums-of-chars)
+ "Return a string consisting of PREVIOUS-STRING and
+NUMS-OF-CHARS random characters."
+ (if (eq nums-of-chars 0) previous-string
+ (org-passwords-generate-password-with-symbols
+ (concat previous-string
+ (char-to-string
+ ;; symbols, letters, numbers are from 33 to 126
+ (+ (random (- 127 33)) 33)))
+ (1- nums-of-chars))))
+
+(defun org-passwords-generate-password-without-symbols (previous-string nums-of-chars)
+ "Return string consisting of PREVIOUS-STRING and NUMS-OF-CHARS
+random numbers, lowercase letters, and numbers."
+ (if (eq nums-of-chars 0)
+ previous-string
+ ; There are 10 numbers, 26 lowercase letters and 26 uppercase
+ ; letters. 10 + 26 + 26 = 62. The number characters go from 48
+ ; to 57, the uppercase letters from 65 to 90, and the lowercase
+ ; from 97 to 122. The following makes each equally likely.
+ (let ((temp-value (random 62)))
+ (cond ((< temp-value 10)
+ ; If temp-value<10, then add a number
+ (org-passwords-generate-password-without-symbols
+ (concat previous-string
+ (char-to-string (+ 48 temp-value)))
+ (1- nums-of-chars)))
+ ((and (> temp-value 9) (< temp-value 36))
+ ; If 9<temp-value<36, then add an uppercase letter
+ (org-passwords-generate-password-without-symbols
+ (concat previous-string
+ (char-to-string (+ 65 (- temp-value 10))))
+ (1- nums-of-chars)))
+ ((> temp-value 35)
+ ; If temp-value>35, then add a lowecase letter
+ (org-passwords-generate-password-without-symbols
+ (concat previous-string
+ (char-to-string (+ 97 (- temp-value 36))))
+ (1- nums-of-chars)))))))
+
+;;; Random words
+
+(defun org-passwords-random-words (arg)
+ "Ask for a number of words and inserts a sequence of that many
+random words from the list in the file
+`org-passwords-random-words-dictionary' separated by
+`org-passwords-random-words-separator'. ARG make substitutions in
+the words as defined by
+`org-passwords-random-words-substitutions'."
+ (interactive "P")
+ (if org-passwords-random-words-dictionary
+ (let ((number-of-words
+ (read-from-minibuffer
+ (concat "Number of words (default "
+ org-passwords-default-random-words-number
+ "): ")
+ nil
+ nil
+ t
+ nil
+ org-passwords-default-random-words-number))
+ (list-of-words
+ (with-temp-buffer
+ (insert-file-contents
+ org-passwords-random-words-dictionary)
+ (split-string (buffer-string) "\n" t))))
+ (insert
+ (org-passwords-substitute
+ (org-passwords-random-words-attach-number-of-words
+ (nth (random (length list-of-words))
+ list-of-words)
+ (1- number-of-words)
+ list-of-words
+ org-passwords-random-words-separator)
+ (if arg
+ org-passwords-random-words-substitutions
+ nil))))
+ (minibuffer-message
+ "No default dictionary file defined. Set the variable `org-passwords-random-words-dictionary'.")))
+
+(defun org-passwords-random-words-attach-number-of-words
+ (previous-string number-of-words list-of-words separator)
+ "Returns a string consisting of PREVIOUS-STRING followed by a
+succession of NUMBER-OF-WORDS random words from the list LIST-OF-WORDS
+separated SEPARATOR."
+ (if (eq number-of-words 0)
+ previous-string
+ (org-passwords-random-words-attach-number-of-words
+ (concat previous-string
+ separator
+ (nth (random (length list-of-words)) list-of-words))
+ (1- number-of-words)
+ list-of-words
+ separator)))
+
+(defun org-passwords-substitute (string-to-change list-of-substitutions)
+ "Substitutes each appearence in STRING-TO-CHANGE of the `car' of
+each element of LIST-OF-SUBSTITUTIONS by the `cdr' of that
+element. For example:
+ (org-passwords-substitute \"ab\" \'((\"a\" . \"b\") (\"b\" . \"c\")))
+ => \"bc\"
+Substitutions are made in order of the list, so for example:
+ (org-passwords-substitute \"ab\" \'((\"ab\" . \"c\") (\"b\" . \"d\")))
+ => \"c\""
+ (if list-of-substitutions
+ (concat (org-passwords-concat-this-with-string
+ (cdar list-of-substitutions)
+ (mapcar (lambda (x)
+ (org-passwords-substitute
+ x
+ (cdr list-of-substitutions)))
+ (split-string string-to-change
+ (caar list-of-substitutions)))))
+ string-to-change))
+
+(defun org-passwords-concat-this-with-string (this list-of-strings)
+ "Put the string THIS in between every string in LIST-OF-STRINGS. For example:
+ (org-passwords-concat-this-with-string \"Here\" \'(\"First\" \"Second\" \"Third\"))
+ => \"FirstHereSencondHereThird\""
+ (if (cdr list-of-strings)
+ (concat (car list-of-strings)
+ this
+ (org-passwords-concat-this-with-string
+ this
+ (cdr list-of-strings)))
+ (car list-of-strings)))
+
+(provide 'org-passwords)
+
+;;; org-passwords.el ends here
diff --git a/contrib/lisp/org-toc.el b/contrib/lisp/org-toc.el
index 255b79e..622cc02 100644
--- a/contrib/lisp/org-toc.el
+++ b/contrib/lisp/org-toc.el
@@ -338,7 +338,7 @@ If DELETE is non-nil, delete other windows when in the Org buffer."
(interactive)
(condition-case nil
(outline-forward-same-level 1)
- (error (message "No next headline at this level.")))
+ (error (message "No next headline at this level")))
(if org-toc-info-mode (org-toc-info))
(if org-toc-follow-mode (org-toc-goto)))
@@ -347,7 +347,7 @@ If DELETE is non-nil, delete other windows when in the Org buffer."
(interactive)
(condition-case nil
(outline-backward-same-level 1)
- (error (message "No previous headline at this level.")))
+ (error (message "No previous headline at this level")))
(if org-toc-info-mode (org-toc-info))
(if org-toc-follow-mode (org-toc-goto)))
diff --git a/contrib/lisp/org-velocity.el b/contrib/lisp/org-velocity.el
index 3631a59..a7820f1 100644
--- a/contrib/lisp/org-velocity.el
+++ b/contrib/lisp/org-velocity.el
@@ -1,10 +1,10 @@
-;;; org-velocity.el --- something like Notational Velocity for Org.
+;;; org-velocity.el --- something like Notational Velocity for Org. -*- lexical-binding: t -*-
;; Copyright (C) 2010-2014 Paul M. Rodriguez
;; Author: Paul M. Rodriguez <paulmrodriguez@gmail.com>
;; Created: 2010-05-05
-;; Version: 3.0
+;; Version: 4.0
;; This file is not part of GNU Emacs.
@@ -64,7 +64,7 @@
(require 'button)
(require 'electric)
(require 'dabbrev)
-(eval-when-compile (require 'cl))
+(require 'cl-lib)
(defgroup org-velocity nil
"Notational Velocity-style interface for Org."
@@ -133,9 +133,9 @@ file."
"Match on whole phrase, any word, or all words?"
:group 'org-velocity
:type '(choice
- (const :tag "Match whole phrase" phrase)
- (const :tag "Match any word" any)
- (const :tag "Match all words" all)
+ (const :tag "Match whole phrase" phrase)
+ (const :tag "Match any word" any)
+ (const :tag "Match all words" all)
(const :tag "Match a regular expression" regexp))
:safe (lambda (v) (memq v '(phrase any all regexp))))
@@ -152,6 +152,17 @@ See the documentation for `org-capture-templates'."
:group 'org-velocity
:type (or (get 'org-capture-templates 'custom-type) 'list))
+(defcustom org-velocity-heading-level 1
+ "Only match headings at this level or higher.
+0 means to match headings at any level."
+ :group 'org-velocity
+ :type 'integer
+ :safe (lambda (x)
+ (and (integerp x)
+ (>= x 0))))
+
+(defvar crm-separator) ;Ensure dynamic binding.
+
(defsubst org-velocity-grab-preview ()
"Grab preview of a subtree.
The length of the preview is determined by `window-width'.
@@ -172,14 +183,14 @@ Replace all contiguous whitespace with single spaces."
(point-max))))
" ")))
-(defstruct org-velocity-heading buffer position name level preview)
+(cl-defstruct org-velocity-heading buffer position name level preview)
(defsubst org-velocity-nearest-heading (position)
"Return last heading at POSITION.
If there is no last heading, return nil."
(save-excursion
(goto-char position)
- (re-search-backward org-velocity-heading-regexp)
+ (re-search-backward (org-velocity-heading-regexp))
(let ((components (org-heading-components)))
(make-org-velocity-heading
:buffer (current-buffer)
@@ -191,15 +202,18 @@ If there is no last heading, return nil."
(defconst org-velocity-index
(eval-when-compile
- (nconc (number-sequence 49 57) ;numbers
+ (nconc (number-sequence 49 57) ;numbers
(number-sequence 97 122) ;lowercase letters
(number-sequence 65 90))) ;uppercase letters
"List of chars for indexing results.")
(defconst org-velocity-match-buffer-name "*Velocity matches*")
-(defconst org-velocity-heading-regexp "^\\* "
- "Regexp to match only top-level headings.")
+(cl-defun org-velocity-heading-regexp (&optional (level org-velocity-heading-level))
+ "Regexp to match headings at LEVEL or deeper."
+ (if (zerop level)
+ "^\\*+ "
+ (format "^\\*\\{1,%d\\} " level)))
(defvar org-velocity-search nil
"Variable to bind to current search.")
@@ -223,12 +237,6 @@ of the base buffer; in the latter, return the file name of
(with-current-buffer (window-buffer (active-minibuffer-window))
(minibuffer-contents))))
-(defsubst org-velocity-singlep (object)
- "Return t when OBJECT is a list or sequence of one element."
- (if (consp object)
- (null (cdr object))
- (= (length object) 1)))
-
(defun org-velocity-bucket-file ()
"Return the proper file for Org-Velocity to search.
If `org-velocity-always-use-bucket' is t, use bucket file;
@@ -260,17 +268,22 @@ use it."
"Return the proper buffer for Org-Velocity to display in."
(get-buffer-create org-velocity-match-buffer-name))
+(defsubst org-velocity-match-window ()
+ (get-buffer-window (org-velocity-match-buffer)))
+
+(defsubst org-velocity-match-staging-buffer ()
+ (get-buffer-create " Velocity matches"))
+
(defun org-velocity-beginning-of-headings ()
"Goto the start of the first heading."
(goto-char (point-min))
;; If we are before the first heading we could still be at the
;; first heading.
- (or (looking-at org-velocity-heading-regexp)
- (re-search-forward org-velocity-heading-regexp)))
+ (or (looking-at (org-velocity-heading-regexp))
+ (re-search-forward (org-velocity-heading-regexp))))
(defun org-velocity-make-indirect-buffer (heading)
"Make or switch to an indirect buffer visiting HEADING."
-
(let* ((bucket (org-velocity-heading-buffer heading))
(name (org-velocity-heading-name heading))
(existing (get-buffer name)))
@@ -279,7 +292,8 @@ use it."
existing
(make-indirect-buffer
bucket
- (generate-new-buffer-name (org-velocity-heading-name heading))))))
+ (generate-new-buffer-name (org-velocity-heading-name heading))
+ t))))
(defun org-velocity-capture ()
"Record a note with `org-capture'."
@@ -287,34 +301,38 @@ use it."
org-velocity-capture-templates))
(org-capture nil
;; This is no longer automatically selected.
- (when (org-velocity-singlep org-capture-templates)
+ (when (null (cdr org-capture-templates))
(caar org-capture-templates)))
- (if org-capture-mode (rename-buffer org-velocity-search t))))
+ (when org-capture-mode
+ (rename-buffer org-velocity-search t))))
(defvar org-velocity-saved-winconf nil)
(make-variable-buffer-local 'org-velocity-saved-winconf)
(defun org-velocity-edit-entry (heading)
"Edit entry at HEADING in an indirect buffer."
- (let ((winconf (current-window-configuration)))
- (let ((buffer (org-velocity-make-indirect-buffer heading)))
- (with-current-buffer buffer
- (let ((org-inhibit-startup t))
- (org-mode))
- (setq org-velocity-saved-winconf winconf)
- (goto-char (org-velocity-heading-position heading))
- (narrow-to-region (point)
- (save-excursion
- (org-end-of-subtree t)
- (point)))
- (goto-char (point-min))
- (add-hook 'org-ctrl-c-ctrl-c-hook 'org-velocity-dismiss nil t))
- (pop-to-buffer buffer)
- (set (make-local-variable 'header-line-format)
- (format "%s Use C-c C-c to finish."
- (abbreviate-file-name
- (buffer-file-name
- (org-velocity-heading-buffer heading))))))))
+ (let ((winconf (current-window-configuration))
+ (buffer (org-velocity-make-indirect-buffer heading))
+ (inhibit-point-motion-hooks t)
+ (inhibit-field-text-motion t))
+ (with-current-buffer buffer
+ (setq org-velocity-saved-winconf winconf)
+ (goto-char (org-velocity-heading-position heading))
+ (let ((start (point))
+ (end (save-excursion
+ (org-end-of-subtree t)
+ (point))))
+ ;; Outline view and narrow-to-region interact poorly.
+ (outline-flag-region start end nil)
+ (narrow-to-region start end))
+ (goto-char (point-max))
+ (add-hook 'org-ctrl-c-ctrl-c-hook 'org-velocity-dismiss nil t))
+ (pop-to-buffer buffer)
+ (set (make-local-variable 'header-line-format)
+ (format "%s Use C-c C-c to finish."
+ (abbreviate-file-name
+ (buffer-file-name
+ (org-velocity-heading-buffer heading)))))))
(defun org-velocity-dismiss ()
"Save current entry and close indirect buffer."
@@ -327,14 +345,18 @@ use it."
(defun org-velocity-visit-button (button)
(run-hooks 'mouse-leave-buffer-hook)
- (if org-velocity-use-search-ring
- (add-to-history 'search-ring
- (button-get button 'search)
- search-ring-max))
- (org-velocity-edit-entry (button-get button 'match)))
+ (when org-velocity-use-search-ring
+ (add-to-history 'search-ring
+ (button-get button 'search)
+ search-ring-max))
+ (let ((match (button-get button 'match)))
+ (throw 'org-velocity-done
+ (lambda ()
+ (org-velocity-edit-entry match)))))
(define-button-type 'org-velocity-button
- 'action #'org-velocity-visit-button)
+ 'action #'org-velocity-visit-button
+ 'follow-link 'mouse-face)
(defsubst org-velocity-buttonize (heading)
"Insert HEADING as a text button with no hints."
@@ -352,8 +374,8 @@ use it."
(org-velocity-heading-preview heading)
'face 'shadow))))
-(defsubst* org-velocity-present-match (&key hint match)
- (with-current-buffer (org-velocity-match-buffer)
+(defsubst org-velocity-present-match (hint match)
+ (with-current-buffer (org-velocity-match-staging-buffer)
(when hint (insert "#" hint " "))
(org-velocity-buttonize match)
(org-velocity-insert-preview match)
@@ -362,19 +384,19 @@ use it."
(defun org-velocity-generic-search (search &optional hide-hints)
"Display any entry containing SEARCH."
(let ((hints org-velocity-index) matches)
- (block nil
+ (cl-block nil
(while (and hints (re-search-forward search nil t))
(let ((match (org-velocity-nearest-heading (point))))
(org-velocity-present-match
- :hint (unless hide-hints (car hints))
- :match match)
+ (unless hide-hints (car hints))
+ match)
(push match matches))
(setq hints (cdr hints))
- (unless (re-search-forward org-velocity-heading-regexp nil t)
+ (unless (re-search-forward (org-velocity-heading-regexp) nil t)
(return))))
(nreverse matches)))
-(defun* org-velocity-all-search (search &optional hide-hints max)
+(cl-defun org-velocity-all-search (search &optional hide-hints)
"Display only entries containing every word in SEARCH."
(let ((keywords (mapcar 'regexp-quote (split-string search)))
(hints org-velocity-index)
@@ -388,23 +410,23 @@ use it."
(setq org-map-continue-from
(save-excursion
(goto-char (line-end-position))
- (if (re-search-forward org-velocity-heading-regexp nil t)
+ (if (re-search-forward (org-velocity-heading-regexp) nil t)
(line-end-position)
(point-max))))
- (when (loop for word in keywords
- always (save-excursion
- (re-search-forward
- (concat "\\<" word "\\>")
- org-map-continue-from t)))
+ (when (cl-loop for word in keywords
+ always (save-excursion
+ (re-search-forward
+ (concat "\\<" word "\\>")
+ org-map-continue-from t)))
(let ((match (org-velocity-nearest-heading (match-end 0))))
(org-velocity-present-match
- :hint (unless hide-hints (car hints))
- :match match)
+ (unless hide-hints (car hints))
+ match)
(push match matches)
(setq hints (cdr hints))))))
(nreverse matches)))
-(defun* org-velocity-present (search &key hide-hints)
+(cl-defun org-velocity-present (search &key hide-hints)
"Buttonize matches for SEARCH in `org-velocity-match-buffer'.
If HIDE-HINTS is non-nil, display entries without indices. SEARCH
binds `org-velocity-search'.
@@ -425,7 +447,7 @@ Return matches."
(inhibit-field-text-motion t))
(save-excursion
(org-velocity-beginning-of-headings)
- (case org-velocity-search-method
+ (cl-case org-velocity-search-method
(all (org-velocity-all-search search hide-hints))
(phrase (org-velocity-generic-search
(concat "\\<" (regexp-quote search))
@@ -440,6 +462,7 @@ Return matches."
(invalid-regexp
(minibuffer-message "%s" lossage))))))))
(with-current-buffer (org-velocity-match-buffer)
+ (buffer-swap-text (org-velocity-match-staging-buffer))
(goto-char (point-min)))))
(with-current-buffer (org-velocity-match-buffer)
(erase-buffer))))
@@ -452,14 +475,14 @@ Return matches."
(add-hook 'org-store-link-functions 'org-velocity-store-link)
-(defun* org-velocity-create (search &key ask)
+(cl-defun org-velocity-create (search &key ask)
"Create new heading named SEARCH.
If ASK is non-nil, ask first."
(when (or (null ask) (y-or-n-p "No match found, create? "))
(let ((org-velocity-search search)
- (org-default-notes-file (org-velocity-bucket-file))
- ;; save a stored link
- org-store-link-plist)
+ (org-default-notes-file (org-velocity-bucket-file))
+ ;; save a stored link
+ org-store-link-plist)
(org-velocity-capture))
search))
@@ -469,17 +492,18 @@ If ASK is non-nil, ask first."
(unless (or
(not (stringp search))
(string= "" search)) ;exit on empty string
- (case
+ (cl-case
(if (and org-velocity-force-new (eq last-command-event ?\C-j))
:force
- (let ((matches (org-velocity-present search)))
+ (let* ((org-velocity-index (org-velocity-adjust-index))
+ (matches (org-velocity-present search)))
(cond ((null matches) :new)
- ((org-velocity-singlep matches) :follow)
+ ((null (cdr matches)) :follow)
(t :prompt))))
(:prompt (progn
(pop-to-buffer (org-velocity-match-buffer))
(let ((hint (org-velocity-electric-read-hint)))
- (when hint (case hint
+ (when hint (cl-case hint
(:edit (org-velocity-read nil search))
(:force (org-velocity-create search))
(otherwise (org-velocity-activate-button hint)))))))
@@ -493,17 +517,10 @@ If ASK is non-nil, ask first."
(button-activate (next-button (point))))
(org-velocity-read nil search)))))))
-(defun org-velocity-position (item list)
- "Return first position of ITEM in LIST."
- (loop for elt in list
- for i from 0
- when (equal elt item)
- return i))
-
(defun org-velocity-activate-button (char)
"Go to button on line number associated with CHAR in `org-velocity-index'."
(goto-char (point-min))
- (forward-line (org-velocity-position char org-velocity-index))
+ (forward-line (cl-position char org-velocity-index))
(goto-char
(button-start
(next-button (point))))
@@ -514,8 +531,8 @@ If ASK is non-nil, ask first."
"Complain about an undefined key."
(interactive)
(message "%s"
- (substitute-command-keys
- "\\[org-velocity-electric-new] for new entry,
+ (substitute-command-keys
+ "\\[org-velocity-electric-new] for new entry,
\\[org-velocity-electric-edit] to edit search,
\\[scroll-up] to scroll up,
\\[scroll-down] to scroll down,
@@ -525,20 +542,11 @@ If ASK is non-nil, ask first."
(defun org-velocity-electric-follow (ev)
"Follow a hint indexed by keyboard event EV."
(interactive (list last-command-event))
- (if (not (> (org-velocity-position ev org-velocity-index)
+ (if (not (> (cl-position ev org-velocity-index)
(1- (count-lines (point-min) (point-max)))))
(throw 'org-velocity-select ev)
(call-interactively 'org-velocity-electric-undefined)))
-(defun org-velocity-electric-click (ev)
- "Follow hint indexed by a mouse event EV."
- (interactive "e")
- (throw 'org-velocity-select
- (nth (1- (count-lines
- (point-min)
- (posn-point (event-start ev))))
- org-velocity-index)))
-
(defun org-velocity-electric-edit ()
"Edit the search string."
(interactive)
@@ -552,14 +560,15 @@ If ASK is non-nil, ask first."
(defvar org-velocity-electric-map
(let ((map (make-sparse-keymap)))
(define-key map [t] 'org-velocity-electric-undefined)
- (loop for c in org-velocity-index
- do (define-key map (char-to-string c) 'org-velocity-electric-follow))
+ (dolist (c org-velocity-index)
+ (define-key map (char-to-string c)
+ 'org-velocity-electric-follow))
(define-key map "0" 'org-velocity-electric-new)
(define-key map "\C-v" 'scroll-up)
(define-key map "\M-v" 'scroll-down)
(define-key map (kbd "RET") 'org-velocity-electric-edit)
- (define-key map [mouse-1] 'org-velocity-electric-click)
- (define-key map [mouse-2] 'org-velocity-electric-click)
+ (define-key map [mouse-1] nil)
+ (define-key map [mouse-2] nil)
(define-key map [escape] 'keyboard-quit)
(define-key map "\C-h" 'help-command)
map))
@@ -567,29 +576,19 @@ If ASK is non-nil, ask first."
(defun org-velocity-electric-read-hint ()
"Read index of button electrically."
(with-current-buffer (org-velocity-match-buffer)
+ (when (featurep 'evil)
+ ;; NB Idempotent.
+ (evil-make-overriding-map org-velocity-electric-map))
(use-local-map org-velocity-electric-map)
(catch 'org-velocity-select
(Electric-command-loop 'org-velocity-select "Follow: "))))
(defvar org-velocity-incremental-keymap
(let ((map (make-sparse-keymap)))
- (define-key map [mouse-1] 'org-velocity-click-for-incremental)
- (define-key map [mouse-2] 'org-velocity-click-for-incremental)
(define-key map "\C-v" 'scroll-up)
(define-key map "\M-v" 'scroll-down)
map))
-(defun org-velocity-click-for-incremental ()
- "Jump out of search and select hint clicked on."
- (interactive)
- (let ((ev last-command-event))
- (org-velocity-activate-button
- (nth (- (count-lines
- (point-min)
- (posn-point (event-start ev))) 2)
- org-velocity-index)))
- (throw 'click (current-buffer)))
-
(defun org-velocity-displaying-completions-p ()
"Is there a *Completions* buffer showing?"
(get-window-with-predicate
@@ -598,8 +597,7 @@ If ASK is non-nil, ask first."
'completion-list-mode))))
(defun org-velocity-update ()
- "Display results of search without hinting.
-Stop searching once there are more matches than can be displayed."
+ "Display results of search without hinting."
(unless (org-velocity-displaying-completions-p)
(let* ((search (org-velocity-minibuffer-contents))
(matches (org-velocity-present search :hide-hints t)))
@@ -607,20 +605,20 @@ Stop searching once there are more matches than can be displayed."
(select-window (active-minibuffer-window))
(unless (or (null search) (string= "" search))
(minibuffer-message "No match; RET to create")))
- ((and (org-velocity-singlep matches)
+ ((and (null (cdr matches))
org-velocity-exit-on-match)
(throw 'click search))
(t
(with-current-buffer (org-velocity-match-buffer)
(use-local-map org-velocity-incremental-keymap)))))))
-(defvar dabbrev--last-abbrev)
+(defvar dabbrev--last-abbreviation)
(defun org-velocity-dabbrev-completion-list (abbrev)
"Return all dabbrev completions for ABBREV."
;; This is based on `dabbrev-completion'.
(dabbrev--reset-global-variables)
- (setq dabbrev--last-abbrev abbrev)
+ (setq dabbrev--last-abbreviation abbrev)
(dabbrev--find-all-expansions abbrev case-fold-search))
(defvar org-velocity-local-completion-map
@@ -638,7 +636,7 @@ Stop searching once there are more matches than can be displayed."
(completion-no-auto-exit t)
(crm-separator " "))
(funcall
- (case org-velocity-search-method
+ (cl-case org-velocity-search-method
(phrase #'completing-read)
(any #'completing-read-multiple)
(all #'completing-read-multiple))
@@ -652,38 +650,50 @@ Stop searching once there are more matches than can be displayed."
;; `read-from-minibuffer'), but in this case it is the user-friendly
;; thing to do.
(minibuffer-with-setup-hook
- (lexical-let ((initial-input initial-input))
+ (let ((initial-input initial-input))
(lambda ()
(and initial-input (insert initial-input))
(goto-char (point-max))))
(if (eq org-velocity-search-method 'regexp)
- (read-regexp prompt)
+ (read-regexp prompt)
(if org-velocity-use-completion
- (org-velocity-read-with-completion prompt)
- (read-string prompt)))))
+ (org-velocity-read-with-completion prompt)
+ (read-string prompt)))))
+
+(cl-defun org-velocity-adjust-index
+ (&optional (match-window (org-velocity-match-window)))
+ "Truncate or extend `org-velocity-index' to the lines in
+MATCH-WINDOW."
+ (with-selected-window match-window
+ (let ((lines (window-height))
+ (hints (length org-velocity-index)))
+ (cond ((= lines hints)
+ org-velocity-index)
+ ;; Truncate the index to the size of
+ ;; the buffer to be displayed.
+ ((< lines hints)
+ (cl-subseq org-velocity-index 0 lines))
+ ;; If the window is so tall we run out of indices, at
+ ;; least make the additional results clickable.
+ ((> lines hints)
+ (append org-velocity-index
+ (make-list (- lines hints) nil)))))))
(defun org-velocity-incremental-read (prompt)
- "Read string with PROMPT and display results incrementally."
+ "Read string with PROMPT and display results incrementally.
+Stop searching once there are more matches than can be
+displayed."
(let ((res
(unwind-protect
(let* ((match-window (display-buffer (org-velocity-match-buffer)))
- (org-velocity-index
- ;; Truncate the index to the size of the buffer to be
- ;; displayed.
- (with-selected-window match-window
- (if (> (window-height) (length org-velocity-index))
- ;; (subseq org-velocity-index 0 (window-height))
- (let ((hints (copy-sequence org-velocity-index)))
- (setcdr (nthcdr (window-height) hints) nil)
- hints)
- org-velocity-index))))
+ (org-velocity-index (org-velocity-adjust-index match-window)))
(catch 'click
(add-hook 'post-command-hook 'org-velocity-update)
- (if (eq org-velocity-search-method 'regexp)
- (read-regexp prompt)
- (if org-velocity-use-completion
- (org-velocity-read-with-completion prompt)
- (read-string prompt)))))
+ (cond ((eq org-velocity-search-method 'regexp)
+ (read-regexp prompt))
+ (org-velocity-use-completion
+ (org-velocity-read-with-completion prompt))
+ (t (read-string prompt)))))
(remove-hook 'post-command-hook 'org-velocity-update))))
(if (bufferp res) (org-pop-to-buffer-same-window res) res)))
@@ -697,24 +707,31 @@ created named SEARCH.
If `org-velocity-bucket' is defined and
`org-velocity-always-use-bucket' is non-nil, then the bucket file
will be used; otherwise, this will work when called in any Org
-file. Calling with ARG forces current file."
+file.
+
+Calling with ARG reverses which file – the current file or the
+bucket file – to use. If the bucket file would have been used,
+then the current file is used instead, and vice versa."
(interactive "P")
(let ((org-velocity-always-use-bucket
- (if arg nil org-velocity-always-use-bucket)))
+ (if org-velocity-always-use-bucket
+ (not arg)
+ arg)))
;; complain if inappropriate
- (assert (org-velocity-bucket-file))
+ (cl-assert (org-velocity-bucket-file))
(let ((org-velocity-bucket-buffer
(find-file-noselect (org-velocity-bucket-file))))
(unwind-protect
(let ((dabbrev-search-these-buffers-only
(list (org-velocity-bucket-buffer))))
- (org-velocity-engine
- (if org-velocity-search-is-incremental
- (org-velocity-incremental-read "Velocity search: ")
- (org-velocity-read-string "Velocity search: " search))))
- (progn
- (kill-buffer (org-velocity-match-buffer))
- (delete-other-windows))))))
+ (funcall
+ (catch 'org-velocity-done
+ (org-velocity-engine
+ (if org-velocity-search-is-incremental
+ (org-velocity-incremental-read "Velocity search: ")
+ (org-velocity-read-string "Velocity search: " search)))
+ #'ignore)))
+ (kill-buffer (org-velocity-match-buffer))))))
(defalias 'org-velocity-read 'org-velocity)
diff --git a/contrib/lisp/org-wikinodes.el b/contrib/lisp/org-wikinodes.el
index 015e001..ff2d55a 100644
--- a/contrib/lisp/org-wikinodes.el
+++ b/contrib/lisp/org-wikinodes.el
@@ -82,8 +82,6 @@ to `directory'."
;; in heading - deactivate flyspell
(org-remove-flyspell-overlays-in (match-beginning 0)
(match-end 0))
- (add-text-properties (match-beginning 0) (match-end 0)
- '(org-no-flyspell t))
t)
;; this is a wiki link
(org-remove-flyspell-overlays-in (match-beginning 0)
@@ -270,7 +268,6 @@ If there is no such wiki target, return nil."
(car org-export-target-aliases))))
(push (caar target-alist) (cdr a)))))
-(defvar org-current-export-file)
(defun org-wikinodes-process-links-for-export ()
"Process Wiki links in the export preprocess buffer.
@@ -296,12 +293,6 @@ with working links."
((eq org-wikinodes-scope 'file)
;; No match in file, and other files are not allowed
(insert (format "%s" link)))
- ((setq file
- (and (org-string-nw-p org-current-export-file)
- (org-wikinodes-which-file
- link (file-name-directory org-current-export-file))))
- ;; Match in another file in the current directory
- (insert (format "[[file:%s::%s][%s]]" file link link)))
(t ;; No match for this link
(insert (format "%s" link)))))))))
@@ -325,11 +316,10 @@ with working links."
(defun org-wikinodes-add-to-font-lock-keywords ()
"Add wikinode CamelCase highlighting to `org-font-lock-extra-keywords'."
- (let ((m (member '(org-activate-plain-links) org-font-lock-extra-keywords)))
- (if m
- (setcdr m (cons '(org-wikinodes-activate-links) (cdr m)))
- (message
- "Failed to add wikinodes to `org-font-lock-extra-keywords'."))))
+ (let ((m (member '(org-activate-plain-links (0 'org-link t))
+ org-font-lock-extra-keywords)))
+ (if m (push '(org-wikinodes-activate-links) (cdr m))
+ (message "Failed to add wikinodes to `org-font-lock-extra-keywords'."))))
(add-hook 'org-font-lock-set-keywords-hook
'org-wikinodes-add-to-font-lock-keywords)
diff --git a/contrib/lisp/ox-bibtex.el b/contrib/lisp/ox-bibtex.el
index ef69395..0719866 100644
--- a/contrib/lisp/ox-bibtex.el
+++ b/contrib/lisp/ox-bibtex.el
@@ -23,21 +23,31 @@
;;; Commentary:
;;
-;; This is an utility to handle BibTeX export to both LaTeX and html
-;; exports. It uses the bibtex2html software from:
+;; This is an utility to handle BibTeX export to LaTeX, html and ascii
+;; exports. For HTML and ascii it uses the bibtex2html software from:
;;
;; http://www.lri.fr/~filliatr/bibtex2html/
;;
+;; For ascii it uses the pandoc software from:
+;;
+;; http://johnmacfarlane.net/pandoc/
+;;
;; It also introduces "cite" syntax for Org links.
;;
;; The usage is as follows:
;;
-;; #+BIBLIOGRAPHY: bibfilebasename stylename optional-options
+;; #+BIBLIOGRAPHY: bibfilename stylename optional-options
;;
;; e.g. given foo.bib and using style plain:
;;
;; #+BIBLIOGRAPHY: foo plain option:-d
;;
+;; "stylename" can also be "nil", in which case no style will be used.
+;;
+;; Full filepaths are also possible:
+;;
+;; #+BIBLIOGRAPHY: /home/user/Literature/foo.bib plain option:-d
+;;
;; Optional options are of the form:
;;
;; option:-foobar pass '-foobar' to bibtex2html
@@ -71,14 +81,18 @@
;; 2) creates a foo.html and foo_bib.html,
;; 3) includes the contents of foo.html in the exported HTML file.
;;
+;; For ascii export it:
+;; 1) converts all \cite{foo} and [[cite:foo]] to links to the
+;; bibliography,
+;; 2) creates a foo.txt and foo_bib.html,
+;; 3) includes the contents of foo.txt in the exported ascii file.
+;;
;; For LaTeX export it:
;; 1) converts all [[cite:foo]] to \cite{foo}.
;; Initialization
(eval-when-compile (require 'cl))
-(org-add-link-type "cite" 'ebib)
-
;;; Internal Functions
@@ -103,9 +117,9 @@ return nil instead."
(defun org-bibtex-get-arguments (keyword)
"Return \"bibtex2html\" arguments specified by the user.
KEYWORD is a \"BIBLIOGRAPHY\" keyword. Return value is a plist
-containing `:options' and `:limit' properties. The former
-contains a list of strings to be passed as options ot
-\"bibtex2html\" process. The latter contains a boolean."
+containing `:options' and `:limit' properties. The former
+contains a list of strings to be passed as options to
+\"bibtex2html\" process. The latter contains a boolean."
(let ((value (org-element-property :value keyword)))
(and value
(string-match "\\(\\S-+\\)[ \t]+\\(\\S-+\\)\\(.*\\)" value)
@@ -137,6 +151,197 @@ to `org-bibtex-citation-p' predicate."
(and (string-match "\\`\\\\cite{" value)
(substring value (match-end 0) -1)))))
+
+;;; Follow cite: links
+
+(defun org-bibtex-file nil "Org-mode file of bibtex entries.")
+
+(defun org-bibtex-goto-citation (&optional citation)
+ "Visit a citation given its ID."
+ (interactive)
+ (let ((citation (or citation
+ (org-icompleting-read "Citation: "
+ (obe-citations)))))
+ (find-file (or org-bibtex-file
+ (error "`org-bibtex-file' has not been configured")))
+ (goto-char (point-min))
+ (when (re-search-forward (format " :CUSTOM_ID: %s" citation) nil t)
+ (outline-previous-visible-heading 1)
+ t)))
+
+(let ((jump-fn (car (org-remove-if-not #'fboundp '(ebib org-bibtex-goto-citation)))))
+ (org-add-link-type "cite" jump-fn))
+
+
+
+;;; Filters
+
+(defun org-bibtex-process-bib-files (tree backend info)
+ "Send each bibliography in parse tree to \"bibtex2html\" process.
+Return new parse tree."
+ (when (org-export-derived-backend-p backend 'ascii 'html)
+ ;; Initialize dynamically scoped variables. The first one
+ ;; contain an alist between keyword objects and their HTML
+ ;; translation. The second one will contain an alist between
+ ;; citation keys and names in the output (according to style).
+ (setq org-bibtex-html-entries-alist nil
+ org-bibtex-html-keywords-alist nil)
+ (org-element-map tree 'keyword
+ (lambda (keyword)
+ (when (equal (org-element-property :key keyword) "BIBLIOGRAPHY")
+ (let ((arguments (org-bibtex-get-arguments keyword))
+ (file (org-bibtex-get-file keyword))
+ temp-file
+ out-file)
+ ;; Test if filename is given with .bib-extension and strip
+ ;; it off. Filenames with another extensions will be
+ ;; untouched and will finally rise an error in bibtex2html.
+ (setq file (if (equal (file-name-extension file) "bib")
+ (file-name-sans-extension file) file))
+ ;; Outpufiles of bibtex2html will be put into current working directory
+ ;; so define a variable for this.
+ (setq out-file (file-name-sans-extension
+ (file-name-nondirectory file)))
+ ;; limit is set: collect citations throughout the document
+ ;; in TEMP-FILE and pass it to "bibtex2html" as "-citefile"
+ ;; argument.
+ (when (plist-get arguments :limit)
+ (let ((citations
+ (org-element-map tree '(latex-fragment link)
+ (lambda (object)
+ (and (org-bibtex-citation-p object)
+ (org-bibtex-get-citation-key object))))))
+ (with-temp-file (setq temp-file (make-temp-file "ox-bibtex"))
+ (insert (mapconcat 'identity citations "\n")))
+ (setq arguments
+ (plist-put arguments
+ :options
+ (append (plist-get arguments :options)
+ (list "-citefile" temp-file))))))
+ ;; Call "bibtex2html" on specified file.
+ (unless (eq 0 (apply
+ 'call-process
+ (append '("bibtex2html" nil nil nil)
+ '("-a" "-nodoc" "-noheader" "-nofooter")
+ (let ((style
+ (org-not-nil
+ (org-bibtex-get-style keyword))))
+ (and style (list "--style" style)))
+ (plist-get arguments :options)
+ (list (concat file ".bib")))))
+ (error "Executing bibtex2html failed"))
+ (and temp-file (delete-file temp-file))
+ ;; Open produced HTML file, and collect Bibtex key names
+ (with-temp-buffer
+ (insert-file-contents (concat out-file ".html"))
+ ;; Update `org-bibtex-html-entries-alist'.
+ (goto-char (point-min))
+ (while (re-search-forward
+ "a name=\"\\([-_a-zA-Z0-9:]+\\)\">\\(\\w+\\)" nil t)
+ (push (cons (match-string 1) (match-string 2))
+ org-bibtex-html-entries-alist)))
+ ;; Open produced HTML file, wrap references within a block and
+ ;; return it.
+ (with-temp-buffer
+ (cond
+ ((org-export-derived-backend-p backend 'html)
+ (insert (format "<div id=\"bibliography\">\n<h2>%s</h2>\n"
+ (org-export-translate "References" :html info)))
+ (insert-file-contents (concat out-file ".html"))
+ (insert "\n</div>"))
+ ((org-export-derived-backend-p backend 'ascii)
+ ;; convert HTML references to text w/pandoc
+ (unless (eq 0 (call-process "pandoc" nil nil nil
+ (concat out-file ".html")
+ "-o"
+ (concat out-file ".txt")))
+ (error "Executing pandoc failed"))
+ (insert
+ (format
+ "%s\n==========\n\n"
+ (org-export-translate
+ "References"
+ (intern (format ":%s" (plist-get info :ascii-charset)))
+ info)))
+ (insert-file-contents (concat out-file ".txt"))
+ (goto-char (point-min))
+ (while (re-search-forward
+ "\\[ \\[bib\\][^ ]+ \\(\\]\\||[\n\r]\\)" nil t)
+ (replace-match ""))
+ (goto-char (point-min))
+ (while (re-search-forward "\\( \\]\\| \\]\\| |\\)" nil t)
+ (replace-match ""))
+ (goto-char (point-min))
+ (while (re-search-forward "[\n\r]\\([\n\r][\n\r]\\)" nil t)
+ (replace-match "\\1"))))
+ ;; Update `org-bibtex-html-keywords-alist'.
+ (push (cons keyword (buffer-string))
+ org-bibtex-html-keywords-alist)))))))
+ ;; Return parse tree unchanged.
+ tree)
+
+(defun org-bibtex-merge-contiguous-citations (tree backend info)
+ "Merge all contiguous citation in parse tree.
+As a side effect, this filter will also turn all \"cite\" links
+into \"\\cite{...}\" LaTeX fragments and will extract options.
+Cite options are placed into square brackets at the beginning of
+the \"\\cite\" command for the LaTeX backend, and are removed for
+the HTML and ASCII backends."
+ (when (org-export-derived-backend-p backend 'html 'latex 'ascii)
+ (org-element-map tree '(link latex-fragment)
+ (lambda (object)
+ (when (org-bibtex-citation-p object)
+ (let ((new-citation (list 'latex-fragment
+ (list :value ""
+ :post-blank (org-element-property
+ :post-blank object))))
+ option)
+ ;; Insert NEW-CITATION right before OBJECT.
+ (org-element-insert-before new-citation object)
+ ;; Remove all subsequent contiguous citations from parse
+ ;; tree, keeping only their citation key.
+ (let ((keys (list (org-bibtex-get-citation-key object)))
+ next)
+ (while (and (setq next (org-export-get-next-element object info))
+ (or (and (stringp next)
+ (not (org-string-match-p "\\S-" next)))
+ (org-bibtex-citation-p next)))
+ (unless (stringp next)
+ (push (org-bibtex-get-citation-key next) keys))
+ (org-element-extract-element object)
+ (setq object next))
+ ;; Find any options in keys, e.g., "(Chapter 2)key" has
+ ;; the option "Chapter 2".
+ (setq keys
+ (mapcar
+ (lambda (k)
+ (if (string-match "^(\\([^)]\+\\))\\(.*\\)" k)
+ (progn
+ (when (org-export-derived-backend-p backend 'latex)
+ (setq option (format "[%s]" (match-string 1 k))))
+ (match-string 2 k))
+ k))
+ keys))
+ (org-element-extract-element object)
+ ;; Eventually merge all keys within NEW-CITATION. Also
+ ;; ensure NEW-CITATION has the same :post-blank property
+ ;; as the last citation removed.
+ (org-element-put-property
+ new-citation
+ :post-blank (org-element-property :post-blank object))
+ (org-element-put-property
+ new-citation
+ :value (format "\\cite%s{%s}"
+ (or option "")
+ (mapconcat 'identity (nreverse keys) ",")))))))))
+ tree)
+
+(eval-after-load 'ox
+ '(progn (add-to-list 'org-export-filter-parse-tree-functions
+ 'org-bibtex-process-bib-files)
+ (add-to-list 'org-export-filter-parse-tree-functions
+ 'org-bibtex-merge-contiguous-citations)))
+
;;; LaTeX Part
@@ -148,22 +353,13 @@ Fallback to `latex' back-end for other keywords."
(if (not (equal (org-element-property :key keyword) "BIBLIOGRAPHY"))
ad-do-it
(let ((file (org-bibtex-get-file keyword))
- (style (org-bibtex-get-style keyword)))
+ (style (org-not-nil (org-bibtex-get-style keyword))))
(setq ad-return-value
(when file
(concat (and style (format "\\bibliographystyle{%s}\n" style))
(format "\\bibliography{%s}" file))))))))
-(defadvice org-latex-link (around bibtex-link)
- "Translate \"cite\" type links into LaTeX syntax.
-Fallback to `latex' back-end for other keywords."
- (let ((link (ad-get-arg 0)))
- (if (not (org-bibtex-citation-p link)) ad-do-it
- (setq ad-return-value
- (format "\\cite{%s}" (org-bibtex-get-citation-key link))))))
-
(ad-activate 'org-latex-keyword)
-(ad-activate 'org-latex-link)
@@ -190,103 +386,46 @@ Fallback to `html' back-end for other keywords."
(let ((fragment (ad-get-arg 0)))
(if (not (org-bibtex-citation-p fragment)) ad-do-it
(setq ad-return-value
- (mapconcat
- (lambda (key)
- (let ((key (org-trim key)))
- (format "[<a href=\"#%s\">%s</a>]"
- key
- (or (cdr (assoc key org-bibtex-html-entries-alist))
- key))))
- (org-split-string (org-bibtex-get-citation-key fragment) ",")
- "")))))
-
-(defadvice org-html-link (around bibtex-link)
- "Translate \"cite:\" type links into HTML syntax.
-Fallback to `html' back-end for other types."
- (let ((link (ad-get-arg 0)))
- (if (not (org-bibtex-citation-p link)) ad-do-it
- (setq ad-return-value
- (mapconcat
- (lambda (key)
- (format "[<a href=\"#%s\">%s</a>]"
- key
- (or (cdr (assoc key org-bibtex-html-entries-alist))
- key)))
- (org-split-string (org-bibtex-get-citation-key link)
- "[ \t]*,[ \t]*")
- "")))))
+ (format "[%s]"
+ (mapconcat
+ (lambda (key)
+ (format "<a href=\"#%s\">%s</a>"
+ key
+ (or (cdr (assoc key org-bibtex-html-entries-alist))
+ key)))
+ (org-split-string
+ (org-bibtex-get-citation-key fragment) ",") ","))))))
(ad-activate 'org-html-keyword)
(ad-activate 'org-html-latex-fragment)
-(ad-activate 'org-html-link)
-
-
-;;;; Filter
-
-(defun org-bibtex-process-bib-files (tree backend info)
- "Send each bibliography in parse tree to \"bibtex2html\" process.
-Return new parse tree. This function assumes current back-end is HTML."
- ;; Initialize dynamically scoped variables. The first one
- ;; contain an alist between keyword objects and their HTML
- ;; translation. The second one will contain an alist between
- ;; citation keys and names in the output (according to style).
- (setq org-bibtex-html-entries-alist nil
- org-bibtex-html-keywords-alist nil)
- (org-element-map tree 'keyword
- (lambda (keyword)
- (when (equal (org-element-property :key keyword) "BIBLIOGRAPHY")
- (let ((arguments (org-bibtex-get-arguments keyword))
- (file (org-bibtex-get-file keyword))
- temp-file)
- ;; limit is set: collect citations throughout the document
- ;; in TEMP-FILE and pass it to "bibtex2html" as "-citefile"
- ;; argument.
- (when (plist-get arguments :limit)
- (let ((citations
- (org-element-map tree '(latex-fragment link)
- (lambda (object)
- (and (org-bibtex-citation-p object)
- (org-bibtex-get-citation-key object))))))
- (with-temp-file (setq temp-file (make-temp-file "ox-bibtex"))
- (insert (mapconcat 'identity citations "\n")))
- (setq arguments
- (plist-put arguments
- :options
- (append (plist-get arguments :options)
- (list "-citefile" temp-file))))))
- ;; Call "bibtex2html" on specified file.
- (unless (eq 0 (apply 'call-process
- (append '("bibtex2html" nil nil nil)
- '("-a" "-nodoc" "-noheader" "-nofooter")
- (list "--style"
- (org-bibtex-get-style keyword))
- (plist-get arguments :options)
- (list (concat file ".bib")))))
- (error "Executing bibtex2html failed"))
- (and temp-file (delete-file temp-file))
- ;; Open produced HTML file, wrap references within a block and
- ;; return it.
- (with-temp-buffer
- (insert "<div id=\"bibliography\">\n<h2>References</h2>\n")
- (insert-file-contents (concat file ".html"))
- (insert "\n</div>")
- ;; Update `org-bibtex-html-keywords-alist'.
- (push (cons keyword (buffer-string))
- org-bibtex-html-keywords-alist)
- ;; Update `org-bibtex-html-entries-alist'.
- (goto-char (point-min))
- (while (re-search-forward
- "a name=\"\\([-_a-zA-Z0-9:]+\\)\">\\(\\w+\\)" nil t)
- (push (cons (match-string 1) (match-string 2))
- org-bibtex-html-entries-alist)))))))
- ;; Return parse tree unchanged.
- tree)
-(eval-after-load 'ox
- '(add-to-list 'org-export-filter-parse-tree-functions
- 'org-bibtex-process-bib-files))
+
+;;; Ascii Part
+(defadvice org-ascii-keyword (around bibtex-keyword)
+ "Translate \"BIBLIOGRAPHY\" keywords into ascii syntax.
+Fallback to `ascii' back-end for other keywords."
+ (let ((keyword (ad-get-arg 0)))
+ (if (not (equal (org-element-property :key keyword) "BIBLIOGRAPHY"))
+ ad-do-it
+ (setq ad-return-value
+ (cdr (assq keyword org-bibtex-html-keywords-alist))))))
+(defadvice org-ascii-latex-fragment (around bibtex-citation)
+ "Translate \"\\cite\" LaTeX fragments into ascii syntax.
+Fallback to `ascii' back-end for other keywords."
+ (let ((fragment (ad-get-arg 0)))
+ (if (not (org-bibtex-citation-p fragment)) ad-do-it
+ (setq ad-return-value
+ (format "[%s]"
+ (mapconcat
+ (lambda (key)
+ (or (cdr (assoc key org-bibtex-html-entries-alist))
+ key))
+ (org-split-string
+ (org-bibtex-get-citation-key fragment) ",") ","))))))
+(ad-activate 'org-ascii-keyword)
+(ad-activate 'org-ascii-latex-fragment)
(provide 'ox-bibtex)
diff --git a/contrib/lisp/ox-confluence.el b/contrib/lisp/ox-confluence.el
index 538fe02..9b96d5f 100644
--- a/contrib/lisp/ox-confluence.el
+++ b/contrib/lisp/ox-confluence.el
@@ -2,7 +2,7 @@
;; Copyright (C) 2012, 2014 Sébastien Delafond
-;; Author: Sébastien Delafond <sdelafond at gmx dot net>
+;; Author: Sébastien Delafond <sdelafond@gmail.com>
;; Keywords: outlines, confluence, wiki
;; This file is not part of GNU Emacs.
@@ -45,7 +45,9 @@
(footnote-reference . org-confluence-empty)
(headline . org-confluence-headline)
(italic . org-confluence-italic)
+ (item . org-confluence-item)
(link . org-confluence-link)
+ (property-drawer . org-confluence-property-drawer)
(section . org-confluence-section)
(src-block . org-confluence-src-block)
(strike-through . org-confluence-strike-through)
@@ -70,6 +72,11 @@
(defun org-confluence-italic (italic contents info)
(format "_%s_" contents))
+(defun org-confluence-item (item contents info)
+ (concat (make-string (1+ (org-confluence--li-depth item)) ?\-)
+ " "
+ (org-trim contents)))
+
(defun org-confluence-fixed-width (fixed-width contents info)
(format "\{\{%s\}\}" contents))
@@ -93,6 +100,11 @@
(t
raw-link))
"]")))
+
+(defun org-confluence-property-drawer (property-drawer contents info)
+ (and (org-string-nw-p contents)
+ (format "\{\{%s\}\}" contents)))
+
(defun org-confluence-section (section contents info)
contents)
@@ -138,6 +150,22 @@
contents
"\{code\}\n"))
+(defun org-confluence--li-depth (item)
+ "Return depth of a list item; -1 means not a list item"
+ ;; FIXME check whether it's worth it to cache depth
+ ;; (it gets recalculated quite a few times while
+ ;; traversing a list)
+ (let ((depth -1)
+ (tag))
+ (while (and item
+ (setq tag (car item))
+ (or (eq tag 'item) ; list items interleave with plain-list
+ (eq tag 'plain-list)))
+ (when (eq tag 'item)
+ (incf depth))
+ (setq item (org-export-get-parent item)))
+ depth))
+
;; main interactive entrypoint
(defun org-confluence-export-as-confluence
(&optional async subtreep visible-only body-only ext-plist)
diff --git a/contrib/lisp/ox-deck.el b/contrib/lisp/ox-deck.el
index 9d84b03..427c7d7 100644
--- a/contrib/lisp/ox-deck.el
+++ b/contrib/lisp/ox-deck.el
@@ -38,6 +38,12 @@
;; See ox.el and ox-html.el for more details on how this exporter
;; works (it is derived from ox-html.)
+;; TODOs
+;; ------
+;; The title page is formatted using format-spec. This is error prone
+;; when details are missing and may insert empty tags, like <h2></h2>,
+;; for missing values.
+
(require 'ox-html)
(eval-when-compile (require 'cl))
@@ -51,11 +57,13 @@
(if a (org-deck-export-to-html t s v b)
(org-open-file (org-deck-export-to-html nil s v b)))))))
:options-alist
- '((:html-link-home "HTML_LINK_HOME" nil nil)
+ '((:description "DESCRIPTION" nil nil newline)
+ (:keywords "KEYWORDS" nil nil space)
+ (:html-link-home "HTML_LINK_HOME" nil nil)
(:html-link-up "HTML_LINK_UP" nil nil)
(:deck-postamble "DECK_POSTAMBLE" nil org-deck-postamble newline)
(:deck-preamble "DECK_PREAMBLE" nil org-deck-preamble newline)
- (:html-head-include-default-style "HTML_INCLUDE_DEFAULT_STYLE" nil nil)
+ (:html-head-include-default-style "HTML_INCLUDE_DEFAULT_STYLE" "html-style" nil)
(:html-head-include-scripts "HTML_INCLUDE_SCRIPTS" nil nil)
(:deck-base-url "DECK_BASE_URL" nil org-deck-base-url)
(:deck-theme "DECK_THEME" nil org-deck-theme)
@@ -259,6 +267,7 @@ Defaults to styles for the title page."
(defcustom org-deck-title-slide-template
"<h1>%t</h1>
+<h2>%s</h2>
<h2>%a</h2>
<h2>%e</h2>
<h2>%d</h2>"
@@ -319,7 +328,7 @@ and have the id \"title-slide\"."
(include (plist-get info :deck-include-extensions))
(exclude (plist-get info :deck-exclude-extensions))
(scripts '()) (sheets '()) (snippets '()))
- (add-to-list 'scripts (concat prefix "jquery-1.7.2.min.js"))
+ (add-to-list 'scripts (concat prefix "jquery.min.js"))
(add-to-list 'scripts (concat prefix "core/deck.core.js"))
(add-to-list 'scripts (concat prefix "modernizr.custom.js"))
(add-to-list 'sheets (concat prefix "core/deck.core.css"))
@@ -368,12 +377,14 @@ holding export options."
"Transcode an ITEM element from Org to HTML.
CONTENTS holds the contents of the item. INFO is a plist holding
contextual information.
-If the containing headline has the property :slide, then
+If the containing headline has the property :STEP, then
the \"slide\" class will be added to the to the list element,
which will make the list into a \"build\"."
(let ((text (org-html-item item contents info)))
(if (org-export-get-node-property :STEP item t)
- (replace-regexp-in-string "^<li>" "<li class='slide'>" text)
+ (progn
+ (replace-regexp-in-string "^<li>" "<li class='slide'>" text)
+ (replace-regexp-in-string "^<li class='checkbox'>" "<li class='checkbox slide'>" text))
text)))
(defun org-deck-link (link desc info)
diff --git a/contrib/lisp/ox-extra.el b/contrib/lisp/ox-extra.el
new file mode 100644
index 0000000..e6d45cc
--- /dev/null
+++ b/contrib/lisp/ox-extra.el
@@ -0,0 +1,190 @@
+;;; ox-extra.el --- Convenience functions for org export
+
+;; Copyright (C) 2014 Aaron Ecay
+
+;; Author: Aaron Ecay <aaronecay@gmail.com>
+
+;; 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 some convenience functions for org export, which
+;; are not part of org's core. Call `ox-extras-activate' passing a
+;; list of symbols naming extras, which will be installed globally in
+;; your org session.
+;;
+;; For example, you could include the following in your .emacs file:
+;;
+;; (require 'ox-extra)
+;; (ox-extras-activate '(latex-header-blocks ignore-headlines))
+;;
+
+;; Currently available extras:
+
+;; - `latex-header-blocks' -- allow the use of latex blocks, the
+;; contents of which which will be interpreted as #+latex_header lines
+;; for export. These blocks should be tagged with #+header: :header
+;; yes. For example:
+;; #+header: :header yes
+;; #+begin_latex
+;; ...
+;; #+end_latex
+
+;; - `ignore-headlines' -- allow a headline (but not its children) to
+;; be ignored. Any headline tagged with the 'ignore' tag will be
+;; ignored (i.e. will not be included in the export), but any child
+;; headlines will not be ignored (unless explicitly tagged to be
+;; ignored), and will instead have their levels promoted by one.
+
+;; TODO:
+;; - add a function to org-mode-hook that looks for a ox-extras local
+;; variable and activates the specified extras buffer-locally
+;; - allow specification of desired extras to be activated via
+;; customize
+
+;;; Code:
+
+(require 'ox)
+(eval-when-compile (require 'cl))
+
+(defun org-latex-header-blocks-filter (backend)
+ (when (org-export-derived-backend-p backend 'latex)
+ (let ((positions
+ (org-element-map (org-element-parse-buffer 'greater-element nil) 'export-block
+ (lambda (block)
+ (when (and (string= (org-element-property :type block) "LATEX")
+ (string= (org-export-read-attribute
+ :header block :header)
+ "yes"))
+ (list (org-element-property :begin block)
+ (org-element-property :end block)
+ (org-element-property :post-affiliated block)))))))
+ (mapc (lambda (pos)
+ (goto-char (nth 2 pos))
+ (destructuring-bind
+ (beg end &rest ignore)
+ (org-edit-src-find-region-and-lang)
+ (let ((contents-lines (split-string
+ (buffer-substring-no-properties beg end)
+ "\n")))
+ (delete-region (nth 0 pos) (nth 1 pos))
+ (dolist (line contents-lines)
+ (insert (concat "#+latex_header: "
+ (replace-regexp-in-string "\\` *" "" line)
+ "\n"))))))
+ ;; go in reverse, to avoid wrecking the numeric positions
+ ;; earlier in the file
+ (reverse positions)))))
+
+
+;; During export headlines which have the "ignore" tag are removed
+;; from the parse tree. Their contents are retained (leading to a
+;; possibly invalid parse tree, which nevertheless appears to function
+;; correctly with most export backends) all children headlines are
+;; retained and are promoted to the level of the ignored parent
+;; headline.
+;;
+;; This makes it possible to add structure to the original Org-mode
+;; document which does not effect the exported version, such as in the
+;; following examples.
+;;
+;; Wrapping an abstract in a headline
+;;
+;; * Abstract :ignore:
+;; #+LaTeX: \begin{abstract}
+;; #+HTML: <div id="abstract">
+;;
+;; ...
+;;
+;; #+HTML: </div>
+;; #+LaTeX: \end{abstract}
+;;
+;; Placing References under a headline (using ox-bibtex in contrib)
+;;
+;; * References :ignore:
+;; #+BIBLIOGRAPHY: dissertation plain
+;;
+;; Inserting an appendix for LaTeX using the appendix package.
+;;
+;; * Appendix :ignore:
+;; #+LaTeX: \begin{appendices}
+;; ** Reproduction
+;; ...
+;; ** Definitions
+;; #+LaTeX: \end{appendices}
+;;
+(defun org-export-ignore-headlines (data backend info)
+ "Remove headlines tagged \"ignore\" retaining contents and promoting children.
+Each headline tagged \"ignore\" will be removed retaining its
+contents and promoting any children headlines to the level of the
+parent."
+ (org-element-map data 'headline
+ (lambda (object)
+ (when (member "ignore" (org-element-property :tags object))
+ (let ((level-top (org-element-property :level object))
+ level-diff)
+ (mapc (lambda (el)
+ ;; recursively promote all nested headlines
+ (org-element-map el 'headline
+ (lambda (el)
+ (when (equal 'headline (org-element-type el))
+ (unless level-diff
+ (setq level-diff (- (org-element-property :level el)
+ level-top)))
+ (org-element-put-property el
+ :level (- (org-element-property :level el)
+ level-diff)))))
+ ;; insert back into parse tree
+ (org-element-insert-before el object))
+ (org-element-contents object)))
+ (org-element-extract-element object)))
+ info nil)
+ data)
+
+(defconst ox-extras
+ '((latex-header-blocks org-latex-header-blocks-filter org-export-before-parsing-hook)
+ (ignore-headlines org-export-ignore-headlines org-export-filter-parse-tree-functions))
+ "A list of org export extras that can be enabled.
+
+Should be a list of items of the form (NAME FN HOOK). NAME is a
+symbol, which can be passed to `ox-extras-activate'. FN is a
+function which will be added to HOOK.")
+
+(defun ox-extras-activate (extras)
+ "Activate certain org export extras.
+
+EXTRAS should be a list of extras (defined in `ox-extras') which
+should be activated."
+ (dolist (extra extras)
+ (let* ((lst (assq extra ox-extras))
+ (fn (nth 1 lst))
+ (hook (nth 2 lst)))
+ (when (and fn hook)
+ (add-hook hook fn)))))
+
+(defun ox-extras-deactivate (extras)
+ "Deactivate certain org export extras.
+
+This function is the opposite of `ox-extras-activate'. EXTRAS
+should be a list of extras (defined in `ox-extras') which should
+be activated."
+ (dolist (extra extras)
+ (let* ((lst (assq extra ox-extras))
+ (fn (nth 1 lst))
+ (hook (nth 2 lst)))
+ (when (and fn hook)
+ (remove-hook hook fn)))))
+
+(provide 'ox-extra)
+;;; ox-extra.el ends here
diff --git a/contrib/lisp/ox-freemind.el b/contrib/lisp/ox-freemind.el
index 39fb1cc..3287d5d 100644
--- a/contrib/lisp/ox-freemind.el
+++ b/contrib/lisp/ox-freemind.el
@@ -312,7 +312,7 @@ will result in following node:
(org-element-property :title element))
(org-data
(plist-get info :title))
- (t (error "Shouldn't come here."))))
+ (t (error "Shouldn't come here"))))
(element-contents (org-element-contents element))
(section (assq 'section element-contents))
(section-contents
diff --git a/contrib/lisp/ox-gfm.el b/contrib/lisp/ox-gfm.el
new file mode 100644
index 0000000..f7acc94
--- /dev/null
+++ b/contrib/lisp/ox-gfm.el
@@ -0,0 +1,193 @@
+;;; 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 b3e3ad3..ade3478 100644
--- a/contrib/lisp/ox-groff.el
+++ b/contrib/lisp/ox-groff.el
@@ -1,6 +1,6 @@
;;; ox-groff.el --- Groff Back-End for Org Export Engine
-;; Copyright (C) 2011-2014 Free Software Foundation, Inc.
+;; Copyright (C) 2011-2015 Free Software Foundation, Inc.
;; Author: Nicolas Goaziou <n.goaziou at gmail dot com>
;; Author: Luis R Anaya <papoanaya aroba hot mail punto com>
@@ -50,8 +50,6 @@
(center-block . org-groff-center-block)
(clock . org-groff-clock)
(code . org-groff-code)
- (comment . (lambda (&rest args) ""))
- (comment-block . (lambda (&rest args) ""))
(drawer . org-groff-drawer)
(dynamic-block . org-groff-dynamic-block)
(entity . org-groff-entity)
@@ -70,13 +68,13 @@
(keyword . org-groff-keyword)
(line-break . org-groff-line-break)
(link . org-groff-link)
+ (node-property . org-groff-node-property)
(paragraph . org-groff-paragraph)
(plain-list . org-groff-plain-list)
(plain-text . org-groff-plain-text)
(planning . org-groff-planning)
- (property-drawer . (lambda (&rest args) ""))
+ (property-drawer . org-groff-property-drawer)
(quote-block . org-groff-quote-block)
- (quote-section . org-groff-quote-section)
(radio-target . org-groff-radio-target)
(section . org-groff-section)
(special-block . org-groff-special-block)
@@ -563,7 +561,8 @@ See `org-groff-text-markup-alist' for details."
(t (format ".AF \"%s\" \n" (or org-groff-organization "")))))
;; 2. Title
- (let ((subtitle1 (plist-get attr :subtitle1))
+ (let ((title (if (plist-get info :with-title) title ""))
+ (subtitle1 (plist-get attr :subtitle1))
(subtitle2 (plist-get attr :subtitle2)))
(cond
@@ -1253,11 +1252,10 @@ INFO is a plist holding contextual information. See
(path (cond
((member type '("http" "https" "ftp" "mailto"))
(concat type ":" raw-path))
- ((and (string= type "file") (file-name-absolute-p raw-path))
- (concat "file://" raw-path))
- (t raw-path)))
- protocol)
+ ((string= type "file") (org-export-file-uri raw-path))
+ (t raw-path))))
(cond
+ ((org-export-custom-protocol-maybe link desc 'groff))
;; Image file.
(imagep (org-groff-link--inline-image link info))
;; import groff files
@@ -1270,8 +1268,7 @@ INFO is a plist holding contextual information. See
(let ((destination (org-export-resolve-radio-link link info)))
(if (not destination) desc
(format "\\fI [%s] \\fP"
- (org-export-solidify-link-text
- (org-element-property :value destination))))))
+ (org-export-get-reference destination info)))))
;; Links pointing to a headline: find destination and build
;; appropriate referencing command.
@@ -1303,9 +1300,9 @@ INFO is a plist holding contextual information. See
(org-element-property :title destination) info))))))
;; Fuzzy link points to a target. Do as above.
(otherwise
- (let ((path (org-export-solidify-link-text path)))
- (if (not desc) (format "\\fI%s\\fP" path)
- (format "%s \\fBat\\fP \\fI%s\\fP" desc path)))))))
+ (let ((ref (org-export-get-reference destination info)))
+ (if (not desc) (format "\\fI%s\\fP" ref)
+ (format "%s \\fBat\\fP \\fI%s\\fP" desc ref)))))))
;; External link with a description part.
((and path desc) (format "%s \\fBat\\fP \\fI%s\\fP" path desc))
;; External link without a description part.
@@ -1313,6 +1310,17 @@ INFO is a plist holding contextual information. See
;; No path, only description. Try to do something useful.
(t (format org-groff-link-with-unknown-path-format desc)))))
+;;; Node Property
+
+(defun org-groff-node-property (node-property contents info)
+ "Transcode a NODE-PROPERTY element from Org to Groff.
+CONTENTS is nil. INFO is a plist holding contextual
+information."
+ (format "%s:%s"
+ (org-element-property :key node-property)
+ (let ((value (org-element-property :value node-property)))
+ (if value (concat " " value) ""))))
+
;;; Paragraph
(defun org-groff-paragraph (paragraph contents info)
@@ -1423,6 +1431,15 @@ information."
"")
""))
+;;;; Property Drawer
+
+(defun org-groff-property-drawer (property-drawer contents info)
+ "Transcode a PROPERTY-DRAWER element from Org to Groff.
+CONTENTS holds the contents of the drawer. INFO is a plist
+holding contextual information."
+ (and (org-string-nw-p contents)
+ (format "\\fC\n%s\\fP" contents)))
+
;;; Quote Block
(defun org-groff-quote-block (quote-block contents info)
@@ -1433,25 +1450,13 @@ holding contextual information."
quote-block
(format ".DS I\n.I\n%s\n.R\n.DE" contents)))
-;;; Quote Section
-
-(defun org-groff-quote-section (quote-section contents info)
- "Transcode a QUOTE-SECTION element from Org to Groff.
-CONTENTS is nil. INFO is a plist holding contextual information."
- (let ((value (org-remove-indentation
- (org-element-property :value quote-section))))
- (when value (format ".DS L\n\\fI%s\\fP\n.DE\n" value))))
-
;;; Radio Target
(defun org-groff-radio-target (radio-target text info)
"Transcode a RADIO-TARGET object from Org to Groff.
TEXT is the text of the target. INFO is a plist holding
contextual information."
- (format "%s - %s"
- (org-export-solidify-link-text
- (org-element-property :value radio-target))
- text))
+ (format "%s - %s" (org-export-get-reference radio-target info) text))
;;; Section
@@ -1467,7 +1472,7 @@ holding contextual information."
"Transcode a SPECIAL-BLOCK element from Org to Groff.
CONTENTS holds the contents of the block. INFO is a plist
holding contextual information."
- (let ((type (downcase (org-element-property :type special-block))))
+ (let ((type (org-element-property :type special-block)))
(org-groff--wrap-label
special-block
(format "%s\n" contents))))
@@ -1781,8 +1786,7 @@ a communication channel."
"Transcode a TARGET object from Org to Groff.
CONTENTS is nil. INFO is a plist holding contextual
information."
- (format "\\fI%s\\fP"
- (org-export-solidify-link-text (org-element-property :value target))))
+ (format "\\fI%s\\fP" (org-export-get-reference target info)))
;;; Timestamp
diff --git a/contrib/lisp/ox-koma-letter.el b/contrib/lisp/ox-koma-letter.el
index 1755fbe..8ba380c 100644
--- a/contrib/lisp/ox-koma-letter.el
+++ b/contrib/lisp/ox-koma-letter.el
@@ -1,6 +1,6 @@
;;; ox-koma-letter.el --- KOMA Scrlttr2 Back-End for Org Export Engine
-;; Copyright (C) 2007-2012, 2014 Free Software Foundation, Inc.
+;; Copyright (C) 2007-2015 Free Software Foundation, Inc.
;; Author: Nicolas Goaziou <n.goaziou AT gmail DOT com>
;; Alan Schmitt <alan.schmitt AT polytechnique DOT org>
@@ -85,16 +85,10 @@
;; with information is present precedence is determined by
;; `org-koma-letter-prefer-special-headings'.
;;
-;; You will need to add an appropriate association in
-;; `org-latex-classes' in order to use the KOMA Scrlttr2 class.
-;; The easiest way to do this is by adding
-;;
-;; (eval-after-load "ox-koma-letter"
-;; '(org-koma-letter-plug-into-ox))
-;;
-;; to your init file. This will add a sparse scrlttr2 class and
-;; set it as the default `org-koma-latex-default-class'. You can also
-;; add you own letter class. For instace:
+;; You need an appropriate association in `org-latex-classes' in order
+;; to use the KOMA Scrlttr2 class. By default, a sparse scrlttr2
+;; class is provided: "default-koma-letter". You can also add you own
+;; letter class. For instance:
;;
;; (add-to-list 'org-latex-classes
;; '("my-letter"
@@ -127,6 +121,11 @@
(require 'ox-latex)
+;; Install a default letter class.
+(unless (assoc "default-koma-letter" org-latex-classes)
+ (add-to-list 'org-latex-classes
+ '("default-koma-letter" "\\documentclass[11pt]{scrlttr2}")))
+
;;; User-Configurable Variables
@@ -136,17 +135,20 @@
:group 'org-export)
(defcustom org-koma-letter-class-option-file "NF"
- "Letter Class Option File."
+ "Letter Class Option File.
+This option can also be set with the LCO keyword."
:group 'org-export-koma-letter
:type 'string)
(defcustom org-koma-letter-author 'user-full-name
- "The sender's name.
+ "Sender's name.
This variable defaults to calling the function `user-full-name'
-which just returns the current function `user-full-name'. Alternatively a
-string, nil or a function may be given. Functions must return a
-string."
+which just returns the current function `user-full-name'.
+Alternatively a string, nil or a function may be given.
+Functions must return a string.
+
+This option can also be set with the AUTHOR keyword."
:group 'org-export-koma-letter
:type '(radio (function-item user-full-name)
(string)
@@ -154,133 +156,223 @@ string."
(const :tag "Do not export author" nil)))
(defcustom org-koma-letter-email 'org-koma-letter-email
- "The sender's email address.
+ "Sender's email address.
This variable defaults to the value `org-koma-letter-email' which
-returns `user-mail-address'. Alternatively a string, nil or a
-function may be given. Functions must return a string."
+returns `user-mail-address'. Alternatively a string, nil or
+a function may be given. Functions must return a string.
+
+This option can also be set with the EMAIL keyword."
:group 'org-export-koma-letter
:type '(radio (function-item org-koma-letter-email)
(string)
(function)
(const :tag "Do not export email" nil)))
-(defcustom org-koma-letter-from-address nil
- "Sender's address, as a string."
+(defcustom org-koma-letter-from-address ""
+ "Sender's address, as a string.
+This option can also be set with one or more FROM_ADDRESS
+keywords."
:group 'org-export-koma-letter
:type 'string)
-(defcustom org-koma-letter-phone-number nil
- "Sender's phone number, as a string."
+(defcustom org-koma-letter-phone-number ""
+ "Sender's phone number, as a string.
+This option can also be set with the PHONE_NUMBER keyword."
:group 'org-export-koma-letter
:type 'string)
-(defcustom org-koma-letter-place nil
- "Place from which the letter is sent."
+(defcustom org-koma-letter-place ""
+ "Place from which the letter is sent, as a string.
+This option can also be set with the PLACE keyword."
:group 'org-export-koma-letter
:type 'string)
-(defcustom org-koma-letter-opening nil
+(defcustom org-koma-letter-opening ""
"Letter's opening, as a string.
-If (1) this value is nil; (2) the letter is started with a
-headline; and (3) `org-koma-letter-headline-is-opening-maybe' is
-t the value opening will be implicit set as the headline title."
+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
+ tag (e.g. \"to\" or \"ps\");
+then the opening will be implicitly set as the headline title."
:group 'org-export-koma-letter
:type 'string)
-(defcustom org-koma-letter-closing nil
- "Koma-Letter's closing, as a string."
+(defcustom org-koma-letter-closing ""
+ "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;
+ (2) `org-koma-letter-headline-is-opening-maybe' is non-nil;
+ (3) the letter contains a headline with the special
+ tag closing;
+then the opening will be set as the title of the closing special
+heading."
:group 'org-export-koma-letter
:type 'string)
-(defcustom org-koma-letter-prefer-special-headings nil
- "If TO and/or FROM is specified using both a heading and a keyword the heading value will be preferred if the variable is t."
+(defcustom org-koma-letter-signature ""
+ "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;
+ (2) `org-koma-letter-headline-is-opening-maybe' is non-nil;
+ (3) the letter contains a headline with the special
+ tag closing;
+then the signature will be set as the content of the
+closing special heading."
:group 'org-export-koma-letter
- :type 'boolean)
+ :type 'string)
-(defcustom org-koma-letter-signature nil
- "String used as the signature."
+(defcustom org-koma-letter-prefer-special-headings nil
+ "Non-nil means prefer headlines over keywords for TO and FROM.
+This option can also be set with the OPTIONS keyword, e.g.:
+\"special-headings:t\"."
:group 'org-export-koma-letter
- :type 'string)
+ :type 'boolean)
(defcustom org-koma-letter-subject-format t
- "Use the title as the subject of the letter.
+ "Non-nil means include the subject.
+
+Support formatting options.
-At this time the following values are allowed:
+When t, insert a subject using default options. When nil, do not
+insert a subject at all. It can also be a list of symbols among
+the following ones:
- - afteropening: subject after opening.
- - beforeopening: subject before opening.
- - centered: subject centered.
- - left:subject left-justified.
- - right: subject right-justified.
- - titled: add title/description to subject.
- - underlined: set subject underlined.
- - untitled: do not add title/description to subject.
- - No-export: do no insert a subject even if present.
+ `afteropening' Subject after opening
+ `beforeopening' Subject before opening
+ `centered' Subject centered
+ `left' Subject left-justified
+ `right' Subject right-justified
+ `titled' Add title/description to subject
+ `underlined' Set subject underlined
+ `untitled' Do not add title/description to subject
Please refer to the KOMA-script manual (Table 4.16. in the
-English manual of 2012-07-22)."
- :type '(radio
- (const :tag "No export" nil)
- (const :tag "Default options" t)
- (set :tag "selection"
- (const 'afteropening)
- (const 'beforeopening)
- (const 'centered)
- (const 'left)
- (const 'right)
- (const 'underlined)
- (const 'titled)
- (const 'untitled))
- (string))
+English manual of 2012-07-22).
+
+This option can also be set with the OPTIONS keyword, e.g.:
+\"subject:(underlined centered)\"."
+ :type
+ '(choice
+ (const :tag "No export" nil)
+ (const :tag "Default options" t)
+ (set :tag "Configure options"
+ (const :tag "Subject after opening" afteropening)
+ (const :tag "Subject before opening" beforeopening)
+ (const :tag "Subject centered" centered)
+ (const :tag "Subject left-justified" left)
+ (const :tag "Subject right-justified" right)
+ (const :tag "Add title or description to subject" underlined)
+ (const :tag "Set subject underlined" titled)
+ (const :tag "Do not add title or description to subject" untitled)))
:group 'org-export-koma-letter)
(defcustom org-koma-letter-use-backaddress nil
- "Print return address in line above to address."
+ "Non-nil prints return address in line above to address.
+This option can also be set with the OPTIONS keyword, e.g.:
+\"backaddress:t\"."
:group 'org-export-koma-letter
:type 'boolean)
-(defcustom org-koma-letter-use-foldmarks "true"
- "Configure appearence of fold marks.
+(defcustom org-koma-letter-use-foldmarks t
+ "Configure appearance of folding marks.
+
+When t, activate default folding marks. When nil, do not insert
+folding marks at all. It can also be a list of symbols among the
+following ones:
+
+ `B' Activate upper horizontal mark on left paper edge
+ `b' Deactivate upper horizontal mark on left paper edge
+
+ `H' Activate all horizontal marks on left paper edge
+ `h' Deactivate all horizontal marks on left paper edge
+
+ `L' Activate left vertical mark on upper paper edge
+ `l' Deactivate left vertical mark on upper paper edge
+
+ `M' Activate middle horizontal mark on left paper edge
+ `m' Deactivate middle horizontal mark on left paper edge
+
+ `P' Activate punch or center mark on left paper edge
+ `p' Deactivate punch or center mark on left paper edge
+
+ `T' Activate lower horizontal mark on left paper edge
+ `t' Deactivate lower horizontal mark on left paper edge
-Accepts any valid value for the KOMA-Script `foldmarks' option.
+ `V' Activate all vertical marks on upper paper edge
+ `v' Deactivate all vertical marks on upper paper edge
-Use `foldmarks:true' to activate default fold marks or
-`foldmarks:nil' to deactivate fold marks."
+This option can also be set with the OPTIONS keyword, e.g.:
+\"foldmarks:(b l m t)\"."
:group 'org-export-koma-letter
- :type 'string)
+ :type '(choice
+ (const :tag "Activate default folding marks" t)
+ (const :tag "Deactivate folding marks" nil)
+ (set
+ :tag "Configure folding marks"
+ (const :tag "Activate upper horizontal mark on left paper edge" B)
+ (const :tag "Deactivate upper horizontal mark on left paper edge" b)
+ (const :tag "Activate all horizontal marks on left paper edge" H)
+ (const :tag "Deactivate all horizontal marks on left paper edge" h)
+ (const :tag "Activate left vertical mark on upper paper edge" L)
+ (const :tag "Deactivate left vertical mark on upper paper edge" l)
+ (const :tag "Activate middle horizontal mark on left paper edge" M)
+ (const :tag "Deactivate middle horizontal mark on left paper edge" m)
+ (const :tag "Activate punch or center mark on left paper edge" P)
+ (const :tag "Deactivate punch or center mark on left paper edge" p)
+ (const :tag "Activate lower horizontal mark on left paper edge" T)
+ (const :tag "Deactivate lower horizontal mark on left paper edge" t)
+ (const :tag "Activate all vertical marks on upper paper edge" V)
+ (const :tag "Deactivate all vertical marks on upper paper edge" v))))
(defcustom org-koma-letter-use-phone nil
- "Print sender's phone number."
+ "Non-nil prints sender's phone number.
+This option can also be set with the OPTIONS keyword, e.g.:
+\"phone:t\"."
:group 'org-export-koma-letter
:type 'boolean)
(defcustom org-koma-letter-use-email nil
- "Print sender's email address."
+ "Non-nil prints sender's email address.
+This option can also be set with the OPTIONS keyword, e.g.:
+\"email:t\"."
:group 'org-export-koma-letter
:type 'boolean)
(defcustom org-koma-letter-use-place t
- "Print the letter's place next to the date."
+ "Non-nil prints the letter's place next to the date.
+This option can also be set with the OPTIONS keyword, e.g.:
+\"place:nil\"."
:group 'org-export-koma-letter
:type 'boolean)
-(defcustom org-koma-letter-default-class nil
+(defcustom org-koma-letter-default-class "default-koma-letter"
"Default class for `org-koma-letter'.
-
The value must be a member of `org-latex-classes'."
:group 'org-export-koma-letter
:type 'string)
(defcustom org-koma-letter-headline-is-opening-maybe t
- "Whether a headline may be used as an opening.
+ "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'."
:group 'org-export-koma-letter
:type 'boolean)
-(defconst org-koma-letter-special-tags-in-letter '(to from)
+(defcustom org-koma-letter-prefer-subject nil
+ "Non-nil means title should be interpreted as subject if subject is missing.
+This option can also be set with the OPTIONS keyword,
+e.g. \"title-subject:t\"."
+ :group 'org-export-koma-letter
+ :type 'boolean)
+
+(defconst org-koma-letter-special-tags-in-letter '(to from closing)
"Header tags related to the letter itself.")
(defconst org-koma-letter-special-tags-after-closing '(ps encl cc)
@@ -292,47 +384,58 @@ A headline is only used if #+OPENING is not set. See also
(defvar org-koma-letter-special-contents nil
"Holds special content temporarily.")
+(make-obsolete-variable 'org-koma-letter-use-title
+ 'org-export-with-title
+ "25.1" 'set)
;;; Define Back-End
(org-export-define-derived-backend 'koma-letter 'latex
:options-alist
- '((:lco "LCO" nil org-koma-letter-class-option-file)
- (:latex-class "LATEX_CLASS" nil (if org-koma-letter-default-class
- org-koma-letter-default-class
- org-latex-default-class) t)
- (:author "AUTHOR" nil (org-koma-letter--get-value org-koma-letter-author) t)
+ '((:latex-class "LATEX_CLASS" nil org-koma-letter-default-class t)
+ (:lco "LCO" nil org-koma-letter-class-option-file)
+ (:author "AUTHOR" nil (org-koma-letter--get-value org-koma-letter-author) parse)
(:author-changed-in-buffer-p "AUTHOR" nil nil t)
(:from-address "FROM_ADDRESS" nil org-koma-letter-from-address newline)
(:phone-number "PHONE_NUMBER" nil org-koma-letter-phone-number)
(:email "EMAIL" nil (org-koma-letter--get-value org-koma-letter-email) t)
- (:email-changed-in-buffer-p "EMAIL" nil nil t)
(:to-address "TO_ADDRESS" nil nil newline)
(:place "PLACE" nil org-koma-letter-place)
- (:opening "OPENING" nil org-koma-letter-opening)
- (:closing "CLOSING" nil org-koma-letter-closing)
+ (: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))
- (:special-headings nil "special-headings"
- org-koma-letter-prefer-special-headings)
(: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)
(:with-backaddress nil "backaddress" org-koma-letter-use-backaddress)
- (:with-backaddress-changed-in-buffer-p nil "backaddress" nil)
+ (:with-email nil "email" org-koma-letter-use-email)
(:with-foldmarks nil "foldmarks" org-koma-letter-use-foldmarks)
- (:with-foldmarks-changed-in-buffer-p nil "foldmarks" "foldmarks-not-set")
(:with-phone nil "phone" org-koma-letter-use-phone)
- (:with-phone-changed-in-buffer-p nil "phone" nil)
- (:with-email nil "email" org-koma-letter-use-email)
- (:with-email-changed-in-buffer-p nil "email" nil)
(:with-place nil "place" org-koma-letter-use-place)
- (:with-subject nil "subject" org-koma-letter-subject-format))
+ (:with-subject nil "subject" org-koma-letter-subject-format)
+ (:with-title-as-subject nil "title-subject" org-koma-letter-prefer-subject)
+ (:with-headline-opening nil nil org-koma-letter-headline-is-opening-maybe)
+ ;; Special properties non-nil when a setting happened in buffer.
+ ;; They are used to prioritize in-buffer settings over "lco"
+ ;; files. See `org-koma-letter-template'.
+ (:inbuffer-author "AUTHOR" 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-signature "SIGNATURE" nil 'koma-letter:empty)
+ (:inbuffer-with-backaddress nil "backaddress" 'koma-letter:empty)
+ (:inbuffer-with-email nil "email" 'koma-letter:empty)
+ (:inbuffer-with-foldmarks nil "foldmarks" 'koma-letter:empty)
+ (:inbuffer-with-phone nil "phone" 'koma-letter:empty))
:translate-alist '((export-block . org-koma-letter-export-block)
(export-snippet . org-koma-letter-export-snippet)
(headline . org-koma-letter-headline)
@@ -348,19 +451,8 @@ A headline is only used if #+OPENING is not set. See also
(if a (org-koma-letter-export-to-pdf t s v b)
(org-open-file (org-koma-letter-export-to-pdf nil s v b))))))))
-
-;;; Initialize class function
-
-(defun org-koma-letter-plug-into-ox ()
- "Add a sparse `default-koma-letter' to `org-latex-classes' and set `org-koma-letter-default-class' to `default-koma-letter'."
- (let ((class "default-koma-letter"))
- (eval-after-load "ox-latex"
- `(unless (member ,class 'org-latex-classes)
- (add-to-list 'org-latex-classes
- `(,class
- "\\documentclass[11pt]{scrlttr2}") ())
- (setq org-koma-letter-default-class class)))))
+
;;; Helper functions
(defun org-koma-letter-email ()
@@ -372,83 +464,63 @@ A headline is only used if #+OPENING is not set. See also
(defun org-koma-letter--get-tagged-contents (key)
"Get contents from a headline tagged with KEY.
-Technically, the contents is stored in `org-koma-letter-special-contents'."
- (cdr (assoc (org-koma-letter--get-value key)
- org-koma-letter-special-contents)))
+The contents is stored in `org-koma-letter-special-contents'."
+ (cdr (assoc-string (org-koma-letter--get-value key)
+ org-koma-letter-special-contents)))
(defun org-koma-letter--get-value (value)
- "Determines if VALUE is nil, a string, a function or a symbol and return a string or nil."
+ "Turn value into a string whenever possible.
+Determines if VALUE is nil, a string, a function or a symbol and
+return a string or nil."
(when value
(cond ((stringp value) value)
((functionp value) (funcall value))
((symbolp value) (symbol-name value))
(t value))))
+(defun org-koma-letter--special-contents-as-macro
+ (keywords &optional keep-newlines no-tag)
+ "Process KEYWORDS members of `org-koma-letter-special-contents'.
+KEYWORDS is a list of symbols. Return them as a string to be
+formatted.
-(defun org-koma-letter--special-contents-as-macro (a-list &optional keep-newlines no-tag)
- "Find members of `org-koma-letter-special-contents' corresponding to A-LIST.
-Return them as a string to be formatted.
-
-The function is used for inserting content of speciall headings
+The function is used for inserting content of special headings
such as PS.
-If KEEP-NEWLINES is t newlines will not be removed. If NO-TAG is
-is t the content in `org-koma-letter-special-contents' will not
-be wrapped in a macro named whatever the members of A-LIST are
-called."
- (let (output)
- (dolist (ac* a-list output)
- (let*
- ((ac (org-koma-letter--get-value ac*))
- (x (org-koma-letter--get-tagged-contents ac)))
- (when x
- (setq output
- (concat
- output "\n"
- ;; sometimes LaTeX complains about newlines
- ;; at the end or beginning of macros. Remove them.
- (org-koma-letter--format-string-as-macro
- (if keep-newlines x (org-koma-letter--normalize-string x))
- (unless no-tag ac)))))))))
-
-(defun org-koma-letter--format-string-as-macro (string &optional macro)
- "Format STRING as \"\\macro{string}\" if MACRO is given else as \"string\"."
- (if macro
- (format "\\%s{%s}" macro string)
- (format "%s" string)))
-
-(defun org-koma-letter--normalize-string (string)
- "Remove new lines in the beginning and end of `STRING'."
- (replace-regexp-in-string "\\`[ \n\t]+\\|[\n\t ]*\\'" "" string))
+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."
+ (mapconcat
+ (lambda (keyword)
+ (let* ((name (org-koma-letter--get-value keyword))
+ (value (org-koma-letter--get-tagged-contents name)))
+ (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)))))))
+ keywords
+ ""))
(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
+`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* ((plist-alist '((from . :from-address)
- (to . :to-address)))
- (default-alist `((from ,org-koma-letter-from-address)
- (to "\\mbox{}")))
- (option-value (plist-get info (cdr-safe (assoc key plist-alist))))
- (head-value (org-koma-letter--get-tagged-contents key))
- (order (append
- (funcall
- (if (plist-get info :special-headings)
- 'reverse 'identity)
- `(,option-value ,head-value))
- (cdr-safe (assoc key default-alist))))
- tmp
- (adr (dolist (x order tmp)
- (when (and (not tmp) x)
- (setq tmp x)))))
- (when adr
+ (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-koma-letter--normalize-string adr)))))
+ (org-trim
+ (if (plist-get info :special-headings) (or headline option "")
+ (or option headline ""))))))
+
+
;;; Transcode Functions
;;;; Export Block
@@ -477,12 +549,11 @@ CONTENTS is nil. INFO is a plist used as a communication
channel."
(let ((key (org-element-property :key keyword))
(value (org-element-property :value keyword)))
- ;; Handle specifically BEAMER and TOC (headlines only) keywords.
- ;; Otherwise, fallback to `latex' back-end.
+ ;; Handle specifically KOMA-LETTER keywords. Otherwise, fallback
+ ;; to `latex' back-end.
(if (equal key "KOMA-LETTER") value
(org-export-with-backend 'latex keyword contents info))))
-
;; Headline
(defun org-koma-letter-headline (headline contents info)
@@ -494,24 +565,21 @@ Note that if a headline is tagged with a tag from
`org-koma-letter-special-tags' it will not be exported, but
stored in `org-koma-letter-special-contents' and included at the
appropriate place."
- (let*
- ((tags (org-export-get-tags headline info))
- (tag* (car tags))
- (tag (when tag*
- (car (member-ignore-case
- tag*
- (mapcar 'symbol-name (plist-get info :special-tags)))))))
- (if tag
- (progn
- (push (cons tag contents)
- org-koma-letter-special-contents)
- nil)
- (unless (or (plist-get info :opening)
- (not org-koma-letter-headline-is-opening-maybe))
- (plist-put info :opening
- (org-export-data (org-element-property :title headline) info)))
- contents)))
-
+ (let ((special-tag (org-koma-letter--special-tag headline info)))
+ (if (not special-tag)
+ contents
+ (push (cons special-tag contents) org-koma-letter-special-contents)
+ "")))
+
+(defun org-koma-letter--special-tag (headline info)
+ "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)))
+ (catch 'exit
+ (dolist (tag (org-export-get-tags headline info))
+ (let ((tag (assoc-string tag special-tags)))
+ (when tag (throw 'exit tag)))))))
;;;; Template
@@ -519,123 +587,89 @@ appropriate place."
"Return complete document string after KOMA Scrlttr2 conversion.
CONTENTS is the transcoded contents string. INFO is a plist
holding export options."
- ;; FIXME: instead of setq'ing org-koma-letter-special-contents and
- ;; callying varioues stuff it might be nice to put a big let* around the templace
- ;; as in org-groff...
(concat
;; Time-stamp.
(and (plist-get info :time-stamp-file)
(format-time-string "%% Created %Y-%m-%d %a %H:%M\n"))
;; Document class and packages.
- (let* ((class (plist-get info :latex-class))
- (class-options (plist-get info :latex-class-options))
- (header (nth 1 (assoc class org-latex-classes)))
- (document-class-string
- (and (stringp header)
- (if (not class-options) header
- (replace-regexp-in-string
- "^[ \t]*\\\\documentclass\\(\\(\\[[^]]*\\]\\)?\\)"
- class-options header t nil 1)))))
- (if (not document-class-string)
- (user-error "Unknown LaTeX class `%s'" class)
- (org-latex-guess-babel-language
- (org-latex-guess-inputenc
- (org-element-normalize-string
- (org-splice-latex-header
- document-class-string
- org-latex-default-packages-alist ; Defined in org.el.
- org-latex-packages-alist nil ; Defined in org.el.
- (concat (org-element-normalize-string (plist-get info :latex-header))
- (plist-get info :latex-header-extra)))))
- info)))
- (let ((lco (plist-get info :lco))
- (author (plist-get info :author))
- (author-set (plist-get info :author-changed-in-buffer-p))
- (from-address (org-koma-letter--determine-to-and-from info 'from))
- (phone-number (plist-get info :phone-number))
- (email (plist-get info :email))
- (email-set (plist-get info :email-changed-in-buffer-p))
- (signature (plist-get info :signature)))
- (concat
- ;; author or email not set in file: may be overridden by lco
- (unless author-set
- (when author (format "\\setkomavar{fromname}{%s}\n"
- (org-export-data author info))))
- (unless email-set
- (when email (format "\\setkomavar{fromemail}{%s}\n" email)))
- ;; Letter Class Option File
- (when lco
- (let ((lco-files (split-string lco " "))
- (lco-def ""))
- (dolist (lco-file lco-files lco-def)
- (setq lco-def (format "%s\\LoadLetterOption{%s}\n" lco-def lco-file)))
- lco-def))
- ;; Define "From" data.
- (when (and author author-set) (format "\\setkomavar{fromname}{%s}\n"
- (org-export-data author info)))
- (when from-address (format "\\setkomavar{fromaddress}{%s}\n" from-address))
- (when phone-number
- (format "\\setkomavar{fromphone}{%s}\n" phone-number))
- (when (and email email-set) (format "\\setkomavar{fromemail}{%s}\n" email))
- (when signature (format "\\setkomavar{signature}{%s}\n" signature))))
+ (org-latex--make-header 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
+ ;; variables, then we insert LCO files, and, eventually, we insert
+ ;; settings coming from buffer keywords.
+ (org-koma-letter--build-settings 'global info)
+ (mapconcat #'(lambda (file) (format "\\LoadLetterOption{%s}\n" file))
+ (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))
- ;; Place
- (let ((with-place (plist-get info :with-place))
- (place (plist-get info :place)))
- (when (or place (not with-place))
- (format "\\setkomavar{place}{%s}\n" (if with-place place ""))))
- ;; KOMA options
- (let ((with-backaddress (plist-get info :with-backaddress))
- (with-backaddress-set (plist-get info :with-backaddress-changed-in-buffer-p))
- (with-foldmarks (plist-get info :with-foldmarks))
- (with-foldmarks-set
- (not (string-equal (plist-get info :with-foldmarks-changed-in-buffer-p)
- "foldmarks-not-set")))
- (with-phone (plist-get info :with-phone))
- (with-phone-set (plist-get info :with-phone-changed-in-buffer-p))
- (with-email (plist-get info :with-email))
- (with-email-set (plist-get info :with-email-changed-in-buffer-p)))
- (concat
- (when with-backaddress-set
- (format "\\KOMAoption{backaddress}{%s}\n" (if with-backaddress "true" "false")))
- (when with-foldmarks-set
- (format "\\KOMAoption{foldmarks}{%s}\n" (if with-foldmarks with-foldmarks "false")))
- (when with-phone-set
- (format "\\KOMAoption{fromphone}{%s}\n" (if with-phone "true" "false")))
- (when with-email-set
- (format "\\KOMAoption{fromemail}{%s}\n" (if with-email "true" "false")))))
- ;; Document start
- "\\begin{document}\n\n"
- ;; Subject
+ ;; Hyperref, document start, and subject and title.
(let* ((with-subject (plist-get info :with-subject))
- (subject-format (cond ((member with-subject '("true" "t" t)) nil)
- ((stringp with-subject) (list with-subject))
- ((symbolp with-subject)
- (list (symbol-name with-subject)))
- (t with-subject)))
- (subject (org-export-data (plist-get info :title) info))
- (l (length subject-format))
- (y ""))
+ (with-title (plist-get info :with-title))
+ (title-as-subject (and with-subject
+ (plist-get info :with-title-as-subject)))
+ (subject* (org-string-nw-p
+ (org-export-data (plist-get info :subject) info)))
+ (title* (and with-title
+ (org-string-nw-p
+ (org-export-data (plist-get info :title) info))))
+ (subject (cond ((not with-subject) nil)
+ (title-as-subject (or subject* title*))
+ (t subject*)))
+ (title (cond ((not with-title) nil)
+ (title-as-subject (and subject* title*))
+ (t title*)))
+ (hyperref-template (plist-get info :latex-hyperref-template))
+ (spec (append (list (cons ?t (or title subject "")))
+ (org-latex--format-spec info))))
(concat
- (when (and with-subject subject-format)
- (concat
- "\\KOMAoption{subject}{"
- (apply 'format
- (dotimes (x l y)
- (setq y (concat (if (> x 0) "%s," "%s") y)))
- subject-format) "}\n"))
- (when (and subject with-subject)
- (format "\\setkomavar{subject}{%s}\n\n" subject))))
- ;; Letter start
+ (when (and with-subject (not (eq with-subject t)))
+ (format "\\KOMAoption{subject}{%s}\n"
+ (if (symbolp with-subject) with-subject
+ (mapconcat #'symbol-name with-subject ","))))
+ ;; Hyperref.
+ (format-spec hyperref-template spec)
+ ;; Document start.
+ "\\begin{document}\n\n"
+ ;; Subject and title.
+ (when subject (format "\\setkomavar{subject}{%s}\n" subject))
+ (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))
;; Opening.
- (format "\\opening{%s}\n\n" (or (plist-get info :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))
+ "")
+ info))
;; Letter body.
contents
;; Closing.
- (format "\n\\closing{%s}\n" (or (plist-get info :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)))
+ info))
(org-koma-letter--special-contents-as-macro
(plist-get info :with-after-closing))
;; Letter end.
@@ -643,8 +677,75 @@ holding export options."
(org-koma-letter--special-contents-as-macro
(plist-get info :with-after-letter) t t)
;; Document end.
- "\n\\end{document}"
- ))
+ "\n\\end{document}"))
+
+(defun org-koma-letter--build-settings (scope info)
+ "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))))))))
+ (concat
+ ;; Name.
+ (let ((author (plist-get info :author)))
+ (and author
+ (funcall check-scope 'author)
+ (format "\\setkomavar{fromname}{%s}\n"
+ (org-export-data author info))))
+ ;; Email.
+ (let ((email (plist-get info :email)))
+ (and email
+ (funcall check-scope 'email)
+ (format "\\setkomavar{fromemail}{%s}\n" email)))
+ (and (funcall check-scope 'with-email)
+ (format "\\KOMAoption{fromemail}{%s}\n"
+ (if (plist-get info :with-email) "true" "false")))
+ ;; Phone number.
+ (let ((phone-number (plist-get info :phone-number)))
+ (and (org-string-nw-p phone-number)
+ (funcall check-scope 'phone-number)
+ (format "\\setkomavar{fromphone}{%s}\n" phone-number)))
+ (and (funcall check-scope 'with-phone)
+ (format "\\KOMAoption{fromphone}{%s}\n"
+ (if (plist-get info :with-phone) "true" "false")))
+ ;; Signature.
+ (let* ((heading-val
+ (and (plist-get info :with-headline-opening)
+ (org-string-nw-p
+ (org-trim
+ (org-export-data
+ (org-koma-letter--get-tagged-contents 'closing)
+ info)))))
+ (signature (org-string-nw-p (plist-get info :signature)))
+ (signature-scope (funcall check-scope 'signature)))
+ (and (or (and signature signature-scope)
+ heading-val)
+ (not (and (eq scope 'global) heading-val))
+ (format "\\setkomavar{signature}{%s}\n"
+ (if signature-scope signature heading-val))))
+ ;; Back address.
+ (and (funcall check-scope 'with-backaddress)
+ (format "\\KOMAoption{backaddress}{%s}\n"
+ (if (plist-get info :with-backaddress) "true" "false")))
+ ;; Place.
+ (and (funcall check-scope 'place)
+ (format "\\setkomavar{place}{%s}\n"
+ (if (plist-get info :with-place) (plist-get info :place) "")))
+ ;; Folding marks.
+ (and (funcall check-scope 'with-foldmarks)
+ (let ((foldmarks (plist-get info :with-foldmarks)))
+ (cond ((consp foldmarks)
+ (format "\\KOMAoptions{foldmarks=true,foldmarks=%s}\n"
+ (mapconcat #'symbol-name foldmarks "")))
+ (foldmarks "\\KOMAoptions{foldmarks=true}\n")
+ (t "\\KOMAoptions{foldmarks=false}\n")))))))
+
;;; Commands
diff --git a/contrib/lisp/ox-rss.el b/contrib/lisp/ox-rss.el
index 5fd2afc..4cdfe0e 100644
--- a/contrib/lisp/ox-rss.el
+++ b/contrib/lisp/ox-rss.el
@@ -1,6 +1,6 @@
;;; ox-rss.el --- RSS 2.0 Back-End for Org Export Engine
-;; Copyright (C) 2013, 2014 Bastien Guerry
+;; Copyright (C) 2013-2015 Bastien Guerry
;; Author: Bastien Guerry <bzg@gnu.org>
;; Keywords: org, wp, blog, feed, rss
@@ -42,6 +42,9 @@
;; PUBDATE property. If `org-rss-use-entry-url-as-guid', it will also add
;; an ID property, later used as the guid for the feed's item.
;;
+;; The top-level headline is used as the title of each RSS item unless
+;; an RSS_TITLE property is set on the headline.
+;;
;; You typically want to use it within a publishing project like this:
;;
;; (add-to-list
@@ -119,7 +122,9 @@ When nil, Org will create ids using `org-icalendar-create-uid'."
(if a (org-rss-export-to-rss t s v)
(org-open-file (org-rss-export-to-rss nil s v)))))))
:options-alist
- '((:with-toc nil nil nil) ;; Never include HTML's toc
+ '((:description "DESCRIPTION" nil nil newline)
+ (:keywords "KEYWORDS" nil nil space)
+ (: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-categories nil nil org-rss-categories))
@@ -204,10 +209,12 @@ publishing directory.
Return output file name."
(let ((bf (get-file-buffer filename)))
(if bf
- (with-current-buffer bf
- (org-rss-add-pubdate-property)
- (write-file filename))
+ (with-current-buffer bf
+ (org-icalendar-create-uid filename 'warn-user)
+ (org-rss-add-pubdate-property)
+ (write-file filename))
(find-file filename)
+ (org-icalendar-create-uid filename 'warn-user)
(org-rss-add-pubdate-property)
(write-file filename) (kill-buffer)))
(org-publish-org-to
@@ -222,29 +229,29 @@ 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* ((htmlext (plist-get info :html-extension))
+ (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-solidify-link-text
- (or (org-element-property :CUSTOM_ID headline)
- (concat "sec-" (mapconcat 'number-to-string hl-number "-")))))
+ (anchor (org-export-get-reference headline info))
(category (org-rss-plain-text
(or (org-element-property :CATEGORY headline) "") info))
- (pubdate
- (let ((system-time-locale "C"))
- (format-time-string
- "%a, %d %b %Y %H:%M:%S %z"
- (org-time-string-to-time
- (or (org-element-property :PUBDATE headline)
- (error "Missing PUBDATE property"))))))
- (title (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)))
+ (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
@@ -259,17 +266,19 @@ communication channel."
(org-element-property :CUSTOM_ID headline)
publink)
info))))
- (format
- (concat
- "<item>\n"
- "<title>%s</title>\n"
- "<link>%s</link>\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 guid pubdate contents))))
+ (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)))))
(defun org-rss-build-categories (headline info)
"Build categories for the RSS item."
diff --git a/contrib/lisp/ox-s5.el b/contrib/lisp/ox-s5.el
index 26e83a3..503bfd0 100644
--- a/contrib/lisp/ox-s5.el
+++ b/contrib/lisp/ox-s5.el
@@ -48,7 +48,14 @@
;; in an Org mode buffer. See ox.el and ox-html.el for more details
;; on how this exporter works.
+;; TODOs
+;; ------
+;; The title page is formatted using format-spec. This is error prone
+;; when details are missing and may insert empty tags, like <h2></h2>,
+;; for missing values.
+
(require 'ox-html)
+(eval-when-compile (require 'cl))
(org-export-define-derived-backend 's5 'html
:menu-entry
@@ -173,6 +180,7 @@ or an empty string."
(defcustom org-s5-title-slide-template
"<h1>%t</h1>
+<h2>%s</h2>
<h2>%a</h2>
<h3>%e</h3>
<h4>%d</h4>"
@@ -201,7 +209,7 @@ INFO is a plist used as a communication channel."
(concat section-number
(org-export-data
(org-export-get-alt-title headline info) info)
- (and tags "&nbsp;&nbsp;&nbsp;") (org-html--tags tags))))
+ (and tags "&nbsp;&nbsp;&nbsp;") (org-html--tags tags info))))
(defun org-s5-toc (depth info)
(let* ((headlines (org-export-collect-headlines info depth))
diff --git a/contrib/lisp/ox-taskjuggler.el b/contrib/lisp/ox-taskjuggler.el
index 761e180..2bd47e6 100644
--- a/contrib/lisp/ox-taskjuggler.el
+++ b/contrib/lisp/ox-taskjuggler.el
@@ -64,7 +64,7 @@
;; should end up with something similar to the example by Peter Jones
;; in:
;;
-;; http://www.contextualdevelopment.com/static/artifacts/articles/2008/project-planning/project-planning.org.
+;; http://www.devalot.com/assets/articles/2008/07/project-planning/project-planning.org.
;;
;; Now mark the top node of your tasks with a tag named
;; "taskjuggler_project" (or whatever you customized
@@ -307,7 +307,23 @@ but before any resource and task declarations."
startbuffer startcredit statusnote chargeset charge)
"Valid attributes for Taskjuggler tasks.
If one of these appears as a property for a headline, it will be
-exported with the corresponding task."
+exported with the corresponding task.
+
+Note that multiline properties are not supported, so attributes
+like note or journalentry have to be on a single line."
+ :group 'org-export-taskjuggler)
+
+(defcustom org-taskjuggler-valid-project-attributes
+ '(timingresolution timezone alertlevels currency currencyformat
+ dailyworkinghours extend includejournalentry now numberformat
+ outputdir scenario shorttimeformat timeformat trackingscenario
+ weekstartsmonday weekstartssunday workinghours
+ yearlyworkingdays)
+ "Valid attributes for Taskjuggler project.
+If one of these appears as a property for a headline that is a
+project definition, it will be exported with the corresponding
+task. Attribute 'timingresolution' should be the first in the
+list."
:group 'org-export-taskjuggler)
(defcustom org-taskjuggler-valid-resource-attributes
@@ -483,9 +499,9 @@ Return new string. If S is the empty string, return it."
(if (equal "" s) s (replace-regexp-in-string "^ *\\S-" " \\&" s)))
(defun org-taskjuggler--build-attributes (item attributes)
- "Return attributes string for task, resource or report ITEM.
-ITEM is a headline. ATTRIBUTES is a list of symbols
-representing valid attributes for ITEM."
+ "Return attributes string for ITEM.
+ITEM is a project, task, resource or report headline. ATTRIBUTES
+is a list of symbols representing valid attributes for ITEM."
(mapconcat
(lambda (attribute)
(let ((value (org-element-property
@@ -587,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))))
+ (org-match-string-no-properties 1 dep-str))))
path)
;; Compute number of exclamation marks by looking for the
;; common ancestor between TASK and DEP.
@@ -715,18 +731,27 @@ PROJECT is a headline. INFO is a plist used as a communication
channel. If no start date is specified, start today. If no end
date is specified, end `org-taskjuggler-default-project-duration'
days from now."
- (format "project %s \"%s\" \"%s\" %s %s {\n}\n"
- (org-taskjuggler-get-id project info)
- (org-taskjuggler-get-name project)
- ;; Version is obtained through :TASKJUGGLER_VERSION:
- ;; property or `org-taskjuggler-default-project-version'.
- (or (org-element-property :VERSION project)
- org-taskjuggler-default-project-version)
- (or (org-taskjuggler-get-start project)
- (format-time-string "%Y-%m-%d"))
- (let ((end (org-taskjuggler-get-end project)))
- (or (and end (format "- %s" end))
- (format "+%sd" org-taskjuggler-default-project-duration)))))
+ (concat
+ ;; Opening project.
+ (format "project %s \"%s\" \"%s\" %s %s {\n"
+ (org-taskjuggler-get-id project info)
+ (org-taskjuggler-get-name project)
+ ;; Version is obtained through :TASKJUGGLER_VERSION:
+ ;; property or `org-taskjuggler-default-project-version'.
+ (or (org-element-property :VERSION project)
+ org-taskjuggler-default-project-version)
+ (or (org-taskjuggler-get-start project)
+ (format-time-string "%Y-%m-%d"))
+ (let ((end (org-taskjuggler-get-end project)))
+ (or (and end (format "- %s" end))
+ (format "+%sd"
+ org-taskjuggler-default-project-duration))))
+ ;; Add attributes.
+ (org-taskjuggler--indent-string
+ (org-taskjuggler--build-attributes
+ project org-taskjuggler-valid-project-attributes))
+ ;; Closing project.
+ "}\n"))
(defun org-taskjuggler--build-resource (resource info)
"Return a resource declaration.