summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--.gitignore1
-rw-r--r--Makefile2
-rw-r--r--README_contribute8
-rw-r--r--README_maintainer1
-rw-r--r--contrib/README11
-rw-r--r--contrib/lisp/htmlize.el25
-rw-r--r--contrib/lisp/ob-csharp.el83
-rw-r--r--contrib/lisp/ob-eukleides.el4
-rw-r--r--contrib/lisp/ob-fomus.el2
-rw-r--r--contrib/lisp/ob-julia.el13
-rw-r--r--contrib/lisp/ob-mathematica.el82
-rw-r--r--contrib/lisp/ob-mathomatic.el64
-rw-r--r--contrib/lisp/ob-oz.el4
-rw-r--r--contrib/lisp/ob-stata.el312
-rw-r--r--contrib/lisp/ob-tcl.el8
-rw-r--r--contrib/lisp/ob-vbnet.el84
-rw-r--r--contrib/lisp/org-annotate-file.el114
-rw-r--r--contrib/lisp/org-bibtex-extras.el30
-rw-r--r--contrib/lisp/org-bookmark.el7
-rw-r--r--contrib/lisp/org-collector.el10
-rw-r--r--contrib/lisp/org-colview-xemacs.el1725
-rw-r--r--contrib/lisp/org-contacts.el485
-rw-r--r--contrib/lisp/org-contribdir.el2
-rw-r--r--contrib/lisp/org-depend.el2
-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.el370
-rw-r--r--contrib/lisp/org-eldoc.el173
-rw-r--r--contrib/lisp/org-elisp-symbol.el7
-rw-r--r--contrib/lisp/org-eval-light.el2
-rw-r--r--contrib/lisp/org-eval.el2
-rw-r--r--contrib/lisp/org-expiry.el21
-rwxr-xr-xcontrib/lisp/org-favtable.el1701
-rw-r--r--contrib/lisp/org-git-link.el39
-rw-r--r--contrib/lisp/org-index.el2987
-rw-r--r--contrib/lisp/org-interactive-query.el4
-rw-r--r--contrib/lisp/org-jira.el64
-rw-r--r--contrib/lisp/org-learn.el2
-rw-r--r--contrib/lisp/org-license.el540
-rw-r--r--contrib/lisp/org-link-edit.el327
-rw-r--r--contrib/lisp/org-mac-link.el822
-rw-r--r--contrib/lisp/org-mairix.el5
-rw-r--r--contrib/lisp/org-man.el6
-rw-r--r--contrib/lisp/org-mew.el20
-rw-r--r--contrib/lisp/org-mime.el151
-rw-r--r--contrib/lisp/org-mtags.el255
-rw-r--r--contrib/lisp/org-notify.el10
-rw-r--r--contrib/lisp/org-notmuch.el53
-rw-r--r--contrib/lisp/org-passwords.el384
-rw-r--r--contrib/lisp/org-screenshot.el13
-rw-r--r--contrib/lisp/org-sudoku.el2
-rw-r--r--contrib/lisp/org-toc.el10
-rw-r--r--contrib/lisp/org-track.el3
-rw-r--r--contrib/lisp/org-velocity.el602
-rw-r--r--contrib/lisp/org-vm.el24
-rw-r--r--contrib/lisp/org-wikinodes.el22
-rw-r--r--contrib/lisp/org-wl.el21
-rw-r--r--contrib/lisp/orgtbl-sqlinsert.el2
-rw-r--r--contrib/lisp/ox-bibtex.el360
-rw-r--r--contrib/lisp/ox-confluence.el45
-rw-r--r--contrib/lisp/ox-deck.el23
-rw-r--r--contrib/lisp/ox-extra.el190
-rw-r--r--contrib/lisp/ox-freemind.el5
-rw-r--r--contrib/lisp/ox-gfm.el192
-rw-r--r--contrib/lisp/ox-groff.el93
-rw-r--r--contrib/lisp/ox-koma-letter.el808
-rw-r--r--contrib/lisp/ox-rss.el138
-rw-r--r--contrib/lisp/ox-s5.el10
-rw-r--r--contrib/lisp/ox-taskjuggler.el63
-rw-r--r--contrib/orgmanual.org19743
-rw-r--r--contrib/scripts/org-docco.org2
-rw-r--r--doc/docstyle.texi10
-rw-r--r--doc/htmlxref.cnf2
-rw-r--r--doc/org.texi5064
-rw-r--r--doc/orgcard.tex2
-rw-r--r--doc/orgguide.texi242
-rw-r--r--doc/texinfo.tex3161
-rw-r--r--etc/ORG-NEWS1178
-rw-r--r--etc/styles/OrgOdtStyles.xml20
-rw-r--r--lisp/ob-C.el422
-rw-r--r--lisp/ob-J.el176
-rw-r--r--lisp/ob-R.el248
-rw-r--r--lisp/ob-abc.el92
-rw-r--r--lisp/ob-asymptote.el41
-rw-r--r--lisp/ob-awk.el34
-rw-r--r--lisp/ob-calc.el20
-rw-r--r--lisp/ob-clojure.el109
-rw-r--r--lisp/ob-comint.el106
-rw-r--r--lisp/ob-coq.el78
-rw-r--r--lisp/ob-core.el2626
-rw-r--r--lisp/ob-css.el10
-rw-r--r--lisp/ob-ditaa.el32
-rw-r--r--lisp/ob-dot.el17
-rw-r--r--lisp/ob-ebnf.el83
-rw-r--r--lisp/ob-emacs-lisp.el40
-rw-r--r--lisp/ob-eval.el12
-rw-r--r--lisp/ob-exp.el511
-rw-r--r--lisp/ob-forth.el87
-rw-r--r--lisp/ob-fortran.el54
-rw-r--r--lisp/ob-gnuplot.el47
-rw-r--r--lisp/ob-groovy.el116
-rw-r--r--lisp/ob-haskell.el39
-rw-r--r--lisp/ob-io.el42
-rw-r--r--lisp/ob-java.el36
-rw-r--r--lisp/ob-js.el18
-rw-r--r--lisp/ob-keys.el9
-rw-r--r--lisp/ob-latex.el127
-rw-r--r--lisp/ob-ledger.el9
-rw-r--r--lisp/ob-lilypond.el350
-rw-r--r--lisp/ob-lisp.el84
-rw-r--r--lisp/ob-lob.el181
-rw-r--r--lisp/ob-lua.el405
-rw-r--r--lisp/ob-makefile.el10
-rw-r--r--lisp/ob-matlab.el4
-rw-r--r--lisp/ob-maxima.el17
-rw-r--r--lisp/ob-mscgen.el6
-rw-r--r--lisp/ob-ocaml.el85
-rw-r--r--lisp/ob-octave.el74
-rw-r--r--lisp/ob-org.el8
-rw-r--r--lisp/ob-perl.el23
-rw-r--r--lisp/ob-picolisp.el12
-rw-r--r--lisp/ob-plantuml.el25
-rw-r--r--lisp/ob-processing.el195
-rw-r--r--lisp/ob-python.el94
-rw-r--r--lisp/ob-ref.el234
-rw-r--r--lisp/ob-ruby.el89
-rw-r--r--lisp/ob-sass.el9
-rw-r--r--lisp/ob-scala.el38
-rw-r--r--lisp/ob-scheme.el40
-rw-r--r--lisp/ob-screen.el18
-rw-r--r--lisp/ob-sed.el107
-rw-r--r--lisp/ob-shell.el (renamed from lisp/ob-sh.el)167
-rw-r--r--lisp/ob-shen.el11
-rw-r--r--lisp/ob-sql.el181
-rw-r--r--lisp/ob-sqlite.el13
-rw-r--r--lisp/ob-stan.el84
-rw-r--r--lisp/ob-table.el46
-rw-r--r--lisp/ob-tangle.el307
-rw-r--r--lisp/ob.el4
-rw-r--r--lisp/org-agenda.el2787
-rw-r--r--lisp/org-archive.el393
-rw-r--r--lisp/org-attach.el143
-rw-r--r--lisp/org-bbdb.el119
-rw-r--r--lisp/org-bibtex.el173
-rw-r--r--lisp/org-capture.el744
-rw-r--r--lisp/org-clock.el1147
-rw-r--r--lisp/org-colview.el2298
-rw-r--r--lisp/org-compat.el656
-rw-r--r--lisp/org-crypt.el146
-rw-r--r--lisp/org-ctags.el119
-rw-r--r--lisp/org-datetree.el278
-rw-r--r--lisp/org-docview.el36
-rw-r--r--lisp/org-element.el5770
-rw-r--r--lisp/org-entities.el1008
-rw-r--r--lisp/org-eshell.el11
-rw-r--r--lisp/org-eww.el172
-rw-r--r--lisp/org-faces.el548
-rw-r--r--lisp/org-feed.el169
-rw-r--r--lisp/org-footnote.el1188
-rw-r--r--lisp/org-gnus.el55
-rw-r--r--lisp/org-habit.el135
-rw-r--r--lisp/org-id.el25
-rw-r--r--lisp/org-indent.el254
-rw-r--r--lisp/org-info.el88
-rw-r--r--lisp/org-inlinetask.el50
-rw-r--r--lisp/org-irc.el30
-rw-r--r--lisp/org-lint.el1222
-rw-r--r--lisp/org-list.el1462
-rw-r--r--lisp/org-macro.el271
-rw-r--r--lisp/org-macs.el208
-rw-r--r--lisp/org-mhe.el19
-rw-r--r--lisp/org-mobile.el194
-rw-r--r--lisp/org-mouse.el172
-rw-r--r--lisp/org-pcomplete.el103
-rw-r--r--lisp/org-plot.el237
-rw-r--r--lisp/org-protocol.el349
-rw-r--r--lisp/org-rmail.el26
-rw-r--r--lisp/org-src.el1507
-rw-r--r--lisp/org-table.el4446
-rw-r--r--lisp/org-timer.el297
-rw-r--r--lisp/org-w3m.el18
-rw-r--r--lisp/org.el17071
-rw-r--r--lisp/ox-ascii.el1106
-rw-r--r--lisp/ox-beamer.el330
-rw-r--r--lisp/ox-html.el2324
-rw-r--r--lisp/ox-icalendar.el451
-rw-r--r--lisp/ox-latex.el2481
-rw-r--r--lisp/ox-man.el477
-rw-r--r--lisp/ox-md.el287
-rw-r--r--lisp/ox-odt.el1819
-rw-r--r--lisp/ox-org.el166
-rw-r--r--lisp/ox-publish.el518
-rw-r--r--lisp/ox-texinfo.el1907
-rw-r--r--lisp/ox.el4293
-rw-r--r--mk/default.mk55
-rwxr-xr-xmk/guidesplit.pl32
-rwxr-xr-xmk/mansplit.pl44
-rw-r--r--mk/org-fixup.el22
-rw-r--r--mk/server.mk6
-rw-r--r--mk/targets.mk31
-rw-r--r--testing/README86
-rw-r--r--testing/examples/babel.org96
-rw-r--r--testing/examples/include.html1
-rw-r--r--testing/examples/include.org25
-rw-r--r--testing/examples/normal.org6
-rw-r--r--testing/examples/ob-C-test.org88
-rw-r--r--testing/examples/ob-awk-test.org7
-rw-r--r--testing/examples/ob-fortran-test.org2
-rw-r--r--testing/examples/ob-header-arg-defaults.org24
-rw-r--r--testing/examples/ob-maxima-test.org9
-rw-r--r--testing/examples/ob-sed-test.org35
-rw-r--r--testing/examples/ob-shell-test.org88
-rw-r--r--testing/examples/open-at-point.org8
-rw-r--r--testing/examples/property-inheritance.org19
-rw-r--r--testing/examples/setupfile.org6
-rw-r--r--testing/examples/setupfile3.org6
-rw-r--r--testing/examples/subdir/setupfile2.org1
-rw-r--r--testing/lisp/test-ob-C.el161
-rw-r--r--testing/lisp/test-ob-R.el20
-rw-r--r--testing/lisp/test-ob-awk.el9
-rw-r--r--testing/lisp/test-ob-emacs-lisp.el12
-rw-r--r--testing/lisp/test-ob-exp.el323
-rw-r--r--testing/lisp/test-ob-header-arg-defaults.el66
-rw-r--r--testing/lisp/test-ob-lilypond.el372
-rw-r--r--testing/lisp/test-ob-lob.el149
-rw-r--r--testing/lisp/test-ob-lua.el141
-rw-r--r--testing/lisp/test-ob-maxima.el4
-rw-r--r--testing/lisp/test-ob-python.el4
-rw-r--r--testing/lisp/test-ob-ruby.el80
-rw-r--r--testing/lisp/test-ob-sed.el60
-rw-r--r--testing/lisp/test-ob-sh.el52
-rw-r--r--testing/lisp/test-ob-shell.el92
-rw-r--r--testing/lisp/test-ob-table.el2
-rw-r--r--testing/lisp/test-ob-tangle.el151
-rw-r--r--testing/lisp/test-ob.el1014
-rw-r--r--testing/lisp/test-org-attach-annex.el95
-rw-r--r--testing/lisp/test-org-capture.el101
-rw-r--r--testing/lisp/test-org-clock.el314
-rw-r--r--testing/lisp/test-org-colview.el1366
-rw-r--r--testing/lisp/test-org-datetree.el209
-rw-r--r--testing/lisp/test-org-element.el1826
-rw-r--r--testing/lisp/test-org-feed.el112
-rw-r--r--testing/lisp/test-org-footnote.el646
-rw-r--r--testing/lisp/test-org-inlinetask.el67
-rw-r--r--testing/lisp/test-org-list.el540
-rw-r--r--testing/lisp/test-org-macro.el69
-rw-r--r--testing/lisp/test-org-open-at-point.el61
-rw-r--r--testing/lisp/test-org-pcomplete.el59
-rw-r--r--testing/lisp/test-org-protocol.el191
-rw-r--r--testing/lisp/test-org-src.el222
-rw-r--r--testing/lisp/test-org-table.el1082
-rw-r--r--testing/lisp/test-org-timer.el283
-rw-r--r--testing/lisp/test-org.el3832
-rw-r--r--testing/lisp/test-ox.el2415
-rw-r--r--testing/lisp/test-property-inheritance.el22
-rw-r--r--testing/org-batch-test-init.el20
-rw-r--r--testing/org-test.el81
258 files changed, 89459 insertions, 42483 deletions
diff --git a/.gitignore b/.gitignore
index a9d73ad..70980ce 100644
--- a/.gitignore
+++ b/.gitignore
@@ -43,6 +43,7 @@ ORGWEBPAGE/Changes.txt
local*.mk
.gitattributes
mk/x11idle
+ChangeLog
# texi2pdf --tidy
diff --git a/Makefile b/Makefile
index f95bcb2..f6312f2 100644
--- a/Makefile
+++ b/Makefile
@@ -17,7 +17,6 @@ help helpall::
$(info )
$(info Getting Help)
$(info ============)
- $(info )
$(info make help - show brief help)
$(info make targets - ditto)
$(info make helpall - show extended help)
@@ -30,6 +29,7 @@ help helpall::
$(info make single - build Org ELisp files, single Emacs per source)
$(info make autoloads - create org-loaddefs.el to load Org in-place)
$(info make test - build Org ELisp files and run test suite)
+ $(info make vanilla - run Emacs with this Org-mode and no personal config)
helpall::
$(info make test-dirty - check without building first)
$(info make compile-dirty - build only stale Org ELisp files)
diff --git a/README_contribute b/README_contribute
index 3e1ef6d..2dc62e6 100644
--- a/README_contribute
+++ b/README_contribute
@@ -58,10 +58,10 @@ development.
new mechanism to make sure all changes end up in the right
place.
- - Creating and pushing a change to the Org-mode core requires
- you also to provide ChangeLog entries. Just press `C-x 4 a'
- in each function or variable you have modified and describe
- the change you made in the ChangeLog buffer/file.
+ - Org mode no longer uses ChangeLog entries to document
+ changes. Instead, special commit messages are used, as
+ described in the `CONTRIBUTE' file in the main Emacs
+ repository.
- Among other things, Org-mode is widely appreciated because
of its simplicity, cleanness and consistency. We should try
diff --git a/README_maintainer b/README_maintainer
index 04dc2c0..6b162aa 100644
--- a/README_maintainer
+++ b/README_maintainer
@@ -2,6 +2,7 @@
#+TITLE: Org maintainer tasks
#+STARTUP: noindent
+#+OPTIONS: ^:nil
This document describes the tasks the Org-mode maintainer has to do
and how they are performed.
diff --git a/contrib/README b/contrib/README
index bdbdb47..48c58b9 100644
--- a/contrib/README
+++ b/contrib/README
@@ -24,21 +24,23 @@ org-contacts.el --- Contacts management
org-contribdir.el --- Dummy file to mark the org contrib Lisp directory
org-depend.el --- TODO dependencies for Org-mode
org-drill.el --- Self-testing with org-learn
+org-effectiveness.el --- Measuring your personal effectiveness
org-element.el --- Parser and applications for Org syntax
+org-eldoc.el --- Eldoc documentation for SRC blocks
org-elisp-symbol.el --- Org links to emacs-lisp symbols
org-eval-light.el --- Evaluate in-buffer code on demand
org-eval.el --- The <lisp> tag, adapted from Muse
org-expiry.el --- Expiry mechanism for Org entries
org-export-generic.el --- Export framework for configurable backends
-org-favtable.el --- Lookup table of favorite references and links
org-git-link.el --- Provide org links to specific file version
+org-index.el --- A personal index for org and beyond
org-interactive-query.el --- Interactive modification of tags query
org-invoice.el --- Help manage client invoices in OrgMode
-org-jira.el --- Add a jira:ticket protocol to Org
org-learn.el --- SuperMemo's incremental learning algorithm
+org-license.el --- Insert free licenses to your org documents
+org-link-edit.el --- Slurp and barf with Org links
org-mac-iCal.el --- Imports events from iCal.app to the Emacs diary
-org-mac-link-grabber.el --- Grab links and URLs from various Mac applications
-org-mac-message.el --- Links to Apple Mail.app messages from within Org-mode
+org-mac-link.el --- Grab links and URLs from various Mac applications
org-mairix.el --- Hook mairix search into Org for different MUAs
org-man.el --- Support for links to manpages in Org-mode
org-mew.el --- Support for links to Mew messages
@@ -79,6 +81,7 @@ ob-fomus.el --- Org-babel functions for fomus evaluation
ob-julia.el --- Org-babel functions for julia evaluation
ob-mathomatic.el --- Org-babel functions for mathomatic evaluation
ob-oz.el --- Org-babel functions for Oz evaluation
+ob-stata.el --- Org-babel functions for Stata evaluation
ob-tcl.el --- Org-babel functions for tcl evaluation
External libraries
diff --git a/contrib/lisp/htmlize.el b/contrib/lisp/htmlize.el
index 3bf5949..8358830 100644
--- a/contrib/lisp/htmlize.el
+++ b/contrib/lisp/htmlize.el
@@ -943,18 +943,7 @@ If no rgb.txt file is found, return nil."
;; frame parameters.
(let* ((function (if fg #'face-foreground #'face-background))
color)
- (if (>= emacs-major-version 22)
- ;; For GNU Emacs 22+ set INHERIT to get the inherited values.
- (setq color (funcall function face nil t))
- (setq color (funcall function face))
- ;; For GNU Emacs 21 (which has `face-attribute'): if the color
- ;; is nil, recursively check for the face's parent.
- (when (and (null color)
- (fboundp 'face-attribute)
- (face-attribute face :inherit)
- (not (eq (face-attribute face :inherit) 'unspecified)))
- (setq color (htmlize-face-color-internal
- (face-attribute face :inherit) fg))))
+ (setq color (funcall function face nil t))
(when (and (eq face 'default) (null color))
(setq color (cdr (assq (if fg 'foreground-color 'background-color)
(frame-parameters)))))
@@ -1132,17 +1121,7 @@ If no rgb.txt file is found, return nil."
(face-underline-p face)))
;; GNU Emacs
(dolist (attr '(:weight :slant :underline :overline :strike-through))
- (let ((value (if (>= emacs-major-version 22)
- ;; Use the INHERIT arg in GNU Emacs 22.
- (face-attribute face attr nil t)
- ;; Otherwise, fake it.
- (let ((face face))
- (while (and (eq (face-attribute face attr)
- 'unspecified)
- (not (eq (face-attribute face :inherit)
- 'unspecified)))
- (setq face (face-attribute face :inherit)))
- (face-attribute face attr)))))
+ (let ((value (face-attribute face attr nil t)))
(when (and value (not (eq value 'unspecified)))
(htmlize-face-emacs21-attr fstruct attr value))))
(let ((size (htmlize-face-size face)))
diff --git a/contrib/lisp/ob-csharp.el b/contrib/lisp/ob-csharp.el
new file mode 100644
index 0000000..bbefcdb
--- a/dev/null
+++ b/contrib/lisp/ob-csharp.el
@@ -0,0 +1,83 @@
+;;; ob-csharp.el --- org-babel functions for csharp evaluation
+
+;; Copyright (C) 2011-2015 Free Software Foundation, Inc.
+
+;; Author: thomas "at" friendlyvillagers.com based on ob-java.el by Eric Schulte
+;; Keywords: literate programming, reproducible research
+;; Homepage: http://orgmode.org
+
+;; This file is not part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Currently this only supports the external compilation and execution
+;; of csharp code blocks (i.e., no session support).
+
+;;; Code:
+(require 'ob)
+
+(defvar org-babel-tangle-lang-exts)
+(add-to-list 'org-babel-tangle-lang-exts '("csharp" . "cs"))
+
+(defcustom org-babel-csharp-command "mono"
+ "Name of the csharp command.
+May be either a command in the path, like mono
+or an absolute path name, like /usr/local/bin/mono
+parameters may be used, like mono -verbose"
+ :group 'org-babel
+ :version "24.3"
+ :type 'string)
+
+(defcustom org-babel-csharp-compiler "mcs"
+ "Name of the csharp compiler.
+May be either a command in the path, like mcs
+or an absolute path name, like /usr/local/bin/mcs
+parameters may be used, like mcs -warnaserror+"
+ :group 'org-babel
+ :version "24.3"
+ :type 'string)
+
+(defun org-babel-execute:csharp (body params)
+ (let* ((full-body (org-babel-expand-body:generic body params))
+ (cmpflag (or (cdr (assoc :cmpflag params)) ""))
+ (cmdline (or (cdr (assoc :cmdline params)) ""))
+ (src-file (org-babel-temp-file "csharp-src-" ".cs"))
+ (exe-file (concat (file-name-sans-extension src-file) ".exe"))
+ (compile
+ (progn (with-temp-file src-file (insert full-body))
+ (org-babel-eval
+ (concat org-babel-csharp-compiler " " cmpflag " " src-file) ""))))
+ (let ((results (org-babel-eval (concat org-babel-csharp-command " " cmdline " " exe-file) "")))
+ (org-babel-reassemble-table
+ (org-babel-result-cond (cdr (assoc :result-params params))
+ (org-babel-read results)
+ (let ((tmp-file (org-babel-temp-file "c-")))
+ (with-temp-file tmp-file (insert results))
+ (org-babel-import-elisp-from-file tmp-file)))
+ (org-babel-pick-name
+ (cdr (assoc :colname-names params)) (cdr (assoc :colnames params)))
+ (org-babel-pick-name
+ (cdr (assoc :rowname-names params)) (cdr (assoc :rownames params)))))))
+
+(defun org-babel-prep-session:csharp (session params)
+ "Return an error because csharp does not support sessions."
+ (error "Sessions are not supported for CSharp"))
+
+(provide 'ob-csharp)
+
+
+
+;;; ob-csharp.el ends here
diff --git a/contrib/lisp/ob-eukleides.el b/contrib/lisp/ob-eukleides.el
index c8ce881..67f3bf4 100644
--- a/contrib/lisp/ob-eukleides.el
+++ b/contrib/lisp/ob-eukleides.el
@@ -1,6 +1,6 @@
;;; ob-eukleides.el --- Org-babel functions for eukleides evaluation
-;; Copyright (C) 2010-2014 Free Software Foundation, Inc.
+;; Copyright (C) 2010-2016 Free Software Foundation, Inc.
;; Author: Luis Anaya
;; Keywords: literate programming, reproducible research
@@ -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-fomus.el b/contrib/lisp/ob-fomus.el
index 1db32e4..7a3280e 100644
--- a/contrib/lisp/ob-fomus.el
+++ b/contrib/lisp/ob-fomus.el
@@ -48,7 +48,7 @@
(defun org-babel-expand-body:fomus (body params)
"Expand BODY according to PARAMS, return the expanded body."
- (let ((vars (mapcar #'cdr (org-babel-get-header params :var))))
+ (let ((vars (org-babel--get-vars params)))
(mapc
(lambda (pair)
(let ((name (symbol-name (car pair)))
diff --git a/contrib/lisp/ob-julia.el b/contrib/lisp/ob-julia.el
index 4d8deb2..99fae27 100644
--- a/contrib/lisp/ob-julia.el
+++ b/contrib/lisp/ob-julia.el
@@ -30,7 +30,7 @@
;;; Code:
(require 'ob)
-(eval-when-compile (require 'cl))
+(require 'cl-lib)
(declare-function orgtbl-to-csv "org-table" (table params))
(declare-function julia "ext:ess-julia" (&optional start-args))
@@ -38,7 +38,6 @@
(declare-function ess-make-buffer-current "ext:ess-inf" ())
(declare-function ess-eval-buffer "ext:ess-inf" (vis))
(declare-function org-number-sequence "org-compat" (from &optional to inc))
-(declare-function org-remove-if-not "org" (predicate seq))
(defconst org-babel-header-args:julia
'((width . :any)
@@ -125,7 +124,7 @@ This function is called by `org-babel-execute-src-block'."
(defun org-babel-variable-assignments:julia (params)
"Return list of julia statements assigning the block's variables."
- (let ((vars (mapcar #'cdr (org-babel-get-header params :var))))
+ (let ((vars (org-babel--get-vars params)))
(mapcar
(lambda (pair)
(org-babel-julia-assign-elisp
@@ -150,9 +149,9 @@ This function is called by `org-babel-execute-src-block'."
(defun org-babel-julia-assign-elisp (name value colnames-p rownames-p)
"Construct julia code assigning the elisp VALUE to a variable named NAME."
(if (listp value)
- (let ((max (apply #'max (mapcar #'length (org-remove-if-not
+ (let ((max (apply #'max (mapcar #'length (cl-remove-if-not
#'sequencep value))))
- (min (apply #'min (mapcar #'length (org-remove-if-not
+ (min (apply #'min (mapcar #'length (cl-remove-if-not
#'sequencep value))))
(transition-file (org-babel-temp-file "julia-import-")))
;; ensure VALUE has an orgtbl structure (depth of at least 2)
@@ -229,7 +228,7 @@ current code buffer."
If RESULT-TYPE equals 'output then return standard output as a
string. If RESULT-TYPE equals 'value then return the value of the
last statement in BODY, as elisp."
- (case result-type
+ (cl-case result-type
(value
(let ((tmp-file (org-babel-temp-file "julia-")))
(org-babel-eval org-babel-julia-command
@@ -251,7 +250,7 @@ last statement in BODY, as elisp."
If RESULT-TYPE equals 'output then return standard output as a
string. If RESULT-TYPE equals 'value then return the value of the
last statement in BODY, as elisp."
- (case result-type
+ (cl-case result-type
(value
(with-temp-buffer
(insert (org-babel-chomp body))
diff --git a/contrib/lisp/ob-mathematica.el b/contrib/lisp/ob-mathematica.el
new file mode 100644
index 0000000..acaa15b
--- a/dev/null
+++ b/contrib/lisp/ob-mathematica.el
@@ -0,0 +1,82 @@
+;;; 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)
+
+(declare-function org-trim "org" (s &optional keep-lead))
+
+;; Optionally require mma.el for font lock, etc
+(require 'mma nil 'noerror)
+(add-to-list 'org-src-lang-modes '("mathematica" . "mma"))
+
+(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 (org-babel--get-vars params)))
+ (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-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-mathomatic.el b/contrib/lisp/ob-mathomatic.el
index bfd8ecf..e6ea796 100644
--- a/contrib/lisp/ob-mathomatic.el
+++ b/contrib/lisp/ob-mathomatic.el
@@ -1,6 +1,6 @@
;;; ob-mathomatic.el --- Org-babel functions for mathomatic evaluation
-;; Copyright (C) 2009-2014 Free Software Foundation, Inc.
+;; Copyright (C) 2009-2016 Free Software Foundation, Inc.
;; Author: Eric S Fraga
;; Eric Schulte
@@ -49,37 +49,37 @@
(defun org-babel-mathomatic-expand (body params)
"Expand a block of Mathomatic code according to its header arguments."
- (let ((vars (mapcar #'cdr (org-babel-get-header params :var))))
- (mapconcat 'identity
- (list
- ;; graphic output
- (let ((graphic-file (org-babel-mathomatic-graphical-output-file params)))
- (if graphic-file
- (cond
- ((string-match ".\.eps$" graphic-file)
- (format ;; Need to add command to send to file.
- "set plot set terminal postscript eps\\;set output %S "
- graphic-file))
- ((string-match ".\.ps$" graphic-file)
- (format ;; Need to add command to send to file.
- "set plot set terminal postscript\\;set output %S "
- graphic-file))
-
- ((string-match ".\.pic$" graphic-file)
- (format ;; Need to add command to send to file.
- "set plot set terminal gpic\\;set output %S "
- graphic-file))
- (t
- (format ;; Need to add command to send to file.
- "set plot set terminal png\\;set output %S "
- graphic-file)))
- ""))
- ;; variables
- (mapconcat 'org-babel-mathomatic-var-to-mathomatic vars "\n")
- ;; body
- body
- "")
- "\n")))
+ (let ((vars (org-babel--get-vars params)))
+ (mapconcat 'identity
+ (list
+ ;; graphic output
+ (let ((graphic-file (org-babel-mathomatic-graphical-output-file params)))
+ (if graphic-file
+ (cond
+ ((string-match ".\.eps$" graphic-file)
+ (format ;; Need to add command to send to file.
+ "set plot set terminal postscript eps\\;set output %S "
+ graphic-file))
+ ((string-match ".\.ps$" graphic-file)
+ (format ;; Need to add command to send to file.
+ "set plot set terminal postscript\\;set output %S "
+ graphic-file))
+
+ ((string-match ".\.pic$" graphic-file)
+ (format ;; Need to add command to send to file.
+ "set plot set terminal gpic\\;set output %S "
+ graphic-file))
+ (t
+ (format ;; Need to add command to send to file.
+ "set plot set terminal png\\;set output %S "
+ graphic-file)))
+ ""))
+ ;; variables
+ (mapconcat 'org-babel-mathomatic-var-to-mathomatic vars "\n")
+ ;; body
+ body
+ "")
+ "\n")))
(defun org-babel-execute:mathomatic (body params)
"Execute a block of Mathomatic entries with org-babel. This function is
diff --git a/contrib/lisp/ob-oz.el b/contrib/lisp/ob-oz.el
index 3531d95..50a5762 100644
--- a/contrib/lisp/ob-oz.el
+++ b/contrib/lisp/ob-oz.el
@@ -197,7 +197,7 @@ StartOzServer.oz is located.")
result))
(defun org-babel-expand-body:oz (body params)
- (let ((vars (mapcar #'cdr (org-babel-get-header params :var))))
+ (let ((vars (org-babel--get-vars params)))
(if vars
;; prepend code to define all arguments passed to the code block
(let ((var-string (mapcar (lambda (pair)
@@ -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..03f34f4
--- a/dev/null
+++ b/contrib/lisp/ob-stata.el
@@ -0,0 +1,312 @@
+;;; 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)
+(require 'cl-lib)
+
+(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))
+
+(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 (org-babel--get-vars params)))
+ (mapcar
+ (lambda (pair)
+ (org-babel-stata-assign-elisp
+ (car pair) (cdr pair)
+ (equal "yes" (cdr (assoc :colnames params)))
+ (equal "yes" (cdr (assoc :rownames params)))))
+ (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 (cl-remove-if-not
+ #'sequencep value))))
+ (min (apply #'min (mapcar #'length (cl-remove-if-not
+ #'sequencep value))))
+ (transition-file (org-babel-temp-file "stata-import-")))
+ ;; ensure VALUE has an orgtbl structure (depth of at least 2)
+ (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."
+ (cl-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."
+ (cl-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..f812ace 100644
--- a/contrib/lisp/ob-tcl.el
+++ b/contrib/lisp/ob-tcl.el
@@ -1,6 +1,6 @@
;;; ob-tcl.el --- Org-babel functions for tcl evaluation
-;; Copyright (C) 2009-2014 Free Software Foundation, Inc.
+;; Copyright (C) 2009-2016 Free Software Foundation, Inc.
;; Authors: Dan Davison
;; Eric Schulte
@@ -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."
@@ -71,7 +71,7 @@ This function is called by `org-babel-execute-src-block'."
(format "set %s %s"
(car pair)
(org-babel-tcl-var-to-tcl (cdr pair))))
- (mapcar #'cdr (org-babel-get-header params :var))))
+ (org-babel--get-vars params)))
;; helper functions
@@ -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/ob-vbnet.el b/contrib/lisp/ob-vbnet.el
new file mode 100644
index 0000000..d326535
--- a/dev/null
+++ b/contrib/lisp/ob-vbnet.el
@@ -0,0 +1,84 @@
+;;; ob-vbnet.el --- org-babel functions for VB.Net evaluation
+
+;; Copyright (C) 2011-2015 Free Software Foundation, Inc.
+
+;; Author: thomas "at" friendlyvillagers.com based on ob-java.el by Eric Schulte
+;; Keywords: literate programming, reproducible research
+;; Homepage: http://orgmode.org
+
+;; This file is not part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Currently this only supports the external compilation and execution
+;; of VB.Net code blocks (i.e., no session support).
+
+;;; Code:
+(require 'ob)
+
+(defvar org-babel-tangle-lang-exts)
+(add-to-list 'org-babel-tangle-lang-exts '("vbnet" . "vb"))
+
+(defcustom org-babel-vbnet-command "mono"
+ "Name of the mono command.
+May be either a command in the path, like mono
+or an absolute path name, like /usr/local/bin/mono
+parameters may be used, like mono -verbose"
+ :group 'org-babel
+ :version "24.3"
+ :type 'string)
+
+(defcustom org-babel-vbnet-compiler "vbnc"
+ "Name of the VB.Net compiler.
+May be either a command in the path, like vbnc
+or an absolute path name, like /usr/local/bin/vbnc
+parameters may be used, like vbnc /warnaserror+"
+ :group 'org-babel
+ :version "24.3"
+ :type 'string)
+
+(defun org-babel-execute:vbnet (body params)
+ (let* ((full-body (org-babel-expand-body:generic body params))
+ (cmpflag (or (cdr (assoc :cmpflag params)) ""))
+ (cmdline (or (cdr (assoc :cmdline params)) ""))
+ (src-file (org-babel-temp-file "vbnet-src-" ".vb"))
+ (exe-file (concat (file-name-sans-extension src-file) ".exe"))
+ (compile
+ (progn (with-temp-file src-file (insert full-body))
+ (org-babel-eval
+ (concat org-babel-vbnet-compiler " " cmpflag " " src-file)
+ ""))))
+ (let ((results (org-babel-eval (concat org-babel-vbnet-command " " cmdline " " exe-file) "")))
+ (org-babel-reassemble-table
+ (org-babel-result-cond (cdr (assoc :result-params params))
+ (org-babel-read results)
+ (let ((tmp-file (org-babel-temp-file "c-")))
+ (with-temp-file tmp-file (insert results))
+ (org-babel-import-elisp-from-file tmp-file)))
+ (org-babel-pick-name
+ (cdr (assoc :colname-names params)) (cdr (assoc :colnames params)))
+ (org-babel-pick-name
+ (cdr (assoc :rowname-names params)) (cdr (assoc :rownames params)))))))
+
+(defun org-babel-prep-session:vbnet (session params)
+ "Return an error because vbnet does not support sessions."
+ (error "Sessions are not supported for VB.Net"))
+
+(provide 'ob-vbnet)
+
+
+
+;;; ob-vbnet.el ends here
diff --git a/contrib/lisp/org-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..92145dd 100644
--- a/contrib/lisp/org-bibtex-extras.el
+++ b/contrib/lisp/org-bibtex-extras.el
@@ -1,6 +1,6 @@
;;; org-bibtex-extras --- extras for working with org-bibtex entries
-;; Copyright (C) 2008-2014 Free Software Foundation, Inc.
+;; Copyright (C) 2008-2016 Free Software Foundation, Inc.
;; Author: Eric Schulte <eric dot schulte at gmx dot com>
;; Keywords: outlines, hypermedia, bibtex, d3
@@ -61,6 +61,8 @@
;;; Code:
(require 'org-bibtex)
+(declare-function org-trim "org" (s &optional keep-lead))
+
(defcustom obe-bibtex-file nil "File holding bibtex entries.")
(defcustom obe-html-link-base nil
@@ -75,25 +77,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
@@ -102,18 +93,9 @@ For example, to point to your `obe-bibtex-file' use the following.
(replace-match
(save-match-data
(mapconcat (lambda (c) (format "[[%s#%s][%s]]" obe-html-link-base c c))
- (mapcar #'org-babel-trim
+ (mapcar #'org-trim
(split-string (match-string 1) ",")) ", "))))))
-(defun obe-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-bookmark.el b/contrib/lisp/org-bookmark.el
index 9a69bbb..f042467 100644
--- a/contrib/lisp/org-bookmark.el
+++ b/contrib/lisp/org-bookmark.el
@@ -1,5 +1,5 @@
;;; org-bookmark.el - Support for links to bookmark
-;; Copyright (C) 2008-2014 Free Software Foundation, Inc.
+;; Copyright (C) 2008-2016 Free Software Foundation, Inc.
;;
;; Author: Tokuya Kameshima <kames AT fa2.so-net.ne.jp>
;; Version: 1.0
@@ -47,8 +47,9 @@ Otherwise prompt the user for the right bookmark to use."
:group 'org-bookmark
:type 'boolean)
-(org-add-link-type "bookmark" 'org-bookmark-open)
-(add-hook 'org-store-link-functions 'org-bookmark-store-link)
+(org-link-set-parameters "bookmark"
+ :follow #'org-bookmark-open
+ :store #'org-bookmark-store-link)
(defun org-bookmark-open (bookmark)
"Visit the bookmark BOOKMARK."
diff --git a/contrib/lisp/org-collector.el b/contrib/lisp/org-collector.el
index 7f3b344..3e2b3c4 100644
--- a/contrib/lisp/org-collector.el
+++ b/contrib/lisp/org-collector.el
@@ -1,6 +1,6 @@
;;; org-collector --- collect properties into tables
-;; Copyright (C) 2008-2014 Free Software Foundation, Inc.
+;; Copyright (C) 2008-2016 Free Software Foundation, Inc.
;; Author: Eric Schulte <schulte dot eric at gmail dot com>
;; Keywords: outlines, hypermedia, calendar, wp, experimentation,
@@ -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
deleted file mode 100644
index 67a2aad..0000000
--- a/contrib/lisp/org-colview-xemacs.el
+++ b/dev/null
@@ -1,1725 +0,0 @@
-;;; org-colview-xemacs.el --- Column View in Org-mode, XEmacs-specific version
-
-;; Copyright (C) 2004-2014
-;; Carsten Dominik
-
-;; Author: Carsten Dominik <carsten at orgmode dot org>
-;; Keywords: outlines, hypermedia, calendar, wp
-;; Homepage: http://orgmode.org
-;;
-;; This file is part of Org mode, it is not part of GNU Emacs.
-;;
-;; This program is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation, either version 3 of the License, or
-;; (at your option) any later version.
-
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;;; Commentary:
-
-;; This file contains the column view for Org.
-
-;;; Code:
-
-(eval-when-compile (require 'cl))
-(require 'org)
-
-(declare-function org-agenda-redo "org-agenda" ())
-
-
-;;; Define additional faces for column view
-
-(when (featurep 'xemacs)
-
- (defface org-columns-level-1;; font-lock-function-name-face
- (org-compatible-face
- 'outline-1
- '((((class color) (min-colors 88) (background light)) (:foreground "Blue1" :background "grey90"))
- (((class color) (min-colors 88) (background dark)) (:foreground "LightSkyBlue" :background "grey30"))
- (((class color) (min-colors 16) (background light)) (:foreground "Blue" :background "grey90"))
- (((class color) (min-colors 16) (background dark)) (:foreground "LightSkyBlue" :background "grey30"))
- (((class color) (min-colors 8)) (:foreground "blue" :bold t))
- (t (:bold t))))
- "Face used for columns-level 1 headlines."
- :group 'org-faces)
-
- (defface org-columns-level-2;; font-lock-variable-name-face
- (org-compatible-face
- 'outline-2
- '((((class color) (min-colors 16) (background light)) (:foreground "DarkGoldenrod" :background "grey90"))
- (((class color) (min-colors 16) (background dark)) (:foreground "LightGoldenrod" :background "grey30"))
- (((class color) (min-colors 8) (background light)) (:foreground "yellow" :background "grey90"))
- (((class color) (min-colors 8) (background dark)) (:foreground "yellow" :bold t))
- (t (:bold t))))
- "Face used for columns-level 2 headlines."
- :group 'org-faces)
-
- (defface org-columns-level-3;; font-lock-keyword-face
- (org-compatible-face
- 'outline-3
- '((((class color) (min-colors 88) (background light)) (:foreground "Purple" :background "grey90"))
- (((class color) (min-colors 88) (background dark)) (:foreground "Cyan1" :background "grey30"))
- (((class color) (min-colors 16) (background light)) (:foreground "Purple" :background "grey90"))
- (((class color) (min-colors 16) (background dark)) (:foreground "Cyan" :background "grey30"))
- (((class color) (min-colors 8) (background light)) (:foreground "purple" :bold t))
- (((class color) (min-colors 8) (background dark)) (:foreground "cyan" :bold t))
- (t (:bold t))))
- "Face used for columns-level 3 headlines."
- :group 'org-faces)
-
- (defface org-columns-level-4;; font-lock-comment-face
- (org-compatible-face
- 'outline-4
- '((((class color) (min-colors 88) (background light)) (:foreground "Firebrick" :background "grey90"))
- (((class color) (min-colors 88) (background dark)) (:foreground "chocolate1" :background "grey30"))
- (((class color) (min-colors 16) (background light)) (:foreground "red"))
- (((class color) (min-colors 16) (background dark)) (:foreground "red1"))
- (((class color) (min-colors 8) (background light)) (:foreground "red" :bold t))
- (((class color) (min-colors 8) (background dark)) (:foreground "red" :bold t))
- (t (:bold t))))
- "Face used for columns-level 4 headlines."
- :group 'org-faces)
-
- (defface org-columns-level-5;; font-lock-type-face
- (org-compatible-face
- 'outline-5
- '((((class color) (min-colors 16) (background light)) (:foreground "ForestGreen" :background "grey90"))
- (((class color) (min-colors 16) (background dark)) (:foreground "PaleGreen" :background "grey30"))
- (((class color) (min-colors 8)) (:foreground "green"))))
- "Face used for columns-level 5 headlines."
- :group 'org-faces)
-
- (defface org-columns-level-6;; font-lock-constant-face
- (org-compatible-face
- 'outline-6
- '((((class color) (min-colors 16) (background light)) (:foreground "CadetBlue" :background "grey90"))
- (((class color) (min-colors 16) (background dark)) (:foreground "Aquamarine" :background "grey30"))
- (((class color) (min-colors 8)) (:foreground "magenta"))))
- "Face used for columns-level 6 headlines."
- :group 'org-faces)
-
- (defface org-columns-level-7;; font-lock-builtin-face
- (org-compatible-face
- 'outline-7
- '((((class color) (min-colors 16) (background light)) (:foreground "Orchid" :background "grey90"))
- (((class color) (min-colors 16) (background dark)) (:foreground "LightSteelBlue" :background "grey30"))
- (((class color) (min-colors 8)) (:foreground "blue"))))
- "Face used for columns-level 7 headlines."
- :group 'org-faces)
-
- (defface org-columns-level-8;; font-lock-string-face
- (org-compatible-face
- 'outline-8
- '((((class color) (min-colors 16) (background light)) (:foreground "RosyBrown" :background "grey90"))
- (((class color) (min-colors 16) (background dark)) (:foreground "LightSalmon" :background "grey30"))
- (((class color) (min-colors 8)) (:foreground "green"))))
- "Face used for columns-level 8 headlines."
- :group 'org-faces)
-
-
- (defface org-columns-space;; font-lock-function-name-face
- (org-compatible-face
- 'outline-1
- '((((class color) (min-colors 88) (background light)) (:background "grey90"))
- (((class color) (min-colors 88) (background dark)) (:background "grey30"))
- (((class color) (min-colors 16) (background light)) (:background "grey90"))
- (((class color) (min-colors 16) (background dark)) (:background "grey30"))
- (((class color) (min-colors 8)) (:bold t :underline t))))
- "Face used for columns space headlines."
- :group 'org-faces)
-
- (defface org-columns-space1;; font-lock-function-name-face
- (org-compatible-face
- 'outline-1
- '((((class color) (min-colors 88) (background light)) (:background "grey90"))
- (((class color) (min-colors 88) (background dark)) (:background "grey30"))
- (((class color) (min-colors 16) (background light)) (:background "grey90"))
- (((class color) (min-colors 16) (background dark)) (:background "grey30"))
- (((class color) (min-colors 8)) (:bold t :underline t))))
- "Face used for columns space headlines."
- :group 'org-faces)
- )
-
-(when (featurep 'xemacs)
- (defconst org-columns-level-faces
- '(org-columns-level-1
- org-columns-level-2 org-columns-level-3
- org-columns-level-4 org-columns-level-5 org-columns-level-6
- org-columns-level-7 org-columns-level-8
- ))
-
- (defun org-get-columns-level-face (n)
- "Get the right face for match N in font-lock matching of headlines."
- (setq org-l (- (match-end 2) (match-beginning 1) 1))
- (if org-odd-levels-only (setq org-l (1+ (/ org-l 2))))
- (setq org-f (nth (% (1- org-l) org-n-level-faces) org-columns-level-faces))
- (cond
- ((eq n 1) (if org-hide-leading-stars 'org-hide org-f))
- ((eq n 2) org-f)
- (t (if org-level-color-stars-only nil org-f))))
- )
-
-
-;;; Column View
-
-(defvar org-columns-overlays nil
- "Holds the list of current column overlays.")
-
-(defvar org-columns-current-fmt nil
- "Local variable, holds the currently active column format.")
-(make-variable-buffer-local 'org-columns-current-fmt)
-(defvar org-columns-current-fmt-compiled nil
- "Local variable, holds the currently active column format.
-This is the compiled version of the format.")
-(make-variable-buffer-local 'org-columns-current-fmt-compiled)
-(defvar org-columns-current-widths nil
- "Local variable, holds the currently widths of fields.")
-(make-variable-buffer-local 'org-columns-current-widths)
-(defvar org-columns-current-maxwidths nil
- "Local variable, holds the currently active maximum column widths.")
-(make-variable-buffer-local 'org-columns-current-maxwidths)
-(defvar org-columns-begin-marker (make-marker)
- "Points to the position where last a column creation command was called.")
-(defvar org-columns-top-level-marker (make-marker)
- "Points to the position where current columns region starts.")
-
-(defvar org-columns-map (make-sparse-keymap)
- "The keymap valid in column display.")
-
-(defun org-columns-content ()
- "Switch to contents view while in columns view."
- (interactive)
- (org-overview)
- (org-content))
-
-(org-defkey org-columns-map "c" 'org-columns-content)
-(org-defkey org-columns-map "o" 'org-overview)
-(org-defkey org-columns-map "e" 'org-columns-edit-value)
-(org-defkey org-columns-map "\C-c\C-t" 'org-columns-todo)
-(org-defkey org-columns-map "\C-c\C-c" 'org-columns-set-tags-or-toggle)
-(org-defkey org-columns-map "\C-c\C-o" 'org-columns-open-link)
-(org-defkey org-columns-map "v" 'org-columns-show-value)
-(org-defkey org-columns-map "q" 'org-columns-quit)
-(org-defkey org-columns-map "r" 'org-columns-redo)
-(org-defkey org-columns-map "g" 'org-columns-redo)
-(org-defkey org-columns-map [left] 'org-columns-backward-char)
-(org-defkey org-columns-map "\M-b" 'org-columns-backward-char)
-(org-defkey org-columns-map "a" 'org-columns-edit-allowed)
-(org-defkey org-columns-map "s" 'org-columns-edit-attributes)
-(org-defkey org-columns-map "\M-f" 'org-columns-forward-char)
-(org-defkey org-columns-map [right] 'org-columns-forward-char)
-(org-defkey org-columns-map [(shift right)] 'org-columns-next-allowed-value)
-(org-defkey org-columns-map "n" 'org-columns-next-allowed-value)
-(org-defkey org-columns-map [(shift left)] 'org-columns-previous-allowed-value)
-(org-defkey org-columns-map "p" 'org-columns-previous-allowed-value)
-(org-defkey org-columns-map "<" 'org-columns-narrow)
-(org-defkey org-columns-map ">" 'org-columns-widen)
-(org-defkey org-columns-map [(meta right)] 'org-columns-move-right)
-(org-defkey org-columns-map [(meta left)] 'org-columns-move-left)
-(org-defkey org-columns-map [(shift meta right)] 'org-columns-new)
-(org-defkey org-columns-map [(shift meta left)] 'org-columns-delete)
-(dotimes (i 10)
- (org-defkey org-columns-map (number-to-string i)
- `(lambda () (interactive)
- (org-columns-next-allowed-value nil ,i))))
-
-(easy-menu-define org-columns-menu org-columns-map "Org Column Menu"
- '("Column"
- ["Edit property" org-columns-edit-value t]
- ["Next allowed value" org-columns-next-allowed-value t]
- ["Previous allowed value" org-columns-previous-allowed-value t]
- ["Show full value" org-columns-show-value t]
- ["Edit allowed values" org-columns-edit-allowed t]
- "--"
- ["Edit column attributes" org-columns-edit-attributes t]
- ["Increase column width" org-columns-widen t]
- ["Decrease column width" org-columns-narrow t]
- "--"
- ["Move column right" org-columns-move-right t]
- ["Move column left" org-columns-move-left t]
- ["Add column" org-columns-new t]
- ["Delete column" org-columns-delete t]
- "--"
- ["CONTENTS" org-columns-content t]
- ["OVERVIEW" org-overview t]
- ["Refresh columns display" org-columns-redo t]
- "--"
- ["Open link" org-columns-open-link t]
- "--"
- ["Quit" org-columns-quit t]))
-
-(defun org-columns-current-column ()
- (if (featurep 'xemacs)
- (/ (current-column) 2)
- (current-column)))
-
-(defun org-columns-forward-char ()
- (interactive)
- (forward-char)
- (if (featurep 'xemacs)
- (while (not (or (eolp)
- (member (extent-at
- (point) (current-buffer)
- 'org-columns-key) org-columns-overlays)))
- (forward-char))))
-
-(defun org-columns-backward-char ()
- (interactive)
- (backward-char)
- (if (featurep 'xemacs)
- (while (not (or (bolp)
- (member (extent-at (point) (current-buffer) 'org-columns-key) org-columns-overlays)))
- (backward-char))))
-
-(defun org-columns-new-overlay (beg end &optional string face)
- "Create a new column overlay and add it to the list."
- (let ((ov (make-overlay beg end)))
- (if (featurep 'xemacs)
- (progn
- (overlay-put ov 'face (or face 'org-columns-space1))
- (overlay-put ov 'start-open t)
- (if string
- (org-overlay-display ov string (or face 'org-columns-space1))))
- (overlay-put ov 'face (or face 'secondary-selection))
- (org-overlay-display ov string face))
- (push ov org-columns-overlays)
- ov))
-
-(defun org-columns-display-here (&optional props)
- "Overlay the current line with column display."
- (interactive)
- (let* ((fmt org-columns-current-fmt-compiled)
- (beg (point-at-bol))
- (level-face (save-excursion
- (beginning-of-line 1)
- (and (looking-at "\\(\\**\\)\\(\\* \\)")
- (org-get-level-face 2))))
- (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)
- (and (looking-at "\\(\\**\\)\\(\\* \\)")
- (org-get-columns-level-face 2)))
- (list :foreground
- (face-attribute
- (or level-face
- (and (eq major-mode 'org-agenda-mode)
- (get-text-property (point-at-bol) 'face))
- 'default) :foreground))))
- (face (if (featurep 'xemacs) color (list color 'org-column)))
- (pl (- (point)
- (or (text-property-any (point-at-bol) (point-at-eol) 'org-heading t)
- (point))))
- (cphr (get-text-property (point-at-bol) 'org-complex-heading-regexp))
- pom property ass width f string ov column val modval s2 title calc)
- ;; Check if the entry is in another buffer.
- (unless props
- (if (eq major-mode 'org-agenda-mode)
- (setq pom (or (org-get-at-bol 'org-hd-marker)
- (org-get-at-bol 'org-marker))
- props (if pom (org-entry-properties pom) nil))
- (setq props (org-entry-properties nil))))
- ;; Walk the format
- (while (setq column (pop fmt))
- (setq property (car column)
- title (nth 1 column)
- ass (if (equal property "ITEM")
- (cons "ITEM" item)
- (assoc property props))
- width (or (cdr (assoc property org-columns-current-maxwidths))
- (nth 2 column)
- (length property))
- f (format (if (featurep 'xemacs) "%%-%d.%ds |" "%%-%d.%ds | ")
- width width)
- val (or (cdr ass) "")
- calc (nth 7 column)
- modval (cond ((and org-columns-modify-value-for-display-function
- (functionp
- org-columns-modify-value-for-display-function))
- (funcall org-columns-modify-value-for-display-function
- title val))
- ((equal property "ITEM")
- (if (derived-mode-p 'org-mode)
- (org-columns-cleanup-item
- val org-columns-current-fmt-compiled)))
- ((and calc (functionp calc)
- (not (string= val ""))
- (not (get-text-property 0 'org-computed val)))
- (org-columns-number-to-string
- (funcall calc (org-columns-string-to-number
- val (nth 4 column)))
- (nth 4 column)))))
- (setq s2 (org-columns-add-ellipses (or modval val) width))
- (setq string (format f s2))
- ;; Create the overlay
- (org-unmodified
- (setq ov (org-columns-new-overlay
- beg (setq beg (1+ beg)) string face))
- (overlay-put ov 'keymap org-columns-map)
- (overlay-put ov 'org-columns-key property)
- (overlay-put ov 'org-columns-value (cdr ass))
- (overlay-put ov 'org-columns-value-modified modval)
- (overlay-put ov 'org-columns-pom pom)
- (overlay-put ov 'org-columns-format f)
- (when (featurep 'xemacs)
- (if (or (not (char-after beg))
- (equal (char-after beg) ?\n))
- (let ((inhibit-read-only t))
- (save-excursion
- (goto-char beg)
- (org-unmodified (insert " "))
- ;; FIXME: add props and remove later?
- )))
- (goto-char beg)
- (org-columns-new-overlay
- beg (1+ beg) nil 'org-columns-space)
- (setq beg (1+ beg))))
-
- (if (or (not (char-after beg))
- (equal (char-after beg) ?\n))
- (let ((inhibit-read-only t))
- (save-excursion
- (goto-char beg)
- ;; FIXME: add props and remove later?
- (org-unmodified (insert " "))))))
- ;; Make the rest of the line disappear.
- (org-unmodified
- (setq ov (org-columns-new-overlay beg (point-at-eol)))
- (overlay-put ov 'invisible t)
- (overlay-put ov 'keymap org-columns-map)
- (overlay-put ov 'intangible t)
- (push ov org-columns-overlays)
- (setq ov (make-overlay (1- (point-at-eol)) (1+ (point-at-eol))))
- (overlay-put ov 'keymap org-columns-map)
- (push ov org-columns-overlays)
- (let ((inhibit-read-only t))
- (put-text-property (max (point-min) (1- (point-at-bol)))
- (min (point-max) (1+ (point-at-eol)))
- 'read-only "Type `e' to edit property")))))
-
-(defun org-columns-add-ellipses (string width)
- "Truncate STRING with WIDTH characters, with ellipses."
- (cond
- ((<= (length string) width) string)
- ((<= width (length org-columns-ellipses))
- (substring org-columns-ellipses 0 width))
- (t (concat (substring string 0 (- width (length org-columns-ellipses)))
- org-columns-ellipses))))
-
-(defvar org-columns-full-header-line-format nil
- "The full header line format, will be shifted by horizontal scrolling." )
-(defvar org-previous-header-line-format nil
- "The header line format before column view was turned on.")
-(defvar org-columns-inhibit-recalculation nil
- "Inhibit recomputing of columns on column view startup.")
-
-
-(defvar header-line-format)
-(defvar org-columns-previous-hscroll 0)
-
-(defun org-columns-display-here-title ()
- "Overlay the newline before the current line with the table title."
- (interactive)
- (let ((fmt org-columns-current-fmt-compiled)
- string (title "")
- property width f column str widths)
- (while (setq column (pop fmt))
- (setq property (car column)
- str (or (nth 1 column) property)
- width (or (cdr (assoc property org-columns-current-maxwidths))
- (nth 2 column)
- (length str))
- widths (push width widths)
- f (format "%%-%d.%ds | " width width)
- string (format f str)
- title (concat title string)))
- (if (featurep 'xemacs)
- (let ((ext (make-extent nil nil)))
- (set-extent-endpoints ext 0 (length title) title)
- (set-extent-face ext (list 'bold 'underline 'org-columns-space1))
- (org-set-local 'org-previous-header-line-format
- (specifier-specs top-gutter))
- (org-set-local 'org-columns-current-widths (nreverse widths))
- (set-specifier top-gutter (make-gutter-specifier
- (cons (current-buffer) title))))
- (setq title (concat
- (org-add-props " " nil 'display '(space :align-to 0))
- (org-add-props title nil 'face '(:weight bold :underline t))))
- (org-set-local 'org-previous-header-line-format header-line-format)
- (org-set-local 'org-columns-current-widths (nreverse widths))
- (setq org-columns-full-header-line-format title)
- (setq org-columns-previous-hscroll -1)
- (org-add-hook 'post-command-hook 'org-columns-hscoll-title nil 'local))))
-
-(defun org-columns-hscoll-title ()
- "Set the `header-line-format' so that it scrolls along with the table."
- (sit-for .0001) ; need to force a redisplay to update window-hscroll
- (when (not (= (window-hscroll) org-columns-previous-hscroll))
- (setq header-line-format
- (concat (substring org-columns-full-header-line-format 0 1)
- (substring org-columns-full-header-line-format
- (1+ (window-hscroll))))
- org-columns-previous-hscroll (window-hscroll))
- (force-mode-line-update)))
-
-(defvar org-colview-initial-truncate-line-value nil
- "Remember the value of `truncate-lines' across colview.")
-
-;;;###autoload
-(defun org-columns-remove-overlays ()
- "Remove all currently active column overlays."
- (interactive)
- (when (marker-buffer org-columns-begin-marker)
- (with-current-buffer (marker-buffer org-columns-begin-marker)
- (when (local-variable-p 'org-previous-header-line-format (current-buffer))
- (if (featurep 'xemacs)
- (set-specifier top-gutter
- (make-gutter-specifier
- (cons (current-buffer)
- (cdar org-previous-header-line-format))))
- (setq header-line-format org-previous-header-line-format)
- (remove-hook 'post-command-hook 'org-columns-hscoll-title 'local))
- (kill-local-variable 'org-previous-header-line-format))
- (move-marker org-columns-begin-marker nil)
- (move-marker org-columns-top-level-marker nil)
- (org-unmodified
- (mapc 'delete-overlay org-columns-overlays)
- (setq org-columns-overlays nil)
- (let ((inhibit-read-only t))
- (remove-text-properties (point-min) (point-max) '(read-only t))))
- (when (local-variable-p 'org-colview-initial-truncate-line-value
- (current-buffer))
- (setq truncate-lines org-colview-initial-truncate-line-value)))))
-
-
-(defun org-columns-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)
- (setq s (replace-match
- (concat "[" (match-string (if (match-end 3) 3 1) s) "]")
- t t s)))
- s)
-
-(defun org-columns-show-value ()
- "Show the full value of the property."
- (interactive)
- (let ((value (get-char-property (point) 'org-columns-value)))
- (message "Value is: %s" (or value ""))))
-
-(defvar org-agenda-columns-active) ;; defined in org-agenda.el
-
-(defun org-columns-quit ()
- "Remove the column overlays and in this way exit column editing."
- (interactive)
- (org-unmodified
- (org-columns-remove-overlays)
- (let ((inhibit-read-only t))
- (remove-text-properties (point-min) (point-max) '(read-only t))))
- (when (eq major-mode 'org-agenda-mode)
- (setq org-agenda-columns-active nil)
- (message
- "Modification not yet reflected in Agenda buffer, use `r' to refresh")))
-
-(defun org-columns-check-computed ()
- "Check if this column value is computed.
-If yes, throw an error indicating that changing it does not make sense."
- (let ((val (get-char-property (point) 'org-columns-value)))
- (when (and (stringp val)
- (get-char-property 0 'org-computed val))
- (error "This value is computed from the entry's children"))))
-
-(defun org-columns-todo (&optional arg)
- "Change the TODO state during column view."
- (interactive "P")
- (org-columns-edit-value "TODO"))
-
-(defun org-columns-set-tags-or-toggle (&optional arg)
- "Toggle checkbox at point, or set tags for current headline."
- (interactive "P")
- (if (string-match "\\`\\[[ xX-]\\]\\'"
- (get-char-property (point) 'org-columns-value))
- (org-columns-next-allowed-value)
- (org-columns-edit-value "TAGS")))
-
-(defun org-columns-edit-value (&optional key)
- "Edit the value of the property at point in column view.
-Where possible, use the standard interface for changing this line."
- (interactive)
- (org-columns-check-computed)
- (let* ((col (current-column))
- (key (or key (get-char-property (point) 'org-columns-key)))
- (value (get-char-property (point) 'org-columns-value))
- (bol (point-at-bol)) (eol (point-at-eol))
- (pom (or (get-text-property bol 'org-hd-marker)
- (point))) ; keep despite of compiler warning
- (line-overlays
- (delq nil (mapcar (lambda (x)
- (and (eq (overlay-buffer x) (current-buffer))
- (>= (overlay-start x) bol)
- (<= (overlay-start x) eol)
- x))
- org-columns-overlays)))
- (org-columns-time (time-to-number-of-days (current-time)))
- nval eval allowed)
- (cond
- ((equal key "CLOCKSUM")
- (error "This special column cannot be edited"))
- ((equal key "ITEM")
- (setq eval '(org-with-point-at pom (org-edit-headline))))
- ((equal key "TODO")
- (setq eval '(org-with-point-at
- pom
- (call-interactively 'org-todo))))
- ((equal key "PRIORITY")
- (setq eval '(org-with-point-at pom
- (call-interactively 'org-priority))))
- ((equal key "TAGS")
- (setq eval '(org-with-point-at
- pom
- (let ((org-fast-tag-selection-single-key
- (if (eq org-fast-tag-selection-single-key 'expert)
- t org-fast-tag-selection-single-key)))
- (call-interactively 'org-set-tags)))))
- ((equal key "DEADLINE")
- (setq eval '(org-with-point-at
- pom
- (call-interactively 'org-deadline))))
- ((equal key "SCHEDULED")
- (setq eval '(org-with-point-at
- pom
- (call-interactively 'org-schedule))))
- (t
- (setq allowed (org-property-get-allowed-values pom key 'table))
- (if allowed
- (setq nval (org-icompleting-read
- "Value: " allowed nil
- (not (get-text-property 0 'org-unrestricted
- (caar allowed)))))
- (setq nval (read-string "Edit: " value)))
- (setq nval (org-trim nval))
- (when (not (equal nval value))
- (setq eval '(org-entry-put pom key nval)))))
- (when eval
-
- (cond
- ((equal major-mode 'org-agenda-mode)
- (org-columns-eval eval)
- ;; The following let preserves the current format, and makes sure
- ;; that in only a single file things need to be upated.
- (let* ((org-agenda-overriding-columns-format org-columns-current-fmt)
- (buffer (marker-buffer pom))
- (org-agenda-contributing-files
- (list (with-current-buffer buffer
- (buffer-file-name (buffer-base-buffer))))))
- (org-agenda-columns)))
- (t
- (let ((inhibit-read-only t))
- (org-unmodified
- (remove-text-properties
- (max (point-min) (1- bol)) eol '(read-only t)))
- (unwind-protect
- (progn
- (setq org-columns-overlays
- (org-delete-all line-overlays org-columns-overlays))
- (mapc 'delete-overlay line-overlays)
- (org-columns-eval eval))
- (org-columns-display-here)))
- (org-move-to-column col)
- (if (and (derived-mode-p 'org-mode)
- (nth 3 (assoc key org-columns-current-fmt-compiled)))
- (org-columns-update key)))))))
-
-(defun org-edit-headline () ; FIXME: this is not columns specific. Make interactive????? Use from agenda????
- "Edit the current headline, the part without TODO keyword, TAGS."
- (org-back-to-heading)
- (when (looking-at org-todo-line-regexp)
- (let ((pos (point))
- (pre (buffer-substring (match-beginning 0) (match-beginning 3)))
- (txt (match-string 3))
- (post "")
- txt2)
- (if (string-match (org-re "[ \t]+:[[:alnum:]:_@#%]+:[ \t]*$") txt)
- (setq post (match-string 0 txt)
- txt (substring txt 0 (match-beginning 0))))
- (setq txt2 (read-string "Edit: " txt))
- (when (not (equal txt txt2))
- (goto-char pos)
- (insert pre txt2 post)
- (delete-region (point) (point-at-eol))
- (org-set-tags nil t)))))
-
-(defun org-columns-edit-allowed ()
- "Edit the list of allowed values for the current property."
- (interactive)
- (let* ((pom (or (org-get-at-bol 'org-marker)
- (org-get-at-bol 'org-hd-marker)
- (point)))
- (key (get-char-property (point) 'org-columns-key))
- (key1 (concat key "_ALL"))
- (allowed (org-entry-get pom key1 t))
- nval)
- ;; FIXME: Cover editing TODO, TAGS etc in-buffer settings.????
- ;; FIXME: Write back to #+PROPERTY setting if that is needed.
- (setq nval (read-string "Allowed: " allowed))
- (org-entry-put
- (cond ((marker-position org-entry-property-inherited-from)
- org-entry-property-inherited-from)
- ((marker-position org-columns-top-level-marker)
- org-columns-top-level-marker)
- (t pom))
- key1 nval)))
-
-(defun org-columns-eval (form)
- (let (hidep)
- (save-excursion
- (beginning-of-line 1)
- ;; `next-line' is needed here, because it skips invisible line.
- (condition-case nil (org-no-warnings (next-line 1)) (error nil))
- (setq hidep (org-at-heading-p 1)))
- (eval form)
- (and hidep (hide-entry))))
-
-(defun org-columns-previous-allowed-value ()
- "Switch to the previous allowed value for this column."
- (interactive)
- (org-columns-next-allowed-value t))
-
-(defun org-columns-next-allowed-value (&optional previous nth)
- "Switch to the next allowed value for this column.
-When PREVIOUS is set, go to the previous value. When NTH is
-an integer, select that value."
- (interactive)
- (org-columns-check-computed)
- (let* ((col (current-column))
- (key (get-char-property (point) 'org-columns-key))
- (value (get-char-property (point) 'org-columns-value))
- (bol (point-at-bol)) (eol (point-at-eol))
- (pom (or (get-text-property bol 'org-hd-marker)
- (point))) ; keep despite of compiler waring
- (line-overlays
- (delq nil (mapcar (lambda (x)
- (and (eq (overlay-buffer x) (current-buffer))
- (>= (overlay-start x) bol)
- (<= (overlay-start x) eol)
- x))
- org-columns-overlays)))
- (allowed (or (org-property-get-allowed-values pom key)
- (and (memq
- (nth 4 (assoc key org-columns-current-fmt-compiled))
- '(checkbox checkbox-n-of-m checkbox-percent))
- '("[ ]" "[X]"))
- (org-colview-construct-allowed-dates value)))
- nval)
- (when (integerp nth)
- (setq nth (1- nth))
- (if (= nth -1) (setq nth 9)))
- (when (equal key "ITEM")
- (error "Cannot edit item headline from here"))
- (unless (or allowed (member key '("SCHEDULED" "DEADLINE")))
- (error "Allowed values for this property have not been defined"))
- (if (member key '("SCHEDULED" "DEADLINE"))
- (setq nval (if previous 'earlier 'later))
- (if previous (setq allowed (reverse allowed)))
- (cond
- (nth
- (setq nval (nth nth allowed))
- (if (not nval)
- (error "There are only %d allowed values for property `%s'"
- (length allowed) key)))
- ((member value allowed)
- (setq nval (or (car (cdr (member value allowed)))
- (car allowed)))
- (if (equal nval value)
- (error "Only one allowed value for this property")))
- (t (setq nval (car allowed)))))
- (cond
- ((equal major-mode 'org-agenda-mode)
- (org-columns-eval '(org-entry-put pom key nval))
- ;; The following let preserves the current format, and makes sure
- ;; that in only a single file things need to be upated.
- (let* ((org-agenda-overriding-columns-format org-columns-current-fmt)
- (buffer (marker-buffer pom))
- (org-agenda-contributing-files
- (list (with-current-buffer buffer
- (buffer-file-name (buffer-base-buffer))))))
- (org-agenda-columns)))
- (t
- (let ((inhibit-read-only t))
- (remove-text-properties (1- bol) eol '(read-only t))
- (unwind-protect
- (progn
- (setq org-columns-overlays
- (org-delete-all line-overlays org-columns-overlays))
- (mapc 'delete-overlay line-overlays)
- (org-columns-eval '(org-entry-put pom key nval)))
- (org-columns-display-here)))
- (org-move-to-column col)
- (and (nth 3 (assoc key org-columns-current-fmt-compiled))
- (org-columns-update key))))))
-
-(defun org-colview-construct-allowed-dates (s)
- "Construct a list of three dates around the date in S.
-This respects the format of the time stamp in S, active or non-active,
-and also including time or not. S must be just a time stamp, no text
-around it."
- (when (and s (string-match (concat "^" org-ts-regexp3 "$") s))
- (let* ((time (org-parse-time-string s 'nodefaults))
- (active (equal (string-to-char s) ?<))
- (fmt (funcall (if (nth 1 time) 'cdr 'car) org-time-stamp-formats))
- time-before time-after)
- (unless active (setq fmt (concat "[" (substring fmt 1 -1) "]")))
- (setf (car time) (or (car time) 0))
- (setf (nth 1 time) (or (nth 1 time) 0))
- (setf (nth 2 time) (or (nth 2 time) 0))
- (setq time-before (copy-sequence time))
- (setq time-after (copy-sequence time))
- (setf (nth 3 time-before) (1- (nth 3 time)))
- (setf (nth 3 time-after) (1+ (nth 3 time)))
- (mapcar (lambda (x) (format-time-string fmt (apply 'encode-time x)))
- (list time-before time time-after)))))
-
-(defun org-verify-version (task)
- (cond
- ((eq task 'columns)
- (if (or (and (featurep 'xemacs) (not (featurep 'org-colview-xemacs)))
- (and (not (featurep 'xemacs)) (< emacs-major-version 22)))
- (error "This version of Emacs cannot run Column View")))))
-
-(defun org-columns-open-link (&optional arg)
- (interactive "P")
- (let ((value (get-char-property (point) 'org-columns-value)))
- (org-open-link-from-string value arg)))
-
-;;;###autoload
-(defun org-columns-get-format-and-top-level ()
- (let (fmt)
- (when (condition-case nil (org-back-to-heading) (error nil))
- (setq fmt (org-entry-get nil "COLUMNS" t)))
- (setq fmt (or fmt org-columns-default-format))
- (org-set-local 'org-columns-current-fmt fmt)
- (org-columns-compile-format fmt)
- (if (marker-position org-entry-property-inherited-from)
- (move-marker org-columns-top-level-marker
- org-entry-property-inherited-from)
- (move-marker org-columns-top-level-marker (point)))
- fmt))
-
-(defun org-columns ()
- "Turn on column view on an org-mode file."
- (interactive)
- (org-verify-version 'columns)
- (when (featurep 'xemacs)
- (set-face-foreground 'org-columns-space
- (face-background 'org-columns-space)))
- (org-columns-remove-overlays)
- (move-marker org-columns-begin-marker (point))
- (let ((org-columns-time (time-to-number-of-days (current-time)))
- beg end fmt cache maxwidths)
- (setq fmt (org-columns-get-format-and-top-level))
- (save-excursion
- (goto-char org-columns-top-level-marker)
- (setq beg (point))
- (unless org-columns-inhibit-recalculation
- (org-columns-compute-all))
- (setq end (or (condition-case nil (org-end-of-subtree t t) (error nil))
- (point-max)))
- ;; Get and cache the properties
- (goto-char beg)
- (when (assoc "CLOCKSUM" org-columns-current-fmt-compiled)
- (save-excursion
- (save-restriction
- (narrow-to-region beg end)
- (org-clock-sum))))
- (while (re-search-forward org-outline-regexp-bol end t)
- (if (and org-columns-skip-archived-trees
- (looking-at (concat ".*:" org-archive-tag ":")))
- (org-end-of-subtree t)
- (push (cons (org-current-line) (org-entry-properties)) cache)))
- (when cache
- (setq maxwidths (org-columns-get-autowidth-alist fmt cache))
- (org-set-local 'org-columns-current-maxwidths maxwidths)
- (org-columns-display-here-title)
- (unless (local-variable-p 'org-colview-initial-truncate-line-value
- (current-buffer))
- (org-set-local 'org-colview-initial-truncate-line-value
- truncate-lines))
- (setq truncate-lines t)
- (mapc (lambda (x)
- (org-goto-line (car x))
- (org-columns-display-here (cdr x)))
- cache)))))
-
-(eval-when-compile (defvar org-columns-time))
-
-(defvar org-columns-compile-map
- '(("none" none +)
- (":" add_times +)
- ("+" add_numbers +)
- ("$" currency +)
- ("X" checkbox +)
- ("X/" checkbox-n-of-m +)
- ("X%" checkbox-percent +)
- ("max" max_numbers max)
- ("min" min_numbers min)
- ("mean" mean_numbers
- (lambda (&rest x) (/ (apply '+ x) (float (length x)))))
- (":max" max_times max)
- (":min" min_times min)
- (":mean" mean_times
- (lambda (&rest x) (/ (apply '+ x) (float (length x)))))
- ("@min" min_age min (lambda (x) (- org-columns-time x)))
- ("@max" max_age max (lambda (x) (- org-columns-time x)))
- ("@mean" mean_age
- (lambda (&rest x) (/ (apply '+ x) (float (length x))))
- (lambda (x) (- org-columns-time x)))
- ("est+" estimate org-estimate-combine))
- "Operator <-> format,function,calc map.
-Used to compile/uncompile columns format and completing read in
-interactive function `org-columns-new'.
-
- operator string used in #+COLUMNS definition describing the
- summary type
- format symbol describing summary type selected interactively in
- `org-columns-new' and internally in
- `org-columns-number-to-string' and
- `org-columns-string-to-number'
- function called with a list of values as argument to calculate
- the summary value
- calc function called on every element before summarizing. This is
- optional and should only be specified if needed")
-
-
-(defun org-columns-new (&optional prop title width op fmt fun &rest rest)
- "Insert a new column, to the left of the current column."
- (interactive)
- (let ((n (org-columns-current-column))
- (editp (and prop (assoc prop org-columns-current-fmt-compiled)))
- cell)
- (setq prop (org-icompleting-read
- "Property: " (mapcar 'list (org-buffer-property-keys t nil t))
- nil nil prop))
- (setq title (read-string (concat "Column title [" prop "]: ") (or title prop)))
- (setq width (read-string "Column width: " (if width (number-to-string width))))
- (if (string-match "\\S-" width)
- (setq width (string-to-number width))
- (setq width nil))
- (setq fmt (org-icompleting-read "Summary [none]: "
- (mapcar (lambda (x) (list (symbol-name (cadr x)))) org-columns-compile-map)
- nil t))
- (setq fmt (intern fmt)
- fun (cdr (assoc fmt (mapcar 'cdr org-columns-compile-map))))
- (if (eq fmt 'none) (setq fmt nil))
- (if editp
- (progn
- (setcar editp prop)
- (setcdr editp (list title width nil fmt nil fun)))
- (setq cell (nthcdr (1- n) org-columns-current-fmt-compiled))
- (setcdr cell (cons (list prop title width nil fmt nil
- (car fun) (cadr fun))
- (cdr cell))))
- (org-columns-store-format)
- (org-columns-redo)))
-
-(defun org-columns-delete ()
- "Delete the column at point from columns view."
- (interactive)
- (let* ((n (org-columns-current-column))
- (title (nth 1 (nth n org-columns-current-fmt-compiled))))
- (when (y-or-n-p
- (format "Are you sure you want to remove column \"%s\"? " title))
- (setq org-columns-current-fmt-compiled
- (delq (nth n org-columns-current-fmt-compiled)
- org-columns-current-fmt-compiled))
- (org-columns-store-format)
- (org-columns-redo)
- (if (>= (org-columns-current-column)
- (length org-columns-current-fmt-compiled))
- (org-columns-backward-char)))))
-
-(defun org-columns-edit-attributes ()
- "Edit the attributes of the current column."
- (interactive)
- (let* ((n (org-columns-current-column))
- (info (nth n org-columns-current-fmt-compiled)))
- (apply 'org-columns-new info)))
-
-(defun org-columns-widen (arg)
- "Make the column wider by ARG characters."
- (interactive "p")
- (let* ((n (org-columns-current-column))
- (entry (nth n org-columns-current-fmt-compiled))
- (width (or (nth 2 entry)
- (cdr (assoc (car entry) org-columns-current-maxwidths)))))
- (setq width (max 1 (+ width arg)))
- (setcar (nthcdr 2 entry) width)
- (org-columns-store-format)
- (org-columns-redo)))
-
-(defun org-columns-narrow (arg)
- "Make the column narrower by ARG characters."
- (interactive "p")
- (org-columns-widen (- arg)))
-
-(defun org-columns-move-right ()
- "Swap this column with the one to the right."
- (interactive)
- (let* ((n (org-columns-current-column))
- (cell (nthcdr n org-columns-current-fmt-compiled))
- e)
- (when (>= n (1- (length org-columns-current-fmt-compiled)))
- (error "Cannot shift this column further to the right"))
- (setq e (car cell))
- (setcar cell (car (cdr cell)))
- (setcdr cell (cons e (cdr (cdr cell))))
- (org-columns-store-format)
- (org-columns-redo)
- (org-columns-forward-char)))
-
-(defun org-columns-move-left ()
- "Swap this column with the one to the left."
- (interactive)
- (let* ((n (org-columns-current-column)))
- (when (= n 0)
- (error "Cannot shift this column further to the left"))
- (org-columns-backward-char)
- (org-columns-move-right)
- (org-columns-backward-char)))
-
-(defun org-columns-store-format ()
- "Store the text version of the current columns format in appropriate place.
-This is either in the COLUMNS property of the node starting the current column
-display, or in the #+COLUMNS line of the current buffer."
- (let (fmt (cnt 0))
- (setq fmt (org-columns-uncompile-format org-columns-current-fmt-compiled))
- (org-set-local 'org-columns-current-fmt fmt)
- (if (marker-position org-columns-top-level-marker)
- (save-excursion
- (goto-char org-columns-top-level-marker)
- (if (and (org-at-heading-p)
- (org-entry-get nil "COLUMNS"))
- (org-entry-put nil "COLUMNS" fmt)
- (goto-char (point-min))
- ;; Overwrite all #+COLUMNS lines....
- (while (re-search-forward "^#\\+COLUMNS:.*" nil t)
- (setq cnt (1+ cnt))
- (replace-match (concat "#+COLUMNS: " fmt) t t))
- (unless (> cnt 0)
- (goto-char (point-min))
- (or (org-at-heading-p t) (outline-next-heading))
- (let ((inhibit-read-only t))
- (insert-before-markers "#+COLUMNS: " fmt "\n")))
- (org-set-local 'org-columns-default-format fmt))))))
-
-(defvar org-agenda-overriding-columns-format nil
- "When set, overrides any other format definition for the agenda.
-Don't set this, this is meant for dynamic scoping.")
-
-(defun org-columns-get-autowidth-alist (s cache)
- "Derive the maximum column widths from the format and the cache."
- (let ((start 0) rtn)
- (while (string-match (org-re "%\\([[:alpha:]][[:alnum:]_-]*\\)") s start)
- (push (cons (match-string 1 s) 1) rtn)
- (setq start (match-end 0)))
- (mapc (lambda (x)
- (setcdr x (apply 'max
- (mapcar
- (lambda (y)
- (length (or (cdr (assoc (car x) (cdr y))) " ")))
- cache))))
- rtn)
- rtn))
-
-(defun org-columns-compute-all ()
- "Compute all columns that have operators defined."
- (org-unmodified
- (remove-text-properties (point-min) (point-max) '(org-summaries t)))
- (let ((columns org-columns-current-fmt-compiled)
- (org-columns-time (time-to-number-of-days (current-time)))
- col)
- (while (setq col (pop columns))
- (when (nth 3 col)
- (save-excursion
- (org-columns-compute (car col)))))))
-
-(defun org-columns-update (property)
- "Recompute PROPERTY, and update the columns display for it."
- (org-columns-compute property)
- (let (fmt val pos face)
- (save-excursion
- (mapc (lambda (ov)
- (when (equal (overlay-get ov 'org-columns-key) property)
- (setq pos (overlay-start ov))
- (goto-char pos)
- (when (setq val (cdr (assoc property
- (get-text-property
- (point-at-bol) 'org-summaries))))
- (setq fmt (overlay-get ov 'org-columns-format))
- (overlay-put ov 'org-columns-value val)
- (if (featurep 'xemacs)
- (progn
- (setq face (glyph-face (extent-end-glyph ov)))
- (org-overlay-display ov (format fmt val) face))
- (org-overlay-display ov (format fmt val))))))
- org-columns-overlays))))
-
-;;;###autoload
-(defun org-columns-compute (property)
- "Sum the values of property PROPERTY hierarchically, for the entire buffer."
- (interactive)
- (let* ((re org-outline-regexp-bol)
- (lmax 30) ; Does anyone use deeper levels???
- (lvals (make-vector lmax nil))
- (lflag (make-vector lmax nil))
- (level 0)
- (ass (assoc property org-columns-current-fmt-compiled))
- (format (nth 4 ass))
- (printf (nth 5 ass))
- (fun (nth 6 ass))
- (calc (or (nth 7 ass) 'identity))
- (beg org-columns-top-level-marker)
- last-level val valflag flag end sumpos sum-alist sum str str1 useval)
- (save-excursion
- ;; Find the region to compute
- (goto-char beg)
- (setq end (condition-case nil (org-end-of-subtree t) (error (point-max))))
- (goto-char end)
- ;; Walk the tree from the back and do the computations
- (while (re-search-backward re beg t)
- (setq sumpos (match-beginning 0)
- last-level level
- level (org-outline-level)
- val (org-entry-get nil property)
- valflag (and val (string-match "\\S-" val)))
- (cond
- ((< level last-level)
- ;; put the sum of lower levels here as a property
- (setq sum (when (aref lvals last-level)
- (apply fun (aref lvals last-level)))
- flag (aref lflag last-level) ; any valid entries from children?
- str (org-columns-number-to-string sum format printf)
- str1 (org-add-props (copy-sequence str) nil 'org-computed t 'face 'bold)
- useval (if flag str1 (if valflag val ""))
- sum-alist (get-text-property sumpos 'org-summaries))
- (if (assoc property sum-alist)
- (setcdr (assoc property sum-alist) useval)
- (push (cons property useval) sum-alist)
- (org-unmodified
- (add-text-properties sumpos (1+ sumpos)
- (list 'org-summaries sum-alist))))
- (when (and val (not (equal val (if flag str val))))
- (org-entry-put nil property (if flag str val)))
- ;; add current to current level accumulator
- (when (or flag valflag)
- (push (if flag
- sum
- (funcall calc (org-columns-string-to-number
- (if flag str val) format)))
- (aref lvals level))
- (aset lflag level t))
- ;; clear accumulators for deeper levels
- (loop for l from (1+ level) to (1- lmax) do
- (aset lvals l nil)
- (aset lflag l nil)))
- ((>= level last-level)
- ;; add what we have here to the accumulator for this level
- (when valflag
- (push (funcall calc (org-columns-string-to-number val format))
- (aref lvals level))
- (aset lflag level t)))
- (t (error "This should not happen")))))))
-
-(defun org-columns-redo ()
- "Construct the column display again."
- (interactive)
- (message "Recomputing columns...")
- (save-excursion
- (if (marker-position org-columns-begin-marker)
- (goto-char org-columns-begin-marker))
- (org-columns-remove-overlays)
- (if (derived-mode-p 'org-mode)
- (call-interactively 'org-columns)
- (org-agenda-redo)
- (call-interactively 'org-agenda-columns)))
- (when (featurep 'xemacs)
- (while (not (or (eolp)
- (member (extent-at (point)) org-columns-overlays)))
- (forward-char)))
- (message "Recomputing columns...done"))
-
-(defun org-columns-not-in-agenda ()
- (if (eq major-mode 'org-agenda-mode)
- (error "This command is only allowed in Org-mode buffers")))
-
-(defun org-string-to-number (s)
- "Convert string to number, and interpret hh:mm:ss."
- (if (not (string-match ":" s))
- (string-to-number s)
- (let ((l (nreverse (org-split-string s ":"))) (sum 0.0))
- (while l
- (setq sum (+ (string-to-number (pop l)) (/ sum 60))))
- sum)))
-
-;;;###autoload
-(defun org-columns-number-to-string (n fmt &optional printf)
- "Convert a computed column number to a string value, according to FMT."
- (cond
- ((memq fmt '(estimate)) (org-estimate-print n printf))
- ((not (numberp n)) "")
- ((memq fmt '(add_times max_times min_times mean_times))
- (let* ((h (floor n)) (m (floor (+ 0.5 (* 60 (- n h))))))
- (format org-time-clocksum-format h m)))
- ((eq fmt 'checkbox)
- (cond ((= n (floor n)) "[X]")
- ((> n 1.) "[-]")
- (t "[ ]")))
- ((memq fmt '(checkbox-n-of-m checkbox-percent))
- (let* ((n1 (floor n)) (n2 (floor (+ .5 (* 1000000 (- n n1))))))
- (org-nofm-to-completion n1 (+ n2 n1) (eq fmt 'checkbox-percent))))
- (printf (format printf n))
- ((eq fmt 'currency)
- (format "%.2f" n))
- ((memq fmt '(min_age max_age mean_age))
- (org-format-time-period n))
- (t (number-to-string n))))
-
-(defun org-nofm-to-completion (n m &optional percent)
- (if (not percent)
- (format "[%d/%d]" n m)
- (format "[%d%%]"(floor (+ 0.5 (* 100. (/ (* 1.0 n) m)))))))
-
-(defun org-columns-string-to-number (s fmt)
- "Convert a column value to a number that can be used for column computing."
- (if s
- (cond
- ((memq fmt '(min_age max_age mean_age))
- (cond ((string= s "") org-columns-time)
- ((string-match
- "\\([0-9]+\\)d \\([0-9]+\\)h \\([0-9]+\\)m \\([0-9]+\\)s"
- s)
- (+ (* 60 (+ (* 60 (+ (* 24 (string-to-number (match-string 1 s)))
- (string-to-number (match-string 2 s))))
- (string-to-number (match-string 3 s))))
- (string-to-number (match-string 4 s))))
- (t (time-to-number-of-days (apply 'encode-time
- (org-parse-time-string s t))))))
- ((string-match ":" s)
- (let ((l (nreverse (org-split-string s ":"))) (sum 0.0))
- (while l
- (setq sum (+ (string-to-number (pop l)) (/ sum 60))))
- sum))
- ((memq fmt '(checkbox checkbox-n-of-m checkbox-percent))
- (if (equal s "[X]") 1. 0.000001))
- ((memq fmt '(estimate)) (org-string-to-estimate s))
- (t (string-to-number s)))))
-
-(defun org-columns-uncompile-format (cfmt)
- "Turn the compiled columns format back into a string representation."
- (let ((rtn "") e s prop title op op-match width fmt printf fun calc)
- (while (setq e (pop cfmt))
- (setq prop (car e)
- title (nth 1 e)
- width (nth 2 e)
- op (nth 3 e)
- fmt (nth 4 e)
- printf (nth 5 e)
- fun (nth 6 e)
- calc (nth 7 e))
- (when (setq op-match (rassoc (list fmt fun calc) org-columns-compile-map))
- (setq op (car op-match)))
- (if (and op printf) (setq op (concat op ";" printf)))
- (if (equal title prop) (setq title nil))
- (setq s (concat "%" (if width (number-to-string width))
- prop
- (if title (concat "(" title ")"))
- (if op (concat "{" op "}"))))
- (setq rtn (concat rtn " " s)))
- (org-trim rtn)))
-
-(defun org-columns-compile-format (fmt)
- "Turn a column format string into an alist of specifications.
-The alist has one entry for each column in the format. The elements of
-that list are:
-property the property
-title the title field for the columns
-width the column width in characters, can be nil for automatic
-operator the operator if any
-format the output format for computed results, derived from operator
-printf a printf format for computed values
-fun the lisp function to compute summary values, derived from operator
-calc function to get values from base elements"
- (let ((start 0) width prop title op op-match f printf fun calc)
- (setq org-columns-current-fmt-compiled nil)
- (while (string-match
- (org-re "%\\([0-9]+\\)?\\([[:alnum:]_-]+\\)\\(?:(\\([^)]+\\))\\)?\\(?:{\\([^}]+\\)}\\)?\\s-*")
- fmt start)
- (setq start (match-end 0)
- width (match-string 1 fmt)
- prop (match-string 2 fmt)
- title (or (match-string 3 fmt) prop)
- op (match-string 4 fmt)
- f nil
- printf nil
- fun '+
- calc nil)
- (if width (setq width (string-to-number width)))
- (when (and op (string-match ";" op))
- (setq printf (substring op (match-end 0))
- op (substring op 0 (match-beginning 0))))
- (when (setq op-match (assoc op org-columns-compile-map))
- (setq f (cadr op-match)
- fun (caddr op-match)
- calc (cadddr op-match)))
- (push (list prop title width op f printf fun calc)
- org-columns-current-fmt-compiled))
- (setq org-columns-current-fmt-compiled
- (nreverse org-columns-current-fmt-compiled))))
-
-
-;;; Dynamic block for Column view
-
-(defun org-columns-capture-view (&optional maxlevel skip-empty-rows)
- "Get the column view of the current buffer or subtree.
-The first optional argument MAXLEVEL sets the level limit. A
-second optional argument SKIP-EMPTY-ROWS tells whether to skip
-empty rows, an empty row being one where all the column view
-specifiers except ITEM are empty. This function returns a list
-containing the title row and all other rows. Each row is a list
-of fields."
- (if (featurep 'xemacs)
- (save-excursion
- (let* ((title (mapcar 'cadr org-columns-current-fmt-compiled))
- (re-comment (format org-heading-keyword-regexp-format
- org-comment-string))
- (re-archive (concat ".*:" org-archive-tag ":"))
- (n (length title)) row tbl)
- (goto-char (point-min))
-
- (while (re-search-forward org-heading-regexp nil t)
- (catch 'next
- (when (and (or (null maxlevel)
- (>= maxlevel
- (if org-odd-levels-only
- (/ (1+ (length (match-string 1))) 2)
- (length (match-string 1)))))
- (get-char-property (match-beginning 0) 'org-columns-key))
- (goto-char (match-beginning 0))
- (when (save-excursion
- (goto-char (point-at-bol))
- (or (looking-at re-comment)
- (looking-at re-archive)))
- (org-end-of-subtree t)
- (throw 'next t))
- (setq row nil)
- (loop for i from 0 to (1- n) do
- (push
- (org-quote-vert
- (or (get-char-property (point)
- 'org-columns-value-modified)
- (get-char-property (point) 'org-columns-value)
- ""))
- row)
- (org-columns-forward-char))
- (setq row (nreverse row))
- (unless (and skip-empty-rows
- (eq 1 (length (delete "" (delete-dups (copy-sequence row))))))
- (push row tbl)))))
- (append (list title 'hline) (nreverse tbl))))
- (save-excursion
- (let* ((title (mapcar 'cadr org-columns-current-fmt-compiled))
- (n (length title)) row tbl)
- (goto-char (point-min))
- (while (and (re-search-forward "^\\(\\*+\\) " nil t)
- (or (null maxlevel)
- (>= maxlevel
- (if org-odd-levels-only
- (/ (1+ (length (match-string 1))) 2)
- (length (match-string 1))))))
- (when (get-char-property (match-beginning 0) 'org-columns-key)
- (setq row nil)
- (loop for i from 0 to (1- n) do
- (push (or (get-char-property (+ (match-beginning 0) i)
- 'org-columns-value-modified)
- (get-char-property (+ (match-beginning 0) i)
- 'org-columns-value)
- "")
- row))
- (setq row (nreverse row))
- (unless (and skip-empty-rows
- (eq 1 (length (delete "" (delete-dups row)))))
- (push row tbl))))
- (append (list title 'hline) (nreverse tbl))))))
-
-(defun org-dblock-write:columnview (params)
- "Write the column view table.
-PARAMS is a property list of parameters:
-
-:width enforce same column widths with <N> specifiers.
-:id the :ID: property of the entry where the columns view
- should be built. When the symbol `local', call locally.
- When `global' call column view with the cursor at the beginning
- of the buffer (usually this means that the whole buffer switches
- to column view). When \"file:path/to/file.org\", invoke column
- view at the start of that file. Otherwise, the ID is located
- using `org-id-find'.
-:hlines When t, insert a hline before each item. When a number, insert
- a hline before each level <= that number.
-:vlines When t, make each column a colgroup to enforce vertical lines.
-:maxlevel When set to a number, don't capture headlines below this level.
-:skip-empty-rows
- When t, skip rows where all specifiers other than ITEM are empty."
- (let ((pos (point-marker))
- (hlines (plist-get params :hlines))
- (vlines (plist-get params :vlines))
- (maxlevel (plist-get params :maxlevel))
- (content-lines (org-split-string (plist-get params :content) "\n"))
- (skip-empty-rows (plist-get params :skip-empty-rows))
- (case-fold-search t)
- tbl id idpos nfields tmp recalc line
- id-as-string view-file view-pos)
- (when (setq id (plist-get params :id))
- (setq id-as-string (cond ((numberp id) (number-to-string id))
- ((symbolp id) (symbol-name id))
- ((stringp id) id)
- (t "")))
- (cond ((not id) nil)
- ((eq id 'global) (setq view-pos (point-min)))
- ((eq id 'local))
- ((string-match "^file:\\(.*\\)" id-as-string)
- (setq view-file (match-string 1 id-as-string)
- view-pos 1)
- (unless (file-exists-p view-file)
- (error "No such file: \"%s\"" id-as-string)))
- ((setq idpos (org-find-entry-with-id id))
- (setq view-pos idpos))
- ((setq idpos (org-id-find id))
- (setq view-file (car idpos))
- (setq view-pos (cdr idpos)))
- (t (error "Cannot find entry with :ID: %s" id))))
- (with-current-buffer (if view-file
- (get-file-buffer view-file)
- (current-buffer))
- (save-excursion
- (save-restriction
- (widen)
- (goto-char (or view-pos (point)))
- (org-columns)
- (setq tbl (org-columns-capture-view maxlevel skip-empty-rows))
- (setq nfields (length (car tbl)))
- (org-columns-quit))))
- (goto-char pos)
- (move-marker pos nil)
- (when tbl
- (when (plist-get params :hlines)
- (setq tmp nil)
- (while tbl
- (if (eq (car tbl) 'hline)
- (push (pop tbl) tmp)
- (if (string-match "\\` *\\(\\*+\\)" (caar tbl))
- (if (and (not (eq (car tmp) 'hline))
- (or (eq hlines t)
- (and (numberp hlines)
- (<= (- (match-end 1) (match-beginning 1))
- hlines))))
- (push 'hline tmp)))
- (push (pop tbl) tmp)))
- (setq tbl (nreverse tmp)))
- (when vlines
- (setq tbl (mapcar (lambda (x)
- (if (eq 'hline x) x (cons "" x)))
- tbl))
- (setq tbl (append tbl (list (cons "/" (make-list nfields "<>"))))))
- (setq pos (point))
- (when content-lines
- (while (string-match "^#" (car content-lines))
- (insert (pop content-lines) "\n")))
- (insert (org-listtable-to-string tbl))
- (when (plist-get params :width)
- (insert "\n|" (mapconcat (lambda (x) (format "<%d>" (max 3 x)))
- org-columns-current-widths "|")))
- (while (setq line (pop content-lines))
- (when (string-match "^#" line)
- (insert "\n" line)
- (when (string-match "^[ \t]*#\\+tblfm" line)
- (setq recalc t))))
- (if recalc
- (progn (goto-char pos) (org-table-recalculate 'all))
- (goto-char pos)
- (org-table-align)))))
-
-(defun org-listtable-to-string (tbl)
- "Convert a listtable TBL to a string that contains the Org-mode table.
-The table still need to be aligned. The resulting string has no leading
-and tailing newline characters."
- (mapconcat
- (lambda (x)
- (cond
- ((listp x)
- (concat "|" (mapconcat 'identity x "|") "|"))
- ((eq x 'hline) "|-|")
- (t (error "Garbage in listtable: %s" x))))
- tbl "\n"))
-
-(defun org-insert-columns-dblock ()
- "Create a dynamic block capturing a column view table."
- (interactive)
- (when (featurep 'xemacs) (org-columns-quit))
- (let ((defaults '(:name "columnview" :hlines 1))
- (id (org-icompleting-read
- "Capture columns (local, global, entry with :ID: property) [local]: "
- (append '(("global") ("local"))
- (mapcar 'list (org-property-values "ID"))))))
- (if (equal id "") (setq id 'local))
- (if (equal id "global") (setq id 'global))
- (setq defaults (append defaults (list :id id)))
- (org-create-dblock defaults)
- (org-update-dblock)))
-
-;;; Column view in the agenda
-
-(defvar org-agenda-view-columns-initially nil
- "When set, switch to columns view immediately after creating the agenda.")
-
-(defvar org-agenda-columns-show-summaries) ; defined in org-agenda.el
-(defvar org-agenda-columns-compute-summary-properties); defined in org-agenda.el
-(defvar org-agenda-columns-add-appointments-to-effort-sum); as well
-
-(defun org-agenda-columns ()
- "Turn on or update column view in the agenda."
- (interactive)
- (org-verify-version 'columns)
- (org-columns-remove-overlays)
- (move-marker org-columns-begin-marker (point))
- (let ((org-columns-time (time-to-number-of-days (current-time)))
- cache maxwidths m p a d fmt)
- (cond
- ((and (boundp 'org-agenda-overriding-columns-format)
- org-agenda-overriding-columns-format)
- (setq fmt org-agenda-overriding-columns-format)
- (org-set-local 'org-agenda-overriding-columns-format fmt))
- ((setq m (org-get-at-bol 'org-hd-marker))
- (setq fmt (or (org-entry-get m "COLUMNS" t)
- (with-current-buffer (marker-buffer m)
- org-columns-default-format))))
- ((and (boundp 'org-columns-current-fmt)
- (local-variable-p 'org-columns-current-fmt (current-buffer))
- org-columns-current-fmt)
- (setq fmt org-columns-current-fmt))
- ((setq m (next-single-property-change (point-min) 'org-hd-marker))
- (setq m (get-text-property m 'org-hd-marker))
- (setq fmt (or (org-entry-get m "COLUMNS" t)
- (with-current-buffer (marker-buffer m)
- org-columns-default-format)))))
- (setq fmt (or fmt org-columns-default-format))
- (org-set-local 'org-columns-current-fmt fmt)
- (org-columns-compile-format fmt)
- (when org-agenda-columns-compute-summary-properties
- (org-agenda-colview-compute org-columns-current-fmt-compiled))
- (save-excursion
- ;; Get and cache the properties
- (goto-char (point-min))
- (while (not (eobp))
- (when (setq m (or (org-get-at-bol 'org-hd-marker)
- (org-get-at-bol 'org-marker)))
- (setq p (org-entry-properties m))
-
- (when (or (not (setq a (assoc org-effort-property p)))
- (not (string-match "\\S-" (or (cdr a) ""))))
- ;; OK, the property is not defined. Use appointment duration?
- (when (and org-agenda-columns-add-appointments-to-effort-sum
- (setq d (get-text-property (point) 'duration)))
- (setq d (org-minutes-to-clocksum-string d))
- (put-text-property 0 (length d) 'face 'org-warning d)
- (push (cons org-effort-property d) p)))
- (push (cons (org-current-line) p) cache))
- (beginning-of-line 2))
- (when cache
- (setq maxwidths (org-columns-get-autowidth-alist fmt cache))
- (org-set-local 'org-columns-current-maxwidths maxwidths)
- (org-columns-display-here-title)
- (mapc (lambda (x)
- (org-goto-line (car x))
- (org-columns-display-here (cdr x)))
- cache)
- (when org-agenda-columns-show-summaries
- (org-agenda-colview-summarize cache))))))
-
-(defun org-agenda-colview-summarize (cache)
- "Summarize the summarizable columns in column view in the agenda.
-This will add overlays to the date lines, to show the summary for each day."
- (let* ((fmt (mapcar (lambda (x)
- (if (equal (car x) "CLOCKSUM")
- (list "CLOCKSUM" (nth 2 x) nil 'add_times nil '+ 'identity)
- (cdr x)))
- org-columns-current-fmt-compiled))
- line c c1 stype calc sumfunc props lsum entries prop v)
- (catch 'exit
- (when (delq nil (mapcar 'cadr fmt))
- ;; OK, at least one summation column, it makes sense to try this
- (goto-char (point-max))
- (while t
- (when (or (get-text-property (point) 'org-date-line)
- (eq (get-text-property (point) 'face)
- 'org-agenda-structure))
- ;; OK, this is a date line that should be used
- (setq line (org-current-line))
- (setq entries nil c cache cache nil)
- (while (setq c1 (pop c))
- (if (> (car c1) line)
- (push c1 entries)
- (push c1 cache)))
- ;; now ENTRIES are the ones we want to use, CACHE is the rest
- ;; Compute the summaries for the properties we want,
- ;; set nil properties for the rest.
- (when (setq entries (mapcar 'cdr entries))
- (setq props
- (mapcar
- (lambda (f)
- (setq prop (car f)
- stype (nth 3 f)
- sumfunc (nth 5 f)
- calc (or (nth 6 f) 'identity))
- (cond
- ((equal prop "ITEM")
- (cons prop (buffer-substring (point-at-bol)
- (point-at-eol))))
- ((not stype) (cons prop ""))
- (t ;; do the summary
- (setq lsum nil)
- (dolist (x entries)
- (setq v (cdr (assoc prop x)))
- (if v
- (push
- (funcall
- (if (not (get-text-property 0 'org-computed v))
- calc
- 'identity)
- (org-columns-string-to-number
- v stype))
- lsum)))
- (setq lsum (remove nil lsum))
- (setq lsum
- (cond ((> (length lsum) 1)
- (org-columns-number-to-string
- (apply sumfunc lsum) stype))
- ((eq (length lsum) 1)
- (org-columns-number-to-string
- (car lsum) stype))
- (t "")))
- (put-text-property 0 (length lsum) 'face 'bold lsum)
- (unless (eq calc 'identity)
- (put-text-property 0 (length lsum) 'org-computed t lsum))
- (cons prop lsum))))
- fmt))
- (org-columns-display-here props)
- (org-set-local 'org-agenda-columns-active t)))
- (if (bobp) (throw 'exit t))
- (beginning-of-line 0))))))
-
-(defun org-agenda-colview-compute (fmt)
- "Compute the relevant columns in the contributing source buffers."
- (let ((files org-agenda-contributing-files)
- (org-columns-begin-marker (make-marker))
- (org-columns-top-level-marker (make-marker))
- f fm a b)
- (while (setq f (pop files))
- (setq b (find-buffer-visiting f))
- (with-current-buffer (or (buffer-base-buffer b) b)
- (save-excursion
- (save-restriction
- (widen)
- (org-unmodified
- (remove-text-properties (point-min) (point-max)
- '(org-summaries t)))
- (goto-char (point-min))
- (org-columns-get-format-and-top-level)
- (while (setq fm (pop fmt))
- (if (equal (car fm) "CLOCKSUM")
- (org-clock-sum)
- (when (and (nth 4 fm)
- (setq a (assoc (car fm)
- org-columns-current-fmt-compiled))
- (equal (nth 4 a) (nth 4 fm)))
- (org-columns-compute (car fm)))))))))))
-
-(defun org-format-time-period (interval)
- "Convert time in fractional days to days/hours/minutes/seconds."
- (if (numberp interval)
- (let* ((days (floor interval))
- (frac-hours (* 24 (- interval days)))
- (hours (floor frac-hours))
- (minutes (floor (* 60 (- frac-hours hours))))
- (seconds (floor (* 60 (- (* 60 (- frac-hours hours)) minutes)))))
- (format "%dd %02dh %02dm %02ds" days hours minutes seconds))
- ""))
-
-(defun org-estimate-mean-and-var (v)
- "Return the mean and variance of an estimate."
- (let* ((low (float (car v)))
- (high (float (cadr v)))
- (mean (/ (+ low high) 2.0))
- (var (/ (+ (expt (- mean low) 2.0) (expt (- high mean) 2.0)) 2.0)))
- (list mean var)))
-
-(defun org-estimate-combine (&rest el)
- "Combine a list of estimates, using mean and variance.
-The mean and variance of the result will be the sum of the means
-and variances (respectively) of the individual estimates."
- (let ((mean 0)
- (var 0))
- (mapc (lambda (e)
- (let ((stats (org-estimate-mean-and-var e)))
- (setq mean (+ mean (car stats)))
- (setq var (+ var (cadr stats)))))
- el)
- (let ((stdev (sqrt var)))
- (list (- mean stdev) (+ mean stdev)))))
-
-(defun org-estimate-print (e &optional fmt)
- "Prepare a string representation of an estimate.
-This formats these numbers as two numbers with a \"-\" between them."
- (if (null fmt) (set 'fmt "%.0f"))
- (format "%s" (mapconcat (lambda (n) (format fmt n)) e "-")))
-
-(defun org-string-to-estimate (s)
- "Convert a string to an estimate.
-The string should be two numbers joined with a \"-\"."
- (if (string-match "\\(.*\\)-\\(.*\\)" s)
- (list (string-to-number (match-string 1 s))
- (string-to-number(match-string 2 s)))
- (list (string-to-number s) (string-to-number s))))
-
-(provide 'org-colview)
-(provide 'org-colview-xemacs)
-
-;;; org-colview-xemacs.el ends here
diff --git a/contrib/lisp/org-contacts.el b/contrib/lisp/org-contacts.el
index 0bc9cd7..2cadd1d 100644
--- a/contrib/lisp/org-contacts.el
+++ b/contrib/lisp/org-contacts.el
@@ -52,9 +52,7 @@
;;
;;; Code:
-(eval-when-compile
- (require 'cl))
-
+(require 'cl-lib)
(require 'org)
(require 'gnus-util)
(require 'gnus-art)
@@ -155,13 +153,20 @@ 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
- org-contacts-tel-property
- org-contacts-address-property
- org-contacts-birthday-property)
- "<>\"\"|")
+ (mapconcat #'identity
+ (mapcar (lambda (x) (concat x "<>\"\""))
+ (list org-contacts-email-property
+ org-contacts-alias-property
+ org-contacts-tel-property
+ org-contacts-address-property
+ org-contacts-birthday-property))
+ "|")
"Matching rule for finding heading that are contacts.
This can be a tag name, or a property check."
:type 'string
@@ -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")
@@ -221,7 +232,7 @@ A regexp matching strings of whitespace, `,' and `;'.")
(defun org-contacts-db-need-update-p ()
"Determine whether `org-contacts-db' needs to be refreshed."
(or (null org-contacts-last-update)
- (org-find-if (lambda (file)
+ (cl-find-if (lambda (file)
(or (time-less-p org-contacts-last-update
(elt (file-attributes file) 5))))
(org-contacts-files))
@@ -241,33 +252,57 @@ to dead or no buffer."
(defun org-contacts-db ()
"Return the latest Org Contacts Database."
- (let* (todo-only
- (contacts-matcher
- (cdr (org-make-tags-matcher org-contacts-matcher)))
- markers result)
+ (let* ((org--matcher-tags-todo-only nil)
+ (contacts-matcher (cdr (org-make-tags-matcher org-contacts-matcher)))
+ result)
(when (org-contacts-db-need-update-p)
(let ((progress-reporter
(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
+ org--matcher-tags-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.
@@ -279,22 +314,22 @@ cell corresponding to the contact properties.
(null prop-match)
(null tags-match))
(org-contacts-db)
- (loop for contact in (org-contacts-db)
- if (or
- (and name-match
- (org-string-match-p name-match
- (first contact)))
- (and prop-match
- (org-find-if (lambda (prop)
- (and (string= (car prop-match) (car prop))
- (org-string-match-p (cdr prop-match) (cdr prop))))
- (caddr contact)))
- (and tags-match
- (org-find-if (lambda (tag)
- (org-string-match-p tags-match tag))
- (org-split-string
- (or (cdr (assoc-string "ALLTAGS" (caddr contact))) "") ":"))))
- collect contact)))
+ (cl-loop for contact in (org-contacts-db)
+ if (or
+ (and name-match
+ (string-match-p name-match
+ (first contact)))
+ (and prop-match
+ (cl-find-if (lambda (prop)
+ (and (string= (car prop-match) (car prop))
+ (string-match-p (cdr prop-match) (cdr prop))))
+ (caddr contact)))
+ (and tags-match
+ (cl-find-if (lambda (tag)
+ (string-match-p tags-match tag))
+ (org-split-string
+ (or (cdr (assoc-string "ALLTAGS" (caddr contact))) "") ":"))))
+ collect contact)))
(when (not (fboundp 'completion-table-case-fold))
;; That function is new in Emacs 24...
@@ -307,34 +342,34 @@ cell corresponding to the contact properties.
"Custom implementation of `try-completion'.
This version works only with list and alist and it looks at all
prefixes rather than just the beginning of the string."
- (loop with regexp = (concat "\\b" (regexp-quote to-match))
- with ret = nil
- with ret-start = nil
- with ret-end = nil
-
- for el in collection
- for string = (if (listp el) (car el) el)
-
- for start = (when (or (null predicate) (funcall predicate string))
- (string-match regexp string))
-
- if start
- do (let ((end (match-end 0))
- (len (length string)))
- (if (= end len)
- (return t)
- (destructuring-bind (string start end)
- (if (null ret)
- (values string start end)
- (org-contacts-common-substring
- ret ret-start ret-end
- string start end))
- (setf ret string
- ret-start start
- ret-end end))))
-
- finally (return
- (replace-regexp-in-string "\\`[ \t\n]*" "" ret))))
+ (cl-loop with regexp = (concat "\\b" (regexp-quote to-match))
+ with ret = nil
+ with ret-start = nil
+ with ret-end = nil
+
+ for el in collection
+ for string = (if (listp el) (car el) el)
+
+ for start = (when (or (null predicate) (funcall predicate string))
+ (string-match regexp string))
+
+ if start
+ do (let ((end (match-end 0))
+ (len (length string)))
+ (if (= end len)
+ (cl-return t)
+ (cl-destructuring-bind (string start end)
+ (if (null ret)
+ (values string start end)
+ (org-contacts-common-substring
+ ret ret-start ret-end
+ string start end))
+ (setf ret string
+ ret-start start
+ ret-end end))))
+
+ finally (cl-return
+ (replace-regexp-in-string "\\`[ \t\n]*" "" ret))))
(defun org-contacts-compare-strings (s1 start1 end1 s2 start2 end2 &optional ignore-case)
"Compare the contents of two strings, using `compare-strings'.
@@ -393,22 +428,22 @@ This function returns a list whose contains:
"Custom version of `all-completions'.
This version works only with list and alist and it looks at all
prefixes rather than just the beginning of the string."
- (loop with regexp = (concat "\\b" (regexp-quote to-match))
- for el in collection
- for string = (if (listp el) (car el) el)
- for match? = (when (and (or (null predicate) (funcall predicate string)))
- (string-match regexp string))
- if match?
- collect (progn
- (let ((end (match-end 0)))
- (org-no-properties string)
- (when (< end (length string))
- ;; Here we add a text property that will be used
- ;; later to highlight the character right after
- ;; the common part between each addresses.
- ;; See `org-contacts-display-sort-function'.
- (put-text-property end (1+ end) 'org-contacts-prefix 't string)))
- string)))
+ (cl-loop with regexp = (concat "\\b" (regexp-quote to-match))
+ for el in collection
+ for string = (if (listp el) (car el) el)
+ for match? = (when (and (or (null predicate) (funcall predicate string)))
+ (string-match regexp string))
+ if match?
+ collect (progn
+ (let ((end (match-end 0)))
+ (org-no-properties string)
+ (when (< end (length string))
+ ;; Here we add a text property that will be used
+ ;; later to highlight the character right after
+ ;; the common part between each addresses.
+ ;; See `org-contacts-display-sort-function'.
+ (put-text-property end (1+ end) 'org-contacts-prefix 't string)))
+ string)))
(defun org-contacts-make-collection-prefix (collection)
"Make a collection function from COLLECTION which will match on prefixes."
@@ -423,7 +458,7 @@ prefixes rather than just the beginning of the string."
((eq flag 'lambda)
(org-contacts-test-completion-prefix string collection predicate))
((and (listp flag) (eq (car flag) 'boundaries))
- (destructuring-bind (to-ignore &rest suffix)
+ (cl-destructuring-bind (to-ignore &rest suffix)
flag
(org-contacts-boundaries-prefix string collection predicate suffix)))
((eq flag 'metadata)
@@ -434,31 +469,28 @@ prefixes rather than just the beginning of the string."
(defun org-contacts-display-sort-function (completions)
"Sort function for contacts display."
(mapcar (lambda (string)
- (loop with len = (1- (length string))
- for i upfrom 0 to len
- if (memq 'org-contacts-prefix
- (text-properties-at i string))
- do (set-text-properties
- i (1+ i)
- (list 'font-lock-face
- (if (char-equal (aref string i)
- (string-to-char " "))
- ;; Spaces can't be bold.
- 'underline
- 'bold)) string)
- else
- do (set-text-properties i (1+ i) nil string)
- finally (return string)))
+ (cl-loop with len = (1- (length string))
+ for i upfrom 0 to len
+ if (memq 'org-contacts-prefix
+ (text-properties-at i string))
+ do (set-text-properties
+ i (1+ i)
+ (list 'font-lock-face
+ (if (char-equal (aref string i)
+ (string-to-char " "))
+ ;; Spaces can't be bold.
+ 'underline
+ 'bold)) string)
+ else
+ do (set-text-properties i (1+ i) nil string)
+ finally (cl-return string)))
completions))
(defun org-contacts-test-completion-prefix (string collection predicate)
- ;; Prevents `org-find-if' from redefining `predicate' and going into
- ;; an infinite loop.
- (lexical-let ((predicate predicate))
- (org-find-if (lambda (el)
- (and (or (null predicate) (funcall predicate el))
- (string= string el)))
- collection)))
+ (cl-find-if (lambda (el)
+ (and (or (null predicate) (funcall predicate el))
+ (string= string el)))
+ collection))
(defun org-contacts-boundaries-prefix (string collection predicate suffix)
(list* 'boundaries (completion-boundaries string collection predicate suffix)))
@@ -473,7 +505,7 @@ prefixes rather than just the beginning of the string."
A group FOO is composed of contacts with the tag FOO."
(let* ((completion-ignore-case org-contacts-completion-ignore-case)
- (group-completion-p (org-string-match-p
+ (group-completion-p (string-match-p
(concat "^" org-contacts-group-prefix) string)))
(when group-completion-p
(let ((completion-list
@@ -483,9 +515,9 @@ A group FOO is composed of contacts with the tag FOO."
(propertize (concat org-contacts-group-prefix group)
'org-contacts-group group))
(org-uniquify
- (loop for contact in (org-contacts-filter)
- nconc (org-split-string
- (or (cdr (assoc-string "ALLTAGS" (caddr contact))) "") ":")))))))
+ (cl-loop for contact in (org-contacts-filter)
+ nconc (org-split-string
+ (or (cdr (assoc-string "ALLTAGS" (caddr contact))) "") ":")))))))
(list start end
(if (= (length completion-list) 1)
;; We've found the correct group, returns the address
@@ -493,60 +525,100 @@ A group FOO is composed of contacts with the tag FOO."
(car completion-list))))
(lambda (string pred &optional to-ignore)
(mapconcat 'identity
- (loop for contact in (org-contacts-filter
- nil
- tag)
- ;; The contact name is always the car of the assoc-list
- ;; returned by `org-contacts-filter'.
- for contact-name = (car contact)
- ;; Grab the first email of the contact
- for email = (org-contacts-strip-link (car (org-contacts-split-property
- (or
- (cdr (assoc-string org-contacts-email-property
- (caddr contact)))
- ""))))
- ;; If the user has an email address, append USER <EMAIL>.
- if email collect (org-contacts-format-email contact-name email))
+ (cl-loop for contact in (org-contacts-filter
+ nil
+ tag)
+ ;; The contact name is always the car of the assoc-list
+ ;; returned by `org-contacts-filter'.
+ for contact-name = (car contact)
+ ;; Grab the first email of the contact
+ for email = (org-contacts-strip-link
+ (or (car (org-contacts-split-property
+ (or
+ (cdr (assoc-string org-contacts-email-property
+ (cl-caddr contact)))
+ ""))) ""))
+ ;; If the user has an email address, append USER <EMAIL>.
+ if email collect (org-contacts-format-email contact-name email))
", ")))
;; We haven't found the correct group
(completion-table-case-fold completion-list
(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 (string-match-p
+ (concat "^" org-contacts-tags-props-prefix) string)))
+ (when completion-p
+ (let ((result
+ (mapconcat
+ 'identity
+ (cl-loop for contact in (org-contacts-db)
+ for contact-name = (car contact)
+ for email = (org-contacts-strip-link (or (car (org-contacts-split-property
+ (or
+ (cdr (assoc-string org-contacts-email-property
+ (cl-caddr contact)))
+ ""))) ""))
+ for tags = (cdr (assoc "TAGS" (nth 2 contact)))
+ for tags-list = (if tags
+ (split-string (substring (cdr (assoc "TAGS" (nth 2 contact))) 1 -1) ":")
+ '())
+ for marker = (nth 1 contact)
+ if (with-current-buffer (marker-buffer marker)
+ (save-excursion
+ (goto-char marker)
+ (let (todo-only)
+ (eval (cdr (org-make-tags-matcher (cl-subseq string 1)))))))
+ collect (org-contacts-format-email contact-name email))
+ ",")))
+ (when (not (string= "" result))
+ ;; return (start end function)
+ (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
regular expressions in the ignore list."
- (org-remove-if (lambda (el)
- (org-find-if (lambda (x)
- (string-match-p x el))
- ignore-list))
- list))
+ (cl-remove-if (lambda (el)
+ (cl-find-if (lambda (x)
+ (string-match-p x el))
+ ignore-list))
+ list))
(defun org-contacts-complete-name (start end string)
"Complete text at START with a user name and email."
(let* ((completion-ignore-case org-contacts-completion-ignore-case)
(completion-list
- (loop for contact in (org-contacts-filter)
- ;; The contact name is always the car of the assoc-list
- ;; returned by `org-contacts-filter'.
- for contact-name = (car contact)
-
- ;; Build the list of the email addresses which has
- ;; been expired
- for ignore-list = (org-contacts-split-property
- (or (cdr (assoc-string org-contacts-ignore-property
- (caddr contact))) ""))
- ;; Build the list of the user email addresses.
- for email-list = (org-contacts-remove-ignored-property-values
- ignore-list
- (org-contacts-split-property
- (or (cdr (assoc-string org-contacts-email-property
- (caddr contact))) "")))
- ;; If the user has email addresses…
- if email-list
- ;; … append a list of USER <EMAIL>.
- nconc (loop for email in email-list
- collect (org-contacts-format-email contact-name (org-contacts-strip-link email)))))
+ (cl-loop for contact in (org-contacts-filter)
+ ;; The contact name is always the car of the assoc-list
+ ;; returned by `org-contacts-filter'.
+ for contact-name = (car contact)
+
+ ;; Build the list of the email addresses which has
+ ;; been expired
+ for ignore-list = (org-contacts-split-property
+ (or (cdr (assoc-string org-contacts-ignore-property
+ (nth 2 contact))) ""))
+ ;; Build the list of the user email addresses.
+ for email-list = (org-contacts-remove-ignored-property-values
+ ignore-list
+ (org-contacts-split-property
+ (or (cdr (assoc-string org-contacts-email-property
+ (nth 2 contact))) "")))
+ ;; If the user has email addresses…
+ if email-list
+ ;; … append a list of USER <EMAIL>.
+ nconc (cl-loop for email in email-list
+ collect (org-contacts-format-email contact-name (org-contacts-strip-link email)))))
(completion-list (org-contacts-all-completions-prefix
string
(org-uniquify completion-list))))
@@ -570,8 +642,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."
@@ -585,13 +657,13 @@ A group FOO is composed of contacts with the tag FOO."
(let* ((address (org-contacts-gnus-get-name-email))
(name (car address))
(email (cadr address)))
- (cadar (or (org-contacts-filter
- nil
- nil
- (cons org-contacts-email-property (concat "\\b" (regexp-quote email) "\\b")))
- (when name
- (org-contacts-filter
- (concat "^" name "$")))))))
+ (cl-cadar (or (org-contacts-filter
+ nil
+ nil
+ (cons org-contacts-email-property (concat "\\b" (regexp-quote email) "\\b")))
+ (when name
+ (org-contacts-filter
+ (concat "^" name "$")))))))
(defun org-contacts-gnus-article-from-goto ()
"Go to contact in the From address of current Gnus message."
@@ -600,14 +672,9 @@ A group FOO is composed of contacts with the tag FOO."
(when marker
(switch-to-buffer-other-window (marker-buffer marker))
(goto-char marker)
- (when (eq major-mode 'org-mode)
- (org-show-context 'agenda)
- (save-excursion
- (and (outline-next-heading)
- ;; show the next heading
- (org-flag-heading nil)))))))
+ (when (eq major-mode 'org-mode) (org-show-context 'agenda)))))
-(org-no-warnings (defvar date)) ;; unprefixed, from calendar.el
+(with-no-warnings (defvar date)) ;; unprefixed, from calendar.el
(defun org-contacts-anniversaries (&optional field format)
"Compute FIELD anniversary for each contact, returning FORMAT.
Default FIELD value is \"BIRTHDAY\".
@@ -621,23 +688,23 @@ Format is a string matching the following format specification:
(let ((calendar-date-style 'american)
(entry ""))
(unless format (setq format org-contacts-birthday-format))
- (loop for contact in (org-contacts-filter)
- for anniv = (let ((anniv (cdr (assoc-string
- (or field org-contacts-birthday-property)
- (caddr contact)))))
- (when anniv
- (calendar-gregorian-from-absolute
- (org-time-string-to-absolute anniv))))
- ;; Use `diary-anniversary' to compute anniversary.
- if (and anniv (apply 'diary-anniversary anniv))
- collect (format-spec format
- `((?l . ,(org-with-point-at (cadr contact) (org-store-link nil)))
- (?h . ,(car contact))
- (?y . ,(- (calendar-extract-year date)
- (calendar-extract-year anniv)))
- (?Y . ,(let ((years (- (calendar-extract-year date)
- (calendar-extract-year anniv))))
- (format "%d%s" years (diary-ordinal-suffix years)))))))))
+ (cl-loop for contact in (org-contacts-filter)
+ for anniv = (let ((anniv (cdr (assoc-string
+ (or field org-contacts-birthday-property)
+ (nth 2 contact)))))
+ (when anniv
+ (calendar-gregorian-from-absolute
+ (org-time-string-to-absolute anniv))))
+ ;; Use `diary-anniversary' to compute anniversary.
+ if (and anniv (apply 'diary-anniversary anniv))
+ collect (format-spec format
+ `((?l . ,(org-with-point-at (cadr contact) (org-store-link nil)))
+ (?h . ,(car contact))
+ (?y . ,(- (calendar-extract-year date)
+ (calendar-extract-year anniv)))
+ (?Y . ,(let ((years (- (calendar-extract-year date)
+ (calendar-extract-year anniv))))
+ (format "%d%s" years (diary-ordinal-suffix years)))))))))
(defun org-completing-read-date (prompt collection
&optional predicate require-match initial-input
@@ -826,7 +893,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)
@@ -918,7 +985,7 @@ to do our best."
(defun org-contacts-vcard-format (contact)
"Formats CONTACT in VCard 3.0 format."
- (let* ((properties (caddr contact))
+ (let* ((properties (nth 2 contact))
(name (org-contacts-vcard-escape (car contact)))
(n (org-contacts-vcard-encode-name name))
(email (cdr (assoc-string org-contacts-email-property properties)))
@@ -946,7 +1013,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 +1027,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: "
+ (nth 0 (org-contacts-at-point))))
+ file
+ (when (equal name '(16))
+ (read-file-name "File: " nil org-contacts-vcard-file))
+ to-buffer
+ (when (equal name '(64))
+ (read-buffer "Buffer: "))))
+ (org-contacts-export-as-vcard-internal name file to-buffer))
+
+(defun org-contacts-export-as-vcard-internal (&optional name file to-buffer)
"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)
@@ -989,9 +1084,9 @@ Requires google-maps-el."
(error "`org-contacts-show-map' requires `google-maps-el'"))
(google-maps-static-show
:markers
- (loop
+ (cl-loop
for contact in (org-contacts-filter name)
- for addr = (cdr (assoc-string org-contacts-address-property (caddr contact)))
+ for addr = (cdr (assoc-string org-contacts-address-property (nth 2 contact)))
if addr
collect (cons (list addr) (list :label (string-to-char (car contact)))))))
@@ -1010,6 +1105,10 @@ link string and return the pure link target."
(setq colonpos (string-match ":" link))
(if startpos (substring link (1+ colonpos)) link)))))
+;; Add the link type supported by org-contacts-strip-link
+;; so everything is in order for its use in Org files
+(org-link-set-parameters "tel")
+
(defun org-contacts-split-property (string &optional separators omit-nulls)
"Custom version of `split-string'.
Split a property STRING into sub-strings bounded by matches
diff --git a/contrib/lisp/org-contribdir.el b/contrib/lisp/org-contribdir.el
index d94e7a0..d0bd951 100644
--- a/contrib/lisp/org-contribdir.el
+++ b/contrib/lisp/org-contribdir.el
@@ -1,5 +1,5 @@
;;; org-contribdir.el --- Mark the location of the contrib directory
-;; Copyright (C) 2009-2014 Free Software Foundation, Inc.
+;; Copyright (C) 2009-2016 Free Software Foundation, Inc.
;;
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
diff --git a/contrib/lisp/org-depend.el b/contrib/lisp/org-depend.el
index 1cd4130..5e49b6c 100644
--- a/contrib/lisp/org-depend.el
+++ b/contrib/lisp/org-depend.el
@@ -1,5 +1,5 @@
;;; org-depend.el --- TODO dependencies for Org-mode
-;; Copyright (C) 2008-2014 Free Software Foundation, Inc.
+;; Copyright (C) 2008-2016 Free Software Foundation, Inc.
;;
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
diff --git a/contrib/lisp/org-download.el b/contrib/lisp/org-download.el
new file mode 100644
index 0000000..cbf335b
--- a/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-2016 Free Software Foundation, Inc.
+
+;; Author: Oleh Krehel
+;; Keywords: images, screenshots, download
+;; Homepage: http://orgmode.org
+
+;; This file is not part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; This extension facilitates moving images from point A to point B.
+;;
+;; Point A (the source) can be:
+;; 1. An image inside your browser that you can drag to Emacs.
+;; 2. An image on your file system that you can drag to Emacs.
+;; 3. A local or remote image address in kill-ring.
+;; Use the `org-download-yank' command for this.
+;; Remember that you can use "0 w" in `dired' to get an address.
+;; 4. An screenshot taken using `gnome-screenshot' or `scrot' or `gm'.
+;; Use the `org-download-screenshot' command for this.
+;; Customize the backend with `org-download-screenshot-method'.
+;;
+;; Point B (the target) is an Emacs `org-mode' buffer where the inline
+;; link will be inserted. Several customization options will determine
+;; where exactly on the file system the file will be stored.
+;;
+;; They are:
+;; `org-download-method':
+;; a. 'attach => use `org-mode' attachment machinery
+;; b. 'directory => construct the directory in two stages:
+;; 1. first part of the folder name is:
+;; * either "." (current folder)
+;; * or `org-download-image-dir' (if it's not nil).
+;; `org-download-image-dir' becomes buffer-local when set,
+;; so each file can customize this value, e.g with:
+;; # -*- mode: Org; org-download-image-dir: "~/Pictures/foo"; -*-
+;; 2. second part is:
+;; * `org-download-heading-lvl' is nil => ""
+;; * `org-download-heading-lvl' is n => the name of current
+;; heading with level n. Level count starts with 0,
+;; i.e. * is 0, ** is 1, *** is 2 etc.
+;; `org-download-heading-lvl' becomes buffer-local when set,
+;; so each file can customize this value, e.g with:
+;; # -*- mode: Org; org-download-heading-lvl: nil; -*-
+;;
+;; `org-download-timestamp':
+;; optionally add a timestamp to the file name.
+;;
+;; Customize `org-download-backend' to choose between `url-retrieve'
+;; (the default) or `wget' or `curl'.
+;;
+;;; Code:
+
+
+(eval-when-compile
+ (require 'cl))
+(require 'url-parse)
+(require 'url-http)
+
+(defgroup org-download nil
+ "Image drag-and-drop for org-mode."
+ :group 'org
+ :prefix "org-download-")
+
+(defcustom org-download-method 'directory
+ "The way images should be stored."
+ :type '(choice
+ (const :tag "Directory" directory)
+ (const :tag "Attachment" attach))
+ :group 'org-download)
+
+(defcustom org-download-image-dir nil
+ "If set, images will be stored in this directory instead of \".\".
+See `org-download--dir-1' for more info."
+ :type '(choice
+ (const :tag "Default" nil)
+ (string :tag "Directory"))
+ :group 'org-download)
+(make-variable-buffer-local 'org-download-image-dir)
+
+(defcustom org-download-heading-lvl 0
+ "Heading level to be used in `org-download--dir-2'."
+ :group 'org-download)
+(make-variable-buffer-local 'org-download-heading-lvl)
+
+(defcustom org-download-backend t
+ "Method to use for downloading."
+ :type '(choice
+ (const :tag "wget" "wget \"%s\" -O \"%s\"")
+ (const :tag "curl" "curl \"%s\" -o \"%s\"")
+ (const :tag "url-retrieve" t))
+ :group 'org-download)
+
+(defcustom org-download-timestamp "_%Y-%m-%d_%H:%M:%S"
+ "This `format-time-string'-style string will be appended to the file name.
+Set this to \"\" if you don't want time stamps."
+ :type 'string
+ :group 'org-download)
+
+(defcustom org-download-img-regex-list
+ '("<img +src=\"" "<img +\\(class=\"[^\"]+\"\\)? *src=\"")
+ "This regex is used to unalias links that look like images.
+The html to which the links points will be searched for these
+regexes, one by one, until one succeeds. The found image address
+will be used."
+ :group 'org-download)
+
+(defcustom org-download-screenshot-method "gnome-screenshot -a -f %s"
+ "The tool to capture screenshots."
+ :type '(choice
+ (const :tag "gnome-screenshot" "gnome-screenshot -a -f %s")
+ (const :tag "scrot" "scrot -s %s")
+ (const :tag "gm" "gm import %s"))
+ :group 'org-download)
+
+(defcustom org-download-image-width 0
+ "When non-zero add #+attr_html: :width tag to the image."
+ :type 'integer
+ :group 'org-download)
+
+(defun org-download-get-heading (lvl)
+ "Return the heading of the current entry's LVL level parent."
+ (save-excursion
+ (let ((cur-lvl (org-current-level)))
+ (if cur-lvl
+ (progn
+ (unless (= cur-lvl 1)
+ (org-up-heading-all (- (1- (org-current-level)) lvl)))
+ (substring-no-properties
+ (org-get-heading)))
+ ""))))
+
+(defun org-download--dir-1 ()
+ "Return the first part of the directory path for `org-download--dir'.
+It's `org-download-image-dir', unless it's nil. Then it's \".\"."
+ (or org-download-image-dir "."))
+
+(defun org-download--dir-2 ()
+ "Return the second part of the directory path for `org-download--dir'.
+Unless `org-download-heading-lvl' is nil, it's the name of the current
+`org-download-heading-lvl'-leveled heading. Otherwise it's \"\"."
+ (and org-download-heading-lvl
+ (org-download-get-heading
+ org-download-heading-lvl)))
+
+(defun org-download--dir ()
+ "Return the directory path for image storage.
+
+The path is composed from `org-download--dir-1' and `org-download--dir-2'.
+The directory is created if it didn't exist before."
+ (let* ((part1 (org-download--dir-1))
+ (part2 (org-download--dir-2))
+ (dir (if part2
+ (format "%s/%s" part1 part2)
+ part1)))
+ (unless (file-exists-p dir)
+ (make-directory dir t))
+ dir))
+
+(defun org-download--fullname (link)
+ "Return the file name where LINK will be saved to.
+
+It's affected by `org-download-timestamp' and `org-download--dir'."
+ (let ((filename
+ (file-name-nondirectory
+ (car (url-path-and-query
+ (url-generic-parse-url link)))))
+ (dir (org-download--dir)))
+ (when (string-match ".*?\\.\\(?:png\\|jpg\\)\\(.*\\)$" filename)
+ (setq filename (replace-match "" nil nil filename 1)))
+ (abbreviate-file-name
+ (expand-file-name
+ (format "%s%s.%s"
+ (file-name-sans-extension filename)
+ (format-time-string org-download-timestamp)
+ (file-name-extension filename))
+ dir))))
+
+(defun org-download--image (link filename)
+ "Save LINK to FILENAME asynchronously and show inline images in current buffer."
+ (when (string-match "^file://\\(.*\\)" link)
+ (setq link (url-unhex-string (match-string 1 link))))
+ (cond ((and (not (file-remote-p link))
+ (file-exists-p link))
+ (org-download--image/command "cp \"%s\" \"%s\"" link filename))
+ ((eq org-download-backend t)
+ (org-download--image/url-retrieve link filename))
+ (t
+ (org-download--image/command org-download-backend link filename))))
+
+(defun org-download--image/command (command link filename)
+ "Using COMMAND, save LINK to FILENAME.
+COMMAND is a format-style string with two slots for LINK and FILENAME."
+ (require 'async)
+ (async-start
+ `(lambda() (shell-command
+ ,(format command link
+ (expand-file-name filename))))
+ (lexical-let ((cur-buf (current-buffer)))
+ (lambda(x)
+ (with-current-buffer cur-buf
+ (org-display-inline-images))))))
+
+(defun org-download--image/url-retrieve (link filename)
+ "Save LINK to FILENAME using `url-retrieve'."
+ (url-retrieve
+ link
+ (lambda (status filename buffer)
+ ;; Write current buffer to FILENAME
+ ;; and update inline images in BUFFER
+ (let ((err (plist-get status :error)))
+ (if err (error
+ "\"%s\" %s" link
+ (downcase (nth 2 (assq (nth 2 err) url-http-codes))))))
+ (delete-region
+ (point-min)
+ (progn
+ (re-search-forward "\n\n" nil 'move)
+ (point)))
+ (let ((coding-system-for-write 'no-conversion))
+ (write-region nil nil filename nil nil nil 'confirm))
+ (with-current-buffer buffer
+ (org-display-inline-images)))
+ (list
+ (expand-file-name filename)
+ (current-buffer))
+ nil t))
+
+(defun org-download-yank ()
+ "Call `org-download-image' with current kill."
+ (interactive)
+ (org-download-image (current-kill 0)))
+
+(defun org-download-screenshot ()
+ "Capture screenshot and insert the resulting file.
+The screenshot tool is determined by `org-download-screenshot-method'."
+ (interactive)
+ (let ((link "/tmp/screenshot.png"))
+ (shell-command (format org-download-screenshot-method link))
+ (org-download-image link)))
+
+(defun org-download-image (link)
+ "Save image at address LINK to `org-download--dir'."
+ (interactive "sUrl: ")
+ (unless (image-type-from-file-name link)
+ (with-current-buffer
+ (url-retrieve-synchronously link t)
+ (let ((regexes org-download-img-regex-list)
+ lnk)
+ (while (and (not lnk) regexes)
+ (goto-char (point-min))
+ (when (re-search-forward (pop regexes) nil t)
+ (backward-char)
+ (setq lnk (read (current-buffer)))))
+ (if lnk
+ (setq link lnk)
+ (error "link %s does not point to an image; unaliasing failed" link)))))
+ (let ((filename
+ (if (eq org-download-method 'attach)
+ (let ((org-download-image-dir (progn (require 'org-attach)
+ (org-attach-dir t)))
+ org-download-heading-lvl)
+ (org-download--fullname link))
+ (org-download--fullname link))))
+ (when (image-type-from-file-name filename)
+ (org-download--image link filename)
+ (when (eq org-download-method 'attach)
+ (org-attach-attach filename nil 'none))
+ (if (looking-back "^[ \t]+")
+ (delete-region (match-beginning 0) (match-end 0))
+ (newline))
+ (insert
+ (format "#+DOWNLOADED: %s @ %s\n%s [[%s]]"
+ link
+ (format-time-string "%Y-%m-%d %H:%M:%S")
+ (if (= org-download-image-width 0)
+ ""
+ (format
+ "#+attr_html: :width %dpx\n" org-download-image-width))
+ filename))
+ (org-display-inline-images))))
+
+(defun org-download--at-comment-p ()
+ "Check if current line begins with #+DOWLOADED:."
+ (save-excursion
+ (move-beginning-of-line nil)
+ (looking-at "#\\+DOWNLOADED:")))
+
+(defun org-download-delete ()
+ "Delete inline image link on current line, and the file that it points to."
+ (interactive)
+ (cond ((org-download--at-comment-p)
+ (delete-region (line-beginning-position)
+ (line-end-position))
+ (org-download--delete (line-beginning-position)
+ nil
+ 1))
+ ((region-active-p)
+ (org-download--delete (region-beginning)
+ (region-end))
+ (delete-region (region-beginning)
+ (region-end)))
+
+ (t (org-download--delete (line-beginning-position)
+ (line-end-position)))))
+
+(defun org-download--delete (beg end &optional times)
+ "Delete inline image links and the files they point to between BEG and END.
+
+When TIMES isn't nil, delete only TIMES links."
+ (unless times
+ (setq times most-positive-fixnum))
+ (save-excursion
+ (goto-char beg)
+ (while (and (>= (decf times) 0)
+ (re-search-forward "\\[\\[\\([^]]*\\)\\]\\]" end t))
+ (let ((str (match-string-no-properties 1)))
+ (delete-region beg
+ (match-end 0))
+ (when (file-exists-p str)
+ (delete-file str))))))
+
+(defun org-download-dnd (uri action)
+ "When in `org-mode' and URI points to image, download it.
+Otherwise, pass URI and ACTION back to dnd dispatch."
+ (cond ((eq major-mode 'org-mode)
+ ;; probably shouldn't redirect
+ (unless (org-download-image uri)
+ (message "not an image URL")))
+ ((eq major-mode 'dired-mode)
+ (org-download-dired uri))
+ ;; redirect to someone else
+ (t
+ (let ((dnd-protocol-alist
+ (rassq-delete-all
+ 'org-download-dnd
+ (copy-alist dnd-protocol-alist))))
+ (dnd-handle-one-url nil action uri)))))
+
+(defun org-download-dired (uri)
+ "Download URI to current directory."
+ (raise-frame)
+ (let ((filename (file-name-nondirectory
+ (car (url-path-and-query
+ (url-generic-parse-url uri))))))
+ (message "Downloading %s to %s ..."
+ filename
+ (expand-file-name filename))
+ (url-retrieve
+ uri
+ (lambda (status filename)
+ (let ((err (plist-get status :error)))
+ (if err (error
+ "\"%s\" %s" uri
+ (downcase (nth 2 (assq (nth 2 err) url-http-codes))))))
+ (let ((coding-system-for-write 'no-conversion))
+ (write-region nil nil filename nil nil nil 'confirm)))
+ (list
+ (expand-file-name filename))
+ t t)))
+
+(defun org-download-enable ()
+ "Enable org-download."
+ (unless (eq (cdr (assoc "^\\(https?\\|ftp\\|file\\|nfs\\)://" dnd-protocol-alist))
+ 'org-download-dnd)
+ (setq dnd-protocol-alist
+ `(("^\\(https?\\|ftp\\|file\\|nfs\\)://" . org-download-dnd) ,@dnd-protocol-alist))))
+
+(defun org-download-disable ()
+ "Disable org-download."
+ (rassq-delete-all 'org-download-dnd dnd-protocol-alist))
+
+(org-download-enable)
+
+(provide 'org-download)
+
+;;; org-download.el ends here
diff --git a/contrib/lisp/org-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..4ed5e50
--- a/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-link-set-parameters "ebib"
+ :follow #'org-ebib-open
+ :store #'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..a653802
--- a/dev/null
+++ b/contrib/lisp/org-effectiveness.el
@@ -0,0 +1,370 @@
+;;; org-effectiveness.el --- Measuring the personal effectiveness
+
+;; Copyright (C) 2013-2016 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)
+ (save-excursion
+ (goto-char (point-min))
+ (if (< org-effectiveness-max-todo (count-matches "* TODO"))
+ (message "An excess of TODOS!"))))
+
+;; Check advice starting an org file
+(add-hook 'org-mode-hook 'org-effectiveness-advice)
+
+(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-count-task()
+ "Print a message with the number of tasks and subtasks in the current buffer"
+ (interactive)
+ (save-excursion
+ (goto-char (point-min))
+ (message "Number of tasks: %d" (count-matches "^*"))))
+
+(defun org-effectiveness()
+ "Returns the effectiveness in the current org buffer"
+ (interactive)
+ (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 &optional notmessage)
+ (interactive "sGive me a date: " date)
+ (save-excursion
+ (goto-char (point-min))
+ (let ((count (count-matches (concat "DONE.*\n.*" date))))
+ (if (eq notmessage 1)
+ (message "%d" count)
+ (message "DONES: %d " count)))))
+
+(defun org-effectiveness-todos-in-date(date)
+ (interactive "sGive me a date: " date)
+ (save-excursion
+ (goto-char (point-min))
+ (setq count (count-matches (concat "TODO.*\n.*" date)))
+ (message "TODOS: %d" count)))
+
+(defun org-effectiveness-canceled-in-date(date)
+ (interactive "sGive me a date: " date)
+ (save-excursion
+ (goto-char (point-min))
+ (setq count (count-matches (concat "CANCEL+ED.*\n.*" date)))
+ (message "CANCELEDS: %d" count)))
+
+(defun org-effectiveness-ntasks-in-date(date &optional notmessage)
+ (interactive "sGive me a date: " date)
+ (save-excursion
+ (goto-char (point-min))
+ (let ((tasks (float (count-matches (concat "^*.*\n.*" date)))))
+ (message "%d" tasks))))
+
+(defun org-effectiveness-in-date(date &optional notmessage)
+ (interactive "sGive me a date: " date)
+ (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-ascii-ntasks (startdate enddate)
+ (interactive "sGive me the start date: \nsGive me the end date: " startdate enddate)
+ (setq dates (org-effectiveness-check-dates startdate enddate))
+ (let ((syear (cadr (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-ntasks-in-date (concat (number-to-string year) "-" (org-effectiveness-month-to-string month)) 1))
+ (switch-to-buffer "*org-effectiveness*")
+ (org-effectiveness-ascii-bar (string-to-number str) (format "%s-%s" year month))
+ (switch-to-buffer buffer)
+ (if (eq month 12)
+ (progn
+ (setq year (+ 1 year))
+ (setq month 1))
+ (setq month (+ 1 month)))))
+ (switch-to-buffer "*org-effectiveness*"))
+
+(defun org-effectiveness-plot-ascii-dones (startdate enddate)
+ (interactive "sGive me the start date: \nsGive me the end date: " startdate enddate)
+ (setq dates (org-effectiveness-check-dates startdate enddate))
+ (let ((syear (cadr (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-dones-in-date (concat (number-to-string year) "-" (org-effectiveness-month-to-string month)) 1))
+ (switch-to-buffer "*org-effectiveness*")
+ (org-effectiveness-ascii-bar (string-to-number str) (format "%s-%s" year month))
+ (switch-to-buffer buffer)
+ (if (eq month 12)
+ (progn
+ (setq year (+ 1 year))
+ (setq month 1))
+ (setq month (+ 1 month)))))
+ (switch-to-buffer "*org-effectiveness*"))
+
+
+(defun org-effectiveness-plot-html (startdate enddate)
+ "Print html bars about the effectiveness in a buffer"
+ (interactive "sGive me the start date: \nsGive me the end date: " startdate enddate)
+ (setq dates (org-effectiveness-check-dates startdate enddate))
+ (let ((syear (cadr (assoc 'startyear dates)))
+ (smonth (cadr (assoc 'startmonth dates)))
+ (year (cadr (assoc 'startyear dates)))
+ (month (cadr (assoc 'startmonth dates)))
+ (emonth (cadr (assoc 'endmonth dates)))
+ (eyear (cadr (assoc 'endyear dates)))
+ (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..046918d
--- a/dev/null
+++ b/contrib/lisp/org-eldoc.el
@@ -0,0 +1,173 @@
+;;; org-eldoc.el --- display org header and src block info using eldoc
+
+;; Copyright (c) 2014-2016 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)
+
+(declare-function org-element-at-point "org-element" ())
+(declare-function org-element-property "org-element" (property element))
+(declare-function org-element-type "org-element" (element))
+
+(defgroup org-eldoc nil "" :group 'org)
+
+(defcustom org-eldoc-breadcrumb-separator "/"
+ "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 (or (nth 0 info) "no lang") '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 ((element (save-match-data (org-element-at-point))))
+ (and (eq (org-element-type element) 'src-block)
+ (>= (line-beginning-position)
+ (org-element-property :post-affiliated element))
+ (<=
+ (line-end-position)
+ (org-with-wide-buffer
+ (goto-char (org-element-property :end element))
+ (skip-chars-backward " \t\n")
+ (line-end-position)))
+ (org-element-property :language element))))
+
+(defvar org-eldoc-local-functions-cache (make-hash-table :size 40 :test 'equal)
+ "Cache of major-mode's eldoc-documentation-functions,
+ 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 (functionp 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-elisp-symbol.el b/contrib/lisp/org-elisp-symbol.el
index 167731e..7c98962 100644
--- a/contrib/lisp/org-elisp-symbol.el
+++ b/contrib/lisp/org-elisp-symbol.el
@@ -1,6 +1,6 @@
;;; org-elisp-symbol.el --- Org links to emacs-lisp symbols
;;
-;; Copyright 2007-2014 Free Software Foundation, Inc.
+;; Copyright 2007-2016 Free Software Foundation, Inc.
;;
;; Author: Bastien Guerry
;; Version: 0.2
@@ -78,8 +78,9 @@
(require 'org)
-(org-add-link-type "elisp-symbol" 'org-elisp-symbol-open)
-(add-hook 'org-store-link-functions 'org-elisp-symbol-store-link)
+(org-link-set-parameters "elisp-symbol"
+ :follow #'org-elisp-symbol-open
+ :store #'org-elisp-symbol-store-link)
(defun org-elisp-symbol-open (path)
"Visit the emacs-lisp elisp-symbol at PATH."
diff --git a/contrib/lisp/org-eval-light.el b/contrib/lisp/org-eval-light.el
index 872f3a4..1449b24 100644
--- a/contrib/lisp/org-eval-light.el
+++ b/contrib/lisp/org-eval-light.el
@@ -1,6 +1,6 @@
;;; org-eval-light.el --- Display result of evaluating code in various languages (light)
-;; Copyright (C) 2008-2014 Free Software Foundation, Inc.
+;; Copyright (C) 2008-2016 Free Software Foundation, Inc.
;; Author: Carsten Dominik <carsten at orgmode dot org>,
;; Eric Schulte <schulte dot eric at gmail dot com>
diff --git a/contrib/lisp/org-eval.el b/contrib/lisp/org-eval.el
index cb5620c..92a4a19 100644
--- a/contrib/lisp/org-eval.el
+++ b/contrib/lisp/org-eval.el
@@ -1,5 +1,5 @@
;;; org-eval.el --- Display result of evaluating code in various languages
-;; Copyright (C) 2008-2014 Free Software Foundation, Inc.
+;; Copyright (C) 2008-2016 Free Software Foundation, Inc.
;;
;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines, hypermedia, calendar, wp
diff --git a/contrib/lisp/org-expiry.el b/contrib/lisp/org-expiry.el
index d58043f..cd36d08 100644
--- a/contrib/lisp/org-expiry.el
+++ b/contrib/lisp/org-expiry.el
@@ -1,6 +1,6 @@
;;; org-expiry.el --- expiry mechanism for Org entries
;;
-;; Copyright 2007-2014 Free Software Foundation, Inc.
+;; Copyright 2007-2016 Free Software Foundation, Inc.
;;
;; Author: Bastien Guerry
;; Version: 0.2
@@ -186,7 +186,7 @@ restart `org-mode' if necessary."
;; need this to refresh org-mode hooks
(when (eq major-mode 'org-mode)
(org-mode)
- (if (org-called-interactively-p)
+ (if (called-interactively-p 'any)
(message "Org-expiry insinuated, `org-mode' restarted.")))))
(defun org-expiry-deinsinuate (&optional arg)
@@ -207,7 +207,7 @@ and restart `org-mode' if necessary."
;; need this to refresh org-mode hooks
(when (eq major-mode 'org-mode)
(org-mode)
- (if (org-called-interactively-p)
+ (if (called-interactively-p 'any)
(message "Org-expiry de-insinuated, `org-mode' restarted.")))))
;;; org-expiry-expired-p:
@@ -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))
@@ -238,8 +239,8 @@ If FORCE is non-nil, don't require confirmation from the user.
Otherwise rely on `org-expiry-confirm-flag' to decide."
(interactive "P")
(save-excursion
- (when (org-called-interactively-p) (org-reveal))
- (when (org-expiry-expired-p)
+ (when (called-interactively-p) (org-reveal))
+ (when (org-expiry-expired-p 'any)
(org-back-to-heading)
(looking-at org-complex-heading-regexp)
(let* ((ov (make-overlay (point) (match-end 0)))
@@ -270,7 +271,7 @@ The expiry process will run the function defined by
(while (and (outline-next-heading) (< (point) end))
(when (org-expiry-expired-p)
(setq expired (1+ expired))
- (if (if (org-called-interactively-p)
+ (if (if (called-interactively-p 'any)
(call-interactively 'org-expiry-process-entry)
(org-expiry-process-entry))
(setq processed (1+ processed)))))
@@ -338,7 +339,7 @@ and insert today's date."
(save-excursion
(if (org-expiry-expired-p)
(org-archive-subtree)
- (if (org-called-interactively-p)
+ (if (called-interactively-p 'any)
(message "Entry at point is not expired.")))))
(defun org-expiry-add-keyword (&optional keyword)
@@ -349,7 +350,7 @@ and insert today's date."
(save-excursion
(if (org-expiry-expired-p)
(org-todo keyword)
- (if (org-called-interactively-p)
+ (if (called-interactively-p 'any)
(message "Entry at point is not expired."))))
(error "\"%s\" is not a to-do keyword in this buffer" keyword)))
diff --git a/contrib/lisp/org-favtable.el b/contrib/lisp/org-favtable.el
deleted file mode 100755
index 3a6bb88..0000000
--- a/contrib/lisp/org-favtable.el
+++ b/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..9d3ff32 100644
--- a/contrib/lisp/org-git-link.el
+++ b/contrib/lisp/org-git-link.el
@@ -69,7 +69,7 @@
;; org link functions
;; bare git link
-(org-add-link-type "gitbare" 'org-gitbare-open)
+(org-link-set-parameters "gitbare" :follow #'org-gitbare-open)
(defun org-gitbare-open (str)
(let* ((strlist (org-git-split-string str))
@@ -92,16 +92,18 @@
(setq buffer-read-only t)))
;; user friendly link
-(org-add-link-type "git" 'org-git-open)
+(org-link-set-parameters "git" :follow #'org-git-open :store #'org-git-store-link)
(defun org-git-open (str)
(let* ((strlist (org-git-split-string str))
(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)
@@ -133,24 +135,25 @@
(eval-and-compile
- (if (featurep 'xemacs)
- (defalias 'org-git-gitrepos-p 'org-git-find-gitdir)
- (defalias 'org-git-gitrepos-p 'org-git-find-gitdir
- "Return non-nil if path is in git repository")))
+ (defalias 'org-git-gitrepos-p 'org-git-find-gitdir
+ "Return non-nil if path is in git repository"))
;; splitting the link string
;; 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,24 +171,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))))))
-
-(add-hook 'org-store-link-functions 'org-git-store-link)
+ :link (org-git-create-git-link file line))))))
(defun org-git-insert-link-interactively (file searchstring &optional description)
(interactive "FFile: \nsSearch string: \nsDescription: ")
diff --git a/contrib/lisp/org-index.el b/contrib/lisp/org-index.el
new file mode 100644
index 0000000..c4341c8
--- a/dev/null
+++ b/contrib/lisp/org-index.el
@@ -0,0 +1,2987 @@
+;;; org-index.el --- A personal adaptive index for org
+
+;; Copyright (C) 2011-2016 Free Software Foundation, Inc.
+
+;; Author: Marc Ihm <org-index@2484.de>
+;; Version: 5.1.2
+;; 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 nodes and things outside of org.
+;;
+;; org-index creates and updates an index table with keywords; each line
+;; either points to a heading in org, references something outside or
+;; carries a snippet of text to yank. When searching the index, the set
+;; of matching lines is updated with every keystroke; results are sorted
+;; by usage count and date, so that frequently used entries appear first
+;; in the list of results.
+;;
+;; References are decorated numbers (e.g. 'R237' or '--455--'); they are
+;; well suited to be used outside of org, e.g. in folder names, ticket
+;; systems or on printed documents.
+;;
+;; On first invocation org-index will assist you in creating the index
+;; table.
+;;
+;; To start using your index, invoke subcommands 'add', 'ref' and 'yank'
+;; to create entries and 'occur' to find them.
+;;
+;;
+;; Setup:
+;;
+;; - Place this file in a directory from your load-path,
+;; e.g. org-mode/contrib/lisp.
+;;
+;; - Add these lines to your .emacs:
+;;
+;; (require 'org-index)
+;; (global-set-key (kbd "C-c i") 'org-index-dispatch) ; this is optional
+;;
+;; - Restart your Emacs to make these lines effective.
+;;
+;; - Invoke `org-index'; on first run it will assist in creating your
+;; index table.
+;;
+;; - Optionally invoke `M-x org-customize' to tune some settings (choose
+;; group org-index).
+;;
+;;
+;; Further information:
+;;
+;; - Watch the screencast at http://2484.de/org-index.html.
+;;
+;; - See the documentation of `org-index', which can also be read by
+;; invoking `org-index' and choosing the command help or '?'.
+;;
+;;
+;; Updates:
+;;
+;; The latest published version of this file can always be found at:
+;;
+;; http://orgmode.org/w/?p=org-mode.git;a=blob_plain;f=contrib/lisp/org-index.el;hb=HEAD
+;;
+;; Development version under:
+;;
+;; https://github.com/marcIhm/org-index
+
+;;; Change Log:
+
+;; [2016-08-05 Fr] Version 5.1.2
+;; - Offering help during query for subcommands
+;; - Removed org-index-default-keybindings
+;; - Renamed subcommand multi-occur to find-ref
+;; - Subcommands add and need no longer be invoked from heading
+;; - Many Bugfixes
+;;
+;; [2015-12-29 Tu] Version 5.0.2
+;; - New commands yank, column and edit
+;; - New column tags
+;; - All columns are now required
+;; - References are now optional
+;; - Subcommand enter has been renamed to index
+;; - Subcommands kill and edit can be invoked from an occur buffer
+;; - Many Bugfixes
+;; - Added link to screencast
+;;
+;; [2015-08-20 Th] Version 4.3.0
+;; - Configuration is done now via standard customize
+;; - New sorting strategy 'mixed'
+;; - Silenced some compiler warnings
+;;
+;; [2015-03-18 We] Version 4.2.1
+;; - No garbage in kill-ring
+;; - No recentering after add
+;;
+;; [2015-03-08 Su] Version 4.2.0
+;; - Reference numbers for subcommands can be passed as a prefix argument
+;; - 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-02-26 Th] to [2015-03-05 Th] Version 4.0.0 to 4.1.2
+;; - Removed command "leave"; rather go back with org-mark-ring-goto
+;; - 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
+;; - Shortened versin history
+;;
+;; [2014-12-08 Mo] to [2015-01-31 Sa] Version 3.0.0 to 3.2.0:
+;; - Complete sorting of index only occurs in idle-timer
+;; - New command "maintain" with some subcommands
+;; - Rewrote command "occur" with overlays in an indirect buffer
+;; - 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.
+;; - 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-lib)
+(require 'widget)
+
+;; Version of this package
+(defvar org-index-version "5.1.2" "Version of `org-index', format is major.minor.bugfix, where \"major\" are incompatible changes and \"minor\" are new features.")
+
+;; customizable options
+(defgroup org-index nil
+ "Options concerning the optional index for org."
+ :tag "Org Index"
+ :group 'org)
+
+(defcustom org-index-id nil
+ "Id of the Org-mode node, which contains the index table."
+ :group 'org-index)
+
+(defcustom org-index-sort-by 'mixed
+ "Strategy for sorting index table (and whence entries in occur).
+Valid values are:
+
+last-access Sort index by date and time of last access; show
+ more recent entries first.
+count Sort by usage count; more often used entries first.
+mixed First, show all index entries, which have been
+ used today; sort them by last access. Then show
+ older entries sorted by usage count."
+ :group 'org-index
+ :set (lambda (s v)
+ (set-default s v)
+ (if (and org-index-id
+ org-index--buffer
+ (functionp 'org-index--sort-silent))
+ (org-index--sort-silent)))
+ :initialize 'custom-initialize-default
+ :type '(choice
+ (const last-accessed)
+ (const count)
+ (const mixed)))
+
+(defcustom org-index-yank-after-add 'ref
+ "Specifies which column should be yanked after adding a new index row.
+Valid values are some columns of index table."
+ :group 'org-index
+ :type '(choice
+ (const ref)
+ (const category)
+ (const keywords)))
+
+(defcustom org-index-point-on-add 'keywords
+ "Specifies in which column point will land when adding a new index row.
+Valid values are some columns of index table."
+ :group 'org-index
+ :type '(choice
+ (const category)
+ (const keywords)))
+
+(defcustom org-index-copy-heading-to-keywords t
+ "When adding a new node to index: Copy heading to keywords-column ?"
+ :group 'org-index
+ :type '(choice (const :tag "Yes" t)
+ (const :tag "No" nil)))
+
+(defcustom org-index-strip-ref-and-date-from-heading t
+ "When adding a node to index: strip leading ref or timestamps ?
+
+This can be useful, if you have the habit of adding refs and
+dates to the start of your headings; then, if you change your
+heading and want to update your index, you do not need to remove
+those pieces."
+ :group 'org-index
+ :type '(choice (const :tag "Yes" t)
+ (const :tag "No" nil)))
+
+(defcustom org-index-edit-on-add '(category keywords)
+ "List of columns to edit when adding a new row."
+ :group 'org-index
+ :type '(repeat (choice
+ (const category)
+ (const keywords))))
+
+(defcustom org-index-edit-on-yank '(yank keywords)
+ "List of columns to edit when adding new text to yank."
+ :group 'org-index
+ :type '(repeat (choice
+ (const yank)
+ (const category)
+ (const keywords))))
+
+(defcustom org-index-edit-on-ref '(category keywords)
+ "List of columns to edit when adding new ref."
+ :group 'org-index
+ :type '(repeat (choice
+ (const category)
+ (const keywords))))
+
+;; Variables to hold the configuration of the index table
+(defvar org-index--maxrefnum nil "Maximum number from reference table, e.g. 153.")
+(defvar org-index--nextref nil "Next reference, that can be used, e.g. 'R154'.")
+(defvar org-index--head nil "Header before number (e.g. 'R').")
+(defvar org-index--tail nil "Tail after number (e.g. '}' or ')'.")
+(defvar org-index--numcols nil "Number of columns in index table.")
+(defvar org-index--ref-regex nil "Regular expression to match a reference.")
+(defvar org-index--ref-format nil "Format, that can print a reference.")
+(defvar org-index--columns nil "Columns of index-table.")
+(defvar org-index--buffer nil "Buffer of index table.")
+(defvar org-index--point nil "Position at start of headline of index table.")
+(defvar org-index--below-hline nil "Position of first cell in first line below hline.")
+(defvar org-index--saved-positions nil "Saved positions within current buffer and index buffer; filled by ‘org-index--save-positions’.")
+(defvar org-index--headings nil "Headlines of index-table as a string.")
+(defvar org-index--headings-visible nil "Visible part of headlines of index-table as a string.")
+
+;; Variables to hold context and state
+(defvar org-index--last-fingerprint nil "Fingerprint of last line created.")
+(defvar org-index--category-before nil "Category of node before.")
+(defvar org-index--active-region nil "Active region, initially. I.e. what has been marked.")
+(defvar org-index--below-cursor nil "Word below cursor.")
+(defvar org-index--within-index-node nil "True, if we are within node of the index table.")
+(defvar org-index--within-occur nil "True, if we are within the occur-buffer.")
+(defvar org-index--message-text nil "Text that was issued as an explanation; helpful for regression tests.")
+(defvar org-index--occur-help-text nil "Text for help in occur buffer.")
+(defvar org-index--occur-help-overlay nil "Overlay for help in occur buffer.")
+(defvar org-index--occur-stack nil "Stack with overlays for hiding lines.")
+(defvar org-index--occur-tail-overlay nil "Overlay to cover invisible lines.")
+(defvar org-index--occur-lines-collected 0 "Number of lines collected in occur buffer; helpful for tests.")
+(defvar org-index--last-sort nil "Last column, the index has been sorted after.")
+(defvar org-index--sort-timer nil "Timer to sort index in correct order.")
+(defvar org-index--aligned nil "Remember for this Emacs session, if table has been aligned at least once.")
+(defvar org-index--edit-widgets nil "List of widgets used to edit.")
+(defvar org-index--context-index nil "Position and line used for index in edit buffer.")
+(defvar org-index--context-occur nil "Position and line used for occur in edit buffer.")
+(defvar org-index--context-node nil "Buffer and position for node in edit buffer.")
+(defvar org-index--short-help-buffer-name "*org-index commands*" "Name of buffer to display short help.")
+(defvar org-index--display-short-help nil "True, if short help should be displayed.")
+(defvar org-index--short-help-displayed nil "True, if short help message has been displayed.")
+(defvar org-index--minibuffer-saved-key nil "Temporarily save entry of minibuffer keymap.")
+
+;; static information for this program package
+(defconst org-index--commands '(occur add kill head ping index ref yank column edit help short-help example sort find-ref highlight maintain) "List of commands available.")
+(defconst org-index--valid-headings '(ref id created last-accessed count keywords category level yank tags) "All valid headings.")
+(defconst org-index--occur-buffer-name "*org-index-occur*" "Name of occur buffer.")
+(defconst org-index--edit-buffer-name "*org-index-edit*" "Name of edit buffer.")
+(defconst org-index--sort-idle-delay 300 "Delay in seconds after which buffer will sorted.")
+(defvar org-index--short-help-text nil "Cache for result of `org-index--get-short-help-text.")
+(defvar org-index--shortcut-chars nil "Cache for result of `org-index--get-shortcut-chars.")
+
+
+(defmacro org-index--on (column value &rest body)
+ "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
+ (let ((,pointvar (point))
+ ,foundvar
+ ,retvar)
+
+ (set-buffer org-index--buffer)
+
+ (setq ,foundvar (org-index--go ,column ,value))
+ (when ,foundvar
+ (setq ,retvar (progn ,@body)))
+
+ (goto-char ,pointvar)
+
+ ,retvar))))
+
+
+(defun org-index (&optional command search-ref arg)
+ "Fast search-index for selected org nodes and things outside of org.
+
+org-index creates and updates an index table with keywords; each line
+either points to a heading in org, references something outside or
+carries a snippet of text to yank. The index table is searched for
+keywords through an incremental occur; results are sorted by usage
+count and date, so that frequently used entries appear first among
+the results.
+
+References are decorated numbers (e.g. 'R237' or '--455--'); they are
+well suited to be used outside of org, e.g. in folder names, ticket
+systems or on printed documents.
+
+On first invocation org-index will help to create a dedicated node
+for its index table.
+
+To start building up your index, use subcommands 'add', 'ref' and
+'yank' to create entries and use 'occur' to find them.
+
+This is version 5.1.2 of org-index.el.
+
+
+The function `org-index' is the only interactive function of this
+package and its main entry point; it will present you with a list
+of subcommands to choose from:
+
+\(Note the one-letter shortcuts, e.g. [o]; used like 'C-c i o'.)
+
+ occur: [o] Incrementally show matching lines from index.
+ Result is updated after every keystroke. You may enter a
+ list of words seperated by space or comma (`,'), to select
+ lines that contain all of the given words.
+
+ add: [a] Add the current node to index.
+ So that (e.g.) it can be found through the subcommand
+ 'occur'. Update index, if node is already present.
+
+ kill: [k] Kill (delete) the current node from index.
+ Can be invoked from index, from occur or from a headline.
+
+ head: [h] Search for heading, by ref or from index line.
+ If invoked from within index table, go to associated
+ node (if any), otherwise ask for ref to search.
+
+ index: [i] Enter index table and maybe go to a specific reference.
+ Use `org-mark-ring-goto' (\\[org-mark-ring-goto]) to go back.
+
+ ping: [p] Echo line from index table for current node.
+ If current node is not in index, than search among its
+ parents.
+
+ ref: [r] Create a new index line with a reference.
+ This line will not be associated with a node.
+
+ yank: [y] Store a new string, that can be yanked from occur.
+ The index line will not be associated with a node.
+
+ column: [c] From within index table: read char and jump to column.
+ Shortcut for column movement; stays within one index line.
+
+ edit: [e] Present current line in edit buffer.
+ Can be invoked from index, from occur or from a headline.
+
+ help: Show complete help text of org-index.
+
+ short-help: [?] Show one-line description of each subcommand.
+ I.e. show this list but only first sentence each.
+
+ example: Create an example index, that will not be saved.
+ May serve as an example.
+
+ sort: Sort lines in index, in region or buffer.
+ Region or buffer can be sorted by contained reference; Index
+ by count, reference or last access.
+
+ find-ref: Search for given reference in all org-buffers.
+ A wrapper to employ emacs standard `multi-occur' function;
+ asks for reference.
+
+ highlight: Highlight or unhighlight all references.
+ Operates on active region or whole buffer. Call with prefix
+ argument (`C-u') to remove highlights.
+
+ maintain: Index maintainance.
+ Offers some choices to check, update or fix your index.
+
+If you invoke `org-index' for the first time, an assistant will be
+invoked, that helps you to create your own index.
+
+Invoke `org-customize' to tweak the behaviour of org-index.
+
+Optionally bind `org-index-dispatch' to a key, e.g. 'C-c i' in
+the global keymap to invoke the most important subcommands with
+a single key.
+
+A numeric prefix argument is used as a reference number for
+commands, that need one (e.g. 'head').
+
+Use from elisp: Optional argument COMMAND is a symbol naming the
+command to execute. SEARCH-REF specifies a reference to search
+for, if needed. ARG allows passing in a prefix argument as in
+interactive calls."
+
+ (interactive "i\ni\nP")
+
+ (let (search-id ; id to search for
+ search-fingerprint ; fingerprint to search for
+ sort-what ; sort what ?
+ kill-new-text ; text that will be appended to kill ring
+ message-text) ; text that will be issued as an explanation
+
+ (catch 'new-index
+
+ ;;
+ ;; Initialize and parse
+ ;;
+
+ ;; 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-sort-by))
+ ;; rearrange for index beeing sorted into default sort order after 300 secs of idle time
+ (unless org-index--sort-timer
+ (setq org-index--sort-timer
+ (run-with-idle-timer org-index--sort-idle-delay t 'org-index--sort-silent)))
+
+
+ ;;
+ ;; Find out, what we are supposed to do
+ ;;
+
+ ;; Check or read command
+ (if (and command (not (eq command 'short-help)))
+ (unless (memq command org-index--commands)
+ (error "Unknown command '%s' passed as argument, valid choices are any of these symbols: %s"
+ command (mapconcat 'symbol-name org-index--commands ",")))
+
+ ;; read command; if requested display help in read-loop
+ (setq org-index--display-short-help (eq command 'short-help))
+ (setq command (org-index--read-command))
+ (setq org-index--display-short-help nil))
+
+ ;;
+ ;; Get search string, if required; process possible sources one after
+ ;; another (lisp argument, prefix argument, user input).
+ ;;
+
+ ;; Try prefix, if no lisp argument given
+ (if (and (not search-ref)
+ (numberp arg))
+ (setq search-ref (format "%s%d%s" org-index--head arg org-index--tail)))
+
+ ;; These actions really need a search string and may even prompt for it
+ (when (memq command '(index head find-ref))
+
+ ;; search from surrounding text ?
+ (unless search-ref
+ (if org-index--within-index-node
+
+ (if (org-at-table-p)
+ (setq search-ref (org-index--get-or-set-field 'ref)))
+
+ (if (and org-index--below-cursor
+ (string-match (concat "\\(" org-index--ref-regex "\\)")
+ org-index--below-cursor))
+ (setq search-ref (match-string 1 org-index--below-cursor)))))
+
+ ;; If we still do not have a search string, ask user explicitly
+ (unless search-ref
+ (if (eq command 'index)
+ (let ((r (org-index--read-search-for-index)))
+ (setq search-ref (first r))
+ (setq search-id (second r))
+ (setq search-fingerprint (third r)))
+ (unless (and (eq command 'head)
+ org-index--within-index-node
+ (org-at-table-p))
+ (setq search-ref (read-from-minibuffer "Search reference number: ")))))
+
+ ;; Clean up search string
+ (when search-ref
+ (setq search-ref (org-trim search-ref))
+ (if (string-match "^[0-9]+$" search-ref)
+ (setq search-ref (concat org-index--head search-ref org-index--tail)))
+ (if (string= search-ref "") (setq search-ref nil)))
+
+ (if (and (not search-ref)
+ (not (eq command 'index))
+ (not (and (eq command 'head)
+ org-index--within-index-node
+ (org-at-table-p))))
+ (error "Command %s needs a reference number" command)))
+
+
+ ;;
+ ;; Command sort needs to know in advance, what to sort for
+ ;;
+
+ (when (eq command 'sort)
+ (setq sort-what (intern (org-completing-read "You may sort:\n - index : your index table by various columns\n - region : the active region by contained reference\n - buffer : the whole current buffer\nPlease choose what to sort: " (list "index" "region" "buffer") nil t))))
+
+
+ ;;
+ ;; Enter table
+ ;;
+
+ ;; Arrange for beeing able to return
+ (when (and (memq command '(occur head index example sort maintain))
+ (not (string= (buffer-name) org-index--occur-buffer-name)))
+ (org-mark-ring-push))
+
+ ;; These commands will leave user in index table after they are finished
+ (when (or (memq command '(index maintain))
+ (and (eq command 'sort)
+ (eq sort-what 'index)))
+
+ (pop-to-buffer-same-window org-index--buffer)
+ (goto-char org-index--point)
+ (org-index--unfold-buffer))
+
+
+ ;;
+ ;; Actually do, what is requested
+ ;;
+
+ (cond
+
+ ((eq command 'help)
+
+ ;; bring up help-buffer for this function
+ (describe-function 'org-index))
+
+
+ ((eq command 'find-ref)
+
+ ;; Construct list of all org-buffers
+ (let (org-buffers)
+ (dolist (buff (buffer-list))
+ (set-buffer buff)
+ (if (string= major-mode "org-mode")
+ (setq org-buffers (cons buff org-buffers))))
+
+ ;; 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 "Found '%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 (if (equal arg '(4)) t nil)
+ (if (numberp arg) arg nil))))
+ (setq message-text (car r))
+ (setq kill-new-text (cdr r))))
+
+
+ ((eq command 'kill)
+ (setq message-text (org-index--do-kill)))
+
+
+ ((eq command 'head)
+
+ (if (and org-index--within-index-node
+ (org-at-table-p))
+ (setq search-id (org-index--get-or-set-field 'id)))
+
+ (if (and (not search-id) search-ref)
+ (setq search-id (org-index--id-from-ref search-ref)))
+
+ (setq message-text
+ (if search-id
+ (org-index--find-id search-id)
+ "Current line has no id")))
+
+
+ ((eq command 'index)
+
+ (goto-char org-index--below-hline)
+
+ (setq message-text
+
+ (if search-ref
+ (if (org-index--go 'ref search-ref)
+ (progn
+ (org-index--update-current-line)
+ (org-table-goto-column (org-index--column-num 'ref))
+ (format "Found index line '%s'" 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))
+
+ (if search-fingerprint
+ (if (org-index--go 'fingerprint org-index--last-fingerprint)
+ (progn
+ (org-index--update-current-line)
+ (beginning-of-line)
+ (format "Found latest index line"))
+ (format "Did not find index line"))
+
+ ;; simply go into table
+ "At index table"))))
+
+ (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)
+ (cl-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 (args)
+
+ (setq args (org-index--collect-values-from-user org-index-edit-on-ref))
+ (setq args (plist-put args 'category "yank"))
+ (setq args (plist-put args 'ref org-index--nextref))
+ (apply 'org-index--do-new-line args)
+
+ (setq kill-new-text org-index--nextref)
+
+ (setq message-text (format "Added new row with ref '%s'" org-index--nextref))))
+
+
+ ((eq command 'yank)
+
+ (let (args)
+
+ (setq args (org-index--collect-values-from-user org-index-edit-on-yank))
+ (if (plist-get args 'yank)
+ (plist-put args 'yank (replace-regexp-in-string "|" (regexp-quote "\\vert") (plist-get args 'yank) nil 'literal)))
+ (setq args (plist-put args 'category "yank"))
+ (apply 'org-index--do-new-line args)
+
+ (setq message-text "Added new row with text to yank")))
+
+
+ ((eq command 'column)
+
+ (if (and org-index--within-index-node
+ (org-at-table-p))
+ (let (char col num)
+ (setq char (read-char "Please specify, which column to go to (r=ref, k=keywords, c=category, y=yank): "))
+ (unless (memq char (list ?r ?k ?c ?y))
+ (error (format "Invalid char '%c', cannot goto this column" char)))
+ (setq col (cdr (assoc char '((?r . ref) (?k . keywords) (?c . category) (?y . yank)))))
+ (setq num (org-index--column-num col))
+ (if num
+ (progn
+ (org-table-goto-column num)
+ (setq message-text (format "At column %s" (symbol-name col))))
+
+ (error (format "Column '%s' is not present" col))))
+ (error "Need to be in index table to go to a specific column")))
+
+
+ ((eq command 'edit)
+
+ (setq message-text (org-index--do-edit)))
+
+
+ ((eq command 'sort)
+
+ (let ((sorts (list "count" "last-accessed" "mixed" "id" "ref"))
+ sort groups-and-counts)
+
+ (cond
+ ((eq sort-what 'index)
+ (setq sort
+ (intern
+ (completing-read
+ "Please choose column to sort index table: "
+ (cl-copy-list sorts)
+ nil t nil nil (symbol-name org-index-sort-by))))
+
+ (org-index--do-sort-index sort)
+ (org-table-goto-column (org-index--column-num (if (eq sort 'mixed) 'last-access sort)))
+ ;; When saving index, it should again be sorted correctly
+ (with-current-buffer org-index--buffer
+ (add-hook 'before-save-hook 'org-index--sort-silent t))
+
+ (setq message-text
+ (format
+ (concat "Your index has been sorted temporarily by %s and will be sorted again by %s after %d seconds of idle time"
+ (if groups-and-counts
+ "; %d groups with equal %s and a total of %d lines have been found"
+ ""))
+ (symbol-name sort)
+ org-index-sort-by
+ org-index--sort-idle-delay
+ (second groups-and-counts)
+ (symbol-name sort)
+ (third groups-and-counts))))
+
+ ((memq sort-what '(region buffer))
+ (org-index--do-sort-lines sort-what)
+ (setq message-text (format "Sorted %s by contained references" sort-what))))))
+
+
+ ((eq command 'highlight)
+
+ (let ((where "buffer"))
+ (save-excursion
+ (save-restriction
+ (when (and transient-mark-mode
+ mark-active)
+ (narrow-to-region (region-beginning) (region-end))
+ (setq where "region"))
+
+ (if arg
+ (progn
+ (unhighlight-regexp org-index--ref-regex)
+ (setq message-text (format "Removed highlights for references in %s" where)))
+ (highlight-regexp org-index--ref-regex 'isearch)
+ (setq message-text (format "Highlighted references in %s" where)))))))
+
+
+ ((eq command 'maintain)
+ (setq message-text (org-index--do-maintain)))
+
+
+ ((eq command 'example)
+
+ (if (y-or-n-p "This assistant will help you to create a temporary index with detailed comments.\nDo you want to proceed ? ")
+ (org-index--create-index t)))
+
+
+ ((not command) (setq message-text "No command given"))
+
+
+ (t (error "Unknown subcommand '%s'" command)))
+
+
+ ;; tell, what we have done and what can be yanked
+ (if kill-new-text (setq kill-new-text
+ (substring-no-properties kill-new-text)))
+ (if (string= kill-new-text "") (setq kill-new-text nil))
+ (let ((m (concat
+ message-text
+ (if (and message-text kill-new-text)
+ " and r"
+ (if kill-new-text "R" ""))
+ (if kill-new-text (format "eady to yank '%s'." kill-new-text) (if message-text "." "")))))
+ (unless (string= m "")
+ (message m)
+ (setq org-index--message-text m)))
+ (if kill-new-text (kill-new kill-new-text)))))
+
+
+(defun org-index-dispatch (&optional arg)
+ "Read additional chars and call subcommands of `org-index'.
+Can be bound in global keyboard map as central entry point.
+Optional argument ARG is passed on."
+ (interactive "P")
+ (let (char command)
+ (if (sit-for 1)
+ (message "org-index (? for detailed prompt) -"))
+ (setq char (key-description (read-key-sequence nil)))
+ (if (string= char "C-g") (keyboard-quit))
+ (if (string= char "SPC") (setq char "?"))
+ (setq command (cdr (assoc char (org-index--get-shortcut-chars))))
+ (unless command
+ (message "No subcommand for '%s'; switching to detailed prompt" char)
+ (sit-for 1)
+ (setq command 'short-help))
+ (org-index command nil arg)))
+
+
+(defun org-index-new-line (&rest keys-values)
+ "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."
+
+ (let ((ref (plist-get keys-values 'ref)))
+ (org-index--verify-id)
+ (org-index--parse-table)
+ (if (not (memq ref '(t nil)))
+ (error "Column 'ref' accepts only 't' or 'nil'"))
+ (when ref
+ (setq ref org-index--nextref)
+ (setq keys-values (plist-put keys-values 'ref ref)))
+
+ (apply 'org-index--do-new-line keys-values)
+ ref))
+
+
+(defun org-index--read-command (&optional with-short-help)
+ "Read subcommand for ‘org-index’ from minibuffer.
+Optional argument WITH-SHORT-HELP displays help screen upfront."
+ (let (minibuffer-scroll-window
+ minibuffer-setup-fun
+ command)
+ (setq org-index--short-help-displayed nil)
+ (add-hook 'minibuffer-setup-hook 'org-index--minibuffer-setup-function)
+ (add-hook 'minibuffer-exit-hook 'org-index--minibuffer-exit-function)
+ (unwind-protect
+ (setq command
+ (intern
+ (completing-read
+ (concat
+ "Please choose"
+ (if org-index--display-short-help "" " (? for short help)")
+ ": ")
+ (mapcar 'symbol-name org-index--commands) nil t)))
+ (remove-hook 'minibuffer-setup-hook 'org-index--minibuffer-setup-function)
+ (remove-hook 'minibuffer-exit-hook 'org-index--minibuffer-exit-function)
+ (when org-index--short-help-displayed
+ (quit-windows-on org-index--short-help-buffer-name)))
+ command))
+
+
+(defun org-index--minibuffer-setup-function ()
+ "Prepare minibuffer for `org-index--read-command'."
+ (setq org-index--minibuffer-saved-key (local-key-binding (kbd "?")))
+ (local-set-key (kbd "?") 'org-index--minibuffer-short-help-helper)
+ (if org-index--display-short-help (org-index--minibuffer-short-help-helper)))
+
+
+(defun org-index--minibuffer-exit-function ()
+ "Restore minibuffer after `org-index--read-command'."
+ (local-set-key (kbd "?") org-index--minibuffer-saved-key)
+ (setq org-index--minibuffer-saved-key nil))
+
+
+(defun org-index--minibuffer-short-help-helper ()
+ "Helper function to show help in minibuffer."
+ (interactive)
+ ;; take original help-text for org-index and extract one-line help for subcommands
+ (with-temp-buffer-window
+ org-index--short-help-buffer-name nil nil
+ (setq org-index--short-help-displayed t)
+ (princ (concat "Short help; all subcommands of `org-index', shortcuts in []; type "
+ (substitute-command-keys "\\[scroll-other-window]")
+ " to scroll:\n"))
+ (princ (org-index--get-short-help-text))))
+
+
+(defun org-index--get-short-help-text ()
+ "Extract text for short help message from long help."
+ (or org-index--short-help-text
+ (with-temp-buffer
+ (insert (documentation 'org-index))
+ (goto-char (point-min))
+ (search-forward (concat " " (symbol-name (first org-index--commands)) ": "))
+ (forward-line 0)
+ (kill-region (point-min) (point))
+ (search-forward (concat " " (symbol-name (car (last org-index--commands))) ": "))
+ (forward-line 1)
+ (kill-region (point) (point-max))
+ (keep-lines "^ [-a-z]+:" (point-min) (point-max))
+ (align-regexp (point-min) (point-max) "\\(\\s-*\\):")
+ (goto-char (point-min))
+ (while (re-search-forward "\\. *$" nil t)
+ (replace-match "" nil nil))
+ (goto-char (point-min))
+ (re-search-forward "short-help")
+ (end-of-line)
+ (insert " (this text)")
+ (goto-char (point-min))
+ (unless (= (line-number-at-pos (point-max)) (1+ (length org-index--commands)))
+ (error "Internal error, unable to properly extract one-line descriptions of subcommands"))
+ (setq org-index--short-help-text (buffer-string)))))
+
+
+(defun org-index--get-shortcut-chars ()
+ "Collect shortcut chars from short help message."
+ (or org-index--shortcut-chars
+ (with-temp-buffer
+ (insert (org-index--get-short-help-text))
+ (goto-char (point-min))
+ (while (< (point) (point-max))
+ (when (looking-at "^ \\([-a-z]+\\) +: +\\[\\([a-z?]\\)\\] ")
+ (setq org-index--shortcut-chars
+ (cons (cons (match-string 2) (intern (match-string 1)))
+ org-index--shortcut-chars)))
+ (forward-line 1))
+ (unless (> (length org-index--shortcut-chars) 0)
+ (error "Internal error, did not find shortcut chars"))
+ org-index--shortcut-chars)))
+
+
+(defun org-index--do-edit ()
+ "Perform command edit."
+ (let ((maxlen 0) cols-vals buffer-keymap field-keymap keywords-pos val)
+
+ (setq org-index--context-node nil)
+ (setq org-index--context-occur nil)
+
+ ;; change to index, if whithin occur
+ (if org-index--within-occur
+ (let ((pos (get-text-property (point) 'org-index-lbp)))
+ (org-index--occur-test-stale pos)
+ (setq org-index--context-occur (cons (point) (org-index--line-in-canonical-form)))
+ (set-buffer org-index--buffer)
+ (goto-char pos))
+
+ ;; change to index, if still not within
+ (if (not org-index--within-index-node)
+ (let ((id (org-id-get)))
+ (setq org-index--context-node (cons (current-buffer) (point)))
+ (set-buffer org-index--buffer)
+ (unless (and id (org-index--go 'id id))
+ (setq org-index--context-node nil)
+ (error "This node is not in index")))))
+
+ ;; retrieve current content of index line
+ (dolist (col (mapcar 'car (reverse org-index--columns)))
+ (if (> (length (symbol-name col)) maxlen)
+ (setq maxlen (length (symbol-name col))))
+ (setq val (org-index--get-or-set-field col))
+ (if (and val (eq col 'yank)) (setq val (replace-regexp-in-string (regexp-quote "\\vert") "|" val nil 'literal)))
+ (setq cols-vals (cons (cons col val)
+ cols-vals)))
+
+ ;; we need two different keymaps
+ (setq buffer-keymap (make-sparse-keymap))
+ (set-keymap-parent buffer-keymap widget-keymap)
+ (define-key buffer-keymap (kbd "C-c C-c") 'org-index--edit-c-c-c-c)
+ (define-key buffer-keymap (kbd "C-c C-k") 'org-index--edit-c-c-c-k)
+
+ (setq field-keymap (make-sparse-keymap))
+ (set-keymap-parent field-keymap widget-field-keymap)
+ (define-key field-keymap (kbd "C-c C-c") 'org-index--edit-c-c-c-c)
+ (define-key field-keymap (kbd "C-c C-k") 'org-index--edit-c-c-c-k)
+
+ ;; prepare buffer
+ (setq org-index--context-index (cons (point) (org-index--line-in-canonical-form)))
+ (if (get-buffer org-index--edit-buffer-name) (kill-buffer org-index--edit-buffer-name))
+ (switch-to-buffer (get-buffer-create org-index--edit-buffer-name))
+
+ ;; create and fill widgets
+ (setq org-index--edit-widgets nil)
+ (widget-insert "Edit this line from index; type C-c C-c when done, C-c C-k to abort.\n\n")
+ (dolist (col-val cols-vals)
+ (if (eq (car col-val) 'keywords) (setq keywords-pos (point)))
+ (setq org-index--edit-widgets (cons
+ (cons (car col-val)
+ (widget-create 'editable-field
+ :format (format (format "%%%ds: %%%%v" maxlen) (symbol-name (car col-val)))
+ :keymap field-keymap
+ (or (cdr col-val) "")))
+ org-index--edit-widgets)))
+
+ (widget-setup)
+ (goto-char keywords-pos)
+ (beginning-of-line)
+ (forward-char (+ maxlen 2))
+ (use-local-map buffer-keymap)
+ "Editing a single line from index"))
+
+
+(defun org-index--edit-c-c-c-c ()
+ "Function to invoked on C-c C-c in Edit buffer."
+ (interactive)
+
+ (let ((obuf (get-buffer org-index--occur-buffer-name))
+ val line)
+
+ ;; Time might have passed
+ (org-index--refresh-parse-table)
+
+ (with-current-buffer org-index--buffer
+
+ ;; check, if buffer has become stale
+ (save-excursion
+ (goto-char (car org-index--context-index))
+ (unless (string= (cdr org-index--context-index)
+ (org-index--line-in-canonical-form))
+ (switch-to-buffer org-index--edit-buffer-name)
+ (error "Index table has changed: Cannot find line, that this buffer is editing")))
+
+ (pop-to-buffer-same-window org-index--buffer)
+ (goto-char (car org-index--context-index))
+
+ ;; write back line to index
+ (dolist (col-widget org-index--edit-widgets)
+ (setq val (widget-value (cdr col-widget)))
+ (if (eq (car col-widget) 'yank) (setq val (replace-regexp-in-string "|" (regexp-quote "\\vert") val)))
+ (org-index--get-or-set-field (car col-widget) val))
+
+ (setq line (org-index--align-and-fontify-current-line))
+ (beginning-of-line))
+
+ ;; write line to occur if appropriate
+ (if org-index--context-occur
+ (if obuf
+ (if (string= (cdr org-index--context-index)
+ (cdr org-index--context-occur))
+ (progn
+ (pop-to-buffer-same-window obuf)
+ (goto-char (car org-index--context-occur))
+ (beginning-of-line)
+ (let ((inhibit-read-only t))
+ (delete-region (line-beginning-position) (line-end-position))
+ (insert line)
+ (put-text-property (line-beginning-position) (line-end-position)
+ 'org-index-lbp (cdr org-index--context-index))))
+ (error "Occur buffer and index buffer do not match any longer"))
+ (message "Occur buffer has gone, cannot switch back."))
+ (setq org-index--context-occur nil))
+
+ ;; return to node, if invoked from there
+ (when org-index--context-node
+ (pop-to-buffer-same-window (car org-index--context-node))
+ (goto-char (cdr org-index--context-node)))
+
+ ;; clean up
+ (kill-buffer org-index--edit-buffer-name)
+ (setq org-index--context-index nil)
+ (setq org-index--edit-widgets nil)
+ (beginning-of-line)
+ (message "Index line has been edited.")))
+
+
+(defun org-index--edit-c-c-c-k ()
+ "Function invoked on C-c C-k in Edit buffer."
+ (interactive)
+ (kill-buffer org-index--edit-buffer-name)
+ (setq org-index--context-index nil)
+ (setq org-index--edit-widgets nil)
+ (beginning-of-line)
+ (message "Edit aborted."))
+
+
+(defun org-index--do-new-line (&rest keys-values)
+ "Do the work for `org-index-new-line'.
+Optional argument KEYS-VALUES specifies content of new line."
+
+ (org-index--retrieve-context)
+ (with-current-buffer org-index--buffer
+ (goto-char org-index--point)
+
+ ;; check arguments early; they might come from userland
+ (let ((kvs keys-values)
+ k v)
+ (while kvs
+ (setq k (car kvs))
+ (setq v (cadr kvs))
+ (if (or (not (symbolp k))
+ (and (symbolp v) (not (eq v t)) (not (eq v nil))))
+ (error "Arguments must be alternation of key and value"))
+ (unless (org-index--column-num k)
+ (error "Unknown column or column not defined in table: '%s'" (symbol-name k)))
+ (setq kvs (cddr kvs))))
+
+ (let (yank)
+ ;; create new line
+ (org-index--create-new-line)
+
+ ;; fill columns
+ (let ((kvs keys-values)
+ k v)
+ (while kvs
+ (setq k (car kvs))
+ (setq v (cadr kvs))
+ (org-table-goto-column (org-index--column-num k))
+ (insert (org-trim (or v "")))
+ (setq kvs (cddr kvs))))
+
+ ;; align and fontify line
+ (org-index--promote-current-line)
+ (org-index--align-and-fontify-current-line)
+
+ ;; remember fingerprint to be able to return
+ (setq org-index--last-fingerprint (org-index--get-or-set-field 'fingerprint))
+
+ ;; get column to yank
+ (setq yank (org-index--get-or-set-field org-index-yank-after-add))
+
+ 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--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--get-fingerprint ()
+ "Get fingerprint of current line."
+ (replace-regexp-in-string
+ "\\s " ""
+ (mapconcat (lambda (x) (org-index--get-or-set-field x)) '(id ref yank keywords created) "")))
+
+
+(defun org-index--read-search-for-index ()
+ "Special input routine for command index."
+
+ ;; Accept single char commands or switch to reading a sequence of digits
+ (let (char prompt search-ref search-id search-fingerprint)
+
+ ;; start with short prompt but give more help on next iteration
+ (setq prompt "Please specify, where to go in index (0-9,.,space,backspace,return or ? for short help) - ")
+
+ ;; read one character
+ (while (not (memq char (append (number-sequence ?0 ?9) (list ?\d ?\b ?\r ?\j ?\s ?.))))
+ (setq char (read-char prompt))
+ (setq prompt "Go to specific position in index table. Digits specify a reference number, <space> goes to top of index, <backspace> or <delete> to last line created and <return> or `.' to index line of current node. Please choose - "))
+
+ (if (memq char (number-sequence ?0 ?9))
+ ;; read rest of digits
+ (setq search-ref (read-from-minibuffer "Search reference number: " (char-to-string char))))
+ ;; decode single chars
+ (if (memq char '(?\r ?\n ?.)) (setq search-id (org-id-get)))
+ (if (memq char '(?\d ?\b)) (setq search-fingerprint org-index--last-fingerprint))
+
+ (list search-ref search-id search-fingerprint)))
+
+
+(defun org-index--verify-id ()
+ "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= answer "create-index")
+ (org-index--create-missing-index "Variable org-index-id is not set, so probably no index table has been created yet.")
+ (describe-function 'org-index)
+ (throw 'new-index nil))))
+
+ ;; 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 occur buffer
+ (setq org-index--within-index-node (string= (org-id-get) org-index-id))
+ (setq org-index--within-occur (string= (buffer-name) org-index--occur-buffer-name)))
+
+
+(defun org-index--parse-table ()
+ "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--maxrefnum 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)
+ (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)
+
+ ;; 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))
+
+ ;; check if the table still seems to be sorted mixed
+ (goto-char org-index--below-hline)
+ (when (eq org-index-sort-by 'mixed)
+ (org-index--go-below-hline)
+ (if (string< (org-index--get-or-set-field 'last-accessed)
+ (org-index--get-mixed-time))
+ (org-index--do-sort-index org-index-sort-by)))
+
+ ;; Go through table to find maximum number and do some checking
+ (let ((refnum 0))
+
+ (while (org-at-table-p)
+
+ (setq ref-field (org-index--get-or-set-field 'ref))
+ (setq id-field (org-index--get-or-set-field 'id))
+
+ (if ref-field
+ (if (string-match org-index--ref-regex ref-field)
+ ;; grab number
+ (setq refnum (string-to-number (match-string 1 ref-field)))
+ (kill-whole-line)
+ (message "Removing line from index-table whose ref does not contain a number")))
+
+ ;; check, if higher ref
+ (if (> refnum org-index--maxrefnum) (setq org-index--maxrefnum refnum))
+
+ (forward-line 1)))
+
+ (setq org-index--nextref (format "%s%d%s" org-index--head (1+ org-index--maxrefnum) org-index--tail))
+ ;; go back to initial position
+ (goto-char initial-point))))
+
+
+(defun org-index--refresh-parse-table ()
+ "Fast refresh of selected results of parsing index table."
+
+ (setq org-index--point (marker-position (org-id-find org-index-id 'marker)))
+ (with-current-buffer org-index--buffer
+ (save-excursion
+ (org-index--go-below-hline))))
+
+
+(defun org-index--do-maintain ()
+ "Choose among and perform some tasks to maintain index."
+ (let ((check-what) (max-mini-window-height 1.0) message-text)
+ (setq check-what (intern (org-completing-read "These checks and fixes are available:\n - statistics : compute statistics about index table\n - check : check ids by visiting their nodes\n - duplicates : check index for duplicate rows (ref or id)\n - clean : remove obsolete property org-index-id\n - update : update content of index lines, with an id \nPlease choose: " (list "statistics" "check" "duplicates" "clean" "update") nil t nil nil "statistics")))
+ (message nil)
+
+ (cond
+ ((eq check-what 'check)
+ (setq message-text (or (org-index--check-ids)
+ "No problems found")))
+
+ ((eq check-what 'statistics)
+ (setq message-text (org-index--do-statistics)))
+
+ ((eq check-what 'duplicates)
+ (setq message-text (org-index--find-duplicates)))
+
+ ((eq check-what 'clean)
+ (let ((lines 0))
+ (org-map-entries
+ (lambda ()
+ (when (org-entry-get (point) "org-index-ref")
+ (cl-incf lines)
+ (org-entry-delete (point) "org-index-ref")))
+ nil 'agenda)
+ (setq message-text (format "Removed property 'org-index-ref' from %d lines" lines))))
+
+ ((eq check-what 'update)
+ (if (y-or-n-p "Updating your index will overwrite certain columns with content from the associated heading and category. If unsure, you may try this for a single, already existing line of your index by invoking `add'. Are you SURE to proceed for ALL INDEX LINES ? ")
+ (setq message-text (org-index--update-all-lines))
+ (setq message-text "Canceled."))))
+ message-text))
+
+
+(defun org-index--get-mixed-time ()
+ "Get timestamp for sorting order mixed."
+ (format-time-string
+ (org-time-stamp-format t t)
+ (apply 'encode-time (append '(0 0 0) (nthcdr 3 (decode-time))))))
+
+
+(defun org-index--do-sort-index (sort)
+ "Sort index table according to SORT."
+
+ (let ((is-modified (buffer-modified-p))
+ top
+ bottom
+ mixed-time)
+
+ (unless buffer-read-only
+
+ (message "Sorting index table for %s..." (symbol-name sort))
+ (undo-boundary)
+
+ (let ((message-log-max nil)) ; we have just issued a message, dont need those of sort-subr
+
+ ;; if needed for mixed sort
+ (if (eq sort 'mixed)
+ (setq mixed-time (org-index--get-mixed-time)))
+
+ ;; get boundaries of table
+ (org-index--go-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))
+ (not (org-index--get-or-set-field 'yank))))
+ (org-table-kill-row))
+ (forward-line 1)
+ (setq bottom (point))
+
+ ;; sort lines
+ (save-restriction
+ (narrow-to-region top bottom)
+ (goto-char top)
+ (sort-subr t
+ 'forward-line
+ 'end-of-line
+ (lambda ()
+ (org-index--get-sort-key sort t mixed-time))
+ nil
+ 'string<)
+ (goto-char (point-min))
+
+ ;; restore modification state
+ (set-buffer-modified-p is-modified)))
+
+ (setq org-index--last-sort sort))))
+
+
+(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 ((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)
+ (setq org-index--below-hline (point))))
+
+
+(defun org-index--parse-headings ()
+ "Parse headings of index table."
+
+ (let (field ;; field content
+ field-symbol) ;; and as a symbol
+
+ (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)))
+ (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--valid-headings))
+
+
+(defun org-index--create-missing-index (&rest reasons)
+ "Create a new empty index table with detailed explanation. Argument REASONS explains why."
+
+ (org-index--ask-before-create-index "Cannot find 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"
+ "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 (leave empty for default 'index'): "))
+ (if (string= title "") (setq title "index"))
+
+ (while (progn
+ (setq firstref (read-from-minibuffer "Please enter your first reference-number. This is an integer number preceeded by some and optionally followed by some non-numeric chars; e.g. 'R1', '-1-' or '#1#' (and your initial number does not need to be '1'). The format of your reference-numbers only needs to make sense for yourself, so that you can spot it easily in your texts or write it on a piece of paper; it should however not already appear frequently within your existing notes, to avoid too many false hits when searching.\n\nPlease choose (leave empty for default 'R1'): "))
+ (if (string= firstref "") (setq firstref "R1"))
+ (let (desc)
+ (when (string-match "[[:blank:]]" firstref)
+ (setq desc "Contains whitespace"))
+ (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; please use it only for evaluation.
+")
+ (insert "
+ Below you find your initial index table, which will grow over time.
+"))
+ (insert " You may start using it by adding some lines. Just
+ move to another heading within org, invoke `org-index' and
+ choose the command 'add'. After adding a few nodes, try the
+ command 'occur' to search among them.
+
+ To gain further insight you may invoke the subcommand 'help', or
+ (same content) read the help of `org-index'.
+
+ Within the index table below, the sequence of columns does not
+ matter. You may reorder them in any way you like. You may also
+ add your own columns, which should start with a dot
+ (e.g. '.my-column').
+
+ Invoke `org-customize' to tweak the behaviour of org-index
+ (see the group org-index).
+
+ This node needs not be a top level node; its name is completely
+ at your choice; it is found through its ID only.
+")
+ (unless temporary
+ (insert "
+ Remark: These lines of explanation can be removed at any time.
+"))
+
+ (setq id (org-id-get-create))
+ (insert (format "
+
+ | ref | category | keywords | tags | count | level | last-accessed | created | id | yank |
+ | | | | | | | | | <4> | <4> |
+ |-----+----------+----------+------+-------+-------+---------------+---------+-----+------|
+ | %s | | %s | | | | | %s | %s | |
+
+"
+ firstref
+ title
+ (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
+ (progn
+ (message "Please compare your existing index (upper window) and a temporary new one (lower window) to fix your index")
+ (throw 'new-index nil))
+ (message "This is your new temporary index, use command add to populate, occur to search.")))
+ (progn
+ ;; Only show the new index
+ (pop-to-buffer-same-window buffer)
+ (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)
+ (message "Saved org-index-id '%s' to %s." id (or custom-file
+ user-init-file))
+ (throw 'new-index nil))
+ (let (sq)
+ (setq sq (format "(setq org-index-id \"%s\")" id))
+ (kill-new sq)
+ (message "Did not make the id of this new index permanent; you may want to put\n\n %s\n\ninto your own initialization; it is copied already, just yank it." sq)
+ (throw 'new-index nil))))))))
+
+
+(defun org-index--unfold-buffer ()
+ "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)))
+
+
+(defun org-index--update-line (&optional ref-or-id-or-pos)
+ "Update columns count and last-accessed in line REF-OR-ID-OR-POS."
+
+ (let (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-or-pos
+ (setq initial (point))
+ (goto-char org-index--below-hline)
+ (while (and (org-at-table-p)
+ (not (if (integerp ref-or-id-or-pos)
+ (and (>= ref-or-id-or-pos (line-beginning-position))
+ (< ref-or-id-or-pos (line-end-position)))
+ (or (string= ref-or-id-or-pos (org-index--get-or-set-field 'ref))
+ (string= ref-or-id-or-pos (org-index--get-or-set-field 'id))))))
+ (forward-line)))
+
+ (if (not (org-at-table-p))
+ (error "Did not find reference or id '%s'" ref-or-id-or-pos)
+ (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 (&optional num)
+ "Make current line (or NUM lines) blend well among others."
+ (let (lines)
+ ;; get current content
+ (unless num (setq num 1))
+ (setq lines (delete-and-extract-region (line-beginning-position) (line-end-position num)))
+ ;; create minimum table with fixed-width columns to align and fontify new line
+ (insert (with-temp-buffer
+ (org-set-font-lock-defaults)
+ (insert org-index--headings-visible)
+ ;; fill columns, so that aligning cannot shrink them
+ (goto-char (point-min))
+ (search-forward "|")
+ (while (search-forward " " (line-end-position) t)
+ (replace-match "." nil t))
+ (goto-char (point-min))
+ (while (search-forward ".|." (line-end-position) t)
+ (replace-match " | " nil t))
+ (goto-char (point-min))
+ (while (search-forward "|." (line-end-position) t)
+ (replace-match "| " nil t))
+ (goto-char (point-max))
+ (insert lines)
+ (forward-line 0)
+ (let ((start (point)))
+ (while (re-search-forward "^\s +|-" nil t)
+ (replace-match "| -"))
+ (goto-char start))
+ (org-mode)
+ (org-table-align)
+ (font-lock-fontify-region (point-min) (point-max))
+ (goto-char (point-max))
+ (if (eq -1 (skip-chars-backward "\n"))
+ (delete-char 1))
+ (forward-line (- 1 num))
+ (buffer-substring (line-beginning-position) (line-end-position num))))
+ lines))
+
+
+(defun org-index--promote-current-line ()
+ "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))
+
+ (cl-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 mixed-time)
+ "Get value for sorting from column SORT, optional WITH-REF; if mixes use MIXED-TIME."
+ (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))
+ (if ref-field
+ (progn
+ (string-match org-index--ref-regex ref-field)
+ (setq ref (format
+ "%06d"
+ (string-to-number
+ (match-string 1 ref-field)))))
+ (setq ref "000000")))
+
+ (setq key
+ (cond
+ ((eq sort 'count)
+ (format "%08d" (string-to-number (or (org-index--get-or-set-field 'count) ""))))
+ ((eq sort 'mixed)
+ (let ((last-accessed (org-index--get-or-set-field 'last-accessed)))
+ (unless mixed-time (setq mixed-time (org-index--get-mixed-time)))
+ (concat
+ (if (string< mixed-time last-accessed) last-accessed mixed-time)
+ (format "%08d" (string-to-number (or (org-index--get-or-set-field 'count) ""))))))
+ ((eq sort 'ref)
+ ref)
+ ((memq sort '(id last-accessed 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
+ (if (eq key 'fingerprint)
+ (progn
+ (if value (error "Internal error, pseudo-column fingerprint cannot be set"))
+ (setq field (org-index--get-fingerprint)))
+ (setq field (org-trim (org-table-get-field (cdr (assoc key org-index--columns)) value))))
+ (if (string= field "") (setq field nil))
+
+ (org-no-properties field))))
+
+
+(defun org-index--column-num (key)
+ "Return number of column KEY."
+ (if (numberp key)
+ key
+ (cdr (assoc key org-index--columns))))
+
+
+(defun org-index--make-guarded-search (ref &optional dont-quote)
+ "Make robust search string from REF; DONT-QUOTE it, if requested."
+ (concat "\\_<" (if dont-quote ref (regexp-quote ref)) "\\_>"))
+
+
+(defun org-index--find-duplicates ()
+ "Find duplicate references or ids in index table."
+ (let (ref-duplicates id-duplicates)
+
+ (setq ref-duplicates (org-index--find-duplicates-helper 'ref))
+ (setq id-duplicates (org-index--find-duplicates-helper 'id))
+ (goto-char org-index--below-hline)
+ (if (or ref-duplicates id-duplicates)
+ (progn
+ ;; show results
+ (pop-to-buffer-same-window
+ (get-buffer-create "*org-index-duplicates*"))
+ (when ref-duplicates
+ (insert "These references appear more than once:\n")
+ (mapc (lambda (x) (insert " " x "\n")) ref-duplicates)
+ (insert "\n\n"))
+ (when id-duplicates
+ (insert "These ids appear more than once:\n")
+ (mapc (lambda (x) (insert " " x "\n")) id-duplicates))
+
+ "Some references or ids are duplicates")
+ "No duplicate references or ids found")))
+
+
+(defun org-index--find-duplicates-helper (column)
+ "Helper for `org-index--find-duplicates': Go through table and count given COLUMN."
+ (let (counts duplicates field found)
+
+ ;; go through table
+ (goto-char org-index--below-hline)
+ (while (org-at-table-p)
+
+ ;; get column
+ (setq field (org-index--get-or-set-field column))
+
+ ;; and increment
+ (setq found (assoc field counts))
+ (if found
+ (cl-incf (cdr found))
+ (setq counts (cons (cons field 1) counts)))
+
+ (forward-line))
+
+ (mapc (lambda (x) (if (and (> (cdr x) 1)
+ (car x))
+ (setq duplicates (cons (car x) duplicates)))) counts)
+
+ duplicates))
+
+
+(defun org-index--do-statistics ()
+ "Compute statistics about index table."
+ (let ((total-lines 0) (total-refs 0)
+ ref ref-field min max message)
+
+ ;; go through table
+ (goto-char org-index--below-hline)
+ (while (org-at-table-p)
+
+ ;; get ref
+ (setq ref-field (org-index--get-or-set-field 'ref))
+
+ (when ref-field
+ (string-match org-index--ref-regex ref-field)
+ (setq ref (string-to-number (match-string 1 ref-field)))
+
+ ;; record min and max
+ (if (or (not min) (< ref min)) (setq min ref))
+ (if (or (not max) (> ref max)) (setq max ref))
+
+ (setq total-refs (1+ total-refs)))
+
+ ;; count
+ (setq total-lines (1+ total-lines))
+
+ (forward-line))
+
+ (setq message (format "%d Lines in index table. First reference is %s, last %s; %d of them are used (%d percent)"
+ total-lines
+ (format org-index--ref-format min)
+ (format org-index--ref-format max)
+ total-refs
+ (truncate (* 100 (/ (float total-refs) (1+ (- max min)))))))
+
+ (goto-char org-index--below-hline)
+ message))
+
+
+(defun org-index--do-add-or-update (&optional create-ref tag-with-ref)
+ "For current node or current line in index, add or update in index table.
+CREATE-REF and TAG-WITH-REF if given."
+
+ (let* (id id-from-index ref args yank ret)
+
+ (org-index--save-positions)
+ (unless (or org-index--within-index-node
+ org-index--within-occur)
+ (org-back-to-heading))
+
+ ;; try to do the same things from within index and from outside
+ (if org-index--within-index-node
+
+ (progn
+ (unless (org-at-table-p)
+ (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 args)
+ (setq yank (org-index--get-or-set-field org-index-yank-after-add))
+
+ (setq ret
+ (if ref
+ (cons (format "Updated index line %s" ref) yank)
+ (cons "Updated index line" nil))))
+
+ (setq id (org-id-get-create))
+ (org-index--refresh-parse-table)
+ (setq id-from-index (org-index--on 'id id id))
+ (setq ref (org-index--on 'id id (org-index--get-or-set-field 'ref)))
+
+ (if tag-with-ref
+ (org-toggle-tag (format "%s%d%s" org-index--head tag-with-ref org-index--tail) 'on))
+ (setq args (org-index--collect-values-for-add-update id))
+
+ (when (and create-ref
+ (not ref))
+ (setq ref org-index--nextref)
+ (setq args (plist-put args 'ref ref)))
+
+
+ (if id-from-index
+ ;; already have an id in index, find it and update fields
+ (progn
+
+ (org-index--on
+ 'id id
+ (org-index--write-fields args)
+ (setq yank (org-index--get-or-set-field org-index-yank-after-add)))
+
+ (setq ret
+ (if ref
+ (cons (format "Updated index line %s" ref) yank)
+ (cons "Updated index line" nil))))
+
+ ;; no id here, create new line in index
+ (if ref (setq ref (plist-put args 'ref org-index--nextref)))
+ (setq yank (apply 'org-index--do-new-line args))
+
+ (setq ret
+ (if ref
+ (cons
+ (format "Added new index line %s" ref)
+ (concat yank " "))
+ (cons
+ "Added new index line"
+ nil)))))
+
+ (org-index--restore-positions)
+
+ ret))
+
+
+(defun org-index--check-ids ()
+ "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"))
+ (cl-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 kvs)
+ (cl-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 'id id))
+ content)
+
+ (dolist (col (mapcar 'car org-index--columns))
+
+ (setq content "")
+
+ (cond
+ ((eq col 'keywords)
+ (if org-index-copy-heading-to-keywords
+ (setq content (nth 4 (org-heading-components))))
+
+ ;; Shift ref and timestamp ?
+ (if org-index-strip-ref-and-date-from-heading
+ (dotimes (i 2)
+ (if (or (string-match (concat "^\\s-*" org-index--ref-regex) content)
+ (string-match (concat "^\\s-*" org-ts-regexp-both) content))
+ (setq content (substring content (match-end 0)))))))
+
+ ((eq col 'category)
+ (setq content (or category org-index--category-before)))
+
+ ((eq col 'level)
+ (setq content (number-to-string (org-outline-level))))
+
+ ((eq col 'tags)
+ (setq content (org-get-tags-string))))
+
+ (unless (string= content "")
+ (setq args (plist-put args col content))))
+
+ (if (not silent)
+ (let ((args-edited (org-index--collect-values-from-user org-index-edit-on-add args)))
+ (setq args (append args-edited args))))
+
+ args))
+
+
+(defun org-index--collect-values-for-add-update-remote (id)
+ "Wrap `org-index--collect-values-for-add-update' by prior moving to remote node identified by ID."
+
+ (let (marker point args)
+
+ (setq marker (org-id-find id t))
+ ;; 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--collect-values-from-user (cols &optional defaults)
+ "Collect values for adding a new yank-line.
+Argument COLS gives list of columns to edit.
+Optional argument DEFAULTS gives default values."
+
+ (let (content args)
+
+ (dolist (col cols)
+
+ (setq content "")
+
+ (setq content (read-from-minibuffer
+ (format "Enter text for column '%s': " (symbol-name col))
+ (plist-get col defaults)))
+
+ (unless (string= content "")
+ (setq args (plist-put args col content))))
+ args))
+
+
+(defun org-index--write-fields (kvs)
+ "Update current line with values from KVS (keys-values)."
+ (while kvs
+ (org-index--get-or-set-field (car kvs) (org-trim (cadr kvs)))
+ (setq kvs (cddr kvs))))
+
+
+(defun org-index--do-kill ()
+ "Perform command kill from within occur, index or node."
+
+ (let (id ref chars-deleted-index text-deleted-from pos-in-index)
+
+ (org-index--save-positions)
+ (unless (or org-index--within-index-node
+ org-index--within-occur)
+ (org-back-to-heading))
+
+ ;; Collect information: What should be deleted ?
+ (if (or org-index--within-occur
+ org-index--within-index-node)
+
+ (progn
+ (if org-index--within-index-node
+ ;; In index
+ (setq pos-in-index (point))
+ ;; In occur
+ (setq pos-in-index (get-text-property (point) 'org-index-lbp))
+ (org-index--occur-test-stale pos-in-index)
+ (set-buffer org-index--buffer)
+ (goto-char pos-in-index))
+ ;; In Index (maybe moved there)
+ (setq id (org-index--get-or-set-field 'id))
+ (setq ref (org-index--get-or-set-field 'ref)))
+
+ ;; At a headline
+ (setq id (org-entry-get (point) "ID"))
+ (setq ref (org-index--ref-from-id id))
+ (setq pos-in-index (org-index--on 'id id (point)))
+ (unless pos-in-index (error "This node is not in index")))
+
+ ;; Remark: Current buffer is not certain here, but we have all the information to delete
+
+ ;; Delete from node
+ (when id
+ (let ((m (org-id-find id 'marker)))
+ (set-buffer (marker-buffer m))
+ (goto-char m)
+ (move-marker m nil)
+ (unless (string= (org-id-get) id)
+ (error "Could not find node with id %s" id)))
+
+ (org-index--delete-any-ref-from-tags)
+ (if ref (org-index--delete-ref-from-heading ref))
+ (setq text-deleted-from (cons "node" text-deleted-from)))
+
+ ;; Delete from index
+ (set-buffer org-index--buffer)
+ (unless pos-in-index "Internal error, pos-in-index should be defined here")
+ (goto-char pos-in-index)
+ (setq chars-deleted-index (length (delete-and-extract-region (line-beginning-position) (line-beginning-position 2))))
+ (setq text-deleted-from (cons "index" text-deleted-from))
+
+ ;; Delete from occur only if we started there, accept that it will be stale otherwise
+ (if org-index--within-occur
+ (let ((inhibit-read-only t))
+ (set-buffer org-index--occur-buffer-name)
+ (delete-region (line-beginning-position) (line-beginning-position 2))
+ ;; correct positions
+ (while (org-at-table-p)
+ (put-text-property (line-beginning-position) (line-end-position) 'org-index-lbp
+ (- (get-text-property (point) 'org-index-lbp) chars-deleted-index))
+ (forward-line))
+ (setq text-deleted-from (cons "occur" text-deleted-from))))
+
+ (org-index--restore-positions)
+ (concat "Deleted from: " (mapconcat 'identity (sort text-deleted-from 'string<) ","))))
+
+
+(defun org-index--save-positions ()
+ "Save current buffer and positions in index- and current buffer; not in occur-buffer."
+
+ (let (cur-buf cur-mrk idx-pnt idx-mrk)
+ (setq cur-buf (current-buffer))
+ (setq cur-mrk (point-marker))
+ (set-buffer org-index--buffer)
+ (if (string= (org-id-get) org-index-id)
+ (setq idx-pnt (point))
+ (setq idx-mrk (point-marker)))
+ (set-buffer cur-buf)
+ (setq org-index--saved-positions (list cur-buf cur-mrk idx-pnt idx-mrk))))
+
+
+(defun org-index--restore-positions ()
+ "Restore positions as saved by `org-index--save-positions'."
+
+ (cl-multiple-value-bind
+ (cur-buf cur-mrk idx-pnt idx-mrk buf)
+ org-index--saved-positions
+ (setq buf (current-buffer))
+ (set-buffer cur-buf)
+ (goto-char cur-mrk)
+ (set-buffer org-index--buffer)
+ (goto-char (or idx-pnt idx-mrk))
+ (set-buffer buf))
+ (setq org-index--saved-positions nil))
+
+
+(defun org-index--delete-ref-from-heading (ref)
+ "Delete given REF from current heading."
+ (save-excursion
+ (end-of-line)
+ (let ((end (point)))
+ (beginning-of-line)
+ (when (search-forward ref end t)
+ (delete-char (- (length ref)))
+ (just-one-space)))))
+
+
+(defun org-index--delete-any-ref-from-tags ()
+ "Delete any reference from list of tags."
+ (let (new-tags)
+ (mapc (lambda (tag)
+ (unless (string-match org-index--ref-regex tag)
+ (setq new-tags (cons tag new-tags) )))
+ (org-get-tags))
+ (org-set-tags-to new-tags)))
+
+
+(defun org-index--go (&optional column value)
+ "Position cursor on index line where COLUMN equals VALUE.
+Return t or nil, leave point on line or at top of table, needs to be in buffer initially."
+ (let (found)
+
+ (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--find-id (id &optional other)
+ "Perform command head: Find node with REF or ID and present it.
+If OTHER in separate window."
+
+ (let (message marker)
+
+ (setq marker (org-id-find id t))
+
+ (if marker
+ (progn
+ (org-index--update-line id)
+ (if other
+ (progn
+ (pop-to-buffer (marker-buffer marker)))
+ (pop-to-buffer-same-window (marker-buffer marker)))
+
+ (goto-char marker)
+ (org-reveal t)
+ (org-show-entry)
+ (recenter)
+ (unless (string= (org-id-get) id)
+ (setq message (format "Could not go to node with id %s (narrowed ?)" id)))
+ (setq message "Found headline"))
+ (setq message (format "Did not find node with %s" id)))
+ message))
+
+
+(defun org-index--do-occur ()
+ "Perform command occur."
+ (let ((word "") ; last word to search for growing and shrinking on keystrokes
+ (prompt "Search for: ")
+ (these-commands " NOTE: If you invoke the org-index subcommands edit or kill from within the occur buffer, the index is updated accordingly.")
+ (lines-wanted (window-body-height))
+ (lines-found 0) ; number of lines found
+ words ; list words that should match
+ occur-buffer
+ begin ; position of first line
+ narrow ; start of narrowed buffer
+ help-text ; cons with help text short and long
+ search-text ; description of text to search for
+ done ; true, if loop is done
+ in-c-backspace ; true, while processing C-backspace
+ help-overlay ; Overlay with help text
+ last-point ; Last position before end of search
+ initial-frame ; Frame when starting occur
+ key ; input from user in various forms
+ key-sequence
+ key-sequence-raw)
+
+
+ ;; make and show buffer
+ (if (get-buffer org-index--occur-buffer-name)
+ (kill-buffer org-index--occur-buffer-name))
+ (setq occur-buffer (make-indirect-buffer org-index--buffer org-index--occur-buffer-name))
+ (pop-to-buffer-same-window occur-buffer)
+ (setq initial-frame (selected-frame))
+
+ ;; avoid modifying direct buffer
+ (setq buffer-read-only t)
+ (toggle-truncate-lines 1)
+ (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 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
+ (concat
+ (propertize "Incremental occur" 'face 'org-todo)
+ (propertize "; ? toggles help and headlines.\n" 'face 'org-agenda-dimmed-todo-face))
+ (concat
+ (propertize
+ (org-index--wrap
+ (concat
+ "Normal keys add to search word; <space> or <comma> start additional word; <backspace> erases last char, <C-backspace> last word; <return> jumps to heading, <tab> jumps to heading in other window, <S-return> jumps to matching line in index; all other keys end search." these-commands "\n"))
+ 'face 'org-agenda-dimmed-todo-face)
+ org-index--headings)))
+
+ ;; insert overlays for help text and to cover unsearched lines
+ (setq help-overlay (make-overlay (point-min) begin))
+ (overlay-put help-overlay 'display (car help-text))
+ (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)) ","))
+ (message "foo")
+
+ ;; read key, if selected frame has not changed
+ (if (eq initial-frame (selected-frame))
+ (progn
+ (setq key-sequence
+ (let ((echo-keystrokes 0)
+ (full-prompt (format "%s%s%s"
+ prompt
+ search-text
+ (if (string= search-text "") "" " "))))
+ (read-key-sequence full-prompt nil nil t t)))
+ (setq key (key-description key-sequence))
+ (setq key-sequence-raw (this-single-command-raw-keys)))
+ (setq done t)
+ (setq key-sequence nil)
+ (setq key nil)
+ (setq key-sequence-raw nil)))
+
+
+ (cond
+
+
+ ((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
+ (unless (string= word "")
+ (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-raw))
+ (message key))
+
+ ;; postprocessing
+ (setq last-point (point))
+
+ ;; For performance reasons do not show matching lines for rest of table. So no code here.
+
+ ;; make permanent copy
+ ;; copy visible lines
+ (let ((lines-collected 0)
+ keymap line all-lines all-lines-lbp header-lines lbp)
+
+ (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 lbp (line-beginning-position))
+ (setq line (buffer-substring-no-properties lbp (line-end-position)))
+ (unless (string= line "")
+ (cl-incf lines-collected)
+ (setq all-lines (cons (concat line
+ "\n")
+ all-lines))
+ (setq all-lines-lbp (cons lbp all-lines-lbp)))
+ (forward-line 1))
+
+ (kill-buffer org-index--occur-buffer-name) ; cannot keep this buffer; might become stale soon
+
+ ;; create new buffer
+ (setq occur-buffer (get-buffer-create org-index--occur-buffer-name))
+ (pop-to-buffer-same-window occur-buffer)
+ (insert org-index--headings)
+ (setq header-lines (line-number-at-pos))
+
+ ;; insert into new buffer
+ (save-excursion
+ (apply 'insert (reverse all-lines))
+ (if (= lines-collected lines-wanted)
+ (insert "\n(more lines omitted)\n")))
+ (setq org-index--occur-lines-collected lines-collected)
+
+ (org-mode)
+ (setq truncate-lines t)
+ (if all-lines (org-index--align-and-fontify-current-line (length all-lines)))
+ (font-lock-ensure)
+ (font-lock-flush)
+ (when all-lines-lbp
+ (while (not (org-at-table-p))
+ (forward-line -1))
+ (while all-lines-lbp
+ (put-text-property (line-beginning-position) (line-end-position) 'org-index-lbp (car all-lines-lbp))
+ (setq all-lines-lbp (cdr all-lines-lbp))
+ (forward-line -1)))
+
+ ;; prepare help text
+ (goto-char (point-min))
+ (forward-line (1- header-lines))
+ (setq org-index--occur-help-overlay (make-overlay (point-min) (point)))
+ (setq org-index--occur-help-text
+ (cons
+ (org-index--wrap
+ (propertize "Search is done; ? toggles help and headlines.\n" 'face 'org-agenda-dimmed-todo-face))
+ (concat
+ (org-index--wrap
+ (propertize
+ (format
+ (concat "Search is done."
+ (if (< lines-collected lines-wanted)
+ " Showing all %d matches for "
+ " Showing one window of matches for ")
+ "\"" search-text
+ "\". <return> jumps to heading, <tab> jumps to heading in other window, <S-return> jumps to matching line in index, <space> increments count.\n" these-commands "\n")
+ (length all-lines))
+ 'face 'org-agenda-dimmed-todo-face))
+ org-index--headings)))
+
+ (overlay-put org-index--occur-help-overlay 'display (car org-index--occur-help-text))
+
+ ;; 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-action)))))
+ (list "<return>" "RET"))
+
+ (define-key keymap (kbd "<tab>")
+ (lambda () (interactive)
+ (message (org-index--occur-action t))))
+
+ (define-key keymap (kbd "SPC")
+ (lambda () (interactive)
+ (org-index--refresh-parse-table)
+ ;; increment in index
+ (let ((ref (org-index--get-or-set-field 'ref))
+ count)
+ (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)
+ (let ((pos (get-text-property (point) 'org-index-lbp)))
+ (org-index--refresh-parse-table)
+ (org-index--occur-test-stale pos)
+ (pop-to-buffer org-index--buffer)
+ (goto-char pos)
+ (org-reveal t)
+ (org-index--update-current-line)
+ (beginning-of-line))))
+
+ (define-key keymap (kbd "?")
+ (lambda () (interactive)
+ (org-index--refresh-parse-table)
+ (setq-local org-index--occur-help-text (cons (cdr org-index--occur-help-text) (car org-index--occur-help-text)))
+ (overlay-put org-index--occur-help-overlay 'display (car org-index--occur-help-text))))
+
+ (use-local-map keymap))))
+
+
+(defun org-index--occur-test-stale (pos)
+ "Test, if current line in occur buffer has become stale at POS."
+ (let (here there)
+ (org-index--refresh-parse-table)
+ (setq here (org-index--line-in-canonical-form))
+ (with-current-buffer org-index--buffer
+ (goto-char pos)
+ (setq there (org-index--line-in-canonical-form)))
+ (unless (string= here there)
+ (error "Occur buffer has become stale"))))
+
+
+(defun org-index--line-in-canonical-form ()
+ "Return current line in its canonical form."
+ (org-trim (substring-no-properties (replace-regexp-in-string "\s +" " " (buffer-substring (line-beginning-position) (line-beginning-position 2))))))
+
+
+(defun org-index--wrap (text)
+ "Wrap TEXT at fill column."
+ (with-temp-buffer
+ (insert text)
+ (fill-region (point-min) (point-max) nil t)
+ (buffer-string)))
+
+
+(defun org-index--occur-action (&optional other)
+ "Helper for `org-index--occur', find heading with ref or id; if OTHER, in other window; or copy yank column."
+ (if (org-at-table-p)
+ (let ((id (org-index--get-or-set-field 'id))
+ (ref (org-index--get-or-set-field 'ref))
+ (yank (org-index--get-or-set-field 'yank)))
+ (if id
+ (org-index--find-id id other)
+ (if ref
+ (progn
+ (org-mark-ring-goto)
+ (format "Found reference %s (no node is associated)" ref))
+ (if yank
+ (progn
+ (org-index--update-line (get-text-property (point) 'org-index-lbp))
+ (setq yank (replace-regexp-in-string (regexp-quote "\\vert") "|" yank nil 'literal))
+ (kill-new yank)
+ (org-mark-ring-goto)
+ (format "Copied '%s' (no node is associated)" yank))
+ (error "Internal error, this line contains neither id, nor reference, nor text to yank")))))
+ (message "Not at table")))
+
+
+(defun org-index--hide-with-overlays (words lines-wanted)
+ "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))
+ (cl-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 (cl-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'."
+
+ ;; insert ref or id as last or first line, depending on sort-column
+ (goto-char org-index--below-hline)
+ (if (eq org-index-sort-by 'count)
+ (progn
+ (while (org-at-table-p)
+ (forward-line))
+ (forward-line -1)
+ (org-table-insert-row t))
+ (org-table-insert-row))
+
+ ;; insert some of the standard values
+ (org-table-goto-column (org-index--column-num 'created))
+ (org-insert-time-stamp nil nil t)
+ (org-table-goto-column (org-index--column-num 'count))
+ (insert "1"))
+
+
+(defun org-index--sort-silent ()
+ "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-sort-by)
+ (org-table-align)
+ (remove-hook 'before-save-hook 'org-index--sort-silent))))
+
+
+(defun org-index--copy-visible (beg end)
+ "Copy the visible parts of the region between BEG and END 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-interactive-query.el b/contrib/lisp/org-interactive-query.el
index 644132c..928c801 100644
--- a/contrib/lisp/org-interactive-query.el
+++ b/contrib/lisp/org-interactive-query.el
@@ -1,6 +1,6 @@
;;; org-interactive-query.el --- Interactive modification of agenda query
;;
-;; Copyright 2007-2014 Free Software Foundation, Inc.
+;; Copyright 2007-2016 Free Software Foundation, Inc.
;;
;; Author: Christopher League <league at contrapunctus dot net>
;; Version: 1.0
@@ -81,7 +81,7 @@ not change the current one."
(split-window-vertically)
(org-switch-to-buffer-other-window (get-buffer-create " *Org tags*")))
(erase-buffer)
- (org-set-local 'org-done-keywords done-keywords)
+ (setq-local org-done-keywords done-keywords)
(insert "Query: " current "\n")
(org-agenda-query-op-line op)
(insert "\n\n")
diff --git a/contrib/lisp/org-jira.el b/contrib/lisp/org-jira.el
deleted file mode 100644
index 43edd08..0000000
--- a/contrib/lisp/org-jira.el
+++ b/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-learn.el b/contrib/lisp/org-learn.el
index 1755e71..e47c8f8 100644
--- a/contrib/lisp/org-learn.el
+++ b/contrib/lisp/org-learn.el
@@ -1,6 +1,6 @@
;;; org-learn.el --- Implements SuperMemo's incremental learning algorithm
-;; Copyright (C) 2009-2014 Free Software Foundation, Inc.
+;; Copyright (C) 2009-2016 Free Software Foundation, Inc.
;; Author: John Wiegley <johnw at gnu dot org>
;; Keywords: outlines, hypermedia, calendar, wp
diff --git a/contrib/lisp/org-license.el b/contrib/lisp/org-license.el
new file mode 100644
index 0000000..dc1d797
--- a/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-2016 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-link-edit.el b/contrib/lisp/org-link-edit.el
new file mode 100644
index 0000000..431c934
--- a/dev/null
+++ b/contrib/lisp/org-link-edit.el
@@ -0,0 +1,327 @@
+;;; org-link-edit.el --- Slurp and barf with Org links -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2015 Kyle Meyer <kyle@kyleam.com>
+
+;; Author: Kyle Meyer <kyle@kyleam.com>
+;; URL: https://github.com/kyleam/org-link-edit
+;; Keywords: convenience
+;; Version: 1.0.1
+;; Package-Requires: ((cl-lib "0.5") (org "8.2"))
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; Org Link Edit provides Paredit-inspired slurping and barfing
+;; commands for Org link descriptions.
+;;
+;; There are four commands, all which operate when point is on an Org
+;; link.
+;;
+;; - org-link-edit-forward-slurp
+;; - org-link-edit-backward-slurp
+;; - org-link-edit-forward-barf
+;; - org-link-edit-backward-barf
+;;
+;; Org Link Edit doesn't bind these commands to any keys. Finding
+;; good keys for these commands is difficult because, while it's
+;; convenient to be able to quickly repeat these commands, they won't
+;; be used frequently enough to be worthy of a short, repeat-friendly
+;; binding. Using Hydra [1] provides a nice solution to this. After
+;; an initial key sequence, any of the commands will be repeatable
+;; with a single key. (Plus, you get a nice interface that displays
+;; the key for each command.) Below is one example of how you could
+;; configure this.
+;;
+;; (define-key org-mode-map YOUR-KEY
+;; (defhydra hydra-org-link-edit ()
+;; "Org Link Edit"
+;; ("j" org-link-edit-forward-slurp "forward slurp")
+;; ("k" org-link-edit-forward-barf "forward barf")
+;; ("u" org-link-edit-backward-slurp "backward slurp")
+;; ("i" org-link-edit-backward-barf "backward barf")
+;; ("q" nil "cancel")))
+;;
+;; [1] https://github.com/abo-abo/hydra
+
+;;; Code:
+
+(require 'org)
+(require 'org-element)
+(require 'cl-lib)
+
+(defun org-link-edit--get-link-data ()
+ "Return list with information about the link at point.
+The list includes
+- the position at the start of the link
+- the position at the end of the link
+- the link text
+- the link description (nil when on a plain link)"
+ (let ((el (org-element-context)))
+ ;; Don't use `org-element-lineage' because it isn't available
+ ;; until Org version 8.3.
+ (while (and el (not (memq (car el) '(link))))
+ (setq el (org-element-property :parent el)))
+ (unless (eq (car el) 'link)
+ (user-error "Point is not on a link"))
+ (save-excursion
+ (goto-char (org-element-property :begin el))
+ (cond
+ ;; Use match-{beginning,end} because match-end is consistently
+ ;; positioned after ]], while the :end property is positioned
+ ;; at the next word on the line, if one is present.
+ ((looking-at org-bracket-link-regexp)
+ (list (match-beginning 0)
+ (match-end 0)
+ (org-link-unescape (match-string-no-properties 1))
+ (or (and (match-end 3)
+ (match-string-no-properties 3))
+ "")))
+ ((looking-at org-plain-link-re)
+ (list (match-beginning 0)
+ (match-end 0)
+ (org-link-unescape (match-string-no-properties 0))
+ nil))
+ (t
+ (error "What am I looking at?"))))))
+
+(defun org-link-edit--forward-blob (n &optional no-punctuation)
+ "Move forward N blobs (backward if N is negative).
+
+A block of non-whitespace characters is a blob. If
+NO-PUNCTUATION is non-nil, trailing punctuation characters are
+not considered part of the blob when going in the forward
+direction.
+
+If the edge of the buffer is reached before completing the
+movement, return nil. Otherwise, return t."
+ (let* ((forward-p (> n 0))
+ (nblobs (abs n))
+ (skip-func (if forward-p 'skip-syntax-forward 'skip-syntax-backward))
+ skip-func-retval)
+ (while (/= nblobs 0)
+ (funcall skip-func " ")
+ (setq skip-func-retval (funcall skip-func "^ "))
+ (setq nblobs (1- nblobs)))
+ (when (and forward-p no-punctuation)
+ (let ((punc-tail-offset (save-excursion (skip-syntax-backward "."))))
+ ;; Don't consider trailing punctuation as part of the blob
+ ;; unless the whole blob consists of punctuation.
+ (unless (= skip-func-retval (- punc-tail-offset))
+ (goto-char (+ (point) punc-tail-offset)))))
+ (/= skip-func-retval 0)))
+
+;;;###autoload
+(defun org-link-edit-forward-slurp (&optional n)
+ "Slurp N trailing blobs into link's description.
+
+ The \[\[http://orgmode.org/\]\[Org mode\]\] site
+
+ |
+ v
+
+ The \[\[http://orgmode.org/\]\[Org mode site\]\]
+
+A blob is a block of non-whitespace characters. When slurping
+forward, trailing punctuation characters are not considered part
+of a blob.
+
+After slurping, return the slurped text and move point to the
+beginning of the link.
+
+If N is negative, slurp leading blobs instead of trailing blobs."
+ (interactive "p")
+ (setq n (or n 1))
+ (cond
+ ((= n 0))
+ ((< n 0)
+ (org-link-edit-backward-slurp (- n)))
+ (t
+ (cl-multiple-value-bind (beg end link desc) (org-link-edit--get-link-data)
+ (goto-char (save-excursion
+ (goto-char end)
+ (or (org-link-edit--forward-blob n 'no-punctuation)
+ (user-error "Not enough blobs after the link"))
+ (point)))
+ (let ((slurped (buffer-substring-no-properties end (point))))
+ (setq slurped (replace-regexp-in-string "\n+" " " slurped))
+ (when (and (= (length desc) 0)
+ (string-match "^\\s-+\\(.*\\)" slurped))
+ (setq slurped (match-string 1 slurped)))
+ (setq desc (concat desc slurped)
+ end (+ end (length slurped)))
+ (delete-region beg (point))
+ (insert (org-make-link-string link desc))
+ (goto-char beg)
+ slurped)))))
+
+;;;###autoload
+(defun org-link-edit-backward-slurp (&optional n)
+ "Slurp N leading blobs into link's description.
+
+ The \[\[http://orgmode.org/\]\[Org mode\]\] site
+
+ |
+ v
+
+ \[\[http://orgmode.org/\]\[The Org mode\]\] site
+
+A blob is a block of non-whitespace characters.
+
+After slurping, return the slurped text and move point to the
+beginning of the link.
+
+If N is negative, slurp trailing blobs instead of leading blobs."
+ (interactive "p")
+ (setq n (or n 1))
+ (cond
+ ((= n 0))
+ ((< n 0)
+ (org-link-edit-forward-slurp (- n)))
+ (t
+ (cl-multiple-value-bind (beg end link desc) (org-link-edit--get-link-data)
+ (goto-char (save-excursion
+ (goto-char beg)
+ (or (org-link-edit--forward-blob (- n))
+ (user-error "Not enough blobs before the link"))
+ (point)))
+ (let ((slurped (buffer-substring-no-properties (point) beg)))
+ (when (and (= (length desc) 0)
+ (string-match "\\(.*\\)\\s-+$" slurped))
+ (setq slurped (match-string 1 slurped)))
+ (setq slurped (replace-regexp-in-string "\n+" " " slurped))
+ (setq desc (concat slurped desc)
+ beg (- beg (length slurped)))
+ (delete-region (point) end)
+ (insert (org-make-link-string link desc))
+ (goto-char beg)
+ slurped)))))
+
+(defun org-link-edit--split-first-blobs (string n)
+ "Split STRING into (N first blobs . other) cons cell.
+'N first blobs' contains all text from the start of STRING up to
+the start of the N+1 blob. 'other' includes the remaining text
+of STRING. If the number of blobs in STRING is fewer than N,
+'other' is nil."
+ (when (< n 0) (user-error "N cannot be negative"))
+ (with-temp-buffer
+ (insert string)
+ (goto-char (point-min))
+ (with-syntax-table org-mode-syntax-table
+ (let ((within-bound (org-link-edit--forward-blob n)))
+ (skip-syntax-forward " ")
+ (cons (buffer-substring 1 (point))
+ (and within-bound
+ (buffer-substring (point) (point-max))))))))
+
+(defun org-link-edit--split-last-blobs (string n)
+ "Split STRING into (other . N last blobs) cons cell.
+'N last blobs' contains all text from the end of STRING back to
+the end of the N+1 last blob. 'other' includes the remaining
+text of STRING. If the number of blobs in STRING is fewer than
+N, 'other' is nil."
+ (when (< n 0) (user-error "N cannot be negative"))
+ (with-temp-buffer
+ (insert string)
+ (goto-char (point-max))
+ (with-syntax-table org-mode-syntax-table
+ (let ((within-bound (org-link-edit--forward-blob (- n))))
+ (skip-syntax-backward " ")
+ (cons (and within-bound
+ (buffer-substring 1 (point)))
+ (buffer-substring (point) (point-max)))))))
+
+;;;###autoload
+(defun org-link-edit-forward-barf (&optional n)
+ "Barf N trailing blobs from link's description.
+
+ The \[\[http://orgmode.org/\]\[Org mode\]\] site
+
+ |
+ v
+
+ The \[\[http://orgmode.org/\]\[Org\]\] mode site
+
+A blob is a block of non-whitespace characters.
+
+After barfing, return the barfed text and move point to the
+beginning of the link.
+
+If N is negative, barf leading blobs instead of trailing blobs."
+ (interactive "p")
+ (setq n (or n 1))
+ (cond
+ ((= n 0))
+ ((< n 0)
+ (org-link-edit-backward-barf (- n)))
+ (t
+ (cl-multiple-value-bind (beg end link desc) (org-link-edit--get-link-data)
+ (when (= (length desc) 0)
+ (user-error "Link has no description"))
+ (pcase-let ((`(,new-desc . ,barfed) (org-link-edit--split-last-blobs
+ desc n)))
+ (unless new-desc (user-error "Not enough blobs in description"))
+ (delete-region beg end)
+ (insert (org-make-link-string link new-desc))
+ (if (string= new-desc "")
+ ;; Two brackets are dropped when an empty description is
+ ;; passed to `org-make-link-string'.
+ (progn (goto-char (- end (+ 2 (length desc))))
+ (setq barfed (concat " " barfed)))
+ (goto-char (- end (- (length desc) (length new-desc)))))
+ (insert barfed)
+ (goto-char beg)
+ barfed)))))
+
+;;;###autoload
+(defun org-link-edit-backward-barf (&optional n)
+ "Barf N leading blobs from link's description.
+
+ The \[\[http://orgmode.org/\]\[Org mode\]\] site
+
+ |
+ v
+
+ The Org \[\[http://orgmode.org/\]\[mode\]\] site
+
+A blob is a block of non-whitespace characters.
+
+After barfing, return the barfed text and move point to the
+beginning of the link.
+
+If N is negative, barf trailing blobs instead of leading blobs."
+ (interactive "p")
+ (setq n (or n 1))
+ (cond
+ ((= n 0))
+ ((< n 0)
+ (org-link-edit-forward-barf (- n)))
+ (t
+ (cl-multiple-value-bind (beg end link desc) (org-link-edit--get-link-data)
+ (when (= (length desc) 0)
+ (user-error "Link has no description"))
+ (pcase-let ((`(,barfed . ,new-desc) (org-link-edit--split-first-blobs
+ desc n)))
+ (unless new-desc (user-error "Not enough blobs in description"))
+ (delete-region beg end)
+ (insert (org-make-link-string link new-desc))
+ (when (string= new-desc "")
+ (setq barfed (concat barfed " ")))
+ (goto-char beg)
+ (insert barfed)
+ (goto-char (+ beg (length barfed)))
+ barfed)))))
+
+(provide 'org-link-edit)
+;;; org-link-edit.el ends here
diff --git a/contrib/lisp/org-mac-link.el b/contrib/lisp/org-mac-link.el
index fef6692..ae2def3 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.
+;; Copyright (c) 2010-2016 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
@@ -18,6 +18,18 @@
;; Author: Mike McLean <mike.mclean@pobox.com>
;; Add support for Microsoft Outlook for Mac as Org mode links
;;
+;; Version: 1.3
+;; Author: Alan Schmitt <alan.schmitt@polytechnique.org>
+;; Consistently use `org-mac-paste-applescript-links'
+;;
+;; Version 1.4
+;; Author: Mike McLean <mike.mclean@pobox.com>
+;; Make the path to Microsoft Outlook a `defcustom'
+;;
+;; Version 1.5
+;; Author: Mike McLean <mike.mclean@pobox.com>
+;; Add Support for Evernote
+;;
;; This file is not part of GNU Emacs.
;;
;; This program is free software; you can redistribute it and/or modify
@@ -57,6 +69,8 @@
;; 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
+;; Evernote.app - Grab a link to the selected Evernote item(s); open Evernote item by ID
;;
;;
;; Installation:
@@ -86,61 +100,72 @@
(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-outlook-path "/Applications/Microsoft Outlook.app"
+ "The path to the installed copy of Microsoft Outlook.app. Do not escape spaces as the AppleScript call will quote this string."
+ :tag "Path to Microsoft Outlook"
+ :group 'org-mac-link
+ :type 'string)
+
+(defcustom org-mac-grab-devonthink-app-p t
+ "Add menu option [d]EVONthink to grab links from DEVONthink Pro Office.app."
+ :tag "Grab DEVONthink Pro Office.app links"
+ :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,27 +173,50 @@ 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)
+(defcustom org-mac-grab-Acrobat-app-p t
+ "Add menu option [A]crobat to grab page links from Acrobat.app."
+ :tag "Grab Acrobat.app page links"
+ :group 'org-mac-link
+ :type 'boolean)
+
(defgroup org-mac-flagged-mail nil
- "Options 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)
+(defcustom org-mac-grab-Evernote-app-p
+ (< 0 (length (shell-command-to-string
+ "mdfind kMDItemCFBundleIdentifier == 'com.evernote.Evernote'")))
+ "Add menu option [e]vernote to grab note links from Evernote.app."
+ :tag "Grab Evernote.app note links"
+ :group 'org-mac-link
+ :type 'boolean)
+
+(defcustom org-mac-evernote-path (replace-regexp-in-string (rx (* (any " \t\n")) eos)
+ ""
+ (shell-command-to-string
+ "mdfind kMDItemCFBundleIdentifier == 'com.evernote.Evernote'"))
+ "The path to the installed copy of Evernote.app. Do not escape spaces as the AppleScript call will quote this string."
+ :tag "Path to Evernote"
+ :group 'org-mac-link
+ :type 'string)
+
;; In mac.c, removed in Emacs 23.
(declare-function do-applescript "org-mac-message" (script))
@@ -185,34 +233,41 @@ 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)
+ ("e" "evernote" org-mac-evernote-note-insert-selected ,org-mac-grab-Evernote-app-p)
+ ("t" "ogether" org-mac-together-insert-selected ,org-mac-grab-Together-app-p)
+ ("S" "kim" org-mac-skim-insert-page ,org-mac-grab-Skim-app-p)
+ ("A" "crobat" org-mac-acrobat-insert-page ,org-mac-grab-Acrobat-app-p)))
(menu-string (make-string 0 ?x))
input)
;; Create the menu string for the keymap
- (mapc '(lambda (descriptor)
+ (mapc (lambda (descriptor)
(when (elt descriptor 3)
- (setf menu-string (concat menu-string "[" (elt descriptor 0) "]" (elt descriptor 1) " "))))
+ (setf menu-string (concat menu-string
+ "[" (elt descriptor 0) "]"
+ (elt descriptor 1) " "))))
descriptors)
(setf (elt menu-string (- (length menu-string) 1)) ?:)
;; Prompt the user, and grab the link
(message menu-string)
(setq input (read-char-exclusive))
- (mapc '(lambda (descriptor)
+ (mapc (lambda (descriptor)
(let ((key (elt (elt descriptor 0) 0))
(active (elt descriptor 3))
(grab-function (elt descriptor 2)))
@@ -221,12 +276,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 +300,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,41 +316,34 @@ 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 ()
(interactive)
(message "Applescript: Getting Firefox url...")
- (let* ((url-and-title (org-as-mac-firefox-get-frontmost-url))
- (split-link (split-string url-and-title "::split::"))
- (URL (car split-link))
- (description (cadr split-link))
- (org-link))
- (when (not (string= URL ""))
- (setq org-link (org-make-link-string URL description)))
- (kill-new org-link)
- org-link))
+ (org-mac-paste-applescript-links (org-as-mac-firefox-get-frontmost-url)))
(defun org-mac-firefox-insert-frontmost-url ()
(interactive)
@@ -303,40 +355,33 @@ 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)
(message "Applescript: Getting Vimperator url...")
- (let* ((url-and-title (org-as-mac-vimperator-get-frontmost-url))
- (split-link (split-string url-and-title "::split::"))
- (URL (car split-link))
- (description (cadr split-link))
- (org-link))
- (when (not (string= URL ""))
- (setq org-link (org-make-link-string URL description)))
- (kill-new org-link)
- org-link))
+ (org-mac-paste-applescript-links (org-as-mac-vimperator-get-frontmost-url)))
(defun org-mac-vimperator-insert-frontmost-url ()
(interactive)
@@ -348,40 +393,25 @@ 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)
(message "Applescript: Getting Chrome url...")
- (let* ((url-and-title (org-as-mac-chrome-get-frontmost-url))
- (split-link (split-string url-and-title "::split::"))
- (URL (car split-link))
- (description (cadr split-link))
- (org-link))
- (when (not (string= URL ""))
- (setq org-link (org-make-link-string URL description)))
- (kill-new org-link)
- org-link))
+ (org-mac-paste-applescript-links (org-as-mac-chrome-get-frontmost-url)))
(defun org-mac-chrome-insert-frontmost-url ()
(interactive)
@@ -392,57 +422,44 @@ 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)
+(org-link-set-parameters "x-together-item" :follow #'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 +469,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 +496,25 @@ 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)
+(org-link-set-parameters "addressbook" :follow #'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,13 +525,12 @@ 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)
-(org-add-link-type "skim" 'org-mac-skim-open)
+(org-link-set-parameters "skim" :follow #'org-mac-skim-open)
(defun org-mac-skim-open (uri)
"Visit page of pdf in Skim"
@@ -531,81 +538,119 @@ 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)
(message "Applescript: Getting Skim page link...")
- (let* ((link-and-descr (as-get-skim-page-link))
- (split-link (split-string link-and-descr "::split::"))
- (link (car split-link))
- (description (cadr split-link))
- (org-link))
- (when (not (string= link ""))
- (setq org-link (org-make-link-string link description)))
- (kill-new org-link)
- org-link))
+ (org-mac-paste-applescript-links (as-get-skim-page-link)))
(defun org-mac-skim-insert-page ()
(interactive)
(insert (org-mac-skim-get-page)))
-
-
+;; Handle links from Adobe Acrobat Pro.app
;;
+;; Original code & idea by Christopher Suckling (org-mac-protocol)
;;
+;; The URI format is path_to_pdf_file::page_number
+
+(org-link-set-parameters "acrobat" :follow #'org-mac-acrobat-open)
+
+(defun org-mac-acrobat-open (uri)
+ "Visit page of pdf in Acrobat"
+ (let* ((page (when (string-match "::\\(.+\\)\\'" uri)
+ (match-string 1 uri)))
+ (document (substring uri 0 (match-beginning 0))))
+ (do-applescript
+ (concat
+ "tell application \"Adobe Acrobat Pro\"\n"
+ " activate\n"
+ " set theDoc to \"" document "\"\n"
+ " set thePage to " page "\n"
+ " open theDoc\n"
+ " tell PDF Window 1\n"
+ " goto page thePage\n"
+ " end tell\n"
+ "end tell"))))
+
+;; The applescript returns link in the format
+;; "adobe:path_to_pdf_file::page_number::split::document_title, p.page_label"
+
+(defun org-mac-as-get-acrobat-page-link ()
+ (do-applescript
+ (concat
+ "tell application \"Adobe Acrobat Pro\"\n"
+ " set theDoc to active doc\n"
+ " set theWindow to (PDF Window 1 of theDoc)\n"
+ " set thePath to (file alias of theDoc)\n"
+ " set theTitle to (name of theWindow)\n"
+ " set thePage to (page number of theWindow)\n"
+ " set theLabel to (label text of (page thePage of theWindow))\n"
+ "end tell\n"
+ "set theResult to \"acrobat:\" & thePath & \"::\" & thePage & \"::split::\" & theTitle & \", p.\" & theLabel\n"
+ "return theResult as string\n")))
+
+(defun org-mac-acrobat-get-page ()
+ (interactive)
+ (message "Applescript: Getting Acrobat page link...")
+ (org-mac-paste-applescript-links (org-mac-as-get-acrobat-page-link)))
+
+(defun org-mac-acrobat-insert-page ()
+ (interactive)
+ (insert (org-mac-acrobat-get-page)))
+
+
;; Handle links from Microsoft Outlook.app
-;;
-(org-add-link-type "mac-outlook" 'org-mac-outlook-message-open)
+(org-link-set-parameters "mac-outlook" :follow #'org-mac-outlook-message-open)
(defun org-mac-outlook-message-open (msgid)
- "Open a message in outlook"
- (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 \"" org-mac-outlook-path "\"\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 \"" org-mac-outlook-path "\"\n"
"set msgCount to count current messages\n"
"if (msgCount < 1) then\n"
"return\n"
@@ -656,40 +701,27 @@ The Org-syntax text will be pushed to the kill ring, and also returned."
(interactive "sLink to (s)elected or (f)lagged messages: ")
(setq select-or-flag (or select-or-flag "s"))
(message "Org Mac Outlook: searching mailboxes...")
- (let* ((as-link-list
- (if (string= select-or-flag "s")
- (org-as-get-selected-outlook-mail)
- (if (string= select-or-flag "f")
- (org-sh-get-flagged-outlook-mail)
- (error "Please select \"s\" or \"f\""))))
- (link-list
- (mapcar
- (lambda (x) (if (string-match "\\`\"\\(.*\\)\"\\'" x) (setq x (match-string 1 x))) x)
- (split-string as-link-list "[\r\n]+")))
- split-link URL description orglink orglink-insert rtn orglink-list)
- (while link-list
- (setq split-link (split-string (pop link-list) "::split::"))
- (setq URL (car split-link))
- (setq description (cadr split-link))
- (when (not (string= URL ""))
- (setq orglink (org-make-link-string URL description))
- (push orglink orglink-list)))
- (setq rtn (mapconcat 'identity orglink-list "\n"))
- (kill-new rtn)
- rtn))
+ (org-mac-paste-applescript-links
+ (if (string= select-or-flag "s")
+ (org-as-get-selected-outlook-mail)
+ (if (string= select-or-flag "f")
+ (org-sh-get-flagged-outlook-mail)
+ (error "Please select \"s\" or \"f\"")))))
(defun org-mac-outlook-message-insert-selected ()
"Insert a link to the messages currently selected in Microsoft Outlook.app.
-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))
@@ -709,18 +741,110 @@ list of mac-outlook:// links to flagged mail after heading."
(insert "\n")
(org-insert-heading nil t)
(insert org-heading "\n" (org-mac-outlook-message-get-links "f"))))))
+
+;; Handle links from Evernote.app
+
+(org-link-set-parameters "mac-evernote" :follow #'org-mac-evernote-note-open)
+
+(defun org-mac-evernote-note-open (noteid)
+ "Open a note in Evernote"
+ (do-applescript
+ (concat
+ "tell application \"" org-mac-evernote-path "\"\n"
+ " set theNotes to get every note of every notebook where its local id is \"" (substring-no-properties noteid) "\"\n"
+ " repeat with _note in theNotes\n"
+ " if length of _note is not 0 then\n"
+ " set _selectedNote to _note\n"
+ " end if\n"
+ " end repeat\n"
+ " open note window with item 1 of _selectedNote\n"
+ " activate\n"
+ "end tell")))
+(defun org-as-get-selected-evernote-notes ()
+ "AppleScript to create links to selected notes in Evernote.app."
+ (do-applescript
+ (concat
+ "tell application \"" org-mac-evernote-path "\"\n"
+ " set noteCount to count selection\n"
+ " if (noteCount < 1) then\n"
+ " return\n"
+ " end if\n"
+ " set theLinkList to {}\n"
+ " set theSelection to selection\n"
+ " repeat with theNote in theSelection\n"
+ " set theTitle to title of theNote\n"
+ " set theID to local id of theNote\n"
+ " set theURL to \"mac-evernote:\" & theID\n"
+ " set theLink to theURL & \"::split::\" & theTitle & \"\n\"\n"
+ " copy theLink to end of theLinkList\n"
+ " end repeat\n"
+ " return theLinkList as string\n"
+ "end tell\n")))
+
+(defun org-mac-evernote-note-insert-selected ()
+ "Insert a link to the notes currently selected in Evernote.app.
+This will use AppleScript to get the note id and the title of the
+note(s) in Evernote.app and make a link out of it/them."
+ (interactive)
+ (message "Org Mac Evernote: searching notes...")
+(insert (org-mac-paste-applescript-links
+ (org-as-get-selected-evernote-notes))))
+
+
+;; Handle links from DEVONthink Pro Office.app
+
+(org-link-set-parameters "x-devonthink-item" :follow #'org-devonthink-item-open)
+
+(defun org-devonthink-item-open (uid)
+ "Open UID, which is a reference to an item in DEVONthink Pro Office."
+ (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...")
+ (org-mac-paste-applescript-links (org-as-get-selected-devonthink-item)))
+
+(defun org-mac-devonthink-item-insert-selected ()
+ "Insert a link to the item(s) currently selected in DEVONthink Pro Office.
+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)
+(org-link-set-parameters "message" :follow #'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 +852,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 +900,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 +935,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-mairix.el b/contrib/lisp/org-mairix.el
index a19719e..84a9582 100644
--- a/contrib/lisp/org-mairix.el
+++ b/contrib/lisp/org-mairix.el
@@ -82,8 +82,9 @@ correctly, you should not need to change this.
;;; The hooks to integrate mairix into org
-(org-add-link-type "mairix" 'org-mairix-open)
-(add-hook 'org-store-link-functions 'org-mairix-store-gnus-link)
+(org-link-set-parameters "mairix"
+ :follow #'org-mairix-open
+ :store #'org-mairix-store-gnus-link)
;;; Generic org-mairix functions
diff --git a/contrib/lisp/org-man.el b/contrib/lisp/org-man.el
index a9db83d..1ccd942 100644
--- a/contrib/lisp/org-man.el
+++ b/contrib/lisp/org-man.el
@@ -25,8 +25,10 @@
(require 'org)
-(org-add-link-type "man" 'org-man-open 'org-man-export)
-(add-hook 'org-store-link-functions 'org-man-store-link)
+(org-link-set-parameters "man"
+ :follow #'org-man-open
+ :export #'org-man-export
+ :store #'org-man-store-link)
(defcustom org-man-command 'man
"The Emacs command to be used to display a man page."
diff --git a/contrib/lisp/org-mew.el b/contrib/lisp/org-mew.el
index 4482375..f4c845c 100644
--- a/contrib/lisp/org-mew.el
+++ b/contrib/lisp/org-mew.el
@@ -1,6 +1,6 @@
;;; org-mew.el --- Support for links to Mew messages from within Org-mode
-;; Copyright (C) 2008-2014 Free Software Foundation, Inc.
+;; Copyright (C) 2008-2016 Free Software Foundation, Inc.
;; Author: Tokuya Kameshima <kames at fa2 dot so-net dot ne dot jp>
;; Keywords: outlines, hypermedia, calendar, wp
@@ -148,8 +148,7 @@ with \"t\" key."
(defvar mew-summary-goto-line-then-display)
;; Install the link type
-(org-add-link-type "mew" 'org-mew-open)
-(add-hook 'org-store-link-functions 'org-mew-store-link)
+(org-link-set-parameters "mew" :follow #'org-mew-open :store #'org-mew-store-link)
;; Implementation
(defun org-mew-store-link ()
@@ -167,19 +166,10 @@ with \"t\" key."
(from (mew-header-get-value "From:"))
(to (mew-header-get-value "To:"))
(date (mew-header-get-value "Date:"))
- (date-ts (and date (format-time-string
- (org-time-stamp-format t)
- (date-to-time date))))
- (date-ts-ia (and date (format-time-string
- (org-time-stamp-format t t)
- (date-to-time date))))
(subject (mew-header-get-value "Subject:"))
desc link)
- (org-store-link-props :type "mew" :from from :to to
+ (org-store-link-props :type "mew" :from from :to to :date date
:subject subject :message-id message-id)
- (when date
- (org-add-link-props :date date :date-timestamp date-ts
- :date-timestamp-inactive date-ts-ia))
(setq message-id (org-remove-angle-brackets message-id))
(setq desc (org-email-link-description))
(setq link (concat "mew:" folder-name "#" message-id))
@@ -308,7 +298,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 +332,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 b0007ac..2ced42e 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
@@ -57,6 +57,7 @@
(declare-function org-export-string-as "ox"
(string backend &optional body-only ext-plist))
+(declare-function org-trim "org" (s &optional keep-lead))
(defcustom org-mime-use-property-inheritance nil
"Non-nil means al MAIL_ properties apply also for sublevels."
@@ -111,7 +112,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)
@@ -163,14 +164,17 @@ and images in a multipart/related part."
('semi (concat
"--" "<<alternative>>-{\n"
"--" "[[text/plain]]\n" plain
- (when images (concat "--" "<<alternative>>-{\n"))
- "--" "[[text/html]]\n" html
- images
- (when images (concat "--" "}-<<alternative>>\n"))
+ (if (and images (> (length images) 0))
+ (concat "--" "<<related>>-{\n"
+ "--" "[[text/html]]\n" html
+ images
+ "--" "}-<<related>>\n")
+ (concat "--" "[[text/html]]\n" html
+ images))
"--" "}-<<alternative>>\n"))
('vm "?")))
-(defun org-mime-replace-images (str current-file)
+(defun org-mime-replace-images (str)
"Replace images in html files with cid links."
(let (html-images)
(cons
@@ -182,7 +186,7 @@ and images in a multipart/related part."
(let* ((url (and (string-match "src=\"\\([^\"]+\\)\"" text)
(match-string 1 text)))
(path (expand-file-name
- url (file-name-directory current-file)))
+ url temporary-file-directory))
(ext (file-name-extension path))
(id (replace-regexp-in-string "[\/\\\\]" "_" path)))
(add-to-list 'html-images
@@ -191,10 +195,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)
@@ -209,8 +213,6 @@ export that region, otherwise export the entire body."
(point-max)))
(raw-body (concat org-mime-default-header
(buffer-substring html-start html-end)))
- (tmp-file (make-temp-name (expand-file-name
- "mail" temporary-file-directory)))
(body (org-export-string-as raw-body 'org t))
;; because we probably don't want to export a huge style file
(org-export-htmlize-output-type 'inline-css)
@@ -221,7 +223,7 @@ export that region, otherwise export the entire body."
;; to hold attachments for inline html images
(html-and-images
(org-mime-replace-images
- (org-export-string-as raw-body 'html t) tmp-file))
+ (org-export-string-as raw-body 'html t)))
(html-images (unless arg (cdr html-and-images)))
(html (org-mime-apply-html-hook
(if arg
@@ -249,28 +251,30 @@ 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)
(let* ((region-p (org-region-active-p))
- (subject (org-export-grab-title-from-buffer))
- (file (buffer-file-name (current-buffer)))
+ (file (buffer-file-name (current-buffer)))
+ (subject (if (not file) (buffer-name (buffer-base-buffer))
+ (file-name-sans-extension
+ (file-name-nondirectory file))))
(body-start (or (and region-p (region-beginning))
(save-excursion (goto-char (point-min)))))
(body-end (or (and region-p (region-end)) (point-max)))
@@ -280,47 +284,48 @@ export that region, otherwise export the entire body."
(defun org-mime-compose (body fmt file &optional to subject headers)
(require 'message)
- (message-mail to subject headers nil)
+ (compose-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-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)))
+ (images (cdr html-and-images))
+ (html (org-mime-apply-html-hook (car html-and-images))))
+ (insert (org-mime-multipart
+ (org-export-string-as
+ (org-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
+++ b/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-notify.el b/contrib/lisp/org-notify.el
index da2c96f..d0acdec 100644
--- a/contrib/lisp/org-notify.el
+++ b/contrib/lisp/org-notify.el
@@ -1,6 +1,6 @@
;;; org-notify.el --- Notifications for Org-mode
-;; Copyright (C) 2012, 2013, 2014 Free Software Foundation, Inc.
+;; Copyright (C) 2012-2016 Free Software Foundation, Inc.
;; Author: Peter Münster <pmrb@free.fr>
;; Keywords: notification, todo-list, alarm, reminder, pop-up
@@ -120,7 +120,7 @@ simple timestamp string."
"Create one todo item."
(macrolet ((get (k) `(plist-get list ,k))
(pr (k v) `(setq result (plist-put result ,k ,v))))
- (let* ((list (nth 1 heading)) (notify (or (get :notify) "default"))
+ (let* ((list (nth 1 heading)) (notify (or (get :NOTIFY) "default"))
(deadline (org-notify-convert-deadline (get :deadline)))
(heading (get :raw-value))
result)
@@ -130,7 +130,7 @@ simple timestamp string."
(pr :file (nth org-notify-parse-file (org-agenda-files 'unrestricted)))
(pr :timestamp deadline) (pr :uid (md5 (concat heading deadline)))
(pr :deadline (- (org-time-string-to-seconds deadline)
- (org-float-time))))
+ (float-time))))
result)))
(defun org-notify-todo-list ()
@@ -148,7 +148,7 @@ simple timestamp string."
'headline 'org-notify-make-todo)))))
(defun org-notify-maybe-too-late (diff period heading)
- "Print waring message, when notified significantly later than defined by
+ "Print warning message, when notified significantly later than defined by
PERIOD."
(if (> (/ diff period) 1.5)
(message "Warning: notification for \"%s\" behind schedule!" heading))
@@ -165,7 +165,7 @@ forgotten tasks."
(dolist (prms (plist-get org-notify-map (td :notify)))
(when (< deadline (org-notify-string->seconds (prm :time)))
(let ((period (org-notify-string->seconds (prm :period)))
- (last-run (prm last-run-sym)) (now (org-float-time))
+ (last-run (prm last-run-sym)) (now (float-time))
(actions (prm :actions)) diff plist)
(when (or (not last-run)
(and period (< period (setq diff (- now last-run)))
diff --git a/contrib/lisp/org-notmuch.el b/contrib/lisp/org-notmuch.el
index 2ab5c17..b77df03 100644
--- a/contrib/lisp/org-notmuch.el
+++ b/contrib/lisp/org-notmuch.el
@@ -41,28 +41,53 @@
(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)
+(org-link-set-parameters "notmuch"
+ :follow #'org-notmuch-open
+ :store #'org-notmuch-store-link)
(defun org-notmuch-store-link ()
"Store a link to a notmuch search or message."
(when (eq major-mode 'notmuch-show-mode)
- (let* ((message-id (notmuch-show-get-prop :id))
+ (let* ((message-id (notmuch-show-get-message-id t))
(subject (notmuch-show-get-subject))
(to (notmuch-show-get-to))
(from (notmuch-show-get-from))
+ (date (org-trim (notmuch-show-get-date)))
desc link)
- (org-store-link-props :type "notmuch" :from from :to to
+ (org-store-link-props :type "notmuch" :from from :to to :date date
:subject subject :message-id message-id)
(setq desc (org-email-link-description))
- (setq link (concat "notmuch:" "id:" message-id))
+ (setq link (concat "notmuch:id:" message-id))
(org-add-link-props :link link :description desc)
link)))
(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.
@@ -74,8 +99,9 @@ Can link to more than one message, if so all matching messages are shown."
-(org-add-link-type "notmuch-search" 'org-notmuch-search-open)
-(add-hook 'org-store-link-functions 'org-notmuch-search-store-link)
+(org-link-set-parameters "notmuch-search"
+ :follow #'org-notmuch-search-open
+ :store #'org-notmuch-search-store-link)
(defun org-notmuch-search-store-link ()
"Store a link to a notmuch search or message."
@@ -90,14 +116,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
--- a/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